text:
      module phiotimer
      enum, bind(C)
        enumerator :: GEOMBC_READ, RESTART_READ, RESTART_WRITE
      end enum
      interface
        subroutine phastaio_setfile(fileidx)
     &   bind(C, NAME='phastaio_setfile')
        use :: iso_c_binding
          integer(c_int), intent(in), value:: fileidx
        end subroutine
      end interface
      end module

ext: f

max_stars_repo_name: polmes/phasta

max_issues_repo_name: polmes/phasta

max_forks_repo_name: polmes/phasta


text:
!==============================================================================!
  logical function Math_Mod_Approx_String(s, t, tol)
!------------------------------------------------------------------------------!
!   For all i and j, d[i,j] will hold the Levenshtein distance between the     !
!   first "i" characters of "s" and the first "j" characters of "t".           !
!                                                                              !
!   Check for details here: https://tinyurl.com/y857p2hf                       !
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  character(*)      :: s, t  ! source and target strings
  integer, optional :: tol   ! number of tolerated misstyped characters
!-----------------------------------[Locals]-----------------------------------!
  integer              :: i, j, m, n, cost, tolerance
  integer, allocatable :: d(:,:)
!==============================================================================!

  if( .not. present(tol) ) then
    tolerance = 3
  else
    tolerance = tol
  end if

  m = len_trim(s)
  n = len_trim(t)

  ! Declare int d[0..m, 0..n], and set each element in d to zero
  allocate(d(0:m, 0:n));  d(:,:) = 0

  ! Source prefixes can be transformed into ...
  ! ... empty string by dropping all characters
  do i = 1, m
    d(i, 0) = i
  end do

  ! Target prefixes can be reached from empty ...
  ! ... source prefix by inserting every character
  do j = 1, n
    d(0, j) = j
  end do

  do j = 1, n
    do i = 1, m
      if(s(i:i) .eq. t(j:j)) then
        cost = 0
      else
        cost = 1
      end if
      d(i, j) = min(d(i-1, j  ) + 1,           &   ! deletion
                    d(i,   j-1) + 1,           &   ! insertion
                    d(i-1, j-1) + cost)            ! substitution
    end do
  end do

  if( d(m,n) > 0 .and. d(m,n) <= tolerance ) then
    Math_Mod_Approx_String = .true.
  else
    Math_Mod_Approx_String = .false.
  end if

  end function

max_issues_repo_name: EdinSmartLab/T-Flows

max_forks_repo_name: EdinSmartLab/T-Flows


