text:
module http_request_m
    use attribute_value_pair_m
    use string_utils
    use url_helper

    implicit none
    private

    type, public :: http_request_t
        private
            character(len=4096) :: auth_type_m = ''
            integer :: content_length_m = 0
            character(len=4096) :: content_type_m = ''
            character(len=4096) :: gateway_interface_m = ''
            character(len=4096) :: path_info_m = ''
            character(len=4096) :: path_translated_m = ''
            character(len=4096) :: query_string_m = ''
            character(len=4096) :: remote_addr_m = ''
            character(len=4096) :: remote_host_m = ''
            character(len=4096) :: remote_ident_m = ''
            character(len=4096) :: remote_user_m = ''
            character(len=4096) :: request_method_m = ''
            character(len=4096) :: script_name_m = ''
            character(len=4096) :: server_name_m = ''
            character(len=4096) :: server_port_m = ''
            character(len=4096) :: server_protocol_m = ''
            character(len=4096) :: server_software_m = ''
            character(len=4096) :: http_accept_m = ''
            character(len=4096) :: request_body_m = ''
            character(len=80), dimension(:), pointer :: path_elements_m
            type(attribute_value_pair_t), dimension(:), pointer :: &
                query_strings_m

        contains
            procedure, public, pass(this) :: get_auth_type, &
                                             get_content_length, &
                                             get_content_type, &
                                             get_gateway_interface, &
                                             get_path_info, &
                                             get_path_translated, &
                                             get_query_string, &
                                             get_remote_addr, &
                                             get_remote_host, &
                                             get_remote_ident, &
                                             get_remote_user, &
                                             get_request_method, &
                                             get_script_name, &
                                             get_server_name, &
                                             get_server_port, &
                                             get_server_protocol, &
                                             get_server_software, &
                                             get_http_accept, &
                                             get_request_body, &
                                             get_path_elements, &
                                             get_query_strings

    end type http_request_t

contains
    character(len=4096) function get_auth_type(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%auth_type_m) == 0) then
            call get_environment_variable("AUTH_TYPE", this%auth_type_m)
        end if

        get_auth_type = this%auth_type_m
    end function get_auth_type

    integer function get_content_length(this)
        class(http_request_t), intent(inout) :: this

        character(len=4096) :: temp_str
        integer :: result_val, status_val

        if (this%content_length_m == 0) then
            call get_environment_variable("CONTENT_LENGTH", temp_str)
            call str2int(temp_str, result_val, status_val)

            if (status_val /= 0) then
                this%content_length_m = 0
            else
                this%content_length_m = result_val
            end if
        end if

        get_content_length = this%content_length_m
    end function get_content_length

    character(len=4096) function get_content_type(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%content_type_m) == 0) then
            call get_environment_variable("CONTENT_TYPE", &
                this%content_type_m)
        end if

        get_content_type = this%content_type_m
    end function get_content_type

    character(len=4096) function get_gateway_interface(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%gateway_interface_m) == 0) then
            call get_environment_variable("GATEWAY_INTERFACE", &
                this%gateway_interface_m)
        end if

        get_gateway_interface = this%gateway_interface_m
    end function get_gateway_interface

    character(len=4096) function get_path_info(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%path_info_m) == 0) then
            call get_environment_variable("PATH_INFO", this%path_info_m)
        end if

        get_path_info = this%path_info_m
    end function get_path_info

    character(len=4096) function get_path_translated(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%path_translated_m) == 0) then
            call get_environment_variable("PATH_TRANSLATED", &
                this%path_translated_m)
        end if

        get_path_translated = this%path_translated_m
    end function get_path_translated

    character(len=4096) function get_query_string(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%query_string_m) == 0) then
            call get_environment_variable("QUERY_STRING", this%query_string_m)
        end if

        get_query_string = this%query_string_m
    end function get_query_string

    character(len=4096) function get_remote_addr(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%remote_addr_m) == 0) then
            call get_environment_variable("REMOTE_ADDR", this%remote_addr_m)
        end if

        get_remote_addr = this%remote_addr_m
    end function get_remote_addr

    character(len=4096) function get_remote_host(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%remote_host_m) == 0) then
            call get_environment_variable("REMOTE_HOST", this%remote_host_m)
        end if

        get_remote_host = this%remote_host_m
    end function get_remote_host

    character(len=4096) function get_remote_ident(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%remote_ident_m) == 0) then
            call get_environment_variable("REMOTE_IDENT", this%remote_ident_m)
        end if

        get_remote_ident = this%remote_ident_m
    end function get_remote_ident

    character(len=4096) function get_remote_user(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%remote_user_m) == 0) then
            call get_environment_variable("REMOTE_USER", this%remote_user_m)
        end if

        get_remote_user = this%remote_user_m
    end function get_remote_user

    character(len=4096) function get_request_method(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%request_method_m) == 0) then
            call get_environment_variable("REQUEST_METHOD", &
                this%request_method_m)
        end if

        get_request_method = this%request_method_m
    end function get_request_method

    character(len=4096) function get_script_name(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%script_name_m) == 0) then
            call get_environment_variable("SCRIPT_NAME", this%script_name_m)
        end if

        get_script_name = this%script_name_m
    end function get_script_name

    character(len=4096) function get_server_name(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%server_name_m) == 0) then
            call get_environment_variable("SERVER_NAME", this%server_name_m)
        end if

        get_server_name = this%server_name_m
    end function get_server_name

    character(len=4096) function get_server_port(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%server_port_m) == 0) then
            call get_environment_variable("SERVER_PORT", this%server_port_m)
        end if

        get_server_port = this%server_port_m
    end function get_server_port

    character(len=4096) function get_server_protocol(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%server_protocol_m) == 0) then
            call get_environment_variable("SERVER_PROTOCOL", &
                this%server_protocol_m)
        end if

        get_server_protocol = this%server_protocol_m
    end function get_server_protocol

    character(len=4096) function get_server_software(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%server_software_m) == 0) then
            call get_environment_variable("SERVER_SOFTWARE", &
                this%server_software_m)
        end if

        get_server_software = this%server_software_m
    end function get_server_software

    character(len=4096) function get_http_accept(this)
        class(http_request_t), intent(inout) :: this

        if (len_trim(this%http_accept_m) == 0) then
            call get_environment_variable("HTTP_ACCEPT", &
                this%http_accept_m)
        end if

        get_http_accept = this%http_accept_m
    end function get_http_accept

    character(len=4096) function get_request_body(this)
        class(http_request_t), intent(inout) :: this

        integer :: body_size, i, bytes_read
        character(len=1) :: in_char

        body_size = this%get_content_length()

        if (len_trim(this%request_body_m) == 0) then
            this%request_body_m = repeat(' ', 4096)
            do i=1,body_size
                bytes_read = 0
                read (5, '(a)', advance='no', size=body_size) in_char
                this%request_body_m(i:i) = in_char
            end do
        end if

        get_request_body = this%request_body_m
    end function get_request_body

    subroutine get_path_elements(this, path_elements)
        class(http_request_t), intent(inout) :: this
        character(len=80), dimension(:), pointer, intent(inout) :: &
            path_elements

        integer :: num_elements
        character(len=4096) :: path_str

        if (.not. associated(this%path_elements_m)) then
            path_str = url_decode(this%get_path_info())
            num_elements = get_num_uri_elements(path_str)
            allocate(this%path_elements_m(num_elements))
            call split_path(path_str, this%path_elements_m)
        end if

        path_elements => this%path_elements_m
    end subroutine get_path_elements

    subroutine get_query_strings(this, query_strings)
        class(http_request_t), intent(inout) :: this
        type(attribute_value_pair_t), dimension(:), pointer, intent(inout) ::&
            query_strings

        integer :: num_elements
        character(len=4096) :: query_str

        if (.not. associated(this%query_strings_m)) then
            query_str = url_decode(this%get_query_string())
            num_elements = get_num_attributes(query_str)
            allocate(this%query_strings_m(num_elements))
            call get_attribute_value_pairs(query_str, this%query_strings_m)
        end if

        query_strings => this%query_strings_m
    end subroutine get_query_strings

