text:
Debats du Senat (hansard)
1ere Session, 36e Legislature,
Volume 137, Numero 37
Le mercredi 11 fevrier 1998
L'honorable Gildas L. Molgat, President
La compagnie Rogers-Augmentation injustifiee des frais de services
Privileges, Reglement et procedure
Le senateur Andrew Thompson-Presentation et examen du deuxieme rapport du comite-Ajournement du debat
Motion visant a donner des instructions supplementaires au comite du Reglement-Suspension du debat
Les travaux du Senat
Le mercredi 11 fevrier 1998
La seance est ouverte a 13 h 30, le President etant au fauteuil.
Comme nous le savons, il y a 104 sieges au Senat.
Il y en a actuellement quatre qui sont vacants.
Ce chiffre est loin des 60 p. 100 rapportes par certains journalistes ce matin.
Je voulais simplement faire cette mise au point.
La compagnie Rogers-Augmentation injustifiee des frais de services
L'honorable Jean-Robert Gauthier :
Comme vous le voyez, il y a des ameliorations.
Rogers n'y perd absolument rien au change.
Qui protege les consommateurs?
Elle n'interviendra pas dans le dossier non plus.
A qui le consommateur peut-il se fier pour le proteger?
A qui doit-on s'adresser?
Privileges, Reglement et procedure
Le senateur Andrew Thompson-Presentation et examen du deuxieme rapport du comite-Ajournement du debat
Le mercredi 11 fevrier 1998
Son Honneur le President :
Honorables senateurs, quand etudierons-nous ce rapport?
Son Honneur le President :
Est-ce d'accord, honorables senateurs?
L'honorable Edward M. Lawson :
Les constitutionnalistes disent que cette sanction est inapplicable.
C'etait la le diagnostic d'un journaliste.
Honorables senateurs, le comite n'a pas pris de decision.
Nous n'avons pas conteste le rapport du medecin.
Nous n'en avons pas parle.
A ma connaissance, il n'existe pas d'autre senateur dans cette categorie.
Est-ce que cela repond a vos questions?
La reponse se trouve-t-elle dans la lettre du medecin?
Cela n'a rien a voir avec un outrage au Senat.
Qu'est-ce qui permet de determiner qu'il y a outrage au Senat?
C'est ce que nous sommes en train d'etudier.
Voila qui devrait regler la question.
Son Honneur le President :
L'honorable senateur Ghitter, appuye par l'honorable senateur Stratton, propose:
Plait-il aux honorables senateurs d'adopter la motion d'amendement?
Honorables senateurs, je voudrais parler de l'amendement, si vous me le permettez.
L'article 18 de la Loi constitutionnelle de 1867 stipule:
dans le cas d'un depute,
...de se presenter de nouveau et de se faire reelire.
La mesure ne doit pas etre prise a la legere ni a des fins politiques.
Jusqu'en 1984, le nombre de ses presences est raisonnable.
Il est bon que nous soyons presents dans nos collectivites.
La perfection n'existe pas au chapitre de l'assiduite.
Ce n'est pas une institution parfaite qui a une parfaite reputation.
Non, ce n'est pas le cas.
Bravo pour le premier ministre Chretien!
Ensuite, le Edmonton Journal en novembre: De longues absences attirent la honte sur le Senat.
Etre nomme au Senat canadien est un honneur national.
Il semble que nous soyons condamnes a endurer cette institution embarrassante encore plusieurs annees.
Cette impasse, cependant, ne devrait pas empecher les senateurs eux-memes de renforcer leur reglement.
Ils pourraient meme convaincre les Canadiens qu'il vaut la peine de preserver cette institution.
Et le Toronto Sun , sous le titre Adios, ecrivait:
Parlant ensuite du Senat, il confesse le mepris que lui inspire l'institution.
Il n'a pas grand-chose d'aimable a dire au sujet du Senat...
Il designant le senateur Thompson...
...qui, selon lui, a desesperement besoin d'etre reforme.
Il pourrait tant faire pour venir en aide aux gens.
On se croirait a la morgue.
Ainsi parle le senateur Thompson.
Ca continue comme ca sur plusieurs paragraphes.
Les honorables senateurs ont sans doute tous lu cet article.
Il y a aussi ce qu'en disent les gens de la rue.
Il y a ce que nous entendons dire quand nous rentrons chez nous.
Pourquoi n'etes-vous pas au Mexique?
Que fait le senateur Thompson?
On lui remet ce document en main propre.
Honorables senateurs, avons-nous eu des nouvelles du senateur Thompson?
S'est-il presente hier?
Avons-nous apercu un avocat, un medecin, une lettre, ou quoi que ce soit?
Dira-t-il: J'ignorais quand le Senat reprendrait ses travaux.
Bien sur que non.
Que nous a fait notre collegue, le senateur Thompson?
Il se fiche du Senat.
Nous disons: Soyons justes; faisons tout cela.
Je dis que trop, c'est trop.
Il est temps que nous fassions preuve d'un peu de cran au Senat.
Son Honneur le President :
Je dois savoir lequel est le bon.
Son Honneur le President :
Honorables senateurs, j'invoque le Reglement.
Le greffier pourrait peut-etre preciser ce qu'il en est.
Son Honneur le President :
Y a-t-il d'autres observations sur le rappel au Reglement du senateur Maheu?
Honorables senateurs, je pense que le point du senateur Maheu est valable.
Pour simplifier la situation, supprimerons-nous la reference a l'indemnite de depenses imprevues?
L'honorable John Lynch-Staunton (chef de l'opposition) :
Son Honneur le President :
Son Honneur le President :
On ne peut plus lui poser de questions sans la permission du Senat.
Permission est-elle accordee?
Son Honneur le President :
Je pense que son comportement jette le discredit sur nous tous.
Je ne pense pas que c'etait necessaire.
Nous n'arretons pas de faire allusion a l'assiduite du senateur Thompson.
Il n'est pas absent.
Honorables senateurs, je ne veux pas intervenir sur la question d'outrage.
Il n'est pas impossible qu'il y ait eu outrage.
Si vous voulez aborder le probleme sous cet angle, faites-le.
Je suis d'accord, mais conformons-nous au Reglement.
C'est la loi.
Ce n'est pas moi qui l'invente.
L'honorable Marcel Prud'homme :
Les senateurs en ont discute entre eux.
Je croyais que nous avions obtenu le consentement du Senat pour le faire.
Son Honneur le President :
Si la Chambre y consent, la question pourra etre posee.
Aurait-il l'amabilite de le repeter?
Je ne veux pas me lancer aujourd'hui dans un debat sur Louis Riel.
Il existe un precedent legal concernant les expulsions.
Il y a eu d'autres cas du genre.
Dans le Beauchesne, il est question de l'affaire Fred Rose survenue en 1946.
Encore la, les faits etaient quelque peu differents.
La Chambre des communes a le droit d'expulser un depute.
J'espere avoir repondu a la question de facon satisfaisante.
L'honorable Jerahmiel S. Grafstein :
Honorables senateurs, cette question revet de l'importance pour nous tous.
Nous devrions par consequent l'aborder de facon juste et transparente.
Je voudrais poser la question suivante a l'honorable senateur Ghitter:
Dans la sixieme edition de Beauchesne, a la page 17, on dit:
Comme condition prealable, il doit y avoir un processus et une accusation precise.
La disposition pertinente figure au paragraphe 4 qui dit:
S'il est atteint de trahison ou convaincu de felonie, ou d'aucun crime infamant;
Je pense que nous nous sommes laisses prendre.
Je comprends les sentiments de tous les senateurs.
Nous nous sommes fait prendre a essayer de faire ce qui etait juste et approprie.
C'est ma question.
Le siege d'un senateur deviendra vacant dans chacun des cas suivants:
Si n'importe lequel de ces cas se produit, le siege devient vacant.
Nous avons tous ces pouvoirs.
Cependant, nos pouvoirs sont plus larges que cela.
C'est l'argument.
Je ne peux dire avec certitude que j'ai raison.
Je suppose que le comite a fait cela.
Il lui a donne un bref delai pour repondre.
Nous voulons faire ce qui s'impose pour la bonne raison.
Arretez-vous sur la question de procedure un instant pour moi.
La Chambre peut trancher comme elle l'entend la question touchant la procedure.
En tout cas, le senateur Thompson s'est deja moque de nous.
Il a deja recu notre ordre de comparaitre.
J'etais ici hier.
L'honorable P. Derek Lewis :
Qu'entendez-vous par expulser?
Est-ce que cela revient a dire que son siege devient vacant?
Cela signifie qu'on est chasse pour de bon.
Vous voulez dire que le siege serait vacant?
Cela pourrait avoir un certain nombre de repercussions sur le plan juridique.
Son Honneur le President :
Honorables senateurs, y a-t-il d'autres questions?
Etes-vous prets a passer au debat?
Je suis desole de revenir sur ce point, mais c'est important.
Ce semble etre la solution que l'honorable senateur propose au Senat.
Essentiellement, il dit que le Senat devrait definir ce qu'il entend par vacant.
Sommes-nous en train de nous substituer a la Constitution?
A mon avis, la Constitution a preseance sur nous.
Le Senat doit faire son travail en se conformant a la Constitution.
Je ne suis pas ici pour me porter a la defense du senateur Thompson.
Or, je ne suis pas certain que cette solution soit la bonne.
L'honorable Philippe Deane Gigantes :
J'ai lu l'article 18 de la loi.
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Aucun d'entre nous n'a de raison de se sentir diminue.
Nous avons adopte ici un ordre le 16 decembre dernier.
Le comite du Reglement s'est reuni hier soir pendant un temps considerable.
Je crois savoir que 18 senateurs ont participe a cette seance.
Je crois savoir qu'ils ont produit un rapport unanime.
Je respecte cette decision.
Je n'etais pas present a la seance du comite.
Je n'ai pas participe au debat.
Honorables senateurs, je ne suis pas un juriste ni ne pretends en etre un.
Je ne crois pas que ce que nous debattons ici n'a pas d'importance.
Cela en a enormement.
Je comprends la position que le comite a prise a l'egard de cette affaire.
Il leur fait un pied de nez, en fait.
Il les met au defi de l'attraper.
Les Canadiens en ont plus qu'assez de ce genre de comportement.
Nous savons tous qu'il a un certificat medical.
Qu'il nous poursuive!
C'est ce que veulent les Canadiens et c'est ce qu'il faut dire.
Qu'il vienne a nous.
C'est absolument insense, comme vous le savez.
Nous avons discute de la question comme il se doit.
Si, d'ici mercredi prochain, il ne se presente pas au Senat, que ferons-nous?
Tiendrons-nous un autre debat comme celui-ci?
Il faut agir maintenant.
Je suis du meme avis que vous.
Je prefererais l'expulser aujourd'hui.
Il suffit de regarder le senateur Gauthier.
Pensez a ce qu'il doit subir pour revenir au Senat.
Jean-Robert Gauthier est un exemple pour nous tous.
Nous ne pouvons pas le faire en laissant une certaine ambiguite.
Le senateur a produit des certificats de nombreux medecins.
Elles disent qu'il doit produire des certificats medicaux.
Il l'a fait.
Nous avons des doutes, et nous lui demandons de venir s'expliquer.
Nous avons dit cela une fois, mais sans preciser la date.
L'honorable J. Michael Forrestall:
Le senateur fait ressortir un point interessant.
Il appartiendra au Senat de decider.
Nous devons prendre une decision, que ce soit aujourd'hui ou dans une semaine.
L'honorable A. Raynell Andreychuk :
J'ai une question a poser au senateur Gigantes.
Comme vous, j'eprouve de la difficulte a decider quelle est la conclusion a tirer.
Vous avez mentionne les droits du senateur Thompson.
Vous avez declare que nous devions faire ce qu'il fallait faire.
Il doit etre ici, c'est sa responsabilite.
Il doit s'informer de ce qui se passe ici, c'est sa responsabilite.
Il lui incombe de bien s'acquitter de ses fonctions.
Il a recu un avis.
Il aurait du se presenter.
Nous avons des responsabilites envers la population canadienne.
Le senateur Andreychuk et moi sommes dans le meme camp.
Vous parlez de la reputation du systeme.
Nous avons donne le benefice du doute au senateur Thompson pendant trop d'annees.
Nous ne pouvons pas combler une vacance.
Honorables senateurs, j'etais a la reunion du comite du Reglement hier soir.
Il ne s'agit pas de cela.
Nous sommes un tribunal.
Il n'y a pas eu de dissidence.
Nous etions d'accord pour donner au senateur Thompson la chance de repondre rapidement.
Nous savons qu'il habite quelque part au Mexique.
Nous avons agi ainsi par souci de respect de la justice naturelle.
Ce n'est pas que nous craignions une action en justice.
Nous ne nous exposons pas a des poursuites.
Le Parlement ne peut pas etre poursuivi en justice.
De quoi s'agit-il?
Il n'en demeure pas moins que cet homme a certains droits.
C'est dans la nature humaine.
Nous aurions tout simplement pu lui demander de le faire.
Il a fourni un certificat medical.
Nous en avons deja parle.
Cette histoire ne date pas d'hier.
Ce n'est pas une chose qui s'est produite aujourd'hui ou recemment.
Le senateur Thompson a droit a une pleine pension.
S'il ne vient pas, je pense qu'il devrait la prendre.
Nous pouvons envoyer la lettre.
Je pense que c'est raisonnable.
Je trouve que c'est une facon tres raisonnable de regler le probleme.
Aucun de nous n'aime cela.
Nous sommes, pour la plupart d'entre nous, des parlementaires consciencieux.
Nous n'aimons pas ce genre de chose.
L'honorable Pierre Claude Nolin :
Je m'excuse, la date etait certaine.
La date etait precise.
Il s'agissait de la date ou cette Chambre recommence a sieger.
Ce n'est pas tous les jours que nous donnons des ordres.
C'est meme tres rare.
Il n'a rien fait de cela.
Il est donc en etat d'outrage.
Les certificats medicaux ne sont plus importants.
Tout cela ne tient plus.
C'est tres simple.
Le juge a ce moment a la latitude de lui imposer une sanction.
Aujourd'hui, nous faisons face a cette situation.
Nous avons differentes options, incluant le depart force en vertu del'article 18.
Ne confondez pas avec d'autres articles de la Constitution qui concernent des departs forces.
La justice naturelle avait toute latitude pour s'exercer jusqu'a hier, a deux heures.
Il avait recu un ordre d'etre ici a deux heures, hier apres-midi.
Il n'est pas venu.
Il est en etat d'outrage vis-a-vis cette institution.
Maintenant, aurons-nous le courage d'aller au bout de nos decisions?
C'est presque impossible.
Je crois que c'est ce que le senateur Andreychuk essayait de faire valoir.
Dans les faits, la conclusion semble etre presque inevitable.
Cela dit, la proposition du senateur Ghitter est tres seduisante.
J'adorerais pouvoir agir ainsi.
Ensuite, nous pourrions reprendre nos travaux normalement; nous serions soulages.
Malheureusement, honorables senateurs, ce n'est pas si simple.
Qu'est-ce qu'on fait alors?
Qu'arrive-t-il pour l'Ontario?
Ils aimeraient bien nous faire tomber un a un.
A l'exterieur de notre Chambre, les visees sont beaucoup plus vastes.
Ma conscience me dicte de suivre les conseils du comite.
Je pense qu'il lui incombe de s'expliquer sans aucun doute.
Honorables senateurs, je crois dans la Constitution, et je tiens a la respecter.
Je ne veux pas qu'on reproche au Senat de l'avoir violee.
C'est clair, maintenant?
L'honorable senateur voudrait-il nous l'expliquer?
L'article 31 dit ceci:
C'est une question de fait que le comite n'a pas encore tranchee.
D'autres senateurs en ont parle.
C'est la premiere proposition.
2. S'il prete un serment... a une puissance etrangere...
Ce n'est pas le cas.
3. S'il est declare en etat de banqueroute ou de faillite...
Ce n'est pas le cas.
5. S'il cesse de posseder la qualification reposant sur la propriete ou le domicile...
Cela semble etre les dispositions aux termes de la loi.
Comme je l'ai declare, j'aimerais bien m'y conformer.
Et si je vous demandais de lire l'article 18 de cette meme Loi constitutionnelle?
Notre Chambre a le droit d'expulser quelqu'un.
Il ne s'applique pas ici.
C'est sur l'article 18 que nous devons nous baser aujourd'hui.
C'est une question tres importante.
Nous devons tout d'abord etablir qu'il y a eu outrage.
J'avais l'impression que c'etait la ce que le comite avait en tete.
Je crois que c'est la une distinction importante.
Le senateur est juriste et il sait la difference.
Le resultat est le meme, mais pas le processus.
Vous ne pouvez pas ne pas etre d'accord avec cela.
J'aimerais donc que le senateur Beaudoin nous donne son avis.
L'honorable Edward M. Lawson :
J'en fais la demande maintenant.
Son Honneur le President :
Honorables senateurs, la Presidence ne peut se prononcer sur des questions juridiques.
Je ne peux donc pas m'en meler.
Il appartient au Senat de decider, pas a la presidence.
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Honorables senateurs, c'est precisement ce que le comite est en train de faire.
L'honorable Herbert O. Sparrow :
Honorables senateurs, j'aurais une question a poser au senateur Ghitter.
Son Honneur le President :
Quelqu'un appuie-t-il la motion, honorables senateurs?
Il s'agirait d'un sous-amendement.
Nous devons etre tres precis.
L'honorable Marcel Prud'homme :
Votre Honneur, j'invoque le Reglement.
Son Honneur le President :
Aujourd'hui, nous sommes saisis d'une proposition avec des amendements et des sous-amendements.
Pourquoi n'intervenez-vous pas pour nous dire ce que vous pensez?
Tout cela demande reflexion.
Cela conviendrait mieux a des senateurs.
J'ai ete impressionne d'entendre les propos des senateurs Grafstein et Lewis.
Je comprends les medias.
Cette question nous preoccupe beaucoup, mais il faut s'en occuper.
Je suis certain que tous les senateurs voudraient reflechir a cette grave question.
C'est la fonction du Senat.
L'honorable Peter A. Stollery :
Son Honneur le President :
Il y a deja un recours au Reglement par l'honorable senateur Prud'homme.
Cela dit, le senateur a fait une suggestion.
Je ne comprends pas tres bien ce qui s'est passe.
Son Honneur le President :
Le sous-amendement de l'honorable senateur Lawson est maintenant pret.
Nous allons d'abord ecouter celui-ci.
Honorables senateurs, je propose, appuye par le senateur Lucier:
Son Honneur le President :
Ce sous-amendement n'est pas recevable dans sa forme actuelle.
Dans ce cas, nous en changerons la forme.
Son Honneur le President :
Dans ce cas, je propose, appuye par le meme senateur:
Que le legiste communique son avis au Senat demain au plus tard.
Son Honneur le President :
Il est propose par l'honorable senateur Lawson, appuye par l'honorable senateur Lucier:
Que la motion d'amendement soit modifiee en ajoutant ce qui suit:
Que le legiste communique son avis au Senat demain au plus tard.
Honorables senateurs, je n'aurais pas d'objection a attendre 24 heures.
Nous nous trouvons devant un probleme de droit fondamental.
Je ne doute absolument pas que l'assemblee legislative puisse expulser un depute.
C'est ce qu'on appelle, en droit constitutionnel, un droit inherent.
La situation demeure la meme depuis de nombreuses annees.
Si une personne est prete a aller au Mexique, pourquoi pas a Ottawa?
En ce sens, nous discutons peut-etre de cette question pour rien.
Cependant, en tant que juriste, j'aimerais avoir un avis independant.
Je me trompe peut-etre, mais je suis porte a penser ainsi.
Telle est cependant, pour le moment, mon opinion.
Honorables senateurs, j'ai siege a la Chambre des communes durant 30 ans.
Nous devons etre tres precis.
Avant de voter, nous devrons lire la motion tres attentivement.
Nous pourrions le punir en disant qu'il est un rien du tout.
J'ai une question a poser au senateur Beaudoin.
La mesure que nous prendrons devrait faire l'unanimite.
Il existe de nombreuses possibilites.
Nous l'avons deja puni.
Je crois qu'il faut conclure le debat de facon ordonnee.
En l'occurrence, la precipitation n'est pas la voie a suivre.
Nous n'avons pas a obeir a une foule hargneuse.
Nous arriverons peut-etre a une meilleure solution.
L'honorable Noel A. Kinsella (chef adjoint suppleant de l'opposition) :
La question des 24 heures n'est pas coulee dans le beton.
Je n'ai aucune objection a ce que ce delai soit change.
Senateur Beaudoin, j'ai ecoute votre expose et je continue a m'interroger.
Qu'est-ce qui viendrait empecher cela?
Je ne parle plus de l'expulsion a caractere temporaire plus ou moins longue.
Si mon souvenir est fidele, il a ete elu.
Cela a resolu le probleme.
Est-ce qu'une fois expulse, le siege devient necessairement vacant?
J'aimerais bien entendre une opinion aussi la-dessus.
Mais cela peut etre, evidemment, conteste quand meme par la suite.
Je n'irai pas plus loin que cela dans ce domaine.
Evidemment, cela va creer un precedent, cela va faire du bruit.
Est-ce que cela empeche l'exercice d'un droit inherent?
Je ne vais pas plus loin pour le moment.
L'honorable Philippe Deane Gigantes :
Si ce n'est pas conteste, le premier ministre pourrait nommer quelqu'un d'autre.
C'est la premiere question.
Les tribunaux traditionnellement ne se melent pas des affaires internes de la legislature.
La cour se prononcerait.
C'est tout ce que je dis.
Je parle de ce droit inherent que vous avez mentionne.
Avec ce droit inherent, est-ce que les tribunaux oseraient intervenir?
Je pense que le droit d'expulsion dans un cas vraiment extraordinaire est inherent.
Maintenant, est-ce que l'on doit s'en servir ?
C'est autre chose!
S'ils l'ont dit hier, cela confirme ce que je dis aujourd'hui.
L'honorable Jerahmiel S. Grafstein :
J'ai une question a poser au senateur Beaudoin.
J'ai parcouru rapidement un avis qui a ete communique au comite hier soir.
Selon moi, nous n'avons pas les memes pouvoirs inherents, ni les memes remedes.
Une belle question est ressortie de la discussion, celle de la definition de crime infamant.
Je laisse a d'autres, plus eclaires que moi, le soin d'y reflechir.
Pour le reste, nous avons les memes pouvoirs.
Nous sommes une assemblee legislative au meme titre que les Communes.
L'histoire montre que les Communes ont expulse des deputes.
Je suis enclin a croire que nous avons egalement ce droit.
Je respecte l'opinion contraire, bien entendu, puisqu'il s'agit d'un point difficile.
Ce sous-amendement devance en quelque sorte le travail que le comite allait faire.
Il voulait que le Senat adopte un ordre pour le faire comparaitre.
Les membres du comite ont entendu le greffier hier soir.
Ils ont aussi recu d'autres avis de constitutionnalistes.
C'est a partir de cela qu'ils ont redige le rapport presente aujourd'hui.
Ils veulent examiner plus a fond les avis sur la constitutionnalite des sanctions.
Ce n'est pas maintenant le moment de le faire.
L'honorable P. Michael Pitfield :
Permettez-moi simplement de vous livrer quelques idees.
Le Senat est la Chambre du second examen objectif.
Je veux simplement parler un instant de notre facon de proceder.
Je ne veux faire aucun commentaire sur le cas particulier en cause.
Il me semble que nous precipitons notre jugement.
Certains disent que nous devons agir maintenant.
Des doutes tres serieux ont ete souleves dans cette affaire.
Le senateur Lawson a emis des doutes au sujet de faits.
Le senateur Grafstein en a exprime d'autres a propos de l'equite.
Nous donnons et nous demandons des avis juridiques improvises.
Je nous exhorte a agir calmement, equitablement et de maniere reflechie.
Nous voulons resoudre ce probleme.
Ce long apres-midi tire a sa fin.
Son Honneur le President :
Quelqu'un d'autre veut-il prendre la parole?
Je ne vois personne.
Peut-etre que nous saurons mieux quoi faire la prochaine fois.
Un autre probleme risque de se poser.
Je m'adresse ici au senateur Ghitter.
Je dis cela simplement a titre d'explication.
L'honorable John Lynch-Staunton (chef de l'opposition) :
Honorables senateurs, je voudrais faire quelques breves observations.
Le probleme actuel date de nombreuses annees.
Lorsqu'il etait invite a comparaitre, il justifiait son absence par des certificats medicaux.
Je n'oserais jamais contester la validite d'un certificat medical presente par un collegue.
Cela me semble toutefois tres improbable.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Serait-il toujours senateur?
Nous avons des doutes sur ce point.
Il y a eu la motion du senateur Kenny.
Nous avions espere que le senateur Thompson se presenterait hier.
Ce comite s'est reuni hier soir et a depose aujourd'hui un rapport unanime.
Nous avons ete autorises a examiner ce rapport aujourd'hui.
Ce rapport proposait une procedure.
Le senateur Nolin demande si nous avons le courage necessaire.
La procedure est en marche.
C'est pourquoi nous avons des comites.
La decision finale se prend toutefois ici, ou elle devrait etre prise.
Honorables senateurs, je suis tres au fait des observations du senateur Pitfield sur la justice.
L'honorable C. William Doody :
Honorables senateurs, j'ai deux questions a poser pour eclaircir les choses.
L'apres-midi a ete tres troublant.
Personnellement, je suis plutot enclin a appuyer la recommandation du senateur Pitfield.
Il ne sera peut-etre pas possible de lui donner suite.
Si cela doit etre fait, que ce soit fait pendant que nous siegeons.
Je ne suis pas tres a l'aise avec l'idee d'un comite plenier.
Nous avons deja renvoye cette affaire a un comite senatorial.
Le comite a fait rapport et nous a presente une recommandation unanime.
Comment allons-nous proceder demain?
Quelqu'un pourrait-il m'aider a ce sujet?
Je pourrais peut-etre preciser en posant une question au senateur Doody.
Il est important de s'en souvenir.
Je repete que toutes ces decisions ont ete prises a l'unanimite.
Honorables senateurs, je suis completement perdu.
Je suis peut-etre a blamer.
Le rapport du comite m'a peut-etre ete expedie plus tot dans la journee.
Je ne l'ai pas vu.
Face a tant d'incertitudes, je demande conseil aux leaders.
Nous avons ete saisis du sous-amendement du senateur Lawson.
Mais il faut d'abord que le sous-amendement du senateur Lawson soit approuve.
Honorables senateurs, ce que nous aimerions savoir concerne deux points souleves par...
Son Honneur le President :
Honorables senateurs, l'honorable senateur Lynch-Staunton a deja parle de cette question.
La permission est-elle accordee a l'honorable senateur pour qu'il parle a nouveau?
Elle devrait etre modifiee pour que ce soit precise.
C'est ce que nous aimerions savoir.
Si nous ne pouvons pas l'expulser, pouvons le suspendre?
Deuxiemement, le Senat peut-il lui refuser son salaire et son allocation mensuelle non imposable?
C'est ce que nous aimerions savoir.
Nous n'avons pas repris nos travaux aujourd'hui, mais hier.
Ainsi, il n'a pas respecte l'ordre du Senat.
Pourquoi voulons-nous lui donner une autre semaine?
L'honorable Richard J. Stanbury :
Honorables senateurs, je suis stupefait de voir ce que le chef de l'opposition propose.
Le comite fait ensuite rapport au Senat, qui etudie a son tour ce rapport.
C'est ce qui s'est produit.
Nous devrions en recevoir l'ordre du Senat.
Cela nous confererait ce pouvoir.
Je comprends parfaitement la motion du senateur Ghitter.
Nous sommes tous frustres et nous voulons qu'on en finisse.
Nous lui avons donne deux semaines pour le faire.
Pour l'amour du ciel, cessons d'embrouiller les choses encore plus.
Adoptons le rapport du comite.
Ainsi, un ordre sera immediatement transmis au senateur Thompson.
L'ordre sera redige et remis en bonne et due forme.
Honorables senateurs, je voudrais poser une question au senateur Stanbury.
Ce dossier preoccupe de nombreux senateurs.
Je crains simplement que nous ayons l'air de tergiverser encore.
Arretez de tergiverser et finissez-en.
Je suis d'avis que la population trouve la preuve tres concluante.
Nous ne pouvons nous eterniser la-dessus.
Il suffit d'appuyer le rapport et nous pourrons aller de l'avant.
C'est formidable, mais il faudra en accepter les consequences.
Quelle a ete la fonction de ce comite?
Nous devons proceder comme il faut, comme nous l'avons decide le 16 decembre.
Nous avons voulu faire les choses comme il faut.
Nous avons forme un comite.
Pourquoi agissez-vous prematurement et demandez-vous au comite de ne pas faire son travail?
Honorables senateurs, je pense que le Senat ne doit pas perdre de temps.
La reponse a chacune des questions des senateurs se trouve dans le rapport provisoire.
Je vais les expliquer brievement.
Le senateur Pitfield dit que nous devrions accorder un certain temps aux chefs.
Je ne doute pas que la presidente du comite presentera des recommandations concretes.
C'est exactement ce que nous avons fait.
Le senateur Grafstein m'a convaincu.
Je me faisais du souci pour la justice et l'equite.
Son Honneur le President :
Honorables senateurs, la situation se complique drolement.
Ce que nous avons devant nous pose de serieux problemes techniques.
Je suis conscient du fait que la presidence ne doit pas participer aux debats.
Cela me semble etre une bonne idee.
Son Honneur le President :
Honorables senateurs, nous serions d'accord avec cette suggestion.
Honorables senateurs, comment pourrais-je refuser une aussi agreable invitation?
Son Honneur le President :
Ai-je l'accord des deux cotes?
Honorables senateurs, je ne serai pas difficile.
Je me sens a l'aise ici, specialement avec mon nouveau voisin.
Je sais que je ne ferai pas partie du processus de consultation.
Son Honneur le President :
Honorables senateurs, je remercie le senateur Prud'homme.
J'essaie de ne jamais oublier personne.
Je demanderais aux leaders des deux cotes de se rencontrer a mon appartement.
Le timbre sonnera a 16 h 30 pour que nous reprenions a 16 h 35.
(La seance est suspendue.)
(Le Senat reprend sa seance.)
Permission ayant ete accordee de revenir aux avis de motion du gouvernement:
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Son Honneur le President :
Plait-il aux honorables senateurs d'adopter la motion?
L'honorable Consiglio Di Nino :
Cette rencontre se fera-t-elle a huis clos ou en public?
Ce sera une rencontre publique, tout comme la reunion d'hier.
L'ajournement est-il fixe a une heure precise?
Je donne au senateur Ghitter l'assurance que ce delai ne sera pas prolonge.
Son Honneur le President :
Cela n'a rien a voir avec les autres motions dont nous avons discute.
L'honorable senateur fait allusion a l'autre debat, qui a ete ajourne.
L'honorable John Lynch-Staunton (chef de l'opposition) :
Si nous voulons debattre de la question demain, nous pouvons le faire demain.
Si nous ne voulons pas en debattre demain, nous reportons le debat.
Son Honneur le President :
Merci de cette mise au point.
Je retire l'amendement.
L'honorable A. Raynell Andreychuk :
Honorables senateurs, ou cet avis sera-t-il envoye?
On nous a parle aujourd'hui d'application reguliere du droit et d'equite.
Nous devons savoir ou cet avis sera envoye.
L'avis sera envoye a son lieu de residence, en Ontario.
Motion visant a donner des instructions supplementaires au comite du Reglement-Suspension du debat
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Honorables senateurs, je propose aussi:
Son Honneur le President :
Plait-il aux honorables senateurs d'adopter la motion?
L'honorable John Lynch-Staunton (chef de l'opposition) :
Honorables senateurs, je suis d'accord avec le senateur.
...et qu'il entende des arguments juridiques allant dans le sens de ce debat.
Cela ne suffit pas.
Son Honneur le President :
Honorables senateurs, il sera difficile d'avoir le libelle exact que vous voulez.
Son Honneur le President :
Les travaux du Senat
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Son Honneur le President :
Est-ce d'accord, honorables senateurs?
(Le Senat s'ajourne a 14 heures demain.)

ext: f


text:
C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.

C $Id: daemodel_df.f,v 1.1 2002/05/02 18:52:14 andreasw Exp $
      subroutine DAEMODEL_DF( NZ_OPT, NY_OPT, NU_OPT, NP_OPT, T, Z,
     1     ZDOT, Y, U_OPT, P_OPT, DF_OPT, LDDF )
C !DEC$ ATTRIBUTES DLLEXPORT :: DAEMODEL_DF
C
C     Layer between decomposition code (dae2nlp) and actual model that
C     allows to give profiles to certain control variables and fixed values
C     to some parameters (see DYNAUX.INC)
C
C     Obtain Jacobian of DAE model from MODEL_DF
C
C     Author:   Andreas Waechter    09-05-01
C
      implicit none
C
      integer NZ_OPT            ! number of differential variables seen by
                                ! optimizer (is same as NZ in DYNAUX.INC)
      integer NY_OPT            ! number of algebraic variables seen by
                                ! optimizer (is same as NZ in DYNAUX.INC)
      integer NU_OPT            ! number of control variables seen by
                                ! optimizer
      integer NP_OPT            ! number of parameters seen by optimizer
      double precision T        ! time at which model is to be evaluated
      double precision Z(NZ_OPT) ! values of differenial variables
      double precision ZDOT(NZ_OPT) ! derivatives of differenial variables
      double precision Y(NY_OPT) ! values of algebraic variables
      double precision U_OPT(NU_OPT) ! values of control variables
      double precision P_OPT(NP_OPT) ! values of parameters
      integer LDDF              ! leading dimension of DF
      double precision DF_OPT(LDDF,2*NZ_OPT+NY_OPT+NU_OPT+NP_OPT)
                                ! Jacobian of DAEs how optimizer needs it
C
      include 'DYNAUX.INC'
C !DEC$ ATTRIBUTES DLLEXPORT :: /DYNAUX/
C
      double precision U(NUMAX) ! controls given to model including given
                                ! profile
      double precision P(NPMAX) ! parameters given to model including fixed
                                ! ones
      double precision DF(NZMAX+NYMAX,2*NZMAX+NYMAX+NUMAX+NPMAX)
                                ! Jacobian of DAEs how models sees it
                                ! NOTE: This is not very memory efficient...

      integer l_uopt, l_popt, l_ele, l_dfopt, i, GET_IELE4T
      double precision ratio, dt, dti

      NO_MODEL_DF_CALL = NO_MODEL_DF_CALL + 1

C     Only need to do something special if there are indeed given profiles
C     or fixed parameters

      if( NU_PROF.eq.0 .and. NP_FIX.eq.0 ) then
         call MODEL_DF( NZ, NY, NU, NP, T, Z, ZDOT, Y,
     1        U_OPT, P_OPT, DF_OPT, LDDF )
         return
      endif

C     Find element l_ele which is responsible for T
      l_ele = GET_IELE4T(T)
      if( l_ele.eq.NELE+1 ) l_ele = NELE

      dt  = T-TI(l_ele)
      dti = TI(l_ele+1)-TI(l_ele)

C     Copy relevant elements from U_OPT into U and include values for
C     given profiles (linear interpolations)
      l_uopt = 0
      do i = 1, NU
         if( IU_PROF(i).eq.0 ) then
            l_uopt = l_uopt + 1
            U(i) = U_OPT(l_uopt)
         else
            ratio = (U_PROF(i,l_ele+1) - U_PROF(i,l_ele))/dti
            U(i)  = U_PROF(i,l_ele) + ratio*dt
         endif
      enddo

C     Copy relevant elements from P_OPT into P and include values for
C     fixed parameters
      l_popt = 0
      do i = 1, NP
         if( IP_FIX(i).eq.0 ) then
            l_popt = l_popt + 1
            P(i) = P_OPT(l_popt)
         else
            P(i) = P_FIX(i)
         endif
      enddo

C     Call the model with augemented U and P
      call MODEL_DF( NZ, NY, NU, NP, T, Z, ZDOT, Y, U, P, DF,
     1     NZMAX+NYMAX )

C     Copy Jacobian from model into Jacobian for optimizer
      do i = 1, 2*NZ+NY
         call DCOPY(NZ+NY, DF(1,i), 1, DF_OPT(1,i), 1)
      enddo

      l_dfopt = 2*NZ+NY
      do i = 1, NU
         if( IU_PROF(i).eq.0 ) then
            l_dfopt = l_dfopt + 1
            call DCOPY(NZ+NY, DF(1,2*NZ+NY+i), 1, DF_OPT(1, l_dfopt), 1)
         endif
      enddo

      do i = 1, NP
         if( IP_FIX(i).eq.0 ) then
            l_dfopt = l_dfopt + 1
            call DCOPY(NZ+NY, DF(1,2*NZ+NY+NU+i), 1,
     1           DF_OPT(1, l_dfopt), 1)
         endif
      enddo

C     That's it

      return
      end

max_stars_repo_name: kant/CMMPPT

max_issues_repo_name: kant/CMMPPT

max_forks_repo_name: kant/CMMPPT


text:
Students at UC Davis are often called Aggies because of the Schools schools College of Agriculture agricultural reputation, though the official mascot is a mustang named Gunrock. As a result, many businesses around town have the word Aggie in their name (e.g. Aggie Inn, Aggie Square, Aggie Nails, etc). The name of the UC Davis newspaper is The California Aggie, also commonly called The Aggie by students.

From the UC Davis News & Notes, 1997: STUDENTS SAY NEIGH TO MUSTANG

A cows cow? A mustang? An Aggie? You might say that the UC Davis mascot has had an identity crisis of late. But now a group of students is attempting to remedy that.

A student body vote on a referendum in February 1997 declared the Aggie the winner ....
Adding to the confusion was a student vote taken in 1993 that, by a slim margin, named the cow as mascot. And while apparently there is no official policy specifying how to go about changing the universitys mascot, a lack of administrative and alumni approval of the cow design left the matter languishing without any consensus.

....
The name Aggie does, indeed, have a long history at UC Davis. A 1922 editorial in the University Farm Agricola, predecessor to The California Aggie, said, Up till now our men here have been known as the Davis Farmers. In practically all the agricultural colleges of the United States, Aggies is the name used. . . . The name has a college air, a football air, about it. . . . Lets call ourselves the Aggies. Hasnt it a winning sound to it? A few years later, the mustanginspired by a famous Thoroughbred stallion named Gunrockwas adopted as the symbol for UC Davis athletic teams and used interchangeably with Aggie.

Of the nearly 3,000 students voting .... 75 percent called for the Aggie to replace the mustang.....

Students at http://www.tamu.edu/ Texas A&M University and http://www.usu.edu/ Utah State University are also notable Aggies among the 24 US schools who use the name (or at least those who are listed on wiki:wikipedia:Aggie Wikipedia).

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      MODULE corre_C
      USE vast_kind_param,  ONLY: DOUBLE
      USE parameter_def,    ONLY: NNNW
!...Created by Pacific-Sierra Research 77to90  4.3E  15:25:01   1/ 6/07
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
      LOGICAL, DIMENSION(NNNW) :: LCORRE
      END MODULE corre_C

max_stars_repo_name: sylas/grasp-continuum

max_issues_repo_name: sylas/grasp-continuum

max_forks_repo_name: sylas/grasp-continuum


module m_command_argument
  use M_CLI2, only : set_args, get_args
  use M_CLI2, only : get_subcommand
  implicit none
  private

  public :: command_argument_t

  type :: command_argument_t
    private
    character(:), allocatable, private :: command_name
  contains
    procedure, pass(self), public :: Parse
    procedure, public :: Get_Name
  end type command_argument_t

contains
  function Get_Name(self) result(name)
    class(command_argument_t), intent(in) :: self
    character(:), allocatable :: name

    name = self%command_name
  end function Get_Name

  subroutine Parse(self, args)
    class(command_argument_t), intent(inout) :: self
    character(*) :: args
    character(len=:), allocatable :: help_text(:), version_text(:)
    character(len=:), allocatable :: mode, start_date, stop_date, basin

    version_text=[character(len=80) :: &
      '@(#)PROGRAM:     demo6            >', &
      '@(#)DESCRIPTION: My demo program  >', &
      '@(#)VERSION:     1.0 20200715     >', &
      '@(#)AUTHOR:      me, myself, and I>', &
      '@(#)LICENSE:     Public Domain    >', &
      '' ]

    help_text=[character(len=80) :: &
     ' allowed subcommands are          ', &
     '   * run  -l -L -title -x -y -z   ', &
     '   * test -l -L -title            ', &
     '' ]

    args = get_subcommand()

    select case (args)
    case('test')
      help_text=[character(len=80) :: &
      '                                  ', &
      ' Help for subcommand "test"   ', &
      '                                  ', &
      '' ]
      self%command_name = args
    case('copy')
      help_text=[character(len=80) :: &
      '                                  ', &
      ' Help for subcommand "copy"        ', &
      '                                  ', &
      '' ]
      self%command_name = args
    case default
      call set_args(' ', help_text, version_text)
      write(*,'(*(a))')'unknown or missing subcommand [',trim(args),']'
      write(*,'(a)')[character(len=80) ::  &
        ' allowed subcommands are          ', &
        '   * copy                         ', &
        '   * test                         ', &
        '' ]
      stop
    end select
  end subroutine Parse

end module m_command_argument


text:
	PROGRAM  SHOCKEPLOT
C
C	PLOTS THINGS DERIVED FROM SHOCK DATA  AS IN  FILE 'SHOCKE.DATA'
C
	CHARACTER*80 JUNK
	REAL  MA,MS, PDATA(500,3)
	INTEGER*4  NEVT,YYMMDD,HHMMSS
C
	OPEN(UNIT=72,FILE='SHOCKE.DATA',STATUS='OLD',READONLY)

C
 	READ(72,1001,END=200) JUNK
	PRINT*,JUNK
	IN = 0
 1001	FORMAT(A80)
  100	READ(72,*,END=200) NEVT,YYMMDD,HHMMSS,BDOTN,MA,MS,DENS,
     1		VDOTB,VEL,CH1AV,CH1PK,CH2AV,CH2PK
 	PRINT*, NEVT,YYMMDD,HHMMSS,BDOTN,MA,MS,DENS,
     1		VDOTB,VEL,CH1AV,CH1PK,CH2AV,CH2PK
	IN = IN+1
	PDATA(IN,1) = SQRT(CH1PK**2 + CH2PK**2)
	PDATA(IN,2) = SQRT(CH1AV**2 + CH2AV**2)
C1	PDATA(IN,3) = BDOTN
C2	PDATA(IN,3) = MA
C3	PDATA(IN,3) = MS
C4	PDATA(IN,3) = ABS(VDOTB)
	PDATA(IN,3) = DENS
	GO TO 100
  200	CONTINUE
	CALL MGPLOT(1,IN,PDATA)
	STOP
	END
	SUBROUTINE MGPLOT(IHARD,NL,PDATA)
C
	DIMENSION PDATA(500,3)
	CHARACTER*20 CH(20)
C
	CH(1) = 'TERMINAL 3'
	IF(IHARD.EQ.1) CH(1) = 'PRINTER 2'
	CH(2) = 'LINES 1 499'
	CH(3) = 'XCOLUMN 3'
	CH(4) = 'YCOLUMN 2'
	CH(5) = 'LIMITS'
	CH(6) = 'PTYPE 6 0'
	CH(7) = 'POINTS'
	CH(8) = 'BOX'
C1	CH(9) = 'XLABEL B dot N'
C2	CH(9) = 'XLABEL M alfven'
C3	CH(9) = 'XLABEL M acoustic'
C4	CH(9) = 'XLABEL V dot B'
	CH(9) = 'XLABEL DENSITY'
	CH(10) = 'YLABEL RMS E (V/M)'
	CH(11) = 'ID [WIND]SHOCKEPLOT  SHOCKE.DATA'
	CH(12) = 'END'
      IF(IHARD.EQ.1) THEN
	CH(12) = 'HARDCOPY'
	CH(13) = 'END'
      ENDIF
	CALL MONGO(12+IHARD,CH,500,3,PDATA)
C
	CH(4) = 'YCOLUMN 1'
	CH(10) = 'YLABEL PEAK E (V/M)'
	CALL MONGO(12+IHARD,CH,500,3,PDATA)
      RETURN
      END

ext: for


text:
! ------------------------------------------------------------------------
! Copyright (C) 2017 Nobuya Sato, Hiori Kino, and Takashi Miyake
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
! ------------------------------------------------------------------------

module rfc5
  use paramlist
  use cif_module
  implicit none

  ! parameters for optimization
  logical, parameter :: fix_first_atom = .false. ! fix coords of the first atom for debug
  integer, parameter :: gdiis_start_step = 2 ! start of GDIIS steps
  integer, parameter :: gdiis_steps = 6      ! depth of GDIIS steps

  ! module arrays for optimization history
  real(8), allocatable :: coord_recent(:,:,:)
  real(8), allocatable :: force_recent(:,:,:)
  real(8), allocatable :: Hessian(:,:,:,:)

contains
  ! optimize atom coordinates and cell vectors
  subroutine updt_coordcell_RFC5( loop, updt_coord, updt_cell )
    integer, intent(in) :: loop ! optimization iteration
    logical, intent(in) :: updt_coord
    logical, intent(in) :: updt_cell

    integer :: size ! total size of positions
    integer :: i, j, k, ia
    integer :: info
    real(8) :: force_mean(3), max_diff

    ! local variables for GDIIS
    real(8), allocatable :: overlap_ff(:,:), beta(:)
    integer, allocatable :: ipiv(:)
    real(8), allocatable :: work(:), eigen(:)
    real(8), allocatable :: force_gdiis(:,:)
    real(8), allocatable :: coord_gdiis(:,:)

    ! local variables for BFGS
    real(8), allocatable :: coord_diff(:,:)
    real(8), allocatable :: force_diff(:,:)
    real(8), allocatable :: direc_diff(:,:)
    real(8), allocatable :: coord_bfgs(:,:)
    real(8) :: prod_rf, prod_rd
    real(8), allocatable :: RF(:,:,:,:)
    real(8), allocatable :: Z(:,:,:)
    integer              :: M
    integer, allocatable :: iwork(:), ifail(:)

    !--- soiap variables
    ! number of atom: QMD%natom
    ! atom coord: QMD%ra(:,ia) (abosolute)
    ! atom coord: QMD%rr(:,ia) (relative)
    ! atom force: QMD%frc(:,ia)
    !
    ! cell vectors: QMD%uv(:,1), QMD%uv(:,2), QMD%uv(:,3)
    ! recp vectors: QMD%bv(:,1), QMD%bv(:,2), QMD%bv(:,3)
    ! cell volume: QMD%omega
    ! cell stress: QMD%strs(:,:)
    !---

    size = QMD%natom + 3 ! sum of atoms and vectors

    ! allocate arrays for recording history
    if( loop == 1 ) then
       allocate( coord_recent(3,size,gdiis_steps) )
       allocate( force_recent(3,size,gdiis_steps) )
       coord_recent = 0.0d0
       force_recent = 0.0d0

       allocate( Hessian(3,size,3,size) )
       Hessian = 0.0d0
    end if

    ! allocate local arrays
    allocate( force_gdiis(3,size), coord_gdiis(3,size) )
    allocate( force_diff(3,size), coord_diff(3,size) )
    allocate( direc_diff(3,size), coord_bfgs(3,size) )

    !---- GDIIS stage

    ! shift the history of coords and forces
    do i=gdiis_steps-1, 1, -1
       coord_recent(:,:,i+1) = coord_recent(:,:,i)
       force_recent(:,:,i+1) = force_recent(:,:,i)
    end do

    ! record the latest coords and forces of atoms
    do ia=1, QMD%natom
       coord_recent(:,ia,1) = QMD%ra(:,ia) ! use absolute coordinate
       force_recent(:,ia,1) = QMD%frc(:,ia) ! use force in absolute coordinate
    end do

    ! remove numerical errors in the sum of force_recent(:,:,1)
    force_mean(:) = 0.0d0
    do ia=1, QMD%natom
       force_mean(:) = force_mean(:) + force_recent(:,ia,1)
    end do
    force_mean(:) = force_mean(:)*(1.0d0/QMD%natom)
    do ia=1, QMD%natom
       force_recent(:,ia,1) = force_recent(:,ia,1) - force_mean(:)
    end do

    ! record the latest coords and forces of unit vectors
    do ia=1, 3
       coord_recent(:,QMD%natom+ia,1) = QMD%uv(:,ia) ! use absolute coordinate
       force_recent(:,QMD%natom+ia,1) = QMD%omega * matmul( QMD%strs(:,:), QMD%bv(:,ia) )
    end do

    if( .not. updt_coord ) then
       do ia=1, QMD%natom
          force_recent(:,ia,1) = 0.0d0
       end do
    else if( fix_first_atom ) then
       ia=1
       force_recent(:,ia,1) = 0.0d0
    end if

    if( .not. updt_cell ) then
       do ia=1, 3
          force_recent(:,QMD%natom+ia,1) = 0.0d0
       end do
    end if

    if( loop<gdiis_start_step ) then
       coord_gdiis(:,:) = coord_recent(:,:,1)
       force_gdiis(:,:) = force_recent(:,:,1)
    else
       allocate( overlap_ff(gdiis_steps,gdiis_steps), beta(gdiis_steps) )
       ! calc matrix of l.h.s of the linear equation
       do j=1, gdiis_steps
          do i=j, gdiis_steps
             if( i>loop .or. j>loop ) then
                if( i== j ) then
                   overlap_ff(i,j) = 1.0d0
                else
                   overlap_ff(i,j) = 0.0d0
                end if
             else
                overlap_ff(i,j) = sum( force_recent(:,:,i)*force_recent(:,:,j) )
             end if
          end do
       end do

       ! calc vector of r.h.s of the linear equation
       do i=1, gdiis_steps
          if( i>loop ) then
             beta(i) = 0.0d0
          else
             beta(i) = 1.0d0
          end if
       end do

       ! solve the linear equation
       allocate( ipiv(gdiis_steps), work(gdiis_steps*4) )
       call dsysv( 'L', gdiis_steps, 1, overlap_ff, gdiis_steps, ipiv, &
            beta, gdiis_steps, work, 4*gdiis_steps, info )
       deallocate( ipiv, work )
       beta(:) = beta(:)*(1.d0/sum(beta(:)))

       ! calc GDIIS trial coords and forces as a linear combination
       coord_gdiis(:,:) = 0.0d0
       force_gdiis(:,:) = 0.0d0
       do i=1, gdiis_steps
          coord_gdiis(:,:) = coord_gdiis(:,:) + beta(i)*coord_recent(:,:,i)
          force_gdiis(:,:) = force_gdiis(:,:) + beta(i)*force_recent(:,:,i)
       end do

       deallocate( overlap_ff, beta )
    end if

    !---- BFGS stage
    if( loop == 1 ) then
       Hessian = 0.0d0
       do ia=1, size
          do k=1, 3
             Hessian(k,ia,k,ia) = 1.0d0
          end do
       end do
    else
       ! calc difference of coords and forces from the previous step
       coord_diff(:,:) = coord_recent(:,:,1) - coord_recent(:,:,2)
       force_diff(:,:) = force_recent(:,:,1) - force_recent(:,:,2)

       ! operate the hessian on the difference of the forces
       do ia=1, size
          do k=1, 3
             direc_diff(k,ia) = sum(Hessian(k,ia,:,:)*coord_diff(:,:))
          end do
       end do

       ! calc inner products
       prod_rf = sum(coord_diff(:,:)*force_diff(:,:))
       prod_rd = sum(coord_diff(:,:)*direc_diff(:,:))

       ! update the hessian
       if( prod_rf /= 0.0d0 ) then
          do ia=1, size
             do k=1, 3
                Hessian(k,ia,:,:) = Hessian(k,ia,:,:) &
                     - (force_diff(k,ia)/prod_rf) * force_diff(:,:)
             end do
          end do
       end if
       if( prod_rd /= 0.0d0 ) then
          do ia=1, size
             do k=1, 3
                Hessian(k,ia,:,:) = Hessian(k,ia,:,:) &
                     - (direc_diff(k,ia)/prod_rd) * direc_diff(:,:)
             end do
          end do
       end if
    end if

    !---- RF stage

    ! calc matrix of RF
    ! [memo] RF matrix is a little larger than 3size+1 x 3size+1.
    ! extra elements in this matrix are not accessed in dsyev.
    allocate( RF(3,size+1,3,size+1), Z(3,size+1,1) )
    RF(:,1:size,:,1:size) = Hessian(:,1:size,:,1:size)
    RF(1,size+1,:,1:size) = (-1.0d0)*force_gdiis(:,1:size)
    RF(1,size+1,1,size+1) = 0.0d0

    ! solve the lowest eigen vector
    allocate( work(8*(3*size+1)), eigen(3*size+1) )
    allocate( iwork(5*(3*size+1)), ifail(3*size+1) )

    call dsyevx( 'V', 'I', 'L', 3*size+1, RF, 3*(size+1), &
         0.0d0, 0.0d0, 1, 1, 0.0d0, M, &
         eigen, Z, 3*(size+1), work, 8*(3*size+1), iwork, ifail, info )

    ! normalize eigen vector as ( vec{coord_bfgs}, 1 )
    if( Z(1,size+1,1) == 0.0d0 ) then
       coord_bfgs(:,:) = 0.0d0
    else
       coord_bfgs(:,:) = Z(:,1:size,1)*(1.0d0/Z(1,size+1,1))
    end if

    deallocate( work, eigen )
    deallocate( iwork, ifail )
    deallocate( RF, Z )

    ! calc diff of coord of unit vectors on the next step
    do ia=1, 3
       coord_diff(:,QMD%natom+ia) = &
            coord_gdiis(:,QMD%natom+ia) + coord_bfgs(:,QMD%natom+ia) &
            - QMD%uv(:,ia)
    end do

    ! calc diff of coord of atoms on the next step
    do ia=1, QMD%natom
       coord_diff(:,ia) = coord_gdiis(:,ia) + coord_bfgs(:,ia) - QMD%ra(:,ia)
    end do

    ! symmetrize diff of coord of atoms
    if( CIF_canSymmetrize() .and. QMD%is_symmetrized ) then
       ! translate from absolute to relative coordinates
       do ia=1, QMD%natom
          coord_diff(:,ia) = matmul(coord_diff(:,ia),QMD%bv(:,:))
       end do
       call CIF_symmetrizeDirection( coord_diff )
       ! translate from relative to absolute coordinates
       do ia=1, QMD%natom
          coord_diff(:,ia) = matmul(QMD%uv(:,:),coord_diff(:,ia))
       end do
    end if

    ! find maximum coord_diff of unit vectors and atoms in absolute coordinates
    max_diff = maxval(abs(coord_diff(:,:)))

    ! modulation coord_diff if it is too large
    if( max_diff > QMD%rdmax ) then
       coord_diff(:,:) = coord_diff(:,:)*(QMD%rdmax/max_diff)
    end if

    ! update coords of unit vectors on the next step
    do ia=1, 3
       if( updt_cell ) then
          QMD%uv(:,ia) = QMD%uv(:,ia) + coord_diff(:,QMD%natom+ia)
       end if
    end do

    ! update reciprocal vectors
    call cross_x(QMD%uv(:,1),QMD%uv(:,2),QMD%bv(:,3))
    call cross_x(QMD%uv(:,2),QMD%uv(:,3),QMD%bv(:,1))
    call cross_x(QMD%uv(:,3),QMD%uv(:,1),QMD%bv(:,2))
    QMD%omega=dot_product(QMD%bv(:,3),QMD%uv(:,3))
    QMD%omegai=1.d0/QMD%omega
    QMD%bv=QMD%bv*QMD%omegai

    ! update coords of atoms on the next step
    do ia=1, QMD%natom
       if( (.not.updt_coord) .or. (fix_first_atom.and.ia==1) ) then
          if( updt_cell ) then
             QMD%ra(:,ia) = matmul(QMD%uv(:,:),QMD%rr(:,ia))
          end if
       else
          QMD%ra(:,ia) = matmul(QMD%uv(:,:),QMD%rr(:,ia)) + coord_diff(:,ia)
          QMD%rr(:,ia) = matmul(QMD%ra(:,ia),QMD%bv(:,:))
       end if
    end do

    ! clear local arrays
    deallocate( force_diff, coord_diff )
    deallocate( direc_diff, coord_bfgs )
    deallocate( force_gdiis, coord_gdiis )

  end subroutine updt_coordcell_RFC5
end module rfc5

max_stars_repo_name: nbsato/soiap

max_issues_repo_name: nbsato/soiap

max_forks_repo_name: nbsato/soiap


text:
      subroutine coepot
*
*
*         compute smooth potential for all particles
*         ------------------------------------------
*
*
      include 'common.h'
*
      real*8 ux,uy,smx,rx
*
      integer i,n,im
*
*
      n = nt
*
      smx = smt
      uy = 0.0d0
      rx = r(n)
      ux = -smx/rx
      u(n) = ux
*
      do 10 i=n-1,1,-1
*
         im = iname(i+1)
         smx = smx - body(im)
         ux = -smx/r(i)
         uy = uy - body(im)/rx
         rx = r(i)
         u(i) = ux + uy
*
 10   continue
*
*
      return
*
      end
*
*
*
*

max_stars_repo_name: rknop/amuse

max_issues_repo_name: rknop/amuse

max_forks_repo_name: rieder/amuse


text:
!-----------------------------------------------------------------------
! Fortran2003 interface to CUDA utility Library
! written by Viktor K. Decyk, UCLA
      module gpulib2_c
      use iso_c_binding
      implicit none
!
      interface
         subroutine gpu_setgbsize(nblock) bind(C,name='gpu_setgbsize')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nblock
         end subroutine
      end interface
!
      interface
         function getmmcc() bind(C,name='getmmcc')
         use iso_c_binding
         implicit none
         integer(c_int) :: getmmcc
         end function
      end interface
!
      interface
         subroutine gpu_fallocate(g_f,nsize,irc)                        &
     &bind(C,name='gpu_fallocate')
         use iso_c_binding
         implicit none
         type (c_ptr) :: g_f
         integer(c_int), value :: nsize
         integer(c_int) :: irc
         end subroutine
      end interface
!
      interface
         subroutine gpu_iallocate(g_i,nsize,irc)                        &
     &bind(C,name='gpu_iallocate')
         use iso_c_binding
         implicit none
         type (c_ptr) :: g_i
         integer(c_int), value :: nsize
         integer(c_int) :: irc
         end subroutine
      end interface
!
      interface
         subroutine gpu_callocate(g_c,nsize,irc)                        &
     &bind(C,name='gpu_callocate')
         use iso_c_binding
         implicit none
         type (c_ptr) :: g_c
         integer(c_int), value :: nsize
         integer(c_int) :: irc
         end subroutine
      end interface
!
      interface
         subroutine gpu_deallocate(g_d,irc) bind(C,name='gpu_deallocate'&
     &)
         use iso_c_binding
         implicit none
         type (c_ptr), value :: g_d
         integer(c_int) :: irc
         end subroutine
      end interface
!
      interface
         subroutine gpu_fcopyin(f,g_f,nsize) bind(C,name='gpu_fcopyin')
         use iso_c_binding
         implicit none
         type (c_ptr), value :: f, g_f
         integer(c_int), value :: nsize
         end subroutine
      end interface
!
      interface
         subroutine gpu_fcopyout(f,g_f,nsize) bind(C,name='gpu_fcopyout'&
     &)
         use iso_c_binding
         implicit none
         type (c_ptr), value :: f, g_f
         integer(c_int), value :: nsize
         end subroutine
      end interface
!
      interface
         subroutine gpu_icopyin(f,g_f,nsize) bind(C,name='gpu_icopyin')
         use iso_c_binding
         implicit none
         type (c_ptr), value :: f, g_f
         integer(c_int), value :: nsize
         end subroutine
      end interface
!
      interface
         subroutine gpu_icopyout(f,g_f,nsize) bind(C,name='gpu_icopyout'&
     &)
         use iso_c_binding
         implicit none
         type (c_ptr), value :: f, g_f
         integer(c_int), value :: nsize
         end subroutine
      end interface
!
      interface
         subroutine gpu_ccopyin(f,g_f,nsize) bind(C,name='gpu_ccopyin')
         use iso_c_binding
         implicit none
         type (c_ptr), value :: f, g_f
         integer(c_int), value :: nsize
         end subroutine
      end interface
!
      interface
         subroutine gpu_ccopyout(f,g_f,nsize) bind(C,name='gpu_ccopyout'&
     &)
         use iso_c_binding
         implicit none
         type (c_ptr), value :: f, g_f
         integer(c_int), value :: nsize
         end subroutine
      end interface
!
      interface
         subroutine gpu_zfmem(g_f,nsize) bind(C,name='gpu_zfmem')
         use iso_c_binding
         implicit none
         type (c_ptr), value :: g_f
         integer(c_int), value :: nsize
         end subroutine
      end interface
!
      interface
         subroutine gpu_zcmem(g_f,nsize) bind(C,name='gpu_zcmem')
         use iso_c_binding
         implicit none
         type (c_ptr), value :: g_f
         integer(c_int), value :: nsize
         end subroutine
      end interface
!
      interface
         subroutine gpu_set_cache_size(nscache)                         &
     &bind(C,name='gpu_set_cache_size')
         use iso_c_binding
         implicit none
         integer(c_int), value :: nscache
         end subroutine
      end interface
!
      interface
         subroutine emptykernel() bind(C,name='emptykernel')
         implicit none
         end subroutine
      end interface
!
      interface
         subroutine init_cu(dev,irc) bind(C,name='init_cu')
         use iso_c_binding
         implicit none
         integer(c_int), value :: dev
         integer(c_int) :: irc
         end subroutine
      end interface
!
      interface
         subroutine end_cu() bind(C,name='end_cu')
         implicit none
         end subroutine
      end interface
!
      end module

max_stars_repo_name: gcasabona/cuda

max_issues_repo_name: gcasabona/cuda

max_forks_repo_name: gcasabona/cuda


text:
Ashley Pyon is obsessed with making lists that she does not end up following. She loves public speaking and aspires to become an inspirational television image one day. She has had too many embarrassing moments in her life that it would be dangerous to dwell on them. She likes to think she is brave and daring, but when certain situations reveal themselves, she easily gets scared. She loves the company of spontaneous people because they let her express her own spontaneity. She needs to stop procrastinating and live everyday to the fullest, but she has yet to do that on a daily basis. She has immense Northern California pride, but secretly wishes she lived in Southern California with their beaches and warm weather. She likes to wear bright colors and outrageous accessories to stand out in a crowd. She loves finding new bands that no one else knows about and blasting their music. She adores sunny days when she feels lazy and just lays outside on the grass, but also likes rainy days as long as she is inside with the heater on and is holding a hot cup of cocoa. If she were an animal, she would be a koala because they have the life—lazing around in trees and eating all day. Her worst fears are rejection, failure, missing chances, and clowns. She leaves Christmas lights up in her room 365 days in the year because they make her feel unbelievably happy and giddy.  She sporadically likes to do things that are reminiscent of her childhood—such as romp around on the playground, play Mario Party, and play “house” with her baby cousins. She is blessed with the most loving family and caring friends that she would never trade for others in this world. She does not have a firing passion as of yet, but when she discovers it, she will give it her all. She is still young and is learning every day.

20070704 21:51:17 nbsp Welcome to the Wiki. How do chucks place and Chuck Weller relate? Should there still be two pages, or should the Chuck Weller page just redirect people to chucks place? Users/JasonAller

20080520 08:16:01 nbsp Hey, I moved your content to this page so that it would match your login. I also put a link on the copy of the page you created on wiki:wikispot:Users/Ashley Wiki Spot to this page so that it would be easier to get to. Sometimes the process of starting out and figuring out the name spaces used around here can be confusing. This page however is on Davis Wiki and should be tied to your Ashley login. You can disable your Users/SUHHHWEEEEEEET account by logging into it and going to the Wiki Settings link and disabling the account if you want. Let us know if you need any help. Users/JasonAller


! negative test -- invalid labels, out of range

! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
! CHECK: end do

SUBROUTINE sub00(a,b,n,m)
  INTEGER n,m
  REAL a(n,m), b(n,m)

  i = n-1
  DO 10 j = 1,m
     g = a(i,j) - b(i,j)
10   PRINT *, g
END SUBROUTINE sub00


text:
*deck sf3eq6
      subroutine sf3eq6( a,        cx,       eta,      g4,
     &         h4,       icb,      icc,      ipt,      iscmci,
     &         is,       isf,      js,       jsf,      ls,
     &         lsf,      ijgt,     ijx,      ijy,      ijz,
     &         klgt,     klx,      kly,      klz,      lmnp1,
     &         lmnv,     mcons,    nc,       ncon,     nfct,
     &         ngw,      nrcr,     nt,       ntl,      ntu,
     &         x,        y,        z,        zet )
      implicit real*8 (a-h,o-z)
      logical jceqkc
      common /parmr/ cutoff, tol
c
      integer
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
      common /parmi/
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
c
      common /ntgr/itl,itu,jtl,jtu,ktl,ktu,ltl,ltu,jcu,kcu,lcu,inx,
     1  jnx,knx,lnx,nwt,nwt1(3),ijsf(3),klsf(3),icxs(2,3),kcxs(2,3),
     2  npri(2,3),nprk(2,3),iesfb,kesfb,ircru,jrcru,krcru,lrcru
      common /cxindx/ ntij,ntik,ntil,ntkl,ntjl,ntjk,ntij1,ntjk1,ntkl1,
     1  ijcxst(2),ikcxst(2),ilcxst(2),klcxst(2),jlcxst(2),jkcxst(2)
      common /dim21/ ipq(256)
      common /ikpr/ npriri(2,3,8), nprirk(2,3,8)
      common /sf3ao/ ibl
      dimension a(*),cx(*),eta(mrcru,mconu,*),g4(*),h4(*),icb(4,24,*),
     1  ipt(*),ijgt(*),ijx(*),ijy(*),ijz(*),klgt(*),klx(*),kly(*),
     2  klz(*),lmnp1(*),lmnv(3,*),mcons(*),nc(*),ncon(*),nfct(*),ngw(*),
     3  nrcr(*),nt(*),ntl(*),ntu(*),x(mcu,*),y(mcu,*),z(mcu,*),
     4  zet(mconu,*)
      dimension icxbg(3),jbl(2), kcxbg(3,3)
c
      ic=icb(inx,1,icc)
      jc=icb(jnx,1,icc)
      kc=icb(knx,1,icc)
      lc=icb(lnx,1,icc)
      jceqkc=jc.eq.kc
      jesfbl=(5-iscmci)/2
      do 12 jesfb=jesfbl,2
        jbl(jesfb)=0
        do 10 ist=1,nst
          jbl(jesfb)=jbl(jesfb)+
     &      npriri(2,iscmci,ist)*nprirk(jesfb,iscmci,ist)
   10   continue
   12 continue
      if(iscmci.eq.3) go to 60
c
      icxbg(1)=ijcxst(2)+((ic-1)*nc(js)+(jc-1))*ntij
      icxbg(2)=icxbg(1)+(kc-jc)*ntij
      kcxbg(2,1)=klcxst(2)+((kc-1)*nc(ls)+(lc-1))*ntkl
      kcxbg(2,2)=kcxbg(2,1)+(jc-kc)*nc(ls)*ntkl
      if(jceqkc) then
        fnfct=(nwt*nfct(icc))
      else
        do 16 igw=2,ngw(icc)
          if(icb(inx,igw,icc).eq.ic.and.
     &       icb(jnx,igw,icc).eq.kc.and.
     &       icb(lnx,igw,icc).eq.lc) go to 24
   16   continue
        iscml=1
        fnfct=(nwt*nfct(icc))
        go to 28
   24   fnfct=(2*nwt*nfct(icc))
      endif
      iscml=2
   28 do 48 iscm=iscml,2
      if(iscm.eq.1) then
        call jandk(a,eta,g4,ipt,is,isf,ic,js,jsf,jc,js,jsf,kc,ls,lsf,lc,
     1    ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2    nrcr,nt,ntl,ntu,x,y,z,zet)
      else
        call jandk(a,eta,g4,ipt,is,isf,ic,js,jsf,kc,js,jsf,jc,ls,lsf,lc,
     1    ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2    nrcr,nt,ntl,ntu,x,y,z,zet)
      endif
      ndx=0
      iblb=0
      do 46 ircr=1,ircru
      do 44 jrcr=1,jrcru
      do 42 krcr=1,krcru
      do 40 lrcr=1,lrcru
      icxs(2,iscm)=icxbg(iscm)
      do 38 it=itl,itu
        do 36 jt=jtl,jtu
          kcxs(2,iscm)=kcxbg(2,iscm)
          do 34 kt=ktl,ktu
            do 32 lt=ltl,ltu
              ndx=ndx+1
              val=g4(ndx)
              if(abs(val).le.cutoff) go to 30
              val=fnfct*val
              ibl=iblb
              call aoso2( h4, cx, iscm, val )
   30         kcxs(2,iscm)=kcxs(2,iscm)+nprk(2,1)
   32       continue
   34     continue
          icxs(2,iscm)=icxs(2,iscm)+npri(2,1)
   36   continue
   38 continue
      iblb=iblb+jbl(2)
   40 continue
   42 continue
   44 continue
   46 continue
   48 continue
      return
c
   60 fnfct=(nwt*nfct(icc))
      jbld=jbl(2)-jbl(1)
      jbljk=ipq(jrcru)*jbl(2)+jrcru*jbl(1)
      icxbg(3)=ilcxst(2)+((ic-1)*nc(ls)+(lc-1))*ntil
      kcxbg(1,3)=jkcxst(1)+ipq((jc-1)*nt(jsf)+1)*nprk(1,3)+(kc-1)*ntjk1
      kcxbg(2,3)=jkcxst(2)+((jc-1)*nc(js)+(kc-1))*ntjk
      kcxbg(3,3)=kcxbg(2,3)-(jc-kc)*(nc(js)-1)*ntjk
      call jandk(a,eta,g4,ipt,is,isf,ic,ls,lsf,lc,js,jsf,jc,js,jsf,kc,
     1  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     2  nrcr,nt,ntl,ntu,x,y,z,zet)
      ndxl=1
      ngtl=nt(jsf)**2
      iblbil=0
      do 98 ircr=1,ircru
      do 96 lrcr=1,lrcru
      do 94 jrcr=1,jrcru
      if(jceqkc) krcru=jrcr
      do 92 krcr=1,krcru
      if(jrcr-krcr) 70, 72, 74
   70 iblb=iblbil+(ipq(krcr)+(jrcr-1))*jbl(2)-(krcr-1)*jbld
      kesfb=2
      kcxbg1=kcxbg(3,3)
      ngtj=1
      ngtk=nt(jsf)
      go to 78
   72 iblb=iblbil+ipq(krcr)*jbl(2)+(krcr-1)*jbl(1)
      kesfb=1
      go to 76
   74 iblb=iblbil+(ipq(jrcr)+(krcr-1))*jbl(2)-(jrcr-1)*jbld
      kesfb=2
   76 kcxbg1=kcxbg(kesfb,3)
      ngtj=nt(jsf)
      ngtk=1
   78 icxs(2,3)=icxbg(3)
      do 88 it=itl,itu
        do 86 lt=ltl,ltu
          kcxs(kesfb,3)=kcxbg1
          ndxj=ndxl
          do 84 jt=jtl,jtu
            if(jrcr.eq.krcr.and.jceqkc) ktu=jt
            ndxk=ndxj
            do 82 kt=ktl,ktu
              val=g4(ndxk)
              if(abs(val).le.cutoff) go to 80
              val=fnfct*val
              ibl=iblb
              call aoso2( h4, cx, 3, val )
   80         ndxk=ndxk+ngtk
              kcxs(kesfb,3)=kcxs(kesfb,3)+nprk(kesfb,3)
   82       continue
            ndxj=ndxj+ngtj
   84     continue
          ndxl=ndxl+ngtl
          icxs(2,3)=icxs(2,3)+npri(2,3)
   86   continue
   88 continue
   92 continue
   94 continue
      iblbil=iblbil+jbljk
   96 continue
   98 continue
      return
      end

max_stars_repo_name: MOLFDIR/MOLFDIR

max_issues_repo_name: yingxingcheng/MOLFDIR

max_forks_repo_name: yingxingcheng/MOLFDIR


text:
c###fdist.for
      SUBROUTINE FDIST (IHOP,K,NUMMOD)
C--------------------------------
C
C     THIS ROUTINE FINDS UP TO SIX RAYSETS FOR THE CURRENT HOP DISTANCE
C     (SET IN SUBROUTINE LUFFY) AND FREQUENCY
C     LOOK FOR E, F1 AND F2 LOW ANGLES AND HIGH ANGLES
C
C     K IS THE SAMPLE AREA (USED AS AN INDEX)
C
      COMMON /CON /D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RZ, VOFL
      COMMON /DON /ALATD, AMIN, AMIND, BTR, BTRD, DLONG, DMP, ERTR, GCD,
     1 GCDKM, PMP, PWR, TLAT, TLATD, TLONG, TLONGD, RSN, SIGTR, RLAT,
     2 RLATD,RLONG,RLONGD,BRTD,FLUX,ULAT,ULATD,ULONG,ULONGD,SSN,D90R,
     3 D50R,D10R,D90S,D50S,D10S
      COMMON/FRQ/FREA(13),FREL(29),FREQ,JMODE,ITXRCP(2)
      COMMON/REFLX/DELFX(45,3),HPFLX(45,3),HTFLX(45,3),GDFLX(45,3),FVFLX
     A (45,3),DSKPKM(3),DELSKP(3),HPSKP(3),HTSKP(3),DMAXKM(3),FVSKP(3)
     B ,ISKP(3),IMODE(45,3),AFFLX(45,3),DELPEN(3,5),GML(45,3),FHP(45,3)
      COMMON /MODES /GHOP, DELMOD (6, 3), HPMOD (6, 3), HTMOD (6, 3), FV
     1MOD (6, 3), ITMOD (6, 3), AFMOD (6, 3)
      COMMON/INFORM/INFO,IHSHR,IHLNG
      character MODZ(6)*3,mlay(3)*3
      data mlay/'  E',' F1',' F2'/
      do 1 i=1,6
    1 MODZ(i)='   '
C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
C.....DHOP= HOP DISTANCE KM
      DHOPKM = GHOP*RZ
      DO 100 IM = 1, 6
C.....THIS INDICATES NO MODE
      HPMOD (IM, K) = - 1.
  100 ITMOD(IM,K) = 5
CRMFORT      IF (DHOPKM - DMAXKM (K))135, 230, 230
ccc      IF(DHOPKM+0.1.GT.DMAXKM(K)) GO TO 230
c    The code below was done to fix a problem of no modes being found.
c    This was done 1/10/97 by Greg Hand.  Apparently the original line
c    was commented out with CRMFORT.  I am assuming this was done by NRL to
c    solve some problem with Ryan McFarlan Fortran compiler.
      IF(DHOPKM.GE.DMAXKM(K)) GO TO 230
      IH = 0
      IL = 0
  140 IL = IL + 1
  145 IH = IH + 1
      IF(IH.gt.44) go to 230
      IF(HPFLX(IH+1,K).le.0.) go to 230
      IF(GDFLX(IH,K) - GDFLX(IH+1,K)) 170, 160, 215
ccc  160 IF(DHOPKM - GDFLX(IH, K)) 145, 165, 145
  160 IF(abs(DHOPKM-GDFLX(IH, K)).le..001) go to 145
  165 DELMOD (IL, K) = DELFX (IH, K)
      HPMOD (IL, K) = HPFLX (IH, K)
      HTMOD (IL, K) = HTFLX (IH, K)
      ITMOD (IL, K) = IMODE (IH, K)
      AFMOD (IL, K) = AFFLX (IH, K)
      FVMOD (IL, K) = FVFLX (IH, K)
      GO TO 305
  170 IF(GDFLX(IH,K) - DHOPKM) 175, 165, 145
  175 IF(DHOPKM - GDFLX(IH+1,K)) 180, 176, 145
  176 IH = IH + 1
      GO TO 165
  180 CONTINUE
      DTH2 = GDFLX (IH + 1, K) - GDFLX (IH, K)
      IF (ABS (DTH2) - 0.001)165, 165, 185
  185 CONTINUE
      DTH = DHOPKM  - GDFLX(IH,K)
C.....BEGINNING OF SECTION TO SEARCH IN TABLE, DO LINEAR INTERPOLATION
      THET = 0.5 * DHOPKM / RZ
      HP1 = HPFLX (IH, K)
      HP2 = HPFLX (IH + 1, K)
      HT1 = HTFLX (IH, K)
      HT2 = HTFLX (IH + 1, K)
      HP = HP1 + (HP2 - HP1) * DTH / DTH2
      HT = HT1 + (HT2 - HT1) * DTH / DTH2
      AFMOD(IL,K)=AFFLX(IH,K)+(AFFLX(IH+1,K)-AFFLX(IH,K))*DTH/DTH2
      HPMOD (IL, K) = HP
      ST = SIN(THET)
      TANP = ST/(1. - COS(THET)  + HP/RZ)
      PHE  = ATAN(TANP)
C.....BUT FORCE CORRECT GEOMETRY BY CALCULATING RADIATION ANGLE AND
C.....SNELL"S LAW BY CALCULATING FV
      DELMOD(IL,K) =  (PIO2 - PHE - THET ) * R2D
      SPHI = RZ * COS (DELMOD (IL, K) * D2R) / (RZ + HT)
      SPHI = 1. - SPHI * SPHI
      SPHI = AMAX1 (SPHI, 0.000001)
      FVMOD (IL, K) = FREQ * SQRT (SPHI)
      HTMOD (IL, K) = HT
      ITMOD (IL, K) = IMODE (IH, K)
C.....CHECK ON MINIMUM ANGLE AFTER INTERPOLATION
  305 IF(DELMOD(IL,K).ge.AMIND) go to 315
      HPMOD(IL,K) = - ABS(HPMOD(IL,K))
      go to 145        !  added from ICEPAC fdist
C.....END OF SECTION TO SEARCH IN TABLE, DO LINEAR INTERPOLATION
  315 IF (IL - 6)140, 230, 230
  215 IF(GDFLX(IH,K) - DHOPKM) 145, 165, 220
  220 IF(DHOPKM - GDFLX(IH+1,K)) 145, 176, 180
  230 CONTINUE
          NUMMOD=0
          do 236 ilm=1,6
          if(HPMOD(ilm,k).lt.0.)go to 236
          NUMMOD=NUMMOD+1
          MODZ(NUMMOD)=mlay(ITMOD(ilm,k))
  236     continue
          IF(IAND(INFO,1).GT.0)THEN
           WRITE(99,'(16h "FDIST"   Nhop=,I1,3x,6hHopkm=,f6.0,7h  Mods=,
     1      I1,3X,6A3)')IHOP,DHOPKM,NUMMOD,MODZ
          ENDIF
      RETURN
      END
C--------------------------------

max_stars_repo_name: jawatson/voacapl

max_issues_repo_name: jawatson/voacapl

max_forks_repo_name: jawatson/voacapl


! { dg-do compile }
! { dg-options "-Wall -fmodule-private" }
! { dg-require-visibility "" }

module bar
  integer :: i ! { dg-warning "Unused PRIVATE" }
end module bar


!
!     -------------------------------------------------------------
!      N O N R E L A T 1
!     -------------------------------------------------------------
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
!     OF TWO PARTICLE OPERATOR IN CASE :           N'1 = N1        *
!                                                  N'2 = N2        *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville            February 1994   *
!                                                                  *
!     Universite Libre de Bruxelles, Brussels                      *
!                                                  December 1995   *
!
      SUBROUTINE NONRELAT1(IA, IB, IIRE)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
      USE MEDEFN_C
      USE DIAGNL_C
      USE OPERAT_C
      USE TRK_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  11:17:07  11/16/01
!...Switches:
!
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE recoupls0_I
      USE calculation_I
      USE hibff_I
      USE w1_I
      USE savenon_I
      USE coulombls_I
      USE wwls1_I
      USE avera_I
      USE orbitorbit_I
      USE ittk_I
      USE recoupls2_I
      USE w1w2ls_I
      USE ixjtik_I
      USE sixj_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: IA
      INTEGER  :: IB
      INTEGER , INTENT(IN) :: IIRE
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
      INTEGER, PARAMETER :: LMAX = 10
      INTEGER, PARAMETER :: L2MAX = 2*LMAX
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: LIA2, LA, IN, IG2, I2, KL, KL2, KL1, LIB2, LB, IG1, I4, IAT, &
         I1, II1, IP2, IGAL, I3, L12, I13, KLL
      REAL(DOUBLE), DIMENSION(L2MAX,2) :: PMG, RAG
      REAL(DOUBLE) :: QM1, QM2, A1, A2, A, RECOPL, B, AA, RE, REP, RA, AB, AC, &
         SI, ABB
      LOGICAL , DIMENSION(2) :: IATT
      LOGICAL :: IATTT
!-----------------------------------------------
!
      LIA2 = LJ(IA)*2
      LA = IJFUL(IA)
      QM1 = HALF
      QM2 = -HALF
      A1 = ZERO
      A2 = ZERO
      IF (IA == IB) THEN
!
!     THE CASE 1111   + + - -
!
         IF (JA /= JB) THEN
            DO IN = 1, 3
               IF (RECOUPLS0(IN,IA,IA,IA,IA,0)) CYCLE
               RETURN
            END DO
         ENDIF
         CALL HIBFF (IA, IA, IA, IA, 1)
         CALL W1 (IK1, BK1, ID1, BD1, 0, 0, QM1, QM2, A)
         RECOPL = ONE/DSQRT(DBLE(IK1(6)+1)*(IK1(5)+1))
         IF (ABS(A) > EPS) THEN
            B = A*RECOPL*HALF*DSQRT(DBLE(4*LJ(IA)+2))
!BAY            IF(DABS(B).GT.EPS) CALL SAVENON(4,B,0,0,LA,0,LA,JA,JB,0)
            IF (DABS(B) > EPS) THEN
               IF (JA /= JB) THEN
                  WRITE (*, '(A,I5,A,I5)') 'Configurations', JA, 'and', JB, &
                     'are identical'
                  STOP
               ELSE
                  CALL SAVENON (4, B, 0, 0, LA, 0, LA, JA, JB, 0)
               ENDIF
            ENDIF
            A = A/DSQRT(DBLE(4*LJ(IA)+2))
         ENDIF
         IF (IIRE == 0) RETURN
         IF (ICOLOM + IORBORB /= 0) THEN
            IG2 = LIA2 + 1
            DO I2 = 1, IG2, 2
               KL = I2 - 1
               IF (ICOLOM == 1) THEN
!GGf                                with    f-shell   ***  beginning
                  IF (JA /= JB) THEN
!GGf                                with    f-shell   ***  e n d
                     CALL COULOMBLS (LJ(IA), LJ(IA), LJ(IA), LJ(IA), KL, A1)
                     IF (DABS(A1) > EPS) THEN
                        CALL WWLS1 (IK1, BK1, ID1, BD1, KL, 0, QM1, QM2, QM1, &
                           QM2, AA)
                        AA = AA/DSQRT(DBLE(2*KL + 1)) + A
                        AA = AA*A1*RECOPL
                        IF (DABS(AA) > EPS) CALL SAVENON (1, AA, KL, 0, LA, 0, &
                           LA, JA, JB, 0)
                     ENDIF
                  ELSE IF (LJ(IA) > 3) THEN
                     CALL COULOMBLS (LJ(IA), LJ(IA), LJ(IA), LJ(IA), KL, A1)
                     IF (DABS(A1) > EPS) THEN
                        CALL WWLS1 (IK1, BK1, ID1, BD1, KL, 0, QM1, QM2, QM1, &
                           QM2, AA)
                        AA = AA/DSQRT(DBLE(2*KL + 1)) + A
                        AA = AA*A1*RECOPL
                        IF (DABS(AA) > EPS) CALL SAVENON (1, AA, KL, 0, LA, 0, &
                           LA, JA, JB, 0)
                     ENDIF
!GGf                                with    f-shell   ***  beginning
                  ELSE
                     CALL AVERA (ID1(3), ID1(1), KL, ID1(4), AA)
                     IF (DABS(AA) > EPS) CALL SAVENON (1, AA, KL, 0, LA, 0, LA&
                        , JA, JB, 0)
!GGf                                with    f-shell   ***  e n d
                  ENDIF
               ENDIF
! Orbit 1111
               IF (IORBORB /= 1) CYCLE
               KL2 = KL + 2
               KL1 = KL + 1
               CALL ORBITORBIT (LJ(IA), LJ(IA), LJ(IA), LJ(IA), KL2, A1)
               IF (DABS(A1) <= EPS) CYCLE
               CALL WWLS1 (IK1, BK1, ID1, BD1, KL1, 0, QM1, QM2, QM1, QM2, AA)
               AA = AA/DBLE(2*KL1 + 1) - A/DSQRT(DBLE(2*KL1 + 1))
               AA = AA*A1*RECOPL
               IF (DABS(AA) > EPS) CALL SAVENON (9, AA, KL, LA, LA, LA, LA, JA&
                  , JB, 0)
!                IF(DABS(AA).GT.EPS)
!     :                               WRITE(77,555) AA,KL,LA,JA,JB
  555          FORMAT(1X,'1111 O-O','AA=',F17.7,'K=',I3,'LA=',I3,'J=',2I4)
            END DO
            RETURN
         ENDIF
      ENDIF
      IF (IIRE == 0) RETURN
      IF (IHSH <= 1) RETURN
      IF (ISOTOP == 1) THEN
         IF (ITTK(LJ(IA),LJ(IB),1) == 0) RETURN
      ENDIF
      IATT(1) = .TRUE.
      IATT(2) = .TRUE.
      IF (JA /= JB) THEN
         IF (.NOT.RECOUPLS0(1,IA,IB,IB,IB,0)) RETURN
         IF (.NOT.RECOUPLS0(2,IA,IB,IB,IB,1)) RETURN
         IATT(1) = RECOUPLS0(3,IA,IB,IB,IB,0)
         IATT(2) = RECOUPLS0(3,IA,IB,IB,IB,1)
         IATTT = .TRUE.
         IF (IATT(1) .OR. IATT(2)) IATTT = .FALSE.
         IF (IATTT) RETURN
      ENDIF
      CALL HIBFF (IA, IB, IA, IA, 2)
      LIB2 = LJ(IB)*2
      LB = IJFUL(IB)
      IG1 = MIN(LIA2,LIB2) + 1
      DO I4 = 1, IG1
         KL = I4 - 1
         RAG(I4,1) = ZERO
         PMG(I4,1) = ZERO
         RAG(I4,2) = ZERO
         PMG(I4,2) = ZERO
         CALL RECOUPLS2 (2, IA, IB, KL*2, 0, IAT, RE)
         IF (IAT == 0) CYCLE
         CALL RECOUPLS2 (2, IA, IB, KL*2, 1, IAT, RE)
         IF (IATT(1)) THEN
            CALL RECOUPLS2 (3, IA, IB, 0, 0, IAT, REP)
            IF (IAT /= 0) THEN
               CALL W1W2LS (KL, 0, KL, 0, QM1, QM2, QM1, QM2, RA)
               RAG(I4,1) = RA
               PMG(I4,1) = RE/DSQRT(DBLE((IK1(6)+1)*(IK2(6)+1)))
            ENDIF
         ENDIF
         IF (.NOT.IATT(2)) CYCLE
         CALL RECOUPLS2 (3, IA, IB, 2, 0, IAT, REP)
         IF (IAT == 0) CYCLE
         CALL W1W2LS (KL, 1, KL, 1, QM1, QM2, QM1, QM2, RA)
         IF (DABS(RA) <= EPS) CYCLE
         RAG(I4,2) = RA
         CALL RECOUPLS2 (3, IA, IB, 2, 1, IAT, REP)
         PMG(I4,2) = RE*REP
      END DO
!
!     CASES 1212   + + - -        TRANSFORM TO  1122   + - + -
!           2121                                1122
!
      IF (IATT(1)) THEN
         IF (ICOLOM + IORBORB /= 0) THEN
            DO I1 = 1, IG1, 2
               KL = I1 - 1
               IF (ICOLOM == 1) THEN
                  CALL COULOMBLS (LJ(IA), LJ(IB), LJ(IA), LJ(IB), KL, AA)
                  IF (DABS(AA) >= EPS) THEN
                     AA = AA*PMG(I1,1)
                     AA = AA*RAG(I1,1)
                     AA = AA*TWO/DSQRT(DBLE(2*KL + 1))
                     IF (DABS(AA) > EPS) CALL SAVENON (1, AA, KL, 0, LA, 0, LB&
                        , JA, JB, 0)
                  ENDIF
               ENDIF
! Orbit 1212
               IF (IORBORB /= 1) CYCLE
               KL2 = KL + 2
               CALL ORBITORBIT (LJ(IA), LJ(IB), LJ(IA), LJ(IB), KL2, AA)
               IF (DABS(AA) <= EPS) CYCLE
               II1 = I1 + 1
               AA = AA*PMG(II1,1)
               AA = AA*RAG(II1,1)
               AA = AA/DBLE(2*(KL2 - 1) + 1)
               IF (DABS(AA) > EPS) THEN
                  CALL SAVENON (9, AA, KL, LA, LB, LA, LB, JA, JB, 0)
                  CALL SAVENON (9, AA, KL, LB, LA, LB, LA, JA, JB, 0)
               ENDIF
!                IF(DABS(AA).GT.EPS)
!     :                         WRITE(78,556) AA,KL,LJ(IA),LJ(IB),JA,JB
  556          FORMAT(1X,'1212 O-O','AA=',F17.7,'K=',I3,'LA=',2I3,'JA=',I4,&
                  'JB=',I4)
            END DO
         ENDIF
      ENDIF
!
!     CASES 1221   + + - -        TRANSFORM TO  1122   + - + -
!           2112                                1122
!
      IP2 = IABS(LJ(IB)-LJ(IA)) + 1
      IG2 = LJ(IB) + LJ(IA) + 1
      IGAL = 2
      IF (IORBORB == 1) IGAL = 1
      DO I2 = IP2, IG2, IGAL
         KL = I2 - 1
         IF (.NOT.CALCULATION(KL)) CYCLE
         IF (ICOLOM + ISOTOP == 1) CALL COULOMBLS (LJ(IA), LJ(IB), LJ(IB), LJ(&
            IA), KL, A1)
         IF (IORBORB == 1) CALL ORBITORBIT (LJ(IA), LJ(IB), LJ(IB), LJ(IA), KL&
             + 1, A2)
         IF (DABS(A1) + DABS(A2) <= EPS) CYCLE
         AB = ZERO
         DO I3 = 1, IG1
            L12 = I3 - 1
            AC = ZERO
            IF (IXJTIK(LIA2,LIB2,KL*2,LIB2,LIA2,L12*2) == 0) CYCLE
            DO I13 = 1, 2
               IF (.NOT.IATT(I13)) CYCLE
               AA = PMG(I3,I13)
               AA = AA*RAG(I3,I13)
               AA = AA*DSQRT(DBLE(2*(I13 - 1) + 1))
               IF (I13 == 1) AA = -AA
               AC = AC + AA
            END DO
            IF (DABS(AC) <= EPS) CYCLE
            CALL SIXJ (LIA2, LIB2, KL*2, LIB2, LIA2, L12*2, 0, SI)
            AA = AC*SI*DSQRT(DBLE(2*L12 + 1))
            AB = AB + AA
         END DO
         IF (DABS(AB) <= EPS) CYCLE
         ABB = AB
         IF (ICOLOM + ISOTOP == 1) THEN
            AB = A1*AB
            IF (DABS(AB) > EPS) CALL SAVENON (2, AB, KL, 0, LA, 0, LB, JA, JB, &
               0)
         ENDIF
! Orbit 1221
         IF (IORBORB /= 1) CYCLE
         IF (DABS(A2) <= EPS) CYCLE
         KLL = KL - 1
         ABB = A2*ABB*HALF/DSQRT(DBLE(2*KL + 1))
         CALL SAVENON (9, ABB, KLL, LA, LB, LB, LA, JA, JB, 0)
         CALL SAVENON (9, ABB, KLL, LB, LA, LA, LB, JA, JB, 0)
!                 WRITE(79,656) ABB,KLL,LJ(IA),LJ(IB),JA,JB
  656    FORMAT(1X,'1221 O-O','AA=',F17.7,'K=',I3,'LA=',2I3,'JA=',I4,'JB=',I4)
      END DO
      RETURN
      END SUBROUTINE NONRELAT1


text:
"!" !%!&)$+#("( %/-$,$-1&/5&2-)0-'"%!&*#))-,,.4*25/#8**#'2--5(8(+35#,.46&0?;C?MASQ9=2FOPEINVUVE<923);+,<<9H2A8+)&$>$97.+=:HD;9?()'131::37/2@<+3.?7633#@*/&*)+9%--,.1+5553154.0(.43818+<02/?9KZV\rYlZUJDPK/;.$.*,/47)9236'/54"/B5374,/?+5B2-48=/5@5.,8'C-=(291+A@)7*+36>855:9=33;849;4:+'7*770J7K:WEAF;C1213%6..1(%.-4,6/;/3.%3.+"5196-7550B@<3)/-)55":,2('%$/(206>02@5-8?A4ABE@751<.$.323!%8 .)# !).!-&./,&,6%(-"2%#1*$%%,##(%3'// $&0++*&-#,%/.2A66KKFA57541"&3-&+&/"'.#*9+:422.;!,0#+2"3*7("")  $+#,"&(&#*##$)#$* -;4<<F?C*4'*-!%# $&!)&&&#"!%!##%(,*/7@4-5.@;G*- "%!"((&(##&.$&!##($*'&*-/+.,,$%#+#$)'(3+!#

 %!)(;+'+4*3.%))

	 +/&*0G2::FC.094)