text:
1ere Session, 36 e Legislature,
Volume 137, Numero 155
Le jeudi 9 septembre 1999
L'honorable Gildas L. Molgat, President
Le deces de l'honorable Robert Rene de Cotret, c.p.
Le deces de l'honorable Alan Macnaughton, c.p., c.r., OC
Le deces de Jean Drapeau
L'effondrement de la peche au saumon rouge dans le fleuve Fraser
Mesures legislatives visant a interdire le don d'organe selectif
Projet de loi canadien sur la protection de l'environnement (1999)
Section canadienne de l'Eglise morave d'Amerique-Rapport du comite
La Loi sur le Parlement du Canada
Projet de loi modificatif-Premiere lecture
Avis d'interpellation-La jeunesse- la dimension politique
Distinctions decernees a des Canadiens par le Royaume-Uni
Projet de loi sur l'office d'investissement des regimes de pensions du secteur public
La Loi canadienne sur la protection de l'environnement (1999)
Les Poursuites contre les passeurs d'immigrants illegaux
Les consequences possibles des compressions budgetaires sur l'avenir des Snowbirds- La position du Gouvernement
Projet de loi sur l'Office d'investissement des regimes de pensions du secteur public
Projet de loi sur l'Office d'investissement des regimes de pensions du secteur public
Troisieme lecture-Suite du debat
Privileges, Reglement et procedure
Le douzieme rapport du comite-Motion d'adoption-Ajournement du debat
Le onzieme rapport du comite-Motion d'adoption-Motion d'amendement- Ajournement du debat
Le Dragon Boat Festival
La situation critique des migrants chinois sur la cote ouest-Interpellation-Ajournement du debat
Le jeudi 9 septembre 1999
La seance est ouverte a 14 heures, le President etant au fauteuil.
Le deces de l'honorable Robert Rene de Cotret, c.p.
Son arrivee ici, apres une defaite electorale, n'etait pas vue de facon favorable.
Toutefois, ses realisations ici ont fait taire toutes les critiques.
La periode des questions au Senat devint un seminaire sur la politique economique.
Sa carriere senatoriale a pris fin avec la convocation des elections generales de 1980.
Il s'est porte candidat dans le comte de Berthier-Maskinonge, au Quebec.
Environ 600 personnes etaient presentes a sa messe d'inhumation.
Heureux le pays qui puisse attirer de tels citoyens a son service.
L'honorable Pierre De Bane :
Il a mis son intelligence et son experience au service de tous les Canadiens.
Je ne peux tolerer la malhonnetete intellectuelle.
Le deces de l'honorable Alan Macnaughton, c.p., c.r., OC
L'honorable Celine Hervieux-Payette :
J'ai ete impressionnee par sa vitalite, sa modestie et son sens de l'humour.
En tout, il fut pendant 29 ans au service du Parlement du Canada.
Son acharnement au travail est legendaire.
J'aimerais rappeler quelques anecdotes a son sujet.
C'est un titre de gloire, surtout lorsque que le compliment vient de l'opposition.
Louis St. Laurent, John G. Diefenbaker, Lester B. Pearson et Pierre Elliott Trudeau.
Alan Macnaughton n'a jamais subi la defaite en tant que candidat aux elections federales.
Il a cede son siege au premier ministre...
[...] une des erreurs qu'il a commises.
Il ajouta en conclusion:
Ce genre de personne est rare en politique.
Il faisait toujours preuve de modestie et de ponderation dans ses propos.
Le senateur Macnaughton a certainement fait honneur a tous les siens.
Les membres de sa nombreuse famille peuvent etre fiers de sa contribution au Canada.
Il aura enrichi le pays par son talent et par son travail.
L'honorable Alan Macnaughton aura vecu pres d'un siecle.
Il est devenu conseiller prive en 1965.
Sa carriere juridique fut egalement tres interessante.
Il s'interessa aussi a plusieurs autres domaines.
Aux membres de sa famille, je desire offrir mes plus profondes condoleances.
Il m'a mise a l'aise.
Il m'a dit: Ne vous laissez pas intimider.
Ayez le courage de vos convictions et laissez-vous guider simplement par votre conscience.
Beaucoup d'entre nous aimeraient avoir ce genre de dossier; sans tache, pour ainsi dire.
Son travail et son experience l'ont mene partout au monde.
Il semble meme qu'il ait deja presente des exposes sur le role du Senat.
Le senateur Macnaughton etait tres fier de sieger au Senat.
Le service funebre etait vraiment une celebration de la vie du senateur Macnaughton.
L'honorable Marcel Prud'homme :
Je voudrais dire un mot a ce sujet.
Il avait vigoureusement fait campagne, discretement, pour l'honorable Alan Macnaughton.
Je conserve precieusement le souvenir du fameux debat sur le drapeau.
Si on compte les annees de service, je serai toujours le deuxieme apres lui.
Ceux qui ont assiste a ce debat ont participe a un veritable debat passionnel.
C'etait un cadeau du peuple canadien-francais, surtout du Quebec, au Canada.
Il faut quand meme avoir de la memoire.
Vous pensez sans doute que le debat sur la TPS au Senat a ete epouvantable.
Je vais laisser l'histoire en juger.
Le Canada a obtenu officiellement son drapeau le 15 fevrier 1965.
Je me devais d'etre present.
Le senateur Finestone et moi-meme etions les seules personnes presentes.
Je remercie le senateur Finestone de me le rappeler.
Le deces de Jean Drapeau
L'honorable John Lynch-Staunton (chef de l'opposition) :
Le mot medisance ne faisait pas partie de son vocabulaire.
Deux mots definissent admirablement bien la carriere deJean Drapeau: integrite et vision.
Comme l'a si bien dit son ancien adversaire politique, Jean Dore:
Jean Drapeau a rendu les Montrealais fiers et confiants d'eux-memes face au monde.
Physiquement, il n'impressionnait guere.
Cela ne s'est pas produit, bien entendu.
Il aimait Montreal avec une passion inebranlable.
Rien n'etait trop beau, nul projet n'etait trop fou pour Montreal.
Il caressait de grands reves et ses concitoyens l'aimaient pour cela.
Il y a eu un moment de silence.
Elle l'a applaudi chaleureusement pour l'aider a surmonter son emotion.
L'honorable Marcel Prud'homme :
Si je disais la verite, plusieurs personnes en seraient genees.
L'image que l'on a creee de Jean Drapeau a toujours ete erronee.
Mon pere etait conseiller municipal independant de la Ville de Montreal.
Il avait raison a l'epoque et il a encore raison aujourd'hui.
Ce serait beaucoup plus sain pour la democratie.
Je m'excuse de le dire au Senat.
En temps utile, nous l'expliquerons.
Vous pouvez constater les contradictions.
Je dis aux conservateurs que Jean Drapeau aurait pu etre votre chef.
Il a pris son chapeau et il est retourne a Montreal.
Cela a ete la fin de sa tentation federale.
Il avait ses defauts.
Dieu sait que le senateur Fraser a su tres souvent nous les rappeler!
Vers la fin, lorsque tout le monde a applaudi, elle-meme a ete tres emue.
Son Honneur le President :
Les senateurs sont-ils d'accord pour que nous entendions ces trois senateurs?
L'effondrement de la peche au saumon rouge dans le fleuve Fraser
Elle n'a jamais ete fermee auparavant.
Ce niveau de collaboration est aussi sans precedent.
Les precedents sont la.
Mesures legislatives visant a interdire le don d'organe selectif
L'honorable Donald H. Oliver :
Les statistiques sur les dons brossent un tableau tout aussi peu reluisant.
Une vie est une vie, quelle que soit la couleur de la peau.
L'honorable Jerahmiel S. Grafstein :
Honorables senateurs, vous etes-vous jamais demande ou en serait le Senat sans les imprimes?
Apres tout, ne sommes-nous pas de simples marchands de mots?
Ou serions-nous, honorables senateurs, sans les Debats du Senat ?
Sans les imprimes, les senateurs laisseraient une trace beaucoup trop delebile dans l'histoire.
Certains jours, d'aucuns diraient que l'idee n'est pas si mauvaise.
Je remercie Richard Greene d'avoir attire mon attention sur son depart.
Jeanie s'est jointe a l'equipe du Senat en fevrier 1983.
Rudyard Kipling a ecrit un jour:
Le travail que Jeanie a fait sur nos mots a rehausse le pouvoir du Senat.
Projet de loi canadien sur la protection de l'environnement (1999)
Le jeudi 9 septembre 1999
( Le texte de l'annexe figure en annexe des Journaux duSenat, p. 1843 )
Son Honneur le President :
Honorables senateurs, quand lirons-nous le projet de loi une troisieme fois?
Section canadienne de l'Eglise morave d'Amerique-Rapport du comite
Le jeudi 9 septembre 1999
Son Honneur le President :
Honorables senateurs, quand lirons-nous ce projet de loi une troisieme fois?
La Loi sur le Parlement du Canada
Projet de loi modificatif-Premiere lecture
(Le projet de loi est lu une premiere fois.)
Son Honneur le President :
Honorables senateurs, quand lirons-nous ce projet de loi une deuxieme fois?
Avis d'interpellation-La jeunesse- la dimension politique
L'honorable Jean-Robert Gauthier :
Distinctions decernees a des Canadiens par le Royaume-Uni
L'honorable Anne C. Cools :
i ) les propos que le premier ministre R.B. Bennett a tenus en 1934:
Projet de loi sur l'office d'investissement des regimes de pensions du secteur public
L'honorable John Lynch-Staunton (chef de l'oppositon) :
La Loi canadienne sur la protection de l'environnement (1999)
L'honorable John Lynch-Staunton (chef de l'opposition) :
C'est effectivement le cas.
Il presume que le surplus appartient entierement au gouvernement.
Telle est en substance la question de l'honorable senateur.
Je presume que oui, mais je ne le sais pas.
Franchement, c'est une question de droit dont je ne connais pas la reponse.
Je soupconne que personne ne peut y repondre categoriquement, car tout depend du jugement.
Toutefois, j'ai pour le moment besoin d'eclaircissements.
Honorables senateurs, je dois soulever une objection.
C'est une toute autre question.
Laissez-moi continuer avec l'expose de M. Hornby.
A la meme occasion, il a dit:
On ne peut pas disposer de quelque chose qui ne nous appartient pas.
On n'est pas cense le faire, en tout cas.
M. Hornby continue en ces termes:
Nous ne sommes pas ici pour regler la question de la propriete.
Cette question sera tranchee par les tribunaux.
On y conteste le droit d'amortir le surplus.
La difference est de taille.
Selon moi, Son Honneur devrait reflechir a cet aspect, a un moment donne.
Je repondrai en signalant deux points.
Elles ne portent pas sur le surplus comme tel, comme vous l'avez dit.
Cela n'empeche certainement pas les demandeurs de poursuivre ces causes.
Ma question s'adresse au leader du gouvernement au Senat.
La province pense que la facture pourrait s'elever a 25 millions de dollars.
L'honorable B. Alasdair Graham (leader du gouvernement) :
On me dit que des discussions sont en cours en ce moment meme.
Elle inquiete les Canadiens d'un ocean a l'autre.
J'espere qu'une solution va etre trouvee tres bientot.
Je sais que le probleme est serieux.
Plusieurs ministeres federaux travaillent de concert afin d'intervenir si d'autres bateaux arrivaient.
Il s'agit d'un probleme international qui necessite des solutions au niveau international.
Le trafic de personnes est une source de grande preoccupation.
Il constitue une violation des lois canadiennes et met en danger des vies humaines.
Nous devons trouver une solution a long terme a l'utilisation abusive de ce systeme.
Les Poursuites contre les passeurs d'immigrants illegaux
L'honorable Donald H. Oliver :
On y dit ce qui suit au sujet des immigrants:
Quand les Canadiens peuvent-ils esperer que ces passeurs seront poursuivis en justice?
L'honorable B. Alasdair Graham (leader du gouvernement) :
Les autorites chinoises ont declare que ces pretendus refugies devraient etre renvoyes en Chine.
Ce sont les Britannico-Colombiens qui ecopent.
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Avons-nous l'assurance que l'Indonesie collaborera?
Quand la force internationale sera-t-elle operationnelle?
L'honorable B. Alasdair Graham (leader du gouvernement) :
Son Honneur le President :
Honorables senateurs, nous avons tout un probleme.
L'honorable Marcel Prud'homme :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Ce serait un desastre.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Honorables senateurs, j'ai une question complementaire.
Honorables senateurs, je ne peux demander rien de tel a un comite.
Je ne suis membre d'aucun comite.
Je suis sur qu'il y a ici des membres du comite.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Nous avons siege mardi et mercredi et c'est aujourd'hui jeudi.
Cela fait trois jours, et nous siegeons demain.
Je renvoie egalement les senateurs au paragraphe 47(5), qui dit ceci:
L'honorable B. Alasdair Graham (leader du gouvernement) :
Le ministre deposera-t-il le decret lundi prochain?
Honorables senateurs, j'essaierai de communiquer avec le ministre des Transports.
Je sais qu'il a l'intention de deposer le document dans le delai prevu.
Honorables senateurs, qui donc a la responsabilite de deposer ce rapport au Senat?
Le ministre des Transports n'est pas membre de notre Chambre.
Vous chargerez-vous de le deposer?
Je verrai a ce qu'il soit depose le plus tot possible.
Les consequences possibles des compressions budgetaires sur l'avenir des Snowbirds- La position du Gouvernement
L'honorable A. Raynell Andreychuk :
Les Snowbirds sont un excellent exemple de tout cela.
Ils ont d'ailleurs une reputation a l'echelle internationale.
L'honorable B. Alasdair Graham (leader du gouvernement) :
C'est la pratique courante.
C'est ainsi que j'interprete la reponse du premier ministre.
L'honorable Fernand Robichaud (Son Honneur le President suppleant) :
Honorables senateurs, la periode reservee aux questions est maintenant ecoulee.
Deux autres senateurs voudraient poser des questions.
La permission de prolonger la periode des questions est-elle accordee?
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Honorables senateurs, nous autorisons ces deux senateurs a poser leurs questions.
Il s'agit bien sur du senateur Andreychuk et du senateur Forrestall.
Son Honneur le President suppleant :
La permission est-elle accordee, honorables senateurs?
L'honorable J. Michael Forrestall :
Envisage-t-on de prendre des mesures dans un avenir tres prochain?
L'honorable B. Alasdair Graham (leader du gouvernement) :
C'est une priorite pour lui.
L'honorable Donald H. Oliver :
Quelles sommes ont ete engagees en vue de la decontamination des lieux?
L'honorable B. Alasdair Graham (leader du gouvernement) :
Honorables senateurs, je remercie l'honorable senateur Oliver pour sa question.
Nous avons tenu plusieurs reunions.
L'an dernier, nous avons recu un protocole d'entente du groupe d'action mixte.
Je remercie l'honorable senateur d'avoir porte ce dossier a notre attention.
Quand les travaux debuteront-ils?
Projet de loi sur l'Office d'investissement des regimes de pensions du secteur public
Permission ayant ete accordee de revenir a la presentation de petitions:
Projet de loi sur l'Office d'investissement des regimes de pensions du secteur public
Troisieme lecture-Suite du debat
Le niveau de risque est trop faible pour constituer un facteur dans ce debat.
Examinons de plus pres la pretention du gouvernement.
... les risques supportes et la politique du Conseil du Tresor sont interdependants.
Il est difficile de definir l'un de ces concepts sans vraiment connaitre l'autre.
Cela ne represente pas la prise en charge du risque.
Le gouvernement n'a pas eponge ces deficits tout seul.
Il y a deux genres de regimes de retraite.
Revenons maintenant a 1999. La meme chose se produit de nouveau.
Ces gens pourraient recevoir ou ne pas recevoir ce qui leur a ete promis.
Le gouvernement n'assume absolument aucun risque.
Les arguments du gouvernement ne tiennent tout simplement pas la route.
Le point de friction est le surplus deja accumule.
Pourquoi donc ces dispositions se retrouvent-elles dans le projet de loi?
Par consequent, je propose, appuye par l'honorable senateur Tkachuk:
Son Honneur le President suppleant :
Vous plait-il, honorables senateurs, d'adopter la motion d'amendement?
Son Honneur le President suppleant :
Son Honneur le President suppleant :
Que les senateurs qui sont contre veuillent bien dire non.
Son Honneur le President suppleant :
A mon avis, les non l'emportent.
Et deux senateurs s'etant leves:
Son Honneur le President suppleant :
(La motion d'amendement, mise aux voix, est rejetee.)
Son Honneur le President :
L'honorable Nicholas W. Taylor :
Honorables senateurs, j'aimerais apporter quelques commentaires.
Honorables senateurs, je voudrais poser une question a l'honorable senateur.
Quelqu'un apparait toujours a un moment donne.
L'honorable Edward M. Lawson :
Honorables senateurs, je voudrais faire un bref commentaire sur la question dont nous sommes saisis.
Les representants militaires ont pose une question interessante.
Prenez-les en pension ou en salaire, cela ne nous derange pas.
La premiere provient de la division de Vancouver de l'Association nationale des retraites federaux.
C'est tres clair.
J'ai apprecie l'echange des senateurs Kirby et Lynch-Staunton sur l'equite.
Je n'ai jamais entendu de telles sottises.
Laissez les tribunaux en decider.
Laissez-leur une chance d'en decider.
Les avocats du gouvernement redigent deja leur declaration preliminaire aux tribunaux.
Ils diront: Votre Honneur, pourquoi en sommes-nous la?
De surcroit, les parlementaires nous ont autorises a en disposer.
Il est le guetteur arriere d'un vol de regime de pension.
Il y a une autre chose que nous devrions prendre en consideration.
La GRC est une organisation paramilitaire.
La chose n'est pas nouvelle.
Elles ont pourtant eu droit a quelque chose.
Il vaudrait mieux leur annoncer la chose immediatement.
Quel bureaucrate sans coeur a pu ecrire une chose semblable?
Leurs demandes auraient ete traitees de facon equitable.
On leur donne tout.
La Charte des droits exige que nous agissions de la sorte.
Si tel n'est pas le cas, pourquoi en est-il ainsi?
Qu'a-t-on fait de la compassion et de l'equite dans ce cas?
Les representants du syndicat qui represente les employes veulent leur part du fonds de pension.
Ils ont l'audace de reclamer un traitement equitable.
Le comite recommande que leur part soit retiree de la caisse.
De la sorte, nous volons deux fois les fonctionnaires.
C'est profondement injuste.
En toute conscience, je ne saurais appuyer ce projet de loi.
(Sur la motion du senateur Kelleher, le debat est ajourne.)
Privileges, Reglement et procedure
Le douzieme rapport du comite-Motion d'adoption-Ajournement du debat
Le rapport recommande que l'appel dure au moins 20 minutes.
Honorables senateurs, je propose l'adoption du rapport.
Son Honneur le President :
Plait-il aux honorables senateurs d'adopter la motion?
Dans ce cas, honorables senateurs, je propose l'ajournement du debat.
(Sur la motion du senateur Murray, le debat est ajourne.)
Le onzieme rapport du comite-Motion d'adoption-Motion d'amendement- Ajournement du debat
L'honorable Edward M. Lawson :
Je fais expressement reference au passage suivant:
L'element de cette disposition auquel je m'oppose est le terme unanime.
J'ignore qui est responsable de cette proposition.
Qui aura le gros bout du baton?
Lorsque je suis arrive ici, on m'a dit que tous les senateurs etaient egaux.
L'honorable Edward M. Lawson :
Par consequent, honorables senateurs, je propose, avec l'appui du senateur Doody:
Son Honneur le President :
Plait-il aux senateurs d'adopter la motion?
L'honorable John B. Stewart :
J'ai de serieuses reserves a l'egard du rapport du comite.
Sept senateurs de notre parti siegeront a ce comite.
C'est ce senateur qui fera partie du comite.
Nous serons recompenses de notre magnanimite par la presence d'un senateur ministeriel additionnel.
C'est une charmante perspective et, si c'est possible, ce sera fait.
Cet aspect du rapport me met tres mal a l'aise.
J'ai enormement de respect pour les senateurs independants qui siegent a cet endroit.
Je ne denigre en rien les senateurs independants actuels.
Examinons toutefois notre systeme.
Cette hypothese est tout a fait plausible.
Que feraient certains de ces senateurs independants?
Leur role se limite a faire partie d'un comite.
En d'autres termes, ils seront les senateurs de ce comite particulier.
Il y a un autre aspect a cette question.
Nous savons qui feliciter et qui blamer.
La reside tout le merite d'un regime de gouvernement responsable.
Generalement, il s'agit d'un regime bipartite.
Il n'en demeure pas moins que le regime est fonde sur deux equipes.
Tout tend essentiellement vers un systeme bipartite.
Toutefois, jusqu'ou peut-on aller?
Le statut d'independant sera encore plus attrayant.
On ne peut blamer personne.
Je le repete, je n'ai absolument rien a reprocher a nos senateurs independants actuels.
Quand on observe nos voisins du Sud, on denonce et on critique leur systeme parlementaire.
Son Honneur le President :
Honorables senateurs, je dois vous informer qu'il est maintenant 18 heures.
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Son Honneur le President :
Est-ce d'accord, honorables senateurs, pour ne pas tenir compte de l'heure?
Je ne suis pas d'accord.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Son Honneur le President :
Vous opposez-vous, senateur Prud'homme?
Son Honneur le President :
Je dois alors quitter le fauteuil.
Le Senat reprendra sa seance a 20 heures.
(La seance du Senat est suspendue.)
(Le Senat reprend sa seance.)
Son Honneur le President :
L'honorable John B. Stewart :
Honorables senateurs, a18 heures, j'avais presque dit tout ce que je voulais dire.
Voila pourquoi il a adopte la Parliament Act de 1911.
Il serait peut-etre preferable de rappeler le contenu du projetd'alinea 85(2.2)
Que se passerait-il dans ce cas?
Revenons au projetd'alinea 85(2.2) a ), qui precise:
Ce serait la une distorsion de ce qui m'apparait etre une intention claire.
La proposition du senateur Lawson empire les choses.
Son Honneur le President :
Demandez-vous l'autorisation de poursuivre, senateur Stewart?
L'honorable Mabel M. DeWare :
C'est la pour nous une question qui revet une si grande importance.
Nous savons que l'automne approche, et cette question doit etre reglee.
Honorables senateurs, je propose l'ajournement du debat.
Son Honneur le President :
Plait-il aux honorables senateurs d'adopter la motion?
(Sur la motion du senateur DeWare, le debat est ajourne avec dissidence.)
Le Dragon Boat Festival
L'honorable senateur Prud'homme, c.p. ).
L'honorable Marcel Prud'homme :
Je n'ai pas parle sur la motion 34 du senateur Simard.
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Je sais tres bien qu'elle porte sur la motion du senateur Poy.
C'etait mon preambule a son interpellation.
J'ai discute avec elle et je la felicite.
Elles demontrent la diversite du Canada.
Je ne voulais pas que la question soit abandonnee aussi rapidement.
Je ne voulais pas que la question en reste la.
Pour certains, il s'agit de celebrer le Dragon Boat Festival.
Pour d'autres, la fete de l'Acadie.
Pour d'autres encore, la Saint-Jean-Baptiste.
J'ai apprecie le discours du senateur Poy.
Il a attire l'attention des senateurs sur l'evenement.
J'espere assister a ce festival l'annee prochaine.
Je felicite chaleureusement le senateur Poy d'avoir attire notre attention sur ce festival.
(Sur la motion du senateur Andreychuk, le debat est ajourne.)
Son Honneur le President :
Avec la permission du Senat, le senateur Kinsella a depose cette lettre.
J'ai soumis en exemple personnel...
Pour le moment, nous disposons de peu de preuves nous permettant de rejeter cette allegation.
J'invite le senateur Kinsella a proposer la motion appropriee.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Son Honneur le President :
L'honorable Anne C. Cools :
Je voudrais poser une question au senateur Kinsella.
Son Honneur le President :
L'honorable senateur a raison.
Il s'agit d'une motion pouvant faire l'objet d'un debat.
Est-ce bien cela?
Son Honneur le President :
Il a seulement demande que la motion soit discutee maintenant.
Il est clair qu'il n'est pas necessaire d'obtenir la permission du Senat.
Son Honneur le President :
Si aucun honorable senateur ne desire prendre la parole, je mettrai la motion aux voix.
Plait-il aux honorables senateurs d'adopter la motion?
La situation critique des migrants chinois sur la cote ouest-Interpellation-Ajournement du debat
L'honorable Vivienne Poy , ayant donne avis le 7 septembre 1999:
Il faut mettre un terme a la contrebande d'etres humains.
Certains revendiqueront sans doute legitimement le statut de refugie.
Par exemple, en 1987, 2 000 Turcs sont arrives a Montreal par bateau.
D'autres etaient des refugies authentiques.
Les medias ont fait etat de taux d'interet de900 p. 100 sur ces sommes.
Etre pauvre n'est pas un crime; il faut aider les victimes.
Certains Canadiens ont traite ces migrants de criminels.
Meme les enfants ont ete menottes de fer.
Des fillettes de 12 ans ont ete soumises a des fouilles a nu.
De jeunes enfants ont ete inutilement separes de leur mere en detention.
Nos lois et reglements en matiere d'immigration sont empreints d'equite et de compassion.
Nous donnons l'occasion a ceux qui demandent de l'aide de presenter leur cas.
Ces derniers cherchaient tout simplement a ameliorer leur sort.
Notre pays a grandi grace a la migration economique.
L'immigration constitue un investissement en capital humain.
Honorables senateurs, j'espere que la bonne volonte des Canadiens prevaudra.
(Sur la motion du senateur Robertson, au nom du senateur Carney, le debat est ajourne.)
(Le Senat s'ajourne a 9 heures demain.)


text:
c=======================================================================
c
c     SDLSS
c
c     Semi-Definite Least Square optimization
c     ( the constraints matrices Ai are symmetric )
c
c-----------------------------------------------------------------------
      SUBROUTINE sdlss ( nmat, cmat, mct, aict, bct, epsbfg,
     &                   iwork, dwork, xmat, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            nmat   : dimension of the matrix                    integer
c            cmat   : symmetric matrix (nmat*nmat) to optimize
c                     vector(nmat*(nmat+1)/2)                     double
c            mct    : number of constraints                      integer
c            aict   : mct Ai symmetric matrices(nmat*nmat)
c                     of constraints
c                     vector( mct*(nmat*(nmat+1)/2) )             double
c            bct    : vector(mct) of constraints                  double
c            epsbfg : BFGS precision stop test                    double
c
c     WORKSPACE
c            iwork  : 2*mct + 12*nmat + 3                        integer
c            dwork  : ( mct*(mct+23)/2)
c                    + (mct+3)*(nmat*(nmat+1)/2)
c                    + (nmat*(3*nmat+27)) )                       double
c
c     OUTPUT
c            xmat   : matrix solution (nmat*(nmat+1)/2)           double
c            info   : diagnostic argument                        integer
c
c     CALL
c        IVX        : initialization at a scalar of a vector
c        YV         : copy a vector in a vector
c        BFGSSDLS   : quasi-Newton optimizer with BFGS method
c                     ( short call version for SDLS )
c        SIMSDLS    : subroutine used by BFGS to compute the value of the
c                     dual function and its gradient
c        SOLSDLS    : computing the solution of SDLS optimization from the
c                     dual solution   x = pK( C + Ai.y(i) )
c        PROJECTS   : projection of a symmetric matrix
c                     on the cone of semidefinite matrices
c                     version with vector (n*(n+1)/2) in input/output
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
      EXTERNAL simsdls, gesterr
c
c     i/o arguments
      INTEGER nmat, mct, info
      DOUBLE PRECISION epsbfg, cmat(*), aict(*), bct(*), xmat(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER ssm, totitr, totsim, piwbf, pnmat, pinfo, pwbf, pb, pc,
     &        pai, pydual, pbinf, pbsup, pgrad, pisim, psim, pisol,
     &        psol, pipro, ppro, infotmp
      DOUBLE PRECISION infini, dzero, funct
      PARAMETER ( infini = 1.E20, dzero = 0.E0 )
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
      infotmp = 0
      ssm  = nmat*(nmat+1)/2
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piwbf = 1
c     piwbf : pointer for BFGSBOX who needs (2*mct + 1)
c             so (2*mct + 1) more
      pisim  = piwbf + (2*mct + 1)
c     pisim : pointer for the simulator SIMSDLS who needs (12*nmat+2)
      pnmat = pisim
c     pnmat : pointer for value nmat the size of the problem, so 1 more
      pinfo = pnmat + 1
c     pinfo : pointer for info (errors of simul), so 1 more
      pisol= 1
c     pisol : pointer for SOLSDLS integer workspace
c             SOLSDLS needs always less place than SIMSDLS
c             and used all now free space
      pipro= 1
c     pipro : pointer for PROJECTS integer workspace
c             SOLSDLS also needs always less place than SIMSDLS
c
c     Total size of dwork array : (2*mct+1) + (12*nmat+2)
c                               = (2*mct+12*nmat+3)
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pydual = 1
c     pydual: pointer for initial value of ydual, so mct more
      pbinf = pydual + mct
c     pbinf : pointer for inferior bounds binf, so mct more
      pbsup = pbinf + mct
c     pbsup : pointer for superior bounds bsup, so mct more
      pgrad = pbsup + mct
c     pgrad : pointer for gradient at solution, so mct more
c
      pwbf = pgrad + mct
c     pwbf  : pointer for BFGSSDLS who needs ( mct*(mct+11)/2 )
c             so ( mct*(mct+11)/2 ) more
c
      psim = pwbf +  mct*(mct+11)/2
c     psim  : pointer for the simulator SIMSDLS who needs
c                     ( (3+mct)*(nmat*(nmat+1)/2)
c                            + 2*mct + nmat*(3*nmat+27) )
      pb = psim
c     pb    : pointer for the vector B(mct), communication with SIMSDLS,
c             so mct more
      pc = pb  + mct
c     pc    : pointer for the vectorized symmetric matrix C,
c             communication with SIMSDLS,
c             so ssm =  (nmat*(nmat+1)/2) more
      pai = pc + ssm
c     pai   : pointer for the mct vectorized symmetric matrix
c             Ai(nmat*(nmat+1)/2), communication with SIMSDLS,
c             so mct*(nmat*(nmat+1)/2) more
      psol= pwbf
c     psol  : pointer for SOLSDLS workspace
c             SOLSDLS needs always less place than SIMSDLS because
c             SIMSDLS call also SOLSDLS
c             and used now free space of BFGSSDLS + SIMSDLS
      ppro= 1
c     ppro  : pointer for PROJECTS workspace
c             PROJECTS also needs always less place than SIMSDLS
c
c     Total size of dwork array : 4*mct + mct*(mct+11)/2
c                         + 2*mct + (mct+3)*(nmat*(nmat+1)/2)
c                         + nmat*(3*nmat+27)
c
c                         = mct*(mct+11)/2) + 6*mct
c                         + (mct+3)*(nmat*(nmat+1)/2)
c                         + (nmat*(3*nmat+27))
c
c                         = mct*(mct+23)/2)
c                         + (mct+3)*(nmat*(nmat+1)/2)
c                         + (nmat*(3*nmat+27))
c
c-----------------------------------------------------------------------
c
      IF (mct .NE. 0) THEN
