#ifdef ISO #ifdef ISOTRAC ! $Id: $ MODULE isotrac_routines_mod ! on créé ce module pour éviter dépendances circulaires. ! isotopes_routines_mod a besoin de isotrac et isotopes_verif ! isotopes_verif a besoin de isotopes et isotrac ! isotrac n'a besoin que de isotopes USE infotrac_phy, ONLY: ntraciso=>ntiso, niso, index_trac=>itZonIso, ntraceurs_zone=>nzone IMPLICIT NONE CONTAINS SUBROUTINE uncompress_commun_zone(ncas, cas, & xtp_cas,xtp,xtwater_cas,xtwater,xtevap_cas,xtevap, & ncum,izone) USE isotopes_mod, ONLY: ridicule,iso_eau IMPLICIT NONE ! decompression des outputs communs à tous les cas dans ! appel_stewart ! cas des traceurs. Ici, aucun risque de revap franche. ! inputs INTEGER ncas,ncum INTEGER cas(ncum) REAL xtevap_cas(niso,ncum) REAL xtp_cas(niso,ncum) REAL xtwater_cas(niso,ncum) INTEGER izone ! outputs REAL xtwater(ntraciso,ncum) REAL xtp(ntraciso,ncum) REAL xtevap(ntraciso,ncum) ! locals INTEGER il,ixt,iiso,ixt_revap DO il=1,ncas DO iiso=1,niso ixt=index_trac(izone,iiso) xtevap(ixt,cas(il))=xtevap_cas(iiso,il) xtp(ixt,cas(il))=xtp_cas(iiso,il) xtwater(ixt,cas(il))=xtwater_cas(iiso,il) enddo !do iiso=1,niso enddo !do il=1,ncas END SUBROUTINE uncompress_commun_zone SUBROUTINE uncompress_commun_zone_revap(ncas, cas, & xtp_cas,xtp,xtwater_cas,xtwater, & xtevap_cas,xtevap, & ncum,izone,Eqi_stewart,fac_ftmr_cas, & #ifdef ISOVERIF Exi_cas,Exi, & #endif xtp_avantevap_cas,liq,hdiag) USE isotopes_mod, ONLY: ridicule,iso_eau,iso_HDO,ridicule_evap USE isotrac_mod, ONLY: option_revap,evap_franche,izone_revap, & & ridicule_trac #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! decompression des outputs communs à tous les cas dans ! appel_stewart ! cas des traceurs: mais ici, risque de révap franche -> on fat ! plus attention ! inputs INTEGER ncas,ncum INTEGER cas(ncum) REAL xtevap_cas(niso,ncum) REAL xtp_cas(niso,ncum) REAL xtwater_cas(niso,ncum) INTEGER izone REAL Eqi_stewart(ncum) REAL xtp_avantevap_cas(niso,ncum) REAL fac_ftmr_cas(ncum) INTEGER liq REAL hdiag(ncas) ! outputs REAL xtwater(ntraciso,ncum) REAL xtp(ntraciso,ncum) REAL xtevap(ntraciso,ncum) ! locals INTEGER il,ixt,iiso,ixt_revap REAL xtaddp_tag(niso,ncum) #ifdef ISOVERIF INTEGER ieau,iHDO REAL Exi_cas(niso,ncum) REAL Exi(ntraciso,ncum) !USE isotopes_verif, ONLY: #endif ! WRITE(*,*) 'compress_stewart 315 tmp: ', ! : 'entrée dans uncompress_commun_zone_revap' DO il=1,ncas IF ((option_revap.EQ.1).AND. & ((((liq.EQ.1).AND. & (Eqi_stewart(il)*fac_ftmr_cas(il).gt.evap_franche) & .AND.(hdiag(il).lt.0.99)).OR. & ((liq.EQ.0).AND. & (Eqi_stewart(il)*fac_ftmr_cas(il).ge.0.0))).OR. & (izone.EQ.izone_revap))) THEN ! if ((option_revap.EQ.1).AND. ! : (((Eqi_stewart(il)*fac_ftmr_cas(il).gt.evap_franche) ! : .OR.((liq.EQ.0).AND. ! : (Eqi_stewart(il)*fac_ftmr_cas(il).ge.0.0))).OR. ! : (izone.EQ.izone_revap))) THEN ! on met la revap dans izone_revap si option_revap=1 et si: ! * evap glace (non fractionnante) ! * ou evap liq suffisemment forte pour que pas de flux ! d'isotopes négatifs. ! si option_revap=1 et izone=izone_revap, on met aussi dans izone_revap !#ifdef ISOVERIF ! if (il.EQ.1) THEN ! WRITE(*,*) 'compress tmp 341: revap dans izone_revap' ! WRITE(*,*) 'Eqi_stewart(il),fac_ftmr_cas(il),evap_franche=', ! : Eqi_stewart(il),fac_ftmr_cas(il),evap_franche ! WRITE(*,*) 'il,xtp_cas(iso_eau,il)=',il,xtp_cas(iso_eau,il) ! WRITE(*,*) 'il,xtp_avantevap_cas(iso_eau,il)=',il, ! : xtp_avantevap_cas(iso_eau,il) ! WRITE(*,*) 'xtp(ixt_revap,cas(il))=', ! : xtp(index_trac(izone_revap,iso_eau),cas(il)) ! endif !#endif ! toute la révap franche va dans izone_revap DO iiso=1,niso ixt=index_trac(izone,iiso) ixt_revap=index_trac(izone_revap,iiso) ! le terme d'évap qui était pour la zone izone devient ! nul, et à la place on le met dans izone_revap& xtevap(ixt_revap,cas(il))=xtevap(ixt_revap,cas(il)) & +xtevap_cas(iiso,il) ! ce qui a été ajouté à xtp par rapport à xtp_avantevap ! est ajouté à izone_revap, au lieu de izone xtaddp_tag(iiso,il)=xtp_cas(iiso,il) & -xtp_avantevap_cas(iiso,il) xtp(ixt_revap,cas(il))= & xtp(ixt_revap,cas(il)) & +xtaddp_tag(iiso,il) enddo !do iiso=1,niso #ifdef ISOVERIF IF (iso_HDO.gt.0) THEN IF (xtevap_cas(iso_eau,il).gt.ridicule_evap) THEN CALL iso_verif_aberrant_choix( & xtevap_cas(iso_HDO,il),xtevap_cas(iso_eau,il), & ridicule_trac,deltalimtrac*2,'compress 344a') endif ieau=index_trac(izone_revap,iso_eau) iHDO=index_trac(izone_revap,iso_HDO) CALL iso_verif_aberrant_choix(xtevap(iHDO,cas(il)), & xtevap(ieau,cas(il)),ridicule_trac,deltalimtrac*2, & 'compress 344b') endif !if (iso_HDO.gt.0) THEN #endif ! l'évap des autres zones devient nulle IF (izone.NE.izone_revap) THEN DO iiso=1,niso ixt=index_trac(izone,iiso) xtevap(ixt,cas(il))=0.0 xtp(ixt,cas(il))=xtp_avantevap_cas(iiso,il) enddo endif !#ifdef ISOVERIF ! if (il.EQ.1) THEN ! WRITE(*,*) 'compress tmp 341: revap dans izone_revap' ! WRITE(*,*) 'xtp(ixt_revap,cas(il))=', ! : xtp(index_trac(izone_revap,iso_eau),cas(il)) ! WRITE(*,*) 'xtp(ixt,cas(il))=', ! : xtp(index_trac(izone,iso_eau),cas(il)) ! endif !#endif else !if ((Eqi_stewart(il).gt.ridicule_evap*100) DO iiso=1,niso ixt=index_trac(izone,iiso) xtevap(ixt,cas(il))=xtevap_cas(iiso,il) xtp(ixt,cas(il))=xtp_cas(iiso,il) enddo !do iiso=1,niso endif !if ((Eqi_stewart(il).gt.ridicule_evap*100) enddo !do il=1,ncas DO il=1,ncas DO iiso=1,niso ixt=index_trac(izone,iiso) xtwater(ixt,cas(il))=xtwater_cas(iiso,il) #ifdef ISOVERIF Exi(ixt,cas(il))=Exi_cas(iiso,il) #endif enddo !do iiso=1,niso enddo !do il=1,ncas ! WRITE(*,*) 'compress_stewart 361 tmp: ', ! : 'sortie de uncompress_commun_zone_revap' END SUBROUTINE uncompress_commun_zone_revap SUBROUTINE compress_cond_facftmr_zone( & ncas, cas, & Eqi_prime_cas,Eqi_prime, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap,& water_cas,water,& #ifdef ISOVERIF evap_cas,evap, & #endif nloc,ncum,nd,i,izone) USE isotopes_mod, ONLY: iso_eau #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr ! inputs INTEGER nd,ncum,nloc INTEGER ncas INTEGER cas(ncum) INTEGER i INTEGER izone real & xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum), & water_cas(ncum),water(ncum) REAL Eqi_prime_cas(ncum),Eqi_prime(ncum), & Pqisup_cas(ncum),Pqisup(ncum), & Pxtisup_cas(niso,ncum),Pxtisup(ntraciso,ncum), & qp_avantevap_cas(ncum),qp_avantevap(ncum), & xtp_avantevap_cas(niso,ncum),xtp_avantevap(ntraciso,ncum) #ifdef ISOVERIF REAL evap_cas(ncum),evap(ncum) #endif ! locals INTEGER il,ixt,ieau,iiso ieau=index_trac(izone,iso_eau) DO il=1,ncas IF (qp_avantevap(cas(il)).gt.0.0) THEN Eqi_prime_cas(il)=Eqi_prime(cas(il)) & *(xtp_avantevap(ieau,cas(il))/qp_avantevap(cas(il))) else !if (qp_avantevap_cas(cas(il)).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite_choix( & (Eqi_prime(cas(il))),0.0, & 'compress_stewart 495',errmax,errmaxrel) #endif Eqi_prime_cas(il)=0.0 endif !if (qp_avantevap_cas(cas(il)).gt.0.0) thens IF (Pqisup(cas(il))-Eqi_prime(cas(il)).gt.0.0) THEN water_cas(il)=water(cas(il)) & *((Pxtisup(ieau,cas(il))-Eqi_prime_cas(il)) & /(Pqisup(cas(il))-Eqi_prime(cas(il)))) else !if (Pqisup(cas(il)).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite_choix(water(cas(il)),0.0, & 'compress_stewart 507',errmax,errmaxrel) #endif water_cas(il)=0.0 endif !if (Pqisup(cas(il)).gt.0.0) THEN Pqisup_cas(il)=Pxtisup(ieau,cas(il)) qp_avantevap_cas(il)=xtp_avantevap(ieau,cas(il)) !#ifdef ISOVERIF ! CALL iso_verif_noNaN(water_cas(il),'compress_stewart 518') ! evap_cas(il)=evap(cas(il)) ! : *(xtp_avantevap(ieau,cas(il))/qp_avantevap(cas(il))) !! qp_cas(il)=xtp(ieau,cas(il)) !#endif DO iiso=1,niso ixt=index_trac(izone,iiso) Pxtisup_cas(iiso,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(iiso,il)=xtp_avantevap(ixt,cas(il)) xtevapsup_cas(iiso,il)=xtevap(ixt,cas(il)) enddo enddo END SUBROUTINE compress_cond_facftmr_zone SUBROUTINE compress_cond_nofftmr_zone( & ncas, cas, & Eqi_prime_cas,Eqi_prime, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & water_cas,water, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xt_cas,xt,q_cas,q, & xtevapsup_cas,xtevap, & #ifdef ISOVERIF evap_cas,evap, & #endif nloc,ncum,nd,i,izone) USE isotopes_mod, ONLY: iso_eau #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr ! inputs INTEGER nloc,nd,ncum INTEGER ncas INTEGER cas(ncum) INTEGER i INTEGER izone real & xt_cas(niso,ncum),q_cas(ncum),xt(ntraciso,ncum),q(ncum), & xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum), & water_cas(ncum),water(ncum) REAL Eqi_prime_cas(ncum),Eqi_prime(ncum), & Pqisup_cas(ncum),Pqisup(ncum), & Pxtisup_cas(niso,ncum),Pxtisup(ntraciso,ncum), & qp_avantevap_cas(ncum),qp_avantevap(ncum), & xtp_avantevap_cas(niso,ncum),xtp_avantevap(ntraciso,ncum) #ifdef ISOVERIF REAL evap_cas(ncum),evap(ncum) #endif ! locals INTEGER il,ixt,ieau,iiso ieau=index_trac(izone,iso_eau) DO il=1,ncas IF (qp_avantevap(cas(il)).gt.0) THEN Eqi_prime_cas(il)=Eqi_prime(cas(il)) & *(xtp_avantevap(ieau,cas(il))/qp_avantevap(cas(il))) else Eqi_prime_cas(il)=Eqi_prime(cas(il)) & *(xt(ieau,cas(il))/q(cas(il))) endif IF (Pqisup(cas(il))-Eqi_prime(cas(il)).gt.0.0) THEN water_cas(il)=water(cas(il)) & *((Pxtisup(ieau,cas(il))-Eqi_prime_cas(il)) & /(Pqisup(cas(il))-Eqi_prime(cas(il)))) else !if (Pqisup(cas(il)).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite_choix(water(cas(il)),0.0, & 'compress_stewart 654',errmax,errmaxrel) #endif water_cas(il)=0.0 endif !if (Pqisup(cas(il)).gt.0.0) THEN Pqisup_cas(il)=Pxtisup(ieau,cas(il)) qp_avantevap_cas(il)=xtp_avantevap(ieau,cas(il)) q_cas(il)=xt(ieau,cas(il)) !#ifdef ISOVERIF ! if (qp_avantevap(cas(il)).gt.0.0) THEN ! evap_cas(il)=evap(cas(il)) ! : *(xtp_avantevap(ieau,cas(il))/qp_avantevap(cas(il))) ! else ! evap_cas(il)=evap(cas(il)) ! : *(xt(ieau,cas(il))/q(cas(il))) ! endif ! qp_cas(il)=xtp(ieau,cas(il)) !#endif DO iiso=1,niso ixt=index_trac(izone,iiso) Pxtisup_cas(iiso,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(iiso,il)=xtp_avantevap(ixt,cas(il)) xt_cas(iiso,il)=xt(ixt,cas(il)) xtevapsup_cas(iiso,il)=xtevap(ixt,cas(il)) enddo enddo END SUBROUTINE compress_cond_nofftmr_zone SUBROUTINE compress_noevap_zone( & ncas, cas, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap, & water_cas,water, & #ifdef ISOVERIF evap_cas,evap, & #endif nloc,ncum,nd,i,izone) USE isotopes_mod, ONLY: ridicule,iso_eau #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr INTEGER nloc,nd,ncum INTEGER ncas INTEGER cas(ncum) INTEGER i INTEGER izone REAL xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum), & water_cas(ncum),water(ncum) REAL Pqisup_cas(ncum),Pqisup(ncum), & Pxtisup_cas(niso,ncum),Pxtisup(ntraciso,ncum), & xtp_avantevap_cas(niso,ncum),xtp_avantevap(ntraciso,ncum) #ifdef ISOVERIF REAL evap_cas(ncum),evap(ncum) #endif INTEGER il,ixt,ieau,iiso ieau=index_trac(izone,iso_eau) DO il=1,ncas Pqisup_cas(il)=Pxtisup(ieau,cas(il)) IF (Pqisup(cas(il)).gt.0.0) THEN water_cas(il)=water(cas(il)) & *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) else water_cas(il)=0.0 #ifdef ISOVERIF CALL iso_verif_egalite_choix(water(cas(il)), & 0.0,'compress_stewart 709',errmax,errmaxrel) #endif endif #ifdef ISOVERIF ! evap_cas(il)=evap(cas(il)) ! : *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) ! qp_cas(il)=xtp(ieau,cas(il)) #endif DO iiso=1,niso ixt=index_trac(izone,iiso) Pxtisup_cas(iiso,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(iiso,il)=xtp_avantevap(ixt,cas(il)) xtevapsup_cas(iiso,il)=xtevap(ixt,cas(il)) enddo enddo END SUBROUTINE compress_noevap_zone SUBROUTINE compress_evap_liq_zone(iflag_con,ncas, & cas, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtp_avantevaptrac_cas,qp_avantevaptrac_cas, & xtevapsup_cas,xtevap, & water_cas,water, & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas,& Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime,ptrac, & Eqi,Eqi_cas, & ! & qp_cas, #ifdef ISOVERIF evap_cas,evap, & #endif nloc,ncum,nd,izone) USE isotopes_mod, ONLY: ridicule,iso_eau #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr ! inputs et outputs INTEGER iflag_con INTEGER izone INTEGER nloc,nd,ncum INTEGER ncas INTEGER cas(ncum) ! integer i REAL xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum) REAL xtp_avantevap_cas(niso,ncum), & xtp_avantevap(ntraciso,ncum) REAL water_cas(ncum),water(ncum) REAL xtp_avantevaptrac_cas(niso,ncum), & qp_avantevaptrac_cas(ncum) REAL ptrac(ncum) ! real qp_cas(ncum) #ifdef ISOVERIF REAL evap_cas(ncum),evap(ncum) #endif REAL & Eqi_stewart(ncum),Pqiinf_stewart(ncum),Eqi_prime_cas(ncum), & Pqiinf(ncum),Eqi_par(ncum),Pqiinf_par(ncum), & Eqi_prime(ncum),Pqisup(ncum),Pqisup_cas(ncum), & Pxtisup(ntraciso,ncum),Pxtisup_cas(niso,ncum), & Eqi(ncum),Eqi_cas(ncum) ! locals INTEGER il,ixt,iiso,ieau ! WRITE(*,*) 'compress 910: xtp_avantevap(iso_eau,cas(1))=', ! : xtp_avantevap(iso_eau,cas(1)) ! WRITE(*,*) 'compress_evap_liq_zone 510: ncas,ncum=',ncas,ncum ptrac(:)=0. ! CR 31 mars 2023: initialisation de ptrac ieau=index_trac(izone,iso_eau) DO il=1,ncas Pqisup_cas(il)=Pxtisup(ieau,cas(il)) IF (Pqisup(cas(il)).gt.0.0) THEN ptrac(il)=Pxtisup(ieau,cas(il))/Pqisup(cas(il)) Eqi_prime_cas(il)=Eqi_prime(cas(il)) & *ptrac(il) else #ifdef ISOVERIF CALL iso_verif_egalite(( & Eqi_prime(cas(il))),0.0, & 'compress_stewart 979') #endif Eqi_prime_cas(il)=0.0 endif IF (Pqisup(cas(il))-Eqi_prime(cas(il)).gt.0.0) THEN water_cas(il)=water(cas(il)) & *((Pxtisup(ieau,cas(il))-Eqi_prime_cas(il)) & /(Pqisup(cas(il))-Eqi_prime(cas(il)))) else !if (Pqisup(cas(il)).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite_choix(water(cas(il)),0.0, & 'compress_stewart 507',errmax,errmaxrel) #endif water_cas(il)=0.0 endif !if (Pqisup(cas(il)).gt.0.0) THEN ! qp_cas(il)=qp(cas(il)) #ifdef ISOVERIF ! evap_cas(il)=evap(cas(il)) ! & *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) ! ! ce calcul est faux& normalement, ! evap_cas(il)=Eqi_prime_cas(il)//100.0/delP_cas(il)/SIGD*g*2.0 ! & -(ieau,cas(il)) #endif qp_avantevaptrac_cas(il)=xtp_avantevap(ieau,cas(il)) DO iiso=1,niso ixt=index_trac(izone,iiso) Pxtisup_cas(iiso,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(iiso,il)=xtp_avantevap(iiso,cas(il)) xtp_avantevaptrac_cas(iiso,il)=xtp_avantevap(ixt,cas(il)) xtevapsup_cas(iiso,il)=xtevap(ixt,cas(il)) enddo enddo !do il=1,ncas ! WRITE(*,*) 'compress_stewart 931: ', ! & 'xtp_avantevap_cas(iso_eau,1)=', ! & xtp_avantevap_cas(iso_eau,1) ! WRITE(*,*) 'xtp_avantevap(iso_eau,cas(1))=', ! & xtp_avantevap(iso_eau,cas(1)) ! calculs des flux de masses à mettre en argument de stewart: ! comme l'eau n'est pas bien concervée dans les ddfts, on est ! obligé de bidouillé. ! 1) soit on considère Pqisup, Eqi, et Pqiinf_par=Pqisup-Eqi ! et on suppose que dans la réalité les compositions de ! Pqiinf sont les même que Pqiinf_par ! 2) soit on considère Pqisup, Eqi_par=Pqisup-Pqiinf, et Pqiinf, ! et on suppose que dans la réalité les compositions de ! Eqi_prime sont les même que Eqi_par DO il=1,ncas IF (Pqisup(cas(il)).gt.0.0) THEN IF ((water(cas(il)).gt.ridicule/100).AND. & (Pqiinf_par(cas(il)).le.0.0)) THEN ! on ne peut pas utiliser la méthode 1, car KE prédit de l'eau ! alors que le bilan de masse n'enprédit pas. ! Peut-on utiliser la méthode 2? Pqiinf_stewart(il)=Pqiinf(cas(il))*ptrac(il) Eqi_stewart(il)=Eqi_par(cas(il)) *ptrac(il) else !if ((water(il,i).gt.ridicule/100).AND.(Pqiinf_par.le.0.0)) THEN ! il n'y a pas d'obstacles à l'utilisation de 1) Pqiinf_stewart(il)=Pqiinf_par(cas(il))*ptrac(il) IF (iflag_con.EQ.30) THEN Eqi_stewart(il)=Eqi_prime(cas(il))*ptrac(il) else Eqi_stewart(il)=Eqi(cas(il))*ptrac(il) endif endif !if ((water(il,i).gt.ridicule/100).AND.(Pqiinf_par.le.0.0)) THEN else ! if (Pqisup(cas(il).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite((Pqiinf(cas(il))), & 0.0,'compress_stewart 1047a') CALL iso_verif_egalite(( & Eqi_prime(cas(il))),0.0,'compress_stewart 1047b') CALL iso_verif_egalite(( & Pqiinf_par(cas(il))),0.0,'compress_stewart 1047c') CALL iso_verif_egalite((Eqi_par(cas(il))), & 0.0,'compress_stewart 1047d') #endif Pqiinf_stewart(il)=0.0 Eqi_stewart(il)=0.0 endif ! if (Pqisup(cas(il).gt.0.0) THEN enddo !do il=1,ncas_evap_glace ! petite vérif #ifdef ISOVERIF DO il=1,ncas IF ((abs(water_cas(il)).ge.ridicule/10.) & .AND.(Pqiinf_stewart(il).le.0.0)) THEN WRITE(*,*) 'compress_stewart 498: evap liq:' WRITE(*,*) 'water(il,i)=', water_cas(il) WRITE(*,*) 'Pqiinf=',Pqiinf(cas(il)) WRITE(*,*) 'Pqiinf_par=',Pqiinf_par(cas(il)) WRITE(*,*) 'Pqiinf_stewart=',Pqiinf_stewart(il) stop endif enddo !do il=1,ncas_evap_glace #endif END SUBROUTINE compress_evap_liq_zone SUBROUTINE compress_evap_glace_zone(iflag_con, & ncas, cas, & water_cas,water, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtp_avantevaptrac_cas,qp_avantevaptrac_cas, & xtevapsup_cas,xtevap, & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas,Eqi_cas, & Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime,Eqi, & ! & qp_cas, #ifdef ISOVERIF evap_cas,evap, & #endif nloc,ncum,nd,i,frac_sublim,izone) USE isotopes_mod, ONLY: ridicule,iso_eau #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr INTEGER iflag_con INTEGER nloc,nd,ncum INTEGER ncas INTEGER cas(ncum) INTEGER i INTEGER izone real & water_cas(ncum),water(ncum), & xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum) ! real qp_cas(ncum) #ifdef ISOVERIF REAL evap_cas(ncum),evap(ncum) #endif real & Pqisup_cas(ncum),Pqisup(ncum), & Pxtisup_cas(niso,ncum),Pxtisup(ntraciso,ncum), & xtp_avantevap_cas(niso,ncum),xtp_avantevap(ntraciso,ncum), & Eqi_stewart(ncum),Pqiinf_stewart(ncum),Eqi_prime_cas(ncum), & Pqiinf(ncum),Eqi_par(ncum),Pqiinf_par(ncum),Eqi_prime(ncum), & Eqi(ncum),Eqi_cas(ncum) REAL xtp_avantevaptrac_cas(niso,ncum), & qp_avantevaptrac_cas(ncum) INTEGER frac_sublim ! locals INTEGER il,ixt,ieau,iiso ieau=index_trac(izone,iso_eau) DO il=1,ncas Pqisup_cas(il)=Pxtisup(ieau,cas(il)) IF (Pqisup(cas(il)).gt.0.0) THEN Eqi_prime_cas(il)=Eqi_prime(cas(il)) & *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) Eqi_cas(il)=Eqi(cas(il)) & ! corr bug Camille 15 juin 2024 *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) else #ifdef ISOVERIF CALL iso_verif_egalite(( & Eqi_prime(cas(il))),0.0, & 'compress_stewart 979b') #endif Eqi_prime_cas(il)=0.0 Eqi_cas(il)=0.0 endif IF (Pqisup(cas(il))-Eqi_prime(cas(il)).gt.0.0) THEN water_cas(il)=water(cas(il)) & *((Pxtisup(ieau,cas(il))-Eqi_prime_cas(il)) & /(Pqisup(cas(il))-Eqi_prime(cas(il)))) else !if (Pqisup(cas(il)).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite_choix(water(cas(il)),0.0, & 'compress_stewart 507',errmax,errmaxrel) #endif water_cas(il)=0.0 endif !if (Pqisup(cas(il)).gt.0.0) THEN qp_avantevaptrac_cas(il)=xtp_avantevap(ieau,cas(il)) ! qp_cas(il)=xtp(ieau,cas(il)) #ifdef ISOVERIF ! evap_cas(il)=evap(cas(il)) ! & *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) ! ce calcul est faux& faire plutot: ! evap_cas(il)=Eqi_prime_cas(il)//100.0/delP_cas(il)/SIGD*g*2.0 ! & -(ieau,cas(il)) #endif DO iiso=1,niso ixt=index_trac(izone,iiso) Pxtisup_cas(iiso,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(iiso,il)=xtp_avantevap(iiso,cas(il)) xtp_avantevaptrac_cas(iiso,il)=xtp_avantevap(ixt,cas(il)) xtevapsup_cas(iiso,il)=xtevap(ixt,cas(il)) enddo enddo !do il=1,ncas ! calculs des flux de masses à mettre en argument de stewart: ! comme l'eau n'est pas bien concervée dans les ddfts, on est ! obligé de bidouillé. ! 1) soit on considère Pqisup, Eqi, et Pqiinf_par=Pqisup-Eqi ! et on suppose que dans la réalité les compositions de ! Pqiinf sont les même que Pqiinf_par ! 2) soit on considère Pqisup, Eqi_par=Pqisup-Pqiinf, et Pqiinf, ! et on suppose que dans la réalité les compositions de ! Eqi_prime sont les même que Eqi_par DO il=1,ncas IF (Pqisup(cas(il)).gt.0.0) THEN IF ((water(cas(il)).gt.ridicule/100).AND. & (Pqiinf_par(cas(il)).le.0.0)) THEN ! on ne peut pas utiliser la méthode 1, car KE prédit de l'eau ! alors que le bilan de masse n'enprédit pas. ! Peut-on utiliser la méthode 2? Pqiinf_stewart(il)=Pqiinf(cas(il)) & *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) Eqi_stewart(il)=Eqi_par(cas(il)) & *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) else !if ((water(il,i).gt.ridicule/100).AND.(Pqiinf_par.le.0.0)) THEN ! il n'y a pas d'obstacles à l'utilisation de 1) Pqiinf_stewart(il)=Pqiinf_par(cas(il)) & *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) IF (iflag_con.EQ.30) THEN Eqi_stewart(il)=Eqi_prime(cas(il)) & *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) else Eqi_stewart(il)=Eqi(cas(il)) & *(Pxtisup(ieau,cas(il))/Pqisup(cas(il))) endif endif !if ((water(il,i).gt.ridicule/100).AND.(Pqiinf_par.le.0.0)) THEN else !if (Pqisup(cas(il).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite((Pqiinf(cas(il))), & 0.0,'compress_stewart 1347a') CALL iso_verif_egalite(( & Eqi_prime(cas(il))),0.0,'compress_stewart 1347b') CALL iso_verif_egalite(( & Pqiinf_par(cas(il))),0.0,'compress_stewart 1347c') CALL iso_verif_egalite((Eqi_par(cas(il))), & 0.0,'compress_stewart 1347d') #endif Pqiinf_stewart(il)=0.0 Eqi_stewart(il)=0.0 endif !if (Pqisup(cas(il).gt.0.0) THEN enddo !do il=1,ncas_evap_glace ! petite vérif #ifdef ISOVERIF DO il=1,ncas IF ((abs(water_cas(il)).ge.ridicule/10.) & .AND.(Pqiinf_stewart(il).le.0.0)) THEN WRITE(*,*) 'compress_stewart 498: evap glace:' WRITE(*,*) 'water(il,i)=', water_cas(il) WRITE(*,*) 'Pqiinf=',Pqiinf(cas(il)) WRITE(*,*) 'Pqiinf_par=',Pqiinf_par(cas(il)) WRITE(*,*) 'Pqiinf_stewart=',Pqiinf_stewart(il) stop endif enddo !do il=1,ncas_evap_glace #endif END SUBROUTINE compress_evap_glace_zone SUBROUTINE uncompress_ilp_zone( & ncas,cas, & zxtrfln_cas,zxt_cas,zxtrfl,zxtrfln,zxt,klon, & izone,Eqi,Exi,fac_ftmr, & xtrevap_tag,liq,hdiag) USE isotopes_mod, ONLY: ridicule,iso_eau USE isotrac_mod, ONLY: option_revap,evap_franche #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas INTEGER cas(ncas) INTEGER klon INTEGER izone REAL zxt_cas(niso,ncas),zxtrfln_cas(niso,ncas) REAL Exi(niso,ncas) REAL Eqi(ncas) REAL fac_ftmr(ncas) INTEGER liq REAL hdiag(ncas) ! output REAL zxt(ntraciso,klon) REAL zxtrfl(ntraciso,klon),zxtrfln(ntraciso,klon) REAL xtrevap_tag(ntraciso,ncas) ! locals INTEGER il,ixt,iiso ! WRITE(*,*) 'uncompress_stewart 1420 tmp: zxt=', ! : zxt(iso_eau:ntraciso:3,cas(1)) ! WRITE(*,*) 'Exi,fac_ftmr=', ! : Exi(iso_eau,1),fac_ftmr(1) DO il=1,ncas DO iiso=1,niso ixt=index_trac(izone,iiso) zxtrfln(ixt,cas(il))=zxtrfln_cas(iiso,il) zxtrfl(ixt,cas(il))=zxtrfln_cas(iiso,il) enddo !do iiso=1,niso !#ifdef ISOVERIF ! if (il.EQ.9) THEN ! WRITE(*,*) 'uncompress 1521' ! WRITE(*,*) 'il,Eqi,fac_ftmr,evap_franche,Exi(2,il)=', ! : il,Eqi(il),fac_ftmr(il),evap_franche,Exi(2,il) ! endif !#endif IF ((option_revap.EQ.1).AND. & (((liq.EQ.1).AND.(Eqi(il)*fac_ftmr(il).gt.evap_franche) & .AND.(hdiag(il).lt.0.99)).OR. & ((liq.EQ.0).AND. & (Eqi(il)*fac_ftmr(il).ge.0.0)))) THEN ! le flux d'évap va dans un tag particulier ! -> zxt est inchangé mais xtrevap_tag(ixt,il) est incrémenté DO iiso=1,niso ixt=index_trac(izone,iiso) xtrevap_tag(ixt,il)=fac_ftmr(il)*Exi(iiso,il) ! zxt(ixt,cas(il))=zxt_cas(iiso,il) ! : -xtrevap_tag(ixt,il) enddo !do iiso=1,niso else !if ((Eqi(il)*fac_ftmr(il).gt.evap_franche).AND. ! reequilibration standard DO iiso=1,niso ixt=index_trac(izone,iiso) zxt(ixt,cas(il))=zxt(ixt,cas(il)) & +fac_ftmr(il)*Exi(iiso,il) zxt(ixt,cas(il))=max(0.0,zxt(ixt,cas(il))) xtrevap_tag(ixt,il)=0.0 #ifdef ISOVERIF CALL iso_verif_positif_choix(zxt(ixt,cas(il)), & 0.0,'compress 1508') #endif enddo ! do iiso=1,niso endif !if ((Eqi(il)*fac_ftmr(il).gt.evap_franche).AND. enddo !do il=1,ncas ! WRITE(*,*) 'compress_stewart 1453 tmp: zxt=', ! : zxt(iso_eau:ntraciso:3,cas(1)) END SUBROUTINE uncompress_ilp_zone SUBROUTINE compress_ilp_evap_liq_zone( & ncas,cas, & zxt_cas,zxt, & zxtrfl_cas,zxtrfl_ancien, & zrfln_cas,zrfln, & zrfl_cas,zrfl_ancien, & zqev_diag_cas,zqev_diag, & klon,izone,ptrac) USE isotopes_mod, ONLY: ridicule,iso_eau #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas INTEGER cas(ncas) INTEGER klon REAL zxt(ntraciso,klon) REAL zxtrfl(ntraciso,klon) REAL zrfl_ancien(klon) REAL zqev_diag(klon) REAL zrfln(klon) REAL zxtrfl_ancien(ntraciso,klon) INTEGER izone ! outputs REAL zxt_cas(niso,ncas) REAL zxtrfl_cas(niso,ncas) REAL zqev_diag_cas(ncas) REAL zrfln_cas(ncas) REAL zrfl_cas(ncas) REAL ptrac(ncas) ! locals INTEGER il,ixt,ieau,iiso ieau=index_trac(izone,iso_eau) DO il=1,ncas DO iiso=1,niso ixt=index_trac(izone,iiso) ! la compo de la vap à l'extérieure reste la vapeur totale zxt_cas(iiso,il)=zxt(iiso,cas(il)) ! le flux de pluie est celui le flux de pluie lié à la zone zxtrfl_cas(iiso,il)=zxtrfl_ancien(ixt,cas(il)) enddo zrfl_cas(il)=zxtrfl_ancien(ieau,cas(il)) IF (zrfl_ancien(cas(il)).gt.0.0) THEN ! proportion de izone dans l'évap = celle dans la goutte ptrac(il)=zxtrfl_ancien(ieau,cas(il))/zrfl_ancien(cas(il)) zrfln_cas(il)=zrfln(cas(il))*ptrac(il) zqev_diag_cas(il)=zqev_diag(cas(il))*ptrac(il) !#ifdef ISOVERIF ! if (il.EQ.9) THEN ! WRITE(*,*) 'compress tmp: il, ptrac=',il,ptrac(il) ! WRITE(*,*) 'ieau,zxtrfl_ancien(ieau,cas(il))=', ! : ieau,zxtrfl_ancien(ieau,cas(il)) ! WRITE(*,*) 'zrfl_ancien(cas(il))=',zrfl_ancien(cas(il)) ! WRITE(*,*) 'zrfl_cas(il)=',zrfl_cas(il) ! endif !#endif else !if (zrfl_ancien(cas(il)).gt.0.0) THEN #ifdef ISOVERIF ! WRITE(*,*) 'il,cas(il),zrfln,zrfl_ancien,zqev_diag=', ! : il,cas(il),zrfln(cas(il)),zrfl_ancien(cas(il)), ! : zqev_diag(cas(il)) CALL iso_verif_egalite(zqev_diag(cas(il)),0.0, & 'compress_stewart 1591a') CALL iso_verif_egalite(zrfln(cas(il)),0.0, & 'compress_stewart 1591b') #endif zrfln_cas(il)=0.0 zqev_diag_cas(il)=0.0 endif !if (zrfl_ancien(cas(il)).gt.0.0) THEN ! les lignes suvantes ne sont pas à recalculer ! zt_cas(il)=zt(cas(il)) ! delP(il)=paprs(cas(il),k)-paprs(cas(il),k+1) enddo !do il=1,ncas END SUBROUTINE compress_ilp_evap_liq_zone SUBROUTINE compress_ilp_evap_glace_zone( & ncas,cas, & zxt_cas,zxt, & zxtrfl_cas,zxtrfl_ancien, & zrfln_cas,zrfln, & zrfl_cas, zrfl_ancien, & zqev_diag_cas,zqev_diag, & klon,izone) USE isotopes_mod, ONLY: ridicule,iso_eau #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas INTEGER cas(ncas) INTEGER klon REAL zxt(ntraciso,klon) REAL zxtrfl_ancien(ntraciso,klon) REAL zqev_diag(klon) REAL zrfln(klon) INTEGER izone REAL zrfl_ancien(klon) ! outputs REAL zxt_cas(niso,ncas) REAL zxtrfl_cas(niso,ncas) REAL zqev_diag_cas(ncas) REAL zrfln_cas(ncas) REAL zrfl_cas(ncas) ! locals INTEGER il,ixt,ieau,iiso ieau=index_trac(izone,iso_eau) DO il=1,ncas DO iiso=1,niso ixt=index_trac(izone,iiso) zxt_cas(iiso,il)=zxt(iiso,cas(il)) zxtrfl_cas(iiso,il)=zxtrfl_ancien(ixt,cas(il)) enddo zrfl_cas(il)=zxtrfl_ancien(ieau,cas(il)) IF (zrfl_ancien(cas(il)).gt.0.0) THEN zrfln_cas(il)=zrfln(cas(il)) & *(zxtrfl_ancien(ieau,cas(il))/zrfl_ancien(cas(il))) ! car la proportion de traceurs dans zqev_diag et la même ! que dans zrfl_ancien. Comme zrfln=zrfl-zqev_diag*fac_ftmr ! alors cette proportion de traceurs est aussi la même dans ! zrfln zqev_diag_cas(il)=zqev_diag(cas(il)) & *zxtrfl_ancien(ieau,cas(il))/zrfl_ancien(cas(il)) else !if (zrfl_ancien(cas(il)).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite(zqev_diag(cas(il)),0.0, & 'compress_stewart 1791a') CALL iso_verif_egalite(zrfln(cas(il)),0.0, & 'compress_stewart 1791b') #endif zrfln_cas(il)=0.0 zqev_diag_cas(il)=0.0 endif !if (zrfl_ancien(cas(il)).gt.0.0) THEN enddo END SUBROUTINE compress_ilp_evap_glace_zone SUBROUTINE ajoute_revap(ncas,cas, & klon,izone,zxt,xtrevap_tag) #ifdef ISOVERIF USE isotopes_verif_mod #endif USE isotrac_mod, ONLY: izone_revap IMPLICIT NONE ! ajoute xtrevap_tag (evaps des différents traceurs d'isotopes) ! dans la vapeur qui est taggée par la révap des gouttes. ! input INTEGER ncas INTEGER cas(ncas) INTEGER klon INTEGER izone REAL xtrevap_tag(ntraciso,ncas) ! inout REAL zxt(ntraciso,klon) ! local INTEGER i,ixt,iiso,ixt_revap !#ifdef ISOVERIF ! integer iso_verif_positif_choix_nostop !#endif #ifdef ISOVERIF DO i=1,ncas DO ixt=1,ntraciso CALL iso_verif_positif_choix(zxt(ixt,cas(i)),0.0, & 'ajoute_revap 29') enddo enddo !do i=1,ncas #endif DO i=1,ncas DO iiso=1,niso ixt_revap=index_trac(izone_revap,iiso) DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) zxt(ixt_revap,cas(i))=zxt(ixt_revap,cas(i)) & +xtrevap_tag(ixt,i) #ifdef ISOVERIF IF (iso_verif_positif_choix_nostop(zxt(ixt_revap,cas(i)), & 0.0,'ajoute_revap 46').EQ.1) THEN WRITE(*,*) 'i,iiso,izone,ixt=',i,iiso,izone,ixt WRITE(*,*) 'xtrevap_tag(ixt,i)=',xtrevap_tag(ixt,i) ! stop endif #endif zxt(ixt_revap,cas(i))=max(0.0,zxt(ixt_revap,cas(i))) enddo !do izone=1,ntraceurs_zone enddo !do iiso=1,niso enddo !do i=1,ncas_evap_liq #ifdef ISOVERIF DO i=1,ncas DO ixt=1,ntraciso CALL iso_verif_positif_choix(zxt(ixt,cas(i)),0.0, & 'ajoute_revap 40') enddo enddo !do i=1,ncas #endif END SUBROUTINE ajoute_revap function is_in_bassin(lat,lon,bassin) USE isotrac_mod, ONLY: use_bassin_atlantic,use_bassin_medit, & & use_bassin_indian,use_bassin_austral,use_bassin_pacific, & & use_bassin_MerArabie,use_bassin_BengalGolf,use_bassin_SouthIndian, & & use_bassin_tropics,use_bassin_midlats,use_bassin_HighLats, & & bassin_atlantic,bassin_medit, & & bassin_indian,bassin_austral,bassin_pacific, & & bassin_MerArabie,bassin_BengalGolf,bassin_SouthIndian, & & bassin_tropics,bassin_midlats,bassin_HighLats IMPLICIT NONE ! répond true si lat,lon se trouve dans le bassin numéroté bassin ! input INTEGER bassin REAL lat,lon ! outut LOGICAL is_in_bassin ! locals !LOGICAL is_in_rectangle !LOGICAL is_in_triangle is_in_bassin=.FALSE. #ifdef ISOVERIF WRITE(*,*) 'is_in_basin 84: entree,bassin=',bassin #endif IF (use_bassin_atlantic .AND. bassin==bassin_atlantic) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin Atlantique?' #endif IF (is_in_rectangle(lon,lat,-67.0,28.0,20.0,-45.0)) THEN ! boite sud is_in_bassin=.TRUE. RETURN endif IF (is_in_rectangle(lon,lat,-100.0,40.0,-5.3,28.0)) THEN ! ouest gibraltar is_in_bassin=.TRUE. RETURN endif IF (is_in_rectangle(lon,lat,-100.0,48.0,0.0,40.0)) THEN ! Ouest France is_in_bassin=.TRUE. RETURN endif IF (is_in_rectangle(lon,lat,-90.0,80.0,10.0,46.0)) THEN ! Atlantic Nord is_in_bassin=.TRUE. RETURN endif IF (is_in_triangle(lon,lat, & -62.0,0.0,-62.0,30.0,-112.0,30.0)) THEN ! golfe du Mexique is_in_bassin=.TRUE. RETURN endif ELSE IF (use_bassin_medit .AND. bassin==bassin_medit) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin Medit?' #endif IF (is_in_rectangle(lon,lat,0.0,48.0,45.0,29.0)) THEN is_in_bassin=.TRUE. RETURN endif IF (is_in_rectangle(lon,lat,-5.3,42.0,45.0,29.0)) THEN is_in_bassin=.TRUE. RETURN endif ELSE IF (use_bassin_indian .AND. bassin==bassin_indian) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin indian?' #endif IF (is_in_rectangle(lon,lat,20.0,30.0,110.0,-45.0)) THEN is_in_bassin=.TRUE. RETURN endif IF (is_in_triangle(lon,lat, & 90.0,30.0,90.0,-45.0,150.0,-45.0)) THEN ! Ouest Australie is_in_bassin=.TRUE. RETURN endif ELSE IF (use_bassin_SouthIndian .AND. bassin==bassin_SouthIndian) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin indian hemisphere Sud?' #endif IF (is_in_rectangle(lon,lat,20.0,0.0,120.0,-45.0)) THEN is_in_bassin=.TRUE. RETURN endif ELSE IF (use_bassin_MerArabie .AND. bassin==bassin_MerArabie) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin Mer d''Arabie?' #endif IF (is_in_rectangle(lon,lat,20.0,30.0,76.0,0.0)) THEN is_in_bassin=.TRUE. RETURN endif ELSE IF (use_bassin_BengalGolf .AND. bassin==bassin_BengalGolf) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin Golfe du Bengale?' #endif IF (is_in_rectangle(lon,lat,76.0,30.0,110.0,0.0)) THEN is_in_bassin=.TRUE. RETURN endif ELSE IF (use_bassin_pacific .AND. bassin==bassin_pacific) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin Pacific?' #endif IF (is_in_rectangle(lon,lat,-180.0,80.0,-100.0,-45.0)) THEN ! pacifique Est is_in_bassin=.TRUE. RETURN endif IF (is_in_rectangle(lon,lat,110.0,80.0,180.0,28.0)) THEN ! Pacifique Nord Ouest is_in_bassin=.TRUE. RETURN endif IF (is_in_rectangle(lon,lat,120.0,80.0,180.0,-45.0)) THEN ! Pacifique central Sud is_in_bassin=.TRUE. RETURN endif IF (is_in_triangle(lon,lat, & 90.0,28.0,150.0,-45.0,150.0,28.0)) THEN ! Pacifque Sud Ouest is_in_bassin=.TRUE. RETURN endif IF (is_in_triangle(lon,lat, & -62.0,0.0,-112.0,30.0,-112.0,0.0)) THEN ! Ouest Amérique centrale is_in_bassin=.TRUE. RETURN endif IF (is_in_rectangle(lon,lat,-180.0,0.0,-67.0,-45.0)) THEN ! Ouest Chili is_in_bassin=.TRUE. RETURN endif ELSE IF (use_bassin_austral .AND. bassin==bassin_austral) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin austral?' #endif IF (lat.lt.-45.0+0.2) THEN is_in_bassin=.TRUE. return endif ELSE IF (use_bassin_HighLats .AND. bassin==bassin_HighLats) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin hautes lats?' #endif IF (abs(lat).gt.35.0) THEN is_in_bassin=.TRUE. return endif ELSE IF (use_bassin_tropics .AND. bassin==bassin_tropics) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin tropics?' #endif IF (abs(lat).lt.15.0) THEN is_in_bassin=.TRUE. return endif ELSE IF (use_bassin_midlats .AND. bassin==bassin_midlats) THEN #ifdef ISOVERIF WRITE(*,*) 'bassin mid lats?' #endif IF ((abs(lat).ge.15.0).AND. & (abs(lat).le.35.0)) THEN is_in_bassin=.TRUE. return endif else WRITE(*,*) 'iso_traceurs_routines 59: bassin inconnu' WRITE(*,*) 'bassin_atlantic=' ,bassin_atlantic WRITE(*,*) 'bassin_medit=' ,bassin_medit WRITE(*,*) 'bassin_indian=' ,bassin_indian WRITE(*,*) 'bassin_austral=' ,bassin_austral WRITE(*,*) 'bassin_MerArabie=' ,bassin_MerArabie WRITE(*,*) 'bassin_BengalGolf=' ,bassin_BengalGolf WRITE(*,*) 'bassin_SouthIndian=' ,bassin_SouthIndian WRITE(*,*) 'use_bassin_atlantic=' ,use_bassin_atlantic WRITE(*,*) 'use_bassin_medit=' ,use_bassin_medit WRITE(*,*) 'use_bassin_indian=' ,use_bassin_indian WRITE(*,*) 'use_bassin_austral=' ,use_bassin_austral WRITE(*,*) 'use_bassin_MerArabie=' ,use_bassin_MerArabie WRITE(*,*) 'use_bassin_BengalGolf=' ,use_bassin_BengalGolf WRITE(*,*) 'use_bassin_SouthIndian=' ,use_bassin_SouthIndian stop endif END FUNCTION is_in_bassin SUBROUTINE find_bassin(lat,lon,bassin) USE isotrac_mod, ONLY: izone_poubelle,ntraceurs_zone=>ntiso,option_traceurs, & & bassin_map #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs REAL lat,lon ! output INTEGER bassin !locals LOGICAL continu !LOGICAL is_in_bassin continu=.TRUE. bassin=1 #ifdef ISOVERIF WRITE(*,*) '' WRITE(*,*) 'find bassin lat,lon=',lat,lon #endif DO while (continu) !#ifdef ISOVERIF !! WRITE(*,*) 'find_bassin 169: lat,lon,bassin=',lat,lon,bassin !#endif IF (is_in_bassin(lat,lon,bassin)) THEN continu=.FALSE. #ifdef ISOVERIF WRITE(*,*) 'find_bassin 173: trouve: bassin=',bassin #endif else !#ifdef ISOVERIF ! WRITE(*,*) 'find_bassin 175: pas trouve: bassin=',bassin !#endif bassin=bassin+1 endif IF (bassin.EQ.izone_poubelle) THEN continu=.FALSE. bassin=izone_poubelle !#ifdef ISOVERIF ! WRITE(*,*) 'find_bassin 179: poubelle: bassin=',bassin !#endif endif enddo ! normalement, le bassin est soit un bassin oce, soit un résidu ! donc bassin<=ntraceurs_zone-1 #ifdef ISOVERIF CALL iso_verif_positif(float(ntraceurs_zone-1-bassin), & 'find_bassin 195') #endif END SUBROUTINE find_bassin SUBROUTINE initialise_bassins_boites(presnivs) USE dimphy, ONLY: klev USE lmdz_geometry, ONLY: longitude_deg, latitude_deg USE isotrac_mod, ONLY: bassin_map,option_traceurs,boite_map #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE REAL presnivs(klev) IF (option_traceurs.EQ.3) THEN ! initialisation de bassin_map CALL bassin_map_init(latitude_deg,longitude_deg,bassin_map) ELSE IF (option_traceurs.EQ.20) THEN ! initialisation de bassin_map selon < ou > 35° lat WRITE(*,*) 'physiq 1681: init de la map pour tag 20' CALL bassin_map_init_opt20(latitude_deg,bassin_map) ELSE IF (option_traceurs.EQ.5) THEN CALL boite_AMMA_init(latitude_deg,longitude_deg,presnivs,boite_map) ELSE IF (option_traceurs.EQ.21) THEN CALL boite_UT_extra_init(latitude_deg,longitude_deg,presnivs,boite_map) endif END SUBROUTINE initialise_bassins_boites SUBROUTINE bassin_map_init(lat,lon,bassin_map) USE dimphy, ONLY: klon #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs REAL lat(klon),lon(klon) ! output INTEGER bassin_map(klon) ! locals INTEGER i DO i=1,klon CALL find_bassin(lat(i),lon(i),bassin_map(i)) #ifdef ISOVERIF WRITE(*,*) 'init 233: i,lat,lon,bassin=',i,lat(i),lon(i), & bassin_map(i) #endif enddo END SUBROUTINE bassin_map_init function is_in_rectangle(x,y,x1,y1,x2,y2) IMPLICIT NONE ! inputs REAL x,y ! point en haut à gauche REAL x1,y1 ! point en bas à droite REAL x2,y2 ! output LOGICAL is_in_rectangle !#ifdef ISOVERIF ! WRITE(*,*) 'is_in_rectange 237: x,y=',x,y ! WRITE(*,*) 'x1,y1,x2,y2=',x1,y1,x2,y2 !#endif IF ((x-x2.lt.0.1).AND.(x-x1.gt.-0.1).AND. & (y-y1.lt.0.1).AND.(y-y2.gt.-0.1)) THEN is_in_rectangle=.TRUE. else is_in_rectangle=.FALSE. endif !#ifdef ISOVERIF ! WRITE(*,*) 'is_in_rectangle=',is_in_rectangle !#endif END FUNCTION is_in_rectangle function is_in_triangle(x,y,x1,y1,x2,y2,x3,y3) IMPLICIT NONE ! inputs REAL x,y ! points dans le sens trigo ! à gauche REAL x1,y1 ! en bas REAL x2,y2 ! à droite REAL x3,y3 ! output LOGICAL is_in_triangle ! locals REAL det1 REAL det2 REAL det3 !#ifdef ISOVERIF ! WRITE(*,*) 'is_in_triange 271: x,y=',x,y ! WRITE(*,*) 'x1,y1,x2,y2,x3,y3=',x1,y1,x2,y2,x3,y3 !#endif det1=(x1-x)*(y2-y)-(y1-y)*(x2-x) det2=(x2-x)*(y3-y)-(y2-y)*(x3-x) det3=(x3-x)*(y1-y)-(y3-y)*(x1-x) is_in_triangle=.FALSE. IF ((det1*det2.gt.0.0).AND.(det2*det3.gt.0.0)) THEN is_in_triangle=.TRUE. else is_in_triangle=.FALSE. endif !#ifdef ISOVERIF ! WRITE(*,*) 'det1,det2,det3,is_in_triangle', ! : det1,det2,det3,is_in_triangle !#endif END FUNCTION is_in_triangle SUBROUTINE isotrac_recolorise_tmin(xt,t) USE dimphy, ONLY: klon, klev USE isotrac_mod, ONLY: zone_temp,nzone_temp #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inout REAL xt(ntraciso,klon,klev) ! input REAL t(klon,klev) ! locals INTEGER izone_temp INTEGER ixt,ixt_recoit INTEGER k,i,izone,iiso !integer find_index DO k=1,klev DO i=1,klon !#ifdef ISOVERIF ! if (i.EQ.1) THEN ! WRITE(*,*) 'recolorise 396: i,k,t=',i,k,t(i,k) ! WRITE(*,*) 'zone_temp=',zone_temp ! endif !#endif ! trouver la zone de cette température izone_temp=find_index(t(i,k),nzone_temp,zone_temp) !#ifdef ISOVERIF ! if (i.EQ.1) THEN ! WRITE(*,*) 'recolorise 414: izone_temp=',izone_temp ! endif !#endif DO izone=1,nzone_temp-1 ! tous les tags de zone < nzone_temp se trouvant à des ! températures plus basses sont convertis !#ifdef ISOVERIF ! if (i.EQ.1) THEN ! WRITE(*,*) 'recolorise 405: izone,xt_eau=', ! : izone,xt(index_trac(izone,iso_eau),i,k) ! endif !#endif IF (izone.lt.izone_temp) THEN DO iiso=1,niso ixt=index_trac(izone,iiso) ! emmetteur ixt_recoit=index_trac(izone_temp,iiso) ! recepteur xt(ixt_recoit,i,k)=xt(ixt_recoit,i,k)+xt(ixt,i,k) xt(ixt,i,k)=0.0 enddo !do iiso=1,niso endif !if (izone.lt.izone_temp) THEN !#ifdef ISOVERIF ! if (i.EQ.1) THEN ! WRITE(*,*) 'recolorise 419: xt_eau,xt_recoit=', ! : xt(index_trac(izone,iso_eau),i,k), ! : xt(index_trac(izone_temp,iso_eau),i,k) ! endif !#endif enddo !do izone=1,zone_pot(k)-1 ! conversion de l'évap en surf et de la revap des gouttes DO izone=nzone_temp+1,ntraceurs_zone DO iiso=1,niso ixt=index_trac(izone,iiso) ! emmetteur ixt_recoit=index_trac(izone_temp,iiso) ! recepteur xt(ixt_recoit,i,k)=xt(ixt_recoit,i,k)+xt(ixt,i,k) xt(ixt,i,k)=0.0 enddo !do iiso=1,niso enddo !do izone=nzone_temp+1,ntraceurs_zone enddo !do i=1,klon enddo !do k=1,klev #ifdef ISOVERIF DO k=1,klev DO i=1,klon CALL iso_verif_traceur(xt(1,i,k),'recolorise 403') enddo !do i=1,klon enddo !do k=1,klev #endif END SUBROUTINE isotrac_recolorise_tmin SUBROUTINE isotrac_recolorise_tmin_sfrev(xt,t) USE dimphy, ONLY: klon,klev USE isotrac_mod, ONLY: nzone_temp,zone_temp #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! recolorise selon la température minimum, mais les tags de ! revap sont laissés en revap ! inout REAL xt(ntraciso,klon,klev) ! input REAL t(klon,klev) ! locals INTEGER izone_temp INTEGER ixt,ixt_recoit INTEGER k,i,izone,iiso !integer find_index DO k=1,klev DO i=1,klon ! trouver la zone de cette température izone_temp=find_index(t(i,k),nzone_temp,zone_temp) DO izone=1,nzone_temp-1 ! tous les tags de zone < nzone_temp se trouvant à des ! températures plus basses sont convertis ! sauf la revap ! le tag de la revap est nzone_temp+1=ntraceurs_zone IF (izone.lt.izone_temp) THEN DO iiso=1,niso ixt=index_trac(izone,iiso) ! emmetteur ixt_recoit=index_trac(izone_temp,iiso) ! recepteur xt(ixt_recoit,i,k)=xt(ixt_recoit,i,k)+xt(ixt,i,k) xt(ixt,i,k)=0.0 enddo !do iiso=1,niso endif !if (izone.lt.izone_temp) THEN enddo !do izone=1,zone_pot(k)-1 enddo !do i=1,klon enddo !do k=1,klev #ifdef ISOVERIF DO k=1,klev DO i=1,klon CALL iso_verif_traceur(xt(1,i,k),'recolorise 594') enddo !do i=1,klon enddo !do k=1,klev #endif END SUBROUTINE isotrac_recolorise_tmin_sfrev SUBROUTINE isotrac_recolorise_saturation(xt,rh,lat,pres) USE dimphy, ONLY: klon,klev #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! recolorise selon la température minimum, mais les tags de ! revap sont laissés en revap ! inout REAL xt(ntraciso,klon,klev) ! input REAL rh(klon,klev) REAL lat(klon) REAL pres(klev) ! locals INTEGER izone_recoit INTEGER ixt,ixt_recoit INTEGER k,i,izone,iiso LOGICAL continu REAL rh_seuil parameter (rh_seuil=0.90) !integer index_zone_latpres #ifdef ISOVERIF DO k=1,klev DO i=1,klon CALL iso_verif_traceur(xt(1,i,k),'recolorise 612') enddo !do i=1,klon enddo !do k=1,klev #endif ! on ne sature pas les 2 premières couches: on les laisse se ! recharger en evap de surface DO k=3,klev DO i=1,klon IF (rh(i,k).gt.rh_seuil) THEN izone_recoit=index_zone_latpres(lat(i),pres(k)) DO izone=1,ntraceurs_zone IF (izone.NE.izone_recoit) THEN DO iiso=1,niso ixt=index_trac(izone,iiso) ! emmetteur ixt_recoit=index_trac(izone_recoit,iiso) ! recepteur xt(ixt_recoit,i,k)=xt(ixt_recoit,i,k)+xt(ixt,i,k) xt(ixt,i,k)=0.0 enddo !do iiso=1,niso endif enddo !do izone=1,ntraceurs_zone endif !if (rh(i,k).gt.rh_seuil) THEN enddo !do i=1,klon enddo !do k=1,klev #ifdef ISOVERIF DO k=1,klev DO i=1,klon CALL iso_verif_traceur(xt(1,i,k),'recolorise 637') enddo !do i=1,klon enddo !do k=1,klev #endif END SUBROUTINE isotrac_recolorise_saturation SUBROUTINE isotrac_recolorise_boite(xt,boite_map) USE dimphy, ONLY: klon,klev #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! SUBROUTINE écrite à la base pour tagguer 3 boites AMMA. ! Mais ça peut être générique, selon comment est initialisée boite_map ! inout REAL xt(ntraciso,klon,klev) ! input INTEGER boite_map(klon,klev) ! locals INTEGER i,k INTEGER izone_recoit,izone,iiso INTEGER ixt,ixt_recoit DO k=1,klev DO i=1,klon izone_recoit=boite_map(i,k) IF (izone_recoit.gt.0) THEN ! on est dans une boite connue ! toutes les molécules sont converties en cete couleur DO izone=1,ntraceurs_zone IF (izone.NE.izone_recoit) THEN ! on met les traceurs izone dans izone_recoit DO iiso=1,niso ixt=index_trac(izone,iiso) ixt_recoit=index_trac(izone_recoit,iiso) xt(ixt_recoit,i,k)=xt(ixt_recoit,i,k) & +xt(ixt,i,k) xt(ixt,i,k)=0.0 enddo endif !if (izone.NE.izone_recoit) THEN enddo !do izone=2,ntraceurs_zone endif !if (izone_recoit.gt.0) THEN enddo !do i=1,klon enddo !do k=1,klev #ifdef ISOVERIF DO k=1,klev DO i=1,klon CALL iso_verif_traceur(xt(1,i,k),'recolorise 514') enddo !do i=1,klon enddo !do k=1,klev #endif END SUBROUTINE isotrac_recolorise_boite SUBROUTINE isotrac_recolorise_extra(xt,rlat) USE dimphy, ONLY: klon,klev usE isotrac_mod, ONLY: lim_tag20,izone_trop,izone_extra #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! SUBROUTINE écrite pour l'option de taggage 20 ! permet de retagguer la vapeur tropicale en vapeur ! extratropicale dès qu'elle atteint 35° de latitude ! inout REAL xt(ntraciso,klon,klev) ! input REAL rlat(klon) ! locals INTEGER i,k INTEGER iiso,ixt,ixt_recoit ! WRITE(*,*) 'iso_traceurs_routines 723: lim_tag20=',lim_tag20 DO k=1,klev DO i=1,klon IF (abs(rlat(i)).gt.lim_tag20) THEN ! on met les traceurs izone_trop dans izone_extra DO iiso=1,niso ixt=index_trac(izone_trop,iiso) ixt_recoit=index_trac(izone_extra,iiso) xt(ixt_recoit,i,k)=xt(ixt_recoit,i,k) & +xt(ixt,i,k) xt(ixt,i,k)=0.0 enddo endif ! if (abs(rlat(i)).lt.35.0) THEN enddo !do i=1,klon enddo !do k=1,klev #ifdef ISOVERIF DO k=1,klev DO i=1,klon CALL iso_verif_traceur(xt(1,i,k),'recolorise 741') enddo !do i=1,klon enddo !do k=1,klev #endif END SUBROUTINE isotrac_recolorise_extra SUBROUTINE isotrac_recolorise_conv(xt,rlat,presnivs,rain_con) USE dimphy, ONLY: klon,klev USE isotrac_mod, ONLY: lim_precip_tag22, & & izone_conv_BT,izone_conv_UT #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! SUBROUTINE écrite pour l'option de taggage 20 ! permet de retagguer la vapeur tropicale en vapeur ! extratropicale dès qu'elle atteint 35° de latitude ! inout REAL xt(ntraciso,klon,klev) ! input REAL rlat(klon) REAL presnivs(klev) REAL rain_con(klon) ! locals INTEGER i,k INTEGER iiso,ixt,ixt_recoit,izone ! WRITE(*,*) 'iso_traceurs_routines 723: lim_tag20=',lim_tag20 ! WRITE(*,*) 'presnivs=',presnivs ! stop DO k=1,klev DO i=1,klon #ifdef ISOVERIF IF ((abs(rlat(i)).lt.30.0).AND.(k.EQ.1)) THEN endif #endif IF ((abs(rlat(i)).lt.30.0).AND. & (rain_con(i)*86400.gt.lim_precip_tag22)) THEN ! on met les traceurs izone_trop dans izone_conv fn z DO iiso=1,niso IF (presnivs(k).gt.650.0*100.0) THEN ixt_recoit=index_trac(izone_conv_BT,iiso) else ixt_recoit=index_trac(izone_conv_UT,iiso) endif DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) IF (ixt.NE.ixt_recoit) THEN xt(ixt_recoit,i,k)=xt(ixt_recoit,i,k) & +xt(ixt,i,k) xt(ixt,i,k)=0.0 endif !if (ixt.NE.ixt_recoit) THEN enddo !do izone=1,ntraceurs_zone enddo !do iiso=1,niso ! WRITE(*,*) 'k,presnivs,ixt,ixt_recoit=',k,presnivs(k), ! : ixt,ixt_recoit ! WRITE(*,*) 'xt(:,i,k)=',xt(:,i,k) endif ! if (abs(rlat(i)).lt.35.0) THEN enddo !do i=1,klon enddo !do k=1,klev #ifdef ISOVERIF DO k=1,klev DO i=1,klon CALL iso_verif_traceur(xt(1,i,k),'recolorise 741') enddo !do i=1,klon enddo !do k=1,klev #endif END SUBROUTINE isotrac_recolorise_conv SUBROUTINE boite_AMMA_init(lat,lon,presnivs,boite_map) USE dimphy, ONLY: klon,klev #ifdef ISOVERIF USE isotopes_verif_mod #endif USE isotrac_mod, ONLY: izone_aej,izone_mousson,izone_harmattan IMPLICIT NONE REAL lat(klon),lon(klon) REAL presnivs(klev) ! output INTEGER boite_map(klon,klev) ! locals INTEGER i,k ! WRITE(*,*) 'izone_aej,izone_mousson,izone_harmattan=', ! : izone_aej,izone_mousson,izone_harmattan DO k=1,klev DO i=1,klon boite_map(i,k)=0.0 ! WRITE(*,*) 'i,k,lat,lon,pres=', ! : i,k,lat(i),lon(i),presnivs(k) IF ((presnivs(k).le.700.0*100.0).AND. & (presnivs(k).gt.400.0*100.0).AND. & (lat(i).gt.8.0).AND. & (lat(i).lt.20.0).AND. & (lon(i).gt.10.0).AND. & (lon(i).lt.30.0)) THEN boite_map(i,k)=izone_aej ! WRITE(*,*) ' -> zone AEJ' ELSE IF ((presnivs(k).ge.850.0*100.0).AND. & (lat(i).gt.-5.0).AND. & (lat(i).le.8.0).AND. & (lon(i).gt.-40.0).AND. & (lon(i).lt.15.0)) THEN boite_map(i,k)=izone_mousson ! WRITE(*,*) ' -> zone flux de mousson' ELSE IF ((presnivs(k).gt.700.0*100.0).AND. & (lat(i).ge.20.0).AND. & (lat(i).lt.30.0).AND. & (lon(i).gt.-10.0).AND. & (lon(i).lt.40.0)) THEN boite_map(i,k)=izone_harmattan ! WRITE(*,*) ' -> zone Harmattan' endif ! WRITE(*,*) ' ** boite_map=',boite_map(i,k) enddo enddo END SUBROUTINE boite_AMMA_init SUBROUTINE boite_UT_extra_init(lat,lon,presnivs,boite_map) USE dimphy, ONLY: klon,klev USE isotrac_mod, ONLY: izone_extra,izone_trop #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE REAL lat(klon),lon(klon) REAL presnivs(klev) ! output INTEGER boite_map(klon,klev) ! locals INTEGER i,k ! WRITE(*,*) 'izone_trop,izone_extra=', ! : izone_trop,izone_extra DO k=1,klev DO i=1,klon boite_map(i,k)=0.0 ! WRITE(*,*) 'i,k,lat,lon,pres=', ! : i,k,lat(i),lon(i),presnivs(k) IF ((presnivs(k).le.500.0*100.0) & .AND.(abs(lat(i)).lt.15.0)) THEN boite_map(i,k)=izone_trop ! WRITE(*,*) ' -> zone trop' ELSE IF (abs(lat(i)).gt.35.0) THEN boite_map(i,k)=izone_extra ! WRITE(*,*) ' -> zone extratropiques' endif ! WRITE(*,*) ' ** boite_map=',boite_map(i,k) enddo enddo END SUBROUTINE boite_UT_extra_init function index_zone_lat(lat) USE isotrac_mod, ONLY: lattag_min,dlattag,nzone_lat IMPLICIT NONE ! inputs REAL lat,pres ! output INTEGER index_zone_lat IF (lat.lt.lattag_min) THEN index_zone_lat=1 else index_zone_lat=int((lat-lattag_min)/dlattag)+2 index_zone_lat=min(index_zone_lat,nzone_lat) endif END FUNCTION index_zone_lat function index_zone_pres(pres) USE isotrac_mod, ONLY: nzone_pres,zone_pres IMPLICIT NONE ! inputs REAL lat,pres ! output INTEGER index_zone_pres !integer find_index index_zone_pres=find_index(pres,nzone_pres,zone_pres) WRITE(*,*) 'iso_traceurs_routines 802: pres,index_zone_pres=', & pres,index_zone_pres WRITE(*,*) 'zone_pres=',zone_pres(1:nzone_pres-1) END FUNCTION index_zone_pres function find_index(pres,nzone_pres,zone_pres) IMPLICIT NONE ! inputs REAL pres INTEGER nzone_pres REAL zone_pres(nzone_pres) ! output INTEGER find_index LOGICAL continu IF (nzone_pres.gt.1) THEN IF (pres.ge.zone_pres(1)) THEN find_index=1 ELSE IF (pres.lt.zone_pres(nzone_pres-1)) THEN find_index=nzone_pres else !if (t(i,k).ge.zone_temp1) THEN continu=.TRUE. find_index=2 DO while (continu) IF (pres.ge.zone_pres(find_index)) THEN continu=.FALSE. ! c'est izone_temp, zone trouvée else find_index=find_index+1 endif enddo !do while (continu) endif !if (t(i,k).ge.zone_temp1) THEN else !if (nzone_pres.gt.1) THEN find_index=1 endif !if (nzone_pres.gt.1) THEN END FUNCTION find_index function index_zone_latpres(lat,pres) USE isotrac_mod, ONLY: nzone_lat IMPLICIT NONE ! inputs REAL lat,pres ! output INTEGER index_zone_latpres ! locals INTEGER index_lat INTEGER index_pres !integer index_zone_lat !integer index_zone_pres index_lat=index_zone_lat(lat) index_pres=index_zone_pres(pres) index_zone_latpres=index_lat+(index_pres-1)*nzone_lat END FUNCTION index_zone_latpres SUBROUTINE iso_recolorise_condensation(qt,cond, & xt,zxtcond,tcond,ep,xtres, & seuil_in) USE dimphy, ONLY: klon,klev USE isotopes_mod, ONLY: bidouille_anti_divergence,iso_eau USE isotrac_mod, ONLY: option_seuil_tag_tmin,izone_cond, & & nzone_temp,zone_temp #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! on recolorise la vapeur résiduelle selon la température de condensation ! on supose qu'une vapeur xt,q condense en cond,zxtcond, à une ! température tcond. A ce stade, la vapeur initiale n'est pas ! retranchée de son condensat. On calcule les tags dans la vepru ! résiduelle xtres qu'on aurait si on retranchait un fraction ep du ! condensat ! inputs REAL qt REAL cond REAL tcond REAL ep REAL xt(ntraciso) REAL zxtcond(ntraciso) REAL seuil_in ! outputs REAL xtres(ntraciso) ! locals INTEGER izone_temp,izone INTEGER ixt,ixt_recoit INTEGER iiso !integer find_index REAL fcond, qmicro ! real f IF ((cond.gt.0.0).AND.(qt.gt.0.0)) THEN izone_temp=find_index(tcond,nzone_temp,zone_temp) ! WRITE(*,*) 'pgm 901 tmp: izone_temp=',izone_temp #ifdef ISOVERIF DO ixt=1,ntraciso CALL iso_verif_positif(xt(ixt)-zxtcond(ixt), & 'iso_trac 898') enddo !do ixt=1,ntraciso CALL iso_verif_traceur_justmass(xt, & 'iso_trac_routines 906') CALL iso_verif_traceur_justmass(zxtcond, & 'iso_trac_routines 908') #endif ! bidouille IF (bidouille_anti_divergence) THEN CALL iso_verif_traceur_jbidouille(xt) CALL iso_verif_traceur_jbidouille(zxtcond) endif DO ixt=1,niso xtres(ixt)=xt(ixt)-ep*zxtcond(ixt) enddo DO ixt=1+niso,ntraciso xtres(ixt)=0.0 enddo ! WRITE(*,*) 'iso_trac_routines tmp 916: xtres=',xtres #ifdef ISOVERIF DO ixt=1,ntraciso CALL iso_verif_positif(xtres(ixt), & 'iso_trac_routines 921') enddo #endif ! cas de izone sfc et izone precip et izone cond et izone< izone_temp ! WRITE(*,*) 'iso_trac 940: cond/qt,seuil_in,izone_temp=', ! : cond/qt,seuil_in,izone_temp IF (option_seuil_tag_tmin.EQ.2) THEN qmicro=0.0 DO izone=nzone_temp+1,ntraceurs_zone ixt= index_trac(izone,iso_eau) qmicro=qmicro+xt(ixt) enddo !do izone=nzone_temp+1,ntraceurs_zone IF (qt-qmicro.gt.0.0) THEN fcond=(cond-qmicro)/(qt-qmicro) else fcond=0.0 endif else fcond=cond/qt endif IF (fcond.gt.seuil_in) THEN ! on les transfert à izone_temp DO izone=1,ntraceurs_zone IF ((izone.gt.nzone_temp).OR.(izone.lt.izone_temp)) THEN ! ieau=index_trac(izone,iso_eau) DO iiso=1,niso ixt= index_trac(izone,iiso) ixt_recoit=index_trac(izone_temp,iiso) ! recepteur xtres(ixt_recoit)=xtres(ixt_recoit) & +(xt(ixt)-zxtcond(ixt)) xtres(ixt)=0.0 ! WRITE(*,*) 'iso_trac 920: izone,ixt,', ! : 'ixt_recoit=', ! : izone,ixt,ixt_recoit ! WRITE(*,*) 'isotrac 924: xt=',xt ! WRITE(*,*) 'isotrac 925: zxtcond=',zxtcond enddo !do iiso=1,niso ! WRITE(*,*) 'iso_trac tmp 944: izone,xtres=',izone,xtres endif !if (izone.NE.izone_cond) THEN enddo !do izone=nzones_temp+1,ntraceurs_zone else !if (cond/qt.gt.seuil_in) THEN ! on les laisse sur place DO izone=1,ntraceurs_zone IF ((izone.gt.nzone_temp).OR.(izone.lt.izone_temp)) THEN DO iiso=1,niso ixt= index_trac(izone,iiso) xtres(ixt)=(xt(ixt)-zxtcond(ixt)) enddo !do iiso=1,niso endif !if (izone.NE.izone_cond) THEN enddo !do izone=nzones_temp+1,ntraceurs_zone endif !if (cond/qt.gt.seuil_in) THEN ! izone_temp est conservé, on lui enlève juste son ! condesat DO iiso=1,niso ixt_recoit=index_trac(izone_temp,iiso) ! recepteur xtres(ixt_recoit)=xtres(ixt_recoit) & +(xt(ixt_recoit)-zxtcond(ixt_recoit)) enddo !do iiso=1,niso #ifdef ISOVERIF DO ixt=1,ntraciso CALL iso_verif_positif(xtres(ixt), & 'iso_trac_routines 940') enddo #endif ! cas des zones > izone temp ! on conserve le condensat résiduel DO izone=izone_temp+1,nzone_temp DO iiso=1,niso ixt= index_trac(izone,iiso) xtres(ixt)=xt(ixt)-zxtcond(ixt) ! WRITE(*,*) 'iso_trac 931: izone,ixt,ixt_recoit=', ! : izone,ixt,ixt_recoit ! WRITE(*,*) 'isotrac 934: xt=',xt ! WRITE(*,*) 'isotrac 935: zxtice=',zxtice enddo !do iiso=1,niso ! WRITE(*,*) 'iso_trac tmp 965: izone,xtres=',izone,xtres enddo !do izone=izone_temp+1,nzones_temp ! on rajoute le condensat qui ne precipite pas IF (ep.lt.1.0) THEN DO iiso=1,niso ixt= index_trac(izone_cond,iiso) xtres(ixt)=xtres(ixt)+(1.0-ep)*zxtcond(iiso) ! WRITE(*,*) 'iso_trac 940: izone,ixt,ixt_recoit=', ! : izone,ixt,ixt_recoit ! WRITE(*,*) 'isotrac 1014: xt=',xt ! WRITE(*,*) 'isotrac 945: zxtice=',zxtice enddo !do iiso=1,niso endif !if (ep.lt.0.0) THEN else ! si cond=0 ou qt=0, tot reste pareil DO ixt=1,ntraciso xtres(ixt)=xt(ixt) enddo !do ixt=1,ntraciso endif ! if (qt.gt.0.0) THEN #ifdef ISOVERIF IF (iso_verif_traceur_jm_nostop(xtres, & 'iso_trac_routines 166').EQ.1) THEN WRITE(*,*) 'isotrac 1024: xt=',xt WRITE(*,*) 'zxtcond=',zxtcond WRITE(*,*) 'xtres=',xtres WRITE(*,*) 'ep=',ep stop endif #endif #ifdef ISOVERIF DO ixt=1,ntraciso CALL iso_verif_positif(xtres(ixt),'iso_trac_routines 953') enddo IF (nzone_temp.ge.5) THEN IF (iso_verif_tag17_q_deltaD_chns(xtres, & 'iso_trac_routines 1025').EQ.1) THEN WRITE(*,*) 'xt=',xt WRITE(*,*) 'zxtcond=',zxtcond WRITE(*,*) 'xtres=',xtres WRITE(*,*) 'ep=',ep WRITE(*,*) 'tcond=',tcond WRITE(*,*) 'izone_temp=',izone_temp stop endif endif ! WRITE(*,*) 'isotrac 1048: sortie de iso_recolorise_condensation' #endif END SUBROUTINE iso_recolorise_condensation SUBROUTINE bassin_map_init_opt20(lat,bassin_map) USE dimphy, ONLY: klon USE isotrac_mod, ONLY: izone_cont,izone_trop,lim_tag20 #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs REAL lat(klon) ! output INTEGER bassin_map(klon) ! locals INTEGER i WRITE(*,*) 'iso_traceurs_routines 1142: lim_tag20=',lim_tag20 DO i=1,klon IF (abs(lat(i)).gt.lim_tag20) THEN bassin_map(i)=izone_cont else bassin_map(i)=izone_trop endif enddo !do i=1,klon END SUBROUTINE bassin_map_init_opt20 SUBROUTINE isotrac_recolorise_general(xt_seri,t_seri,zx_rh,presnivs) USE lmdz_geometry, ONLY: latitude_deg USE dimphy, ONLY: klon,klev USE isotrac_mod, ONLY: option_traceurs,boite_map IMPLICIT NONE ! inputs REAL, DIMENSION(ntraciso,klon,klev), INTENT(IN) :: xt_seri REAL, DIMENSION(klon,klev), INTENT(IN) :: t_seri REAL, DIMENSION(klon,klev), INTENT(IN) :: zx_rh REAL, DIMENSION(klev), INTENT(IN) :: presnivs IF (option_traceurs.EQ.4) THEN CALL isotrac_recolorise_tmin(xt_seri,t_seri) elseif ((option_traceurs.EQ.5).OR. & (option_traceurs.EQ.21)) THEN CALL isotrac_recolorise_boite(xt_seri,boite_map) elseif (option_traceurs.EQ.13) THEN CALL isotrac_recolorise_tmin_sfrev(xt_seri,t_seri) elseif (option_traceurs.EQ.14) THEN CALL isotrac_recolorise_saturation(xt_seri,zx_rh,latitude_deg,presnivs) elseif (option_traceurs.EQ.20) THEN CALL isotrac_recolorise_extra(xt_seri,latitude_deg) endif !if (option_traceurs.EQ.4) THEN END SUBROUTINE isotrac_recolorise_general SUBROUTINE iso_verif_traceur_jbid_vect(x,n,m) USE isotopes_mod, ONLY: bidouille_anti_divergence,iso_eau,ridicule !use isotrac_mod, ONLY: ntraceurs_zone=>nzone USE infotrac_phy, ONLY: ntraceurs_zone=>nzone IMPLICIT NONE ! version vectrisée de iso_verif_traceur_jbidouille ! inputs INTEGER n,m REAL x(ntraciso,n,m) ! locals INTEGER iiso,izone,ixt,i,j REAL xtractot(n,m) IF (bidouille_anti_divergence) THEN DO iiso=1,niso DO j=1,m DO i=1,n xtractot(i,j)=0.0 enddo !do j=1,m enddo !do j=1,m DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) DO j=1,m DO i=1,n xtractot(i,j)=xtractot(i,j)+x(ixt,i,j) enddo !do j=1,m enddo !do j=1,m enddo !do izone=1,ntraceurs_zone ! on réajuste pour que les traceurs fasses bien la somme ! des traceurs DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) DO j=1,m DO i=1,n ! if (abs(xtractot(i,j)).gt.ridicule*10) THEN IF (abs(xtractot(i,j)).gt.ridicule) THEN ! modif le 19 fev 2011 x(ixt,i,j)=x(ixt,i,j)/xtractot(i,j)*x(iiso,i,j) endif !if (abs(xtractot(i,j)).gt.ridicule*10) THEN enddo !do i=1,n enddo !do j=1,m enddo !do izone=1,ntraceurs_zone ! ! ajout le 19 fev 2011 ! ! on rend plutot les vérifs plus strictes ! ixt=index_trac(izone_poubelle,iiso) ! do j=1,m ! do i=1,n ! if ((abs(xtractot(i,j)).lt.1e-18).AND. ! : (x(iiso,i,j).gt.ridicule)) THEN ! x(ixt,i,j)=x(iiso,i,j) ! endif !if (abs(xtractot(i,j)).gt.ridicule*10) THEN ! enddo ! do i=1,n ! enddo !do j=1,m enddo !do iiso=1,ntraceurs_iso endif !if (bidouille_anti_divergence) THEN END SUBROUTINE iso_verif_traceur_jbid_vect SUBROUTINE iso_verif_traceur_jbidouille(x) USE isotopes_mod, ONLY: bidouille_anti_divergence,iso_eau,ridicule IMPLICIT NONE ! on réajuste aussi les valeurs des traceurs pour la ! conservation de la masse, dans le cas bidouille ! inputs REAL x(ntraciso) ! locals INTEGER iiso,izone,ixt REAL xtractot IF (bidouille_anti_divergence) THEN DO iiso=1,niso xtractot=0.0 DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) xtractot=xtractot+x(ixt) enddo !do izone=1,ntraceurs_zone ! on réajuste pour que les traceurs fasses bien la somme ! des traceurs IF (abs(xtractot).gt.ridicule*10) THEN DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) x(ixt)=x(ixt)/xtractot*x(iiso) enddo !do izone=1,ntraceurs_zone endif enddo !do iiso=1,ntraceurs_iso endif !if (bidouille_anti_divergence) THEN END SUBROUTINE iso_verif_traceur_jbidouille SUBROUTINE iso_verif_traceur_jbid_pos(x) USE isotopes_mod, ONLY: bidouille_anti_divergence,iso_eau,ridicule !#ifdef ISOVERIF ! use isotopes_verif_mod, ONLY: iso_verif_traceur_pbidouille !#endif IMPLICIT NONE ! on réajuste les valeurs des traceurs pour qu'il n'y ai pas de ! valeurs négatives. Si valeurs négatives -> on pompe les autres ! traceurs ! attention: fait la même chose pour tous les isos -> peut ! induire des fractionnements. ! Pour ne pas induire des fractionnements, prendre ! iso_verif_traceur_jbid_pos2 ! avantage de cette subroutine: conserve la masse en isotopes ! légers, ce qui nest pas le cas de pos2 ! inputs REAL x(ntraciso) ! locals INTEGER iiso,izone,ixt REAL xtractot,xtractotprec IF (bidouille_anti_divergence) THEN ! WRITE(*,*) 'pgm 532 tmp: x=',x DO iiso=1,niso xtractot=0.0 xtractotprec=0.0 DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) xtractotprec=xtractotprec+x(ixt) x(ixt)=max(x(ixt),0.0) xtractot=xtractot+x(ixt) enddo !do izone=1,ntraceurs_zone ! WRITE(*,*) 'iiso,xtractotprec,xtractot=', ! : iiso,xtractotprec,xtractot IF (xtractot.gt.xtractotprec) THEN ! on réajuste pour que les traceurs fasses bien la somme ! des traceurs IF (abs(xtractot).gt.ridicule) THEN DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) x(ixt)=x(ixt)*xtractotprec/xtractot enddo !do izone=1,ntraceurs_zone ! on modifie aussi l'isotope de base si lui aussi était ! négatif ! x(iiso)=xtractot else !if (abs(xtractot).gt.ridicule) THEN ! normallement, valeurs restantes très faibles ! on ne fait rien. ! on met juste un max x(iiso)=max(x(iiso),0.0) DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) x(ixt)=max(x(ixt),0.0) enddo !do izone=1,ntraceurs_zone endif !if (abs(xtractot).gt.ridicule) THEN endif !if (xtractot.gt.xtractotprec) THEN enddo !do iiso=1,ntraceurs_iso #ifdef ISOVERIF CALL iso_verif_traceur_pbidouille(x,'iso_verif_trac 558') #else CALL iso_verif_traceur_jbidouille(x) #endif endif !if (bidouille_anti_divergence) THEN END SUBROUTINE iso_verif_traceur_jbid_pos SUBROUTINE iso_verif_traceur_jbid_pos_vect(n,m,x) USE isotopes_mod, ONLY: bidouille_anti_divergence,iso_eau,ridicule #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER n,m REAL x(ntraciso,n,m) ! locals INTEGER iiso,izone,ixt REAL xtractot(n,m),xtractotprec(n,m) INTEGER i,j IF (bidouille_anti_divergence) THEN ! WRITE(*,*) 'pgm 532 tmp: x=',x DO iiso=1,niso DO j=1,m DO i=1,n xtractot(i,j)=0.0 xtractotprec(i,j)=0.0 enddo !do j=1,m enddo !do i=1,n DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) DO j=1,m DO i=1,n xtractotprec(i,j)=xtractotprec(i,j)+x(ixt,i,j) x(ixt,i,j)=max(x(ixt,i,j),0.0) xtractot(i,j)=xtractot(i,j)+x(ixt,i,j) enddo !do i=1,n enddo !do j=1,m enddo !do izone=1,ntraceurs_zone ! WRITE(*,*) 'iiso,xtractotprec,xtractot=', ! : iiso,xtractotprec,xtractot DO j=1,m DO i=1,n IF (xtractot(i,j).gt.xtractotprec(i,j)) THEN ! on réajuste pour que les traceurs fasses bien la somme ! des traceurs IF (abs(xtractot(i,j)).gt.ridicule) THEN DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) x(ixt,i,j)=x(ixt,i,j)*xtractotprec(i,j)/xtractot(i,j) enddo !do izone=1,ntraceurs_zone ! on modifie aussi l'isotope de base si lui aussi était ! négatif ! x(iiso)=xtractot else !if (abs(xtractot).gt.ridicule) THEN ! normallement, valeurs restantes très faibles ! on ne fait rien. ! on met juste un max x(iiso,i,j)=max(x(iiso,i,j),0.0) DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) x(ixt,i,j)=max(x(ixt,i,j),0.0) enddo !do izone=1,ntraceurs_zone endif !if (abs(xtractot).gt.ridicule) THEN endif !if (xtractot.gt.xtractotprec) THEN enddo !do i=1,n enddo !do j=1,m enddo !do iiso=1,ntraceurs_iso #ifdef ISOVERIF CALL iso_verif_traceur_pbid_vect(x,n,m,'iso_verif_trac 558') #else CALL iso_verif_traceur_jbid_vect(x,n,m) #endif endif !if (bidouille_anti_divergence) THEN END SUBROUTINE iso_verif_traceur_jbid_pos_vect SUBROUTINE iso_verif_traceur_jbid_pos2(x,q) USE isotopes_mod, ONLY: bidouille_anti_divergence,iso_eau,ridicule #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! même but que iso_verif_traceur_jbid_pos, mais n'induit ! pas de fractionnement. ! on regarde si xteau est positif. S'il ne l'est pas, on pompe ! dans les autres tags pour le mettre à 0. On conserve la compo ! iso. ! Pb: ne conserve pas la masse d'isotopes légers. ! inputs REAL x(ntraciso),q ! locals INTEGER iiso,izone,ixt,ieau REAL dqtmp,factmp IF (bidouille_anti_divergence) THEN ! WRITE(*,*) 'iso_verif_trac 578 tmp: q,xt=', ! : q,x(1:ntraciso) IF (q.gt.0.0) THEN dqtmp=0.0 DO izone=1,ntraceurs_zone ieau=index_trac(izone,iso_eau) IF (x(ieau).lt.0.0) THEN ! WRITE(*,*) 'local_x<0 pour izone=',izone dqtmp=dqtmp-x(ieau) DO iiso=1,niso ixt=index_trac(izone,iiso) x(ixt) =0.0 enddo !do iiso=1,niso endif !if (local_xt(ieau,i,k).lt.0.0) THEN enddo !do izone=1,ntraceurs_zone ! WRITE(*,*) 'dqtmp=',dqtmp IF (dqtmp.gt.0.0) THEN ! WRITE(*,*) 'iso_verif_trac 593 warning: q,dqtmp,xt=', ! : q,dqtmp,x(1:ntraciso) ! on redistribue la négativité des traceurs dans les ! traceurs positifs ! factmp=(1.0-dqtmp/(local_q(i,k)+dqtmp)) ! correction janv 2010 factmp=(q/(q+dqtmp)) ! WRITE(*,*) 'factmp=',factmp DO izone=1,ntraceurs_zone ieau=index_trac(izone,iso_eau) IF (x(ieau).gt.0.0) THEN DO iiso=1,niso ixt=index_trac(izone,iiso) x(ixt)=x(ixt)*factmp enddo !do iiso=1,niso endif !if (local_xt(ieau,i,k).gt.0.0) THEN enddo ! do izone=1,ntraceurs_zone ! WRITE(*,*) 'apres bidouille: xt=',x(1:ntraciso) endif !if (dqtmp.gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_traceur(x,'iso_verif_traceurs 612') #endif endif !if (local_q(i,k).lt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_traceur_pbidouille(x,'iso_verif_trac 625') #endif endif ! if (bidouille_anti_divergence) THEN END SUBROUTINE iso_verif_traceur_jbid_pos2 SUBROUTINE iso_verif_traceur_jbid_vect1D(x,n) USE isotopes_mod, ONLY: bidouille_anti_divergence,iso_eau,ridicule IMPLICIT NONE ! version vectrisée de iso_verif_traceur_jbidouille ! inputs INTEGER n REAL x(ntraciso,n) ! locals INTEGER iiso,izone,ixt,i REAL xtractot IF (bidouille_anti_divergence) THEN DO i=1,n DO iiso=1,niso xtractot=0.0 DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) xtractot=xtractot+x(ixt,i) enddo !do izone=1,ntraceurs_zone ! on réajuste pour que les traceurs fasses bien la somme ! des traceurs IF (abs(xtractot).gt.ridicule*10) THEN DO izone=1,ntraceurs_zone ixt=index_trac(izone,iiso) x(ixt,i)=x(ixt,i)/xtractot*x(iiso,i) enddo !do izone=1,ntraceurs_zone endif enddo !do iiso=1,ntraceurs_iso enddo !do i=1,n endif !if (bidouille_anti_divergence) THEN END SUBROUTINE iso_verif_traceur_jbid_vect1D ! on met ces routines ici pour éviter dépendances circulaires #ifdef ISOVERIF SUBROUTINE iso_verif_traceur_pbidouille(x,err_msg) USE isotopes_verif_mod IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on réajuste aussi les valeurs des traceurs pour la ! conservation de la masse, dans le cas bidouille ! on prend les valeurs pas défaut pour ! errmax,errmaxrel,ridicule_trac,deltalimtrac ! inputs REAL x(ntraciso) CHARACTER*(*) err_msg ! message d''erreur à afficher ! local !integer iso_verif_traceur_pbid_ns IF (iso_verif_traceur_pbid_ns(x,err_msg).EQ.1) THEN stop endif END SUBROUTINE iso_verif_traceur_pbidouille function iso_verif_traceur_pbid_ns(x,err_msg) USE isotopes_mod, ONLY: iso_HDO,bidouille_anti_divergence USE isotrac_mod, ONLY: ridicule_trac USE isotopes_verif_mod IMPLICIT NONE ! vérifier des choses sur les traceurs ! * toutes les zones donne t l'istope total ! * pas de deltaD aberrant ! on réajuste aussi les valeurs des traceurs pour la ! conservation de la masse, dans le cas bidouille ! 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_pbid_ns ! locals !integer iso_verif_traceur_noNaN_nostop !integer iso_verif_tracm_choix_nostop !integer iso_verif_tracdD_choix_nostop INTEGER iiso,izone,ixt REAL xtractot ! verif noNaN iso_verif_traceur_pbid_ns=0 IF (iso_verif_traceur_noNaN_nostop(x,err_msg).EQ.1) THEN ! stop iso_verif_traceur_pbid_ns=1 endif ! verif masse IF (iso_verif_tracm_choix_nostop(x,err_msg, & errmax*10,errmaxrel*50).EQ.1) THEN ! on est plus laxiste car ça vient en général après une ! bidouille pour iso_eau normal ! stop iso_verif_traceur_pbid_ns=1 endif IF (bidouille_anti_divergence) THEN ! on réajuste pour que les traceurs fasses bien la somme ! des traceurs CALL iso_verif_traceur_jbidouille(x) endif !if (bidouille_anti_divergence) THEN ! verif deltaD IF (iso_HDO.gt.0) THEN IF (iso_verif_tracdD_choix_nostop(x,err_msg, & ridicule_trac,deltalimtrac).EQ.1) THEN ! stop iso_verif_traceur_pbid_ns=1 endif endif !if (iso_HDO.gt.0) THEN END FUNCTION iso_verif_traceur_pbid_ns SUBROUTINE iso_verif_traceur_pbid_vect(x,n,m,err_msg) USE isotopes_mod, ONLY: iso_HDO,bidouille_anti_divergence USE isotopes_verif_mod IMPLICIT NONE ! inputs INTEGER n,m REAL x(ntraciso,n,m) CHARACTER*(*) err_msg ! message d''erreur à afficher ! locals INTEGER iiso,izone,ixt REAL xtractot ! verif noNaN CALL iso_verif_traceur_noNaN_vect(x,n,m,err_msg) ! verif masse CALL iso_verif_trac_masse_vect(x,n,m,err_msg,errmax*10, & errmaxrel*50) IF (bidouille_anti_divergence) THEN ! on réajuste pour que les traceurs fasses bien la somme ! des traceurs CALL iso_verif_traceur_jbid_vect(x,n,m) endif !if (bidouille_anti_divergence) THEN ! verif deltaD IF (iso_HDO.gt.0) THEN CALL iso_verif_tracdd_vect(x,n,m,err_msg) endif END SUBROUTINE iso_verif_traceur_pbid_vect #endif END MODULE isotrac_routines_mod #endif #endif