end module http_request_m

max_stars_repo_name: bceverly/FABS

max_issues_repo_name: bceverly/FABS

max_forks_repo_name: bceverly/FABS


text:
!> @file
!! Other fortran file for f_malloc routines for f_buffers, declaration
!! @author
!!    Copyright (C) 2012-2015 BigDFT group
!!    This file is distributed under the terms of the
!!    GNU General Public License, see ~/COPYING file
!!    or http://www.gnu.org/copyleft/gpl.txt .
!!    For the list of contributors, see ~/AUTHORS
      type(malloc_information_buf) :: m
      integer, intent(in), optional :: sizes
      !local variables
      integer :: i

max_stars_repo_name: adegomme/aiida-bigdft-plugin


text:
Debats du Senat (hansard)
1ere Session, 36 e Legislature,
Volume 137, Numero 127
Le mercredi 14 avril 1999
L'honorable Gildas L. Molgat, President
Les fetes celebrant le nouveau territoire
L'Organisation du Traite de l'Atlantique Nord
Reponses differees a des questions orales
La liberte religieuse au Tibet sous l'occupation chinoise-La position du gouvernement
La demande d'affectations dans le budget pour la force aerienne-La position du gouvernement
Les travaux du Senat
Le mercredi 14 avril 1999
La seance est ouverte a 13 h 30, le President etant au fauteuil.
Son Honneur le President :
L'honorable Erminie J. Cohen :
Dans le communique qui accompagnait son nouveau rapport intitule: Preschool Children:
Comme l'a declare John Murphy, president du Conseil national du bien-etre:
Honorables senateurs, je suis tout a fait d'accord.
Les fetes celebrant le nouveau territoire
Le 1er avril a ete une grande journee historique pour le Nunavut.
C'etait un evenement de premiere classe.
Les aines peuvent s'enorgueillir du fait que leurs efforts ont porte fruit.
Les enfants profitent de leur connaissance des coutumes.
Les premiers pourparlers avaient commence il y a presque 30 ans.
Aujourd'hui, il y a au Nunavut un nouveau gouvernement forme de 19 deputes elus.
C'etait le debut.
C'est pourquoi il a demenage ses bureaux a Ottawa en 1972.
C'etait il y a presque 30 ans et maintenant, la question est reglee.
Ce n'est plus le cas maintenant.
Nous entrevoyons l'avenir avec beaucoup d'espoir.
J'ai ete nomme au Senat il y a 22 ans, le 5 avril 1977.
Les pauvres huskies devaient supporter une chaleur de 80 degres Fahrenheit.
Il reste encore beaucoup de travail a faire.
C'est un vaste territoire a gouverner.
Il ne sera pas aise de se rendre jusque dans les communautes eloignees.
Certaines ne sont accessibles que par avion.
Notre avenir repose sur nos enfants, a qui nous avons legue un magnifique heritage.
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Je crois savoir que de nombreux senateurs ont contribue a la realisation de cette initiative.
La famille du senateur Kroft a offert sa contribution, tout comme le senateur Watt.
Honorables senateurs, je donne avis que, le jeudi 15 avril 1999, je proposerai:
L'honorable J. Michael Forrestall :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Honorables senateurs, ma reponse ne peut etre plus affirmative.
L'honorable J. Michael Forrestall :
L'honorable B. Alasdair Graham (leader du gouvernement) :
Par consequent, l'entrainement des militaires doit les preparer a faire face a toute eventualite.
Honorables senateurs, j'ai une derniere question complementaire.
Je remercie le ministre de sa reponse, malgre son manque de candeur.
Je ne sais pas pourquoi nous nous pretons a ces petits jeux.
On parle bien de quelque 2 000 militaires, et non de 800.
Parle-t-on de la meme unite?
Honorables senateurs, les chiffres qu'on m'a donnes s'echelonnent entre 500 et 800.
Je n'ai jamais entendu parler d'un effectif de 2 000 personnes.
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Le Canada accueillera chaudement et appuiera toute initiative qu'il pourrait prendre.
L'Organisation du Traite de l'Atlantique Nord
Est-ce que le leader du gouvernement va la presenter personnellement au gouvernement?
Comment le Senat pourra-t-il savoir ce qu'il adviendra de sa motion?
L'honorable B. Alasdair Graham (leader du gouvernement) :
Honorables senateurs, je peux vous dire immediatement ce qu'il en est.
Le senateur Roche avait demande que la resolution soit transmise aux autorites competentes.
L'honorable Donald H. Oliver :
Honorables senateurs, ma question s'adresse au leader du gouvernement au Senat.
Il s'agit de Son Honneur Corrine Sparks.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Permettez-moi de resumer ces nouveaux developpements inquietants qui se sont produits hier.
Le president americain n'exclut plus l'envoi de troupes terrestres.
Est-il vraiment au courant de ce qui se passe dans cette region?
L'honorable B. Alasdair Graham (leader du gouvernement) :
L'honorable senateur a parfaitement raison.
Il y a eu des incursions en Albanie hier.
Cela s'est apparemment produit a deux ou trois reprises.
Je n'ai pas entendu parler de nouvelles incursions du genre aujourd'hui.
Il s'agit cependant d'une affaire tres grave.
Hier, le senateur Andreychuk a demande si l'on consulterait la Russie et l'Ukraine.
Une rencontre de ministres de la Communaute europeenne a lieu en ce moment.
J'ignore a quelles mesures cette proposition pourrait donner lieu.
L'honorable B. Alasdair Graham (leader du gouvernement) :
Je n'ai pas dit cela, honorables senateurs.
Le premier ministre a-t-il peur de nous aviser qu'un vote aura lieu?
Un debat fort utile vient d'etre tenu aux Communes.
L'honorable Marcel Prud'homme :
Je ne crois pas que le Parlement soit forme uniquement de la Chambre des communes.
Aucune decision ne peut etre prise ici.
Je ferai remarquer tres respectueusement que c'est la Chambre des communes qui decidera.
Voila l'observation que je voulais faire.
Avec plaisir, honorables senateurs.
Collectivement ou individuellement, les senateurs peuvent prendre toutes les mesures qu'ils veulent.
Nous entretenons des liens d'amitie de longue date avec le peuple russe.
Je suis certain que le senateur Prud'homme etait present, tout comme le senateur Stollery.
Je presidais cette reunion.
Le senateur Prud'homme etait le president de ce comite.
Le senateur Roche dit qu'il etait present.
L'honorable Gerry St. Germain :
Je m'en remets au ministre.
L'honorable Michael A. Meighen :
L'honorable B. Alasdair Graham (leader du gouvernement) :
Honorables senateurs, je remercie l'honorable senateur Meighen pour sa question.
Peut-etre pourrais-je les rappeler.
Je voulais a nouveau informer les senateurs de cette initiative prise par le gouvernement allemand.
Reponses differees a des questions orales
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
La liberte religieuse au Tibet sous l'occupation chinoise-La position du gouvernement
( Reponse a la question posee par l'honorableConsiglio Di Nino le 18 mars 1999 )
L'Association legislative Canada-Chine tiendra sa deuxieme reunion en octobre prochain.
La demande d'affectations dans le budget pour la force aerienne-La position du gouvernement
(Reponse a une question posee par l'honorableConsiglio Di Nino le 17 mars 1999)
Non calculees comme telles*
Inde, Pakistan and Malaisia
Coree, Philippines et Thailand
Mexique, Bresil, Argentine and Chili
(Reponse a une question posee par l'honorable J. Michael Forrestall le 18 mars 1999)
(Reponse a une question posee par l'honorable Pat Carney le 25 mars 1999)
Aucune levee des moratoires devrait donc etre coordonnee.
Ce dossier n'est donc pas a l'etude actuellement.
L'honorable Jerahmiel S. Grafstein :
Mais j'ai trouve le temps de l'examiner rapidement dans la soiree.
Les senateurs se souviendront que nos abstentions ont cause une certaine controverse.
Cela est maintenu dans la nouvelle loi.
La Criminal Lawyers' Association ne s'attaque pas a cette question.
Honorables senateurs, je ne suis pas certain d'etre d'accord avec M. Greenspan.
Je ne suis pas sur qu'il ait raison.
Adoptons ce projet de loi.
Honorables senateurs, j'ai ete place dans cette situation regrettable.
Je n'ai pas pu obtenir l'accord de mes chefs la-dessus.
Il m'a repondu qu'il faudrait de quatre a huit heures.
J'aimerais commencer par faire part d'une de mes preoccupations aux honorables senateurs.
Ce n'est pas tres complique, mais c'est fondamental.
Ce que je reponds a cela, c'est que ce n'est pas notre probleme.
D'ou mon premier amendement.
Telle est la position de la ministre.
J'ai essaye de l'exposer de facon impartiale.
... dans 26, je crois, honorables senateurs...
... rend cette mesure tres reelle et importante pour nous.
Je reviendrai sur cette question dans un moment.
Honorables senateurs, je ne suis pas d'accord avec la ministre.
Je ne suis pas d'accord avec le gouvernement.
Qui se range de mon cote?
Je vais vous dire qui se range de mon cote.
Le pape et les eveques americains sont du meme avis que moi.
L'honorable Jerahmiel S. Grafstein :
Honorables senateurs, j'aimerais parler du premier amendement.
Il est plutot court.
Je propose, appuye par le senateur Joyal:
a ) par substitution, a la ligne 30, a la page 17, de ce qui suit:
c ) soit la demande d'extradition est presen-;
C'est mon premier amendement.
C'est ce que veut Amnistie Internationale.
C'est une question compliquee.
Un meurtre a-t-il la meme equivalence qu'un genocide?
Oui, mais ne devrions-nous pas les traiter quelque peu differemment, si cela est possible?
C'est du passe.
La ministre a repondu que nous devons respecter la Charte.
Cependant, l'accuse pourra invoquer les memes dispositions d'appel.
Par consequent, je ne suis pas d'accord avec la ministre sur ce point.
Honorables senateurs, voila en substance ma deuxieme proposition, soit un systeme a deux vitesses.
Je l'ai fait apres avoir lu la breve declaration suivante de madame la ministre.
Et elle explique pourquoi.
Je rentrerai a La Haye le 11 ou le 12 avril.
Votre note ne precise pas clairement quand vous avez besoin de notre reponse...
Je ne savais pas moi-meme quand il me faudrait cette information.
Il est l'un des grands specialistes du Canada dans ce domaine.
Honorables senateurs, je reviens a mon deuxieme amendement.
J'implore votre indulgence.
Il y en a pour plusieurs pages, mais le but est d'accelerer les choses:
a ) par substitution, au terme accord, de accord general d'extradition;
b ) par substitution, a l'expression accord specifique, de accord specifique d'extradition
c ) a l'article 2:
(i) a la page 2, par adjonction, apres la ligne 8, de ce qui suit:
(ii) a la page 1, par suppression des lignes 7 a 10;
(iii) a la page 2, par substitution, a la ligne 13, de ce qui suit:
partenaire Etat qui est soit partie;
(iv) a la page 1, par adjonction, apres la ligne 10, de ce qui suit:
accord specifique d'extradition Accord vise a l'article 10 qui est en vigueur.
vi) a la page 2, par substitution, aux lignes 7 et 8 [...]
Son Honneur le President :
Est-ce que vous auriez le texte francais, par hasard?
Le texte francais sera disponible bientot.
Je le remets pour qu'il puisse etre presente simultanement.
Son Honneur le President :
Les interpretes ne peuvent pas suivre.
Vous nous obligeriez en ralentissant.
Son Honneur le President :
Le senateur Bolduc invoque le Reglement.
Je suis bien d'accord que cet amendement doit etre traduit.
Sinon, comment voulez-vous qu'on comprenne?
Ma deuxieme objection est beaucoup plus serieuse.
Le senateur Grafstein est un homme travaillant, et un modele au Senat.
Il n'y a pas de doute la-dessus.
Son role est essentiellement d'etre juge au Canada.
On lui a demande son avis sur une politique.
Nous sommes en train de formuler la politique.
Nous voudrions avoir votre avis a cet egard.
Je ne vous cacherai pas que cela m'a embete.
J'ai assez d'experience pour vous dire que cela n'est pas acceptable.
Je pense que le senateur Grafstein, comme on dit en anglais ...
... s'est emballe pour cette affaire.
Telles sont mes deux objections.
L'honorable Jerahmiel S. Grafstein :
Honorables senateurs, si vous me le permettez, je repondrez a cela que c'est inusite.
Je suis on ne peut plus d'accord avec le senateur Bolduc.
La ministre m'y a pousse.
Ce n'est pas pertinent.
Tres franchement, c'est accessoire a mon argumentation.
Je ne cherche pas ici a critiquer la juge Arbour.
Si j'ai depasse les bornes, je me retracte.
Je suis d'accord avec le senateur.
Honorables senateurs, je ne mets pas en cause l'ethique du senateur Grafstein.
Il n'y a pas de doute qu'il a fait cela pour bien faire.
Je ne mets pas en cause l'ethique de Mme Arbour.
Et cela est tres embetant.
It is a mistake, a huge mistake.
Nous recevons souvent des temoins du ministere des Finances.
Je fais toujours attention de ne pas les coincer sur des questions de politique.
Cela ne marche pas.
Je pense qu'elle ne doit pas dire cela.
Si elle l'a dit, c'est une erreur.
Je pense qu'il ne faut pas lui demander son avis la-dessus.
Je l'assimile donc a un sous-ministre.
Ils doivent le lui dire avec conviction.
Le ministre, a ce moment-la, decide.
Pour sauver notre processus, il est important qu'on n'y fasse pas allusion.
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
Je suis d'accord avec le leader adjoint du gouvernement.
Il y a la un defaut de processus fondamental.
L'honorable Noel A. Kinsella (chef adjoint de l'opposition) :
Cet usage est clair.
Il est enonce dans le Beauchesne.
L'honorable Marcel Prud'homme :
Honorables senateurs, je pense que les senateurs Kinsella et Carstairs ont souleve un excellent point.
Vous pourriez rendre votre decision demain.
L'honorable John Lynch-Staunton (chef de l'opposition) :
Je pense meme qu'il ne devrait pas y avoir de debat la-dessus.
Tout d'abord, la question du texte en francais me preoccupe aussi.
Le traducteur travaille sur ce texte depuis environ huit heures.
Je reconnais que la question est extremement complexe.
Je ne suis pas du tout insensible a l'aspect linguistique.
Honorables senateurs, j'invoque le Reglement.
Honorables senateurs, on ne peut pas dissocier Mme Arbour de son titre.
Elle est la juge Arbour.
On ne peut pas la dissocier de son titre.
Nous nous enlisons de plus en plus.
Mon coeur ne pourrait pas tenir jusqu'a la fin du debat.
J'essaie d'etre raisonnable et de faire une proposition intelligente au senateur Grafstein.
Le senateur Grafstein pourra alors poursuivre son intervention.
De plus, nous aurons le temps de voir ses amendements dans les deux langues officielles.
Le debat sur les amendements est suspendu ipso facto .
Son Honneur le President :
Le senateur Kinsella desire-t-il s'exprimer sur la question?
Honorables senateurs, le senateur Grafstein pourrait peut-etre ajourner le debat, qui pourrait reprendre demain.
Le President n'aurait donc pas a se prononcer sur cette question.
Cela ne regle pas le probleme.
Son Honneur le President :
Je pense que ce pourrait etre la meilleure solution pour l'instant.
Je pourrais me prononcer immediatement.
Cependant, je prefererais analyser les precedents de plus pres.
(Sur la motion du senateur Grafstein, le debat est ajourne.)
Les travaux du Senat
L'honorable Sharon Carstairs (leader adjoint du gouvernement) :
L'honorable Marcel Prud'homme :
Je suis pret et dispose a aller de l'avant.
La notion de senateur independant n'existe pas.
Je vois que tous les interesses sont presents au Senat aujourd'hui.
Seront-ils la demain?
J'espere que nous aborderons bientot cette question.
Je ne m'oppose pas a la suggestion du senateur Carstairs.
Son Honneur le President :
L'honorable James F. Kelleher :
Honorables senateurs, je propose...
Honorables senateurs, pourrais-je interrompre ce que, sauf erreur, le senateur Kelleher essaie de faire?
Honorables senateurs, j'invoque le Reglement.
Le senateur Carstairs a propose l'ajournement du Senat.
D'autres senateurs pourraient dire en effet: Et la mienne?
Bien sur, elle peut demander le report, nous verrons.
Son Honneur le President :
S'il veut bien donner le consentement unanime, nous ajournerons.
Y a-t-il consentement unanime, honorables senateurs?
(Le Senat s'ajourne a 14 heures demain.)

ext: f


text:
ELEMENTAL FUNCTION func_degrees(x) RESULT(ans)
    ! This function returns the passed angle converted from radians to degrees.

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare input variables ...
    REAL(kind = REAL64), INTENT(in)                                             :: x        ! The input angle in radians.

    ! Declare output variables ...
    REAL(kind = REAL64)                                                         :: ans      ! The output angle in degrees.

    ! Set value ...
    ans = 180.0e0_REAL64 * x / const_pi                                         ! [deg]
END FUNCTION func_degrees

max_stars_repo_name: Guymer/fortranlib

max_issues_repo_name: Guymer/fortranlib

max_forks_repo_name: Guymer/fortranlib


text:
C Copyright (c) 2007 Sandia Corporation. Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government
C retains certain rights in this software.
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C     * Redistributions of source code must retain the above copyright
C       notice, this list of conditions and the following disclaimer.
C
C     * Redistributions in binary form must reproduce the above
C       copyright notice, this list of conditions and the following
C       disclaimer in the documentation and/or other materials provided
C       with the distribution.
C
C     * Neither the name of Sandia Corporation nor the names of its
C       contributors may be used to endorse or promote products derived
C       from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C

C=======================================================================
      SUBROUTINE WRNAME (NTXT, NDIM, NELBLK, NVARGL, NVARNP,
     &                   NVAREL, NAMEGV, NAMENV, NAMEEV, ISEVOK, NAMLEN)
C=======================================================================
C   --
C   --*** WRNAME *** (TXTEXO) Write database names
C   --   Written by Amy Gilkey - revised 02/08/88
C   --   Modified for ExodusIIv2 format 10/16/95
C   --
C   --WRNAME writes the names of the coordinates, the element block types,
C   --and the database variables.  The element block variable truth table
C   --is also written.
C   --
C   --Parameters:
C   --   NTXT   - IN - the text file
C   --   NDIM   - IN - the number of coordinates per node; written only if >= 0
C   --   NELBLK - IN - the number of element blocks; written only if >= 0
C   --   NVARGL - IN - the number of global variables
C   --   NVARNP - IN - the number of nodal variables
C   --   NVAREL - IN - the number of element variables
C   --   NAMEGV - IN - the global variable names
C   --   NAMENV - IN - the nodal variable names
C   --   NAMEEV - IN - the element variable names
C   --   ISEVOK - IN - the element block variable truth table;
C   --                 variable i of block j exists iff ISEVOK(j,i)

      INTEGER NTXT, NDIM, NELBLK, NVARGL, NVARNP, NVAREL
      CHARACTER*(namlen) NAMEGV(*)
      CHARACTER*(namlen) NAMENV(*)
      CHARACTER*(namlen) NAMEEV(*)
      LOGICAL ISEVOK(NELBLK,*)

      IF (NDIM .LT. 0) GOTO 110

C   --Write variable names

      WRITE (NTXT, '(A)') '! Variable names'
      WRITE (NTXT, 10010) NVARGL, NVARNP, NVAREL,
     &   '! global, nodal, element variables'

      WRITE (NTXT, 10000) (NAMEGV(I), I=1,NVARGL)

      WRITE (NTXT, 10000) (NAMENV(I), I=1,NVARNP)

      WRITE (NTXT, 10000) (NAMEEV(I), I=1,NVAREL)

C   --Write the element block variable truth table

      if (nvarel .gt. 0) then
        WRITE (NTXT, '(A)') '! Element block variable truth table'
        DO 100 IELB = 1, NELBLK
          WRITE (NTXT, 10020) (ISEVOK(IELB,I), I=1,NVAREL)
 100    CONTINUE
      end if
  110 CONTINUE
      RETURN
10000  FORMAT (2 (A, 1X))
10010  FORMAT (3I10, 6X, A)
10020  FORMAT (40L2)
      END

max_stars_repo_name: milljm/seacas

max_issues_repo_name: milljm/seacas

max_forks_repo_name: milljm/seacas


text:
subroutine SHExpandDHC(grid, n, cilm, lmax, norm, sampling, csphase, lmax_calc)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This routine will expand a grid containing N samples in both longitude
!	and latitude (or N x 2N, see below) into spherical harmonics. This routine
!	makes use of the sampling theorem presented in Driscoll and Healy (1994)
!	and employs FFTs when calculating the exponential terms. The number of
!	samples, N, must be EVEN for this routine to work, and the spherical
!	harmonic expansion is exact if the function is bandlimited to degree N/2-1.
!	Legendre functions are computed on the fly using the scaling methodolgy
!	presented in Holmes and Featherston (2002). When NORM is 1,2 or 4, these are
!	accurate to about degree 2800. When NORM is 3, the routine is only stable
!	to about degree 15. If the optional parameter LMAX_CALC is specified, the
!	spherical harmonic coefficients will only be calculated up to this degree.
!
!	If SAMPLING is 1 (default), the input grid contains N samples in latitude from
!	90 to -90+interval, and N samples in longitude from 0 to 360-2*interval, where
!	interval is the latitudinal sampling interval 180/N. Note that the datum at
!	90 degees North latitude is ultimately downweighted to zero, so this point
!	does not contribute to the spherical harmonic coefficients. If SAMPLING is 2,
!	the input grid must contain N samples in latitude and 2N samples in longitude.
!	In this case, the sampling intervals in latitude and longitude are 180/N and
!	360/N respectively. When performing the FFTs in longitude, the frequencies greater
!	than N/2-1 are simply discarded to prevent aliasing.
!
!	The complex spherical harmonics are output in the array cilm. Cilm(1,,) contains the
!	positive m term, wheras cilm(2,,) contains the negative m term. The negative order
!	Legendre functions are calculated making use of the identity Y_{lm}^* = (-1)^m Y_{l,-m}.
!
!	Calling Parameters:
!		IN
!			grid		Equally sampled grid in latitude and longitude of dimension
!					(1:N, 1:N) or and equally spaced grid of dimension (1:N,2N).
!			N		Number of samples in latitude and longitude (for SAMPLING=1),
!					or the number of samples in latitude (for SAMPLING=2).
!		OUT
!			cilm		Array of spherical harmonic coefficients with dimension
!					(2, LMAX+1, LMAX+1), or, if LMAX_CALC is present
!					(2, LMAX_CALC+1, LMAX_CALC+1).
!			lmax		Spherical harmonic bandwidth of the grid. This corresponds
!					to the maximum spherical harmonic degree of the expansion
!					if the optional parameter LMAX_CALC is not specified.
!		OPTIONAL (IN)
!			norm		Normalization to be used when calculating Legendre functions
!						(1) "geodesy" (default)
!						(2) Schmidt
!						(3) unnormalized
!						(4) orthonormalized
!			sampling	(1) Grid is N latitudes by N longitudes (default).
!					(2) Grid is N by 2N. The higher frequencies resulting
!					from this oversampling are discarded, and hence not
!					aliased into lower frequencies.
!			csphase		1: Do not include the Condon-Shortley phase factor of (-1)^m.
!					-1: Apply the Condon-Shortley phase factor of (-1)^m.
!			lmax_calc	The maximum spherical harmonic degree calculated in the
!					spherical harmonic expansion.
!
!	Notes:
!		1.	This routine does not use the fast legendre transforms that
!		   	are presented in Driscoll and Heally (1994).
!		2. 	Use of a N by 2N grid is implemented because many geographic grids are
!			sampled this way. When taking the Fourier transforms in longitude, all of the
!			higher frequencies are ultimately discarded. If, instead, every other column of the
!			grid were discarded to form a NxN grid, higher frequencies could be aliased
!			into lower frequencies.
!
!	Dependencies:		DHaj, FFTW3, CSPHASE_DEFAULT
!
!
!	Written by Mark Wieczorek (May 2008).
!
!	August 18, 2009.	Fixed memory issue that could have given rise to errors when
!				called with LMAX_CALC = 0.
!	November 21, 2011	Fixed problem where saved variables used in Plm recursion were not recalculated
!				if NORM changed from one call to the next (with the same value of N).
!
!
!	Copyright (c) 2008-2011, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	use FFTW3
	use SHTOOLS, only: DHaj, CSPHASE_DEFAULT

	implicit none

	complex*16, intent(in) ::	grid(:,:)
	complex*16, intent(out) ::	cilm(:,:,:)
	integer, intent(in) ::	n
	integer, intent(out) ::	lmax
	integer, intent(in), optional :: norm, sampling, csphase, lmax_calc
	complex*16 ::		cc(2*n), gridl(2*n), fcoef1(2*n), fcoef2(2*n)
	integer ::		l, m, k, kstart, i, l1, m1, i_eq, i_s, phase, lnorm, astat(5), &
				lmax_comp, nlong
	integer*8 ::		plan
	real*8 ::		pi, aj(n), theta, prod, scalef, rescalem, u, p, pmm, pm1, pm2, z
	real*8, save, allocatable ::	f1(:), f2(:), sqr(:), symsign(:)
	integer, save ::	lmax_old=0, norm_old = 0

	lmax = n/2 - 1

	if (present(lmax_calc)) then
		lmax_comp = min(lmax, lmax_calc)
	else
		lmax_comp = lmax
	endif

	if (present(lmax_calc)) then
		if (lmax_calc > lmax) then
			print*, "Error --- SHExpandDHC"
			print*, "LMAX_CALC must be less than or equal to the effective bandwidth of GRID."
			print*, "Effective bandwidth of GRID = N/2 - 1 = ", lmax
			print*, "LMAX_CALC = ", lmax_calc
			stop
		endif
	endif

	if (present(sampling)) then
		if (sampling /= 1 .and. sampling /=2) then
			print*, "Error --- SHExpandDHC"
			print*, "Optional parameter SAMPLING must be 1 (N by N) or 2 (N by 2N)."
			print*, "Input value is ", sampling
			stop
		endif
	endif

	if (mod(n,2) /=0) then
		print*, "Error --- SHExpandDHC"
		print*, "The number of samples in latitude and longitude, n, must be even."
		print*, "Input value is ", n
		stop
	elseif (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) <  lmax_comp+1 .or. &
			size(cilm(1,1,:)) < lmax_comp+1) then
		print*, "Error --- SHExpandDHC"
		print*, "CILM must be dimensioned as (2, LMAX_COMP+1, LMAX_COMP+1) where"
		print*, "LMAX_COMP = MIN(N/2, LMAX_CALC+1)"
		print*, "N = ", n
		if (present(lmax_calc)) print*, "LMAX_CALC = ", lmax_calc
		print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), size(cilm(1,1,:))
		stop
	endif

	if (present(sampling)) then
		if (sampling == 1) then
			if (size(grid(:,1)) < n .or. size(grid(1,:)) < n) then
				print*, "Error --- SHExpandDHC"
				print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
				print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
				stop
			endif
		elseif (sampling ==2) then
			if (size(grid(:,1)) < n .or. size(grid(1,:)) < 2*n) then
				print*, "Error --- SHExpandDHC"
				print*, "GRIDDH must be dimensioned as (N, 2*N) where N is ", n
				print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
				stop
			endif
		endif
	else

		if (size(grid(:,1)) < n .or. size(grid(1,:)) < n) then
			print*, "Error --- SHExpandDHC"
			print*, "GRIDDH must be dimensioned as (N, N) where N is ", n
			print*, "Input dimension is ", size(grid(:,1)), size(grid(1,:))
			stop
		endif

	endif

	if (present(csphase)) then
     		if (csphase /= -1 .and. csphase /= 1) then
     			print*, "SHExpandDHC --- Error"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)."
     			print*, "Input value is ", csphase
     			stop
     		else
     			phase = csphase
     		endif
     	else
     		phase = CSPHASE_DEFAULT
     	endif

    	if (present(norm)) then
		if (norm > 4 .or. norm < 1) then
			print*, "Error --- SHExpandDHC"
			print*, "Parameter NORM must be 1 (geodesy), 2 (Schmidt), 3 (unnormalized), or 4 (orthonormalized)."
			print*, "Input value is ", norm
			stop
		endif

		lnorm = norm

	else
		lnorm = 1
	endif

	pi = acos(-1.0d0)

	cilm = (0.0d0, 0.0d0)

	scalef = 1.0d-280

	call DHaj(n, aj)
	aj(1:n) = aj(1:n)*sqrt(4.0d0*pi) 	! Driscoll and Heally use unity normalized spherical harmonics

	if (present(sampling)) then
		if (sampling == 1) then
			nlong = n
		else
			nlong = 2*n
		endif
	else
		nlong = n
	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate recursion constants used in computing the Legendre polynomials
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	if (lmax_comp /= lmax_old .or. lnorm /= norm_old) then

		if (allocated(sqr)) deallocate(sqr)
		if (allocated(f1)) deallocate(f1)
		if (allocated(f2)) deallocate(f2)
		if (allocated(symsign)) deallocate(symsign)

		allocate(sqr(2*lmax_comp+1), stat=astat(1))
		allocate(f1((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(2))
		allocate(f2((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(3))
		allocate(symsign((lmax_comp+1)*(lmax_comp+2)/2), stat=astat(4))

		if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0 .or. astat(4) /= 0) then
			print*, "Error --- SHExpandDHC"
			print*, "Problem allocating arrays SQR, F1, F2, or SYMSIGN", astat(1), astat(2), astat(3), astat(4)
			stop
		endif

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Calculate signs used for symmetry of Legendre functions about equator
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		k = 0
		do l = 0, lmax_comp, 1
			do m = 0, l, 1
				k = k + 1
				if (mod(l-m,2) == 0) then
					symsign(k) = 1.0d0
				else
					symsign(k) = -1.0d0
				endif
			enddo
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		!	Precompute square roots of integers that are used several times.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		do l=1, 2*lmax_comp+1
			sqr(l) = sqrt(dble(l))
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Precompute multiplicative factors used in recursion relationships
		! 		P(l,m) = x*f1(l,m)*P(l-1,m) - P(l-2,m)*f2(l,m)
		!		k = l*(l+1)/2 + m + 1
		!	Note that prefactors are not used for the case when m=l as a different
		!	recursion is used. Furthermore, for m=l-1, Plmbar(l-2,m) is assumed to be zero.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		k = 1

		select case(lnorm)

			case(1,4)

				if (lmax_comp /= 0) then
					k = k + 1
					f1(k) = sqr(3)
					f2(k) = 0.0d0
					k = k + 1
				endif

				do l=2, lmax_comp, 1
					k = k + 1
					f1(k) = sqr(2*l-1) * sqr(2*l+1) / dble(l)
					f2(k) = dble(l-1) * sqr(2*l+1) / sqr(2*l-3) / dble(l)
					do m=1, l-2, 1
						k = k+1
						f1(k) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                				f2(k) = sqr(2*l+1) * sqr(l-m-1) * sqr(l+m-1) &
                  				 	/ sqr(2*l-3) / sqr(l+m) / sqr(l-m)
					enddo
					k = k+1
					f1(k) = sqr(2*l+1) * sqr(2*l-1) / sqr(l+m) / sqr(l-m)
                			f2(k) = 0.0d0
					k = k + 1
				enddo

			case(2)

				if (lmax_comp /= 0) then
					k = k + 1
					f1(k) = 1.0d0
					f2(k) = 0.0d0
					k = k + 1
				endif

				do l=2, lmax_comp, 1
					k = k + 1
					f1(k) = dble(2*l-1) /dble(l)
					f2(k) = dble(l-1) /dble(l)
					do m=1, l-2, 1
						k = k+1
						f1(k) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  				f2(k) = sqr(l-m-1) * sqr(l+m-1) / sqr(l+m) / sqr(l-m)
					enddo
					k = k+1
					f1(k) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  			f2(k) = 0.0d0
					k = k + 1
				enddo

			case(3)

				do l=1, lmax_comp, 1
					k = k + 1
					f1(k) = dble(2*l-1) /dble(l)
					f2(k) = dble(l-1) /dble(l)
					do m=1, l-1, 1
						k = k+1
						f1(k) = dble(2*l-1) / dble(l-m)
                  				f2(k) = dble(l+m-1) / dble(l-m)
					enddo
					k = k + 1
				enddo

		end select

		lmax_old = lmax_comp
		norm_old = lnorm

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Create generic plan for gridl
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	call dfftw_plan_dft_1d_(plan, nlong, gridl(1:nlong), cc(1:nlong), FFTW_FORWARD, FFTW_MEASURE)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Integrate over all latitudes. Take into account symmetry of the
	!	Plms about the equator.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	i_eq = n/2 + 1	! Index correspondong to the equator

	do i=2, i_eq - 1, 1

		theta = pi * dble(i-1)/dble(n)
		z = cos(theta)
		u = sqrt( (1.0d0-z) * (1.0d0+z) )

		gridl(1:nlong) = grid(i,1:nlong)
		call dfftw_execute_(plan)	! take fourier transform
		fcoef1(1:nlong) = cc(1:nlong) * sqrt(2.0d0*pi) * aj(i) / dble(nlong) 	! positive frequencies up to n/2,
											! negative frequencies beyond in oposite order

		i_s = 2*i_eq -i

		gridl(1:nlong) = grid(i_s,1:nlong)
		call dfftw_execute_(plan)	! take fourier transform
		fcoef2(1:nlong) = cc(1:nlong) * sqrt(2.0d0*pi) * aj(i_s) / dble(nlong)

		select case(lnorm)
			case(1,2,3);	pm2 = 1.0d0
			case(4);	pm2 = 1.0d0 / sqrt(4.0d0*pi)
		end select

		cilm(1,1,1) = cilm(1,1,1) + pm2 * (fcoef1(1) + fcoef2(1) )
		! symsign(1) = 1

		if (lmax_comp == 0) cycle

		k = 2
		pm1 =  f1(k) * z * pm2
		cilm(1,2,1) = cilm(1,2,1) + pm1 * ( fcoef1(1) - fcoef2(1) )
		! symsign(2) = -1

		do l=2, lmax_comp, 1
			l1 = l+1
			k = k+l
			p = f1(k) * z * pm1 - f2(k) * pm2
			pm2 = pm1
			pm1 = p
			cilm(1,l1,1) = cilm(1,l1,1) + p * ( fcoef1(1) + fcoef2(1) * symsign(k) )
		enddo

		select case(lnorm)
			case(1,2,3);	pmm = scalef
			case(4);	pmm = scalef / sqrt(4.0d0*pi)
		end select

		rescalem = 1.0d0/scalef
		kstart = 1

		do m = 1, lmax_comp-1, 1

			m1 = m+1
			rescalem = rescalem * u
			kstart = kstart+m+1

			select case(lnorm)
				case(1,4)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm
				case(2)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm / sqr(2*m+1)
				case(3)
					pmm = phase * pmm * dble(2*m-1)
					pm2 = pmm
			end select

			fcoef1(m1) = fcoef1(m1) * rescalem
			fcoef1(nlong-(m-1)) = fcoef1(nlong-(m-1)) * rescalem * dble((-1)**mod(m,2)) ! multiply by (-1)^m for P_{l,-m}
			fcoef2(m1) = fcoef2(m1) * rescalem
			fcoef2(nlong-(m-1)) = fcoef2(nlong-(m-1)) * rescalem * dble((-1)**mod(m,2))

			cilm(1,m1,m1) = cilm(1,m1,m1) + pm2 * ( fcoef1(m1) + fcoef2(m1) )
			cilm(2,m1,m1) = cilm(2,m1,m1) + pm2 * ( fcoef1(nlong-(m-1)) + fcoef2(nlong-(m-1)) )
			! symsign(kstart) = 1

			k = kstart+m+1
	   		pm1 = z * f1(k) * pm2

	   		cilm(1,m1+1,m1) = cilm(1,m1+1,m1) + pm1 * ( fcoef1(m1) - fcoef2(m1) )
               		cilm(2,m1+1,m1) = cilm(2,m1+1,m1) +  pm1 * ( fcoef1(nlong-(m-1)) - fcoef2(nlong-(m-1)) )
               		! symsign(k) = -1

			do l = m+2, lmax_comp, 1
				l1 = l+1
				k = k+l
                  		p = z * f1(k) * pm1-f2(k) * pm2
                  		pm2 = pm1
                  		pm1 = p
				cilm(1,l1,m1) = cilm(1,l1,m1) + p * ( fcoef1(m1) + fcoef2(m1) * symsign(k) )
				cilm(2,l1,m1) = cilm(2,l1,m1) + p * &
						( fcoef1(nlong-(m-1)) + fcoef2(nlong-(m-1)) * symsign(k) )
			enddo

		enddo

		rescalem = rescalem * u

            	select case(lnorm)
            		case(1,4);	pmm = phase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            		case(2);	pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
            		case(3);	pmm = phase * pmm * dble(2*lmax_comp-1) * rescalem
        	end select

        	cilm(1,lmax_comp+1,lmax_comp+1) = cilm(1,lmax_comp+1,lmax_comp+1) + pmm * &
        			( fcoef1(lmax_comp+1) + fcoef2(lmax_comp+1) )
        	cilm(2,lmax_comp+1,lmax_comp+1) = cilm(2,lmax_comp+1,lmax_comp+1) + pmm * &
        			( fcoef1(nlong-(lmax_comp-1)) + fcoef2(nlong-(lmax_comp-1)) )
        			! symsign = 1

	enddo

	! Finally, do equator

	i = i_eq

	z = 0.0d0
	u = 1.0d0

	gridl(1:nlong) = grid(i,1:nlong)
	call dfftw_execute_(plan)	! take fourier transform
	fcoef1(1:nlong) = cc(1:nlong) * sqrt(2.0d0*pi) * aj(i) / dble(nlong)

	select case(lnorm)
		case(1,2,3);	pm2 = 1.0d0
		case(4);	pm2 = 1.0d0 / sqrt(4.0d0*pi)
	end select

	cilm(1,1,1) = cilm(1,1,1) + pm2 * fcoef1(1)

	if (lmax_comp /= 0) then

		k = 2

		do l=2, lmax_comp, 2
			l1 = l+1
			k = k+l
			p = - f2(k) * pm2
			pm2 = p
			cilm(1,l1,1) = cilm(1,l1,1) + p * fcoef1(1)
			k = k + l + 1
		enddo

		select case(lnorm)
			case(1,2,3);	pmm = scalef
			case(4);	pmm = scalef / sqrt(4.0d0*pi)
		end select

		rescalem = 1.0d0/scalef
		kstart = 1

		do m = 1, lmax_comp-1, 1

			m1 = m+1
			kstart = kstart+m+1

			select case(lnorm)
				case(1,4)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm
				case(2)
					pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
					pm2 = pmm / sqr(2*m+1)
				case(3)
					pmm = phase * pmm * dble(2*m-1)
					pm2 = pmm
			end select

			fcoef1(m1) = fcoef1(m1) * rescalem
			fcoef1(nlong-(m-1)) = fcoef1(nlong-(m-1)) * rescalem * dble((-1)**mod(m,2))

			cilm(1,m1,m1) = cilm(1,m1,m1) + pm2 * fcoef1(m1)
			cilm(2,m1,m1) = cilm(2,m1,m1) + pm2 * fcoef1(nlong-(m-1))

			k = kstart+m+1

			do l = m+2, lmax_comp, 2
				l1 = l+1
				k = k+l
                  		p = - f2(k) * pm2
                  		pm2 = p
				cilm(1,l1,m1) = cilm(1,l1,m1) + p * fcoef1(m1)
				cilm(2,l1,m1) = cilm(2,l1,m1) + p * fcoef1(nlong-(m-1))
				k = k + l + 1
			enddo

		enddo

        	select case(lnorm)
            		case(1,4);	pmm = phase * pmm * sqr(2*lmax_comp+1) / sqr(2*lmax_comp) * rescalem
            		case(2);	pmm = phase * pmm / sqr(2*lmax_comp) * rescalem
            		case(3);	pmm = phase * pmm * dble(2*lmax_comp-1) * rescalem
        	end select

        	cilm(1,lmax_comp+1,lmax_comp+1) = cilm(1,lmax_comp+1,lmax_comp+1) + pmm * fcoef1(lmax_comp+1)
        	cilm(2,lmax_comp+1,lmax_comp+1) = cilm(2,lmax_comp+1,lmax_comp+1) + dble((-1)**mod(lmax_comp,2)) * &
        		pmm * fcoef1(nlong-(lmax_comp-1))

        endif

	call dfftw_destroy_plan_(plan)

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	! 	Divide by integral of Ylm*Ylm
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	select case(lnorm)

		case(1)

			do l=0, lmax_comp, 1
				cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) / (4.0d0*pi)
			enddo

		case(2)

			do l=0, lmax_comp, 1
				cilm(1:2,l+1, 1:l+1) = cilm(1:2,l+1, 1:l+1) * dble(2*l+1) / (4.0d0*pi)
			enddo

		case(3)

			do l=0, lmax_comp, 1
				prod = 4.0d0*pi/dble(2*l+1)
				cilm(1,l+1,1) = cilm(1,l+1,1) / prod
				do m=1, l-1, 1
					prod = prod * dble(l+m) * dble(l-m+1)
					cilm(1:2,l+1,m+1) = cilm(1:2,l+1,m+1) / prod
				enddo
				!do m=l case
				if (l /= 0) cilm(1:2,l+1,l+1) = cilm(1:2,l+1, l+1)/(prod*dble(2*l))
			enddo

	end select

end subroutine SHExpandDHC

max_stars_repo_name: JackWalpole/seismo-fortran-fork

max_issues_repo_name: JackWalpole/seismo-fortran-fork

max_forks_repo_name: JackWalpole/seismo-fortran-fork


text:
      SUBROUTINE DROTMGF (DD1,DD2,DX1,DY1,DPARAM)
C
C     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
C     THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)*
C     DY2)**T.
C     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
C
C     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0
C
C       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0)
C     H=(          )    (          )    (          )    (          )
C       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0).
C     LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
C     RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
C     VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
C
C     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
C     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
C     OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
C
      DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2,
     1 DQ2,DU,DY1,ZERO,GAMSQ,DD1,DFLAG,DH12,DH22,DP1,DQ1,
     2 DTEMP,DX1,TWO
      DIMENSION DPARAM(5)