c
c     initialization of ydual
      CALL IVX ( mct, dwork(pydual), dzero )
c
c     initializations of bounds
      CALL IVX ( mct, dwork(pbinf), -infini )
      CALL IVX ( mct, dwork(pbsup), infini )
c
c     construction of work vectors (communication with simsdls)
      iwork(pnmat) = nmat
      iwork(pinfo) = 0
c     matrix C (nmat*(nmat+1)/2)
      CALL YV ( ssm, cmat, dwork(pc) )
c     matrices of equal constraints Ai mct*(nmat*(nmat+1)/2)
      CALL YV ( mct*ssm, aict, dwork(pai) )
c     vector of equal constraints b (mct)
      CALL YV ( mct, bct, dwork(pb) )
c
c     optimization BFGS-SDLS
c
c     (the second parameter is not used here, we can replace GESTERR
c      by an other name of subroutine)
      CALL bfgssdls ( simsdls, gesterr, mct, dwork(pydual), epsbfg,
     &                dwork(pbinf), dwork(pbsup),
     &                iwork(piwbf), dwork(pwbf),
     &                funct, dwork(pgrad), totitr, totsim, infotmp)
c
c     construction of the matrix solution from dual solution
      CALL solsdls ( nmat, cmat, mct, aict, dwork(pydual),
     &               iwork(pisol), dwork(psol),
     &               xmat, info )
      IF (info .LT. 0) RETURN
c
c     case with no constraints : we do only a projection
c                                on the cone of semidefinite matrices
      ELSE
         CALL PROJECTS ( nmat, cmat, iwork(pipro), dwork(ppro),
     &                   xmat, info )
         IF (info .LT. 0) RETURN
      ENDIF

      info = infotmp

      RETURN
      END

max_stars_repo_name: alpgodev/numx

max_issues_repo_name: alpgodev/numx

max_forks_repo_name: alpgodev/numx


!
!  @GLOBAL.SOURCE@ - This file contains the main entry point for the
!  COM Server
!
!  Generated by the Intel(R) Visual Fortran COM Server Wizard on
!  @GLOBAL.DATE@ at @GLOBAL.TIME@.
!
!   DO NOT EDIT THIS FILE!
!
!  This file is re-generated every time the object hierarchy is changed.
!

integer*4 function WinMain( hInstance, hPrevInstance, lpszCmdLine, nCmdShow )
    !dec$ if defined(_X86_)
    !dec$ attributes dllexport, stdcall, alias : '_WinMain@16' :: WinMain
    !dec$ else
    !dec$ attributes dllexport, stdcall, alias : 'WinMain' :: WinMain
    !dec$ end if

    use @GLOBAL.NAME@_global
    use ifcom
    use user32
    use ole32

    implicit none

    integer(HANDLE) hInstance
    integer(HANDLE) hPrevInstance
    integer(LPVOID) lpszCmdLine
    integer(DWORD)  nCmdShow

    interface
        logical function ProcessCommandLine (ret)
            integer*4 ret
        end function
        @#PER CLASS
        function Register@CLASS.NAME@()
            use ifwinty
            integer(DWORD) Register@CLASS.NAME@
        end function
        @#ENDPER
    end interface

    ! Variables
    type (T_MSG)            mesg
    integer*4               ret
    logical*4               lret
    logical                 lrun

    ! Per Class
    @#PER CLASS
    integer(DWORD)          @CLASS.NAME@_Reg
    @#ENDPER

    ! Initialize global variables
    ghinst =  hInstance
    call InitializeCriticalSection(loc(gGlobalCriticalSection))
    ! Per Class
    @#PER CLASS
    g@CLASS.NAME@IClassFactory = NULL
    g@CLASS.NAME@ITypeInfo = NULL
    @#ENDPER

    ! Initialize COM
    call COMInitialize(ret)
    if (ret < 0) then
        ret = MessageBox(0, "Error initializing COM"C, &
                         "Error"C, MB_OK)
        WinMain = 0
        return
    end if

    ! Check the command line for the /Register and /Unregister switches
    lrun = ProcessCommandLine(ret)
    if (ret < 0) then
        ret = MessageBox(0, "Error registering or unregistering server"C, &
                         "Error"C, MB_OK)
        WinMain = 0
        return
    end if

    ! If /Register or /Unregister were found, don't start the server
    if (lrun) then
        @#PER CLASS
        @CLASS.NAME@_Reg = Register@CLASS.NAME@()
        @#ENDPER
        ret = CoResumeClassObjects()

        ! Read and process messsages
        do while( GetMessage (mesg, NULL, 0, 0) )
           ret = DispatchMessage( mesg )
        end do
        WinMain = mesg.wParam

        ! Revoke the server's classes
        ! Per Class
        @#PER CLASS
        ret = CoRevokeClassObject(@CLASS.NAME@_Reg)
        @#ENDPER
    else
        WinMain = ret
    end if

    ! Cleanup
    @#PER CLASS
    if (g@CLASS.NAME@IClassFactory /= NULL) then
        ret = COMReleaseObject(g@CLASS.NAME@IClassFactory)
    end if
    if (g@CLASS.NAME@ITypeInfo /= NULL) then
        ret = COMReleaseObject(g@CLASS.NAME@ITypeInfo)
    end if
    @#ENDPER
    call COMUnInitialize()
    call DeleteCriticalSection(loc(gGlobalCriticalSection))

