Changeset 5229 for LMDZ6/branches/Amaury_dev/libf/dyn3d_common/iso_verif_dyn.f90

Timestamp:

Sep 25, 2024, 12:03:08 PM (3 months ago)

Author:

abarral

Message:

Merge r5214

File:

• LMDZ6/branches/Amaury_dev/libf/dyn3d_common/iso_verif_dyn.f90 (modified) (1 diff)

LMDZ6/branches/Amaury_dev/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
+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
 
-  ! input:
-  REAL :: x
-  CHARACTER(LEN = *) :: err_msg ! message d''erreur à afficher
-
-  ! output
-  REAL :: borne
-  parameter (borne = 1e19)
-  INTEGER :: iso_verif_noNaN_nostop
-
-  IF ((x>-borne).AND.(x<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_nonan_nostop
-
-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(LEN = *) :: 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)>errmax) THEN
-    IF (abs((a - b) / max(max(abs(b), abs(a)), 1e-18)) &
-            >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
+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
 
 
-function iso_verif_aberrant_nostop &
-        (x, iso, q, err_msg)
-  USE lmdz_infotrac, ONLY: isoName, getKey
+LOGICAL FUNCTION iso_verif_aberrant_nostop(x, iso, q, err_msg) RESULT(lerr)
   USE ioipsl, ONLY: getin
+  USE iso_params_mod, ONLY: tnat_HDO
 
   IMPLICIT NONE
 
-  ! input:
-  REAL :: x, q
-  INTEGER :: iso ! 2=HDO, 1=O18
-  CHARACTER(LEN = *) :: err_msg ! message d''erreur à afficher
+  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.
-
-  ! 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>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>deltaDmax).OR.(deltaD<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
+     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
-