C
      DATA ZERO,ONE,TWO /0.D0,1.D0,2.D0/
      DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
      IF(.NOT. DD1 .LT. ZERO) GO TO 10
C       GO ZERO-H-D-AND-DX1..
          GO TO 60
   10 CONTINUE
C     CASE-DD1-NONNEGATIVE
      DP2=DD2*DY1
      IF(.NOT. DP2 .EQ. ZERO) GO TO 20
          DFLAG=-TWO
          GO TO 260
C     REGULAR-CASE..
   20 CONTINUE
      DP1=DD1*DX1
      DQ2=DP2*DY1
      DQ1=DP1*DX1
C
      IF(.NOT. DABS(DQ1) .GT. DABS(DQ2)) GO TO 40
          DH21=-DY1/DX1
          DH12=DP2/DP1
C
          DU=ONE-DH12*DH21
C
          IF(.NOT. DU .LE. ZERO) GO TO 30
C         GO ZERO-H-D-AND-DX1..
               GO TO 60
   30     CONTINUE
               DFLAG=ZERO
               DD1=DD1/DU
               DD2=DD2/DU
               DX1=DX1*DU
C         GO SCALE-CHECK..
               GO TO 100
   40 CONTINUE
          IF(.NOT. DQ2 .LT. ZERO) GO TO 50