end

logical function ProcessCommandLine (ret)
    use ServerHelper
    use ifwinty
    use user32

    implicit none

    integer*4               ret

    integer                 status
    integer                 argc
    integer                 argi
    integer(DWORD)          nchars
    character*(MAX_PATH)    p

    ret = S_OK

    ! Check the command line for the /Register and /Unregister switches
    argc = nargs()           ! First arg is command name
    if (argc > 1) then
        argi = 1
        do while (argi < argc)
            call getarg(argi, p, nchars)
            argi = argi + 1
            if (nchars > 0) then
                if (p(1:1) == '/' .or. p(1:1) == '-') then
                    status = CharUpperBuff ( p, nchars )
                    if (p(2:10) == "REGSERVER") then
                        ret = RegisterServer()
                        ProcessCommandLine = .FALSE.    !Don't run server
                        return
                    end if
                    if (p(2:12) == "UNREGSERVER") then
                        ret = UnregisterServer()
                        ProcessCommandLine = .FALSE.    !Don't run server
                        return
                    end if
                end if
            end if
        end do
    end if

    ProcessCommandLine = .TRUE.
end function

@#PER CLASS
function Register@CLASS.NAME@()
    use @GLOBAL.NAME@_global
    use @CLASS.NAME@_Types
    use IClassFactory_Types
    use IClassFactory_Methods
    use ifwinty
    use ifcom
    use ole32, only: CoRegisterClassObject

    implicit none

    integer(dword)          Register@CLASS.NAME@
    integer(dword)          dwFlags
    integer(dword)          dwReg
    integer(int_ptr_kind()) ppv
    integer(long)           status

    !  Create the class factory
    !  Allocate an instance data structure and a Vtbl
    allocate (gp@CLASS.NAME@CFData)
    allocate (gp@CLASS.NAME@CFData % pVtbl)
    gp@CLASS.NAME@CFData % refCount = 1
    !  The Vtbl implementations are in ClsFact.f90
    gp@CLASS.NAME@CFData % pVtbl % QueryInterface = &
            loc(IClassFactory_QueryInterface)
    gp@CLASS.NAME@CFData % pVtbl % AddRef = &
            loc(IClassFactory_AddRef)
    gp@CLASS.NAME@CFData % pVtbl % Release = &
            loc(IClassFactory_Release)
    gp@CLASS.NAME@CFData % pVtbl % CreateInstance = &
            loc(IClassFactory_Create@CLASS.NAME@Instance)
    gp@CLASS.NAME@CFData % pVtbl % LockServer = &
            loc(IClassFactory_LockServer)
    g@CLASS.NAME@IClassFactory  = loc(gp@CLASS.NAME@CFData)
    ppv = loc(gp@CLASS.NAME@CFData)
    status = COMAddObjectReference (ppv)

    ! Register the class
    dwFlags = REGCLS_MULTIPLEUSE .or. REGCLS_SUSPENDED
    dwReg = 0
    status = CoRegisterClassObject(CLSID_@CLASS.NAME@, ppv, CLSCTX_LOCAL_SERVER, dwFlags, dwReg)
    Register@CLASS.NAME@ = dwReg
end function
@#ENDPER


text:
C   size, centre pixel of output region and loop counters
       integer    nddd
       parameter (nddd = 20000)
       real*4     dout( nddd )
       integer    din( nddd )
       integer    status

C prompt for file and open
       status = 0
       call io_initio
       call dowork( dout, din, status )
       end
C
C
       subroutine dowork( dout, din, status )
C   file name and user name
       character  infile*(64), outfile*(64)
       integer    iun, iuo, n, m, nx
       real*4     xpix, xpixl, xpixr, x
       real*4     dout(*)
       integer    din(*)
       integer    chr_lenb, status

       call io_getfil('Input file name : ',' ',infile,status)
       call io_getfil('Output file name : ',' ',outfile,status)
       call io_geti( 'Dimension : ','1024',nx,status)
       call io_getr('X-scale : ','1.0',xpix,status)
       if (xpix.lt.0.0) then
          call io_getr('X-left : ','1.0',xpixl,status)
          call io_getr('X-right : ','1.0',xpixr,status)
       endif
       n = nx
       call io_operan(iun,infile(1:chr_lenb(infile)),
     *                  'READ',n*4,0,status)
       call io_rdfile(iun,1,din,n,status)
       close (iun)

       if (xpix.gt.0.0) then
         xpixl = (-float(nx)/2.0)*xpix
       else
         xpix = (xpixr - xpixl)/float(nx - 1)
       endif
       do m=1,nx
         dout(m) = din(m)
       enddo
       call io_opefil(iuo,outfile(1:chr_lenb(outfile)),
     *                  'WRITE',0,status)
       write(iuo,*)'%ndata ',nx
       write(iuo,*)'%ncols ',2
       do m=1,nx
          x=(m-1)*xpix + xpixl
          write(iuo,*) x, dout(m)
       enddo
       close (iuo)

       end

max_stars_repo_name: CavendishAstrophysics/anmap

max_issues_repo_name: CavendishAstrophysics/anmap

max_forks_repo_name: CavendishAstrophysics/anmap


text:
       subroutine plnp(p1,l,p,d)
      real l(3),p1(2),p(2),l1(3)
      call lperlp(l,p1,l1)
      s=sqrt(l(1)*l(1)+l(2)*l(2))
      d=abs((l(1)*p1(1)+l(2)*p1(2)+l(3))/s)
      if(d.lt.1.e-6) go to 1
      a=l1(2)*l(1)-l(2)*l1(1)
      p(1)=(l1(3)*l(2)-l(3)*l1(2))/a
      p(2)=(l(3)*l1(1)-l1(3)*l(1))/a
      return
  1   p(1)=p1(1)
      p(2)=p1(2)
      return
      end

max_stars_repo_name: sergev/grafor

max_issues_repo_name: sergev/grafor

max_forks_repo_name: sergev/grafor


text:
! { dg-do compile }
! Structure constructor with default initialization, test that an error is
! emitted for components without default initializer missing value.

PROGRAM test
  IMPLICIT NONE

  ! Structure of basic data types
  TYPE :: basics_t
    INTEGER :: i = 42
    REAL :: r
    COMPLEX :: c = (0., 1.)
  END TYPE basics_t

  TYPE(basics_t) :: basics

  basics = basics_t (i = 42) ! { dg-error "No initializer for component 'r'" }
  basics = basics_t (42) ! { dg-error "No initializer for component 'r'" }

END PROGRAM test

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


