text:
Debats du Senat (hansard)
2e Session, 36e Legislature,
Volume 138, Numero 8
Le mercredi 17 novembre 1999
L'honorable Gildas L. Molgat, President
Les prix internationaux et nationaux remportes par les habitants de Lunenburg
La reforme du Senat
Le chanvre industriel-Les obstacles aux exportations vers les Etats-Unis
L'annee internationale des personnes agees
Depot du rapport du comite des affaires etrangeres
Depot du premier rapport du comite
Societe de developpement du cap-breton
Depot du premier rapport du comite special
La liberte religieuse en Chine en rapport avec les pactes internationaux des Nations Unies
Le remplacement des helicopteres Sea King-La possibilite du credit-bail
La proposition du Parti reformiste de reevaluer la participation du Canada-La position du gouvernement
Les travaux du Senat
Projet de loi modificatif-Deuxieme lecture
Affaires juridiques et constitutionnelles
Les travaux du Senat
Le Budget des depenses de 1999-2000
Autorisation donnee au comite des finances nationales d'etudier le Budget supplementaire (A)
Le Budget des depenses de 1999-2000
Renvoi du credit 25a du Conseil prive au comite mixte permanent des langues officielles
Le Budget des depenses de 1999-2000
Projet de loi modificatif-Deuxieme lecture-Ajournement du debat
Etude du troisieme rapport-Retrait de l'article
Affaires juridiques et constitutionnelles
La Conference sur l'egalite et la participation des femmes a la vie publique
La situation des autochtones et leur avenir
Affaires sociales, sciences et technologie
Autorisation au comite de sieger en meme temps que le Senat
Autorisation au comite de sieger en meme temps que le Senat
Le Bureau de salubrite de l'environnement pour les enfants
Adoption de la motion d'etablissement
Le mercredi 17 novembre 1999
La seance est ouverte a 13 h 30, le President etant au fauteuil.
Les prix internationaux et nationaux remportes par les habitants de Lunenburg
L'honorable Wilfred P. Moore :
Les membres de l'ASTA viennent de partout en Amerique.
C'est la premiere fois qu'un port canadien remporte cet honneur.
La reforme du Senat
L'honorable Donald H. Oliver :
Il est temps que nous assumions un leadership.
Le chanvre industriel-Les obstacles aux exportations vers les Etats-Unis
Mes felicitations a Kenex.
C'est une bonne nouvelle pour les agriculteurs canadiens.
L'annee internationale des personnes agees
L'honorable Lois M. Wilson :
Depot du rapport du comite des affaires etrangeres
L'honorable John B. Stewart :
Son Honneur le President :
Honorables senateurs, quand etudierons-nous ce rapport?
Son Honneur le President :
Plait-il aux honorables senateurs d'adopter la motion?
Depot du premier rapport du comite
Societe de developpement du cap-breton
Depot du premier rapport du comite special
L'honorable John G. Bryden :
( Le texte du rapport figure aux Journaux du Senat d'aujourd'hui.
L'honorable Leonce Mercier , president du Comite de selection, presente le rapport suivant:
Le mercredi 17 novembre 1999
Le Comite de selection a l'honneur de presenter son
Son Honneur le President :
Honorables senateurs, quand etudierons-nous ce rapport?
Son Honneur le President :
Vous plait-il d'adopter la motion, honorables senateurs?
La liberte religieuse en Chine en rapport avec les pactes internationaux des Nations Unies
L'honorable Lois M. Wilson :
L'honorable Donald H. Oliver :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Notre engagement envers le Cap-Breton s'est poursuivi.
Cette partie du plan etait tres importante et grandement necessaire.
Deux choix s'offraient au gouvernement.
Je sais que le senateur n'approuverait pas une telle solution.
L'honorable Donald H. Oliver :
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Ce travailleur se tirera tres bien d'affaire.
Sauf erreur, je me suis engage hier a remettre cet avis au senateur Murray.
Je vais en remettre egalement une copie a l'honorable senateur Oliver.
L'honorable Gerald J. Comeau :
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Honorables senateurs, je connais le dossier dont le senateur parle.
Ces vitraux ont ete enleves d'une chapelle qui etait inutilisee.
J'ai une question complementaire, honorables senateurs.
Je demande au leader d'appuyer cette initiative.
L'honorable J. Michael Forrestall :
Honorables senateurs, j'ai moi aussi une question complementaire.
Je pourrais sans doute jeter le premier caillou.
Le remplacement des helicopteres Sea King-La possibilite du credit-bail
L'honorable Gerry St. Germain :
Honorables senateurs, ma question s'adresse aussi au leader du gouvernement au Senat.
Pourrait-il maintenant me donner une reponse plus directe et definitive?
L'honorable J. Bernard Boudreau (leader du gouvernement) :
C'est ce que le gouvernement dit toujours.
Le ministre a obtenu un certain succes.
Combien coutera la modernisation?
C'est la l'aspect cle.
Je parle a titre de pilote ayant une experience active.
J'ai parle des sous-marins.
Pour les sous-marins, les sommes engagees sont de 750 millions de dollars.
Je ne veux pas eluder la question de l'honorable senateur.
Il faut trouver une solution.
Elle devrait fermer ses portes.
Je remercie l'honorable senateur pour ses commentaires.
Quant au cout de l'entretien, certaines questions peuvent se poser.
La proposition du Parti reformiste de reevaluer la participation du Canada-La position du gouvernement
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Les reformistes n'ont-ils rien retenu de l'histoire?
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
En juillet dernier, il s'est produit un incident malheureux au Manitoba.
Des bovins ont ete empoisonnes par un herbicide tres puissant.
Heureusement, cependant, cela n'a pas ete demontre.
L'honorable J. Bernard Boudreau (leader du gouvernement) :
Honorables senateurs, je suis bien heureux de la question posee par le senateur.
J'aimerais mieux y voir votre collegue du Cap-Breton!
L'honorable senateur souleve un point important.
Cependant, je vais m'informer et je lui fournirai une reponse aussi rapidement que possible.
Les travaux du Senat
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
L'honorable Dan Hays (leader adjoint du gouvernement) :
Honorables senateurs, je propose l'adoption de ce rapport.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Nous sommes tres heureux d'appuyer la motion du senateur Mercier.
L'honorable Dan Hays (leader adjoint du gouvernement) :
Honorables senateurs, permettez-moi d'ajouter un mot dans le debat sur ce rapport.
(La motion est adoptee, et le rapport est adopte.)
Projet de loi modificatif-Deuxieme lecture
L'honorable Pierre Claude Nolin :
Je lui en suis tres reconnaissant.
Ces dispositions contribuent a faciliter la reinsertion sociale des delinquants.
Le solliciteur general pourra decider de la pertinence de divulguer le contenu du casier.
C'est un probleme epineux.
C'est le consensus auquel sont parvenus tous ces ministres.
Comme vous le savez, cette question me preoccupe au plus haut point.
A cet effet, je lui ai pose plusieurs questions.
Cela est trop vague et trop large.
Les fonctionnaires du ministere ont affirme que cette liste existe deja.
Cela nous aurait donne l'occasion de l'etudier immediatement.
Je tiens a vous rappeler que le droit penal est fondamental.
Un crime est un crime.
Dans plusieurs autres lois federales, ce processus de consentement est present specifiquement dans la loi.
Il me semblait plus urgent d'adopter le projet de loi rapidement.
Je presume que vous comprenez que je parle du projet de loi C-69.
Cette derniere pourra etre modifiee, par contre, par decret.
Il sera examine comme il le faut au comite des affaires juridiques et constitutionnelles.
Nous serons, encore une fois, tres vigilants en votre nom, honorables senateurs.
Son Honneur le President :
Vous plait-il d'adopter la motion, honorables senateurs?
(La motion est adoptee et le projet de loi est lu une deuxieme fois.)
Son Honneur le President :
Honorables senateurs, quand lirons-nous ce projet de loi une troiseme fois?
Son Honneur le President :
Au nom de tous les senateurs, je vous souhaite la bienvenue au Senat du Canada.
Affaires juridiques et constitutionnelles
Permission ayant ete accordee de revenir aux avis de motion:
Honorables senateurs, je donne avis que demain, le jeudi 18 novembre 1999, je proposerai:
Son Honneur le President :
De la part de tous les senateurs, je vous souhaite la bienvenue au Senat.
Permission ayant ete accordee de revenir aux avis de motion:
L'honorable John B. Stewart , conformement a l'avis du 16 novembre 1999, propose:
Les travaux du Senat
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Honorables senateurs, j'invoque le Reglement.
Nous avons recu il y a un instant un avis de motion du senateur Fraser.
Une motion similaire du senateur Oliver figure au Feuilleton .
On ne semble pas tres bien connaitre le Reglement.
Pouvez-vous nous fournir des eclaircissements afin d'ecarter tout malentendu?
Son Honneur le President :
Je remercie le senateur Kinsella de signaler cette affaire.
L'honorable Dan Hays (leader adjoint du gouvernement) :
L'honorable Anne C. Cools :
Honorables senateurs, je serais tres heureuse d'ajouter mon grain de sel au debat.
Tout d'abord, je voudrais des eclaircissements.
Est-ce un rappel au Reglement?
De quelle question sommes-nous saisis?
Cela me parait etrange.
Une motion semblable a ete presentee par le senateur Oliver la semaine derniere.
A mon avis, il importe de clarifier la question.
J'essaie de determiner dans quel contexte je reponds aux questions du senateur Kinsella.
Je suis prete a aborder cette question.
Son Honneur le President :
Honorables senateurs, nous allons au-devant des choses.
Tout ce que nous avons, c'est un avis de motion du senateur Fraser.
La question doit etre soulevee une fois que nous sommes saisis de la motion.
Toutefois, je me plierai a la volonte des honorables senateurs.
Son Honneur le President :
Honorables senateurs, je le repete, je crois que nous allons trop vite en besogne.
Autrement dit, nous ne sommes pas saisis de cette affaire.
On nous dit simplement que madame le senateur entend proposer quelque chose.
Nous pourrons en debattre quand elle se sera executee.
Si tel est le bon plaisir du Senat, nous pouvons commencer des maintenant.
Je m'en remets a vous a cet egard.
Toutefois, je m'en remets a vous.
Serait-il acceptable que nous en discutions lorsque la motion du senateur Oliver sera etudiee?
Si c'est acceptable, je suggere que nous procedions ainsi.
Son Honneur le President :
Ils ne sont toutefois pas identiques puisqu'ils traitent de sujets differents.
Je m'en remets au Senat.
Le Budget des depenses de 1999-2000
Autorisation donnee au comite des finances nationales d'etudier le Budget supplementaire (A)
Le Budget des depenses de 1999-2000
Renvoi du credit 25a du Conseil prive au comite mixte permanent des langues officielles
Qu'un message soit transmis a la Chambre des communes pour l'en informer.
Le Budget des depenses de 1999-2000
Qu'un message soit transmis a la Chambre des communes pour l'en informer.
Projet de loi modificatif-Deuxieme lecture-Ajournement du debat
En consequence, le projet de loi C-251 a expire au Feuilleton .
Je la tiens en haute estime.
Tous les Canadiens lui doivent beaucoup.
Christie Blatchford a tres bien decrit cette audience.
Ainsi, indiquait l'avocat, Olson pourrait pleinement profiter du systeme de peines concurrentes.
Olson a nargue le tribunal en leur disant: Ils ne peuvent rien faire.
Ils ne peuvent que me donner une peine concurrente.
Il s'agit de la determination de la peine pour des actes vraiment mauvais.
Les tres rares explications de la mechancete qui ont ete elaborees sont d'ordre theologique.
Or, les explications theologiques sont ecartees de nos jours au nom de la neutralite morale.
The Hope for Healing Human Evil .
Je crois cependant qu'instinctivement, nous avons tous une certaine comprehension de sa nature.
Le docteur Peck ecrit encore, a la page 46:
Le docteur Peck a ajoute, a la page 47:
Ils sont tout simplement mechants.
Un tel mal resiste aux traitements ou aux remedes.
Le mot maladie signifie mal a l'aise.
Loin de les rendre mal a l'aise, leur comportement ne les gene aucunement.
Le detenu Olson est tout a fait a l'aise avec sa condition.
Il signe ses lettres Clifford Robert Olson, TUEUR EN SERIE de 11 enfants.
J'ai recu une de ses lettres qu'il avait signee de cette facon.
Le detenu Olson n'est pas malade, il est mechant.
Ces temoins ont essentiellement demande au comite de rejeter l'initiative.
Mes opposants n'ont voulu ni d'un debat ni d'un examen.
... les fonctionnaires de la Justice etaient la pour donner des renseignements sur cet article controverse.
Les Canadiens n'ont jamais vote pour les peines concurrentes.
Les peines concurrentes vont a l'encontre de la notion fondamentale de justice.
C'est ce qu'a indique un sondage national effectue par POLLARA le mois dernier.
Albina Guarnieri poursuivait ainsi l'explication de son projet de loi:
La duree du mandat est celle de la vie du delinquant.
La date d'expiration du mandat est celle du deces du detenu.
Le Service correctionnel du Canada parle de date d'expiration du mandat.
La peine dure toute la vie.
Il regne une grande confusion a ce sujet.
Bien des gens pensent que l'emprisonnement a vie a une duree de 25 ans.
Durant le debat du 12 decembre 1996, j'ai dit ceci :
Ce pouvoir appartient de plein droit a certains organismes precis.
Par contre, les pouvoirs des juges en chef seront augmentes.
Ce sont des pouvoirs exerces par les representants de la societe.
Il s'agit la d'un pouvoir executif.
Les detenus Olson et Homolka nous en donnent des exemples frappants.
Le juge qui presidait l'audience presidait une audience politique.
Cette audience etait bel et bien politique, elle n'avait pas un caractere juridique.
Le juge, le jury et tout le monde present dans cette salle le savaient.
Voila pourquoi nous tenons ce debat aujourd'hui.
Je puis vous dire que personne ne le liberera.
Karla Homolka est son equivalent le plus naturel.
Honorables senateurs, j'ai fait partie de la Commission nationale des liberations conditionnelles.
J'ai interroge de nombreux detenus et autorise ou suspendu bien des liberations conditionnelles.
La capacite de ces predateurs de choisir leurs victimes en exploitant leur vulnerabilite est diabolique.
Nous parlons ici de deviants sexuels malveillants.
On peut lire ceci a la page 48:
Je dis bien obtenir justice, honorables senateurs.
Dans notre systeme, on parle de prerogative royale en justice.
Le chatiment peut toujours etre tempere par la clemence de la Reine.
Il n'est pas ici question du delinquant juvenile traditionnel.
Le senateur Cools est une personne qui connait tres bien ce domaine.
Je remercie l'honorable senateur de sa question.
C'est le dilemme que pose l'article 745 du Code criminel du Canada.
La situation a ce sujet est tres claire.
L'honorable senateur Finestone a frappe en plein dans le mille.
Le sujet exige que l'on s'en occupe.
J'espere que certaines questions surgiront au cours du debat.
Pourquoi les juges n'imposent-ils pas des peines consecutives, comme ils le peuvent?
C'est un cas tres inhabituel.
Je dirai que tous les meurtres sont inhabituels.
S'ils ne l'etaient pas, l'espece humaine n'existerait plus.
C'est tres vrai.
J'ai une quantite impressionnante de documents sur ce genre d'individus.
Ce qui n'est pas si inhabituel chez les meurtriers, ce sont les recidivistes.
C'est tout a fait vrai.
Cela ne se fait pas au Canada.
Il y avait de nombreuses facons de tuer plusieurs fois la meme personne.
J'espere avoir aide quelque peu mon honorable collegue.
L'honorable Pierre Claude Nolin :
Oui, j'ai dit quelque chose du genre.
Ce n'est pas une question de primaute du droit.
Son Honneur le President :
Honorables senateurs, la periode de temps prevue pour les discours et les questions est terminee.
Honorables senateurs, ne nous meprenons pas.
Se trouvent-ils encore en prison?
Dans ce cas particulier, j'ai revoque le regime de liberte surveillee dont il beneficiait.
Je parle de nombreuses annees plus tard.
Vous prouvez ce que je soutiens.
Je ne pense pas que l'on puisse rehabiliter un tel individu.
Je tire mon information de ce seul article.
Il n'y a pas de changement de principe.
C'est ce que le senateur demande.
Expliquez-vous car jusqu'ici, vous ne l'avez pas fait.
Il n'y a pas de changement.
Certes, nous avions l'habitude de les executer.
Pourquoi avons-nous change cette coutume?
A propos, nous n'appelons plus ces gens-la des violeurs.
Comment les appelez-vous maintenant?
Je crois qu'on les appelle des agresseurs sexuels.
La peine ne se reduit pas seulement a la punition.
C'est un mauvais exemple, mais ca va.
Laissez-moi finir de poser ma question, je vous prie.
J'ai laisse l'honorable senateur finir son discours.
Aujourd'hui, il ne s'agit plus seulement de punir.
Si elle arrive a me convaincre, je serai heureux de l'appuyer.
Il doit bien y avoir des raisons.
Je ne doute pas des motifs du senateur.
Ce projet de loi d'initiative parlementaire n'est pas nouveau.
Cela fait quatre ans qu'il est etudie et examine par la Chambre des communes.
Ce sont la les quatre principes de la determination de la peine.
Le projet de loi est parfaitement conforme a ces principes.
C'est sur cet article que se fonde le projet de loi.
Qu'il me fasse confiance.
J'ai examine la Charte.
Ce n'est pas du tout ce que propose la mesure.
Peut-etre le senateur ne comprend-t-il pas le projet de loi.
Quel serait le minimum d'une peine d'emprisonnement a vie?
Le minimum reste le meme pour le moment dans la loi.
La sanction prevue par la loi est reprise dans ce projet de loi.
Le projet de loi limite simplement la marge de manoeuvre du magistrat.
J'espere que le senateur comprend a present.
L'honorable senateur doit donner une explication claire aux honorables senateurs.
Madame le senateur aurait-elle l'obligeance de m'expliquer cela?
Je suis heureuse de fournir une explication a l'honorable senateur.
C'est le regime actuel.
Le raisonnement est exactement le meme.
Quel serait le maximum?
C'est la limite.
C'est 25 annees supplementaires.
Ce n'est pas 25 annees supplementaires.
C'est un total supplementaire de 25 annees.
C'est ce que vous venez de dire.
En d'autres mots, la peine d'emprisonnement a perpetuite demeure.
Le detenu purge toujours une peine d'emprisonnement a perpetuite.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Etude du troisieme rapport-Retrait de l'article
L'honorable Dan Hays (leader adjoint du gouvernement) :
Son Honneur le President :
Affaires juridiques et constitutionnelles
L'honorable Dan Hays (leader adjoint du gouvernement) :
Je me suis deja prononce la-dessus.
Le senateur Kinsella voudra peut-etre ajouter quelque chose.
Je cede maintenant la parole au senateur Cools.
L'honorable Anne C. Cools :
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
A la deuxieme page du rapport, l'ordre de renvoi est reproduit.
Il est bloque la.
Il a ete laisse au comite.
J'ai justement en mains une citation, senateur Kinsella.
On parle d'un projet de loi qui a ete renvoye.
Le commentaire 874 de Beauchesne, sixieme edition, precise clairement que:
Le rapport etablit que des temoignages ont ete entendus.
Les termes performatifs ici sont a en tenir compte.
La question qu'il faut poser est la suivante: l'autorisation de faire quoi?
L'alinea 58(1) f ) se lit comme suit:
des instructions a un comite.
Par consequent, la motion est essentiellement une instruction au comite.
Mais c'est maintenant tout a fait theorique.
Nous sommes parfois un peu negligents, quoique le mot soit tres fort.
Le comite a les pouvoirs dont il a besoin.
C'etait simplement une exigence supplementaire.
Son Honneur le President :
Son Honneur le President:
Je vais maintenant essayer de presenter mes explications dans un ordre logique.
... avec la permission du Senat et nonobstantl'alinea 58(1) f )...
Son Honneur le President :
La permission est-elle accordee?
La motion du senateur Oliver etait donc recevable parce que la permission avait ete accordee.
Nous consultons d'abord notre Reglement, puis nous examinons nos usages et nos precedents.
L'honorable senateur Kinsella a explique en detail deux de nos usages et precedents.
Je peux trouver d'autres precedents si les senateurs le demandent.
Toutefois, telle est, a ma connaissance, la pratique habituelle du Senat.
Le senateur Cools nous a renvoyes au Beauchesne.
Comme je l'ai fait remarquer, nos pratiques ont preseance sur le Beauchesne.
Notre pratique etait differente.
Voulez-vous que la question reste inscrite au nom du senateur Cools?
Son Honneur le President :
Elle restera donc au nom du senateur Cools.
(La question demeure inscrite au nom du senateur Cools.)
La Conference sur l'egalite et la participation des femmes a la vie publique
L'honorable Lorna Milne , ayant donne avis le 2 novembre 1999:
La conference etait divisee en plusieurs seances de travail, dont je vais mentionner quelques-unes.
Je crois que ce n'etait qu'une excuse pour ne pas nommer Emily.
La conferenciere suivante a ete Frances Wright, de Calgary.
Elle est presidente-directrice generale de la Famous Five Foundation.
A Calgary, j'ai pu visiter ce nouveau monument impressionnant.
Il s'agissait de Francis Wright, qui surveillait son oeuvre.
C'est une femme d'une vive intelligence et tres douee.
Vous connaissez tous l'histoire d'Allerednic...
Le prince epouse une princesse et la transforme en souillon.
C'est apparemment la triste realite pour beaucoup de femmes britanniques.
Le deuxieme groupe de discussion avait pour theme De la peripherie au centre:
Faire entendre la voix des femmes.
Il etait dirige par Sandra Anstey, presidente de Anstey Associates, de Toronto.
Cependant, dans le nouveau Parlement ecossais, sur les 139 deputes, 48 sont des femmes.
La Commission de l'egalite des chances a 25 ans en Grande-Bretagne.
Mme Barshevkin a aborde le theme Le defi de la personne:
La citoyennete des femmes dans une perspective contemporaine.
Elle a cite certaines nouvelles recentes au Canada.
Yvonne Roberts, une journaliste pigiste, decrit:
Pendant la seance intitulee: Les femmes et le droit:
Cela se passait en 1991.
Le syndrome de la femme battue n'y est pas reconnu.
Le resultat est le seul element de mesure valable de la veritable egalite.
Un regime national de salaire minimum a ete adopte.
Cet article etait l'oeuvre d'Yvonne Roberts et s'intitulait: Northern rights.
Son Honneur le President :
Beaudoin , ayant donne avis le mardi 2 novembre 1999:
Le Forum des federations aura une existence permanente.
Le prochain colloque aura lieu en Suisse dans deux ans.
A mon avis, ce forum avait sa raison d'etre.
Notre Constitution a beaucoup evolue.
L'histoire nous enseigne que nous avons des phases de centralisation et de decentralisation.
Nous sommes actuellement dans une phase de decentralisation.
On constate, dans le monde, un interet croissant pour le federalisme.
En matiere de traites, le Canada a adopte le systeme dualiste.
Dans plusieurs pays, la signature d'un traite change la loi du pays.
Selon la jurisprudence, c'est l'autorite federale qui signe les traites.
Bon nombre d'ententes France-Quebec ont ete conclues de cette facon.
Ils ne modifient pas la Constitution, mais facilitent son application.
Ils sont necessaires dans le federalisme moderne.
Les echanges et le commerce ne connaissent presque plus de frontieres.
Il en est ainsi dans les autres parties du monde, en Europe, par exemple.
Au Canada, on pense spontanement aux Sommets de la Francophonie.
Il pourrait exister d'autres domaines.
Comme l'affirmait le professeur Richard Simeon au Forum des federations au Mont-Tremblant:
Son Honneur le President suppleant :
La situation des autochtones et leur avenir
L'honorable Aurelien Gill , ayant donne avis lejeudi 4 novembre 1999:
Depuis un an, j'observe, j'entends et j'apprends.
Il est temps desormais de prendre la parole.
Mon identite et ma vie temoignent de mes principes et de mes convictions.
La parole est souvent tout ce qu'il nous reste.
La question des Premieres nations est d'une grande importance pour le Canada.
Il en va de son avenir.
Or, le coeur de la question n'est que rarement aborde.
Le XIXe siecle avait ete catastrophique et miserable.
Cela fait donc 200 ans que nos nations sont les souffre-douleur de l'histoire.
Nous avons ete depouilles de nos identites.
Nos terres furent spoliees.
Les traites n'ont pas ete respectes, on nous a mis en tutelle.
Depuis 20 ans, il en est ainsi:
Kanesatake, Ipperwash, Gustafsen Lake et Burnt Church.
Il est heureux qu'aucune n'ait vraiment derape.
Bien sur, depuis 40 ans, nous avons tous fait du chemin.
Plus personne ne dispute le fait que nous sommes les premiers habitants de ce pays.
Nous vivons sur cette terre, aujourd'hui appelee Canada, depuis des millenaires.
La Constitution canadienne temoigne de notre droit.
La premiere partie de l'histoire de nos relations en est une de partenariat.
Ce n'est que plus tard que l'humeur de l'invite a change.
Oui, il faudrait reecrire l'histoire.
Comment eriger quoi que ce soit sur un pareil oubli, sur un semblable malentendu?
Nous avons ete et nous sommes toujours.
Voila le bruit que l'on entend.
Le statut d'Indien canadien en est un de sous-citoyennete.
La loi applique le concept de tutelle.
Mais cela reste un secret bien garde.
Je repete que, durant mon temps de vie, nous avons fait du chemin.
Malheureusement, la reconnaissance de nos droits semble jouer en notre defaveur.
Le contenu de ces droits demeure un mystere, semble-t-il.
Cette reconnaissance en exaspere plus d'un.
En tant que peuples, nous sommes percus comme des menaces.
Notre destin est devenu juridique.
Un jour ou l'autre, il faudra en sortir.
Les Premieres nations aspirent a l'autonomie, a la responsabilite et a la dignite.
Les Affaires indiennes coutent tres cher aux Canadiens et les resultats seront negatifs.
Je suis senateur et je suis autochtone.
Je ne veux pas avoir honte de mon pays.
Un immense fosse reste a combler, mais il faut le franchir.
Je parie sur la sagesse.
Nous devons tous travailler a l'ouverture de l'esprit.
Dans mes interventions prochaines, je me propose de revenir devant vous avec davantage d'informations.
Je me propose de participer pleinement aux discussions du comite permanent des peuples autochtones.
Si nous ne reussissons pas a faire ce debat au Senat, qui donc y reussira?
Nous devons etre restaures dans nos responsabilites.
Il faut aller plus loin que les affirmations de droit.
Les autochtones doivent disposer de leur present, de leur avenir.
En conclusion, je vous dirai que l'affaire va plus loin.
L'indianite ne se resume pas aux mocassins, a la danse et aux traditions.
Le Canada de demain sera aussi celui des Premieres nations.
Car nous avons survecu a une bien triste histoire.
Il n'y a pas a reinventer la roue.
Durant les 50 dernieres annees, je crois bien que tout a ete dit.
Les Premieres nations doivent se gouverner.
Le processus est irreversible.
Nous avons une cote enorme a remonter.
(Sur la motion du senateur Watt, le debat est ajourne.)
Affaires sociales, sciences et technologie
Autorisation au comite de sieger en meme temps que le Senat
L'honorable Dan Hays (leader adjoint du gouvernement) :
Son Honneur le President :
Est-on d'accord, honorables senateurs?
Autorisation au comite de sieger en meme temps que le Senat
Son Honneur le President :
Honorables senateurs, la permission est-elle accordee?
Le Bureau de salubrite de l'environnement pour les enfants
Adoption de la motion d'etablissement
L'honorable Mira Spivak , conformement a l'avisdu 2 novembre 1999, propose:
Les enfants sont davantage affectes par les polluants environnementaux.
Cet impact laisse parfois des sequelles pour toute la vie; il est parfois irreversible.
Les nourrissons absorbent chaque jour une quantite de dioxine beaucoup plus elevee que les adultes.
La raison, c'est que la dioxine s'accumule dans le lait maternel.
Je n'en connais pas la raison.
Quels sont exactement les effets de la dioxine sur les enfants?
Le rapport contient des tas de recommandations pour prevenir les maux futurs.
Nous avons le choix.
Pourquoi le nombre des enfants asthmatiques a-t-il quadruple depuis quelques decennies?
Une trentaine de mois ont passe, mais rien n'a ete fait.
Son Honneur le President :
Plait-il aux senateurs d'adopter la motion?
(Le Senat s'ajourne a 14 heures demain.)


text:
      SUBROUTINE TGLOC05B(THISNAME,TSEC50,SCPOS,SCVEL,
     *            TIMTARG,TARG,LUERR,IERR)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C THIS ROUTINE IS PART OF THE TOSS TARGET LOCATION PACKAGE, TGLOC.
C
C THIS IS A SEVICE ROUTINE FOR THE TARGET LOCATION PACKAGE.  IT FINDS
C THE NOON/MIDNIGHT ZENITH DIRECTION VECTOR FOR THE ALGORITHM WHERE
C NOON IS DEFINED AS OCCURRING WHEN THE S/C HAS THE SAME RIGHT ASCENSION
C AS THE SUN AND MIDNIGHT IS WHEN THE S/C HAS THE SAME RIGHT ASCENSION
C AS THE ANTI-SUN.
C
C VAR     DIM    TYPE I/O DESCRIPTION
C ---     ---    ---- --- -----------
C
C THISNAME 1     CH*16 I  NAME OF THE ZENITH TARGET.  THE ONLY VALID
C                         NAMES ARE 'NOONZENITH2' AND 'MIDZENITH2'.
C
C TSEC50   1      R*8  I  THE TIME ASSOCIATED WITH SCPOS AND SCVEL. TIME
C                         IS NEEDED BECAUSE THE SUN POSITION IS
C                         INVOLVED.  IN SECONDS SINCE 1/1/50, 0.0 HR
C
C SCPOS    3      R*8  I  THE SPACECRAFT POSITION VECTOR AT TIME TSEC50.
C                         THE S/C STATE IS NEEDED BECAUSE ZENITH DEPENDS
C                         ON THE TRAJECTORY.  MEAN OF 1950.0 IS ASSUMED.
C                         IN KM.
C
C SCVEL    3      R*8  I  THE SPACECRAFT VELOCITY VECTOR AT TIME TSEC50.
C                         MEAN OF 1950.0 IS ASSUMED.  IN KM/SEC.
C
C TIMTARG  1      R*8  O  THE TIME WHEN THE S/C ARRIVES AT THE NOON OR
C                         MIDNIGHT POSITION.  IN SECONDS SINCE
C                         1/1/50, 0.0 HRS
C
C TARG     3      R*8  O  TARG IS THE CARTESIAN UNIT VECTOR OF THE
C                         NOON/MIDNIGHT ZENITH TARGET. IN MEAN OF 1950.0
C
C LUERR    1      I*4  I  FORTRAN UNIT NUMBER FOR ERROR MESSAGES.
C                          = 0/NEGATIVE, NO MESSAGES POSSIBLE.
C
C IERR     1      I*4  O  ERROR RETURN FLAG.
C                          = 0, NO ERROR.
C                          = OTHERWISE, ERROR.
C
C***********************************************************************
C
C BY C PETRUZZO, GSFC/742, 8/85.
C        MODIFIED....
C
C***********************************************************************
C
      REAL*8 SUNPOS(3),STATE1(6),PLANE2(2),ELEMS(6),
     *       ORBNORM(3),MERIDNORM(3),SCPOS(3),SCVEL(3),TARG(3)
      REAL*8 HALFPI/ 1.570796326794897D0 /
      REAL*8 PI/ 3.141592653589793D0 /
      REAL*8 TWOPI/ 6.283185307179586D0 /
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      LOGICAL WRONGSIDE,CONVERGED
      CHARACTER*16 THISNAME,NOONZ/'NOONZENITH2'/,MIDZ/'MIDZENITH2'/
C
      IBUG = 0
      LUBUG = 19
C
C SET INDICATOR TELLING THE ROUTINE WHICH ZENITH TARGET THIS IS
C
      KEY = 0
      IF(THISNAME.EQ.NOONZ) KEY = +1
      IF(THISNAME.EQ.MIDZ)  KEY = -1
C
C    ERROR CHECK. IF THIS OCCURS, ROUTINE SHOULD NOT HAVE BEEN CALLED.
      IF(KEY.EQ.0) THEN
        TYPE *,'TGLOC05B. CODING ERROR 1. RUN STOPPED.'
        STOP   'TGLOC05B. CODING ERROR 1. RUN STOPPED.'
        END IF
C
C INITIALIZE MISC PARAMS
C
      IERR = 0
      ERTHMU = CONST(56)
      ANGTEST = 0.001D0/DEGRAD
C
C METHOD: THE S/C CROSSES THE MERIDIAN CONTAINING THE SUN AT TWO PLACES,
C         ONE ON THE DAY SIDE AND ONE ON THE NIGHT SIDE. WE PROPAGATE
C         THE STATE TO THE NEAREST(IN TIME) CROSSING, SEE WHICH ONE IT
C         IS, AND PROPAGATE TO THE PROPER ONE IF NECESSARY. WE ITERATE
C         BECAUSE THE SUN IS MOVING.
C
C LOAD INPUT CONDS INTO ITERATION LOOP ARRAY FOR FIRST ITERATION
C
      TSTATE1 = TSEC50
      STATE1(1) = SCPOS(1)
      STATE1(2) = SCPOS(2)
      STATE1(3) = SCPOS(3)
      STATE1(4) = SCVEL(1)
      STATE1(5) = SCVEL(2)
      STATE1(6) = SCVEL(3)
C
C SET THE ORBITAL PERIOD.
C
      PD = PERIOD(ERTHMU,STATE1(1),STATE1(4))
C
C COMPUTE ORBIT NORMAL VECTOR.
C
      CALL UCROSS(STATE1(1),STATE1(4),ORBNORM)
      IF(IBUG.NE.0) THEN
        CALL XYZSPH(-1,ONRA,ONDEC,DUM,ORBNORM,1.D0)
        WRITE(LUBUG,5009) ONRA*DEGRAD,ONDEC*DEGRAD
 5009   FORMAT(' TGLOC05B DEBUG. ORBNORM  RA,DEC=',2G18.10)
        END IF
C
C
C SET PARAMETERS FOR ITERATION LOOPS.
C
      MAXITER = 10    ! MAX LOOPS TO ITERATE
      TIMEPS = 0.1D0  ! FOR CONVERGENCE TEST
      TLAST = -1.D10  ! FOR CONVERGENCE TEST
      CONVERGED = .FALSE.
      ITER = 0
C
C
      DO WHILE ( .NOT.CONVERGED .AND. ITER.LT.MAXITER )
        ITER = ITER + 1
        IF(IBUG.NE.0) WRITE(LUBUG,5002) ITER,PAKTIM50(TSTATE1)
 5002   FORMAT(/,' TGLOC05B DEBUG. START ITER=',I2,'  TIME=',F15.8)
C
C
C      FIND MERIDIAN PLANE CONTAINING THE SUN. SET ITS NORMAL VECTOR.
C
        CALL SOLM50(TSTATE1,SUNPOS,0)
        CALL XYZSPH(-1,SUNRA,SUNDEC,DUM,SUNPOS,1.D0)
        PLANE2(1) = HALFPI
        PLANE2(2) = SUNRA
        CALL XYZSPH(1,SUNRA+HALFPI,0.D0,1.D0,MERIDNORM,1.D0)
        IF(IBUG.NE.0) WRITE(LUBUG,5010) SUNRA*DEGRAD,SUNDEC*DEGRAD
 5010   FORMAT(' TGLOC05B DEBUG. SUN RA,DEC=',2G18.10)
C
C
C      FIND THE TIME UNTIL THE NEAREST CROSSING OF THE SUN MERIDIAN
C      PLANE BY THE S/C.
C
        CALL XPLANE(ERTHMU,STATE1,-1,PLANE2,0,KCROSS,DELTIM,LUERR,IERR1)
        IF(IBUG.NE.0) WRITE(LUBUG,5004)
     *     PLANE2(1)*DEGRAD,PLANE2(2)*DEGRAD,ICROSS,KCROSS,DELTIM,IERR1
 5004   FORMAT(' TGLOC05B DEBUG. '/,
     *         '    MERIDIAN PLANE INCL=',G12.5/,
     *         '    MERIDIAN PLANE NODE=',G12.5/,
     *         '    ICROSS, KCROSS =',2I5/,
     *         '    DELTIM=',G12.5,'  IERR1=',I3)
        IF(IERR1.NE.0) THEN
          IF(LUERR.GT.0) WRITE(LUERR,3001)
 3001     FORMAT(/,' TGLOC05B. ERROR CONDITION. ERROR RETURN FROM ',
     *      'XPLANE.'/,'    BAD NOON OR MIDNIGHT ZENITH LOCATION.')
          IERR = 1
          GO TO 9999
          END IF
C
C
C      PROPAGATE STATE1 TO THE NEAREST CROSSING.
C
        CALL TUBODY(ERTHMU,STATE1(1),STATE1(4),DELTIM,
     *                     STATE1(1),STATE1(4),LUERR,IERR1)
        TSTATE1 = TSTATE1 + DELTIM
C
C      FOR MIDNIGHT ZENITH, WE WANT THE S/C POSITION AT THE MERIDIAN
C      CROSSING ON THE BACK SIDE OF THE EARTH. FOR NOON ZENITH, WE WANT
C      THE FRONT SIDE. TEST THE LOCATION WE HAVE FOUND AND PROPAGATE IT
C      1/2 ORBIT IF NECESSARY.
C
        IF(IBUG.NE.0) WRITE(LUBUG,5005) ANGVEC(SUNPOS,STATE1)*DEGRAD
 5005   FORMAT(' TGLOC05B DEBUG. SUN/SC SEPARATION=',G12.5)
        TEST = DOT(SUNPOS,STATE1)
        WRONGSIDE = ( TEST.GT.0.D0 .AND. KEY.EQ.-1)     .OR.
     *              ( TEST.LT.0.D0 .AND. KEY.EQ.+1)
        IF(WRONGSIDE) THEN
          TPROP = PD/2.D0
          IF(DELTIM.GT.0.D0) TPROP = -TPROP  ! KEEP CLOSE TO EPOCH TIME
          CALL TUBODY(ERTHMU,STATE1(1),STATE1(4),TPROP,
     *                       STATE1(1),STATE1(4),LUERR,IERR1)
          TSTATE1 = TSTATE1 + TPROP
          IF(IBUG.NE.0) WRITE(LUBUG,5011) TPROP,PAKTIM50(TSTATE1)
 5011     FORMAT(' TGLOC05B DEBUG. FOUND CROSSING ON FRONT.'/,
     *           '    PROPAGATE ',G12.5,' SECONDS TO TIME ',G15.8)
          END IF
C
C      TEST FOR 'CLOSE ENOUGH' TIME. IF SO, EXIT THE ITERATION LOOP.
C
        IF(IBUG.NE.0) WRITE(LUBUG,5006) TSTATE1-TLAST
 5006   FORMAT(' TGLOC05B CONVERGENCE TEST. TSTATE1-TLAST=',G14.7)
        CONVERGED = DABS(TSTATE1-TLAST) .LT. TIMEPS
        TLAST = TSTATE1
C
        END DO
C
C
      IF(CONVERGED) THEN
        TIMTARG = TSTATE1
        TARG(1) = STATE1(1)
        TARG(2) = STATE1(2)
        TARG(3) = STATE1(3)
      ELSE
        IERR = 1
        IF(LUERR.GT.0) WRITE(LUERR,9001)
 9001   FORMAT(/,
     *   ' TGLOC05B. MAX ITERATIONS EXCEEDED. BAD NOON OR MIDNIGHT ',
     *       ' ZENITH LOCATION COMPUTED.')
        END IF
C
C
 9999 CONTINUE
      RETURN
      END

ext: for


text:
! { dg-do compile }
! { dg-options "-Warray-temporaries" }
! No temporary should be created for this, as a missing stride and
! a stride equal to one should be equal.
program main
  integer a(100)
  a(10:16) = a(11:17)
  a(10:16) = a(11:17:1)
  a(10:16:1) = a(11:17)
  a(10:16:1) = a(11:17:1)
end program main

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
      module utility_module

c***********************************************************************
c
c     dl_poly module for utility subroutines and functions
c
c     copyright - daresbury laboratory
c     author    - w. smith    aug 2006
c
c***********************************************************************

      implicit none

      contains

      subroutine global_sum_forces(natms,mxnode,gxx,gyy,gzz)

c***********************************************************************
c
c     dl_poly subroutine to perform global sum of atomic forces as
c     requred by replicated data strategy
c
c     copyright - daresbury laboratory
c     author    - w.smith december 2005
c
c***********************************************************************

      use config_module

      implicit none

      integer natms,mxnode,i,j
      real(8) gxx(*),gyy(*),gzz(*)

      if(mxnode.gt.1) then

        j=0
        do i=1,natms

          buffer(j+1)=gxx(i)
          buffer(j+2)=gyy(i)
          buffer(j+3)=gzz(i)
          j=j+3

        enddo
        call gdsum(buffer(1),3*natms,buffer(3*natms+1))
        j=0
        do i=1,natms

          gxx(i)=buffer(j+1)
          gyy(i)=buffer(j+2)
          gzz(i)=buffer(j+3)
          j=j+3

        enddo

      endif

      return
      end subroutine global_sum_forces

      subroutine images
     x  (imcon,idnode,mxnode,natms,cell,xxx,yyy,zzz)

c***********************************************************************
c
c     dl_poly subroutine for calculating the minimum image
c     of atom pairs within a specified MD cell
c
c     parallel replicated data version
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith march 1992.
c     T3D optimised version. t.forester july 1994
c
c     for
c     imcon=0 no boundary conditions apply
c     imcon=1 standard cubic boundaries apply
c     imcon=2 orthorhombic boundaries apply
c     imcon=3 parallelepiped boundaries apply
c     imcon=4 truncated octahedron boundaries apply
c     imcon=5 rhombic dodecahedron boundaries apply
c     imcon=6 x-y parallelogram boundary conditions : no periodicity in z
c     imcon=7 hexagonal prism boundaries apply
c
c     note: in all cases the centre of the cell is at (0,0,0)
c     warning - replicated data version: does not re-merge
c     coordinate arrays
c
c***********************************************************************

      use error_module

      implicit none

      integer imcon,idnode,mxnode,natms,iatm1,iatm2,i
      real(8) cell,xxx,yyy,zzz,aaa,bbb,ccc,det,rt2,rt3,ssx
      real(8) ssy,ssz,ddd,xss,yss,zss,rcell

      dimension xxx(*),yyy(*),zzz(*)
      dimension cell(9),rcell(9)

      data rt2/1.41421356623d0/,rt3/1.7320508075d0/

      if(imcon.gt.0) then

c     block indices

        iatm1 = (idnode*natms)/mxnode+1
        iatm2 = ((idnode+1)*natms)/mxnode

      endif

      if(imcon.eq.1)then

c     standard cubic boundary conditions

        aaa=1.d0/cell(1)

        do i=iatm1,iatm2
          xxx(i)=xxx(i)-cell(1)*nint(aaa*xxx(i))
          yyy(i)=yyy(i)-cell(1)*nint(aaa*yyy(i))
          zzz(i)=zzz(i)-cell(1)*nint(aaa*zzz(i))
        enddo

      else if(imcon.eq.2)then

c     rectangular (slab) boundary conditions

        aaa=1.d0/cell(1)
        bbb=1.d0/cell(5)
        ccc=1.d0/cell(9)

        do i=iatm1,iatm2

          xxx(i)=xxx(i)-cell(1)*nint(aaa*xxx(i))
          yyy(i)=yyy(i)-cell(5)*nint(bbb*yyy(i))
          zzz(i)=zzz(i)-cell(9)*nint(ccc*zzz(i))

        enddo

      else if(imcon.eq.3)then

c     parallelepiped boundary conditions

        call invert(cell,rcell,det)

        do i=iatm1,iatm2

          ssx=(rcell(1)*xxx(i)+rcell(4)*yyy(i)+rcell(7)*zzz(i))
          ssy=(rcell(2)*xxx(i)+rcell(5)*yyy(i)+rcell(8)*zzz(i))
          ssz=(rcell(3)*xxx(i)+rcell(6)*yyy(i)+rcell(9)*zzz(i))

          xss=ssx-nint(ssx)
          yss=ssy-nint(ssy)
          zss=ssz-nint(ssz)

          xxx(i)=(cell(1)*xss+cell(4)*yss+cell(7)*zss)
          yyy(i)=(cell(2)*xss+cell(5)*yss+cell(8)*zss)
          zzz(i)=(cell(3)*xss+cell(6)*yss+cell(9)*zss)

        enddo

      else if(imcon.eq.4)then

c     truncated octahedral boundary conditions

        if(.not.(abs(cell(1)-cell(5)).lt.1.d-6.and.
     x    abs(cell(5)-cell(9)).lt.1.d-6)) call error(idnode,130)

        aaa=1.d0/cell(1)

        do i=iatm1,iatm2

          xxx(i)=xxx(i)-cell(1)*nint(aaa*xxx(i))
          yyy(i)=yyy(i)-cell(1)*nint(aaa*yyy(i))
          zzz(i)=zzz(i)-cell(1)*nint(aaa*zzz(i))

          if((abs(xxx(i))+abs(yyy(i))+abs(zzz(i))).ge.
     x      (0.75d0*cell(1)))then

            xxx(i)=xxx(i)-0.5d0*sign(cell(1),xxx(i))
            yyy(i)=yyy(i)-0.5d0*sign(cell(1),yyy(i))
            zzz(i)=zzz(i)-0.5d0*sign(cell(1),zzz(i))

          endif

        enddo

      else if(imcon.eq.5)then

c     rhombic dodecahedral boundary conditions

        if(.not.(abs(cell(1)-cell(5)).lt.1.d-6.and.
     x    abs(cell(9)-cell(1)*rt2).lt.1.d-6))
     x    call error(idnode,140)

        aaa=1.d0/cell(1)
        bbb=1.d0/cell(9)

        do i=iatm1,iatm2

          xxx(i)=xxx(i)-cell(1)*nint(aaa*xxx(i))
          yyy(i)=yyy(i)-cell(1)*nint(aaa*yyy(i))
          zzz(i)=zzz(i)-cell(9)*nint(bbb*zzz(i))

          if((abs(xxx(i))+abs(yyy(i))+abs(rt2*zzz(i))).ge.
     x      cell(1))then

            xxx(i)=xxx(i)-0.5d0*sign(cell(1),xxx(i))
            yyy(i)=yyy(i)-0.5d0*sign(cell(1),yyy(i))
            zzz(i)=zzz(i)-0.5d0*sign(cell(9),zzz(i))

          endif

        enddo

      else if(imcon.eq.6) then

c     x-y boundary conditions

        det = cell(1)*cell(5) - cell(2)*cell(4)

        if(abs(det).lt.1.d-6)call error(idnode,120)

        det = 1.d0/det

        rcell(1) =  det*cell(5)
        rcell(2) = -det*cell(2)
        rcell(4) = -det*cell(4)
        rcell(5) =  det*cell(1)

        do i=iatm1,iatm2

          ssx = rcell(1)*xxx(i) + rcell(4)*yyy(i)
          ssy = rcell(2)*xxx(i) + rcell(5)*yyy(i)

          xss = ssx - nint(ssx)
          yss = ssy - nint(ssy)

          xxx(i)=cell(1)*xss + cell(4)*yss
          yyy(i)=cell(2)*xss + cell(5)*yss

        enddo

      else if(imcon.eq.7) then

c     hexagonal prism boundary conditions

        if(abs(cell(1)-rt3*cell(5)).ge.1.d-6)
     x    call error(idnode,135)

        aaa=cell(1)/(rt3*2.d0)
        bbb=cell(1)/rt3
        ccc=rt3/cell(1)
        ddd=1.d0/cell(9)

        do i=iatm1,iatm2

          yyy(i)=yyy(i)-bbb*nint(ccc*yyy(i))
          zzz(i)=zzz(i)-cell(9)*nint(ddd*zzz(i))

          if((abs(yyy(i))+abs(rt3*xxx(i))).ge.bbb)then

            xxx(i)=xxx(i)-rt3*sign(aaa,xxx(i))
            yyy(i)=yyy(i)-sign(aaa,yyy(i))

          endif

        enddo

      endif

      return
      end subroutine images

      subroutine config_write(fname,levcfg,imcon,natms,engcfg)

c***********************************************************************
c
c     dl_poly subroutine for writing CONFIG files
c
c     copyright - daresbury laboratory
c     author    - w. smith aug 2007
c
c***********************************************************************

      use config_module
      use setup_module

      implicit none

      character*6 fname

      integer i,natms,levcfg,imcon,nstep
      real(8) engcfg

      open(nconf,file=fname,form='formatted')

      write(nconf,'(80a1)') cfgname
      write(nconf,'(3i10,1p,g20.12)') levcfg,imcon,natms,engcfg
      if(imcon.gt.0) write(nconf,'(3f20.12)') cell

      do i=1,natms

        write(nconf,'(a8,i10)') atmnam(i),i
        write(nconf,'(3g20.10)') xxx(i),yyy(i),zzz(i)
        if(levcfg.gt.0)write(nconf,'(3g20.12)')
     x    vxx(i),vyy(i),vzz(i)
        if(levcfg.gt.1)write(nconf,'(3g20.12)')
     x    fxx(i),fyy(i),fzz(i)

      enddo

      close (nconf)

      return
      end subroutine config_write

      subroutine bomb(idnode,nyr,nmn,ndy)

c***********************************************************************
c
c     dl_poly subroutine to set an expiry date in a compiled program
c
c     copyright - daresbury laboratory
c     author    - w. smith    oct 2002
c
c***********************************************************************

      use setup_module

      implicit none

      logical safe
      integer info(8)
      character*12 dat,tim,zon
      integer idnode,nyr,nmn,ndy

      safe=.true.

      call date_and_time(dat,tim,zon,info)

      if(info(1).gt.nyr)then

        safe=.false.

      else if(info(1).eq.nyr)then

        if(info(2).gt.nmn)then

          safe=.false.

        else if(info(2).eq.nmn)then

          if(info(3).ge.ndy)safe=.false.

        endif

      endif

      if(.not.safe)then

        if(idnode.eq.0)write(nrite,'(a,/,a)')
     x    'THE EXPIRY DATE OF THIS EXECUTABLE HAS PASSED.',
     X    'PLEASE CONTACT W.SMITH@DL.AC.UK FOR A NEW LICENCE'

        call exitcomms()

      endif

      return
      end subroutine bomb

      subroutine cpy_rtc(nnn,aaa,bbb)

c**********************************************************************
c
c     dl_poly subroutine for copying a real array into a complex array
c     of the same dimension
c
c     copyright daresbury laboratory 1998
c     author w.smith oct 1998
c
c**********************************************************************

      implicit none

      integer i,nnn
      real(8) aaa(*)
      complex(8) bbb(*)

      do i=1,nnn

        bbb(i)=cmplx(aaa(i),0.d0,kind=8)

      enddo

      return
      end subroutine cpy_rtc

      function duni()

c*********************************************************************
c
c     dl_poly random number generator based on the universal
c     random number generator of marsaglia, zaman and tsang
c     (stats and prob. lett. 8 (1990) 35-39.) it must be
c     called once to initialise parameters u,c,cd,cm
c
c     copyright daresbury laboratory 1992
c     author -  w.smith         july 1992
c
c*********************************************************************

      implicit none

      logical new
      integer ir,jr,i,j,k,l,m,ii,jj
      real(4) s,t,u,c,cd,cm,uni
      real(8) duni
      dimension u(97)
      save u,c,cd,cm,uni,ir,jr,new
      data new/.true./

      if(new)then

c     initial values of i,j,k must be in range 1 to 178 (not all 1)
c     initial value of l must be in range 0 to 168.

        i=12
        j=34
        k=56
        l=78
c
        ir=97
        jr=33
        new=.false.

        do 200 ii=1,97
          s=0.0
          t=0.5
          do 100 jj=1,24
            m=mod(mod(i*j,179)*k,179)
            i=j
            j=k
            k=m
            l=mod(53*l+1,169)
            if(mod(l*m,64).ge.32)s=s+t
            t=0.5*t
  100     continue
          u(ii)=s
  200   continue
        c =  362436.0/16777216.0
        cd= 7654321.0/16777216.0
        cm=16777213.0/16777216.0
      else

c     calculate random number
        uni=u(ir)-u(jr)
        if(uni.lt.0.0)uni=uni+1.0
        u(ir)=uni
        ir=ir-1
        if(ir.eq.0)ir=97
        jr=jr-1
        if(jr.eq.0)jr=97
        c=c-cd
        if(c.lt.0.0)c=c+cm
        uni=uni-c
        if(uni.lt.0.0)uni=uni+1.0
        duni=dble(uni)
      endif

      return
      end function duni

      function puni(key,uuu)

c*********************************************************************
c
c     dl_poly random number generator based on the universal
c     random number generator of marsaglia, zaman and tsang
c     (stats and prob. lett. 8 (1990) 35-39.) it must be
c     called once to initialise parameters u,c,cd,cm
c
c     copyright daresbury laboratory 1992
c     author -  w.smith         july 1992
c
c     parallel version - w.smith sep 2016
c
c     set key=0 to return a random number
c     set key=1 to initialise random number generator
c     set key=2 to reload control variables at restart
c     set key=3 to return control variables for saving
c
c*********************************************************************

      implicit none

      integer ir,jr,i,j,k,l,m,ii,jj,key,idnode,mynode
      real(4) s,t,c,cd,cm,uni
      real(8) puni,uuu(102)
      real(4) u(97)
      save u,c,cd,cm,uni,ir,jr

      if(key.eq.1)then

c     initialise random number generator
c     initial values of i,j,k must be in range 1 to 178 (not all 1)
c     initial value of l must be in range 0 to 168.

        idnode=mynode()
        i=mod(11+idnode,178)+1
        j=mod(33+idnode,178)+1
        k=mod(55+idnode,178)+1
        l=mod(77+idnode,168)+1
        if(i.eq.1.and.j.eq.1.and.k.eq.1)then
          j=13
          k=131
        endif

        ir=97
        jr=33

        do ii=1,97
          s=0.0
          t=0.5
          do jj=1,24
            m=mod(mod(i*j,179)*k,179)
            i=j
            j=k
            k=m
            l=mod(53*l+1,169)
            if(mod(l*m,64).ge.32)s=s+t
            t=0.5*t
          enddo
          u(ii)=s
        enddo

        c =  362436.0/16777216.0
        cd= 7654321.0/16777216.0
        cm=16777213.0/16777216.0

      else if(key.eq.2)then

c     reload control variables at restart

        do ii=1,97
          u(ii)=uuu(ii)
        enddo
        c=uuu(98)
        cd=uuu(99)
        cm=uuu(100)
        ir=nint(uuu(101))
        jr=nint(uuu(102))

      else if(key.eq.3)then

c     return control variables for saving

        do ii=1,97
          uuu(ii)=u(ii)
        enddo
        uuu(98)=c
        uuu(99)=cd
        uuu(100)=cm
        uuu(101)=dble(ir)
        uuu(102)=dble(jr)

      else

c     generate random number

        uni=u(ir)-u(jr)
        if(uni.lt.0.0)uni=uni+1.0
        u(ir)=uni
        ir=ir-1
        if(ir.eq.0)ir=97
        jr=jr-1
        if(jr.eq.0)jr=97
        c=c-cd
        if(c.lt.0.0)c=c+cm
        uni=uni-c
        if(uni.lt.0.0)uni=uni+1.0
        puni=dble(uni)

      endif

      return
      end function puni

      subroutine ele_prd(nnn,aaa,bbb,ccc)

c**********************************************************************
c
c     dl_poly subroutine for element by element product of
c     a real array (bbb) and a complex array (ccc)
c
c     copyright daresbury laboratory 1998
c     author w.smith july 1998
c
c**********************************************************************

      implicit none

      integer i,nnn
      real(8) bbb(*)
      complex(8) aaa(*),ccc(*)

      do i=1,nnn

        aaa(i)=bbb(i)*ccc(i)

      enddo

      return
      end subroutine ele_prd

      subroutine gauss(natms,vxx,vyy,vzz)

c*********************************************************************
c
c     dl_poly subroutine for constructing velocity arrays
c     with a gaussian distribution of unit variance.
c
c     based on the Box-Muller method
c
c     note - this version uses a universal random number
c     generator, which generates pseudo-random numbers between
c     0 and 1. it is based on the algorithm of marsaglia, zaman
c     and tsang in: stats and prob. lett. 8 (1990) 35-39.
c
c     copyright daresbury laboratory 2007
c     author - w. smith         nov  2007
c
c*********************************************************************

      use setup_module

      implicit none

      integer natms,i
      real(8) vxx,vyy,vzz,rrr,rr1,rr2

      dimension vxx(natms),vyy(natms),vzz(natms)

c     initialise random number generator

      rrr=duni()

c     calculate gaussian random numbers

      do i=1,2*(natms/2),2

        rr1=sqrt(-2.d0*log(duni()))
        rr2=2.d0*pi*duni()
        vxx(i)=rr1*cos(rr2)
        vxx(i+1)=rr1*sin(rr2)

        rr1=sqrt(-2.d0*log(duni()))
        rr2=2.d0*pi*duni()
        vyy(i)=rr1*cos(rr2)
        vyy(i+1)=rr1*sin(rr2)

        rr1=sqrt(-2.d0*log(duni()))
        rr2=2.d0*pi*duni()
        vzz(i)=rr1*cos(rr2)
        vzz(i+1)=rr1*sin(rr2)

      enddo
      if(mod(natms,2).ne.0)then

        rr1=sqrt(-2.d0*log(duni()))
        rr2=2.d0*pi*duni()
        vxx(natms)=rr1*cos(rr2)
        vyy(natms)=rr1*sin(rr2)
        rr1=sqrt(-2.d0*log(duni()))
        rr2=2.d0*pi*duni()
        vzz(natms)=rr1*cos(rr2)

      endif

      return
      end subroutine gauss

      subroutine invert(a,b,d)

c***********************************************************************
c
c     dl_poly subroutine to invert a 3 * 3 matrix using cofactors
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith       april 1992
c
c***********************************************************************

      implicit none

      real(8) a,b,d,r

      dimension a(9),b(9)

c     calculate adjoint matrix
      b(1)=a(5)*a(9)-a(6)*a(8)
      b(2)=a(3)*a(8)-a(2)*a(9)
      b(3)=a(2)*a(6)-a(3)*a(5)
      b(4)=a(6)*a(7)-a(4)*a(9)
      b(5)=a(1)*a(9)-a(3)*a(7)
      b(6)=a(3)*a(4)-a(1)*a(6)
      b(7)=a(4)*a(8)-a(5)*a(7)
      b(8)=a(2)*a(7)-a(1)*a(8)
      b(9)=a(1)*a(5)-a(2)*a(4)

c     calculate determinant
      d=a(1)*b(1)+a(4)*b(2)+a(7)*b(3)
      r=0.d0
      if(abs(d).gt.0.d0)r=1.d0/d

c     complete inverse matrix
      b(1)=r*b(1)
      b(2)=r*b(2)
      b(3)=r*b(3)
      b(4)=r*b(4)
      b(5)=r*b(5)
      b(6)=r*b(6)
      b(7)=r*b(7)
      b(8)=r*b(8)
      b(9)=r*b(9)

      return
      end subroutine invert

      subroutine jacobi(a,v,n)

c***********************************************************************
c
c     diagonalisation of real symmetric matices by jacobi method
c
c     input parameters:
c
c     a(n,n) is the matrix to be diagonalised
c     v(n,n) is the eigenvector matrix
c     n   is the dimension of the matrices
c
c     jacobi processes lower triangle only (upper triangle unchanged)
c
c     variable rho sets absolute tolerance on convergence
c     variable tes is a moving tolerance that diminishes
c     on each pass until at true convergence tes<rho
c
c     author w.smith 1993
c
c***********************************************************************

      implicit none

      logical pass
      integer n,i,j,k
      real(8) a,v,rho,tes,scl,v1,v2,v3,u,omg,s,c,tem

      dimension a(n,n),v(n,n)

      rho=1.0d-16
      tes=0.0d0
      scl=0.0d0

c     initialize eigenvectors

      do i=1,n
        do j=1,n
          v(i,j)=0.0d0
        enddo
        v(i,i)=1.0d0
      enddo

c     rescale matrix for optimal accuracy

      do i=1,n
        if(abs(a(i,i)).gt.scl)scl=abs(a(i,i))
      enddo
      do i=1,n
        do j=1,i
          a(i,j)=a(i,j)/scl
        enddo
      enddo

c     set initial value of moving tolerance

      do i=2,n
        do j=1,i-1
          tes=tes+2.0d0*a(i,j)*a(i,j)
        enddo
      enddo
      tes=sqrt(tes)

c     recycle until absolute tolerance satisfied

      do while(tes.gt.rho)

        tes=tes/dble(n)
        if(tes.lt.rho)tes=rho

c     jacobi diagonalisation

        pass=.true.

c     recycle until moving tolerance satisfied

        do while(pass)

          pass=.false.

          do i=2,n

            do j=1,i-1

              if(abs(a(i,j)).ge.tes)then
                pass=.true.
                v1=a(j,j)
                v2=a(i,j)
                v3=a(i,i)
                u=0.5d0*(v1-v3)
                if(abs(u).lt.rho)then
                  omg=-1.0d0
                else
                  omg=-v2/sqrt(v2*v2+u*u)
                  if(u.lt.0.0d0)omg=-omg
                endif
                s=omg/sqrt(2.0d0*(1.0d0+sqrt(1.0d0-omg*omg)))
                c=sqrt(1.0d0-s*s)
                do k=1,n
                  if(k.ge.i)then
                    tem=a(k,j)*c-a(k,i)*s
                    a(k,i)=a(k,j)*s+a(k,i)*c
                    a(k,j)=tem
                  else if(k.lt.j)then
                    tem=a(j,k)*c-a(i,k)*s
                    a(i,k)=a(j,k)*s+a(i,k)*c
                    a(j,k)=tem
                  else
                    tem=a(k,j)*c-a(i,k)*s
                    a(i,k)=a(k,j)*s+a(i,k)*c
                    a(k,j)=tem
                  endif
                  tem=v(k,j)*c-v(k,i)*s
                  v(k,i)=v(k,j)*s+v(k,i)*c
                  v(k,j)=tem
                enddo
                a(j,j)=v1*c*c+v3*s*s-2.0d0*v2*s*c
                a(i,i)=v1*s*s+v3*c*c+2.0d0*v2*s*c
                a(i,j)=(v1-v3)*s*c+v2*(c*c-s*s)
              endif

            enddo

          enddo

        enddo

      enddo

c     rescale matrix

      do i=1,n
        do j=1,i
          a(i,j)=scl*a(i,j)
        enddo
      enddo

      return
      end subroutine jacobi

      subroutine scl_csum(nnn,tot,aaa)

c**********************************************************************
c
c     dl_poly subroutine to calculate the scalar sum of the elements
c     of a complex array
c
c     copyright daresbury laboratory 1998
c     author w.smith july 1998
c
c**********************************************************************

      implicit none

      integer i,nnn
      complex(8) aaa(*),tot

      tot=(0.d0,0.d0)

      do i=1,nnn

        tot=tot+aaa(i)

      enddo

      return
      end subroutine scl_csum

      subroutine set_block(nnn,ccc,aaa)

c**********************************************************************
c
c     dl_poly subroutine to initialise an array to a single value
c
c     copyright daresbury laboratory 1998
c     author w.smith july 1998
c
c**********************************************************************

      implicit none

      integer i,nnn
      real(8) ccc,aaa(nnn)

      do i=1,nnn,2

        aaa(i)=ccc
        aaa(i+1)=ccc

      enddo

      return
      end subroutine set_block

      subroutine shellsort(n,list)

c***********************************************************************
c
c     dlpoly shell sort routine.
c     Sorts an array of integers into ascending order
c
c     copyright daresbury laboratory 1993
c     author - t.forester   november 1993
c
c***********************************************************************

      implicit none

      integer n,list,nn,nl,i,j,ix,imax

      dimension list(*)

c     set up sort

      if(n.gt.1) then

c     number of lists

        nl = n/2

c     iterate shell sort

        do while(nl.gt.0)

          do nn = 1,nl

c     begin insertion sort on nnth list

            do i = nn+nl,n,nl

              imax = list(i)
              ix = i

c     find location for insertion

              j = i
              do while(j.ge.nl+1)

                j = j-nl
                if (list(j).gt.imax) then
                  ix = j
                else
                  j =1
                endif

              enddo

c     insert in index array

              do j = i,ix+nl,-nl
                list(j) = list(j-nl)
              enddo

              list(ix) = imax

            enddo

          enddo

          nl = nl/2

        enddo

      endif

      return
      end subroutine shellsort

      subroutine fcap(lfcap,natms,fmax,temp)

c*********************************************************************
c
c     DLPOLY routinue for limiting the absolute magnitude of
c     forces. Used in equilibration period only
c
c     copyright daresbury laboratory 1993
c
c     author -     t. forester march 1993
c     amended-     t. forester  sept 1994
c
c*********************************************************************

      use config_module

      implicit none

      logical lfcap
      integer natms,i
      real(8) fmax,temp,fmax1,fmax2,fxc,fyc,fzc,fmod,fscale

      if(lfcap) then

c     maximum force permitted

        fmax1 = boltz*fmax*temp
        fmax2 = fmax1*fmax1

c     cap forces and conserve linear momentum

        fxc = 0.d0
        fyc = 0.d0
        fzc = 0.d0

        do i = 1,natms

          fmod = fxx(i)**2 + fyy(i)**2 + fzz(i)**2

          if(fmod.gt.fmax2) then

            fscale = sqrt(fmax2/fmod)

            fxx(i) = fxx(i)*fscale
            fyy(i) = fyy(i)*fscale
            fzz(i) = fzz(i)*fscale

          endif

c     accummulate forces - to check on momentum conservation

          fxc = fxc + fxx(i)
          fyc = fyc + fyy(i)
          fzc = fzc + fzz(i)

        enddo

c     ensure net forces sum to zero

        fxc = -fxc/dble(natms)
        fyc = -fyc/dble(natms)
        fzc = -fzc/dble(natms)

c     conserve momentum

        do i = 1,natms

          fxx(i) = fxx(i) + fxc
          fyy(i) = fyy(i) + fyc
          fzz(i) = fzz(i) + fzc

        enddo

      endif

      return
      end subroutine fcap

      subroutine freeze(natms)

c***********************************************************************
c
c     dlpoly routine to quench forces and velocities on 'frozen' atoms
c     replicated data version - blocked data
c
c     copyright daresbury laboratory 1994
c     author t.forester nov 1994
c
c***********************************************************************

      use config_module

      implicit none

      integer natms,i

      do i = 1,natms

        if(lstfrz(i).ne.0) then

          vxx(i) = 0.d0
          vyy(i) = 0.d0
          vzz(i) = 0.d0
          fxx(i) = 0.d0
          fyy(i) = 0.d0
          fzz(i) = 0.d0

        endif

      enddo

      return
      end subroutine freeze

      subroutine mat_mul(aaa,bbb,ccc)

c***********************************************************************
c
c     dlpoly utility to multiply 3x3 matrices
c
c     copyright daresbury laboratory
c     author      w.smith  oct  2005
c
c**********************************************************************

      implicit none

      integer i
      real(8) aaa(9),bbb(9),ccc(9),tmp(9)

      tmp(1)=aaa(1)*bbb(1)+aaa(4)*bbb(2)+aaa(7)*bbb(3)
      tmp(2)=aaa(2)*bbb(1)+aaa(5)*bbb(2)+aaa(8)*bbb(3)
      tmp(3)=aaa(3)*bbb(1)+aaa(6)*bbb(2)+aaa(9)*bbb(3)

      tmp(4)=aaa(1)*bbb(4)+aaa(4)*bbb(5)+aaa(7)*bbb(6)
      tmp(5)=aaa(2)*bbb(4)+aaa(5)*bbb(5)+aaa(8)*bbb(6)
      tmp(6)=aaa(3)*bbb(4)+aaa(6)*bbb(5)+aaa(9)*bbb(6)

      tmp(7)=aaa(1)*bbb(7)+aaa(4)*bbb(8)+aaa(7)*bbb(9)
      tmp(8)=aaa(2)*bbb(7)+aaa(5)*bbb(8)+aaa(8)*bbb(9)
      tmp(9)=aaa(3)*bbb(7)+aaa(6)*bbb(8)+aaa(9)*bbb(9)

      do i=1,9
        ccc(i)=tmp(i)
      enddo

      return
      end subroutine mat_mul

      subroutine getrotmat(q0,q1,q2,q3,rot)

c***********************************************************************
c
c     dlpoly utility to  construct rotation matrix
c     from quaternions using x convention for euler angles
c
c     copyright daresbury laboratory
c     author      w.smith   mar 2005
c
c**********************************************************************

      implicit none

      real(8) q0,q1,q2,q3,rot(9)

      rot(1)=q0**2+q1**2-q2**2-q3**2
      rot(2)=2.d0*(q1*q2-q0*q3)
      rot(3)=2.d0*(q1*q3+q0*q2)
      rot(4)=2.d0*(q1*q2+q0*q3)
      rot(5)=q0**2-q1**2+q2**2-q3**2
      rot(6)=2.d0*(q2*q3-q0*q1)
      rot(7)=2.d0*(q1*q3-q0*q2)
      rot(8)=2.d0*(q2*q3+q0*q1)
      rot(9)=q0**2-q1**2-q2**2+q3**2

      return
      end subroutine getrotmat

      function sdot0(n,aaa,bbb)

c***********************************************************************
c
c     dlpoly utility to calculate scalar product of two arrays
c
c     copyright daresbury laboratory
c     author      w.smith  july 2005
c
c**********************************************************************

      implicit none

      integer n,i
      real(8) sdot0,aaa,bbb

      dimension aaa(*),bbb(*)

      sdot0=0.d0

      do i=1,n
        sdot0=sdot0+aaa(i)*bbb(i)
      enddo

      return
      end function sdot0

      function sdot1(natms,idnode,mxnode,aaa,bbb)

c***********************************************************************
c
c     dlpoly utility to calculate scalar product of two arrays
c     distributed version
c
c     copyright daresbury laboratory
c     author      w.smith  july 2005
c
c**********************************************************************

      use config_module

      implicit none

      integer natms,idnode,mxnode,i,iatm0,iatm1
      real(8) sdot1,aaa,bbb

      dimension aaa(*),bbb(*)

c     assign block of atoms to processor

      iatm0=(idnode*natms)/mxnode + 1
      iatm1=((idnode+1)*natms)/mxnode

      sdot1=0.d0

      do i=iatm0,iatm1
        sdot1=sdot1+aaa(i)*bbb(i)
      enddo

      if(mxnode.gt.1)then
        buffer(1)=sdot1
        call gdsum(buffer(1),1,buffer(2))
        sdot1=buffer(1)
      endif

      return
      end function sdot1

      integer function loc2(i,j)

c*********************************************************************
c
c     calculates double index array minimum reference
c
c     copyright daresbury laboratory
c     author w.smith november 2005
c
c*********************************************************************

      integer i,j

      loc2=(max(i,j)*(max(i,j)-1))/2+min(i,j)

      return
      end function loc2

      integer function loc3(i,j,k)

c*********************************************************************
c
c     calculates triple index array minimum reference
c
c     copyright daresbury laboratory
c     author w.smith september 2008
c
c*********************************************************************

      integer i,j,k,a,b,c,u,v,w

      a=max(i,j)
      b=min(a,k)
      c=min(i,j)
      u=max(a,k)
      v=max(b,c)
      w=min(b,c)
      loc3=(u*(u*u-1))/6+(v*(v-1))/2+w

      return
      end function loc3

      integer function loc4(i,j,k,l)

c*********************************************************************
c
c     calculates quaduple index array minimum reference
c
c     copyright daresbury laboratory
c     author w.smith september 2008
c
c*********************************************************************

      integer i,j,k,l,a,b,c,d,e,f,t,u,v,w

      a=max(i,j)
      b=max(k,l)
      c=min(i,j)
      d=min(k,l)
      e=max(c,d)
      f=min(a,b)
      t=max(a,b)
      u=max(e,f)
      v=min(e,f)
      w=min(c,d)
      loc4=((((t+2)*t-1)*t-2)*t)/24+(u*(u*u-1))/6+(v*(v-1))/2+w

      return
      end function loc4

      character*3 function intstr3(nnn)

c*********************************************************************
c
c     converts a 3 digit integer to a string "001" etc.
c
c     copyright daresbury laboratory
c     author w.smith november 2005
c
c*********************************************************************

      implicit none

      integer nnn

      write(intstr3,'(i3.3)')nnn

      return
      end function intstr3

      subroutine traject
     x  (ltraj,idnode,imcon,istraj,keytrj,natms,nstraj,nstep,tstep)

c***********************************************************************
c
c     dl_poly subroutine for writing history file at selected
c     intervals in simulation
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith dec 1992.
c
c***********************************************************************

      use setup_module
      use config_module

      implicit none

      logical newjob,ltraj
      integer idnode,imcon,istraj,keytrj,natms,nstraj,nstep,i
      real(8) tstep

      save newjob
      data newjob/.true./

      if(ltraj.and.idnode.eq.0)then

c     open the history file if new job or file closed

        if(newjob)then

          newjob = .false.

          open(nhist,file='HISTORY',position='append')

        endif

        if(nstep.eq.nstraj.or.nstep.eq.istraj)then

          write(nhist,'(80a1)') cfgname
          write(nhist,'(3i10)') keytrj,imcon,natms

        endif

        if(mod(nstep-nstraj,istraj).eq.0)then

          write(nhist,'(a8,4i10,f12.6)') 'timestep',
     x         nstep,natms,keytrj,imcon,tstep

          if(imcon.gt.0) write(nhist,'(3g12.4)') cell

          do i = 1,natms

            write(nhist,'(a8,i10,2f12.6)')
     x        atmnam(i),i,weight(i),chge(i)
            write(nhist,'(1p,3e12.4)') xxx(i),yyy(i),zzz(i)
            if(keytrj.ge.1)then
              write(nhist,'(1p,3e12.4)') vxx(i),vyy(i),vzz(i)
            endif
            if(keytrj.ge.2)then
              write(nhist,'(1p,3e12.4)') fxx(i),fyy(i),fzz(i)
            endif

          enddo

        endif

c     close history file at regular intervals

        if(.not.newjob.and.mod(nstep,ndump).eq.0)then

          close (nhist)
          newjob = .true.

        endif

      endif

      return
      end subroutine traject

      subroutine traject_u
     x     (ltraj,idnode,imcon,istraj,keytrj,natms,nstraj,nstep,tstep)

c***********************************************************************
c
c     dl_poly subroutine for writing history file at selected
c     intervals in simulation
c
c     Unformatted, double precision version
c
c     copyright - daresbury laboratory 1992
c     author    - w. smith dec 1992.
c
c***********************************************************************

      use setup_module
      use config_module

      implicit none

      logical newjob,ltraj
      integer idnode,imcon,istraj,keytrj,natms,nstraj,nstep,i
      real(8) tstep

      save newjob
      data newjob/.true./

      if(ltraj.and.idnode.eq.0)then

c     open the history file if new job or file closed

        if(newjob)  then

          newjob = .false.
          open(nhist,file='HISTORY',form='unformatted',
     x      position='append')

        endif
        if(nstep.eq.nstraj.or.nstep.eq.istraj)then

          write(nhist) cfgname
          write(nhist) dble(natms)
          write(nhist) (atmnam(i),i=1,natms)
          write(nhist) (weight(i),i=1,natms)
          write(nhist) (chge(i),i=1,natms)

        endif

        if(mod(nstep-nstraj,istraj).eq.0)then

          write(nhist)dble(nstep),dble(natms),dble(keytrj),
     x      dble(imcon),tstep

          if(imcon.gt.0) write(nhist) cell

          write(nhist) (xxx(i),i = 1,natms)
          write(nhist) (yyy(i),i = 1,natms)
          write(nhist) (zzz(i),i = 1,natms)

          if(keytrj.ge.1)then
            write(nhist) (vxx(i),i = 1,natms)
            write(nhist) (vyy(i),i = 1,natms)
            write(nhist) (vzz(i),i = 1,natms)
          endif
          if(keytrj.ge.2)then
            write(nhist) (fxx(i),i = 1,natms)
            write(nhist) (fyy(i),i = 1,natms)
            write(nhist) (fzz(i),i = 1,natms)
          endif

        endif

c     close history file at regular intervals

        if(.not.newjob.and.mod(nstep,ndump).eq.0)then

          close (nhist)
          newjob=.true.

        endif

      endif

      return
      end subroutine traject_u

      subroutine getcom_mol(ibeg,iend,imcon,idnode,mxnode,molmas,com)

c*********************************************************************
c
c     dl_poly routine to calculate centre of mass of a molecule
c     specified between two atomic indices of the configuration
c
c     copyright daresbury laboratory
c     author - w.smith june 2009
c
c*********************************************************************

      use config_module

      implicit none

      integer ibeg,iend,imcon,i,idnode,mxnode,iatm0,iatm1,nmol
      integer j,fail
      real(8) molmas
      real(8) com(3)
      real(8), allocatable :: disx(:),disy(:),disz(:)
      data fail/0/

      nmol=iend-ibeg+1
      if(mxnode.eq.1.or.nmol.lt.mxnode)then

        iatm0=ibeg
        iatm1=iend

      else

        iatm0=(idnode*nmol)/mxnode+ibeg
        iatm1=((idnode+1)*nmol)/mxnode+ibeg-1
        nmol=(iend-ibeg+1)/mxnode+1

      endif

      allocate (disx(nmol),disy(nmol),disz(nmol),stat=fail)

      com(1)=0.d0
      com(2)=0.d0
      com(3)=0.d0
      molmas=0.d0

      j=0
      do i=iatm0,iatm1

        j=j+1
        disx(j)=xxx(i)-xxx(ibeg)
        disy(j)=yyy(i)-yyy(ibeg)
        disz(j)=zzz(i)-zzz(ibeg)

      enddo
      nmol=j

      call images(imcon,0,1,nmol,cell,disx,disy,disz)

      j=0
      do i=iatm0,iatm1

        j=j+1
        molmas=molmas+weight(i)
        com(1)=com(1)+weight(i)*(disx(j)+xxx(ibeg))
        com(2)=com(2)+weight(i)*(disy(j)+yyy(ibeg))
        com(3)=com(3)+weight(i)*(disz(j)+zzz(ibeg))

      enddo

      nmol=iend-ibeg+1
      if(mxnode.gt.1.and.nmol.ge.mxnode)then

        buffer(1)=com(1)
        buffer(2)=com(2)
        buffer(3)=com(3)
        buffer(4)=molmas
        call gdsum(buffer(1),4,buffer(5))
        com(1)=buffer(1)
        com(2)=buffer(2)
        com(3)=buffer(3)
        molmas=buffer(4)

      endif

      com(1)=com(1)/molmas
      com(2)=com(2)/molmas
      com(3)=com(3)/molmas

      call images(imcon,0,1,1,cell,com(1),com(2),com(3))

      deallocate(disx,disy,disz)

      return
      end subroutine getcom_mol

      subroutine timchk(ktim,time)

c***********************************************************************
c
c     dlpoly timing routine for time elapsed in seconds
c
c     copyright daresbury laboratory
c     author w.smith nov 2003
c
c***********************************************************************

      use setup_module

      implicit none

      logical init
      character*12 dat,tim,zon
      integer idnode,mynode,ktim,day
      real(8) time,told,tsum,tnow
      integer info(8)

      save init,idnode,told,tsum,day

      data init/.true./

   10 format(/,' time elapsed since job start = ',f15.3,' seconds',/)

      call date_and_time(dat,tim,zon,info)

      if(init)then

         tsum=0.d0
         time=0.d0
         day=info(3)
         idnode=mynode()
         told=3600.d0*dble(info(5))+60.d0*dble(info(6))+
     x         dble(info(7))+0.001d0*dble(info(8))
         init=.false.

      else

         tnow=3600.d0*dble(info(5))+60.d0*dble(info(6))+
     x         dble(info(7))+0.001d0*dble(info(8))
         if(day.ne.info(3))then
           told=told-86400.d0
           day=info(3)
         endif
         tsum=tsum+tnow-told
         told=tnow
         time=tsum

      endif

      if(ktim.gt.0.and.idnode.eq.0) write(nrite,10)time

      return
      end subroutine timchk

      subroutine get_prntime(hms,timelp,prntim)

c***********************************************************************
c
c     dlpoly routine for casting cpu elapsed time into days, hours,
c     minutes and seconds for printing (input timelp in seconds)
c     copyright daresbury laboratory
c     author w.smith may 2009
c
c***********************************************************************

      implicit none

      character*1 hms
      real(8) timelp,prntim

      if(timelp.ge.8.64d4)then
        hms='d'
        prntim=timelp/8.64d4
      elseif(timelp.ge.3.6d3)then
        hms='h'
        prntim=timelp/3.6d3
      elseif(timelp.ge.6.0d1)then
        hms='m'
        prntim=timelp/6.0d1
      else
        hms='s'
        prntim=timelp
      endif

      return
      end subroutine get_prntime

      subroutine get_simtime(dec,nstep,tstep,simtim)

c***********************************************************************
c
c     dlpoly routine for casting simulation time into microseconds,
c     nanoseconds, picoseconds and femtoseconds for printing (input
c     tstep in picoseconds)
c     copyright daresbury laboratory
c     author w.smith may 2009
c
c***********************************************************************

      implicit none

      character*1 dec
      integer nstep
      real(8) tmptim,simtim,tstep

      tmptim=tstep*dble(nstep)

      if(tmptim.ge.1.0d6)then
        dec='m'
        simtim=tmptim*1.0d-6
      elseif(tmptim.ge.1.0d3)then
        dec='n'
        simtim=tmptim*1.0d-3
      elseif(tmptim.ge.1.0d0)then
        dec='p'
        simtim=tmptim
      else
        dec='f'
        simtim=tmptim*1.0d3
      endif

      return
      end subroutine get_simtime

      end module utility_module

ext: f


text:
      MODULE ittk_I
      INTERFACE
!...Generated by Pacific-Sierra Research 77to90 4.3E  09:56:17  11/16/01
      INTEGER FUNCTION ittk (I, J, K)
      INTEGER, INTENT(IN) :: I
      INTEGER, INTENT(IN) :: J
      INTEGER, INTENT(IN) :: K
      END FUNCTION
      END INTERFACE
      END MODULE

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


text:
C     cycle_02.f
C     A simple example of cycle with break within the loop.
C     Output: i = 1...19 k = 19
C     Source: http://annefou.github.io/Fortran/basics/control.html

      program odd_number
      implicit none
      integer :: n, k
      n = 19
      k = 0
      do while (.true.)
        k = k + 1
        if (k > n) exit
        if (mod(k,2) .eq. 0) cycle
        write(*,10) k, n
      enddo

 10   format('k = ', i3, '; n = ', i8)
      end program odd_number


text:
! { dg-do run }
! { dg-add-options ieee }
! { dg-skip-if "NaN not supported" { spu-*-* } { "*" } { "" } }
  real :: a(3,3), b(3), nan, minf, pinf, h
  logical :: l, l2
  logical :: l3(3,3), l4(3,3), l5(3,3)

  nan = 0.0
  minf = 0.0
  pinf = 0.0
  nan = 0.0/nan
  minf = -1.0/minf
  pinf = 1.0/pinf
  h = -huge(h)
  l = .false.
  l2 = .true.
  l3 = .false.
  l4 = .true.
  l5 = .true.
  l5(1,1) = .false.
  l5(1,2) = .false.
  l5(2,3) = .false.
  a = reshape ((/ nan, nan, nan, minf, minf, minf, minf, pinf, minf /), (/ 3, 3 /))
  if (maxval (a).ne.pinf) call abort
  if (any (maxloc (a).ne.(/ 2, 3 /))) call abort
  b = maxval (a, dim = 1)
  if (.not.isnan(b(1))) call abort
  b(1) = 0.0
  if (any (b.ne.(/ 0.0, minf, pinf /))) call abort
  if (any (maxloc (a, dim = 1).ne.(/ 1, 1, 2 /))) call abort
  b = maxval (a, dim = 2)
  if (any (b.ne.(/ minf, pinf, minf /))) call abort
  if (any (maxloc (a, dim = 2).ne.(/ 2, 3, 2 /))) call abort
  if (maxval (a, mask = l).ne.h) call abort
  if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) call abort
  b = maxval (a, dim = 1, mask = l)
  if (any (b.ne.(/ h, h, h /))) call abort
  if (any (maxloc (a, dim = 1, mask = l).ne.(/ 0, 0, 0 /))) call abort
  b = maxval (a, dim = 2, mask = l)
  if (any (b.ne.(/ h, h, h /))) call abort
  if (any (maxloc (a, dim = 2, mask = l).ne.(/ 0, 0, 0 /))) call abort
  if (maxval (a, mask = l3).ne.h) call abort
  if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
  b = maxval (a, dim = 1, mask = l3)
  if (any (b.ne.(/ h, h, h /))) call abort
  if (any (maxloc (a, dim = 1, mask = l3).ne.(/ 0, 0, 0 /))) call abort
  b = maxval (a, dim = 2, mask = l3)
  if (any (b.ne.(/ h, h, h /))) call abort
  if (any (maxloc (a, dim = 2, mask = l3).ne.(/ 0, 0, 0 /))) call abort
  if (maxval (a, mask = l2).ne.pinf) call abort
  if (maxval (a, mask = l4).ne.pinf) call abort
  if (any (maxloc (a, mask = l2).ne.(/ 2, 3 /))) call abort
  if (any (maxloc (a, mask = l4).ne.(/ 2, 3 /))) call abort
  b = maxval (a, dim = 1, mask = l2)
  if (.not.isnan(b(1))) call abort
  b(1) = 0.0
  if (any (b.ne.(/ 0.0, minf, pinf /))) call abort
  if (any (maxloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) call abort
  b = maxval (a, dim = 2, mask = l2)
  if (any (b.ne.(/ minf, pinf, minf /))) call abort
  if (any (maxloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) call abort
  b = maxval (a, dim = 1, mask = l4)
  if (.not.isnan(b(1))) call abort
  b(1) = 0.0
  if (any (b.ne.(/ 0.0, minf, pinf /))) call abort
  if (any (maxloc (a, dim = 1, mask = l2).ne.(/ 1, 1, 2 /))) call abort
  b = maxval (a, dim = 2, mask = l4)
  if (any (b.ne.(/ minf, pinf, minf /))) call abort
  if (any (maxloc (a, dim = 2, mask = l2).ne.(/ 2, 3, 2 /))) call abort
  if (maxval (a, mask = l5).ne.minf) call abort
  if (any (maxloc (a, mask = l5).ne.(/ 2, 2 /))) call abort
  b = maxval (a, dim = 1, mask = l5)
  if (.not.isnan(b(1))) call abort
  b(1) = 0.0
  if (any (b.ne.(/ 0.0, minf, minf /))) call abort
  if (any (maxloc (a, dim = 1, mask = l5).ne.(/ 2, 2, 1 /))) call abort
  b = maxval (a, dim = 2, mask = l5)
  if (any (b.ne.(/ minf, minf, minf /))) call abort
  if (any (maxloc (a, dim = 2, mask = l5).ne.(/ 3, 2, 2 /))) call abort
  a = nan
  if (.not.isnan(maxval (a))) call abort
  if (maxval (a, mask = l).ne.h) call abort
  if (.not.isnan(maxval (a, mask = l2))) call abort
  if (maxval (a, mask = l3).ne.h) call abort
  if (.not.isnan(maxval (a, mask = l4))) call abort
  if (.not.isnan(maxval (a, mask = l5))) call abort
  if (any (maxloc (a).ne.(/ 1, 1 /))) call abort
  if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) call abort
  if (any (maxloc (a, mask = l2).ne.(/ 1, 1 /))) call abort
  if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
  if (any (maxloc (a, mask = l4).ne.(/ 1, 1 /))) call abort
  if (any (maxloc (a, mask = l5).ne.(/ 2, 1 /))) call abort
  a = minf
  if (maxval (a).ne.minf) call abort
  if (maxval (a, mask = l).ne.h) call abort
  if (maxval (a, mask = l2).ne.minf) call abort
  if (maxval (a, mask = l3).ne.h) call abort
  if (maxval (a, mask = l4).ne.minf) call abort
  if (maxval (a, mask = l5).ne.minf) call abort
  if (any (maxloc (a).ne.(/ 1, 1 /))) call abort
  if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) call abort
  if (any (maxloc (a, mask = l2).ne.(/ 1, 1 /))) call abort
  if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
  if (any (maxloc (a, mask = l4).ne.(/ 1, 1 /))) call abort
  if (any (maxloc (a, mask = l5).ne.(/ 2, 1 /))) call abort
  a = nan
  a(1,3) = minf
  if (maxval (a).ne.minf) call abort
  if (maxval (a, mask = l).ne.h) call abort
  if (maxval (a, mask = l2).ne.minf) call abort
  if (maxval (a, mask = l3).ne.h) call abort
  if (maxval (a, mask = l4).ne.minf) call abort
  if (maxval (a, mask = l5).ne.minf) call abort
  if (any (maxloc (a).ne.(/ 1, 3 /))) call abort
  if (any (maxloc (a, mask = l).ne.(/ 0, 0 /))) call abort
  if (any (maxloc (a, mask = l2).ne.(/ 1, 3 /))) call abort
  if (any (maxloc (a, mask = l3).ne.(/ 0, 0 /))) call abort
  if (any (maxloc (a, mask = l4).ne.(/ 1, 3 /))) call abort
  if (any (maxloc (a, mask = l5).ne.(/ 1, 3 /))) call abort
end

max_stars_repo_name: maurizioabba/rose


text:
! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download

program update_bc

!----------------------------------------------------------------------
! purpose: interface between DART and the model model
!
! method: Read DART analysis vector in netcdf and replace the corresponding
!         field in the mpas file to advance model after running this program.
!         Updated to process all ensemble members.
!
!         The update_bc_nml namelist defines the input and output file
!         name lists for all ensemble members.
!         The input list should be matched with output_state_file_list in &filter_nml.
!
! author: Soyoung Ha 23 Aug 16
!         Updated in  4 May 2017 for the Manhatten release
!         Updated in 28 Jul 2020 for checking dimension sizes in analysis and lbc files.
!----------------------------------------------------------------------

use        types_mod, only : r8
use    utilities_mod, only : initialize_utilities, finalize_utilities, &
                             find_namelist_in_file, check_namelist_read, &
                             logfileunit, open_file, close_file, nc_check, &
                             get_next_filename, E_ERR, error_handler
use time_manager_mod, only : time_type, print_time, print_date, operator(-), &
                             get_time, get_date, operator(/=)
use direct_netcdf_mod,only : read_transpose, read_variables
use        model_mod, only : static_init_model, statevector_to_analysis_file, &
                             get_model_size, get_init_template_filename,      &
                             get_analysis_time, statevector_to_boundary_file, &
                             print_variable_ranges, &  ! , get_num_vars
                             set_lbc_variables, force_u_into_state
use state_structure_mod, only : get_num_variables, get_domain_size

use netcdf_utilities_mod, only : nc_open_file_readonly, &
                                 nc_open_file_readwrite, &
                                 nc_get_dimension_size,   &   ! Ha
                                 nc_close_file

use netcdf

implicit none

! version controlled file description for error handling, do not edit
character(len=*), parameter :: source   = 'models/mpas_atm/update_bc.f90'
character(len=*), parameter :: revision = ''
character(len=*), parameter :: revdate  = ''

!------------------------------------------------------------------
! The namelist variables
!------------------------------------------------------------------

character(len=256)  :: update_analysis_file_list = 'filter_in.txt'
character(len=256)  :: update_boundary_file_list = 'boundary_inout.txt'
integer             :: debug = 0
logical             :: lbc_update_from_reconstructed_winds = .true.
logical             :: lbc_update_winds_from_increments    = .true.

namelist /update_bc_nml/ update_analysis_file_list, update_boundary_file_list, debug, &
                         lbc_update_from_reconstructed_winds, lbc_update_winds_from_increments

!----------------------------------------------------------------------
character (len=256)   :: next_infile, next_outfile
character (len=256)   :: bdy_template_filename
character (len=256)   :: static_filename
character (len=512)   :: string1
integer               :: iunit, io, x_size, nanlvars, nbdyvars
integer               :: d1size, d2size
integer               :: ncAnlID, ncBdyID, istatus
integer               :: filenum
real(r8), allocatable :: statevector(:)
type(time_type)       :: model_time
type(time_type)       :: state_time
integer :: nCellsA      = -1  ! Total number of cells  in ncAnlID
integer :: nCellsB      = -1  ! Total number of cells  in ncBdyID
integer :: nVertLevelsA = -1  ! Total number of levels in ncAnlID
integer :: nVertLevelsB = -1  ! Total number of levels in ncBdyID
!----------------------------------------------------------------------

call initialize_utilities(progname='update_bc')

! Read the namelist to get the input filename.

call find_namelist_in_file("input.nml", "update_bc_nml", iunit)
read(iunit, nml = update_bc_nml, iostat = io)
call check_namelist_read(iunit, io, "update_bc_nml")

!----------------------------------------------------------------------
! Call model_mod:static_init_model() which reads the model namelists
! to set grid sizes, etc.
!----------------------------------------------------------------------

! get the first member file to use as a template
bdy_template_filename = get_next_filename(update_boundary_file_list, 1)

! Note that force_u_into_state should be called before static_init_model, which is unusual.
call force_u_into_state()
call set_lbc_variables(bdy_template_filename)

call static_init_model()
call get_init_template_filename(static_filename)

x_size = get_model_size()
allocate(statevector(x_size))

! use get_num_variables() after setting the domains
! separate number for analysis file, boundary file
nanlvars = get_num_variables(1)
nbdyvars = get_num_variables(2)

write(*,*)
write(*,*) 'update_bc: Updating ',nbdyvars,' variables'

!----------------------------------------------------------------------
! Reads lists of input mpas (prior) and filter (analysis) files
!----------------------------------------------------------------------
filenum = 1
fileloop: do        ! until out of files

  ! get a file name from the list, one at a time.
  next_infile  = get_next_filename(update_analysis_file_list, filenum)
  next_outfile = get_next_filename(update_boundary_file_list, filenum)
  if (next_infile == '' .or. next_outfile == '') exit fileloop

  !----------------------------------------------------------------------
  ! Reads input lbc (prior) and filter (analysis) files
  !----------------------------------------------------------------------

  ncAnlID = nc_open_file_readonly(next_infile,  'update_bc - open readonly')
  ncBdyID = nc_open_file_readwrite(next_outfile, 'update_bc - open readwrite')

  !----------------------------------------------------------------------
  ! Read the model time
  !----------------------------------------------------------------------
  model_time = get_analysis_time(ncBdyID, next_outfile)
  state_time = get_analysis_time(ncAnlID, next_infile)
  call print_time(state_time,'DART current time')
  call print_time(model_time,'mpas current time')

  if ( model_time /= state_time ) then
   call print_time(state_time,'DART current time',logfileunit)
   call print_time(model_time,'mpas current time',logfileunit)
   write(string1,*) trim(next_infile),' current time must equal model time'
   call error_handler(E_ERR,'update_bc',string1,source,revision,revdate)
  endif

  !----------------------------------------------------------------------
  ! Check dimension size in both files
  !----------------------------------------------------------------------
  nCellsA      = nc_get_dimension_size(ncAnlID, 'nCells',      'update_bc')        ! Ha
  nCellsB      = nc_get_dimension_size(ncBdyID, 'nCells',      'update_bc')        ! Ha
  nVertLevelsA = nc_get_dimension_size(ncAnlID, 'nVertLevels', 'update_bc')        ! Ha
  nVertLevelsB = nc_get_dimension_size(ncBdyID, 'nVertLevels', 'update_bc')        ! Ha
  print*,'nCells, nVertLevels:', nCellsA, nVertLevelsA,' in ',trim(next_infile)    ! Ha

  if((nCellsA /= nCellsB) .or. (nVertLevelsA /= nVertLevelsB)) then  ! Ha
     print*,'nCells, nVertLevels:', nCellsB, nVertLevelsB,' in ',trim(next_outfile)
     write(string1,*) 'Domain size mismatches'
     call error_handler(E_ERR,'update_bc',string1,source,revision,revdate)
  endif

  !----------------------------------------------------------------------
  ! Read analysis state vector (assuming to be available at the model time)
  !----------------------------------------------------------------------
  d1size = get_domain_size(1)
  d2size = get_domain_size(2)

  call read_variables(ncAnlID, statevector(1:d1size), 1, nanlvars, domain=1)
  call read_variables(ncBdyID, statevector(d1size+1:d1size+d2size), 1, nbdyvars, domain=2)

  !----------------------------------------------------------------------
  ! update the current model state vector
  !----------------------------------------------------------------------
  write(*,*) 'Updating boundary variables in ',trim(next_outfile)
  call statevector_to_boundary_file(statevector, ncBdyID, ncAnlID, &
       lbc_update_from_reconstructed_winds, lbc_update_winds_from_increments, debug)

  !----------------------------------------------------------------------
  ! Log what we think we're doing, and exit.
  !----------------------------------------------------------------------

  call print_date( model_time,'update_bc:model date')
  call print_time( model_time,'update_bc:model time')
  call print_date( model_time,'update_bc:model date',logfileunit)
  call print_time( model_time,'update_bc:model time',logfileunit)

  ! Because the files were open with the nc_open_file...() routines,
  ! it is not necessary to supply the filenames for error msg purposes.

  call nc_close_file(ncAnlID,'update_bc')
  call nc_close_file(ncBdyID,'update_bc')

  filenum = filenum + 1

end do fileloop

call finalize_utilities()

end program update_bc

max_stars_repo_name: hkershaw-brown/feature-preprocess

max_issues_repo_name: hkershaw-brown/feature-preprocess

max_forks_repo_name: hkershaw-brown/feature-preprocess


text:
! This file is generated!
module implementation_wrapper
implicit none
  interface

    type(c_ptr) function create_copy_stencil_impl(arg0, arg1) bind(c, name="create_copy_stencil")
      use iso_c_binding
      use array_descriptor
      type(gt_fortran_array_descriptor) :: arg0
      type(gt_fortran_array_descriptor) :: arg1
    end function
    subroutine run_stencil_impl(arg0) bind(c, name="run_stencil")
      use iso_c_binding
      type(c_ptr), value :: arg0
    end subroutine
    subroutine sync_data_store_impl(arg0) bind(c, name="sync_data_store")
      use iso_c_binding
      use array_descriptor
      type(gt_fortran_array_descriptor) :: arg0
    end subroutine

  end interface
contains
    type(c_ptr) function create_copy_stencil(arg0, arg1)
      use iso_c_binding
      use array_descriptor
      real(c_double), dimension(:,:,:), target :: arg0
      real(c_double), dimension(:,:,:), target :: arg1
      type(gt_fortran_array_descriptor) :: descriptor0
      type(gt_fortran_array_descriptor) :: descriptor1

      descriptor0%rank = 3
      descriptor0%type = 6
      descriptor0%dims = reshape(shape(arg0), &
        shape(descriptor0%dims), (/0/))
      descriptor0%data = c_loc(arg0(lbound(arg0, 1),lbound(arg0, 2),lbound(arg0, 3)))

      descriptor1%rank = 3
      descriptor1%type = 6
      descriptor1%dims = reshape(shape(arg1), &
        shape(descriptor1%dims), (/0/))
      descriptor1%data = c_loc(arg1(lbound(arg1, 1),lbound(arg1, 2),lbound(arg1, 3)))

      create_copy_stencil = create_copy_stencil_impl(descriptor0, descriptor1)
    end function
    subroutine run_stencil(arg0)
      use iso_c_binding
      type(c_ptr), value, target :: arg0

      call run_stencil_impl(arg0)
    end subroutine
    subroutine sync_data_store(arg0)
      use iso_c_binding
      use array_descriptor
      real(c_double), dimension(:,:,:), target :: arg0
      type(gt_fortran_array_descriptor) :: descriptor0

      descriptor0%rank = 3
      descriptor0%type = 6
      descriptor0%dims = reshape(shape(arg0), &
        shape(descriptor0%dims), (/0/))
      descriptor0%data = c_loc(arg0(lbound(arg0, 1),lbound(arg0, 2),lbound(arg0, 3)))

      call sync_data_store_impl(descriptor0)
    end subroutine
end

max_stars_repo_name: mbianco/gridtools

max_issues_repo_name: mbianco/gridtools

max_forks_repo_name: mbianco/gridtools


text:
      double complex function nAmpppp(j5,j1,j2,j3,j4)
c--- Caclculation of the amplitudes using results of S. Badger
c--- as adapted from routines written by F. Caola
      include 'constants.f'
      include 'zprods_com.f'
      include 'sprods_com.f'
      integer j1,j2,j3,j4,j5
      double complex zaa_5_pH_12_5, zaa_2_pH_34_5, zaa_2_pH_pH12_5,
     & zaa_3_pH_12_5,zab_5_pH_1, zab_2_pH_1, zab_5_pH_4, zab_3_pH_4,
     & zab_5_pH2_1, zab_5_pH3_4, zab_2_pH3_4, zab_3_pH2_1,
     & zab2, zab3
      double precision sH1, sH2, sH3, sH4, s125, s145, s345
      double precision s3, s4
      double precision qsq
C--- begin statement functions
      zab2(j1,j2,j3,j4)=za(j1,j2)*zb(j2,j4)+za(j1,j3)*zb(j3,j4)
      zab3(j1,j2,j3,j4,j5)=
     & za(j1,j2)*zb(j2,j5)+za(j1,j3)*zb(j3,j5)+za(j1,j4)*zb(j4,j5)
      s3(j1,j2,j3)=s(j1,j2)+s(j1,j3)+s(j2,j3)
      s4(j1,j2,j3,j4)=s(j1,j2)+s(j1,j3)+s(j1,j4)
     &               +s(j2,j3)+s(j2,j4)+s(j3,j4)
C--- end statement functions

      qsq=
     & +s(j1,j2)+s(j1,j3)+s(j1,j4)+s(j1,j5)
     &          +s(j2,j3)+s(j2,j4)+s(j2,j5)
     &                   +s(j3,j4)+s(j3,j5)
     &                            +s(j4,j5)

      sH1 = s4(j2,j3,j4,j5)
      sH2 = s4(j1,j3,j4,j5)
      sH3 = s4(j1,j2,j4,j5)
      sH4 = s4(j1,j2,j3,j5)
      s125 = s3(j1,j2,j5)
      s145 = s3(j1,j4,j5)
      s345 = s3(j3,j4,j5)

      zaa_5_pH_12_5=-za(j1,j5)*zab2(j5,j3,j4,j1)
     & -za(j2,j5)*zab2(j5,j3,j4,j2)
      zaa_2_pH_34_5 = -za(j2,j5)*s345 - za(j2,j1)*zab2(j5,j3,j4,j1)
      zaa_2_pH_pH12_5 = - zaa_2_pH_34_5
      zaa_3_pH_12_5 = -za(j3,j5)*s125 - za(j3,j4)*zab2(j5,j1,j2,j4)

      zab_5_pH_1 = -zab3(j5,j2,j3,j4,j1)
      zab_2_pH_1 = -zab3(j2,j3,j4,j5,j1)
      zab_5_pH_4 = -zab3(j5,j1,j2,j3,j4)
      zab_3_pH_4 = -zab3(j3,j1,j2,j5,j4)
      zab_5_pH2_1 = -zab2(j5,j3,j4,j1)
      zab_5_pH3_4 = -zab2(j5,j1,j2,j4)
      zab_2_pH3_4 = -zab2(j2,j1,j5,j4)
      zab_3_pH2_1 = -zab2(j3,j4,j5,j1)

      nAmpppp = -zaa_5_pH_12_5**3/(za(j1,j2)*za(j3,j4)*za(j4,j5)
     & *za(j1,j5)*
     &   zaa_2_pH_34_5 * zaa_3_pH_12_5)
     &   + zab_5_pH_1**3/(sH1*za(j2,j3)*za(j3,j4)*za(j4,j5)*zab_2_pH_1)
     &   - zab_5_pH_4**3/(sH4*za(j1,j2)*za(j2,j3)*za(j1,j5)*zab_3_pH_4)
     &   - qsq**2 * zab_5_pH2_1**4/(sH2*s345*za(j3,j4)*za(j4,j5)*
     &   zaa_2_pH_pH12_5*zab_2_pH_1*zab_3_pH2_1)
     &   + qsq**2 * zab_5_pH3_4**4/(sH3*s125*za(j1,j2)*za(j1,j5)*
     &   zaa_3_pH_12_5*zab_2_pH3_4*zab_3_pH_4)
     &   -qsq**2 * zb(j4,j1)**4/(s145*za(j2,j3)*zab_2_pH3_4*
     &   zab_3_pH2_1*zb(j5,j1)*zb(j5,j4))

      return
      end

max_stars_repo_name: tmartini/JHUGen

max_issues_repo_name: tmartini/JHUGen

max_forks_repo_name: tmartini/JHUGen


text:
!! R615 type-param-inquiry
!    is designator % type-param-name
!
!  NOTE 6.8

z = a%kind
z = s%len
z = b(10)%kind
z = p%dim

a%kind = z
s%len = z
b(10)%kind = z
p%dim = z

end

max_stars_repo_name: OpenFortranProject/ofp-sdf

max_issues_repo_name: OpenFortranProject/ofp-sdf

max_forks_repo_name: OpenFortranProject/ofp-sdf


text: #redirect City Council

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search