C         GO ZERO-H-D-AND-DX1..
               GO TO 60
   50     CONTINUE
               DFLAG=ONE
               DH11=DP1/DP2
               DH22=DX1/DY1
               DU=ONE+DH11*DH22
               DTEMP=DD2/DU
               DD2=DD1/DU
               DD1=DTEMP
               DX1=DY1*DU
C         GO SCALE-CHECK
               GO TO 100
C     PROCEDURE..ZERO-H-D-AND-DX1..
   60 CONTINUE
          DFLAG=-ONE
          DH11=ZERO
          DH12=ZERO
          DH21=ZERO
          DH22=ZERO
C
          DD1=ZERO
          DD2=ZERO
          DX1=ZERO
C         RETURN..
          GO TO 220
C     PROCEDURE..FIX-H..
   70 CONTINUE
      IF(.NOT. DFLAG .GE. ZERO) GO TO 90
C
          IF(.NOT. DFLAG .EQ. ZERO) GO TO 80
          DH11=ONE
          DH22=ONE
          DFLAG=-ONE
          GO TO 90
   80     CONTINUE
          DH21=-ONE
          DH12=ONE
          DFLAG=-ONE
   90 CONTINUE
      GO TO IGO,(120,150,180,210)
C     PROCEDURE..SCALE-CHECK
  100 CONTINUE
  110     CONTINUE
          IF(.NOT. DD1 .LE. RGAMSQ) GO TO 130
               IF(DD1 .EQ. ZERO) GO TO 160
               ASSIGN 120 TO IGO