text:
c=======================================================================
c
c     subroutine SOLSTRACE
c
c     Computing the solution of SDLS optimization from the dual solution
c     specific to Trace constraint
c
c-----------------------------------------------------------------------
      SUBROUTINE solstrace ( n, C, ydual, iwork, dwork, X, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : matrix size                                        integer
c       C      : matrix (n*n)                                        double
c       ydual  : dual solution                                       double
c
c     WORKSPACE
c       iwork  : 12*n                                               integer
c       dwork  : n*(4*n+27)                                          double
c
c     OUTPUT
c       X      : matrix solution (n*n)                               double
c       info   : diagnostic argument                                integer
c
c     CALL
c       SM      : computing the sum of 2 matrices
c       PROJECT : projection of a symmetric matrix on SDP cone
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER n, info
      DOUBLE PRECISION C(*), X(*), ydual
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piw, pmat, pdw
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piw    = 1
c     piw    : pointer for workspace used by PROJECT (n)
c
c     Total size of iwork array : 12*n
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pmat = 1
c     pmat  : pointer for a work matrix (n*n)
      pdw = pmat + (n*n)
c     pdw   : pointer for workspace used by PROJECT (n*(3*n+27))
c
c     Total size of work array : n*(4*n+27)
c
c-----------------------------------------------------------------------
c
c     computing the sum: C + y*Id
      CALL SEMDX ( n, C, ydual, dwork(pmat) )
c
c     projection X = pK( C + y*Id )
      CALL PROJECT ( n, dwork(pmat), iwork(piw), dwork(pdw), X, info )
c
      RETURN
      END


text:
	SUBROUTINE BISEC(Y1_ARG,Y2_ARG,E_ARG,E1_ARG,F,X,ERROR)
C
C-Description-----------------------------------------------------------
	IMPLICIT NONE
C
C  Function:
C	bisection
C	This procedure evaluates a function at the end-points of a real
C	interval.  An error exit is taken if there is no change of sign.
C	Finds a root by iterated bisection and evaluation at the midpoint,
C	halting if either the value of the function is less than E_ARG or
C	two successive approximations of the root differ by less than
C	E1_ARG.
C  Usage:
C
C  Arguments:
C   i	Y1_ARG	Lower end of interval
C   i	Y2_ARG  Upper end of interval
C   i	E_AGR	If value of function <= E_ARG then done
C   i	E1_ARG  If two successive approximations differ <= E1_ARG then done
C   i	F	The function to evaluate
C   o	X	Argument to function that produces root if one is found
C   o	ERROR	0 if solution found
C		1 if no solution is found
C  Notes:
C   .	Reference:
C	"Bisection Routine", _Collected Algorithms from ACM_, vol I,
C	Algorithm 4, 1980.
C
C-Declarations----------------------------------------------------------
C
C
C  Arguments
C
	REAL Y1_ARG,Y2_ARG,E_ARG,E1_ARG,X
	INTEGER ERROR
C
C  Functions
C
	REAL F
C
C  Locals
C
        REAL F1,FX
	REAL Y1,Y2,E,E1
	INTEGER I,J,K
C
C-Code------------------------------------------------------------------
C
C    Assume success.
C
	ERROR=0
C
C    Copy arguments to local variables.
C
	Y1=Y1_ARG
	Y2=Y2_ARG
	E=E_ARG
	E1=E1_ARG
C
C    Initialize values.
C
10	CONTINUE
	I=1
	J=1
	K=1
	X=Y2
C
C    Evaluate the function at X.  If result is <= E then done.
C
20	FX=F(X)
	IF (ABS(FX).LE.E) RETURN
	GO TO (30,40) I
30	CONTINUE
	I=2
	F1=FX
	X=Y1
	GO TO 20
40	CONTINUE
	IF (FX*F1.GT.0) GO TO (1090,70) J
	GO TO (50,90) K
50	CONTINUE
	J=2
	K=2
C
C    Calculate a new midpoint.
C
60	CONTINUE
	X=(Y1+Y2)/2.
	GO TO 20
C
C    Set interval end to be current midpoint.
C
70	CONTINUE
	Y2=X
C
C    If two successive iteration differ by <= E1 then end.
C
80	CONTINUE
	IF (ABS(Y1-Y2).GE.E1) GO TO 60
	RETURN
C
C    Set interval end to be current midpoint.
C
90	CONTINUE
	Y1=X
	GO TO 80
1090	CONTINUE
C
C    Set an error flag if unable to find a root.
C
	ERROR=1
	RETURN
	END

ext: for

max_stars_repo_name: vubiostat/ps

max_issues_repo_name: vubiostat/ps

max_forks_repo_name: vubiostat/ps


text:
c function ppoiss.f
c
c source
c   Bevington, page 39.
c
c purpose
c   evaluate poisson probability function
c
c usage
c   result = ppoiss (nobs, averag)
c
c description of parameters
c   nobs   - number of items observed
c   averag - mean of distribution
c
c subroutines and function subprograms required
c   factor (n)
c      calculates n factorial for integers
c
	function ppoiss (nobs,averag)
1	ppoiss=((averag**nobs)/factor(nobs))*exp(-averag)
	return
	end

max_stars_repo_name: ysBach/irafdocgen

max_issues_repo_name: kirxkirx/iraf

max_forks_repo_name: kirxkirx/iraf


text:
-makelib xcelium_lib/xilinx_vip -sv \
  "F:/Xilinx/Vivado/2020.1/data/xilinx_vip/hdl/axi4stream_vip_axi4streampc.sv" \
  "F:/Xilinx/Vivado/2020.1/data/xilinx_vip/hdl/axi_vip_axi4pc.sv" \
  "F:/Xilinx/Vivado/2020.1/data/xilinx_vip/hdl/xil_common_vip_pkg.sv" \
  "F:/Xilinx/Vivado/2020.1/data/xilinx_vip/hdl/axi4stream_vip_pkg.sv" \
  "F:/Xilinx/Vivado/2020.1/data/xilinx_vip/hdl/axi_vip_pkg.sv" \
  "F:/Xilinx/Vivado/2020.1/data/xilinx_vip/hdl/axi4stream_vip_if.sv" \
  "F:/Xilinx/Vivado/2020.1/data/xilinx_vip/hdl/axi_vip_if.sv" \
  "F:/Xilinx/Vivado/2020.1/data/xilinx_vip/hdl/clk_vip_if.sv" \
  "F:/Xilinx/Vivado/2020.1/data/xilinx_vip/hdl/rst_vip_if.sv" \
-endlib
-makelib xcelium_lib/xpm -sv \
  "F:/Xilinx/Vivado/2020.1/data/ip/xpm/xpm_cdc/hdl/xpm_cdc.sv" \
  "F:/Xilinx/Vivado/2020.1/data/ip/xpm/xpm_fifo/hdl/xpm_fifo.sv" \
  "F:/Xilinx/Vivado/2020.1/data/ip/xpm/xpm_memory/hdl/xpm_memory.sv" \
-endlib
-makelib xcelium_lib/xpm \
  "F:/Xilinx/Vivado/2020.1/data/ip/xpm/xpm_VCOMP.vhd" \
-endlib
-makelib xcelium_lib/axi_infrastructure_v1_1_0 \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/ec67/hdl/axi_infrastructure_v1_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/axi_vip_v1_1_7 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/ce6c/hdl/axi_vip_v1_1_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/processing_system7_vip_v1_0_9 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/6b56/hdl/processing_system7_vip_v1_0_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_processing_system7_0_0/sim/Write_to_BRAM_processing_system7_0_0.v" \
-endlib
-makelib xcelium_lib/axi_bram_ctrl_v4_1_3 \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/db86/hdl/axi_bram_ctrl_v4_1_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_bram_ctrl_0_0/sim/Write_to_BRAM_axi_bram_ctrl_0_0.vhd" \
-endlib
-makelib xcelium_lib/blk_mem_gen_v8_4_4 \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/2985/simulation/blk_mem_gen_v8_4.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_blk_mem_gen_0_0/sim/Write_to_BRAM_blk_mem_gen_0_0.v" \
-endlib
-makelib xcelium_lib/xlconstant_v1_1_7 \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/fcfc/hdl/xlconstant_v1_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_0/sim/bd_fbc6_one_0.v" \
-endlib
-makelib xcelium_lib/lib_cdc_v1_0_2 \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/ef1e/hdl/lib_cdc_v1_0_rfs.vhd" \
-endlib
-makelib xcelium_lib/proc_sys_reset_v5_0_13 \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/8842/hdl/proc_sys_reset_v5_0_vh_rfs.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_1/sim/bd_fbc6_psr_aclk_0.vhd" \
-endlib
-makelib xcelium_lib/smartconnect_v1_0 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/2702/hdl/sc_util_v1_0_vl_rfs.sv" \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/053f/hdl/sc_mmu_v1_0_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/xil_defaultlib -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_2/sim/bd_fbc6_s00mmu_0.sv" \
-endlib
-makelib xcelium_lib/smartconnect_v1_0 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/ca72/hdl/sc_transaction_regulator_v1_0_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/xil_defaultlib -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_3/sim/bd_fbc6_s00tr_0.sv" \
-endlib
-makelib xcelium_lib/smartconnect_v1_0 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/9d43/hdl/sc_si_converter_v1_0_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/xil_defaultlib -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_4/sim/bd_fbc6_s00sic_0.sv" \
-endlib
-makelib xcelium_lib/smartconnect_v1_0 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/b89e/hdl/sc_axi2sc_v1_0_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/xil_defaultlib -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_5/sim/bd_fbc6_s00a2s_0.sv" \
-endlib
-makelib xcelium_lib/smartconnect_v1_0 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/4676/hdl/sc_node_v1_0_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/xil_defaultlib -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_6/sim/bd_fbc6_sarn_0.sv" \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_7/sim/bd_fbc6_srn_0.sv" \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_8/sim/bd_fbc6_sawn_0.sv" \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_9/sim/bd_fbc6_swn_0.sv" \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_10/sim/bd_fbc6_sbn_0.sv" \
-endlib
-makelib xcelium_lib/smartconnect_v1_0 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/7005/hdl/sc_sc2axi_v1_0_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/xil_defaultlib -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_11/sim/bd_fbc6_m00s2a_0.sv" \
-endlib
-makelib xcelium_lib/smartconnect_v1_0 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/7af8/hdl/sc_exit_v1_0_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/xil_defaultlib -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/ip/ip_12/sim/bd_fbc6_m00e_0.sv" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/bd_0/sim/bd_fbc6.v" \
-endlib
-makelib xcelium_lib/smartconnect_v1_0 -sv \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/c012/hdl/sc_switchboard_v1_0_vl_rfs.sv" \
-endlib
-makelib xcelium_lib/axi_register_slice_v2_1_21 \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ipshared/2ef9/hdl/axi_register_slice_v2_1_vl_rfs.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_axi_smc_0/sim/Write_to_BRAM_axi_smc_0.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/ip/Write_to_BRAM_rst_ps7_0_50M_0/sim/Write_to_BRAM_rst_ps7_0_50M_0.vhd" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  "../../../../Write_to_BRAM.srcs/sources_1/bd/Write_to_BRAM/sim/Write_to_BRAM.v" \
-endlib
-makelib xcelium_lib/xil_defaultlib \
  glbl.v
-endlib


text:
module single_case_properties_test
    use example_asserts_m, only: example_multiple_asserts
    use example_cases_m, only: example_passing_test_case, EXAMPLE_DESCRIPTION
    use helpers_m, only: test_item_input_t
    use vegetables, only: &
            input_t, &
            result_t, &
            test_item_t, &
            test_result_item_t, &
            assert_equals, &
            assert_faster_than, &
            assert_includes, &
            describe, &
            fail, &
            it_

    implicit none
    private

    public :: test_case_properties
contains
    function test_case_properties() result(test)
        type(test_item_t) :: test

        test = describe( &
                "A test case", &
                test_item_input_t(example_passing_test_case()), &
                [ it_("includes the given description", check_case_description) &
                , it_("only has 1 test case", check_num_cases) &
                , it_( &
                        "takes less than 3 times as long as the assertions to run", &
                        check_speed) &
                ])
    end function

    function check_case_description(input) result(result_)
        class(input_t), intent(in) :: input
        type(result_t) :: result_

        type(test_item_t) :: example_case

        select type (input)
        class is (test_item_input_t)
            example_case = input%input()
            result_ = assert_includes(EXAMPLE_DESCRIPTION, example_case%description())
        class default
            result_ = fail("Expected to get a test_item_input_t")
        end select
    end function

    function check_num_cases(input) result(result_)
        class(input_t), intent(in) :: input
        type(result_t) :: result_

        type(test_item_t) :: example_case

        select type (input)
        class is (test_item_input_t)
            example_case = input%input()
            result_ = assert_equals(1, example_case%num_cases())
        class default
            result_ = fail("Expected to get a test_item_input_t")
        end select
    end function

    function check_speed(input) result(result_)
        class(input_t), intent(in) :: input
        type(result_t) :: result_

        type(test_item_t) :: internal_case

        select type (input)
        type is (test_item_input_t)
            internal_case = input%input()
            result_ = assert_faster_than(run_assertions, run_case, 100)
        class default
            result_ = fail("Expected to get a test_item_input_t")
        end select
    contains
        subroutine run_case
            integer :: i
            type(test_result_item_t) :: internal_result

            do i = 1, 100
                internal_result = internal_case%run()
            end do
        end subroutine

        subroutine run_assertions
            integer :: i
            type(result_t) :: result__

            do i = 1, 300
                result__ = example_multiple_asserts()
            end do
        end subroutine
    end function
end module

max_stars_repo_name: everythingfunctional/vegetables

max_issues_repo_name: everythingfunctional/vegetables

max_forks_repo_name: everythingfunctional/vegetables


text:
C Test Fortran 77 colon edit descriptor
C      (ANSI X3.9-1978 Section 13.5.5)
C
C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
C
C { dg-do run }
C { dg-output "^123(\n|\r\n|\r)45(\n|\r\n|\r)\$" }
      write(*,'((3(I1:)))')  (I,I=1,5)
      end


text:
      subroutine xghis2(temp,nodes,nft,nlt)
c     implicit double precision (a-h,o-z)                                    dp
       use mod_parameters
      common/vect91/xargat(nelemg),exx(nelemg,4),eps(nelemg,5),
     > sa(nelemg),sb(nelemg),sc(nelemg),ang1(nelemg),ang2(nelemg)
      dimension temp(*),nodes(4,*)
      do 10 i=nft,nlt
      xargat(i)=0.
   10 continue
      do 30 k=1,4
      do 20 i=nft,nlt
      xargat(i)=xargat(i)+.25*temp(nodes(k,i))
   20 continue
   30 continue
      return
      end

max_stars_repo_name: imohame/LabCode

max_issues_repo_name: imohame/LabCode

max_forks_repo_name: imohame/LabCode


text:
Land Grant Universities were created by an Act of Congress during the American Civil War, the wiki:WikiPedia:Morrill_LandGrant_Colleges_Act Morrill LandGrant Colleges Act of 1862.  The University of California is one of these colleges, and UC Berkeley was established shortly after in 1868.  Land Grants established many of the major universities in the U.S., especially in the Western States.

The land grant gave the University a great deal of land, which partially explains why UC Davis still owns such a large amount of acreage.  The University sold most of its land to emigrants in the 1800s and early 1900s, raising funds to build the schools.  However, UC Davis retains over 5,300 acres of land (http://facts.ucdavis.edu/numbers.lasso source).  The University puts the land to unique uses for a college campus  there is an University Airport airport, a Landfill,  and Highway 113 two Interstate 80 freeways running through campus.

The LandGrant Colleges Act decreed that landgrant schools have a Cooperative Extension, which still exists to this day.  Land grant colleges are also required to teach engineering and military science, so kicking the ROTC off of Campus may be more difficult than it sounds.

And the rest is Town History.

More info:  see the wiki:WikiPedia:Landgrant_university wikipedia article.

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    get_pseudo_ensperts
!   prgmmr: mtong           org: np22                date: 2011-09-06
!
! abstract: read pseudo ensemble members from TC library, and interpolate to analysis
!           grid. Calculate pseudo ensemble perturbations and replace global ensemble
!           perturbations in vortex region (300 km from storm center)
!
! program history log:
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block
module get_pseudo_ensperts_mod
use abstract_get_pseudo_ensperts_mod
  type, extends(abstract_get_pseudo_ensperts_class) :: get_pseudo_ensperts_class
  contains
    procedure, pass(this) :: get_pseudo_ensperts => get_pseudo_ensperts_dummy
  end type get_pseudo_ensperts_class

contains

  subroutine get_pseudo_ensperts_dummy(this,en_perts,nelen)
    use gsi_bundlemod, only: gsi_bundle
    use kinds, only: i_kind
    implicit none
    class(get_pseudo_ensperts_class), intent(inout) :: this
    type(gsi_bundle),allocatable, intent(in   ) :: en_perts(:,:)
    integer(i_kind),                   intent(in   ) :: nelen

    write(6,*)'get_pseudo_ensperts:  ***WARNING*** dummy call ... does nothing!'

    return

  end subroutine get_pseudo_ensperts_dummy
end module get_pseudo_ensperts_mod


text:
      SUBROUTINE LORENTZ(PA,PI,PF)
      IMPLICIT NONE
      REAL PA(4)                ! Boost vector
      REAL PI(4)                ! Initial vector
      REAL PF(4)                ! Final vector
      REAL SMS, SCAL4, SCALG, SRS, GM, DOT1, DOT2
      INTEGER J

      SMS=SCALG(PA(1),PA(1))
      SRS=SQRT(SMS)
      GM=SRS*PA(4)+SMS
      DOT1=SCAL4(PA(1),PI(1))
      DOT2=SCALG(PA(1),PI(1))
      DO J=1,3
         PF(J)=PI(J)-PA(J)*(PI(4)/SRS)+PA(J)*DOT1/GM
      END DO
      PF(4)=DOT2/SRS
      RETURN
      END

c     -----------------------------------------------------

      FUNCTION SCALG(A,B)
      IMPLICIT NONE
      REAL A(4),B(4),SXS,SCALG

      SXS=A(4)*B(4)-A(1)*B(1)-A(2)*B(2)-A(3)*B(3)
      SCALG=SXS
      RETURN
      END

c     -----------------------------------------------------

      FUNCTION SCAL4(A,B)
      REAL A(4),B(4),SXS,SCAL4

      SXS=A(1)*B(1)+A(2)*B(2)+A(3)*B(3)
      SCAL4=SXS
      RETURN
      END

max_stars_repo_name: williamhbell/HepCppIntro

max_issues_repo_name: williamhbell/HepCppIntro

max_forks_repo_name: williamhbell/HepCppIntro


text:
module Mod_CaseVariables
   use Mod_MasterVariables
   use Mod_DomainVariables
   use Mod_AdaptiveVariables

   type CaseVariables
      type (MasterVariables)   :: masterVars
      type (DomainVariables)   :: domainVars
      type (AdaptiveVariables) :: adaptiveVars

      integer(ip) :: ndrivers
   end type

end module

max_stars_repo_name: ciaid-colombia/InsFEM

max_issues_repo_name: ciaid-colombia/InsFEM

max_forks_repo_name: ciaid-colombia/InsFEM


text:
      MODULE FFT36
!@sum  FFT36 calculates the Fast Fourier Transform
!@auth Gary Russell
!@ver  1.0 (for KM=36)
      USE CONSTANT, only : twopi,rt3
      IMPLICIT NONE
      SAVE
!@param KM length of input array; to change KM => rewrite module !!!
      INTEGER, PARAMETER :: KM=36

      REAL*8, PARAMETER :: BYKM=1d0/KM   !@param BYKM  1/KM
      REAL*8, PARAMETER :: BYKMH=2d0/KM  !@param BYKMH 1/(KM/2)
      REAL*8, PARAMETER :: BYKM2=1d0/(2*KM)!@param BYKM2 1/(2*KM)
!@var S sin evaluated on grid points
      REAL*8 :: S(KM)
!@var CH,SH cos/sin evaluated on half points
      REAL*8 :: CH(KM/2-1),SH(KM/2-1)

!@var C2,S2,C4,S4 etc. intermediate coefficients
      REAL*8 :: C200,C210,C201,C211,C202,C212,C203,C213,C204,C214,C205,
     *     C215,C206,C216,C207,C217,C208,C218,C209,C400,C410,C420,C430,
     *     S201,S211,S202,S212,S203,S213,S204,S214,S205,S215,S206,
     *     S216,S207,S217,S208,S218,S219,S401,S421,S402,S422,S403,S423,
     *     S404,S424,S411,S431,S412,S432,S413,S433,S414,S434,C401,C421,
     *     C402,C422,C403,C423,C404,C424,C411,C431,C412,C432,C413,C433,
     *     C414,C434,CC00,CC40,CC80,CC90,CC10,CC50,CC60,CC20,CCA0,CC30,
     *     CC70,CCB0,CC01,SC01,SC41,SC81,CC41,CC81,CC61,SC61,CC21,CCA1,
     *     SC21,SCA1,CC91,SC91,CC11,CC51,SC11,SC51,CC31,SC31,SC71,SCB1,
     *     CC71,CCB1
      COMMON /FFTCOM/ C200,C210,C201,C211,C202,C212,C203,C213,
     *     C204,C214,C205,C215,C206,C216,C207,C217,C208,C218,C209,C400,
     *     C410,C420,C430,S201,S211,S202,S212,S203,S213,S204,S214,S205,
     *     S215,S206,S216,S207,S217,S208,S218,S219,S401,S421,S402,S422,
     *     S403,S423,S404,S424,S411,S431,S412,S432,S413,S433,S414,S434,
     *     C401,C421,C402,C422,C403,C423,C404,C424,C411,C431,C412,C432,
     *     C413,C433,C414,C434,CC00,CC40,CC80,CC90,CC10,CC50,CC60,CC20,
     *     CCA0,CC30,CC70,CCB0,CC01,SC01,SC41,SC81,CC41,CC81,CC61,SC61,
     *     CC21,CCA1,SC21,SCA1,CC91,SC91,CC11,CC51,SC11,SC51,CC31,SC31,
     *     SC71,SCB1,CC71,CCB1
!$OMP  THREADPRIVATE(/FFTCOM/)

      END MODULE FFT36
C****
      SUBROUTINE FFT0 (IM)
!@sum  FFT0 initializes sines and cosines used by FFT routines.
!@auth Gary Russell
!@ver  1.0
      USE FFT36
      IMPLICIT NONE
      INTEGER N !@var IQ,N loop variables
      INTEGER, INTENT(IN) :: IM    !@var IM size of arrays (must=KM)
C
      IF(IM.NE.KM)  GO TO 100
      DO N=1,KM/4
        S(N) = DSIN(TWOPI*N/REAL(KM,KIND=8))
      END DO
      DO N=1,KM/2-1
        CH(N) = COS(TWOPI*N/REAL(2*KM,KIND=8))
        SH(N) = SIN(TWOPI*N/REAL(2*KM,KIND=8))
      END DO
      RETURN
 100  WRITE (6,*) ' This version of FFT is for ',KM,'. IM =',IM
      call stop_model('stopped in FFT36.f',255)
      END SUBROUTINE FFT0

      SUBROUTINE FFT (F,A,B)
!@sum   FFT calculates fast fourier transform of an input array F
!@auth  Gary Russell
!@ver   1.0
!@calls DOCALC
C****
C**** FFT calculates a fast fourier transform of the input array
C**** F, producing the cosine and sine coefficients in the output
C**** arrays A and B.  F is dimensioned by 36 = KM; A and B are
C**** dimensioned 0:18.  Upon entering FFT, the total energy is:
C****   .5*sum(F(K)**2)
C**** with the sum being taken over all K from 1 to KM.  The
C**** Fourier coefficients are defined by:
C****   A(N)+i*B(N) = sum(F(K)*exp(-2*PI*i*N*K/KM))/KMH
C**** with the sum being taken over all K from 1 to KM.  KMH = KM
C**** when N = 0 or KM/2, and KMH = KM/2 otherwise.  In the
C**** program's notation, CPQN means:
C****   CPQN = sum(F(K)*cos(2*PI*N*K/KM))
C**** with the sum being taken over all K = Q mod(P).  SPQN has a
C**** similar definition, but cos is replaced by sin.  The notation
C**** A=10, B=11, etc. is used for P, Q and N.  The same total
C**** energy can be calculated from the spectral coefficients as:
C****   .5*sum(A(N)**2+B(N)**2)*KMH
C**** with the sum being taken over all wave numbers N from 0 to KM/2.
C****
      USE FFT36
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: F(KM)      !@var F input gridpoint array
      REAL*8, INTENT(OUT) :: A(0:KM/2) !@var A fourier coeffs. (cos)
      REAL*8, INTENT(OUT) :: B(0:KM/2) !@var B fourier coeffs. (sin)

      CALL DOCALC(F)

C**** Calculate final coefficients of Fourier expansion
      A(0)  = (C200+C210)*BYKM
      A(1)  = (C201+C211)*BYKMH
      A(2)  = (C202+C212)*BYKMH
      A(3)  = (C203+C213)*BYKMH
      A(4)  = (C204+C214)*BYKMH
      A(5)  = (C205+C215)*BYKMH
      A(6)  = (C206+C216)*BYKMH
      A(7)  = (C207+C217)*BYKMH
      A(8)  = (C208+C218)*BYKMH
      A(9)  = (C400-C420)*BYKMH
      A(10) = (C208-C218)*BYKMH
      A(11) = (C207-C217)*BYKMH
      A(12) = (C206-C216)*BYKMH
      A(13) = (C205-C215)*BYKMH
      A(14) = (C204-C214)*BYKMH
      A(15) = (C203-C213)*BYKMH
      A(16) = (C202-C212)*BYKMH
      A(17) = (C201-C211)*BYKMH
      A(18) = (C200-C210)*BYKM
      B(0)  = 0.
      B(1)  = (S201+S211)*BYKMH
      B(2)  = (S202+S212)*BYKMH
      B(3)  = (S203+S213)*BYKMH
      B(4)  = (S204+S214)*BYKMH
      B(5)  = (S205+S215)*BYKMH
      B(6)  = (S206+S216)*BYKMH
      B(7)  = (S207+S217)*BYKMH
      B(8)  = (S208+S218)*BYKMH
      B(9)  = (C410-C430)*BYKMH
      B(10) = (S218-S208)*BYKMH
      B(11) = (S217-S207)*BYKMH
      B(12) = (S216-S206)*BYKMH
      B(13) = (S215-S205)*BYKMH
      B(14) = (S214-S204)*BYKMH
      B(15) = (S213-S203)*BYKMH
      B(16) = (S212-S202)*BYKMH
      B(17) = (S211-S201)*BYKMH
      B(18) = 0.
C****
      RETURN
      END SUBROUTINE FFT
C****
      SUBROUTINE FFTI (A,B,F)
!@sum  FFTI performs an inverse fast fourier transform
!@auth Gary Russell
!@ver  1.0 (KM=36)
      USE FFT36
      IMPLICIT NONE
      REAL*8, INTENT(OUT) :: F(KM)     !@var F output gridpoint array
      REAL*8, INTENT(IN) :: A(0:KM/2)  !@var A fourier coeffs. (cos)
      REAL*8, INTENT(IN) :: B(0:KM/2)  !@var B fourier coeffs. (sin)

C     S200 = 0
      S201 = B(1)-B(17)
      S211 = B(1)+B(17)
      S202 = B(2)-B(16)
      S212 = B(2)+B(16)
      S203 = B(3)-B(15)
      S213 = B(3)+B(15)
      S204 = B(4)-B(14)
      S214 = B(4)+B(14)
      S205 = B(5)-B(13)
      S215 = B(5)+B(13)
      S206 = B(6)-B(12)
      S216 = B(6)+B(12)
      S207 = B(7)-B(11)
      S217 = B(7)+B(11)
      S208 = B(8)-B(10)
      S218 = B(8)+B(10)
C     S210 = 0
      S219 = B(9)*2.

      C200 =(A(0)+A(18))*2.
      C210 =(A(0)-A(18))*2.
      C201 = A(1)+A(17)
      C211 = A(1)-A(17)
      C202 = A(2)+A(16)
      C212 = A(2)-A(16)
      C203 = A(3)+A(15)
      C213 = A(3)-A(15)
      C204 = A(4)+A(14)
      C214 = A(4)-A(14)
      C205 = A(5)+A(13)
      C215 = A(5)-A(13)
      C206 = A(6)+A(12)
      C216 = A(6)-A(12)
      C207 = A(7)+A(11)
      C217 = A(7)-A(11)
      C208 = A(8)+A(10)
      C218 = A(8)-A(10)
      C209 = A(9)*2.

      S401 = S201-S208
      S421 = S201+S208
      S402 = S202-S207
      S422 = S202+S207
      S403 = S203-S206
      S423 = S203+S206
      S404 = S204-S205
      S424 = S204+S205
      S411 = S211+C218
      S431 = S211-C218
      S412 = S212+C217
      S432 = S212-C217
      S413 = S213+C216
      S433 = S213-C216
      S414 = S214+C215
      S434 = S214-C215

      C400 = C200+C209
      C420 = C200-C209
      C401 = C201+C208
      C421 = C201-C208
      C402 = C202+C207
      C422 = C202-C207
      C403 = C203+C206
      C423 = C203-C206
      C404 = C204+C205
      C424 = C204-C205
      C410 = C210+S219
      C430 = C210-S219
      C411 = C211+S218
      C431 = C211-S218
      C412 = C212+S217
      C432 = C212-S217
      C413 = C213+S216
      C433 = C213-S216
      C414 = C214+S215
      C434 = C214-S215
C Factor here = 9/2
      CC00 =  C400+C403*2.
      CC40 =  C400-C403+S403*rt3
      CC80 =  C400-C403-S403*rt3
      CC90 =  C410-S413*2.
      CC10 =  C410+S413+C413*rt3
      CC50 =  C410+S413-C413*rt3
      CC60 =  C420-C423*2.
      CC20 =  C420+C423+S423*rt3
      CCA0 =  C420+C423-S423*rt3
      CC30 =  C430+S433*2.
      CC70 =  C430-S433-C433*rt3
      CCB0 =  C430-S433+C433*rt3
      CC01 =   C402+C404+C401
      SC01 =  -S402+S404+S401
      SC41 =  (S402-S404)*S(3)+(C402-C404)*S(6)+S401
      SC81 =  (S402-S404)*S(3)-(C402-C404)*S(6)+S401
      CC41 = -(C402+C404)*S(3)+(S402+S404)*S(6)+C401
      CC81 = -(C402+C404)*S(3)-(S402+S404)*S(6)+C401
      CC61 = -(C424+C422)+C421
      SC61 = -(S424-S422)+S421
      CC21 =  (C424+C422)*S(3)+(S424+S422)*S(6)+C421
      CCA1 =  (C424+C422)*S(3)-(S424+S422)*S(6)+C421
      SC21 =  (S424-S422)*S(3)-(C424-C422)*S(6)+S421
      SCA1 =  (S424-S422)*S(3)+(C424-C422)*S(6)+S421
      CC91 =   C411-S412-S414
      SC91 =   S411-C412+C414
      CC11 =  (S412+S414)*S(3)+(C412+C414)*S(6)+C411
      CC51 =  (S412+S414)*S(3)-(C412+C414)*S(6)+C411
      SC11 =  (C412-C414)*S(3)-(S412-S414)*S(6)+S411
      SC51 =  (C412-C414)*S(3)+(S412-S414)*S(6)+S411
      CC31 =   S432+S434+C431
      SC31 =   C432-C434+S431
      SC71 = -(C432-C434)*S(3)+(S432-S434)*S(6)+S431
      SCB1 = -(C432-C434)*S(3)-(S432-S434)*S(6)+S431
      CC71 = -(S432+S434)*S(3)-(C432+C434)*S(6)+C431
      CCB1 = -(S432+S434)*S(3)+(C432+C434)*S(6)+C431

C FACTOR HERE =(1/3)*(9/2)=3/2 (KM/24)
      F(36) =  CC00*S(3)+CC01
      F(35) =  CCB0*S(3)-SCB1*S(1)+CCB1*S(8)
      F(34) =  CCA0*S(3)-SCA1*S(2)+CCA1*S(7)
      F(33) = (CC90-SC91)*S(3)+CC91*S(6)
      F(32) =  CC80*S(3)-SC81*S(4)+CC81*S(5)
      F(31) =  CC70*S(3)-SC71*S(5)+CC71*S(4)
      F(30) = (CC60+CC61)*S(3)-SC61*S(6)
      F(29) =  CC50*S(3)-SC51*S(7)+CC51*S(2)
      F(28) =  CC40*S(3)-SC41*S(8)+CC41*S(1)
      F(27) =  CC30*S(3)-SC31
      F(26) =  CC20*S(3)-SC21*S(8)-CC21*S(1)
      F(25) =  CC10*S(3)-SC11*S(7)-CC11*S(2)
      F(24) = (CC00-CC01)*S(3)-SC01*S(6)
      F(23) =  CCB0*S(3)-CCB1*S(4)-SCB1*S(5)
      F(22) =  CCA0*S(3)-CCA1*S(5)-SCA1*S(4)
      F(21) = (CC90-SC91)*S(3)-CC91*S(6)
      F(20) =  CC80*S(3)-CC81*S(7)-SC81*S(2)
      F(19) =  CC70*S(3)-CC71*S(8)-SC71*S(1)
      F(18) =  CC60*S(3)-CC61
      F(17) =  CC50*S(3)-CC51*S(8)+SC51*S(1)
      F(16) =  CC40*S(3)-CC41*S(7)+SC41*S(2)
      F(15) = (CC30+SC31)*S(3)-CC31*S(6)
      F(14) =  CC20*S(3)-CC21*S(5)+SC21*S(4)
      F(13) =  CC10*S(3)-CC11*S(4)+SC11*S(5)
      F(12) =  1.5*CC00-F(24)-F(36)
      F(11) =  1.5*CCB0-F(23)-F(35)
      F(10) =  1.5*CCA0-F(22)-F(34)
      F( 9) =  1.5*CC90-F(21)-F(33)
      F( 8) =  1.5*CC80-F(20)-F(32)
      F( 7) =  1.5*CC70-F(19)-F(31)
      F( 6) =  1.5*CC60-F(18)-F(30)
      F( 5) =  1.5*CC50-F(17)-F(29)
      F( 4) =  1.5*CC40-F(16)-F(28)
      F( 3) =  1.5*CC30-F(15)-F(27)
      F( 2) =  1.5*CC20-F(14)-F(26)
      F( 1) =  1.5*CC10-F(13)-F(25)
C****
      RETURN
      END SUBROUTINE FFTI
C****
      SUBROUTINE FFTE (F,E)
!@sum   FFTE calcs. the spectral energy E from input gridpoint values F
!@auth  Gary Russell
!@ver   1.0
!@calls DOCALC
      USE FFT36
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: F(KM)       !@var F input gridpoint array
      REAL*8, INTENT(OUT) :: E(0:KM/2)  !@var E spectral energy

      CALL DOCALC(F)
C****
      E(0)  =  (C200+C210)*(C200+C210)*BYKM2
      E(1)  = ((C201+C211)*(C201+C211)+(S201+S211)*(S201+S211))*BYKM
      E(2)  = ((C202+C212)*(C202+C212)+(S202+S212)*(S202+S212))*BYKM
      E(3)  = ((C203+C213)*(C203+C213)+(S203+S213)*(S203+S213))*BYKM
      E(4)  = ((C204+C214)*(C204+C214)+(S204+S214)*(S204+S214))*BYKM
      E(5)  = ((C205+C215)*(C205+C215)+(S205+S215)*(S205+S215))*BYKM
      E(6)  = ((C206+C216)*(C206+C216)+(S206+S216)*(S206+S216))*BYKM
      E(7)  = ((C207+C217)*(C207+C217)+(S207+S217)*(S207+S217))*BYKM
      E(8)  = ((C208+C218)*(C208+C218)+(S208+S218)*(S208+S218))*BYKM
      E(9)  = ((C400-C420)*(C400-C420)+(C410-C430)*(C410-C430))*BYKM
      E(10) = ((C208-C218)*(C208-C218)+(S218-S208)*(S218-S208))*BYKM
      E(11) = ((C207-C217)*(C207-C217)+(S217-S207)*(S217-S207))*BYKM
      E(12) = ((C206-C216)*(C206-C216)+(S216-S206)*(S216-S206))*BYKM
      E(13) = ((C205-C215)*(C205-C215)+(S215-S205)*(S215-S205))*BYKM
      E(14) = ((C204-C214)*(C204-C214)+(S214-S204)*(S214-S204))*BYKM
      E(15) = ((C203-C213)*(C203-C213)+(S213-S203)*(S213-S203))*BYKM
      E(16) = ((C202-C212)*(C202-C212)+(S212-S202)*(S212-S202))*BYKM
      E(17) = ((C201-C211)*(C201-C211)+(S211-S201)*(S211-S201))*BYKM
      E(18) =  (C200-C210)*(C200-C210)*BYKM2
C****
      RETURN
      END SUBROUTINE FFTE
C****
      SUBROUTINE FFT2 (F,A,B)
!@sum   FFT2 calculates Fourier coefficients on secondary grid
!@auth  Gary Russell
!@ver   1.0
!@calls FFT
C****
C**** Values in F(K) are located a half space right of those in FFT.
C****
      USE FFT36
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: F(KM)      !@var input array
      REAL*8, INTENT(OUT) :: A(0:KM/2) !@var fourier coefficients (cos)
      REAL*8, INTENT(OUT) :: B(0:KM/2) !@var fourier coefficients (sin)
      REAL*8  ANEW  !@var  ANEW  dummy variable
      INTEGER N !@var N loop variable

      CALL FFT (F,A,B)
      DO N=1,KM/2-1
        ANEW = A(N)*CH(N)-B(N)*SH(N)
        B(N) = A(N)*SH(N)+B(N)*CH(N)
        A(N) = ANEW
      END DO
      B(KM/2) = A(KM/2)
      A(KM/2) = 0.
      RETURN
      END SUBROUTINE FFT2
C****
      SUBROUTINE DOCALC(F)
!@sum  DOCALC calculate intermediate expressions for FFT
!@auth Gary Russell
!@ver  1.0 (KM=36)
      USE FFT36
      IMPLICIT NONE
      REAL*8, INTENT(IN) :: F(KM) !@var F input grid point array

C**** Calculate expressions summed by increments of 12
      CC00 = F(36)+F(12)+F(24)
      CC10 = F(1)+F(13)+F(25)
      CC20 = F(2)+F(14)+F(26)
      CC30 = F(3)+F(15)+F(27)
      CC40 = F(4)+F(16)+F(28)
      CC50 = F(5)+F(17)+F(29)
      CC60 = F(6)+F(18)+F(30)
      CC70 = F(7)+F(19)+F(31)
      CC80 = F(8)+F(20)+F(32)
      CC90 = F(9)+F(21)+F(33)
      CCA0 = F(10)+F(22)+F(34)
      CCB0 = F(11)+F(23)+F(35)
      CC01 = F(36)-(F(12)+F(24))*S(3)
      CC11 = F(1)*S(8)-F(13)*S(4)-F(25)*S(2)
      CC21 = F(2)*S(7)-F(14)*S(5)-F(26)*S(1)
      CC31 = (F(3)-F(15))*S(6)
      CC41 = F(4)*S(5)-F(16)*S(7)+F(28)*S(1)
      CC51 = F(5)*S(4)-F(17)*S(8)+F(29)*S(2)
      CC61 = (F(6)+F(30))*S(3)-F(18)
      CC71 = F(7)*S(2)-F(19)*S(8)+F(31)*S(4)
      CC81 = F(8)*S(1)-F(20)*S(7)+F(32)*S(5)
      CC91 = (F(33)-F(21))*S(6)
      CCA1 = F(34)*S(7)-F(10)*S(1)-F(22)*S(5)
      CCB1 = F(35)*S(8)-F(11)*S(2)-F(23)*S(4)
      SC01 = (F(12)-F(24))*S(6)
      SC11 = F(1)*S(1)+F(13)*S(5)-F(25)*S(7)
      SC21 = F(2)*S(2)+F(14)*S(4)-F(26)*S(8)
      SC31 = (F(3)+F(15))*S(3)-F(27)
      SC41 = F(4)*S(4)+F(16)*S(2)-F(28)*S(8)
      SC51 = F(5)*S(5)+F(17)*S(1)-F(29)*S(7)
      SC61 = (F(6)-F(30))*S(6)
      SC71 = F(7)*S(7)-F(19)*S(1)-F(31)*S(5)
      SC81 = F(8)*S(8)-F(20)*S(2)-F(32)*S(4)
      SC91 = F(9)-(F(21)+F(33))*S(3)
      SCA1 = F(10)*S(8)-F(22)*S(4)-F(34)*S(2)
      SCB1 = F(11)*S(7)-F(23)*S(5)-F(35)*S(1)
C**** Calculate expressions summed by increments of 4
      C400 = CC00+CC40+CC80
      C410 = CC10+CC50+CC90
      C420 = CC20+CC60+CCA0
      C430 = CC30+CC70+CCB0
      C401 = CC01+CC41+CC81
      C411 = CC11+CC51+CC91
      C421 = CC21+CC61+CCA1
      C431 = CC31+CC71+CCB1
      C402 = (CC01-(CC41+CC81)*S(3))+(SC41-SC81)*S(6)
      C412 = (CC11-CC51)*S(6)+((SC11+SC51)*S(3)-SC91)
      C422 = ((CC21+CCA1)*S(3)-CC61)+(SC21-SCA1)*S(6)
      C432 = (CCB1-CC71)*S(6)+(SC31-(SC71+SCB1)*S(3))
      C403 = CC00-(CC40+CC80)*S(3)
      C413 = (CC10-CC50)*S(6)
      C423 = (CC20+CCA0)*S(3)-CC60
      C433 = (CCB0-CC70)*S(6)
      C404 = (CC01-(CC41+CC81)*S(3))-(SC41-SC81)*S(6)
      C414 = (CC11-CC51)*S(6)-((SC11+SC51)*S(3)-SC91)
      C424 = ((CC21+CCA1)*S(3)-CC61)-(SC21-SCA1)*S(6)
      C434 = (CCB1-CC71)*S(6)-(SC31-(SC71+SCB1)*S(3))
      S401 = SC01+SC41+SC81
      S411 = SC11+SC51+SC91
      S421 = SC21+SC61+SCA1
      S431 = SC31+SC71+SCB1
      S402 = ((CC41-CC81)*S(6))+((SC41+SC81)*S(3)-SC01)
      S412 = ((CC11+CC51)*S(3)-CC91)+((SC51-SC11)*S(6))
      S422 = ((CC21-CCA1)*S(6))+(SC61-(SC21+SCA1)*S(3))
      S432 = (CC31-(CC71+CCB1)*S(3))+((SC71-SCB1)*S(6))
      S403 = (CC40-CC80)*S(6)
      S413 = (CC10+CC50)*S(3)-CC90
      S423 = (CC20-CCA0)*S(6)
      S433 = CC30-(CC70+CCB0)*S(3)
      S404 = (CC41-CC81)*S(6)-((SC41+SC81)*S(3)-SC01)
      S414 = ((CC11+CC51)*S(3)-CC91)-(SC51-SC11)*S(6)
      S424 = (CC21-CCA1)*S(6)-(SC61-(SC21+SCA1)*S(3))
      S434 = (CC31-(CC71+CCB1)*S(3))-(SC71-SCB1)*S(6)
C**** Calculate expressions summed by increments of 2
      C200 = C400+C420
      C210 = C410+C430
      C201 = C401+C421
      C211 = C411+C431
      C202 = C402+C422
      C212 = C412+C432
      C203 = C403+C423
      C213 = C413+C433
      C204 = C404+C424
      C214 = C414+C434
      C205 = C404-C424
      C215 = S414-S434
      C206 = C403-C423
      C216 = S413-S433
      C207 = C402-C422
      C217 = S412-S432
      C208 = C401-C421
      C218 = S411-S431
C     C209 = C400-C420
C     C219 = 0.
C     S200 = 0.
C     S210 = 0.
      S201 = S401+S421
      S211 = S411+S431
      S202 = S402+S422
      S212 = S412+S432
      S203 = S403+S423
      S213 = S413+S433
      S204 = S404+S424
      S214 = S414+S434
      S205 = S424-S404
      S215 = C414-C434
      S206 = S423-S403
      S216 = C413-C433
      S207 = S422-S402
      S217 = C412-C432
      S208 = S421-S401
      S218 = C411-C431
C     S209 = 0.
C     S219 = C410-C430
C****
      RETURN
      END SUBROUTINE DOCALC


text:
      subroutine NewGRF(id)
      use maccbk
      use maccode
      use macvar
      use tfmem, only:ktaloc
      implicit none
      integer*4 id,LPARM,LBUF,ktcaloc
       parameter(LPARM=10,LBUF=1+2*1024)
c
       idtype(id)=icGRAF
       idval(id)=ktcaloc(LPARM)
c       idval(id)=mcfallo(LPARM)
       klist(idval(id))=ktaloc(LBUF)
c       ilist(2,idval(id))=mfalloc(LBUF)
       ilist(2,idval(id)-1)=LBUF
       ilist(1,klist(idval(id)))=LBUF
       ilist(1,idval(id)+1)=50+id
c      ilist(1,idval(id)+1)=50+gid
c      ilist(1,idval(id)+1)=fopen(gid)
       ilist(2,idval(id)+1)=ilist(2,idval(id))+1
       return
       end

max_stars_repo_name: noboruatkek/SAD

max_issues_repo_name: noboruatkek/SAD

max_forks_repo_name: noboruatkek/SAD


text:
      SUBROUTINE  DCOPY(N,DX,INCX,DY,INCY)

C     COPIES A VECTOR, X, TO A VECTOR, Y.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.

      DOUBLE PRECISION DX(*),DY(*)
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N

      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20

C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C        NOT EQUAL TO 1

      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DY(IY) = DX(IX)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      RETURN

C        CODE FOR BOTH INCREMENTS EQUAL TO 1

C        CLEAN-UP LOOP

   20 M = MOD(N,7)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DY(I) = DX(I)
   30 CONTINUE
      IF( N .LT. 7 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,7
        DY(I) = DX(I)
        DY(I + 1) = DX(I + 1)
        DY(I + 2) = DX(I + 2)
        DY(I + 3) = DX(I + 3)
        DY(I + 4) = DX(I + 4)
        DY(I + 5) = DX(I + 5)
        DY(I + 6) = DX(I + 6)
   50 CONTINUE
      RETURN
      END

      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)

C     FORMS THE DOT PRODUCT OF TWO VECTORS.
C     USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE.
C     JACK DONGARRA, LINPACK, 3/11/78.

      DOUBLE PRECISION DX(*),DY(*),DTEMP
      INTEGER I,INCX,INCY,IX,IY,M,MP1,N

      DDOT = 0.0D0
      DTEMP = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20

C        CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS
C          NOT EQUAL TO 1

      IX = 1
      IY = 1
      IF(INCX.LT.0)IX = (-N+1)*INCX + 1
      IF(INCY.LT.0)IY = (-N+1)*INCY + 1
      DO 10 I = 1,N
        DTEMP = DTEMP + DX(IX)*DY(IY)
        IX = IX + INCX
        IY = IY + INCY
   10 CONTINUE
      DDOT = DTEMP
      RETURN

C        CODE FOR BOTH INCREMENTS EQUAL TO 1

C        CLEAN-UP LOOP

   20 M = MOD(N,5)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
        DTEMP = DTEMP + DX(I)*DY(I)
   30 CONTINUE
      IF( N .LT. 5 ) GO TO 60
   40 MP1 = M + 1
      DO 50 I = MP1,N,5
        DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) +
     *   DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4)
   50 CONTINUE
   60 DDOT = DTEMP
      RETURN
      END

      DOUBLE PRECISION FUNCTION DNRM1(N,X,I,J)
      INTEGER N, I, J, K
      DOUBLE PRECISION SNORMX, SUM, X(N), ZERO, ONE, SCALE, TEMP
      DATA ZERO/0.0D0/, ONE/1.0D0/

