Changeset 5214 for LMDZ6/trunk/libf/dyn3d_common/iso_verif_dyn.F90

Timestamp:

Sep 22, 2024, 10:07:56 PM (8 hours ago)

Author:

dcugnet

Message:

The fortran parameters file "iso_params_mod.F90" is introduced so that "tnat" and "alpha_ideal" are defined in a single place but used in several.
The "getKey" routine is only used in "infotrac" and "infotrac_phy" routines, but could be used outside this scope to get tracers parameters (read from "tracer.def") or isotopic parameters (read from "isotopes_params.def" - disabled for now).

File:

• LMDZ6/trunk/libf/dyn3d_common/iso_verif_dyn.F90 (moved) (moved from LMDZ6/trunk/libf/dyn3d_common/iso_verif_dyn.F) (1 diff)

LMDZ6/trunk/libf/dyn3d_common/iso_verif_dyn.F90

@@ -1 @@
-        function iso_verif_noNaN_nostop(x,err_msg)
-        implicit none
-        ! si x est NaN, on affiche message
-        ! d'erreur et return 1 si erreur
-
-        ! input:
-        real x
-        character*(*) err_msg ! message d''erreur à afficher
-
-        ! output 
-        real borne
-        parameter (borne=1e19)
-        integer iso_verif_noNaN_nostop
-
-        if ((x.gt.-borne).and.(x.lt.borne)) then
-                iso_verif_noNAN_nostop=0
-        else
-            write(*,*) 'erreur detectee par iso_verif_nonNaN:'
-            write(*,*) err_msg
-            write(*,*) 'x=',x
-            iso_verif_noNaN_nostop=1
-        endif      
-
-        return
-        end
-
-        function iso_verif_egalite_nostop
-     :           (a,b,err_msg)
-        implicit none
-        ! compare a et b. Si pas egal, on affiche message
-        ! d'erreur et stoppe
-        ! pour egalite, on verifie erreur absolue et arreur relative
-
-        ! input:
-        real a, b
-        character*(*) err_msg ! message d''erreur à afficher
-
-        ! locals
-        real errmax ! erreur maximale en absolu.
-        real errmaxrel ! erreur maximale en relatif autorisée
-        parameter (errmax=1e-8)
-        parameter (errmaxrel=1e-3)
-
-        ! output
-        integer iso_verif_egalite_nostop
-
-        iso_verif_egalite_nostop=0
-
-        if (abs(a-b).gt.errmax) then
-          if (abs((a-b)/max(max(abs(b),abs(a)),1e-18))
-     :            .gt.errmaxrel) then
-            write(*,*) 'erreur detectee par iso_verif_egalite:'
-            write(*,*) err_msg
-            write(*,*) 'a=',a
-            write(*,*) 'b=',b
-            iso_verif_egalite_nostop=1
-          endif
-        endif     
-        
-        return
-        end        
+LOGICAL FUNCTION iso_verif_noNaN_nostop(x, err_msg) RESULT(lerr)
+   IMPLICIT NONE
+! If "x" is NaN, print an error message .
+   REAL,             INTENT(IN) :: x
+   CHARACTER(LEN=*), INTENT(IN) :: err_msg
+   REAL, PARAMETER :: borne = 1e19
+   lerr = x > -borne .AND. x < borne
+   IF(.NOT.lerr) RETURN
+   WRITE(*,*) 'erreur detectee par iso_verif_nonNaN:'
+   WRITE(*,*) err_msg
+   WRITE(*,*) 'x=',x
+END FUNCTION iso_verif_noNaN_nostop
 
 
-        function iso_verif_aberrant_nostop
-     :           (x,iso,q,err_msg)
+LOGICAL FUNCTION iso_verif_egalite_nostop(a, b, err_msg) RESULT(lerr)
+   IMPLICIT NONE
+!   Compare "a" and "b". If a/=b, print an error message.
+!   Both absolute and relative errors are checked for equality.
+   REAL,             INTENT(IN) :: a, b
+   CHARACTER(LEN=*), INTENT(IN) :: err_msg
+   REAL, PARAMETER :: errmax = 1e-8, &           ! max absolute error
+                   errmaxrel = 1e-3              ! max relative error
+   lerr = ABS(a-b) > errmax
+   IF(.NOT.lerr) RETURN
+   lerr = ABS( (a-b) / MAX(MAX(ABS(b), ABS(a)),1e-18) ) > errmaxrel
+   IF(.NOT.lerr) RETURN
+   WRITE(*,*) 'erreur detectee par iso_verif_egalite:'
+   WRITE(*,*) err_msg
+   WRITE(*,*) 'a=',a
+   WRITE(*,*) 'b=',b
+END FUNCTION iso_verif_egalite_nostop
+
+
+LOGICAL FUNCTION iso_verif_aberrant_nostop(x, iso, q, err_msg) RESULT(lerr)
 #ifdef CPP_IOIPSL