C              FIX-H..
               GO TO 70
  120          CONTINUE
               DD1=DD1*GAM**2
               DX1=DX1/GAM
               DH11=DH11/GAM
               DH12=DH12/GAM
          GO TO 110
  130 CONTINUE
  140     CONTINUE
          IF(.NOT. DD1 .GE. GAMSQ) GO TO 160
               ASSIGN 150 TO IGO
C              FIX-H..
               GO TO 70
  150          CONTINUE
               DD1=DD1/GAM**2
               DX1=DX1*GAM
               DH11=DH11*GAM
               DH12=DH12*GAM
          GO TO 140
  160 CONTINUE
  170     CONTINUE
          IF(.NOT. DABS(DD2) .LE. RGAMSQ) GO TO 190
               IF(DD2 .EQ. ZERO) GO TO 220
               ASSIGN 180 TO IGO
C              FIX-H..
               GO TO 70
  180          CONTINUE
               DD2=DD2*GAM**2
               DH21=DH21/GAM
               DH22=DH22/GAM
          GO TO 170
  190 CONTINUE
  200     CONTINUE
          IF(.NOT. DABS(DD2) .GE. GAMSQ) GO TO 220
               ASSIGN 210 TO IGO
C              FIX-H..
               GO TO 70
  210          CONTINUE
               DD2=DD2/GAM**2
               DH21=DH21*GAM
               DH22=DH22*GAM
          GO TO 200
  220 CONTINUE
          IF(DFLAG)250,230,240
  230     CONTINUE
               DPARAM(3)=DH21
               DPARAM(4)=DH12
               GO TO 260
  240     CONTINUE
               DPARAM(2)=DH11
               DPARAM(5)=DH22
               GO TO 260
  250     CONTINUE
               DPARAM(2)=DH11
               DPARAM(3)=DH21
               DPARAM(4)=DH12
               DPARAM(5)=DH22
  260 CONTINUE
          DPARAM(1)=DFLAG
          RETURN
      END


text:
Describe Users/SabrinaT here.
Welcome to the Wiki, Sabrina!  Like Peter said on The Arbors page, you might have better luck calling them directly.  As a side note, texting shorthand is kinda tough to read sometimes.  Here on the wiki, we generally try to write things out. Users/TomGarberson

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search