C      DNRM1 - COMPUTES THE I-NORM OF A VECTOR
C              BETWEEN THE ITH AND THE JTH ELEMENTS

C      INPUT -
C      N       LENGTH OF VECTOR
C      X       VECTOR OF LENGTH N
C      I       INITIAL ELEMENT OF VECTOR TO BE USED
C      J       FINAL ELEMENT TO USE

C      OUTPUT -
C      DNRM1   NORM

      SNORMX=ZERO
      DO 10 K=I,J
 10      SNORMX=MAX(SNORMX,ABS(X(K)))
      DNRM1 = SNORMX
      IF (SNORMX.EQ.ZERO) RETURN
      SCALE = SNORMX
      IF (SNORMX.GE.ONE) SCALE=SQRT(SNORMX)
      SUM=ZERO
      DO 20 K=I,J
         TEMP=ZERO
         IF (ABS(X(K))+SCALE .NE. SCALE) TEMP = X(K)/SNORMX
         IF (ONE+TEMP.NE.ONE) SUM = SUM+TEMP*TEMP
 20      CONTINUE
      SUM=SQRT(SUM)
      DNRM1=SNORMX*SUM
      RETURN
      END

      DOUBLE PRECISION FUNCTION DNRM2 ( N, DX, INCX)
      INTEGER          N, I, J, NN, NEXT, INCX
      DOUBLE PRECISION DX(*), CUTLO, CUTHI, HITEST, SUM, XMAX, ZERO, ONE
      DATA             ZERO, ONE /0.0D0, 1.0D0/