max_stars_repo_name: kilir/examples

max_issues_repo_name: kilir/examples

max_forks_repo_name: kilir/examples


text:
*DECK OHTROL
      SUBROUTINE OHTROL (Q, N, NRDA, DIAG, IRANK, DIV, TD)
C***BEGIN PROLOGUE  OHTROL
C***SUBSIDIARY
C***PURPOSE  Subsidiary to BVSUP
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (OHTROL-S, DOHTRL-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C     For a rank deficient problem, additional orthogonal
C     HOUSEHOLDER transformations are applied to the left side
C     of Q to further reduce the triangular form.
C     Thus, after application of the routines ORTHOR and OHTROL
C     to the original matrix, the result is a nonsingular
C     triangular matrix while the remainder of the matrix
C     has been zeroed out.
C
C***SEE ALSO  BVSUP
C***ROUTINES CALLED  SDOT
C***REVISION HISTORY  (YYMMDD)
C   750601  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  OHTROL
      DIMENSION Q(NRDA,*),DIAG(*),DIV(*),TD(*)
C***FIRST EXECUTABLE STATEMENT  OHTROL
      NMIR=N-IRANK
      IRP=IRANK+1
      DO 30 K=1,IRANK
         KIR=IRP-K
         DIAGK=DIAG(KIR)
         SIG=(DIAGK*DIAGK)+SDOT(NMIR,Q(IRP,KIR),1,Q(IRP,KIR),1)
         DD=SIGN(SQRT(SIG),-DIAGK)
         DIV(KIR)=DD
         TDV=DIAGK-DD
         TD(KIR)=TDV
         IF (K .EQ. IRANK) GO TO 30
         KIRM=KIR-1
         SQD=DD*DIAGK-SIG
         DO 20 J=1,KIRM
            QS=((TDV*Q(KIR,J))+SDOT(NMIR,Q(IRP,J),1,Q(IRP,KIR),1))
     1               /SQD
            Q(KIR,J)=Q(KIR,J)+QS*TDV
            DO 10 L=IRP,N
   10          Q(L,J)=Q(L,J)+QS*Q(L,KIR)
   20    CONTINUE
   30 CONTINUE
      RETURN
      END


text:
      subroutine lagdat (ia,iex)
c        * non diagonal lagrange parameteres *
c lagrange parameters involving orbital ia if ia is positive
c all lagrange parameters are calculated if ia is negative or zero
c contribution of the exchange terms is omitted if iex=0
c        this program uses akeato(bkeato) fdrirk multrk

      implicit double precision (a-h,o-z)
      common/itescf/testy,rap(2),teste,nz,norb,norbsc
      common/ratom1/xnel(30),en(30),scc(30),scw(30),sce(30),
     1nq(30),kap(30),nmax(30)
      common/scrhf1/eps(435),nre(30),ipl
      dimension ni(2),nj(2)
c#mn
       external akeato, bkeato, fdrirk

      i1= max(ia,1)
      idep=1
      if (ia.gt.0) go to 15
 11   idep=i1+1
 15   ni(1)=i1
      nj(2)=i1
      ji1=2* abs(kap(i1))-1
      do 201 i2=idep,norbsc
         if (i2.eq.i1.or.kap(i2).ne.kap(i1)) go to 201
         if (nre(i1).lt.0.and.nre(i2).lt.0) go to 201
c the following line was included to handle the case of 1 electron in
c 2 s-shells.
c Probably need to use schmidt orthogonalization in this case
         if (xnel(i1).eq.xnel(i2)) go to 201
         ni(2)=i2
         nj(1)=i2
         d=0.0d 00
         do 101 l=1,norbsc
            k=0
            jjl=2* abs(kap(l))-1
            kma= min(ji1,jjl)
 41         a=akeato(l,i1,k)/xnel(i1)
            b=a-akeato(l,i2,k)/xnel(i2)
            c=b
            if (a.ne.0.0d 00) c=c/a
            if ( abs(c).lt.1.0d-07) go to 51
            d=d+b*fdrirk(l,l,i1,i2,k)
 51         k=k+2
            if (k.le.kma) go to 41
            if (iex.eq.0) go to 101
            kma=(ji1+jjl)/2
            k= abs(jjl-kma)
            if ((kap(i1)*kap(l)).lt.0) k=k+1
 61         a=bkeato(l,i2,k)/xnel(i2)
            b=a-bkeato(l,i1,k)/xnel(i1)
            c=b
            if (a.ne.0.0d 00) c=c/a
            if ( abs(c).lt.1.0d-07) go to 71
            d=d+b*fdrirk(i1,l,i2,l,k)
 71         k=k+2
            if (k.le.kma) go to 61
 101     continue
         i= min(i1,i2)
         j= max(i1,i2)
         eps(i+((j-1)*(j-2))/2)=d/(xnel(i2)-xnel(i1))
 201  continue
      if (ia.gt.0) go to 999
      i1=i1+1
      if (i1.lt.norbsc) go to 11
 999  return
      end


text:
Subroutine momntm(px, py, pz, e)
  Implicit Double Precision (A-H, O-Z)
  External ran1
  Parameter (pi=3.14159265358979D0)
  Common /rndm3/iseedp
  Save
  iseed = iseedp
  cost = 2D0*ran1(iseed) - 1D0
  sint = dsqrt(1D0-cost**2)
  phi = 2D0*pi*ran1(iseed)
  px = e*sint*cos(phi)
  py = e*sint*sin(phi)
  pz = e*cost
  Return
End Subroutine momntm

max_stars_repo_name: xiaohaijin/AMPT

max_issues_repo_name: xiaohaijin/AMPT

max_forks_repo_name: xiaohaijin/AMPT


text:
!     Check replacement of non-affine loop bounds

!     Bug found in BU_INTER_su2cor.f, loop 200, subroutine LOOPS

!     The bug is reproduced with property PARSER_LINEARIZE_LOOP_BOUNDS

      program loop_bound01

      real a(16)

      n = 4
!     U_0 is going to be used
      do i = 1, 2**n
         a(i) = 0.
      enddo

!     Oops, U_0 is going to be re-used
      do i = 1, 2**n
         a(i) = float(i)
      enddo

      end


text:
!     -*- Mode: Fortran; -*-
!  (C) 2008 by Argonne National Laboratory.
!       See COPYRIGHT in top-level directory.
        MODULE MPI_CONSTANTS
        IMPLICIT NONE
        INCLUDE 'mpifnoext.h'
        TYPE :: MPI_Status
           SEQUENCE
           INTEGER :: MPI_SOURCE, MPI_TAG, MPI_ERROR
           INTEGER :: count_lo
           INTEGER :: count_hi_and_cancelled
        END TYPE MPI_Status
       TYPE :: MPI_Info
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_Info
       TYPE :: MPI_Request
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_Request
       TYPE :: MPI_Comm
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_Comm
       TYPE :: MPI_Win
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_Win
       TYPE :: MPI_File
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_File
       TYPE :: MPI_Message
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_Message
       TYPE :: MPI_Errhandler
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_Errhandler
       TYPE :: MPI_Group
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_Group
       TYPE :: MPI_Datatype
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_Datatype
       TYPE :: MPI_Op
          SEQUENCE
          INTEGER :: MPI_VAL
       END TYPE MPI_Op
        INTERFACE OPERATOR(.EQ.)
            MODULE PROCEDURE infoeq
            MODULE PROCEDURE requesteq
            MODULE PROCEDURE commeq
            MODULE PROCEDURE wineq
            MODULE PROCEDURE fileeq
            MODULE PROCEDURE messageeq
            MODULE PROCEDURE errhandlereq
            MODULE PROCEDURE groupeq
            MODULE PROCEDURE datatypeeq
            MODULE PROCEDURE opeq
        END INTERFACE
        INTERFACE OPERATOR(.NE.)
            MODULE PROCEDURE infoneq
            MODULE PROCEDURE requestneq
            MODULE PROCEDURE commneq
            MODULE PROCEDURE winneq
            MODULE PROCEDURE fileneq
            MODULE PROCEDURE messageneq
            MODULE PROCEDURE errhandlerneq
            MODULE PROCEDURE groupneq
            MODULE PROCEDURE datatypeneq
            MODULE PROCEDURE opneq
        END INTERFACE
        CONTAINS
            LOGICAL FUNCTION infoeq(lhs,rhs)
            TYPE(MPI_Info), INTENT(IN) :: lhs, rhs
            infoeq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION infoeq
            LOGICAL FUNCTION infoneq(lhs,rhs)
            TYPE(MPI_Info), INTENT(IN) :: lhs, rhs
            infoneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION infoneq
            LOGICAL FUNCTION requesteq(lhs,rhs)
            TYPE(MPI_Request), INTENT(IN) :: lhs, rhs
            requesteq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION requesteq
            LOGICAL FUNCTION requestneq(lhs,rhs)
            TYPE(MPI_Request), INTENT(IN) :: lhs, rhs
            requestneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION requestneq
            LOGICAL FUNCTION commeq(lhs,rhs)
            TYPE(MPI_Comm), INTENT(IN) :: lhs, rhs
            commeq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION commeq
            LOGICAL FUNCTION commneq(lhs,rhs)
            TYPE(MPI_Comm), INTENT(IN) :: lhs, rhs
            commneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION commneq
            LOGICAL FUNCTION wineq(lhs,rhs)
            TYPE(MPI_Win), INTENT(IN) :: lhs, rhs
            wineq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION wineq
            LOGICAL FUNCTION winneq(lhs,rhs)
            TYPE(MPI_Win), INTENT(IN) :: lhs, rhs
            winneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION winneq
            LOGICAL FUNCTION fileeq(lhs,rhs)
            TYPE(MPI_File), INTENT(IN) :: lhs, rhs
            fileeq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION fileeq
            LOGICAL FUNCTION fileneq(lhs,rhs)
            TYPE(MPI_File), INTENT(IN) :: lhs, rhs
            fileneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION fileneq
            LOGICAL FUNCTION messageeq(lhs,rhs)
            TYPE(MPI_Message), INTENT(IN) :: lhs, rhs
            messageeq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION messageeq
            LOGICAL FUNCTION messageneq(lhs,rhs)
            TYPE(MPI_Message), INTENT(IN) :: lhs, rhs
            messageneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION messageneq
            LOGICAL FUNCTION errhandlereq(lhs,rhs)
            TYPE(MPI_Errhandler), INTENT(IN) :: lhs, rhs
            errhandlereq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION errhandlereq
            LOGICAL FUNCTION errhandlerneq(lhs,rhs)
            TYPE(MPI_Errhandler), INTENT(IN) :: lhs, rhs
            errhandlerneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION errhandlerneq
            LOGICAL FUNCTION groupeq(lhs,rhs)
            TYPE(MPI_Group), INTENT(IN) :: lhs, rhs
            groupeq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION groupeq
            LOGICAL FUNCTION groupneq(lhs,rhs)
            TYPE(MPI_Group), INTENT(IN) :: lhs, rhs
            groupneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION groupneq
            LOGICAL FUNCTION datatypeeq(lhs,rhs)
            TYPE(MPI_Datatype), INTENT(IN) :: lhs, rhs
            datatypeeq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION datatypeeq
            LOGICAL FUNCTION datatypeneq(lhs,rhs)
            TYPE(MPI_Datatype), INTENT(IN) :: lhs, rhs
            datatypeneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION datatypeneq
            LOGICAL FUNCTION opeq(lhs,rhs)
            TYPE(MPI_Op), INTENT(IN) :: lhs, rhs
            opeq = lhs%MPI_VAL .EQ. rhs%MPI_VAL
            END FUNCTION opeq
            LOGICAL FUNCTION opneq(lhs,rhs)
            TYPE(MPI_Op), INTENT(IN) :: lhs, rhs
            opneq = lhs%MPI_VAL .NE. rhs%MPI_VAL
            END FUNCTION opneq
        END MODULE MPI_CONSTANTS

max_stars_repo_name: valiantljk/collectiveIO-profile

max_issues_repo_name: valiantljk/collectiveIO-profile

max_forks_repo_name: valiantljk/collectiveIO-profile


text:
Subroutine pi2et2(i1, i2, lbb1, lbb2, ei1, ei2, iblock, iseed)
  Parameter (maxstr=150001)
  Parameter (ap1=0.13496, ap2=0.13957, etam=0.5475)
  Common /ee/id(maxstr), lb(maxstr)
  Common /ppb1/ene, factr2(6), fsum, ppinnb, s, wtot
  Common /ppmm/pprr, ppee, pppe, rpre, xopoe, rree
  Common /rndf77/nseed
  Save
  If ((lb(i1)>=3 .And. lb(i1)<=5) .And. (lb(i2)>=3 .And. lb(i2)<=5)) Then
    iblock = 1860
    ei1 = etam
    ei2 = etam
    lbb1 = 0
    lbb2 = 0
  Else If (lb(i1)==0 .And. lb(i2)==0) Then
    iblock = 1861
    lbb1 = 3 + int(3*ranart(nseed))
    lbb2 = 3 + int(3*ranart(nseed))
    ei1 = ap2
    ei2 = ap2
    If (lbb1==4) ei1 = ap1
    If (lbb2==4) ei2 = ap1
  End If
  Return
End Subroutine pi2et2


text:
	SUBROUTINE AW_SVER ( bdata, irept, iff, iret )
C************************************************************************
C* AW_SVER                                                              *
C*                                                                      *
C* This subroutine is the systems version block.  It identifies the     *
C* version that the graphics file was encoded.  This subroutine         *
C* represents mode 2, submode 5.              	                        *
C* 								        *
C* AW_SVER ( BDATA, IREPT, IFF, IRET )                        	*
C*								        *
C* Input parameters: 						        *
C*      BDATA(*) BYTE		Byte data array                         *
C*      IREPT   INTEGER         Beginning byte position for the block   *
C*      IFF     INTEGER         Length and checksum indicator           *
C*								        *
C* Output parameters:						        *
C*	IRET	INTEGER		Return code                             *
C**								        *
C* Log:									*
C* A. Hardy/GSC          7/98                                           *
C* T. Piper/GSC		11/98	Updated prolog				*
C* A. Hardy/GSC		 3/99   Updated prolog				*
C* A. Hardy/GSC         10/00   Put file number and dbug in awcmn.cmn	*
C* T. Piper/SAIC	 2/03	Changed b to bdata and added INT	*
C************************************************************************
 	INCLUDE         'awcmn.cmn'
C*
	BYTE		bdata(*)
	CHARACTER*40    verid
        INTEGER         icnt
C------------------------------------------------------------------------
 	iret = 0
	icnt = irept + 3
C
C*      Get the 4 character version number.
C
        DO i = 1, 4
	    verid(i:i) = CHAR(INT(bdata(icnt+i)))
        END DO
	icnt = icnt + 5
	IF ( dbug .eq. 'y' ) THEN
	    write(flun,*)'VERSION NUMBER'
	    write(flun,36)verid
 36         format(a4)
        END IF
C
	IF ( dbug .eq. 'y' ) THEN
           IF ( iff .eq. 0 ) write (flun,*)'Checksum found.'
        END IF
C*
	RETURN
	END

max_stars_repo_name: oxelson/gempak

max_issues_repo_name: oxelson/gempak

max_forks_repo_name: oxelson/gempak