Ignore:
Timestamp:
Jul 23, 2024, 7:14:34 PM (8 weeks ago)
Author:
abarral
Message:

Replace 1DUTILS.h by module lmdz_1dutils.f90
Replace 1DConv.h by module lmdz_old_1dconv.f90 (it's only used by old_* files)
Convert *.F to *.f90
Fix gradsdef.h formatting
Remove unnecessary "RETURN" at the end of functions/subroutines

File:
1 moved

Legend:

Unmodified
Added
Removed

  • LMDZ6/branches/Amaury_dev/libf/dyn3d_common/iso_verif_dyn.f90

    r5104 r5105  
    1         function iso_verif_noNaN_nostop(x,err_msg)
    2         implicit none
    3         ! si x est NaN, on affiche message
    4         ! d'erreur et return 1 si erreur
     1  function iso_verif_noNaN_nostop(x,err_msg)
     2    implicit none
     3    ! ! si x est NaN, on affiche message
     4    ! ! d'erreur et return 1 si erreur
    55
    6         ! input:
    7         real x
    8         character*(*) err_msg ! message d''erreur à afficher
     6    ! ! input:
     7    real :: x
     8    character(len=*) :: err_msg ! message d''erreur à afficher
    99
    10         ! output
    11         real borne
    12         parameter (borne=1e19)
    13         integer iso_verif_noNaN_nostop
     10    ! ! output
     11    real :: borne
     12    parameter (borne=1e19)
     13    integer :: iso_verif_noNaN_nostop
    1414
    15         if ((x>-borne).and.(x<borne)) then
    16                 iso_verif_noNAN_nostop=0
    17         else
    18             write(*,*) 'erreur detectee par iso_verif_nonNaN:'
    19             write(*,*) err_msg
    20             write(*,*) 'x=',x
    21             iso_verif_noNaN_nostop=1
    22         endif     
     15    if ((x>-borne).and.(x<borne)) then
     16            iso_verif_noNAN_nostop=0
     17    else
     18        write(*,*) 'erreur detectee par iso_verif_nonNaN:'
     19        write(*,*) err_msg
     20        write(*,*) 'x=',x
     21        iso_verif_noNaN_nostop=1
     22    endif
    2323
    24         return
    25         end
     24    return
     25end function iso_verif_nonan_nostop
    2626
    27         function iso_verif_egalite_nostop
    28      :           (a,b,err_msg)
    29         implicit none
    30         ! compare a et b. Si pas egal, on affiche message
    31         ! d'erreur et stoppe
    32         ! pour egalite, on verifie erreur absolue et arreur relative
     27  function iso_verif_egalite_nostop &
     28          (a,b,err_msg)
     29    implicit none
     30    ! ! compare a et b. Si pas egal, on affiche message
     31    ! ! d'erreur et stoppe
     32    ! ! pour egalite, on verifie erreur absolue et arreur relative
    3333
    34         ! input:
    35         real a, b
    36         character*(*) err_msg ! message d''erreur à afficher
     34    ! ! input:
     35    real :: a, b
     36    character(len=*) :: err_msg ! message d''erreur à afficher
    3737
    38         ! locals
    39         real errmax ! erreur maximale en absolu.
    40         real errmaxrel ! erreur maximale en relatif autorisée
    41         parameter (errmax=1e-8)
    42         parameter (errmaxrel=1e-3)
     38    ! ! locals
     39    real :: errmax ! erreur maximale en absolu.
     40    real :: errmaxrel ! erreur maximale en relatif autorisée
     41    parameter (errmax=1e-8)
     42    parameter (errmaxrel=1e-3)
    4343
    44         ! output
    45         integer iso_verif_egalite_nostop
     44    ! ! output
     45    integer :: iso_verif_egalite_nostop
    4646
    47         iso_verif_egalite_nostop=0
     47    iso_verif_egalite_nostop=0
    4848
    49         if (abs(a-b)>errmax) then
    50           if (abs((a-b)/max(max(abs(b),abs(a)),1e-18))
    51      :            >errmaxrel) then
    52             write(*,*) 'erreur detectee par iso_verif_egalite:'
    53             write(*,*) err_msg
    54             write(*,*) 'a=',a
    55             write(*,*) 'b=',b
    56             iso_verif_egalite_nostop=1
    57           endif
    58         endif     
    59        
    60         return
    61         end       
     49    if (abs(a-b)>errmax) then
     50      if (abs((a-b)/max(max(abs(b),abs(a)),1e-18)) &
     51            >errmaxrel) then
     52        write(*,*) 'erreur detectee par iso_verif_egalite:'
     53        write(*,*) err_msg
     54        write(*,*) 'a=',a
     55        write(*,*) 'b=',b
     56        iso_verif_egalite_nostop=1
     57      endif
     58    endif
     59
     60    return
     61end function iso_verif_egalite_nostop
    6262
    6363
    64         function iso_verif_aberrant_nostop
    65      :           (x,iso,q,err_msg)
    66         USE infotrac, ONLY: isoName, getKey
    67         implicit none
    68        
    69         ! input:
    70         real x,q
    71         integer iso ! 2=HDO, 1=O18
    72         character*(*) err_msg ! message d''erreur à afficher
     64  function iso_verif_aberrant_nostop &
     65          (x,iso,q,err_msg)
     66    USE infotrac, ONLY: isoName, getKey
     67    implicit none
    7368
    74         ! locals
    75         real qmin,deltaD
    76         real deltaDmax,deltaDmin,tnat
    77         parameter (qmin=1e-11)
    78         parameter (deltaDmax=200.0,deltaDmin=-999.9)
     69    ! ! input:
     70    real :: x,q
     71    integer :: iso ! 2=HDO, 1=O18
     72    character(len=*) :: err_msg ! message d''erreur à afficher
    7973
    80         ! output
    81         integer iso_verif_aberrant_nostop
     74    ! ! locals
     75    real :: qmin,deltaD
     76    real :: deltaDmax,deltaDmin,tnat
     77    parameter (qmin=1e-11)
     78    parameter (deltaDmax=200.0,deltaDmin=-999.9)
    8279
    83         iso_verif_aberrant_nostop=0
     80    ! ! output
     81    integer :: iso_verif_aberrant_nostop
    8482
    85         ! verifier que HDO est raisonable
    86          if (q>qmin) then
    87              IF(getKey('tnat', tnat, isoName(iso))) THEN
    88                   err_msg = 'Missing isotopic parameter "tnat"'
    89                   iso_verif_aberrant_nostop=1
    90                   RETURN
    91              END IF
    92              deltaD=(x/q/tnat-1)*1000
    93              if ((deltaD>deltaDmax).or.(deltaD<deltaDmin)) then
    94                   write(*,*) 'erreur detectee par iso_verif_aberrant:'
    95                   write(*,*) err_msg
    96                   write(*,*) 'q=',q
    97                   write(*,*) 'deltaD=',deltaD
    98                   write(*,*) 'iso=',iso
    99                   iso_verif_aberrant_nostop=1
    100              endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
    101           endif !if (q(i,k,iq).gt.qmin) then
     83    iso_verif_aberrant_nostop=0
    10284
    103        
    104         return
    105         end       
     85    ! ! verifier que HDO est raisonable
     86     if (q>qmin) then
     87         IF(getKey('tnat', tnat, isoName(iso))) THEN
     88              err_msg = 'Missing isotopic parameter "tnat"'
     89              iso_verif_aberrant_nostop=1
     90              RETURN
     91         END IF
     92         deltaD=(x/q/tnat-1)*1000
     93         if ((deltaD>deltaDmax).or.(deltaD<deltaDmin)) then
     94              write(*,*) 'erreur detectee par iso_verif_aberrant:'
     95              write(*,*) err_msg
     96              write(*,*) 'q=',q
     97              write(*,*) 'deltaD=',deltaD
     98              write(*,*) 'iso=',iso
     99              iso_verif_aberrant_nostop=1
     100         endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
     101      endif !if (q(i,k,iq).gt.qmin) then
    106102
     103
     104    return
     105end function iso_verif_aberrant_nostop
     106
Note: See TracChangeset for help on using the changeset viewer.