C     EUCLIDEAN NORM OF THE N-VECTOR STORED IN DX() WITH STORAGE
C     INCREMENT INCX .
C     IF    N .LE. 0 RETURN WITH RESULT = 0.
C     IF N .GE. 1 THEN INCX MUST BE .GE. 1

C           C.L.LAWSON, 1978 JAN 08

C     FOUR PHASE METHOD     USING TWO BUILT-IN CONSTANTS THAT ARE
C     HOPEFULLY APPLICABLE TO ALL MACHINES.
C         CUTLO = MAXIMUM OF  SQRT(U/EPS)   OVER ALL KNOWN MACHINES.
C         CUTHI = MINIMUM OF  SQRT(V)       OVER ALL KNOWN MACHINES.
C     WHERE
C         EPS = SMALLEST NO. SUCH THAT EPS + 1. .GT. 1.
C         U   = SMALLEST POSITIVE NO.   (UNDERFLOW LIMIT)
C         V   = LARGEST  NO.            (OVERFLOW  LIMIT)

C     BRIEF OUTLINE OF ALGORITHM..

C     PHASE 1    SCANS ZERO COMPONENTS.
C     MOVE TO PHASE 2 WHEN A COMPONENT IS NONZERO AND .LE. CUTLO
C     MOVE TO PHASE 3 WHEN A COMPONENT IS .GT. CUTLO
C     MOVE TO PHASE 4 WHEN A COMPONENT IS .GE. CUTHI/M
C     WHERE M = N FOR X() REAL AND M = 2*N FOR COMPLEX.

