#ifdef ISO ! $Id: $ MODULE isotopes_routines_mod USE infotrac_phy, ONLY: niso, ntraciso=>ntiso, index_trac=>itZonIso, ntraceurs_zone=>nzone USE lmdz_abort_physic, ONLY: abort_physic IMPLICIT NONE CONTAINS SUBROUTINE iso_revap_fisrtilp(klon,klev,k, & & zrfl_ancien,zrfl,zrfln,zt,zxt_ancien, & & zxtrfl,zxtrfl_ancien,zxtrfln,zxt, & & paprs,dtime, & & zqs,zq_ancien,zqev_diag,zq) USE isotopes_mod, ONLY: ridicule, ridicule_rain, thumxt1, no_pce, & & bidouille_anti_divergence, & & iso_eau,iso_HDO,iso_O18 USE lmdz_yomcst #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: option_revap,index_iso,izone_revap USE isotrac_routines_mod, ONLY: ajoute_revap, & & compress_ilp_evap_glace_zone,compress_ilp_evap_liq_zone, & & uncompress_ilp_zone #endif IMPLICIT NONE ! inputs INTEGER klon,klev,k REAL zrfl_ancien(klon) REAL zrfl(klon) ! pas necessaire, juste pour vérif REAL zxt_ancien(ntraciso,klon) ! equivalent local de xt REAL zqev_diag(klon) REAL zxtrfl_ancien(ntraciso,klon) REAL zrfln(klon) REAL dtime ! intervalle du temps (s) REAL paprs(klon,klev+1) ! pression a inter-couche REAL zt(klon) REAL zqs(klon) REAL zq_ancien(klon) REAL zq(klon) ! pas necessaire, juste pour vérifs ! outputs REAL zxtrfln(ntraciso,klon) REAL zxtrfl(ntraciso,klon) ! identique à zxtrfln REAL zxt(ntraciso,klon) ! locals REAL zqevfl(klon) REAL fac_fluxtomixratio(klon) REAL zrfl_cas(klon) REAL zqev_diag_cas(klon) REAL zxtrfl_cas(niso,klon) REAL zxtrfln_cas(niso,klon) REAL zrfln_cas(klon) REAL zxt_cas(niso,klon) ! zxt compress en input REAL zxtnew_cas(niso,klon) ! zxt compresse en output REAL qeff(klon) REAL zqs_cas(klon),zt_cas(klon) REAL zq_cas(klon) REAL delP(klon),delP_s_dt(klon) REAL Exi(niso,klon) REAL ztglace_kelvin parameter (ztglace_kelvin=273) INTEGER frac_sublim parameter (frac_sublim=0) ! pour le parsage INTEGER icas_evap_tot,ncas_evap_tot INTEGER icas_evap_liq,ncas_evap_liq INTEGER icas_evap_glace,ncas_evap_glace ! integer cas_evap_tot(klon) INTEGER cas_evap_liq(klon) INTEGER cas_evap_glace(klon) INTEGER i,ixt #ifdef ISOVERIF !integer iso_verif_aberrant_nostop !integer iso_verif_egalite_choix_nostop !integer iso_verif_positif_nostop !integer iso_verif_positif_choix_nostop INTEGER trace_cas(klon) !real !integer iso_verif_egalite_nostop !integer iso_verif_aberrant_choix_nostop #endif #ifdef ISOTRAC INTEGER iiso,ieau,izone REAL xtrevap_tag(ntraciso,klon) REAL ptrac(klon) REAL hdiag(klon) #endif ! ** parsage des cas pour isotopes icas_evap_tot=0 icas_evap_liq=0 icas_evap_glace=0 #ifdef ISOVERIF ! WRITE(*,*) 'iso_routines tmp 96: entree' ! initialisation de l'outil de tracage de cas: DO i=1,klon trace_cas(i)=0 IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zxt_ancien(iso_eau,i), & & zq_ancien(i),'iso_revap_ilp 94', & & errmax,errmaxrel) CALL iso_verif_egalite_choix( & & zxtrfl_ancien(iso_eau,i), & & zrfl_ancien(i),'iso_revap_ilp 99', & & errmax,errmaxrel) ENDIF END DO !do il=1,ncum #endif DO i=1,klon IF (zrfl_ancien(i) .GT.0.) THEN IF (zrfln(i).gt.ridicule*1e-2) THEN IF (zt(i).ge.ztglace_kelvin) THEN icas_evap_liq=icas_evap_liq+1 cas_evap_liq(icas_evap_liq)=i #ifdef ISOVERIF trace_cas(i)=2 #endif else !if (zt(i).ge.ztglace_kelvin) THEN icas_evap_glace=icas_evap_glace+1 cas_evap_glace(icas_evap_glace)=i #ifdef ISOVERIF trace_cas(i)=3 #endif endif !if (zt(i).ge.ztglace_kelvin) THEN else !if (zrfln(i).gt.ridicule*1e-2) THEN icas_evap_tot=icas_evap_tot+1 ! cas_evap_tot(icas_evap_tot)=i ! traitement à la volée DO ixt=1,ntraciso zxtrfln(ixt,i)=0.0 zxt(ixt,i)=zxt_ancien(ixt,i) & & +zxtrfl_ancien(ixt,i)*RG*dtime/(paprs(i,k)-paprs(i,k+1)) zxt(ixt,i)=max(0.0,zxt(ixt,i)) zxtrfl(ixt,i)=0.0 enddo !do ixt=1,niso #ifdef ISOVERIF trace_cas(i)=1 IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zxt(iso_eau,i), & & zq(i),'iso_revap_ilp 116',errmax,errmaxrel) endif DO ixt=1,ntraciso CALL iso_verif_positif_choix(zxt(ixt,i),0.0, & & 'revap_ilp 131') enddo #ifdef ISOTRAC CALL iso_verif_traceur(zxtrfl_ancien(1,i), & & 'iso_revap_fisrtilp 158: debut') #endif #endif endif !if (zrfln(i).gt.ridicule*1e-2) THEN else !IF (zrfl_ancien(i) .GT.0.) THEN ! pas de precip, rien à signaler DO ixt=1,ntraciso zxtrfln(ixt,i)=0.0 zxt(ixt,i)=zxt_ancien(ixt,i) zxt(ixt,i)=max(0.0,zxt(ixt,i)) zxtrfl(ixt,i)=0.0 enddo !do ixt=1,niso #ifdef ISOVERIF trace_cas(i)=4 ! WRITE(*,*) 'iso_routines tmp 160: i=',i ! WRITE(*,*) 'zrfl(i)=',zrfl(i) ! WRITE(*,*) 'zrfln(i)=',zrfln(i) ! WRITE(*,*) 'zrfl_ancien(i)=',zrfl_ancien(i) ! WRITE(*,*) 'zqev_diag(i)=',zqev_diag(i) CALL iso_verif_egalite_choix(zqev_diag(i), & & 0.0,'iso_revap_ilp 148a',ridicule,errmaxrel) CALL iso_verif_egalite_choix(zrfl(i), & & 0.0,'iso_revap_ilp 148b',ridicule,errmaxrel) CALL iso_verif_egalite_choix(zrfln(i), & & 0.0,'iso_revap_ilp 148c',ridicule,errmaxrel) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zxt(iso_eau,i), & & zq(i),'iso_revap_ilp 149',errmax,errmaxrel) CALL iso_verif_egalite_choix(zxtrfln(iso_eau,i), & & zrfln(i),'iso_revap_ilp 151',errmax,errmaxrel) CALL iso_verif_egalite_choix(zxtrfl(iso_eau,i), & & zrfl(i),'iso_revap_ilp 151b',errmax,errmaxrel) endif IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0)) THEN IF (zq(i).gt.ridicule) THEN CALL iso_verif_aberrant_encadre(zxt(iso_HDO,i)/zq(i), & 'iso_revap_ilp 178') CALL iso_verif_O18_aberrant(zxt(iso_HDO,i)/zq(i), & zxt(iso_O18,i)/zq(i),'iso_revap_ilp 180') endif !if (zq(i).gt.ridicule) THEN endif !if ((iso_HDO.gt.0.AND.(iso_O18.gt.0) THEN #ifdef ISOTRAC CALL iso_verif_traceur(zxtrfl_ancien(1,i), & & 'iso_revap_fisrtilp 201: debut quand pas de precip') #endif ! WRITE(*,*) 'iso_routines tmp 184' #endif END IF !IF (zrfl_ancien(i) .GT.0.) THEN END DO !do i=1,klon ncas_evap_liq=icas_evap_liq ncas_evap_glace=icas_evap_glace ncas_evap_tot=icas_evap_tot ! WRITE(*,*) 'zrfln 773,k,klev,klon=',k,klev,klon ! WRITE(*,*) 'ncas_evap_liq=',ncas_evap_liq ! WRITE(*,*) 'ncas_evap_glace=',ncas_evap_glace ! WRITE(*,*) 'ncas_evap_tot=',ncas_evap_tot ! ** cas evap_liq=2 IF (ncas_evap_liq.gt.0) THEN CALL compress_ilp_evap_liq( & & ncas_evap_liq,cas_evap_liq(1), & & zq_cas(1),zq_ancien(1), & & zqs_cas(1),zqs(1), & & zxt_cas(1,1),zxt_ancien(1,1), & & zxtrfl_cas(1,1),zxtrfl_ancien(1,1), & & zrfln_cas(1),zrfln(1), & & zrfl_cas(1),zrfl_ancien(1), & & zqev_diag_cas(1),zqev_diag(1), & & zt_cas(1),zt(1), & & delP(1),paprs,k,klon,klev) DO i=1,ncas_evap_liq fac_fluxtomixratio(i)=RG*dtime/delP(i) delP_s_dt(i)=delP(i)/dtime qeff(i)=(1-thumxt1)*zq_cas(i)+thumxt1*zqs_cas(i) enddo DO i=1,ncas_evap_liq zqevfl(i)=zqev_diag_cas(i)/fac_fluxtomixratio(i) enddo #ifdef ISOVERIF DO i=1,ncas_evap_liq CALL iso_verif_egalite_choix((zrfln_cas(i)), & & zrfln(cas_evap_liq(i)), & & 'iso_revap_fisrtilp 690; ap compress_evap_liq', & & errmax,errmaxrel) CALL iso_verif_egalite_choix((zrfl_cas(i)), & & zrfl_ancien(cas_evap_liq(i)), & & 'iso_revap_fisrtilp 695; ap compress_evap_liq', & & errmax,errmaxrel) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(( & & zxtrfl_cas(iso_eau,i)),(zrfl_cas(i)), & & 'iso_revap_fisrtilp 639; ap compress_evap_liq', & & errmax,errmaxrel) ENDIF ! if (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zqev_diag_cas(i), & & zqev_diag(cas_evap_liq(i)), & & 'iso_revap_fisrtilp 692; ap compress_evap_liq', & & errmax,errmaxrel) CALL iso_verif_egalite_choix(zrfl_ancien(cas_evap_liq(i)) & & -zqev_diag(cas_evap_liq(i)) & & *(paprs(cas_evap_liq(i),k)-paprs(cas_evap_liq(i),k+1)) & & /RG/dtime-zrfln(cas_evap_liq(i)),0.0, & & 'iso_revap_fisrtilp 693; ap compress_evap_liq', & & errmax,errmaxrel) CALL iso_verif_egalite(( & & zrfl_cas(i)-zqevfl(i)-zrfln_cas(i)),0.0, & & 'iso_revap_fisrtilp 691, après compress_evap_liq') enddo !do i=1,ncas_evap_liq ! WRITE(*,*) 'iso_revap_fisrtilp temp 715: qeff(1),zqs_cas(1)=', ! : qeff(1),zqs_cas(1) #endif IF (no_pce.EQ.1) THEN CALL stewart_sublim_nofrac_vectall( & & ncas_evap_liq,zq_cas(1), & & zxt_cas(1,1),zrfl_cas(1), & & zxtrfl_cas(1,1),zqevfl(1),zrfln_cas(1), & & zxtrfln_cas(1,1),zxtnew_cas(1,1),Exi(1,1), & & fac_fluxtomixratio(1)) else !if (no_pce.EQ.1) THEN CALL stewart_explicite_vectall(ncas_evap_liq, & & zq_cas(1),zxt_cas(1,1), & & zrfl_cas(1),zxtrfl_cas(1,1),zqevfl(1), & & zrfln_cas(1),qeff(1), & & zxtrfln_cas(1,1),zxtnew_cas(1,1),Exi(1,1), & & fac_fluxtomixratio(1), & & zqs_cas(1),zt_cas(1), & & delP_s_dt(1), & & delP(1) & #ifdef ISOVERIF & ,0,1 & #endif & ) END IF !if (no_pce.EQ.1) THEN #ifdef ISOVERIF DO i=1,ncas_evap_liq DO ixt=1,niso CALL iso_verif_noNaN((zxtrfln_cas(ixt,i)), & & 'iso_revap_fisrtilp 8283') CALL iso_verif_noNaN((zxtnew_cas(ixt,i)), & & 'iso_revap_fisrtilp 8293') CALL iso_verif_positif_choix(( & & zxtnew_cas(ixt,i)),0.0,'revap_ilp 225') enddo enddo IF (iso_eau.gt.0) THEN DO i=1,ncas_evap_liq CALL iso_verif_egalite_choix( & & (zxtrfln_cas(iso_eau,i)), & & (zrfln_cas(i)),'il pleut 4552', & & errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (zxtnew_cas(iso_eau,i)), & & zq(cas_evap_liq(i)), & & 'il pleut 4102',errmax,errmaxrel) enddo !do i=1,ncas_evap_liq endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN DO i=1,ncas_evap_liq IF (zrfln_cas(i).gt.ridicule_rain) THEN CALL iso_verif_aberrant( & & (zxtrfln_cas(iso_HDO,i) & & /zrfln_cas(i)), 'iso_revap_fisrtilp 4562') endif enddo !do i=1,ncas_evap_liq endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN ! WRITE(*,*) 'iso_routines tmp 308: i=',i IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0)) THEN DO i=1,ncas_evap_liq IF (zq(i).gt.ridicule) THEN CALL iso_verif_aberrant_encadre((zxtnew_cas(iso_HDO,i))/zq(cas_evap_liq(i)), & 'iso_revap_ilp 311') CALL iso_verif_O18_aberrant((zxtnew_cas(iso_HDO,i))/zq(cas_evap_liq(i)), & (zxtnew_cas(iso_O18,i))/zq(cas_evap_liq(i)),'iso_revap_ilp 312') endif !if (zq(i).gt.ridicule) THEN enddo !do i=1,ncas_evap_liq endif !if ((iso_HDO.gt.0.AND.(iso_O18.gt.0) THEN ! WRITE(*,*) 'iso_routines tmp 319' #endif IF ((bidouille_anti_divergence).AND. & & (iso_eau.gt.0)) THEN DO i=1,ncas_evap_liq zxtrfln_cas(iso_eau,i)=zrfln_cas(i) zxtnew_cas(iso_eau,i)=zq(cas_evap_liq(i)) enddo !do i=1,ncas_evap_liq ENDIF CALL uncompress_ilp( & & ncas_evap_liq,cas_evap_liq(1), & & zxtrfln_cas(1,1),zxtnew_cas(1,1), & & zxtrfl(1,1),zxtrfln(1,1),zxt(1,1),klon) #ifdef ISOTRAC DO izone=1,ntraceurs_zone ! on compresse, mais en plus on séléctionne que la preciip ! correspondant à la zone izone. Par contre, la vapeur reste ! la vapeur totale #ifdef ISOVERIF WRITE(*,*) 'iso_revap_ilp 245 tmp: izone=',izone WRITE(*,*) 'avant CALL compress_ilp_evap_liq_zone' ! if (ncas_evap_liq.ge.9) THEN ! i=9 ! WRITE(*,*) 'i,cas_evap_liq(i),zrfln,zrfl_ancien,zqev_diag=', ! : i,cas_evap_liq(i),zrfln(cas_evap_liq(i)), ! : zrfl_ancien(cas_evap_liq(i)), ! : zqev_diag(cas_evap_liq(i)) ! WRITE(*,*) 'zxtrfl_ancien(1:ntraciso:2,i)=', ! : zxtrfl_ancien(1:ntraciso:2,cas_evap_liq(i)) ! WRITE(*,*) 'ieau,zxtrfl_ancien(ieau,cas_evap_liq(i)=', ! : index_trac(izone,iso_eau),zxtrfl_ancien ! : (index_trac(izone,iso_eau),cas_evap_liq(i)) ! endif #endif CALL compress_ilp_evap_liq_zone( & & ncas_evap_liq,cas_evap_liq(1), & & zxt_cas(1,1),zxt_ancien(1,1), & & zxtrfl_cas(1,1),zxtrfl_ancien(1,1), & & zrfln_cas(1),zrfln(1), & & zrfl_cas(1),zrfl_ancien(1), & & zqev_diag_cas(1),zqev_diag(1), & & klon,izone,ptrac(1)) DO i=1,ncas_evap_liq zqevfl(i)=zqev_diag_cas(i)/fac_fluxtomixratio(i) enddo #ifdef ISOVERIF DO i=1,ncas_evap_liq CALL iso_verif_egalite(( & & zrfl_cas(i)-zqevfl(i)-zrfln_cas(i)),0.0, & & 'iso_revap_fisrtilp 286') enddo !do i=1,ncas_evap_liq #endif ! renormaliser les flux de precip pour que la proportion masse ! de liq/masse de vap soit la même pour toutes les zones ! on pourrait faire les choses plus proprement à l'avenir... DO i=1,ncas_evap_liq ! 1er juin 2009: on remplace ridicule par ridicule*1e3 IF (ptrac(i).gt.ridicule*1e3) THEN zrfl_cas(i)=zrfl_cas(i)/ptrac(i) zqevfl(i)=zqevfl(i)/ptrac(i) zrfln_cas(i)=zrfln_cas(i)/ptrac(i) DO ixt=1,niso zxtrfl_cas(ixt,i)=zxtrfl_cas(ixt,i)/ptrac(i) enddo else !if (ptrac(i).gt.ridicule*1e3) THEN #ifdef ISOVERIF CALL iso_verif_egalite((zrfl_cas(i)), & & 0.0,'revap_ilp 294') CALL iso_verif_egalite((zqevfl(i)), & & 0.0,'revap_ilp 296') CALL iso_verif_egalite((zrfln_cas(i)), & & 0.0,'revap_ilp 298') #endif zrfl_cas(i)=0.0 zqevfl(i)=0.0 zrfln_cas(i)=0.0 DO ixt=1,niso zxtrfl_cas(ixt,i)=0.0 enddo endif !if (ptrac(i).gt.ridicule*1e3) THEN enddo !do i=1,ncas_evap_liq #ifdef ISOVERIF DO i=1,ncas_evap_liq IF (iso_verif_egalite_nostop(( & & zrfl_cas(i)-zqevfl(i)-zrfln_cas(i)),0.0, & & 'iso_revap_fisrtilp 314').EQ.1) THEN WRITE(*,*) 'i,zrfl_cas(i),zqevfl(i),zrfln_cas(i)=', & & i,zrfl_cas(i),zqevfl(i),zrfln_cas(i) WRITE(*,*) 'ptrac(i),zrfl_ancien=', & & ptrac(i),zrfl_ancien(cas_evap_liq(i)) stop endif IF (iso_verif_aberrant_choix_nostop( & & (zxtrfl_cas(iso_HDO,i)), & & (zrfl_cas(i)), & & ridicule_rain,deltalimtrac, & & 'iso_revap_ilp 342').EQ.1) THEN WRITE(*,*) 'i,ptrac(i),zrfl_cas(i)=', & & i,ptrac(i),zrfl_cas(i) stop endif enddo !do i=1,ncas_evap_liq #endif IF (no_pce.EQ.1) THEN CALL stewart_sublim_nofrac_vectall( & & ncas_evap_liq,zq_cas(1), & & zxt_cas(1,1),zrfl_cas(1), & & zxtrfl_cas(1,1),zqevfl(1),zrfln_cas(1), & & zxtrfln_cas(1,1),zxtnew_cas(1,1),Exi(1,1), & & fac_fluxtomixratio(1)) else !if (no_pce.EQ.1) THEN CALL stewart_explicite_vectall(ncas_evap_liq, & & zq_cas(1),zxt_cas(1,1), & & zrfl_cas(1),zxtrfl_cas(1,1),zqevfl(1), & & zrfln_cas(1),qeff(1), & & zxtrfln_cas(1,1),zxtnew_cas(1,1),Exi(1,1), & & fac_fluxtomixratio(1), & & zqs_cas(1),zt_cas(1), & & delP_s_dt(1), & & delP(1) & #ifdef ISOVERIF & ,1,9 & #endif & ) ENDIF !if (no_pce.EQ.1) theniso_revap_fisrtilp 776 ! renormaliser les flux de precip pour que la proportion masse ! de liq/masse de vap soit la même pour toutes les zones ! on pourrait faire les choses plus proprement à l'avenir... DO i=1,ncas_evap_liq zrfl_cas(i)=zrfl_cas(i)*ptrac(i) zqevfl(i)=zqevfl(i)*ptrac(i) zrfln_cas(i)=zrfln_cas(i)*ptrac(i) DO ixt=1,niso zxtrfl_cas(ixt,i)=zxtrfl_cas(ixt,i)*ptrac(i) Exi(ixt,i)=Exi(ixt,i)*ptrac(i) zxtrfln_cas(ixt,i)=zxtrfln_cas(ixt,i)*ptrac(i) zxtnew_cas(ixt,i)=zxt_cas(ixt,i) & & +(zxtnew_cas(ixt,i)-zxt_cas(ixt,i))*ptrac(i) enddo hdiag(i)=qeff(i)/zqs_cas(i) enddo !do i=1,ncas_evap_liq #ifdef ISOVERIF DO i=1,ncas_evap_liq DO iiso=1,niso CALL iso_verif_positif_choix(( & & zxtnew_cas(iiso,i)),0.0,'revap_ilp 394') ixt=index_trac(izone,iiso) CALL iso_verif_positif_choix( & & zxt(ixt,cas_evap_liq(i)),0.0,'revap_ilp 397') IF (iso_verif_positif_choix_nostop( & & zxt(ixt,cas_evap_liq(i))+( & & fac_fluxtomixratio(i)*Exi(iiso,i)), & & 0.0,'revap_ilp 401').EQ.1) THEN WRITE(*,*) 'i,iiso,iso_eau=',i,iiso,iso_eau WRITE(*,*) 'zxt=',zxt(ixt,cas_evap_liq(i)) WRITE(*,*) 'Exi=',Exi(iiso,i) WRITE(*,*) 'zxt_eau=',zxt( & & index_trac(izone,iso_eau),cas_evap_liq(i)) WRITE(*,*) 'Exi_eau=',Exi(iso_eau,i) WRITE(*,*) 'fac_ftmr=',fac_fluxtomixratio(i) WRITE(*,*) 'ptrac=',ptrac(i) ! stop ENDIF enddo !do iiso=1,niso END DO !do i=1,ncas_evap_liq #endif CALL uncompress_ilp_zone( & & ncas_evap_liq,cas_evap_liq(1), & & zxtrfln_cas(1,1),zxtnew_cas(1,1), & & zxtrfl(1,1),zxtrfln(1,1),zxt(1,1),klon, & & izone,zqevfl(1),Exi(1,1),fac_fluxtomixratio(1), & & xtrevap_tag(1,1),1,hdiag(1)) ! dans cette routine, zxtrfl reçoit zxtrfln_cas enddo !do izone=1,ntraceurs_zone #ifdef ISOVERIF DO i=1,ncas_evap_liq DO ixt=1,ntraciso CALL iso_verif_positif_choix(zxt(ixt,cas_evap_liq(i)), & & 0.0,'revap_ilp 414') END DO CALL iso_verif_traceur(zxtrfl(1,cas_evap_liq(i)), & & 'iso_revap_fisrtilp 470a: apres stewart_explicite_vectall') END DO !do i=1,ncas #endif ! si on taggue la révap, alors les évaporations des ! différentes zones ont été stockées dans xtrevap_tag ! on les somme toute dans la vap au tag revap IF (option_revap.EQ.1) THEN CALL ajoute_revap(ncas_evap_liq,cas_evap_liq(1), & & klon,izone,zxt(1,1),xtrevap_tag(1,1)) ENDIF !if (option_revap.EQ.1) THEN #ifdef ISOVERIF DO i=1,ncas_evap_liq CALL iso_verif_traceur(zxt(1,cas_evap_liq(i)), & & 'iso_revap_fisrtilp 282') CALL iso_verif_traceur(zxtrfl(1,cas_evap_liq(i)), & & 'iso_revap_fisrtilp 804a') CALL iso_verif_traceur(zxtrfln(1,cas_evap_liq(i)), & & 'iso_revap_fisrtilp 804b') DO ixt=1,ntraciso CALL iso_verif_positif_choix(zxt(ixt,cas_evap_liq(i)), & & 0.0,'revap_ilp 424') enddo enddo #endif #endif ! #endif ISOTRAC END IF !if (ncas_evap_liq.gt.0) THEN ! ** cas evap_glace=3 IF (ncas_evap_glace.gt.0) THEN #ifdef ISOVERIF ! WRITE(*,*) '' ! WRITE(*,*) 'iso_revap tmp 469: traitement cas evap glace' ! WRITE(*,*) 'cas_evap_glace(1),zqev_diag=', ! : cas_evap_glace(1),zqev_diag(cas_evap_glace(1)) IF (iso_eau.gt.0) THEN DO i=1,ncas_evap_glace CALL iso_verif_egalite_choix( & & zrfl_ancien(cas_evap_glace(i)), & & zxtrfl_ancien(iso_eau,cas_evap_glace(i)), & & 'iso_revap_fisrtilp 742: zrfl_ancien=zxtrfl?', & & errmax,errmaxrel) enddo !do i=1,ncas_evap_glace ENDIF !if (iso_eau.gt.0) THEN #endif CALL compress_ilp_evap_glace( & & ncas_evap_glace,cas_evap_glace(1), & & zq_cas(1),zq_ancien(1), & & zxt_cas(1,1),zxt_ancien(1,1), & & zxtrfl_cas(1,1),zxtrfl_ancien(1,1), & & zrfln_cas(1),zrfln(1), & & zrfl_cas(1),zrfl_ancien(1), & & zqev_diag_cas(1),zqev_diag(1), & & zt_cas(1),zt(1), & & delP(1),paprs,k,klon,klev,frac_sublim) #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO i=1,ncas_evap_glace CALL iso_verif_egalite_choix((zrfl_cas(i)), & & (zxtrfl_cas(iso_eau,i)), & & 'iso_revap_fisrtilp 731: apres compress evap_glace', & & errmax,errmaxrel) CALL iso_verif_egalite_choix((zq_cas(i)), & & (zxt_cas(iso_eau,i)), & & 'iso_revap_fisrtilp 755: apres compress evap_glace', & & errmax,errmaxrel) CALL iso_verif_egalite_choix(zqev_diag_cas(i), & & zqev_diag(cas_evap_glace(i)), & & 'iso_revap_fisrtilp 755: apres compress evap_glace', & & errmax,errmaxrel) CALL iso_verif_egalite_choix(delP(i), & & paprs(cas_evap_glace(i),k)-paprs(cas_evap_glace(i),k+1), & & 'iso_revap_fisrtilp 769: apres compress evap_glace', & & errmax,errmaxrel) enddo !do i=1,ncas_evap_glace ENDIF ! if (iso_eau.gt.0) THEN #endif DO i=1,ncas_evap_glace fac_fluxtomixratio(i)=RG*dtime/delP(i) zqevfl(i)=zqev_diag_cas(i)/fac_fluxtomixratio(i) enddo !do i=1,ncas_evap_glace ! WRITE(*,*) 'zqev_diag,fac_fluxtomixratio=', ! : zqev_diag(cas_evap_glace(1)), ! : fac_fluxtomixratio(1) #ifdef ISOVERIF DO i=1,ncas_evap_glace CALL iso_verif_noNaN((fac_fluxtomixratio(i)), & & 'iso_revap_fisrtilp 763') ! WRITE(*,*) 'i,cas_evap_glace(i)=',i,cas_evap_glace(i) ! WRITE(*,*) 'zqevfl(i),zrfl_cas(i),zrfln_cas(i)=', ! : zqevfl(i),zrfl_cas(i),zrfln_cas(i) ! WRITE(*,*) 'zqev_diag_cas(i),fac_fluxtomixratio(i)=', ! : zqev_diag_cas(i),fac_fluxtomixratio(i) IF (iso_verif_positif_nostop( & & (zrfl_cas(i)-zqevfl(i)),'iso_revap_fisrtilp 776') & & .EQ.1) THEN IF (zrfl_cas(i)-zqevfl(i).lt.-ridicule*1e3) THEN stop endif endif !if (iso_verif_positif_nostop enddo !do i=1,ncas_evap_glace #endif IF (frac_sublim.EQ.1) THEN CALL stewart_glace_vectall(ncas_evap_glace & & ,zq_cas(1),zxt_cas(1,1) & & ,zrfl_cas(1),zxtrfl_cas(1,1) & & ,zqevfl(1),zrfln_cas(1) & & ,zxtrfln_cas(1,1),zxtnew_cas(1,1),Exi(1,1) & & ,fac_fluxtomixratio(1),zt(1)) else !if (frac_sublim.EQ.1) THEN CALL stewart_sublim_nofrac_vectall(ncas_evap_glace & & ,zq_cas(1),zxt_cas(1,1),zrfl_cas(1),zxtrfl_cas(1,1) & & ,zqevfl(1),zrfln_cas(1) & & ,zxtrfln_cas(1,1),zxtnew_cas(1,1),Exi(1,1) & & ,fac_fluxtomixratio(1)) ENDIF !if (frac_sublim.EQ.1) THEN #ifdef ISOVERIF !WRITE(*,*) 'ncas_evap_glace=',ncas_evap_glace !WRITE(*,*) 'cas_evap_glace(6)=',cas_evap_glace(6) DO i=1,ncas_evap_glace DO ixt=1,niso CALL iso_verif_noNaN((zxtrfln_cas(ixt,i)), & & 'iso_revap_fisrtilp 8883') CALL iso_verif_noNaN((zxtnew_cas(ixt,i)), & & 'iso_revap_fisrtilp 8893') CALL iso_verif_positif_choix(( & & zxtnew_cas(ixt,i)),0.0,'revap_ilp 534') enddo enddo !do i=1,ncas_evap_glace IF (iso_eau.gt.0) THEN DO i=1,ncas_evap_glace CALL iso_verif_egalite_choix( & & (zxtrfln_cas(iso_eau,i)), & & (zrfln_cas(i)), & & 'iso_revap_fisrtilp 4553', & & errmax,errmaxrel) IF (iso_verif_egalite_choix_nostop( & & (zxtnew_cas(iso_eau,i)), & & zq(cas_evap_glace(i)), & & 'iso_revap_fisrtilp 4103',errmax,errmaxrel) & & .EQ.1) THEN WRITE(*,*) 'i,cas_evap_glace(i)=',i,cas_evap_glace(i) WRITE(*,*) 'zq(cas_evap_glace(i))=', & & zq(cas_evap_glace(i)) WRITE(*,*) 'zq_cas(i)=',zq_cas(i) stop endif !if (iso_verif_egalite_choix_nostop enddo !do i=1,ncas_evap_glace endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN DO i=1,ncas_evap_glace CALL iso_verif_aberrant_choix(zxtrfln_cas(iso_HDO,i), zrfln_cas(i), & ridicule_rain,deltalim_snow, 'iso_revap_fisrtilp 4563') enddo !do i=1,ncas_evap_glace endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN ! WRITE(*,*) 'iso_routines tmp 667: i=',i IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0)) THEN DO i=1,ncas_evap_glace IF (zq(i).gt.ridicule) THEN ! WRITE(*,*) 'iso_routines tmp 679a' ! WRITE(*,*) 'cas_evap_glace(i)=',cas_evap_glace(i) CALL iso_verif_aberrant_encadre((zxtnew_cas(iso_HDO,i))/zq(cas_evap_glace(i)), & 'iso_revap_ilp 669') ! WRITE(*,*) 'iso_routines tmp 679b' CALL iso_verif_O18_aberrant((zxtnew_cas(iso_HDO,i))/zq(cas_evap_glace(i)), & (zxtnew_cas(iso_O18,i))/zq(cas_evap_glace(i)),'iso_revap_ilp 671') ! WRITE(*,*) 'iso_routines tmp 679c' endif !if (zq(i).gt.ridicule) THEN enddo ! do i=1,ncas_evap_glac endif !if ((iso_HDO.gt.0.AND.(iso_O18.gt.0) THEN ! WRITE(*,*) 'iso_routines tmp 679d' #endif IF ((bidouille_anti_divergence).AND. & & (iso_eau.gt.0)) THEN DO i=1,ncas_evap_glace zxtrfln_cas(iso_eau,i)=zrfln_cas(i) zxtnew_cas(iso_eau,i)=zq(cas_evap_glace(i)) enddo !do i=1,ncas_evap_liq ENDIF ! if ((bidouille_anti_divergence).AND. #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO i=1,ncas_evap_glace CALL iso_verif_egalite_choix( & & (zxtrfln_cas(iso_eau,i)), & & zrfln(cas_evap_glace(i)),'iso_revap_fisrtilp 810', & & errmax,errmaxrel) enddo !do i=1,ncas_evap_glace ENDIF !if (iso_eau.gt.0) THEN #endif CALL uncompress_ilp( & & ncas_evap_glace,cas_evap_glace(1), & & zxtrfln_cas(1,1),zxtnew_cas(1,1), & & zxtrfl(1,1),zxtrfln(1,1),zxt(1,1),klon) ! WRITE(*,*) 'iso_revap tmp 448: traitement cas evap glace traceurs' ! WRITE(*,*) 'zqev_diag,fac_fluxtomixratio=', ! : zqev_diag(cas_evap_glace(1)), ! : fac_fluxtomixratio(1) #ifdef ISOTRAC DO izone=1,ntraceurs_zone ! WRITE(*,*) 'iso_revap_ilp 509 tmp: izone=',izone ! on compresse, mais en plus on séléctionne que la preciip ! correspondant à la zone izone. Par contre, la vapeur reste ! la vapeur totale CALL compress_ilp_evap_glace_zone( & & ncas_evap_glace,cas_evap_glace(1), & & zxt_cas(1,1),zxt_ancien(1,1), & & zxtrfl_cas(1,1),zxtrfl_ancien(1,1), & & zrfln_cas(1),zrfln(1), & & zrfl_cas(1),zrfl_ancien(1), & & zqev_diag_cas(1),zqev_diag(1), & & klon,izone) DO i=1,ncas_evap_glace zqevfl(i)=zqev_diag_cas(i)/fac_fluxtomixratio(i) enddo IF (frac_sublim.EQ.1) THEN CALL stewart_glace_vectall(ncas_evap_glace & & ,zq_cas(1),zxt_cas(1,1) & & ,zrfl_cas(1),zxtrfl_cas(1,1) & & ,zqevfl(1),zrfln_cas(1) & & ,zxtrfln_cas(1,1),zxtnew_cas(1,1),Exi(1,1) & & ,fac_fluxtomixratio(1),zt(1)) else CALL stewart_sublim_nofrac_vectall(ncas_evap_glace & & ,zq_cas(1),zxt_cas(1,1),zrfl_cas(1),zxtrfl_cas(1,1) & & ,zqevfl(1),zrfln_cas(1) & & ,zxtrfln_cas(1,1),zxtnew_cas(1,1),Exi(1,1) & & ,fac_fluxtomixratio(1)) ENDIF ! WRITE(*,*) 'iso_revap_ilp 509 tmp: Exi,zqev_diag_cas=', ! : Exi(iso_eau,1),zqev_diag_cas(1) CALL uncompress_ilp_zone( & & ncas_evap_glace,cas_evap_glace(1), & & zxtrfln_cas(1,1),zxtnew_cas(1,1), & & zxtrfl(1,1),zxtrfln(1,1),zxt(1,1),klon, & & izone,zqevfl(1),Exi(1,1),fac_fluxtomixratio(1), & & xtrevap_tag(1,1),0,hdiag(1)) ! hdiag not used enddo !do izone=1,ntraceurs_zone ! si on taggue la révap, alors les évaporations des ! différentes zones ont été stockées dans xtrevap_tag ! on les somme toute dans la vap au tag revap IF (option_revap.EQ.1) THEN CALL ajoute_revap(ncas_evap_glace,cas_evap_glace(1), & & klon,izone,zxt(1,1),xtrevap_tag(1,1)) ENDIF !if (option_revap.EQ.1) THEN #ifdef ISOVERIF DO i=1,ncas_evap_glace ! WRITE(*,*) 'iso_revap_ilp 520 tmp: i=',i ! WRITE(*,*) 'zxt=',zxt(iso_eau:ntraciso:3,cas_evap_glace(i)) ! WRITE(*,*) 'zxt_ancien=',zxt_ancien ! : (iso_eau:ntraciso:3,cas_evap_glace(i)) CALL iso_verif_traceur(zxt(1,cas_evap_glace(i)), & & 'iso_revap_fisrtilp 1033') CALL iso_verif_traceur(zxtrfl(1,cas_evap_glace(i)), & & 'iso_revap_fisrtilp 1035a') CALL iso_verif_traceur(zxtrfln(1,cas_evap_glace(i)), & & 'iso_revap_fisrtilp 1035b') enddo #endif #endif !#ifdef ISOTRAC END IF !if (ncas_evap_glace.gt.0) THEN #ifdef ISOVERIF ! dernières vérifs pour l'évap IF (iso_eau.gt.0) THEN DO i=1,klon IF (zrfl_ancien(i).gt.0.0) THEN CALL iso_verif_egalite_choix( & & zxtrfln(iso_eau,i), & & zrfln(i),'iso_revap_fisrtilp 801', & & errmax,errmaxrel) IF (iso_verif_egalite_choix_nostop( & & zxtrfl(iso_eau,i), & & zrfl(i),'iso_revap_fisrtilp 802', & & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'i,k,trace_cas(i)=',i,k,trace_cas(i) WRITE(*,*) 'zxtrfln(iso_eau,i),zrfln(i)=', & & zxtrfln(iso_eau,i),zrfln(i) stop END IF ! if (iso_verif_egalite_choix_nostop( IF (iso_verif_egalite_choix_nostop( & & zxt(iso_eau,i),zq(i), & & 'iso_revap_fisrtilp 807',errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'i,k,trace_cas(i)=',i,k,trace_cas(i) stop END IF !if (iso_verif_egalite_choix_nostop( END IF !if (zrfl_ancien(i).gt.0.0) THEN END DO !do i=1,klon END IF !if (iso_eau.gt.0) THEN #ifdef ISOTRAC ! grande vérif finale DO i=1,klon CALL iso_verif_traceur(zxt(1,i),'iso_revap_fisrtilp 532') CALL iso_verif_traceur(zxtrfln(1,i), & & 'iso_revap_fisrtilp 533a') CALL iso_verif_traceur(zxtrfl(1,i), & & 'iso_revap_fisrtilp 533b') DO ixt=1,ntraciso CALL iso_verif_positif_choix(zxt(ixt,i),0.0, & & 'revap_ilp 701') enddo END DO !do i=1,klon !WRITE(*,*) 'revap_ilp 814: sortie' #endif #endif END SUBROUTINE iso_revap_fisrtilp SUBROUTINE iso_evap_sol_nu(qsol0,qevap,q10,Rsol0,R1,h,T,alphak, & & L, xtnu,Pveg) USE isotopes_mod, ONLY: ridicule_qsol, ridicule, & & ridicule_evap,P_veg,iso_HDO,iso_eau,iso_O17,iso_O18 #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel,faccond USE isotopes_verif_mod #endif IMPLICIT NONE ! calcul de Rsol et Revap lors de l'évaporation de l'eau du sol ! par évap nue. ! inputs: REAL qsol0 ! eau du sol REAL qevap ! eau perdue par le sol REAL Rsol0(niso) ! rapport iso initial dans sol REAL R1(niso) ! rapport iso dans couche 1, supposé constant REAL q10 ! humidité 1ère couche, en mm REAL h ! humidité rel dans couche 1, supposée cosntante REAL T ! température REAL alphak(niso) ! coef cinétique REAL L ! longueur de diffusion REAL Pveg ! just pour débguage ! outputs! REAL xtnu(niso) ! flux iso dans l'évap ! locals REAL f ! fraction d'eau résiduelle dans le sol REAL interm(niso) REAL betaprime(niso) ! beta de stewart75 REAL gama(niso) ! le gama de Stewart75 REAL zxtalphal(niso), zxtalphai(niso) ! coeffs frac INTEGER ixt ! calcul de l'évap: ordre 1 (on prend l'évap en t0) ou bilan total ! (on prend l'évap tel que la 1ère couche se mette à l'équilibre INTEGER ordre1 ! 1: ordre 1: deltaDevap= si deltaDvap ne change pas ! 2: deltaDvap change parameter (ordre1=2) #ifdef ISOVERIF !integer iso_verif_aberrant_nostop !integer iso_verif_aberrant_choix_nostop !integer iso_verif_egalite_choix_nostop !real deltaD REAL xtnu2(niso) #endif ! ca ne marche que si déjà de l'eau dans le sol au départ IF (qsol0.lt.ridicule_qsol) THEN DO ixt=1,niso xtnu(ixt)=Rsol0(ixt)*qevap enddo #ifdef ISOVERIF IF (iso_HDO.gt.0) THEN ! WRITE(*,*) 'sol_nu 66: deltaDsol(iso_HDO)=', ! : (Rsol(iso_HDO)/tnat(iso_HDO)-1)*1000 ! WRITE(*,*) 'deltaDevap(iso_HDO)=',(Revap(iso_HDO)/ ! : tnat(iso_HDO)-1)*1000 endif !if (iso_HDO.gt.0) THEN #endif RETURN END IF !if (qsol0.lt.ridicule_qsol) THEN ! vérif des rapports isotopiques en entrée #ifdef ISOVERIF ! provisoire, à enlever pour tests avec evap sol nu! IF (P_veg.EQ.1.0) THEN CALL iso_verif_egalite(Pveg,1.0,'iso_evap_sol_nu 64') END IF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(Rsol0(iso_eau),1.0, & & 'sol_nu 83',errmax,errmaxrel) CALL iso_verif_egalite_choix(R1(iso_eau),1.0, & & 'sol_nu 56',errmax,errmaxrel) END IF !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qsol0.gt.ridicule_qsol*1e2) THEN IF (iso_verif_aberrant_nostop(Rsol0(iso_HDO)/faccond, & & 'sol_nu 58').EQ.1) THEN WRITE(*,*) 'qsol0=',qsol0 stop endif !if (iso_verif_aberrant_nostop ENDIF !if (qsol0.gt.ridicule*1e2) THEN IF (h.gt.0.01) THEN CALL iso_verif_aberrant(R1(iso_HDO),'sol_nu 59') ENDIF !if (h.gt.0.01) THEN END IF !if (iso_HDO.gt.0) THEN #endif ! calcul de la fraction résiduelle de liq dans sol ! cas général: f=(L-qevap)/L ! cas si qevap>L: f=0 ! cas si qsol0 f=(qsol0-qevap)/qsol0 f=max((min(L,qsol0)-qevap)/min(L,qsol0),0.0) #ifdef ISOVERIF CALL iso_verif_positif(1.0-f,'iso_evap_sol_nu 68') #endif IF (f.lt.ridicule) THEN ! il ne reste plus rien après l'évap ! -> evap sans frac DO ixt=1,niso xtnu(ixt)=qevap*Rsol0(ixt) enddo else !if (f.lt.ridicule) THEN ! 2 e cas simple: h=1 IF (h.gt.0.99) THEN #ifdef ISOVERIF WRITE(*,*) 'sol_nu 102: h=',h #endif DO ixt=1,niso CALL fractcalk(ixt,T,zxtalphal(ixt),zxtalphai(ixt)) enddo ! do ixt=1,niso IF (qevap.gt.min(L,qsol0)) THEN ! évap trop rapide pour fractionner DO ixt=1,niso xtnu(ixt)=qevap*Rsol0(ixt) enddo ! do ixt=1,niso ELSE IF (qsol0.lt.L) THEN ! il ne reste plus beaucou d'eau, tout diffuse ! cas simple où q10>>qevap IF (ordre1.EQ.1) THEN DO ixt=1,niso xtnu(ixt)=qsol0*(Rsol0(ixt)-zxtalphal(ixt)*R1(ixt)) & & +qevap*zxtalphal(ixt)*R1(ixt) enddo ! do ixt=1,niso else !if (ordre1.EQ.1) THEN ! cas général DO ixt=1,niso xtnu(ixt)=(qsol0*q10*(Rsol0(ixt)-zxtalphal(ixt)*R1(ixt)) & & +qevap*(qsol0*Rsol0(ixt)+zxtalphal(ixt)*q10*R1(ixt))) & & /(q10+qevap+(qsol0-qevap)*zxtalphal(ixt)) enddo ! do ixt=1,niso endif !if (ordre1.EQ.1) THEN else !if (qevap.gt.min(L,qsol0)) THEN ! évaporation non totale et plus d'eau que dans couche de ! diffusion ! cas simple où q10>>qevap IF (ordre1.EQ.1) THEN DO ixt=1,niso xtnu(ixt)=L*(Rsol0(ixt)-zxtalphal(ixt)*R1(ixt)) & & +qevap*zxtalphal(ixt)*R1(ixt) enddo ! do ixt=1,niso else !if (ordre1.EQ.1) THEN ! cas général DO ixt=1,niso xtnu(ixt)=(L*q10*(Rsol0(ixt)-zxtalphal(ixt)*R1(ixt)) & & +qevap*(L*Rsol0(ixt)+zxtalphal(ixt)*q10*R1(ixt))) & & /(q10+qevap+(L-qevap)*zxtalphal(ixt)) enddo ! do ixt=1,niso endif !if (ordre1.EQ.1) THEN ENDIF !if (qevap.gt.min(L,qsol0)) THEN #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xtnu(ixt), & & 'iso_evap_sol_nu 121') enddo IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop(xtnu(iso_eau),qevap, & & 'sol_nu 110',errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'qevap=',qevap WRITE(*,*) 'qsol0=',qsol0 WRITE(*,*) 'L=',L WRITE(*,*) 'Rsol0(iso_eau)=',Rsol0(iso_eau) WRITE(*,*) 'R1(iso_eau)=',R1(iso_eau) WRITE(*,*) 'q10=',q10 WRITE(*,*) 'zxtalphal(iso_eau)=',zxtalphal(iso_eau) stop endif endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qevap.gt.ridicule_evap*1800) THEN IF (iso_verif_aberrant_nostop(xtnu(iso_HDO)/qevap, & & 'sol_nu 113').EQ.1) THEN WRITE(*,*) 'qevap=',qevap WRITE(*,*) 'qsol0=',qsol0 WRITE(*,*) 'deltaD(R1)=',deltaD(R1((iso_HDO))) WRITE(*,*) 'deltaD(alpha*R1)=',deltaD & & (zxtalphal(iso_HDO)*R1((iso_HDO))) WRITE(*,*) 'deltaD(Rsol0)=', & & deltaD(Rsol0((iso_HDO))) WRITE(*,*) 'L=',L WRITE(*,*) 'Pveg=',Pveg ! on ne plante que si ca donne lieu à des valeurs ! aberrante de deltaD1 WRITE(*,*) 'deltaD1new=',deltaD(( & & xtnu(iso_HDO)+q10*R1(iso_HDO)) & & /(q10+qevap)) CALL iso_verif_aberrant( & & (xtnu(iso_hdo)+q10*R1(iso_hdo)) & & /(qevap+q10), & & 'sol_nu 1390') endif !if (iso_verif_aberrant_nosto endif !if (qevap.gt.ridicule_evap*1800) THEN IF (iso_verif_aberrant_choix_nostop(xtnu(iso_HDO), & & qevap,ridicule,1e5,'sol_nu 195').EQ.1) THEN WRITE(*,*) 'h=',h WRITE(*,*) 'qsol0=',qsol0 WRITE(*,*) 'deltaD(R1)=',deltaD(R1((iso_HDO))) WRITE(*,*) 'deltaD(alpha*R1)=',deltaD & & (zxtalphal(iso_HDO)*R1((iso_HDO))) WRITE(*,*) 'deltaD(Rsol0)=', & & deltaD(Rsol0((iso_HDO))) WRITE(*,*) 'deltaD1new=',deltaD(( & & xtnu(iso_HDO)+q10*R1(iso_HDO)) & & /(q10+qevap)) IF (ordre1.EQ.1) THEN ! l'ordre 2 aurait-il amélioré? DO ixt=1,niso xtnu2(ixt)=(L*q10*(Rsol0(ixt) & & -zxtalphal(ixt)*R1(ixt))+qevap & & *(L*Rsol0(ixt)+zxtalphal(ixt)*q10*R1(ixt))) & & /(q10+qevap+(L-qevap)*zxtalphal(ixt)) enddo WRITE(*,*) 'si 2e ordre:deltaDevap=', & & deltaD(xtnu2(iso_hdo)/qevap) WRITE(*,*) 'si 2e ordre, deltaD1new=', & & deltaD(( & & xtnu2(iso_HDO)+q10*R1(iso_HDO)) & & /(q10+qevap)) endif CALL iso_verif_aberrant(( & & xtnu(iso_HDO)+q10*R1(iso_HDO)) & & /(q10+qevap),'sol_nu 224') endif endif !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qevap.gt.ridicule_evap) THEN CALL iso_verif_aberrant_o17(xtnu(iso_O17) & & /qevap,xtnu(iso_O18)/qevap, & & 'iso_evap_nu 238') endif !if (qevap(i).gt.ridicule_evap) THEN endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif ! 3 e cas limite : f=1 else !if (h.gt.0.99) THEN IF (f.gt.0.95) THEN #ifdef ISOVERIF ! WRITE(*,*) 'sol_nu 139: f=',f #endif DO ixt=1,niso CALL fractcalk(ixt,T,zxtalphal(ixt),zxtalphai(ixt)) interm(ixt)=zxtalphal(ixt)*alphak(ixt)*(1-h) betaprime(ixt)=(1.0-interm(ixt))/interm(ixt) gama(ixt)=zxtalphal(ixt)*h/(1.0-interm(ixt)) ! Rsol(ixt)=(Rsol0(ixt)-gama(ixt)*R1(ixt)) ! : *f**(betaprime(ixt))+gama(ixt)*R1(ixt) ! Revap(ixt)=(1+betaprime(ixt))*Rsol0(ixt) ! : -betaprime(ixt)*gama(ixt)*R1(ixt) ! 1er ordre !! : +(1-f)*(-Rsol0(ixt)*(1+betaprime(ixt))*0.5 ! 2e ordre !! : +betaprime(ixt)*(0.5+gama(ixt)*R1(ixt))) ! 2e ordre ! 2e ordre conserve mal la masse -> ne pas utiliser xtnu(ixt)= qevap*((Rsol0(ixt)/zxtalphal(ixt)-h*R1(ixt) ) & & /alphak(ixt)/(1-h)) ! =Revap0 <=>1er ordre enddo !do ixt=1,niso #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xtnu(ixt), & & 'iso_evap_sol_nu 169') enddo IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtnu(iso_eau),qevap, & & 'sol_nu 151',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qevap.gt.ridicule_evap*1800) THEN IF (iso_verif_aberrant_nostop(xtnu(iso_HDO)/qevap, & & 'sol_nu 154').EQ.1) THEN WRITE(*,*) 'deltaDRsol0=',deltaD(Rsol0(iso_HDO)) WRITE(*,*) 'deltaDR1=',deltaD(R1(iso_HDO)) WRITE(*,*) 'deltaD gama*R1=', & & deltaD(gama(iso_HDO)*R1(iso_HDO)) WRITE(*,*) 'f=',f WRITE(*,*) 'qevap,L=',qevap,L WRITE(*,*) 'betaprime,h=',betaprime(iso_HDO),h WRITE(*,*) 'alphak,zxtalphal=', & & alphak(iso_HDO),zxtalphal(iso_HDO) ! on ne stppe que si deltaD1new devient ! aberrant. WRITE(*,*) 'deltaD1new=',deltaD(( & & xtnu(iso_HDO)+q10*R1(iso_HDO)) & & /(q10+qevap)) CALL iso_verif_aberrant( & & (xtnu(iso_hdo)+q10*R1(iso_hdo)) & & /(qevap+q10), & & 'sol_nu 282') endif !if (iso_verif_aberrant_nostop endif !if (qevap.gt.ridicule_evap*1800) THEN CALL iso_verif_aberrant_choix(xtnu(iso_HDO), & & qevap,ridicule,1e5,'sol_nu 269') endif !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qevap.gt.ridicule_evap) THEN CALL iso_verif_aberrant_o17(xtnu(iso_O17) & & /qevap,xtnu(iso_O18)/qevap, & & 'iso_evap_nu 307') endif !if (qevap(i).gt.ridicule_evap) THEN endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif else !if (f.gt.0.90) THEN ! 4e cas simple: si h=0 IF (h.lt.0.01) THEN #ifdef ISOVERIF WRITE(*,*) 'sol_nu 165: h=',h #endif DO ixt=1,niso CALL fractcalk(ixt,T,zxtalphal(ixt),zxtalphai(ixt)) END DO DO ixt=1,niso betaprime(ixt)=1.0/alphak(ixt)/zxtalphal(ixt)-1.0 xtnu(ixt)=qevap*Rsol0(ixt)*(1-f**(1+betaprime(ixt)))/(1.0-f) END DO !do ixt=1,niso #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xtnu(ixt), & & 'iso_evap_sol_nu 206') enddo IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtnu(iso_eau),qevap, & & 'sol_nu 168',errmax,errmaxrel) ENDIF !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qevap.gt.ridicule_qsol) THEN CALL iso_verif_aberrant(xtnu(iso_HDO)/qevap, & & 'sol_nu 171') endif !if (qevap.gt.ridicule_qsol) THEN CALL iso_verif_aberrant_choix(xtnu(iso_HDO), & & qevap,ridicule,1e5,'sol_nu 302') ENDIF !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qevap.gt.ridicule_evap) THEN CALL iso_verif_aberrant_o17(xtnu(iso_O17) & & /qevap,xtnu(iso_O18)/qevap, & & 'iso_evap_nu 347') endif !if (qevap(i).gt.ridicule_evap) THEN endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif else !if (h.lt.0.01) THEN ! cas général #ifdef ISOVERIF ! WRITE(*,*) 'sol_nu 182: cas général' #endif DO ixt=1,niso CALL fractcalk(ixt,T,zxtalphal(ixt),zxtalphai(ixt)) interm(ixt)=zxtalphal(ixt)*alphak(ixt)*(1.0-h) betaprime(ixt)=((1.0-interm(ixt))/interm(ixt)) gama(ixt)=zxtalphal(ixt)*h/(1.0-interm(ixt)) xtnu(ixt)=qevap*(Rsol0(ixt)*(1.0-f**(1.0+betaprime(ixt))) & & -f*gama(ixt)*R1(ixt)*(1.0-f**betaprime(ixt)))/(1.0-f) END DO !do ixt=1,niso #ifdef ISOVERIF DO ixt=1,niso ! WRITE(*,*) 'qevap,Rsol0(ixt),f,betaprime(ixt)=', ! : qevap,Rsol0(ixt),f,betaprime(ixt) CALL iso_verif_noNAN(xtnu(ixt), & & 'iso_evap_sol_nu 234') END DO IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtnu(iso_eau),qevap, & & 'sol_nu 185',errmax,errmaxrel) END IF !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qevap.gt.ridicule_evap*1800) THEN IF (iso_verif_aberrant_nostop(xtnu(iso_HDO)/qevap, & & 'sol_nu 189').EQ.1) THEN WRITE(*,*) 'deltaDRsol0=',deltaD(Rsol0(iso_HDO)) WRITE(*,*) 'deltaDR1=',deltaD(R1(iso_HDO)) WRITE(*,*) 'deltaD gama*R1=', & & deltaD(gama(iso_HDO)*R1(iso_HDO)) WRITE(*,*) 'f=',f WRITE(*,*) 'betaprime=',betaprime(iso_HDO) ! on ne stppe que si deltaD1new devient ! aberrant. WRITE(*,*) 'deltaD1new=',deltaD(( & & xtnu(iso_HDO)+q10*R1(iso_HDO)) & & /(q10+qevap)) CALL iso_verif_aberrant( & & (xtnu(iso_hdo)+q10*R1(iso_hdo)) & & /(qevap+q10), & & 'sol_nu 321') endif !if (iso_verif_aberrant_nostop endif !if (qevap.gt.ridicule_evap*1800) THEN CALL iso_verif_aberrant_choix(xtnu(iso_HDO), & & qevap,ridicule,1e5,'sol_nu 354') IF (qsol0-qevap.gt.ridicule_qsol*1e2) THEN IF (iso_verif_aberrant_nostop((qsol0*Rsol0(iso_HDO) & & -xtnu(iso_HDO))/(qsol0-qevap)/faccond, & & 'evap_sol_nu, reste sol aberrant 375').EQ.1) THEN WRITE(*,*) 'qsol0=',qsol0 WRITE(*,*) 'deltaDRsol0=',deltaD(Rsol0(iso_HDO)) WRITE(*,*) 'deltaD gama*R1=', & & deltaD(gama(iso_HDO)*R1(iso_HDO)) WRITE(*,*) 'deltaDevap=',deltaD(xtnu(iso_HDO)/qevap) WRITE(*,*) 'f,h=',f,h stop endif endif END IF !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qevap.gt.ridicule_evap) THEN CALL iso_verif_aberrant_o17(xtnu(iso_O17) & & /qevap,xtnu(iso_O18)/qevap, & & 'iso_evap_nu 419') endif !if (qevap(i).gt.ridicule_evap) THEN ENDIF !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif END IF !if (h.lt.0.01) THEN END IF ! if f>0.9 END IF ! if h>0.99 END IF !if (f.lt.ridicule) THEN #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xtnu(ixt), & & 'iso_evap_sol_nu 194') END DO ! WRITE(*,*) 'sol_nu tmp 252: xtnu(iso_eau),qevap=', ! : xtnu(iso_eau),qevap IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtnu(iso_eau),qevap, & & 'sol_nu 244',errmax,errmaxrel) END IF !if (iso_eau.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qevap.gt.ridicule_evap) THEN CALL iso_verif_aberrant_o17(xtnu(iso_O17) & & /qevap,xtnu(iso_O18)/qevap, & & 'iso_evap_nu 443') ENDIF !if (qevap(i).gt.ridicule_evap) THEN END IF !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif END SUBROUTINE iso_evap_sol_nu ! subroutines traitant l'évaporation en surface SUBROUTINE calcul_kcin(Vsurf,KCIN) USE isotopes_mod, ONLY: tv0cin,tkcin0,tkcin1,tkcin2 IMPLICIT NONE ! calcul de kcin en fonction de Vsurf ! input: REAL Vsurf ! vent de surface ! output: REAL kcin(niso) ! coef cin ! locals INTEGER ixt ! numéro d'isotope IF ( VSURF .LT. tv0cin ) THEN DO ixt=1,niso KCIN(IXT) = tkcin0(IXT) enddo ELSE DO ixt=1,niso KCIN(IXT) = tkcin1(IXT)*VSURF + tkcin2(IXT) enddo ENDIF END SUBROUTINE calcul_kcin SUBROUTINE fractcalk(kt, ptin, pxtfra, pfraice) USE isotopes_mod, ONLY: talph1,talph2,talph3,pxtmin,iso_O17, & & fac_coeff_eq17_liq, pxtmelt, & & musi, lambda_sursat,tdifrel,talps1,talps2,fac_coeff_eq17_ice,pxtice, & & iso_eau,iso_O18,iso_HDO,iso_O17,iso_HTO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE !C------------------------------------------------------------------------- !C Calculation of the fractionation coefficient of water isotopes. !C !C March 2003 !C Sandrine Bony (LMD/CNRS), after MPI code from Georg Hoffmann (LSCE) !C------------------------------------------------------------------------- !c -- inputs: INTEGER kt ! tracor number REAL ptin ! temperature (K) !c -- outputs: REAL pxtfra ! fractionation factor for vapor/liquid condensation REAL pfraice ! fractionation factor for vapor/ice condensation !c -- local variables: REAL ZCELS, ZSATVAL parameter (ZCELS=273.15) REAL pt ! la température max(ptin,pxtmin) ! integer iso_verif_noNAN_nostop ! pour debugage !c----------------------------------------------------------- !C FRACTIONATION OVER WATER: !c----------------------------------------------------------- pt=max(ptin,pxtmin) IF ((iso_O17.gt.0).AND.(kt.EQ.iso_O17)) THEN pxtfra=(EXP(talph1(kt)/(pt**2)+talph2(kt)/pt+talph3(kt))) & **fac_coeff_eq17_liq else pxtfra=EXP(talph1(kt)/(pt**2)+talph2(kt)/pt+talph3(kt)) endif #ifdef ISOVERIF IF (pt.gt.pxtice) THEN IF (iso_verif_noNAN_nostop(pxtfra,'iso_fractcal 33') & .EQ.1) THEN ! WRITE(*,*) 'kt,pt=',kt,pt ! WRITE(*,*) 'talph1(kt),talph2(kt),talph3(kt)=', ! : talph1(kt),talph2(kt),talph3(kt) endif endif !if (pt.gt.pxtice) THEN #endif pxtfra=max(min(pxtfra,100.0),0.0) !c----------------------------------------------------------- !C FRACTIONATION OVER ICE !c----------------------------------------------------------- IF ((iso_HTO.gt.0).AND.(kt.EQ.iso_HTO)) THEN pfraice=EXP(talps1(kt)/(pt**2)+talps2(kt)/pt) elseif ((iso_HDO.gt.0).AND.(kt.EQ.iso_HDO)) THEN pfraice=EXP(talps1(kt)/(pt**2)+talps2(kt)) elseif ((iso_O18.gt.0).AND.(kt.EQ.iso_O18)) THEN pfraice=EXP(talps1(kt)/pt+talps2(kt)) elseif ((iso_O17.gt.0).AND.(kt.EQ.iso_O17)) THEN pfraice=(EXP(talps1(kt)/pt+talps2(kt))) & **fac_coeff_eq17_ice elseif ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN pfraice=1. else WRITE(*,*) 'iso_fractcal 1404: non prévu: kt=',kt #ifdef ISOVERIF stop #endif endif #ifdef ISOVERIF IF (pt.lt.pxtmelt) THEN IF (iso_verif_noNAN_nostop(pfraice,'iso_fractcal 55') & .EQ.1) THEN ! WRITE(*,*) 'kt,pt=',kt,pt ! WRITE(*,*) 'talps1(kt),talps2(kt)=', ! & talps1(kt),talps2(kt) endif endif !if (pt.lt.pxtmelt) THEN #endif pfraice=max(min(pfraice,100.0),0.0) !c----------------------------------------------------------- !C EFFECTIVE FRACTIONATION OVER ICE if NECESSARY !c----------------------------------------------------------- IF ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN pfraice=1. else !if ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN IF (pt.lt.pxtmelt) THEN ZSATVAL=musi-lambda_sursat*(pt-ZCELS) pfraice=pfraice*(ZSATVAL/(1.+pfraice*(ZSATVAL-1.) & *tdifrel(kt))) endif !if (pt.lt.pxtmelt) THEN endif !if ((kt.NE.iso_eau).OR.(iso_eau.gt.0.NE.1)) THEN #ifdef ISOVERIF IF (iso_verif_noNAN_nostop(pfraice,'iso_fractcal 73') & .EQ.1) THEN ! WRITE(*,*) 'kt,pt=',kt,pt ! WRITE(*,*) 'ZSATVAL,tdifrel(kt)=',ZSATVAL,tdifrel(kt) endif IF ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN CALL iso_verif_egalite(pfraice,1.0,'iso_fractcal 63') CALL iso_verif_egalite(pxtfra,1.0,'iso_fractcal 67') endif !if ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN #endif pfraice=max(min(pfraice,100.0),0.0) END SUBROUTINE fractcalk SUBROUTINE fractcalk_liq(kt, ptin, pxtfra) USE isotopes_mod, ONLY: pxtmin,talph1,talph2,talph3, & & fac_coeff_eq17_liq, pxtice, & & iso_eau,iso_O18,iso_HDO,iso_O17,iso_HTO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE !C------------------------------------------------------------------------- !C Calculation of the fractionation coefficient of water isotopes. !C !C March 2003 !C Sandrine Bony (LMD/CNRS), after MPI code from Georg Hoffmann (LSCE) !C------------------------------------------------------------------------- !c -- inputs: INTEGER kt ! tracor number REAL ptin ! temperature (K) !c -- outputs: REAL pxtfra ! fractionation factor for vapor/liquid condensation REAL pt ! la température max(ptin,pxtmin) ! integer iso_verif_noNAN_nostop ! pour debugage REAL alpha_max parameter (alpha_max=10.0) !c----------------------------------------------------------- !C FRACTIONATION OVER WATER: !c----------------------------------------------------------- pt=max(ptin,pxtmin) IF ((iso_O17.gt.0).AND.(kt.EQ.iso_O17)) THEN pxtfra=(EXP(talph1(kt)/(pt**2)+talph2(kt)/pt+talph3(kt))) & **fac_coeff_eq17_liq else pxtfra=EXP(talph1(kt)/(pt**2)+talph2(kt)/pt+talph3(kt)) endif #ifdef ISOVERIF IF (pt.gt.pxtice) THEN IF (iso_verif_noNAN_nostop(pxtfra,'iso_fractcal 33') & .EQ.1) THEN ! WRITE(*,*) 'kt,pt=',kt,pt ! WRITE(*,*) 'talph1(kt),talph2(kt),talph3(kt)=', ! & talph1(kt),talph2(kt),talph3(kt) endif endif !if (pt.gt.pxtice) THEN IF ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN CALL iso_verif_egalite(pxtfra,1.0,'iso_fractcal_phase 51') endif #endif pxtfra=max(min(pxtfra,alpha_max),0.0) END SUBROUTINE fractcalk_liq SUBROUTINE fractcalk_glace(kt, ptin, pfraice) USE isotopes_mod, ONLY: talps1,talps2, iso_O17,fac_coeff_eq17_ice, & pxtmelt,musi, lambda_sursat, tdifrel, & iso_eau,iso_O18,iso_HDO,iso_O17,iso_HTO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE !C------------------------------------------------------------------------- !C Calculation of the fractionation coefficient of water isotopes. !C !C March 2003 !C Sandrine Bony (LMD/CNRS), after MPI code from Georg Hoffmann (LSCE) !C------------------------------------------------------------------------- !c -- inputs: INTEGER kt ! tracor number REAL ptin ! temperature (K) !c -- outputs: REAL pfraice ! fractionation factor for vapor/ice condensation !c -- local variables: REAL ZCELS, ZSATVAL parameter (ZCELS=273.15) REAL Tmin ! valeur minimum de la température en K. Si elle est de ! l'ordre de quelques K seulement, les coeffs de fractionnement ! deviennent démesurément grands, et en plus ça fait planter l'execution à ! l'idris. parameter (Tmin=100.0) REAL pt ! la température max(ptin,Tmin) ! integer iso_verif_noNAN_nostop ! pour debugage REAL alpha_max parameter (alpha_max=10.0) pt=max(ptin,Tmin) !c----------------------------------------------------------- !C FRACTIONATION OVER ICE !c----------------------------------------------------------- IF ((iso_HTO.gt.0).AND.(kt.EQ.iso_HTO)) THEN pfraice=EXP(talps1(kt)/(pt**2)+talps2(kt)/pt) elseif ((iso_HDO.gt.0).AND.(kt.EQ.iso_HDO)) THEN pfraice=EXP(talps1(kt)/(pt**2)+talps2(kt)) elseif ((iso_O18.gt.0).AND.(kt.EQ.iso_O18)) THEN pfraice=EXP(talps1(kt)/pt+talps2(kt)) elseif ((iso_O17.gt.0).AND.(kt.EQ.iso_O17)) THEN pfraice=(EXP(talps1(kt)/pt+talps2(kt)))**fac_coeff_eq17_ice elseif ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN pfraice=1. else WRITE(*,*) 'iso_fractcal 1676: non prévu: kt=',kt #ifdef ISOVERIF stop #endif endif #ifdef ISOVERIF IF (pt.lt.pxtmelt) THEN IF (iso_verif_noNAN_nostop(pfraice,'iso_fractcal 55') & .EQ.1) THEN ! WRITE(*,*) 'kt,pt=',kt,pt ! WRITE(*,*) 'talps1(kt),talps2(kt)=', ! : talps1(kt),talps2(kt) endif endif !if (pt.lt.pxtmelt) THEN #endif pfraice=max(min(pfraice,alpha_max),0.0) ! WRITE(*,*) 'fractcalk tmp 130: kt,pfraice,fac_coeff_eq17_ice=', ! : kt,pfraice,fac_coeff_eq17_ice !c----------------------------------------------------------- !C EFFECTIVE FRACTIONATION OVER ICE if NECESSARY !c----------------------------------------------------------- IF ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN pfraice=1. else !if ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN IF (pt.lt.pxtmelt) THEN ZSATVAL=musi-lambda_sursat*(pt-ZCELS) pfraice=pfraice*(ZSATVAL/(1.+pfraice*(ZSATVAL-1.) & *tdifrel(kt))) endif !if (pt.lt.pxtmelt) THEN endif !if ((kt.NE.iso_eau).OR.(iso_eau.gt.0.NE.1)) THEN #ifdef ISOVERIF IF (iso_verif_noNAN_nostop(pfraice,'iso_fractcal 73') & .EQ.1) THEN ! WRITE(*,*) 'kt,pt=',kt,pt ! WRITE(*,*) 'ZSATVAL,tdifrel(kt)=',ZSATVAL,tdifrel(kt) endif IF ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN CALL iso_verif_egalite(pfraice,1.0,'iso_fractcal 63') endif !if ((iso_eau.gt.0).AND.(kt.EQ.iso_eau)) THEN #endif pfraice=max(min(pfraice,alpha_max),0.0) ! WRITE(*,*) 'fractcalk tmp 130: kt,pfraice=',kt,pfraice END SUBROUTINE fractcalk_glace SUBROUTINE fractcalk_vectall(ptin, pxtfra, pfraice,n) USE isotopes_mod, ONLY: talph1,talph2,talph3,tdifrel,pxtmin, & & iso_O17, iso_HTO, iso_eau, iso_O18, iso_HDO, musi, lambda_sursat, & & fac_coeff_eq17_liq,fac_coeff_eq17_ice,talps1,talps2,pxtmelt,pxtice #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE !C------------------------------------------------------------------------- !C Calculation of the fractionation coefficient of water isotopes. !C !C March 2003 !C Sandrine Bony (LMD/CNRS), after MPI code from Georg Hoffmann (LSCE) !C------------------------------------------------------------------------- ! camille risi: vectorisation sur les points de grilles !c -- inputs: INTEGER n ! nombre de mailles à traiter REAL ptin(n) ! temperature (K) !c -- outputs: REAL pxtfra(niso,n) ! fractionation factor for vapor/liquid condensation REAL pfraice(niso,n) ! fractionation factor for vapor/ice condensation !c -- local variables: REAL ZCELS, ZSATVAL(n) parameter (ZCELS=273.15) REAL pt(n) ! la température max(ptin,pxtmin) INTEGER i ! compteur: indice des mailles INTEGER ixt ! compteur: indice de l'isotope !#ifdef ISOVERIF ! integer iso_verif_noNAN_nostop ! pour debugage !#endif REAL alpha_max parameter (alpha_max=10.0) !c----------------------------------------------------------- !C FRACTIONATION OVER WATER: !c----------------------------------------------------------- DO i=1,n pt(i)=max(ptin(i),pxtmin) enddo DO ixt=1,niso ! ******************************* IF ((iso_O17.gt.0).AND.(ixt.EQ.iso_O17)) THEN DO i=1,n pxtfra(ixt,i)=(EXP(talph1(ixt)/(pt(i)**2) & +talph2(ixt)/pt(i)+talph3(ixt))) & **fac_coeff_eq17_liq enddo else DO i=1,n pxtfra(ixt,i)=EXP(talph1(ixt)/(pt(i)**2) & +talph2(ixt)/pt(i)+talph3(ixt)) enddo endif #ifdef ISOVERIF DO i=1,n IF (pt(i).gt.pxtice) THEN IF (iso_verif_noNAN_nostop(pxtfra(ixt,i), & 'iso_fractcal 33').EQ.1) THEN endif endif !if (pt(i).gt.pxtice) THEN enddo #endif DO i=1,n pxtfra(ixt,i)=max(min( & pxtfra(ixt,i),alpha_max),0.0) enddo !do i=1,n !c----------------------------------------------------------- !C FRACTIONATION OVER ICE !c----------------------------------------------------------- IF ((iso_HTO.gt.0).AND.(ixt.EQ.iso_HTO)) THEN DO i=1,n pfraice(ixt,i)=EXP(talps1(ixt)/(pt(i)**2) & +talps2(ixt)/pt(i)) enddo !do i=1,n elseif ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN DO i=1,n pfraice(ixt,i)=EXP(talps1(ixt)/(pt(i)**2) & +talps2(ixt)) enddo !do i=1,n elseif ((iso_O18.gt.0).AND.(ixt.EQ.iso_O18)) THEN DO i=1,n pfraice(ixt,i)=EXP(talps1(ixt)/pt(i)+talps2(ixt)) enddo !do i=1,n elseif ((iso_O17.gt.0).AND.(ixt.EQ.iso_O17)) THEN DO i=1,n pfraice(ixt,i)=(EXP(talps1(ixt)/pt(i) & +talps2(ixt)))**fac_coeff_eq17_ice enddo !do i=1,n elseif ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN DO i=1,n pfraice(ixt,i)=1. enddo !do i=1,n else WRITE(*,*) 'iso_fractcal 1734: non prévu: ixt=',ixt !#ifdef ISOVERIF CALL abort_physic('isotopes_routines_mod', 'iso_fractcal 1734', 1) !#endif endif #ifdef ISOVERIF DO i=1,n IF (pt(i).lt.pxtmelt) THEN IF (iso_verif_noNAN_nostop(pfraice(ixt,i), & 'iso_fractcal 55').EQ.1) THEN endif endif !if (pt(i).lt.pxtmelt) THEN enddo !do i=1,n #endif DO i=1,n pfraice(ixt,i)=max(min( & pfraice(ixt,i),alpha_max),0.0) enddo !c----------------------------------------------------------- !C EFFECTIVE FRACTIONATION OVER ICE if NECESSARY !c----------------------------------------------------------- IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN else !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN DO i=1,n IF (pt(i).lt.pxtmelt) THEN ZSATVAL(i)=musi-lambda_sursat*(pt(i)-ZCELS) pfraice(ixt,i)=pfraice(ixt,i) & *(ZSATVAL(i)/(1.+pfraice(ixt,i)*(ZSATVAL(i)-1.) & *tdifrel(ixt))) endif !if (pt(i).lt.pxtmelt) THEN enddo ! do i=1,n endif !if ((ixt.NE.iso_eau).OR.(iso_eau.gt.0.NE.1)) THEN #ifdef ISOVERIF DO i=1,n IF (iso_verif_noNAN_nostop(pfraice(ixt,i), & 'iso_fractcal 73').EQ.1) THEN ! WRITE(*,*) 'ixt,pt(i)=',ixt,pt(i) ! WRITE(*,*) 'ZSATVAL,tdifrel(ixt)=',ZSATVAL,tdifrel(ixt) endif enddo IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN DO i=1,n CALL iso_verif_egalite(pfraice(ixt,i),1.0, & 'iso_fractcal 63') CALL iso_verif_egalite(pxtfra(ixt,i),1.0, & 'iso_fractcal 67') enddo ! do i=1,n endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN #endif DO i=1,n pfraice(ixt,i)=max(min( & pfraice(ixt,i),alpha_max),0.0) enddo enddo ! do ixt=1,niso **************************** END SUBROUTINE fractcalk_vectall ! séparation entre la SUBROUTINE pour solide et celle pour liquide. SUBROUTINE fractcalk_vectall_liq(ptin, pxtfra, n) USE isotopes_mod, ONLY: pxtmin,talph1,talph2,talph3, & & iso_eau,iso_HDO, iso_O18, iso_O17,iso_HTO,fac_coeff_eq17_liq, & & pxtice #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE !C------------------------------------------------------------------------- !C Calculation of the fractionation coefficient of water isotopes. !C !C March 2003 !C Sandrine Bony (LMD/CNRS), after MPI code from Georg Hoffmann (LSCE) !C------------------------------------------------------------------------- ! camille risi: vectorisation sur les points de grilles !c -- inputs: INTEGER n ! nombre de mailles à traiter REAL ptin(n) ! temperature (K) !c -- outputs: REAL pxtfra(niso,n) ! fractionation factor for vapor/liquid condensation REAL pt(n) ! la température max(ptin,pxtmin) INTEGER i ! compteur: indice des mailles INTEGER ixt ! compteur: indice de l'isotope ! integer iso_verif_noNAN_nostop ! pour debugage REAL alpha_max parameter (alpha_max=10.0) !c----------------------------------------------------------- !C FRACTIONATION OVER WATER: !c----------------------------------------------------------- DO i=1,n pt(i)=max(ptin(i),pxtmin) enddo DO ixt=1,niso ! ******************************* IF ((iso_O17.gt.0).AND.(ixt.EQ.iso_O17)) THEN DO i=1,n pxtfra(ixt,i)=(EXP(talph1(ixt)/(pt(i)**2) & +talph2(ixt)/pt(i)+talph3(ixt))) & **fac_coeff_eq17_liq enddo else DO i=1,n pxtfra(ixt,i)=EXP(talph1(ixt)/(pt(i)**2) & +talph2(ixt)/pt(i)+talph3(ixt)) enddo endif #ifdef ISOVERIF DO i=1,n IF (pt(i).gt.pxtice) THEN IF (iso_verif_noNAN_nostop(pxtfra(ixt,i), & 'iso_fractcal 33').EQ.1) THEN endif endif !if (pt(i).gt.pxtice) THEN enddo #endif DO i=1,n pxtfra(ixt,i)=max(min( & pxtfra(ixt,i),alpha_max),0.0) enddo !do i=1,n enddo ! do ixt=1,niso **************************** END SUBROUTINE fractcalk_vectall_liq !***************************** SUBROUTINE fractcalk_vectall_ice(ptin, pfraice,n) USE isotopes_mod, ONLY: talps1,talps2, fac_coeff_eq17_ice, & pxtmelt,musi, lambda_sursat, tdifrel, & iso_eau, iso_HDO, iso_O18, iso_HTO, iso_O17 #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE !C------------------------------------------------------------------------- !C Calculation of the fractionation coefficient of water isotopes. !C !C March 2003 !C Sandrine Bony (LMD/CNRS), after MPI code from Georg Hoffmann (LSCE) !C------------------------------------------------------------------------- ! camille risi: vectorisation sur les points de grilles !c -- inputs: INTEGER n ! nombre de mailles à traiter REAL ptin(n) ! temperature (K) !c -- outputs: REAL pfraice(niso,n) ! fractionation factor for vapor/ice condensation !c -- local variables: REAL ZCELS, ZSATVAL(n) parameter (ZCELS=273.15) REAL Tmin ! valeur minimum de la température en K. Si elle est de ! l'ordre de quelques K seulement, les coeffs de fractionnement ! deviennent démesurément grands, et en plus ça fait planter l'execution à ! l'idris. parameter (Tmin=100.0) REAL pt(n) ! la température max(ptin,Tmin) INTEGER i ! compteur: indice des mailles INTEGER ixt ! compteur: indice de l'isotope ! integer iso_verif_noNAN_nostop ! pour debugage REAL alpha_max parameter (alpha_max=10.0) DO i=1,n pt(i)=max(ptin(i),Tmin) enddo DO ixt=1,niso ! **************** !c----------------------------------------------------------- !C FRACTIONATION OVER ICE !c----------------------------------------------------------- IF ((iso_HTO.gt.0).AND.(ixt.EQ.iso_HTO)) THEN DO i=1,n pfraice(ixt,i)=EXP(talps1(ixt)/(pt(i)**2) & +talps2(ixt)/pt(i)) enddo !do i=1,n elseif ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN DO i=1,n pfraice(ixt,i)=EXP(talps1(ixt)/(pt(i)**2) & +talps2(ixt)) enddo !do i=1,n elseif ((iso_O18.gt.0).AND.(ixt.EQ.iso_O18)) THEN DO i=1,n pfraice(ixt,i)=EXP(talps1(ixt)/pt(i)+talps2(ixt)) enddo !do i=1,n elseif ((iso_O17.gt.0).AND.(ixt.EQ.iso_O17)) THEN DO i=1,n pfraice(ixt,i)=(EXP(talps1(ixt)/pt(i)+talps2(ixt))) & **fac_coeff_eq17_ice enddo !do i=1,n elseif ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN DO i=1,n pfraice(ixt,i)=1. enddo !do i=1,n else WRITE(*,*) 'iso_fractcal 1954: non prévu: ixt=',ixt !#ifdef ISOVERIF CALL abort_physic('isotopes_routines_mod', 'iso_fractcal 1954', 1) !#endif endif #ifdef ISOVERIF DO i=1,n IF (pt(i).lt.pxtmelt) THEN IF (iso_verif_noNAN_nostop(pfraice(ixt,i), & 'iso_fractcal 55').EQ.1) THEN endif endif !if (pt(i).lt.pxtmelt) THEN enddo !do i=1,n #endif DO i=1,n pfraice(ixt,i)=max(min( & pfraice(ixt,i),alpha_max),0.0) enddo !c----------------------------------------------------------- !C EFFECTIVE FRACTIONATION OVER ICE if NECESSARY !c----------------------------------------------------------- IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN else !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN DO i=1,n IF (pt(i).lt.pxtmelt) THEN ZSATVAL(i)=musi-lambda_sursat*(pt(i)-ZCELS) pfraice(ixt,i)=pfraice(ixt,i) & *(ZSATVAL(i)/(1.+pfraice(ixt,i)*(ZSATVAL(i)-1.) & *tdifrel(ixt))) endif !if (pt(i).lt.pxtmelt) THEN enddo ! do i=1,n endif !if ((ixt.NE.iso_eau).OR.(iso_eau.gt.0.NE.1)) THEN #ifdef ISOVERIF DO i=1,n IF (iso_verif_noNAN_nostop(pfraice(ixt,i), & 'iso_fractcal 73').EQ.1) THEN ! WRITE(*,*) 'ixt,pt(i)=',ixt,pt(i) ! WRITE(*,*) 'ZSATVAL,tdifrel(ixt)=',ZSATVAL,tdifrel(ixt) endif enddo IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN DO i=1,n CALL iso_verif_egalite(pfraice(ixt,i),1.0, & 'iso_fractcal 63') enddo ! do i=1,n endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN #endif DO i=1,n pfraice(ixt,i)=max(min( & pfraice(ixt,i),alpha_max),0.0) enddo enddo ! do ixt=1,niso **************************** END SUBROUTINE fractcalk_vectall_ice SUBROUTINE calcul_Rsol(qsol,evap,xtsol,xt1lay,q1lay,t1lay, & & i,Rsol,klon) USE isotopes_mod, ONLY: iso_eau, iso_HDO,ridicule, & & ridicule_qsol,iso_O17,iso_O18 #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel,faccond USE isotopes_verif_mod #endif IMPLICIT NONE ! calcul de Rsol ! inputs INTEGER klon INTEGER i REAL qsol(klon) REAL evap(klon) REAL xtsol(niso,klon) REAL xt1lay(ntraciso,klon) REAL q1lay(klon) REAL t1lay(klon) ! outputs REAL Rsol(niso) ! locals INTEGER ixt REAL zxtalphal(niso),zxtalphai(niso) !#ifdef ISOVERIF !integer iso_verif_egalite_choix_nostop !real !#endif ! verif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix((qsol(i)), & & (xtsol(iso_eau,i)), & & 'iso_surf>calcul_Rsol 303',errmax,errmaxrel) CALL iso_verif_egalite_choix(q1lay(i),xt1lay(iso_eau,i), & & 'iso_surf>calcul_Rsol 387',errmax,errmaxrel) ! WRITE(*,*) 'qsol(i)=',qsol(i) ! WRITE(*,*) 'xtsol(4,i)=',xtsol(4,i) END IF !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qsol(i).gt.ridicule_qsol*1e2) THEN CALL iso_verif_aberrant(( & & xtsol(iso_HDO,i)/qsol(i))/faccond, & & 'iso_surf>calcul_Rsol 301') END IF ! if (qsol(i).gt.ridicule_qsol) THEN END IF !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qsol(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17( & & (xtsol(iso_O17,i) & & /qsol(i)),(xtsol(iso_O18,i) & & /qsol(i)),'iso_surf 401') endif !if ((qsol(i).gt.ridicule).AND.(xtsol(iso_O18,i) END IF !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif ! end verif IF (qsol(i).gt.ridicule_qsol) THEN DO ixt=1,niso Rsol(ixt)=xtsol(ixt,i)/qsol(i) END DO !do ixt=1,niso ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(Rsol(ixt),'iso_surf>calcul_Rsol 3191') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop(Rsol(iso_eau),1.0, & & 'iso_surf>calcul_Rsol 312',errmax,errmaxrel*10) & & .EQ.1) THEN WRITE(*,*) 'xtsol(ixt,i),qsol(i),ridicule_qsol=', & & xtsol(ixt,i),qsol(i),ridicule_qsol stop endif !if (iso_verif_egalite_choix_nostop(Rsol(iso_eau),1.0, ENDIF !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qsol(i).gt.ridicule_qsol*1e2) THEN CALL iso_verif_aberrant(Rsol(iso_HDO)/faccond, & & 'iso_surf>calcul_Rsol 3201') endif !if (qsol(i).gt.ridicule_qsol) THEN ENDIF !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qsol(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17(Rsol(iso_O17), & & Rsol(iso_O18),'iso_surf 437') endif !if ((qsol(i).gt.ridicule).AND.(xtsol(iso_O18,i) END IF !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif ! end verif else !if (qsol(i).gt.ridicule_rain) THEN #ifdef ISOVERIF IF (evap(i)*1800.0.gt.qsol(i)) THEN WRITE(*,*) 'iso_surf>calcul_Rsol 2989' WRITE(*,*) 'qsol(i)=',qsol(i),' mais evap(i)=',evap(i) END IF #endif IF (q1lay(i).gt.ridicule) THEN ! on suppose que ! deltaDsol=deltaDprecip~deltaDcond(INB)~deltaDNK DO ixt=1,niso CALL fractcalk(ixt,t1lay(i),zxtalphal(ixt),zxtalphai(ixt)) enddo IF (t1lay(i).ge.0.0) THEN DO ixt=1,niso Rsol(ixt)=zxtalphal(ixt)*xt1lay(ixt,i)/q1lay(i) enddo !do ixt=1,niso ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(Rsol(ixt), & & 'iso_surf>calcul_Rsol 3202') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(Rsol(iso_eau),1.0, & & 'iso_surf>calcul_Rsol 467',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qsol(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant(Rsol(iso_HDO)/faccond, & & 'iso_surf>calcul_Rsol 338') endif !if (qsol(i).gt.ridicule_qsol) THEN endif !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qsol(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17(Rsol(iso_O17) & & ,Rsol(iso_O18),'iso_surf 480') endif !if ((qsol(i).gt.ridicule).AND.(xtsol(iso_O18,i) endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif ! end verif else !if (t1lay(i).ge.0.0) THEN DO ixt=1,niso Rsol(ixt)=zxtalphai(ixt)*xt1lay(ixt,i)/q1lay(i) enddo !do ixt=1,niso ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(Rsol(ixt), & & 'iso_surf>calcul_Rsol 3207') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(Rsol(iso_eau),1.0, & & 'iso_surf>calcul_Rsol 335',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qsol(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant(Rsol(iso_HDO)/faccond, & & 'iso_surf>calcul_Rsol 338') endif !if (qsol(i).gt.ridicule_qsol) THEN endif !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qsol(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17(Rsol(iso_O17) & & ,Rsol(iso_O18),'iso_surf 513') endif !if ((qsol(i).gt.ridicule).AND.(xtsol(iso_O18,i) endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif ! end verif endif !if (t1lay(i).ge.0.0) THEN else !if (q1lay(i).gt.ridicule) THEN WRITE(*,*) 'warning: iso_surf>calcul_Rsol 3209' WRITE(*,*) 'qsol(i)=',qsol(i),' mais evap(i)=',evap(i) WRITE(*,*) 'q1lay(i)=',q1lay(i) CALL abort_physic('isotopes_routines_mod', 'iso_surf 2187', 1) END IF !if (q1lay(i).gt.ridicule) THEN END IF !if (qsol(i).gt.ridicule_rain) THEN ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(Rsol(ixt), & & 'iso_surf>calcul_Rsol 3217, sur terre') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(Rsol(iso_eau),1.0, & & 'iso_surf>calcul_Rsol 371',errmax,errmaxrel*10) END IF !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qsol(i).gt.ridicule_qsol*1e2) THEN CALL iso_verif_aberrant(Rsol(iso_HDO)/faccond, & & 'iso_surf>calcul_Rsol 374') endif !if (qsol(i).gt.ridicule_qsol) THEN END IF !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qsol(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17(Rsol(iso_O17), & & Rsol(iso_O18),'iso_surf 548') endif !if ((qsol(i).gt.ridicule).AND.(xtsol(iso_O18,i) END IF !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif ! end verif END SUBROUTINE calcul_Rsol !*************** SUBROUTINE iso_rosee_givre(xt1lay,q1lay,tsurf,t_coup,evap, & & i,xtevap,klon) USE isotopes_mod, ONLY: iso_eau, iso_HDO,ridicule,ridicule_rain, & iso_O18,iso_O17 #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: index_iso #endif IMPLICIT NONE ! inputs INTEGER i INTEGER klon REAL evap(klon) ! en kg d'eau/s REAL xt1lay(ntraciso,klon) ! en kg d'iso/kg d'air REAL q1lay(klon) ! en kg d'eau/kg d'air REAL tsurf(klon) REAL t_coup ! real dtime ! en s: typiquement: 1800s ! real Mair ! en kg d'air ! outputs REAL xtevap(ntraciso,klon) ! en kg d'iso/s ! locals INTEGER ixt REAL zxtalphal(niso),zxtalphai(niso) REAL zxtliq,zxtice ! en kg d'eau /kg d'air ! real qevap ! en kg d'eau /kg d'air !real deltaD ! juste pour vérif REAL R1eff !#ifdef ISOVERIF !integer iso_verif_aberrant_o17_nostop !real deltaO,o17excess !#endif ! WRITE(*,*) 'iso_surf>rosée 527: entrée dans rosée' IF (evap(i).EQ.0.0) THEN #ifdef ISOVERIF WRITE(*,*) 'iso_surf>rosée 528: evap(i)=',evap(i) #endif DO ixt=1,niso xtevap(ixt,i)=0.0 END DO RETURN END IF IF (q1lay(i).gt.ridicule) THEN ! verif de R1 #ifdef ISOVERIF IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant(xt1lay(iso_HDO,i)/q1lay(i), & & 'iso_surf>rosée 530') endif !if (iso_HDO.gt.0) THEN #endif ! end verif R1 ! qevap=-evap(i)*dtime/Mair ! en kg d'eau par kg d'air ! WRITE(*,*) 'iso_surf>rosé 554: qevap=',qevap ! WRITE(*,*) 'evap(i),dtime,Mair,q1lay(i)=', ! : evap(i),dtime,Mair,q1lay(i) IF (tsurf(i).ge.t_coup) THEN !WRITE(*,*) 'iso_surf>iso_rosee_givre 3181: tsurf(i)=',tsurf(i) DO ixt=1,niso ! methode 1: condensation à l'équilibre, approx 1er ordre R1eff= xt1lay(ixt,i)/q1lay(i) CALL fractcalk_liq(ixt,tsurf(i),zxtalphal(ixt)) xtevap(ixt,i)=evap(i)*zxtalphal(ixt)*R1eff ! methode 2: condensation, approche sans approximation ! CALL condiso_liq_ice(ixt,xt1lay(ixt,i),q1lay(i), ! : qevap,tsurf(i),0.0,zxtice,zxtliq) ! xtevap(ixt,i)=-zxtliq/dtime*Mair ! WRITE(*,*) 'iso_surf>rosée 545: qevap=', qevap ! WRITE(*,*) 'q1lay(i)=',q1lay(i) ! WRITE(*,*) 'zxtice=',zxtice ! WRITE(*,*) 'zxtliq=',zxtliq enddo !do ixt=1,niso #ifdef ISOTRAC DO ixt=niso+1,ntraciso R1eff= xt1lay(ixt,i)/q1lay(i) xtevap(ixt,i)=evap(i)*R1eff*zxtalphal(index_iso(ixt)) enddo #endif #ifdef ISOVERIF DO ixt=1,ntraciso CALL iso_verif_noNAN(xtevap(ixt,i),'iso_surf>rosée 557') enddo !do ixt=1,niso IF (iso_HDO.gt.0) THEN ! WRITE(*,*) 'iso_surf>rosée 554: deltaD1=', ! : deltaD(xt1lay(iso_HDO,i)/q1lay(i)) ! WRITE(*,*) 'deltaDcond=', ! : deltaD(xtevap(iso_HDO,i)/evap(i)) endif ! if (iso_HDO.gt.0)) THEN #ifdef ISOTRAC CALL iso_verif_tracnps(xtevap(1,i), & & 'iso_surf_rosée 643') #endif #endif else !if (tsurf(i).ge.t_coup) THEN !WRITE(*,*) 'iso_surf>iso_rosee_givre 3186: tsurf(i)=',tsurf(i) DO ixt=1,niso ! methode 1: condensation à l'équilibre, approx 1er ordre R1eff= xt1lay(ixt,i)/q1lay(i) CALL fractcalk_glace(ixt,tsurf(i),zxtalphai(ixt)) xtevap(ixt,i)=evap(i)*zxtalphai(ixt)*R1eff ! methode 2: condensation, approche sans approximation ! CALL condiso_liq_ice(ixt,xt1lay(ixt,i),q1lay(i), ! : qevap,tsurf(i),1.0,zxtice,zxtliq) ! xtevap(ixt,i)=-zxtice/dtime*Mair ! WRITE(*,*) 'iso_surf>rosée 558: qevap=',qevap ! WRITE(*,*) 'q1lay(i)=',q1lay(i) ! WRITE(*,*) 'zxtice=',zxtice ! WRITE(*,*) 'zxtliq=',zxtliq enddo !do ixt=1,niso #ifdef ISOTRAC DO ixt=niso+1,ntraciso R1eff= xt1lay(ixt,i)/q1lay(i) xtevap(ixt,i)=evap(i)*R1eff*zxtalphai(index_iso(ixt)) enddo #endif #ifdef ISOVERIF IF (iso_HDO.gt.0) THEN ! WRITE(*,*) 'iso_surf>rosée 571: deltaD1=', ! : deltaD(xt1lay(iso_HDO,i)/q1lay(i)) ! WRITE(*,*) 'deltaDcond=', ! : deltaD(xtevap(iso_HDO,i)/evap(i)) endif !if (iso_HDO.gt.0) THEN IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xt1lay(iso_eau,i),q1lay(i), & & 'iso_surf>iso_rosee_givre 621',errmax,errmaxrel) CALL iso_verif_egalite_choix(xtevap(iso_eau,i),evap(i), & & 'iso_surf>iso_rosee_givre 622',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN #ifdef ISOTRAC CALL iso_verif_tracnps(xtevap(1,i), & & 'iso_surf_rosée 687') #endif #endif ENDIF !if (tsurf(i).ge.0.0) THEN ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xtevap(ixt,i), & & 'iso_surf>iso_rosee_givre 3199') enddo !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtevap(iso_eau,i),evap(i), & & 'iso_surf>iso_rosee_givre 3192',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (abs(evap(i)).gt.ridicule_rain) THEN IF (iso_HDO.gt.0) THEN IF (iso_verif_aberrant_choix_nostop(xtevap(iso_HDO,i),evap(i), & & ridicule_rain,deltalim_snow,'iso_surf>iso_rosee_givre 3193').EQ.1) THEN WRITE(*,*) 'zxtalphai(iso_HDO)=',zxtalphai(iso_HDO) WRITE(*,*) 'deltaD1eff=',deltaD(xt1lay(iso_HDO,i)/q1lay(i)) WRITE(*,*) 'tsurf(i)=',tsurf(i) WRITE(*,*) 'q1lay(i)=',q1lay(i) !stop endif !if (iso_verif_aberrant_nostop endif !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (iso_verif_aberrant_o17_nostop(xtevap(iso_O17,i) & & /evap(i),xtevap(iso_O18,i) & & /evap(i),'iso_surf>iso_rosee_givre 713').EQ.1) THEN WRITE(*,*) 'tsurf(i)-t_coup=',tsurf(i)-t_coup WRITE(*,*) 'deltaO18, O17excess, 1lay', & & deltaO(xt1lay(iso_O18,i)/q1lay(i)),o17excess( & & xt1lay(iso_O17,i)/q1lay(i), & & xt1lay(iso_O18,i)/q1lay(i)) WRITE(*,*) 'zxtalphai(:)=',zxtalphai(:) stop endif endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN endif !if (evap(i).gt.ridicule_rain) THEN #endif ! end verif else !if (q1lay(i).gt.0) THEN WRITE(*,*) 'iso_surf>iso_rosee_givre 3189: evap=',evap(i) WRITE(*,*) 'q1lay(i)=',q1lay(i) CALL abort_physic('isotopes_routines_mod', 'iso_surf 2416', 1) END IF !if (q1lay(i).gt.0) THEN END SUBROUTINE iso_rosee_givre ! SUBROUTINE générique de traitement de l'évaporation des gouttes ! à ne pas modifier sauf si vous êtes surs de ce que vous faites. SUBROUTINE stewart_explicite_vectall(ncas, & & qp0,xtp0,Pqisup & & ,Pxtisup,Eqi,Pqiinf,qeff, & & Pxtiinf,xtnew,Exi,fac_ftmr, & & qs,Tevap,wt,deltaP & #ifdef ISOVERIF & ,debug,il_debug & #endif & ) USE isotopes_mod, ONLY: iso_eau, iso_HDO,expb_max,tdifrel,tdifexp, & & ridicule,thumxt1,ridicule_rain,bidouille_anti_divergence, & & iso_O17,iso_O18 #ifdef ISOVERIF ! USE isotopes_verif_mod, ONLY: O17_verif, errmax, errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! version véctorisée: sur les isotopes et sur les points de ! grille ! on s'interresse à l'isotope ixt ! on a un air de propriété (q,xt) ! on lui apporte une goutte de flux (Pqisup,Pxtisup) ! cette goutte s'évapore avec un flux Eqi ! on cherche le flux de sortie Pxtiinf et la nouvelle ! composition de l'air xtnew, sachant que qnew=q+Eqi*fac_ftmr ! declaration des variables ! **inputs INTEGER ncas REAL qp0(ncas),xtp0(niso,ncas) REAL Pxtisup(niso,ncas) REAL Pqisup(ncas),Eqi(ncas),Pqiinf(ncas) REAL qs(ncas),qeff(ncas) REAL fac_ftmr(ncas) REAL Tevap(ncas) REAL deltaP(ncas),wt(ncas) ! **outputs REAL Pxtiinf(niso,ncas) REAL xtnew(niso,ncas) REAL Exi(niso,ncas) INTEGER ixt ! **locals ! verifs #ifdef ISOVERIF !real deltaD,deltaO,O17excess REAL Rlfin(niso),Rbfin(niso) INTEGER debug ! si 1: on sort à l'écran ce qui se passe en il_debug INTEGER il_debug #endif ! intermediaires REAL h(ncas) REAL gama(niso,ncas), beta(niso,ncas), & & interm(niso,ncas) REAL alphap(niso,ncas) REAL Rl0(niso,ncas), Rb0(niso,ncas), Rl(niso,ncas), & & Rb(niso,ncas) REAL m(ncas), m0(ncas), A(ncas), qp(ncas) REAL J(niso,ncas),e(niso,ncas) REAL r_l0qp0(ncas), r_jqp0(niso,ncas), & & r_jl0(niso,ncas) REAL f(ncas),g(ncas) REAL Revap(niso,ncas) REAL Revap0(niso,ncas) REAL Revapfin(niso,ncas) REAL fv(ncas) !real ! debugage REAL real_to_double INTEGER il #ifdef ISOVERIF !integer iso_verif_aberrant_nostop !integer iso_verif_egalite_choix_nostop !integer iso_verif_egalite_nostop REAL Jtmp,etmp #endif !integer iso_verif_noNaN_nostop ! calcul d'intégrale: métode? ! si rieman: !#define rieman ! sinon: gauss. ! parsage INTEGER trace(ncas) INTEGER icas_Jsimple,ncas_Jsimple INTEGER icas_rieman,ncas_rieman INTEGER cas_Jsimple(ncas) INTEGER cas_rieman(ncas) REAL m_cas(ncas), m0_cas(ncas), & & qp0_cas(ncas),A_cas(ncas), & & beta_cas(niso,ncas),gama_cas(niso,ncas),f_cas(ncas), & & g_cas(ncas), & & Rb0_cas(niso,ncas),Rl0_cas(niso,ncas),r_l0qp0_cas(ncas), & & Exi_cas(niso,ncas),Pxtiinf_cas(niso,ncas), & & Pxtisup_cas(niso,ncas), & & xtnew_cas(niso,ncas),Pqiinf_cas(ncas), & & Eqi_cas(ncas),xtp0_cas(niso,ncas) REAL fac_ftmr_cas(ncas) ! integer ntot_cas(ncas) ! include "dimiso.h" ! quelques verifs de bilan d'eau #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNaN((Pxtisup(ixt,il)), & & 'stewart_explicite_vectall 113') CALL iso_verif_noNaN((xtp0(ixt,il)), & & 'stewart_explicite_vectall 115') enddo END DO !do il=1,ncas #endif #ifdef ISOVERIF ! WRITE(*,*) 'stewart_explicite 50: entrée' DO il=1,ncas IF (iso_verif_egalite_nostop(( & & Pqisup(il)-Eqi(il)-Pqiinf(il)),0.0, & & 'stewart_explicite 37' ).EQ.1) THEN WRITE(*,*) 'il,Pqisup(il),Eqi(il),Pqiinf(il)=', & & il,Pqisup(il),Eqi(il),Pqiinf(il) CALL abort_physic('isotopes_routines_mod', 'stewart 2554', 1) END IF !if (iso_verif_egalite END DO !do il=1,ncas IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix((Pqisup(il)), & & (Pxtisup(iso_eau,il)), & & 'stewart_explicite 38',errmax,errmaxrel) CALL iso_verif_egalite_choix(( & & xtp0(iso_eau,il)), & & (qp0(il)), & & 'stewart_explicite 58',errmax,errmaxrel) enddo !do il=1,ncas END IF !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN #endif ! WRITE(*,*) 'stewart_explicite 88: Pqisup=',Pqisup DO il=1,ncas Pqisup(il)=max(Pqisup(il),0.0) DO ixt=1,niso Pxtisup(ixt,il)=max(Pxtisup(ixt,il),0.0) enddo !do ixt=1,niso enddo !do il=1,ncas ! ***************** début des calculs ********** icas_Jsimple=0 icas_rieman=0 DO il=1,ncas ! ****************************** ! WRITE(*,*) 'stewart_explicite 78: il=',il ! WRITE(*,*) 'stewart_explicite 112: Pqisup=',Pqisup !****** traitement rapide du cas sans pluie: IF (Pqisup(il).lt.ridicule**2) THEN ! WRITE(*,*) 'stewart_explicit 96: cas pas de goutte' ! pas de pluie, pas de Pqiinf, pas de changement de vap ! cam verif ! le 21 dec 2012: on change le.0 en lt.ridicule**2 pour ! éviter des Pqisup pathologiquement petits #ifdef ISOVERIF IF ((abs(Pqiinf(il)).gt.ridicule) & & .OR.(abs(Eqi(il)).gt.ridicule)) THEN WRITE(*,*) 'stewart_explicite 39' WRITE(*,*) 'Pqisup=',Pqisup(il) WRITE(*,*) 'Eqi=',Eqi(il) WRITE(*,*) 'Eqi*fac_ftmr=',Eqi(il)*fac_ftmr(il) WRITE(*,*) 'Pqiinf=',Pqiinf(il) stop endif !if ((abs(Pqiinf).gt.ridicule) #endif ! end cam verif DO ixt=1,niso Pxtiinf(ixt,il)=0.0 enddo IF (abs(Eqi(il)*fac_ftmr(il)).gt.ridicule) THEN ! attention: pour des raisons obscures, il y a parfois ! de le réévaporation significative alors qu'il n'y a ! aucune goutte à réévaporer. ! Dans ce cas, on admet cette réévaporation obscure et ! on suppose qu'elle ne change pas la composition ! isotopique de la vapeur. IF (qp0(il).gt.ridicule) THEN DO ixt=1,niso Rb0(ixt,il)=xtp0(ixt,il)/qp0(il) enddo else !if (qp0.gt.ridicule) THEN ! il n'y a pas encore de vapeur dans le ddft. On est ! très embétté, mais on se dit que le ddft sera ! bientot rechargé par de la vapeur plus légitime DO ixt=1,niso Rb0(ixt,il)=0.0 enddo ! do ixt=1,niso IF (iso_eau.gt.0) THEN Rb0(iso_eau,il)=1.0 endif endif !if (qp0.gt.ridicule) THEN DO ixt=1,niso Exi(ixt,il)=Rb0(ixt,il)*Eqi(il) xtnew(ixt,il)=xtp0(ixt,il)+Exi(ixt,il)*fac_ftmr(il) enddo ! do ixt=1,niso else !if (abs(Eqi*fac_ftmr).gt.ridicule) THEN ! ça va, tout est logique, tous les flux d'eau sont nuls DO ixt=1,niso xtnew(ixt,il)=xtp0(ixt,il) Exi(ixt,il)=0.0 enddo !do ixt=1,niso endif !if (abs(Eqi*fac_ftmr).gt.ridicule) THEN #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNaN((Exi(ixt,il)), & & 'stewart_explicite_vectall 206') CALL iso_verif_noNaN((xtnew(ixt,il)), & & 'stewart_explicite_vectall 220') enddo IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_expilicit 125',errmax*10,errmaxrel*10) CALL iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)), & & 'stewart_explicite 143',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (xtnew(iso_eau,il)), & & (qp0(il)+Eqi(il)*fac_ftmr(il)), & & 'stewart_explicite 218',errmax*10,errmaxrel*50) endif !if (iso_eau.gt.0) THEN IF ((iso_HDO.gt.0).AND. & & (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule)) THEN CALL iso_verif_aberrant(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 214') endif !if ((iso_HDO.gt.0).AND. #endif else !if (Pqisup.EQ.0) THEN h(il)=qeff(il)/qs(il) h(il)= MAX(MIN(h(il),1.0),0.0) #ifdef ISOVERIF CALL iso_verif_positif(h(il)-thumxt1,'stewart_explicit 209') #endif ! ******** cas avec eau: Pqisup>0 ! cas ou pas d'évaporation -> tout reste pareil si pas de diff. ! en fait, tout reste pareil si h<1, car diff devient alors ! difficile IF ((Eqi(il)*fac_ftmr(il).lt.ridicule).AND.(h(il).lt.0.99)) THEN ! WRITE(*,*) 'stewart_explicite 137: cas pas d''évap' DO ixt=1,niso Pxtiinf(ixt,il)=Pqiinf(il)*(Pxtisup(ixt,il)/Pqisup(il)) Exi(ixt,il)=0.0 xtnew(ixt,il)=xtp0(ixt,il) enddo !do ixt=1,niso ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN((Pxtiinf(ixt,il)), & & 'stewart_explicite 152') CALL iso_verif_noNAN((xtnew(ixt,il)), & & 'stewart_explicite 152b') enddo #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)), & & 'stewart_explicite 143',errmax,errmaxrel) IF (iso_verif_egalite_choix_nostop( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_explicit 283',errmax*10,errmaxrel*10) & & .EQ.1) THEN WRITE(*,*) 'il=',il WRITE(*,*) 'Eqi(il)=',Eqi(il) WRITE(*,*) 'fac_ftmr(il)=',fac_ftmr(il) stop endif IF (Pqiinf(il).gt.ridicule) THEN CALL iso_verif_egalite_choix & & ((Pxtiinf(iso_eau,il)/Pqiinf(il)), & & 1.,'stewart_explicite 143',errmax,errmaxrel) endif !if (Pqiinf.gt.ridicule) THEN endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN CALL iso_verif_aberrant( & & (Pxtiinf(iso_HDO,il)/Pqiinf(il)), & & 'stewart_explicie 132') endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. IF (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN CALL iso_verif_aberrant(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 268') endif !if ((iso_HDO.gt.0).AND. endif !if (iso_HDO.gt.0) THEN IF ((debug.EQ.1).AND.(il.EQ.il_debug).AND.(Eqi(il).gt.0.)) THEN WRITE(*,*) 'stewart_explicit 302: cas evap~0' WRITE(*,*) 'deltaDv est inchangé:',deltaD( & & (xtnew(iso_HDO,il)/(qp0(il) & & +Eqi(il)*fac_ftmr(il)))) endif #endif ! end verif else !if ((Eqi(il)*fac_ftmr(il).lt.ridicule).AND.(h(il).lt.0.99)) THEN A(il)=wt(il)/deltaP(il)*fac_ftmr(il) m0(il)=max(Pqisup(il)*deltaP(il)/wt(il),0.0) m(il)=max(Pqiinf(il)*deltaP(il)/wt(il),0.0) IF (qp0(il).gt.ridicule*1e-3) THEN DO ixt=1,niso Rb0(ixt,il)=xtp0(ixt,il)/qp0(il) enddo else DO ixt=1,niso Rb0(ixt,il)=0.0 enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN Rb0(iso_eau,il)=1.0 ENDIF END IF IF (Pqisup(il).gt.ridicule*1e-3) THEN DO ixt=1,niso Rl0(ixt,il)=Pxtisup(ixt,il)/Pqisup(il) enddo !do ixt=1,niso else ! if (Pqisup(il).gt.ridicule*1e-3) THEN DO ixt=1,niso Rl0(ixt,il)=0.0 enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN Rl0(iso_eau,il)=1.0 ENDIF END IF ! if (Pqisup(il).gt.ridicule*1e-3) THEN f(il)=m(il)/m0(il) ! verifs #ifdef ISOVERIF CALL iso_verif_positif((m(il)), & & 'stewart_explicite 173') CALL iso_verif_positif((qp0(il)), & & 'stewart_explicite 174') CALL iso_verif_positif(1.0-(f(il)), & & 'stewart_explicite 373') ! WRITE(*,*) 'il,m0(il),m(il)=', il,m0(il),m(il) CALL iso_verif_positif((m0(il))- & & (m(il)),'stewart explicite 123') #endif qp0(il)=max(0.0,qp0(il)) m(il)=min(m(il),m0(il)) f(il)=min(f(il),1.0) f(il)=max(f(il),0.0) #ifdef ISOVERIF DO ixt=1,niso IF ((iso_verif_noNaN_nostop((Rl0(ixt,il)), & & 'stewart_explicit 357').EQ.1).OR. & & (iso_verif_noNaN_nostop((Rb0(ixt,il)), & & 'stewart_explicit 359').EQ.1)) THEN WRITE(*,*) 'Pxtisup(ixt,il)=',Pxtisup(ixt,il) WRITE(*,*) 'Pqisup(il)',Pqisup(il) WRITE(*,*) 'xtp0(ixt,il)=',xtp0(ixt,il) WRITE(*,*) 'qp0(il)=',qp0(il) stop ENDIF !if ((iso_verif_noNaN_nostop END DO !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (xtp0(iso_eau,il)), & & (qp0(il)),'stewart_explicit 199', & & errmax,errmaxrel) IF (iso_verif_egalite_choix_nostop( & & (Rb0(iso_eau,il)),1.0, & & 'stewart_explicit 136', & & errmax*10,errmaxrel*10).EQ.1) THEN WRITE(*,*) 'xtp0,qp0,Rb0=', & & xtp0(iso_eau,il),qp0(il),Rb0(iso_eau,il) stop endif !if (iso_verif_egalite_choix_nostop( CALL iso_verif_egalite_choix(( & & Pxtisup(iso_eau,il)),(Pqisup(il)), & & 'stewart_explicit 208',errmax,errmaxrel) IF (iso_verif_egalite_choix_nostop( & & (Rl0(iso_eau,il)),1.0, & & 'stewart_explicit 209',errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'Pxtisup(iso_eau,il),Pqisup=', & & Pxtisup(iso_eau,il),Pqisup(il) stop endif !if (iso_verif_egalite_choix_nostop( ! rajout verif 4 sept 2009 IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(Rl0(iso_HDO,il)*Pqisup(il),Pqisup(il), & & ridicule_rain,deltalim_snow,'stewart_explicite 368') endif !if (iso_HDO.gt.0) THEN ENDIF !(iso_eau.gt.0) #endif ! end verif ! **** cas où m=0 <-> f=0 IF ((f(il).lt.1e-9).OR.(Pqiinf(il).lt.ridicule/10.)) THEN !WRITE(*,*) 'stewart_explicit 137: cas f=0: il=',il DO ixt=1,niso Pxtiinf(ixt,il)=0.0 ! plus rien ne ressors ! Exi(ixt,il)=Eqi(il)*(Pxtisup(ixt,il)/Pqisup(il)) ! tout se réévapore en totalité Exi(ixt,il)=Eqi(il)* Rl0(ixt,il) ! modif le 21 dec 2012 !Exi=max(Exi,0) !xtnew=(xtp0+Rl0*m0*A) xtnew(ixt,il)=xtp0(ixt,il)+Exi(ixt,il)*fac_ftmr(il) xtnew(ixt,il)=max(xtnew(ixt,il),0.0) enddo !do ixt=1,niso ! cam verifs #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNaN((Pxtiinf(ixt,il)), & & 'stewart_explicite 259') CALL iso_verif_noNaN((Exi(ixt,il)), & & 'stewart_explicite 260') CALL iso_verif_noNaN((xtnew(ixt,il)), & & 'stewart_explicite 271') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)), & & 'stewart_explicite 168',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)), & & (Eqi(il)),'stewart_explicite 169', & & errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_expilicit 229',errmax*10,errmaxrel*10) IF (Pqiinf(il).gt.ridicule) THEN CALL iso_verif_egalite_choix & & ((Pxtiinf(iso_eau,il)/Pqiinf(il)), & & 1.,'stewart_explicite 143',errmax,errmaxrel) endif !if (Pqiinf.gt.ridicule) THEN IF (iso_verif_egalite_choix_nostop( & & (xtnew(iso_eau,il)), & & (qp0(il)+Eqi(il)*fac_ftmr(il)), & & 'stewart_explicite 218',errmax*10,errmaxrel*50) & & .EQ.1) THEN WRITE(*,*) 'xtnew=',xtnew(iso_eau,il) WRITE(*,*) 'qp=',qp0(il)+Eqi(il)*fac_ftmr(il) WRITE(*,*) 'Exi=',Exi(iso_eau,il) WRITE(*,*) 'Eqi(il)=',Eqi(il) WRITE(*,*) 'xtp0=',xtp0(iso_eau,il), & & 'qp0=',qp0(il) WRITE(*,*) 'Pxtisup=',Pxtisup(iso_eau,il), & & ' Pqisup=',pqisup(il) WRITE(*,*) 'Pxtiinf=',Pxtiinf(iso_eau,il), & & ' Pqiinf=',pqiinf(il) stop endif !if (iso_verif_egalite_choix_nostop( ! pour meilleure conv !Pxtiinf=Pqiinf !Exi=Eqi !xtnew=qp0+Eqi*fac_ftmr endif !if (iso_eau.gt.0).AND.(ixt.EQ.iso_eau) IF (iso_HDO.gt.0) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN CALL iso_verif_aberrant( & & (Pxtiinf(iso_HDO,il)/Pqiinf(il)), & & 'stewart_explicie 224') endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. IF (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN CALL iso_verif_aberrant(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 420') endif !if (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN endif !if (iso_HDO.gt.0) IF ((debug.EQ.1).AND.(il.EQ.il_debug).AND.(Eqi(il).gt.0.)) THEN WRITE(*,*) 'stewart_explicit 442: tout se réévapore' WRITE(*,*) 'Eqi(il),deltaD=',Eqi(il), & & deltaD((Exi(iso_HDO,il)/Eqi(il))) endif #endif ! end verifs else !if ((f.lt.errmaxrel).OR.(Pqiinf.lt.errmax)) THEN DO ixt=1,niso CALL FRACTCALK_liq(IXT, TEVAP(il), alphap(ixt,il)) END DO !do ixt=1,niso ! **** cas où h=1 -> equilibre ! on rajoute ce cas le 8 dec 2011 pour éviter overflow errors ! dans le cas 1er ordre pour la vapeur ! on remplace aussi le alpha en gama pour être plus précis IF ((h(il).gt.0.99).OR. & & (h(il).gt.0.98).AND.(f(il).lt.1e-3)) THEN DO ixt=1,niso interm(ixt,il)=alphap(ixt,il)*(1.0-h(il)) & & *tdifrel(IXT)**(tdifexp) gama(ixt,il)=alphap(ixt,il)*h(il)/(1.0-interm(ixt,il)) Rb(ixt,il)=(Rb0(ixt,il)*qp0(il)+Rl0(ixt,il)*m0(il)*A(il))/ & & (qp0(il)+A(il)*m0(il)*(1-f(il))+A(il)*f(il)*m0(il) & & *gama(ixt,il)) Rl(ixt,il)=gama(ixt,il)*Rb(ixt,il) Pxtiinf(ixt,il)=Pqiinf(il)*Rl(ixt,il) Pxtiinf(ixt,il)=max(Pxtiinf(ixt,il),0.0) !xtnew=xtp0+Exi*fac_ftmr xtnew(ixt,il)=Rb(ixt,il)*(qp0(il)+Eqi(il)*fac_ftmr(il)) xtnew(ixt,il)=max(xtnew(ixt,il),0.0) enddo !do ixt=1,niso IF (fac_ftmr(il).gt.0.0) THEN DO ixt=1,niso Exi(ixt,il)=(xtnew(ixt,il)-xtp0(ixt,il))/fac_ftmr(il) enddo !do ixt=1,niso else DO ixt=1,niso Exi(ixt,il)=Pxtisup(ixt,il)-Pxtiinf(ixt,il) enddo !do ixt=1,niso ENDIF !Exi=max(Exi,0) ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN((Pxtiinf(ixt,il)), & & 'stewart_explicite 209') CALL iso_verif_noNAN((Exi(ixt,il)), & & 'stewart_explicite 259') CALL iso_verif_noNAN((xtnew(ixt,il)), & & 'stewart_explicite 261') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (Rb(iso_eau,il)), & & 1.0,'stewart_explicite 232',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)),'stewart_explicite 232', & & errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)), & & (Eqi(il)),'stewart_explicite 233', & & errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_expilicit 291',errmax*10,errmaxrel*10) IF (Pqiinf(il).gt.ridicule) THEN CALL iso_verif_egalite_choix & & ((Pxtiinf(iso_eau,il)/Pqiinf(il)), & & 1.,'stewart_explicite 312',errmax,errmaxrel) endif !if (Pqiinf.gt.ridicule) THEN endif !if (iso_eau.gt.0).AND.(ixt.EQ.iso_eau) IF (iso_HDO.gt.0) THEN IF (iso_verif_aberrant_choix_nostop(Pxtiinf(iso_HDO,il),Pqiinf(il), & & ridicule_rain,deltalim_snow,'stewart_explicite 248').EQ.1) THEN WRITE(*,*) 'cas reeq totale, il=',il WRITE(*,*) 'deltaDl0=',deltaD( & & (Rl0(iso_hdo,il))) WRITE(*,*) 'deltaDb0=',deltaD( & & (Rb0(iso_hdo,il))) WRITE(*,*) 'deltaDb=',deltaD( & & (Rb(iso_hdo,il))) stop endif !if (iso_verif_aberrant_choix_nostop IF (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN CALL iso_verif_aberrant(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 499') endif !if ((iso_HDO.gt.0).AND. endif !if (iso_HDO.gt.0) THEN IF ((debug.EQ.1).AND.(il.EQ.il_debug).AND.(Eqi(il).gt.0.)) THEN WRITE(*,*) 'stewart_explicit 526: cas h~1: rééq' WRITE(*,*) 'Eqi(il),deltaD=',Eqi(il), & & deltaD((Exi(iso_HDO,il)/Eqi(il))) WRITE(*,*) 'deltaDv0,l0=',deltaD( & & (Rb0(iso_hdo,il))),deltaD( & & (Rl0(iso_hdo,il))) endif !if ((debug.EQ.1).AND.(il.EQ.il_debug)) THEN #endif ! end verifs ELSE IF ((f(il).gt.0.998).AND. & & (Eqi(il)*fac_ftmr(il).lt.1e-2*qp0(il))) then ! if ((h(il).gt.0.99).OR. !*** cas particulier pour éviter imprécisions numériques: ! dans ce cas, on fait l'hypoythèse que Rl et Rb varient peu ! -> approx au premier ordre: Revap intégré = Revap initial ! f>0.998 veut dire que la goutte varie peu, tandis que ! Eqi<1 DO ixt=1,niso interm(ixt,il)=alphap(ixt,il)*tdifrel(IXT)**(tdifexp) beta(ixt,il)=(1.0-interm(ixt,il))/(interm(ixt,il)) ! Rl(ixt,il)=Rl0(ixt,il)*puissance_double(f,beta(ixt,il)) ! on inline: Rl(ixt,il)=Rl0(ixt,il) & & *10.0**(min(max(beta(ixt,il)*log(f(il)), & & -expb_max),expb_max)) enddo #ifdef ISOVERIF CALL iso_verif_egalite_choix(( & & Rl(iso_eau,il)),1.0, & & 'stewart_explicit 722',errmax,errmaxrel) #endif ! **** calcul de Rb ! Rb=Rl0*(1-f**(beta+1))/(1-f) ! on fait autrement pour ! éviter underflow exception: DO ixt=1,niso Rb(ixt,il)=(A(il)*m0(il)*Rl0(ixt,il)*(1.0-exp & & (min(max((beta(ixt,il)+1.0)*log(f(il)), & & -expb_max),expb_max)))+qp0(il)*Rb0(ixt,il)) & & /(qp0(il)+A(il)*m0(il)*(1.0-f(il))) ! correction bug 19 mars 2010: dénom était faux Pxtiinf(ixt,il)=Pqiinf(il)*Rl(ixt,il) Pxtiinf(ixt,il)=max(Pxtiinf(ixt,il),0.0) xtnew(ixt,il)=Rb(ixt,il) & & *(qp0(il)+Eqi(il)*fac_ftmr(il)) enddo IF (fac_ftmr(il).gt.0.0) THEN DO ixt=1,niso Exi(ixt,il)=(xtnew(ixt,il)-xtp0(ixt,il)) & & /fac_ftmr(il) enddo else !if (fac_ftmr.gt.0.0) THEN DO ixt=1,niso Exi(ixt,il)=Pxtisup(ixt,il)-Pxtiinf(ixt,il) enddo ! do ixt=1,niso endif !if (fac_ftmr.gt.0.0) THEN !Exi=max(Exi,0) ! cam verifs #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN((Pxtiinf(ixt,il)), & & 'stewart_explicite 282b') CALL iso_verif_noNAN((Exi(ixt,il)), & & 'stewart_explicite 283b') CALL iso_verif_noNAN((xtnew(ixt,il)), & & 'stewart_explicite 284b') enddo !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)), & & 'stewart_explicite 305',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)), & & (Eqi(il)),'stewart_explicite 306', & & errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_expilicit 419',errmax*10,errmaxrel*10) IF (Pqiinf(il).gt.ridicule) THEN CALL iso_verif_egalite_choix & & ((Pxtiinf(iso_eau,il)/Pqiinf(il)), & & 1.,'stewart_explicite 143',errmax,errmaxrel) endif !if (Pqiinf.gt.ridicule) THEN endif !(iso_eau.gt.0).AND.(ixt.EQ.iso_eau) IF (iso_HDO.gt.0) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN CALL iso_verif_aberrant( & & (Pxtiinf(iso_HDO,il)/Pqiinf(il)), & & 'stewart_explicie 484') endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. IF (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN CALL iso_verif_aberrant(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 214') endif !if (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN endif !if ((iso_HDO.gt.0) IF ((debug.EQ.1).AND.(il.EQ.il_debug).AND.(Eqi(il).gt.0.)) THEN WRITE(*,*) 'stewart_explicit 767: cas de réévap sèche' WRITE(*,*) 'distill de Rayleigh' WRITE(*,*) 'Eqi(il),deltaD=',Eqi(il), & & deltaD((Exi(iso_HDO,il)/Eqi(il))) endif #endif ! end verifs !ELSE IF (fac_ftmr(il).gt.1e18) THEN ELSE IF (fac_ftmr(il).gt.1e24) THEN ! *** cas où flux de masse nul DO ixt=1,niso interm(ixt,il)=alphap(ixt,il)*(1.0-h(il)) & & *tdifrel(IXT)**(tdifexp) beta(ixt,il)=(1.0-interm(ixt,il))/(interm(ixt,il)) enddo #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNaN((beta(ixt,il)), & & 'stewart_explicit 269') enddo !do ixt=1,niso #endif ! WRITE(*,*) 'stewart_explicit 349: cas Mp=0' DO ixt=1,niso Rl(ixt,il)=Rl0(ixt,il)*f(il)**beta(ixt,il) Pxtiinf(ixt,il)=Pqiinf(il)*Rl(ixt,il) Pxtiinf(ixt,il)=max(Pxtiinf(ixt,il),0.0) Exi(ixt,il)=Pxtisup(ixt,il)-Pxtiinf(ixt,il) !Exi=max(Exi,0) xtnew(ixt,il)=xtp0(ixt,il) enddo ! do ixt=1,niso ! cam verifs #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN((Pxtiinf(ixt,il)), & & 'stewart_explicite 463') CALL iso_verif_noNAN((Exi(ixt,il)), & & 'stewart_explicite 465') CALL iso_verif_noNAN((xtnew(ixt,il)), & & 'stewart_explicite 467') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)), & & 'stewart_explicite 471',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)), & & (Eqi(il)),'stewart_explicite 472', & & errmax,errmaxrel) IF (iso_verif_egalite_choix_nostop( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_expilicit 472b',errmax*10,errmaxrel*10) & & .EQ.1) THEN WRITE(*,*) 'il=',il WRITE(*,*) 'f,h=',f(il),h(il) WRITE(*,*) 'fac_ftmr,Eqi=',fac_ftmr(il),Eqi(il) WRITE(*,*) 'Pqisup,Pqiinf=', & & Pqisup(il),Pqiinf(il) WRITE(*,*) 'Pxtisup,Pxtiinf', & & Pxtisup(iso_eau,il),Pxtiinf(iso_eau,il) stop endif !if (iso_verif_egalite_choix_nostop( IF (Pqiinf(il).gt.ridicule) THEN CALL iso_verif_egalite_choix & & ((Pxtiinf(iso_eau,il)/Pqiinf(il)), & & 1.,'stewart_explicite 143',errmax,errmaxrel) endif !if (Pqiinf.gt.ridicule) THEN endif !(iso_eau.gt.0).AND.(ixt.EQ.iso_eau) IF (iso_HDO.gt.0) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN CALL iso_verif_aberrant( & & (Pxtiinf(iso_HDO,il)/Pqiinf(il)), & & 'stewart_explicie 484') endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. IF (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN CALL iso_verif_aberrant(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 759') endif !if (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN endif !if (iso_HDO.gt.0) IF ((debug.EQ.1).AND.(il.EQ.il_debug).AND.(Eqi(il).gt.0.)) THEN WRITE(*,*) 'stewart_explicit 831: flux de masse vap~0' WRITE(*,*) 'Eqi(il),deltaD=',Eqi(il), & & deltaD((Exi(iso_HDO,il)/Eqi(il))) endif #endif ! end verifs else ! ELSE IF (fac_ftmr(il).gt.1e18) THEN !**** cas général ! WRITE(*,*) 'stewart_explicit 403: cas général' DO ixt=1,niso interm(ixt,il)=alphap(ixt,il)*(1.0-h(il)) & & *tdifrel(IXT)**(tdifexp) beta(ixt,il)=(1.0-interm(ixt,il))/(interm(ixt,il)) gama(ixt,il)=alphap(ixt,il)*h(il)/(1-interm(ixt,il)) enddo ! modif le 13 juin 2012: seuil 1e-2 -> 5e-2 ! le 15 juin: on revient à 1e-2 car sinon, vapeur varie trop IF (Eqi(il)*fac_ftmr(il)/qp0(il).lt.1e-2) THEN ! premier ordre pour la vapeur ! cas ajouté le 7 dec 2011 car le cas général ! compliqué donne des choses aberrantes pour ! l'O17excess ! distinction ajoutee le 8 dec 2011 pour eviter les ! underflow exceptions quand f**beta fait dans les ! 1e-300. IF (-h(il)/(1-h(il))*log(f(il)).gt.30.0) THEN DO ixt=1,niso Rl(ixt,il) = Rl0(ixt,il)*f(il)**beta(ixt,il) & & +gama(ixt,il)*Rb0(ixt,il)*(1.0-f(il)**beta(ixt,il)) enddo else !if (-h(il)/(1-h(il))*log(f(il)).gt.30.0) THEN DO ixt=1,niso Rl(ixt,il) = gama(ixt,il)*Rb0(ixt,il) enddo endif !if (-h(il)/(1-h(il))*log(f(il)).gt.30.0) THEN DO ixt=1,niso Rb(ixt,il)=((Rl0(ixt,il)-Rl(ixt,il)*f(il)) & & *Pqisup(il)*fac_ftmr(il) & & +Rb0(ixt,il)*qp0(il)) & & /(qp0(il)+Eqi(il)*fac_ftmr(il)) Pxtiinf(ixt,il)=Pqiinf(il)*Rl(ixt,il) Pxtiinf(ixt,il)=max(Pxtiinf(ixt,il),0.0) xtnew(ixt,il)=Rb(ixt,il)*(qp0(il)+Eqi(il)*fac_ftmr(il)) xtnew(ixt,il)=max(xtnew(ixt,il),0.0) IF (fac_ftmr(il).gt.0.0) THEN Exi(ixt,il)=(xtnew(ixt,il)-xtp0(ixt,il))/fac_ftmr(il) else Exi(ixt,il)=Pxtisup(ixt,il)-Pxtiinf(ixt,il) endif !Exi=max(Exi,0) Pxtiinf(ixt,il)=max(Pxtiinf(ixt,il),0.0) enddo !do ixt=1,niso #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNaN((Pxtiinf(ixt,il)), & & 'stewart_explicite 913') CALL iso_verif_noNaN((Exi(ixt,il)), & & 'stewart_explicite 915') CALL iso_verif_noNaN((xtnew(ixt,il)), & & 'stewart_explicite 917') enddo !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)), & & 'stewart_explicite 923',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)), & & (Eqi(il)),'stewart_explicite 926', & & errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_expilicit 931',errmax*10,errmaxrel*10) IF (Pqiinf(il).gt.ridicule) THEN CALL iso_verif_egalite_choix & & ((Pxtiinf(iso_eau,il)/Pqiinf(il)), & & 1.,'stewart_explicite 935',errmax,errmaxrel) endif !if (Pqiinf.gt.ridicule) THEN endif !(iso_eau.gt.0).AND.(ixt.EQ.iso_eau) IF (iso_HDO.gt.0) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN CALL iso_verif_aberrant( & & (Pxtiinf(iso_HDO,il)/Pqiinf(il)), & & 'stewart_explicie 484') endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. IF (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN IF (iso_verif_aberrant_nostop(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 947') & & .EQ.1) THEN WRITE(*,*) 'Eqi(il)*fac_ftmr(il)/qp0(il)=', & & Eqi(il)*fac_ftmr(il)/qp0(il) WRITE(*,*) 'f,h=',f(il),h(il) WRITE(*,*) 'Eqi(il)= ',Eqi(il) WRITE(*,*) 'Pqisup(il)= ',Pqisup(il) WRITE(*,*) 'fac_ftmr(il)= ',fac_ftmr(il) WRITE(*,*) 'qp0(il)= ',qp0(il) WRITE(*,*) 'beta(iso_HDO,il)= ', & & beta(iso_HDO,il) WRITE(*,*) 'gama(iso_HDO,il)= ', & & gama(iso_HDO,il) WRITE(*,*) 'deltaDl0,b0=',deltaD( & & (Rl0(iso_HDO,il))),deltaD( & & (Rb0(iso_HDO,il))) WRITE(*,*) 'deltaDl,b=',deltaD( & & (Rl(iso_HDO,il))),deltaD( & & (Rb(iso_HDO,il))) WRITE(*,*) 'deltaDe=',deltaD( & & (Exi(iso_HDO,il)/Eqi(il))) WRITE(*,*) 'deltaDgamaRb0=',deltaD( & & (gama(iso_HDO,il) & & *Rb0(iso_HDO,il))) WRITE(*,*) 'deltaDalphaRb0=',deltaD( & & (alphap(iso_HDO,il) & & *Rb0(iso_HDO,il))) stop endif endif !if (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN endif !if ((iso_HDO.gt.0) IF ((iso_O17.gt.0).AND.(iso_O18.gt.0).AND. & & (O17_verif)) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN CALL iso_verif_aberrant_o17( & & (Pxtiinf(iso_O17,il)/Pqiinf(il)), & & (Pxtiinf(iso_O18,il)/Pqiinf(il)), & & 'stewart_explicie 955') endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. endif ! if ((iso_O17.gt.0).AND.(iso_O18.gt.0).AND. IF ((debug.EQ.1).AND.(il.EQ.il_debug)) THEN WRITE(*,*) 'stewart_explicit 951: 1er ordre pour la vap' endif !if ((debug.EQ.1).AND.(il.EQ.il_debug)) THEN #endif ELSE IF ((A(il)*m0(il)/qp0(il).gt.10.0).AND. & & (1.0-f(il).lt.1e-5)) THEN ! beaucoup de liquide se réévaporant très peu dans un ! tout petit peu de vapeur. Ca peut donner des cas ! pathologiques avec des vapeurs abérrantes -> on fait ! une approx de compo constante du liquide et on se ! concentre sur l'évolution de la compo de la vapeur. fv(il)=1.0+Eqi(il)*fac_ftmr(il)/qp0(il) DO ixt=1,niso Rb(ixt,il)=(1+beta(ixt,il))/(1+beta(ixt,il) & & *gama(ixt,il))*Rl0(ixt,il) & & *(1-fv(il)**(-(1+beta(ixt,il)*gama(ixt,il)))) & & +Rb0(ixt,il)*fv(il) & & **(-(1+beta(ixt,il)*gama(ixt,il))) Rl(ixt,il)=(Rl0(ixt,il)*A(il)*m0(il) & & +Rb0(ixt,il)*qp0(il) & & -fv(il)*qp0(il)*Rb(ixt,il)) & & /(A(il)*m0(il)+qp0(il)*(1-fv(il))) Pxtiinf(ixt,il)=Pqiinf(il)*Rl(ixt,il) xtnew(ixt,il)=Rb(ixt,il)* & & (qp0(il)+Eqi(il)*fac_ftmr(il)) Pxtiinf(ixt,il)=max(Pxtiinf(ixt,il),0.0) xtnew(ixt,il)=max(xtnew(ixt,il),0.0) IF (fac_ftmr(il).gt.0.0) THEN Exi(ixt,il)=(xtnew(ixt,il) & & -xtp0(ixt,il))/fac_ftmr(il) else Exi(ixt,il)=Pxtisup(ixt,il)-Pxtiinf(ixt,il) endif enddo !do ixt=1,niso ! vérifs #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNaN((Pxtiinf(ixt,il)), & 'stewart_explicite 1092') CALL iso_verif_noNaN((Exi(ixt,il)), & & 'stewart_explicite 1095') CALL iso_verif_noNaN((xtnew(ixt,il)), & & 'stewart_explicite 1097') enddo !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)), & & 'stewart_explicite 1103',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)), & & (Eqi(il)),'stewart_explicite 926', & & errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_expilicit 1111',errmax*10,errmaxrel*10) IF (Pqiinf(il).gt.ridicule) THEN CALL iso_verif_egalite_choix & & ((Pxtiinf(iso_eau,il)/Pqiinf(il)), & & 1.,'stewart_explicite 1115',errmax,errmaxrel) endif !if (Pqiinf.gt.ridicule) THEN endif !(iso_eau.gt.0).AND.(ixt.EQ.iso_eau) IF (iso_HDO.gt.0) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN CALL iso_verif_aberrant( & & (Pxtiinf(iso_HDO,il)/Pqiinf(il)), & & 'stewart_explicie 1122') endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. IF (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN IF (iso_verif_aberrant_nostop(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 1127') & & .EQ.1) THEN WRITE(*,*) 'Eqi(il)*fac_ftmr(il)/qp0(il)=', & & Eqi(il)*fac_ftmr(il)/qp0(il) WRITE(*,*) 'f,h=',f(il),h(il) WRITE(*,*) 'deltaDl0,b0=',deltaD( & & (Rl0(iso_HDO,il))),deltaD( & & (Rb0(iso_HDO,il))) WRITE(*,*) 'deltaDl,b=',deltaD( & & (Rl(iso_HDO,il))),deltaD( & & (Rb(iso_HDO,il))) WRITE(*,*) 'deltaDe=',deltaD( & & (Exi(iso_HDO,il)/Eqi(il))) WRITE(*,*) 'deltaDgamaRb0=',deltaD( & & (gama(iso_HDO,il) & & *Rb0(iso_HDO,il))) WRITE(*,*) 'deltaDalphaRb0=',deltaD( & & (alphap(iso_HDO,il) & & *Rb0(iso_HDO,il))) stop endif endif !if (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN endif !if ((iso_HDO.gt.0) IF ((iso_O17.gt.0).AND.(iso_O18.gt.0).AND. & & (O17_verif)) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN CALL iso_verif_aberrant_o17( & & (Pxtiinf(iso_O17,il)/Pqiinf(il)), & & (Pxtiinf(iso_O18,il)/Pqiinf(il)), & & 'stewart_explicite 1156') endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. endif ! if ((iso_O17.gt.0).AND.(iso_O18.gt.0).AND. IF ((debug.EQ.1).AND.(il.EQ.il_debug)) THEN WRITE(*,*) 'stewart_explicit 1160: 1er ordre pour le liq' endif !if ((debug.EQ.1).AND.(il.EQ.il_debug)) THEN #endif else !if (Eqi(il)*fac_ftmr(il)/qp0(il).lt.5e-2) THEN !**** cas général #ifdef ISOVERIF ! WRITE(*,*) 'stewart_explicit 1170: cas général: il=',il DO ixt=1,niso CALL iso_verif_noNaN((beta(ixt,il)), & & 'stewart_explicit 269') END DO !do ixt=1,niso #endif ! if ((allow_ordre1v).AND. ! : (Eqi(il)*fac_ftmr(il).lt.1e-2*qp0(il)).AND. ! : (h.lt.0.97)) THEN ! ! peu d'apport d'évap dans la vapeur, et peu diffusf -> ! ! peu de modif de la vapeur -> on utilse l'ordre 1 pour ! ! la vapeur ! endif g(il)=(qp0(il)-A(il)*(m(il)-m0(il)))/qp0(il) ! encore un cas particulier! ! quand f très petit et surtout f**beta très petit, on ! traite à part. r_l0qp0(il)=A(il)*m0(il)/qp0(il) ! if ( ((f.lt.0.005).AND.(h.gt.0.5)) ! orig: beta.gt.7 ! : .OR.((f.lt.0.01).AND.(h.gt.0.85)) ! orig: beta.gt.8 ! : .OR.((f.lt.0.1).AND.(h.gt.0.9)) ! : .OR.((f.lt.0.15).AND.(h.gt.0.95)) ! : .OR.((f.lt.0.2).AND.(h.gt.0.98))) THEN IF ((h(il).gt.0.5).AND.(f(il).lt.0.2).AND. & & (f(il).lt.0.005+3*(h(il)-0.5)**4)) THEN ! la fonction flimite(h(il))=0.005+3*(h(il)-0.5)**4 est ! une courbe qui colle aux points de repères utilisés ! précédemment. Elle est testée das GCMiso/tests_offline/integrale/gnuplot_cas_f_petit.plot DO ixt=1,niso Rl(ixt,il) = gama(ixt,il) & & * (Rl0(ixt,il)*r_l0qp0(il)+Rb0(ixt,il)) & & / (1+r_l0qp0(il)) & & * (1-f(il)*r_l0qp0(il)) & & /(1-f(il)*r_l0qp0(il)*gama(ixt,il)) Rb(ixt,il)= (Rl0(ixt,il)*r_l0qp0(il)+Rb0(ixt,il)) & & / (1+r_l0qp0(il)) Pxtiinf(ixt,il)=Pqiinf(il)*Rl(ixt,il) Pxtiinf(ixt,il)=max(Pxtiinf(ixt,il),0.0) xtnew(ixt,il)=Rb(ixt,il)*(qp0(il)+Eqi(il)*fac_ftmr(il)) xtnew(ixt,il)=max(xtnew(ixt,il),0.0) IF (fac_ftmr(il).gt.0.0) THEN Exi(ixt,il)=(xtnew(ixt,il)-xtp0(ixt,il))/fac_ftmr(il) else Exi(ixt,il)=Pxtisup(ixt,il)-Pxtiinf(ixt,il) endif !Exi=max(Exi,0) Pxtiinf(ixt,il)=max(Pxtiinf(ixt,il),0.0) xtnew(ixt,il)=max(xtnew(ixt,il),0.0) enddo !do ixt=1,niso ! cam verifs #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN((Pxtiinf(ixt,il)), & & 'stewart_explicite 518') CALL iso_verif_noNAN((Exi(ixt,il)), & & 'stewart_explicite 520') CALL iso_verif_noNAN((xtnew(ixt,il)), & & 'stewart_explicite 522') enddo !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & & (Rl(iso_eau,il)), & & 1.0,'stewart_explicite 591', & & errmax*50,errmaxrel*10) CALL iso_verif_egalite_choix( & & (Rb(iso_eau,il)), & & 1.0,'stewart_explicite 592', & & errmax*50,errmaxrel*10) CALL iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)),'stewart_explicite 593', & & errmax*50,errmaxrel*10) CALL iso_verif_egalite_choix( & & (xtnew(iso_eau,il)), & & (qp0(il)+Eqi(il)*fac_ftmr(il)), & & 'stewart_explicite 594', & & errmax*50,errmaxrel*10) IF (iso_verif_egalite_choix_nostop( & & (Exi(iso_eau,il)), & & (Eqi(il)),'stewart_explicite 595', & & errmax*50,errmaxrel*10).EQ.1) THEN WRITE(*,*) 'il,fac_ftmr(il)=',il,fac_ftmr(il) WRITE(*,*) 'xtnew(iso_eau,il),qp(il)=', & & xtnew(iso_eau,il),qp0(il)+Eqi(il)*fac_ftmr(il) WRITE(*,*) 'xtp0(iso_eau,il),qp0(il)=', & & xtp0(iso_eau,il),qp0(il) WRITE(*,*) 'il=',il WRITE(*,*) 'xtp0(iso_eau,7),qp0(7)=', & & xtp0(iso_eau,7),qp0(7) stop endif IF (iso_verif_egalite_choix_nostop( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_expilicit 521',errmax*10,errmaxrel*10) & & .EQ.1) THEN WRITE(*,*) 'il=',il stop endif !if (iso_verif_egalite_choix_nostop IF (Pqiinf(il).gt.ridicule) THEN CALL iso_verif_egalite_choix & & ((Pxtiinf(iso_eau,il)/Pqiinf(il)), & & 1.,'stewart_explicite 143',errmax,errmaxrel) endif !if (Pqiinf.gt.ridicule) THEN ! pour meilleure convergence numérique !Pxtiinf=Pqiinf !Exi=Eqi IF (iso_verif_egalite_choix_nostop( & & (xtnew(iso_eau,il)), & & (qp0(il)+Eqi(il)*fac_ftmr(il)), & & 'stewart_explicite 605',errmax*10,errmaxrel*50) & & .EQ.1) THEN WRITE(*,*) 'xtnew=',xtnew(iso_eau,il) WRITE(*,*) 'qp=',qp0(il)+Eqi(il)*fac_ftmr(il) WRITE(*,*) 'errrel=', & & (xtnew(iso_eau,il)- & & (qp0(il)+Eqi(il)*fac_ftmr(il))) & & /(qp0(il)+Eqi(il)*fac_ftmr(il)) WRITE(*,*) 'Rb=',Rb(iso_eau,il) WRITE(*,*) 'Rl=',Rl(iso_eau,il) stop endif !if (iso_verif_egalite_choix_nostop( ! pour meilleure convergence numérique: !xtnew=qp0+Eqi*fac_ftmr endif ! if (iso_eau.gt.0).AND.(ixt.EQ.iso_eau) IF (iso_HDO.gt.0) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN IF (iso_verif_aberrant_nostop( & & (Pxtiinf(iso_HDO,il)/Pqiinf(il)), & & 'stewart_explicie 675').EQ.1) THEN WRITE(*,*) 'cas général f petit: il=',il WRITE(*,*) 'Rl,deltaDRl=',Rl(iso_HDO,il), & & deltaD((Rl(iso_HDO,il))) WRITE(*,*) 'gama,h=',gama(iso_HDO,il),h(il) WRITE(*,*) 'Rl0,Rb0,deltaDRl0,RbO=',Rl0(iso_HDO,il), & & Rb0(iso_HDO,il), & & deltaD((Rl0(iso_HDO,il))), & & deltaD((Rb0(iso_HDO,il))) WRITE(*,*) 'r_l0qp0/(1+r_l0qp0),1/(1+r_l0qp0)=', & & r_l0qp0(il)/(1.0+r_l0qp0(il)),1.0/(1.0+r_l0qp0(il)) WRITE(*,*) 'f,r_l0qp0=',f(il),r_l0qp0(il) WRITE(*,*) 'fac=',(1-f(il)*r_l0qp0(il)) & & /(1-f(il)*r_l0qp0(il)*gama(iso_HDO,il)) WRITE(*,*) 'Rl=gama*(RlO*r_l0qp0+rb0)/(1+r_l0qp0)*fac' stop endif !if iso_verif_aberrant_nostop( endif !if (Pqiinf(il).gt.ridicule_rain) THEN IF (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN CALL iso_verif_aberrant(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 912') endif !if (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN IF ((debug.EQ.1).AND.(il.EQ.il_debug).AND.(Eqi(il).gt.0.)) THEN WRITE(*,*) 'stewart_explicit 991: fcas général' WRITE(*,*) 'mais avec formule simplifiée' WRITE(*,*) 'il,Eqi(il)=',il,Eqi(il) WRITE(*,*) 'deltaD=',deltaD((Exi(iso_HDO,il)/Eqi(il))) endif endif !if (iso_HDO.gt.0) #endif ! end verifs ELSE IF (abs((g(il)**((1-2*h(il))/(1-h(il))))-1.0).lt.1e-2) THEN ! dans ce cas, le premier facteur de func (la fonction a ! intégrer) est environ constant et égal à 1. on a alors ! func=(x/m)**(-beta-1), intégrable analytiquement: ! WRITE(*,*) 'stewart_explicite 684:calcul analytique' icas_Jsimple=icas_Jsimple+1 cas_Jsimple(icas_Jsimple)=il #ifdef ISOVERIF ! WRITE(*,*) 'stewart_expl 894 tmp: '// ! : 'icas_jsimple,il=',icas_jsimple,il trace(il)=2532 #endif else !if ((g**(1-beta*gama))-1.0.lt.errmaxrel*10) THEN ! dans ce cas, la fonction est trop compliqué à intégrer ! analytiquement. On intègre donc numériquement. ! WRITE(*,*) 'stewart_explicite 684:calcul numérique' ! on traitera ce cas en vectoriel: icas_rieman=icas_rieman+1 cas_rieman(icas_rieman)=il #ifdef ISOVERIF ! WRITE(*,*) 'stewart_expl 895 tmp: '// ! : 'icas_rieman,il=',icas_rieman,il trace(il)=2533 #endif ENDIF !if ((g**(1-beta*gama))-1.0.lt.errmaxrel*10) THEN ! end verifs END IF !if (Eqi(il)*fac_ftmr(il)/qp0(il).lt.5e-2) THEN END IF !if ((h.lt.1e-3).OR.(qp0.lt.1e-8)) THEN END IF !if (h(il).gt.0.99) THEN END IF !if ((f(il).lt.1e-9).OR.(Pqiinf(il).lt.ridicule/10.)) THEN END IF !!if ((Eqi(il)*fac_ftmr(il).lt.ridicule).AND.(h(il).lt.0.99)) THEN END IF ! Pqisup.le.0 END DO ! do il=1,ncas ncas_rieman=icas_rieman ncas_Jsimple=icas_Jsimple !#ifdef ISOVERIF ! WRITE(*,*) 'stewart_explicite_vectall 812: ncas=',ncas ! WRITE(*,*) 'ncas_rieman=',ncas_rieman ! WRITE(*,*) 'ncas_Jsimple=',ncas_Jsimple !#endif !******** traitement vectoriel des cas Rieman et Jsimple: ! compression IF (ncas_Jsimple+ncas_rieman.gt.0) THEN !#ifdef ISOVERIF ! WRITE(*,*) 'stewart_explicite_vectall 873:compression_calculJ' !#endif CALL compress_calculJ(ncas,ncas_Rieman,ncas_Jsimple, & & cas_rieman,cas_Jsimple, & & m_cas,m, m0_cas,m0, & & qp0_cas,qp0, A_cas,A, & & xtp0_cas,xtp0, & & beta_cas,beta,gama_cas,gama, & ! : f_cas,f, g_cas,g,ntot_cas,h, & f_cas,f, g_cas,g,h, & & Rb0_cas,Rb0, & & Rl0_cas,Rl0, & & r_l0qp0_cas,r_l0qp0, & & Eqi_cas,Eqi, & & fac_ftmr_cas,fac_ftmr, & & Pxtisup_cas,Pxtisup, & & Pqiinf_cas,Pqiinf) #ifdef ISOVERIF ! vérif de la compression: DO icas_Jsimple=1,ncas_Jsimple CALL iso_verif_egalite_choix( & & (Pqiinf_cas(icas_Jsimple)), & & (Pqiinf(cas_Jsimple(icas_Jsimple))), & & 'stewart_explicit 912',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (qp0_cas(icas_Jsimple)), & & (qp0(cas_Jsimple(icas_Jsimple))), & & 'stewart_explicit 913',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Eqi_cas(icas_Jsimple)), & & (Eqi(cas_Jsimple(icas_Jsimple))), & & 'stewart_explicit 913',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (fac_ftmr_cas(icas_Jsimple)), & & (fac_ftmr(cas_Jsimple(icas_Jsimple))), & & 'stewart_explicit 913',errmax,errmaxrel) CALL iso_verif_egalite_choix & & ((f_cas(icas_Jsimple)), & & (m_cas(icas_Jsimple)/m0_cas(icas_Jsimple)), & & 'stewart_explicite_vectall 953 apres compression', & & errmax,errmaxrel) END DO !do icas_Jsimple=1,ncas_Jsimple DO icas_Jsimple=1,ncas_rieman CALL iso_verif_egalite_choix( & & (Pqiinf_cas(icas_Jsimple+ncas_Jsimple)), & & (Pqiinf(cas_rieman(icas_Jsimple))), & & 'stewart_explicit 918',errmax,errmaxrel) IF (iso_verif_egalite_choix_nostop( & & (f_cas(icas_Jsimple+ncas_Jsimple)), & & (m_cas(icas_Jsimple+ncas_Jsimple) & & /m0_cas(icas_Jsimple+ncas_Jsimple)), & & 'stewart_explicite_vectall 953b apres compression', & & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'icas_Jsimple,cas_rieman(icas_Jsimple)=', & & icas_Jsimple,cas_rieman(icas_Jsimple) stop ENDIF END DO !do icas_Jsimple=1,ncas_Jsimple #endif ! ************ traitement vectoriel du cas J simplifié IF (ncas_Jsimple.gt.0) THEN !#ifdef ISOVERIF ! WRITE(*,*) 'traitement vectoriel J simple: x',ncas_Jsimple !#endif DO il=1,ncas_Jsimple DO ixt=1,niso J(ixt,il)=m_cas(il)*(1.0-10.0 & & **(min(max(beta_cas(ixt,il)*log(f_cas(il))/log(10.0), & & -expb_max),expb_max)))/beta_cas(ixt,il) e(ixt,il)=0.0 #ifdef ISOVERIF CALL iso_verif_noNAN((J(ixt,il)), & & 'stewart_explicit 691') CALL iso_verif_egalite_choix((J(ixt,il)), & & (m_cas(il)/beta_cas(ixt,il) & & *(1.0-f_cas(il)**(beta_cas(ixt,il)))), & & 'stewart_explicite 998: vérif de fonction puissance', & & errmax,errmaxrel) #endif enddo !do ixt=1,niso END DO !do il=1,ncas_Jsimple END IF !if (ncas_Jsimple.gt.0) THEN ! ******* traitement vectoriel du cas Rieman (=2533) IF (ncas_rieman.gt.0) THEN icas_rieman=1+ncas_Jsimple CALL integrale_gauss_vectall & & (ncas_rieman,m_cas(icas_rieman), & & J(1,icas_rieman), & & qp0_cas(icas_rieman),A_cas(icas_rieman), & & m0_cas(icas_rieman),beta_cas(1,icas_rieman), & & gama_cas(1,icas_rieman), & ! : g_cas(icas_rieman),ntot_cas(icas_rieman)) & g_cas(icas_rieman)) ENDIF !if (ncas_rieman.gt.0) THEN ! ******* traitement vectoriel commun du cas Rieman et Jsimple #ifdef ISOVERIF ! WRITE(*,*) 'traitement vectoriel commun rieman/Jsimple' #endif DO il=1,ncas_Jsimple+ncas_rieman DO ixt=1,niso r_jqp0(ixt,il)=A_cas(il)*J(ixt,il)/qp0_cas(il) r_jl0(ixt,il)=J(ixt,il)/m0_cas(il) Rl(ixt,il)=Rl0_cas(ixt,il)*((f_cas(il)**beta_cas(ixt,il)) & & *(g_cas(il)**(-beta_cas(ixt,il)*gama_cas(ixt,il))) & & +beta_cas(ixt,il)*gama_cas(ixt,il)*r_jqp0(ixt,il) & & /f_cas(il)/g_cas(il)) & & +Rb0_cas(ixt,il)*gama_cas(ixt,il)*beta_cas(ixt,il) & & *r_jl0(ixt,il)/f_cas(il)/g_cas(il) Rb(ixt,il)=Rb0_cas(ixt,il)*(1/g_cas(il) & & - 1/g_cas(il)/g_cas(il) & & * gama_cas(ixt,il)*beta_cas(ixt,il)*r_jqp0(ixt,il)) & & +Rl0_cas(ixt,il)*r_l0qp0_cas(il)* (1.0/g_cas(il) & & -(f_cas(il)**(beta_cas(ixt,il)+1.0)) & & *(g_cas(il)**(-beta_cas(ixt,il)*gama_cas(ixt,il)-1.0)) & & -beta_cas(ixt,il)*gama_cas(ixt,il)*r_jqp0(ixt,il) & & /g_cas(il)/g_cas(il)) Pxtiinf_cas(ixt,il)=Pqiinf_cas(il)*Rl(ixt,il) Pxtiinf_cas(ixt,il)=max(Pxtiinf_cas(ixt,il),0.0) xtnew_cas(ixt,il)=Rb(ixt,il)*(qp0_cas(il)+Eqi_cas(il) & & *fac_ftmr_cas(il)) xtnew_cas(ixt,il)=max(xtnew_cas(ixt,il),0.0) IF ((fac_ftmr_cas(il).gt.0.0).AND. & & (Pqiinf_cas(il).gt.(Eqi_cas(il)+qp0_cas(il) & & /fac_ftmr_cas(il)))) THEN ! méthode (1) ! WRITE(*,*) 'stewart_explicite 739: methode 1' Exi_cas(ixt,il)=(xtnew_cas(ixt,il)-xtp0_cas(ixt,il)) & & /fac_ftmr_cas(il) else ! méthode (2): ! WRITE(*,*) 'stewart_explicite 743: methode 2' Exi_cas(ixt,il)=Pxtisup_cas(ixt,il)-Pxtiinf_cas(ixt,il) endif enddo !do ixt=1,niso #ifdef ISOVERIF DO ixt=1,niso IF ((iso_verif_noNaN_nostop(Exi_cas(ixt,il), & & 'stewart_explicite 1345').EQ.1).OR. & & (iso_verif_noNaN_nostop(Pxtiinf_cas(ixt,il), & & 'stewart_explicite 1348').EQ.1).OR. & & (iso_verif_noNaN_nostop(xtnew_cas(ixt,il), & & 'stewart_explicite 1348b').EQ.1)) THEN WRITE(*,*) 'ixt,ncas_Jsimple,il=',ixt,ncas_Jsimple,il WRITE(*,*) 'Exi_cas(ixt,il)=',Exi_cas(ixt,il) WRITE(*,*) 'Pxtiinf_cas(ixt,il)=',Pxtiinf_cas(ixt,il) WRITE(*,*) 'xtnew_cas(ixt,il)=',xtnew_cas(ixt,il) WRITE(*,*) 'xtp0_cas(ixt,il)=',xtp0_cas(ixt,il) WRITE(*,*) 'Pxtisup_cas(ixt,il)=',Pxtisup_cas(ixt,il) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'Eqi_cas(il)=',Eqi_cas(il) WRITE(*,*) 'Pqiinf_cas(il)=',Pqiinf_cas(il) WRITE(*,*) 'qp0_cas(il)=',qp0_cas(il) WRITE(*,*) 'm0_cas(il)=',m0_cas(il) WRITE(*,*) 'Rb(ixt,il)=',Rb(ixt,il) WRITE(*,*) 'Rl(ixt,il)=',Rl(ixt,il) WRITE(*,*) 'r_jqp0(ixt,il)=',r_jqp0(ixt,il) WRITE(*,*) 'r_jl0(ixt,il)=',r_jl0(ixt,il) WRITE(*,*) 'J(ixt,il)=',J(ixt,il) WRITE(*,*) 'A_cas(il)=',A_cas(il) WRITE(*,*) 'f_cas(il)=',f_cas(il) WRITE(*,*) 'g_cas(il)=',g_cas(il) WRITE(*,*) 'beta_cas(ixt,il)=',beta_cas(ixt,il) WRITE(*,*) 'gama_cas(ixt,il)=',gama_cas(ixt,il) WRITE(*,*) 'f**beta=',f_cas(il)**beta_cas(ixt,il) WRITE(*,*) 'f**(beta+1)=',f_cas(il)**(beta_cas(ixt,il)+1) WRITE(*,*) 'g*(-beta*gama)=',g_cas(il)** & & (-beta_cas(ixt,il)*gama_cas(ixt,il)) WRITE(*,*) 'g*(-beta*gama-1)=',g_cas(il)** & & (-beta_cas(ixt,il)*gama_cas(ixt,il)-1.0) stop endif enddo #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop( & & (Pxtiinf_cas(iso_eau,il)), & & (Pqiinf_cas(il)),'stewart_explicite 451', & & errmax*50,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'il=',il IF (il.le.ncas_Jsimple) THEN WRITE(*,*) 'cas_Jsimple(il)=',cas_Jsimple(il) else !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'cas_rieman(il)=',cas_rieman(il) endif !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'Rl=',Rl(iso_eau,il),' Rb=',Rb(iso_eau,il) WRITE(*,*) 'g**(1-beta*gama)=',g_cas(il)** & & (1-beta_cas(iso_eau,il)*gama_cas(iso_eau,il)) WRITE(*,*) 'j=',j(iso_eau,il) !#ifdef rieman ! WRITE(*,*) 'e=',e(iso_eau,il) !#endif ! WRITE(*,*) 'ntot_cas(il)=',ntot_cas(il) WRITE(*,*) 'gama=',gama_cas(iso_eau,il), & & ' beta=',beta_cas(iso_eau,il) IF (il.le.ncas_Jsimple) THEN WRITE(*,*) 'h=',h(cas_Jsimple(il)), & & ' Tevap=',Tevap(cas_Jsimple(il)) else !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'h=',h(cas_rieman(il)), & & ' Tevap=',Tevap(cas_rieman(il)) endif !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'f=',f_cas(il),' g=',g_cas(il) WRITE(*,*) 'r_jl0=',r_jl0(iso_eau,il), & & ' r_jqp0=',r_jqp0(iso_eau,il) WRITE(*,*) 'r_l0qp0=',r_l0qp0_cas(il) WRITE(*,*) 'm0=',m0_cas(il),' m=',m_cas(il), & & ' m0-m=',m0_cas(il)-m_cas(il) WRITE(*,*) 'A=',A_cas(il),' qp0=',qp0_cas(il) WRITE(*,*) 'Rl0=',Rl0_cas(iso_eau,il), & & ' Rb0=',Rb0_cas(iso_eau,il) WRITE(*,*) 'pond Rl0=',(f_cas(il) & & **beta_cas(iso_eau,il)) & & *(g_cas(il)**(-beta_cas(iso_eau,il) & & *gama_cas(iso_eau,il))) & & +beta_cas(iso_eau,il)*gama_cas(iso_eau,il) & & *r_jqp0(iso_eau,il)/f_cas(il)/g_cas(il) WRITE(*,*) 'pond Rb0=', & & gama_cas(iso_eau,il)*beta_cas(iso_eau,il) & & *r_jl0(iso_eau,il)/f_cas(il)/g_cas(il) WRITE(*,*) 'fac1=', & & f_cas(il)**beta_cas(iso_eau,il) WRITE(*,*) 'fac2=',g_cas(il) & & **(-beta_cas(iso_eau,il)*gama_cas(iso_eau,il)) WRITE(*,*) 't3=',beta_cas(iso_eau,il) & & *gama_cas(iso_eau,il)*r_jqp0(iso_eau,il) & & /f_cas(il)/g_cas(il) stop endif !if (iso_verif_egalite_choix_nostop( IF (iso_verif_egalite_choix_nostop( & & (xtnew_cas(iso_eau,il)), & & (qp0_cas(il)+Eqi_cas(il) & & *fac_ftmr_cas(il)),'stewart_explicite 1026', & & errmax*50,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'il=',il IF (il.le.ncas_Jsimple) THEN WRITE(*,*) 'cas_Jsimple(il)=',cas_Jsimple(il) else !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'cas_rieman(il)=',cas_rieman(il) endif !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'Rl=',Rl(iso_eau,il),' Rb=',Rb(iso_eau,il) WRITE(*,*) 'g**(1-beta*gama)=',g_cas(il)** & & (1-beta_cas(iso_eau,il)*gama_cas(iso_eau,il)) WRITE(*,*) 'J=',J(iso_eau,il) !#ifdef rieman ! WRITE(*,*) 'e=',e(iso_eau,il) !#endif ! WRITE(*,*) 'ntot_cas(il)=',ntot_cas(il) WRITE(*,*) 'gama=',gama_cas(iso_eau,il), & & ' beta=',beta_cas(iso_eau,il) IF (il.le.ncas_Jsimple) THEN WRITE(*,*) 'h=',h(cas_Jsimple(il)), & & ' Tevap=',Tevap(cas_Jsimple(il)) else !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'h=',h(cas_rieman(il)), & & ' Tevap=',Tevap(cas_rieman(il)) endif !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'f=',f_cas(il),' g=',g_cas(il) WRITE(*,*) 'r_jl0=',r_jl0(iso_eau,il), & & ' r_jqp0=',r_jqp0(iso_eau,il) WRITE(*,*) 'r_l0qp0=',r_l0qp0_cas(il) WRITE(*,*) 'm0=',m0_cas(il),' m=',m_cas(il) WRITE(*,*) 'A=',A_cas(il),' qp0=',qp0_cas(il) WRITE(*,*) 'Rl0=',Rl0_cas(iso_eau,il), & & ' Rb0=',Rb0_cas(iso_eau,il) WRITE(*,*) 'pond Rl0=',r_l0qp0_cas(il)* (1/g_cas(il) & & -(f_cas(il)**(beta_cas(iso_eau,il)+1)) & & *(g_cas(il)**(-beta_cas(iso_eau,il) & & *gama_cas(iso_eau,il)-1)) & & -beta_cas(iso_eau,il)*gama_cas(iso_eau,il) & & *r_jqp0(iso_eau,il) & & /g_cas(il)/g_cas(il)) WRITE(*,*) 'pond Rb0=',(1/g_cas(il) & & - 1/g_cas(il)/g_cas(il) * gama_cas(iso_eau,il) & & *beta_cas(iso_eau,il)*r_jqp0(iso_eau,il)) stop endif !if (iso_verif_egalite_choix_nostop( IF ((iso_verif_egalite_choix_nostop( & & (Exi_cas(iso_eau,il)), & & (Eqi_cas(il)),'stewart_explicite 777', & & errmax*800,errmaxrel*800).EQ.1).OR. & & (iso_verif_egalite_choix_nostop( & & (Exi_cas(iso_eau,il)*fac_ftmr_cas(il)), & & (Eqi_cas(il)*fac_ftmr_cas(il)), & & 'stewart_explicite 586', & & errmax*3000,errmaxrel*800).EQ.1)) THEN WRITE(*,*) 'il=',il IF (il.le.ncas_Jsimple) THEN WRITE(*,*) 'cas_Jsimple(il)=',cas_Jsimple(il) else !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'cas_rieman(il)=',cas_rieman(il) endif !if (il.le.ncas_Jsimple) THEN WRITE(*,*) 'g**(1-beta*gama)=',g_cas(il) & & **(1-beta_cas(iso_eau,il)*gama_cas(iso_eau,il)) WRITE(*,*) 'Eqi,Exi,fac_ftmr,Pqiinf=',Eqi_cas(il), & & Exi_cas(iso_eau,il),fac_ftmr_cas(il),Pqiinf_cas(il) WRITE(*,*) 'xtnew(iso_eau,il),xtp0(iso_eau,il)=', & & xtnew_cas(iso_eau,il),xtp0_cas(iso_eau,il) stop endif endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qp0_cas(il)+Eqi_cas(il)*fac_ftmr_cas(il) & & .gt.ridicule) THEN IF (iso_verif_aberrant_nostop(( & & xtnew_cas(iso_HDO,il)/(qp0_cas(il)+Eqi_cas(il) & & *fac_ftmr_cas(il))), & & 'stewart_explicite 1316').EQ.1) THEN WRITE(*,*) 'il,fac_ftmr_cas(il)=',il,fac_ftmr_cas(il) WRITE(*,*) 'h(il)=',h(il) WRITE(*,*) 'alphap(iso_HDO,il)=',alphap(iso_HDO,il) WRITE(*,*) 'Di/D)^n=',tdifrel(iso_HDO)**(tdifexp) WRITE(*,*) 'qp0_cas(il)=',qp0_cas(il) WRITE(*,*) 'Eqi_cas(il)=',Eqi_cas(il) WRITE(*,*) 'Pqiinf_cas(il)=',Pqiinf_cas(il) WRITE(*,*) 'm0_cas(il)=',m0_cas(il) WRITE(*,*) 'deltaD(Rb0(iso_HDO,il))=', & & deltaD(Rb0(iso_HDO,il)) WRITE(*,*) 'deltaD(Rl0(iso_HDO,il))=', & & deltaD(Rl0(iso_HDO,il)) WRITE(*,*) 'deltaD(Rb(iso_HDO,il))=', & & deltaD(Rb(iso_HDO,il)) WRITE(*,*) 'deltaD(Rl(iso_HDO,il))=', & & deltaD(Rl(iso_HDO,il)) WRITE(*,*) 'r_jqp0(iso_HDO,il)=',r_jqp0(iso_HDO,il) WRITE(*,*) 'r_jl0(iso_HDO,il)=',r_jl0(iso_HDO,il) WRITE(*,*) 'J(iso_HDO,il)=',J(iso_HDO,il) WRITE(*,*) 'A_cas(il)=',A_cas(il) WRITE(*,*) 'f_cas(il)=',f_cas(il) WRITE(*,*) 'g_cas(il)=',g_cas(il) WRITE(*,*) 'beta_cas(iso_HDO,il)=', & & beta_cas(iso_HDO,il) WRITE(*,*) 'gama_cas(iso_HDO,il)=', & & gama_cas(iso_HDO,il) stop endif endif !if (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN endif !if (iso_HDO.gt.0) #endif enddo !do il=1,ncas_Jsimple+ncas_rieman CALL uncompress_calculJ(ncas,ncas_rieman,ncas_Jsimple, & & cas_rieman,cas_Jsimple,Exi_cas,Exi, & & xtnew_cas,xtnew,Pxtiinf_cas,Pxtiinf) #ifdef ISOVERIF ! vérif de la décompression: DO icas_Jsimple=1,ncas_Jsimple DO ixt=1,niso CALL iso_verif_egalite_choix( & & (xtnew_cas(ixt,icas_Jsimple)), & & (xtnew(ixt,cas_Jsimple(icas_Jsimple))), & & 'stewart_explicit 1046',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi_cas(ixt,icas_Jsimple)), & & (Exi(ixt,cas_Jsimple(icas_Jsimple))), & & 'stewart_explicit 1047',errmax,errmaxrel) enddo !do ixt=1,niso END DO !do icas_Jsimple=1,ncas_Jsimple DO icas_Jsimple=1,ncas_rieman DO ixt=1,niso CALL iso_verif_egalite_choix( & & (xtnew_cas(ixt,icas_Jsimple+ncas_Jsimple)), & & (xtnew(ixt,cas_rieman(icas_Jsimple))), & & 'stewart_explicit 1054',errmax,errmaxrel) CALL iso_verif_egalite_choix( & & (Exi_cas(ixt,icas_Jsimple+ncas_Jsimple)), & & (Exi(ixt,cas_rieman(icas_Jsimple))), & & 'stewart_explicit 1055',errmax,errmaxrel) enddo !do ixt=1,niso END DO !do icas_Jsimple=1,ncas_Jsimple #endif ! cam verifs #ifdef ISOVERIF DO icas_Jsimple=1,ncas_Jsimple+ncas_rieman IF (icas_Jsimple.le.ncas_Jsimple) THEN il=cas_Jsimple(icas_Jsimple) else il=cas_rieman(icas_Jsimple-ncas_Jsimple) endif DO ixt=1,niso IF ((iso_verif_noNaN_nostop((Pxtiinf(ixt,il)), & & 'stewart_explicite 618').EQ.1).OR. & & (iso_verif_noNaN_nostop((Exi(ixt,il)), & & 'stewart_explicite 620').EQ.1).OR. & & (iso_verif_noNaN_nostop((xtnew(ixt,il)), & & 'stewart_explicite 622').EQ.1)) THEN WRITE(*,*) 'ixt,il=',ixt,il WRITE(*,*) 'icas_Jsimple,ncas_Jsimple=', & & icas_Jsimple,ncas_Jsimple stop endif !if ((iso_verif_noNaN_nostop enddo !do ixt=1,niso enddo !do icas_Jsimple=1,ncas_Jsimple+ncas_rieman #endif #ifdef ISOVERIF DO icas_Jsimple=1,ncas_Jsimple+ncas_rieman IF (icas_Jsimple.le.ncas_Jsimple) THEN il=cas_Jsimple(icas_Jsimple) else il=cas_rieman(icas_Jsimple-ncas_Jsimple) endif IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)),'stewart_explicite 1105', & & errmax*50,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'icas_Jsimple,il,trace(il)=', & & icas_Jsimple,il,trace(il) WRITE(*,*) 'Pqiinf_cas(icas_Jsimple)=', & & Pqiinf_cas(icas_Jsimple) WRITE(*,*) 'Pxtiinf_cas(iso_eau,icas_Jsimple)=', & & Pxtiinf_cas(iso_eau,icas_Jsimple) stop endif !Pxtiinf=Pqiinf IF ((iso_verif_egalite_choix_nostop( & & (Exi(iso_eau,il)), & & (Eqi(il)),'stewart_explicite 778', & & errmax*800,errmaxrel*800).EQ.1).OR. & & (iso_verif_egalite_choix_nostop( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_explicite 587', & & errmax*3000,errmaxrel*800).EQ.1)) THEN WRITE(*,*) 'il,icas_Jsimple=',il,icas_Jsimple WRITE(*,*) 'g**(1-beta*gama)=', & & g(il)**(1-beta(iso_eau,il)*gama(iso_eau,il)) WRITE(*,*) 'Eqi,Exi,fac_ftmr=', & & Eqi(il),Exi(iso_eau,il),fac_ftmr(il) stop endif ! le 6 dec 2011: on relache ridicule en ridicule*2 IF (Pqiinf(il).gt.ridicule*2) THEN IF (iso_verif_egalite_choix_nostop & & ((Pxtiinf(iso_eau,il)/Pqiinf(il)),1., & & 'stewart_explicite 716', & & errmax*10,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'il=',il WRITE(*,*) 'Pqiinf,Pxtiinf=', & & Pqiinf(il),Pxtiinf(iso_eau,il) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'f,h(il)=',f(il),h(il) WRITE(*,*) 'Eqi(il)*fac_ftmr(il)/qp0(il)=', & & Eqi(il)*fac_ftmr(il)/qp0(il) WRITE(*,*) 'g(il)=',g(il) stop endif !if (iso_verif_egalite_choix_nostop endif !if (Pqiinf.gt.ridicule) THEN IF (iso_verif_egalite_choix_nostop( & & (xtnew(iso_eau,il)), & & (qp0(il)+Eqi(il)*fac_ftmr(il)), & & 'stewart_explicite 732',errmax*10,errmaxrel*50) & & .EQ.1) THEN WRITE(*,*) 'icas_Jsimple,il,trace(il)=', & & icas_Jsimple,il,trace(il) WRITE(*,*) 'xtnew_cas(iso_eau,icas_Jsimple)=', & & xtnew_cas(iso_eau,icas_Jsimple) WRITE(*,*) 'xtnew(iso_eau,il)=', & & xtnew(iso_eau,il) WRITE(*,*) 'qp0(il)=',qp0(il) WRITE(*,*) 'qp0_cas(icas_Jsimple)=', & & qp0(icas_Jsimple) WRITE(*,*) 'Eqi(il)=',Eqi(il) WRITE(*,*) 'Eqi_cas(icas_Jsimple)=', & & Eqi(icas_Jsimple) WRITE(*,*) 'fac_ftmr(il)=',fac_ftmr(il) WRITE(*,*) 'fac_ftmr_cas(icas_Jsimple)=', & & fac_ftmr_cas(icas_Jsimple) stop endif ! pour meilleure convergence numérique: IF (bidouille_anti_divergence) THEN Exi(iso_eau,il)=Eqi(il) xtnew(iso_eau,il)=qp0(il)+Eqi(il)*fac_ftmr(il) Pxtiinf(iso_eau,il)=Pqiinf(il) endif endif ! if if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) the IF (iso_HDO.gt.0) THEN IF (Pqiinf(il).gt.ridicule_rain) THEN IF (iso_verif_aberrant_choix_nostop(Pxtiinf(iso_HDO,il),Pqiinf(il),ridicule_rain,deltalim_snow, & & 'stewart_explicite 871').EQ.1) THEN WRITE(*,*) 'deltaDl0=',deltaD( & & (Rl0(iso_HDO,il))) WRITE(*,*) 'deltaDb0=',deltaD( & & (Rb0(iso_HDO,il))) stop endif !if (iso_verif_aberrant_nostop( endif !if (Pqiinf(il).gt.ridicule_rain) THEN IF (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN CALL iso_verif_aberrant(( & & xtnew(iso_HDO,il)/(qp0(il)+Eqi(il) & & *fac_ftmr(il))),'stewart_explicite 1461') endif !if (qp0(il)+Eqi(il)*fac_ftmr(il).gt.ridicule) THEN endif !if (iso_HDO.gt.0) IF ((debug.EQ.1).AND.(il.EQ.il_debug).AND.(Eqi(il).gt.0.)) THEN WRITE(*,*) 'stewart_explicit 1558: cas avec calcul J' WRITE(*,*) 'Eqi(il),deltaD=',Eqi(il), & & deltaD((Exi(iso_HDO,il)/Eqi(il))) IF (icas_Jsimple.le.ncas_Jsimple) THEN WRITE(*,*) 'calcul J par simple' else WRITE(*,*) 'calcul J par Rieman' endif WRITE(*,*) 'stewart_explict 1051: h(il)=',h(il) WRITE(*,*) 'f(il)=',f(il) WRITE(*,*) 'Eqi(il)*fac_ftmr(il)/qp0(il)=', & & Eqi(il)*fac_ftmr(il)/qp0(il) WRITE(*,*) 'Pqisup,deltaD=',Pqisup(il),deltaD( & & (Pxtisup(iso_HDO,il)/Pqisup(il))) WRITE(*,*) 'qp0,deltaD=',qp0(il),deltaD( & & (xtp0(iso_HDO,il)/qp0(il))) WRITE(*,*) 'f_cas(icas)=',f_cas(icas_Jsimple) WRITE(*,*) 'g_cas(icas)=',g_cas(icas_Jsimple) WRITE(*,*) 'beta_cas(icas)=', & & beta_cas(iso_HDO,icas_Jsimple) WRITE(*,*) 'gama_cas(icas)=', & & gama_cas(iso_HDO,icas_Jsimple) WRITE(*,*) 'r_jqp0(icas)=', & & r_jqp0(iso_HDO,icas_Jsimple) WRITE(*,*) 'r_jl0(icas)=',r_jl0(iso_HDO,icas_Jsimple) WRITE(*,*) 'r_l0qp0(icas)=', & & r_l0qp0_cas(icas_Jsimple) WRITE(*,*) 'J(icas)=',J(iso_HDO,icas_Jsimple) WRITE(*,*) 'deltaDl0(icas)=',deltaD & & ((Rl0_cas(iso_HDO,icas_Jsimple))) WRITE(*,*) 'deltaDb0(icas)=',deltaD & & ((Rb0_cas(iso_HDO,icas_Jsimple))) WRITE(*,*) 'deltaDl(icas)=',deltaD & & ((Rl(iso_HDO,icas_Jsimple))) WRITE(*,*) 'deltaDb(icas)=',deltaD & & ((Rb(iso_HDO,icas_Jsimple))) WRITE(*,*) 'Pqiinf_cas(icas)=', & & Pqiinf_cas(icas_Jsimple) WRITE(*,*) 'Eqi_cas(icas)=',Eqi_cas(icas_Jsimple) WRITE(*,*) 'qp0_cas(icas)=',qp0_cas(icas_Jsimple) WRITE(*,*) 'fac_ftmr_cas(icas)=', & & fac_ftmr_cas(icas_Jsimple) endif !if ((debug.EQ.1).AND.(il.EQ.il_debug)) THEN enddo !do il=1,ncas_Jsimple+ncas_rieman #endif END IF !if (ncas_rieman+ncas_Jsimple.gt.0) THEN #ifdef ISOVERIF WRITE(*,*) 'stewart_explicite vectall 1179: fin' #endif END SUBROUTINE stewart_explicite_vectall SUBROUTINE stewart_glace_vectall(ncas,q,xt,Pqisup & & ,Pxtisup,Eqi,Pqiinf & & ,Pxtiinf,xtnew,Exi,fac_ftmr, & & Tevap) USE isotopes_mod, ONLY: iso_eau, iso_HDO,bidouille_anti_divergence, & & ridicule,ridicule_rain #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! idem que stewart_loop, mais pour la rrévap de la glace. ! On n'applique donc pas la formule de stewart, on applique ! juste le bilan de masse et une réévap sans effets cinétaiques ! declaration des variables ! **inputs INTEGER ncas REAL q(ncas),xt(niso,ncas) REAL Pxtisup(niso,ncas) REAL Pqisup(ncas) REAL Eqi(ncas),Pqiinf(ncas) REAL fac_ftmr(ncas) REAL Tevap(ncas) ! **outputs REAL xtnew(niso,ncas) REAL Pxtiinf(niso,ncas) REAL Exi(niso,ncas) ! **locals REAL zxtalphai(niso,ncas) REAL f(ncas) INTEGER ixt,il ! WRITE(*,*) 'sttewart_glace 39: entrée' ! quelques verifs de bilan d'eau #ifdef ISOVERIF DO il=1,ncas CALL iso_verif_egalite( & & (Pqisup(il)-Eqi(il)-Pqiinf(il)),0.0, & & 'stewart_glace 37') IF (iso_eau.gt.0) THEN CALL iso_verif_egalite((Pqisup(il)), & & (Pxtisup(iso_eau,il)),'stewart_loop 52') CALL iso_verif_egalite((xt(iso_eau,il)), & & (q(il)),'stewart_loop 58') ENDIF !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN END DO !do il=1,ncas #endif ! fin des verifs ! ***************** début des calculs ********** DO il=1,ncas ! traitement rapide de quelques cas particuliers: IF (Pqisup(il).EQ.0) THEN ! pas de pluie, pas de Pqiinf, pas de changement de vap ! cam verif #ifdef ISOVERIF IF ((abs(Pqiinf(il)).gt.ridicule) & & .OR.(abs(Eqi(il)).gt.ridicule)) THEN WRITE(*,*) 'stewart_loop 39' WRITE(*,*) 'Pqisup=',Pqisup(il) WRITE(*,*) 'Eqi=',Eqi(il) WRITE(*,*) 'Pqiinf=',Pqiinf(il) stop endif #endif ! end cam verif DO ixt=1,niso xtnew(ixt,il)=xt(ixt,il) Pxtiinf(ixt,il)=0.0 Exi(ixt,il)=0.0 enddo !do ixt=1,niso else !if (Pqisup(il).EQ.0) THEN ! calcul du coeff de fractionnement DO ixt=1,niso CALL fractcalk_glace(ixt,Tevap(il),zxtalphai(ixt,il)) END DO ! calcul de f=la fraction résiduelle f(il)=Pqiinf(il)/Pqisup(il) ! calcul de Pxtiinf et Exi ! séparation en 2 cas pour une meilleure convergence numérique IF (f(il).lt.0.9) THEN DO ixt=1,niso Pxtiinf(ixt,il)=Pxtisup(ixt,il)*Pqiinf(il)*zxtalphai(ixt,il) & & /(Eqi(il)+Pqiinf(il)*zxtalphai(ixt,il)) Exi(ixt,il)=Pxtisup(ixt,il)-Pxtiinf(ixt,il) enddo !do ixt=1,niso else DO ixt=1,niso Exi(ixt,il)=Eqi(il)*Pxtisup(ixt,il) & & /(Eqi(il)+Pqiinf(il)*zxtalphai(ixt,il)) Pxtiinf(ixt,il)=Pxtisup(ixt,il)-Exi(ixt,il) enddo !do ixt=1,niso END IF !if (f.lt.0.9) THEN ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN((Exi(ixt,il)), & & 'stewart_glace 102') CALL iso_verif_noNAN((Pxtiinf(ixt,il)), & & 'stewart_glace 111') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite((Exi(iso_eau,il)), & & (Eqi(il)),'stewart_glace 101') CALL iso_verif_egalite((Pxtiinf(iso_eau,il)), & & (Pqiinf(il)),'stewart_glace 110') END IF !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN #endif IF ((bidouille_anti_divergence).AND. & & (iso_eau.gt.0)) THEN ! assurer la convergence numérique pour ixt=4: Exi(iso_eau,il)=Eqi(il) Pxtiinf(iso_eau,il)=Pqiinf(il) END IF !if ((bidouille_anti_divergence).AND.(iso_eau.gt.0) ! calcul de xtnew DO ixt=1,niso xtnew(ixt,il)=xt(ixt,il)+Exi(ixt,il)*fac_ftmr(il) xtnew(ixt,il)=max(0.0,xtnew(ixt,il)) END DO ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNaN((xtnew(ixt,il)), & & 'stewart_glace 140') END DO !do ixt=1,niso IF ((iso_HDO.gt.0).AND. & & (Pqisup(il).gt.ridicule_rain)) THEN CALL iso_verif_aberrant(( & & Pxtiinf(iso_HDO,il)/Pqiinf(il)),'stewart_glace 175') ENDIF !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN #endif ! end verif END IF !if (Pqisup(il).EQ.0) THEN END DO !do il=1,ncas ! ************ fin des calculs *************** ! WRITE(*,*) 'sttewart_glace 155: sortie' END SUBROUTINE stewart_glace_vectall ! SUBROUTINE stewart_glace_vectiso -> supprimée, pas utilisée nullepart SUBROUTINE stewart_sublim_nofrac_vectall(ncas,q & & ,xt,Pqisup,Pxtisup & & ,Eqi,Pqiinf & & ,Pxtiinf,xtnew,Exi & & ,fac_ftmr) USE isotopes_mod, ONLY: iso_eau, iso_HDO,bidouille_anti_divergence, & & Rdefault,ridicule,ridicule_rain #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! rrévap de la glace. ! on suppose que pas de ractionnement lors de la sublimation de ! la glace ! declaration des variables ! **inputs INTEGER ncas REAL q(ncas),xt(niso,ncas) REAL Pxtisup(niso,ncas) REAL Pqisup(ncas) REAL Eqi(ncas),Pqiinf(ncas) REAL fac_ftmr(ncas) ! **outputs REAL xtnew(niso,ncas) REAL Pxtiinf(niso,ncas) REAL Exi(niso,ncas) ! **locals INTEGER il !real ! debuggage REAL Rb0(niso,ncas) REAL real_to_double INTEGER ixt !#ifdef ISOVERIF !integer iso_verif_egalite_nostop !integer iso_verif_egalite_choix_nostop !#endif ! WRITE(*,*) 'sttewart_glace 39: entrée' ! quelques verifs de bilan d'eau #ifdef ISOVERIF DO il=1,ncas IF (iso_verif_egalite_nostop(( & & Pqisup(il)-Eqi(il)-Pqiinf(il)),0.0, & & 'stewart_sublim_nofrac 37').EQ.1) THEN WRITE(*,*) 'il,Pqisup(il),Eqi(il),Pqiinf(il)=', & & il,Pqisup(il),Eqi(il),Pqiinf(il) stop END IF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite((Pqisup(il)), & & (Pxtisup(iso_eau,il)), & & 'stewart_sublim_nofrac 38') CALL iso_verif_egalite((xt(iso_eau,il)), & & (q(il)), & & 'stewart_sublim_nofrac 39') END IF !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) then ! Camille 9 mars 2023: moins stricte pour condensat CALL iso_verif_aberrant_choix(Pxtisup(iso_HDO,il),Pqisup(il), & & ridicule_rain,deltalim_snow, 'stewart_sublim_nofrac 40') END IF !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. END DO !do il=1,ncas #endif ! fin des verifs ! ***************** début des calculs ********** DO il=1,ncas ! traitement rapide de quelques cas particuliers: IF (Pqisup(il).le.0) THEN ! pas de pluie, pas de Pqiinf, pas de changement de vap ! cam verif #ifdef ISOVERIF IF ((abs(Pqiinf(il)).gt.ridicule) & & .OR.(abs(Eqi(il)).gt.ridicule)) THEN WRITE(*,*) 'stewart_sublim 57' WRITE(*,*) 'Pqisup=',Pqisup(il) WRITE(*,*) 'Eqi=',Eqi(il) WRITE(*,*) 'Pqiinf=',Pqiinf(il) stop endif #endif ! end cam verif DO ixt=1,niso Pxtiinf(ixt,il)=0.0 enddo IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN Pxtiinf(iso_eau,il)=Pqiinf(il) endif IF (abs(Eqi(il)*fac_ftmr(il)).gt.ridicule) THEN ! attention: pour des raisons obscures, il y a parfois ! de le réévaporation significative alors qu'il n'y a ! aucun cristal à réévaporer. ! Dans ce cas, on admet cette réévaporation obscure et ! on suppose qu'elle ne change pas la composition ! isotopique de la vapeur. IF (q(il).gt.ridicule) THEN DO ixt=1,niso Rb0(ixt,il)=xt(ixt,il)/q(il) enddo else !if (qp0.gt.ridicule) THEN ! il n'y a pas encore de vapeur dans le ddft. On est ! très embétté, mais on se dit que le ddft sera ! bientot rechargé par de la vapeur plus légitime DO ixt=1,niso Rb0(ixt,il)=0.0 enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN Rb0(iso_eau,il)=1.0 endif endif !if (qp0.gt.ridicule) THEN DO ixt=1,niso Exi(ixt,il)=Rb0(ixt,il)*Eqi(il) xtnew(ixt,il)=xt(ixt,il)+Exi(ixt,il)*fac_ftmr(il) enddo !do ixt=1,niso else !if (abs(Eqi*fac_ftmr).gt.ridicule) THEN ! ça va, tout est logique, tous les flux d'eau sont nuls DO ixt=1,niso xtnew(ixt,il)=xt(ixt,il) Exi(ixt,il)=0.0 enddo !do ixt=1,niso endif !if (abs(Eqi*fac_ftmr).gt.ridicule) THEN #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (Exi(iso_eau,il)*fac_ftmr(il)), & (Eqi(il)*fac_ftmr(il)), & 'stewart_sublim_nofrac 125',errmax*10,errmaxrel*10) CALL iso_verif_egalite_choix( & (Pxtiinf(iso_eau,il)), & (Pqiinf(il)), & 'stewart_sublim_nofrac 143',errmax,errmaxrel) CALL iso_verif_egalite_choix( & (xtnew(iso_eau,il)), & (q(il)+Eqi(il)*fac_ftmr(il)), & 'stewart_sublim_nofrac 218',errmax*10,errmaxrel*50) endif #endif else !if (Pqisup(il).le.0) THEN ! dorénavant, Pqisup est différenent de 0 ! calcul de Pxtiinf et Exi; pas de fractionnement DO ixt=1,niso Pxtiinf(ixt,il)=Pxtisup(ixt,il)/Pqisup(il)*Pqiinf(il) Exi(ixt,il)=Pxtisup(ixt,il)/Pqisup(il)*Eqi(il) enddo ! do ixt=1,niso ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN((Exi(ixt,il)), & 'stewart_sublim 102') CALL iso_verif_noNAN((Pxtiinf(ixt,il)), & 'stewart_sublim 102') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix((Exi(iso_eau,il)), & (Eqi(il)), & 'stewart_sublim 101',errmax*1e-2,errmaxrel*1e-2) CALL iso_verif_egalite((Pxtiinf(iso_eau,il)), & (Pqiinf(il)),'stewart_sublim 110') endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN #endif IF ((bidouille_anti_divergence).AND. & (iso_eau.gt.0)) THEN ! assurer la convergence numérique pour ixt=4: Exi(iso_eau,il)=Eqi(il) Pxtiinf(iso_eau,il)=Pqiinf(il) endif !if if ((bidouille_anti_divergence).AND.(iso_eau.gt.0) ! calcul de xtnew DO ixt=1,niso xtnew(ixt,il)=xt(ixt,il)+Exi(ixt,il)*fac_ftmr(il) xtnew(ixt,il)=max(0.0,xtnew(ixt,il)) enddo !do ixt=1,niso ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN( & (xtnew(ixt,il)),'stewart_sublim 140') enddo ! do ixt=1,niso ! verif que deltaD(Pqiinf) raisonable IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(Pxtiinf(iso_HDO,il),Pqiinf(il), & ridicule_rain,deltalim_snow, 'stewart_sublim 175') endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO).AND. IF (iso_eau.gt.0) THEN IF (q(il)+Eqi(il)*fac_ftmr(il).ge.0.0) THEN IF (iso_verif_egalite_choix_nostop( & (xtnew(iso_eau,il)), & (q(il)+Eqi(il)*fac_ftmr(il)), & 'stewart_sublim 108', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'q(il)=',q(il) WRITE(*,*) 'Eqi(il)=',Eqi(il) WRITE(*,*) 'fac_ftmr(il)=',fac_ftmr(il) stop endif !if (iso_verif_egalite_choix_nostop endif !if (q(il)+Eqi(il)*fac_ftmr(il).ge.0.0) THEN IF (iso_verif_egalite_choix_nostop( & (Pxtiinf(iso_eau,il)), & (Pqiinf(il)),'stewart_sublim 204', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'Pqisup(il)=',Pqisup(il) stop endif !if (iso_verif_egalite_choix_nostop endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN #endif ! end verif endif ! if pqisup.gt.0 enddo ! do il=1,ncas ! en verif ! ************ fin des calculs *************** ! WRITE(*,*) 'sttewart_sublim 155: sortie' END SUBROUTINE stewart_sublim_nofrac_vectall SUBROUTINE compress_calculJ(ncas,ncas_Rieman,ncas_Jsimple, & cas_rieman,cas_Jsimple, & m_cas,m, m0_cas,m0, & qp0_cas,qp0, A_cas,A, & xtp0_cas,xtp0, & beta_cas,beta,gama_cas,gama, & ! & f_cas,f, g_cas,g,ntot_cas,h, f_cas,f, g_cas,g,h, & Rb0_cas,Rb0, & Rl0_cas,Rl0, & r_l0qp0_cas,r_l0qp0, & Eqi_cas,Eqi, & fac_ftmr_cas,fac_ftmr, & Pxtisup_cas,Pxtisup, & Pqiinf_cas,Pqiinf) USE isotopes_mod, ONLY: iso_eau, iso_HDO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! compression des variables en tableaux spécifiques pour le ! calcul d'intégral soit simple, soit par Rieman. INTEGER ncas ! dimension officielle des variables INTEGER ncas_rieman,ncas_Jsimple ! nombre de variables à compresser INTEGER cas_rieman(ncas),cas_Jsimple(ncas) ! tableaux d'index REAL m_cas(ncas),m(ncas), & m0_cas(ncas),m0(ncas), & qp0_cas(ncas),qp0(ncas), & xtp0_cas(niso,ncas),xtp0(niso,ncas), & A_cas(ncas),A(ncas), & beta_cas(niso,ncas),beta(niso,ncas), & gama_cas(niso,ncas),gama(niso,ncas), & f_cas(ncas),f(ncas), & g_cas(ncas),g(ncas), & Rb0_cas(niso,ncas),Rb0(niso,ncas), & Rl0_cas(niso,ncas),Rl0(niso,ncas), & r_l0qp0_cas(ncas),r_l0qp0(ncas), & Eqi_cas(ncas),Eqi(ncas), & Pxtisup_cas(niso,ncas),Pxtisup(niso,ncas), & Pqiinf_cas(ncas),Pqiinf(ncas), & fac_ftmr_cas(ncas),fac_ftmr(ncas) REAL h(ncas) ! integer ntot_cas(ncas) INTEGER il,ixt ! méthode de calcul d'intégrale ! si rieman: !#define rieman ! sinon: méthode de gauss !#ifdef ISOVERIF ! real !#endif #ifdef ISOVERIF ! WRITE(*,*) 'compress_stewart 45: entrée compress_calculJ' ! WRITE(*,*) 'ncas_Jsimple=',ncas_Jsimple #endif IF (ncas_Jsimple.gt.0) THEN DO il=1,ncas_Jsimple ! WRITE(*,*) 'compress_stewart 50: il=',il m0_cas(il)=m0(cas_Jsimple(il)) ! WRITE(*,*) 'compress_stewart 51: il=',il m_cas(il)=m(cas_Jsimple(il)) qp0_cas(il)=qp0(cas_Jsimple(il)) ! WRITE(*,*) 'compress_stewart 54: il=',il A_cas(il)=A(cas_Jsimple(il)) f_cas(il)=f(cas_Jsimple(il)) #ifdef ISOVERIF CALL iso_verif_egalite_choix((f_cas(il)), & (m_cas(il)/m0_cas(il)), & 'compress_stewart 66',errmax,errmaxrel) #endif ! WRITE(*,*) 'compress_stewart 56: il=',il g_cas(il)=g(cas_Jsimple(il)) r_l0qp0_cas(il)=r_l0qp0(cas_Jsimple(il)) Eqi_cas(il)=Eqi(cas_Jsimple(il)) ! WRITE(*,*) 'compress_stewart 60: il=',il fac_ftmr_cas(il)=fac_ftmr(cas_Jsimple(il)) Pqiinf_cas(il)=Pqiinf(cas_Jsimple(il)) ! WRITE(*,*) 'compress_stewart 61: il=',il DO ixt=1,niso ! WRITE(*,*) 'il,ixt=',il,ixt xtp0_cas(ixt,il)=xtp0(ixt,cas_Jsimple(il)) beta_cas(ixt,il)=beta(ixt,cas_Jsimple(il)) gama_cas(ixt,il)=gama(ixt,cas_Jsimple(il)) Rb0_cas(ixt,il)=Rb0(ixt,cas_Jsimple(il)) Rl0_cas(ixt,il)=Rl0(ixt,cas_Jsimple(il)) Pxtisup_cas(ixt,il)=Pxtisup(ixt,cas_Jsimple(il)) enddo !do ixt=1,niso enddo !do il=1,ncas_Jsimple endif !if (ncas_Jsimple.gt.0) THEN IF (ncas_rieman.gt.0) THEN DO il=1,ncas_rieman m0_cas(il+ncas_Jsimple)=m0(cas_rieman(il)) m_cas(il+ncas_Jsimple)=m(cas_rieman(il)) qp0_cas(il+ncas_Jsimple)=qp0(cas_rieman(il)) A_cas(il+ncas_Jsimple)=A(cas_rieman(il)) f_cas(il+ncas_Jsimple)=f(cas_rieman(il)) r_l0qp0_cas(il+ncas_Jsimple)=r_l0qp0(cas_rieman(il)) #ifdef ISOVERIF CALL iso_verif_egalite_choix( & (f_cas(il+ncas_Jsimple)), & (m_cas(il+ncas_Jsimple) & /m0_cas(il+ncas_Jsimple)),'compress_stewart 66', & errmax,errmaxrel) #endif g_cas(il+ncas_Jsimple)=g(cas_rieman(il)) Eqi_cas(il+ncas_Jsimple)=Eqi(cas_rieman(il)) fac_ftmr_cas(il+ncas_Jsimple)=fac_ftmr(cas_rieman(il)) Pqiinf_cas(il+ncas_Jsimple)=Pqiinf(cas_rieman(il)) DO ixt=1,niso xtp0_cas(ixt,il+ncas_Jsimple)=xtp0(ixt,cas_rieman(il)) beta_cas(ixt,il+ncas_Jsimple)=beta(ixt,cas_rieman(il)) gama_cas(ixt,il+ncas_Jsimple)=gama(ixt,cas_rieman(il)) Rb0_cas(ixt,il+ncas_Jsimple)=Rb0(ixt,cas_rieman(il)) Rl0_cas(ixt,il+ncas_Jsimple)=Rl0(ixt,cas_rieman(il)) Pxtisup_cas(ixt,il+ncas_Jsimple)= & Pxtisup(ixt,cas_rieman(il)) enddo !do ixt=1,niso !#ifdef rieman ! ntot_cas(il+ncas_Jsimple)=10 ! : +int((1-0.5*f(cas_rieman(il))) ! : *0.02*(exp(2*h(cas_rieman(il))))**6) !#else ! ntot_cas(il+ncas_Jsimple)=300 ! : +35*(1-f(cas_rieman(il)))**3 ! : +2.1e4*(h(cas_rieman(il))-0.9)**3 ! : +2.5e5*((1-f(cas_rieman(il)))**6) ! : *((h(cas_rieman(il))-0.9)**3) !#endif !#ifdef ISOVERIF !! WRITE(*,*) ' f,h,ntot_cas=',f(cas_rieman(il)), !! : h(cas_rieman(il)),ntot_cas(il+ncas_Jsimple) ! CALL iso_verif_positif(float(ntot_cas(il+ncas_Jsimple))-1.0, ! : 'compress_stewart 136: ntot faux') !#endif enddo !do il=1,ncas_rieman endif !if (ncas_rieman.gt.0) THEN #ifdef ISOVERIF ! vérif de la compression: DO il=1,ncas_Jsimple CALL iso_verif_egalite_choix( & (Pqiinf_cas(il)), & (Pqiinf(cas_Jsimple(il))), & 'compress_stewart 111',errmax,errmaxrel) enddo !do icas_Jsimple=1,ncas_Jsimple DO il=1,ncas_rieman CALL iso_verif_egalite_choix( & (Pqiinf_cas(ncas_Jsimple+il)), & (Pqiinf(cas_rieman(il))), & 'compress_stewart 117',errmax,errmaxrel) enddo !do icas_Jsimple=1,ncas_Jsimple ! WRITE(*,*) 'compress_stewart 91: fin compress_calculJ' #endif END SUBROUTINE compress_calculJ !******************* SUBROUTINE uncompress_calculJ(ncas,ncas_rieman,ncas_Jsimple, & cas_rieman,cas_Jsimple,Exi_cas,Exi, & xtnew_cas,xtnew,Pxtiinf_cas,Pxtiinf) USE isotopes_mod, ONLY: iso_eau, iso_HDO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! des compressions des cas de calcul de J dans stewart_explicit INTEGER ncas,ncas_rieman,ncas_Jsimple INTEGER cas_rieman(ncas),cas_Jsimple(ncas) REAL Exi_cas(niso,ncas),Exi(niso,ncas), & xtnew_cas(niso,ncas),xtnew(niso,ncas), & Pxtiinf_cas(niso,ncas),Pxtiinf(niso,ncas) INTEGER il,ixt DO il=1,ncas_Jsimple DO ixt=1,niso Exi(ixt,cas_Jsimple(il))=Exi_cas(ixt,il) xtnew(ixt,cas_Jsimple(il))=xtnew_cas(ixt,il) Pxtiinf(ixt,cas_Jsimple(il))=Pxtiinf_cas(ixt,il) enddo enddo DO il=1,ncas_rieman DO ixt=1,niso Exi(ixt,cas_rieman(il))=Exi_cas(ixt,il+ncas_Jsimple) xtnew(ixt,cas_rieman(il))=xtnew_cas(ixt,il+ncas_Jsimple) Pxtiinf(ixt,cas_rieman(il))=Pxtiinf_cas(ixt,il+ncas_Jsimple) enddo enddo END SUBROUTINE uncompress_calculJ ! **************** SUBROUTINE uncompress_commun(ncas, cas, & xtp_cas,xtp,xtwater_cas,xtwater,xtevap_cas,xtevap, & #ifdef ISOVERIF Exi_cas,Exi, & #endif ncum) USE isotopes_mod, ONLY: iso_eau, iso_HDO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! decompression des outputs communs à tous les cas dans ! appel_stewart INTEGER ncas,ncum INTEGER cas(ncum) REAL xtevap_cas(niso,ncum) REAL xtp_cas(niso,ncum) REAL xtwater_cas(niso,ncum) ! outputs REAL xtwater(ntraciso,ncum) REAL xtp(ntraciso,ncum) REAL xtevap(ntraciso,ncum) ! locals INTEGER il,ixt #ifdef ISOVERIF REAL Exi_cas(niso,ncum) REAL Exi(ntraciso,ncum) #endif DO il=1,ncas DO ixt=1,niso xtevap(ixt,cas(il))=xtevap_cas(ixt,il) xtp(ixt,cas(il))=xtp_cas(ixt,il) xtwater(ixt,cas(il))=xtwater_cas(ixt,il) #ifdef ISOVERIF Exi(ixt,cas(il))=Exi_cas(ixt,il) #endif enddo enddo END SUBROUTINE uncompress_commun !************** SUBROUTINE compress_cond_facftmr( & ncas, cas, & Eqi_prime_cas,Eqi_prime, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & T_cas,T, & fac_ftmr_cas,fac_ftmr, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap, & water_cas,water, & delP_cas,Ph, & sigd_cas,sigd, & #ifdef ISOVERIF evap_cas,evap,qp_cas,qp, & #endif nloc,ncum,nd,i) USE isotopes_mod, ONLY: iso_eau, iso_HDO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr INTEGER nd,ncum,nloc INTEGER ncas INTEGER cas(ncum) INTEGER i REAL T_cas(ncum),T(ncum), & xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum), & water_cas(ncum),water(ncum), & delP_cas(ncum),Ph(nloc,ND), & sigd_cas(ncum),sigd(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), & fac_ftmr_cas(ncum),fac_ftmr(ncum) REAL evap_cas(ncum),evap(ncum),qp_cas(ncum),qp(ncum) INTEGER il,ixt DO il=1,ncas Eqi_prime_cas(il)=Eqi_prime(cas(il)) Pqisup_cas(il)=Pqisup(cas(il)) T_cas(il)=T(cas(il)) fac_ftmr_cas(il)=fac_ftmr(cas(il)) qp_avantevap_cas(il)=qp_avantevap(cas(il)) water_cas(il)=water(cas(il)) delP_cas(il)=Ph(cas(il),i) & -Ph(cas(il),i+1) sigd_cas(il)=sigd(cas(il)) #ifdef ISOVERIF evap_cas(il)=evap(cas(il)) qp_cas(il)=qp(cas(il)) IF (iso_verif_positif_nostop(sigd_cas(il)-1e-3, & 'compress_cond_facftmr 5215').EQ.1) THEN WRITE(*,*) 'il,cas(il),sigd_cas(il)=',il,cas(il),sigd_cas(il) CALL abort_physic('isotopes_routines_mod', 'compress_cond_facftmr 5215: sigd_cas<1e3', 1) endif !if (iso_verif_positif_nostop #endif DO ixt=1,niso Pxtisup_cas(ixt,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(ixt,il)=xtp_avantevap(ixt,cas(il)) xtevapsup_cas(ixt,il)=xtevap(ixt,cas(il)) enddo enddo !do il=1,ncas END SUBROUTINE compress_cond_facftmr ! ************** SUBROUTINE compress_cond_nofftmr( & ncas, cas, & Eqi_prime_cas,Eqi_prime, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & water_cas,water, & T_cas,T, & qp_avantevap_cas,qp_avantevap,& xtp_avantevap_cas,xtp_avantevap,& xt_cas,xt,q_cas,q, & xtevapsup_cas,xtevap, & delP_cas,Ph, & sigd_cas,sigd, & #ifdef ISOVERIF evap_cas,evap,qp_cas,qp, & #endif nloc,ncum,nd,i) USE isotopes_mod, ONLY: iso_eau, iso_HDO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr INTEGER nloc,nd,ncum INTEGER ncas INTEGER cas(ncum) INTEGER i REAL T_cas(ncum),T(ncum), & xt_cas(niso,ncum),q_cas(ncum),xt(ntraciso,ncum),q(ncum), & xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum), & water_cas(ncum),water(ncum), & delP_cas(ncum),Ph(nloc,ND), & sigd_cas(ncum), sigd(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),qp_cas(ncum),qp(ncum) #endif INTEGER il,ixt DO il=1,ncas Eqi_prime_cas(il)=Eqi_prime(cas(il)) Pqisup_cas(il)=Pqisup(cas(il)) water_cas(il)=water(cas(il)) T_cas(il)=T(cas(il)) qp_avantevap_cas(il)=qp_avantevap(cas(il)) q_cas(il)=q(cas(il)) delP_cas(il)=Ph(cas(il),i) & -Ph(cas(il),i+1) sigd_cas(il)=sigd(cas(il)) #ifdef ISOVERIF qp_cas(il)=qp(cas(il)) evap_cas(il)=evap(cas(il)) IF (iso_verif_positif_nostop(sigd_cas(il)-1e-3, & 'compress_cond_nofftmr 5294').EQ.1) THEN WRITE(*,*) 'il,cas(il),sigd_cas(il)=',il,cas(il),sigd_cas(il) CALL abort_physic('isotopes_routines_mod', 'compress_cond_nofftmr 5294: sigd_cas<1e3', 1) endif !if (iso_verif_positif_nostop #endif DO ixt=1,niso Pxtisup_cas(ixt,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(ixt,il)=xtp_avantevap(ixt,cas(il)) xt_cas(ixt,il)=xt(ixt,cas(il)) xtevapsup_cas(ixt,il)=xtevap(ixt,cas(il)) enddo enddo END SUBROUTINE compress_cond_nofftmr ! ************** SUBROUTINE compress_noevap( & ncas, cas, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap, & water_cas,water, & delP_cas,Ph, & #ifdef ISOVERIF evap_cas,evap,qp_cas,qp, & #endif nloc,ncum,nd,i) USE isotopes_mod, ONLY: iso_eau, iso_HDO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr INTEGER nloc,nd,ncum INTEGER ncas INTEGER cas(ncum) INTEGER i REAL xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum), & water_cas(ncum),water(ncum), & delP_cas(ncum),Ph(nloc,ND) 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),qp_cas(ncum),qp(ncum) #endif INTEGER il,ixt DO il=1,ncas Pqisup_cas(il)=Pqisup(cas(il)) water_cas(il)=water(cas(il)) delP_cas(il)=Ph(cas(il),i) & -Ph(cas(il),i+1) #ifdef ISOVERIF evap_cas(il)=evap(cas(il)) qp_cas(il)=qp(cas(il)) #endif DO ixt=1,niso Pxtisup_cas(ixt,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(ixt,il)=xtp_avantevap(ixt,cas(il)) xtevapsup_cas(ixt,il)=xtevap(ixt,cas(il)) enddo enddo END SUBROUTINE compress_noevap ! ************** SUBROUTINE compress_evap_liq(iflag_con, & ncas, & cas, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & qp_avantevap_cas,qp_avantevap,& xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap, & water_cas,water, & qs_cas,qs, & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas,& Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime, & Eqi,Eqi_cas, & fac_ftmr_cas,fac_ftmr, & T_cas,T, & wt_cas,wt, & INB_cas,INB, & delP_cas,Ph, & qp_cas,qp, & sigd_cas,sigd, & #ifdef ISOVERIF evap_cas,evap, & #endif nloc,ncum,nd,i) USE isotopes_mod, ONLY: iso_eau, iso_HDO,ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr ! inputs et outputs INTEGER iflag_con INTEGER nloc,nd,ncum INTEGER ncas INTEGER cas(ncum) INTEGER i REAL xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum), & water_cas(ncum),water(ncum), & qs_cas(ncum),qs(ncum), & T_cas(ncum),T(ncum), & wt_cas(ncum),wt(ncum), & delP_cas(ncum),Ph(nloc,ND), & sigd_cas(ncum),sigd(ncum) REAL qp_cas(ncum),qp(ncum) #ifdef ISOVERIF REAL evap_cas(ncum),evap(ncum) ! real ! integer iso_verif_positif_nostop #endif real & qp_avantevap_cas(ncum),qp_avantevap(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),Pqisup(ncum),Pqisup_cas(ncum), & Pxtisup(ntraciso,ncum),Pxtisup_cas(niso,ncum), & fac_ftmr_cas(ncum),fac_ftmr(ncum), & Eqi(ncum),Eqi_cas(ncum) INTEGER INB_cas(ncum),INB(ncum) ! locals INTEGER il,ixt DO il=1,ncas Pqisup_cas(il)=Pqisup(cas(il)) water_cas(il)=water(cas(il)) qp_avantevap_cas(il)=qp_avantevap(cas(il)) qs_cas(il)=qs(cas(il)) Eqi_prime_cas(il)=Eqi_prime(cas(il)) Eqi_cas(il)=Eqi(cas(il)) fac_ftmr_cas(il)=fac_ftmr(cas(il)) T_cas(il)=T(cas(il)) qp_cas(il)=qp(cas(il)) sigd_cas(il)=sigd(cas(il)) #ifdef ISOVERIF evap_cas(il)=evap(cas(il)) #endif wt_cas(il)=wt(cas(il)) INB_cas(il)=INB(cas(il)) delP_cas(il)=Ph(cas(il),i)-Ph(cas(il),i+1) DO ixt=1,niso Pxtisup_cas(ixt,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(ixt,il)=xtp_avantevap(ixt,cas(il)) xtevapsup_cas(ixt,il)=xtevap(ixt,cas(il)) enddo !do ixt=1,niso enddo ! 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 ((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)) Eqi_stewart(il)=Eqi_par(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)) IF (iflag_con.EQ.30) THEN Eqi_stewart(il)=Eqi_prime(cas(il)) else !if (iflag_con.EQ.30) THEN IF (Eqi(cas(il)).ge.0.0) THEN Eqi_stewart(il)=Eqi(cas(il)) else !if (Eqi(cas(il)).gt.0.0) THEN ! cas ajouté le 7 dec 2012: si Eqi est négatif, ! alors on plante dans compress_stewart 977b ! Parfois, Eqi' est positif grace à Eqi+1 qui est ! positif, mais Eqi est faiblement négatif (même si ! très faible) Eqi_stewart(il)=Eqi_prime(cas(il)) endif !if (Eqi(cas(il)).gt.0.0) THEN endif !if (iflag_con.EQ.30) THEN endif !if ((water(il,i).gt.ridicule/100).AND.(Pqiinf_par.le.0.0)) THEN enddo !do il=1,ncas ! petite vérif #ifdef ISOVERIF DO il=1,ncas IF ((iso_verif_positif_nostop(( & Eqi_stewart(il)),'compress_stewart 977a').EQ.1) & .OR.(iso_verif_positif_nostop(( & Eqi_stewart(il))*fac_ftmr_cas(il), & 'compress_stewart 977b').EQ.1)) THEN WRITE(*,*) 'Pqiinf=',Pqiinf(cas(il)) WRITE(*,*) 'Pqisup=',Pqisup(cas(il)) WRITE(*,*) 'Pqiinf_par=',Pqiinf_par(cas(il)) WRITE(*,*) 'Eqi=',Eqi(cas(il)) WRITE(*,*) 'Eqi_par=',Eqi_par(cas(il)) WRITE(*,*) 'Eqi_prime=',Eqi_prime(cas(il)) WRITE(*,*) 'Eqi_stewart=',Eqi_stewart(il) WRITE(*,*) 'il,cas=',il,cas(il) WRITE(*,*) 'fac_ftmr_cas=',fac_ftmr_cas(il) WRITE(*,*) 'qp_avantevap_cas=',qp_avantevap_cas(il) WRITE(*,*) 'qp_cas=',qp_cas(il) stop endif DO ixt=1,niso CALL iso_verif_noNaN((Pxtisup_cas(ixt,il)), & 'compress_stewart 976') enddo !do ixt=1,niso enddo #endif #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 ! ************** SUBROUTINE compress_evap_glace(iflag_con, & ncas, cas, & water_cas,water, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & T_cas,T, & fac_ftmr_cas,fac_ftmr, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap, & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas,Eqi_cas, & Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime,Eqi, & INB_cas,INB, & delP_cas,Ph, & qp_cas,qp, & sigd_cas,sigd, & #ifdef ISOVERIF evap_cas,evap, & #endif nloc,ncum,nd,i,frac_sublim) USE isotopes_mod, ONLY: iso_eau, iso_HDO,ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #ifdef ISOTRAC USE isotrac_routines_mod, ONLY: iso_verif_traceur_pbidouille #endif #endif IMPLICIT NONE ! compression dans le cas condensation_facftmr INTEGER iflag_con INTEGER nloc,nd,ncum INTEGER ncas INTEGER cas(ncum) INTEGER i REAL T_cas(ncum),T(ncum), & delP_cas(ncum),Ph(nloc,ND), & water_cas(ncum),water(ncum), & xtevapsup_cas(niso,ncum),xtevap(ntraciso,ncum) REAL qp_cas(ncum),qp(ncum) REAL sigd_cas(ncum),sigd(ncum) #ifdef ISOVERIF REAL evap_cas(ncum),evap(ncum) #endif real fac_ftmr_cas(ncum),fac_ftmr(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), & 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) INTEGER frac_sublim INTEGER INB_cas(ncum),INB(ncum) INTEGER il,ixt DO il=1,ncas Pqisup_cas(il)=Pqisup(cas(il)) qp_avantevap_cas(il)=qp_avantevap(cas(il)) Eqi_prime_cas(il)=Eqi_prime(cas(il)) Eqi_cas(il)=Eqi(cas(il)) fac_ftmr_cas(il)=fac_ftmr(cas(il)) water_cas(il)=water(cas(il)) INB_cas(il)=INB(cas(il)) qp_cas(il)=qp(cas(il)) sigd_cas(il)=sigd(cas(il)) #ifdef ISOVERIF evap_cas(il)=evap(cas(il)) #endif delP_cas(il)=Ph(cas(il),i) & -Ph(cas(il),i+1) DO ixt=1,niso Pxtisup_cas(ixt,il)=Pxtisup(ixt,cas(il)) xtp_avantevap_cas(ixt,il)=xtp_avantevap(ixt,cas(il)) xtevapsup_cas(ixt,il)=xtevap(ixt,cas(il)) enddo enddo !do il=1,ncas ! WRITE(*,*) 'qp_avantevap_cas(1),qp_avantevap(cas(1))=', ! : qp_avantevap_cas(1),qp_avantevap(cas(1)) IF (frac_sublim.EQ.1) THEN DO il=1,ncas T_cas(il)=T(cas(il)) enddo !do il=1,ncas endif !if (frac_sublim) THEN ! 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 ((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)) Eqi_stewart(il)=Eqi_par(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)) IF (iflag_con.EQ.30) THEN Eqi_stewart(il)=Eqi_prime(cas(il)) else !if (iflag_con.EQ.30) THEN ! pour quoi avait-on fait un traitement différent dans ! le cas iflag_con=3?? C'est vraiment le bordel ici! IF ((Eqi_prime(cas(il)).gt.0.0).AND. & (Pqiinf(cas(il)).ge.Pqisup(cas(il))).AND. & (Pqisup(cas(il)).gt.0.0).AND. & (Pqisup(cas(il))-Eqi_prime(cas(il)).gt.0.0)) THEN ! rustine au cas patho en 1D pour -90hPa/d Eqi_stewart(il)=Eqi_prime(cas(il)) else !if (Eqi_prime(il).gt.0.0).AND. Eqi_stewart(il)=Eqi(cas(il)) endif !if (Eqi_prime(il).gt.0.0).AND. endif !if (iflag_con.EQ.30) THEN endif !if ((water(il,i).gt.ridicule/100).AND.(Pqiinf_par.le.0.0)) THEN enddo !do il=1,ncas_evap_glace ! petite vérif #ifdef ISOVERIF ! il=1 ! WRITE(*,*) 'compress_stewart 1249& il=',il ! WRITE(*,*) 'Pqiinf_stewart(il)=',Pqiinf_stewart(il) ! WRITE(*,*) 'Eqi_stewart(il)=',Eqi_stewart(il) ! WRITE(*,*) 'Pqisup_cas=',Pqisup_cas(il) 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 ! ************** SUBROUTINE uncompress_ilp( & ncas,cas, & zxtrfln_cas,zxt_cas,zxtrfl,zxtrfln,zxt,klon) USE isotopes_mod, ONLY: iso_eau, iso_HDO IMPLICIT NONE ! inputs INTEGER ncas INTEGER cas(ncas) INTEGER klon REAL zxt_cas(niso,ncas),zxtrfln_cas(niso,ncas) ! outputs REAL zxt(ntraciso,klon) REAL zxtrfl(ntraciso,klon),zxtrfln(ntraciso,klon) ! locals INTEGER il,ixt DO il=1,ncas DO ixt=1,niso zxt(ixt,cas(il))=zxt_cas(ixt,il) zxtrfln(ixt,cas(il))=zxtrfln_cas(ixt,il) zxtrfl(ixt,cas(il))=zxtrfln_cas(ixt,il) enddo enddo END SUBROUTINE uncompress_ilp ! ************** SUBROUTINE compress_ilp_evap_tot( & ncas,cas, & zxt_cas,zxt,zxtrfl_cas,zxtrfl, & delP,paprs,k,klon,klev) USE isotopes_mod, ONLY: iso_eau, iso_HDO IMPLICIT NONE INTEGER ncas INTEGER cas(ncas) INTEGER klon,klev REAL zxt(niso,klon) REAL zxtrfl(niso,klon) REAL delP(ncas),paprs(klon,klev+1) REAL zxt_cas(niso,ncas), zxtrfl_cas(niso,ncas) INTEGER k INTEGER il,ixt DO il=1,ncas DO ixt=1,niso zxt_cas(ixt,il)=zxt(ixt,cas(il)) zxtrfl_cas(ixt,il)=zxtrfl(ixt,cas(il)) enddo delP(il)=paprs(cas(il),k)-paprs(cas(il),k+1) enddo END SUBROUTINE compress_ilp_evap_tot ! ************** SUBROUTINE compress_ilp_evap_liq( & ncas,cas, & zq_cas,zq, & zqs_cas,zqs, & zxt_cas,zxt, & zxtrfl_cas,zxtrfl_ancien, & zrfln_cas,zrfln, & zrfl_cas,zrfl_ancien, & zqev_diag_cas,zqev_diag, & zt_cas,zt, & delP,paprs,k,klon,klev) USE isotopes_mod, ONLY: iso_eau, iso_HDO IMPLICIT NONE INTEGER ncas INTEGER cas(ncas) INTEGER klon,klev REAL zq(klon), zxt(ntraciso,klon) REAL zq_cas(ncas),zxt_cas(niso,ncas) REAL zxtrfl_cas(niso,ncas) REAL zxtrfl_ancien(ntraciso,klon) REAL delP(ncas),paprs(klon,klev+1) REAL zqs(klon),zqs_cas(ncas) REAL zt_cas(ncas),zt(klon) REAL zqev_diag_cas(ncas),zqev_diag(klon) REAL zrfln_cas(ncas) REAL zrfln(klon) REAL zrfl_cas(ncas) REAL zrfl_ancien(klon) INTEGER k INTEGER il,ixt DO il=1,ncas DO ixt=1,niso zxt_cas(ixt,il)=zxt(ixt,cas(il)) zxtrfl_cas(ixt,il)=zxtrfl_ancien(ixt,cas(il)) enddo zqs_cas(il)=zqs(cas(il)) zrfln_cas(il)=zrfln(cas(il)) zrfl_cas(il)=zrfl_ancien(cas(il)) zq_cas(il)=zq(cas(il)) zqev_diag_cas(il)=zqev_diag(cas(il)) zt_cas(il)=zt(cas(il)) delP(il)=paprs(cas(il),k)-paprs(cas(il),k+1) enddo END SUBROUTINE compress_ilp_evap_liq ! ************** SUBROUTINE compress_ilp_evap_glace( & ncas,cas, & zq_cas,zq, & zxt_cas,zxt, & zxtrfl_cas,zxtrfl_ancien, & zrfln_cas,zrfln, & zrfl_cas,zrfl_ancien, & zqev_diag_cas,zqev_diag, & zt_cas,zt, & delP,paprs,k,klon,klev,frac_sublim) USE isotopes_mod, ONLY: iso_eau, iso_HDO #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas INTEGER cas(ncas) INTEGER klon REAL zq(klon), zxt(ntraciso,klon) REAL zxtrfl_ancien(ntraciso,klon) REAL zt(klon) REAL zqev_diag(klon) REAL zrfln(klon) INTEGER k,klev REAL paprs(klon,klev+1) INTEGER frac_sublim ! outputs REAL zq_cas(ncas),zxt_cas(niso,ncas) REAL zxtrfl_cas(niso,ncas) REAL zt_cas(ncas) REAL zqev_diag_cas(ncas) REAL zrfln_cas(ncas) REAL zrfl_cas(ncas) REAL zrfl_ancien(klon) REAL delP(ncas) ! locals INTEGER il,ixt !#ifdef ISOVERIF ! real !#endif DO il=1,ncas DO ixt=1,niso zxt_cas(ixt,il)=zxt(ixt,cas(il)) zxtrfl_cas(ixt,il)=zxtrfl_ancien(ixt,cas(il)) enddo delP(il)=paprs(cas(il),k)-paprs(cas(il),k+1) zrfln_cas(il)=zrfln(cas(il)) zrfl_cas(il)=zrfl_ancien(cas(il)) zq_cas(il)=zq(cas(il)) zqev_diag_cas(il)=zqev_diag(cas(il)) IF (frac_sublim.EQ.1) THEN zt_cas(il)=zt(cas(il)) endif enddo #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncas ! WRITE(*,*) 'il=',il CALL iso_verif_egalite_choix(zrfl_ancien(cas(il)), & zxtrfl_ancien(iso_eau,cas(il)), & 'compress 1655a: compress evap_glace pour ilp', & errmax,errmaxrel) CALL iso_verif_egalite_choix((zrfl_cas(il)), & (zxtrfl_cas(iso_eau,il)), & 'compress 1655b: compress evap_glace pour ilp', & errmax,errmaxrel) enddo endif !if (iso_eau.gt.0) THEN #endif END SUBROUTINE compress_ilp_evap_glace ! ************** SUBROUTINE integrale_gauss_vectall(ncas,m,I, & ! : qp0,A,m0,beta,gama,g0,ntot) qp0,A,m0,beta,gama,g0) USE isotopes_mod, ONLY: iso_eau, iso_HDO,ntot #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! version vectorisée en ncas. La vesrion _bak23fev2008 était ! vectorisée en ntot ! calcul d'intégral par méthode de gauss ! on vectorise sur toutes les intégrales à calculer ! ***declarations: ! **inputs: INTEGER ncas ! arguments de la fonction à intégrer: REAL qp0(ncas) REAL A(ncas),m(ncas),m0(ncas),beta(niso,ncas), & gama(niso,ncas),f0(ncas),g0(ncas) ! integer ntot(ncas) ! integer ntot ! parameter (ntot=40) ! ** output REAL I(niso,ncas) ! integrale ! **locals ! nombre max d'itération dans integrale rieman INTEGER j INTEGER il,ixt,k REAL dxj(ncas) INTEGER ndeg ! degrès du polynome de Legendre parameter (ndeg=5) REAL w(ndeg),z(ndeg) REAL fj ! real xj ! verifs !#ifdef ISOVERIF ! real !#endif ! *** verifs ! WRITE(*,*) 'ntot=',ntot #ifdef ISOVERIF DO il=1,ncas IF (m0(il).lt.m(il)) THEN WRITE(*,*) 'integrale_rieman 25' WRITE(*,*) 'binf=',m(il),' bsup=',m0(il) stop endif enddo #endif ! WRITE(*,*) 'binf=',binf,' bsup=',bsup !*** calculs IF (ndeg.EQ.1) THEN z(1)=0.0 w(1)=2.0 ELSE IF (ndeg.EQ.2) THEN z(1)=-0.577350269189 z(2)=0.577350269189 w(1)=1.0 w(2)=1.0 ELSE IF (ndeg.EQ.3) THEN z(1)=-0.774596669241 z(2)=0.0 z(3)=0.774596669241 w(1)=0.5555555555555 w(2)=0.8888888888888 w(3)=0.5555555555555 ELSE IF (ndeg.EQ.4) THEN z(1)=-0.861136311594 z(2)=-0.3399810435848 z(3)=0.3399810435848 z(4)=0.861136311594 w(1)=0.34785484513745 w(2)=0.6521451548625 w(3)=0.6521451548625 w(4)=0.34785484513745 ELSE IF (ndeg.EQ.5) THEN z(1)=-0.90617984593866399280 z(2)=-0.53846931010568309104 z(3)=0.0 z(4)=0.53846931010568309104 z(5)=0.90617984593866399280 w(1)=0.23692688505618908751 w(2)=0.47862867049936646804 w(3)=0.568888888888888888889 w(4)=0.47862867049936646804 w(5)=0.23692688505618908751 else WRITE(*,*) 'integrale gauss: non prévu: ndeg=',ndeg stop endif DO il=1,ncas ! dxj(il)=(m0(il)-m(il))/float(ntot(il)) dxj(il)=(m0(il)-m(il))/float(ntot) DO ixt=1,niso I(ixt,il)=0.0 enddo enddo !do il=1,ncas DO j=1,ntot fj=float(j) DO il=1,ncas DO ixt=1,niso ! I(ixt,il)=I(ixt,il) ! : +w(k)*( ! : ((((qp0(il)-A(il) ! : *((m(il)+0.5*(z(k)+2*float(j)-1.0)*dxj(il))-m0(il))) ! : /qp0(il))/g0(il)) ! : **(beta(ixt,il)*gama(ixt,il)-1)) ! : *((((m(il)+0.5*(z(k)+2*float(j)-1.0)*dxj(il))/m(il))) ! : **(-beta(ixt,il)-1)) ) I(ixt,il)=I(ixt,il)+w(1)*( & ((((qp0(il)-A(il) & *((m(il)+0.5*(z(1)+2*fj-1.0)*dxj(il))-m0(il))) & /qp0(il))/g0(il)) & **(beta(ixt,il)*gama(ixt,il)-1)) & *((((m(il)+0.5*(z(1)+2*fj-1.0)*dxj(il))/m(il))) & **(-beta(ixt,il)-1)) ) & +w(2)*( & ((((qp0(il)-A(il) & *((m(il)+0.5*(z(2)+2*fj-1.0)*dxj(il))-m0(il))) & /qp0(il))/g0(il)) & **(beta(ixt,il)*gama(ixt,il)-1)) & *((((m(il)+0.5*(z(2)+2*fj-1.0)*dxj(il))/m(il))) & **(-beta(ixt,il)-1)) ) & +w(3)*( & ((((qp0(il)-A(il) & *((m(il)+0.5*(z(3)+2*fj-1.0)*dxj(il))-m0(il))) & /qp0(il))/g0(il)) & **(beta(ixt,il)*gama(ixt,il)-1)) & *((((m(il)+0.5*(z(3)+2*fj-1.0)*dxj(il))/m(il))) & **(-beta(ixt,il)-1)) )& +w(4)*( & ((((qp0(il)-A(il) & *((m(il)+0.5*(z(4)+2*fj-1.0)*dxj(il))-m0(il))) & /qp0(il))/g0(il)) & **(beta(ixt,il)*gama(ixt,il)-1)) & *((((m(il)+0.5*(z(4)+2*fj-1.0)*dxj(il))/m(il))) & **(-beta(ixt,il)-1)) ) & +w(5)*( & ((((qp0(il)-A(il) & *((m(il)+0.5*(z(5)+2*fj-1.0)*dxj(il))-m0(il))) & /qp0(il))/g0(il)) & **(beta(ixt,il)*gama(ixt,il)-1)) & *((((m(il)+0.5*(z(5)+2*fj-1.0)*dxj(il))/m(il))) & **(-beta(ixt,il)-1)) ) enddo !do ixt=1,niso ! enddo !do k=1,ndeg enddo !do j=2,ntot(il) enddo ! integrale avec valeur au début de l'intervalle (en m) DO il=1,ncas DO ixt=1,niso I(ixt,il)=I(ixt,il)*0.5*dxj(il) enddo !do ixt=1,niso enddo !do il=1,ncas ! verif #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNaN((I(ixt,il)),'integrale 68') enddo enddo #endif ! end verif ! WRITE(*,*) 'I=',I ! WRITE(*,*) 'Imax=',Imax,'Imin=',Imin ! WRITE(*,*) 'e=',e END SUBROUTINE integrale_gauss_vectall SUBROUTINE appel_stewart_vectall(lwork,ncum, & PH,T,EVAP,XTWDTRAIN, & WDTRAIN, & WATER,Q,XT, QS,QP,MP,WT, & ! inputs physiques XTWATER,XTP, & ! outputs indispensables XTEVAP, & ! diagnostiques sigd, & ! inputs tunables i,INB, & ! altitude: car cas particulier en INB NA,ND,nloc,cvflag_grav,ginv,Mpmin) ! dimensions USE isotopes_mod, ONLY: iso_eau, iso_HDO,thumxt1, & & bidouille_anti_divergence,ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: index_iso, index_zone,option_revap,izone_revap, & & ridicule_trac USE isotrac_routines_mod, ONLY: & & iso_verif_traceur_jbidouille,uncompress_commun_zone_revap, & & compress_evap_glace_zone,compress_evap_liq_zone, & & uncompress_commun_zone,compress_noevap_zone, & & compress_cond_facftmr_zone,compress_cond_nofftmr_zone #ifdef ISOVERIF USE isotrac_routines_mod, ONLY: iso_verif_traceur_pbidouille #endif #endif IMPLICIT NONE !*inputs et outputs INTEGER ncum ! dimension horiz effective LOGICAL lwork(nloc) INTEGER NA,ND,nloc ! dimensions officielles REAL PH(nloc,ND),T(nloc,ND),EVAP(nloc,NA) REAL XTWDTRAIN(ntraciso,nloc),WDTRAIN(nloc), & WATER(nloc,NA), Q(nloc,NA), XT(ntraciso,nloc,ND), & QS(nloc,ND),QP(nloc,NA), & XTWATER(ntraciso,nloc,NA),XTP(ntraciso,nloc,NA), & XTEVAP(ntraciso,nloc,NA), & WT(nloc,NA), MP(nloc,NA) REAL sigd INTEGER i,INB(nloc) LOGICAL cvflag_grav REAL ginv REAL Mpmin !* variables intermediaires INTEGER ixt,j,il REAL qeff(ncum) REAL xtp_avantevap(ntraciso,ncum),qp_avantevap(ncum) ! real Exi(niso,ncum) ! equivalent à Eqi_prime REAL Pqisup(ncum),Pqiinf(ncum),Eqi(ncum) REAL Pqiinf_par(ncum), Eqi_prime(ncum), & Eqi_plus1(ncum), Eqi_par(ncum) REAL Pqiinf_stewart(ncum), Eqi_stewart(ncum) REAL Exi_prime(ntraciso,ncum) REAL Pxtiinf_stewart(niso,ncum), & Exi_stewart(niso,ncum) REAL Exi_plus1(niso,ncum) REAL Pxtisup(ntraciso,ncum), Pxtiinf(niso,ncum) REAL xtnew(niso,ncum) REAL fac_ftmr(ncum) ! facteur de conversion des flux en mixing ratio ! real Risup(ntraciso,ncum), Rcond(ntraciso,ncum), ! : Renv(ntraciso,ncum) ! real Revap(ntraciso,ncum), Riinf(ntraciso,ncum) ! real xtice(ntraciso,ncum), xtliq(ntraciso,ncum) ! real xtp0(ntraciso,ncum), qp0(ncum) ! real fcond(ncum), fice(ncum), cond(ncum) ! real zxtalphal(niso,ncum), zxtalphai(niso,ncum) REAL g REAL rat(ncum) REAL ztglace_kelvin parameter (ztglace_kelvin=273.15) INTEGER frac_sublim !real !real real_to_double ! compteurs de parsage INTEGER icas_condensation_facftmr,ncas_condensation_facftmr INTEGER icas_condensation_nofacftmr,ncas_condensation_nofacftmr INTEGER icas_noevap,ncas_noevap INTEGER icas_evap_liq,ncas_evap_liq INTEGER icas_evap_glace,ncas_evap_glace INTEGER ncas_tot ! tableaux d'indice issus du parsage INTEGER cas_condensation_facftmr(ncum) INTEGER cas_condensation_nofacftmr(ncum) INTEGER cas_noevap(ncum) INTEGER cas_evap_liq(ncum) INTEGER cas_evap_glace(ncum) #ifdef ISOVERIF ! tracage des cas INTEGER trace_cas(ncum) ! integer iso_verif_positif_nostop ! integer iso_verif_positif_choix_nostop ! integer iso_verif_aberrant_nostop ! integer iso_verif_traceur_nostop ! integer iso_verif_egalite_nostop ! integer iso_verif_egalite_choix_nostop ! real deltaD REAL Exi_cas(niso,ncum),Exi(ntraciso,ncum) #endif ! outputs des calculs, compressés REAL xtevap_cas(niso,ncum),xtp_cas(niso,ncum), & xtwater_cas(niso,ncum) ! inputs des calculs, compréssés REAL T_cas(ncum),delP_cas(ncum), & xtevapsup_cas(niso,ncum),evap_cas(ncum), & qp_cas(ncum),wt_cas(ncum), & xt_cas(niso,ncum),q_cas(ncum), & qs_cas(ncum),water_cas(ncum), & sigd_cas(ncum) REAL sigd_vec(ncum) real qp_avantevap_cas(ncum), & xtp_avantevap_cas(niso,ncum), & Pqisup_cas(ncum), Pxtisup_cas(niso,ncum), & Eqi_prime_cas(ncum),fac_ftmr_cas(ncum), & Eqi_cas(ncum) #ifdef ISOTRAC real qp_avantevaptrac_cas(ncum), & xtp_avantevaptrac_cas(niso,ncum) INTEGER izone ,iiso REAL xtaddp_tag(niso,ncum) REAL ptrac(ncum) REAL hdiag(ncum) #endif INTEGER INB_cas(ncum) ! WRITE(*,*) 'appel stewart 48: entrée, i=',i ! definition de quelques constantes: !gravité: IF (cvflag_grav) THEN g=1/ginv else g=10. endif ! rendre sigd vecteur pour homogénéiser par rapport au cas np: DO il=1,ncum sigd_vec(il)=sigd enddo ! fractionne-t-on lors de la sublimation? frac_sublim=0 ! -> on ne fractionne pas !frac_sublim=1 ! -> oui, on fractionne ! ***** verification des inputs ************ #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN CALL iso_verif_egalite_choix(xt(iso_eau,il,i),q(il,i), & 'appel stewart 58',errmax,errmaxrel) endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if (iso_eau.gt.0) THEN #ifdef ISOTRAC DO il=1,ncum CALL iso_verif_traceur(xt(1,il,i), & 'appel_stewart_vectall 141') enddo #endif #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN xt(iso_eau,il,i)= q(il,i) endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN ! verif que les vapeurs du ddft plus haut sont bonnes ! si i=INB, on ne verifie rien car pas de vapeur au dessus de INB #ifdef ISOVERIF DO il=1,ncum IF (i.lt.inb(il) .AND. lwork(il)) THEN DO j=i+1,INB(il) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtp(iso_eau,il,j),qp(il,j), & 'appel_stewart 66',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN DO ixt=1,ntraciso CALL iso_verif_noNAN(xtevap(ixt,il,j), & 'appel_stewart 96') enddo #ifdef ISOTRAC CALL iso_verif_traceur(xtp(1,il,j), & 'appel_stewart_vectall 167') #endif enddo !do j=i+1,INB endif ! (i.lt.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO il=1,ncum IF (i.lt.inb(il) .AND. lwork(il)) THEN DO j=i+1,INB(il) xtp(iso_eau,il,j)=qp(il,j) enddo !do j=i+1,INB endif ! (i.lt.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN ! end verif des inputs ! ****** calcul du facteur de conversion des flux en mixing ratio DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN IF (Mp(il,i).gt.Mp(il,i+1)) THEN ! cas entrainant fac_ftmr(il)=1.0/Mp(il,i) else !if (Mp(il,i).gt.Mp(il,i+1)) THEN IF (Mp(il,i+1).gt.Mpmin) THEN ! cas non entrainant, mais flux existe fac_ftmr(il)=1.0/Mp(il,i+1) else !if (Mp(il,i+1).gt.Mpmin) THEN ! pas de flux de masse, XTP reste constant fac_ftmr(il)=0.0 endif !if (Mp(il,i+1).gt.Mpmin) THEN endif !if (Mp(il,i).gt.Mp(il,i+1)) THEN endif ! (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum ! ****** calcul de la vapeur dans le ddft avant réévap DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN IF (i.lt.INB(il)) THEN IF (Mp(il,i).gt.Mp(il,i+1)) THEN ! cas entrainant rat(il)=Mp(il,i+1)/Mp(il,i) qp_avantevap(il)=qp(il,i+1)*rat(il)+q(il,i)*(1-rat(il)) DO ixt=1,ntraciso xtp_avantevap(ixt,il)=xtp(ixt,il,i+1)*rat(il) & +xt(ixt,il,i)*(1-rat(il)) enddo else !if (Mp(il,i).gt.Mp(il,i+1)) THEN IF (Mp(il,i+1).gt.Mpmin) THEN ! cas non entrainant, mais flux existe qp_avantevap(il)=qp(il,i+1) DO ixt=1,ntraciso xtp_avantevap(ixt,il)=xtp(ixt,il,i+1) enddo else !if (Mp(il,i+1).gt.0) THEN ! pas de flux de masse, on ne calcule rien ! on garde le qp calculé dans cv3_unsat, original ! on suppose que le deltaD dans le ddft est celui de ! l'environnement qp_avantevap(il)=qp(il,i) IF (qp(il,i).gt.0) THEN #ifdef ISOVERIF CALL iso_verif_positif_strict(q(il,i), & 'appel_stewart 226') #endif DO ixt=1,ntraciso xtp_avantevap(ixt,il)=xt(ixt,il,i)/q(il,i)*qp(il,i) enddo else !if (qp(il,i).gt.0) THEN ! si qp est négatif, on met les isos dedans à 0 DO ixt=1,ntraciso xtp_avantevap(ixt,il)=0.0 enddo endif !if (qp(il,i).gt.0) THEN endif !if (Mp(il,i+1).gt.0) THEN endif !if (Mp(il,i).gt.Mp(il,i+1)) THEN else ! if i.lt.INB ! cas ou i=inb ! on garde le qp calculé dans cv3_unsat, original ! on suppose que le deltaD dans le ddft est celui de ! l'environnement qp_avantevap(il)=qp(il,i) IF (qp(il,i).gt.0) THEN DO ixt=1,ntraciso xtp_avantevap(ixt,il)=xt(ixt,il,i)/q(il,i)*qp(il,i) enddo else !if (qp(il,i).gt.0) THEN ! si qp négatif, on met les isotopes dedans à 0 DO ixt=1,ntraciso xtp_avantevap(ixt,il)=0.0 enddo endif !if (qp(il,i).gt.0) THEN endif ! if i.lt.INB(il) endif ! (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN CALL iso_verif_egalite_choix( & (xtp_avantevap(iso_eau,il)), & (qp_avantevap(il)), & 'appel stewart 95',errmax,errmaxrel) endif ! (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if (iso_eau.gt.0) THEN #endif ! ********* calculs des flux DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN Pqisup(il)=sigd_vec(il)/g*wt(il,i)*water(il,i+1)+wdtrain(il)/g Pqiinf(il)=sigd_vec(il)/g*wt(il,i)*water(il,i) ! ce qu'on aurait dans si ce ! ce qu s'évapore en i ne vient que de i, comme dans le schéma de ! KE original. Eqi_prime(il)=(evap(il,i)+evap(il,i+1))/2 & *100.*(PH(il,i)-PH(il,I+1))*sigd_vec(il)/g Eqi(il)=evap(il,i)*100.*(PH(il,i)-PH(il,I+1))*sigd_vec(il)/g Eqi_plus1(il)=evap(il,i+1)*100.*(PH(il,i)-PH(il,I+1))*sigd_vec(il)/g Pqiinf_par(il)=Pqisup(il)-Eqi_prime(il) Eqi_par(il)=Pqisup(il)-Pqiinf(il) DO ixt=1,ntraciso Pxtisup(ixt,il)=sigd_vec(il)/g*wt(il,i+1)*xtwater(ixt,il,i+1) & +xtwdtrain(ixt,il)/g enddo endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #ifdef ISOVERIF DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN CALL iso_verif_egalite_choix((Pqiinf(il)), & (Pqiinf_par(il)),'appel_setwart 218', & errmax,errmaxrel) endif !#ifdef ISOTRAC ! if ((option_traceurs.EQ.17).OR. ! : (option_traceurs.EQ.18)) THEN ! if (iso_verif_positif_nostop(( ! : Pxtisup(index_trac(izone_cond,iso_eau),il) ! : -Pxtisup(iso_eau,il)), ! : 'appel_stewart 332').EQ.1) THEN ! WRITE(*,*) 'Pxtisup(:,il)=',Pxtisup(:,il) ! WRITE(*,*) 'xtwater(:,il,i+1)=',xtwater(:,il,i+1) ! WRITE(*,*) 'xtwdtrain(:,il)=',xtwdtrain(:,il) ! stop ! endif !if (iso_verif_positif_nostop(Pxtisup(iso_eau,il)- ! endif !if ((option_traceurs.EQ.17).OR. !#endif enddo !do il=1,ncum ! il=370 ! WRITE(*,*) 'appel_stewart 327: il=',il ! WRITE(*,*) 'Pqisup,Pqiinf,Eqi_prime,Eqi,Pqiinf_par,Eqi_par=', ! : Pqisup(il),Pqiinf(il),Eqi_prime(il),Eqi(il), ! : Pqiinf_par(il),Eqi_par(il) ! WRITE(*,*) 'fac_ftmr=',fac_ftmr(il) ! WRITE(*,*) 'qp_avantevap,qp=',qp_avantevap(il),qp(il,i) #endif ! petite vérif sur les flux DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN IF ((Eqi_par(il).lt.0.0) & .AND.(Pqiinf_par(il).le.0.0) & .AND.(water(il,i).gt.ridicule/10.)) THEN ! dans ce cas, on a de l'eau sortant dont il faut déterminer la ! composition, mais pourtant le bilan de masse indique qu'il ! n'y a pas d'eau sortant. Et si on recalcule l'évap pour avoir de ! l'eau sortant, Eqi_par<0 -> condensation! On est donc très ! embétté car Eqi_prime indique qu'il y a évaporation... ! WRITE(*,*) 'appel_stewart 239: cas génant' IF (Eqi_prime(il)*fac_ftmr(il).lt. & qp_avantevap(il)*1e-2) THEN ! ouf: Eqi_prime a peut d'effet sur la vapeur du ddft. ! on peut donc condenser tranquillement pour obtenir de ! l'eau en sortie, ça ne changera pas grand chose sur la ! vapeur. Eqi_prime(il)=Eqi_par(il) else WRITE(*,*) 'appel_stewart 222: ce cas est très génant' stop endif endif endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO il=1,ncum xtp_avantevap(iso_eau,il)=qp_avantevap(il) Pxtisup(iso_eau,il)=Pqisup(il) enddo endif ! ******** parsage des différents cas + quelques vérifs icas_condensation_facftmr=0 icas_condensation_nofacftmr=0 icas_noevap=0 icas_evap_glace=0 icas_evap_liq=0 #ifdef ISOVERIF ! initialisation de l'outil de tracage de cas: DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN trace_cas(il)=0 else trace_cas(il)=-1 endif enddo !do il=1,ncum ! if (ncum.ge.602) THEN ! WRITE(*,*) 'appel_stewart tmp 379: avant parsage' ! il=602 ! WRITE(*,*) 'il,Eqi_prime(il)=',il,Eqi_prime(il) ! WRITE(*,*) 'fac_ftmr(il)=',fac_ftmr(il) ! WRITE(*,*) 'ridicule,errmax=',ridicule,errmax ! endif #endif DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN ! WRITE(*,*) 'tmp 417: il,Eqi_prime=',il,Eqi_prime(il) IF ((Eqi_prime(il).lt.-ridicule*1e-3).OR. & (Eqi_prime(il)*fac_ftmr(il).lt.-ridicule*10)) THEN ! modif le 10 mai 2009: si Eqi_prime très petit, on le ! traite comme du 0 ! modif 15 mai 2009: on rajoute condition sur Eqi*fac_ftmr ! modif le 5 dec 2012: on change les seuils pour homo avec ! noevap ! 1: Eqi_prime<0: condensation ! WRITE(*,*) 'tmp 426: condensation' IF (fac_ftmr(il).gt.ridicule/100.) THEN ! si fac_ftmr très petit, on le traite comme du 0 ! 1.1: si Mpi>0 icas_condensation_facftmr=icas_condensation_facftmr+1 cas_condensation_facftmr(icas_condensation_facftmr)=il #ifdef ISOVERIF trace_cas(il)=11 #endif else !if (fac_ftmr.gt.0.0) THEN ! 1.2: si Mpi=0 icas_condensation_nofacftmr=icas_condensation_nofacftmr+1 cas_condensation_nofacftmr(icas_condensation_nofacftmr)=il #ifdef ISOVERIF trace_cas(il)=12 #endif endif !if (fac_ftmr.gt.0.0) THEN ! ELSE IF ((abs(Eqi_prime(il)).lt.ridicule*1e-3).AND. ! : (abs(Eqi_prime(il)*fac_ftmr(il)).lt.ridicule*10)) THEN ELSE IF ((Eqi_prime(il).lt.ridicule*1e-3).AND. & (Eqi_prime(il)*fac_ftmr(il).lt.ridicule*10)) THEN ! 2: Eqi_prime est compris entre 1e-14 et -1e-14: rien ! ! 27 mai 2009: on remplace le seuil pour Eqi_prime(il)*fac_ftmr(il) ! ! de errmax/10 par ridicule*10 ! 18 sept 2009: on remplace ridicule*1e-2 par ridicule*1e-3 !pour éviter Eqi_prime=-1.87e-15, Pqisup=0 et water=1.44e-12 ! correction le 5 décembre 2012: il y a incohérence entre ! conditions condensation et noevap: ex de cas patho: ! Eqi'=-5e-15 et Eqi'*facftmr=-4e-10. Dans ce cas, tombe ! dans le trou entre condensation et noevap, et ça part dans ! l'évap positive! -> on enlève la valeur absolue. ! WRITE(*,*) 'tmp 457: noevap' icas_noevap=icas_noevap+1 cas_noevap(icas_noevap)=il #ifdef ISOVERIF trace_cas(il)=2 IF ((Pqisup(il).le.0.0).AND. & (water(il,i).gt.ridicule)) THEN WRITE(*,*) 'appel_stewart 420: water=',water(il,i) WRITE(*,*) 'Pqisup,Eqi_prime,fac_ftmr=',Pqisup(il), & Eqi_prime(il),fac_ftmr(il) stop endif #endif else !if (Eqi_prime.lt.0.0) THEN ! 3: Eqi_prime>0 #ifdef ISOVERIF ! WRITE(*,*) 'tmp 473: evap' ! quelques vérifs du bilan de masse d'eau IF (iso_verif_positif_nostop(( & Pqisup(il)-Eqi_prime(il)), & 'appel_stewart 388').EQ.1) THEN WRITE(*,*) 'Pqisup=',Pqisup(il) WRITE(*,*) 'Eqi_prime=',Eqi_prime(il) WRITE(*,*) 'Pqiinf=',Pqiinf(il) ! WRITE(*,*) 'stop temporaire, à enlever' ! stop endif IF (iso_verif_positif_choix_nostop(( & Pqisup(il)-Pqiinf_par(il)),errmax, & 'appel_stewart 442').EQ.1) THEN WRITE(*,*) 'appel_stewart 174' WRITE(*,*) 'Pqisup=',Pqisup(il), & ' Pqiinf_par=',Pqiinf_par(il) stop endif IF (iso_verif_positif_nostop((Eqi_par(il)), & 'appel_stewart 559b').EQ.1) THEN WRITE(*,*) 'Eqi(il),Eqi_plus1(il),Eqi_prime(il)=', & Eqi(il),Eqi_plus1(il),Eqi_prime(il) WRITE(*,*) 'Pqisup(il),Pqiinf(il),Eqi_par(il)=', & Pqisup(il),Pqiinf(il),Eqi_par(il) endif #endif IF (T(il,i).ge.ztglace_kelvin) THEN ! 3.1: evap des gouttes icas_evap_liq=icas_evap_liq+1 cas_evap_liq(icas_evap_liq)=il #ifdef ISOVERIF trace_cas(il)=31 #endif else !if (T(il,i).ge.ztglace_kelvin) THEN ! 3.2: evap de la glace icas_evap_glace=icas_evap_glace+1 cas_evap_glace(icas_evap_glace)=il #ifdef ISOVERIF trace_cas(il)=32 #endif endif !if (T(il,i).ge.ztglace_kelvin) THEN endif !if (Eqi_prime.lt.0.0) THEN endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum ncas_condensation_facftmr=icas_condensation_facftmr ncas_condensation_nofacftmr=icas_condensation_nofacftmr ncas_noevap=icas_noevap ncas_evap_liq=icas_evap_liq ncas_evap_glace=icas_evap_glace #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart vectoriel 355: parsage des cas:' ! if (ncum.ge.602) THEN ! WRITE(*,*) 'trace_cas(602)=',trace_cas(602) ! endif ncas_tot=0 DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN ncas_tot=ncas_tot+1 endif enddo ! WRITE(*,*) 'i,ncum,ncas_tot=',i,ncum,ncas_tot ! WRITE(*,*) 'ncas_condensation_facftmr=',ncas_condensation_facftmr ! WRITE(*,*) 'ncas_condensation_nofacftmr=', ! : ncas_condensation_nofacftmr ! WRITE(*,*) 'ncas_noevap=',ncas_noevap ! WRITE(*,*) 'ncas_evap_liq_=',ncas_evap_liq ! WRITE(*,*) 'ncas_evap_glace=',ncas_evap_glace IF (ncas_tot.NE.ncas_condensation_facftmr & +ncas_condensation_nofacftmr& +ncas_noevap& +ncas_evap_liq & +ncas_evap_glace) THEN WRITE(*,*) 'mauvais parsage' stop endif !if (ncas_tot.NE.ncas_condensation_facftmr #endif ! ****** traitement vectoriel du cas 1.1 IF (ncas_condensation_facftmr.gt.0) THEN CALL compress_cond_facftmr(ncas_condensation_facftmr, & cas_condensation_facftmr, & Eqi_prime_cas,Eqi_prime, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & T_cas,T(1,i), & fac_ftmr_cas,fac_ftmr, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1),& water_cas,water(1,i),& delP_cas,Ph, & sigd_cas,sigd_vec, & #ifdef ISOVERIF evap_cas(1),evap(1,i),qp_cas(1),qp(1,i), & #endif nloc,ncum,nd,i) #ifdef ISOVERIF ! vérif de la compression WRITE(*,*) 'appel_stewart tmp 506: ', & 'après compress_condensation_facftmr' WRITE(*,*) 'cas_condensation_facftmr(1)=', & cas_condensation_facftmr(1) WRITE(*,*) 'sigd_cas(1:3)=',sigd_cas(1:3) DO il=1,ncas_condensation_facftmr CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_condensation_facftmr(il))), & 'appel_stewart 457: compression condensation_facftmr', & errmax,errmax) CALL iso_verif_egalite_choix(water_cas(il), & water(cas_condensation_facftmr(il),i), & 'appel_stewart 460: compression condensation_facftmr', & errmax,errmax) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)),& 'appel_stewart 520: compression condensation_facftmr',& errmax,errmax) endif ! if (iso_eau.gt.0) THEN enddo ! do il=1,ncas_condensation_facftmr #endif CALL make_condensation_facftmr(ncas_condensation_facftmr, & Eqi_prime_cas(1),Pqisup_cas(1),Pxtisup_cas(1,1), & fac_ftmr_cas(1),T_cas(1),& qp_avantevap_cas(1),xtp_avantevap_cas(1,1),water_cas(1),& delP_cas(1),xtevapsup_cas(1,1),ztglace_kelvin, & xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1),g,sigd_cas(1) & #ifdef ISOVERIF ,evap_cas,qp_cas,1 & #endif ) #ifdef ISOVERIF DO il=1,ncas_condensation_facftmr DO ixt=1,niso CALL iso_verif_noNaN(xtwater_cas(ixt,il), & 'appel_stewart 539') enddo enddo #endif CALL uncompress_commun(ncas_condensation_facftmr, & cas_condensation_facftmr, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC DO izone=1,ntraceurs_zone !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 538: condensation_facftmr, izone=', ! & izone !#endif CALL compress_cond_facftmr_zone( & ncas_condensation_facftmr, & cas_condensation_facftmr, & Eqi_prime_cas,Eqi_prime,& Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & qp_avantevap_cas,qp_avantevap,& xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1),& water_cas,water(1,i),& #ifdef ISOVERIF evap_cas(1),evap(1,i), & #endif nloc,ncum,nd,i,izone) #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncas_condensation_facftmr CALL iso_verif_egalite_choix( & (qp_avantevap_cas(il)), & (xtp_avantevap_cas(iso_eau,il)), & 'appel_stewart 558',errmax,errmaxrel) enddo !do il=1,ncas_condensation_nofacftmr endif !if (iso_eau.gt.0) THEN #endif CALL make_condensation_facftmr(ncas_condensation_facftmr, & Eqi_prime_cas(1),Pqisup_cas(1),Pxtisup_cas(1,1), & fac_ftmr_cas(1),T_cas(1), & qp_avantevap_cas(1),xtp_avantevap_cas(1,1),water_cas(1),& delP_cas(1),xtevapsup_cas(1,1),ztglace_kelvin, & xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1),g,sigd_cas(1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),1 & #endif ) #ifdef ISOVERIF DO il=1,ncas_condensation_facftmr DO ixt=1,niso CALL iso_verif_noNaN(xtwater_cas(ixt,il), & 'appel_stewart 588') enddo enddo #endif !#ifdef ISOVERIF CALL uncompress_commun_zone(ncas_condensation_facftmr, & cas_condensation_facftmr, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone) enddo !do izone=1,ntraceurs_zone #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 574: ', ! : 'fin cas condensation_facftmr' DO il=1,ncas_condensation_facftmr ! WRITE(*,*) 'il,cas_condensation_facftmr(il)=', ! : il,cas_condensation_facftmr(il) ! WRITE(*,*) 'xtp(1:ntraciso:3)=',xtp(1:ntraciso:3, ! : cas_condensation_facftmr(il),i) ! WRITE(*,*) 'xtp_avantevap(1:ntraciso:3)=', ! : xtp_avantevap(1:ntraciso:3, ! : cas_condensation_facftmr(il)) ! if (il.EQ.cas_condensation_facftmr(602)) THEN ! WRITE(*,*) 'appel_stewart 638: il=602' ! WRITE(*,*) 'xtp(iso_eau:ntraciso:3,il,i)=', ! : xtp(iso_eau:ntraciso:3,cas_condensation_facftmr(il),i) ! endif CALL iso_verif_traceur(xtp & (1,cas_condensation_facftmr(il),i), & 'appel_stewart_vectall 557') CALL iso_verif_traceur(xtwater & (1,cas_condensation_facftmr(il),i), & 'appel_stewart_vectall 560') CALL iso_verif_traceur_justmass(xtevap & (1,cas_condensation_facftmr(il),i),& 'appel_stewart_vectall 563') enddo !do il=1,ncas_condensation_nofacftmr #endif !#ifdef ISOVERIF #endif !#ifdef ISOTRAC endif !if (ncas_condensation_facftmr.gt.0) THEN ! ****** traitement vectoriel du cas 1.2 IF (ncas_condensation_nofacftmr.gt.0) THEN CALL compress_cond_nofftmr(ncas_condensation_nofacftmr, & cas_condensation_nofacftmr, & Eqi_prime_cas,Eqi_prime(1), & Pqisup_cas,Pqisup(1), & Pxtisup_cas,Pxtisup(1,1), & water_cas,water(1,i), & T_cas,T(1,i), & qp_avantevap_cas,qp_avantevap(1), & xtp_avantevap_cas,xtp_avantevap(1,1), & xt_cas,xt(1,1,i),q_cas,q(1,i), & xtevapsup_cas,xtevap(1,1,i+1),& delP_cas,Ph, & sigd_cas,sigd_vec, & #ifdef ISOVERIF evap_cas(1),evap(1,i),qp_cas(1),qp(1,i), & #endif nloc,ncum,nd,i) #ifdef ISOVERIF ! vérif de la compression ! WRITE(*,*) 'appel_stewart tmp 616: ', & ! & 'après compress condensation_nofacftmr' ! WRITE(*,*) 'iso_routines 6854: sigd_cas(1:3)=', sigd_cas(1:3) DO il=1,ncas_condensation_nofacftmr CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_condensation_nofacftmr(il))), & 'appel_stewart 594: compression condensation_nofacftmr', & errmax,errmax) CALL iso_verif_egalite_choix(T_cas(il), & T(cas_condensation_nofacftmr(il),i), & 'appel_stewart 597: compression condensation_nofacftmr',& errmax,errmax) enddo #endif CALL make_condensation_nofacftmr(ncas_condensation_nofacftmr, & Eqi_prime_cas(1),Pqisup_cas(1), & Pxtisup_cas(1,1),water_cas(1),T_cas(1), & qp_avantevap_cas(1), xtp_avantevap_cas(1,1), & q_cas(1),xt_cas(1,1), & xtevapsup_cas(1,1) ,delP_cas(1), & ztglace_Kelvin, g,sigd_cas(1), & xtevap_cas(1,1),xtp_cas(1,1),xtwater_cas(1,1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),0 & #endif ) CALL uncompress_commun(ncas_condensation_nofacftmr, & cas_condensation_nofacftmr, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC DO izone=1,ntraceurs_zone ! WRITE(*,*) 'appel_stewart 718: izone=',izone CALL compress_cond_nofftmr_zone( & ncas_condensation_nofacftmr, & cas_condensation_nofacftmr, & Eqi_prime_cas,Eqi_prime(1),& Pqisup_cas,Pqisup(1), & Pxtisup_cas,Pxtisup(1,1), & water_cas,water(1,i), & qp_avantevap_cas,qp_avantevap(1), & xtp_avantevap_cas,xtp_avantevap(1,1), & xt_cas,xt(1,1,i),q_cas,q(1,i), & xtevapsup_cas,xtevap(1,1,i+1), & #ifdef ISOVERIF evap_cas(1),evap(1,i), & #endif nloc,ncum,nd,i,izone) CALL make_condensation_nofacftmr(ncas_condensation_nofacftmr, & Eqi_prime_cas(1),Pqisup_cas(1), & Pxtisup_cas(1,1),water_cas(1),T_cas(1), & qp_avantevap_cas(1), xtp_avantevap_cas(1,1), & q_cas(1),xt_cas(1,1), & xtevapsup_cas(1,1) ,delP_cas(1), & ztglace_Kelvin, g,sigd_cas(1), & xtevap_cas(1,1),xtp_cas(1,1),xtwater_cas(1,1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),1 & #endif ) CALL uncompress_commun_zone(ncas_condensation_nofacftmr, & cas_condensation_nofacftmr, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone) enddo !do izone=1,ntraceurs_zone #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 690: ', ! : 'fin du cas condensation_nofacftmr' DO il=1,ncas_condensation_nofacftmr CALL iso_verif_traceur(xtp & (1,cas_condensation_nofacftmr(il),i), & 'appel_stewart_vectall 651') CALL iso_verif_traceur(xtwater & (1,cas_condensation_nofacftmr(il),i), & 'appel_stewart_vectall 653') CALL iso_verif_traceur_justmass(xtevap & (1,cas_condensation_nofacftmr(il),i), & 'appel_stewart_vectall 655') enddo !do il=1,ncas_condensation_nofacftmr #endif #endif endif !if (ncas_condensation_nofacftmr.gt.0) THEN ! ****** traitement vectoriel du cas 2 IF (ncas_noevap.gt.0) THEN CALL compress_noevap(ncas_noevap, & cas_noevap, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i),& delP_cas,Ph, & #ifdef ISOVERIF evap_cas(1),evap(1,i),qp_cas(1),qp(1,i), & #endif nloc,ncum,nd,i) #ifdef ISOVERIF ! vérif de la compression ! WRITE(*,*) 'appel stewart 719: après compression iso noevap' DO il=1,ncas_noevap CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_noevap(il))), & 'appel_stewart 692: compression',errmax,errmaxrel) CALL iso_verif_egalite_choix(water_cas(il), & water(cas_noevap(il),i), & 'appel_stewart 693: compression',errmax,errmaxrel) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)), & 'appel_stewart 759',errmax,errmaxrel) CALL iso_verif_egalite_choix( & (xtp_avantevap(iso_eau,cas_noevap(il))), & qp(cas_noevap(il),i), & 'appel_stewart 739',errmax,errmaxrel) CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & qp_cas(il), & 'appel_stewart 735',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN enddo !do il=1,ncas_noevap #endif CALL make_cas_noevap(ncas_noevap, & xtp_avantevap_cas(1,1),xtevapsup_cas(1,1), & Pxtisup_cas(1,1),Pqisup_cas(1),water_cas(1), & xtevap_cas(1,1),xtp_cas(1,1),xtwater_cas(1,1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),0 & #endif ) CALL uncompress_commun(ncas_noevap,cas_noevap, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC DO izone=1,ntraceurs_zone CALL compress_noevap_zone(ncas_noevap, & cas_noevap, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i), & #ifdef ISOVERIF evap_cas(1),evap(1,i), & #endif nloc,ncum,nd,i,izone) #ifdef ISOVERIF ! WRITE(*,*) 'appel stewart 765: après compression isotrac' DO il=1,ncas_noevap CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)), & 'appel_stewart 759',errmax,errmaxrel) enddo !do il=1,ncas_noevap #endif CALL make_cas_noevap(ncas_noevap, & xtp_avantevap_cas(1,1),xtevapsup_cas(1,1), & Pxtisup_cas(1,1),Pqisup_cas(1),water_cas(1), & xtevap_cas(1,1),xtp_cas(1,1),xtwater_cas(1,1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),1& #endif ) CALL uncompress_commun_zone(ncas_noevap,cas_noevap, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone) enddo !do izone=1,ntraceurs_zone #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 806: ', ! : 'fin du cas noevap' DO il=1,ncas_noevap CALL iso_verif_traceur(xtp(1,cas_noevap(il),i), & 'appel_stewart_vectall 734') CALL iso_verif_traceur(xtevap(1,cas_noevap(il),i), & 'appel_stewart_vectall 736') CALL iso_verif_traceur(xtwater(1,cas_noevap(il),i), & 'appel_stewart_vectall 738') enddo !do il=1,ncas_noevap #endif #endif endif !if (ncas_noevap.gt.0) THEN ! ****** traitement vectoriel du cas 3.1 IF (ncas_evap_liq.gt.0) THEN CALL compress_evap_liq(30,ncas_evap_liq, & cas_evap_liq, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i), & qs_cas,qs(1,i), & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas, & Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime, & Eqi,Eqi_cas, & fac_ftmr_cas,fac_ftmr, & T_cas,T(1,i), & wt_cas,wt(1,i), & INB_cas,INB(1), & delP_cas,Ph, & qp_cas,qp(1,i), & sigd_cas,sigd_vec, & #ifdef ISOVERIF evap_cas,evap(1,i), & #endif nloc,ncum,nd,i) #ifdef ISOVERIF ! vérif de la compression ! WRITE(*,*) 'appel_stewart tmp 899: ', ! : 'après compress_evap_liq' DO il=1,ncas_evap_liq ! WRITE(*,*) 'il=',il ! WRITE(*,*) 'qp_avantevap_cas(il),xtp_avantevap_cas(iso_eau,il)=', ! : qp_avantevap_cas(il),xtp_avantevap_cas(iso_eau,il) CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_evap_liq(il))), & 'appel_stewart 822: compression evap_liq', & errmax,errmax) CALL iso_verif_egalite_choix(water_cas(il), & water(cas_evap_liq(il),i), & 'appel_stewart 825: compression evap_liq', & errmax,errmax) CALL iso_verif_egalite_choix( & (qp_avantevap_cas(il)), & (qp_avantevap(cas_evap_liq(il))), & 'appel_stewart 783: compression evap_liq', & errmax,errmax) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart 789: compression evap_liq', & errmax,errmax) endif enddo !do il=1,ncas_evap_liq #endif DO il=1,ncas_evap_liq qeff(il)=thumxt1*Qs_cas(il) & +(1.0-thumxt1)*qp_avantevap_cas(il) enddo !do il=1,ncas_evap_liq ! WRITE(*,*) 'appel tmp 802: xtp_avantevap_cas(iso_eau,2)=', ! : xtp_avantevap_cas(iso_eau,2) ! WRITE(*,*) 'appel tmp 1490: qp_avantevap_cas(2)=', ! : qp_avantevap_cas(2) ! WRITE(*,*) 'appel_stewart 933: make_cas_evap_liq pr eau normale' ! ici, ptrac ne sera pas utilisé CALL make_cas_evap_liq(ncas_evap_liq, & water_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & Pxtisup_cas(1,1),Pqisup_cas(1), & Eqi_stewart(1),Pqiinf_stewart(1),fac_ftmr_cas(1), & qs_cas(1), T_cas(1),wt_cas(1), delP_cas(1), & xtevapsup_cas(1,1),qeff(1),g,sigd_cas(1), Eqi_prime_cas(1), & qp_cas(1), INB_cas(1),i,0, & #ifdef ISOTRAC ptrac(1),hdiag(1), & #endif #ifdef ISOVERIF evap_cas(1),Exi_cas(1,1), & #endif xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1)) CALL uncompress_commun(ncas_evap_liq,cas_evap_liq, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC ! initialisation dans le cas où la revap est taggée: IF (option_revap.EQ.1) THEN DO il=1,ncas_evap_liq DO iiso=1,niso ixt=index_trac(izone_revap,iiso) xtevap(ixt,cas_evap_liq(il),i)=0.0 xtp(ixt,cas_evap_liq(il),i)= & xtp_avantevap(ixt,cas_evap_liq(il)) enddo !do iiso=1,niso enddo !do il=1,ncas_evap_glace endif !if (option_revap.EQ.1) th DO izone=1,ntraceurs_zone ! WRITE(*,*) 'appel_stewart 924 tmp: cas liq: izone=',izone ! WRITE(*,*) 'appel 924: xtp_avantevap(c,cas(2))=', ! : xtp_avantevap(1:ntraciso:3,cas_evap_liq(2)) ! WRITE(*,*) 'Pxtisup(1:ntraciso:3,cas(2))=', ! : Pxtisup(1:ntraciso:3,cas_evap_liq(2)) CALL compress_evap_liq_zone(30,ncas_evap_liq, & cas_evap_liq, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtp_avantevaptrac_cas, qp_avantevaptrac_cas, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i), & 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(1,i), & #endif nloc,ncum,nd,izone) #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 941' ! if (ncas_evap_liq.ge.162) THEN ! WRITE(*,*) 'Eqi_prime_cas=',Eqi_prime_cas(162) ! WRITE(*,*) 'Pqisup=',Pqisup(cas_evap_liq(162)) ! WRITE(*,*) 'Eqi_prime=',Eqi_prime(cas_evap_liq(162)) ! WRITE(*,*) 'Pxtisup=', ! : Pxtisup(iso_eau:ntraciso:3,cas_evap_liq(162)) ! endif ! WRITE(*,*) 'qp_avantevap_cas(2)=', ! : qp_avantevap_cas(2) ! WRITE(*,*) 'xtp_avantevap(iso_eau,cas_evap_liq(1))=', ! : xtp_avantevap(iso_eau,cas_evap_liq(1)) ! WRITE(*,*) 'xtp_avantevap_cas(iso_eau,2)=', ! : xtp_avantevap_cas(iso_eau,2) ! WRITE(*,*) 'xtp_avantevaptrac_cas(iso_eau,2)=', ! : xtp_avantevaptrac_cas(iso_eau,2) IF (iso_eau.gt.0) THEN DO il=1,ncas_evap_liq ! WRITE(*,*) 'appel_stewart tmp 943: il=',il CALL iso_verif_egalite_choix( & (qp_avantevap(cas_evap_liq(il))), & (xtp_avantevap(iso_eau,cas_evap_liq(il))), & 'appel_stewart 944', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (qp_avantevap(cas_evap_liq(il))), & (qp_avantevap_cas(il)), & 'appel_stewart 951', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (xtp_avantevap(iso_eau,cas_evap_liq(il))), & (xtp_avantevap_cas(iso_eau,il)), & 'appel_stewart 956', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (qp_avantevap_cas(il)), & (xtp_avantevap_cas(iso_eau,il)), & 'appel_stewart 961', & errmax,errmaxrel) ! if ((option_traceurs.EQ.17).OR. ! : (option_traceurs.EQ.18)) THEN ! if (izone.EQ.izone_cond) THEN ! CALL iso_verif_positif(( ! : Pxtisup_cas(iso_eau,il) ! : -Pxtisup(iso_eau,cas_evap_liq(il))), ! : 'appel_stewart_vectall 1114') ! else !if (izone.EQ.izone_cond) THEN ! CALL iso_verif_positif(( ! : -Pxtisup_cas(iso_eau,il)), ! : 'appel_stewart_vectall 1118') ! endif !if (izone.EQ.izone_cond) THEN ! endif !if ((option_traceurs.EQ.17).OR. enddo !do il=1,ncas_evap_liq endif !if (iso_eau.gt.0) THEN #endif CALL make_cas_evap_liq(ncas_evap_liq, & water_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & xtp_avantevaptrac_cas(1,1),qp_avantevaptrac_cas(1), & Pxtisup_cas(1,1),Pqisup_cas(1), & Eqi_stewart(1),Pqiinf_stewart(1),fac_ftmr_cas(1), & qs_cas(1), T_cas(1),wt_cas(1), delP_cas(1), & xtevapsup_cas(1,1),qeff(1), g,sigd_cas(1),Eqi_prime_cas(1),& qp_cas(1),INB_cas(1),i,1, & ptrac(1),hdiag(1), & #ifdef ISOVERIF evap_cas(1),Exi_cas(1,1), & #endif xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1)) ! verif #ifdef ISOVERIF DO il=1,ncas_evap_liq DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il),'appel stewart 198') CALL iso_verif_noNAN(xtevap_cas(ixt,il), & 'appel stewart 745') enddo !do ixt=1,niso ! if ((option_traceurs.EQ.17).OR.(option_traceurs.EQ.18)) THEN ! if (izone.EQ.izone_cond) THEN ! CALL iso_verif_positif(xtwater_cas(iso_eau,il) ! : -xtwater(iso_eau,cas_evap_liq(il),i), ! : 'appel_stewart_vectall 1138') ! else !if (izone.EQ.izone_cond) THEN ! CALL iso_verif_positif(-xtwater_cas(iso_eau,il), ! : 'appel_stewart_vectall 1147') ! endif !if (izone.EQ.izone_cond) THEN ! endif !if ((option_traceurs.EQ.17).OR. enddo !do il=1,ncas_evap_liq #endif CALL uncompress_commun_zone_revap(ncas_evap_liq,cas_evap_liq, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone,Eqi_stewart,fac_ftmr_cas, & #ifdef ISOVERIF Exi_cas(1,1),Exi(1,1), & #endif xtp_avantevaptrac_cas,1,hdiag(1)) enddo ! do izone=ntraceurs_zone #ifdef ISOVERIF DO il=1,ncas_evap_liq IF (iso_verif_traceur_nostop(xtp(1,cas_evap_liq(il),i), & 'appel_stewart_vectall 1256').EQ.1) THEN WRITE(*,*) 'il,cas_evap_liq(il)=',il,cas_evap_liq(il) WRITE(*,*) 'trace_cas(cas_evap_liq(il))=', & trace_cas(cas_evap_liq(il)) IF (trace_cas(cas_evap_liq(il)).EQ.31) THEN WRITE(*,*) 'cas evap_liq' WRITE(*,*) 'xtp(:,cas_evap_liq(il),i)=', & xtp(:,cas_evap_liq(il),i) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'Eqi_stewart(il),Eqi_prime=', & Eqi_stewart(il),Eqi_prime(cas_evap_liq(il)) WRITE(*,*) 'Pxtisup(:,cas_evap_liq(il))=', & Pxtisup(:,cas_evap_liq(il)) WRITE(*,*) 'xtp_avantevap(:,cas_evap_liq(il))=', & xtp_avantevap(:,cas_evap_liq(il)) WRITE(*,*) 'Exi(:,cas_evap_liq(il))=', & Exi(:,cas_evap_liq(il)) WRITE(*,*) 'T_cas(il)=',T_cas(il) WRITE(*,*) 'h(il)=',thumxt1+(1.0-thumxt1)* & qp_avantevap_cas(il)/qs_cas(il) endif !if (trace_cas(il).EQ.31) THEN ! en cas de problème ci, activer l'option débug de ! stewart_explicit ! stop ! le 22 aout: on replace errmaxrel*20 par errmaxrel*25 ! pour que ça marche à l'idris CALL iso_verif_traceur_choix(xtp(1,cas_evap_liq(il),i), & 'appel_stewart_vectall 1154', & errmax,errmaxrel*25,ridicule_trac,deltalimtrac) endif !if (iso_verif_traceur_nostop ! dans le test suivant, c'est errmaxrel*50 CALL iso_verif_traceur_pbidouille( & xtp(1,cas_evap_liq(il),i), & 'appel_stewart_vectall 1124') CALL iso_verif_traceur_justmass(xtevap(1,cas_evap_liq(il),i), & 'appel_stewart_vectall 1258') ! WRITE(*,*) 'appel_stewart tmp 1172: il,i=',il,i CALL iso_verif_traceur(xtwater(1,cas_evap_liq(il),i), & 'appel_stewart_vectall 1260') enddo !do il=1,ncas_evap_liq #endif #endif endif !if (ncas_evap_liq.gt.0) THEN ! ****** traitement vectoriel du cas 3.2 IF (ncas_evap_glace.gt.0) THEN CALL compress_evap_glace(30, & ncas_evap_glace,cas_evap_glace, & water_cas,water(1,i), & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & T_cas,T(1,i), & fac_ftmr_cas,fac_ftmr, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas,Eqi_cas, & Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime,Eqi, & INB_cas,INB(1), & delP_cas,Ph, & qp_cas,qp(1,i),& sigd_cas,sigd_vec, & #ifdef ISOVERIF evap_cas,evap(1,i),& #endif nloc,ncum,nd,i,frac_sublim) #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 898 après compress glace' ! WRITE(*,*) 'qp_avantevap_cas(1),qp_avantevap(cas(1))=', ! : qp_avantevap_cas(1),qp_avantevap(cas_evap_glace(1)) ! vérif de la compression DO il=1,ncas_evap_glace ! WRITE(*,*) 'il=',il ! WRITE(*,*) 'qp_avantevap_cas(il),qp_avantevap(cas(il))=', ! & qp_avantevap_cas(il),qp_avantevap(cas_evap_glace(il)) CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_evap_glace(il))), & 'appel_stewart 1096: compression evap_glace', & errmax,errmax) CALL iso_verif_egalite_choix(water_cas(il), & water(cas_evap_glace(il),i), & 'appel_stewart 1099: compression evap_glace',& errmax,errmax) CALL iso_verif_egalite_choix(evap_cas(il), & evap(cas_evap_glace(il),i), & 'appel_stewart 910: compression evap_glace', & errmax,errmax) CALL iso_verif_egalite_choix(xtevapsup_cas(iso_eau,il),& xtevap(iso_eau,cas_evap_glace(il),i+1), & 'appel_stewart 1106: compression evap_glace', & errmax,errmax) CALL iso_verif_egalite_choix( & (qp_avantevap_cas(il)), & (qp_avantevap(cas_evap_glace(il))), & 'appel_stewart 914: compression evap_glace', & errmax,errmax) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart 919: compression evap_glace',& errmax,errmax) endif !if (iso_eau.gt.0) THEN enddo !do il=1,ncas_evap_glace ! WRITE(*,*) 'appel_stewart tmp 1054 appel make_cas_evap_glace' #endif CALL make_cas_evap_glace(ncas_evap_glace, & water_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & Pxtisup_cas(1,1),Pqisup_cas(1), & Eqi_stewart(1),Eqi_prime_cas(1), & Pqiinf_stewart(1),fac_ftmr_cas(1),& qs_cas(1), T_cas(1),wt_cas(1), delP_cas(1), & xtevapsup_cas(1,1),g,sigd_cas(1),INB_cas(1),i, & frac_sublim,qp_cas(1), & #ifdef ISOVERIF evap_cas(1),0,Exi_cas(1,1), & #endif xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1)) !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 1073 après make_cas_evap_glace' !#endif CALL uncompress_commun(ncas_evap_glace,cas_evap_glace, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC ! initialisation dans le cas où la revap est taggée: IF (option_revap.EQ.1) THEN DO il=1,ncas_evap_glace DO iiso=1,niso ixt=index_trac(izone_revap,iiso) xtevap(ixt,cas_evap_glace(il),i)=0.0 xtp(ixt,cas_evap_glace(il),i)= & xtp_avantevap(ixt,cas_evap_glace(il)) enddo !do iiso=1,niso enddo !do il=1,ncas_evap_glace endif !if (option_revap.EQ.1) THEN DO izone=1,ntraceurs_zone ! WRITE(*,*) 'tmp appel_stewart 1284: izone=',izone CALL compress_evap_glace_zone(30, & ncas_evap_glace,cas_evap_glace, & water_cas,water(1,i), & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtp_avantevaptrac_cas,qp_avantevaptrac_cas, & xtevapsup_cas,xtevap(1,1,i+1),& Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas,Eqi_cas, & Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime,Eqi, & ! & qp_cas, #ifdef ISOVERIF evap_cas,evap(1,i), & #endif nloc,ncum,nd,i,frac_sublim,izone) !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 1101 CALL make_cas_evap_glace' !#endif CALL make_cas_evap_glace(ncas_evap_glace, & water_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & xtp_avantevaptrac_cas(1,1),qp_avantevaptrac_cas(1), & Pxtisup_cas(1,1),Pqisup_cas(1), & Eqi_stewart(1),Eqi_prime_cas(1), & Pqiinf_stewart(1),fac_ftmr_cas(1), & qs_cas(1), T_cas(1),wt_cas(1), delP_cas(1), & xtevapsup_cas(1,1),g,sigd_cas(1),INB_cas(1),i, & frac_sublim,qp_cas(1), & #ifdef ISOVERIF evap_cas(1),1,Exi_cas(1,1), & #endif xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1)) !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 1134 après make_cas_evap_glace' ! WRITE(*,*) 'izone,xtp_avantevap_cas(1)=',izone, ! : xtp_avantevap_cas(1:niso,1) ! WRITE(*,*) 'izone,xtp_avantevaptrac_cas(1)=',izone, ! & xtp_avantevaptrac_cas(1:niso,1) !#endif CALL uncompress_commun_zone_revap(ncas_evap_glace,cas_evap_glace, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone,Eqi_stewart,fac_ftmr_cas, & #ifdef ISOVERIF Exi_cas(1,1),Exi(1,1), & #endif xtp_avantevaptrac_cas,0,hdiag(1)) ! hdiag ne sera pas utilisé enddo ! do izone=1,ntraceurs_zone #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 1117: ', ! : 'fin du cas evap_glace' DO il=1,ncas_evap_glace ! WRITE(*,*) 'appel_stewart tmp 1146: il=',il ! WRITE(*,*) 'xtp_avantevap=',xtp_avantevap ! : (1:ntraciso,cas_evap_glace(il)) ! WRITE(*,*) 'xtp=',xtp(1:ntraciso,cas_evap_glace(il),i) IF (iso_verif_traceur_nostop(xtp(1,cas_evap_glace(il),i), & 'appel_stewart_vectall 1314').EQ.1) THEN WRITE(*,*) 'il,cas_evap_glace(il)=',il,cas_evap_glace(il) WRITE(*,*) 'trace_cas(cas_evap_glace(il))=', & trace_cas(cas_evap_glace(il)) WRITE(*,*) 'cas evap_glace' WRITE(*,*) 'xtp(:,cas_evap_glace(il),i)=', & xtp(:,cas_evap_glace(il),i) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'Eqi_stewart(il)=',Eqi_stewart(il) WRITE(*,*) 'Pxtisup(:,cas_evap_glace(il))=', & Pxtisup(:,cas_evap_glace(il)) WRITE(*,*) 'xtp_avantevap(:,cas_evap_glace(il))=', & xtp_avantevap(:,cas_evap_glace(il)) WRITE(*,*) 'Exi(:,cas_evap_glace(il))=', & Exi(:,cas_evap_glace(il)) ! on laisse quand même une chance CALL iso_verif_traceur_pbidouille( & xtp(1,cas_evap_glace(il),i), & 'appel_stewart_vectall 1331') endif CALL iso_verif_traceur(xtevap(1,cas_evap_glace(il),i), & 'appel_stewart_vectall 2150') CALL iso_verif_traceur(xtwater(1,cas_evap_glace(il),i), & 'appel_stewart_vectall 2152') enddo !do il=1,ncas_evap_glace #endif #endif endif !if (ncas_evap_glace.gt.0) THEN ! ****** dernières vérifs et bidouilles #ifdef ISOVERIF DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN ! WRITE(*,*) 'appel_stewart 1380 temp: il,trace_cas(il)=', ! & il,trace_cas(il) DO ixt=1,ntraciso CALL iso_verif_noNAN(xtp(ixt,il,i), & 'appel_stewart 1382') CALL iso_verif_noNAN(xtwater(ixt,il,i), & 'appel_stewart 1381') CALL iso_verif_noNAN(xtevap(ixt,il,i), & 'appel_stewart 1661') enddo !do ixt=1,ntraciso IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop(xtwater(iso_eau,il,i), & water(il,i),'appel stewart 1277, fin, water', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'il,i,trace_cas=',il,i,trace_cas(il) stop endif !if (iso_verif_egalite_choix_nostop( IF (iso_verif_egalite_choix_nostop( & xtp(iso_eau,il,i),qp(il,i),'appel stewart 1278', & errmax,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'il,i,trace_cas=',il,i,trace_cas(il) stop endif !if (iso_verif_egalite_choix_nostop( IF (iso_verif_egalite_choix_nostop( & xtevap(iso_eau,il,i),evap(il,i), & 'appel stewart 1279', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'il,i,trace_cas=',il,i,trace_cas(il) stop endif !if (iso_verif_egalite_choix_nostop( endif !if (iso_eau.gt.0) THEN IF ((iso_HDO.gt.0).AND. & (qp(il,i).gt.ridicule)) THEN CALL iso_verif_aberrant( & xtp(iso_HDO,il,i)/qp(il,i), & 'appel_stewart 1498') endif ! if (iso_HDO.gt.0) THEN #ifdef ISOTRAC ! if (il.EQ.602) THEN ! WRITE(*,*) 'appel_stewart 1334: il,i=',il,i ! WRITE(*,*) 'xtp(iso_eau:ntraciso:3,il,i)=', ! : xtp(iso_eau:ntraciso:3,il,i) ! endif CALL iso_verif_traceur(xtp(1,il,i), & 'appel_stewart_vectall 1632') CALL iso_verif_traceur_justmass(xtevap(1,il,i), & 'appel_stewart_vectall 1634') CALL iso_verif_traceur(xtwater(1,il,i), & 'appel_stewart_vectall 1636') ! if ((option_traceurs.EQ.17).OR. ! & (option_traceurs.EQ.18)) THEN ! if (iso_verif_positif_nostop(xtwater( ! & index_trac(izone_cond,iso_eau),il,i) ! & -xtwater(iso_eau,il,i), ! & 'appel_stewart_vectall 1457').EQ.1) THEN ! WRITE(*,*) 'il,trace_cas=',il,trace_cas(il) ! stop ! endif !if (iso_verif_positif_nostop(xtwater(iso_eau,il,i)- ! endif !if ((option_traceurs.EQ.17).OR. #endif endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN xtwater(iso_eau,il,i)= water(il,i) xtp(iso_eau,il,i)=qp(il,i) xtevap(iso_eau,il,i)= evap(il,i) #ifdef ISOTRAC #ifdef ISOVERIF CALL iso_verif_traceur_pbidouille(xtp(1,il,i), & 'appel_stewart_vectall 1362') CALL iso_verif_traceur_pbidouille( & xtwater(1,il,i), & 'appel_stewart_vectall 1381') #else CALL iso_verif_traceur_jbidouille(xtp(1,il,i)) CALL iso_verif_traceur_jbidouille(xtwater(1,il,i)) #endif #endif endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if (bidouille_anti_divergence) THEN !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart tmp 1197: sortie' !#endif END SUBROUTINE appel_stewart_vectall SUBROUTINE make_condensation_facftmr(ncas, & Eqi_prime_cas,Pqisup_cas,Pxtisup_cas, & fac_ftmr_cas,T_cas, & qp_avantevap_cas,xtp_avantevap_cas,water_cas, & delP_cas,xtevapsup_cas,ztglace_kelvin, & xtp_cas,xtwater_cas,xtevap_cas,g,sigd & #ifdef ISOVERIF ,evap_cas,qp_cas,oktrac & #endif ) USE isotopes_mod, ONLY: iso_eau, iso_HDO, Rdefault, ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas REAL ztglace_kelvin REAL T_cas(ncas),delP_cas(ncas), & xtevapsup_cas(niso,ncas),water_cas(ncas) real qp_avantevap_cas(ncas), & xtp_avantevap_cas(niso,ncas), & Pqisup_cas(ncas), Pxtisup_cas(niso,ncas), & Eqi_prime_cas(ncas),fac_ftmr_cas(ncas) REAL g,sigd(ncas) #ifdef ISOVERIF REAL evap_cas(ncas),qp_cas(ncas) INTEGER oktrac #endif ! outputs REAL xtevap_cas(niso,ncas),xtp_cas(niso,ncas), & xtwater_cas(niso,ncas) ! locals REAL Risup(niso,ncas), Rcond(niso,ncas) REAL xtice(ntraciso,ncas), xtliq(ntraciso,ncas) REAL xtp0(ntraciso,ncas), qp0(ncas) ! rq: xtice,xtliq,xtp0 sont de dimension ntraciso car condiso_liq_ice_vectall prend des choses de dimension ntraciso. Mais c'est une perte de mémoire. Seuls les premiers niso sont utilisés REAL fcond(ncas), fice(ncas), cond(ncas) REAL Exi_prime(niso,ncas) INTEGER il,ixt REAL zxtalphal,zxtalphai !#ifdef ISOVERIF ! real ! integer iso_verif_egalite_choix_nostop ! integer iso_verif_noNaN_nostop ! integer iso_verif_positif_nostop !#endif ! WRITE(*,*) 'ncas=',ncas DO il=1,ncas #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart 1349',errmax,errmaxrel) endif CALL iso_verif_noNaN((Eqi_prime_cas(il)), & 'appel_stewart 1357a') IF (iso_verif_noNaN_nostop((fac_ftmr_cas(il)), & 'appel_stewart 1357b').EQ.1) THEN WRITE(*,*) 'il=',il endif ! if (il.EQ.1) THEN ! WRITE(*,*) 'Eqi_prime_cas=',Eqi_prime_cas(il) ! WRITE(*,*) 'fac_ftmr_cas=',fac_ftmr_cas(il) ! WRITE(*,*) 'Pqisup_cas=',Pqisup_cas(il) ! WRITE(*,*) 'qp_avantevap_cas=',qp_avantevap_cas(il) ! endif #endif IF ((Eqi_prime_cas(il).gt.-ridicule*1e-2).AND. & (Eqi_prime_cas(il)*fac_ftmr_cas(il).gt.-ridicule*10).AND. & (Pqisup_cas(il).le.0.0)) THEN fcond(il)=1.0 cond(il)=0.0 !#ifdef ISOVERIF ! WRITE(*,*) 'tmp 1399: il,cond,Eqi,fac_ftmr_cas=', & ! & il,cond(il),Eqi_prime_cas(il),fac_ftmr_cas(il) !#endif else !if ((Eqi_prime_cas(il).gt.-ridicule*1e-2).AND. fcond(il)=-Eqi_prime_cas(il)/(Pqisup_cas(il)-Eqi_prime_cas(il)) cond(il)=-Eqi_prime_cas(il)*fac_ftmr_cas(il) #ifdef ISOVERIF ! WRITE(*,*) 'tmp 1404: il,cond,Eqi,fac_ftmr_cas=', ! : il,cond(il),Eqi_prime_cas(il),fac_ftmr_cas(il) ! WRITE(*,*) 'Pqisup_cas,qp_cas=',Pqisup_cas(il),qp_cas(il) #endif endif IF (T_cas(il).ge.ztglace_kelvin) THEN fice(il)=0.0 else fice(il)=1.0 endif IF (cond(il).gt.qp_avantevap_cas(il)) THEN ! dans ce cas, qp doit être nul. on vérifie et si oui, on ! met cond=qp_avantevap_cas ! cas ajouté le 11 dec 2011 #ifdef ISOVERIF CALL iso_verif_egalite(qp_cas(il),0.0,'appel_stewart 1626') #endif cond(il)=qp_avantevap_cas(il) ! ajouté le 10 juin 2012: qp0(il)=qp_avantevap_cas(il) DO ixt=1,niso xtp0(ixt,il)=xtp_avantevap_cas(ixt,il) enddo !do ixt=1,niso else ! if (cond(il).gt.qp_avantevap_cas(il)) THEN IF (cond(il).lt.1e-11) THEN ! pour des raisons numériques, ça ne marchera pas cond(il)=cond(il)*1e4 qp0(il)=qp_avantevap_cas(il)*1e4 DO ixt=1,niso xtp0(ixt,il)=xtp_avantevap_cas(ixt,il)*1e4 enddo !do ixt=1,niso else !if (cond(il).lt.1e-11) THEN qp0(il)=qp_avantevap_cas(il) DO ixt=1,niso xtp0(ixt,il)=xtp_avantevap_cas(ixt,il) enddo endif !if (cond(il).lt.1e-11) THEN endif ! if (cond(il).gt.qp0(il)) THEN #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart 1378 tmp: il=',il ! WRITE(*,*) 'cond(il),qp0(il)=',cond(il),qp0(il) CALL iso_verif_noNaN(qp0(il),'appel_stewart 1384a') CALL iso_verif_noNaN(cond(il),'appel_stewart 1384b') DO ixt=1,niso CALL iso_verif_noNaN(xtp0(ixt,il),'appel_stewart 1384c') enddo #endif #ifdef ISOVERIF IF (iso_verif_positif_nostop(qp0(il)-cond(il), & 'appel_stewart 1664').EQ.1) THEN WRITE(*,*) 'il,qp0,cond=',il,qp0(il),cond(il) WRITE(*,*) 'qp_avantevap_cas,qp_cas=', & qp_avantevap_cas(il),qp_cas(il) WRITE(*,*) 'Eqi_prime_cas,Pqisup_cas=', & Eqi_prime_cas,Pqisup_cas WRITE(*,*) 'fac_ftmr_cas=',fac_ftmr_cas(il) stop endif IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtp0(iso_eau,il), & qp0(il),'appel_stewart 1353',errmax,errmaxrel) endif #endif enddo !do il=1,ncas_condensation_facftmr CALL condiso_liq_ice_vectall(xtp0(1,1), qp0(1), & cond(1),T_cas(1),fice(1),xtice(1,1),xtliq(1,1), & ncas) DO il=1,ncas IF (cond(il).gt.ridicule*1e-2) THEN DO ixt=1,niso Rcond(ixt,il)=(xtice(ixt,il)+xtliq(ixt,il))/cond(il) enddo !do ixt=1,niso ELSE IF ((cond(il).gt.0.0).AND.(qp0(il).gt.ridicule)) THEN DO ixt=1,niso CALL fractcalk(ixt,T_cas(il),zxtalphal,zxtalphai) Rcond(ixt,il)=xtp0(ixt,il)/qp0(il)* & (fice(il)*zxtalphai+(1.0-fice(il))*zxtalphal) enddo !do ixt=1,niso else !if (cond(il).gt.ridicule*1e-2) THEN DO ixt=1,niso Rcond(ixt,il)=Rdefault(ixt) enddo !do ixt=1,niso endif !Eqi_prime_cas(il) enddo !do il=1,ncas_condensation_facftmr #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncas ! WRITE(*,*) 'tmp il,cond(il)=',il ,cond(il) IF (cond(il).gt.errmax/50) THEN CALL iso_verif_egalite_choix( & (Rcond(iso_eau,il)),1.0, & 'appel_stewart 257',errmax,errmaxrel*50) endif !if (cond.gt.errmax/50) THEN enddo endif !if (iso_eau.gt.0) THEN #endif DO il=1,ncas ! le 30 avril 2012: on remplace 0 par ridicule*1e-2 ! le 2 juillet 2012: on remplace ridicule*1e-2 par ridicule*1e-4 IF (Pqisup_cas(il).gt.ridicule*1e-4) THEN DO ixt=1,niso Risup(ixt,il)=Pxtisup_cas(ixt,il)/Pqisup_cas(il) enddo !do ixt=1,niso else !if (Pqisup.gt.0.0) THEN ! il n'y avait pas d'eau au dessus ! on vérifie que toute l'eau en i provient de la rosée: on ! vérifie que fcond=1.0 !#ifdef ISOVERIF ! CALL iso_verif_egalite_choix(fcond(il),1.0, ! : 'appel_stewart 548',errmax,errmaxrel) ! il y a des cas pathos: ex: facftmr=8e7 ! Eqi_prime=-3e-15 -> qp varie de 2e-7 -> pas négligeable ! Pqisup=1e-15 -> fcond=70% !#endif ! c'est bon, Risup n'a pas d'importance ! ou alors, le flux Pqiinf n'a pas d'importance DO ixt=1,niso Risup(ixt,il)=Rdefault(ixt) enddo !do ixt=1,niso endif !if (Pqisup.gt.0.0) THEN enddo !do il=1,ncas_condensation_facftmr #ifdef ISOVERIF DO il=1,ncas ! WRITE(*,*) 'tmp 1487: il,cond,Eqi,fac_ftmr_cas=', ! : il,cond(il),Eqi_prime_cas(il),fac_ftmr_cas(il) DO ixt=1,niso IF ((iso_verif_noNaN_nostop((Rcond(ixt,il)), & 'appel_stewart 1482, cas 1.1, Rcond').EQ.1).OR. & (iso_verif_noNaN_nostop((Risup(ixt,il)), & 'appel_stewart 1484, cas 1.1, Risup').EQ.1)) THEN WRITE(*,*) 'ixt,il=',ixt,il WRITE(*,*) 'Pxtisup_cas(ixt,il)=',Pxtisup_cas(ixt,il) WRITE(*,*) 'Pqisup_cas(il)=',Pqisup_cas(il) WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'T_cas(il)=',T_cas(il) WRITE(*,*) 'fcond(il)=',fcond(il) WRITE(*,*) 'cond(il)=',cond(il) WRITE(*,*) 'qp_avantevap_cas(il)=',qp_avantevap_cas(il) WRITE(*,*) 'fice(il)=',fice(il) WRITE(*,*) 'xtice(ixt,il)=',xtice(ixt,il) WRITE(*,*) 'xtliq(ixt,il)=',xtliq(ixt,il) stop endif enddo CALL iso_verif_noNAN(water_cas(il), & 'appel_stewart 1469') CALL iso_verif_noNAN(fcond(il), & 'appel_stewart 1471') enddo #endif DO il=1,ncas !#ifdef ISOVERIF ! if (iso_eau.gt.0) THEN ! WRITE(*,*) 'appel_stewart 1489: il,fac_ftmr_cas(il)=', ! : il,fac_ftmr_cas(il) ! WRITE(*,*) 'xtp_avantevap_cas(iso_eau,il)=', ! : xtp_avantevap_cas(iso_eau,il) ! WRITE(*,*) 'Eqi_prime_cas(il),Rcond(iso_eau,il)=', ! : Eqi_prime_cas(il),Rcond(iso_eau,il) ! endif !#endif DO ixt=1,niso Exi_prime(ixt,il)=Rcond(ixt,il)*Eqi_prime_cas(il) xtevap_cas(ixt,il)=2*Exi_prime(ixt,il) & /100.0/delP_cas(il)/sigd(il)*g & -xtevapsup_cas(ixt,il) xtwater_cas(ixt,il)=water_cas(il) & *(Rcond(ixt,il)*fcond(il) & +Risup(ixt,il)*(1.0-fcond(il))) xtp_cas(ixt,il)=xtp_avantevap_cas(ixt,il)+ & fac_ftmr_cas(il)*Exi_prime(ixt,il) xtp_cas(ixt,il)=max(0.0,xtp_cas(ixt,il)) enddo !do ixt=1,niso enddo !do il=1,ncas_condensation_facftmr ! il=1 ! WRITE(*,*) 'appel_stewart 1745: il=',il ! WRITE(*,*) 'xtp_cas(iso_eau,il)=',xtp_cas(iso_eau,il) ! WRITE(*,*) 'xtp_avantevap_cas(iso_eau,il)=', ! : xtp_avantevap_cas(iso_eau,il) ! WRITE(*,*) 'qp_cas(il)=',qp_cas(il) ! WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) ! WRITE(*,*) 'Exi_prime(iso_eau,il)=',Exi_prime(iso_eau,il) ! WRITE(*,*) 'oktrac=',oktrac #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso IF (iso_verif_noNaN_nostop(xtwater_cas(ixt,il), & 'appel_stewart 1487').EQ.1) THEN WRITE(*,*) 'ixt,il=',ixt,il WRITE(*,*) 'water_cas(il)=',water_cas(il) WRITE(*,*) 'Rcond(ixt,il)=',Rcond(ixt,il) WRITE(*,*) 'fcond(il)=',fcond(il) WRITE(*,*) 'Risup(ixt,il)=',Risup(ixt,il) WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'T_cas(il)=',T_cas(il) WRITE(*,*) 'cond(il)=',cond(il) WRITE(*,*) 'Pqisup_cas(il)=',Pqisup_cas(il) WRITE(*,*) 'qp_avantevap_cas(il)=',qp_avantevap_cas(il) stop endif enddo enddo #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix(xtwater_cas(iso_eau,il), & water_cas(il),'appel_stewart 262, cas 1.1', & errmax,errmaxrel) IF ((xtwater_cas(iso_eau,il).EQ.0.0).AND. & (water_cas(il).gt.ridicule)) THEN WRITE(*,*) 'appel_stewart 1535, cas 1.1, il=',il WRITE(*,*) 'xtwater(iso_eau,il,i)=', & xtwater_cas(iso_eau,il) WRITE(*,*) 'water(il,i)=',water_cas(il) WRITE(*,*) 'Rcond(iso_eau,il)=',Rcond(iso_eau,il) WRITE(*,*) 'Risup(iso_eau,il)=',Risup(iso_eau,il) WRITE(*,*) 'fcond(il)=',fcond(il) WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) stop endif IF (oktrac.EQ.0) THEN CALL iso_verif_egalite_choix(xtp_cas(iso_eau,il), & qp_cas(il), & 'appel_stewart 269, cas 1.1', & errmax,errmaxrel) IF (iso_verif_egalite_choix_nostop(xtevap_cas(iso_eau,il), & evap_cas(il), & 'appel_stewart 275, cas 1.1', & errmax,errmaxrel).EQ.1) THEN ! WRITE(*,*) 'il,cas_condensation_facftmr(il)=', ! & il,cas_condensation_facftmr(il) WRITE(*,*) 'xtevapsup_cas(iso_eau,il)=', & xtevapsup_cas(iso_eau,il) ! WRITE(*,*) 'evap(cas_condensation_facftmr(il),i+1)=', ! & evap(cas_condensation_facftmr(il),i+1) WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'Exi_prime(iso_eau,il)=', & Exi_prime(iso_eau,il) stop endif !if (iso_verif_egalite_choix_nostop(xtevap_cas(iso_eau,il), endif ! if (oktrac.EQ.0) THEN enddo !do il=1,ncas_condensation_facftmr endif ! if (iso_eau.gt.0) THEN IF (oktrac.EQ.0) THEN IF (iso_HDO.gt.0) THEN DO il=1,ncas IF (qp_cas(il).gt.ridicule) THEN CALL iso_verif_aberrant(xtp_cas(iso_HDO,il)/ & qp_cas(il), 'appel_stewart 613') endif !if (qp(cas_condensation_facftmr(il),i).gt.ridicule) THEN enddo !do il=1,ncas endif ! if (iso_HDO.gt.0) THEN else !if (oktrac.EQ.0) THEN IF ((iso_HDO.gt.0).AND.(iso_eau.gt.0)) THEN DO il=1,ncas IF (xtp_cas(iso_eau,il).gt.ridicule) THEN CALL iso_verif_aberrant(xtp_cas(iso_HDO,il)/ & xtp_cas(iso_eau,il), & 'appel_stewart 1569') endif !if (qp(cas_condensation_nofacftmr(il),i) enddo ! do il=1,ncas endif ! if (iso_HDO.gt.0) THEN endif !if (oktrac.EQ.0) THEN #endif END SUBROUTINE make_condensation_facftmr SUBROUTINE make_condensation_nofacftmr(ncas, & Eqi_prime_cas,Pqisup_cas,Pxtisup_cas,water_cas,T_cas, & qp_avantevap_cas, xtp_avantevap_cas,q_cas,xt_cas, & xtevapsup_cas ,delP_cas, & ztglace_Kelvin, g,sigd_cas,xtevap_cas,xtp_cas,xtwater_cas & #ifdef ISOVERIF ,evap_cas,qp_cas,oktrac & #endif ) USE isotopes_mod, ONLY: iso_eau, iso_HDO, Rdefault,ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas REAL ztglace_kelvin REAL T_cas(ncas),delP_cas(ncas), & xtevapsup_cas(niso,ncas),water_cas(ncas), & q_cas(ncas),xt_cas(niso,ncas) real qp_avantevap_cas(ncas), & xtp_avantevap_cas(niso,ncas), & Pqisup_cas(ncas), Pxtisup_cas(niso,ncas), & Eqi_prime_cas(ncas) REAL g,sigd_cas(ncas) #ifdef ISOVERIF INTEGER oktrac REAL evap_cas(ncas),qp_cas(ncas) #endif ! outputs REAL xtevap_cas(niso,ncas),xtp_cas(niso,ncas), & xtwater_cas(niso,ncas) ! locals REAL Risup(niso,ncas), Rcond(niso,ncas), & Renv(niso,ncas) REAL zxtalphal(niso,ncas), zxtalphai(niso,ncas) REAL fcond(ncas) REAL Exi_prime(niso,ncas) INTEGER il,ixt !real CALL fractcalk_vectall(T_cas,zxtalphal,zxtalphai,ncas) DO il=1,ncas IF (Pqisup_cas(il)-Eqi_prime_cas(il).gt.0.0) THEN fcond(il)=-Eqi_prime_cas(il) & /(Pqisup_cas(il)-Eqi_prime_cas(il)) else fcond(il)=1.0 endif IF (qp_avantevap_cas(il).gt.0) THEN DO ixt=1,niso Renv(ixt,il)=xtp_avantevap_cas(ixt,il) & /qp_avantevap_cas(il) enddo !do ixt=1,niso ELSE IF (q_cas(il).gt.0.0) then !if (qp_avantevap_cas(il).gt.0) THEN DO ixt=1,niso Renv(ixt,il)=xt_cas(ixt,il)/q_cas(il) enddo !do ixt=1,niso else ! aucune vapeur dispo pour condenser ensuite. On vérifie ! que la condensation est nulle #ifdef ISOVERIF CALL iso_verif_egalite((Eqi_prime_cas(il)), & 0.0,'appel_stewart 1641') #endif DO ixt=1,niso Renv(ixt,il)=Rdefault(ixt) enddo !do ixt=1,niso endif !if (qp_avantevap_cas(il).gt.0) THEN enddo !do il=1,ncas DO il=1,ncas IF (T_cas(il).ge.ztglace_Kelvin) THEN DO ixt=1,niso Rcond(ixt,il)=zxtalphal(ixt,il)*Renv(ixt,il) enddo ! do ixt=1,niso else !if (T(il).ge.ztglace_Kelvin) THEN DO ixt=1,niso Rcond(ixt,il)=zxtalphai(ixt,il)*Renv(ixt,il) enddo ! do ixt=1,niso endif !if (T(il).ge.ztglace_Kelvin) THEN enddo !do il=1,ncas DO il=1,ncas IF (Pqisup_cas(il).gt.0.0) THEN DO ixt=1,niso Risup(ixt,il)=Pxtisup_cas(ixt,il)/Pqisup_cas(il) enddo !do ixt=1,niso else !if (Pqisup.gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite_choix(fcond(il),1.0, & 'appel_stewart 1988',errmax,errmaxrel) #endif DO ixt=1,niso Risup(ixt,il)=Rdefault(ixt) enddo !do ixt=1,niso endif !if (Pqisup.gt.0.0) THEN enddo !do il=1,ncas #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix( & (Rcond(iso_eau,il)), & 1.0,'appel_stewart 658, cas 1.2, Rcond', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (Risup(iso_eau,il)), & 1.0,'appel_stewart 661, cas 1.2, Risup', & errmax,errmaxrel) enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_noNAN((Eqi_prime_cas(il)), & 'appel stewart 1678a') DO ixt=1,niso CALL iso_verif_noNAN((Rcond(ixt,il)), & 'appel stewart 1678b') CALL iso_verif_noNAN(xtevapsup_cas(ixt,il), & 'appel stewart 1678c') enddo enddo #endif DO il=1,ncas DO ixt=1,niso Exi_prime(ixt,il)=Rcond(ixt,il)*Eqi_prime_cas(il) xtevap_cas(ixt,il)=2.0*Exi_prime(ixt,il) & /100.0/delP_cas(il)/sigd_cas(il)*g & -xtevapsup_cas(ixt,il) xtwater_cas(ixt,il)=water_cas(il) & *(Rcond(ixt,il)*fcond(il) & +Risup(ixt,il)*(1.0-fcond(il))) xtp_cas(ixt,il)=xtp_avantevap_cas(ixt,il) enddo !do ixt=1,niso enddo !do il=1,ncas #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il), & 'appel stewart 265.12: cas 1.2') IF (iso_verif_noNAN_nostop(xtevap_cas(ixt,il), & 'appel_stewart 286.12: cas 1.2, xtevap').EQ.1) THEN WRITE(*,*) 'ixt,il=',ixt,il WRITE(*,*) 'Exi_prime(ixt,il)=',Exi_prime(ixt,il) WRITE(*,*) 'delP_cas(il)=',delP_cas(il) WRITE(*,*) 'sigd_cas(il)=',sigd_cas(il) WRITE(*,*) 'xtevapsup_cas(ixt,il)=',xtevapsup_cas(ixt,il) CALL abort_physic('isotopes_routines_mod', 'appel_stewart 286.12: cas 1.2, xtevap', 1) endif !if (iso_verif_noNAN_nostop(xtevap_cas(ixt,il) CALL iso_verif_noNAN(xtwater_cas(ixt,il), & 'appel_stewart 287.12: cas 1.2, xtwater') enddo !do ixt=1,niso enddo !do il=1,ncas IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix(xtwater_cas(iso_eau,il), & water_cas(il), & 'appel_stewart 262.12, cas 1.2', & errmax,errmaxrel) IF ((xtwater_cas(iso_eau,il).EQ.0).AND. & (water_cas(il).gt.ridicule)) THEN WRITE(*,*) 'appel_stewart 263.12, cas 1.2' WRITE(*,*) 'xtwater(iso_eau,il,i)=', & xtwater_cas(iso_eau,il) WRITE(*,*) 'water_cas(il)=',water_cas(il) stop endif IF (oktrac.EQ.0) THEN CALL iso_verif_egalite_choix(xtp_cas(iso_eau,il), & qp_cas(il) & ,'appel_stewart 269.12, cas 1.2',errmax,errmaxrel) CALL iso_verif_egalite_choix(xtevap_cas(iso_eau,il), & evap_cas(il),'appel_stewart 275.12, cas 1.2', & errmax,errmaxrel) endif !if (oktrac.EQ.0) THEN enddo !do il=1,ncas endif ! if (iso_eau.gt.0) THEN IF (oktrac.EQ.0) THEN IF (iso_HDO.gt.0) THEN DO il=1,ncas IF (qp_cas(il).gt.ridicule) THEN CALL iso_verif_aberrant(xtp_cas(iso_HDO,il)/ & qp_cas(il), & 'appel_stewart 763') endif !if (qp(cas_condensation_nofacftmr(il),i) enddo ! do il=1,ncas endif ! if (iso_HDO.gt.0) THEN else !if (oktrac.EQ.0) THEN IF ((iso_HDO.gt.0).AND.(iso_eau.gt.0)) THEN DO il=1,ncas IF (xtp_cas(iso_eau,il).gt.ridicule) THEN CALL iso_verif_aberrant(xtp_cas(iso_HDO,il)/ & xtp_cas(iso_eau,il), & 'appel_stewart 1731') endif !if (qp(cas_condensation_nofacftmr(il),i) enddo ! do il=1,ncas endif ! if (iso_HDO.gt.0) THEN endif !if (oktrac.EQ.0) THEN #endif END SUBROUTINE make_condensation_nofacftmr SUBROUTINE make_cas_noevap(ncas, & xtp_avantevap_cas,xtevapsup_cas, & Pxtisup_cas,Pqisup_cas,water_cas, & xtevap_cas,xtp_cas,xtwater_cas & #ifdef ISOVERIF ,evap_cas,qp_cas,oktrac & #endif ) USE isotopes_mod, ONLY: iso_eau, iso_HDO, Rdefault,ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas REAL xtevapsup_cas(niso,ncas),water_cas(ncas) real xtp_avantevap_cas(niso,ncas), & Pqisup_cas(ncas), Pxtisup_cas(niso,ncas) #ifdef ISOVERIF REAL evap_cas(ncas),qp_cas(ncas) INTEGER oktrac ! si traceurs, certaines verifs ne sont pas !valides #endif ! outputs REAL xtevap_cas(niso,ncas),xtp_cas(niso,ncas), & xtwater_cas(niso,ncas) ! locals REAL Risup(niso,ncas) INTEGER il,ixt !real ! WRITE(*,*) 'appel_stewart tmp 1530: Pxtisup_cas(iso_eau,2)=', ! : Pxtisup_cas(iso_eau,2) ! WRITE(*,*) 'Pqisup_cas(2)=',Pqisup_cas(2) DO il=1,ncas DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevap_cas(ixt,il) xtevap_cas(ixt,il)=-xtevapsup_cas(ixt,il) enddo !do ixt=1,niso enddo !do il=1,ncas_noevap #ifdef ISOVERIF DO il=1,ncas IF ((Pqisup_cas(il).le.0.0).AND. & (water_cas(il).gt.ridicule*10)) THEN ! 27 mai 2009: on est plus laxiste dans le cas des traceurs ! d'eau: on met ridicule*10 WRITE(*,*) 'appel_stewart 372: water(il,i)=', & water_cas(il) WRITE(*,*) 'appel_stewart 372: Pqisup=',Pqisup_cas(il) stop endif IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)), & 'appel_stewart 1548',errmax,errmaxrel) endif CALL iso_verif_noNAN(water_cas(il), & 'appel_stewart 1583') enddo !do il=1,ncas_noevap #endif DO il=1,ncas IF (Pqisup_cas(il).gt.0.0) THEN DO ixt=1,niso Risup(ixt,il)=Pxtisup_cas(ixt,il)/Pqisup_cas(il) xtwater_cas(ixt,il)=water_cas(il)*Risup(ixt,il) enddo !do ixt=1,niso else !if (Pqisup.gt.0.0) THEN DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il)*Rdefault(ixt) enddo !do ixt=1,niso endif !if (Pqisup.gt.0.0) THEN enddo !do il=1,ncas_noevap #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il), & 'appel stewart 265.2: cas 1.1') CALL iso_verif_noNAN(xtevap_cas(ixt,il), & 'appel_stewart 286') CALL iso_verif_noNAN(xtwater_cas(ixt,il), & 'appel_stewart 1594') enddo !do ixt=1,niso enddo !do il=1,ncas_noevap IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix(xtwater_cas(iso_eau,il), & water_cas(il),'appel_stewart 262.2, cas 1.1', & errmax,errmaxrel) IF ((xtwater_cas(iso_eau,il).EQ.0).AND. & (water_cas(il).gt.ridicule)) THEN WRITE(*,*) 'appel_stewart 263.2, cas 1.1' WRITE(*,*) 'xtwater(iso_eau,il)=',xtwater_cas(iso_eau,il) WRITE(*,*) 'water(il)=',water_cas(il) stop endif IF (oktrac.EQ.0) THEN ! WRITE(*,*) 'appel_stewart 1743 noevap tmp: il=',il CALL iso_verif_egalite_choix(xtp_cas(iso_eau,il), & qp_cas(il) & ,'appel_stewart 269.2, cas 1.1',errmax,errmaxrel) CALL iso_verif_egalite_choix(xtevap_cas(iso_eau,il), & evap_cas(il), & 'appel_stewart 275.2, cas 1.1', & errmax,errmaxrel) endif !if (oktrac.EQ.0) THEN enddo !do il=1,ncas endif ! if (iso_eau.gt.0) THEN IF (oktrac.EQ.0) THEN IF (iso_HDO.gt.0) THEN DO il=1,ncas IF (qp_cas(il).gt.ridicule) THEN CALL iso_verif_aberrant( & xtp_cas(iso_HDO,il)/qp_cas(il), & 'appel_stewart 613') endif !if (qp(cas_noevap(il),i).gt.ridicule) THEN enddo !do il=1,ncas endif ! if (iso_HDO.gt.0) THEN endif !if (oktrac.EQ.0) THEN #endif END SUBROUTINE make_cas_noevap SUBROUTINE make_cas_evap_liq(ncas, & water_cas, & xtp_avantevap_cas,qp_avantevap_cas, & xtp_avantevaptrac_cas,qp_avantevaptrac_cas, & Pxtisup_cas,Pqisup_cas, & Eqi_stewart,Pqiinf_stewart,fac_ftmr_cas, & qs_cas, T_cas,wt_cas, delP_cas, & xtevapsup_cas,qeff, g,sigd,Eqi_prime_cas, & qp_cas,INB_cas,i,oktrac & #ifdef ISOTRAC ,ptrac,hdiag & #endif #ifdef ISOVERIF ,evap_cas,Exi_stewart & #endif ,xtp_cas,xtwater_cas,xtevap_cas) USE isotopes_mod, ONLY: iso_eau, iso_HDO,no_pce, Rdefault,ridicule #ifdef ISOVERIF USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: ridicule_trac #endif IMPLICIT NONE ! inputs INTEGER ncas REAL xtp_avantevap_cas(niso,ncas), & qp_avantevap_cas(ncas) REAL xtp_avantevaptrac_cas(niso,ncas), & qp_avantevaptrac_cas(ncas) ! dans le cas des traceurs: xtp_avantevaptrac_cas est la ! quantité de traceur izone dans la vapeur ! alors que xtp_avantevap_cas est le total de toutes les zone ! on rééquilibre la goutte avec le total de toutes les zones, ! mais c'est xtp_avantevaptrac_cas qui recoit l'évap REAL Pqisup_cas(ncas), Pxtisup_cas(niso,ncas) REAL Pqiinf_stewart(ncas), Eqi_stewart(ncas) REAL fac_ftmr_cas(ncas),Eqi_prime_cas(ncas) REAL T_cas(ncas),delP_cas(ncas), & xtevapsup_cas(niso,ncas), & wt_cas(ncas),qeff(ncas), & qs_cas(ncas),water_cas(ncas), & qp_cas(ncas) INTEGER oktrac #ifdef ISOTRAC REAL ptrac(ncas) REAL hdiag(ncas) #endif #ifdef ISOVERIF REAL evap_cas(ncas) #endif INTEGER INB_cas(ncas),i REAL g,sigd(ncas) ! outputs real xtp_cas(niso,ncas),xtwater_cas(niso,ncas), & xtevap_cas(niso,ncas) ! locals INTEGER il,ixt REAL Pxtiinf_stewart(niso,ncas), & Exi_stewart(niso,ncas) REAL xtnew(niso,ncas) !#ifdef ISOVERIF ! integer iso_verif_egalite_choix_nostop ! integer iso_verif_aberrant_nostop ! real ! real deltaD ! integer iso_verif_aberrant_choix_nostop !#endif #ifdef ISOVERIF ! if (ncas.ge.162) THEN ! WRITE(*,*) 'appel tmp 1975: xtp_avantevap_cas(iso_eau,162)=', ! : xtp_avantevap_cas(iso_eau,162) ! WRITE(*,*) 'appel tmp 1975b: qp_avantevap_cas(162)=', ! : qp_avantevap_cas(162) ! endif !if (ncas_evap_liq.ge.162) THEN IF (iso_eau.gt.0) THEN DO il=1,ncas ! WRITE(*,*) 'appel tmp 1492: il=',il CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart 473', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (xtp_avantevaptrac_cas(iso_eau,il)), & (qp_avantevaptrac_cas(il)), & 'appel_stewart 473b',errmax,errmaxrel) CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)),'appel_stewart 475', & errmax,errmaxrel) enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN #endif #ifdef ISOTRAC ! à l'avenir, il faudra faire les choses plus proprement! IF (oktrac.EQ.1) THEN ! on renormalise le flux de précip et d'évap ! on suppose que la seule différence entre les différentes ! zones, c'est la compo du liquide DO il=1,ncas IF (ptrac(il).gt.1e-20) THEN Pqisup_cas(il)=Pqisup_cas(il)/ptrac(il) Eqi_stewart(il)=Eqi_stewart(il)/ptrac(il) Pqiinf_stewart(il)=Pqiinf_stewart(il)/ptrac(il) DO ixt=1,niso Pxtisup_cas(ixt,il)=Pxtisup_cas(ixt,il)/ptrac(il) enddo else !if (ptrac(il).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite((Pqisup_cas(il)), & 0.0,'appel 2104') CALL iso_verif_egalite((Eqi_stewart(il)), & 0.0,'appel 2105') CALL iso_verif_egalite((Pqiinf_stewart(il)), & 0.0,'appel 2106') #endif Pqisup_cas(il)=0.0 Eqi_stewart(il)=0.0 Pqiinf_stewart(il)=0.0 DO ixt=1,niso Pxtisup_cas(ixt,il)=0.0 enddo endif !if (ptrac(il).gt.0.0) THEN enddo !do il=1,ncas endif !if (oktrac.EQ.1) THEN #endif IF (no_pce.EQ.1) THEN CALL stewart_sublim_nofrac_vectall( & ncas,qp_avantevap_cas(1), & xtp_avantevap_cas(1,1),Pqisup_cas(1), & Pxtisup_cas(1,1),Eqi_stewart(1),Pqiinf_stewart(1), & Pxtiinf_stewart(1,1),xtnew(1,1),Exi_stewart(1,1), & fac_ftmr_cas(1)) else !if (no_pce.EQ.1) THEN CALL stewart_explicite_vectall(ncas, & qp_avantevap_cas(1),xtp_avantevap_cas(1,1), & Pqisup_cas,Pxtisup_cas(1,1),Eqi_stewart(1), & Pqiinf_stewart(1),qeff(1), & Pxtiinf_stewart(1,1),xtnew(1,1),Exi_stewart(1,1), & fac_ftmr_cas(1), & qs_cas(1),T_cas(1),wt_cas(1),delP_cas(1) & #ifdef ISOVERIF ,0,73 & #endif ) endif !if (no_pce.EQ.1) THEN #ifdef ISOTRAC ! à l'avenir, il faudra faire les choses plus proprement! IF (oktrac.EQ.1) THEN ! on renormalise le flux de précip et d'évap ! on suppose que la seule différence entre les différentes ! zones, c'est la compo du liquide DO il=1,ncas Pqisup_cas(il)=Pqisup_cas(il)*ptrac(il) Eqi_stewart(il)=Eqi_stewart(il)*ptrac(il) Pqiinf_stewart(il)=Pqiinf_stewart(il)*ptrac(il) DO ixt=1,niso Pxtisup_cas(ixt,il)=Pxtisup_cas(ixt,il)*ptrac(il) Exi_stewart(ixt,il)=Exi_stewart(ixt,il)*ptrac(il) Pxtiinf_stewart(ixt,il)=Pxtiinf_stewart(ixt,il)*ptrac(il) xtnew(ixt,il)=xtp_avantevap_cas(ixt,il) & +(xtnew(ixt,il)-xtp_avantevap_cas(ixt,il))*ptrac(il) enddo hdiag(il)=qeff(il)/qs_cas(il) enddo !do il=1,ncas endif !if (oktrac.EQ.1) THEN #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix( & (Exi_stewart(iso_eau,il) & *fac_ftmr_cas(il)), & (Eqi_stewart(il)*fac_ftmr_cas(il)), & 'appel stewart 520',errmax*80,errmaxrel*80) CALL iso_verif_egalite_choix( & (Pxtiinf_stewart(iso_eau,il)), & (Pqiinf_stewart(il)), & 'appel_stewart 586', & errmax,errmaxrel) IF (Pqiinf_stewart(il).gt.ridicule) THEN CALL iso_verif_egalite_choix(( & Pxtiinf_stewart(iso_eau,il)/Pqiinf_stewart(il)), & 1.,'appel_setwart 575a', errmax*10, errmaxrel*10) endif !if (Pqiinf_par.gt.ridicule) THEN enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_noNAN(water_cas(il), & 'appel_stewart 2009') CALL iso_verif_noNAN((Pqiinf_stewart(il)), & 'appel_stewart 2011') DO ixt=1,niso CALL iso_verif_noNAN(( & Pxtiinf_stewart(ixt,il)),'appel_stewart 2014') enddo enddo #endif ! deduction de XTWATER à partir de Pxtiinf: ! hypothèse: l'eau en i a la même composition que le flux d'eau ! qui sort de la boite i (Pqiinf_par) DO il=1,ncas IF (abs(water_cas(il)).lt.ridicule/10.) THEN DO ixt=1,niso xtwater_cas(ixt,il)=0.0 enddo !do ixt=1,niso else !if (water(il,i).EQ.0.0) THEN IF (Pqiinf_stewart(il).gt.0.0) then !if (Pxtiinf_par(iso_eau).gt.0.0) THEN DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il) & *Pxtiinf_stewart(ixt,il)/Pqiinf_stewart(il) enddo else !if (Pxtiinf_stewart(iso_eau).gt.0.0) THEN ! normalement, ce cas a déjà été interdit dans ! compress_evp_glace DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il)*Rdefault(ixt) enddo !do ixt=1,niso endif endif !if (water(il,i).EQ.0.0) THEN enddo !do il=1,ncas #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtwater_cas(ixt,il), & 'appel_stewart 566') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtwater_cas(iso_eau,il), & water_cas(il),'appel_stewart 568',errmax,errmaxrel) IF (water_cas(il).gt.ridicule*10) THEN IF (iso_verif_egalite_choix_nostop( & xtwater_cas(iso_eau,il)/water_cas(il),1.0, & 'appel stewart 155',errmax*10,errmaxrel*10).EQ.1) THEN ! WRITE(*,*) 'i=',i WRITE(*,*) 'Tevap=',T_cas(il) WRITE(*,*) 'xtwater(iso_eau,il,i)=', & xtwater_cas(iso_eau,il) WRITE(*,*) 'water(il,i)=',water_cas(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau)=', & Pxtiinf_stewart(iso_eau,il) ! WRITE(*,*) 'Pqiinf_par,Pqiinf_stewart=', ! & Pqiinf_par(cas_evap_liq(il)),Pqiinf_stewart(il) stop endif !if (iso_verif_egalite_nostop( endif !if (water(il,i).gt.ridicule) THEN endif !if (iso_eau.gt.0) THEN enddo !do il=1,ncas #endif ! rappel, le Eqi_prime qu'on a mis en argument dans stewart est en ! fait égal à 0.5*(Eqi+Eqi+1) -> en tenir compte quand on ! calcule xtevapi. DO il=1,ncas IF (Eqi_stewart(il).gt.0.0) THEN DO ixt=1,niso xtevap_cas(ixt,il)=Eqi_prime_cas(il) & *Exi_stewart(ixt,il)/Eqi_stewart(il) & /100/delP_cas(il)/sigd(il)*g*2 & -xtevapsup_cas(ixt,il) enddo ! do ixt=1,niso else !if (Eqi_stewart.gt.0.0) THEN ! il peut quand même y a voir de la diffusion DO ixt=1,niso xtevap_cas(ixt,il)=Exi_stewart(ixt,il) & /100.0/delP_cas(il)/sigd(il)*g*2.0 & -xtevapsup_cas(ixt,il) enddo !do ixt=1,niso endif !if (Eqi_stewart.gt.0.0) THEN enddo !do il=1,ncas #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtevap_cas(ixt,il),'appel stewart 131') enddo ! do ixt=1,nisio IF (oktrac.EQ.0) THEN ! dans le cas traceur, le calcul de evap_cas est plus ! compliqué: il faut le faire plus proprement dans ! compress_stewart IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop(xtevap_cas(iso_eau,il), & evap_cas(il),'appel stewart 142', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'il=',il WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'Eqi_stewart(il)=',Eqi_stewart(il) WRITE(*,*) 'Exi_stewart(iso_eau,il)=', & Exi_stewart(iso_eau,il) WRITE(*,*) '1/100/delP_cas(il)/sigd(il)*g*2=', & 1.0/100.0/delP_cas(il)/sigd(il)*g*2.0 WRITE(*,*) 'xtevapsup_cas(iso_eau,il)=', & xtevapsup_cas(iso_eau,il) stop endif endif !if (iso_eau.gt.0) THEN endif !if (oktrac.EQ.0) THEN #ifdef ISOTRAC IF (oktrac.EQ.1) THEN IF ((iso_eau.gt.0).AND.(iso_HDO.gt.0)) THEN CALL iso_verif_aberrant_choix( & (xtp_avantevaptrac_cas(iso_HDO,il)), & (xtp_avantevaptrac_cas(iso_eau,il)), & ridicule_trac,deltalimtrac, & 'appel_stewart 2053') endif !if ((iso_eau.gt.0).AND.(iso_HDO.gt.0)) THEN endif #endif enddo !do il=1,ncas #endif ! deduction de XTP partir de Exi DO il=1,ncas IF (i.lt.INB_cas(il)) THEN IF (fac_ftmr_cas(il).gt.0.0) THEN IF (Eqi_stewart(il)*fac_ftmr_cas(il).gt.ridicule) THEN DO ixt=1,niso ! xtp(ixt,il,i)=xtnew(ixt)*qp(il,i)/xtnew(4) xtp_cas(ixt,il)=max(xtp_avantevaptrac_cas(ixt,il) & +fac_ftmr_cas(il)*Eqi_prime_cas(il) & *Exi_stewart(ixt,il)/Eqi_stewart(il),0.0) enddo !do ixt=1,niso else ! if (Eqi_stewart.gt.ridicule) THEN IF (qp_cas(il).gt.0.0) THEN IF (Eqi_prime_cas(il)*fac_ftmr_cas(il).gt.ridicule) & THEN ! il va manquer quelque chose: il faut augmenter ! xtp en lui ajoutant l'évap du niveau d'eau ! dessus ! pour l'instant, on bidouille: WRITE(*,*) 'appel_stewart 2487: il=',il DO ixt=1,niso xtnew(ixt,il)=xtnew(ixt,il) & *(qp_avantevap_cas(il) & +Eqi_prime_cas(il)*fac_ftmr_cas(il)) & /(qp_avantevap_cas(il) & +Eqi_stewart(il)*fac_ftmr_cas(il)) enddo endif !if (Eqi_prime_cas(il)*fac_ftmr_cas(il).gt.ridicule) DO ixt=1,niso ! xtp_cas(ixt,il)=xtnew(ixt,il) xtp_cas(ixt,il)=(xtp_avantevaptrac_cas(ixt,il) & +(xtnew(ixt,il) & -xtp_avantevap_cas(ixt,il))) ! modif 1 mai 2009, pour le cas des traceurs enddo !do ixt=1,niso ! WRITE(*,*) 'appel_stewart 1963 tmp: ', ! : 'xtp_cas(iso_eau,il)=',xtp_cas(iso_eau,il) else !if (qp(il,i).gt.0.0) THEN DO ixt=1,niso xtp_cas(ixt,il)=0.0 enddo !do ixt=1,niso endif !if (qp(il,i).gt.0.0) THEN endif !if (Eqi_stewart.gt.ridicule) THEN #ifdef ISOVERIF ! if (il.EQ.87) THEN ! WRITE(*,*) 'appel_stewart 2244: tmp, après calcul xtp' ! WRITE(*,*) 'xtnew(:,il)=',xtnew(:,il) ! WRITE(*,*) 'Pxtiinf_stewart(:,il)=', ! : Pxtiinf_stewart(:,il) ! endif !if (il.EQ.87) THEN DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il), & 'appel stewart 684') enddo ! do ixt=1,niso #ifdef ISOTRAC IF (oktrac.EQ.1) THEN IF ((iso_HDO.gt.0).AND.(iso_eau.gt.0)) THEN ! le 10 mai 2009: on remonte le seuil de vérif de deltaD ! aberrant car dans le cas des traceurs, des très ! petites concentrations sont très facilement ! influencées par des évaps qui peuvent être aberantes ! si ces evaps sont petites IF (iso_verif_aberrant_choix_nostop( & xtp_cas(iso_HDO,il),xtp_cas(iso_eau,il), & ridicule_trac,deltalimtrac, & 'appel_stewart 2090').EQ.1) THEN WRITE(*,*) 'xtp_avantevaptrac_cas(iso_eau),deltaD=', & xtp_avantevaptrac_cas(iso_eau,il),deltaD & ((xtp_avantevaptrac_cas(iso_HDO,il)) & /(xtp_avantevaptrac_cas(iso_eau,il))) WRITE(*,*) 'xtp_avantevap_cas(iso_eau),deltaD=', & xtp_avantevap_cas(iso_eau,il),deltaD & ((xtp_avantevap_cas(iso_HDO,il)) & /(xtp_avantevap_cas(iso_eau,il))) WRITE(*,*) 'xtnew(iso_eau),deltaD=', & xtnew(iso_eau,il),deltaD & ((xtnew(iso_HDO,il)) & /(xtnew(iso_eau,il))) WRITE(*,*) 'xtp_cas(iso_eau),deltaD=', & xtp_cas(iso_eau,il),deltaD & (xtp_cas(iso_HDO,il)/xtp_cas(iso_eau,il)) WRITE(*,*) 'Eqi_stewart(il),fac_ftmr_cas(il)=', & Eqi_stewart(il),fac_ftmr_cas(il) WRITE(*,*) 'Eqi_prime_cas(il)=', & Eqi_prime_cas(il) WRITE(*,*) 'deltaD_Eqi_stewart=', & deltaD(( & Exi_stewart(iso_HDO,il)/Eqi_stewart(il))) WRITE(*,*) 'xtnew-xtp_avantevap_cas,deltaD=', & xtnew(iso_eau,il)-xtp_avantevap_cas(iso_eau,il), & deltaD(((xtnew(iso_HDO,il) & -xtp_avantevap_cas(iso_HDO,il))/ & (xtnew(iso_eau,il) & -xtp_avantevap_cas(iso_eau,il)))) WRITE(*,*) 'Pqisup,deltaD=', & Pqisup_cas(il),deltaD(( & Pxtisup_cas(iso_HDO,il)/Pqisup_cas(il))) stop endif endif !if (iso_HDO.gt.0) THEN endif !if (oktrac.EQ.1) THEN #endif ! #ifdef ISOTRAC IF (oktrac.EQ.0) THEN IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtp_cas(iso_eau,il), & qp_cas(il),'appel stewart 688', & errmax,errmaxrel*30) endif !if (iso_eau.gt.0) THEN IF ((iso_HDO.gt.0).AND. & (qp_cas(il).gt.ridicule)) THEN IF (iso_verif_aberrant_nostop(xtp_cas(iso_HDO,il)/ & qp_cas(il), & 'appel_stewart_vectall 1079').EQ.1) THEN WRITE(*,*) 'i,qp(cas_evap_liq(il),i)=', & i,qp_cas(il) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'deltaDxtnew=',deltaD(( & xtnew(iso_HDO,il))/qp_cas(il)) stop endif endif !if (iso_HDO.gt.0) THEN endif ! if (oktrac.EQ.0) THEN #endif else !if (fac_ftmr.gt.0.0) THEN ! ca veut dire que Mp=0, xtp pas définit DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevaptrac_cas(ixt,il) enddo !do ixt=1,niso endif !if (fac_ftmr.gt.0.0) THEN else !if (i.lt.INB) THEN ! si i=inb, on ne change rien au calcul original, et on ! suppose que la composition du ddft est égale à celle de ! l'env. Ceci a déjà été calculé plus haut DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevaptrac_cas(ixt,il) !xtp_avantevap(ixt) a déjà été définit proprement !dans ce cas là enddo endif !if (i.lt.INB) THEN enddo !do il=1,ncas ! verif #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il),'appel stewart 198') CALL iso_verif_noNAN(xtevap_cas(ixt,il),'appel stewart 745') enddo !do ixt=1,niso #ifdef ISOTRAC IF ((iso_HDO.gt.0).AND.(iso_eau.gt.0)) THEN IF (oktrac.EQ.1) THEN CALL iso_verif_aberrant_choix( & xtp_cas(iso_HDO,il),xtp_cas(iso_eau,il), & ridicule,deltalim,'appel_stewart 2138') endif endif !if (iso_HDO.gt.0) THEN #endif enddo !do il=1,ncas !#ifdef ISOTRAC IF (oktrac.EQ.0) THEN IF (iso_eau.gt.0) THEN DO il=1,ncas IF (iso_verif_egalite_choix_nostop( & xtp_cas(iso_eau,il), & qp_cas(il), & 'appel stewart 197', & errmax,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'i=',i,' INB=',INB_cas(il) WRITE(*,*) 'Tevap=',T_cas(il) WRITE(*,*) 'xtp(iso_eau,il,i)=',xtp_cas(iso_eau,il) WRITE(*,*) 'qp(il,i)=',qp_cas(il) WRITE(*,*) 'xtnew(iso_eau)=',xtnew(iso_eau,il) WRITE(*,*) 'fac_ftmr=',fac_ftmr_cas(il) ! WRITE(*,*) 'Mp(il,i)=',Mp(cas_evap_liq(il),i) WRITE(*,*) 'xtp_avantevap(iso_eau)=', & xtp_avantevap_cas(iso_eau,il) WRITE(*,*) 'qp_avantevap=',qp_avantevap_cas(il) ! WRITE(*,*) 'Exi_prime(iso_eau)=',Exi_prime(iso_eau,il) ! WRITE(*,*) 'Eqi_prime=',Eqi_prime(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau)=', & Pxtiinf_stewart(iso_eau,il) ! WRITE(*,*) 'Pqiinf_par=',Pqiinf_par(cas_evap_liq(il)) WRITE(*,*) 'Pxtisup(iso_eau)=',Pxtisup_cas(iso_eau,il) WRITE(*,*) 'Pqisup=',Pqisup_cas(il) stop endif !if iso_verif_egalite_choix_nostop enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN DO il=1,ncas ! WRITE(*,*) 'appel_stewart 2166: fin make_cas_evap_liq, ', ! & 'il,deltaDqp=',il,deltaD(xtp_cas(iso_HDO,il)/qp_cas(il)) IF (qp_cas(il).gt.ridicule) THEN CALL iso_verif_aberrant( & xtp_cas(iso_HDO,il)/qp_cas(il), & 'appel_stewart 1130') endif !if (qp(cas_evap_liq(il),i).gt.ridicule) THEN enddo !do il=1,ncas endif endif ! if (oktrac.EQ.0) THEN !#endif ! ISOTRAC #endif END SUBROUTINE make_cas_evap_liq SUBROUTINE make_cas_evap_glace(ncas, & water_cas, & xtp_avantevap_cas,qp_avantevap_cas, & xtp_avantevaptrac_cas,qp_avantevaptrac_cas, & Pxtisup_cas,Pqisup_cas, & Eqi_stewart,Eqi_prime_cas, & Pqiinf_stewart,fac_ftmr_cas, & qs_cas, T_cas,wt_cas, delP_cas, & xtevapsup_cas,g,sigd,INB_cas,i, & frac_sublim,qp_cas & #ifdef ISOVERIF ,evap_cas,oktrac,Exi_stewart & #endif ,xtp_cas,xtwater_cas,xtevap_cas) USE isotopes_mod, ONLY: iso_eau, iso_HDO, Rdefault, ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas REAL xtp_avantevap_cas(niso,ncas), & qp_avantevap_cas(ncas) REAL xtp_avantevaptrac_cas(niso,ncas), & qp_avantevaptrac_cas(ncas) REAL Pqisup_cas(ncas), Pxtisup_cas(niso,ncas) REAL Pqiinf_stewart(ncas), Eqi_stewart(ncas) REAL fac_ftmr_cas(ncas),Eqi_prime_cas(ncas) REAL T_cas(ncas),delP_cas(ncas), & xtevapsup_cas(niso,ncas), & wt_cas(ncas),qeff(ncas), & qs_cas(ncas),water_cas(ncas) REAL qp_cas(ncas) #ifdef ISOVERIF REAL evap_cas(ncas) INTEGER oktrac #endif REAL g,sigd(ncas) INTEGER frac_sublim INTEGER INB_cas(ncas),i ! outputs real xtp_cas(niso,ncas),xtwater_cas(niso,ncas), & xtevap_cas(niso,ncas) ! locals INTEGER il,ixt REAL Pxtiinf_stewart(niso,ncas), & Exi_stewart(niso,ncas) REAL xtnew(niso,ncas) !#ifdef ISOVERIF ! real ! integer iso_verif_egalite_choix_nostop ! integer iso_verif_aberrant_nostop ! real deltaD !#endif #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart 2052: entrée dans make_cas_evap_glace' IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart 473b', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)),'appel_stewart 475b', & errmax,errmaxrel) enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN #endif ! 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 IF (frac_sublim.EQ.1) THEN CALL stewart_glace_vectall(ncas, & qp_avantevap_cas(1),xtp_avantevap_cas(1,1),Pqisup_cas(1), & Pxtisup_cas(1,1),Eqi_stewart(1),Pqiinf_stewart(1), & Pxtiinf_stewart(1,1),xtnew(1,1),Exi_stewart(1,1), & fac_ftmr_cas(1), & T_cas(1)) else !if (frac_sublim.EQ.1) THEN !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_explicite 2736' !#endif CALL stewart_sublim_nofrac_vectall( & ncas,qp_avantevap_cas(1), & xtp_avantevap_cas(1,1),Pqisup_cas(1), & Pxtisup_cas(1,1),Eqi_stewart(1),Pqiinf_stewart(1), & Pxtiinf_stewart(1,1),xtnew(1,1),Exi_stewart(1,1), & fac_ftmr_cas(1)) endif !if (frac_sublim.EQ.1) THEN #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart 2096: dans make_cas_evap_glace' IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix( & (Exi_stewart(iso_eau,il)*fac_ftmr_cas(il)), & (Eqi_stewart(il)*fac_ftmr_cas(il)), & 'appel stewart 520b',errmax*80,errmaxrel*80) CALL iso_verif_egalite_choix( & (Pxtiinf_stewart(iso_eau,il)), & (Pqiinf_stewart(il)), & 'appel_stewart 586', & errmax,errmaxrel) IF (Pqiinf_stewart(il).gt.ridicule) THEN IF (iso_verif_egalite_choix_nostop(( & Pxtiinf_stewart(iso_eau,il)/Pqiinf_stewart(il)), & 1.,'appel_setwart 575b', errmax*10, errmaxrel*10) & .EQ.1) THEN WRITE(*,*) 'Pqiinf_stewart(il)=',Pqiinf_stewart(il) ! WRITE(*,*) 'Pqiinf_par(il)=',Pqiinf_par(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau,il)=', & Pxtiinf_stewart(iso_eau,il) stop endif endif !if (Pqiinf_par.gt.ridicule) THEN enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN #endif ! deduction de XTWATER à partir de Pxtiinf: ! hypothèse: l'eau en i a la même composition que le flux d'eau ! qui sort de la boite i (Pqiinf_par) DO il=1,ncas IF (abs(water_cas(il)).lt.ridicule/10.) THEN DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il)*Rdefault(ixt) enddo !do ixt=1,niso else !if (water(il,i).EQ.0.0) THEN IF (Pqiinf_stewart(il).gt.0.0) then !if (Pxtiinf_par(iso_eau).gt.0.0) THEN DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il) & *Pxtiinf_stewart(ixt,il)/Pqiinf_stewart(il) enddo else !if (Pxtiinf_stewart(iso_eau).gt.0.0) THEN ! normalement, ce cas a déjà été interdit dans ! compress_evp_glace DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il)*Rdefault(ixt) enddo !do ixt=1,niso endif endif !if (water(il,i).EQ.0.0) THEN enddo !do il=1,ncas #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart 2563: dans make_cas_evap_glace' DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtwater_cas(ixt,il), & 'appel_stewart 566b') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtwater_cas(iso_eau,il), & water_cas(il),'appel_stewart 568b',errmax,errmaxrel) IF (water_cas(il).gt.ridicule*10) THEN IF (iso_verif_egalite_choix_nostop( & xtwater_cas(iso_eau,il)/water_cas(il),1.0, & 'appel stewart 155b',errmax*10,errmaxrel*10).EQ.1) THEN WRITE(*,*) 'i=',i WRITE(*,*) 'Tevap=',T_cas(il) WRITE(*,*) 'xtwater(iso_eau,il,i)=', & xtwater_cas(iso_eau,il) WRITE(*,*) 'water(il,i)=',water_cas(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau)=', & Pxtiinf_stewart(iso_eau,il) ! WRITE(*,*) 'Pqiinf_par,Pqiinf_stewart=', ! & Pqiinf_par(il),Pqiinf_stewart(il) stop endif !if (iso_verif_egalite_nostop( endif !if (water(il,i).gt.ridicule) THEN endif !if (iso_eau.gt.0) THEN enddo !do il=1,ncas #endif ! rappel, le Eqi_prime qu'on a mis en argument dans stewart est en ! fait égal à 0.5*(Eqi+Eqi+1) -> en tenir compte quand on ! calcule xtevapi. DO il=1,ncas IF (Eqi_stewart(il).gt.0.0) THEN DO ixt=1,niso xtevap_cas(ixt,il)=Eqi_prime_cas(il) & *Exi_stewart(ixt,il)/Eqi_stewart(il) & /100.0/delP_cas(il)/sigd(il)*g*2.0 & -xtevapsup_cas(ixt,il) enddo ! do ixt=1,niso else !if (Eqi_stewart.gt.0.0) THEN ! il peut quand même y a voir de la diffusion DO ixt=1,niso xtevap_cas(ixt,il)=Exi_stewart(ixt,il) & /100.0/delP_cas(il)/sigd(il)*g*2.0 & -xtevapsup_cas(ixt,il) enddo !do ixt=1,niso endif !if (Eqi_stewart.gt.0.0) THEN enddo !do il=1,ncas #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtevap_cas(ixt,il),'appel stewart 131b') enddo ! do ixt=1,niso IF (oktrac.EQ.0) THEN ! dans le cas traceur, le calcul de evap_cas est plus ! compliqué: il faut le faire plus proprement dans ! compress_stewart IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop(xtevap_cas(iso_eau,il), & evap_cas(il), & 'appel stewart 142b',errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'i,il=',i,il WRITE(*,*) 'Exi_stewart(iso_eau,il),Eqi_stewart(il)=', & Exi_stewart(iso_eau,il),Eqi_stewart(il) WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'xtevapsup_cas(iso_eau,il)=', & xtevapsup_cas(iso_eau,il) ! WRITE(*,*) 'evap,evapsup=',evap(cas_evap_glace(il),i), ! & evap(cas_evap_glace(il),i+1) stop endif !if (iso_verif_egalite_choix_nostop(xtevap_cas(iso_eau,il), endif !if (iso_eau.gt.0) THEN endif ! if (oktrac.EQ.0) THEN enddo !do il=1,ncas #endif ! WRITE(*,*) 'appel_stewart tmp 2243: Eqi_stewart(1)=', ! & Eqi_stewart(1) ! WRITE(*,*) 'Eqi_prime_cas=',Eqi_prime_cas(1) ! deduction de XTP partir de Exi DO il=1,ncas IF (i.lt.INB_cas(il)) THEN IF (fac_ftmr_cas(il).gt.0.0) THEN IF (Eqi_stewart(il)*fac_ftmr_cas(il).gt.ridicule) THEN DO ixt=1,niso ! xtp(ixt,il,i)=xtnew(ixt)*qp(il,i)/xtnew(4) xtp_cas(ixt,il)=max(xtp_avantevaptrac_cas(ixt,il) & +fac_ftmr_cas(il)*Eqi_prime_cas(il) & *Exi_stewart(ixt,il)/Eqi_stewart(il),0.0) enddo !do ixt=1,niso else ! if (Eqi_stewart.gt.ridicule) THEN IF (qp_cas(il).gt.0.0) THEN IF (Eqi_prime_cas(il)*fac_ftmr_cas(il).gt.ridicule) & THEN ! il va manquer quelque chose: il faut augmenter ! xtp en lui ajoutant l'évap du niveau d'eau ! dessus ! pour l'instant, on bidouille: WRITE(*,*) 'appel_stewart 2930: il=',il DO ixt=1,niso xtnew(ixt,il)=xtnew(ixt,il) & *(qp_avantevap_cas(il) & +Eqi_prime_cas(il)*fac_ftmr_cas(il)) & /(qp_avantevap_cas(il) & +Eqi_stewart(il)*fac_ftmr_cas(il)) enddo endif !if (Eqi_prime_cas(il)*fac_ftmr_cas(il).gt.ridicule) DO ixt=1,niso xtp_cas(ixt,il)=xtnew(ixt,il) & +(xtp_avantevaptrac_cas(ixt,il) & -xtp_avantevap_cas(ixt,il)) enddo !do ixt=1,niso else !if (qp(il,i).gt.0.0) THEN DO ixt=1,niso xtp_cas(ixt,il)=0.0 enddo !do ixt=1,niso endif !if (qp(il,i).gt.0.0) THEN endif !if (Eqi_stewart.gt.ridicule) THEN #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il), & 'appel stewart 684b') enddo ! do ixt=1,niso IF (oktrac.EQ.0) THEN IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop( & xtp_cas(iso_eau,il),qp_cas(il), & 'appel stewart 688b',errmax,errmaxrel*30) & .EQ.1) THEN WRITE(*,*) 'il=',il WRITE(*,*) 'xtp_avantevaptrac_cas(iso_eau,il)=', & xtp_avantevaptrac_cas(iso_eau,il) WRITE(*,*) 'qp_avantevap_cas(il)=', & qp_avantevap_cas(il) WRITE(*,*) 'fac_ftmr_cas(il),Eqi_prime_cas(il)=', & fac_ftmr_cas(il),Eqi_prime_cas(il) WRITE(*,*) 'Exi_stewart(iso_eau,il),Eqi_stewart=', & Exi_stewart(iso_eau,il),Eqi_stewart(il) stop endif endif !if (iso_eau.gt.0) THEN IF ((iso_HDO.gt.0).AND. & (qp_cas(il).gt.ridicule)) THEN CALL iso_verif_aberrant( & xtp_cas(iso_HDO,il)/qp_cas(il), & 'appel_stewart 1384') endif ! if (iso_HDO.gt.0) THEN endif ! if (oktrac.EQ.0) THEN #endif else !if (fac_ftmr.gt.0.0) THEN ! ca veut dire que Mp=0, xtp pas définit DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevaptrac_cas(ixt,il) enddo !do ixt=1,niso endif !if (fac_ftmr.gt.0.0) THEN else !if (i.lt.INB) THEN ! si i=inb, on ne change rien au calcul original, et on ! suppose que la composition du ddft est égale à celle de ! l'env. Ceci a déjà été calculé plus haut DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevaptrac_cas(ixt,il) !xtp_avantevap(ixt) a déjà été définit proprement !dans ce cas là enddo endif !if (i.lt.INB) THEN enddo !do il=1,ncas ! verif #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il),'appel stewart 198b') CALL iso_verif_noNAN(xtevap_cas(ixt,il),'appel stewart 745b') enddo !do ixt=1,niso enddo ! do il=1,ncas IF (oktrac.EQ.0) THEN IF (iso_eau.gt.0) THEN DO il=1,ncas IF (iso_verif_egalite_choix_nostop( & xtp_cas(iso_eau,il), & qp_cas(il), & 'appel stewart 197b: cas_evap_glace', & errmax,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'i,il=',i,il,' INB(il)=',INB_cas(il) ! & ,' cas(il)=',cas_evap_glace(il) WRITE(*,*) 'Tevap=',T_cas(il) WRITE(*,*) 'xtp(iso_eau,il,i)=',xtp_cas(iso_eau,il) WRITE(*,*) 'qp(il,i)=',qp_cas(il) WRITE(*,*) 'xtnew(iso_eau)=',xtnew(iso_eau,il) WRITE(*,*) 'fac_ftmr=',fac_ftmr_cas(il) ! WRITE(*,*) 'Mp(il,i)=',Mp(cas_evap_glace(il),i) WRITE(*,*) 'xtp_avantevap(iso_eau)=', & xtp_avantevap_cas(iso_eau,il) WRITE(*,*) 'qp_avantevap=',qp_avantevap_cas(il) WRITE(*,*) 'Exi_stewart(iso_eau)=',Exi_stewart(iso_eau,il) WRITE(*,*) 'Eqi_stewart=',Eqi_stewart(il) ! WRITE(*,*) 'Eqi_prime=',Eqi_prime_cas(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau)=', & Pxtiinf_stewart(iso_eau,il) ! WRITE(*,*) 'Pqiinf_par=',Pqiinf_par(cas_evap_glace(il)) WRITE(*,*) 'Pxtisup(iso_eau)=',Pxtisup_cas(iso_eau,il) WRITE(*,*) 'Pqisup=',Pqisup_cas(il) stop endif !if iso_verif_egalite_choix_nostop enddo !do il=1,ncas endif IF (iso_HDO.gt.0) THEN DO il=1,ncas IF (qp_cas(il).gt.ridicule) THEN CALL iso_verif_aberrant( & xtp_cas(iso_HDO,il)/qp_cas(il), & 'appel_stewart 1449') endif !if (qp_cas(il).gt.ridicule) THEN enddo !do il=1,ncas endif ! if (iso_HDO.gt.0) THEN endif ! if (oktrac.EQ.0) THEN ! WRITE(*,*) 'appel_stewart 2331: sortie de make_cas_evap_glace' #endif END SUBROUTINE make_cas_evap_glace ! SUBROUTINE traitant l'évaporation des gouttes spécfiquement pour ! schéma de KE ! à modifier à la moindre modif du schéma de KE SUBROUTINE appel_stewart_vectall_np(lwork,ncum, & PH,T,EVAP,XTWDTRAIN, & WDTRAIN, & WATER,Q,XT, QS,QP,MP,WT, & ! inputs physiques XTWATER,XTP, & ! outputs indispensables XTEVAP, & ! diagnostiques sigd, & ! inputs tunables i,INB, & ! altitude: car cas particulier en INB NA,ND,nloc,cvflag_grav,ginv,Mpmin) ! dimensions USE isotopes_mod, ONLY: iso_eau, iso_HDO,bidouille_anti_divergence, & & thumxt1, ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: izone_revap, option_revap,ridicule_trac USE isotrac_routines_mod, ONLY: & & iso_verif_traceur_jbidouille,uncompress_commun_zone_revap, & & compress_evap_glace_zone,compress_evap_liq_zone, & & uncompress_commun_zone,compress_noevap_zone, & & compress_cond_facftmr_zone,compress_cond_nofftmr_zone #ifdef ISOVERIF USE isotrac_routines_mod, ONLY: iso_verif_traceur_pbidouille #endif #endif IMPLICIT NONE !*inputs et outputs INTEGER ncum ! dimension horiz effective LOGICAL lwork(nloc) INTEGER NA,ND,nloc ! dimensions officielles REAL PH(nloc,ND),T(nloc,ND),EVAP(nloc,NA) REAL XTWDTRAIN(ntraciso,nloc),WDTRAIN(nloc), & WATER(nloc,NA), Q(nloc,NA), XT(ntraciso,nloc,ND), & QS(nloc,ND),QP(nloc,NA), & XTWATER(ntraciso,nloc,NA),XTP(ntraciso,nloc,NA), & XTEVAP(ntraciso,nloc,NA), & WT(nloc,NA), MP(nloc,NA) REAL sigd(nloc) INTEGER i,INB(nloc) LOGICAL cvflag_grav REAL ginv REAL Mpmin !* variables intermediaires INTEGER ixt,j,il REAL qeff(ncum) REAL xtp_avantevap(ntraciso,ncum),qp_avantevap(ncum) ! real Exi(niso,ncum) ! equivalent à Eqi_prime REAL Pqisup(ncum),Pqiinf(ncum),Eqi(ncum) REAL Pqiinf_par(ncum), Eqi_prime(ncum), & Eqi_plus1(ncum), Eqi_par(ncum) REAL Pqiinf_stewart(ncum), Eqi_stewart(ncum) REAL Exi_prime(ntraciso,ncum) REAL Pxtiinf_stewart(niso,ncum), & Exi_stewart(niso,ncum) REAL Exi_plus1(niso,ncum) REAL Pxtisup(ntraciso,ncum), Pxtiinf(niso,ncum) REAL xtnew(niso,ncum) REAL fac_ftmr(ncum) ! facteur de conversion des flux en mixing ratio ! real Risup(ntraciso,ncum), Rcond(ntraciso,ncum), ! : Renv(ntraciso,ncum) ! real Revap(ntraciso,ncum), Riinf(ntraciso,ncum) ! real xtice(ntraciso,ncum), xtliq(ntraciso,ncum) ! real xtp0(ntraciso,ncum), qp0(ncum) ! real fcond(ncum), fice(ncum), cond(ncum) ! real zxtalphal(niso,ncum), zxtalphai(niso,ncum) REAL g REAL rat(ncum) REAL ztglace_kelvin parameter (ztglace_kelvin=273.15) INTEGER frac_sublim !real !real real_to_double ! compteurs de parsage INTEGER icas_condensation_facftmr,ncas_condensation_facftmr INTEGER icas_condensation_nofacftmr,ncas_condensation_nofacftmr INTEGER icas_noevap,ncas_noevap INTEGER icas_evap_liq,ncas_evap_liq INTEGER icas_evap_glace,ncas_evap_glace INTEGER ncas_tot ! tableaux d'indice issus du parsage INTEGER cas_condensation_facftmr(ncum) INTEGER cas_condensation_nofacftmr(ncum) INTEGER cas_noevap(ncum) INTEGER cas_evap_liq(ncum) INTEGER cas_evap_glace(ncum) INTEGER trace_cas(ncum) #ifdef ISOVERIF ! tracage des cas ! -1: ce n'est pas un point de travail ! 0: initialisation des points de travail ! 11: condensation_facftmr ! 12: condensation_nofacftmr ! 2: noevap ! 31: evap_liq ! 32: evap_glace ! integer iso_verif_positif_nostop ! integer iso_verif_positif_choix_nostop ! integer iso_verif_aberrant_nostop ! integer iso_verif_traceur_nostop ! integer iso_verif_egalite_nostop ! integer iso_verif_egalite_choix_nostop ! real deltaD REAL Exi_cas(niso,ncum),Exi(ntraciso,ncum) #endif ! integer iso_verif_noNAN_nostop ! outputs des calculs, compressés REAL xtevap_cas(niso,ncum),xtp_cas(niso,ncum), & xtwater_cas(niso,ncum) ! inputs des calculs, compréssés REAL T_cas(ncum),delP_cas(ncum), & xtevapsup_cas(niso,ncum),evap_cas(ncum), & qp_cas(ncum),wt_cas(ncum), & xt_cas(niso,ncum),q_cas(ncum), & qs_cas(ncum),water_cas(ncum), & sigd_cas(ncum) real qp_avantevap_cas(ncum), & xtp_avantevap_cas(niso,ncum), & Pqisup_cas(ncum), Pxtisup_cas(niso,ncum), & Eqi_prime_cas(ncum),fac_ftmr_cas(ncum) , & Eqi_cas(ncum) #ifdef ISOTRAC real qp_avantevaptrac_cas(ncum), & xtp_avantevaptrac_cas(niso,ncum) INTEGER izone ,iiso REAL xtaddp_tag(niso,ncum) REAL ptrac(ncum) REAL hdiag(ncum) #endif INTEGER INB_cas(ncum) ! WRITE(*,*) 'appel_stewart_np 48: entrée, i=',i ! definition de quelques constantes: !gravité: IF (cvflag_grav) THEN g=1/ginv else g=10. endif ! fractionne-t-on lors de la sublimation? frac_sublim=0 ! -> on ne fractionne pas !frac_sublim=1 ! -> oui, on fractionne ! ***** verification des inputs ************ #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN CALL iso_verif_egalite_choix(xt(iso_eau,il,i),q(il,i), & 'appel_stewart_np 58',errmax,errmaxrel) endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if (iso_eau.gt.0) THEN #ifdef ISOTRAC DO il=1,ncum CALL iso_verif_traceur(xt(1,il,i), & 'appel_stewart_np 141') enddo #endif #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN xt(iso_eau,il,i)= q(il,i) endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN ! verif que les vapeurs du ddft plus haut sont bonnes ! si i=INB, on ne verifie rien car pas de vapeur au dessus de INB #ifdef ISOVERIF DO il=1,ncum IF (i.lt.inb(il) .AND. lwork(il)) THEN DO j=i+1,INB(il) DO ixt=1,ntraciso CALL iso_verif_noNAN(xtevap(ixt,il,j), & 'appel_stewart_np 96') enddo enddo !do j=i+1,INB endif ! (i.lt.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #endif #ifdef ISOVERIF DO il=1,ncum IF (i.lt.inb(il) .AND. lwork(il)) THEN DO j=i+1,INB(il) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtp(iso_eau,il,j),qp(il,j), & 'appel_stewart_np 66',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN #ifdef ISOTRAC CALL iso_verif_traceur(xtp(1,il,j), & 'appel_stewart_np 167') #endif enddo !do j=i+1,INB endif ! (i.lt.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO il=1,ncum IF (i.lt.inb(il) .AND. lwork(il)) THEN DO j=i+1,INB(il) xtp(iso_eau,il,j)=qp(il,j) enddo !do j=i+1,INB endif ! (i.lt.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN ! end verif des inputs ! ****** calcul du facteur de conversion des flux en mixing ratio DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN IF ((Mp(il,i).gt.Mp(il,i+1)).AND.(Mp(il,i).gt.Mpmin)) THEN ! cas entrainant fac_ftmr(il)=1.0/Mp(il,i) else !if ((Mp(il,i).gt.Mp(il,i+1)) IF (Mp(il,i+1).gt.Mpmin) THEN ! cas non entrainant, mais flux existe fac_ftmr(il)=1.0/Mp(il,i+1) else ! pas de flux de masse, XTP reste constant fac_ftmr(il)=0.0 endif endif !if ((Mp(il,i).gt.Mp(il,i+1)) #ifdef ISOVERIF #endif endif ! (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum ! ****** calcul de la vapeur dans le ddft avant réévap DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN IF (i.lt.INB(il)) THEN IF ((Mp(il,i).gt.Mp(il,i+1)).AND.(Mp(il,i).gt.Mpmin)) THEN ! cas entrainant rat(il)=Mp(il,i+1)/Mp(il,i) qp_avantevap(il)=qp(il,i+1)*rat(il)+q(il,i)*(1-rat(il)) DO ixt=1,ntraciso xtp_avantevap(ixt,il)=xtp(ixt,il,i+1)*rat(il) & +xt(ixt,il,i)*(1-rat(il)) enddo else !if (Mp(il,i).gt.Mp(il,i+1)) THEN IF (Mp(il,i+1).gt.Mpmin) THEN ! cas non entrainant, mais flux existe qp_avantevap(il)=qp(il,i+1) DO ixt=1,ntraciso xtp_avantevap(ixt,il)=xtp(ixt,il,i+1) enddo else !if (Mp(il,i+1).gt.0) THEN ! pas de flux de masse, on ne calcule rien ! on garde le qp calculé dans cv3_unsat, original ! on suppose que le deltaD dans le ddft est celui de ! l'environnement qp_avantevap(il)=qp(il,i) IF (qp(il,i).gt.0) THEN #ifdef ISOVERIF CALL iso_verif_positif_strict(q(il,i), & 'appel_stewart_np 226') #endif DO ixt=1,ntraciso xtp_avantevap(ixt,il)=xt(ixt,il,i)/q(il,i)*qp(il,i) enddo else !if (qp(il,i).gt.0) THEN ! si qp est négatif, on met les isos dedans à 0 DO ixt=1,ntraciso xtp_avantevap(ixt,il)=0.0 enddo endif !if (qp(il,i).gt.0) THEN endif !if (Mp(il,i+1).gt.0) THEN endif !if (Mp(il,i).gt.Mp(il,i+1)) THEN else ! if i.lt.INB ! cas ou i=inb ! on garde le qp calculé dans cv3_unsat, original ! on suppose que le deltaD dans le ddft est celui de ! l'environnement qp_avantevap(il)=qp(il,i) IF (qp(il,i).gt.0) THEN DO ixt=1,ntraciso xtp_avantevap(ixt,il)=xt(ixt,il,i)/q(il,i)*qp(il,i) enddo else !if (qp(il,i).gt.0) THEN ! si qp négatif, on met les isotopes dedans à 0 qp_avantevap(il)=0.0 DO ixt=1,ntraciso xtp_avantevap(ixt,il)=0.0 enddo endif !if (qp(il,i).gt.0) THEN endif ! if i.lt.INB(il) endif ! (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN CALL iso_verif_egalite_choix( & (xtp_avantevap(iso_eau,il)), & (qp_avantevap(il)), & 'appel_stewart_np 95',errmax,errmaxrel) endif ! (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if (iso_eau.gt.0) THEN #endif ! ********* calculs des flux DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN Pqisup(il)=sigd(il)/g*wt(il,i)*water(il,i+1)+wdtrain(il)/g Pqiinf(il)=sigd(il)/g*wt(il,i)*water(il,i) ! ce qu'on aurait dans si ce ! ce qu s'évapore en i ne vient que de i, comme dans le schéma de ! KE original. Eqi_prime(il)=(evap(il,i)+evap(il,i+1))/2 & *100.*(PH(il,i)-PH(il,I+1))*sigd(il)/g Eqi(il)=evap(il,i)*100.*(PH(il,i)-PH(il,I+1))*sigd(il)/g Eqi_plus1(il)=evap(il,i+1)*100.*(PH(il,i)-PH(il,I+1))*sigd(il)/g ! avant le 15 juillet 2012, on avait juste Pqiinf_par(il)=Pqisup(il)-Eqi(il) ! mais donne pbs en 1D. On met une rustine, mais c'est pas bien ! justifié. Il faudrait reprendre ça proprement un jour. IF ((Eqi_prime(il).gt.0.0).AND. & (Pqiinf(il).ge.Pqisup(il)).AND. & (Pqisup(il).gt.0.0).AND. & (Pqisup(il)-Eqi_prime(il).gt.0.0)) THEN ! rustine au cas patho en 1D pour -90hPa/d Pqiinf_par(il)=Pqisup(il)-Eqi_prime(il) else Pqiinf_par(il)=Pqisup(il)-Eqi(il) endif Eqi_par(il)=Pqisup(il)-Pqiinf(il) DO ixt=1,ntraciso Pxtisup(ixt,il)=sigd(il)/g*wt(il,i+1)*xtwater(ixt,il,i+1) & +xtwdtrain(ixt,il)/g enddo endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np 335 nostop ' ! il=1 ! WRITE(*,*) 'Pqisup=',Pqisup(il) ! WRITE(*,*) 'Pqiinf=',Pqiinf(il) ! WRITE(*,*) 'Eqi_prime=',Eqi_prime(il) ! WRITE(*,*) 'Eqi=',Eqi(il) ! WRITE(*,*) 'Eqi_plus1=',Eqi_plus1(il) ! WRITE(*,*) 'Pqiinf_par=',Pqiinf_par(il) ! WRITE(*,*) 'Eqi_par=',Eqi_par(il) ! WRITE(*,*) 'qp=',qp(il,i) ! WRITE(*,*) 'qp_avantevap=',qp_avantevap(il) DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN DO ixt=1,niso IF (iso_verif_noNaN_nostop((Pxtisup(ixt,il)), & 'appel_setwart_vectall_np 338').EQ.1) THEN WRITE(*,*) 'il,i,ixt=',il,i,ixt WRITE(*,*) 'xtwater(ixt,il,i+1)=',xtwater(ixt,il,i+1) WRITE(*,*) 'xtwdtrain(ixt,il)=',xtwdtrain(ixt,il) WRITE(*,*) 'wt(il,i+1)=',wt(il,i+1) WRITE(*,*) 'water(il,i+1)=',water(il,i+1) WRITE(*,*) 'wdtrain(il)=',wdtrain(il) stop endif enddo !do ixt=1,niso endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #endif #ifdef ISOVERIF ! il =243 ! WRITE(*,*) 'appel_stewart 327: il=',il ! WRITE(*,*) 'Pqisup,Pqiinf,Eqi_prime,Eqi,Pqiinf_par,Eqi_par=', ! : Pqisup(il),Pqiinf(il),Eqi_prime(il),Eqi(il), ! : Pqiinf_par(il),Eqi_par(il) DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN CALL iso_verif_egalite_choix((Pqiinf(il)), & (Pqiinf_par(il)),'appel_stewart_np 218', & errmax,errmaxrel) endif !#ifdef ISOTRAC ! if ((option_traceurs.EQ.17).OR. ! : (option_traceurs.EQ.18)) THEN ! if (iso_verif_positif_nostop(( ! : Pxtisup(index_trac(izone_cond,iso_eau),il) ! : -Pxtisup(iso_eau,il)), ! : 'appel_stewart_np 332').EQ.1) THEN ! WRITE(*,*) 'Pxtisup(:,il)=',Pxtisup(:,il) ! WRITE(*,*) 'xtwater(:,il,i+1)=',xtwater(:,il,i+1) ! WRITE(*,*) 'xtwdtrain(:,il)=',xtwdtrain(:,il) ! stop ! endif !if (iso_verif_positif_nostop(Pxtisup(iso_eau,il)- ! endif !if ((option_traceurs.EQ.17).OR. !#endif enddo !do il=1,ncum ! il=243 ! WRITE(*,*) 'il,Pqisup,Pqiinf,Pqiinf_par=', ! ; il,Pqisup(il),Pqiinf(il),Pqiinf_par(il) ! WRITE(*,*) 'Eqi_prime,Eqi,Eqi_plus1,Eqi_par=', ! ; Eqi_prime(il),Eqi(il),Eqi_plus1(il),Eqi_par(il) ! WRITE(*,*) 'evap(il,i:i+1)=',evap(il,i:i+1) #endif ! petite vérif sur les flux DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN IF ((Eqi_par(il).lt.0.0) & .AND.(Pqiinf_par(il).le.0.0) & .AND.(water(il,i).gt.ridicule/10.)) THEN ! dans ce cas, on a de l'eau sortant dont il faut déterminer la ! composition, mais pourtant le bilan de masse indique qu'il ! n'y a pas d'eau sortant. Et si on recalcule l'évap pour avoir de ! l'eau sortant, Eqi_par<0 -> condensation! On est donc très ! embétté car Eqi_prime indique qu'il y a évaporation... #ifdef ISOVERIF WRITE(*,*) 'appel_stewart_np 239: cas génant' #endif IF (Eqi_prime(il)*fac_ftmr(il).lt. & qp_avantevap(il)*1e-2) THEN ! ouf: Eqi_prime a peut d'effet sur la vapeur du ddft. ! on peut donc condenser tranquillement pour obtenir de ! l'eau en sortie, ça ne changera pas grand chose sur la ! vapeur. Eqi_prime(il)=Eqi_par(il) #ifdef ISOVERIF WRITE(*,*) 'appel_stewart 409: Eqi_prime=Eqi_par' #endif else WRITE(*,*) 'appel_stewart_np 222: ce cas est très génant' stop endif endif endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO il=1,ncum xtp_avantevap(iso_eau,il)=qp_avantevap(il) Pxtisup(iso_eau,il)=Pqisup(il) enddo endif !if ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN ! ******** parsage des différents cas + quelques vérifs icas_condensation_facftmr=0 icas_condensation_nofacftmr=0 icas_noevap=0 icas_evap_glace=0 icas_evap_liq=0 !#ifdef ISOVERIF ! initialisation de l'outil de tracage de cas: DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN trace_cas(il)=0 else trace_cas(il)=-1 endif enddo !do il=1,ncum ! if (ncum.ge.602) THEN ! WRITE(*,*) 'appel_stewart_np tmp 379: avant parsage' ! il=602 ! WRITE(*,*) 'fac_ftmr(il)=',fac_ftmr(il) ! WRITE(*,*) 'ridicule,errmax=',ridicule,errmax ! endif !#endif DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN IF ((Eqi_prime(il).lt.-ridicule*1e-3).OR. & (Eqi_prime(il)*fac_ftmr(il).lt.-ridicule*10)) THEN ! modif le 10 mai 2009: si Eqi_prime très petit, on le ! traite comme du 0 ! modif 15 mai 2009: on rajoute condition sur Eqi*fac_ftmr ! 1: Eqi_prime<0: condensation IF (fac_ftmr(il).gt.ridicule/100.) THEN ! si fac_ftmr très petit, on le traite comme du 0 ! 1.1: si Mpi>0 icas_condensation_facftmr=icas_condensation_facftmr+1 cas_condensation_facftmr(icas_condensation_facftmr)=il !#ifdef ISOVERIF trace_cas(il)=11 !#endif else !if (fac_ftmr.gt.0.0) THEN ! 1.2: si Mpi=0 icas_condensation_nofacftmr=icas_condensation_nofacftmr+1 cas_condensation_nofacftmr(icas_condensation_nofacftmr)=il !#ifdef ISOVERIF trace_cas(il)=12 !#endif endif !if (fac_ftmr.gt.0.0) THEN ELSE IF ((Eqi_prime(il).lt.ridicule*1e-3).AND. & (Eqi_prime(il)*fac_ftmr(il).lt.ridicule*10)) THEN ! 2: Eqi_prime est compris entre 1e-14 et -1e-14: rien ! ! 27 mai 2009: on remplace le seuil pour Eqi_prime(il)*fac_ftmr(il) ! ! de errmax/10 par ridicule*10 ! 18 sept 2009: on remplace ridicule*1e-2 par ridicule*1e-3 !pour éviter Eqi_prime=-1.87e-15, Pqisup=0 et water=1.44e-12 icas_noevap=icas_noevap+1 cas_noevap(icas_noevap)=il !#ifdef ISOVERIF trace_cas(il)=2 !#endif qp_avantevap(il)=max(0.0,qp_avantevap(il)) qp(il,i)=max(0.0,qp(il,i)) DO ixt=1,ntraciso xtp_avantevap(ixt,il)=max(0.0,xtp_avantevap(ixt,il)) enddo #ifdef ISOVERIF IF ((Pqisup(il).le.0.0).AND. & (water(il,i).gt.ridicule)) THEN WRITE(*,*) 'appel_stewart_np 420: water=',water(il,i) WRITE(*,*) 'Pqisup,Eqi_prime,fac_ftmr=',Pqisup(il), & Eqi_prime(il),fac_ftmr(il) stop endif IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop( & (qp_avantevap(il)), & qp(il,i),'appel_stewart_np 521', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'Mp(il,i)=',Mp(il,i) WRITE(*,*) 'Mp(il,i+1)=',Mp(il,i+1) WRITE(*,*) 'qp(il,i)=',qp(il,i) WRITE(*,*) 'qp(il,i+1)=',qp(il,i+1) WRITE(*,*) 'q(il,i)=',q(il,i) WRITE(*,*) 'evap(il,i)=',evap(il,i) WRITE(*,*) 'evap(il,i+1)=',evap(il,i+1) WRITE(*,*) 'Eqi_prime(il)=',Eqi_prime(il) WRITE(*,*) 'fac_ftmr(il)=',fac_ftmr(il) stop endif endif !if (iso_eau.gt.0) THEN #endif else !if (Eqi_prime.lt.0.0) THEN ! 3: Eqi_prime>0 #ifdef ISOVERIF ! ! quelques vérifs du bilan de masse d'eau ! if (iso_verif_positif_nostop(( ! : Pqisup(il)-Eqi_prime(il)), ! : 'appel_stewart_np 388 nostop ').EQ.1) THEN ! WRITE(*,*) 'il,Pqisup=',il,Pqisup(il) ! WRITE(*,*) 'Eqi_prime=',Eqi_prime(il) ! WRITE(*,*) 'Pqiinf=',Pqiinf(il) !! WRITE(*,*) 'stop temporaire, à enlever' !! stop ! endif IF (iso_verif_positif_choix_nostop(( & Pqisup(il)-Pqiinf_par(il)),errmax, & 'appel_stewart_np 442').EQ.1) THEN WRITE(*,*) 'appel_stewart_np 174' WRITE(*,*) 'Pqisup=',Pqisup(il), & ' Pqiinf_par=',Pqiinf_par(il) stop endif IF (iso_verif_positif_nostop((Eqi_par(il)), & 'appel_stewart_np 559b').EQ.1) THEN WRITE(*,*) 'Eqi(il),Eqi_plus1(il),Eqi_prime(il)=', & Eqi(il),Eqi_plus1(il),Eqi_prime(il) WRITE(*,*) 'Pqisup(il),Pqiinf(il),Eqi_par(il)=', & Pqisup(il),Pqiinf(il),Eqi_par(il) endif #endif IF (T(il,i).ge.ztglace_kelvin) THEN ! 3.1: evap des gouttes icas_evap_liq=icas_evap_liq+1 cas_evap_liq(icas_evap_liq)=il !#ifdef ISOVERIF trace_cas(il)=31 !#endif else !if (T(il,i).ge.ztglace_kelvin) THEN ! 3.2: evap de la glace icas_evap_glace=icas_evap_glace+1 cas_evap_glace(icas_evap_glace)=il !#ifdef ISOVERIF trace_cas(il)=32 !#endif endif !if (T(il,i).ge.ztglace_kelvin) THEN endif !if (Eqi_prime.lt.0.0) THEN endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum ncas_condensation_facftmr=icas_condensation_facftmr ncas_condensation_nofacftmr=icas_condensation_nofacftmr ncas_noevap=icas_noevap ncas_evap_liq=icas_evap_liq ncas_evap_glace=icas_evap_glace #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np vectoriel 355: parsage des cas:' ! if (ncum.ge.602) THEN ! WRITE(*,*) 'trace_cas(602)=',trace_cas(602) ! endif ncas_tot=0 DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN ncas_tot=ncas_tot+1 endif enddo ! WRITE(*,*) 'i,ncum,ncas_tot=',i,ncum,ncas_tot ! WRITE(*,*) 'ncas_condensation_facftmr=',ncas_condensation_facftmr ! WRITE(*,*) 'ncas_condensation_nofacftmr=', ! & ncas_condensation_nofacftmr ! WRITE(*,*) 'ncas_noevap=',ncas_noevap ! WRITE(*,*) 'ncas_evap_liq_=',ncas_evap_liq ! WRITE(*,*) 'ncas_evap_glace=',ncas_evap_glace IF (ncas_tot.NE.ncas_condensation_facftmr & +ncas_condensation_nofacftmr & +ncas_noevap & +ncas_evap_liq & +ncas_evap_glace) THEN WRITE(*,*) 'mauvais parsage' stop endif #endif ! ****** traitement vectoriel du cas 1.1 IF (ncas_condensation_facftmr.gt.0) THEN !#ifdef ISOVERIF ! WRITE(*,*) 'cas_condensation_facftmr(1)=', & ! & cas_condensation_facftmr(1) !#endif CALL compress_cond_facftmr(ncas_condensation_facftmr, & cas_condensation_facftmr, & Eqi_prime_cas,Eqi_prime, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & T_cas,T(1,i), & fac_ftmr_cas,fac_ftmr, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i), & delP_cas,Ph, & sigd_cas,sigd(1), & #ifdef ISOVERIF evap_cas(1),evap(1,i),qp_cas(1),qp(1,i), & #endif nloc,ncum,nd,i) #ifdef ISOVERIF ! vérif de la compression ! WRITE(*,*) 'appel_stewart_np tmp 506: ', & ! & 'après compress_condensation_facftmr' ! WRITE(*,*) 'sigd_cas(1:3)=',sigd_cas(1:3) ! if (ncas_condensation_facftmr.ge.4) THEN ! WRITE(*,*) 'cas_condensation_facftmr(4)=', & ! & cas_condensation_facftmr(4) ! endif DO il=1,ncas_condensation_facftmr CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_condensation_facftmr(il))), & 'appel_stewart_np 457: compress condensation_facftmr', & errmax,errmax) CALL iso_verif_egalite_choix(water_cas(il), & water(cas_condensation_facftmr(il),i), & 'appel_stewart_np 460: compress condensation_facftmr', & errmax,errmax) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart_np 520: compress condensation_facftmr', & errmax,errmax) endif ! if (iso_eau.gt.0) THEN enddo #endif CALL make_condensation_facftmr(ncas_condensation_facftmr, & Eqi_prime_cas(1),Pqisup_cas(1),Pxtisup_cas(1,1), & fac_ftmr_cas(1),T_cas(1), & qp_avantevap_cas(1),xtp_avantevap_cas(1,1),water_cas(1), & delP_cas(1),xtevapsup_cas(1,1),ztglace_kelvin, & xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1),g,sigd_cas(1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),1 & #endif ) #ifdef ISOVERIF DO il=1,ncas_condensation_facftmr DO ixt=1,niso CALL iso_verif_noNaN(xtwater_cas(ixt,il), & 'appel_stewart_np 539') enddo enddo #endif CALL uncompress_commun(ncas_condensation_facftmr, & cas_condensation_facftmr, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC DO izone=1,ntraceurs_zone !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 538: condensation_facftmr, izone=', ! : izone !#endif CALL compress_cond_facftmr_zone( & ncas_condensation_facftmr, & cas_condensation_facftmr, & Eqi_prime_cas,Eqi_prime, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i), & #ifdef ISOVERIF evap_cas(1),evap(1,i), & #endif nloc,ncum,nd,i,izone) #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncas_condensation_facftmr CALL iso_verif_egalite_choix( & (qp_avantevap_cas(il)), & (xtp_avantevap_cas(iso_eau,il)), & 'appel_stewart_np 558',errmax,errmaxrel) enddo !do il=1,ncas_condensation_nofacftmr endif !if (iso_eau.gt.0) THEN #endif CALL make_condensation_facftmr(ncas_condensation_facftmr, & Eqi_prime_cas(1),Pqisup_cas(1),Pxtisup_cas(1,1), & fac_ftmr_cas(1),T_cas(1), & qp_avantevap_cas(1),xtp_avantevap_cas(1,1),water_cas(1), & delP_cas(1),xtevapsup_cas(1,1),ztglace_kelvin, & xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1),g,sigd_cas(1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),1 & #endif ) #ifdef ISOVERIF DO il=1,ncas_condensation_facftmr DO ixt=1,niso CALL iso_verif_noNaN(xtwater_cas(ixt,il), & 'appel_stewart_np 588') enddo enddo #endif !#ifdef ISOVERIF CALL uncompress_commun_zone(ncas_condensation_facftmr, & cas_condensation_facftmr, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone) enddo !do izone=1,ntraceurs_zone #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 574: ', ! : 'fin cas condensation_facftmr' DO il=1,ncas_condensation_facftmr ! WRITE(*,*) 'il,cas_condensation_facftmr(il)=', ! : il,cas_condensation_facftmr(il) ! WRITE(*,*) 'xtp(1:ntraciso:3)=',xtp(1:ntraciso:3, ! : cas_condensation_facftmr(il),i) ! WRITE(*,*) 'xtp_avantevap(1:ntraciso:3)=', ! : xtp_avantevap(1:ntraciso:3, ! : cas_condensation_facftmr(il)) ! if (il.EQ.cas_condensation_facftmr(602)) THEN ! WRITE(*,*) 'appel_stewart_np 638: il=602' ! WRITE(*,*) 'xtp(iso_eau:ntraciso:3,il,i)=', ! : xtp(iso_eau:ntraciso:3,cas_condensation_facftmr(il),i) ! endif CALL iso_verif_traceur(xtp & (1,cas_condensation_facftmr(il),i), & 'appel_stewart_np 557') CALL iso_verif_traceur(xtwater & (1,cas_condensation_facftmr(il),i), & 'appel_stewart_np 560') CALL iso_verif_traceur_justmass(xtevap & (1,cas_condensation_facftmr(il),i), & 'appel_stewart_np 563') enddo !do il=1,ncas_condensation_nofacftmr #endif !#ifdef ISOVERIF #endif !#ifdef ISOTRAC endif !if (ncas_condensation_facftmr.gt.0) THEN ! ****** traitement vectoriel du cas 1.2 IF (ncas_condensation_nofacftmr.gt.0) THEN CALL compress_cond_nofftmr(ncas_condensation_nofacftmr, & cas_condensation_nofacftmr, & Eqi_prime_cas,Eqi_prime(1), & Pqisup_cas,Pqisup(1), & Pxtisup_cas,Pxtisup(1,1), & water_cas,water(1,i), & T_cas,T(1,i), & qp_avantevap_cas,qp_avantevap(1), & xtp_avantevap_cas,xtp_avantevap(1,1), & xt_cas,xt(1,1,i),q_cas,q(1,i), & xtevapsup_cas,xtevap(1,1,i+1), & delP_cas,Ph, & sigd_cas,sigd(1), & #ifdef ISOVERIF evap_cas(1),evap(1,i),qp_cas(1),qp(1,i), & #endif nloc,ncum,nd,i) #ifdef ISOVERIF ! vérif de la compression ! WRITE(*,*) 'appel_stewart_np tmp 616: ', & ! & 'apres compress condensation_nofacftmr' ! WRITE(*,*) 'iso_routines 10153: sigd_cas(1:3)=', sigd_cas(1:3) DO il=1,ncas_condensation_nofacftmr CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_condensation_nofacftmr(il))), & 'appel_stewart_np 594: compress condensation_nofacftmr', & errmax,errmax) CALL iso_verif_egalite_choix(T_cas(il), & T(cas_condensation_nofacftmr(il),i), & 'appel_stewart_np 597: compress condensation_nofacftmr', & errmax,errmax) enddo #endif CALL make_condensation_nofacftmr(ncas_condensation_nofacftmr, & Eqi_prime_cas(1),Pqisup_cas(1), & Pxtisup_cas(1,1),water_cas(1),T_cas(1), & qp_avantevap_cas(1), xtp_avantevap_cas(1,1), & q_cas(1),xt_cas(1,1), & xtevapsup_cas(1,1) ,delP_cas(1), & ztglace_Kelvin, g,sigd_cas(1), & xtevap_cas(1,1),xtp_cas(1,1),xtwater_cas(1,1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),0 & #endif ) #ifdef ISOVERIF DO il=1,ncas_condensation_nofacftmr DO ixt=1,niso CALL iso_verif_noNaN(xtwater_cas(ixt,il), & 'appel_stewart_np 803') enddo enddo #endif CALL uncompress_commun(ncas_condensation_nofacftmr, & cas_condensation_nofacftmr, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC DO izone=1,ntraceurs_zone ! WRITE(*,*) 'appel_stewart_np 718: izone=',izone CALL compress_cond_nofftmr_zone( & ncas_condensation_nofacftmr, & cas_condensation_nofacftmr, & Eqi_prime_cas,Eqi_prime(1), & Pqisup_cas,Pqisup(1), & Pxtisup_cas,Pxtisup(1,1), & water_cas,water(1,i), & qp_avantevap_cas,qp_avantevap(1), & xtp_avantevap_cas,xtp_avantevap(1,1), & xt_cas,xt(1,1,i),q_cas,q(1,i), & xtevapsup_cas,xtevap(1,1,i+1), & #ifdef ISOVERIF evap_cas(1),evap(1,i), & #endif nloc,ncum,nd,i,izone) CALL make_condensation_nofacftmr(ncas_condensation_nofacftmr, & Eqi_prime_cas(1),Pqisup_cas(1), & Pxtisup_cas(1,1),water_cas(1),T_cas(1), & qp_avantevap_cas(1), xtp_avantevap_cas(1,1), & q_cas(1),xt_cas(1,1), & xtevapsup_cas(1,1) ,delP_cas(1), & ztglace_Kelvin, g,sigd_cas(1), & xtevap_cas(1,1),xtp_cas(1,1),xtwater_cas(1,1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),1 & #endif ) CALL uncompress_commun_zone(ncas_condensation_nofacftmr, & cas_condensation_nofacftmr, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone) enddo !do izone=1,ntraceurs_zone #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 690: ', & ! & 'fin du cas condensation_nofacftmr' DO il=1,ncas_condensation_nofacftmr CALL iso_verif_traceur(xtp & (1,cas_condensation_nofacftmr(il),i), & 'appel_stewart_np 651') CALL iso_verif_traceur(xtwater & (1,cas_condensation_nofacftmr(il),i), & 'appel_stewart_np 653') CALL iso_verif_traceur_justmass(xtevap & (1,cas_condensation_nofacftmr(il),i), & 'appel_stewart_np 655') enddo !do il=1,ncas_condensation_nofacftmr #endif #endif endif !if (ncas_condensation_nofacftmr.gt.0) THEN ! ****** traitement vectoriel du cas 2 IF (ncas_noevap.gt.0) THEN CALL compress_noevap(ncas_noevap, & cas_noevap, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i), & delP_cas,Ph, & #ifdef ISOVERIF evap_cas(1),evap(1,i),qp_cas(1),qp(1,i), & #endif nloc,ncum,nd,i) #ifdef ISOVERIF ! vérif de la compression ! WRITE(*,*) 'appel_stewart_np 719: apres compression iso noevap' DO il=1,ncas_noevap CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_noevap(il))), & 'appel_stewart_np 692: compression',errmax,errmaxrel) CALL iso_verif_egalite_choix(water_cas(il), & water(cas_noevap(il),i), & 'appel_stewart_np 693: compression',errmax,errmaxrel) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)), & 'appel_stewart_np 759',errmax,errmaxrel) IF (iso_verif_egalite_choix_nostop( & (xtp_avantevap(iso_eau,cas_noevap(il))), & qp(cas_noevap(il),i), & 'appel_stewart_np 739',errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'il,cas_noevap=',il,cas_noevap(il) stop endif CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & qp_cas(il), & 'appel_stewart_np 735',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN enddo !do il=1,ncas_noevap #endif CALL make_cas_noevap_np(ncas_noevap, & xtp_avantevap_cas(1,1),xtevapsup_cas(1,1), & Pxtisup_cas(1,1),Pqisup_cas(1),water_cas(1), & xtevap_cas(1,1),xtp_cas(1,1),xtwater_cas(1,1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),0 & #endif ) #ifdef ISOVERIF DO il=1,ncas_noevap DO ixt=1,niso CALL iso_verif_noNaN(xtwater_cas(ixt,il), & 'appel_stewart_np 935') enddo enddo #endif CALL uncompress_commun(ncas_noevap,cas_noevap, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC DO izone=1,ntraceurs_zone CALL compress_noevap_zone(ncas_noevap, & cas_noevap, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i), & #ifdef ISOVERIF evap_cas(1),evap(1,i), & #endif nloc,ncum,nd,i,izone) #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np 765: après compression isotrac' DO il=1,ncas_noevap CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)), & 'appel_stewart_np 759',errmax,errmaxrel) enddo !do il=1,ncas_noevap #endif CALL make_cas_noevap_np(ncas_noevap, & xtp_avantevap_cas(1,1),xtevapsup_cas(1,1), & Pxtisup_cas(1,1),Pqisup_cas(1),water_cas(1), & xtevap_cas(1,1),xtp_cas(1,1),xtwater_cas(1,1) & #ifdef ISOVERIF ,evap_cas(1),qp_cas(1),1 & #endif ) CALL uncompress_commun_zone(ncas_noevap,cas_noevap, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone) enddo !do izone=1,ntraceurs_zone #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 806: ', ! & 'fin du cas noevap' DO il=1,ncas_noevap CALL iso_verif_traceur(xtp(1,cas_noevap(il),i), & 'appel_stewart_np 734') CALL iso_verif_traceur(xtevap(1,cas_noevap(il),i), & 'appel_stewart_np 736') CALL iso_verif_traceur(xtwater(1,cas_noevap(il),i), & 'appel_stewart_np 738') enddo !do il=1,ncas_noevap #endif #endif endif !if (ncas_noevap.gt.0) THEN ! ****** traitement vectoriel du cas 3.1 IF (ncas_evap_liq.gt.0) THEN CALL compress_evap_liq(3,ncas_evap_liq, & cas_evap_liq, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i), & qs_cas,qs(1,i), & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas, & Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime, & Eqi,Eqi_cas, & fac_ftmr_cas,fac_ftmr, & T_cas,T(1,i), & wt_cas,wt(1,i), & INB_cas,INB(1), & delP_cas,Ph, & qp_cas,qp(1,i), & sigd_cas,sigd(1), & #ifdef ISOVERIF evap_cas,evap(1,i), & #endif nloc,ncum,nd,i) #ifdef ISOVERIF ! vérif de la compression ! WRITE(*,*) 'appel_stewart_np tmp 899: ', ! : 'apres compress_evap_liq' ! WRITE(*,*) 'cas_evap_liq(1)=',cas_evap_liq(1) ! if (ncas_evap_liq.ge.85) THEN ! WRITE(*,*) 'cas_evap_liq(85)=',cas_evap_liq(85) ! endif ! WRITE(*,*) 'Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas,Eqi_cas', ! : Eqi_stewart(1),Pqiinf_stewart(1), ! : Eqi_prime_cas(1),Eqi_cas(1) DO il=1,ncas_evap_liq ! WRITE(*,*) 'il=',il ! WRITE(*,*) 'qp_avantevap_cas(il),xtp_avantevap_cas(iso_eau,il)=', ! : qp_avantevap_cas(il),xtp_avantevap_cas(iso_eau,il) CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_evap_liq(il))), & 'appel_stewart_np 822: compression evap_liq', & errmax,errmax) CALL iso_verif_egalite_choix(water_cas(il), & water(cas_evap_liq(il),i), & 'appel_stewart_np 825: compression evap_liq', & errmax,errmax) CALL iso_verif_egalite_choix( & (qp_avantevap_cas(il)), & (qp_avantevap(cas_evap_liq(il))), & 'appel_stewart_np 783: compression evap_liq', & errmax,errmax) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart_np 789: compression evap_liq', & errmax,errmax) endif ! if (iso_eau.gt.0) THEN CALL iso_verif_positif((Eqi_stewart(il)), & 'appel_stewart_np 1124: compression evap_liq') enddo !do il=1,ncas_evap_liq #endif DO il=1,ncas_evap_liq qeff(il)=thumxt1*Qs_cas(il) & +(1.0-thumxt1)*qp_avantevap_cas(il) enddo !do il=1,ncas_evap_liq ! WRITE(*,*) 'appel tmp 802: xtp_avantevap_cas(iso_eau,2)=', ! : xtp_avantevap_cas(iso_eau,2) ! WRITE(*,*) 'appel tmp 1490: qp_avantevap_cas(2)=', ! : qp_avantevap_cas(2) ! WRITE(*,*) 'appel_stewart_np 933: make_cas_evap_liq_np pr eau normale' ! ici, ptrac ne sera pas utilisé CALL make_cas_evap_liq_np(ncas_evap_liq, & water_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & Pxtisup_cas(1,1),Pqisup_cas(1), & Eqi_stewart(1),Pqiinf_stewart(1),fac_ftmr_cas(1), & qs_cas(1), T_cas(1),wt_cas(1), delP_cas(1), & xtevapsup_cas(1,1),qeff(1),g,sigd_cas(1), Eqi_prime_cas(1), & Eqi_cas(1), & qp_cas(1), INB_cas(1),i,0, & #ifdef ISOTRAC ptrac(1),hdiag(1), & #endif #ifdef ISOVERIF evap_cas(1),Exi_cas(1,1), & #endif xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1)) #ifdef ISOVERIF DO il=1,ncas_evap_liq DO ixt=1,niso CALL iso_verif_noNaN(xtwater_cas(ixt,il), & 'appel_stewart_np 1105') enddo enddo #endif CALL uncompress_commun(ncas_evap_liq,cas_evap_liq, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC ! initialisation dans le cas où la revap est taggée: IF (option_revap.EQ.1) THEN DO il=1,ncas_evap_liq DO iiso=1,niso ixt=index_trac(izone_revap,iiso) xtevap(ixt,cas_evap_liq(il),i)=0.0 xtp(ixt,cas_evap_liq(il),i)= & xtp_avantevap(ixt,cas_evap_liq(il)) enddo !do iiso=1,niso enddo !do il=1,ncas_evap_glace endif DO izone=1,ntraceurs_zone ! WRITE(*,*) 'appel_stewart_np 924 tmp: cas liq: izone=',izone ! WRITE(*,*) 'appel 924: xtp_avantevap(c,cas(2))=', ! & xtp_avantevap(1:ntraciso:3,cas_evap_liq(2)) ! WRITE(*,*) 'Pxtisup(1:ntraciso:3,cas(2))=', ! & Pxtisup(1:ntraciso:3,cas_evap_liq(2)) CALL compress_evap_liq_zone(3,ncas_evap_liq, & cas_evap_liq, & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtp_avantevaptrac_cas, qp_avantevaptrac_cas, & xtevapsup_cas,xtevap(1,1,i+1), & water_cas,water(1,i), & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas, & Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime,ptrac, & Eqi,Eqi_cas, & #ifdef ISOVERIF evap_cas,evap(1,i), & #endif nloc,ncum,nd,izone) #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 941' ! if (ncas_evap_liq.ge.162) THEN ! WRITE(*,*) 'Eqi_prime_cas=',Eqi_prime_cas(162) ! WRITE(*,*) 'Pqisup=',Pqisup(cas_evap_liq(162)) ! WRITE(*,*) 'Eqi_prime=',Eqi_prime(cas_evap_liq(162)) ! WRITE(*,*) 'Pxtisup=', ! : Pxtisup(iso_eau:ntraciso:3,cas_evap_liq(162)) ! endif ! WRITE(*,*) 'qp_avantevap_cas(2)=', ! : qp_avantevap_cas(2) ! WRITE(*,*) 'xtp_avantevap(iso_eau,cas_evap_liq(1))=', ! : xtp_avantevap(iso_eau,cas_evap_liq(1)) ! WRITE(*,*) 'xtp_avantevap_cas(iso_eau,2)=', ! : xtp_avantevap_cas(iso_eau,2) ! WRITE(*,*) 'xtp_avantevaptrac_cas(iso_eau,2)=', ! : xtp_avantevaptrac_cas(iso_eau,2) IF (iso_eau.gt.0) THEN DO il=1,ncas_evap_liq ! WRITE(*,*) 'appel_stewart_np tmp 943: il=',il CALL iso_verif_egalite_choix( & (qp_avantevap(cas_evap_liq(il))), & (xtp_avantevap(iso_eau,cas_evap_liq(il))), & 'appel_stewart_np 944', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (qp_avantevap(cas_evap_liq(il))), & (qp_avantevap_cas(il)), & 'appel_stewart_np 951', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (xtp_avantevap(iso_eau,cas_evap_liq(il))), & (xtp_avantevap_cas(iso_eau,il)), & 'appel_stewart_np 956', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (qp_avantevap_cas(il)), & (xtp_avantevap_cas(iso_eau,il)), & 'appel_stewart_np 961', & errmax,errmaxrel) ! if ((option_traceurs.EQ.17).OR. ! : (option_traceurs.EQ.18)) THEN ! if (izone.EQ.izone_cond) THEN ! CALL iso_verif_positif(( ! : Pxtisup_cas(iso_eau,il) ! : -Pxtisup(iso_eau,cas_evap_liq(il))), ! : 'appel_stewart_np 1114') ! else !if (izone.EQ.izone_cond) THEN ! CALL iso_verif_positif(( ! : -Pxtisup_cas(iso_eau,il)), ! : 'appel_stewart_np 1118') ! endif !if (izone.EQ.izone_cond) THEN ! endif !if ((option_traceurs.EQ.17).OR. enddo !do il=1,ncas_evap_liq endif !if (iso_eau.gt.0) THEN #endif CALL make_cas_evap_liq_np(ncas_evap_liq, & water_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & xtp_avantevaptrac_cas(1,1),qp_avantevaptrac_cas(1), & Pxtisup_cas(1,1),Pqisup_cas(1), & Eqi_stewart(1),Pqiinf_stewart(1),fac_ftmr_cas(1), & qs_cas(1), T_cas(1),wt_cas(1), delP_cas(1), & xtevapsup_cas(1,1),qeff(1), g,sigd_cas(1),Eqi_prime_cas(1), & Eqi_cas(1), & qp_cas(1),INB_cas(1),i,1, & ptrac(1),hdiag(1), & #ifdef ISOVERIF evap_cas(1),Exi_cas(1,1), & #endif xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1)) ! verif #ifdef ISOVERIF DO il=1,ncas_evap_liq DO ixt=1,niso CALL iso_verif_noNaN(xtp_cas(ixt,il),'appel_stewart_np 198') CALL iso_verif_noNaN(xtevap_cas(ixt,il), & 'appel_stewart_np 745') CALL iso_verif_noNaN(xtwater_cas(ixt,il), & 'appel_stewart_np 745') enddo !do ixt=1,niso enddo !do il=1,ncas_evap_liq #endif CALL uncompress_commun_zone_revap(ncas_evap_liq,cas_evap_liq, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone,Eqi_stewart,fac_ftmr_cas, & #ifdef ISOVERIF Exi_cas(1,1),Exi(1,1), & #endif xtp_avantevaptrac_cas,1,hdiag(1)) enddo ! do izone=ntraceurs_zone #ifdef ISOVERIF DO il=1,ncas_evap_liq IF (iso_verif_traceur_nostop(xtp(1,cas_evap_liq(il),i), & 'appel_stewart_np 1256').EQ.1) THEN WRITE(*,*) 'il,cas_evap_liq(il)=',il,cas_evap_liq(il) WRITE(*,*) 'trace_cas(cas_evap_liq(il))=', & trace_cas(cas_evap_liq(il)) IF (trace_cas(cas_evap_liq(il)).EQ.31) THEN WRITE(*,*) 'cas evap_liq' WRITE(*,*) 'xtp(:,cas_evap_liq(il),i)=', & xtp(:,cas_evap_liq(il),i) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'Eqi_stewart(il),Eqi_prime=', & Eqi_stewart(il),Eqi_prime(cas_evap_liq(il)) WRITE(*,*) 'Pxtisup(:,cas_evap_liq(il))=', & Pxtisup(:,cas_evap_liq(il)) WRITE(*,*) 'xtp_avantevap(:,cas_evap_liq(il))=', & xtp_avantevap(:,cas_evap_liq(il)) WRITE(*,*) 'Exi(:,cas_evap_liq(il))=', & Exi(:,cas_evap_liq(il)) WRITE(*,*) 'T_cas(il)=',T_cas(il) WRITE(*,*) 'h(il)=',thumxt1+(1.0-thumxt1)* & qp_avantevap_cas(il)/qs_cas(il) endif !if (trace_cas(il).EQ.31) THEN ! en cas de problème ci, activer l'option débug de ! stewart_explicit ! stop ! le 22 aout: on replace errmaxrel*20 par errmaxrel*25 ! pour que ça marche à l'idris CALL iso_verif_traceur_choix(xtp(1,cas_evap_liq(il),i), & 'appel_stewart_np 1154', & errmax,errmaxrel*25,ridicule_trac,deltalimtrac) endif !if (iso_verif_traceur_nostop ! dans le test suivant, c'est errmaxrel*50 CALL iso_verif_traceur_pbidouille( & xtp(1,cas_evap_liq(il),i), & 'appel_stewart_np 1124') CALL iso_verif_traceur_justmass(xtevap(1,cas_evap_liq(il),i), & 'appel_stewart_np 1258') ! WRITE(*,*) 'appel_stewart_np tmp 1172: il,i=',il,i CALL iso_verif_traceur(xtwater(1,cas_evap_liq(il),i), & 'appel_stewart_np 1260') enddo !do il=1,ncas_evap_liq #endif #endif endif !if (ncas_evap_liq.gt.0) THEN ! ****** traitement vectoriel du cas 3.2 IF (ncas_evap_glace.gt.0) THEN CALL compress_evap_glace(3, & ncas_evap_glace,cas_evap_glace, & water_cas,water(1,i), & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & T_cas,T(1,i), & fac_ftmr_cas,fac_ftmr, & qp_avantevap_cas,qp_avantevap, & xtp_avantevap_cas,xtp_avantevap, & xtevapsup_cas,xtevap(1,1,i+1), & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas,Eqi_cas, & ! & Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime, Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime,Eqi, & ! modif 22 dec 2011 INB_cas,INB(1), & delP_cas,Ph, & qp_cas,qp(1,i), & sigd_cas,sigd(1), & #ifdef ISOVERIF evap_cas,evap(1,i), & #endif nloc,ncum,nd,i,frac_sublim) #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 898 apres compress glace' ! WRITE(*,*) 'qp_avantevap_cas(1),qp_avantevap(cas(1))=', ! & qp_avantevap_cas(1),qp_avantevap(cas_evap_glace(1)) !WRITE(*,*) 'Pqiinf_stewart(1)=',Pqiinf_stewart(1) ! vérif de la compression DO il=1,ncas_evap_glace ! WRITE(*,*) 'il=',il ! WRITE(*,*) 'qp_avantevap_cas(il),qp_avantevap(cas(il))=', ! : qp_avantevap_cas(il),qp_avantevap(cas_evap_glace(il)) CALL iso_verif_egalite_choix((Pqisup_cas(il)), & (Pqisup(cas_evap_glace(il))), & 'appel_stewart_np 1096: compression evap_glace', & errmax,errmax) CALL iso_verif_egalite_choix(water_cas(il), & water(cas_evap_glace(il),i), & 'appel_stewart_np 1099: compression evap_glace', & errmax,errmax) CALL iso_verif_egalite_choix(evap_cas(il), & evap(cas_evap_glace(il),i), & 'appel_stewart_np 910: compression evap_glace', & errmax,errmax) CALL iso_verif_egalite_choix(xtevapsup_cas(iso_eau,il), & xtevap(iso_eau,cas_evap_glace(il),i+1), & 'appel_stewart_np 1106: compression evap_glace', & errmax,errmax) CALL iso_verif_egalite_choix( & (qp_avantevap_cas(il)), & (qp_avantevap(cas_evap_glace(il))), & 'appel_stewart_np 914: compression evap_glace', & errmax,errmax) IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart_np 919: compression evap_glace', & errmax,errmax) endif enddo ! WRITE(*,*) 'appel_stewart_np tmp 1054:', ! : ' appel make_cas_evap_glace_np' ! WRITE(*,*) 'cas_evap_glace(1)=',cas_evap_glace(1) ! WRITE(*,*) 'Pqiinf_stewart(1)=',Pqiinf_stewart(1) #endif CALL make_cas_evap_glace_np(ncas_evap_glace, & water_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & Pxtisup_cas(1,1),Pqisup_cas(1), & Eqi_stewart(1),Eqi_prime_cas(1),Eqi_cas(1), & Pqiinf_stewart(1),fac_ftmr_cas(1), & qs_cas(1), T_cas(1),wt_cas(1), delP_cas(1), & xtevapsup_cas(1,1),g,sigd_cas(1),INB_cas(1),i, & frac_sublim,qp_cas(1), & #ifdef ISOVERIF evap_cas(1),0,Exi_cas(1,1), & #endif xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1)) !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 1073 après make_cas_evap_glace_np' !#endif #ifdef ISOVERIF DO il=1,ncas_evap_glace DO ixt=1,niso CALL iso_verif_noNaN(xtwater_cas(ixt,il), & 'appel_stewart_np 1402') enddo enddo #endif CALL uncompress_commun(ncas_evap_glace,cas_evap_glace, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & #ifdef ISOVERIF Exi_cas(1,1),Exi, & #endif ncum) #ifdef ISOTRAC ! initialisation dans le cas où la revap est taggée: IF (option_revap.EQ.1) THEN DO il=1,ncas_evap_glace DO iiso=1,niso ixt=index_trac(izone_revap,iiso) xtevap(ixt,cas_evap_glace(il),i)=0.0 xtp(ixt,cas_evap_glace(il),i)= & xtp_avantevap(ixt,cas_evap_glace(il)) enddo !do iiso=1,niso enddo !do il=1,ncas_evap_glace endif DO izone=1,ntraceurs_zone ! WRITE(*,*) 'tmp appel_stewart_np 1284: izone=',izone CALL compress_evap_glace_zone(3, & ncas_evap_glace,cas_evap_glace, & water_cas,water(1,i), & Pqisup_cas,Pqisup, & Pxtisup_cas,Pxtisup, & xtp_avantevap_cas,xtp_avantevap, & xtp_avantevaptrac_cas,qp_avantevaptrac_cas, & xtevapsup_cas,xtevap(1,1,i+1), & Eqi_stewart,Pqiinf_stewart,Eqi_prime_cas,Eqi_cas, & Pqiinf,Eqi_par,Pqiinf_par,Eqi_prime,Eqi, & ! & qp_cas, #ifdef ISOVERIF evap_cas,evap(1,i), & #endif nloc,ncum,nd,i,frac_sublim,izone) !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 1101 CALL make_cas_evap_glace_np' !#endif CALL make_cas_evap_glace_np(ncas_evap_glace, & water_cas(1), & xtp_avantevap_cas(1,1),qp_avantevap_cas(1), & xtp_avantevaptrac_cas(1,1),qp_avantevaptrac_cas(1), & Pxtisup_cas(1,1),Pqisup_cas(1), & Eqi_stewart(1),Eqi_prime_cas(1),Eqi_cas(1), & Pqiinf_stewart(1),fac_ftmr_cas(1), & qs_cas(1), T_cas(1),wt_cas(1), delP_cas(1), & xtevapsup_cas(1,1),g,sigd_cas(1),INB_cas(1),i, & frac_sublim,qp_cas(1), & #ifdef ISOVERIF evap_cas(1),1,Exi_cas(1,1), & #endif xtp_cas(1,1),xtwater_cas(1,1),xtevap_cas(1,1)) CALL uncompress_commun_zone_revap(ncas_evap_glace,cas_evap_glace, & xtp_cas,xtp(1,1,i),xtwater_cas,xtwater(1,1,i), & xtevap_cas,xtevap(1,1,i), & ncum,izone,Eqi_stewart,fac_ftmr_cas, & #ifdef ISOVERIF Exi_cas(1,1),Exi(1,1), & #endif xtp_avantevaptrac_cas,0,hdiag(1)) ! hdiag ne sera pas utilise enddo ! do izone=1,ntraceurs_zone #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 1117: ', ! : 'fin du cas evap_glace' DO il=1,ncas_evap_glace ! WRITE(*,*) 'appel_stewart_np tmp 1146: il=',il ! WRITE(*,*) 'xtp_avantevap=',xtp_avantevap ! : (1:ntraciso,cas_evap_glace(il)) ! WRITE(*,*) 'xtp=',xtp(1:ntraciso,cas_evap_glace(il),i) IF (iso_verif_traceur_nostop(xtp(1,cas_evap_glace(il),i), & 'appel_stewart_np 1314').EQ.1) THEN WRITE(*,*) 'il,cas_evap_glace(il)=',il,cas_evap_glace(il) WRITE(*,*) 'trace_cas(cas_evap_glace(il))=', & trace_cas(cas_evap_glace(il)) WRITE(*,*) 'cas evap_glace' WRITE(*,*) 'xtp(:,cas_evap_glace(il),i)=', & xtp(:,cas_evap_glace(il),i) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'Eqi_stewart(il)=',Eqi_stewart(il) WRITE(*,*) 'Pxtisup(:,cas_evap_glace(il))=', & Pxtisup(:,cas_evap_glace(il)) WRITE(*,*) 'xtp_avantevap(:,cas_evap_glace(il))=', & xtp_avantevap(:,cas_evap_glace(il)) WRITE(*,*) 'Exi(:,cas_evap_glace(il))=', & Exi(:,cas_evap_glace(il)) ! on laisse quand même une chance CALL iso_verif_traceur_pbidouille( & xtp(1,cas_evap_glace(il),i), & 'appel_stewart_np 1331') endif CALL iso_verif_traceur(xtevap(1,cas_evap_glace(il),i), & 'appel_stewart_np 2150') CALL iso_verif_traceur(xtwater(1,cas_evap_glace(il),i), & 'appel_stewart_np 2152') enddo !do il=1,ncas_evap_glace #endif #endif endif !if (ncas_evap_glace.gt.0) THEN ! ****** dernières vérifs et bidouilles #ifdef ISOVERIF DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN DO ixt=1,ntraciso IF ((iso_verif_noNAN_nostop(xtevap(ixt,il,i), & 'appel_stewart_np 1661').EQ.1).OR. & (iso_verif_noNAN_nostop(xtp(ixt,il,i), & 'appel_stewart_np 1382').EQ.1).OR. & (iso_verif_noNAN_nostop(xtwater(ixt,il,i), & 'appel_stewart_np 1381').EQ.1)) THEN WRITE(*,*) 'il,i,trace_cas=',il,i,trace_cas(il) stop endif enddo endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #endif #ifdef ISOVERIF DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop(xtwater(iso_eau,il,i), & water(il,i),'appel_stewart_np 1277, fin, water', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'il,i,trace_cas=',il,i,trace_cas(il) stop endif !if (iso_verif_egalite_choix_nostop( IF (iso_verif_egalite_choix_nostop( & xtp(iso_eau,il,i),qp(il,i),'appel_stewart_np 1278', & errmax,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'il,i,trace_cas=',il,i,trace_cas(il) stop endif !if (iso_verif_egalite_choix_nostop( IF (iso_verif_egalite_choix_nostop( & xtevap(iso_eau,il,i),evap(il,i), & 'appel_stewart_np 1279', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'il,i,trace_cas=',il,i,trace_cas(il) stop endif !if (iso_verif_egalite_choix_nostop( endif !if (iso_eau.gt.0) THEN IF ((iso_HDO.gt.0).AND. & (qp(il,i).gt.ridicule)) THEN CALL iso_verif_aberrant( & xtp(iso_HDO,il,i)/qp(il,i), & 'appel_stewart_np 1498') endif ! if (iso_HDO.gt.0) THEN #ifdef ISOTRAC ! if (il.EQ.602) THEN ! WRITE(*,*) 'appel_stewart_np 1334: il,i=',il,i ! WRITE(*,*) 'xtp(iso_eau:ntraciso:3,il,i)=', ! : xtp(iso_eau:ntraciso:3,il,i) ! endif CALL iso_verif_traceur(xtp(1,il,i), & 'appel_stewart_np 1632') CALL iso_verif_traceur_justmass(xtevap(1,il,i), & 'appel_stewart_np 1634') CALL iso_verif_traceur(xtwater(1,il,i), & 'appel_stewart_np 1636') ! if ((option_traceurs.EQ.17).OR. ! : (option_traceurs.EQ.18)) THEN ! if (iso_verif_positif_nostop(xtwater( ! : index_trac(izone_cond,iso_eau),il,i) ! : -xtwater(iso_eau,il,i), ! : 'appel_stewart_np 1457').EQ.1) THEN ! WRITE(*,*) 'il,trace_cas=',il,trace_cas(il) ! stop ! endif !if (iso_verif_positif_nostop(xtwater(iso_eau,il,i)- ! endif !if ((option_traceurs.EQ.17).OR. #endif endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO il=1,ncum IF (i.le.inb(il) .AND. lwork(il)) THEN xtwater(iso_eau,il,i)= water(il,i) xtp(iso_eau,il,i)=qp(il,i) xtevap(iso_eau,il,i)= evap(il,i) #ifdef ISOTRAC #ifdef ISOVERIF CALL iso_verif_traceur_pbidouille(xtp(1,il,i), & 'appel_stewart_np 1362') CALL iso_verif_traceur_pbidouille( & xtwater(1,il,i), & 'appel_stewart_np 1381') #else CALL iso_verif_traceur_jbidouille(xtp(1,il,i)) CALL iso_verif_traceur_jbidouille(xtwater(1,il,i)) #endif #endif endif !if (i.le.inb(il) .AND. lwork(il)) THEN enddo !do il=1,ncum endif !if (bidouille_anti_divergence) THEN !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np tmp 1197: sortie' !#endif END SUBROUTINE appel_stewart_vectall_np SUBROUTINE make_cas_noevap_np(ncas, & xtp_avantevap_cas,xtevapsup_cas, & Pxtisup_cas,Pqisup_cas,water_cas, & xtevap_cas,xtp_cas,xtwater_cas & #ifdef ISOVERIF ,evap_cas,qp_cas,oktrac & #endif ) USE isotopes_mod, ONLY: iso_eau, iso_HDO,Rdefault,ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas REAL xtevapsup_cas(niso,ncas),water_cas(ncas) real xtp_avantevap_cas(niso,ncas), & Pqisup_cas(ncas), Pxtisup_cas(niso,ncas) #ifdef ISOVERIF REAL evap_cas(ncas),qp_cas(ncas) INTEGER oktrac ! si traceurs, certaines verifs ne sont pas !valides #endif ! integer iso_verif_noNaN_nostop ! outputs REAL xtevap_cas(niso,ncas),xtp_cas(niso,ncas), & xtwater_cas(niso,ncas) ! locals REAL Risup(niso,ncas) INTEGER il,ixt !real ! WRITE(*,*) 'appel_stewart_np tmp 1530: Pxtisup_cas(iso_eau,2)=', ! & Pxtisup_cas(iso_eau,2) ! WRITE(*,*) 'Pqisup_cas(2)=',Pqisup_cas(2) DO il=1,ncas DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevap_cas(ixt,il) xtevap_cas(ixt,il)=0.0 enddo !do ixt=1,niso enddo !do il=1,ncas_noevap #ifdef ISOVERIF DO il=1,ncas IF ((Pqisup_cas(il).le.0.0).AND. & (water_cas(il).gt.ridicule*10)) THEN ! 27 mai 2009: on est plus laxiste dans le cas des traceurs ! d'eau: on met ridicule*10 WRITE(*,*) 'appel_stewart_np 372: water(il,i)=', & water_cas(il) WRITE(*,*) 'appel_stewart_np 372: Pqisup=',Pqisup_cas(il) stop endif IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)), & 'appel_stewart_np 1548',errmax,errmaxrel) endif CALL iso_verif_noNaN(water_cas(il), & 'appel_stewart_np 1583') enddo !do il=1,ncas_noevap #endif DO il=1,ncas ! changement: >0 -> >ridicule*1e-2 IF (Pqisup_cas(il).gt.ridicule*1e-2) THEN DO ixt=1,niso Risup(ixt,il)=Pxtisup_cas(ixt,il)/Pqisup_cas(il) xtwater_cas(ixt,il)=water_cas(il)*Risup(ixt,il) enddo !do ixt=1,niso else !if (Pqisup.gt.0.0) THEN DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il)*Rdefault(ixt) enddo !do ixt=1,niso endif !if (Pqisup.gt.0.0) THEN enddo !do il=1,ncas_noevap #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNaN(xtp_cas(ixt,il), & 'appel stewart 265.2: cas 1.1') CALL iso_verif_noNaN(xtevap_cas(ixt,il), & 'appel_stewart_np 286') IF (iso_verif_noNaN_nostop(xtwater_cas(ixt,il), & 'appel_stewart_np 1594').EQ.1) THEN WRITE(*,*) 'il,ixt=',il,ixt WRITE(*,*) 'water_cas(il)=',water_cas(il) WRITE(*,*) 'Pxtisup_cas(ixt,il),Pqisup_cas(il)=', & Pxtisup_cas(ixt,il),Pqisup_cas(il) stop endif enddo !do ixt=1,niso enddo !do il=1,ncas_noevap #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix(xtwater_cas(iso_eau,il), & water_cas(il),'appel_stewart_np 262.2, cas 1.1', & errmax,errmaxrel) IF ((xtwater_cas(iso_eau,il).EQ.0).AND. & (water_cas(il).gt.ridicule)) THEN WRITE(*,*) 'appel_stewart_np 263.2, cas 1.1' WRITE(*,*) 'xtwater(iso_eau,il)=',xtwater_cas(iso_eau,il) WRITE(*,*) 'water(il)=',water_cas(il) stop endif IF (oktrac.EQ.0) THEN ! WRITE(*,*) 'appel_stewart_np 1743 noevap tmp: il=',il CALL iso_verif_egalite_choix(xtp_cas(iso_eau,il), & qp_cas(il) & ,'appel_stewart_np 269.2, cas 1.1',errmax,errmaxrel) CALL iso_verif_egalite_choix(xtevap_cas(iso_eau,il), & evap_cas(il), & 'appel_stewart_np 275.2, cas 1.1', & errmax,errmaxrel) endif !if (oktrac.EQ.0) THEN enddo !do il=1,ncas endif ! if (iso_eau.gt.0) THEN IF (oktrac.EQ.0) THEN IF (iso_HDO.gt.0) THEN DO il=1,ncas IF (qp_cas(il).gt.ridicule) THEN CALL iso_verif_aberrant( & xtp_cas(iso_HDO,il)/qp_cas(il), & 'appel_stewart_np 613') endif !if (qp(cas_noevap(il),i).gt.ridicule) THEN enddo !do il=1,ncas endif ! if (iso_HDO.gt.0) THEN endif !if (oktrac.EQ.0) THEN #endif END SUBROUTINE make_cas_noevap_np SUBROUTINE make_cas_evap_liq_np(ncas, & water_cas, & xtp_avantevap_cas,qp_avantevap_cas, & xtp_avantevaptrac_cas,qp_avantevaptrac_cas, & Pxtisup_cas,Pqisup_cas, & Eqi_stewart,Pqiinf_stewart,fac_ftmr_cas, & qs_cas, T_cas,wt_cas, delP_cas, & xtevapsup_cas,qeff, g,sigd,Eqi_prime_cas, & Eqi_cas, & qp_cas,INB_cas,i,oktrac & #ifdef ISOTRAC ,ptrac,hdiag & #endif #ifdef ISOVERIF ,evap_cas,Exi_stewart & #endif ,xtp_cas,xtwater_cas,xtevap_cas) USE isotopes_mod, ONLY: iso_eau, iso_HDO,Rdefault,no_pce,ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #ifdef ISOTRAC USE isotrac_mod, ONLY: ridicule_trac #endif #endif IMPLICIT NONE ! inputs INTEGER ncas REAL xtp_avantevap_cas(niso,ncas), & qp_avantevap_cas(ncas) REAL xtp_avantevaptrac_cas(niso,ncas), & qp_avantevaptrac_cas(ncas) ! dans le cas des traceurs: xtp_avantevaptrac_cas est la ! quantité de traceur izone dans la vapeur ! alors que xtp_avantevap_cas est le total de toutes les zone ! on rééquilibre la goutte avec le total de toutes les zones, ! mais c'est xtp_avantevaptrac_cas qui recoit l'évap REAL Pqisup_cas(ncas), Pxtisup_cas(niso,ncas) REAL Pqiinf_stewart(ncas), Eqi_stewart(ncas) REAL fac_ftmr_cas(ncas),Eqi_prime_cas(ncas) REAL Eqi_cas(ncas) REAL T_cas(ncas),delP_cas(ncas), & xtevapsup_cas(niso,ncas), & wt_cas(ncas),qeff(ncas), & qs_cas(ncas),water_cas(ncas), & qp_cas(ncas) INTEGER oktrac #ifdef ISOTRAC REAL ptrac(ncas) REAL hdiag(ncas) #endif #ifdef ISOVERIF REAL evap_cas(ncas) #endif INTEGER INB_cas(ncas),i REAL g,sigd(ncas) ! outputs real xtp_cas(niso,ncas),xtwater_cas(niso,ncas), & xtevap_cas(niso,ncas) ! locals INTEGER il,ixt REAL Pxtiinf_stewart(niso,ncas), & Exi_stewart(niso,ncas) REAL xtnew(niso,ncas) !#ifdef ISOVERIF ! integer iso_verif_egalite_choix_nostop ! integer iso_verif_aberrant_nostop ! real deltaD ! integer iso_verif_aberrant_choix_nostop !#endif ! real ! integer iso_verif_noNaN_nostop #ifdef ISOVERIF ! if (ncas.ge.162) THEN ! WRITE(*,*) 'appel tmp 1975: xtp_avantevap_cas(iso_eau,162)=', ! : xtp_avantevap_cas(iso_eau,162) ! WRITE(*,*) 'appel tmp 1975b: qp_avantevap_cas(162)=', ! : qp_avantevap_cas(162) ! endif !if (ncas_evap_liq.ge.162) THEN IF (iso_eau.gt.0) THEN DO il=1,ncas ! WRITE(*,*) 'appel tmp 1492: il=',il CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart_np 473', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (xtp_avantevaptrac_cas(iso_eau,il)), & (qp_avantevaptrac_cas(il)), & 'appel_stewart_np 473b',errmax,errmaxrel) CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)),'appel_stewart_np 475', & errmax,errmaxrel) CALL iso_verif_positif( & (Eqi_stewart(il)),'appel_stewart_np 1908') enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_positif((Eqi_stewart(il)), & 'appel_stewart_np 1913') enddo !do il=1,ncas #endif #ifdef ISOTRAC ! à l'avenir, il faudra faire les choses plus proprement! IF (oktrac.EQ.1) THEN ! on renormalise le flux de précip et d'évap ! on suppose que la seule différence entre les différentes ! zones, c'est la compo du liquide DO il=1,ncas IF (ptrac(il).gt.1e-20) THEN Pqisup_cas(il)=Pqisup_cas(il)/ptrac(il) Eqi_stewart(il)=Eqi_stewart(il)/ptrac(il) Pqiinf_stewart(il)=Pqiinf_stewart(il)/ptrac(il) DO ixt=1,niso Pxtisup_cas(ixt,il)=Pxtisup_cas(ixt,il)/ptrac(il) enddo else !if (ptrac(il).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite((Pqisup_cas(il)), & 0.0,'appel 2104') CALL iso_verif_egalite((Eqi_stewart(il)), & 0.0,'appel 2105') CALL iso_verif_egalite((Pqiinf_stewart(il)), & 0.0,'appel 2106') #endif Pqisup_cas(il)=0.0 Eqi_stewart(il)=0.0 Pqiinf_stewart(il)=0.0 DO ixt=1,niso Pxtisup_cas(ixt,il)=0.0 enddo endif !if (ptrac(il).gt.0.0) THEN enddo !do il=1,ncas endif !if (oktrac.EQ.1) THEN #endif IF (no_pce.EQ.1) THEN CALL stewart_sublim_nofrac_vectall( & ncas,qp_avantevap_cas(1), & xtp_avantevap_cas(1,1),Pqisup_cas(1), & Pxtisup_cas(1,1),Eqi_stewart(1),Pqiinf_stewart(1), & Pxtiinf_stewart(1,1),xtnew(1,1),Exi_stewart(1,1), & fac_ftmr_cas(1)) else !if (no_pce.EQ.1) THEN CALL stewart_explicite_vectall(ncas, & qp_avantevap_cas(1),xtp_avantevap_cas(1,1), & Pqisup_cas, & Pxtisup_cas(1,1),Eqi_stewart(1), & Pqiinf_stewart(1),qeff(1), & Pxtiinf_stewart(1,1),xtnew(1,1),Exi_stewart(1,1), & fac_ftmr_cas(1), & qs_cas(1),T_cas(1),wt_cas(1),delP_cas(1) & #ifdef ISOVERIF ,0,73 & #endif ) endif !if (no_pce.EQ.1) THEN #ifdef ISOTRAC ! à l'avenir, il faudra faire les choses plus proprement! IF (oktrac.EQ.1) THEN ! on renormalise le flux de précip et d'évap ! on suppose que la seule différence entre les différentes ! zones, c'est la compo du liquide DO il=1,ncas Pqisup_cas(il)=Pqisup_cas(il)*ptrac(il) Eqi_stewart(il)=Eqi_stewart(il)*ptrac(il) Pqiinf_stewart(il)=Pqiinf_stewart(il)*ptrac(il) DO ixt=1,niso Pxtisup_cas(ixt,il)=Pxtisup_cas(ixt,il)*ptrac(il) Exi_stewart(ixt,il)=Exi_stewart(ixt,il)*ptrac(il) Pxtiinf_stewart(ixt,il)=Pxtiinf_stewart(ixt,il)*ptrac(il) xtnew(ixt,il)=xtp_avantevap_cas(ixt,il) & +(xtnew(ixt,il)-xtp_avantevap_cas(ixt,il))*ptrac(il) enddo hdiag(il)=qeff(il)/qs_cas(il) enddo !do il=1,ncas endif !if (oktrac.EQ.1) THEN #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix( & (Exi_stewart(iso_eau,il) & *fac_ftmr_cas(il)), & (Eqi_stewart(il)*fac_ftmr_cas(il)), & 'appel stewart 520',errmax*80,errmaxrel*80) CALL iso_verif_egalite_choix( & (Pxtiinf_stewart(iso_eau,il)), & (Pqiinf_stewart(il)), & 'appel_stewart_np 586', & errmax,errmaxrel) IF (Pqiinf_stewart(il).gt.ridicule) THEN CALL iso_verif_egalite_choix(( & Pxtiinf_stewart(iso_eau,il)/Pqiinf_stewart(il)), & 1.,'appel_setwart 575a', errmax*10, errmaxrel*10) endif !if (Pqiinf_par.gt.ridicule) THEN enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN #endif #ifdef ISOVERIF DO il=1,ncas CALL iso_verif_noNAN(water_cas(il), & 'appel_stewart_np 2009') CALL iso_verif_noNAN((Pqiinf_stewart(il)), & 'appel_stewart_np 2011') DO ixt=1,niso CALL iso_verif_noNAN(( & Pxtiinf_stewart(ixt,il)),'appel_stewart_np 2014') CALL iso_verif_noNAN(( & xtnew(ixt,il)),'appel_stewart_np 2014') enddo enddo #endif ! deduction de XTWATER à partir de Pxtiinf: ! hypothèse: l'eau en i a la même composition que le flux d'eau ! qui sort de la boite i (Pqiinf_par) DO il=1,ncas IF (abs(water_cas(il)).lt.ridicule/10.) THEN DO ixt=1,niso xtwater_cas(ixt,il)=0.0 enddo !do ixt=1,niso else !if (water(il,i).EQ.0.0) THEN IF (Pqiinf_stewart(il).gt.0.0) then !if (Pxtiinf_par(iso_eau).gt.0.0) THEN DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il) & *Pxtiinf_stewart(ixt,il)/Pqiinf_stewart(il) enddo else !if (Pxtiinf_stewart(iso_eau).gt.0.0) THEN ! normalement, ce cas a déjà été interdit dans ! compress_evp_glace DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il)*Rdefault(ixt) enddo !do ixt=1,niso endif endif !if (water(il,i).EQ.0.0) THEN enddo !do il=1,ncas #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtwater_cas(ixt,il), & 'appel_stewart_np 566') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtwater_cas(iso_eau,il), & water_cas(il),'appel_stewart_np 568',errmax,errmaxrel) IF (water_cas(il).gt.ridicule*10) THEN IF (iso_verif_egalite_choix_nostop( & xtwater_cas(iso_eau,il)/water_cas(il),1.0, & 'appel stewart 155',errmax*10,errmaxrel*10).EQ.1) THEN ! WRITE(*,*) 'i=',i WRITE(*,*) 'Tevap=',T_cas(il) WRITE(*,*) 'xtwater(iso_eau,il,i)=', & xtwater_cas(iso_eau,il) WRITE(*,*) 'water(il,i)=',water_cas(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau)=', & Pxtiinf_stewart(iso_eau,il) ! WRITE(*,*) 'Pqiinf_par,Pqiinf_stewart=', ! : Pqiinf_par(cas_evap_liq(il)),Pqiinf_stewart(il) stop endif !if (iso_verif_egalite_nostop( endif !if (water(il,i).gt.ridicule) THEN endif !if (iso_eau.gt.0) THEN enddo !do il=1,ncas #endif ! rappel, le Eqi_prime qu'on a mis en argument dans stewart est en ! fait égal à 0.5*(Eqi+Eqi+1) -> en tenir compte quand on ! calcule xtevapi. DO il=1,ncas IF (Eqi_stewart(il)*fac_ftmr_cas(il).gt.ridicule) THEN ! changement le 20avril 2012: >0 -> >ridicule DO ixt=1,niso xtevap_cas(ixt,il)=Eqi_cas(il) & *Exi_stewart(ixt,il)/Eqi_stewart(il) & /100/delP_cas(il)/sigd(il)*g enddo ! do ixt=1,niso else !if (Eqi_stewart.gt.0.0) THEN ! il peut quand même y a voir de la diffusion DO ixt=1,niso xtevap_cas(ixt,il)=Exi_stewart(ixt,il) & /100.0/delP_cas(il)/sigd(il)*g enddo !do ixt=1,niso endif !if (Eqi_stewart.gt.0.0) THEN enddo !do il=1,ncas #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso IF ((iso_verif_noNAN_nostop(xtevap_cas(ixt,il), & 'appel stewart 131').EQ.1).OR. & (iso_verif_noNAN_nostop(xtnew(ixt,il), & 'appel stewart 131b').EQ.1)) THEN WRITE(*,*) 'Exi_stewart(ixt,il)=',Exi_stewart(ixt,il) WRITE(*,*) 'Eqi_stewart(il)=',Eqi_stewart(il) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'Eqi_cas(il)=',Eqi_cas(il) WRITE(*,*) 'xtevap_cas(ixt,il)=',xtevap_cas(ixt,il) stop endif enddo ! do ixt=1,nisio enddo #endif #ifdef ISOVERIF DO il=1,ncas IF (oktrac.EQ.0) THEN ! dans le cas traceur, le calcul de evap_cas est plus ! compliqué: il faut le faire plus proprement dans ! compress_stewart IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop(xtevap_cas(iso_eau,il), & evap_cas(il),'appel stewart 142', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'il=',il WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'Eqi_stewart(il)=',Eqi_stewart(il) WRITE(*,*) 'Exi_stewart(iso_eau,il)=', & Exi_stewart(iso_eau,il) WRITE(*,*) '1/100/delP_cas(il)/sigd(il)*g*2=', & 1.0/100.0/delP_cas(il)/sigd(il)*g*2.0 WRITE(*,*) 'xtevapsup_cas(iso_eau,il)=', & xtevapsup_cas(iso_eau,il) stop endif endif !if (iso_eau.gt.0) THEN endif !if (oktrac.EQ.0) THEN #ifdef ISOTRAC IF (oktrac.EQ.1) THEN IF ((iso_eau.gt.0).AND.(iso_HDO.gt.0)) THEN CALL iso_verif_aberrant_choix( & (xtp_avantevaptrac_cas(iso_HDO,il)), & (xtp_avantevaptrac_cas(iso_eau,il)), & ridicule_trac,deltalimtrac, & 'appel_stewart_np 2053') endif !if ((iso_eau.gt.0).AND.(iso_HDO.gt.0)) THEN endif #endif enddo !do il=1,ncas #endif ! deduction de XTP partir de Exi DO il=1,ncas IF (i.lt.INB_cas(il)) THEN IF (fac_ftmr_cas(il).gt.0.0) THEN IF (Eqi_stewart(il)*fac_ftmr_cas(il).gt.ridicule) THEN DO ixt=1,niso ! xtp(ixt,il,i)=xtnew(ixt)*qp(il,i)/xtnew(4) xtp_cas(ixt,il)=max(xtp_avantevaptrac_cas(ixt,il) & +fac_ftmr_cas(il)*Eqi_prime_cas(il) & *Exi_stewart(ixt,il)/Eqi_stewart(il),0.0) enddo !do ixt=1,niso else ! if (Eqi_stewart.gt.ridicule) THEN IF (qp_cas(il).gt.0.0) THEN IF (Eqi_prime_cas(il)*fac_ftmr_cas(il).gt.ridicule) & THEN ! il va manquer quelque chose: il faut augmenter ! xtp en lui ajoutant l'évap du niveau d'eau ! dessus ! pour l'instant, on bidouille: ! WRITE(*,*) 'appel_stewart_np 2041: il=',il DO ixt=1,niso xtnew(ixt,il)=xtnew(ixt,il) & *(qp_avantevap_cas(il) & +Eqi_prime_cas(il)*fac_ftmr_cas(il)) & /(qp_avantevap_cas(il) & +Eqi_stewart(il)*fac_ftmr_cas(il)) enddo endif !if (Eqi_prime_cas(il)*fac_ftmr_cas(il).gt.ridicule) DO ixt=1,niso ! xtp_cas(ixt,il)=xtnew(ixt,il) xtp_cas(ixt,il)=(xtp_avantevaptrac_cas(ixt,il) & +(xtnew(ixt,il) & -xtp_avantevap_cas(ixt,il))) ! modif 1 mai 2009, pour le cas des traceurs enddo !do ixt=1,niso ! WRITE(*,*) 'appel_stewart_np 1963 tmp: ', ! : 'xtp_cas(iso_eau,il)=',xtp_cas(iso_eau,il) else !if (qp(il,i).gt.0.0) THEN DO ixt=1,niso xtp_cas(ixt,il)=0.0 enddo !do ixt=1,niso endif !if (qp(il,i).gt.0.0) THEN endif !if (Eqi_stewart.gt.ridicule) THEN #ifdef ISOVERIF ! if (il.EQ.87) THEN ! WRITE(*,*) 'appel_stewart_np 2244: tmp, après calcul xtp' ! WRITE(*,*) 'xtnew(:,il)=',xtnew(:,il) ! WRITE(*,*) 'Pxtiinf_stewart(:,il)=', ! : Pxtiinf_stewart(:,il) ! endif !if (il.EQ.87) THEN DO ixt=1,niso IF (iso_verif_noNAN_nostop(xtp_cas(ixt,il), & 'appel stewart 684').EQ.1) THEN WRITE(*,*) 'i,INB_cas(il)=',i,INB_cas(il) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'Eqi_stewart(il)=',Eqi_stewart(il) WRITE(*,*) 'xtp_avantevaptrac_cas(ixt,il)=', & xtp_avantevaptrac_cas(ixt,i) WRITE(*,*) 'Exi_stewart(ixt,il)=',Exi_stewart(ixt,il) WRITE(*,*) 'xtnew(ixt,il)=',xtnew(ixt,il) WRITE(*,*) 'xtp_avantevap_cas(ixt,il)=', & xtp_avantevap_cas(ixt,il) WRITE(*,*) 'qp_cas(il)=',qp_cas(il) stop endif !if (iso_verif_noNAN(xtp_cas(ixt,il), enddo ! do ixt=1,niso #endif #ifdef ISOVERIF #ifdef ISOTRAC IF (oktrac.EQ.1) THEN IF ((iso_HDO.gt.0).AND.(iso_eau.gt.0)) THEN ! le 10 mai 2009: on remonte le seuil de vérif de deltaD ! aberrant car dans le cas des traceurs, des très ! petites concentrations sont très facilement ! influencées par des évaps qui peuvent être aberantes ! si ces evaps sont petites IF (iso_verif_aberrant_choix_nostop( & xtp_cas(iso_HDO,il),xtp_cas(iso_eau,il), & ridicule_trac,deltalimtrac, & 'appel_stewart_np 2090').EQ.1) THEN WRITE(*,*) 'xtp_avantevaptrac_cas(iso_eau),deltaD=', & xtp_avantevaptrac_cas(iso_eau,il),deltaD & ((xtp_avantevaptrac_cas(iso_HDO,il)) & /(xtp_avantevaptrac_cas(iso_eau,il))) WRITE(*,*) 'xtp_avantevap_cas(iso_eau),deltaD=', & xtp_avantevap_cas(iso_eau,il),deltaD & ((xtp_avantevap_cas(iso_HDO,il)) & /(xtp_avantevap_cas(iso_eau,il))) WRITE(*,*) 'xtnew(iso_eau),deltaD=', & xtnew(iso_eau,il),deltaD & ((xtnew(iso_HDO,il)) & /(xtnew(iso_eau,il))) WRITE(*,*) 'xtp_cas(iso_eau),deltaD=', & xtp_cas(iso_eau,il),deltaD & (xtp_cas(iso_HDO,il)/xtp_cas(iso_eau,il)) WRITE(*,*) 'Eqi_stewart(il),fac_ftmr_cas(il)=', & Eqi_stewart(il),fac_ftmr_cas(il) WRITE(*,*) 'Eqi_prime_cas(il)=', & Eqi_prime_cas(il) WRITE(*,*) 'deltaD_Eqi_stewart=', & deltaD(( & Exi_stewart(iso_HDO,il)/Eqi_stewart(il))) WRITE(*,*) 'xtnew-xtp_avantevap_cas,deltaD=', & xtnew(iso_eau,il)-xtp_avantevap_cas(iso_eau,il), & deltaD(((xtnew(iso_HDO,il) & -xtp_avantevap_cas(iso_HDO,il))/ & (xtnew(iso_eau,il) & -xtp_avantevap_cas(iso_eau,il)))) WRITE(*,*) 'Pqisup,deltaD=', & Pqisup_cas(il),deltaD(( & Pxtisup_cas(iso_HDO,il)/Pqisup_cas(il))) stop endif endif !if (iso_HDO.gt.0) THEN endif !if (oktrac.EQ.1) THEN #endif !#ifdef ISOTRAC IF (oktrac.EQ.0) THEN IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop(xtp_cas(iso_eau,il), & qp_cas(il),'appel stewart 688', & errmax,errmaxrel*30).EQ.1) THEN WRITE(*,*) 'il=',il WRITE(*,*) 'q,xtp_avantevap_cas(iso_eau)=', & qp_avantevap_cas(il), & xtp_avantevap_cas(iso_eau,il) WRITE(*,*) 'xtnew,qp,xtpcas=', & xtnew(iso_eau,il),qp_cas(il),xtp_cas(iso_eau,il) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'Eqi_prime_cas(il)=', & Eqi_prime_cas(il) WRITE(*,*) 'Eqi_stewart, Exi_stewart=', & Eqi_stewart(il), & Exi_stewart(iso_eau,il) WRITE(*,*) 'Pqisup=',Pqisup_cas(il) stop endif !if (iso_verif_egalite_choix_nostop(xtp_cas(iso_eau,il), endif !if (iso_eau.gt.0) THEN IF ((iso_HDO.gt.0).AND. & (qp_cas(il).gt.ridicule)) THEN IF (iso_verif_aberrant_nostop(xtp_cas(iso_HDO,il)/ & qp_cas(il), & 'appel_stewart_np 1079').EQ.1) THEN WRITE(*,*) 'i,qp(cas_evap_liq(il),i)=', & i,qp_cas(il) WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) WRITE(*,*) 'deltaDxtnew=',deltaD(( & xtnew(iso_HDO,il))/qp_cas(il)) stop endif endif !if (iso_HDO.gt.0) THEN endif ! if (oktrac.EQ.0) THEN #endif else !if (fac_ftmr.gt.0.0) THEN ! ca veut dire que Mp=0, xtp pas définit DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevaptrac_cas(ixt,il) enddo !do ixt=1,niso endif !if (fac_ftmr.gt.0.0) THEN else !if (i.lt.INB) THEN ! si i=inb, on ne change rien au calcul original, et on ! suppose que la composition du ddft est égale à celle de ! l'env. Ceci a déjà été calculé plus haut DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevaptrac_cas(ixt,il) !xtp_avantevap(ixt) a déjà été définit proprement !dans ce cas là enddo endif !if (i.lt.INB) THEN enddo !do il=1,ncas ! verif #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il),'appel stewart 198') CALL iso_verif_noNAN(xtevap_cas(ixt,il),'appel stewart 745') enddo !do ixt=1,niso enddo !do il=1,ncas #endif #ifdef ISOVERIF DO il=1,ncas #ifdef ISOTRAC IF ((iso_HDO.gt.0).AND.(iso_eau.gt.0)) THEN IF (oktrac.EQ.1) THEN CALL iso_verif_aberrant_choix( & xtp_cas(iso_HDO,il),xtp_cas(iso_eau,il), & ridicule_trac,deltalimtrac,'appel_stewart_np 2138') endif endif !if (iso_HDO.gt.0) THEN #endif enddo !do il=1,ncas IF (oktrac.EQ.0) THEN IF (iso_eau.gt.0) THEN DO il=1,ncas IF (iso_verif_egalite_choix_nostop( & xtp_cas(iso_eau,il), & qp_cas(il), & 'appel stewart 197', & errmax,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'i=',i,' INB=',INB_cas(il) WRITE(*,*) 'Tevap=',T_cas(il) WRITE(*,*) 'xtp(iso_eau,il,i)=',xtp_cas(iso_eau,il) WRITE(*,*) 'qp(il,i)=',qp_cas(il) WRITE(*,*) 'xtnew(iso_eau)=',xtnew(iso_eau,il) WRITE(*,*) 'fac_ftmr=',fac_ftmr_cas(il) ! WRITE(*,*) 'Mp(il,i)=',Mp(cas_evap_liq(il),i) WRITE(*,*) 'xtp_avantevap(iso_eau)=', & xtp_avantevap_cas(iso_eau,il) WRITE(*,*) 'qp_avantevap=',qp_avantevap_cas(il) ! WRITE(*,*) 'Exi_prime(iso_eau)=',Exi_prime(iso_eau,il) ! WRITE(*,*) 'Eqi_prime=',Eqi_prime(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau)=', & Pxtiinf_stewart(iso_eau,il) ! WRITE(*,*) 'Pqiinf_par=',Pqiinf_par(cas_evap_liq(il)) WRITE(*,*) 'Pxtisup(iso_eau)=',Pxtisup_cas(iso_eau,il) WRITE(*,*) 'Pqisup=',Pqisup_cas(il) stop endif !if iso_verif_egalite_choix_nostop enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN DO il=1,ncas ! WRITE(*,*) 'appel_stewart_np 2166: fin make_cas_evap_liq_np, ', ! : 'il,deltaDqp=',il,deltaD(xtp_cas(iso_HDO,il)/qp_cas(il)) IF (qp_cas(il).gt.ridicule) THEN CALL iso_verif_aberrant( & xtp_cas(iso_HDO,il)/qp_cas(il), & 'appel_stewart_np 1130') endif !if (qp(cas_evap_liq(il),i).gt.ridicule) THEN enddo !do il=1,ncas endif endif ! if (oktrac.EQ.0) THEN #endif END SUBROUTINE make_cas_evap_liq_np SUBROUTINE make_cas_evap_glace_np(ncas, & water_cas, & xtp_avantevap_cas,qp_avantevap_cas, & xtp_avantevaptrac_cas,qp_avantevaptrac_cas, & Pxtisup_cas,Pqisup_cas, & Eqi_stewart,Eqi_prime_cas,Eqi_cas, & Pqiinf_stewart,fac_ftmr_cas, & qs_cas, T_cas,wt_cas, delP_cas, & xtevapsup_cas,g,sigd,INB_cas,i, & frac_sublim,qp_cas & #ifdef ISOVERIF ,evap_cas,oktrac,Exi_stewart & #endif ,xtp_cas,xtwater_cas,xtevap_cas) USE isotopes_mod, ONLY: iso_eau, iso_HDO, Rdefault, ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER ncas REAL xtp_avantevap_cas(niso,ncas), & qp_avantevap_cas(ncas) REAL xtp_avantevaptrac_cas(niso,ncas), & qp_avantevaptrac_cas(ncas) REAL Pqisup_cas(ncas), Pxtisup_cas(niso,ncas) REAL Pqiinf_stewart(ncas), Eqi_stewart(ncas) REAL fac_ftmr_cas(ncas),Eqi_prime_cas(ncas), & Eqi_cas(ncas) REAL T_cas(ncas),delP_cas(ncas), & xtevapsup_cas(niso,ncas), & wt_cas(ncas),qeff(ncas), & qs_cas(ncas),water_cas(ncas) REAL qp_cas(ncas) #ifdef ISOVERIF REAL evap_cas(ncas) INTEGER oktrac #endif REAL g,sigd(ncas) INTEGER frac_sublim INTEGER INB_cas(ncas),i ! outputs real xtp_cas(niso,ncas),xtwater_cas(niso,ncas), & xtevap_cas(niso,ncas) ! locals INTEGER il,ixt REAL Pxtiinf_stewart(niso,ncas), & Exi_stewart(niso,ncas) REAL xtnew(niso,ncas) !#ifdef ISOVERIF ! real ! integer iso_verif_egalite_choix_nostop ! integer iso_verif_aberrant_nostop ! real deltaD !#endif #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np 2052: entrée dans make_cas_evap_glace' IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix( & (xtp_avantevap_cas(iso_eau,il)), & (qp_avantevap_cas(il)), & 'appel_stewart_np 473b', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (Pxtisup_cas(iso_eau,il)), & (Pqisup_cas(il)),'appel_stewart_np 475b', & errmax,errmaxrel) enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN #endif ! 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 IF (frac_sublim.EQ.1) THEN CALL stewart_glace_vectall(ncas, & qp_avantevap_cas(1),xtp_avantevap_cas(1,1),Pqisup_cas(1), & Pxtisup_cas(1,1),Eqi_stewart(1),Pqiinf_stewart(1), & Pxtiinf_stewart(1,1),xtnew(1,1),Exi_stewart(1,1), & fac_ftmr_cas(1), & T_cas(1)) else !if (frac_sublim.EQ.1) THEN !#ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_explicite_np 2269' ! WRITE(*,*) 'Pqiinf_stewart(1)=',Pqiinf_stewart(1) ! WRITE(*,*) 'Pqisup_cas(1)=',Pqisup_cas(1) ! WRITE(*,*) 'Eqi_cas(1)=',Eqi_cas(1) ! WRITE(*,*) 'Eqi_prime_cas(1)=',Eqi_prime_cas(1) ! WRITE(*,*) 'Eqi_stewart(1)=',Eqi_stewart(1) !#endif CALL stewart_sublim_nofrac_vectall( & ncas,qp_avantevap_cas(1), & xtp_avantevap_cas(1,1),Pqisup_cas(1), & Pxtisup_cas(1,1), & Eqi_stewart(1),Pqiinf_stewart(1), & Pxtiinf_stewart(1,1),xtnew(1,1),Exi_stewart(1,1), & fac_ftmr_cas(1)) endif !if (frac_sublim.EQ.1) THEN #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np 2096: dans make_cas_evap_glace' IF (iso_eau.gt.0) THEN DO il=1,ncas CALL iso_verif_egalite_choix( & (Exi_stewart(iso_eau,il)*fac_ftmr_cas(il)), & (Eqi_stewart(il)*fac_ftmr_cas(il)), & 'appel stewart 520b',errmax*80,errmaxrel*80) CALL iso_verif_egalite_choix( & (Pxtiinf_stewart(iso_eau,il)), & (Pqiinf_stewart(il)), & 'appel_stewart_np 586', & errmax,errmaxrel) IF (Pqiinf_stewart(il).gt.ridicule) THEN IF (iso_verif_egalite_choix_nostop(( & Pxtiinf_stewart(iso_eau,il)/Pqiinf_stewart(il)), & 1.,'appel_setwart 575b', errmax*10, errmaxrel*10) & .EQ.1) THEN WRITE(*,*) 'Pqiinf_stewart(il)=',Pqiinf_stewart(il) ! WRITE(*,*) 'Pqiinf_par(il)=',Pqiinf_par(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau,il)=', & Pxtiinf_stewart(iso_eau,il) stop endif endif !if (Pqiinf_par.gt.ridicule) THEN enddo !do il=1,ncas endif !if (iso_eau.gt.0) THEN #endif ! deduction de XTWATER à partir de Pxtiinf: ! hypothèse: l'eau en i a la même composition que le flux d'eau ! qui sort de la boite i (Pqiinf_par) DO il=1,ncas IF (abs(water_cas(il)).lt.ridicule/10.) THEN DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il)*Rdefault(ixt) enddo !do ixt=1,niso else !if (water(il,i).EQ.0.0) THEN IF (Pqiinf_stewart(il).gt.0.0) then !if (Pxtiinf_par(iso_eau).gt.0.0) THEN DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il) & *Pxtiinf_stewart(ixt,il)/Pqiinf_stewart(il) enddo else !if (Pxtiinf_stewart(iso_eau).gt.0.0) THEN ! normalement, ce cas a déjà été interdit dans ! compress_evp_glace DO ixt=1,niso xtwater_cas(ixt,il)=water_cas(il)*Rdefault(ixt) enddo !do ixt=1,niso endif endif !if (water(il,i).EQ.0.0) THEN enddo !do il=1,ncas #ifdef ISOVERIF ! WRITE(*,*) 'appel_stewart_np 2563: dans make_cas_evap_glace' DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtwater_cas(ixt,il), & 'appel_stewart_np 566b') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtwater_cas(iso_eau,il), & water_cas(il),'appel_stewart_np 568b',errmax,errmaxrel) IF (water_cas(il).gt.ridicule*10) THEN IF (iso_verif_egalite_choix_nostop( & xtwater_cas(iso_eau,il)/water_cas(il),1.0, & 'appel stewart 155b',errmax*10,errmaxrel*10).EQ.1) THEN WRITE(*,*) 'i=',i WRITE(*,*) 'Tevap=',T_cas(il) WRITE(*,*) 'xtwater(iso_eau,il,i)=', & xtwater_cas(iso_eau,il) WRITE(*,*) 'water(il,i)=',water_cas(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau)=', & Pxtiinf_stewart(iso_eau,il) ! WRITE(*,*) 'Pqiinf_par,Pqiinf_stewart=', ! & Pqiinf_par(il),Pqiinf_stewart(il) stop endif !if (iso_verif_egalite_nostop( endif !if (water(il,i).gt.ridicule) THEN endif !if (iso_eau.gt.0) THEN enddo !do il=1,ncas #endif ! rappel, le Eqi_prime qu'on a mis en argument dans stewart est en ! fait égal à 0.5*(Eqi+Eqi+1) -> en tenir compte quand on ! calcule xtevapi. DO il=1,ncas IF (Eqi_stewart(il)*fac_ftmr_cas(il).gt.0.0) THEN DO ixt=1,niso xtevap_cas(ixt,il)=Eqi_cas(il) & *Exi_stewart(ixt,il)/Eqi_stewart(il) & /100.0/delP_cas(il)/sigd(il)*g enddo ! do ixt=1,niso else !if (Eqi_stewart.gt.0.0) THEN ! il peut quand même y a voir de la diffusion DO ixt=1,niso xtevap_cas(ixt,il)=Exi_stewart(ixt,il) & /100.0/delP_cas(il)/sigd(il)*g enddo !do ixt=1,niso endif !if (Eqi_stewart.gt.0.0) THEN enddo !do il=1,ncas #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtevap_cas(ixt,il),'appel stewart 131b') enddo ! do ixt=1,niso IF (oktrac.EQ.0) THEN ! dans le cas traceur, le calcul de evap_cas est plus ! compliqué: il faut le faire plus proprement dans ! compress_stewart IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop(xtevap_cas(iso_eau,il), & evap_cas(il), & 'appel stewart 142b',errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'i,il=',i,il WRITE(*,*) 'Exi_stewart(iso_eau,il),Eqi_stewart(il)=', & Exi_stewart(iso_eau,il),Eqi_stewart(il) WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) WRITE(*,*) 'xtevapsup_cas(iso_eau,il)=', & xtevapsup_cas(iso_eau,il) ! WRITE(*,*) 'evap,evapsup=',evap(cas_evap_glace(il),i), ! & evap(cas_evap_glace(il),i+1) stop endif !if (iso_verif_egalite_choix_nostop(xtevap_cas(iso_eau,il), endif !if (iso_eau.gt.0) THEN endif ! if (oktrac.EQ.0) THEN enddo !do il=1,ncas #endif ! WRITE(*,*) 'appel_stewart_np tmp 2243: Eqi_stewart(1)=', ! : Eqi_stewart(1) ! WRITE(*,*) 'Eqi_prime_cas=',Eqi_prime_cas(1) ! deduction de XTP partir de Exi ! temporaire: ! il=2 ! ixt=iso_eau ! WRITE(*,*) 'tmp 2619: Eqi_stewart(il)=',Eqi_stewart(il) ! WRITE(*,*) 'fac_ftmr_cas(il)=',fac_ftmr_cas(il) ! WRITE(*,*) 'xtp_avantevaptrac_cas(ixt,il)=', ! : xtp_avantevaptrac_cas(ixt,il) ! WRITE(*,*) 'Eqi_prime_cas(il)=',Eqi_prime_cas(il) ! WRITE(*,*) 'Exi_stewart(ixt,il)=',Exi_stewart(ixt,il) ! WRITE(*,*) 'tmp 2625: xtnew(ixt,il)=',xtnew(ixt,il) DO il=1,ncas IF (i.lt.INB_cas(il)) THEN IF (fac_ftmr_cas(il).gt.0.0) THEN ! if (Eqi_stewart(il).gt.ridicule) THEN IF (Eqi_stewart(il)*fac_ftmr_cas(il).gt.ridicule) THEN ! WRITE(*,*) 'appel_stewart_v_np 2633 tmp: il=',il DO ixt=1,niso ! xtp(ixt,il,i)=xtnew(ixt)*qp(il,i)/xtnew(4) xtp_cas(ixt,il)=max(xtp_avantevaptrac_cas(ixt,il) & +fac_ftmr_cas(il)*Eqi_prime_cas(il) & *Exi_stewart(ixt,il)/Eqi_stewart(il),0.0) enddo !do ixt=1,niso #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & xtp_cas(iso_eau,il),qp_cas(il), & 'appel stewart 2643a',errmax,errmaxrel*30) endif #endif else ! if (Eqi_stewart.gt.ridicule) THEN IF (qp_cas(il).gt.0.0) THEN ! if (Eqi_prime_cas(il)*fac_ftmr_cas(il).gt.ridicule) ! & THEN IF ((Eqi_prime_cas(il)-Eqi_stewart(il)) & *fac_ftmr_cas(il).gt.ridicule) THEN ! il va manquer quelque chose: il faut augmenter ! xtp en lui ajoutant l'évap du niveau d'eau ! dessus ! pour l'instant, on bidouille: IF (qp_avantevap_cas(il)+Eqi_stewart(il) & *fac_ftmr_cas(il).gt.ridicule) THEN !WRITE(*,*) 'appel_stewart_np 2500: il=',il DO ixt=1,niso xtnew(ixt,il)=xtnew(ixt,il) & *(qp_avantevap_cas(il) & +Eqi_prime_cas(il)*fac_ftmr_cas(il)) & /(qp_avantevap_cas(il) & +Eqi_stewart(il)*fac_ftmr_cas(il)) enddo else #ifdef ISOVERIF WRITE(*,*) 'appel_stewart_np 2672: on stoppe' stop #endif endif !if ((Eqi_prime_cas(il)-Eqi_stewart(il)) endif !if (Eqi_prime_cas(il)*fac_ftmr_cas(il).gt.ridicule) DO ixt=1,niso xtp_cas(ixt,il)=xtnew(ixt,il) & +(xtp_avantevaptrac_cas(ixt,il) & -xtp_avantevap_cas(ixt,il)) enddo !do ixt=1,niso #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & xtp_cas(iso_eau,il),qp_cas(il), & 'appel stewart 2643c',errmax,errmaxrel*30) endif !if (iso_eau.gt.0) THEN #endif else !if (qp(il,i).gt.0.0) THEN DO ixt=1,niso xtp_cas(ixt,il)=0.0 enddo !do ixt=1,niso endif !if (qp(il,i).gt.0.0) THEN endif !if (Eqi_stewart.gt.ridicule) THEN #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il), & 'appel stewart 684b') enddo ! do ixt=1,niso #endif #ifdef ISOVERIF IF (oktrac.EQ.0) THEN IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop( & xtp_cas(iso_eau,il),qp_cas(il), & 'appel stewart 688b',errmax,errmaxrel*30) & .EQ.1) THEN WRITE(*,*) 'il=',il WRITE(*,*) 'xtp_avantevaptrac_cas(iso_eau,il)=', & xtp_avantevaptrac_cas(iso_eau,il) WRITE(*,*) 'qp_avantevap_cas(il)=', & qp_avantevap_cas(il) WRITE(*,*) 'fac_ftmr_cas(il),Eqi_prime_cas(il)=', & fac_ftmr_cas(il),Eqi_prime_cas(il) WRITE(*,*) 'Exi_stewart(iso_eau,il),Eqi_stewart=', & Exi_stewart(iso_eau,il),Eqi_stewart(il) stop endif endif !if (iso_eau.gt.0) THEN IF ((iso_HDO.gt.0).AND. & (qp_cas(il).gt.ridicule)) THEN CALL iso_verif_aberrant( & xtp_cas(iso_HDO,il)/qp_cas(il), & 'appel_stewart_np 1384') endif ! if (iso_HDO.gt.0) THEN endif ! if (oktrac.EQ.0) THEN #endif else !if (fac_ftmr.gt.0.0) THEN ! ca veut dire que Mp=0, xtp pas définit DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevaptrac_cas(ixt,il) enddo !do ixt=1,niso endif !if (fac_ftmr.gt.0.0) THEN else !if (i.lt.INB) THEN ! si i=inb, on ne change rien au calcul original, et on ! suppose que la composition du ddft est égale à celle de ! l'env. Ceci a déjà été calculé plus haut DO ixt=1,niso xtp_cas(ixt,il)=xtp_avantevaptrac_cas(ixt,il) !xtp_avantevap(ixt) a déjà été définit proprement !dans ce cas là enddo endif !if (i.lt.INB) THEN enddo !do il=1,ncas ! verif #ifdef ISOVERIF DO il=1,ncas DO ixt=1,niso CALL iso_verif_noNAN(xtp_cas(ixt,il),'appel stewart 198b') CALL iso_verif_noNAN(xtevap_cas(ixt,il),'appel stewart 745b') enddo !do ixt=1,niso enddo ! do il=1,ncas #endif #ifdef ISOVERIF IF (oktrac.EQ.0) THEN IF (iso_eau.gt.0) THEN DO il=1,ncas IF (iso_verif_egalite_choix_nostop( & xtp_cas(iso_eau,il), & qp_cas(il), & 'appel stewart 197b: cas_evap_glace', & errmax,errmaxrel*50).EQ.1) THEN WRITE(*,*) 'i,il=',i,il,' INB(il)=',INB_cas(il) ! & ,' cas(il)=',cas_evap_glace(il) WRITE(*,*) 'Tevap=',T_cas(il) WRITE(*,*) 'xtp(iso_eau,il,i)=',xtp_cas(iso_eau,il) WRITE(*,*) 'qp(il,i)=',qp_cas(il) WRITE(*,*) 'xtnew(iso_eau)=',xtnew(iso_eau,il) WRITE(*,*) 'fac_ftmr=',fac_ftmr_cas(il) ! WRITE(*,*) 'Mp(il,i)=',Mp(cas_evap_glace(il),i) WRITE(*,*) 'xtp_avantevap(iso_eau)=', & xtp_avantevap_cas(iso_eau,il) WRITE(*,*) 'qp_avantevap=',qp_avantevap_cas(il) WRITE(*,*) 'Exi_stewart(iso_eau)=',Exi_stewart(iso_eau,il) WRITE(*,*) 'Eqi_stewart=',Eqi_stewart(il) ! WRITE(*,*) 'Eqi_prime=',Eqi_prime_cas(il) WRITE(*,*) 'Pxtiinf_stewart(iso_eau)=', & Pxtiinf_stewart(iso_eau,il) ! WRITE(*,*) 'Pqiinf_par=',Pqiinf_par(cas_evap_glace(il)) WRITE(*,*) 'Pxtisup(iso_eau)=',Pxtisup_cas(iso_eau,il) WRITE(*,*) 'Pqisup=',Pqisup_cas(il) stop endif !if iso_verif_egalite_choix_nostop enddo !do il=1,ncas endif IF (iso_HDO.gt.0) THEN DO il=1,ncas IF (qp_cas(il).gt.ridicule) THEN CALL iso_verif_aberrant( & xtp_cas(iso_HDO,il)/qp_cas(il), & 'appel_stewart_np 1449') endif !if (qp_cas(il).gt.ridicule) THEN enddo !do il=1,ncas endif ! if (iso_HDO.gt.0) THEN endif ! if (oktrac.EQ.0) THEN ! WRITE(*,*) 'appel_stewart_np 2331: sortie de make_cas_evap_glace' #endif END SUBROUTINE make_cas_evap_glace_np SUBROUTINE condiso_liq_ice_vectiso(xt,qt,cond, & tcond,zfice,zxtice,zxtliq) USE isotopes_mod, ONLY: iso_eau,iso_HDO,essai_convergence, & & bidouille_anti_divergence,ridicule #ifdef ISOVERIF ! USE isotopes_verif_mod, ONLY: Tmin_verif, faccond, errmax,errmaxrel USE isotopes_verif_mod #endif IMPLICIT NONE ! version vectorisée de condiso_liq_ice ! on fait d'un coup tous les iso de 1 à niso !d'un point de grille donnée ! déclarations ! **inputs REAL xt(ntraciso),qt,cond,tcond,zfice ! tcond en K ! **outputs REAL zxtice(ntraciso),zxtliq(ntraciso) ! Rq: on met ntraciso au cas où on passe direct en argument les ! tableaux comportant les traceurs. Mais on ne fait que des ! isotopes normaux ici. ! **locals REAL zxtalphal(niso),zxtalphai(niso) REAL t_coup parameter (t_coup=273.15) INTEGER ixt REAL zcond !#ifdef ISOVERIF ! integer iso_verif_aberrant_nostop ! debugage ! integer iso_verif_aberrant_choix_nostop ! real deltaD !#endif ! ********* début des calculs ********* ! traitement rapide du cas où cond=0 IF (cond.EQ.0) THEN DO ixt=1,niso zxtliq(ixt)=0 zxtice(ixt)=0 enddo RETURN endif ! verif que qt n'est pas nul IF (qt.EQ.0) THEN IF (cond.lt.ridicule) THEN DO ixt=1,niso zxtliq(ixt)=0 zxtice(ixt)=0 enddo RETURN else !if (cond.lt.ridicule) THEN ! c'est impossible de condenser qi pas d'eau au départ WRITE(*,*) 'condiso_liq_ice_vectiso 35' WRITE(*,*) 'qt=',qt WRITE(*,*) 'cond=',cond stop endif endif !if (cond.lt.ridicule) THEN ! verif xt et qt #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(qt,xt(iso_eau), & 'condiso_liq_ice_vectiso 62',errmax,errmaxrel) endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN CALL iso_verif_positif(qt-cond, & 'condiso_liq_ice_vectiso 56: cond>qt') CALL iso_verif_positif(tcond-Tmin_verif, & 'condiso_liq_ice_vectiso 70') CALL iso_verif_positif(300.0-tcond, & 'condiso_liq_ice_vectiso 70') #endif zcond=max(0.0,min(cond,qt)) IF (essai_convergence) THEN else cond=min(cond,qt) endif ! maintenant, qt et cond ne sont pas nuls: DO ixt=1,niso CALL fractcalk(ixt,tcond,zxtalphal(ixt),zxtalphai(ixt)) enddo #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(zxtalphal(ixt), & 'condiso_liq_ice_vectiso 65') CALL iso_verif_noNAN(zxtalphai(ixt), & 'condiso_liq_ice_vectiso 66') enddo IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zxtalphal(iso_eau),1.0, & 'condiso 21',errmax,errmaxrel) CALL iso_verif_egalite_choix(zxtalphai(iso_eau),1.0, & 'condiso 21',errmax,errmaxrel) endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN IF (qt.gt.ridicule) THEN IF (iso_verif_aberrant_nostop(xt(iso_HDO) & /qt*zxtalphai(iso_HDO)/faccond, & 'condiso_liq_ice_vectiso 64').EQ.1) THEN ! WRITE(*,*) 'deltaDt=',(xt/qt/tnat(iso_HDO)-1)*1000 ! WRITE(*,*) 'tcond,fcond,zxtalphai=', ! : tcond,cond/qt,zxtalphai ! stop endif !if (iso_verif_aberrant_nostop(xt/qt*zxtalphai/faccond, endif !if (qt.gt.ridicule) THEN endif !if (iso_HDO.gt.0) THEN #endif DO ixt=1,niso zxtliq(ixt)=zxtalphal(ixt)*xt(ixt)*zcond & /(qt+zcond*(zxtalphal(ixt)-1)) enddo IF (zcond/qt.lt.1e-5) THEN ! cas particulier pour éviter FI quand cond/qt->0 DO ixt=1,niso zxtice(ixt)=xt(ixt)/qt*zcond*zxtalphai(ixt) enddo ELSE IF (1.0-zcond/qt.lt.ridicule) THEN ! condensation totale ! on ajoute ce cas particulier le 9 avril 2012 car sur vargas ! en batch, 0**alpha est NaN DO ixt=1,niso zxtice(ixt)=xt(ixt) enddo !do ixt=1,niso else ! cas général DO ixt=1,niso zxtice(ixt)=xt(ixt)*(1.0-(1.0-(zcond/qt))**zxtalphai(ixt)) enddo endif !if (zcond/qt.lt.1e-5) THEN ! verif ! verif egalité pour ixt=4 et eau normale: #ifdef ISOVERIF IF (zfice.lt.1) THEN DO ixt=1,niso CALL iso_verif_noNAN(zxtliq(ixt), & 'condiso_liq_ice_vectiso 91') enddo IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zxtliq(iso_eau),cond, & 'condiso_liq_ice_vectiso 30',errmax,errmaxrel) endif ! if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN IF (cond.gt.ridicule) THEN CALL iso_verif_aberrant(zxtliq(iso_HDO)/cond, & 'condiso_liq_ice_vectiso 32') endif !if (cond.gt.ridicule) THEN endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN endif !if (zfice.lt.1) THEN IF (zfice.gt.0) THEN DO ixt=1,niso CALL iso_verif_noNAN(zxtice(ixt),'condiso_liq_ice_vectiso 149') enddo IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zxtice(iso_eau),cond, & 'condiso_liq_ice_vectiso 31',errmax,errmaxrel) endif ! if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN IF (cond.gt.ridicule) THEN IF (iso_verif_aberrant_nostop(zxtice(iso_HDO)/cond & /faccond,'condiso_liq_ice_vectiso 33').EQ.1) THEN WRITE(*,*) 'debug condiso 88: zfice=',zfice WRITE(*,*) 'cond/qt=',cond/qt WRITE(*,*) 'xt(iso_HDO)/qt=',xt(iso_HDO)/qt WRITE(*,*) 'deltaD(xt(iso_HDO)/qt)=', & deltaD(xt(iso_HDO)/qt) WRITE(*,*) 'zxtalphai(iso_HDO)=',zxtalphai(iso_HDO) WRITE(*,*) 'Rice/Rv0=',qt/cond* & (1-(1-cond/qt)**zxtalphai(iso_HDO))/(1-(1-cond/qt)) WRITE(*,*) 'tcond=',tcond-t_coup,'°C' IF (tcond-t_coup.gt.-40.0) THEN ! au dessus de -40, il y a de quoi s'inquiéter ! en dessous, on ne sait pas ce que valent les alphas stop endif !if (tcond(i).gt.100.0) THEN endif endif !if (cond.gt.ridicule) THEN endif !if (iso_HDO.gt.0) THEN endif !if (zfice.gt.0) THEN ! verif que deltaD n'est pas abberant: #endif ! end verif DO ixt=1,ntraciso zxtliq(ixt)=(1-zfice)*zxtliq(ixt) zxtice(ixt)=zfice*zxtice(ixt) enddo ! cam verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(zxtliq(ixt), & 'condiso_liq_ice_vectiso 132') CALL iso_verif_noNAN(zxtice(ixt), & 'condiso_liq_ice_vectiso 193') enddo IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & zxtice(iso_eau)+zxtliq(iso_eau),cond, & 'condiso_liq_ice_vectiso 79',errmax,errmaxrel) endif ! if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN ! assurer convergence IF (zfice.EQ.1.0) THEN zxtice(iso_eau)=cond endif !if (zfice.EQ.1.0) THEN endif !if ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO ixt=1,ntraciso zxtice(ixt)=max(0.0,zxtice(ixt)) zxtliq(ixt)=max(0.0,zxtliq(ixt)) enddo ! end verif ! *********** fin des calculs ********* END SUBROUTINE condiso_liq_ice_vectiso SUBROUTINE condiso_liq_ice_vectall(xt,qt,cond, & tcond,zfice,zxtice,zxtliq,n) USE isotopes_mod, ONLY: iso_eau,iso_HDO,iso_O18,bidouille_anti_divergence, & & ridicule #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel,deltalim,Tmin_verif, & ! deltalim_snow,faccond USE isotopes_verif_mod #ifdef ISOTRAC USE isotrac_mod, ONLY: ridicule_trac #endif #endif IMPLICIT NONE ! version vectorisée de condiso_liq_ice ! on fait d'un coup tous les lieux i de 1 à n ! et tous les iso de 1 à niso ! déclarations ! **inputs INTEGER n REAL xt(ntraciso,n),qt(n),cond(n),tcond(n),zfice(n) ! tcond en K ! **outputs REAL zxtice(ntraciso,n),zxtliq(ntraciso,n) ! Rq: on met ntraciso au cas où on passe direct en argument les ! tableaux comportant les traceurs. Mais on ne fait que des ! isotopes normaux ici. ! **locals REAL zxtalphal(niso,n),zxtalphai(niso,n) REAL t_coup parameter (t_coup=273.15) REAL zcond(n) INTEGER ixt, i ! compteurs #ifdef ISOVERIF ! integer iso_verif_aberrant_nostop ! debugage ! integer iso_verif_aberrant_choix_nostop ! integer iso_verif_noNaN_nostop ! integer iso_verif_positif_nostop ! real deltaD REAL xtv(niso,n),qv(n) #endif ! verif xt et qt #ifdef ISOVERIF DO i=1,n CALL iso_verif_noNaN(qt(i),'condiso_liq_ice_vectall 270') DO ixt=1,niso CALL iso_verif_noNaN(xt(ixt,i),'condiso_liq_ice_vectall 271') enddo enddo !do i=1,n #endif #ifdef ISOVERIF ! WRITE(*,*) 'condiso 253: entrée dans condiso' IF (iso_eau.gt.0) THEN DO i=1,n CALL iso_verif_egalite_choix & (qt(i),xt(iso_eau,i), & 'condiso_liq_ice_vectall 251',errmax,errmaxrel) enddo !do i=1,no endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN DO i=1,n ! if (qt(i).gt.ridicule) THEN #ifdef ISOTRAC CALL iso_verif_aberrant_choix(xt(iso_hdo,i),qt(i), & ridicule_trac,deltalimtrac,'condiso_liq_ice 256') #else CALL iso_verif_aberrant_choix(xt(iso_hdo,i),qt(i), & ridicule,deltalim,'condiso_liq_ice 256b') #endif ! on met deltalim*2 car les traceurs sont plus capricieux ! endif enddo !do i=1,n endif DO i=1,n ! WRITE(*,*) 'condiso_liq_ice_vect 292: i,qt(i),cond(i)=', ! & i,qt(i),cond(i) #ifdef VERIFNEGATIF CALL iso_verif_positif(qt(i), & 'condiso_liq_ice_vectall 268: qt<0') #endif IF ((iso_verif_positif_nostop(qt(i)-cond(i), & 'condiso_liq_ice_vectall 269: cond>qt').EQ.1).OR. & (iso_verif_positif_nostop(tcond(i)-Tmin_verif, & 'condiso_liq_ice_vectall 284').EQ.1).OR. & (iso_verif_positif_nostop(370.0-tcond(i), & 'condiso_liq_ice_vectall 286').EQ.1).OR. & ((qt(i).EQ.0).AND.(cond(i).gt.ridicule))) THEN ! c'est impossible de condenser qi pas d'eau au départ WRITE(*,*) 'condiso_liq_ice_vectall 315' WRITE(*,*) 'i=',i WRITE(*,*) 'qt(i)=',qt(i) WRITE(*,*) 'cond(i)=',cond(i) WRITE(*,*) 'tcond=',tcond(i) stop endif enddo !do i=1,n #endif DO i=1,n zcond(i)=max(0.0,min(cond(i),qt(i))) enddo ! paragraphe enlevé le 29 avril 2012 car redondant. !if (essai_convergence) THEN !else ! do i=1,n ! cond(i)=min(cond(i),qt(i)) ! enddo !endif ! calculs des coefs de fracs CALL fractcalk_vectall(tcond(1),zxtalphal(1,1),zxtalphai(1,1),n) #ifdef ISOVERIF DO i=1,n DO ixt=1,niso CALL iso_verif_noNAN(zxtalphal(ixt,i), & 'condiso_liq_ice_vectall 65') CALL iso_verif_noNAN(zxtalphai(ixt,i), & 'condiso_liq_ice_vectall 66') enddo IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zxtalphal(iso_eau,i),1.0, & 'condiso 21',errmax,errmaxrel) CALL iso_verif_egalite_choix(zxtalphai(iso_eau,i),1.0, & 'condiso 21',errmax,errmaxrel) endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN IF (qt(i).gt.ridicule) THEN IF (iso_verif_aberrant_nostop(xt(iso_HDO,i) & /qt(i)*zxtalphai(iso_HDO,i)/faccond, & 'condiso_liq_ice_vectall 64').EQ.1) THEN ! WRITE(*,*) 'deltaDt=',(xt/qt/tnat(iso_HDO)-1)*1000 ! WRITE(*,*) 'tcond,fcond,zxtalphai=', ! : tcond,cond/qt,zxtalphai ! stop endif !if (iso_verif_aberrant_nostop(xt/qt*zxtalphai/faccond, endif !if (qt.gt.ridicule) THEN endif !if (iso_HDO.gt.0) THEN enddo !do i=1,n ! WRITE(*,*) 'condiso 320: après calculs alpha' #endif ! calculs du condensat DO i=1,n ! on change les seuils IF ((zcond(i).le.1e-15).OR. & ((qt(i).le.1e-15).AND.(zcond(i).lt.ridicule))) THEN DO ixt=1,niso zxtliq(ixt,i)=0.0 zxtice(ixt,i)=0.0 enddo else !if ((cond(i).le.0.0).OR. DO ixt=1,niso zxtliq(ixt,i)=zxtalphal(ixt,i) & *xt(ixt,i)*zcond(i) & /(qt(i)+zcond(i)*(zxtalphal(ixt,i)-1.0)) enddo IF (zcond(i)/qt(i).lt.1e-5) THEN ! cas particulier pour éviter FI quand cond/qt->0 DO ixt=1,niso zxtice(ixt,i)=xt(ixt,i)/ & qt(i)*zcond(i)*zxtalphai(ixt,i) enddo !do ixt=1,niso ELSE IF (1.0-zcond(i)/qt(i).lt.ridicule) THEN ! condensation totale ! on ajoute ce cas particulier le 9 avril 2012 car sur vargas ! en batch, 0**alpha est NaN DO ixt=1,niso zxtice(ixt,i)=xt(ixt,i) enddo !do ixt=1,niso else !if (cond(i)/qt(i).lt.1e-5) THEN ! cas général DO ixt=1,niso zxtice(ixt,i)=xt(ixt,i) & *(1.0-(1.0-zcond(i)/qt(i))**zxtalphai(ixt,i)) enddo !do ixt=1,niso endif !if (cond(i)/qt(i).lt.1e-5) THEN endif !if ((cond(i).le.0.0).OR. enddo !do i=1,n ! verif ! verif egalité pour ixt=4 et eau normale: #ifdef ISOVERIF DO i=1,n DO ixt=1,niso IF ((iso_verif_noNaN_nostop(zxtliq(ixt,i), & 'condiso_liq_ice_vectall 91').EQ.1).OR. & (iso_verif_noNaN_nostop(zxtice(ixt,i), & 'condiso_liq_ice_vectall 92').EQ.1)) THEN WRITE(*,*) 'zxtalphal(ixt,i)=',zxtalphal(ixt,i) WRITE(*,*) 'xt(ixt,i)=',xt(ixt,i) WRITE(*,*) 'zcond(i)=',zcond(i) WRITE(*,*) 'qt(i)=',qt(i) stop endif enddo !do ixt=1,niso IF (zfice(i).lt.1.0) THEN DO ixt=1,niso CALL iso_verif_noNaN(zxtliq(ixt,i), & 'condiso_liq_ice_vectall 91') enddo IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zxtliq(iso_eau,i),cond(i), & 'condiso_liq_ice_vectall 30',errmax,errmaxrel) endif ! if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN IF (cond(i).gt.ridicule) THEN #ifdef ISOTRAC CALL iso_verif_aberrant_choix( & zxtliq(iso_HDO,i),cond(i), & ridicule_trac,deltalimtrac, & 'condiso_liq_ice_vectall 32') #else IF (iso_verif_aberrant_choix_nostop( & zxtliq(iso_HDO,i),cond(i), & ridicule,deltalim_snow, & 'condiso_liq_ice_vectall 32b').EQ.1) THEN WRITE(*,*) 'deltaDvap=',deltaD(xt(iso_hdo,i)/qt(i)) WRITE(*,*) 'T,alphal=', & tcond(i)-t_coup,zxtalphal(iso_hdo,i) WRITE(*,*) 'qt(i)=',qt(i) stop endif !if (iso_verif_aberrant_nostop( IF (iso_O18.gt.0) THEN IF (iso_verif_O18_aberrant_nostop( & zxtliq(iso_HDO,i)/cond(i), & zxtliq(iso_O18,i)/cond(i), & 'condiso_liq_ice_vectall 12546').EQ.1) THEN WRITE(*,*) 'debug condiso_liq_ice_vect 12364: i,zfice=',i,zfice (i) WRITE(*,*) 'cond,qt,cond/qt=',cond(i),qt(i),cond(i)/qt(i) WRITE(*,*) 'deltaD(xt(iso_HDO)/qt)=',deltaD(xt(iso_HDO,i)/qt(i)) WRITE(*,*) 'deltaD(zxtliq/cond)=',deltaD(zxtliq(iso_HDO,i)/cond(i)) WRITE(*,*) 'deltaO18(xt(iso_HDO)/qt)=',deltaO(xt(iso_O18,i)/qt(i)) WRITE(*,*) 'deltaO18(zxtliq/cond)=',deltaO(zxtliq(iso_O18,i)/cond(i)) WRITE(*,*) 'tcond(i)=',tcond(i)-t_coup,'°C' !stop ! Camille 9 mars 2023: trop strict endif !if (iso_verif_O18_aberrant_nostop( endif ! if (iso_O18.gt.0) THEN #endif endif !if (cond(i).gt.ridicule) THEN endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN endif !if (zfice.lt.1) THEN IF (zfice(i).gt.0) THEN DO ixt=1,niso IF (iso_verif_noNAN_nostop(zxtice(ixt,i), & 'condiso_liq_ice_vectall 417').EQ.1) THEN WRITE(*,*) 'ixt,i=',ixt,i WRITE(*,*) 'xt(ixt,i)=',xt(ixt,i) WRITE(*,*) 'qt(i)=',qt(i) WRITE(*,*) 'zcond(i),zcond/qt=',zcond(i),zcond(i)/qt(i) WRITE(*,*) 'zxtalphai(ixt,i)=',zxtalphai(ixt,i) stop endif enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(zxtice(iso_eau,i),cond(i), & 'condiso_liq_ice_vectall 31',errmax,errmaxrel) endif ! if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF (iso_HDO.gt.0) THEN IF (cond(i).gt.ridicule) THEN IF (iso_verif_aberrant_nostop( & zxtice(iso_HDO,i)/cond(i)/faccond, & 'condiso_liq_ice_vectall 414').EQ.1) THEN WRITE(*,*) 'debug condiso_liq_ice_vect 13364: i,zfice=', & i,zfice (i) WRITE(*,*) 'cond,qt,cond/qt=',cond(i)/qt(i), & cond(i),qt(i) WRITE(*,*) 'xt(iso_HDO)/qt=', & xt(iso_HDO,i)/qt(i) WRITE(*,*) 'deltaD(xt(iso_HDO)/qt)=', & deltaD(xt(iso_HDO,i)/qt(i)) WRITE(*,*) 'zxtalphai(iso_HDO)=', & zxtalphai(iso_HDO,i) WRITE(*,*) 'Rice/Rv0=',qt(i)/cond(i)* & (1.0-(1.0-cond(i)/qt(i))**zxtalphai(iso_HDO,i)) WRITE(*,*) 'deltaD(zxtice/cond)=', & deltaD(zxtice(iso_HDO,i)/cond(i)) WRITE(*,*) 'tcond(i)=',tcond(i)-t_coup,'°C' IF (tcond(i)-t_coup.gt.-40.0) THEN ! sinon, c'est pas grave, il y aura juste une ! abérrance dans les zones très froides. #ifdef ISOTRAC ! on est plus indulgent CALL iso_verif_aberrant_choix( & zxtice(iso_HDO,i),cond(i), & ridicule_trac,deltalimtrac, & 'condiso_liq_ice_vectall 441') #else stop #endif endif !if (tcond(i)-t_coup.gt.-40.0) THEN endif !if (iso_verif_aberrant_nostop IF (iso_O18.gt.0) THEN IF (iso_verif_O18_aberrant_nostop( & zxtice(iso_HDO,i)/cond(i), & zxtice(iso_O18,i)/cond(i), & 'condiso_liq_ice_vectall 12601').EQ.1) THEN WRITE(*,*) 'debug condiso_liq_ice_vect 364: i,zfice=',i,zfice (i) WRITE(*,*) 'cond,qt,cond/qt=',cond(i),qt(i),cond(i)/qt(i) WRITE(*,*) 'deltaD(xt(iso_HDO)/qt)=',deltaD(xt(iso_HDO,i)/qt(i)) WRITE(*,*) 'deltaD(zxtice/cond)=',deltaD(zxtice(iso_HDO,i)/cond(i)) WRITE(*,*) 'deltaO18(xt(iso_HDO)/qt)=',deltaO(xt(iso_O18,i)/qt(i)) WRITE(*,*) 'deltaO18(zxtice/cond)=',deltaO(zxtice(iso_O18,i)/cond(i)) WRITE(*,*) 'dexcess vap=',deltaD(xt(iso_HDO,i)/qt(i)) & & -8*deltaO(xt(iso_O18,i)/qt(i)) WRITE(*,*) 'tcond(i)=',tcond(i)-t_coup,'°C' WRITE(*,*) 'zxtalphai(iso_O18,i)=',zxtalphai(iso_O18,i) WRITE(*,*) 'xt(1:niso,i)=',xt(1:niso,i) !stop ! Camille 9 mars 2023: trop strict endif !if (iso_verif_O18_aberrant_nostop( endif ! if (iso_O18.gt.0) THEN endif !if (cond.gt.ridicule) THEN IF ((zcond(i)/max(qt(i),1e-15).gt.0.95).AND. & (zfice(i).EQ.1).AND.(qt(i).gt.5e-4)) THEN ! verif que la vapeur est très pauvre DO ixt=1,niso xtv(ixt,i)=xt(ixt,i)-zxtice(ixt,i) enddo #ifdef ISOVERIF CALL iso_verif_noNaN(qt(i), & 'condiso_liq_ice_vect 467b') CALL iso_verif_noNaN(zcond(i), & 'condiso_liq_ice_vect 467c') DO ixt=1,niso CALL iso_verif_noNaN(xtv(ixt,i), & 'condiso_liq_ice_vect 475a') CALL iso_verif_noNaN(xt(ixt,i), & 'condiso_liq_ice_vect 475b') CALL iso_verif_noNaN(zxtice(ixt,i), & 'condiso_liq_ice_vect 475c') enddo !do ixt=1,niso #endif qv(i)=qt(i)-zcond(i) IF (qv(i).gt.ridicule) THEN IF (deltaD(xtv(iso_HDO,i)/qv(i)).gt.-200.0) THEN WRITE(*,*) 'condiso 454: deltaDv trop fort' WRITE(*,*) 'tcond(i)-t_coup=',tcond(i)-t_coup WRITE(*,*) 'xt(:,i)=',xt(:,i) WRITE(*,*) 'zxtice(:,i)=',zxtice(:,i) WRITE(*,*) 'xtv(:,i)=',xtv(:,i) WRITE(*,*) 'zxtalphai(:,i)=',zxtalphai(:,i) WRITE(*,*) 'qt(i),zcond(i)=',qt(i),zcond(i) stop endif !if (deltaD((xt(ixt,i)-zxtice(ixt,i))/ endif !if (qv(i).gt.ridicule) THEN endif !if (zcond(i)/qt(i).gt.0.95) THEN endif !if (iso_HDO.gt.0) THEN endif !if (zfice.gt.0) THEN enddo ! do i=1,n #endif ! #ifdef ISOVERIF #ifdef ISOVERIF ! ajout temporaire le 28 oct: IF (iso_HDO.gt.0) THEN DO i=1,n IF (zfice(i).gt.0.9) THEN IF (iso_verif_aberrant_choix_nostop( & zxtice(iso_HDO,i),cond(i),ridicule,deltalim_snow, & ! Camille 9 mars 2023: pour le condensat, on laisse plus de ! marge 'condiso_liq_ice_vect 412').EQ.1) THEN WRITE(*,*) 'debug condiso_liq_ice_vect 449: i,zfice=', & i,zfice (i) WRITE(*,*) 'cond/qt=',cond(i)/qt(i) WRITE(*,*) 'deltaD(xt(iso_HDO)/qt)=', & deltaD(xt(iso_HDO,i)/qt(i)) WRITE(*,*) 'zxtalphai(iso_HDO)=', & zxtalphai(iso_HDO,i) WRITE(*,*) 'Rice/Rv0=',qt(i)/cond(i)* & (1.0-(1.0-cond(i)/qt(i))**zxtalphai(iso_HDO,i)) WRITE(*,*) 'deltaD(zxtice/cond)=', & deltaD(zxtice(iso_HDO,i)/cond(i)) WRITE(*,*) 'tcond(i)=',tcond(i)-t_coup,'°C' IF (tcond(i)-t_coup.gt.-40.0) THEN ! sinon, c'est pas grave, il y aura juste une ! abérrance dans les zones très froides. #ifdef ISOTRAC ! on est plus indulgent CALL iso_verif_aberrant_choix( & zxtice(iso_HDO,i),cond(i), & ridicule_trac,deltalimtrac, & 'condiso_liq_ice_vectall 480') #else stop #endif endif endif endif enddo endif !if (iso_HDO.gt.0) THEN #endif ! end verif DO i=1,n DO ixt=1,niso zxtliq(ixt,i)=(1-zfice(i))*zxtliq(ixt,i) zxtice(ixt,i)=zfice(i)*zxtice(ixt,i) enddo enddo ! cam verif #ifdef ISOVERIF DO i=1,n DO ixt=1,niso CALL iso_verif_noNAN(zxtliq(ixt,i), & 'condiso_liq_ice_vectall 132') CALL iso_verif_noNAN(zxtice(ixt,i), & 'condiso_liq_ice_vectall 537') enddo !do ixt=1,niso enddo !do i=1,n IF (iso_eau.gt.0) THEN DO i=1,n CALL iso_verif_egalite_choix(zxtice(iso_eau,i) & +zxtliq(iso_eau,i),cond(i), & 'condiso_liq_ice_vectall 79',errmax,errmaxrel) enddo !do i=1,n endif ! if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN ! WRITE(*,*) 'condiso 477: fin de condiso' #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN ! assurer convergence DO i=1,n IF (zfice(i).EQ.1.0) THEN zxtice(iso_eau,i)=cond(i) endif !if (zfice.EQ.1.0) THEN enddo endif !if ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO i=1,n DO ixt=1,niso zxtice(ixt,i)=max(0.0,zxtice(ixt,i)) zxtliq(ixt,i)=max(0.0,zxtliq(ixt,i)) enddo enddo ! end verif ! *********** fin des calculs ********* END SUBROUTINE condiso_liq_ice_vectall SUBROUTINE condiso_liq_ice(ixt,xt,qt,cond, & tcond,zfice,zxtice,zxtliq) USE isotopes_mod, ONLY: iso_eau,iso_HDO,bidouille_anti_divergence, & & ridicule,iso_O18 #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel,faccond USE isotopes_verif_mod #endif IMPLICIT NONE ! on s'interresse à l'isotope ixt. ! de l'air de propriétés (qt,xt) condense cond, à la température ! tcond, donc zfice*cond est sous forme de glace. ! on cherche alors les isotopes contenus dans les phases liquide ! et glace: zxtliq et zxtice ! déclarations ! **inputs REAL xt,qt,cond,tcond,zfice ! tcond en K INTEGER ixt ! **outputs REAL zxtice,zxtliq ! **locals REAL zxtalphal,zxtalphai ! integer iso_verif_aberrant_nostop ! debugage ! ********* début des calculs ********* ! traitement rapide du cas où cond=0 IF (cond.EQ.0) THEN zxtliq=0 zxtice=0 RETURN endif ! verif que qt n'est pas nul IF (qt.EQ.0) THEN IF (cond.lt.ridicule) THEN zxtliq=0 zxtice=0 RETURN else ! c'est impossible de condenser qi pas d'eau au départ WRITE(*,*) 'condiso_liq_ice 35' WRITE(*,*) 'qt=',qt WRITE(*,*) 'cond=',cond stop endif endif ! verif xt et qt #ifdef ISOVERIF IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN CALL iso_verif_egalite_choix & (qt,xt,'condiso_liq_ice 51',errmax,errmaxrel) endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN CALL iso_verif_positif(qt-cond,'condiso_liq_ice 56: cond>qt') #endif cond=min(cond,qt) ! maintenant, qt et cond ne sont pas nuls: CALL fractcalk(ixt,tcond,zxtalphal,zxtalphai) #ifdef ISOVERIF CALL iso_verif_noNAN(zxtalphal,'condiso_liq_ice 65') CALL iso_verif_noNAN(zxtalphai,'condiso_liq_ice 66') IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN CALL iso_verif_egalite(zxtalphal,1.0,'condiso 21') CALL iso_verif_egalite(zxtalphai,1.0,'condiso 21') endif !if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN #endif #ifdef ISOVERIF IF ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN IF (qt.gt.ridicule) THEN IF (iso_verif_aberrant_nostop(xt/qt*zxtalphai/faccond, & 'condiso_liq_ice 64').EQ.1) THEN ! WRITE(*,*) 'deltaDt=',(xt/qt/tnat(iso_HDO)-1)*1000 ! WRITE(*,*) 'tcond,fcond,zxtalphai=', ! : tcond,cond/qt,zxtalphai ! stop endif !if (iso_verif_aberrant_nostop(xt/qt*zxtalphai/faccond, endif !if (qt.gt.ridicule) THEN endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN #endif zxtliq=zxtalphal*xt*cond/(qt+cond*(zxtalphal-1)) IF (cond/qt.lt.1e-5) THEN ! cas particulier pour éviter FI quand cond/qt->0 zxtice=xt/qt*cond*zxtalphai ELSE IF (1.0-cond/qt.lt.ridicule) THEN ! condensation totale ! on ajoute ce cas particulier le 9 avril 2012 car sur vargas ! en batch, 0**alpha est NaN zxtice=xt else ! cas général zxtice=xt*(1-(1-cond/qt)**zxtalphai) endif ! verif ! verif egalité pour ixt=4 et eau normale: #ifdef ISOVERIF IF (zfice.lt.1) THEN CALL iso_verif_noNAN(zxtliq,'condiso_liq_ice 91') IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN CALL iso_verif_egalite(zxtliq,cond,'condiso_liq_ice 30') endif ! if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN IF (cond.gt.ridicule) THEN CALL iso_verif_aberrant(zxtliq/cond, & 'condiso_liq_ice 32') endif !if (cond.gt.ridicule) THEN endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN endif !if (zfice.lt.1) THEN IF (zfice.gt.0) THEN CALL iso_verif_noNAN(zxtice,'condiso_liq_ice 92') IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN CALL iso_verif_egalite(zxtice,cond,'condiso_liq_ice 31') endif ! if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN IF ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN IF (cond.gt.ridicule) THEN IF (iso_verif_aberrant_nostop(zxtice/cond, & 'condiso_liq_ice 33').EQ.1) THEN WRITE(*,*) 'debug condiso 88: zfice=',zfice WRITE(*,*) 'cond/qt=',cond/qt WRITE(*,*) 'xt/qt=',xt/qt WRITE(*,*) 'zxtalphai=',zxtalphai WRITE(*,*) 'qt/cond*(1-(1-cond/qt)**zxtalphai)=', & (qt/cond)*1-(1-cond/qt)**zxtalphai WRITE(*,*) 'zxtice/cond=',zxtice/cond stop endif endif !if (cond.gt.ridicule) THEN endif !if ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN endif !if (zfice.gt.0) THEN ! verif que deltaD n'est pas abberant: #endif ! end verif zxtliq=(1-zfice)*zxtliq zxtice=zfice*zxtice ! cam verif #ifdef ISOVERIF CALL iso_verif_noNAN(zxtliq,'condiso_liq_ice 132') CALL iso_verif_noNAN(zxtice,'condiso_liq_ice 92') IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN CALL iso_verif_egalite(zxtice+zxtliq,cond, & 'condiso_liq_ice 79') endif ! if ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN CALL iso_verif_noNAN(zxtice+zxtliq,'condiso_liq_ice 108') #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN IF (ixt.EQ.iso_eau) THEN ! assurer convergence IF (zfice.EQ.1.0) THEN zxtice=cond endif !if (zfice.EQ.1.0) THEN endif !if (ixt.EQ.iso_eau) THEN endif !if ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN zxtice=max(0.0,zxtice) zxtliq=max(0.0,zxtliq) ! end verif ! *********** fin des calculs ********* END SUBROUTINE condiso_liq_ice !************ SUBROUTINE calcul_zfice(T,zfice) USE isotopes_mod, ONLY: pxtmelt,pxtice IMPLICIT NONE ! inputs REAL T ! température en K ! output: REAL zfice ! fraction de condensation en glace zfice = 1.0-(T-pxtice)/(pxtmelt-pxtice) zfice = MIN(MAX(zfice,0.0),1.0) END SUBROUTINE calcul_zfice SUBROUTINE gestion_neige(klon,knon,snow,xtsnow, & snow_prec,xtsnow_prec,dtime, & precip_snow,xtprecip_snow,xtprecip_rain,fq_fonte_neige,fqfonte_neige, & fqcalving,snow_evap,xtsnow_evap,fxt_fonte_neige,fxtfonte_neige,fxtcalving, & xt1lay,q1lay,tsurf,t_coup,nisurf,Rland_ice) USE isotopes_mod, ONLY: Rdefault,iso_eau,iso_HDO, & & bidouille_anti_divergence, ridicule,ridicule_snow, & & tcorr,toce,alpha_liq_sol USE indice_sol_mod USE lmdz_yomcst #ifdef ISOVERIF ! USE isotopes_verif_mod, ONLY: errmax,errmaxrel,errmax_sol,deltalim_snow USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: izone_cont,index_zone,index_iso #endif USE lmdz_yoethf IMPLICIT NONE INCLUDE "FCTTRE.h" ! gestion de la neige: on precipte dessus, sublime, effondre, ! fond, etc... ! commun aux dfférentes sous-surfaces. ! inputs INTEGER, INTENT(IN) :: klon,knon REAL, INTENT(IN) :: dtime REAL, INTENT(IN) :: snow(klon),snow_prec(klon) REAL, INTENT(IN) :: xtsnow_prec(niso,klon) REAL, INTENT(IN) :: precip_snow(klon),xtprecip_snow(ntraciso,klon),xtprecip_rain(ntraciso,klon) REAL, INTENT(IN) :: snow_evap(klon) REAL, INTENT(IN) :: fq_fonte_neige(klon) REAL, INTENT(IN) :: fqfonte_neige(klon) REAL, INTENT(IN) :: fqcalving(klon) REAL, INTENT(IN) :: t_coup REAL, INTENT(IN) :: q1lay(klon) REAL, INTENT(IN) :: xt1lay(ntraciso,klon) REAL, INTENT(IN) :: tsurf(klon) INTEGER, INTENT(IN) :: nisurf REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice ! inouts REAL, INTENT(INOUT) :: xtsnow(niso,klon) ! outputs REAL, DIMENSION(ntraciso,klon), INTENT(OUT) :: xtsnow_evap REAL, DIMENSION(niso,klon), INTENT(OUT) :: fxt_fonte_neige REAL, DIMENSION(niso,klon), INTENT(OUT) :: fxtfonte_neige REAL, DIMENSION(niso,klon), INTENT(OUT) :: fxtcalving ! locals REAL snow_apres_precip(klon),xtsnow_apres_precip(niso,klon) REAL snow_avant_evap(klon),xtsnow_avant_evap(niso,klon) REAL Rsnow_apres_precip(niso,klon), Rsnow_avant_evap(niso,klon) REAL snow_avant_calving(klon) REAL fqfonte_neige_add INTEGER i,ixt,j #ifdef ISOVERIF ! integer iso_verif_aberrant_O17_nostop ! juste debug ! real o17excess REAL dqdiag REAL snow_max parameter (snow_max=3000.) #endif !#ifdef ISOVERIF ! integer iso_verif_aberrant_nostop ! juste debug ! integer iso_verif_aberrant_choix_nostop ! integer iso_verif_egalite_choix_nostop ! integer iso_verif_positif_nostop ! integer iso_verif_egalite_nostop ! integer iso_verif_positif_choix_nostop ! real deltaD !#endif !#ifdef ISOVERIF ! integer iso_verif_noNaN_nostop !#endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO i=1,knon CALL iso_verif_egalite_choix( & xtsnow(iso_eau,i),snow_prec(i), & 'calcul_iso_surf_vectall 2157',errmax,errmaxrel) enddo endif #endif ! on precipe sur la neige DO i=1,knon snow_apres_precip(i)=snow_prec(i)+precip_snow(i)*dtime DO ixt=1,niso xtsnow_apres_precip(ixt,i)=xtsnow_prec(ixt,i) & +xtprecip_snow(ixt,i)*dtime #ifdef ISOVERIF IF (iso_verif_noNaN_nostop(xtsnow_apres_precip(ixt,i), & 'calcul_iso_surf_vectall 2260').EQ.1) THEN WRITE(*,*) 'xtsnow_prec(ixt,i)=',xtsnow_prec(ixt,i) WRITE(*,*) 'xtprecip_snow(ixt,i)=',xtprecip_snow(ixt,i) stop endif #endif enddo ! peu importe la compo en traceurs de la neige, car de toute ! façon la nege est évaporée avec un certain tagging: izone_cont enddo !do i=1,knon #ifdef ISOVERIF DO i=1,knon IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop( & xtsnow_apres_precip(iso_eau,i), & snow_apres_precip(i),'calcul_iso_surf_ter 1028', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'snow_prec(i),xtsnow_prec(iso_eau,i)=', & snow_prec(i),xtsnow_prec(iso_eau,i) WRITE(*,*) 'precip_snow(i),xtprecip_snow(iso_eau,i)=', & precip_snow(i),xtprecip_snow(iso_eau,i) stop endif endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix( & xtsnow_apres_precip(iso_hdo,i), & snow_apres_precip(i),ridicule_snow,deltalim_snow, & 'calcul_iso_surf_ter 1931') endif !if (iso_eau.gt.0) THEN enddo #endif ! on ajoute éventuellement du givre sur la neige ! C Risi: juin 2020: on ajoute le givre ici car sinon, on ne sait pas ! quoi fondre. DO i=1,knon IF (snow_evap(i).lt.0.0) THEN snow_apres_precip(i)=snow_apres_precip(i)-snow_evap(i)*dtime CALL iso_rosee_givre(xt1lay,q1lay,tsurf,t_coup,snow_evap,i, & xtsnow_evap,klon) DO ixt=1,niso xtsnow_apres_precip(ixt,i)=xtsnow_apres_precip(ixt,i) & -xtsnow_evap(ixt,i)*dtime enddo !do ixt=1,niso endif !if (snow_evap(i).lt.0.0) THEN enddo !do i=1,knon #ifdef ISOVERIF DO i=1,knon IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop( & xtsnow_apres_precip(iso_eau,i), & snow_apres_precip(i),'calcul_iso_surf_ter 1028', & errmax,errmaxrel).EQ.1) THEN WRITE(*,*) 'snow_prec(i),xtsnow_prec(iso_eau,i)=', & snow_prec(i),xtsnow_prec(iso_eau,i) WRITE(*,*) 'precip_snow(i),xtprecip_snow(iso_eau,i)=', & precip_snow(i),xtprecip_snow(iso_eau,i) stop endif endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix( & xtsnow_apres_precip(iso_hdo,i), & snow_apres_precip(i),ridicule_snow,deltalim_snow, & 'calcul_iso_surf_ter 1931') endif !if (iso_eau.gt.0) THEN enddo #endif ! on fond la neige DO i=1,knon IF (fq_fonte_neige(i).gt.ridicule) THEN IF (snow_apres_precip(i).gt.ridicule) THEN DO ixt=1,niso Rsnow_apres_precip(ixt,i)=xtsnow_apres_precip(ixt,i)/ & snow_apres_precip(i) ! (H) pas de frac pendant la fonte neige fxt_fonte_neige(ixt,i)=fq_fonte_neige(i) & *Rsnow_apres_precip(ixt,i) #ifdef ISOVERIF IF ((iso_verif_noNaN_nostop(Rsnow_apres_precip(ixt,i), & 'calcul_iso_surf_ter 2294a').EQ.1).OR. & (iso_verif_noNaN_nostop(fxt_fonte_neige(ixt,i), & 'calcul_iso_surf_ter 2294b').EQ.1)) THEN WRITE(*,*) 'ixt,i=',ixt,i WRITE(*,*) 'xtsnow_apres_precip,snow_apres_precip=', & xtsnow_apres_precip(ixt,i), & snow_apres_precip(i) WRITE(*,*) 'fq_fonte_neige(i)=',fq_fonte_neige(i) stop endif #endif enddo !do ixt=1,niso else !if (snow_apres_precip(i).gt.0) THEN ! fonte de quoi? pas de neige!! WRITE(*,*) 'calcul_iso_surf_ter 588: fq_fonte_neige(i)=', & fq_fonte_neige(i) WRITE(*,*) 'snow_apres_precip(i)=',snow_apres_precip(i) WRITE(*,*) 'i=',i WRITE(*,*) 'snow_prec(i)=',snow_prec(i) WRITE(*,*) 'precip_snow(i)*dtime=',precip_snow(i)*dtime stop endif !if (snow_apres_precip(i).gt.0) THEN else !endif !if (fq_fonte_neige(i).gt.0.0) THEN DO ixt=1,niso fxt_fonte_neige(ixt,i)=0.0 enddo !do ixt=1,niso endif !if (fq_fonte_neige(i).gt.0.0) THEN enddo !do i=1,knon #ifdef ISOVERIF DO i=1,knon DO ixt=1,niso CALL iso_verif_noNaN(xtsnow_apres_precip(ixt,i), & 'calcul_iso_surf_ter 2312') CALL iso_verif_noNaN(fxt_fonte_neige(ixt,i), & 'calcul_iso_surf_ter 2315') enddo !do ixt=1,niso enddo !do i=1,knon #endif DO i=1,knon snow_avant_evap(i)=snow_apres_precip(i)-fq_fonte_neige(i) DO ixt=1,niso xtsnow_avant_evap(ixt,i)=xtsnow_apres_precip(ixt,i) & -fxt_fonte_neige(ixt,i) #ifdef ISOVERIF IF (iso_verif_noNaN_nostop(xtsnow_avant_evap(ixt,i), & 'calcul_iso_surf_ter 2363').EQ.1) THEN WRITE(*,*) 'xtsnow_apres_precip(ixt,i)=', & xtsnow_apres_precip(ixt,i) WRITE(*,*) 'fxt_fonte_neige(ixt,i)=', & fxt_fonte_neige(ixt,i) stop endif #endif enddo !do ixt=1,niso enddo !do i=1,knon ! calcul de xtsnow_evap et du nouveau xtsnow: ! a condition que snow_evap > 0, car le givre a déjà été traité plus ! haut #ifdef ISOVERIF DO i=1,knon ! on verifie que snow_avant_evap-snow_evap-fqcalving=snow IF (iso_verif_egalite_choix_nostop(snow_avant_evap(i) & -max(snow_evap(i),0.0)*dtime-fqcalving(i)*dtime,snow(i), & 'calcul_iso_surf_ter 224',errmax_sol*max(snow(i),1.0), & errmaxrel).EQ.1) THEN WRITE(*,*) 'snow(i)=',snow(i) WRITE(*,*) 'snow_prec(i)=',snow_prec(i) WRITE(*,*) 'precip_snow(i)*dt=',precip_snow(i)*dtime WRITE(*,*) 'fq_fonte_neige(i)=',fq_fonte_neige(i) WRITE(*,*) 'snow_evap(i)*dt=',snow_evap(i)*dtime WRITE(*,*) 'fqcalving(i)=',fqcalving(i)*dtime WRITE(*,*) 'snow_avant_evap(i)=',snow_avant_evap(i) WRITE(*,*) 'snow_apres_precip(i)=',snow_apres_precip(i) stop endif IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & xtsnow_avant_evap(iso_eau,i), & snow_avant_evap(i),'calcul_iso_surf_ter 1082', & errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(xtsnow_avant_evap(iso_hdo,i), & snow_avant_evap(i),ridicule_snow,deltalim_snow, & 'calcul_iso_surf_ter 1991') endif !if (iso_eau.gt.0) THEN enddo !do i=1,knon #endif DO i=1,knon snow_avant_calving(i)=snow_avant_evap(i)-max(0.0,snow_evap(i))*dtime enddo !do i=1,knon DO i=1,knon IF (snow_evap(i).gt.ridicule**2) THEN ! CRisi 9 juin 2021: on met un seuil plus strict. ! sublimation positive, sans fractionnement IF (snow_avant_evap(i).gt.ridicule**2) THEN ! on sublime sans fractionnement une partie de la neige. ! on en profite pour en effonfrer aussi éventuellement une ! partie. DO ixt=1,niso Rsnow_avant_evap(ixt,i)=xtsnow_avant_evap(ixt,i)/ & snow_avant_evap(i) xtsnow(ixt,i)=Rsnow_avant_evap(ixt,i) & *snow_avant_calving(i) xtsnow_evap(ixt,i)=snow_evap(i)*Rsnow_avant_evap(ixt,i) enddo !do ixt=1,niso #ifdef ISOVERIF DO ixt=1,niso ! CALL iso_verif_noNaN(xtsnow_evap(ixt,i), ! & 'calcul_iso_surf_ter 2543') IF (iso_verif_noNaN_nostop(xtsnow_evap(ixt,i), & 'calcul_iso_surf_ter 2543').EQ.1) THEN WRITE(*,*) 'xtsnow_avant_evap(ixt,i)=', & xtsnow_avant_evap(ixt,i) WRITE(*,*) 'snow_avant_evap(i)=',snow_avant_evap(i) WRITE(*,*) 'Rsnow_avant_evap(ixt,i)=', & Rsnow_avant_evap(ixt,i) WRITE(*,*) 'snow_evap(i)=',snow_evap(i) WRITE(*,*) 'ixt,i=',ixt,i stop endif !if (iso_verif_noNaN_nostop(xtsnow_evap(ixt,i), enddo !do ixt=1,niso #endif else !if (snow_avant_evap(i).gt.0.0) THEN #ifdef ISOVERIF WRITE(*,*) 'iso_surf_lic 952: quoi evaporer?' WRITE(*,*) 'snow_evap(i),snow_avant_evap(i)=', & snow_evap(i),snow_avant_evap(i) WRITE(*,*) 'snow(i)=',snow(i) WRITE(*,*) 'snow_apres_precip(i)=',snow_apres_precip(i) WRITE(*,*) 'Rsnow_apres_precip(:,i)=',Rsnow_apres_precip(:,i) WRITE(*,*) 'i=',i ! stop #endif IF (snow_apres_precip(i).gt.ridicule) THEN ! on évapore la snow apres precip DO ixt=1,niso xtsnow(ixt,i)=Rsnow_apres_precip(ixt,i)*snow_avant_calving(i) xtsnow_evap(ixt,i)=snow_evap(i) & *Rsnow_apres_precip(ixt,i) #ifdef ISOVERIF CALL iso_verif_noNaN(xtsnow_evap(ixt,i), & 'calcul_iso_surf_ter 2414') #endif enddo else !if (snow_apres_precip(i).gt.0.0) THEN #ifdef ISOVERIF WRITE(*,*) 'iso_surf_lic 967: quoi evaporer? '// & 'sans espoir' WRITE(*,*) 'snow_apres_precip(i)=', & snow_apres_precip(i) stop #endif ! on prend la compo par défaut DO ixt=1,niso Rsnow_avant_evap(ixt,i)=Rdefault(ixt) xtsnow(ixt,i)=Rsnow_avant_evap(ixt,i) & *snow_avant_calving(i) xtsnow_evap(ixt,i)=snow_evap(i) & *Rsnow_avant_evap(ixt,i) #ifdef ISOVERIF CALL iso_verif_noNaN(xtsnow_evap(ixt,i), & 'calcul_iso_surf_ter 2430') #endif enddo endif !if (snow_apres_precip(i).gt.0.0) THEN endif !if (snow_avant_evap(i).gt.0.0) THEN ! C Risi juin 2020: on supprime la rosée ici car ça a déjà été traité ! plus haut ELSE IF (snow_evap(i).lt.-ridicule**2) then ! if (snow_evap(i).gt.0.0) THEN ! ! on a de la rosée ! CALL iso_rosee_givre(xt1lay,q1lay,tsurf, & ! & t_coup,snow_evap,i,xtsnow_evap,klon) ! ! les traceurs d'isotopes sont déjà dans la rosée DO ixt=1,niso !xtsnow(ixt,i)=xtsnow_avant_evap(ixt,i)-xtsnow_evap(ixt,i) xtsnow(ixt,i)=xtsnow_avant_evap(ixt,i) enddo else ! if (snow_evap(i).lt.-ridicule**2) THEN ! évaporation nulle DO ixt=1,ntraciso xtsnow_evap(ixt,i)=0.0 enddo DO ixt=1,niso xtsnow(ixt,i)=xtsnow_avant_evap(ixt,i) enddo endif !if (snow_evap(i).gt.0.0) THEN #ifdef ISOTRAC DO ixt=niso+1,ntraciso IF (index_zone(ixt).EQ.izone_cont) THEN xtsnow_evap(ixt,i)=xtsnow_evap(index_iso(ixt),i) else xtsnow_evap(ixt,i)=0.0 endif enddo #endif enddo !do i=1,knon ! calving de la neige #ifdef ISOVERIF DO i=1,knon DO ixt=1,ntraciso CALL iso_verif_noNaN(xtsnow_evap(ixt,i), & 'calcul_iso_surf_ter 2167') enddo enddo ! on verifie que snow_avant_evap-snow_evap-fqcalving=snow DO i=1,knon IF (iso_verif_egalite_choix_nostop(snow_avant_calving(i) & -fqcalving(i)*dtime,snow(i), & 'gestion_neige 1087',errmax_sol*max(snow(i),1.0), & errmaxrel).EQ.1) THEN WRITE(*,*) 'snow(i)=',snow(i) WRITE(*,*) 'snow_prec(i)=',snow_prec(i) WRITE(*,*) 'precip_snow(i)*dt=',precip_snow(i)*dtime WRITE(*,*) 'fq_fonte_neige(i)=',fq_fonte_neige(i) WRITE(*,*) 'snow_evap(i)*dt=',snow_evap(i)*dtime WRITE(*,*) 'fqcalving(i)*dt=',fqcalving(i)*dtime WRITE(*,*) 'snow_avant_evap(i)=',snow_avant_evap(i) WRITE(*,*) 'snow_apres_precip(i)=',snow_apres_precip(i) WRITE(*,*) 'snow_avant_calving(i)=',snow_avant_calving(i) stop endif IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtsnow(iso_eau,i), & snow_avant_calving(i),'gestion_neige 1172', & errmax,errmaxrel) CALL iso_verif_egalite_choix(xtsnow_evap(iso_eau,i), & snow_evap(i),'gestion_neige 1198', & errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(xtsnow(iso_hdo,i), & snow_avant_calving(i),ridicule_snow,deltalim_snow, & 'gestion_neige 2090') endif !if (iso_eau.gt.0) THEN #ifdef ISOTRAC ! CALL iso_verif_traceur(xtsnow_evap(1,i), & ! & 'gestion neige 2146') ! attention car snow_evap parfois ! négatif -> il ne faut pas passer dans les verifs de positivité. CALL iso_verif_traceur_justmass(xtsnow_evap(1,i), & 'gestion neige 2146') #endif enddo !do i=1,knon #endif DO i=1,knon IF (fqcalving(i).gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_positif_strict(snow_avant_calving(i), & 'calcul_iso_surf_ter 1092') #endif DO ixt=1,niso xtsnow(ixt,i)=xtsnow(ixt,i) & /snow_avant_calving(i)*snow(i) fxtcalving(ixt,i)=xtsnow(ixt,i) & /snow_avant_calving(i)*fqcalving(i) enddo !do ixt=1,niso else DO ixt=1,niso ! xtsnow(ixt,i) non modifié fxtcalving(ixt,i)=0.0 enddo endif !if (fqcalving(i).gt.0.0) THEN enddo ! do i=1,knon ! bidouille anti-divergence: utile pour éviter propagation des ! erreurs numériques IF ((iso_eau.gt.0).AND.(bidouille_anti_divergence)) THEN DO i=1,knon xtsnow(iso_eau,i)=snow(i) enddo endif !if ((iso_eau.gt.0).AND.(bidouille_anti_divergence)) THEN ! verif cons masse de la neige #ifdef ISOVERIF DO i=1,knon dqdiag=min(precip_snow(i)*dtime-fq_fonte_neige(i) & -snow_evap(i)*dtime-fqcalving(i)*dtime, & snow_max-snow_prec(i)) IF (iso_verif_egalite_choix_nostop(dqdiag, & snow(i)-snow_prec(i),'ter 2128', & errmax_sol*max(snow(i),1.0),errmaxrel).EQ.1) THEN WRITE(*,*) 'calcul_iso_surf_ter 2086: bilan qsnow' WRITE(*,*) 'snow(i)=',snow(i) WRITE(*,*) 'snow_prec(i)=',snow_prec(i) WRITE(*,*) 'precip_snow(i)*dt=',precip_snow(i)*dtime WRITE(*,*) 'fq_fonte_neige(i)=',fq_fonte_neige(i) WRITE(*,*) 'snow_evap(i)*dt=',snow_evap(i)*dtime WRITE(*,*) 'fqcalving(i)=',fqcalving(i)*dtime stop endif IF (snow(i).lt.snow_max) THEN DO ixt=1,niso dqdiag=xtprecip_snow(ixt,i)*dtime-fxt_fonte_neige(ixt,i) & -xtsnow_evap(ixt,i)*dtime-fxtcalving(ixt,i) IF (iso_verif_egalite_choix_nostop(dqdiag, & xtsnow(ixt,i)-xtsnow_prec(ixt,i),'ter 2144', & errmax_sol*max(snow(i),1.0),errmaxrel).EQ.1) THEN WRITE(*,*) 'calcul_iso_surf_ter 2101: bilan xtsnow, ixt=', & ixt WRITE(*,*) 'i=',i WRITE(*,*) 'snow(i)=',snow(i) WRITE(*,*) 'snow_prec(i)=',snow_prec(i) WRITE(*,*) 'precip_snow(i)*dt=',precip_snow(i)*dtime WRITE(*,*) 'fq_fonte_neige(i)=',fq_fonte_neige(i) WRITE(*,*) 'snow_evap(i)*dt=',snow_evap(i)*dtime WRITE(*,*) 'fqcalving(i)=',fqcalving(i)*dtime WRITE(*,*) 'xtsnow(ixt,i)=',xtsnow(ixt,i) WRITE(*,*) 'xtsnow_prec(i)=',xtsnow_prec(ixt,i) WRITE(*,*) 'xtprecip_snow(i)*dt=',xtprecip_snow(ixt,i) & *dtime WRITE(*,*) 'fxt_fonte_neige(i)=',fxt_fonte_neige(ixt,i) WRITE(*,*) 'xtsnow_evap(i)*dt=',xtsnow_evap(ixt,i)*dtime WRITE(*,*) 'fxtcalving(i)=',fxtcalving(ixt,i) stop endif enddo ! do ixt=1,niso endif ! if (snow(i).lt.snow_max) THEN enddo !do i=1,knon #endif ! calcul de fxtfonte_neige, équivalent de fqfonte ! attention, il est différent de fq_fonte ! fqfonte=fq_fonte/dtime+terme additionel de fonte de la banquise ou de ! la glace ! cette partie est ajoutée le 31 juillet 2017 DO i=1,knon IF (fqfonte_neige(i).gt.fq_fonte_neige(i)/dtime) THEN ! on font la banquise ou la land ice. fqfonte_neige_add=fqfonte_neige(i)-fq_fonte_neige(i)/dtime IF (nisurf == is_sic) THEN DO ixt=1,niso fxtfonte_neige(ixt,i)=fxt_fonte_neige(ixt,i)/dtime & +fqfonte_neige_add*tcorr(ixt)*toce(ixt)*alpha_liq_sol(ixt) enddo ELSE IF (nisurf == is_lic) THEN DO ixt=1,niso fxtfonte_neige(ixt,i)=fxt_fonte_neige(ixt,i)/dtime & +fqfonte_neige_add*Rland_ice(ixt,i) enddo else #ifdef ISOVERIF WRITE(*,*) 'iso_routines > gestion_neige 13480: nisurf=',nisurf WRITE(*,*) 'i,dtime=',i,dtime WRITE(*,*) 'fqfonte_neige(i),fq_fonte_neige(i)=',fqfonte_neige(i),fq_fonte_neige(i) stop #endif DO ixt=1,niso fxtfonte_neige(ixt,i)=fxt_fonte_neige(ixt,i)/dtime & +fqfonte_neige_add*Rdefault(ixt) enddo endif else !if (fqfonte_neige(i).gt.fq_fonte_neige(i)/dtime) THEN #ifdef ISOVERIF CALL iso_verif_egalite(fqfonte_neige(i),fq_fonte_neige(i)/dtime, & 'iso_routines > gestion_neige 13469') #endif DO ixt=1,niso fxtfonte_neige(ixt,i)=fxt_fonte_neige(ixt,i)/dtime enddo endif !if (fqfonte_neige(i).gt.fq_fonte_neige(i)/dtime) THEN #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite(fqfonte_neige(i),fxtfonte_neige(iso_eau,i), & 'iso_routines > gestion_neige 13479') endif #endif enddo ! do i=1,knon END SUBROUTINE gestion_neige ! ***** subroutines permettant de calculer les flux de surface pour ! les isos SUBROUTINE calcul_iso_surf_oce_vectall(klon, knon,t_coup, & ps,tsurf,q1lay,u1lay, v1lay, xt1lay, & evap, Roce,xtevap,h1 & #ifdef ISOTRAC ,knindex & #endif ) USE isotopes_mod, ONLY: iso_eau,iso_HDO,cste_surf_cond, & & rh_cste_surf_cond,Rdefault,T_cste_surf_cond,iso_O17,iso_O18, & & ridicule_evap,tnat USE lmdz_yomcst #ifdef ISOVERIF ! USE isotopes_verif_mod, ONLY: deltaDfaible, faible_evap,errmax,errmaxrel USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: option_traceurs,izone_oce,index_zone,index_iso, & & bassin_map #endif USE lmdz_yoethf IMPLICIT NONE INCLUDE "FCTTRE.h" ! inputs INTEGER, INTENT(IN) :: klon,knon ! dimensions REAL, INTENT(IN) :: ps(klon) ! surface pressure REAL, INTENT(IN) :: tsurf(klon) ! SST REAL, INTENT(IN) :: q1lay(klon) ! near-surface specific humidity REAL, INTENT(IN) :: u1lay(klon), v1lay(klon) ! near surface wind REAL, INTENT(IN) :: xt1lay(ntraciso,klon) ! isotopes in near surface water vapor REAL, INTENT(IN) :: evap(klon) ! evaporation flux !REAL, INTENT(IN) :: tsurf(klon) REAL, INTENT(IN) :: Roce(niso,klon) ! isotopic ratio in surface ocean !REAL, INTENT(IN) :: dtime REAL, INTENT(IN) :: t_coup ! limit temperature between ice/liquid when calculating saturation humidity ! output REAL, INTENT(OUT) :: xtevap(ntraciso,klon) ! isotopic evaporation flux REAL, INTENT(OUT) :: h1(klon) ! only diagnostic, not useful ! locals INTEGER ixt REAL VSURF REAL kcin(niso,klon) REAL zqs(klon) REAL R1(niso) REAL Revap(niso) REAL zxtalphal(niso,klon), zxtalphai(niso) INTEGER i INTEGER ncas_evap,ncas_noevap,ncas_rosee INTEGER cas_evap(klon),cas_noevap(klon),cas_rosee(klon) INTEGER icas REAL zxtalphal_tmp #ifdef ISOVERIF ! real deltaD,O17excess,deltaO INTEGER trace_cas(klon) ! integer iso_verif_aberrant_nostop ! juste debug ! integer iso_verif_aberrant_o17_nostop #endif #ifdef ISOTRAC INTEGER, DIMENSION(klon), INTENT(IN) :: knindex ! locals INTEGER izone_recoit #endif ! vérif préliminaire !WRITE(*,*) 'calcul_iso_surf_oce 41' #ifdef ISOVERIF DO i=1,knon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(Roce(iso_eau,i),1.0, & 'calcul_iso_surf_oce 47',errmax,errmaxrel) CALL iso_verif_egalite_choix(xt1lay(iso_eau,i), & q1lay(i),'calcul_iso_surf_oce 69', & errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_positif(deltaD(Roce(iso_HDO,i))+100.0, & 'calcul_iso_surf_oce 54') endif !if (iso_eau.gt.0) THEN CALL iso_verif_noNaN(tsurf(i),'calcul_iso_surf_ice 62') enddo #endif ! parsage des cas ncas_evap=0 ncas_noevap=0 ncas_rosee=0 DO i=1,knon IF (evap(i).gt.0.0) THEN ncas_evap=ncas_evap+1 cas_evap(ncas_evap)=i #ifdef ISOVERIF trace_cas(i)=1 #endif ELSE IF (evap(i).EQ.0.0) THEN ncas_noevap=ncas_noevap+1 cas_noevap(ncas_noevap)=i #ifdef ISOVERIF trace_cas(i)=2 #endif else ncas_rosee=ncas_rosee+1 cas_rosee(ncas_rosee)=i #ifdef ISOVERIF trace_cas(i)=3 #endif endif enddo !do i=1,knon !WRITE(*,*) 'calcul_iso_surf_oce 13703' ! traitement vectoriel du cas d'évaporation DO icas=1,ncas_evap i=cas_evap(icas) !WRITE(*,*) 'icas, i, ncas_evap=',icas, i, ncas_evap IF (tsurf(i).lt.t_coup) THEN zqs(i)=qsats(tsurf(i))/ps(i) #ifdef ISOVERIF CALL iso_verif_positif(zqs(i),'calcul_iso_surf 183') CALL iso_verif_positif(0.1-zqs(i),'calcul_iso_surf 184') #endif else zqs(i)=qsatl(tsurf(i))/ps(i) #ifdef ISOVERIF CALL iso_verif_positif(zqs(i),'calcul_iso_surf 187') CALL iso_verif_positif(0.1-zqs(i),'calcul_iso_surf 188') #endif endif h1(i)=q1lay(i)/zqs(i) h1(i)=min(1.0,max(0.0,h1(i))) IF (cste_surf_cond.EQ.2) THEN ! on suppose la température de surface constante dans le ! calcul des coefs de frac, pour faire un test de ! sensibilité DO ixt=1,niso CALL fractcalk_liq(ixt,T_cste_surf_cond, & zxtalphal(ixt,i)) enddo else !if (cste_surf_cond.EQ.2) THEN DO ixt=1,niso CALL fractcalk_liq(ixt,tsurf(i), & zxtalphal(ixt,i)) enddo endif !if (cste_surf_cond.EQ.2) THEN IF (q1lay(i).gt.0.0) THEN DO ixt=1,niso R1(ixt)=xt1lay(ixt,i)/q1lay(i) enddo else #ifdef ISOVERIF WRITE(*,*) 'calcul_iso_surf 124: q1lay=',q1lay(i) stop #endif DO ixt=1,niso R1(ixt)=Rdefault(ixt) enddo endif VSURF=sqrt(u1lay(i)**2+v1lay(i)**2) CALL calcul_kcin(vsurf,kcin(1,i)) IF (cste_surf_cond.EQ.0) THEN IF (h1(i).lt.0.98) THEN DO ixt=1,niso xtevap(ixt,i)=evap(i)* & (Roce(ixt,i)/zxtalphal(ixt,i)-h1(i)*R1(ixt)) & /(1.0-h1(i))*(1.0-kcin(ixt,i)) enddo !do ixt=1,niso else !if (h1(i).lt.0.98) THEN DO ixt=1,niso xtevap(ixt,i)=evap(i)*Roce(ixt,i)/zxtalphal(ixt,i) enddo endif !if (h1(i).lt.0.98) THEN else !if (cste_surf_cond.EQ.0) THEN DO ixt=1,niso xtevap(ixt,i)=evap(i)* & (Roce(ixt,i)/zxtalphal(ixt,i) & -rh_cste_surf_cond*R1(ixt)) & /(1.0-rh_cste_surf_cond)*(1.0-kcin(ixt,i)) enddo !do ixt=1,niso endif !if (cste_surf_cond.EQ.0) THEN !WRITE(*,*) 'calcul_iso_surf_oce 13772' !WRITE(*,*) 'knindex(i),klon=',knindex(i),klon #ifdef ISOTRAC IF ((option_traceurs.EQ.3).OR. & (option_traceurs.EQ.20)) THEN izone_recoit=bassin_map(knindex(i)) else izone_recoit=izone_oce endif !WRITE(*,*) 'calcul_iso_surf_oce 13781, izone_recoit=',izone_recoit DO ixt=niso+1,ntraciso IF (index_zone(ixt).EQ.izone_recoit) THEN xtevap(ixt,i)=xtevap(index_iso(ixt),i) else xtevap(ixt,i)=0.0 endif enddo !do ixt=niso+1,ntraciso #endif !WRITE(*,*) 'calcul_iso_surf_oce 13786' #ifdef ISOVERIF DO ixt=1,ntraciso CALL iso_verif_noNAN(xtevap(ixt,i), & 'calcul_iso_surf_oce 3038, sur océan') enddo #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtevap(iso_eau,i),evap(i), & 'calcul_iso_surf_oce 3309: sur ocean', & errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (abs(evap(i)).gt.ridicule_evap) THEN IF (iso_verif_aberrant_nostop(xtevap(iso_HDO,i)/evap(i), & 'calcul_iso_surf_oce 3308: sur ocean').EQ.1) THEN WRITE(*,*) 'h1(i),kcin(iso_HDO,i)=',h1(i),kcin(iso_HDO,i) WRITE(*,*) 'deltaD(R1)=',deltaD(R1(iso_HDO)) WRITE(*,*) 'deltaD(Roce/alpha)=', & deltaD(Roce(iso_HDO,i)/zxtalphal(iso_HDO,i)) ! si deltaD vap très faible, c'est normale d'avoir deltaD ! très fort dans l'évap IF ((evap(i).gt.faible_evap).AND. & (deltaD(R1(iso_HDO)).gt.deltaDfaible)) THEN stop endif endif endif !if (abs(evap(i)).gt.ridicule_evap) THEN IF ((xtevap(iso_HDO,i)/evap(i).lt.R1(iso_HDO)-20.0) & .AND.(evap(i).gt.ridicule_evap)) THEN WRITE(*,*) 'calcul_iso_surf_oce 106, i=',i WRITE(*,*) 'deltaDevap=', & deltaD(xtevap(iso_HDO,i)/evap(i)) WRITE(*,*) 'deltaDv1=',deltaD(R1(iso_HDO)) WRITE(*,*) 'tsurf, kcin(iso_HDO,i)=',tsurf(i)-273.5, & kcin(iso_HDO,i) WRITE(*,*) 'deltaD(Roce/alpha)=', & deltaD(Roce(iso_HDO,i)/zxtalphal(iso_HDO,i)) WRITE(*,*) 'h1(i),evap(i)=',h1(i),evap(i) stop endif ! if (xtevap(iso_HDO,i)/evap(i).lt.R1(iso_HDO)) THEN endif !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (abs(evap(i)).gt.ridicule_evap) THEN IF (iso_verif_aberrant_o17_nostop(xtevap(iso_O17,i) & /evap(i),xtevap(iso_O18,i) & /evap(i),'calcul_iso_surf > oce 232').EQ.1) THEN WRITE(*,*) 'deltaO18,O17excess v1=',deltaO( & R1(iso_O18)),O17excess( & R1(iso_O17),R1(iso_O18)) WRITE(*,*) 'tsurf, kcin(iso_O17,i)=', & tsurf(i)-273.5, kcin(iso_O17,i) WRITE(*,*) 'deltaO18,O17excess(Roce/alpha)=', & deltaO(Roce(iso_O18,i)/zxtalphal(iso_O18,i)), & O17excess(Roce(iso_O17,i)/zxtalphal(iso_O17,i), & Roce(iso_O18,i)/zxtalphal(iso_O18,i)) WRITE(*,*) 'h1(i),evap(i)=',h1(i),evap(i) IF (xtevap(iso_O18,i)/evap(i).lt.tnat(iso_O18)) THEN stop endif endif !if (iso_verif_aberrant_o17_nostop(xtevap(iso_O17,i) endif !if (abs(evap(i)).gt.ridicule_evap) THEN endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #ifdef ISOTRAC CALL iso_verif_traceur_justmass(xtevap(1,i), & 'calcul_iso_surf_oce 213') #endif #endif !WRITE(*,*) 'calcul_iso_surf_oce 13858' enddo !do icas_evap=1,ncas_evap !WRITE(*,*) 'calcul_iso_surf_oce 13859' ! traitement vectoriel du cas pas d'évap DO icas=1,ncas_noevap i=cas_noevap(icas) DO ixt=1,ntraciso xtevap(ixt,i)=0.0 enddo !do ixt=1,niso enddo !do icas_evap=1,ncas_evap !WRITE(*,*) 'calcul_iso_surf_oce 13868' ! traitement vectoriel du cas rosée DO icas=1,ncas_rosee i=cas_rosee(icas) CALL iso_rosee_givre(xt1lay,q1lay,tsurf,t_coup,evap,i, & xtevap,klon) ! traceurs d'eau et d'isos mis directement dans iso_rosee_givre enddo !do icas_evap=1,ncas_evap !WRITE(*,*) 'calcul_iso_surf_oce tmp 13876' #ifdef ISOVERIF DO i=1,knon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtevap(iso_eau,i),evap(i), & 'calcul_iso_surf_oce 115',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (evap(i).gt.ridicule_evap) THEN IF (deltaD(R1(iso_HDO)).gt.200.0) THEN CALL iso_verif_aberrant(xtevap(iso_HDO,i)/evap(i), & 'calcul_iso_surf_oce 119') endif endif !if (evap.gt.ridicule_evap) THEN endif !if (iso_eau.gt.0) THEN enddo !do i=1,knon ! WRITE(*,*) 'calcul_iso_surf 274: stop temporaire' ! stop #endif END SUBROUTINE calcul_iso_surf_oce_vectall !***************************** SUBROUTINE calcul_iso_surf_sic_vectall(klon,knon, & evap,snow_evap,tsurf,Roce,snow, & fq_fonte_neige,fqfonte_neige,dtime, t_coup, & precip_snow,xtprecip_snow,xtprecip_rain, snow_prec,xtsnow_prec, & xt1lay,q1lay,ps, & xtevap,xtsnow,fqcalving, & knindex,nisurf,run_off_lic_diag,coeff_rel_diag,Rland_ice & ) USE isotopes_mod, ONLY: tcorr, toce, alpha_liq_sol,ridicule_evap, & iso_eau,iso_HDO USE fonte_neige_mod, ONLY: gestion_neige_besoin_varglob_fonte_neige #ifdef ISOVERIF ! use isotopes_verif_mod, ONLY: deltalim, errmax, errmaxrel USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: izone_poubelle,index_iso,index_zone, & & option_traceurs,izone_oce,izone_oce, & & bassin_map #endif IMPLICIT NONE ! inputs INTEGER, INTENT(IN) :: klon,knon REAL, INTENT(IN) :: snow(klon),snow_prec(klon) REAL, INTENT(INOUT) :: xtsnow(niso,klon) REAL, INTENT(IN) :: xtsnow_prec(niso,klon) REAL, INTENT(IN) :: precip_snow(klon),xtprecip_snow(ntraciso,klon),xtprecip_rain(ntraciso,klon) REAL, INTENT(IN) :: evap(klon), snow_evap(klon) REAL, INTENT(IN) :: fq_fonte_neige(klon) REAL, INTENT(IN) :: fqfonte_neige(klon) REAL, INTENT(IN) :: xt1lay(ntraciso,klon),ps(klon),q1lay(klon) REAL, INTENT(IN) :: tsurf(klon) REAL, INTENT(IN) :: Roce(niso,klon) REAL, INTENT(IN) :: dtime REAL, INTENT(IN) :: t_coup REAL, INTENT(IN) :: fqcalving(klon) INTEGER, INTENT(IN) :: nisurf INTEGER, DIMENSION(klon), INTENT(IN) :: knindex REAL, DIMENSION(klon), INTENT(IN) :: run_off_lic_diag REAL, INTENT(IN) :: coeff_rel_diag REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice ! output REAL, INTENT(OUT) :: xtevap(ntraciso,klon) ! locals REAL fxtfonte_neige(niso,klon) REAL fxt_fonte_neige(niso,klon) REAL fxtcalving(niso,klon) ! real zxtalphals REAL sol_evap(klon) REAL xtsol_evap(ntraciso,klon) REAL xtsnow_evap(ntraciso,klon) INTEGER i,ixt INTEGER ncas_evap,ncas_noevap,ncas_rosee INTEGER cas_evap(klon),cas_noevap(klon),cas_rosee(klon) INTEGER icas #ifdef ISOVERIF ! real deltaD INTEGER trace_cas(klon) ! integer iso_verif_egalite_nostop #endif #ifdef ISOTRAC ! locals INTEGER izone_recoit #endif #ifdef ISOVERIF DO i=1,knon DO ixt=1,ntraciso CALL iso_verif_noNaN(xtprecip_snow(ixt,i), & 'calcul_iso_surf 365') enddo enddo #endif ! gestion de la neige CALL gestion_neige(klon,knon,snow,xtsnow, & snow_prec,xtsnow_prec,dtime, & precip_snow,xtprecip_snow,xtprecip_rain,fq_fonte_neige,fqfonte_neige, & fqcalving,snow_evap,xtsnow_evap,fxt_fonte_neige,fxtfonte_neige,fxtcalving, & xt1lay,q1lay,tsurf,t_coup,nisurf,Rland_ice) CALL gestion_neige_besoin_varglob_fonte_neige(klon,knon, & xtprecip_snow,xtprecip_rain, & fxtfonte_neige,fxtcalving, & knindex,nisurf,run_off_lic_diag,coeff_rel_diag) #ifdef ISOVERIF IF (iso_eau.gt.0) THEN DO i=1,knon CALL iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), & 'calcul_iso_surf_sic_vectall 363',errmax,errmaxrel) enddo endif #endif ! les traceurs d'isotopes sont déjà dans gestion neige ! on suppose que l'évaporation de la neige est taggée "continent" ! en fait, il n'y a pas de neige sur sea-ice de toutes façon. DO i=1,knon sol_evap(i)=evap(i)-snow_evap(i) enddo !do i=1,knon ! parsage des cas ncas_evap=0 ncas_noevap=0 ncas_rosee=0 DO i=1,knon ! modif 2 octobre 2008 ! c'est sol_evap plutot que evap ! if (evap(i).gt.0.0) THEN IF (sol_evap(i).gt.0.0) THEN ncas_evap=ncas_evap+1 cas_evap(ncas_evap)=i #ifdef ISOVERIF trace_cas(i)=1 #endif ELSE IF (sol_evap(i).EQ.0.0) THEN ncas_noevap=ncas_noevap+1 cas_noevap(ncas_noevap)=i #ifdef ISOVERIF trace_cas(i)=2 #endif else ncas_rosee=ncas_rosee+1 cas_rosee(ncas_rosee)=i #ifdef ISOVERIF trace_cas(i)=3 #endif endif enddo !do i=1,knon ! traitement vectoriel du cas d'évaporation DO icas=1,ncas_evap i=cas_evap(icas) DO ixt=1,niso ! CALL fractcalk_liq_sol(ixt,tsurf(i),zxtalphals) ! xtsol_evap(ixt,i)=sol_evap(i)*Roce(ixt,i) ! : *alpha_liq_sol(ixt) ! non car Roce n'est lu que sur les océans et par sur les ! zones de sea ice xtsol_evap(ixt,i)=sol_evap(i)*tcorr(ixt)*toce(ixt) & *alpha_liq_sol(ixt) enddo !do ixt=1,niso #ifdef ISOTRAC IF (option_traceurs.EQ.3) THEN izone_recoit=izone_poubelle ELSE IF (option_traceurs.EQ.3) THEN izone_recoit=bassin_map(knindex(i)) else izone_recoit=izone_oce endif DO ixt=niso+1,ntraciso IF (index_zone(ixt).EQ.izone_recoit) THEN xtsol_evap(ixt,i)=xtsol_evap(index_iso(ixt),i) else xtsol_evap(ixt,i)=0.0 endif enddo #endif #ifdef ISOVERIF IF (iso_HDO.gt.0) THEN IF (deltaD(xtsol_evap(iso_HDO,i)/sol_evap(i)).lt.0.0) THEN WRITE(*,*) 'calcul_iso_surf_lic 255' WRITE(*,*) 'sol_evap(i),xtsol_evap(iso_HDO,i)=', & sol_evap(i),xtsol_evap(iso_HDO,i) stop endif CALL iso_verif_egalite_choix(deltaD & (xtsol_evap(iso_HDO,i)/sol_evap(i)),25.2847, & 'calcul_iso_surf_sic 398',0.5,0.5) endif #endif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNaN(xtsol_evap(ixt,i), & 'calcul_iso_surf_lic 142') enddo !do ixt=1,niso #endif enddo !!do icas_evap=1,ncas_evap ! traitement vectoriel du cas pas d'évap !#ifdef ISOVERIF ! WRITE(*,*) 'calcul_iso_surf_sic 455: pas d''evap' !#endif DO icas=1,ncas_noevap i=cas_noevap(icas) DO ixt=1,ntraciso xtsol_evap(ixt,i)=0.0 enddo !do ixt=1,niso enddo !do icas_evap=1,ncas_evap ! traitement vectoriel du cas rosée !#ifdef ISOVERIF ! WRITE(*,*) 'calcul_iso_surf_sic 465: cas rosee' !#endif DO icas=1,ncas_rosee i=cas_rosee(icas) ! evap<0 -> on condense. !WRITE(*,*) 'calcul_iso_surf_oce 3176: on condense: evap(i)=',evap(i) CALL iso_rosee_givre(xt1lay,q1lay,tsurf, & t_coup,sol_evap,i,xtsol_evap,klon) #ifdef ISOVERIF IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(-xtsol_evap(iso_HDO,i), & sol_evap(i),ridicule_evap,deltalim_snow, & 'calcul_iso_surf_sic 257_sol_evap') endif #endif enddo !do icas=1,ncas_rosee DO i=1,knon DO ixt=1,ntraciso xtevap(ixt,i)=xtsol_evap(ixt,i)+xtsnow_evap(ixt,i) enddo !do ixt=1,niso enddo ! verif #ifdef ISOVERIF DO i=1,knon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtevap(iso_eau,i),evap(i), & 'calcul_iso_surf_sic 248',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(xtevap(iso_HDO,i),evap(i), & ridicule_evap,deltalim_snow,'calcul_iso_surf_sic 257_evap') endif !if (iso_eau.gt.0) THEN #ifdef ISOTRAC CALL iso_verif_tracnps(xtevap(1,i), & 'calcul_iso_surf_sic 431') #endif enddo ! WRITE(*,*) 'calcul_iso_surf_sic 507: sortie' #endif ! end verif END SUBROUTINE calcul_iso_surf_sic_vectall !***************************** SUBROUTINE calcul_iso_surf_lic_vectall(klon,knon, & evap,snow_evap,tsurf,snow, & fq_fonte_neige,fqfonte_neige,dtime, t_coup, & precip_snow,xtprecip_snow,precip_rain,xtprecip_rain, snow_prec,xtsnow_prec, & xt1lay,q1lay,ps,Rland_ice, & xtevap,xtsnow,fqcalving, & knindex,nisurf,run_off_lic_diag,coeff_rel_diag & ) USE isotopes_mod, ONLY: h_land_ice, ridicule,ridicule_snow,ridicule_evap, & iso_eau,iso_HDO,iso_O18 USE fonte_neige_mod, ONLY: gestion_neige_besoin_varglob_fonte_neige #ifdef ISOVERIF ! USE isotopes_verif_mod, ONLY: deltalim_snow, errmax, errmaxrel,deltalim USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: index_zone,index_iso, option_traceurs,izone_cont, & & bassin_map #endif IMPLICIT NONE ! inputs INTEGER klon,knon REAL snow(klon),snow_prec(klon) REAL xtsnow(niso,klon),xtsnow_prec(niso,klon) REAL precip_snow(klon),xtprecip_snow(ntraciso,klon) REAL xtprecip_rain(ntraciso,klon),precip_rain(klon) REAL evap(klon), snow_evap(klon) REAL fq_fonte_neige(klon) REAL fqfonte_neige(klon) REAL xt1lay(ntraciso,klon),ps(klon),q1lay(klon) REAL, INTENT(IN) :: tsurf(klon) REAL Rland_ice(niso,klon) ! real run_off_lic_0(klon) REAL dtime REAL t_coup REAL fqcalving(klon) INTEGER, INTENT(IN) :: nisurf INTEGER, DIMENSION(klon), INTENT(IN) :: knindex REAL, DIMENSION(klon), INTENT(IN) :: run_off_lic_diag REAL, INTENT(IN) :: coeff_rel_diag ! output REAL xtevap(ntraciso,klon) ! real xtrun_off_lic_0(niso,klon) ! locals REAL fxt_fonte_neige(niso,klon) REAL fxtfonte_neige(niso,klon) REAL fxtcalving(niso,klon) REAL sol_evap(klon) REAL xtsol_evap(ntraciso,klon) REAL xtsnow_evap(ntraciso,klon) INTEGER i,ixt,j INTEGER ncas_evap,ncas_noevap,ncas_rosee INTEGER cas_evap(klon),cas_noevap(klon),cas_rosee(klon) INTEGER icas #ifdef ISOVERIF INTEGER trace_cas(klon) ! real deltaD ! integer iso_verif_positif_strict_nostop REAL Rland_ice_prec(niso,klon) ! integer iso_verif_egalite_choix_nostop #endif #ifdef ISOTRAC ! locals INTEGER izone_recoit #endif ! real mair ! masse d'air en kg concernée par rosée #ifdef ISOVERIF WRITE(*,*) 'calcul_iso_surf_lic 306' DO i=1,knon DO ixt=1,ntraciso CALL iso_verif_noNaN(xtprecip_snow(ixt,i), & 'calcul_iso_surf 609') enddo enddo #endif ! initialisation: xtevap=0. ! xtrun_off_lic_0=0. ! gestion de la neige CALL gestion_neige(klon,knon,snow,xtsnow, & snow_prec,xtsnow_prec,dtime, & precip_snow,xtprecip_snow,xtprecip_rain,fq_fonte_neige,fqfonte_neige, & fqcalving,snow_evap,xtsnow_evap,fxt_fonte_neige,fxtfonte_neige,fxtcalving, & xt1lay,q1lay,tsurf,t_coup,nisurf,Rland_ice) ! les traceurs d'isotopes sont déjà dans gestion neige ! on suppose que l'évaporation de la neige est taggée "continent" CALL gestion_neige_besoin_varglob_fonte_neige(klon,knon, & xtprecip_snow,xtprecip_rain, & fxtfonte_neige,fxtcalving, & knindex,nisurf,run_off_lic_diag,coeff_rel_diag) ! on incorpore la composition neige à celle du glacier ! on suppose que l'épaisseur caractéristique du glacier est hland_ice DO i=1,knon #ifdef ISOVERIF DO ixt=1,niso Rland_ice_prec(ixt,i)=Rland_ice(ixt,i) enddo !do ixt=1,niso #endif IF (precip_snow(i).gt.ridicule) THEN DO ixt=1,niso Rland_ice(ixt,i)=(h_land_ice*Rland_ice(ixt,i) & +xtprecip_snow(ixt,i)*dtime)/ & (h_land_ice+precip_snow(i)*dtime) enddo endif enddo !do i=1,knon #ifdef ISOVERIF ! vérifier que Rland_ice a bien été modifié. A l'état initiale, ! Rland_ice vaut -150 permil pour le deltaD IF (iso_HDO.gt.0) THEN DO i=1,knon IF (precip_snow(i).gt.1e-5) THEN IF (abs(deltaD(xtprecip_snow(iso_hdo,i)/precip_snow(i)) & +150).gt.5.0) THEN IF (iso_verif_positif_strict_nostop & (abs(deltaD(Rland_ice(iso_hdo,i))+150.0) & -1e-6,'calcul_iso_surf_lic 565').EQ.1) THEN WRITE(*,*) 'calcul_iso_surf_lic 575 tmp: i=',i WRITE(*,*) 'h_land_ice,precip_snow(i)*dtime=' , & h_land_ice,precip_snow(i)*dtime WRITE(*,*) 'deltaDsnow=',deltaD(xtprecip_snow(iso_hdo,i) & /precip_snow(i)) WRITE(*,*) 'deltaDland_ice=',deltaD(Rland_ice(iso_hdo,i)) WRITE(*,*) 'deltaDland_ice_prec=',deltaD( & Rland_ice_prec(iso_hdo,i)) ! stop endif endif endif !if (precip_snow(i).gt.0.0) THEN enddo !do i=1,knon endif !if (iso_HDO.gt.0) THEN DO i=1,knon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), & 'calcul_iso_surf_lic_vectall 587a',errmax,errmaxrel) endif IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(xtsnow(iso_HDO,i), & snow(i),ridicule_snow,deltalim_snow, & 'calcul_iso_surf_lic 587b') endif enddo !do i=1,knon #endif DO i=1,knon sol_evap(i)=evap(i)-snow_evap(i) enddo !do i=1,knon ! évaporation du sol ! parsage des cas ncas_evap=0 ncas_noevap=0 ncas_rosee=0 DO i=1,knon ! if (evap(i).gt.0.0) THEN IF (sol_evap(i).gt.0.0) THEN ! modif le 2 octobre 2008: c'est le signe de sol_evap qui ! doit être important ici ncas_evap=ncas_evap+1 cas_evap(ncas_evap)=i #ifdef ISOVERIF trace_cas(i)=1 #endif ! ELSE IF (evap(i).EQ.0.0) THEN ELSE IF (sol_evap(i).EQ.0.0) THEN ncas_noevap=ncas_noevap+1 cas_noevap(ncas_noevap)=i #ifdef ISOVERIF trace_cas(i)=2 #endif else ncas_rosee=ncas_rosee+1 cas_rosee(ncas_rosee)=i #ifdef ISOVERIF trace_cas(i)=3 #endif endif enddo !do i=1,knon ! traitement vectoriel du cas d'évaporation DO icas=1,ncas_evap i=cas_evap(icas) #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(Rland_ice(iso_eau,i),1.0, & 'calcul_iso_surf_lic 740',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN #endif DO ixt=1,niso xtsol_evap(ixt,i)=sol_evap(i)*Rland_ice(ixt,i) enddo !do ixt=1,niso #ifdef ISOTRAC IF (option_traceurs.EQ.20) THEN izone_recoit=bassin_map(knindex(i)) else izone_recoit=izone_cont endif DO ixt=niso+1,ntraciso IF (index_zone(ixt).EQ.izone_recoit) THEN xtsol_evap(ixt,i)=xtsol_evap(index_iso(ixt),i) else xtsol_evap(ixt,i)=0.0 endif enddo #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(sol_evap(i), & xtsol_evap(iso_eau,i), & 'calcul_iso_surf_lic 365',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN #endif enddo !!do icas_evap=1,ncas_evap ! traitement vectoriel du cas pas d'évap DO icas=1,ncas_noevap i=cas_noevap(icas) DO ixt=1,ntraciso xtsol_evap(ixt,i)=0.0 enddo !do ixt=1,niso enddo !do icas_evap=1,ncas_evap ! traitement vectoriel du cas rosée DO icas=1,ncas_rosee i=cas_rosee(icas) ! evap<0 -> on condense. !WRITE(*,*) 'calcul_iso_surf_oce 3176: on condense: evap(i)=',evap(i) ! WRITE(*,*) 'calcul_iso_surf_lic 391: dtime=',dtime ! Mair=100*100/9.8 CALL iso_rosee_givre(xt1lay,q1lay,tsurf,t_coup,sol_evap,i, & xtsol_evap,klon) #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(sol_evap(i), & xtsol_evap(iso_eau,i), & 'calcul_iso_surf_lic 365',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(-xtsol_evap(iso_hdo,i), & -sol_evap(i),ridicule_evap,deltalim, & 'calcul_iso_surf_lic 747') endif !if (iso_eau.gt.0) THEN #endif enddo !do icas=1,ncas_rosee ! fin du calcul de xtsol_evap DO i=1,knon DO ixt=1,ntraciso xtevap(ixt,i)=xtsol_evap(ixt,i)+xtsnow_evap(ixt,i) enddo enddo !do i=1,knon ! do i=1,knon ! j = knindex(i) ! do ixt=1,niso ! xtrun_off_lic_0(ixt,j)=run_off_lic_0(j)*Rland_ice(ixt,i) ! peu importe ! enddo !do ixt=1,niso !#ifdef ISOVERIF ! if (iso_eau.gt.0) THEN ! if ((j.EQ.291).OR.(j.EQ.231).OR.(j.EQ.418).OR. & ! & (j.EQ.38).OR.(j.EQ.60)) THEN ! WRITE(*,*) 'calcul_iso_surf 776 tmp& i,j,klon,knon,', & ! & 'run_off_lic_0,xt=',i,j,klon,knon, & ! & run_off_lic_0(j),xtrun_off_lic_0(iso_eau,j) ! endif ! endif !#endif ! enddo !do i=1,knon ! verif #ifdef ISOVERIF DO i=1,knon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(evap(i),xtevap(iso_eau,i), & 'calcul_iso_surf_lic 361',errmax,errmaxrel) CALL iso_verif_egalite_choix(snow(i),xtsnow(iso_eau,i), & 'calcul_iso_surf_lic 363',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(xtsnow(iso_HDO,i), & snow(i),ridicule_snow,deltalim_snow, & 'calcul_iso_surf_lic 797') CALL iso_verif_aberrant_choix(xtevap(iso_HDO,i),evap(i), & ridicule_evap,deltalim_snow, 'calcul_iso_surf_lic 369') endif !if (iso_eau.gt.0) THEN #ifdef ISOTRAC CALL iso_verif_tracnps(xtevap(1,i), & 'calcul_iso_surf_lic 723') #endif enddo !do i=1,knon ! if (iso_eau.gt.0) THEN ! do i=1,klon ! if (iso_verif_egalite_choix_nostop(run_off_lic_0(i), & ! & xtrun_off_lic_0(iso_eau,i),'calcul_iso_surf_lic 783', & ! & errmax,errmaxrel).EQ.1) THEN ! WRITE(*,*) 'i,knon,klon=',i,knon,klon ! stop ! endif ! enddo !do i=1,klon ! endif ! if (iso_eau.gt.0) THEN ! déjà vérifié dans gestion_neige #endif END SUBROUTINE calcul_iso_surf_lic_vectall !***************************** SUBROUTINE calcul_iso_surf_ter_vectall(klon,knon, & evap,snow_evap,snow, & fq_fonte_neige,fqfonte_neige,dtime, precip_rain,xtprecip_rain, & precip_snow,xtprecip_snow, snow_prec,xtsnow_prec, & tsurf,xt1lay,ps,q1lay,t_coup,u1lay,v1lay,p1lay, & qsol,xtsol,qsol_prec,xtsol_prec, & max_eau_sol, & xtevap,xtsnow,h1,run_off,xtrun_off,fqcalving, & knindex,nisurf,run_off_lic_diag,coeff_rel_diag,Rland_ice & ) USE isotopes_mod, ONLY: tdifrel,tdifexp_sol, iso_eau, iso_HDO, & & bidouille_anti_divergence,ruissellement_pluie, Rdefault,Kd, & & ridicule_rain,tnat, iso_O18,evap_cont_cste,alphak_stewart, & & deltaP_BL,iso_O18,iso_O17,deltaO18_evap_cont,d_evap_cont, & & iso_HTO, ridicule_qsol, ridicule, ridicule_snow,P_veg, & & ridicule_evap USE fonte_neige_mod, ONLY: gestion_neige_besoin_varglob_fonte_neige USE lmdz_yomcst #ifdef ISOVERIF !USE isotopes_verif_mod, ONLY: errmax,errmaxrel,errmax_sol,deltalim_snow, & ! faccond USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: index_zone,index_iso,option_traceurs,izone_cont, & & bassin_map #endif USE lmdz_yoethf IMPLICIT NONE INCLUDE "FCTTRE.h" ! inputs INTEGER klon,knon REAL snow(klon),snow_prec(klon) REAL xtsnow(niso,klon),xtsnow_prec(niso,klon) REAL precip_snow(klon),xtprecip_snow(ntraciso,klon) REAL precip_rain(klon),xtprecip_rain(ntraciso,klon) REAL qsol(klon),qsol_prec(klon) ! hauteur d'eau, en mm. REAL xtsol(niso,klon),xtsol_prec(niso,klon) REAL evap(klon), snow_evap(klon) REAL fq_fonte_neige(klon) REAL fqfonte_neige(klon) REAL xt1lay(ntraciso,klon),q1lay(klon) REAL u1lay(klon),v1lay(klon) REAL p1lay(klon) REAL ps(klon) REAL, INTENT(IN) :: tsurf(klon) REAL dtime REAL t_coup REAL max_eau_sol REAL run_off(klon) REAL fqcalving(klon) INTEGER, INTENT(IN) :: nisurf INTEGER, DIMENSION(klon), INTENT(IN) :: knindex REAL, DIMENSION(klon), INTENT(IN) :: run_off_lic_diag REAL, INTENT(IN) :: coeff_rel_diag REAL, DIMENSION(niso,klon), INTENT(IN) :: Rland_ice ! output REAL xtevap(ntraciso,klon) REAL xtrun_off(niso,klon) ! locals REAL sol_evap(klon) REAL xtsol_evap(ntraciso,klon) REAL xtnu(niso,klon) REAL L REAL xtsnow_evap(ntraciso,klon) REAL qsol_avant_evap(klon), & xtsol_avant_evap(niso,klon) REAL fxt_fonte_neige(niso,klon) REAL fxtfonte_neige(niso,klon) REAL fxtcalving(niso,klon) REAL VSURF REAL kcin(niso) REAL alphak(niso) ! integer alphak_stewart ! parameter (alphak_stewart=1) ! si 1: alphak=(D/Diso)^nsol ! si 0: alphak=1/(1-kcin(vsurf)) ! 31 aout: ce param est maintenant dans wateriso ! real tdifexp_sol ! parameter (tdifexp_sol=0.8) ! tdifexp_sol est l'exposant de D/Diso. Il paramétrise ! la turbulence. D'abitude, il est de 0.58. Mais d'après ! Mathieu et Bariac, il est entre 0.67 et 1: 0.67 pour ! les sols secs et 1 pour les sols saturés. ! 31 aout: ce param est maintenant dans wateriso REAL h1(klon) REAL zqs(klon) REAL R1(niso) REAL Revap(niso) REAL zxtalphal(niso), zxtalphai(niso) REAL qevap(klon) REAL q10 ! humidité 1ère couche en mm REAL rowl ! densité eau en kg/m3 parameter (rowl=1000.0) REAL Pveg INTEGER i,ixt,j REAL Rsol_new(niso), Rsol(niso) REAL qsol_avant_deversement(klon) ! qu'est-ce qui ruisselle? ! integer ruissellement_pluie ! parameter (ruissellement_pluie=0) ! si 1: c'est la pluie qui ruisselle. elle ne s'infiltre ! donc jamais dans un sol saturé. ! si 0: c'est le sol qui ruisselle. La pluie s'inglitre ! donc dans le sol saturé. ! 31 aout: ce param est maintenant dans wateriso REAL precip_rain_eff(klon),fq_fonte_neige_eff(klon) REAL sol_evap_eff(klon) REAL xtsol_evap_eff(niso,klon) REAL xtprecip_rain_eff(niso,klon), & fxt_fonte_neige_eff(niso,klon) INTEGER ncas_evap,ncas_noevap,ncas_rosee INTEGER cas_evap(klon),cas_noevap(klon),cas_rosee(klon) INTEGER icas REAL runoff_tmp(knon) #ifdef ISOVERIF INTEGER trace_cas(klon) ! integer iso_verif_aberrant_nostop ! juste debug ! integer iso_verif_aberrant_O17_nostop ! juste debug ! integer iso_verif_aberrant_choix_nostop ! integer iso_verif_egalite_choix_nostop ! integer iso_verif_positif_nostop ! integer iso_verif_egalite_nostop ! integer iso_verif_positif_choix_nostop ! real deltaD,o17excess REAL dqdiag #endif !#ifdef ISOVERIF ! integer iso_verif_noNaN_nostop !#endif #ifdef ISOTRAC ! locals INTEGER izone_recoit #endif #ifdef ISOVERIF ! WRITE(*,*) 'calcul_iso_surf_ter 494' DO i=1,knon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & xtsnow_prec(iso_eau,i), & snow_prec(i),'calcul_iso_surf_ter 1019',& errmax,errmaxrel) CALL iso_verif_egalite_choix( & xtprecip_snow(iso_eau,i), & precip_snow(i),'calcul_iso_surf_ter 1023', & errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN DO ixt=1,ntraciso CALL iso_verif_noNaN(xtprecip_snow(ixt,i), & 'calcul_iso_surf 1025') enddo enddo #endif ! gestion de la neige CALL gestion_neige(klon,knon,snow,xtsnow, & snow_prec,xtsnow_prec,dtime, & precip_snow,xtprecip_snow,xtprecip_rain,fq_fonte_neige,fqfonte_neige, & fqcalving,snow_evap,xtsnow_evap,fxt_fonte_neige,fxtfonte_neige,fxtcalving,& xt1lay,q1lay,tsurf,t_coup,nisurf,Rland_ice) ! les traceurs d'isotopes sont déjà dans gestion neige ! on suppose que l'évaporation de la neige est taggée "continent" CALL gestion_neige_besoin_varglob_fonte_neige(klon,knon, & xtprecip_snow,xtprecip_rain, & fxtfonte_neige,fxtcalving, & knindex,nisurf,run_off_lic_diag,coeff_rel_diag) ! calcul de la partition entre snow_evap et sol_evap DO i=1,knon sol_evap(i)=evap(i)-snow_evap(i) enddo !do i=1,knon ! bilan du sol avant evap ! verif #ifdef ISOVERIF DO i=1,knon DO ixt=1,niso CALL iso_verif_noNaN(xtsol_prec(ixt,i),'surf_ter 974') enddo enddo #endif #ifdef ISOVERIF ! WRITE(*,*) 'calcul_iso_surf_ter 910' DO i=1,knon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(qsol_prec(i), & xtsol_prec(iso_eau,i),'calcul_iso_surf_ter 504', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & xtsnow(iso_eau,i),snow(i), & 'calcul_iso_surf_tic_vectall 964', & errmax,errmaxrel) endif IF (iso_HDO.gt.0) THEN IF (qsol_prec(i).gt.ridicule_qsol*1e2) THEN CALL iso_verif_aberrant(xtsol_prec(iso_HDO,i)/ & qsol_prec(i)/faccond,'calcul_iso_surf_ter 506') endif !if (qsol_prec(i).gt.ridicule_qsol) endif !if (iso_eau.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qsol_prec(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17(xtsol_prec(iso_O17,i) & /qsol_prec(i),xtsol_prec(iso_O18,i) & /qsol_prec(i),'iso_surf_ter 1035') endif !if ((qsol_prec(i).gt.ridicule).AND.(xtsol_prec(iso_O18,i) endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN enddo !do i=1,knon #endif #ifdef ISOVERIF DO i=1,knon DO ixt=1,niso CALL iso_verif_noNaN(xtsol_prec(ixt,i), & 'iso_surf_ter 1061') enddo !do ixt=1,niso enddo !do i=1,knon #endif ! end verif DO i=1,knon ! flux efficaces, en tenant compte du ruissellement precip_rain_eff(i)=precip_rain(i) fq_fonte_neige_eff(i)=fq_fonte_neige(i) sol_evap_eff(i)=sol_evap(i) DO ixt=1,niso xtprecip_rain_eff(ixt,i)=max(xtprecip_rain(ixt,i),0.0) fxt_fonte_neige_eff(ixt,i)=fxt_fonte_neige(ixt,i) enddo #ifdef ISOVERIF CALL iso_verif_positif(precip_rain(i),'calcul_iso_surf_ter 655') CALL iso_verif_positif(fq_fonte_neige(i), & 'calcul_iso_surf_ter 656') CALL iso_verif_positif(max_eau_sol-qsol_prec(i), & 'calcul_iso_surf_ter 882') IF (iso_eau.gt.0) THEN CALL iso_verif_positif(xtprecip_rain(iso_eau,i), & 'calcul_iso_surf_ter 655b') endif #endif enddo !do i=1,knon !WRITE(*,*) 'surf_ter 14041' IF (ruissellement_pluie.EQ.1) THEN DO i=1,knon ! c'est la pluie que l'on fait ruisseller ! WRITE(*,*) '' ! WRITE(*,*) 'calcul_iso_surf_ter 676, tmp:' ! WRITE(*,*) 'qsol,qsol_prec',qsol(i),qsol_prec(i) ! WRITE(*,*) 'precip_rain*dtime=',precip_rain(i)*dtime ! WRITE(*,*) 'sol_evap*dtime=',sol_evap(i)*dtime ! WRITE(*,*) 'fq_fonte_neige=',fq_fonte_neige(i) ! WRITE(*,*) 'max_eau_sol=',max_eau_sol DO ixt=1,niso xtrun_off(ixt,i)=0.0 enddo runoff_tmp(i)=0.0 IF (qsol_prec(i) & +(precip_rain(i)-sol_evap(i))*dtime & +fq_fonte_neige(i).gt.max_eau_sol) THEN ! ça déborde ! on réduit l'infiltration de la pluie: precip_rain_eff(i)=min(sol_evap(i) & +(max_eau_sol-qsol_prec(i)-fq_fonte_neige(i))/dtime, & precip_rain(i)) IF (precip_rain_eff(i).lt.0.0) THEN ! ça déborderait même sans pluie ! on réduit donc la fonte precip_rain_eff(i)=0.0 fq_fonte_neige_eff(i)=min(sol_evap(i)*dtime & +max_eau_sol-qsol_prec(i),fq_fonte_neige(i)) IF (fq_fonte_neige_eff(i).lt.0.0) THEN ! ca déborderait même sans precip ni fonte car il ! y a de la rosée #ifdef ISOVERIF CALL iso_verif_positif(-sol_evap(i), & 'calcul_iso_surf_ter 912') #endif fq_fonte_neige_eff(i)=0.0 sol_evap_eff(i)=(qsol_prec(i)-max_eau_sol)/dtime endif !if (fq_fonte_neige_eff(i).lt.0.0) THEN endif !if (precip_rain_eff(i).lt.0.0) THEN endif !if (qsol_prec(i) #ifdef ISOVERIF ! WRITE(*,*) 'calcul_iso_surf_ter 706 tmp:' ! WRITE(*,*) 'precip_rain_eff(i)*dtime=', ! : precip_rain_eff(i)*dtime ! WRITE(*,*) 'fq_fonte_neige_eff(i)*dtime=', ! : fq_fonte_neige_eff(i)*dtime ! WRITE(*,*) 'sol_evap(i)*dtime=', ! : sol_evap(i)*dtime ! WRITE(*,*) 'sol_evap_eff(i)*dtime=', ! : sol_evap_eff(i)*dtime ! WRITE(*,*) 'max_eau_sol,qsol_prec(i)=', ! : max_eau_sol,qsol_prec(i) CALL iso_verif_positif_choix(max_eau_sol- & (qsol_prec(i)+ & (precip_rain_eff(i)-sol_evap_eff(i)*dtime & +fq_fonte_neige_eff(i))),ridicule_qsol*10, & 'calcul iso_surf_ter 669') ! 12 mai 2009: ridicule_qsol*10 car erreurs nums en 32 bits CALL iso_verif_positif((fq_fonte_neige_eff(i)), & 'calcul iso_surf_ter 702') CALL iso_verif_positif((precip_rain_eff(i)), & 'calcul iso_surf_ter 703') IF (sol_evap(i).ge.0.0) THEN CALL iso_verif_egalite_choix( & sol_evap(i), & (sol_evap_eff(i)), & 'calcul iso_surf_ter 724',errmax,errmaxrel) endif #endif ! pour les isostopes: IF (abs(precip_rain(i)-precip_rain_eff(i)) & .gt.ridicule*1e-2) THEN ! * pour precip_rain_eff: IF (precip_rain_eff(i).gt.ridicule_rain) THEN IF (precip_rain(i).gt.ridicule_rain) THEN DO ixt=1,niso xtprecip_rain_eff(ixt,i)=xtprecip_rain(ixt,i) & /precip_rain(i)*precip_rain_eff(i) enddo else !if (precip_rain(i).gt.ridicule_rain) THEN WRITE(*,*) 'calcul_iso_surf_ter 723' stop endif !if (precip_rain(i).gt.ridicule_rain) THEN else !if (precip_rain_eff(i).gt.ridicule_rain) THEN DO ixt=1,niso xtprecip_rain_eff(ixt,i)=0.0 enddo IF ((bidouille_anti_divergence).AND. & (iso_eau.gt.0)) THEN xtprecip_rain_eff(iso_eau,i)=precip_rain_eff(i) endif endif !if (precip_rain_eff(i).gt.ridicule_rain) THEN runoff_tmp(i)=runoff_tmp(i) & +(precip_rain(i)-precip_rain_eff(i))*dtime DO ixt=1,niso xtrun_off(ixt,i)=xtrun_off(ixt,i) & +(xtprecip_rain(ixt,i)-xtprecip_rain_eff(ixt,i))*dtime enddo endif !if (abs(precip_rain(i)-precip_rain_eff(i)).gt.ridicule) THEN #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & runoff_tmp(i),xtrun_off(iso_eau,i), & 'calcul_iso_surf_ter 1142', & errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN #endif IF (abs(fq_fonte_neige_eff(i)-fq_fonte_neige(i)) & .gt.ridicule) THEN ! * pour fq_fonte_neige_eff: IF (fq_fonte_neige_eff(i).gt.ridicule_rain) THEN IF (fq_fonte_neige(i).gt.ridicule_rain) THEN DO ixt=1,niso fxt_fonte_neige_eff(ixt,i)=fxt_fonte_neige(ixt,i) & /fq_fonte_neige(i)*fq_fonte_neige_eff(i) enddo else !if (fq_fonte_neige(i).gt.ridicule_rain) THEN WRITE(*,*) 'calcul_iso_surf_ter 723' stop endif !if (fq_fonte_neige(i).gt.ridicule_rain) THEN else !if (fq_fonte_neige_eff(i).gt.ridicule_rain) THEN DO ixt=1,niso fxt_fonte_neige_eff(ixt,i)=0.0 enddo endif !if (fq_fonte_neige_eff(i).gt.ridicule_rain) THEN runoff_tmp(i)=runoff_tmp(i) & +(fq_fonte_neige(i)-fq_fonte_neige_eff(i)) DO ixt=1,niso xtrun_off(ixt,i)=xtrun_off(ixt,i) & +(fxt_fonte_neige(ixt,i)-fxt_fonte_neige_eff(ixt,i)) enddo endif !if (abs(fq_fonte_neige_eff(i)-fq_fonte_neige(i)) #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(( & fq_fonte_neige_eff(i)), & (fxt_fonte_neige_eff(iso_eau,i)), & 'calcul_iso_surf_ter 705', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & (precip_rain_eff(i)), & (xtprecip_rain_eff(iso_eau,i)), & 'calcul_iso_surf_ter 711', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & runoff_tmp(i),xtrun_off(iso_eau,i), & 'calcul_iso_surf_ter 1179', & errmax,errmaxrel) endif #endif enddo !do i=1,knon endif !if (ruissellement_pluie) THEN ! on ajoute les flux entrants dans le sol ! attention, c'est facile si qsol>=0. ! mais par contre, si qsol<0, on est obligé de mettre ! Rsol=Rflux_entrants, sinon on a des aberrances. ! la conservation de la masse d'iso dans le sol ne sera donc pas ! vérifiée... Donc prudence! DO i=1,knon qsol_avant_evap(i)=qsol_prec(i) & +precip_rain_eff(i)*dtime+fq_fonte_neige_eff(i) enddo !do i=1,knon DO i=1,knon IF (qsol_prec(i).ge.0.0) THEN DO ixt=1,niso xtsol_avant_evap(ixt,i)=xtsol_prec(ixt,i) & +xtprecip_rain_eff(ixt,i)*dtime+fxt_fonte_neige_eff(ixt,i) enddo !do ixt=1,niso else !if (qsol_prec(i).ge.0.0) THEN IF (precip_rain_eff(i)*dtime+fq_fonte_neige_eff(i) & .gt.ridicule_qsol) THEN DO ixt=1,niso xtsol_avant_evap(ixt,i)=qsol_avant_evap(i)* & (xtprecip_rain_eff(ixt,i)*dtime+fxt_fonte_neige_eff(ixt,i)) & /(precip_rain_eff(i)*dtime+fq_fonte_neige_eff(i)) enddo !do ixt=1,niso else ! il n'y a pas de flux entrants ! on a donc qsol_avant_evap(i)=qsol_prec(i) DO ixt=1,niso xtsol_avant_evap(ixt,i)=xtsol_prec(ixt,i) enddo !do ixt=1,niso endif endif !if (qsol_prec(i).ge.0.0) THEN enddo !do i=1,knon ! verif #ifdef ISOVERIF DO i=1,knon DO ixt=1,niso IF (iso_verif_noNaN_nostop(( & xtsol_avant_evap(ixt,i)),'surf_ter 1239').EQ.1) THEN WRITE(*,*) 'qsol_prec(i)=',qsol_prec(i) WRITE(*,*) 'xtsol_prec(ixt,i)=',xtsol_prec(ixt,i) WRITE(*,*) 'xtprecip_rain_eff(ixt,i)=', & xtprecip_rain_eff(ixt,i) WRITE(*,*) 'fxt_fonte_neige_eff(ixt,i)=', & fxt_fonte_neige_eff(ixt,i) WRITE(*,*) 'precip_rain_eff(i)=',precip_rain_eff(i) WRITE(*,*) 'fq_fonte_neige_eff(i)=',fq_fonte_neige_eff(i) WRITE(*,*) 'qsol_avant_evap(i)=',qsol_avant_evap(i) WRITE(*,*) 'xtsol_avant_evap(ixt,i)=',xtsol_avant_evap(ixt,i) WRITE(*,*) 'dtime=',dtime stop endif enddo enddo #endif #ifdef ISOVERIF DO i=1,knon IF (iso_eau.gt.0) THEN ! WRITE(*,*) 'qsol_prec=',qsol_prec(i) ! WRITE(*,*) 'xtsol_prec=',xtsol_prec(iso_eau,i) ! WRITE(*,*) 'precip_rain_eff=',precip_rain_eff(i) ! WRITE(*,*) 'fq_fonte_neige_eff=',fq_fonte_neige_eff(i) ! WRITE(*,*) 'qsol_avant_evap=',qsol_avant_evap(i) ! WRITE(*,*) 'xtsol_avant_evap=',xtsol_avant_evap(iso_eau,i) ! WRITE(*,*) 'xtprecip_rain_eff=',xtprecip_rain_eff(iso_eau,i) ! WRITE(*,*) 'fxt_fonte_neige_eff=', ! : fxt_fonte_neige_eff(iso_eau,i) CALL iso_verif_egalite_choix( & (qsol_avant_evap(i)), & (xtsol_avant_evap(iso_eau,i)), & 'calcul_iso_surf_ter 527',errmax,errmaxrel) endif IF (iso_HDO.gt.0) THEN IF (qsol_avant_evap(i).gt.ridicule_qsol*1e2) THEN IF (iso_verif_aberrant_nostop(( & xtsol_avant_evap(iso_HDO,i)/qsol_avant_evap(i)) & /faccond,'calcul_iso_surf_ter 5032').EQ.1) THEN WRITE(*,*) 'qsol_avant_evap(i)=',qsol_avant_evap(i) WRITE(*,*) 'ridicule_qsol=',ridicule_qsol WRITE(*,*) 'qsol_prec(i)=',qsol_prec(i) WRITE(*,*) 'precip_rain_eff(i)*dtime=', & precip_rain_eff(i)*dtime WRITE(*,*) 'fq_fonte_neige_eff(i)=',fq_fonte_neige_eff(i) WRITE(*,*) 'deltaD_sol_prec=', & deltaD(xtsol_prec(iso_HDO,i)/qsol_prec(i)) WRITE(*,*) 'deltaDprecip_rain_eff=',& deltaD(( & xtprecip_rain_eff(iso_HDO,i)/precip_rain_eff(i))) WRITE(*,*) 'deltaD_finte_neige_eff=', & deltaD(( & fxt_fonte_neige_eff(iso_HDO,i)/fq_fonte_neige_eff(i))) WRITE(*,*) 'precip_rain(i)*dtime=', & precip_rain(i)*dtime WRITE(*,*) 'fq_fonte_neige(i)=',fq_fonte_neige(i) stop endif !if (iso_verif_aberrant_nostop( endif ! if ( qsol_avant_evap(i).gt.ridicule_qsol) endif !if (iso_eau.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qsol_avant_evap(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17(( & xtsol_avant_evap(iso_O17,i)/qsol_avant_evap(i)), & (xtsol_avant_evap(iso_O18,i) & /qsol_avant_evap(i)),'iso_surf_ter 1263') endif !if ((qsol_prec(i).gt.ridicule).AND.(xtsol_prec(iso_O18,i) endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN enddo !do i=1,knon #endif ! end verif DO i=1,knon qsol_avant_deversement(i)=qsol_avant_evap(i) & -sol_evap_eff(i)*dtime enddo !do i=1,knon ! verif du bilan du sol #ifdef ISOVERIF ! WRITE(*,*) 'calcul_iso_surf_ter 1200' DO i=1,knon CALL iso_verif_egalite_choix(min(( & qsol_avant_deversement(i)),max_eau_sol), & qsol(i), & 'calcul_iso_surf_ter 587',errmax,errmaxrel) IF (ruissellement_pluie.EQ.1) THEN IF (iso_verif_positif_choix_nostop( & max_eau_sol-(qsol_avant_deversement(i)), & ridicule_qsol,'calcul_iso_surf_ter 843').EQ.1) THEN WRITE(*,*) 'qsol_avant_evap(i)=',qsol_avant_evap(i) WRITE(*,*) 'qsol_avant_deversement(i)=', & qsol_avant_deversement(i) WRITE(*,*) 'sol_evap_eff(i)*dtime=',sol_evap_eff(i)*dtime stop endif endif enddo ! do i=1,knon #endif ! parsage des cas ncas_evap=0 ncas_noevap=0 ncas_rosee=0 DO i=1,knon ! modif 2 octobre! sol_evap au lie de evap ! modif 5 oct: gt au lieu de ge. IF (sol_evap(i).gt.0.0) THEN ncas_evap=ncas_evap+1 cas_evap(ncas_evap)=i #ifdef ISOVERIF trace_cas(i)=1 #endif ELSE IF (sol_evap(i).lt.0.0) THEN ncas_rosee=ncas_rosee+1 cas_rosee(ncas_rosee)=i #ifdef ISOVERIF trace_cas(i)=3 #endif else !if (sol_evap(i).gt.0.0) THEN ncas_noevap=ncas_noevap+1 cas_noevap(ncas_noevap)=i #ifdef ISOVERIF trace_cas(i)=2 #endif endif !if (sol_evap(i).gt.0.0) THEN enddo !do i=1,knon ! évaporation du sol: ! traitement vectoriel du cas d'évaporation ! calcul longueur de diffusion L=1e3*sqrt(dtime*Kd) ! en mm DO icas=1,ncas_evap i=cas_evap(icas) ! verif du sol #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xtsol(ixt,i), & 'calcul_iso_surf_ter 2960') enddo !do ixt=1,niso #endif #ifdef ISOVERIF ! WRITE(*,*) 'calcul_iso_surf_ter 767: i,sol_evap=', ! : i,sol_evap(i) ! WRITE(*,*) 'xtsol_avant_evap,qsol_avant_evap=', ! : xtsol_avant_evap(iso_eau,i),qsol_avant_evap(i) IF (iso_verif_egalite_nostop(sol_evap(i), & (sol_evap_eff(i)), & 'calcul_iso_surf_ter 1100').EQ.1) THEN WRITE(*,*) 'calcul_iso_surf_ter 543: qsol(',i,')=',qsol(i) WRITE(*,*) 'qsol_avant_evap(',i,')=',qsol_avant_evap(i) WRITE(*,*) 'sol_evap(',i,')*dtime=',sol_evap(i)*dtime WRITE(*,*) 'qsol_prec(',i,')=',qsol_prec(i) WRITE(*,*) 'precip_rain(',i,')*dtime=',precip_rain(i)*dtime WRITE(*,*) 'fq_fonte_neige(',i,')=',fq_fonte_neige(i) stop endif IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(( & xtsol_avant_evap(iso_eau,i)) & ,(qsol_avant_evap(i)), & 'calcul_iso_surf_ter 2952', & errmax,errmaxrel) IF (qsol_avant_evap(i).gt.ridicule_qsol) THEN IF (iso_verif_egalite_choix_nostop(( & xtsol_avant_evap(iso_eau,i)/qsol_avant_evap(i)), & 1.0,'calcul_iso_surf_ter 2952', & errmax,errmaxrel*10).EQ.1) THEN WRITE(*,*) 'xtsol_avant_evap(iso_eau,i)=', & xtsol_avant_evap(iso_eau,i) WRITE(*,*) 'qsol_avant_evap(i)=', & qsol_avant_evap(i) WRITE(*,*) 'xtsol_prec(iso_eau,i)=', & xtsol_prec(iso_eau,i) WRITE(*,*) 'qsol_prec(i)=', & qsol_prec(i) WRITE(*,*) 'xtprecip_rain_eff(iso_eau,i)=', & xtprecip_rain_eff(iso_eau,i) WRITE(*,*) 'precip_rain_eff(i)=',& precip_rain_eff(i) WRITE(*,*) 'fxt_fonte_neige_eff(iso_eau,i)=', & fxt_fonte_neige_eff(iso_eau,i) WRITE(*,*) 'fq_fonte_neige_eff(i)=', & fq_fonte_neige_eff(i) stop endif !if (iso_verif_egalite_choix( endif !if (qsol(i).gt.ridicule_qsol) THEN endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (qsol_avant_evap(i).gt.ridicule_qsol*1e2) THEN CALL iso_verif_aberrant(( & xtsol_avant_evap(iso_HDO,i)/qsol_avant_evap(i)) & /faccond ,'calcul_iso_surf_ter 3181') endif !if (qsol(i).gt.ridicule_qsol) THEN endif !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qsol_avant_evap(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17(( & xtsol_avant_evap(iso_O17,i)/qsol_avant_evap(i)), & (xtsol_avant_evap(iso_O18,i) & /qsol_avant_evap(i)),'iso_surf_ter 1390') endif !if ((qsol_prec(i).gt.ridicule).AND.(xtsol_prec(iso_O18,i) endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif ! end verif du sol ! calcul de h1 IF (tsurf(i).lt.t_coup) THEN zqs(i)=qsats(tsurf(i))/ps(i) #ifdef ISOVERIF CALL iso_verif_positif(zqs(i),'calcul_iso_surf 1183') CALL iso_verif_positif(0.1-zqs(i),'calcul_iso_surf 1184') #endif else zqs(i)=qsatl(tsurf(i))/ps(i) #ifdef ISOVERIF CALL iso_verif_positif(zqs(i),'calcul_iso_surf 1187') IF (iso_verif_positif_nostop(0.15-zqs(i),& 'calcul_iso_surf 1188').EQ.1) THEN WRITE(*,*) 'tsurf(i)=',tsurf(i)-t_coup,'°C' IF (tsurf(i)-t_coup.lt.50.0) THEN stop endif endif #endif endif h1(i)=q1lay(i)/zqs(i) h1(i)=min(1.0,max(0.0,h1(i))) ! calcul de Rsol CALL calcul_Rsol(qsol_avant_evap, & sol_evap,xtsol_avant_evap, & xt1lay, q1lay,tsurf, i,Rsol,klon) #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(Rsol(ixt), & 'calcul_iso_surf_ter 3217, sur terre') enddo !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(Rsol(iso_eau),1.0, & 'calcul_iso_surf_ter 700',errmax*10,errmaxrel*10) endif !if (iso_eau.gt.0) THEN IF ((iso_HDO.gt.0).AND. & (qsol_avant_evap(i).gt.ridicule_qsol*1e2)) THEN CALL iso_verif_aberrant(Rsol(iso_HDO)/faccond, & 'calcul_iso_surf_ter 703') endif IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qsol_avant_evap(i).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17(Rsol(iso_o17),Rsol(iso_o18), & 'iso_surf_ter 1447') endif !if ((qsol_prec(i).gt.ridicule).AND.(xtsol_prec(iso_O18,i) endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif IF ((bidouille_anti_divergence).AND. & (iso_eau.gt.0)) THEN Rsol(iso_eau)=1.0 endif ! CALCUL de R1 #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xt1lay(ixt,i), & 'calcul_iso_surf_ter 3222') CALL iso_verif_noNAN(q1lay(i), & 'calcul_iso_surf_ter 3223') enddo #endif IF (q1lay(i).gt.0.0) THEN DO ixt=1,niso R1(ixt)=xt1lay(ixt,i)/q1lay(i) enddo else #ifdef ISOVERIF WRITE(*,*) 'calcul_iso_surf 1415: q1lay=',q1lay(i) stop #endif DO ixt=1,niso R1(ixt)=Rdefault(ixt) enddo endif ! calcul humidité de la couche 1, en mm ! cela servira en cas de réévaporation en h=1, pour éviter ! instabilités. ! deltaP=2.0*(ps(i)-p1lay(i)) ! q10=1.0e3*2.0*(ps(i)-p1lay(i))*q1lay(i)/rowl/RG q10=1.0e3*deltaP_BL*q1lay(i)/rowl/RG ! modif 31 aout 2008 #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(R1(ixt), & 'calcul_iso_surf_ter 3227, sur terre') enddo !do ixt=1,niso #endif ! calcul de l'évap IF (alphak_stewart.EQ.1) THEN ! calcul de alphak en accord avec stewart, mathieu et ! Bariac DO ixt=1,niso alphak(ixt)=tdifrel(ixt)**tdifexp_sol enddo !do ixt=1,niso else ! calcul de alphak comme une surfacae ouvert, fonction du ! vent VSURF=sqrt(u1lay(i)**2+v1lay(i)**2) CALL calcul_kcin(vsurf,kcin) DO ixt=1,niso alphak(ixt)=1.0/(1-kcin(ixt)) enddo !do ixt=1,niso endif qevap(i)=sol_evap(i)*dtime ! quantité d'eau du sol perdue par evap IF (tsurf(i).gt.t_coup) THEN ! Pveg est la fraction d'eau évaporée sans fractionnement Pveg=P_veg else !if (tsurf(i).gt.t_coup) THEN ! à 0°C, on sublime, donc on révap tout sans fractionnement Pveg=1.0 endif !if (tsurf(i).gt.t_coup) THEN ! calcul de ce que donnerait l'évap du sol nu #ifdef ISOVERIF IF (P_veg.EQ.1.0) THEN CALL iso_verif_egalite(Pveg,1.0,'calcul_iso_surf_ter 1314') endif #endif IF (Pveg.gt.1.0-1e-3) THEN DO ixt=1,niso xtnu(ixt,i)=0.0 enddo else CALL iso_evap_sol_nu((qsol_avant_evap(i)), & qevap(i),q10,Rsol,R1,h1(i), & tsurf(i),alphak, L, xtnu(1,i),Pveg) #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtnu(iso_eau,i),qevap(i),& 'calcul_iso_surf_ter 1253',errmax,errmaxrel) endif IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qevap(i).gt.ridicule_evap) THEN CALL iso_verif_aberrant_o17(xtnu(iso_O17,i) & /qevap(i),xtnu(iso_O18,i)/qevap(i), & 'iso_surf_ter 1623') endif !if (qevap(i).gt.ridicule_evap) THEN endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif endif ! CALL iso_evap_sol((qsol_avant_evap(i)), ! & qevap,Pveg,Rsol,R1,h1(i), ! & tsurf(i),alphak, Rsol_new,Revap) ! bilan de masse DO ixt=1,niso ! xtsol_evap(ixt,i)=sol_evap(i)*Revap(ixt) ! xtsol(ixt,i)=qsol_avant_deversement(i)*Rsol_new(ixt) xtsol_evap(ixt,i)=(1.0-Pveg)*xtnu(ixt,i) & +Pveg*Rsol(ixt)*qevap(i) ! mm xtsol(ixt,i)=xtsol_avant_evap(ixt,i)-xtsol_evap(ixt,i) ! mm xtsol_evap(ixt,i)=xtsol_evap(ixt,i)/dtime ! mm/s enddo !do ixt=1,niso IF (evap_cont_cste.EQ.1) THEN ! on fixe la compo de l'évap continentale IF (iso_eau.gt.0) THEN xtsol_evap(iso_eau,i)=sol_evap(i) endif IF (iso_O18.gt.0) THEN xtsol_evap(iso_O18,i)=sol_evap(i) & *(deltaO18_evap_cont/1000.+1.)*tnat(iso_O18) endif IF (iso_HDO.gt.0) THEN xtsol_evap(iso_HDO,i)=sol_evap(i) & *((d_evap_cont+8*deltaO18_evap_cont)/1000.+1.) & *tnat(iso_HDO) endif IF (iso_O17.gt.0) THEN xtsol_evap(iso_O17,i)=0.0 endif IF (iso_HTO.gt.0) THEN xtsol_evap(iso_HTO,i)=0.0 endif endif #ifdef ISOTRAC IF (option_traceurs.EQ.20) THEN izone_recoit=bassin_map(knindex(i)) else izone_recoit=izone_cont endif DO ixt=niso+1,ntraciso IF (index_zone(ixt).EQ.izone_recoit) THEN xtsol_evap(ixt,i)=xtsol_evap(index_iso(ixt),i) else xtsol_evap(ixt,i)=0.0 endif enddo !do ixt=niso+1,ntraciso #endif ! verif #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(xtsol_evap(ixt,i), & 'calcul_iso_surf_ter 3002, sur terre') CALL iso_verif_noNAN(xtsol(ixt,i), & 'calcul_iso_surf_ter 680') enddo !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & xtsol_evap(iso_eau,i), & sol_evap(i), & 'calcul_iso_surf_ter 741',errmax,errmaxrel) CALL iso_verif_egalite_choix(xtsol(iso_eau,i), & (qsol_avant_deversement(i)), & 'calcul_iso_surf_ter 2976',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (abs(sol_evap(i)).gt.ridicule_evap) THEN IF (iso_verif_aberrant_nostop( & xtsol_evap(iso_HDO,i)/sol_evap(i), & 'calcul_iso_surf_ter 3273: sur terre').EQ.1) THEN ! WRITE(*,*) 'deltaDsol=',deltaD(Rsol(ixt)) ! on ne plante que si ca donne lieu à des valeurs ! aberrante de deltaD1 WRITE(*,*) 'deltaD1new=',deltaD( & (xtsol_evap(iso_hdo,i)*dtime+q10*R1(iso_hdo)) & /(sol_evap(i)*dtime+q10)) CALL iso_verif_aberrant( & (xtsol_evap(iso_hdo,i)*dtime+q10*R1(iso_hdo)) & /(sol_evap(i)*dtime+q10), & 'calcul_iso_surf_ter 1390') endif !if (iso_verif_aberrant endif !if (abs(evap(i)).gt.ridicule_rain*1e-2) THEN IF (iso_verif_aberrant_choix_nostop(xtsol_evap(iso_HDO,i), & sol_evap(i),ridicule,1e5, & 'calcul_iso_surf_ter 1403').EQ.1) THEN CALL iso_verif_aberrant( & (xtsol_evap(iso_hdo,i)*dtime+q10*R1(iso_hdo)) & /(sol_evap(i)*dtime+q10), & 'calcul_iso_surf_ter 1390') endif IF (qsol_avant_deversement(i).gt.ridicule_qsol*1e2) THEN IF (iso_verif_aberrant_nostop(xtsol(iso_HDO,i)& /(qsol_avant_deversement(i)) & /faccond, 'calcul_iso_surf_ter 1542').EQ.1) THEN WRITE(*,*) 'i, qsol(i)=',i, qsol(i) WRITE(*,*) 'qsol_avant_evap,qevap,L=', & qsol_avant_evap(i),qevap(i),L WRITE(*,*) 'deltaDsol_avant_evap',deltaD( & (xtsol_avant_evap(iso_HDO,i) & /qsol_avant_evap(i))) WRITE(*,*) 'deltaDRsol=',deltaD(Rsol(iso_HDO)) WRITE(*,*) 'deltaDsol_evap=',deltaD( & xtnu(iso_HDO,i)/qevap(i)) WRITE(*,*) 'h1(i),f=',h1(i),max((min(L, & (qsol_avant_evap(i)))-qevap(i)) & /min(L,(qsol_avant_evap(i))),0.0) stop endif endif !if (qsol(i).gt.ridicule_qsol) THEN endif !if (iso_HDO.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (qevap(i).gt.ridicule_evap) THEN CALL iso_verif_aberrant_o17(xtnu(iso_O17,i) & /qevap(i),xtnu(iso_O18,i)/qevap(i), & 'iso_surf_ter 1626') endif IF (sol_evap(i).gt.ridicule_evap) THEN CALL iso_verif_aberrant_o17(xtsol_evap(iso_O17,i) & /sol_evap(i),xtsol_evap(iso_O18,i)/sol_evap(i), & 'iso_surf_ter 1631') endif IF (qsol(i).gt.ridicule_qsol) THEN IF (iso_verif_aberrant_o17_nostop(xtsol(iso_O17,i) & /(qsol_avant_deversement(i)), & xtsol(iso_O18,i) & /(qsol_avant_deversement(i)), & 'iso_surf_ter 1623').EQ.1) THEN WRITE(*,*) 'i, qsol(i)=',i,qsol_avant_deversement(i) WRITE(*,*) 'qsol_avant_evap,qevap,L=', & qsol_avant_evap(i),qevap(i),L WRITE(*,*) 'o17excess_sol_avant_evap',o17excess( & (xtsol_avant_evap(iso_o17,i) & /qsol_avant_evap(i)),( & xtsol_avant_evap(iso_o18,i)/qsol_avant_evap(i))) WRITE(*,*) 'o17excess_sol_evap=',o17excess( & xtsol_evap(iso_o17,i)/sol_evap(i), & xtsol_evap(iso_o18,i)/sol_evap(i)) WRITE(*,*) 'h1(i),f=',h1(i),max((min(L, & (qsol_avant_evap(i)))-qevap(i)) & /min(L,(qsol_avant_evap(i))),0.0) WRITE(*,*) 'qsol_avant_evap,sol_evap,qsol,dt=', & qsol_avant_evap(i),sol_evap(i),& qsol_avant_deversement(i),dtime WRITE(*,*) 'qsol_avant_evap17,sol_evap17,qsol17=', & xtsol_avant_evap(iso_o17,i), & xtsol_evap(iso_o17,i),xtsol(iso_o17,i) WRITE(*,*) 'qsol_avant_evap18,sol_evap17,qsol18=', & xtsol_avant_evap(iso_o18,i), & xtsol_evap(iso_o18,i),xtsol(iso_o18,i) stop endif !if (iso_verif_aberrant_o17_nostop(xtsol(iso_O17,i) endif !if ((qsol(i).gt.ridicule).AND.(xtsol(iso_O18,i) endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #ifdef ISOTRAC CALL iso_verif_traceur(xtsol_evap(1,i), & 'calcul_iso_surf_ter 1558') #endif #endif ! end verif enddo !do icas_evap=1,ncas_evap ! traitement vectoriel du cas pas d'évap DO icas=1,ncas_noevap i=cas_noevap(icas) ! WRITE(*,*) 'calcul_iso_surf_oce 3175: pas d''évap' DO ixt=1,ntraciso xtsol_evap(ixt,i)=0.0 enddo DO ixt=1,niso xtsol(ixt,i)=xtsol_avant_evap(ixt,i) enddo !do ixt=1,niso enddo !do icas_evap=1,ncas_evap ! traitement vectoriel du cas rosée DO icas=1,ncas_rosee i=cas_rosee(icas) ! evap<0 -> on condense. ! WRITE(*,*) 'calcul_iso_surf_oce 3176: condense: sol_evap(i)=', ! : sol_evap(i) ! WRITE(*,*) 'calcul_iso_surf_ter 716: dtime=',dtime ! Mair=100*100/9.8 CALL iso_rosee_givre(xt1lay,q1lay,tsurf,t_coup, & sol_evap,i,xtsol_evap,klon) ! les traceurs d'eau sont déjà dans iso_rosee_givre ! sol_evap est le flux d'eau sortant de la première couche ! calcul de la rosée s'inflitrant dans le sol: ! sol_evap est divisé sans fractionnement en une partie ! dirigée vers le sol, et une partie partant en ruissellement IF (abs(sol_evap(i)).gt.0.0) THEN DO ixt=1,niso xtsol_evap_eff(ixt,i)=xtsol_evap(ixt,i) & /sol_evap(i)*sol_evap_eff(i) #ifdef ISOVERIF IF (iso_verif_noNaN_nostop(( & xtsol_evap_eff(ixt,i)),'iso_surf_ter 1790') & .EQ.1) THEN WRITE(*,*) 'xtsol_evap,sol_evap,sol_evap_eff=', & xtsol_evap(ixt,i),sol_evap(i),sol_evap_eff(i) stop endif !if (iso_verif_noNaN_nostop(( #endif enddo !do ixt=1,niso else ! if (sol_evap.gt.0.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite(sol_evap_eff(i),0.0, & 'iso_surf_ter 1862') #endif DO ixt=1,niso xtsol_evap_eff(ixt,i)=0.0 enddo !do ixt=1,niso endif !if (sol_evap.gt.0.0) THEN IF (ruissellement_pluie.EQ.1) THEN DO ixt=1,niso xtrun_off(ixt,i)=xtrun_off(ixt,i)+(xtsol_evap_eff(ixt,i) & -xtsol_evap(ixt,i))*dtime enddo runoff_tmp(i)=runoff_tmp(i) & +(sol_evap_eff(i)-sol_evap(i))*dtime endif !if (ruissellement_pluie.EQ.1) THEN #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN( & (xtsol_evap_eff(ixt,i)), & 'calcul_iso_surf_ter 1020') enddo !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix( & (xtsol_evap_eff(iso_eau,i)), & (sol_evap_eff(i)), & 'calcul_iso_surf_ter 1025', & errmax,errmaxrel) endif IF (iso_HDO.gt.0) THEN ! si il y a rosée, il faut que le flux d'isotopes soit ! aussi négatif CALL iso_verif_positif(-xtsol_evap(iso_hdo,i), & 'calcul_iso_surf_ter 1448') endif #endif ! calcul de la nouvelle composition du sol en prenant en ! compte la rsoée infiltrée DO ixt=1,niso xtsol(ixt,i)=xtsol_avant_evap(ixt,i) & -xtsol_evap_eff(ixt,i)*dtime enddo #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNAN(( & xtsol_avant_evap(ixt,i)), & 'calcul_iso_surf_ter 1826') CALL iso_verif_noNAN(( & xtsol_evap_eff(ixt,i)), & 'calcul_iso_surf_ter 1832') CALL iso_verif_noNAN(xtsol(ixt,i), & 'calcul_iso_surf_ter 1828') enddo !do ixt=1,niso #endif #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(xtsol(iso_eau,i), & (qsol_avant_deversement(i)), & 'calcul_iso_surf_ter 1967', & errmax,errmaxrel) CALL iso_verif_egalite_choix( & xtsol_evap(iso_eau,i), & sol_evap(i), & 'calcul_iso_surf_ter 771',errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (abs(evap(i)).gt.ridicule_evap) THEN CALL iso_verif_aberrant_o17(xtsol_evap(iso_O17,i) & /sol_evap(i),xtsol_evap(iso_O18,i) & /sol_evap(i),'calcul_iso_surf 1754') endif !if (qsol(i).gt.ridicule) THEN endif ! if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #endif enddo !do icas_evap=1,ncas_rosee ! deversement du trop plein ! seulement si c'est le sol qu'on fait ruisseller: IF (ruissellement_pluie.EQ.0) THEN DO i=1,knon IF (qsol_avant_deversement(i).gt.max_eau_sol) THEN DO ixt=1,niso xtrun_off(ixt,i)=run_off(i)*xtsol(ixt,i) & /qsol_avant_deversement(i) xtsol(ixt,i)=min(xtsol(ixt,i)/qsol_avant_deversement(i) & *max_eau_sol,max_eau_sol) #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(run_off(i), & xtrun_off(iso_eau,i),'calcul_iso_surf_ter 1774', & errmax,errmaxrel) endif #endif enddo else !if (qsol_avant_deversement(i).gt.max_eau_sol) THEN #ifdef ISOVERIF CALL iso_verif_egalite(run_off(i),0.0, & 'calcul_iso_surf_ter 1672') #endif DO ixt=1,niso xtrun_off(ixt,i)=0.0 enddo endif !if (qsol(i).gt.max_eau_sol) THEN enddo ! do i=1,knon ELSE IF (ruissellement_pluie.EQ.1) THEN ! on vérifie que rien ne déborde #ifdef ISOVERIF DO i=1,knon CALL iso_verif_positif_choix( & max_eau_sol-(qsol_avant_deversement(i)), & ridicule_qsol,'calcul_iso_surf_ter 935') IF (iso_eau.gt.0) THEN call iso_verif_egalite_choix(runoff_tmp(i), & xtrun_off(iso_eau,i),'calcul_iso_surf_ter 1794', & errmax,errmaxrel) endif !if (iso_eau.gt.0) THEN ! WRITE(*,*) 'tmp ter 1929: i,runoff_tmp,run_off=', ! : i,runoff_tmp(i),run_off(i) IF (iso_verif_egalite_choix_nostop(runoff_tmp(i), & run_off(i),'calcul_iso_surf_ter 1772', & errmax_sol*max(qsol_prec(i),1.0),errmaxrel).EQ.1) THEN ! il y a beaucoup d'inprecision associée à runoff, car dans ! LMDZ, runoff=qsol-max_eau_sol (cf fonte_neige). ! en R4, qsol a 6 chiffres significatifs après la virgule -> ! la precision sur le résultat ne peut pas être meilleure que ! 1e-5. WRITE(*,*) 'i,max_eau_sol=',i,max_eau_sol WRITE(*,*) 'qsol_prec=',qsol_prec(i) WRITE(*,*) 'precip_rain*dt=',precip_rain(i)*dtime WRITE(*,*) 'fq_fonte_neige=',fq_fonte_neige(i) WRITE(*,*) 'sol_evap*dt=',sol_evap(i)*dtime WRITE(*,*) 'precip_rain_eff*dt=',precip_rain_eff(i)*dtime WRITE(*,*) 'fq_fonte_neige_eff=',fq_fonte_neige_eff(i) WRITE(*,*) 'sol_evap_eff*dt=',sol_evap_eff(i)*dtime WRITE(*,*) 'qsol_avant_evap=',qsol_avant_evap(i) WRITE(*,*) 'qsol_avant_deversement=', & qsol_avant_deversement(i) WRITE(*,*) 'run_off=',run_off(i) WRITE(*,*) 'runoff_tmp=',runoff_tmp(i) ! WRITE(*,*) 'xtsol_prec=',xtsol_prec(iso_eau,i) ! WRITE(*,*) 'xtsol_avant_evap=',xtsol_avant_evap(iso_eau,i) ! WRITE(*,*) 'xtprecip_rain_eff=',xtprecip_rain_eff(iso_eau,i) ! WRITE(*,*) 'fxt_fonte_neige_eff=', ! : fxt_fonte_neige_eff(iso_eau,i) stop endif !if (iso_verif_egalite_choix_nostop enddo !do i=1,knon #endif ! rectification éventuelle du runoff DO i=1,knon IF (runoff_tmp(i).gt.0.0) THEN DO ixt=1,niso xtrun_off(ixt,i)=xtrun_off(ixt,i)/runoff_tmp(i)*run_off(i) enddo !do ixt=1,niso endif enddo #ifdef ISOVERIF DO i=1,knon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(run_off(i), & xtrun_off(iso_eau,i),'calcul_iso_surf_ter 1834', & errmax,errmaxrel) endif enddo !do i=1,knon #endif else WRITE(*,*) 'calcul_iso_surf 1764: option non valide:' WRITE(*,*) 'ruissellement_pluie=',ruissellement_pluie stop endif !if (ruissellement_pluie.EQ.0) THEN ! on en déduit l'évap vers l'atm: DO i=1,knon DO ixt=1,ntraciso xtevap(ixt,i)=xtsol_evap(ixt,i)+xtsnow_evap(ixt,i) enddo !do ixt=1,niso enddo !do i=1,knon ! verif #ifdef ISOVERIF DO i=1,knon DO ixt=1,niso CALL iso_verif_noNAN(xtsol_evap(ixt,i), & 'calcul_iso_surf_ter 800') CALL iso_verif_noNAN(xtsnow_evap(ixt,i), & 'calcul_iso_surf_ter 801') CALL iso_verif_noNAN(xtevap(ixt,i), & 'calcul_iso_surf_ter 802') CALL iso_verif_noNAN(xtsnow(ixt,i), & 'calcul_iso_surf_ter 803') CALL iso_verif_noNAN(xtsol(ixt,i), & 'calcul_iso_surf_ter 804') enddo !do ixt=1,niso enddo ! do i=1,knon #endif #ifdef ISOVERIF DO i=1,knon IF (iso_eau.gt.0) THEN IF (iso_verif_egalite_choix_nostop( & xtevap(iso_eau,i),evap(i), & 'calcul_iso_surf_ter 1059',errmax,errmaxrel) & .EQ.1) THEN WRITE(*,*) 'xtevap(iso_eau,i)=',xtevap(iso_eau,i) WRITE(*,*) 'evap(i)=',evap(i) WRITE(*,*) 'xtsol_evap(iso_eau,i)=', & xtsol_evap(iso_eau,i) WRITE(*,*) 'sol_evap(i)=',sol_evap(i) WRITE(*,*) 'xtsnow_evap(iso_eau,i)=', & xtsnow_evap(iso_eau,i) WRITE(*,*) 'snow_evap(i)=',snow_evap(i) stop endif CALL iso_verif_egalite_choix(xtsnow(iso_eau,i),snow(i), & 'calcul_iso_surf_ter 743',errmax,errmaxrel) CALL iso_verif_egalite_choix(xtsol(iso_eau,i),qsol(i), & 'calcul_iso_surf_ter 745',errmax,errmaxrel) CALL iso_verif_positif(max_eau_sol-qsol(i), & 'calcul_iso_surf_ter 746a') IF (iso_verif_positif_nostop( & max_eau_sol-xtsol(iso_eau,i), & 'calcul_iso_surf_ter 746b').EQ.1) THEN WRITE(*,*) 'i=',i WRITE(*,*) 'max_eau_sol=',max_eau_sol WRITE(*,*) 'qsol(i)=',qsol(i) WRITE(*,*) 'xtsol(iso_eau,i)=',xtsol(iso_eau,i) WRITE(*,*) 'qsol_avant_deversement(i)=', & qsol_avant_deversement(i) WRITE(*,*) 'precip_rain(i)=',precip_rain(i) WRITE(*,*) 'precip_rain_eff(i)=',precip_rain_eff(i) WRITE(*,*) 'fq_fonte_neige(i)=',fq_fonte_neige(i) WRITE(*,*) 'qsol_avant_evap(i)=',qsol_avant_evap(i) WRITE(*,*) 'qsol_prec(i)=',qsol_prec(i) WRITE(*,*) 'sol_evap(i)=',sol_evap(i) WRITE(*,*) 'xtprecip_rain(iso_eau,i)=', & xtprecip_rain(iso_eau,i) WRITE(*,*) 'xtprecip_rain_eff(iso_eau,i)=', & xtprecip_rain_eff(iso_eau,i) WRITE(*,*) 'xtsol_avant_evap(iso_eau,i)=', & xtsol_avant_evap(iso_eau,i) WRITE(*,*) 'xtsol_prec(iso_eau,i)=', & xtsol_prec(iso_eau,i) WRITE(*,*) 'xtsol_evap(iso_eau,i)=', & xtsol_evap(iso_eau,i) IF (xtsol(iso_eau,i)-max_eau_sol.gt.1e-9) THEN stop else xtsol(iso_eau,i)=min(xtsol(iso_eau,i), & max_eau_sol) endif endif endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(xtsnow(iso_HDO,i),snow(i), & ridicule_snow,deltalim_snow, 'calcul_iso_surf_ter 749') CALL iso_verif_aberrant_choix(xtsnow(iso_HDO,i), & snow(i),ridicule,deltalim_snow, & 'calcul_iso_surf_lic 1955') IF (evap(i).gt.ridicule_evap) THEN IF (iso_verif_aberrant_nostop( & xtevap(iso_HDO,i)/evap(i), & 'calcul_iso_surf_ter 751').EQ.1) THEN WRITE(*,*) 'i=',i WRITE(*,*) 'sol_evap,snow_evap=', & sol_evap(i),snow_evap(i) IF (sol_evap(i).gt.ridicule_evap)WRITE(*,*) 'deltaDsol_evap=', & deltaD(xtsol_evap(iso_hdo,i)/sol_evap(i)) IF (snow_evap(i).gt.ridicule_evap)WRITE(*,*) 'deltaDsnow_evap=', & deltaD(xtsnow_evap(iso_hdo,i)/snow_evap(i)) WRITE(*,*) 'deltaD1new=',deltaD( & (xtevap(iso_hdo,i)*dtime+q10*R1(iso_hdo)) & /(evap(i)*dtime+q10)) WRITE(*,*) 'deltaD1=', deltaD(R1(iso_hdo)) CALL iso_verif_aberrant( & (xtevap(iso_hdo,i)*dtime+q10*R1(iso_hdo)) & /(evap(i)*dtime+q10), & 'calcul_iso_surf_ter 1571') endif endif !if (evap(i).gt.ridicule_evap) THEN IF (iso_verif_aberrant_choix_nostop(xtevap(iso_HDO,i), & evap(i),ridicule,1e5,'calcul_iso_surf_ter 1578') & .EQ.1) THEN WRITE(*,*) 'i=',i WRITE(*,*) 'sol_evap,snow_evap=', & sol_evap(i),snow_evap(i) WRITE(*,*) 'deltaDsol_evap=', & deltaD(xtsol_evap(iso_hdo,i)/sol_evap(i)) WRITE(*,*) 'deltaDsnow_evap=', & deltaD(xtsnow_evap(iso_hdo,i)/snow_evap(i)) CALL iso_verif_aberrant( & (xtevap(iso_hdo,i)*dtime+q10*R1(iso_hdo)) & /(evap(i)*dtime+q10), & 'calcul_iso_surf_ter 1590') endif IF (qsol(i).gt.ridicule_qsol*1e2) THEN CALL iso_verif_aberrant(xtsol(iso_HDO,i)/qsol(i) & /faccond,'calcul_iso_surf_ter 752') endif !if (qsol(i).gt.ridicule_qsol) THEN endif !if (iso_eau.gt.0) THEN IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF (abs(evap(i)).gt.ridicule_qsol) THEN CALL iso_verif_aberrant_o17(xtevap(iso_O17,i) & /evap(i),xtevap(iso_O18,i) & /evap(i),'iso_surf_ter 1827') endif !if ((evap(i).gt.ridicule).AND.(xtevap(iso_O18,i) endif !if ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN #ifdef ISOTRAC CALL iso_verif_tracnps(xtevap(1,i), & 'calcul_iso_surf_ter 1847') #endif enddo !do i=1,knon #endif IF ((bidouille_anti_divergence).AND.(iso_eau.gt.0)) THEN DO i=1,knon xtsol(iso_eau,i)=qsol(i) enddo !do i=1,knon endif #ifdef ISOVERIF ! verif du bilan de masse d'eau et d'isotopes pour le sol DO i=1,knon dqdiag=precip_rain(i)*dtime+fq_fonte_neige(i) & -(evap(i)-snow_evap(i))*dtime-run_off(i) IF (iso_verif_egalite_choix_nostop(dqdiag, & qsol(i)-qsol_prec(i),'ter 2087', & errmax_sol*max(qsol(i),1.0),errmaxrel).EQ.1) THEN WRITE(*,*) 'calcul_iso_surf_ter 2050: bilan qsol,i=',i WRITE(*,*) 'qsol(i)=',qsol(i) WRITE(*,*) 'qsol_prec(i)=',qsol_prec(i) WRITE(*,*) 'precip_rain(i)*dt=',precip_rain(i)*dtime WRITE(*,*) 'fq_fonte_neige(i)=',fq_fonte_neige(i) WRITE(*,*) 'evap(i)*dt=',evap(i)*dtime WRITE(*,*) 'snow_evap(i)*dt=',snow_evap(i)*dtime WRITE(*,*) 'run_off(i) (diag)=',run_off(i) WRITE(*,*) 'runoff_tmp(i)=',runoff_tmp(i) stop endif !if (iso_verif_egalite_choix_nostop(dqdiag, IF (evap_cont_cste.NE.1) THEN ! si evap_cont_cste=1, on prescrit compo de l'évap du sol ! -> normal de ne pas conserver la masse d'isotopes DO ixt=1,niso dqdiag=xtprecip_rain(ixt,i)*dtime+fxt_fonte_neige(ixt,i) & -(xtevap(ixt,i)-xtsnow_evap(ixt,i))*dtime & -xtrun_off(ixt,i) IF (iso_verif_egalite_choix_nostop(dqdiag, & xtsol(ixt,i)-xtsol_prec(ixt,i),'ter 1887', & errmax_sol*max(qsol(i),1.0),errmaxrel).EQ.1) THEN WRITE(*,*) 'calcul_iso_surf_ter 2066: bilan xtsol, ixt=', & ixt WRITE(*,*) 'xtsol(ixt,i)=',xtsol(ixt,i) WRITE(*,*) 'xtsol_prec(i)=',xtsol_prec(ixt,i) WRITE(*,*) 'xtprecip_rain(i)*dt=',xtprecip_rain(ixt,i) & *dtime WRITE(*,*) 'fxt_fonte_neige(i)=',fxt_fonte_neige(ixt,i) WRITE(*,*) 'xtevap(i)*dt=',xtevap(ixt,i)*dtime WRITE(*,*) 'xtsnow_evap(i)*dt=',xtsnow_evap(ixt,i)*dtime WRITE(*,*) 'xtrun_off(i)=',xtrun_off(ixt,i) WRITE(*,*) 'i=',i WRITE(*,*) 'qsol(i)=',qsol(i) WRITE(*,*) 'qsol_prec(i)=',qsol_prec(i) WRITE(*,*) 'precip_rain(i)*dt=',precip_rain(i)*dtime WRITE(*,*) 'fq_fonte_neige(i)=',fq_fonte_neige(i) WRITE(*,*) 'evap(i)*dt=',evap(i)*dtime WRITE(*,*) 'snow_evap(i)*dt=',snow_evap(i)*dtime WRITE(*,*) 'run_off(i) (diag)=',run_off(i) WRITE(*,*) 'runoff_tmp(i)=',runoff_tmp(i) IF (qsol_prec(i).gt.-ridicule) THEN stop ! sinon, si qsolprec<0, on fait compo du sol=compo des ! inputs pour éviyer deltaD aberrants -> masse pas tout ! à fait conservée. On croise les doigts pour que ce ! cas pathologique arrive rarement. endif endif enddo endif !if (evap_cont_cste.NE.1) THEN enddo !do i=1,knon #endif ! on rescale le runoff pour qu'il soit en kg/m2/s DO i=1,knon run_off(i)=run_off(i)/dtime runoff_tmp(i)=runoff_tmp(i)/dtime DO ixt=1,niso xtrun_off(ixt,i)=xtrun_off(ixt,i)/dtime enddo !do ixt=1,niso enddo !do i=1,knon END SUBROUTINE calcul_iso_surf_ter_vectall !*** SUBROUTINE phyisoetat0(snow,run_off_lic_0, & xtsnow,xtrun_off_lic_0, & Rland_ice) USE dimphy, ONLY: klon,klev !USE lmdz_grid_phy !USE lmdz_phys_para USE iophy USE phys_state_var_mod, ONLY: q_ancien,xt_ancien,wake_deltaq,wake_deltaxt, & xtrain_fall,xtsnow_fall, ql_ancien,xtl_ancien,qs_ancien,xts_ancien, & rain_fall,snow_fall,fevap,fxtevap,xtsol,qsol !USE iostart, ONLY: close_startphy, get_field, get_var, open_startphy !USE lmdz_writefield_phy USE indice_sol_mod, ONLY: nbsrf USE isotopes_mod, ONLY: initialisation_iso, iso_eau,iso_HDO, & ridicule_qsol,tnat, P_veg,iso_O18,ridicule, ridicule_snow,iso_O17, & iso_HTO USE lmdz_clesphys USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! equivalent de phyetat0 pour les isotopes include "dimsoil.h" !#ifdef ISOVERIF ! real deltaD !#endif ! arguments !real xtsol(niso,klon) REAL xtsnow(niso,klon,nbsrf) !real xtevap(ntraciso,klon,nbsrf) REAL xtrun_off_lic_0(niso,klon) REAL Rland_ice(niso,klon) !REAL qsol(klon) REAL snow(klon,nbsrf) !REAL evap(klon,nbsrf) REAL run_off_lic_0(klon) ! locals INTEGER ixt,i,k,nsrf ! CHARACTER*50 text ! WRITE(*,*) 'phyisoetat0 20: fichnom=',fichnom WRITE(*,*) 'initialisation_iso=',initialisation_iso IF (initialisation_iso.EQ.0) THEN CALL phyiso_etat0_fichier( & snow,run_off_lic_0, & xtsnow,xtrun_off_lic_0, & Rland_ice) else WRITE(*,*) 'phyisoetat0 57:' WRITE(*,*) 'initialisation_iso=',initialisation_iso ! stop CALL phyiso_etat0_dur( & xtsnow, & xtrun_off_lic_0, Rland_ice, & snow,run_off_lic_0) endif ! verif #ifdef ISOVERIF DO i=1,klon DO ixt=1,niso CALL iso_verif_noNaN(xtsol(ixt,i),'phyisoetat0 753') CALL iso_verif_noNaN(xtrain_fall(ixt,i),'phyisoetat0 754') CALL iso_verif_noNaN(xtsnow_fall(ixt,i),'phyisoetat0 755') CALL iso_verif_noNaN(xtrun_off_lic_0(ixt,i),'phyisoetat0 756') enddo !do ixt=1,niso enddo !do i=1,klon DO i=1,klon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite(xtsol(iso_eau,i),qsol(i), & 'phyisoetat0 759') CALL iso_verif_egalite(xtrain_fall(iso_eau,i),rain_fall(i), & 'phyisoetat0 760') CALL iso_verif_egalite(xtsnow_fall(iso_eau,i),snow_fall(i), & 'phyisoetat0 761') CALL iso_verif_egalite(xtrun_off_lic_0(iso_eau,i), & run_off_lic_0(i), 'phyisoetat0 762') endif !if (iso_eau.gt.0) THEN DO k=1,klev DO ixt=1,niso CALL iso_verif_noNaN(xt_ancien(ixt,i,k), & 'phyisoetat0 771a') CALL iso_verif_noNaN(xtl_ancien(ixt,i,k), & 'phyisoetat0 771b') CALL iso_verif_noNaN(xts_ancien(ixt,i,k), & 'phyisoetat0 771c') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite(xt_ancien(iso_eau,i,k), & q_ancien(i,k),'phyisoetat0 775a') CALL iso_verif_egalite(xtl_ancien(iso_eau,i,k), & ql_ancien(i,k),'phyisoetat0 775b') CALL iso_verif_egalite(xts_ancien(iso_eau,i,k), & qs_ancien(i,k),'phyisoetat0 775c') endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (q_ancien(i,k).gt.2e-3) THEN ! WRITE(*,*) 'i,k=',i,k CALL iso_verif_aberrant(xt_ancien(iso_hdo,i,k) & /q_ancien(i,k),'phyisoetat0 103a') endif !if (q_ancien(i,k).gt.2e-3) THEN IF (ql_ancien(i,k).gt.2e-3) THEN CALL iso_verif_positif(xtl_ancien(iso_hdo,i,k) & /ql_ancien(i,k),'phyisoetat0 103b') endif !if (q_ancien(i,k).gt.2e-3) THEN IF (qs_ancien(i,k).gt.2e-3) THEN CALL iso_verif_positif(xts_ancien(iso_hdo,i,k) & /qs_ancien(i,k),'phyisoetat0 103c') endif !if (q_ancien(i,k).gt.2e-3) THEN endif !if (iso_HDO.gt.0) THEN #ifdef ISOTRAC CALL iso_verif_traceur(xt_ancien(1,i,k), & 'phyisoetat0 111a') CALL iso_verif_traceur(xtl_ancien(1,i,k), & 'phyisoetat0 111b') CALL iso_verif_traceur(xts_ancien(1,i,k), & 'phyisoetat0 111c') #endif enddo !do k=1,klev DO nsrf=1,nbsrf DO ixt=1,niso CALL iso_verif_noNAN(xtsnow(ixt,i,nsrf), & 'phyisoetat0 781') CALL iso_verif_noNAN(fxtevap(ixt,i,nsrf), & 'phyisoetat0 783') enddo !do ixt=1,niso #ifdef ISOTRAC CALL iso_verif_traceur_justmass(fxtevap(1,i,nsrf), & 'phyisoetat0 123') #endif IF (iso_eau.gt.0) THEN CALL iso_verif_egalite(xtsnow(iso_eau,i,nsrf),snow(i,nsrf), & 'phyisoetat0 787') CALL iso_verif_egalite(fxtevap(iso_eau,i,nsrf),fevap(i,nsrf), & 'phyisoetat0 75') endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(xtsnow(iso_hdo,i,nsrf),snow(i,nsrf), & ridicule_snow, deltalim_snow, 'phyisoetat0 117') endif !if (iso_eau.gt.0) THEN enddo !do nsrf=1,nbsrf enddo !do i=1,klon DO i=1,klon IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF ((qsol(i).gt.ridicule_qsol).AND.(xtsol(iso_O18,i) & .gt.ridicule_qsol*tnat(iso_o18))) THEN CALL iso_verif_aberrant_o17(xtsol(iso_O17,i) & /qsol(i),xtsol(iso_O18,i) & /qsol(i),'phyisoetat0 123') endif endif enddo !do i=1,klon #endif !end verif ! pour le tritium: initialisation des tableaux d'essais nucléaires: IF (iso_HTO.gt.0) THEN CALL table_tritium_nucl() endif END SUBROUTINE phyisoetat0 SUBROUTINE phyiso_etat0_dur( & xtsnow, & xtrun_off_lic_0, Rland_ice, & snow,run_off_lic_0) USE dimphy, ONLY: klon,klev !USE lmdz_grid_phy !USE lmdz_phys_para USE iophy USE phys_state_var_mod, ONLY: q_ancien,xt_ancien,wake_deltaq,wake_deltaxt, & xtrain_fall,xtsnow_fall,rain_fall,snow_fall, ql_ancien,xtl_ancien,qs_ancien,xts_ancien, & fevap,fxtevap,xtsol,qsol !USE iostart !USE lmdz_writefield_phy USE indice_sol_mod, ONLY: nbsrf USE isotopes_mod, ONLY: tnat,iso_HDO,iso_O18,iso_HTO, iso_eau,toce, & & Rdefault,iso_O17,ridicule,ridicule_qsol USE lmdz_clesphys USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree #ifdef ISOVERIF USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: index_iso,index_zone,izone_init #endif IMPLICIT NONE include "dimsoil.h" ! arguments !integer niso !real xtsol(niso,klon) REAL xtsnow(niso,klon,nbsrf) !real xtevap(ntraciso,klon,nbsrf) REAL xtrun_off_lic_0(niso,klon) REAL Rland_ice(niso,klon) !REAL qsol(klon) REAL snow(klon,nbsrf) !REAL evap(klon,nbsrf) REAL run_off_lic_0(klon) !locals INTEGER ixt, k, i, nsrf REAL deltaD_rain_fall(niso) REAL deltaD_snow_fall(niso) REAL deltaD_snow(niso) REAL deltaD_land_ice(niso) REAL deltaD_sol(niso) REAL deltaD_run_off_lic_0(niso) REAL deltaD_evap(niso) REAL RMerlivat(niso) ! constes REAL deltaD_snow_fall_O18,deltaD_rain_fall_O18 REAL alpha(niso),kcin(niso) ! CHARACTER*50 text ! initialisation des isotopes ! 1. initialisation de la neige qui tombe ! 2. initialisation de la pluie deltaD_snow_fall_O18=-20. deltaD_rain_fall_O18=-5. IF (iso_HTO.gt.0) THEN deltaD_snow_fall(iso_HTO)=-1000. deltaD_rain_fall(iso_HTO)=-1000. endif IF (iso_O18.gt.0) THEN deltaD_snow_fall(iso_O18)=deltaD_snow_fall_O18 deltaD_rain_fall(iso_O18)=deltaD_rain_fall_O18 endif IF (iso_O17.gt.0) THEN deltaD_snow_fall(iso_O17)=(exp(25.0/1e6) & *(deltaD_snow_fall_O18/1000.0+1.0)**0.528 & -1.0)*1000.0 deltaD_rain_fall(iso_O17)=(exp(25.0/1e6) & *(deltaD_rain_fall_O18/1000.0+1.0)**0.528 & -1.0)*1000.0 endif IF (iso_HDO.gt.0) THEN deltaD_snow_fall(iso_HDO)=deltaD_snow_fall_O18*8.0+10.0 deltaD_rain_fall(iso_HDO)=deltaD_rain_fall_O18*8.0+10. endif IF (iso_eau.gt.0) THEN deltaD_snow_fall(iso_eau)=0. deltaD_rain_fall(iso_eau)=0. endif DO ixt=1,niso deltaD_snow(ixt)=deltaD_snow_fall(ixt) deltaD_sol(ixt)=deltaD_rain_fall(ixt) deltaD_evap(ixt)=deltaD_sol(ixt) deltaD_run_off_lic_0(ixt)=deltaD_sol(ixt) deltaD_land_ice(ixt)=deltaD_snow(ixt) CALL fractcalk_liq(ixt, 283.0, alpha(ixt)) enddo !do ixt=1,niso CALL calcul_kcin(2.0,kcin) DO i=1,klon DO ixt=1,niso xtsnow_fall(ixt,i)=snow_fall(i) & *tnat(ixt)*(deltaD_snow_fall(ixt)/1000.0+1.0) enddo DO ixt=1,niso xtrain_fall(ixt,i)=rain_fall(i) & *tnat(ixt)*(deltaD_rain_fall(ixt)/1000.0+1.0) enddo enddo !do i=1,klon #ifdef ISOTRAC DO i=1,klon DO ixt=niso+1,ntraciso IF (index_zone(ixt).EQ.izone_init) THEN xtrain_fall(ixt,i)=rain_fall(i) & *tnat(index_iso(ixt)) & *(deltaD_rain_fall(index_iso(ixt))/1000.0+1.0) xtsnow_fall(ixt,i)=snow_fall(i) & *tnat(index_iso(ixt)) & *(deltaD_snow_fall(index_iso(ixt))/1000.0+1.0) else xtsnow_fall(ixt,i)=0.0 xtrain_fall(ixt,i)=0.0 endif enddo !do ixt=niso+1,ntraciso enddo !do i=1,klon #endif ! 3. initialisation de la neige au sol DO i=1,klon DO nsrf=1,nbsrf DO ixt=1,niso xtsnow(ixt,i,nsrf)=snow(i,nsrf) & *tnat(ixt)*(deltaD_snow(ixt)/1000+1) enddo enddo !do nsrf=1,nbsrf enddo !do i=1,klon ! 4. initialisation du sol DO i=1,klon DO ixt=1,niso xtsol(ixt,i)=qsol(i) & *tnat(ixt)*(deltaD_sol(ixt)/1000.0+1) enddo enddo !do i=1,klon ! verif #ifdef ISOVERIF DO i=1,klon IF (iso_eau.gt.0) THEN CALL iso_verif_egalite(xtsol(iso_eau,i),qsol(i), & 'phyiso_etat0_dur 74') endif enddo !do i=1,klon #endif ! end verif ! 5. initialisation de l'évaporation DO i=1,klon DO nsrf=1,nbsrf DO ixt=1,niso fxtevap(ixt,i,nsrf)=fevap(i,nsrf) & *tnat(ixt)*(deltaD_evap(ixt)/1000+1) enddo #ifdef ISOTRAC DO ixt=niso+1,ntraciso IF (index_zone(ixt).EQ.izone_init) THEN fxtevap(ixt,i,nsrf)=fevap(i,nsrf) & *tnat(index_iso(ixt)) & *(deltaD_evap(index_iso(ixt))/1000.0+1.0) else fxtevap(ixt,i,nsrf)=0.0 endif enddo !do ixt=niso+1,ntraciso #endif enddo !do nsrf=1,nbsrf enddo !do i=1,klon ! 6. initialisation de xtrun_off_lic0 DO i=1,klon DO ixt=1,niso xtrun_off_lic_0(ixt,i)=run_off_lic_0(i) & *tnat(ixt)*(deltaD_run_off_lic_0(ixt)/1000.0+1.0) enddo enddo !do i=1,klon ! 7. initialisation de xt_ancien et wake_deltaxt DO i=1,klon DO k=1,klev DO ixt=1,niso CALL iso_init_ideal(q_ancien(i,k),xt_ancien(ixt,i,k),ixt, & alpha(ixt),kcin(ixt),toce(ixt)) IF (q_ancien(i,k).gt.ridicule) THEN xtl_ancien(ixt,i,k)=ql_ancien(i,k)*alpha(ixt) & *xt_ancien(ixt,i,k)/q_ancien(i,k) xts_ancien(ixt,i,k)=qs_ancien(i,k)*alpha(ixt) & *xt_ancien(ixt,i,k)/q_ancien(i,k) else !if (q_ancien(i,k).gt.ridicule) THEN xtl_ancien(ixt,i,k)=ql_ancien(i,k)*Rdefault(ixt) xts_ancien(ixt,i,k)=qs_ancien(i,k)*Rdefault(ixt) endif !if (q_ancien(i,k).gt.ridicule) THEN enddo !do ixt=1,niso #ifdef ISOVERIF DO ixt=1,niso CALL iso_verif_noNaN(xt_ancien(ixt,i,k), & 'phyisoetat0 16062') CALL iso_verif_noNaN(xtl_ancien(ixt,i,k), & 'phyisoetat0 16063') CALL iso_verif_noNaN(xts_ancien(ixt,i,k), & 'phyisoetat0 16067') enddo !do ixt=1,niso ! Camille 7 mars 2023: ajout d'un check IF ((i.EQ.1).AND.(k.EQ.1).AND.(iso_HDO.gt.0)) THEN WRITE(*,*) 'phyisoetat0 16362: q_ancien(1,1)=',q_ancien(1,1) WRITE(*,*) 'deltaD_ancien=',deltaD(xt_ancien(iso_HDO,i,k)/q_ancien(i,k)) WRITE(*,*) 'xt_ancien(:,i,k)=',xt_ancien(:,i,k) endif !if ((i.EQ.1).AND.(k.EQ.1)) THEN IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0)) THEN IF (q_ancien(i,k).gt.ridicule) THEN IF (iso_verif_o18_aberrant_nostop( & xt_ancien(iso_HDO,i,k)/q_ancien(i,k), & xt_ancien(iso_O18,i,k)/q_ancien(i,k), & 'phyisoetat0 16366 q_ancien').EQ.1) THEN WRITE(*,*) 'phyisoetat0 16367: i,k,q_ancien(i,k)=',i,k,q_ancien(i,k) WRITE(*,*) 'xt_ancien(:,i,k)=',xt_ancien(:,i,k) stop endif ! if (iso_verif_o18_aberrant_nostop endif !if (q_seri(i,k).gt.errmax) THEN endif !if ((iso_HDO.gt.0).AND.(iso_O18.gt.0)) THEN #endif #ifdef ISOTRAC DO ixt=niso+1,ntraciso IF (index_zone(ixt).EQ.izone_init) THEN xt_ancien(ixt,i,k)=xt_ancien(index_iso(ixt),i,k) xtl_ancien(ixt,i,k)=xtl_ancien(index_iso(ixt),i,k) xts_ancien(ixt,i,k)=xts_ancien(index_iso(ixt),i,k) else xt_ancien(ixt,i,k)=0.0 xtl_ancien(ixt,i,k)=0.0 xts_ancien(ixt,i,k)=0.0 endif enddo !do ixt=niso+1,ntraciso #endif enddo !do k=1,klev enddo ! do i=1,klon ! 7bis: wake_deltaxt DO i=1,klon DO k=1,klev IF (q_ancien(i,k).gt.ridicule) THEN DO ixt=1,niso wake_deltaxt(ixt,i,k)=xt_ancien(ixt,i,k)/q_ancien(i,k) & *wake_deltaq(i,k) enddo !do ixt=1,niso else !if (q_ancien(i,k).gt.ridicule) THEN DO ixt=1,niso wake_deltaxt(ixt,i,k)=Rdefault(ixt)*wake_deltaq(i,k) enddo !do ixt=1,niso endif !if (q_ancien(i,k).gt.ridicule) THEN #ifdef ISOTRAC DO ixt=niso+1,ntraciso IF (index_zone(ixt).EQ.izone_init) THEN wake_deltaxt(ixt,i,k)=wake_deltaxt(index_iso(ixt),i,k) else wake_deltaxt(ixt,i,k)=0.0 endif enddo !do ixt=niso+1,ntraciso #endif #ifdef ISOVERIF DO ixt=1,ntraciso CALL iso_verif_noNaN(wake_deltaxt(ixt,i,k), & 'phyiso_etat0_dur 288a') enddo !do ixt=1,niso #endif enddo !do k=1,klev enddo ! do i=1,klon ! 8. initialisation de la composition des glaciers DO i=1,klon DO ixt=1,niso Rland_ice(ixt,i)= & tnat(ixt)*(deltaD_snow(ixt)/1000.0+1.0) enddo enddo !do i=1,klon #ifdef ISOVERIF WRITE(*,*) 'phyisoetat0 16468: verif init dure' DO i=1,klon DO ixt=1,niso CALL iso_verif_noNAN(xtsol(ixt,i),'phyiso_etat0_dur 753') CALL iso_verif_noNAN(xtrain_fall(ixt,i),'phyiso_etat0_dur 754') CALL iso_verif_noNAN(xtsnow_fall(ixt,i),'phyiso_etat0_dur 755') CALL iso_verif_noNAN(xtrun_off_lic_0(ixt,i), & 'phyiso_etat0_dur 756') CALL iso_verif_noNAN(Rland_ice(ixt,i),'phyiso_etat0_dur 757') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite(xtsol(iso_eau,i),qsol(i), & 'phyiso_etat0_dur 759') CALL iso_verif_egalite(xtrain_fall(iso_eau,i),rain_fall(i), & 'phyiso_etat0_dur 760') CALL iso_verif_egalite(xtsnow_fall(iso_eau,i),snow_fall(i), & 'phyiso_etat0_dur 761') CALL iso_verif_egalite(xtrun_off_lic_0(iso_eau,i), & run_off_lic_0(i), 'phyiso_etat0_dur 762') CALL iso_verif_egalite(Rland_ice(iso_eau,i), & 1.0, 'phyiso_etat0_dur 763') endif !if (iso_eau.gt.0) THEN DO k=1,klev DO ixt=1,niso ! WRITE(*,*) 'ixt,i,k=',ixt,i,k CALL iso_verif_noNAN(xt_ancien(ixt,i,k), & 'phyiso_etat0_dur 771') CALL iso_verif_noNAN(wake_deltaxt(ixt,i,k), & 'phyiso_etat0_dur 240') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite(xt_ancien(iso_eau,i,k), & q_ancien(i,k),'phyiso_etat0_dur 775a') endif !if (iso_eau.gt.0) THEN IF (iso_HDO.gt.0) THEN IF (q_ancien(i,k).gt.ridicule) THEN CALL iso_verif_aberrant_encadre( & xt_ancien(iso_hdo,i,k)/q_ancien(i,k), & 'phyiso_etat0_dur 775b') endif !if (q_ancien(i,k).gt.ridicule) THEN endif !if (iso_HDO.gt.0) THEN IF ((iso_HDO.gt.0).AND.(iso_O18.gt.0)) THEN IF (q_ancien(i,k).gt.ridicule) THEN CALL iso_verif_O18_aberrant( & xt_ancien(iso_hdo,i,k)/q_ancien(i,k), & xt_ancien(iso_O18,i,k)/q_ancien(i,k), & 'phyiso_etat0_dur 775c') endif ! if (q_ancien(i,k).gt.ridicule) THEN endif ! if ((iso_HDO.gt.0).AND.(iso_O18.gt.0)) THEN enddo !do k=1,klev DO nsrf=1,nbsrf DO ixt=1,niso CALL iso_verif_noNAN(xtsnow(ixt,i,nsrf), & 'phyiso_etat0_dur 781') CALL iso_verif_noNAN(fxtevap(ixt,i,nsrf), & 'phyiso_etat0_dur 783') enddo !do ixt=1,niso IF (iso_eau.gt.0) THEN CALL iso_verif_egalite(xtsnow(iso_eau,i,nsrf),snow(i,nsrf), & 'phyiso_etat0_dur 787') CALL iso_verif_egalite(fxtevap(iso_eau,i,nsrf),fevap(i,nsrf), & 'phyiso_etat0_dur 789') endif !if (iso_eau.gt.0) THEN enddo !do nsrf=1,nbsrf IF ((iso_O17.gt.0).AND.(iso_O18.gt.0)) THEN IF ((qsol(i).gt.ridicule_qsol).AND.(xtsol(iso_O18,i) & .gt.ridicule_qsol*tnat(iso_o18))) THEN CALL iso_verif_aberrant_o17(xtsol(iso_O17,i) & /qsol(i),xtsol(iso_O18,i) & /qsol(i),'phyisoeta0 193') endif endif #ifdef ISOTRAC DO nsrf=1,nbsrf CALL iso_verif_traceur_justmass(fxtevap(1,i,nsrf), & 'phyiso_etat0_dur 231') enddo !do nsrf=1,nbsrf DO k=1,klev CALL iso_verif_traceur(xt_ancien(1,i,k), & 'phyiso_etat0_dur 236') enddo !do k=1,klev CALL iso_verif_traceur(xtrain_fall(1,i), & 'phyiso_etat0_dur 238') CALL iso_verif_traceur(xtsnow_fall(1,i), & 'phyiso_etat0_dur 241') #endif enddo !do i=1,klon #endif END SUBROUTINE phyiso_etat0_dur SUBROUTINE phyiso_etat0_fichier(snow, run_off_lic_0, xtsnow, xtrun_off_lic_0, Rland_ice) USE dimphy, ONLY: klon,klev USE iophy USE phys_state_var_mod, ONLY: q_ancien, xt_ancien, wake_deltaq, wake_deltaxt, & #ifdef ISOVERIF rain_fall, snow_fall, fevap,qsol, & #endif xtrain_fall, xtsnow_fall, ql_ancien, xtl_ancien, qs_ancien, xts_ancien, fxtevap, xtsol USE indice_sol_mod, ONLY: nbsrf USE isotopes_mod, ONLY: isoName,iso_HDO,iso_eau USE phyetat0_get_mod, ONLY: phyetat0_get, phyetat0_srf USE infotrac_phy, ONLY: new2oldH2O USE lmdz_strings, ONLY: strIdx, strHead, strTail, maxlen, msg, int2str #ifdef ISOVERIF USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: strtrac, initialisation_isotrac, index_iso, index_zone, izone_init #endif USE lmdz_clesphys USE lmdz_compbl, ONLY: iflag_pbl, iflag_pbl_split, iflag_order2_sollw, ifl_pbltree IMPLICIT NONE include "dimsoil.h" REAL, INTENT(IN) :: snow (klon,nbsrf) REAL, INTENT(IN) :: run_off_lic_0 (klon) REAL, INTENT(OUT) :: xtsnow(niso,klon,nbsrf) REAL, INTENT(OUT) :: xtrun_off_lic_0(niso,klon) REAL, INTENT(OUT) :: Rland_ice(niso,klon) INTEGER :: ierr, i, ixt, k, nsrf, nid, nvarid, lnblnk CHARACTER(LEN=2) :: str2 CHARACTER(LEN=5) :: str5 CHARACTER(LEN=maxlen) :: outiso, oldIso, modname, nam(3), oldIso2 REAL :: xmin, xmax LOGICAL :: found #ifdef ISOTRAC INTEGER :: iiso, izone #endif modname = 'phyiso_etat0_fichier' CALL msg('3', modname) CALL msg('niso = '//TRIM(int2str(niso)), modname) CALL msg('isoName(1) = '//TRIM(isoName(1)), modname) DO ixt = 1, ntraciso outiso = isoName(ixt) oldIso = strTail(new2oldH2O(outiso), '_') !--- Remove "H2O_" from "H2O_[_]" oldIso2= TRIM(strHead(outiso,'_'))//strTail(outiso,'_') ! CR 2023: most recent possibility ! WRITE(*,*) 'tmp 16541:' ! WRITE(*,*) 'outiso=',outiso ! WRITE(*,*) 'oldIso=',oldIso ! WRITE(*,*) 'oldIso2=',oldIso2 ! on lit seulement si ixt<=niso ou si on initialise les traceurs d'après fichier: #ifdef ISOTRAC IF(ixt <= niso .OR. initialisation_isotrac == 0) THEN #endif found = phyetat0iso_srf3(fxtevap, "XTEVAP", "evaporation", 0.) IF (.NOT.found) CALL abort_physic('isotopes_routines_mod', 'phyiso_etat0_fichier 16581a: unfound isotopic variable',1) found = phyetat0iso_get2(xtrain_fall, "xtrain_f", "xrain fall", 0.) found = phyetat0iso_get2(xtsnow_fall, "xtsnow_f", "xsnow fall", 0.) found = phyetat0iso_get3(xt_ancien, "XTANCIEN", "QANCIEN", 0.) found = phyetat0iso_get3(xtl_ancien, "XTLANCIEN", "QLANCIEN", 0.) found = phyetat0iso_get3(xts_ancien, "XTSANCIEN", "QSANCIEN", 0.) found = phyetat0iso_get3(wake_deltaxt, "WAKE_DELTAXT", "Delta hum. wake/env", 0.) #ifdef ISOVERIF IF(ixt == iso_eau .AND. iso_eau > 0) THEN DO i=1,klon CALL iso_verif_egalite(xtrain_fall(iso_eau,i),rain_fall(i),TRIM(modname)//' 231a') CALL iso_verif_egalite(xtsnow_fall(iso_eau,i),snow_fall(i),TRIM(modname)//' 231b') DO nsrf = 1, nbsrf CALL iso_verif_egalite(fxtevap(iso_eau,i,nsrf),fevap(i,nsrf),TRIM(modname)//' 231c') END DO END DO END IF IF(ixt == iso_HDO .AND. iso_HDO > 0) THEN DO k=1,klev DO i=1,klon IF(q_ancien(i,k) > 2e-3) & CALL iso_verif_aberrant(xt_ancien(iso_hdo,i,k)/q_ancien(i,k),TRIM(modname)//' 312') END DO END DO END IF #endif ! ces variables n'ont pas de traceurs: IF(ixt <= niso) THEN found = phyetat0iso_get2(xtsol, "XTSOL", "Surface humidity / bucket", 0.) IF (.NOT.found) CALL abort_physic('isotopes_routines_mod', 'phyiso_etat0_fichier 16581b: unfound isotopic variable',1) found = phyetat0iso_get2(Rland_ice, "Rland_ice", "SR land ice", 0.) found = phyetat0iso_srf3(xtsnow, "XTSNOW", "Surface snow", 0.) ! CR avril 2023: deplacer ici found = phyetat0iso_get2(xtrun_off_lic_0, "XTRUNOFFLIC0", "RUNOFFLIC0", 0.) #ifdef ISOVERIF DO i=1,klon IF(iso_verif_noNaN_nostop(xtsol(ixt,i),TRIM(modname)//' 95') == 1) THEN WRITE(*,*) 'ixt,i=',ixt,i STOP END IF IF(ixt == iso_eau .AND. iso_eau > 0) THEN DO nsrf = 1, nbsrf CALL iso_verif_egalite(fxtevap(iso_eau,i,nsrf),fevap(i,nsrf),TRIM(modname)//' 231c') CALL iso_verif_egalite( xtsnow(iso_eau,i,nsrf), snow(i,nsrf),TRIM(modname)//' 231d') END DO CALL iso_verif_egalite( xtrun_off_lic_0(iso_eau,i), run_off_lic_0(i),TRIM(modname)//' 231e') ENDIF !IF(ixt == iso_eau .AND. iso_eau > 0) THEN END DO !DO i=1,klon #endif END IF #ifdef ISOTRAC END IF ! IF(ixt > niso .OR. initialisation_isotrac == 0)) #endif END DO #ifdef ISOTRAC IF(initialisation_isotrac /= 0) THEN ! On n'initialise pas d'apres le fichier. L'eau normale est mise dans la zone izone_init DO ixt=niso+1,ntraciso iiso=index_iso(ixt) IF(index_zone(ixt) == izone_init) THEN DO i = 1, klon fxtevap(ixt,i,1:nbsrf) = fxtevap(iiso,i,1:nbsrf) xtsnow_fall(ixt,i) = xtsnow_fall(iiso,i) xtrain_fall(ixt,i) = xtrain_fall(iiso,i) DO k = 1, klev xt_ancien (ixt,i,k) = xt_ancien (iiso,i,k) xtl_ancien (ixt,i,k) = xtl_ancien (iiso,i,k) xts_ancien (ixt,i,k) = xts_ancien (iiso,i,k) wake_deltaxt(ixt,i,k) = wake_deltaxt(iiso,i,k) END DO END DO ELSE DO i = 1, klon fxtevap(ixt,i,1:nbsrf)=0.0 xtsnow_fall(ixt,i)=0.0 xtrain_fall(ixt,i)=0.0 xt_ancien (ixt,i,1:klev) = 0.0 xtl_ancien(ixt,i,1:klev) = 0.0 xts_ancien(ixt,i,1:klev) = 0.0 END DO END IF END DO END IF #ifdef ISOVERIF DO nsrf = 1, nbsrf DO i = 1, klon CALL iso_verif_traceur(fxtevap(1,i,nsrf), 'phyiso_etat0_fichier 426') END DO END DO DO i=1,klon CALL iso_verif_traceur(xtrain_fall(1,i), 'phyiso_etat0_fichier 466') CALL iso_verif_traceur(xtsnow_fall(1,i), 'phyiso_etat0_fichier 468') END DO DO k = 1, klev DO i = 1, klon CALL iso_verif_traceur(xt_ancien(1,i,k), 'phyiso_etat0_fichier 591') END DO END DO #endif ! END IF ISOVERIF #endif ! END IF ISOTRAC CONTAINS LOGICAL FUNCTION phyetat0iso_get2(field, pref, descr, default) RESULT(lFound) REAL, INTENT(INOUT) :: field(:,:) CHARACTER(LEN=*), INTENT(IN) :: pref, descr REAL, INTENT(IN) :: default REAL :: iso_tmp(klon) nam(1) = TRIM(pref)//TRIM(outiso) nam(2) = TRIM(pref)//TRIM(oldIso) nam(3) = TRIM(pref)//TRIM(oldIso2) lFound = phyetat0_get(iso_tmp, nam, descr, default) field(ixt,:) = iso_tmp END FUNCTION phyetat0iso_get2 LOGICAL FUNCTION phyetat0iso_get3(field, pref, descr, default) RESULT(lFound) REAL, INTENT(INOUT) :: field(:,:,:) CHARACTER(LEN=*), INTENT(IN) :: pref, descr REAL, INTENT(IN) :: default REAL :: iso_tmp_lonlev(klon,klev) nam(1) = TRIM(pref)//TRIM(outiso) nam(2) = TRIM(pref)//TRIM(oldIso) nam(3) = TRIM(pref)//TRIM(oldIso2) lFound = phyetat0_get(iso_tmp_lonlev, nam, descr, default) field(ixt,:,:) = iso_tmp_lonlev(:,:) END FUNCTION phyetat0iso_get3 LOGICAL FUNCTION phyetat0iso_srf3(field, pref, descr, default) RESULT(lFound) REAL, INTENT(INOUT) :: field(:,:,:) CHARACTER(LEN=*), INTENT(IN) :: pref, descr REAL, INTENT(IN) :: default REAL :: iso_tmp_lonsrf(klon,nbsrf) nam(1) = TRIM(pref)//TRIM(outiso) nam(2) = TRIM(pref)//TRIM(oldIso) nam(3) = TRIM(pref)//TRIM(oldIso2) lFound = phyetat0_srf(iso_tmp_lonsrf, nam, descr, default) field(ixt,:,:) = iso_tmp_lonsrf END FUNCTION phyetat0iso_srf3 END SUBROUTINE phyiso_etat0_fichier !#ifdef ISOHTO !=================================================================== ! subroutines utilisees par iso_tritium: ecrites par Alexandre Cauquoin !=================================================================== SUBROUTINE iso_tritium(paprs,pplay, & zphi,dtime, & d_xt_prod_nucl, & d_xt_cosmo, & d_xt_decroiss, & xt_seri) USE isotopes_mod, ONLY: iso_HTO,ok_prod_nucl_tritium USE dimphy, ONLY: klon,klev USE lmdz_geometry, ONLY: latitude_deg,longitude_deg, & ! en degré, remplace rlat et rlon latitude,longitude ! en radian, remplace rlatd et rlond USE lmdz_yomcst #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! input !integer iim,jjm ! nombre de couches en lat et lon !integer klon,klev !real rlat(klon), rlon(klon) ! Latitude et longitude en degre !real rlatd(klon), rlond(klon) ! Latitude et longitude en radian REAL paprs(klon,klev+1) ! input-R-pression pour chaque inter-couche (en Pa) REAL zphi(klon,klev) ! input-R-geopotentiel de chaque couche (reference ocean, en m2/s2) REAL pplay(klon,klev) ! input-R-pression pour le mileu de chaque couche (en Pa) REAL dtime ! pas de temps en secondes !real airephy(klon) ! aire d'une grille (m2) ! output REAL d_xt_prod_nucl(ntraciso,klon,klev) ! tritium provenant des essais nucleaires REAL d_xt_cosmo(ntraciso,klon,klev) ! production naturelle de tritium REAL d_xt_decroiss(ntraciso,klon,klev) ! decroissance radioactive REAL xt_seri(ntraciso,klon,klev) ! quantite d'isotopes de l'eau ! local ! integer iso_verif_noNAN_nostop ! pour debuggage ! integer iso_verif_positif_strict_nostop ! pour debuggage INTEGER ixt,i,k,k_ref,kb,nlev_prod REAL pi parameter (pi=4.*atan(1.)) REAL rlat_geo(klon) ! latitude geomagnetique de la grille (en radians, entre 0 et 90 degres) REAL glat ! latitude du pole geomagnetique REAL glon ! longitude du pole geomagnetique REAL lat_geo,qcos parameter (nlev_prod=34) REAL p_ref ! grille de pression de reference dimension p_ref(nlev_prod) REAL masse_tritium ! masse d'une molecule de HTO en kg parameter (masse_tritium=33.3388E-27 ) REAL tau_decroissance_tritium ! periode radioactive du tritium (17.77 ans en secondes) parameter (tau_decroissance_tritium=560520955.6) data p_ref / & 100062.00, 97119.00, 94176.00, 91233.00, & 88290.00, 85347.00, 82404.00, 79461.00, & 76518.00, 73575.00, 70632.00, 67689.00, & 64746.00, 61803.00, 58860.00, 55917.00, & 52974.00, 50031.00, 47088.00, 44145.00, & 41202.00, 38259.00, 35316.00, 32373.00, & 29430.00, 26487.00, 23544.00, 20601.00, & 17658.00, 14715.00, 11772.00, 8829.00, & 5886.00, 2943.00 / INTEGER j_1ere_bombe ! numero du premier essai nucleaire de la journee en cours (486 au total) INTEGER nbombe ! pour savoir si c'est un jour de bombe et le nombre de bombes durant ce jour #ifdef ISOVERIF CALL iso_verif_noNaN_vect2D(xt_seri, & 'iso_tritium 66: debut iso_tritium',ntraciso,klon,klev) #endif ! --------------------------------------------------------------------- ! initialisation ! --------------------------------------------------------------------- !pi=4.*atan(1.) !masse_tritium=33.3388E-27 !tau_decroissance_tritium=560520955.6 DO ixt=1,ntraciso DO i=1,klon DO k=1,klev d_xt_cosmo(ixt,i,k)=0. d_xt_prod_nucl(ixt,i,k)=0. d_xt_decroiss(ixt,i,k)=0. enddo enddo enddo !#ifdef ISOVERIF ! do kb=1,nlev_prod ! WRITE(*,*) 'iso_tritium 103' ! WRITE(*,*) 'kb, p_ref', kb, p_ref(kb) ! enddo !#endif ! ---------------------------------------------------------------------------- ! Production naturelle de tritium --> d_xt_cosmo ! ---------------------------------------------------------------------------- ! On passe des coordonnees geographiques a la latitude geomagnetique glat = 78.5*pi/180. glon = -69.0*pi/180. DO i=1,klon qcos=sin(glat)*sin(latitude(i)) qcos=qcos+cos(glat)*cos(latitude(i))*cos(longitude(i)-glon) IF ( qcos .lt. -1.) qcos = -1. IF ( qcos .gt. 1.) qcos = 1. rlat_geo(i)=pi/2.-acos(qcos) enddo ! Pour chaque niveau de pression atmospherique, on implemente a chaque bande de latitude ! la production de tritium IF (iso_HTO.gt.0) then ! Tritium ixt=iso_HTO DO i = 1,klon DO k = 1,klev ! Determination du niveau k_ref dans la grille de reference k_ref = 1 DO kb = 1,nlev_prod IF (p_ref(kb) .gt. pplay(i,k)) k_ref=kb enddo lat_geo=(180./pi)*abs(rlat_geo(i)) ! latitude geomagnetique ! Pour le moment, la production d_xt_cosmo est exprime en at/g/s IF ( k_ref .EQ. 1 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 8.9433E-7 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.9432E-7 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.9247E-7 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.4992E-7 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.655E-7 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.9815E-7 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.4847E-7 else d_xt_cosmo(ixt,i,k) = 6.2824E-7 endif endif IF ( k_ref .EQ. 2 ) THEN IF (lat_geo.ge.60.) THEN d_xt_cosmo(ixt,i,k) = 1.736E-6 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.171E-6 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.1121E-6 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 9.9709E-7 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 9.0662E-7 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.3986E-7 else d_xt_cosmo(ixt,i,k) = 8.1299E-7 endif endif IF ( k_ref .EQ. 3 ) THEN IF (lat_geo.ge.60.) THEN d_xt_cosmo(ixt,i,k) = 1.5402E-6 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.5365E-6 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.4552E-6 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.2989E-6 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.1775E-6 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.0879E-6 else d_xt_cosmo(ixt,i,k) = 1.0522E-6 endif endif IF ( k_ref .EQ. 4 ) THEN IF (lat_geo.ge.60.) THEN d_xt_cosmo(ixt,i,k) = 2.0198E-6 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.0145E-6 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.9024E-6 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.6901E-6 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.5273E-6 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.4072E-6 else d_xt_cosmo(ixt,i,k) = 1.3599E-6 endif endif IF ( k_ref .EQ. 5 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 2.6465E-6 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.6464E-6 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.6389E-6 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.4846E-6 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.1965E-6 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.9785E-6 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.8177E-6 else d_xt_cosmo(ixt,i,k) = 1.755E-6 endif endif IF ( k_ref .EQ. 6 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 3.4646E-6 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.4645E-6 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.454E-6 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.2415E-6 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.851E-6 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.5595E-6 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.3444E-6 else d_xt_cosmo(ixt,i,k) = 2.2613E-6 endif endif IF ( k_ref .EQ. 7 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 4.5316E-6 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.5315E-6 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.5166E-6 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.2244E-6 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.6958E-6 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.3062E-6 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.0191E-6 else d_xt_cosmo(ixt,i,k) = 2.909E-6 endif endif IF ( k_ref .EQ. 8 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 5.9217E-6 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.9216E-6 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.9006E-6 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.499E-6 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.7842E-6 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.2644E-6 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.8815E-6 else d_xt_cosmo(ixt,i,k) = 3.736E-6 endif endif IF ( k_ref .EQ. 9 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 7.7309E-6 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.7307E-6 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.701E-6 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.1498E-6 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.1842E-6 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.4915E-6 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.9818E-6 else d_xt_cosmo(ixt,i,k) = 4.7894E-6 endif endif IF ( k_ref .EQ. 10 ) THEN IF (lat_geo.ge.60.) THEN d_xt_cosmo(ixt,i,k) = 1.0082E-5 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.004E-5 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 9.2843E-6 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.9817E-6 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.0598E-6 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.3824E-6 else d_xt_cosmo(ixt,i,k) = 6.1283E-6 endif endif IF ( k_ref .EQ. 11 ) THEN IF (lat_geo.ge.60.) THEN d_xt_cosmo(ixt,i,k) = 1.3135E-5 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.3076E-5 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.204E-5 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.0285E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 9.0599E-6 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.1612E-6 else d_xt_cosmo(ixt,i,k) = 7.8258E-6 endif endif IF ( k_ref .EQ. 12 ) THEN IF (lat_geo.ge.60.) THEN d_xt_cosmo(ixt,i,k) = 1.7093E-5 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.701E-5 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.5592E-5 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.3231E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.1605E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.0414E-5 else d_xt_cosmo(ixt,i,k) = 9.9722E-6 endif endif IF ( k_ref .EQ. 13 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 2.2217E-5 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.2216E-5 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.21E-5 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.0162E-5 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.6989E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.4835E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.3261E-5 else d_xt_cosmo(ixt,i,k) = 1.2679E-5 endif endif IF ( k_ref .EQ. 14 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 2.8816E-5 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.8815E-5 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.8652E-5 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.6002E-5 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.1746E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.8898E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.6822E-5 else d_xt_cosmo(ixt,i,k) = 1.6056E-5 endif endif IF ( k_ref .EQ. 15 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 3.7386E-5 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.7384E-5 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.7157E-5 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.3546E-5 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.7847E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.4084E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.1349E-5 else d_xt_cosmo(ixt,i,k) = 2.0343E-5 endif endif IF ( k_ref .EQ. 16 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 4.8393E-5 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.8392E-5 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.8073E-5 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.3156E-5 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.5536E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.0578E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.6983E-5 else d_xt_cosmo(ixt,i,k) = 2.5663E-5 endif endif IF ( k_ref .EQ. 17 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 6.2543E-5 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.2541E-5 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.2097E-5 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.541E-5 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.5241E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.8722E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.4007E-5 else d_xt_cosmo(ixt,i,k) = 3.228E-5 endif endif IF ( k_ref .EQ. 18 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 8.0696E-5 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.0693E-5 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.0074E-5 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.0993E-5 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.7449E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.8897E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.273E-5 else d_xt_cosmo(ixt,i,k) = 4.0472E-5 endif endif IF ( k_ref .EQ. 19 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 1.0393E-4 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.0392E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.0306E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 9.0753E-5 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.2752E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.1561E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.3513E-5 else d_xt_cosmo(ixt,i,k) = 5.057E-5 endif endif IF ( k_ref .EQ. 20 ) THEN IF (lat_geo.ge.60.) THEN d_xt_cosmo(ixt,i,k) = 1.3358E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.3238E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.1573E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 9.1859E-5 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.7254E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.678E-5 else d_xt_cosmo(ixt,i,k) = 6.2953E-5 endif endif IF ( k_ref .EQ. 21 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 1.7134E-4 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.7133E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.6968E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.4718E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.1561E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 9.661E-5 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.3017E-5 else d_xt_cosmo(ixt,i,k) = 7.8054E-5 endif endif IF ( k_ref .EQ. 22 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 2.1926E-4 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.1925E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.1696E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.8664E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.45E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.2036E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.0277E-4 else d_xt_cosmo(ixt,i,k) = 9.6352E-5 endif endif IF ( k_ref .EQ. 23 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 2.7986E-4 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.7984E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.7669E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.3591E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.8117E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.4931E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.2663E-4 else d_xt_cosmo(ixt,i,k) = 1.1836E-4 endif endif IF ( k_ref .EQ. 24 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 3.5619E-4 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.5617E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.5183E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.9712E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.2536E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.8436E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.552E-4 else d_xt_cosmo(ixt,i,k) = 1.446E-4 endif endif IF ( k_ref .EQ. 25 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 4.5186E-4 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.5183E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.4587E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.7264E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.7894E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.2638E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.8906E-4 else d_xt_cosmo(ixt,i,k) = 1.7554E-4 endif endif IF ( k_ref .EQ. 26 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 5.7102E-4 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.7098E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.628E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.6503E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.4318E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.7618E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.2861E-4 else d_xt_cosmo(ixt,i,k) = 2.1146E-4 endif endif IF ( k_ref .EQ. 27 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 7.1820E-4 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.1815E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.0693E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.7675E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.1904E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.3416E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.7389E-4 else d_xt_cosmo(ixt,i,k) = 2.5228E-4 endif endif IF ( k_ref .EQ. 28 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 8.9801E-4 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.9794E-4 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.8255E-4 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.0966E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.0671E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.0001E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.242E-4 else d_xt_cosmo(ixt,i,k) = 2.9724E-4 endif endif IF ( k_ref .EQ. 29 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 1.1145E-3 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.1144E-3 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.0932E-3 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.6421E-4 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.0487E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.7209E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.7768E-4 else d_xt_cosmo(ixt,i,k) = 3.4441E-4 endif endif IF ( k_ref .EQ. 30 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 1.3709E-3 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.3708E-3 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.3415E-3 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.0387E-3 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.1001E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.4689E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.3085E-4 else d_xt_cosmo(ixt,i,k) = 3.9032E-4 endif endif IF ( k_ref .EQ. 31 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 1.6712E-3 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.671E-3 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.63E-3 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.2296E-3 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 8.1648E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.1899E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 4.787E-4 else d_xt_cosmo(ixt,i,k) = 4.2993E-4 endif endif IF ( k_ref .EQ. 32 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 2.0296E-3 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.0293E-3 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.9704E-3 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.4366E-3 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 9.1906E-4 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 6.8278E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.1594E-4 else d_xt_cosmo(ixt,i,k) = 4.5743E-4 endif endif IF ( k_ref .EQ. 33 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 2.4971E-3 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.4967E-3 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 2.4078E-3 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.6751E-3 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.017E-3 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.3425E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.3723E-4 else d_xt_cosmo(ixt,i,k) = 4.662E-4 endif endif IF ( k_ref .EQ. 34 ) THEN IF (lat_geo.ge.70.) THEN d_xt_cosmo(ixt,i,k) = 3.2169E-3 ELSE IF ( (lat_geo.ge.60.0) .AND. (lat_geo.lt.70.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.2161E-3 ELSE IF ( (lat_geo.ge.50.0) .AND. (lat_geo.lt.60.0) ) THEN d_xt_cosmo(ixt,i,k) = 3.0665E-3 ELSE IF ( (lat_geo.ge.40.0) .AND. (lat_geo.lt.50.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.9861E-3 ELSE IF ( (lat_geo.ge.30.0) .AND. (lat_geo.lt.40.0) ) THEN d_xt_cosmo(ixt,i,k) = 1.1059E-3 ELSE IF ( (lat_geo.ge.20.0) .AND. (lat_geo.lt.30.0) ) THEN d_xt_cosmo(ixt,i,k) = 7.6337E-4 ELSE IF ( (lat_geo.ge.10.0) .AND. (lat_geo.lt.20.0) ) THEN d_xt_cosmo(ixt,i,k) = 5.2801E-4 else d_xt_cosmo(ixt,i,k) = 4.4129E-4 endif endif !#ifdef ISOVERIF ! if (k.EQ.klev) THEN ! WRITE(*,*) 'iso_tritium 1096' ! WRITE(*,*) 'ixt,i,k,klev=',ixt,i,k,klev ! WRITE(*,*) 'rlat,rlatd=',rlat(i),rlatd(i) ! WRITE(*,*) 'rlon,rlond=',rlon(i),rlond(i) ! WRITE(*,*) 'rlat_geo(i), lat_geo=',rlat_geo(i),lat_geo ! WRITE(*,*) 'pplay(i,k)=',pplay(i,k) ! WRITE(*,*) 'k_ref=',k_ref ! WRITE(*,*) 'd_xt_cosmo(ixt,i,k)=',d_xt_cosmo(ixt,i,k) ! endif !#endif #ifdef ISOVERIF IF (iso_verif_positif_strict_nostop(d_xt_cosmo(ixt,i,k), & 'iso_tritium 1110 : d_xt_cosmo negatif ou pas').EQ.1) THEN WRITE(*,*) 'i,k,klev=',i,k,klev WRITE(*,*) 'latitude_deg,latitude=',latitude_deg(i),latitude(i) WRITE(*,*) 'longitude_deg,longitude=',longitude_deg(i),longitude(i) WRITE(*,*) 'rlat_geo(i), lat_geo=',rlat_geo(i),lat_geo WRITE(*,*) 'pplay(i,k)=',pplay(i,k) WRITE(*,*) 'kb,k_ref, p_ref=',kb,k_ref,p_ref(kb) stop endif #endif enddo enddo endif ! Conversion de la production naturelle de tritium en kg(HTO)/kg(air)/s ! Facteur 1.3/0.7 : test augmentation/baisse de 30% de la production naturelle de tritium DO ixt=1,ntraciso DO i=1,klon DO k=1,klev d_xt_cosmo(ixt,i,k)=d_xt_cosmo(ixt,i,k)*masse_tritium*1000. #ifdef ISOVERIF IF ((iso_HTO.gt.0).AND.(ixt.EQ.iso_HTO)) THEN IF (d_xt_cosmo(ixt,i,k).EQ.0) THEN WRITE(*,*) 'prod cosmo nulle iso_tritium 1134' WRITE(*,*) 'ixt,i,k',ixt,i,k WRITE(*,*) 'masse_tritium', masse_tritium stop endif ! if ((k.EQ.klev).AND.(ixt.EQ.iso_HTO)) THEN ! WRITE(*,*) 'iso_tritium 1140' ! WRITE(*,*) 'ixt,i,k,klev=',ixt,i,k,klev ! WRITE(*,*) 'pplay(i,k)=',pplay(i,k) ! WRITE(*,*) 'masse_tritium', masse_tritium ! WRITE(*,*) 'd_xt_cosmo(ixt,i,k)=',d_xt_cosmo(ixt,i,k) ! endif endif #endif enddo enddo enddo #ifdef ISOVERIF DO ixt=1,ntraciso ! boucler sur tous les isotopes DO i=1,klon ! boucler sur toutes les points horizontaux DO k=1,klev ! boucler sur l'échelle vertical IF (iso_verif_noNAN_nostop(d_xt_cosmo(ixt,i,k), & 'iso_tritium cosmo 1151').EQ.1) THEN WRITE(*,*) 'ixt,i,k,klev=',ixt,i,k,klev WRITE(*,*) 'latitude_deg,latitude=',latitude_deg(i),latitude(i) WRITE(*,*) 'longitude_deg,longitude=',longitude_deg(i),longitude(i) WRITE(*,*) 'rlat_geo(i), lat_geo=',rlat_geo(i),lat_geo WRITE(*,*) 'pplay(i,k)=',pplay(i,k) WRITE(*,*) 'kb,k_ref, p_ref=',kb,k_ref,p_ref(kb) WRITE(*,*) 'masse tritium=', masse_tritium stop endif enddo enddo enddo #endif #ifdef ISOVERIF CALL iso_verif_noNaN_vect2D(xt_seri, & 'iso_tritium 1167: apres d_xt_cosmo',ntraciso,klon,klev) #endif ! -------------------------------------------------------------------------------- ! Production de tritium liee aux essais nucleaires --> d_xt_prod_nucl ! -------------------------------------------------------------------------------- IF (ok_prod_nucl_tritium) then ! production nucleaire de tritium = true IF (iso_HTO.gt.0) then ! Tritium ixt=iso_HTO ! on verifie si la date dans la simulation est un jour d'essai nucleaire CALL date_prod_nucl_HTO(j_1ere_bombe, nbombe) WRITE(*,*) 'iso_tritium 1183, apres CALL date_prod_nucl_HTO' WRITE(*,*) 'j_1ere_bombe, nbombe', j_1ere_bombe, nbombe IF (nbombe.ge.1) then ! si c'est un jour avec un ou plusieurs essais nucleaires CALL lancer_bombes(nbombe, j_1ere_bombe, & zphi, & paprs, & d_xt_prod_nucl) endif ! if (nbombe.ge.1) endif ! if tritium endif ! if ok_prod_nucl_tritium #ifdef ISOVERIF DO ixt=1,ntraciso ! boucler sur tous les isotopes DO i=1,klon ! boucler sur toutes les points horizontaux DO k=1,klev ! boucler sur l'échelle verticle IF ((.NOT.ok_prod_nucl_tritium).OR. & (iso_HTO.EQ.0).OR.(ixt.NE.iso_HTO).OR. & (nbombe.EQ.0)) THEN IF (d_xt_prod_nucl(ixt,i,k).NE.0.) THEN WRITE(*,*) 'iso_tritium 1208 apres d_xt_prod_nucl' WRITE(*,*) 'la prod nucleaire d isotopes devrait etre nulle' WRITE(*,*) 'ixt, i, k', ixt, i, k WRITE(*,*) 'd_xt_prod_nucl', d_xt_prod_nucl(ixt,i,k) stop endif endif enddo enddo enddo #endif #ifdef ISOVERIF DO ixt=1,ntraciso ! boucler sur tous les isotopes DO i=1,klon ! boucler sur toutes les points horizontaux DO k=1,klev ! boucler sur l'échelle verticae IF (iso_verif_noNAN_nostop(d_xt_prod_nucl(ixt,i,k), & 'iso_tritium prod nucl 1225').EQ.1) THEN WRITE(*,*) 'ixt,i,k,latitude_deg(i)',ixt,i,k,latitude_deg(i) stop endif enddo enddo enddo #endif #ifdef ISOVERIF CALL iso_verif_noNaN_vect2D(xt_seri, & 'iso_tritium 1236: apres d_xt_prod_nucl',ntraciso,klon,klev) #endif ! ------------------------------------------------------------------------ ! Definition de la decroissance radioactive du tritium --> d_xt_decroiss ! ------------------------------------------------------------------------ #ifdef ISOTRAC IF (iso_HTO.gt.0) THEN WRITE(*,*) 'cas pas prevu, a coder' ! utiliser index_iso au lieu de ixt dans la condition ci dessous ! et vérifier ailleurs stop endif #endif DO ixt=1,ntraciso ! boucler sur tous les isotopes IF ((iso_HTO.gt.0).AND.(ixt.EQ.iso_HTO)) then ! Tritium DO i=1,klon ! boucler sur toutes les points horizontaux DO k=1,klev ! boucler sur l'échelle verticale d_xt_decroiss(ixt,i,k)=-xt_seri(ixt,i,k) & *1./tau_decroissance_tritium enddo enddo endif enddo ! fin de la boucle en ntraciso #ifdef ISOVERIF CALL iso_verif_noNaN_vect2D(xt_seri, & 'iso_tritium 1257: apres d_xt_decroiss',ntraciso,klon,klev) #endif ! ---------------------------------------------------------------------- ! concentration totale de tritium --> calcul de xt_seri ! ---------------------------------------------------------------------- DO ixt=1,ntraciso ! boucler sur tous les isotopes DO i=1,klon ! boucler sur toutes les points horizontaux DO k=1,klev ! boucler sur l'échelle verticale xt_seri(ixt,i,k)=xt_seri(ixt,i,k) & +d_xt_cosmo(ixt,i,k)*dtime & +d_xt_prod_nucl(ixt,i,k)*dtime & +d_xt_decroiss(ixt,i,k)*dtime !#ifdef ISOVERIF ! if ((ixt.EQ.iso_HTO).AND.(k.ge.(klev-2))) then !ok ! WRITE(*,*) 'iso_tritium 1284 - test concentration totale' ! WRITE(*,*) 'ixt,i,k,klev=',ixt,i,k,klev ! WRITE(*,*) 'rlat,rlon=',rlat(i),rlon(i) ! WRITE(*,*) 'dtime=', dtime ! WRITE(*,*) 'd_xt_cosmo(ixt,i,k)=',d_xt_cosmo(ixt,i,k) ! WRITE(*,*) 'd_xt_prod_nucl(ixt,i,k)=',d_xt_prod_nucl(ixt,i,k) ! endif !#endif enddo enddo enddo #ifdef ISOVERIF CALL iso_verif_noNaN_vect2D(xt_seri, & 'iso_tritium 1289: fin de iso_tritium',ntraciso,klon,klev) #endif END SUBROUTINE iso_tritium !=================================================================== ! End SUBROUTINE iso_tritium !=================================================================== !=================================================================== ! Subroutine chargement des tableaux de donnees pour production ! nucleaire de tritium --> CALL dans iso_init.F !=================================================================== SUBROUTINE table_tritium_nucl() USE isotopes_mod, ONLY: ok_prod_nucl_tritium,nessai, & day_nucl,month_nucl,year_nucl, & lat_nucl,lon_nucl, & zmin_nucl,zmax_nucl, & HTO_nucl #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! Arguments !integer nessai !integer day_nucl(nessai), month_nucl(nessai), year_nucl(nessai) !real lat_nucl(nessai), lon_nucl(nessai) !real zmin_nucl(nessai) ,zmax_nucl(nessai) !real HTO_nucl(nessai) ! local INTEGER iessai IF (ok_prod_nucl_tritium) THEN ! tableau pour day_nucl open(30, file='day_nucl.txt') DO iessai=1,nessai read(30,*) day_nucl(iessai) enddo close(30) ! tableau pour month_nucl open(31, file='month_nucl.txt') DO iessai=1,nessai read(31,*) month_nucl(iessai) enddo close(31) ! tableau pour year_nucl open(32, file='year_nucl.txt') DO iessai=1,nessai read(32,*) year_nucl(iessai) enddo close(32) ! tableau pour lat_nucl open(33, file='lat_nucl.txt') DO iessai=1,nessai read(33,*) lat_nucl(iessai) enddo close(33) ! tableau pour lon_nucl open(34, file='lon_nucl.txt') DO iessai=1,nessai read(34,*) lon_nucl(iessai) enddo close(34) ! tableau pour zmin_nucl open(35, file='zmin_nucl.txt') DO iessai=1,nessai read(35,*) zmin_nucl(iessai) enddo close(35) ! tableau pour zmax_nucl open(36, file='zmax_nucl.txt') DO iessai=1,nessai read(36,*) zmax_nucl(iessai) enddo close(36) ! tableau pour HTO_nucl open(37, file='HTO_nucl.txt') DO iessai=1,nessai read(37,*) HTO_nucl(iessai) enddo close(37) else DO iessai=1,nessai day_nucl(iessai) = 0 month_nucl(iessai) = 0 year_nucl(iessai) = 0 lat_nucl(iessai) = 0. lon_nucl(iessai) = 0. zmin_nucl(iessai) = 0. zmax_nucl(iessai) = 0. HTO_nucl(iessai) = 0. enddo endif ! if (ok_prod_nucl_tritium) END SUBROUTINE table_tritium_nucl !=================================================================== ! Subroutines production nucleaire utilisees par iso_tritium !=================================================================== ! Subroutines pour la production nucleaire de tritium : ! 1. Les donnees (temps, localisation, quantite de tritium injecte) sont ! chargees prealablement dans la SUBROUTINE table_tritium_nucl qui ! est appelee dans iso_init.F. Ces donnees sont mis dans le COMMON ! de wateriso2 ! 2. Determiner si le jour dans la simulation correspond a un jour d'un ! essai nucleaire, connaitre la ligne correspondante dans le ! fichier de forcage de production nucleaire, et savoir le nombres ! de bombes nbombe dans cette journee --> SUBROUTINE ! date_prod_nucl_HTO ! 3. Si oui (nbombe > 0), on utilise la SUBROUTINE lancer_bombes qui va ! definir les variables de localisation et quantite de tritium ! produit avec le bon nombre de bombes dans la journee et appeler les ! deux subroutines suivantes ! 4. SUBROUTINE coord_prod_nucl_HTO --> pour la localisation de l'essai ! nucleaire sur (klon,klev) ! 5. calcul de la production de tritium (kg) (a partir de P_HTO dans le tableau ! repertoriant tous les essais nucleaires) etalee uniformement sur la journee ! entre zmin et zmax --> SUBROUTINE calcul_prod_nucl_HTO ! -------------------------------------------------------------------------------- ! date_prod_nucl_HTO ! -------------------------------------------------------------------------------- SUBROUTINE date_prod_nucl_HTO(j_1ere_bombe, nbombe) ! anciennement: ! !date_prod_nucl_HTO(ntest, day_essai, month_essai, & ! & year_essai, j_1ere_bombe, nbombe) USE phys_cal_mod ! pour le calendrier USE isotopes_mod, ONLY: nessai, day_nucl, month_nucl, year_nucl IMPLICIT NONE ! Arguments INTEGER nbombe,j_1ere_bombe ! pour un jour dans la simulation, on cherche le nombre de bombes nbombe de la journee et la ligne correspondant a la 1ere bombe de cette journee ! integer day_essai(nessai),month_essai(nessai),year_essai(nessai) ! date (jour, mois, annee) des essais nucleaires ! local INTEGER j ! indices ! initialisation nbombe=0 j_1ere_bombe=0 WRITE(*,*) 'iso_tritium 1456, SUBROUTINE date_prod_nucl_HTO' WRITE(*,*) 'Date dans la simulation:',day_cur,mth_cur,year_cur DO j=1,nessai ! il faut que le tableau d'entree soit dans l'ordre chronologique IF (nbombe.EQ.0) THEN IF ((day_cur.EQ.day_nucl(j)).AND. & (mth_cur.EQ.month_nucl(j)).AND. & (year_cur.EQ.year_nucl(j))) THEN nbombe=1 j_1ere_bombe=j endif else IF ((day_cur.EQ.day_nucl(j)).AND. & (mth_cur.EQ.month_nucl(j)).AND. & (year_cur.EQ.year_nucl(j))) THEN nbombe=nbombe+1 else exit endif endif !#ifdef ISOVERIF ! WRITE(*,*) 'controle SUBROUTINE date_prod_nucl_HTO' !ok ! WRITE(*,*) 'day_cur, mth_cur, year_cur',day_cur,mth_cur,year_cur ! WRITE(*,*) 'j, nessai', j, nessai ! WRITE(*,*) 'nbombe, j_1ere_bombe', nbombe, j_1ere_bombe ! WRITE(*,*) 'day_nucl(j), month_nucl(j), year_nucl(j)', ! : day_nucl(j), month_nucl(j), year_nucl(j) !#endif enddo END SUBROUTINE date_prod_nucl_HTO ! -------------------------------------------------------------------------------- ! lancer_bombes ! -------------------------------------------------------------------------------- SUBROUTINE lancer_bombes(nbombe, j_1ere_bombe, & zphi, & paprs, & prod_nucl_HTO) ! anciennement: ! lancer_bombes(iim, jjm, nbombe, j_1ere_bombe, & ! & klon, klev, zphi, & ! & rlat, rlon, paprs, airephy, & ! & lat_essai, lon_essai, & ! & zmin_essai, zmax_essai, & ! & HTO_essai, ntest, & ! & prod_nucl_HTO) USE isotopes_mod, ONLY: nessai, lat_nucl, lon_nucl, & & zmin_nucl, zmax_nucl, HTO_nucl USE dimphy, ONLY: klon,klev USE lmdz_geometry, ONLY: latitude_deg,longitude_deg #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! Arguments !integer iim, jjm INTEGER nbombe, j_1ere_bombe !integer klon, klev !integer ntest REAL zphi(klon,klev) !real rlat(klon), rlon(klon) REAL paprs(klon,klev+1) !real lat_nucl(ntest), lon_nucl(ntest) ! latitude et longitude des essais nucleaires !real zmin_nucl(ntest), zmax_nucl(ntest) ! altitudes min et max des nbombes champignons atomiques !real HTO_nucl(ntest) ! production de HTO en kg par les essais nucleaires REAL prod_nucl_HTO(ntraciso,klon,klev) ! calcul de la production de tritium (kg/kg d'air) liee aux essais nucleaire de la journee --> d_xt_prod_nucl(ntraciso,klon,klev) ! local INTEGER ibombe,jessai REAL lat_HTO, lon_HTO ! latitude et longitude de l'essai nucleaire jessai REAL zmin_HTO, zmax_HTO ! altitudes min et max du champignon atomique jessai REAL P_HTO ! production de HTO en kg de l'essai nucleaire jessai INTEGER coord_HTO INTEGER kmin_HTO, kmax_HTO ! coordonnees lat, lon, zmin et zmax de l'essai nucleaire jessai DO ibombe=1,nbombe jessai=j_1ere_bombe+ibombe-1 lat_HTO = lat_nucl(jessai) lon_HTO = lon_nucl(jessai) zmin_HTO = zmin_nucl(jessai) zmax_HTO = zmax_nucl(jessai) P_HTO = HTO_nucl(jessai) !#ifdef ISOVERIF !ok ! WRITE(*,*) 'controle SUBROUTINE lancer_bombes' ! WRITE(*,*) 'ibombe, nbombe', ibombe, nbombe ! WRITE(*,*) 'jessai, j_1ere_bombe', jessai, j_1ere_bombe ! WRITE(*,*) 'lat_HTO, lon_HTO', lat_HTO, lon_HTO ! WRITE(*,*) 'zmin_HTO, zmax_HTO', zmin_HTO, zmax_HTO ! WRITE(*,*) 'P_HTO', P_HTO !#endif CALL coord_prod_nucl_HTO(zphi, & lat_HTO, lon_HTO, & zmin_HTO, zmax_HTO, & coord_HTO, & kmin_HTO,kmax_HTO) IF (coord_HTO.gt.0) then ! quand on trouve les coordonnees de l'essai nucleaire dans la simulation WRITE(*,*) 'iso_tritium 1552 dans SUBROUTINE lancer_bombes' WRITE(*,*) 'Apres CALL coord_prod_nucl_HTO pour coord_HTO>0' WRITE(*,*) 'ibombe, nbombe', ibombe, nbombe WRITE(*,*) 'coord_HTO',coord_HTO WRITE(*,*) 'latitude_deg(coord_HTO), longitude_deg(coord_HTO)', & latitude_deg(coord_HTO), longitude_deg(coord_HTO) WRITE(*,*) 'kmin_HTO, kmax_HTO', kmin_HTO, kmax_HTO CALL calcul_prod_nucl_HTO(P_HTO,coord_HTO, & kmin_HTO,kmax_HTO, & paprs, & prod_nucl_HTO) endif enddo END SUBROUTINE lancer_bombes ! -------------------------------------------------------------------------------- ! coord_prod_nucl_HTO ! -------------------------------------------------------------------------------- SUBROUTINE coord_prod_nucl_HTO(zphi, & lat_jessai, lon_jessai, & zmin_jessai, zmax_jessai, & coord_jessai,& kmin_jessai,kmax_jessai) USE dimphy, ONLY: klon,klev USE lmdz_geometry, ONLY: latitude_deg,longitude_deg USE lmdz_yomcst #ifdef ISOVERIF USE isotopes_verif_mod #endif USE lmdz_dimensions, ONLY: iim, jjm, llm, ndm IMPLICIT NONE ! pour avoir iim et jjm ! Arguments !integer klon, klev ! indices grilles horizontales et verticales !integer iim, jjm ! nombre de mailles en longitude et latitude REAL zphi(klon,klev) ! input-R-geopotentiel de chaque couche (reference ocean, en m2/s2) !real rlat(klon), rlon(klon) ! latitude et longitude en degres REAL lat_jessai, lon_jessai ! latitude et longitude de l'essai nucleaire jessai REAL zmin_jessai, zmax_jessai ! altitudes min et max du champignon atomique jessai INTEGER coord_jessai, kmin_jessai, kmax_jessai ! coordonnees lat, lon, zmin et zmax en sortie de la SUBROUTINE de l'essai nucleaire jessai ! local INTEGER i,k ! pour le boucles REAL dlat, dlon ! pas en latitude et longitude REAL alt(klon,klev) ! altitude a chaque niveau ! initialisation kmin_jessai=0 kmax_jessai=0 coord_jessai=0 !dlat=180./jjm !dlon=(2.*180.)/iim DO i=1,klon DO k=1,klev alt(i,k)=zphi(i,k)/RG enddo enddo !#ifdef ISOVERIF !ok ! do i=1,klon ! do k=1,klev ! WRITE(*,*) 'i,k,RG',i,k,RG ! WRITE(*,*) 'zphi', zphi(i,k) ! WRITE(*,*) 'alt', alt(i,k) ! enddo ! enddo !#endif DO i=1,klon ! ajout Camille Risi 14 aout 2017: calcul local de dlat et dlon en cas ! de grille zoomée IF (i.gt.1) THEN dlon=longitude_deg(i)-longitude_deg(i-1) else dlon=longitude_deg(i+1)-longitude_deg(i) endif IF (i.gt.iim) THEN dlat=latitude_deg(i)-latitude_deg(i-iim) else dlat=latitude_deg(i+iim)-latitude_deg(i) endif #ifdef ISOVERIF CALL iso_verif_positif(dlon-0.1,'iso_routines 18504a') CALL iso_verif_positif(30.0-dlon,'iso_routines 18504b') CALL iso_verif_positif(dlat-0.1,'iso_routines 18504c') CALL iso_verif_positif(20.0-dlat,'iso_routines 18504d') #endif IF (((latitude_deg(i)-dlat/2.).le.lat_jessai).AND. & ((latitude_deg(i)+dlat/2.).gt.lat_jessai).AND. & ((longitude_deg(i)-dlon/2.).le.lon_jessai).AND. & ((longitude_deg(i)+dlon/2.).gt.lon_jessai)) THEN coord_jessai=i IF (alt(i,1).ge.zmin_jessai) kmin_jessai = 1 ! si base du champignon est plus bas que le niveau 1 dans le modele IF (alt(i,1).ge.zmax_jessai) kmax_jessai = 2 ! si le haut du champignon est plus bas que le niveau 1 du modele IF (alt(i,klev).lt.zmin_jessai) kmin_jessai = klev ! si base du champignon est plus haut que le niveau klev dans le modele IF (alt(i,klev).lt.zmax_jessai) kmax_jessai = klev ! si le haut du champignon est plus haut que le niveau klev du modele DO k=1,klev-1 IF ((alt(i,k).lt.zmin_jessai).AND. & (alt(i,k+1).ge.zmin_jessai)) THEN kmin_jessai = max(1,k) ! si base du champignon est entre le niveau k et k+1 endif IF ((alt(i,k).lt.zmax_jessai).AND. & (alt(i,k+1).ge.zmax_jessai)) THEN kmax_jessai = min(k+1,klev) ! si le haut du champignon est entre le niveau k et k+1 endif enddo ! boucle klev exit ! on arrete la boucle le long de klon quand on a trouve les bonnes coordonnees endif ! trouve les bonnes coordonnees sur klon enddo ! boucle klon #ifdef ISOVERIF IF (kmin_jessai.gt.kmax_jessai) then ! on plante si kmin>=kmax pour kkmax)' WRITE(*,*) 'coord_jessai', coord_jessai WRITE(*,*) 'lon_nucl, lat_nucl', lon_jessai, lat_jessai WRITE(*,*) 'zmin_nucl, zmax_nucl', zmin_jessai, zmax_jessai WRITE(*,*) 'kmin,kmax',kmin_jessai,kmax_jessai stop endif IF ((kmin_jessai.EQ.klev).AND.(kmax_jessai.NE.klev)) then ! on plante si on n'a pas kmax=klev quand kmin=klev WRITE(*,*) 'Pb SUBROUTINE coord_prod_nucl_HTO(kmin=klev)' WRITE(*,*) 'coord_jessai', coord_jessai WRITE(*,*) 'lon_nucl, lat_nucl', lon_jessai, lat_jessai WRITE(*,*) 'zmin_nucl, zmax_nucl', zmin_jessai, zmax_jessai WRITE(*,*) 'kmin,kmax',kmin_jessai,kmax_jessai stop endif #endif !#ifdef ISOVERIF ! WRITE(*,*) 'controle SUBROUTINE coord_prod_nucl_HTO' !ok ! WRITE(*,*) 'iim,jjm,dlat,dlon',iim,jjm,dlat,dlon ! WRITE(*,*) 'indice coord_HTO', coord_jessai ! WRITE(*,*) 'latitude_deg, lat_HTO',latitude_deg(coord_jessai),lat_jessai ! WRITE(*,*) 'longitude_deg, lon_HTO',longitude_deg(coord_jessai),lon_jessai ! WRITE(*,*) 'kmin_HTO, kmax_HTO', kmin_jessai, kmax_jessai ! WRITE(*,*) 'alt_min(k), alt_min(k+1), zmin_HTO', ! : alt(coord_jessai,kmin_jessai), ! : alt(coord_jessai,kmin_jessai+1), ! : zmin_jessai ! WRITE(*,*) 'alt_max(k), alt_max(k+1), zmax_HTO', ! : alt(coord_jessai,kmax_jessai), ! : alt(coord_jessai,kmax_jessai+1), ! : zmax_jessai !#endif END SUBROUTINE coord_prod_nucl_HTO ! -------------------------------------------------------------------------------- ! calcul_prod_nucl_HTO ! -------------------------------------------------------------------------------- SUBROUTINE calcul_prod_nucl_HTO(P_jessai,coord_jessai, & kmin_jessai,kmax_jessai, & paprs, & prod_nucl) USE isotopes_mod, ONLY: iso_HTO USE lmdz_geometry, ONLY: cell_area USE dimphy, ONLY: klon,klev USE lmdz_yomcst #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! Arguments REAL P_jessai ! production de HTO en kg par l'essai nucleaire jessai INTEGER coord_jessai ! indice de coordonnee lat(coord_jessai) et lon(coord_jessai) de l'essai nucleaire jessai INTEGER kmin_jessai, kmax_jessai ! indice de hauteur (ou pression) min et max du champignon atomique jessai !integer klon, klev REAL paprs(klon,klev+1) ! input-R-pression pour chaque inter-couche (en Pa) !real airephy(klon) ! aire d'une grille (m2) REAL prod_nucl(ntraciso,klon,klev) ! calcul de la production de HTO en kg par kg d'air sur la journee entre zmin et zmax --> d_xt_prod_nucl ! local INTEGER ixt,i,j,k ! pour les boucles REAL day_sec ! 1 jour en secondes REAL prod_nucl_tmp(klon,klev) ! calcul de la production de HTO en kg/kg d'air pour l'essai nucleaire jessai day_sec = 86400. ixt=iso_HTO j = coord_jessai DO i=1,klon DO k=1,klev prod_nucl_tmp(i,k)=0. enddo enddo !#ifdef ISOVERIF ! WRITE(*,*) 'ixt,j,coord_HTO',ixt,j,coord_jessai !ok ! WRITE(*,*) 'kmin_HTO, kmax_HTO', kmin_jessai, kmax_jessai ! WRITE(*,*) 'day_sec, P_HTO', day_sec, P_jessai !#endif IF (kmin_jessai.lt.klev) then ! si kmin < klev, normalement kmin < kmax DO k=kmin_jessai,kmax_jessai prod_nucl_tmp(j,k) = & (P_jessai/day_sec)/( & (paprs(j,kmin_jessai)-paprs(j,kmax_jessai)) & /RG*cell_area(j) ) prod_nucl(ixt,j,k)=prod_nucl(ixt,j,k)+prod_nucl_tmp(j,k) #ifdef ISOVERIF IF (kmin_jessai.ge.kmax_jessai) THEN WRITE(*,*) 'Pb SUBROUTINE calcul_prod_nucl_HTO(k=1' ! WRITE(*,*) 'klon, klev', klon, klev ! WRITE(*,*) 'ixt, i, k', ixt, i, k ! WRITE(*,*) 'RG, cell_area(i)', RG, cell_area(i) ! WRITE(*,*) 'coord_HTO,kmin_HTO,kmax_HTO', ! : coord_jessai,kmin_jessai,kmax_jessai ! WRITE(*,*) 'P_HTO, day_sec', P_jessai, day_sec ! WRITE(*,*) 'paprs(coord_HTO,kmin),paprs(coord_HTO,kmax)', ! : paprs(coord_jessai,kmin_jessai), ! : paprs(coord_jessai,kmax_jessai) ! WRITE(*,*) 'd_xt_prod_nucl(ixt,i,k)', prod_nucl(ixt,i,k) ! enddo ! enddo !#endif END SUBROUTINE calcul_prod_nucl_HTO !#endif !=================================================================== ! End subroutines utilisees par iso_tritium !=================================================================== ! ces routines propres au water tagging sont dépacées ici pour éviter les ! dépendances circulaires #ifdef ISOTRAC SUBROUTINE condiso_liq_ice_vectiso_trac(xt,qt,cond, & tcond,zfice,zxtice,zxtliq) USE isotopes_mod, ONLY: iso_eau,iso_HDO,essai_convergence, & & bidouille_anti_divergence,ridicule ! USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectiso USE isotrac_mod, ONLY: index_iso, index_zone,option_traceurs,izone_cond #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! version vectorisée de condiso_liq_ice ! on fait d'un coup tous les iso de 1 à niso !d'un point de grille donnée ! déclarations ! **inputs REAL xt(ntraciso),qt,cond,tcond,zfice ! tcond en K ! **outputs REAL zxtice(ntraciso),zxtliq(ntraciso) ! **locals INTEGER ixt REAL zcond INTEGER ieau,izone,iiso REAL zcondtrac,qttrac REAL xttrac(ntraciso),zxtliqtrac(ntraciso), & zxticetrac(ntraciso) ! normallement, niso en dimension suffirait, mais serait pas ! cohérent avec les dimensions dans condiso_liq_ice !#include "iso_verif.h" ! verif que qt n'est pas nul IF (qt.EQ.0) THEN IF (cond.lt.ridicule) THEN DO ixt=1,ntraciso zxtliq(ixt)=0 zxtice(ixt)=0 enddo RETURN else ! c'est impossible de condenser qi pas d'eau au départ WRITE(*,*) 'condiso_liq_ice_vectiso_trac 35' WRITE(*,*) 'qt=',qt WRITE(*,*) 'cond=',cond stop endif endif !if (qt.EQ.0) THEN zcond=max(0.0,min(cond,qt)) #ifdef ISOVERIF DO izone=1,ntraceurs_zone ieau=index_trac(izone,iso_eau) CALL iso_verif_positif((qt-xt(ieau))*1e-4,'condisotrac 54') enddo CALL iso_verif_traceur(xt(1),'condisotrac 56') #endif DO izone=1,ntraceurs_zone ieau=index_trac(izone,iso_eau) qttrac=xt(ieau) zcondtrac=(zcond/qt)*xt(ieau) zcondtrac=min(zcondtrac,qttrac) DO iiso=1,niso xttrac(iiso)=xt(index_trac(izone,iiso)) enddo CALL condiso_liq_ice_vectiso(xttrac,qttrac,zcondtrac, & tcond,zfice,zxticetrac,zxtliqtrac) ! WRITE(*,*) 'zxticetrac=',zxticetrac DO iiso=1,niso zxtice(index_trac(izone,iiso))=zxticetrac(iiso) zxtliq(index_trac(izone,iiso))=zxtliqtrac(iiso) enddo #ifdef ISOVERIF IF (iso_HDO.gt.0) THEN IF (zcondtrac.gt.ridicule) THEN IF (iso_verif_aberrant_nostop(zxtice(iso_HDO)/cond & /faccond,'condiso_trac 79').EQ.1) THEN WRITE(*,*) 'izone=',izone WRITE(*,*) 'zcondtrac/qttrac=',cond/qt WRITE(*,*) 'deltaD(xt(iso_HDO)/qt)=', & deltaD(xttrac(iso_HDO)/qttrac) WRITE(*,*) 'tcond=',tcond-273,'°C' IF (tcond-273.gt.-40.0) THEN ! au dessus de -40, il y a de quoi s'inquiéter ! en dessous, on ne sait pas ce que valent les alphas stop endif !if (tcond(i).gt.100.0) THEN endif endif !if (cond.gt.ridicule) THEN endif !if (iso_HDO.gt.0) THEN #endif enddo ! do izone=1,ntraceurs_zone #ifdef ISOVERIF ! WRITE(*,*) 'zxtice=',zxtice ! WRITE(*,*) 'zcond=',zcond ! WRITE(*,*) 'xt=',xt ! WRITE(*,*) 'qt=',qt CALL iso_verif_traceur(zxtliq(1), & 'condiso_liq_ice_vectiso_trac 194') CALL iso_verif_traceur_justmass(zxtice(1), & 'condiso_liq_ice_vectiso_trac 196') ! on ne peut pas faire pour xt #endif IF (option_traceurs.EQ.17) THEN ! colorier le condensat en un tag spécifique DO ixt=1,ntraciso IF (index_zone(ixt).EQ.izone_cond) THEN zxtliq(ixt)=zxtliq(index_iso(ixt)) zxtice(ixt)=zxtice(index_iso(ixt)) else !if (index_zone(ixt).EQ.izone_cond) THEN zxtliq(ixt)=0.0 zxtice(ixt)=0.0 endif !if (index_zone(ixt).EQ.izone_cond) THEN enddo !do ixt=1,ntraciso endif !if (option_traceurs.EQ.17) THEN #ifdef ISOVERIF CALL iso_verif_traceur(zxtliq(1), & 'condiso_liq_ice_vectiso_trac 122') CALL iso_verif_traceur_justmass(zxtice(1), & 'condiso_liq_ice_vectiso_trac 124') #endif END SUBROUTINE condiso_liq_ice_vectiso_trac SUBROUTINE condiso_liq_ice_vectall_trac(xt,qt,cond, & tcond,zfice,zxtice,zxtliq,n) USE isotopes_mod, ONLY: iso_eau,iso_HDO,iso_O18,bidouille_anti_divergence, & & ridicule ! USE isotopes_routines_mod, ONLY: condiso_liq_ice_vectall USE isotrac_mod, ONLY: index_iso, index_zone,option_traceurs,izone_cond, & & ridicule_trac #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! version vectorisée de condiso_liq_ice ! on fait d'un coup tous les lieux i de 1 à n ! et tous les iso de 1 à niso ! déclarations ! **inputs INTEGER n REAL xt(ntraciso,n),qt(n),cond(n),tcond(n),zfice(n) ! tcond en K ! **outputs REAL zxtice(ntraciso,n),zxtliq(ntraciso,n) ! **locals INTEGER ixt, i ! compteurs REAL zcond(n) !#ifdef ISOVERIF ! integer iso_verif_aberrant_nostop ! debugage ! integer iso_verif_aberrant_choix_nostop ! real deltaD !#endif INTEGER izone,ieau,iiso REAL zcondtrac(n),qttrac(n) REAL xttrac(ntraciso,n),zxtliqtrac(ntraciso,n), & zxticetrac(ntraciso,n) ! normallement, niso en dimension suffirait, mais serait pas ! cohérent avec les dimensions dans condiso_liq_ice !#ifdef ISOVERIF ! WRITE(*,*) 'condisotrac 112: entrée, n=',n !#endif ! ! verif qt pas nul ! do i=1,n ! if (qt(i).EQ.0) THEN ! if (cond(i).lt.ridicule) THEN ! do ixt=1,ntraciso ! zxtliq(ixt,i)=0 ! zxtice(ixt,i)=0 ! enddo ! RETURN ! else ! ! c'est impossible de condenser qi pas d'eau au départ ! WRITE(*,*) 'condiso_liq_ice_vectall_trac 119' ! WRITE(*,*) 'qt=',qt(i) ! WRITE(*,*) 'cond=',cond(i) ! stop ! endif ! endif !if (qt(i).EQ.0) THEN ! enddo !do i=1,n DO i=1,n zcond(i)=max(0.0,min(cond(i),qt(i))) enddo #ifdef ISOVERIF DO i=1,n CALL iso_verif_traceur(xt(1,i), & 'condiso_liq_ice_vectall_trac 132') enddo !do i=1,n #endif DO izone=1,ntraceurs_zone ieau=index_trac(izone,iso_eau) DO i=1,n qttrac(i)=xt(ieau,i) IF (qt(i).gt.0.0) then ! modif C Risi juillet 2020 ! remodif Camille 9 mars 2023 ! if ((qt(i).gt.0.0).AND.(xt(ieau,i).gt.0.0)) THEN zcondtrac(i)=(zcond(i)/qt(i))*qttrac(i) else !if (qt(i).EQ.0) THEN #ifdef ISOVERIF CALL iso_verif_egalite(cond(i),0.0,'condisotrac 195') #endif zcondtrac(i)=0.0 endif !if (qt(i).EQ.0) THEN zcondtrac(i)=min(zcondtrac(i),qttrac(i)) DO iiso=1,niso xttrac(iiso,i)=xt(index_trac(izone,iiso),i) enddo ! do iiso=1,niso #ifdef ISOVERIF IF (iso_eau.gt.0) THEN CALL iso_verif_egalite_choix(qttrac(i), & xttrac(iso_eau,i),'condisotrac 148', & errmax,errmaxrel) endif IF (iso_HDO.gt.0) THEN CALL iso_verif_aberrant_choix(xttrac(iso_HDO,i), & qttrac(i),ridicule_trac,deltalimtrac, & 'condisotrac 205') endif CALL iso_verif_positif(qt(i)-cond(i), & 'condisotrac 163: cond>qt') CALL iso_verif_positif(qttrac(i)-zcondtrac(i), & 'condisotrac 165: cond>qt') #endif enddo !do i=1,n #ifdef ISOVERIF ! WRITE(*,*) 'condisotrac 164: avant condiso, izone=',izone #endif CALL condiso_liq_ice_vectall(xttrac,qttrac,zcondtrac, & tcond,zfice,zxticetrac,zxtliqtrac,n) DO i=1,n DO iiso=1,niso zxtice(index_trac(izone,iiso),i)=zxticetrac(iiso,i) zxtliq(index_trac(izone,iiso),i)=zxtliqtrac(iiso,i) enddo enddo !do i=1,n enddo !do izone=1,ntraceurs_zone ! WRITE(*,*) 'zxtice(1:ntraciso,2)=', ! : zxtice(1:ntraciso,2) ! WRITE(*,*) 'zxtliq(1:ntraciso,2)=', ! : zxtliq(1:ntraciso,2) #ifdef ISOVERIF DO i=1,n CALL iso_verif_traceur(zxtliq(1,i), & 'condiso_liq_ice_vectall_trac 144') CALL iso_verif_traceur(zxtice(1,i), & 'condiso_liq_ice_vectall_trac 146') enddo !do i=1,n #endif END SUBROUTINE condiso_liq_ice_vectall_trac #endif SUBROUTINE iso_init_ideal(q,xt,ixt,alpha,kcin,toce) USE isotopes_mod, ONLY: iso_eau,iso_HDO,ridicule #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs REAL q ! humidité spec INTEGER ixt ! indice isotopique REAL alpha ! coef frac à l'eq REAL kcin ! coef frac cinétique REAL toce ! rapport iso ds ocean surface ! outputs REAL xt ! equivalent iso de l'humidité spec, même unité. ! locals REAL RMerlivat REAL q0,h0 ! conditions initiales de la distill de Rayleigh parameter (q0=20e-3,h0=0.7) ! verifier que ixt est un isotope et pas un tagging IF (ixt.gt.niso) THEN CALL abort_physic('isotopes_routines_mod', 'iso_init_ideal, ixt>niso', 1) endif ! R selon Merlivat: RMerlivat=toce/alpha *(1.0-kcin)/(1.0-kcin*h0) ! R d'après Rayleigh xt=q*RMerlivat*(min(q0,q)/q0)**(alpha-1.0) #ifdef ISOVERIF CALL iso_verif_noNaN(xt, 'isotopes_routines_mod 18930a: iso_init_ideal') IF ((iso_HDO.gt.0).AND.(ixt.EQ.iso_HDO)) THEN IF (q.gt.ridicule) THEN WRITE(*,*) 'xt,q=',xt,q WRITE(*,*) 'alpha=',alpha WRITE(*,*) 'toce,kcin,h0=',toce,kcin,h0 WRITE(*,*) 'RMerlivat=',RMerlivat CALL iso_verif_aberrant_encadre( xt/q, 'isotopes_routines_mod 18930b: iso_init_ideal') endif endif IF ((iso_eau.gt.0).AND.(ixt.EQ.iso_eau)) THEN CALL iso_verif_egalite(xt,q, 'isotopes_routines_mod 18930c: iso_init_ideal') endif #endif END SUBROUTINE iso_init_ideal SUBROUTINE appel_stewart_debug(lwork,nloc,inb,na,i, & evap,water,rpprec,rr,wdtrain, & xtevap,xtwater,xtp,xt,xtwdtrain) USE isotopes_mod, ONLY: iso_eau, iso_HDO,thumxt1, & & bidouille_anti_divergence,ridicule,Rdefault USE infotrac_phy, ONLY: ntraciso=>ntiso, niso #ifdef ISOTRAC USE isotrac_mod, ONLY: option_cond,izone_cond,index_iso,index_zone,izone_poubelle #endif #ifdef ISOVERIF USE isotopes_verif_mod #endif IMPLICIT NONE ! inputs INTEGER nloc,na,i ! dimension horiz effective LOGICAL lwork(nloc) REAL wdtrain(nloc),xtwdtrain(ntraciso,nloc) REAL xt(ntraciso,nloc,na) REAL evap(nloc,na),water(nloc,na),rpprec(nloc,na),rr(nloc,na) INTEGER inb(nloc) ! outputs REAL xtevap(ntraciso,nloc,na),xtwater(ntraciso,nloc,na),xtp(ntraciso,nloc,na) ! locals INTEGER il,ixt DO il=1,nloc IF (i.le.inb(il) .AND. lwork(il)) THEN IF (wdtrain(il).gt.0.) THEN DO ixt=1,ntraciso xtwater(ixt,il,i)= xtwdtrain(ixt,il)/wdtrain(il)*water(il,i) xtevap(ixt,il,i)= xtwdtrain(ixt,il)/wdtrain(il)*evap(il,i) enddo else !if (wdtrain(il).gt.0.) THEN DO ixt=1,niso xtwater(ixt,il,i)= Rdefault(ixt)*water(il,i) xtevap(ixt,il,i)= Rdefault(ixt)*evap(il,i) enddo #ifdef ISOTRAC DO ixt=1+niso,ntraciso IF (index_zone(ixt).EQ.izone_poubelle) THEN xtwater(ixt,il,i)= Rdefault(index_iso(ixt))*water(il,i) xtevap(ixt,il,i)= Rdefault(index_iso(ixt))*evap(il,i) else xtwater(ixt,il,i)= 0. xtevap(ixt,il,i)=0. endif enddo ! do ixt=1+niso,ntraciso #endif endif !if (wdtrain(il).gt.0.) THEN DO ixt=1,ntraciso xtp(ixt,il,i)= xt(ixt,il,i)/rr(il,i)*rpprec(il,i) enddo !do ixt=1,ntraciso endif enddo ! do il=1,ncum END SUBROUTINE appel_stewart_debug SUBROUTINE dispatch(klon,klev,qx,q_seri,xt_seri,ql_seri,xtl_seri,qs_seri,xts_seri) USE infotrac_phy, ONLY: nqtot,nqo,ivap,iliq,isol,iqIsoPha,ntraciso=>ntiso IMPLICIT NONE ! inputs INTEGER, INTENT(IN) :: klon,klev REAL,DIMENSION(klon,klev,nqtot), INTENT(IN) ::qx ! outputs REAL,DIMENSION(klon,klev), INTENT(OUT) ::q_seri,ql_seri,qs_seri REAL,DIMENSION(ntraciso,klon,klev), INTENT(OUT) :: xt_seri,xtl_seri,xts_seri ! locals INTEGER :: i,k,ixt DO k=1,klev DO i=1,klon q_seri(i,k) = qx(i,k,ivap) ql_seri(i,k) = qx(i,k,iliq) IF (nqo.EQ.2) THEN !--vapour and liquid only qs_seri(i,k) = 0. ELSE IF (nqo.ge.3) THEN !--vapour, liquid and ice qs_seri(i,k) = qx(i,k,isol) ENDIF DO ixt=1,ntraciso xt_seri(ixt,i,k) = qx(i,k,iqIsoPha(ixt,ivap)) xtl_seri(ixt,i,k) = qx(i,k,iqIsoPha(ixt,iliq)) IF (nqo.EQ.2) THEN xts_seri(ixt,i,k) = 0. ELSE IF (nqo.EQ.3) THEN xts_seri(ixt,i,k) = qx(i,k,iqIsoPha(ixt,isol)) endif enddo !do ixt=1,niso END DO END DO END SUBROUTINE dispatch SUBROUTINE together(klon,klev,qx,q_seri,xt_seri,ql_seri,xtl_seri,qs_seri,xts_seri) USE infotrac_phy, ONLY: nqtot,nqo,ivap,iliq,isol,iqIsoPha,ntraciso=>ntiso IMPLICIT NONE ! inputs INTEGER, INTENT(IN) :: klon,klev REAL,DIMENSION(klon,klev), INTENT(IN) ::q_seri,ql_seri,qs_seri REAL,DIMENSION(ntraciso,klon,klev), INTENT(IN) :: xt_seri,xtl_seri,xts_seri ! inputs REAL,DIMENSION(klon,klev,nqtot), INTENT(OUT) ::qx ! locals INTEGER :: i,k,ixt DO k=1,klev DO i=1,klon qx(i,k,ivap) = q_seri(i,k) qx(i,k,iliq) = ql_seri(i,k) IF (nqo.ge.3) THEN !--vapour, liquid and ice qx(i,k,isol) = qs_seri(i,k) ENDIF DO ixt=1,ntraciso qx(i,k,iqIsoPha(ixt,ivap)) = xt_seri(ixt,i,k) qx(i,k,iqIsoPha(ixt,iliq)) = xtl_seri(ixt,i,k) IF (nqo.ge.3) THEN qx(i,k,iqIsoPha(ixt,isol)) = xts_seri(ixt,i,k) endif enddo !do ixt=1,niso END DO END DO END SUBROUTINE together END MODULE isotopes_routines_mod #endif