-        USE IOIPSL, ONLY: getin
+   USE IOIPSL, ONLY: getin
 #else
-        USE ioipsl_getincom, ONLY: getin
+   USE ioipsl_getincom, ONLY: getin
 #endif
-        USE infotrac, ONLY: isoName, getKey
-        implicit none
-        
-        ! input:
-        real x,q
-        integer iso ! 2=HDO, 1=O18
-        character*(*) err_msg ! message d''erreur à afficher
+   USE iso_params_mod, ONLY: tnat_HDO
+   IMPLICIT NONE
+   REAL,             INTENT(IN) :: x, q
+   INTEGER,          INTENT(IN) :: iso ! 2=HDO, 1=O18
+   CHARACTER(LEN=*), INTENT(IN) :: err_msg
 
-        ! locals
-        real qmin,deltaD
-        real deltaDmax,deltaDmin,tnat
-        parameter (qmin=1e-11)
-        parameter (deltaDmax=200.0,deltaDmin=-999.9)
-        LOGICAL, SAVE :: ltnat1
-        LOGICAL, SAVE :: lFirst=.TRUE.
+   REAL, PARAMETER :: qmin = 1e-11, &
+                 deltaDmax = 200.0, &
+                 deltaDmin =-999.9
+   LOGICAL       :: ltnat1
+   LOGICAL, SAVE :: lFirst=.TRUE.
+   REAL,    SAVE :: tnat
+   REAL          :: deltaD
+   IF(lFirst) THEN
+      ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
+      tnat = tnat_HDO; IF(ltnat1) tnat = 1.0
+      lFirst = .FALSE.
+   END IF
+   lerr = q > qmin
+   IF(.NOT.lerr) RETURN
+   deltaD = (x / q /tnat - 1.) * 1000.
+   lerr = deltaD > deltaDmax .OR. deltaD < deltaDmin
+   IF(.NOT.lerr) RETURN
+   WRITE(*,*) 'erreur detectee par iso_verif_aberrant:'
+   WRITE(*,*) err_msg
+   WRITE(*,*) 'q=',q
+   WRITE(*,*) 'deltaD=',deltaD
+   WRITE(*,*) 'iso=',iso
+END FUNCTION iso_verif_aberrant_nostop
 
-        ! output
-        integer iso_verif_aberrant_nostop
-
-        IF(lFirst) THEN
-           ltnat1 = .TRUE.; CALL getin('tnateq1', ltnat1)
-           lFirst = .FALSE.
-        END IF
-        iso_verif_aberrant_nostop=0
-
-        ! verifier que HDO est raisonable
-         if (q.gt.qmin) then
-             IF(ltnat1) THEN
-                tnat = 1.0
-             ELSE IF(getKey('tnat', tnat, isoName(iso))) THEN
-                  err_msg = 'Missing isotopic parameter "tnat"'
-                  iso_verif_aberrant_nostop=1
-                  RETURN
-             END IF
-             deltaD=(x/q/tnat-1)*1000
-             if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
-                  write(*,*) 'erreur detectee par iso_verif_aberrant:'
-                  write(*,*) err_msg
-                  write(*,*) 'q=',q
-                  write(*,*) 'deltaD=',deltaD
-                  write(*,*) 'iso=',iso
-                  iso_verif_aberrant_nostop=1
-             endif !if ((deltaD.gt.deltaDmax).or.(deltaD.lt.deltaDmin)) then
-          endif !if (q(i,k,iq).gt.qmin) then
-
-       
-        return
-        end        
-