C     VALUES FOR CUTLO AND CUTHI..
C     FROM THE ENVIRONMENTAL PARAMETERS LISTED IN THE IMSL CONVERTER
C     DOCUMENT THE LIMITING VALUES ARE AS FOLLOWS..
C     CUTLO, S.P.   U/EPS = 2**(-102) FOR  HONEYWELL.  CLOSE SECONDS ARE
C                   UNIVAC AND DEC AT 2**(-103)
C                   THUS CUTLO = 2**(-51) = 4.44089E-16
C     CUTHI, S.P.   V = 2**127 FOR UNIVAC, HONEYWELL, AND DEC.
C                   THUS CUTHI = 2**(63.5) = 1.30438E19
C     CUTLO, D.P.   U/EPS = 2**(-67) FOR HONEYWELL AND DEC.
C                   THUS CUTLO = 2**(-33.5) = 8.23181D-11
C     CUTHI, D.P.   SAME AS S.P.  CUTHI = 1.30438D19
C     DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /
C     DATA CUTLO, CUTHI / 4.441E-16,  1.304E19 /
      DATA CUTLO, CUTHI / 8.232D-11,  1.304D19 /

      IF(N .GT. 0) GO TO 10
         DNRM2  = ZERO
         GO TO 300

   10 ASSIGN 30 TO NEXT
      SUM = ZERO
      NN = N * INCX
C                       BEGIN MAIN LOOP
      I = 1
   20    GO TO NEXT,(30, 50, 70, 110)
   30 IF( ABS(DX(I)) .GT. CUTLO) GO TO 85
      ASSIGN 50 TO NEXT
      XMAX = ZERO

C                        PHASE 1.  SUM IS ZERO

   50 IF( DX(I) .EQ. ZERO) GO TO 200
      IF( ABS(DX(I)) .GT. CUTLO) GO TO 85

C                        PREPARE FOR PHASE 2.

      ASSIGN 70 TO NEXT
      GO TO 105

C                        PREPARE FOR PHASE 4.

  100 I = J
      ASSIGN 110 TO NEXT
      SUM = (SUM / DX(I)) / DX(I)
  105 XMAX = ABS(DX(I))
      GO TO 115

C                   PHASE 2.  SUM IS SMALL.
C                             SCALE TO AVOID DESTRUCTIVE UNDERFLOW.

   70 IF( ABS(DX(I)) .GT. CUTLO ) GO TO 75

C                   COMMON CODE FOR PHASES 2 AND 4.
C                   IN PHASE 4 SUM IS LARGE.  SCALE TO AVOID OVERFLOW.

  110 IF( ABS(DX(I)) .LE. XMAX ) GO TO 115
         SUM = ONE + SUM * (XMAX / DX(I))**2
         XMAX = ABS(DX(I))
         GO TO 200

  115 SUM = SUM + (DX(I)/XMAX)**2
      GO TO 200

C                  PREPARE FOR PHASE 3.

   75 SUM = (SUM * XMAX) * XMAX

C     FOR REAL OR D.P. SET HITEST = CUTHI/N
C     FOR COMPLEX      SET HITEST = CUTHI/(2*N)

   85 HITEST = CUTHI/FLOAT( N )

C                   PHASE 3.  SUM IS MID-RANGE.  NO SCALING.

      DO 95 J =I,NN,INCX
      IF(ABS(DX(J)) .GE. HITEST) GO TO 100
   95    SUM = SUM + DX(J)**2
      DNRM2 = SQRT( SUM )
      GO TO 300

  200 CONTINUE
      I = I + INCX
      IF ( I .LE. NN ) GO TO 20

C              END OF MAIN LOOP.

C              COMPUTE SQUARE ROOT AND ADJUST FOR SCALING.

      DNRM2 = XMAX * SQRT(SUM)
  300 CONTINUE
      RETURN
      END

max_stars_repo_name: robfalck/pyoptsparse

max_issues_repo_name: jcchin/OpenMDAO-Framework

max_forks_repo_name: jcchin/OpenMDAO-Framework


text:
Jump to Timeline #Navigation Navigation

  February: ASUCD begins operating the University Transport System (Unitrans) buses and the Coffee House in East Hall.  They both had been campaign promises of Bob Black.
  The UC Davis School of Medicine starts training doctors.
  UC Davis starts the worlds first Department of Environmental Toxicology.
  The UC Davis Law Review publishes their first issue.