#ifdef ISOVERIF ! $Id: $ MODULE isotopes_verif_mod !use isotopes_mod, ONLY: !#ifdef ISOTRAC ! USE isotrac_mod, ONLY: nzone !#endif USE infotrac_phy, ONLY: ntraciso=>ntiso, niso, itZonIso, nzone IMPLICIT NONE save ! variables de vérifications REAL errmax ! erreur maximale en absolu. parameter (errmax=1e-8) REAL errmax_sol ! erreur maximale en absolu. parameter (errmax_sol=5e-7) REAL errmaxrel ! erreur maximale en relatif autorisée ! parameter (errmaxrel=1e10) parameter (errmaxrel=1e-3) REAL borne ! valeur maximale que n'importe quelle variable peut ! atteindre, en val abs; utile pour vérif que pas NAN parameter (borne=1e19) REAL, save :: deltalim ! deltalim est le maximum de deltaD qu'on ! autorise dans la vapeur, au-dela, en suppose que c'est abérrant. ! dans le liquide, on autorise deltalim*faccond. !$OMP THREADPRIVATE(deltalim) ! parameter (deltalim=1e10) ! parameter (deltalim=300.0) ! maintenant défini dans iso.def REAL, save :: deltalimtrac ! max de deltaD dans les traceurs, défini dans iso.def !$OMP THREADPRIVATE(deltalimtrac) REAL, save :: deltalim_snow ! deltalim est le maximum de deltaD qu'on ! autorise dans la neige, au-dela, en suppose que c'est abérrant. !$OMP THREADPRIVATE(deltalim_snow) ! parameter (deltalim_snow=500.0) ! initalisé dans iso_init REAL, save :: deltaDmin !$OMP THREADPRIVATE(deltaDmin) ! parameter (deltaDmin=-900.0) ! maintentant, défini dans iso.def REAL, save :: o17excess_bas,o17excess_haut ! bornes inf et sup de l'O17-excess ! parameter(o17excess_bas=-200.0,o17excess_haut=120) !$OMP THREADPRIVATE(o17excess_bas,o17excess_haut) INTEGER nlevmaxO17 !$OMP THREADPRIVATE(nlevmaxO17) logical, save :: O17_verif !$OMP THREADPRIVATE(O17_verif) ! parameter (O17_verif=.TRUE.) REAL, save :: dexcess_min,dexcess_max !$OMP THREADPRIVATE(dexcess_min,dexcess_max) REAL faccond ! dans le liquide, on autorise R(deltalim)*faccond. parameter (faccond=1.1) ! LOGICAL bidouille_anti_divergence ! si true, alors on fait un ! ! rappel régulier des xt4 vers les q pour ! !éviter accumulation d'érreurs et divergences ! parameter (bidouille_anti_divergence=.TRUE.) ! parameter (bidouille_anti_divergence=.FALSE.) ! bidouille_anti_divergence a été déplacé dans wateriso2.h et est lue à l'execution real deltaDfaible ! deltaD en dessous duquel la vapeur est tellement faible !que on peut accepter que la remise à l'équilibre du sol avec ! cette vapeur donne des deltaDevap aberrants. parameter (deltaDfaible=-300) REAL deltaDfaible_lax ! deltaD en dessous duquel la vapeur est tellement faible !que on peut accepter que la remise à l'équilibre du sol avec ! cette vapeur donne des deltaDevap aberrants. parameter (deltaDfaible_lax=-180) real faible_evap ! faible évaporation: on est plus laxiste !pour les deltaD aberrant dans le cas de l'évap venant d'orchidee parameter (faible_evap=3.0) real Tmin_verif parameter (Tmin_verif=5.0) ! en K real Tmax_verif parameter (Tmax_verif=1000.0) ! en K ! subroutines de vérifications génériques, à ne pas modifier CONTAINS SUBROUTINE iso_verif_init() USE lmdz_ioipsl_getin_p, ONLY: getin_p USE isotopes_mod, ONLY: iso_O17, iso_O18, iso_HDO IMPLICIT NONE WRITE(*,*) 'iso_verif_init 99: entree' deltalim=300.0 deltalim_snow=500.0 deltaDmin=-900.0 deltalimtrac=2000.0 O17_verif=.FALSE. o17excess_bas=-200.0 o17excess_haut=120.0 dexcess_min=-100.0 dexcess_max=1000.0 CALL getin_p('deltalim',deltalim) deltalim_snow=deltalim+200.0 CALL getin_p('deltaDmin',deltaDmin) CALL getin_p('deltalimtrac',deltalimtrac) WRITE(*,*) 'iso_O17,iso_O18,iso_HDO=',iso_O17,iso_O18,iso_HDO IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN CALL getin_p('O17_verif',O17_verif) CALL getin_p('o17excess_bas',o17excess_bas) CALL getin_p('o17excess_haut',o17excess_haut) CALL getin_p('nlevmaxO17',nlevmaxO17) END IF IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0)) THEN CALL getin_p('dexcess_min',dexcess_min) CALL getin_p('dexcess_max',dexcess_max) END IF WRITE(*,*) 'deltalim=',deltalim WRITE(*,*) 'deltaDmin=',deltaDmin WRITE(*,*) 'deltalimtrac=',deltalimtrac WRITE(*,*) 'O17_verif=',O17_verif WRITE(*,*) 'o17excess_bas=',o17excess_bas WRITE(*,*) 'o17excess_haut=',o17excess_haut WRITE(*,*) 'dexcess_min=',dexcess_min WRITE(*,*) 'dexcess_max=',dexcess_max END SUBROUTINE iso_verif_init SUBROUTINE iso_verif_egalite(a,b,err_msg) IMPLICIT NONE ! compare a et b. Si pas egal à errmax près, on affiche message ! d'erreur et stoppe ! input: REAL a, b character*(*) err_msg ! message d''erreur à afficher ! local !integer iso_verif_egalite_choix_nostop IF (iso_verif_egalite_choix_nostop(a,b,err_msg, & errmax,errmaxrel).EQ.1) THEN stop endif #ifdef ISOVERIF #else WRITE(*,*) 'err_msg=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_egalite !***************** function iso_verif_egalite_nostop(a,b,err_msg) IMPLICIT NONE ! compare a et b. Si pas egal à errmax près, on affiche message ! d'erreur et stoppe ! input: REAL a, b character*(*) err_msg ! message d''erreur à afficher !ouptut INTEGER iso_verif_egalite_nostop ! local !integer iso_verif_egalite_choix_nostop iso_verif_egalite_nostop=iso_verif_egalite_choix_nostop & (a,b,err_msg,errmax,errmaxrel) #ifdef ISOVERIF #else WRITE(*,*) 'err_msg=',err_msg,': pourquoi verif?' stop #endif END FUNCTION iso_verif_egalite_nostop !************************************ SUBROUTINE iso_verif_aberrant(R,err_msg) USE isotopes_mod, ONLY: ridicule, iso_HDO IMPLICIT NONE ! si le rapprot iso R est plus grand que deltaDlim, on affiche message ! d'erreur et stoppe ! input: REAL R character*(*) err_msg ! message d''erreur à afficher !real deltaD !integer iso_verif_aberrant_choix_nostop IF (iso_verif_aberrant_choix_nostop(R,1.0,ridicule, & deltalim,err_msg).EQ.1) THEN stop endif #ifdef ISOVERIF IF (.NOT.(iso_HDO.gt.0)) THEN WRITE(*,*) 'iso86: err_msg=',err_msg,': pourquoi verif?' stop endif #else WRITE(*,*) 'iso 90: err_msg=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_aberrant SUBROUTINE iso_verif_aberrant_encadre(R,err_msg) USE isotopes_mod, ONLY: ridicule, iso_HDO IMPLICIT NONE ! si le rapprot iso R est plus grand que deltaDlim, on affiche message ! d'erreur et stoppe ! input: REAL R character*(*) err_msg ! message d''erreur à afficher !real deltaD !integer iso_verif_aberrant_enc_choix_nostop IF (iso_verif_aberrant_enc_choix_nostop(R,1.0,ridicule, & deltalim,err_msg).EQ.1) THEN WRITE(*,*) 'deltaD=',deltaD(R) CALL abort_physic('isotopes_verif_mod > iso_verif_aberrant_encadre',err_msg,1) !stop endif #ifdef ISOVERIF IF (.NOT.(iso_HDO.gt.0)) THEN WRITE(*,*) 'iso86: err_msg=',err_msg,': pourquoi verif?' stop endif #else WRITE(*,*) 'iso 90: err_msg=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_aberrant_encadre !************************************ SUBROUTINE iso_verif_aberrant_choix(xt,q,qmin,deltaDmax,err_msg) USE isotopes_mod, ONLY: iso_HDO IMPLICIT NONE ! si le rapprot iso R est plus grand que deltaDlim, on affiche message ! d'erreur et stoppe ! input: REAL xt,q,qmin,deltaDmax character*(*) err_msg ! message d''erreur à afficher !real deltaD ! locals !integer iso_verif_aberrant_choix_nostop IF (iso_verif_aberrant_choix_nostop(xt,q,qmin, & deltaDmax,err_msg).EQ.1) THEN stop endif #ifdef ISOVERIF IF (.NOT.(iso_HDO.gt.0)) THEN WRITE(*,*) 'iso122: err_msg=',err_msg,': pourquoi verif?' stop endif #else WRITE(*,*) 'iso126: err_msg=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_aberrant_choix !************************************ function iso_verif_aberrant_nostop(R,err_msg) USE isotopes_mod, ONLY: ridicule,iso_HDO IMPLICIT NONE ! si le rapprot iso R est plus grand que deltaDlim, on affiche message ! d'erreur et stoppe ! input: REAL R character*(*) err_msg ! message d''erreur à afficher INTEGER iso_verif_aberrant_nostop ! output: 1 si erreur, 0 sinon !real deltaD ! locals !integer iso_verif_aberrant_choix_nostop iso_verif_aberrant_nostop=iso_verif_aberrant_choix_nostop & (R,1.0,ridicule,deltalim,err_msg) #ifdef ISOVERIF IF (.NOT.(iso_HDO.gt.0)) THEN WRITE(*,*) 'iso156: err_msg=',err_msg,': pourquoi verif?' stop endif #else WRITE(*,*) 'iso160: err_msg=',err_msg,': pourquoi verif?' stop #endif END FUNCTION iso_verif_aberrant_nostop function iso_verif_aberrant_enc_nostop(R,err_msg) USE isotopes_mod, ONLY: ridicule,iso_HDO IMPLICIT NONE ! si le rapprot iso R est plus grand que deltaDlim, on affiche message ! d'erreur et stoppe ! input: REAL R character*(*) err_msg ! message d''erreur à afficher INTEGER iso_verif_aberrant_enc_nostop ! output: 1 si erreur, 0 sinon !real deltaD ! locals !integer iso_verif_aberrant_enc_choix_nostop iso_verif_aberrant_enc_nostop= & iso_verif_aberrant_enc_choix_nostop & (R,1.0,ridicule,deltalim,err_msg) #ifdef ISOVERIF IF (.NOT.(iso_HDO.gt.0)) THEN WRITE(*,*) 'iso156: err_msg=',err_msg,': pourquoi verif?' stop endif #else WRITE(*,*) 'iso160: err_msg=',err_msg,': pourquoi verif?' stop #endif END FUNCTION iso_verif_aberrant_enc_nostop !************************************ function iso_verif_aberrant_choix_nostop(xt,q, & qmin,deltaDmax,err_msg) USE isotopes_mod, ONLY: iso_HDO IMPLICIT NONE ! si le rapprot iso R est plus grand que deltaDlim, on affiche message ! d'erreur et stoppe ! input: REAL xt,q,qmin,deltaDmax character*(*) err_msg ! message d''erreur à afficher ! output INTEGER iso_verif_aberrant_choix_nostop ! locals !real deltaD !integer iso_verif_noNaN_nostop iso_verif_aberrant_choix_nostop=0 #ifdef ISOVERIF IF (iso_verif_noNaN_nostop(q,err_msg).EQ.1) THEN WRITE(*,*) 'q=',q iso_verif_aberrant_choix_nostop=1 endif IF (iso_verif_noNaN_nostop(xt,err_msg).EQ.1) THEN WRITE(*,*) 'xt=',xt iso_verif_aberrant_choix_nostop=1 endif #endif IF (q.gt.qmin) THEN IF ((deltaD(xt/q).gt.deltaDmax).OR. & (deltaD(xt/q).lt.-borne).OR. & (xt.lt.-borne).OR. & (xt.gt.borne)) THEN WRITE(*,*) 'erreur detectee par '// & 'iso_verif_aberrant_choix_nostop:' WRITE(*,*) err_msg WRITE(*,*) 'q,deltaD=',q,deltaD(xt/q) WRITE(*,*) 'deltaDmax=',deltaDmax iso_verif_aberrant_choix_nostop=1 IF (abs(xt-q)/q.lt.errmax) THEN WRITE(*,*) 'attention, n''a-t-on pas confondu'// & ' iso_HDO et iso_eau dans l''appel à la verif?' endif endif endif #ifdef ISOVERIF IF (.NOT.(iso_HDO.gt.0)) THEN WRITE(*,*) 'iso205: err_msg=',err_msg,': pourquoi verif?' stop endif #else WRITE(*,*) 'iso 209: err_msg=',err_msg,': pourquoi verif?' stop #endif END FUNCTION iso_verif_aberrant_choix_nostop function iso_verif_aberrant_enc_choix_nostop(xt,q, & qmin,deltaDmax,err_msg) USE isotopes_mod, ONLY: iso_HDO IMPLICIT NONE ! si le rapprot iso R est plus grand que deltaDlim, on affiche message ! d'erreur et stoppe ! input: REAL xt,q,qmin,deltaDmax character*(*) err_msg ! message d''erreur à afficher ! output INTEGER iso_verif_aberrant_enc_choix_nostop ! locals !real deltaD iso_verif_aberrant_enc_choix_nostop=0 IF (q.gt.qmin) THEN IF ((deltaD(xt/q).gt.deltaDmax).OR. & (deltaD(xt/q).lt.deltaDmin)) THEN WRITE(*,*) 'erreur detectee par '// & 'iso_verif_aberrant_choix_nostop:' WRITE(*,*) err_msg WRITE(*,*) 'q,deltaD=',q,deltaD(xt/q) iso_verif_aberrant_enc_choix_nostop=1 IF (abs(xt-q)/q.lt.errmax) THEN WRITE(*,*) 'attention, n''a-t-on pas confondu'// & ' iso_HDO et iso_eau dans l''appel à la verif?' endif endif endif #ifdef ISOVERIF IF (.NOT.(iso_HDO.gt.0)) THEN WRITE(*,*) 'iso205: err_msg=',err_msg,': pourquoi verif?' stop endif #else WRITE(*,*) 'iso 209: err_msg=',err_msg,': pourquoi verif?' stop #endif END FUNCTION iso_verif_aberrant_enc_choix_nostop !******************* SUBROUTINE iso_verif_aberrant_o17(R17,R18,err_msg) IMPLICIT NONE ! si l'O17-excess est aberrant, on affiche un message ! d'erreur et stoppe ! input: REAL R17,R18 character*(*) err_msg ! message d''erreur à afficher !real o17excess ! locals !integer iso_verif_aberrant_o17_nostop ! WRITE(*,*) 'O17_verif=',O17_verif IF (O17_verif) THEN IF (iso_verif_aberrant_o17_nostop(R17,R18,err_msg) & .EQ.1) THEN stop endif endif !if (O17_verif) THEN #ifdef ISOVERIF #else WRITE(*,*) 'err_msg=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_aberrant_o17 !******************* function iso_verif_aberrant_o17_nostop(R17,R18,err_msg) USE isotopes_mod, ONLY: tnat,iso_O17,iso_O18 IMPLICIT NONE ! si l'O17-excess est aberrant, on affiche un message ! d'erreur et renvoit 1 ! input: REAL R17,R18 character*(*) err_msg ! message d''erreur à afficher !local !real o17excess ! output INTEGER iso_verif_aberrant_o17_nostop IF (O17_verif) THEN iso_verif_aberrant_o17_nostop=0 IF ((o17excess(R17,R18).gt.o17excess_haut).OR. & (o17excess(R17,R18).lt.o17excess_bas)) THEN WRITE(*,*) 'erreur detectee par iso_verif_aberrant_O17:' WRITE(*,*) err_msg WRITE(*,*) 'o17excess=',o17excess(R17,R18) WRITE(*,*) 'deltaO17=',(R17/tnat(iso_o17)-1.0)*1000.0 WRITE(*,*) 'deltaO18=',(R18/tnat(iso_O18)-1.0)*1000.0 ! attention, vérifier que la ligne suivante est bien activée iso_verif_aberrant_o17_nostop=1 endif endif !if (O17_verif) THEN #ifdef ISOVERIF #else WRITE(*,*) 'err_msg=',err_msg,': pourquoi verif?' stop #endif END FUNCTION iso_verif_aberrant_o17_nostop !************************************ SUBROUTINE iso_verif_noNaN(x,err_msg) IMPLICIT NONE ! si x est NaN, on affiche message ! d'erreur et stoppe ! input: REAL x character*(*) err_msg ! message d''erreur à afficher ! locals !integer iso_verif_noNAN_nostop IF (iso_verif_noNAN_nostop(x,err_msg).EQ.1) THEN stop endif #ifdef ISOVERIF #else WRITE(*,*) 'err_msg iso443=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_noNaN !************************************ 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 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 #ifdef ISOVERIF #else WRITE(*,*) 'err_msg iso 482=',err_msg,': pourquoi verif?' stop #endif END FUNCTION iso_verif_noNaN_nostop SUBROUTINE iso_verif_noNaN_vect2D(x,err_msg,ni,n,m) IMPLICIT NONE ! si x est NaN, on affiche message ! d'erreur et return 1 si erreur ! input: INTEGER n,m,ni REAL x(ni,n,m) character*(*) err_msg ! message d''erreur à afficher ! output ! locals INTEGER i,j,ixt do i=1,n do j=1,m do ixt=1,ni IF ((x(ixt,i,j).gt.-borne).AND. & (x(ixt,i,j).lt.borne)) THEN else !if ((x(ixt,i,j).gt.-borne).AND. WRITE(*,*) 'erreur detectee par iso_verif_nonNAN:' WRITE(*,*) err_msg WRITE(*,*) 'x,ixt,i,j=',x(ixt,i,j),ixt,i,j stop endif !if ((x(ixt,i,j).gt.-borne).AND. enddo !do ixt=1,ni enddo !do j=1,m enddo !do i=1,n #ifdef ISOVERIF #else WRITE(*,*) 'err_msg iso525=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_noNaN_vect2D SUBROUTINE iso_verif_noNaN_vect1D(x,err_msg,ni,n) IMPLICIT NONE ! si x est NaN, on affiche message ! d'erreur et return 1 si erreur ! input: INTEGER n,ni REAL x(ni,n) character*(*) err_msg ! message d''erreur à afficher ! output ! locals INTEGER i,ixt do i=1,n do ixt=1,ni IF ((x(ixt,i).gt.-borne).AND. & (x(ixt,i).lt.borne)) THEN else !if ((x(ixt,i,j).gt.-borne).AND. WRITE(*,*) 'erreur detectee par iso_verif_nonNAN:' WRITE(*,*) err_msg WRITE(*,*) 'x,ixt,i=',x(ixt,i),ixt,i stop endif !if ((x(ixt,i,j).gt.-borne).AND. enddo !do ixt=1,ni enddo !do i=1,n #ifdef ISOVERIF #else WRITE(*,*) 'err_msg iso525=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_noNaN_vect1D !************************ SUBROUTINE iso_verif_egalite_choix(a,b,err_msg,erabs,errel) 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 REAL erabs,errel !erreur absolue et relative character*(*) err_msg ! message d''erreur à afficher ! locals !integer iso_verif_egalite_choix_nostop IF (iso_verif_egalite_choix_nostop( & a,b,err_msg,erabs,errel).EQ.1) THEN stop endif #ifdef ISOVERIF #else WRITE(*,*) 'err_msg=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_egalite_choix !************************ function iso_verif_egalite_choix_nostop & (a,b,err_msg,erabs,errel) 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 REAL erabs,errel !erreur absolue et relative character*(*) err_msg ! message d''erreur à afficher ! output INTEGER iso_verif_egalite_choix_nostop ! locals !integer iso_verif_noNaN_nostop iso_verif_egalite_choix_nostop=0 #ifdef ISOVERIF IF (iso_verif_noNaN_nostop(a,err_msg).EQ.1) THEN WRITE(*,*) 'a=',a iso_verif_egalite_choix_nostop=1 endif IF (iso_verif_noNaN_nostop(b,err_msg).EQ.1) THEN WRITE(*,*) 'b=',b iso_verif_egalite_choix_nostop=1 endif #endif IF (abs(a-b).gt.erabs) THEN IF (abs((a-b)/max(max(abs(b),abs(a)),1e-18)) & .gt.errel) THEN WRITE(*,*) 'erreur detectee par iso_verif_egalite:' WRITE(*,*) err_msg WRITE(*,*) 'a=',a WRITE(*,*) 'b=',b WRITE(*,*) 'erabs,errel=',erabs,errel iso_verif_egalite_choix_nostop=1 ! stop endif endif #ifdef ISOVERIF #else WRITE(*,*) 'err_msg=',err_msg,': pourquoi verif?' stop #endif END FUNCTION iso_verif_egalite_choix_nostop !****************** SUBROUTINE iso_verif_positif(x,err_msg) USE isotopes_mod, ONLY: ridicule IMPLICIT NONE ! si x<0, on plante. ! si très limite, on le met à 0. ! input: REAL x character*(*) err_msg ! message d''erreur à afficher ! locals !integer iso_verif_positif_choix_nostop IF (iso_verif_positif_choix_nostop(x,ridicule,err_msg) & .EQ.1) THEN stop endif #ifdef ISOVERIF #else WRITE(*,*) 'iso_verif 637: err_msg=',err_msg, & ': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_positif !****************** SUBROUTINE iso_verif_positif_vect(x,n,err_msg) USE isotopes_mod, ONLY: ridicule IMPLICIT NONE ! si x<0, on plante. ! input: INTEGER n REAL x(n) character*(*) err_msg ! message d''erreur à afficher ! locals INTEGER i INTEGER iso_verif_positif_nostop INTEGER ifaux iso_verif_positif_nostop=0 do i=1,n IF (x(i).lt.-ridicule) THEN iso_verif_positif_nostop=1 ifaux=i endif enddo IF (iso_verif_positif_nostop.EQ.1) THEN WRITE(*,*) 'erreur detectee par iso_verif_positif_vect:' WRITE(*,*) err_msg WRITE(*,*) 'i,x=',ifaux,x(ifaux) stop endif END SUBROUTINE iso_verif_positif_vect SUBROUTINE iso_verif_positif_choix_vect(x,n,ridic,err_msg) IMPLICIT NONE ! si x<0, on plante. ! input: INTEGER n REAL x(n) REAL ridic character*(*) err_msg ! message d''erreur à afficher ! locals INTEGER i INTEGER iso_verif_positif_nostop INTEGER ifaux iso_verif_positif_nostop=0 do i=1,n IF (x(i).lt.-ridic) THEN iso_verif_positif_nostop=1 ifaux=i endif enddo IF (iso_verif_positif_nostop.EQ.1) THEN WRITE(*,*) 'erreur detectee par iso_verif_positif_choix_vect:' WRITE(*,*) err_msg WRITE(*,*) 'i,x=',ifaux,x(ifaux) stop endif END SUBROUTINE iso_verif_positif_choix_vect !****************** SUBROUTINE iso_verif_positif_strict(x,err_msg) IMPLICIT NONE ! si x<0, on plante. ! si très limite, on le met à 0. ! input: REAL x character*(*) err_msg ! message d''erreur à afficher ! locals !integer iso_verif_positif_strict_nostop IF (iso_verif_positif_strict_nostop(x,err_msg) & .EQ.1) THEN stop endif END SUBROUTINE iso_verif_positif_strict !****************** function iso_verif_positif_strict_nostop(x,err_msg) IMPLICIT NONE ! si x<0, on plante. ! si très limite, on le met à 0. ! input: REAL x character*(*) err_msg ! message d''erreur à afficher* ! output INTEGER iso_verif_positif_strict_nostop IF (x.gt.0.0) THEN iso_verif_positif_strict_nostop=0 else WRITE(*,*) 'erreur detectee par iso_verif_positif_strict:' WRITE(*,*) err_msg WRITE(*,*) 'x=',x iso_verif_positif_strict_nostop=1 ! stop endif END FUNCTION iso_verif_positif_strict_nostop !****************** SUBROUTINE iso_verif_positif_choix(x,ridic,err_msg) IMPLICIT NONE ! si x<0, on plante. ! si très limite, on le met à 0. ! input: REAL x REAL ridic character*(*) err_msg ! message d''erreur à afficher ! locals !integer iso_verif_positif_choix_nostop IF (iso_verif_positif_choix_nostop(x,ridic,err_msg) & .EQ.1) THEN stop endif #ifdef ISOVERIF #else WRITE(*,*) 'iso_verif 801: err_msg=',err_msg, & ': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_positif_choix !****************** function iso_verif_positif_nostop(x,err_msg) USE isotopes_mod, ONLY: ridicule IMPLICIT NONE ! si x<0, on plante. ! si très limite, on le met à 0. ! input: REAL x character*(*) err_msg ! message d''erreur à afficher ! output INTEGER iso_verif_positif_nostop ! locals !integer iso_verif_positif_choix_nostop iso_verif_positif_nostop=iso_verif_positif_choix_nostop & (x,ridicule,err_msg) #ifdef ISOVERIF #else WRITE(*,*) 'iso_verif 837: err_msg=',err_msg, & ': pourquoi verif?' stop #endif END FUNCTION iso_verif_positif_nostop !****************** function iso_verif_positif_choix_nostop(x,ridic,err_msg) IMPLICIT NONE ! si x<0, on plante. ! si très limite, on le met à 0. ! input: REAL x REAL ridic character*(*) err_msg ! message d''erreur à afficher ! output INTEGER iso_verif_positif_choix_nostop IF (x.lt.-ridic) THEN WRITE(*,*) 'erreur detectee par iso_verif_positif_nostop:' WRITE(*,*) err_msg WRITE(*,*) 'x=',x iso_verif_positif_choix_nostop=1 else ! x=max(x,0.0) iso_verif_positif_choix_nostop=0 endif #ifdef ISOVERIF #else WRITE(*,*) 'iso_verif 877: err_msg=',err_msg, & ': pourquoi verif?' stop #endif END FUNCTION iso_verif_positif_choix_nostop !************** SUBROUTINE iso_verif_O18_aberrant(Rd,Ro,err_msg) IMPLICIT NONE ! vérifie que: ! 1) deltaD et deltaO18 dans bonne gamme ! 2) dexcess dans bonne gamme ! input: REAL Rd,Ro character*(*) err_msg ! message d''erreur à afficher ! local !integer iso_verif_O18_aberrant_nostop IF (iso_verif_O18_aberrant_nostop(Rd,Ro,err_msg).EQ.1) THEN stop endif END SUBROUTINE iso_verif_O18_aberrant function iso_verif_O18_aberrant_nostop(Rd,Ro,err_msg) USE isotopes_mod, ONLY: tnat, iso_HDO, iso_O18 IMPLICIT NONE ! vérifie que: ! 1) deltaD et deltaO18 dans bonne gamme ! 2) dexcess dans bonne gamme ! input: REAL Rd,Ro character*(*) err_msg ! message d''erreur à afficher ! outputs INTEGER iso_verif_O18_aberrant_nostop !locals REAL deltaD,deltao,dexcess deltaD=(Rd/tnat(iso_hdo)-1)*1000 deltao=(Ro/tnat(iso_O18)-1)*1000 dexcess=deltaD-8*deltao iso_verif_O18_aberrant_nostop=0 IF ((deltaD.lt.deltaDmin).OR.(deltao.lt.deltaDmin/2.0).OR. & (deltaD.gt.deltalim).OR.(deltao.gt.deltalim/8.0).OR. & ((deltaD.gt.-500.0).AND.((dexcess.lt.dexcess_min) & .OR.(dexcess.gt.dexcess_max)))) THEN WRITE(*,*) 'erreur detectee par iso_verif_O18_aberrant:' WRITE(*,*) err_msg WRITE(*,*) 'delta180=',deltao WRITE(*,*) 'deltaD=',deltaD WRITE(*,*) 'Dexcess=',dexcess WRITE(*,*) 'tnat=',tnat ! stop iso_verif_O18_aberrant_nostop=1 endif #ifdef ISOVERIF #else WRITE(*,*) 'err_msg=',err_msg,': pourquoi verif?' stop #endif END FUNCTION iso_verif_O18_aberrant_nostop ! ********** function deltaD(R) USE isotopes_mod, ONLY: tnat,iso_HDO IMPLICIT NONE REAL R,deltaD IF (iso_HDO.gt.0) THEN deltaD=(R/tnat(iso_HDO)-1)*1000.0 else WRITE(*,*) 'iso_verif_egalite>deltaD 260: iso_HDO.gt.0=', & iso_HDO.gt.0 endif END FUNCTION deltaD ! ********** function deltaO(R) USE isotopes_mod, ONLY: tnat,iso_O18 IMPLICIT NONE REAL R,deltaO IF (iso_O18.gt.0) THEN deltaO=(R/tnat(iso_O18)-1)*1000.0 else WRITE(*,*) 'iso_verif_egalite>deltaO18 260: iso_O18.gt.0=', & iso_O18.gt.0 endif END FUNCTION deltaO ! ********** function dexcess(RD,RO) USE isotopes_mod, ONLY: tnat,iso_O18,iso_HDO IMPLICIT NONE REAL RD,RO,deltaD,deltaO,dexcess IF ((iso_O18.gt.0).AND.(iso_HDO.gt.0)) THEN deltaD=(RD/tnat(iso_HDO)-1)*1000.0 deltaO=(RO/tnat(iso_O18)-1)*1000.0 dexcess=deltaD-8*deltaO else WRITE(*,*) 'iso_verif_egalite 1109: iso_O18,iso_HDO=',iso_O18,iso_HDO endif END FUNCTION dexcess ! ********** function delta_all(R,ixt) USE isotopes_mod, ONLY: tnat IMPLICIT NONE REAL R,delta_all INTEGER ixt delta_all=(R/tnat(ixt)-1)*1000.0 END FUNCTION delta_all ! ********** function delta_to_R(delta,ixt) USE isotopes_mod, ONLY: tnat IMPLICIT NONE REAL delta,delta_to_R INTEGER ixt delta_to_R=(delta/1000.0+1.0)*tnat(ixt) END FUNCTION delta_to_R ! ********** function o17excess(R17,R18) USE isotopes_mod, ONLY: tnat,iso_O18,iso_O17 IMPLICIT NONE REAL R17,R18,o17excess IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN o17excess=1e6*(log(R17/tnat(iso_o17)) & -0.528*log(R18/tnat(iso_O18))) ! WRITE(*,*) 'o17excess=',o17excess else WRITE(*,*) 'iso_verif_egalite>deltaD 260: iso_O17.gt.0,18=', & iso_O17.gt.0,iso_O18.gt.0 endif END FUNCTION o17excess ! **************** SUBROUTINE iso_verif_egalite_vect2D( & xt,q,err_msg,ni,n,m) USE isotopes_mod, ONLY: iso_eau IMPLICIT NONE ! inputs INTEGER n,m,ni REAL q(n,m) REAL xt(ni,n,m) character*(*) err_msg ! locals INTEGER iso_verif_egalite_nostop_loc INTEGER i,j,ixt INTEGER ifaux,jfaux !WRITE(*,*) 'iso_verif_egalite_vect2D 1099 tmp: q(2,1),xt(iso_eau,2,1)=',q(2,1),xt(iso_eau,2,1) !WRITE(*,*) 'ni,n,m=',ni,n,m,errmax,errmaxrel IF (iso_eau.gt.0) THEN iso_verif_egalite_nostop_loc=0 do i=1,n do j=1,m IF (abs(q(i,j)-xt(iso_eau,i,j)).gt.errmax) THEN IF (abs((q(i,j)-xt(iso_eau,i,j))/ & max(max(abs(q(i,j)),abs(xt(iso_eau,i,j))),1e-18)) & .gt.errmaxrel) THEN iso_verif_egalite_nostop_loc=1 ifaux=i jfaux=j endif endif enddo !do j=1,m enddo !do i=1,n IF (iso_verif_egalite_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par iso_verif_egalite_vect2D:' WRITE(*,*) err_msg WRITE(*,*) 'i,j=',ifaux,jfaux WRITE(*,*) 'xt,q=',xt(iso_eau,ifaux,jfaux),q(ifaux,jfaux) stop endif endif #ifdef ISOVERIF CALL iso_verif_noNaN_vect2D(xt,err_msg,ni,n,m) #endif END SUBROUTINE iso_verif_egalite_vect2D SUBROUTINE iso_verif_egalite_vect1D( & xt,q,err_msg,ni,n) USE isotopes_mod, ONLY: iso_eau IMPLICIT NONE ! inputs INTEGER n,ni REAL q(n) REAL xt(ni,n) character*(*) err_msg ! locals INTEGER iso_verif_egalite_nostop_loc INTEGER i INTEGER ifaux IF (iso_eau.gt.0) THEN iso_verif_egalite_nostop_loc=0 do i=1,n IF (abs(q(i)-xt(iso_eau,i)).gt.errmax) THEN IF (abs((q(i)-xt(iso_eau,i))/ & max(max(abs(q(i)),abs(xt(iso_eau,i))),1e-18)) & .gt.errmaxrel) THEN iso_verif_egalite_nostop_loc=1 ifaux=i endif !if (abs((q(i)-xt(iso_eau,i))/ endif !if (abs(q(i)-xt(iso_eau,i)).gt.errmax) THEN enddo !do i=1,n IF (iso_verif_egalite_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par iso_verif_egalite_vect2D:' WRITE(*,*) err_msg WRITE(*,*) 'i=',ifaux WRITE(*,*) 'xt,q=',xt(iso_eau,ifaux),q(ifaux) stop endif !if (iso_verif_egalite_nostop.EQ.1) THEN endif !if (iso_eau.gt.0) THEN END SUBROUTINE iso_verif_egalite_vect1D SUBROUTINE iso_verif_egalite_std_vect( & a,b,err_msg,n,m,errmax,errmaxrel) IMPLICIT NONE ! inputs INTEGER n,m,ni REAL a(n,m) REAL b(n,m) character*(*) err_msg REAL errmax,errmaxrel ! locals INTEGER iso_verif_egalite_nostop_loc INTEGER i,j INTEGER ifaux,jfaux iso_verif_egalite_nostop_loc=0 do i=1,n do j=1,m IF (abs(a(i,j)-b(i,j)).gt.errmax) THEN IF (abs((a(i,j)-b(i,j))/ & max(max(abs(a(i,j)),abs(b(i,j))),1e-18)) & .gt.errmaxrel) THEN iso_verif_egalite_nostop_loc=1 ifaux=i jfaux=j endif endif enddo !do j=1,m enddo !do i=1,n IF (iso_verif_egalite_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par iso_verif_egalite_vect2D:' WRITE(*,*) err_msg WRITE(*,*) 'i,j=',ifaux,jfaux WRITE(*,*) 'a,b=',a(ifaux,jfaux),b(ifaux,jfaux) stop endif END SUBROUTINE iso_verif_egalite_std_vect SUBROUTINE iso_verif_aberrant_vect2D( & xt,q,err_msg,ni,n,m) USE isotopes_mod, ONLY: ridicule,tnat,iso_HDO IMPLICIT NONE ! inputs INTEGER n,m,ni REAL q(n,m) REAL xt(ni,n,m) character*(*) err_msg ! locals INTEGER iso_verif_aberrant_nostop_loc INTEGER i,j INTEGER ifaux,jfaux !real deltaD IF (iso_HDO.gt.0) THEN iso_verif_aberrant_nostop_loc=0 do i=1,n do j=1,m IF (q(i,j).gt.ridicule) THEN IF (((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .gt.deltalim).OR. & ((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .lt.-borne)) THEN iso_verif_aberrant_nostop_loc=1 ifaux=i jfaux=j endif endif enddo !do j=1,m enddo !do i=1,n IF (iso_verif_aberrant_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par iso_verif_aberrant_vect2D:' WRITE(*,*) err_msg WRITE(*,*) 'i,j=',ifaux,jfaux WRITE(*,*) 'deltaD=',deltaD(xt(iso_HDO,ifaux,jfaux) & /q(ifaux,jfaux)) WRITE(*,*) 'xt(:,ifaux,jfaux)=',xt(:,ifaux,jfaux) stop endif endif !if (iso_HDO.gt.0) THEN END SUBROUTINE iso_verif_aberrant_vect2D SUBROUTINE iso_verif_aberrant_enc_vect2D( & xt,q,err_msg,ni,n,m) USE isotopes_mod, ONLY: ridicule,tnat,iso_HDO IMPLICIT NONE ! inputs INTEGER n,m,ni REAL q(n,m) REAL xt(ni,n,m) character*(*) err_msg ! locals INTEGER iso_verif_aberrant_nostop_loc INTEGER i,j INTEGER ifaux,jfaux !real deltaD IF (iso_HDO.gt.0) THEN iso_verif_aberrant_nostop_loc=0 do i=1,n do j=1,m IF (q(i,j).gt.ridicule) THEN IF (((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .gt.deltalim).OR. & ((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .lt.deltaDmin).OR. & (xt(iso_HDO,i,j).lt.-borne).OR. & (xt(iso_HDO,i,j).gt.borne)) THEN iso_verif_aberrant_nostop_loc=1 ifaux=i jfaux=j endif endif enddo !do j=1,m enddo !do i=1,n IF (iso_verif_aberrant_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par ', & 'iso_verif_aberrant_enc_vect2D:' WRITE(*,*) err_msg WRITE(*,*) 'i,j=',ifaux,jfaux WRITE(*,*) 'deltaD=',deltaD(xt(iso_HDO,ifaux,jfaux) & /q(ifaux,jfaux)) WRITE(*,*) 'xt(:,ifaux,jfaux)=',xt(:,ifaux,jfaux) WRITE(*,*) 'q(ifaux,jfaux)=',q(ifaux,jfaux) CALL abort_physic('isotopes_verif_mod','iso_verif_aberrant_enc_vect2D',1) endif endif !if (iso_HDO.gt.0) THEN END SUBROUTINE iso_verif_aberrant_enc_vect2D SUBROUTINE iso_verif_aberrant_enc_vect2D_ns( & xt,q,err_msg,ni,n,m) USE isotopes_mod, ONLY: ridicule,tnat,iso_HDO IMPLICIT NONE ! inputs INTEGER n,m,ni REAL q(n,m) REAL xt(ni,n,m) character*(*) err_msg ! locals INTEGER iso_verif_aberrant_nostop_loc INTEGER i,j INTEGER ifaux,jfaux !real deltaD IF (iso_HDO.gt.0) THEN iso_verif_aberrant_nostop_loc=0 do i=1,n do j=1,m IF (q(i,j).gt.ridicule) THEN IF (((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .gt.deltalim).OR. & ((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .lt.deltaDmin)) THEN iso_verif_aberrant_nostop_loc=1 ifaux=i jfaux=j endif endif enddo !do j=1,m enddo !do i=1,n IF (iso_verif_aberrant_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par ', & 'iso_verif_aberrant_vect2D_ns:' WRITE(*,*) err_msg WRITE(*,*) 'i,j=',ifaux,jfaux WRITE(*,*) 'deltaD=',deltaD(xt(iso_HDO,ifaux,jfaux) & /q(ifaux,jfaux)) WRITE(*,*) 'xt(:,ifaux,jfaux)=',xt(:,ifaux,jfaux) ! stop endif endif !if (iso_HDO.gt.0) THEN END SUBROUTINE iso_verif_aberrant_enc_vect2D_ns SUBROUTINE iso_verif_aberrant_vect2Dch( & xt,q,err_msg,ni,n,m,deltaDmax) USE isotopes_mod, ONLY: ridicule,tnat,iso_HDO IMPLICIT NONE ! inputs INTEGER n,m,ni REAL q(n,m) REAL xt(ni,n,m) character*(*) err_msg REAL deltaDmax ! locals INTEGER iso_verif_aberrant_nostop_loc INTEGER i,j INTEGER ifaux,jfaux !real deltaD IF (iso_HDO.gt.0) THEN iso_verif_aberrant_nostop_loc=0 do i=1,n do j=1,m IF (q(i,j).gt.ridicule) THEN IF (((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .gt.deltaDmax).OR. & ((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .lt.-borne)) THEN iso_verif_aberrant_nostop_loc=1 ifaux=i jfaux=j endif endif enddo !do j=1,m enddo !do i=1,n IF (iso_verif_aberrant_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par iso_verif_aberrant_vect2D:' WRITE(*,*) err_msg WRITE(*,*) 'i,j=',ifaux,jfaux WRITE(*,*) 'deltaD=',deltaD(xt(iso_HDO,ifaux,jfaux) & /q(ifaux,jfaux)) WRITE(*,*) 'xt(:,ifaux,jfaux)=',xt(:,ifaux,jfaux) stop endif endif !if (iso_HDO.gt.0) THEN END SUBROUTINE iso_verif_aberrant_vect2Dch SUBROUTINE iso_verif_O18_aberrant_enc_vect2D( & xt,q,err_msg,ni,n,m) USE isotopes_mod, ONLY: ridicule,tnat,iso_HDO,iso_O18 IMPLICIT NONE ! inputs INTEGER n,m,ni REAL q(n,m) REAL xt(ni,n,m) character*(*) err_msg ! locals INTEGER iso_verif_aberrant_nostop_loc INTEGER i,j INTEGER ifaux,jfaux REAL deltaDloc,deltaoloc,dexcessloc IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0)) THEN iso_verif_aberrant_nostop_loc=0 do i=1,n do j=1,m IF (q(i,j).gt.ridicule) THEN deltaDloc=(xt(iso_HDO,i,j)/q(i,j)/tnat(iso_hdo)-1)*1000 deltaoloc=(xt(iso_O18,i,j)/q(i,j)/tnat(iso_O18)-1)*1000 dexcessloc=deltaDloc-8*deltaoloc IF ((deltaDloc.lt.deltaDmin).OR.(deltaoloc.lt.deltaDmin/2.0).OR. & (deltaDloc.gt.deltalim).OR.(deltaoloc.gt.deltalim/8.0).OR. & ((deltaDloc.gt.-500.0).AND.((dexcessloc.lt.dexcess_min) & .OR.(dexcessloc.gt.dexcess_max)))) THEN iso_verif_aberrant_nostop_loc=1 ifaux=i jfaux=j WRITE(*,*) 'deltaD,deltao,dexcess=',deltaDloc,deltaoloc,dexcessloc endif endif enddo !do j=1,m enddo !do i=1,n IF (iso_verif_aberrant_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par ', & 'iso_verif_aberrant_enc_vect2D:' WRITE(*,*) err_msg WRITE(*,*) 'i,j=',ifaux,jfaux WRITE(*,*) 'xt(:,ifaux,jfaux)=',xt(:,ifaux,jfaux) WRITE(*,*) 'q(ifaux,jfaux)=',q(ifaux,jfaux) CALL abort_physic('isotopes_verif_mod','iso_verif_aberrant_enc_vect2D',1) endif endif !if (iso_HDO.gt.0) THEN END SUBROUTINE iso_verif_O18_aberrant_enc_vect2D SUBROUTINE select_dim23_from4D(n1,n2,n3,n4, & var,vec,i1,i4) IMPLICIT NONE ! inputs INTEGER n1,n2,n3,n4 REAL var(n1,n2,n3,n4) INTEGER i1,i4 ! outputs REAL vec(n2,n3) ! locals INTEGER i2,i3 do i2=1,n2 do i3=1,n3 vec(i2,i3)=var(i1,i2,i3,i4) enddo enddo END SUBROUTINE select_dim23_from4D SUBROUTINE select_dim4_from4D(ntime,nlev,nlat,nlon, & var,vec,itime,ilev,ilat) IMPLICIT NONE ! inputs INTEGER ntime,nlev,nlat,nlon REAL var(ntime,nlev,nlat,nlon) INTEGER itime,ilev,ilat ! outputs REAL vec(nlon) ! locals INTEGER ilon do ilon=1,nlon vec(ilon)=var(itime,ilev,ilat,ilon) enddo END SUBROUTINE select_dim4_from4D SUBROUTINE select_dim5_from5D(n1,n2,n3,n4,n5, & var,vec,i1,i2,i3,i4) IMPLICIT NONE ! inputs INTEGER n1,n2,n3,n4,n5 REAL var(n1,n2,n3,n4,n5) INTEGER i1,i2,i3,i4 ! outputs REAL vec(n5) ! locals INTEGER i5 do i5=1,n5 vec(i5)=var(i1,i2,i3,i4,i5) enddo END SUBROUTINE select_dim5_from5D SUBROUTINE select_dim3_from3D(ntime,nlat,nlon, & var,vec,itime,ilat) IMPLICIT NONE ! inputs INTEGER ntime,nlat,nlon REAL var(ntime,nlat,nlon) INTEGER itime,ilat ! outputs REAL vec(nlon) ! locals INTEGER ilon do ilon=1,nlon vec(ilon)=var(itime,ilat,ilon) enddo END SUBROUTINE select_dim3_from3D SUBROUTINE select_dim23_from3D(n1,n2,n3, & var,vec,i1) IMPLICIT NONE ! inputs INTEGER n1,n2,n3 REAL var(n1,n2,n3) INTEGER i1 ! outputs REAL vec(n2,n3) ! locals INTEGER i2,i3 do i2=1,n2 do i3=1,n3 vec(i2,i3)=var(i1,i2,i3) enddo enddo END SUBROUTINE select_dim23_from3D SUBROUTINE putinto_dim23_from4D(n1,n2,n3,n4, & var,vec,i1,i4) IMPLICIT NONE ! inputs INTEGER n1,n2,n3,n4 REAL vec(n2,n3) INTEGER i1,i4 ! inout REAL var(n1,n2,n3,n4) ! locals INTEGER i2,i3 do i2=1,n2 do i3=1,n3 var(i1,i2,i3,i4)=vec(i2,i3) enddo enddo END SUBROUTINE putinto_dim23_from4D SUBROUTINE putinto_dim12_from4D(n1,n2,n3,n4, & var,vec,i3,i4) IMPLICIT NONE ! inputs INTEGER n1,n2,n3,n4 REAL vec(n1,n2) INTEGER i3,i4 ! inout REAL var(n1,n2,n3,n4) ! locals INTEGER i1,i2 do i1=1,n1 do i2=1,n2 var(i1,i2,i3,i4)=vec(i1,i2) enddo enddo END SUBROUTINE putinto_dim12_from4D SUBROUTINE putinto_dim23_from3D(n1,n2,n3, & var,vec,i1) IMPLICIT NONE ! inputs INTEGER n1,n2,n3 REAL vec(n2,n3) INTEGER i1 ! inout REAL var(n1,n2,n3) ! locals INTEGER i2,i3 do i2=1,n2 do i3=1,n3 var(i1,i2,i3)=vec(i2,i3) enddo enddo END SUBROUTINE putinto_dim23_from3D SUBROUTINE iso_verif_noNaN_par2D(x,err_msg,ni,n,m,ib,ie) IMPLICIT NONE ! si x est NaN, on affiche message ! d'erreur et return 1 si erreur ! input: INTEGER n,m,ni,ib,ie REAL x(ni,n,m) character*(*) err_msg ! message d''erreur à afficher ! output ! locals INTEGER i,j,ixt do i=ib,ie do j=1,m do ixt=1,ni IF ((x(ixt,i,j).gt.-borne).AND. & (x(ixt,i,j).lt.borne)) THEN else !if ((x(ixt,i,j).gt.-borne).AND. WRITE(*,*) 'erreur detectee par iso_verif_nonNAN:' WRITE(*,*) err_msg WRITE(*,*) 'x,ixt,i,j=',x(ixt,i,j),ixt,i,j stop endif !if ((x(ixt,i,j).gt.-borne).AND. enddo !do ixt=1,ni enddo !do j=1,m enddo !do i=1,n #ifdef ISOVERIF #else WRITE(*,*) 'err_msg iso1772=',err_msg,': pourquoi verif?' stop #endif END SUBROUTINE iso_verif_noNaN_par2D SUBROUTINE iso_verif_aberrant_enc_par2D( & xt,q,err_msg,ni,n,m,ib,ie) USE isotopes_mod, ONLY: ridicule,tnat,iso_HDO IMPLICIT NONE ! inputs INTEGER n,m,ni,ib,ie REAL q(n,m) REAL xt(ni,n,m) character*(*) err_msg ! locals INTEGER iso_verif_aberrant_nostop_loc INTEGER i,j INTEGER ifaux,jfaux !real deltaD IF (iso_HDO.gt.0) THEN iso_verif_aberrant_nostop_loc=0 do i=ib,ie do j=1,m IF (q(i,j).gt.ridicule) THEN IF (((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .gt.deltalim).OR. & ((xt(iso_HDO,i,j)/q(i,j)/tnat(iso_HDO)-1)*1000.0 & .lt.deltaDmin)) THEN iso_verif_aberrant_nostop_loc=1 ifaux=i jfaux=j endif endif enddo !do j=1,m enddo !do i=1,n IF (iso_verif_aberrant_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par iso_verif_aberrant_par2D:' WRITE(*,*) err_msg WRITE(*,*) 'i,j=',ifaux,jfaux WRITE(*,*) 'deltaD=',deltaD(xt(iso_HDO,ifaux,jfaux) & /q(ifaux,jfaux)) WRITE(*,*) 'xt(:,ifaux,jfaux)=',xt(:,ifaux,jfaux) WRITE(*,*) 'q(ifaux,jfaux)=',q(ifaux,jfaux) stop endif endif !if (iso_HDO.gt.0) THEN END SUBROUTINE iso_verif_aberrant_enc_par2D SUBROUTINE iso_verif_egalite_par2D( & xt,q,err_msg,ni,n,m,ib,ie) USE isotopes_mod, ONLY: iso_eau IMPLICIT NONE ! inputs INTEGER n,m,ni,ib,ie REAL q(n,m) REAL xt(ni,n,m) character*(*) err_msg ! locals INTEGER iso_verif_egalite_nostop_loc INTEGER i,j INTEGER ifaux,jfaux IF (iso_eau.gt.0) THEN iso_verif_egalite_nostop_loc=0 do i=ib,ie do j=1,m IF (abs(q(i,j)-xt(iso_eau,i,j)).gt.errmax) THEN IF (abs((q(i,j)-xt(iso_eau,i,j))/ & max(max(abs(q(i,j)),abs(xt(iso_eau,i,j))),1e-18)) & .gt.errmaxrel) THEN iso_verif_egalite_nostop_loc=1 ifaux=i jfaux=j endif endif enddo !do j=1,m enddo !do i=1,n IF (iso_verif_egalite_nostop_loc.EQ.1) THEN WRITE(*,*) 'erreur detectee par iso_verif_egalite_vect2D:' WRITE(*,*) err_msg WRITE(*,*) 'i,j=',ifaux,jfaux WRITE(*,*) 'xt,q=',xt(iso_eau,ifaux,jfaux),q(ifaux,jfaux) stop endif endif END SUBROUTINE iso_verif_egalite_par2D #ifdef ISOTRAC function iso_verif_traceur_choix_nostop(x,err_msg, & errmax,errmaxrel,ridicule_trac,deltalimtrac) USE isotopes_mod, ONLY: iso_HDO IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher REAL errmax,errmaxrel,ridicule_trac,deltalimtrac ! output INTEGER iso_verif_traceur_choix_nostop ! locals !integer iso_verif_traceur_noNaN_nostop !integer iso_verif_tracm_choix_nostop !integer iso_verif_tracdD_choix_nostop !integer iso_verif_tracpos_choix_nostop iso_verif_traceur_choix_nostop=0 ! verif noNaN IF (iso_verif_traceur_noNaN_nostop(x,err_msg).EQ.1) THEN iso_verif_traceur_choix_nostop=1 endif ! verif masse IF (iso_verif_tracm_choix_nostop(x,err_msg, & errmax,errmaxrel).EQ.1) THEN iso_verif_traceur_choix_nostop=1 endif ! verif deltaD IF (iso_HDO.gt.0) THEN IF (iso_verif_tracdD_choix_nostop(x,err_msg, & ridicule_trac,deltalimtrac).EQ.1) THEN iso_verif_traceur_choix_nostop=1 endif endif !if (iso_HDO.gt.0) THEN ! verif pas aberramment negatif IF (iso_verif_tracpos_choix_nostop(x,err_msg, & 1e-5).EQ.1) THEN iso_verif_traceur_choix_nostop=1 endif END FUNCTION iso_verif_traceur_choix_nostop function iso_verif_tracnps_choix_nostop(x,err_msg, & errmax,errmaxrel,ridicule_trac,deltalimtrac) USE isotopes_mod, ONLY: iso_HDO IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on ne vérfie pas la positivité ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher REAL errmax,errmaxrel,ridicule_trac,deltalimtrac ! output INTEGER iso_verif_tracnps_choix_nostop ! locals !integer iso_verif_traceur_noNaN_nostop !integer iso_verif_tracm_choix_nostop !integer iso_verif_tracdD_choix_nostop iso_verif_tracnps_choix_nostop=0 ! verif noNaN IF (iso_verif_traceur_noNaN_nostop(x,err_msg).EQ.1) THEN iso_verif_tracnps_choix_nostop=1 endif ! verif masse IF (iso_verif_tracm_choix_nostop(x,err_msg, & errmax,errmaxrel).EQ.1) THEN iso_verif_tracnps_choix_nostop=1 endif ! verif deltaD IF (iso_HDO.gt.0) THEN IF (iso_verif_tracdD_choix_nostop(x,err_msg, & ridicule_trac,deltalimtrac).EQ.1) THEN iso_verif_tracnps_choix_nostop=1 endif endif ! if (iso_HDO.gt.0) THEN END FUNCTION iso_verif_tracnps_choix_nostop function iso_verif_tracpos_choix_nostop(x,err_msg,seuil) USE isotopes_mod, ONLY: isoName IMPLICIT NONE ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher REAL seuil ! output INTEGER iso_verif_tracpos_choix_nostop ! locals INTEGER lnblnk INTEGER iiso,ixt !integer iso_verif_positif_choix_nostop iso_verif_tracpos_choix_nostop=0 do ixt=niso+1,ntraciso IF (iso_verif_positif_choix_nostop(x(ixt),seuil,err_msg// & ', verif positif, iso'//TRIM(isoName(ixt))).EQ.1) THEN iso_verif_tracpos_choix_nostop=1 endif enddo END FUNCTION iso_verif_tracpos_choix_nostop function iso_verif_traceur_noNaN_nostop(x,err_msg) USE isotopes_mod, ONLY: isoName IMPLICIT NONE ! on vérifie juste que pas NaN ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher ! output INTEGER iso_verif_traceur_noNaN_nostop ! locals INTEGER lnblnk INTEGER iiso,ixt !integer iso_verif_nonaN_nostop iso_verif_traceur_noNaN_nostop=0 do ixt=niso+1,ntraciso ! WRITE(*,*) 'iso_verif_traceurs 154: iiso,ixt=',iiso,ixt IF (iso_verif_noNaN_nostop(x(ixt),err_msg// & ', verif trac no NaN, iso'//TRIM(isoName(ixt))) & .EQ.1) THEN iso_verif_traceur_noNaN_nostop=1 endif enddo END FUNCTION iso_verif_traceur_noNaN_nostop function iso_verif_tracm_choix_nostop(x,err_msg, & errmaxin,errmaxrelin) USE isotopes_mod, ONLY: ridicule,isoName ! on vérifie juste bilan de masse IMPLICIT NONE ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher REAL errmaxin,errmaxrelin ! output INTEGER iso_verif_tracm_choix_nostop ! locals !integer iso_verif_egalite_choix_nostop INTEGER iiso,izone,ixt REAL xtractot iso_verif_tracm_choix_nostop=0 do iiso=1,niso xtractot=0.0 do izone=1,nzone ixt=itZonIso(izone,iiso) xtractot=xtractot+x(ixt) enddo IF (iso_verif_egalite_choix_nostop(xtractot,x(iiso), & err_msg//', verif trac egalite1, iso '// & TRIM(isoName(iiso)), & errmaxin,errmaxrelin).EQ.1) THEN WRITE(*,*) 'iso_verif_traceur 202: x=',x ! WRITE(*,*) 'xtractot=',xtractot do izone=1,nzone ixt=itZonIso(izone,iiso) WRITE(*,*) 'izone,iiso,ixt=',izone,iiso,ixt enddo iso_verif_tracm_choix_nostop=1 endif ! verif ajoutée le 19 fev 2011 IF ((abs(xtractot).lt.ridicule**2).AND. & (abs(x(iiso)).gt.ridicule)) THEN WRITE(*,*) err_msg,', verif masse traceurs, iso ', & TRIM(isoName(iiso)) WRITE(*,*) 'iso_verif_traceur 209: x=',x ! iso_verif_tracm_choix_nostop=1 endif enddo !do iiso=1,ntraceurs_iso END FUNCTION iso_verif_tracm_choix_nostop function iso_verif_tracdD_choix_nostop(x,err_msg, & ridicule_trac,deltalimtrac) USE isotopes_mod, ONLY: iso_eau, iso_HDO USE isotrac_mod, ONLY: strtrac ! on vérifie juste deltaD IMPLICIT NONE ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher REAL ridicule_trac,deltalimtrac ! output INTEGER iso_verif_tracdD_choix_nostop ! locals INTEGER izone,ieau,ixt !integer iso_verif_aberrant_choix_nostop iso_verif_tracdD_choix_nostop=0 IF ((iso_eau.gt.0).AND.(iso_HDO.gt.0)) THEN do izone=1,nzone ieau=itZonIso(izone,iso_eau) ixt=itZonIso(izone,iso_HDO) IF (iso_verif_aberrant_choix_nostop(x(ixt),x(ieau), & ridicule_trac,deltalimtrac,err_msg// & ', verif trac no aberrant zone '//strtrac(izone)) & .EQ.1) THEN iso_verif_tracdD_choix_nostop=1 endif ! if (x(ieau).gt.ridicule) THEN ! CALL iso_verif_aberrant(x(ixt)/x(ieau), ! : err_msg//', verif trac no aberrant zone ' ! : //strtrac(izone)) ! endif enddo !do izone=1,nzone endif ! if ((iso_eau.gt.0).AND.(iso_HDO.gt.0)) THEN END FUNCTION iso_verif_tracdD_choix_nostop INTEGER FUNCTION iso_verif_tag17_q_deltaD_chns(x,err_msg) RESULT(res) USE isotopes_mod, ONLY: iso_HDO, iso_eau, ridicule USE isotrac_mod, ONLY: nzone_temp, option_traceurs IMPLICIT NONE REAL, INTENT(IN) :: x(ntraciso) CHARACTER(LEN=*), INTENT(IN) :: err_msg INTEGER :: ieau, ixt, ieau1 res = 0 IF(ALL([17,18]/=option_traceurs)) RETURN !--- Check whether * deltaD(highest tagging layer) < 200 permil ! * q < ieau=itZonIso(nzone_temp,iso_eau) ixt=itZonIso(nzone_temp,iso_HDO) IF(x(ieau)>ridicule) THEN IF(iso_verif_positif_nostop(-200.0-deltaD(x(ixt)/x(ieau)), err_msg//': deltaDt05 trop fort')==1) THEN res=1; WRITE(*,*) 'x=',x END IF END IF IF(iso_verif_positif_nostop(2.0e-3-x(ieau),err_msg//': qt05 trop fort')==1) THEN res=1; WRITE(*,*) 'x=',x END IF !--- Check whether q is small ; then, qt01 < 10% IF(x(iso_eau)<2.0e-3) THEN ieau1= itZonIso(1,iso_eau) IF(iso_verif_positif_nostop(0.1-(x(ieau1)/x(iso_eau)),err_msg//': qt01 trop abondant')==1) THEN res=1; WRITE(*,*) 'x=',x END IF END IF END FUNCTION iso_verif_tag17_q_deltaD_chns SUBROUTINE iso_verif_trac17_q_deltaD(x,err_msg) USE isotrac_mod, ONLY: nzone_temp, option_traceurs IMPLICIT NONE REAL, INTENT(IN) :: x(ntraciso) CHARACTER(LEN=*), INTENT(IN) :: err_msg IF(ALL([17,18]/=option_traceurs)) RETURN IF(nzone_temp>=5) THEN IF(iso_verif_tag17_q_deltaD_chns(x,err_msg)==1) STOP END IF END SUBROUTINE iso_verif_trac17_q_deltaD SUBROUTINE iso_verif_traceur(x,err_msg) USE isotrac_mod, ONLY: ridicule_trac IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher ! locals !integer iso_verif_traceur_choix_nostop IF (iso_verif_traceur_choix_nostop(x,err_msg, & errmax,errmaxrel,ridicule_trac,deltalimtrac) & .EQ.1) THEN stop endif END SUBROUTINE iso_verif_traceur SUBROUTINE iso_verif_traceur_retourne3D(x,n1,n2,n3, & i1,i2,i3,err_msg) USE isotrac_mod, ONLY: ridicule_trac IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs INTEGER n1,n2,n3 REAL x(n1,n2,n3,ntraciso) character*(*) err_msg ! message d''erreur à afficher INTEGER i1,i2,i3 ! locals !integer iso_verif_traceur_choix_nostop REAL xiso(ntraciso) CALL select_dim4_from4D(n1,n2,n3,ntraciso, & x,xiso,i1,i2,i3) IF (iso_verif_traceur_choix_nostop(xiso,err_msg, & errmax,errmaxrel,ridicule_trac,deltalimtrac) & .EQ.1) THEN stop endif END SUBROUTINE iso_verif_traceur_retourne3D SUBROUTINE iso_verif_traceur_retourne4D(x,n1,n2,n3,n4, & i1,i2,i3,i4,err_msg) USE isotrac_mod, ONLY: ridicule_trac IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs INTEGER n1,n2,n3,n4 REAL x(n1,n2,n3,n4,ntraciso) character*(*) err_msg ! message d''erreur à afficher INTEGER i1,i2,i3,i4 ! locals !integer iso_verif_traceur_choix_nostop REAL xiso(ntraciso) CALL select_dim5_from5D(n1,n2,n3,n4,ntraciso, & x,xiso,i1,i2,i3,i4) IF (iso_verif_traceur_choix_nostop(xiso,err_msg, & errmax,errmaxrel,ridicule_trac,deltalimtrac) & .EQ.1) THEN stop endif END SUBROUTINE iso_verif_traceur_retourne4D SUBROUTINE iso_verif_traceur_retourne2D(x,n1,n2, & i1,i2,err_msg) USE isotrac_mod, ONLY: ridicule_trac IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs INTEGER n1,n2 REAL x(n1,n2,ntraciso) character*(*) err_msg ! message d''erreur à afficher INTEGER i1,i2 ! locals !integer iso_verif_traceur_choix_nostop REAL xiso(ntraciso) CALL select_dim3_from3D(n1,n2,ntraciso, & x,xiso,i1,i2) IF (iso_verif_traceur_choix_nostop(xiso,err_msg, & errmax,errmaxrel,ridicule_trac,deltalimtrac) & .EQ.1) THEN stop endif END SUBROUTINE iso_verif_traceur_retourne2D SUBROUTINE iso_verif_traceur_vect(x,n,m,err_msg) USE isotopes_mod, ONLY: iso_HDO IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs INTEGER n,m REAL x(ntraciso,n,m) character*(*) err_msg ! message d''erreur à afficher ! locals LOGICAL iso_verif_traceur_nostop INTEGER i,j,ixt,iiso,izone,ieau INTEGER ifaux,jfaux,ixtfaux CALL iso_verif_traceur_noNaN_vect(x,n,m,err_msg) ! verif masse: iso_verif_tracm_choix_nostop CALL iso_verif_trac_masse_vect(x,n,m,err_msg,errmax,errmaxrel) ! verif deltaD: iso_verif_tracdD_choix_nostop IF (iso_HDO.gt.0) THEN CALL iso_verif_tracdd_vect(x,n,m,err_msg) endif !if (iso_HDO.gt.0) THEN ! verif pas aberramment negatif: iso_verif_tracpos_choix_nostop CALL iso_verif_tracpos_vect(x,n,m,err_msg,1e-5) END SUBROUTINE iso_verif_traceur_vect SUBROUTINE iso_verif_tracnps_vect(x,n,m,err_msg) USE isotopes_mod, ONLY: iso_HDO IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs INTEGER n,m REAL x(ntraciso,n,m) character*(*) err_msg ! message d''erreur à afficher ! locals LOGICAL iso_verif_traceur_nostop INTEGER i,j,ixt,iiso,izone,ieau INTEGER ifaux,jfaux,ixtfaux CALL iso_verif_traceur_noNaN_vect(x,n,m,err_msg) ! verif masse: iso_verif_tracm_choix_nostop CALL iso_verif_trac_masse_vect(x,n,m,err_msg,errmax,errmaxrel) ! verif deltaD: iso_verif_tracdD_choix_nostop IF (iso_HDO.gt.0) THEN CALL iso_verif_tracdd_vect(x,n,m,err_msg) endif !if (iso_HDO.gt.0) THEN END SUBROUTINE iso_verif_tracnps_vect SUBROUTINE iso_verif_traceur_noNaN_vect(x,n,m,err_msg) IMPLICIT NONE ! inputs INTEGER n,m REAL x(ntraciso,n,m) character*(*) err_msg ! message d''erreur à afficher ! locals LOGICAL iso_verif_traceur_nostop INTEGER i,j,ixt,iiso INTEGER ifaux,jfaux,ixtfaux iso_verif_traceur_nostop=.FALSE. ! verif noNaN: iso_verif_traceur_noNaN_nostop do j=1,m do i=1,n do ixt=niso+1,ntraciso IF ((x(ixt,i,j).gt.-borne).AND.(x(ixt,i,j).lt.borne)) THEN else !if ((x.gt.-borne).AND.(x.lt.borne)) THEN iso_verif_traceur_nostop=.TRUE. ifaux=i jfaux=i endif !if ((x.gt.-borne).AND.(x.lt.borne)) THEN enddo !do ixt=niso+1,ntraciso enddo ! do i=1,n enddo ! do j=1,m IF (iso_verif_traceur_nostop) THEN WRITE(*,*) 'erreur detectée par iso_verif_nonNAN ', & 'dans iso_verif_traceur_vect' WRITE(*,*) '' WRITE(*,*) err_msg WRITE(*,*) 'x=',x(:,ifaux,jfaux) stop endif END SUBROUTINE iso_verif_traceur_noNaN_vect SUBROUTINE iso_verif_trac_masse_vect(x,n,m,err_msg, & errmax,errmaxrel) USE isotopes_mod, ONLY: isoName IMPLICIT NONE ! inputs INTEGER n,m REAL x(ntraciso,n,m) character*(*) err_msg ! message d''erreur à afficher REAL errmax,errmaxrel ! locals LOGICAL iso_verif_traceur_nostop INTEGER i,j,ixt,iiso,izone INTEGER ifaux,jfaux,ixtfaux REAL xtractot(n,m) REAL xiiso(n,m) do iiso=1,niso do j=1,m do i=1,n xtractot(i,j)=0.0 xiiso(i,j)=x(iiso,i,j) do izone=1,nzone ixt=itZonIso(izone,iiso) xtractot(i,j)=xtractot(i,j)+x(ixt,i,j) enddo !do izone=1,nzone enddo !do i=1,n enddo !do j=1,m CALL iso_verif_egalite_std_vect( & xtractot,xiiso, & err_msg//', verif trac egalite2, iso ' & //TRIM(isoName(iiso)), & n,m,errmax,errmaxrel) enddo !do iiso=1,niso END SUBROUTINE iso_verif_trac_masse_vect SUBROUTINE iso_verif_tracdd_vect(x,n,m,err_msg) USE isotopes_mod, ONLY: iso_HDO,iso_eau USE isotrac_mod, ONLY: strtrac IMPLICIT NONE ! inputs INTEGER n,m REAL x(ntraciso,n,m) character*(*) err_msg ! message d''erreur à afficher ! locals INTEGER i,j,iiso,izone,ieau,ixt REAL xiiso(niso,n,m) REAL xeau(n,m) INTEGER lnblnk IF (iso_HDO.gt.0) THEN do izone=1,nzone ieau=itZonIso(izone,iso_eau) do iiso=1,niso ixt=itZonIso(izone,iiso) do j=1,m do i=1,n xiiso(iiso,i,j)=x(ixt,i,j) enddo !do i=1,n enddo !do j=1,m enddo !do iiso=1,niso do j=1,m do i=1,n xeau(i,j)=x(ieau,i,j) enddo !do i=1,n enddo !do j=1,m CALL iso_verif_aberrant_vect2Dch( & xiiso,xeau,err_msg//strtrac(izone),niso,n,m, & deltalimtrac) enddo !do izone=1,nzone endif !if (iso_HDO.gt.0) THEN END SUBROUTINE iso_verif_tracdd_vect SUBROUTINE iso_verif_tracpos_vect(x,n,m,err_msg,seuil) IMPLICIT NONE ! inputs INTEGER n,m REAL x(ntraciso,n,m) character*(*) err_msg ! message d''erreur à afficher REAL seuil ! locals INTEGER i,j,ixt LOGICAL iso_verif_traceur_nostop INTEGER ifaux,jfaux,ixtfaux iso_verif_traceur_nostop=.FALSE. do j=1,m do i=1,n do ixt=niso+1,ntraciso IF (x(ixt,i,j).lt.-seuil) THEN ifaux=i jfaux=j ixtfaux=ixt iso_verif_traceur_nostop=.TRUE. endif enddo !do ixt=niso+1,ntraciso enddo !do i=1,n enddo !do j=1,m IF (iso_verif_traceur_nostop) THEN WRITE(*,*) 'erreur detectée par verif positif ', & 'dans iso_verif_traceur_vect' WRITE(*,*) '' WRITE(*,*) err_msg WRITE(*,*) 'x=',x(:,ifaux,jfaux) stop endif END SUBROUTINE iso_verif_tracpos_vect SUBROUTINE iso_verif_tracnps(x,err_msg) USE isotrac_mod, ONLY: ridicule_trac IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher ! locals !integer iso_verif_tracnps_choix_nostop IF (iso_verif_tracnps_choix_nostop(x,err_msg, & errmax,errmaxrel,ridicule_trac,deltalimtrac) & .EQ.1) THEN stop endif END SUBROUTINE iso_verif_tracnps SUBROUTINE iso_verif_tracpos_choix(x,err_msg,seuil) IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher REAL seuil ! locals !integer iso_verif_tracpos_choix_nostop IF (iso_verif_tracpos_choix_nostop(x,err_msg,seuil) & .EQ.1) THEN stop endif END SUBROUTINE iso_verif_tracpos_choix SUBROUTINE iso_verif_traceur_choix(x,err_msg, & errmax,errmaxrel,ridicule_trac_loc,deltalimtrac) IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher REAL errmax,errmaxrel,ridicule_trac_loc,deltalimtrac ! locals !integer iso_verif_traceur_choix_nostop IF (iso_verif_traceur_choix_nostop(x,err_msg, & errmax,errmaxrel,ridicule_trac_loc,deltalimtrac) & .EQ.1) THEN stop endif END SUBROUTINE iso_verif_traceur_choix function iso_verif_traceur_nostop(x,err_msg) USE isotrac_mod, ONLY: ridicule_trac !use isotopes_verif, ONLY: errmax,errmaxrel,deltalimtrac IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher ! output INTEGER iso_verif_traceur_nostop ! locals !integer iso_verif_traceur_choix_nostop iso_verif_traceur_nostop= & iso_verif_traceur_choix_nostop(x,err_msg, & errmax,errmaxrel,ridicule_trac,deltalimtrac) END FUNCTION iso_verif_traceur_nostop SUBROUTINE iso_verif_traceur_justmass(x,err_msg) IMPLICIT NONE ! on vérifie que noNaN et masse ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher ! locals !integer iso_verif_traceur_noNaN_nostop !integer iso_verif_tracm_choix_nostop ! verif noNaN IF (iso_verif_traceur_noNaN_nostop(x,err_msg).EQ.1) THEN stop endif ! verif masse IF (iso_verif_tracm_choix_nostop(x,err_msg, & errmax,errmaxrel).EQ.1) THEN stop endif END SUBROUTINE iso_verif_traceur_justmass function iso_verif_traceur_jm_nostop(x,err_msg) IMPLICIT NONE ! on vérifie que noNaN et masse ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs REAL x(ntraciso) character*(*) err_msg ! message d''erreur à afficher ! output INTEGER iso_verif_traceur_jm_nostop ! locals ! integer iso_verif_traceur_noNaN_nostop !integer iso_verif_tracm_choix_nostop iso_verif_traceur_jm_nostop=0 ! ! verif noNaN ! if (iso_verif_traceur_noNaN_nostop(x,err_msg).EQ.1) THEN ! iso_verif_traceur_jm_nostop=1 ! endif ! verif masse IF (iso_verif_tracm_choix_nostop(x,err_msg, & errmax,errmaxrel).EQ.1) THEN iso_verif_traceur_jm_nostop=1 endif END FUNCTION iso_verif_traceur_jm_nostop SUBROUTINE iso_verif_tag17_q_deltaD_vect(x,n,m,err_msg) USE isotopes_mod, ONLY: tnat,iso_eau, ridicule,iso_HDO USE isotrac_mod, ONLY: option_traceurs,nzone_temp IMPLICIT NONE ! inputs INTEGER n,m REAL x(ntraciso,n,m) character*(*) err_msg ! locals !integer iso_verif_positif_nostop !real deltaD INTEGER ieau,ixt,ieau1 INTEGER i,k IF ((option_traceurs.EQ.17).OR. & (option_traceurs.EQ.18)) THEN ! verifier que deltaD du tag de la couche la plus haute < ! 200 permil, et vérifier que son q est inférieur à ieau=itZonIso(nzone_temp,iso_eau) ixt=itZonIso(nzone_temp,iso_HDO) ieau1=itZonIso(1,iso_eau) do i=1,n do k=1,m IF (x(ieau,i,k).gt.ridicule) THEN IF ((x(ixt,i,k)/x(ieau,i,k)/tnat(iso_HDO)-1)*1000 & .gt.-200.0) THEN WRITE(*,*) err_msg,', vect:deltaDt05 trop fort' WRITE(*,*) 'i,k=',i,k WRITE(*,*) 'x(:,i,k)=',x(:,i,k) stop endif !if (iso_verif_positif_nostop(-200.0-deltaD(x(ixt),x(ieau)), endif !if (x(ieau).gt.ridicule) THEN IF (x(ieau,i,k).gt.2.0e-3) THEN WRITE(*,*) err_msg,', vect:qt05 trop fort' WRITE(*,*) 'i,k=',i,k WRITE(*,*) 'x(:,i,k)=',x(:,i,k) stop endif !if (iso_verif_positif_nostop(1.0e-3-x(ieau), IF (x(iso_eau,i,k).lt.2.0e-3) THEN IF (x(ieau1,i,k)/x(iso_eau,i,k).gt.0.1) THEN WRITE(*,*) err_msg,', vect: qt01 trop abondant' WRITE(*,*) 'i,k=',i,k WRITE(*,*) 'ieau1,iso_eau,x(ieau1,i,k),', & 'x(iso_eau,i,k)=',ieau1,iso_eau, & x(ieau1,i,k),x(iso_eau,i,k) WRITE(*,*) 'x(:,i,k)=',x(:,i,k) stop endif !if (x(ieau1,i,k)/x(iso_eau,i,k).gt.0.1) THEN endif enddo !do k=1,m enddo !do i=1,n endif !if (option_traceurs.EQ.17) THEN END SUBROUTINE iso_verif_tag17_q_deltaD_vect SUBROUTINE iso_verif_tag17_q_deltaD_vect_ret3D(x,n,m,nq,err_msg) USE isotopes_mod, ONLY: tnat,iso_eau,iso_HDO,ridicule USE isotrac_mod, ONLY: option_traceurs,nzone_temp IMPLICIT NONE ! inputs INTEGER n,m,nq REAL x(n,m,nq,ntraciso) character*(*) err_msg ! locals !integer iso_verif_positif_nostop !real deltaD INTEGER ieau,ixt,ieau1 INTEGER i,k,iq IF ((option_traceurs.EQ.17).OR. & (option_traceurs.EQ.18)) THEN ! verifier que deltaD du tag de la couche la plus haute < ! 200 permil, et vérifier que son q est inférieur à ieau=itZonIso(nzone_temp,iso_eau) ixt=itZonIso(nzone_temp,iso_HDO) ieau1=itZonIso(1,iso_eau) do iq=1,nq do i=1,n do k=1,m IF (x(i,k,iq,ieau).gt.ridicule) THEN IF ((x(i,k,iq,ixt)/x(i,k,iq,ieau)/tnat(iso_HDO)-1)*1000 & .gt.-200.0) THEN WRITE(*,*) err_msg,', vect:deltaDt05 trop fort' WRITE(*,*) 'i,k=',i,k WRITE(*,*) 'x(i,k,iq,:)=',x(i,k,iq,:) stop endif !if (iso_verif_positif_nostop(-200.0-deltaD(x(ixt),x(ieau)), endif !if (x(ieau).gt.ridicule) THEN IF (x(i,k,iq,ieau).gt.2.0e-3) THEN WRITE(*,*) err_msg,', vect:qt05 trop fort' WRITE(*,*) 'i,k=',i,k WRITE(*,*) 'x(i,k,iq,:)=',x(i,k,iq,:) stop endif !if (iso_verif_positif_nostop(1.0e-3-x(ieau), IF (x(i,k,iq,iso_eau).lt.2.0e-3) THEN IF (x(i,k,iq,ieau1)/x(i,k,iq,iso_eau).gt.0.1) THEN WRITE(*,*) err_msg,', vect: qt01 trop abondant' WRITE(*,*) 'i,k=',i,k WRITE(*,*) 'ieau1,iso_eau,x(i,k,iq,ieau1),', & 'x(i,k,iq,ieau)=',ieau1,iso_eau, & x(i,k,iq,ieau1),x(i,k,iq,iso_eau) WRITE(*,*) 'x(i,k,iq,:)=',x(i,k,iq,:) stop endif !if (x(ieau1,i,k)/x(iso_eau,i,k).gt.0.1) THEN endif enddo !do k=1,m enddo !do i=1,n enddo ! do iq=1,nq endif !if (option_traceurs.EQ.17) THEN END SUBROUTINE iso_verif_tag17_q_deltaD_vect_ret3D #endif ! END IF ISOTRAC END MODULE isotopes_verif_mod #endif ! END IF ISOVERIF