#ifdef ISO ! $Id: isotopes_routines_mod.F90 5748 2025-07-02 10:00:08Z dcugnet $ MODULE isotopes_routines_mod USE infotrac_phy, ONLY: niso, ntraciso=>ntiso, index_trac=>itZonIso, ntraceurs_zone=>nzone 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 #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 USE yomcst_mod_h 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 enddo !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 endif !IF (zrfl_ancien(i) .GT.0.) THEN enddo !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 & ) endif !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 enddo !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') enddo call iso_verif_traceur(zxtrfl(1,cas_evap_liq(i)), & & 'iso_revap_fisrtilp 470a: apres stewart_explicite_vectall') enddo !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 endif !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 endif !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 endif ! 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 endif !if (iso_verif_egalite_choix_nostop( endif !if (zrfl_ancien(i).gt.0.0) then enddo !do i=1,klon endif !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 enddo !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 endif !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') endif 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) endif !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 endif !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<L -> 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)) enddo 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) enddo !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) enddo !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') enddo if (iso_eau.gt.0) then call iso_verif_egalite_choix(xtnu(iso_eau),qevap, & & 'sol_nu 185',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 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 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 419') endif !if (qevap(i).gt.ridicule_evap) then endif !if ((iso_O17.gt.0).and.(iso_O18.gt.0)) then #endif endif !if (h.lt.0.01) then endif ! if f>0.9 endif ! if h>0.99 endif !if (f.lt.ridicule) then #ifdef ISOVERIF do ixt=1,niso call iso_verif_noNAN(xtnu(ixt), & & 'iso_evap_sol_nu 194') enddo ! 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) endif !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 endif !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) 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(( & & xtsol(iso_HDO,i)/qsol(i))/faccond, & & 'iso_surf>calcul_Rsol 301') 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( & & (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) endif !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) enddo !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) endif !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) endif #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) endif !if (q1lay(i).gt.ridicule) then endif !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) 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 374') 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 548') 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 return 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 enddo return endif 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) endif !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 enddo !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) endif !if (iso_verif_egalite enddo !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 endif !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 endif 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 endif ! 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 enddo !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)) enddo !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<<qp0/fac_ftmr veut dire que la vapeur varie peu do ixt=1,niso Revap0(ixt,il)=tdifrel(IXT)**(tdifexp) & & *(Rl0(ixt,il)/alphap(ixt,il) & & -h(il)*Rb0(ixt,il))/(1-h(il)) Exi(ixt,il)=Eqi(il)*Revap0(ixt,il) Pxtiinf(ixt,il)=Pxtisup(ixt,il)-Exi(ixt,il) xtnew(ixt,il)=xtp0(ixt,il)+Exi(ixt,il)*fac_ftmr(il) #ifdef ISOVERIF Rlfin(ixt)=Pxtiinf(ixt,il)/Pqiinf(il) Rbfin(ixt)=xtnew(ixt,il)/(qp0(il)+Eqi(il)*fac_ftmr(il)) #endif ! ! modif du 4 sept 2007: on simplifie ! Revap(ixt,il)=Revap0(ixt,il) ! modif abandonnée Revapfin(ixt,il)=tdifrel(IXT)**(tdifexp) & & *(Pxtiinf(ixt,il)/Pqiinf(il)/alphap(ixt,il) & & -h(il)*xtnew(ixt,il)/(qp0(il)+Eqi(il)*fac_ftmr(il))) & & /(1-h(il)) Revap(ixt,il)=0.5*(Revap0(ixt,il)+Revapfin(ixt,il)) Exi(ixt,il)=Eqi(il)*Revap(ixt,il) Exi(ixt,il)=max(min(Exi(ixt,il),Pxtisup(ixt,il)), & & -xtp0(ixt,il)/fac_ftmr(il)) Pxtiinf(ixt,il)=Pxtisup(ixt,il)-Exi(ixt,il) xtnew(ixt,il)=xtp0(ixt,il)+Exi(ixt,il)*fac_ftmr(il) enddo !do ixt=1,niso ! verifs #ifdef ISOVERIF do ixt=1,niso call iso_verif_noNAN((Pxtiinf(ixt,il)), & & 'stewart_explicite 395') call iso_verif_noNAN((Exi(ixt,il)), & & 'stewart_explicite 396') call iso_verif_noNAN((xtnew(ixt,il)), & & 'stewart_explicite 397') enddo !do ixt=1,niso if (iso_eau.gt.0) then call iso_verif_egalite_choix( & & (Pxtiinf(iso_eau,il)), & & (Pqiinf(il)),'stewart_explicite 418', & & errmax,errmaxrel) call iso_verif_egalite_choix( & & (Exi(iso_eau,il)), & & (Eqi(il)),'stewart_explicite 419', & & errmax,errmaxrel) if (iso_verif_egalite_choix_nostop( & & (Exi(iso_eau,il)*fac_ftmr(il)), & & (Eqi(il)*fac_ftmr(il)), & & 'stewart_expilicit 344', & & errmax*10,errmaxrel*10).eq.1) then write(*,*) 'Rl0,Rb0=',Rl0(iso_eau,il),Rb0(iso_eau,il) write(*,*) 'Revap0=',Revap0(iso_eau,il) write(*,*) 'Eqi,Pqisup,Pxtisup,Pqiinf=', & & Eqi(il),Pqisup(il),Pxtisup(iso_eau,il),Pqiinf(il) write(*,*) 'fac_ftmr,qp0,xtp0=', & & fac_ftmr(il),qp0(il),xtp0(iso_eau,il) write(*,*) 'Revapfin=',Revapfin(iso_eau,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 if (iso_verif_egalite_choix_nostop( & & (xtnew(iso_eau,il)), & & (qp0(il)+Eqi(il)*fac_ftmr(il)), & & 'stewart_explicite 380',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=',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( 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 384') endif !(iso_HDO.gt.0).and.(ixt.eq.iso_HDO) 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 603').eq.1) then write(*,*) 'qp0(il),Eqi(il),fac_ftmr(il)=', & & qp0(il),Eqi(il),fac_ftmr(il) write(*,*) 'Pqisup(il)=',Pqisup(il) write(*,*) 'Rl0(iso_HDO,il),Rb0(iso_HDO,il)=', & & Rl0(iso_HDO,il),Rb0(iso_HDO,il) write(*,*)'Revap0(iso_HDO,il),Revapfin(iso_HDO,il)=', & & Revap0(iso_HDO,il),Revapfin(iso_HDO,il) write(*,*) 'Revap(iso_HDO,il)=',Revap(iso_HDO,il) write(*,*) 'Rlfin,Rbfin=', & & Rlfin(iso_HDO),Rbfin(iso_HDO) write(*,*) 'h(il),alphap(iso_HDO,il),(D/D'')^n=', & & h(il),alphap(iso_HDO,il),tdifrel(iso_HDO)**(tdifexp) write(*,*) 'deltaDl0,deltaDb0=', & & deltaD((Rl0(iso_HDO,il))), & & deltaD((Rb0(iso_HDO,il))) write(*,*) 'deltaDe0,deltaDefin,deltaDe=', & & deltaD((Revap0(iso_HDO,il))), & & deltaD((Revapfin(iso_HDO,il))), & & deltaD((Revap(iso_HDO,il))) write(*,*) 'deltaDlfin,deltaDbfin=', & & deltaD((Rlfin(iso_HDO))), & & deltaD((Rbfin(iso_HDO))) stop endif !if (iso_verif_aberrant_nostop(( 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 663: cas où réévap faible' write(*,*) 'ordre 1 pour la vapeur et le liquide' write(*,*) 'Eqi(il),deltaD=',Eqi(il), & & deltaD((Exi(iso_HDO,il)/Eqi(il))) endif #endif ! end verif else ! f.gt.0.99 ! *** cas où pas d'air if ((h(il).lt.1e-3).or.(qp0(il).lt.1e-8)) then ! write(*,*) 'stewart_explicit 349: cas pas d''air' !**** calcul de Rl ! Rl=Rl0*f**beta ! on fait autrement pour éviter ! underflow exception si f trop petit et beta >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') enddo !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 endif !if (Eqi(il)*fac_ftmr(il)/qp0(il).lt.5e-2) then endif !if ((h.lt.1e-3).or.(qp0.lt.1e-8)) then endif !if (h(il).gt.0.99) then endif !if ((f(il).lt.1e-9).or.(Pqiinf(il).lt.ridicule/10.)) then endif !!if ((Eqi(il)*fac_ftmr(il).lt.ridicule).and.(h(il).lt.0.99)) then endif ! Pqisup.le.0 enddo ! 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) enddo !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 enddo !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 enddo !do il=1,ncas_Jsimple endif !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 enddo !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 enddo !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 endif !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 enddo !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)) enddo ! 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 endif !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') 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 ((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 ! verif #ifdef ISOVERIF do ixt=1,niso call iso_verif_noNaN((xtnew(ixt,il)), & & 'stewart_glace 140') enddo !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 endif !if (Pqisup(il).eq.0) then enddo !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 endif 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') endif !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') endif !if ((iso_HDO.gt.0).and.(ixt.eq.iso_HDO).and. enddo !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 #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 yoethf_mod_h USE yomcst_mod_h USE dimensions_mod, ONLY: iim, jjm, llm, ndm implicit none ! gestion de la neige: on precipte dessus, sublime, effondre, ! fond, etc... ! commun aux dfférentes sous-surfaces. INCLUDE "FCTTRE.h" ! !INCLUDE "paramet.h" ! 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 #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 yoethf_mod_h USE yomcst_mod_h 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 return 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 return 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 return 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 #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 yoethf_mod_h USE dimensions_mod, ONLY: iim, jjm, llm, ndm USE paramet_mod_h USE yomcst_mod_h 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 return 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 mod_grid_phy_lmdz !USE mod_phys_lmdz_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 write_field_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 #ifdef ISOVERIF USE isotopes_verif_mod #endif USE compbl_mod_h USE clesphys_mod_h implicit none ! equivalent de phyetat0 pour les isotopes !#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 RETURN 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 mod_grid_phy_lmdz !USE mod_phys_lmdz_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 write_field_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 #ifdef ISOVERIF USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: index_iso,index_zone,izone_init #endif USE compbl_mod_h USE clesphys_mod_h implicit none ! 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 strings_mod, ONLY: strIdx, strHead, strTail, maxlen, msg, num2str #ifdef ISOVERIF USE isotopes_verif_mod #endif #ifdef ISOTRAC USE isotrac_mod, ONLY: strtrac, initialisation_isotrac, index_iso, index_zone, izone_init #endif USE compbl_mod_h USE clesphys_mod_h IMPLICIT NONE 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(num2str(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_<iso>[_<tag>]" 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 ! endif ISOVERIF #endif ! endif 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 geometry_mod, only: latitude_deg,longitude_deg, & ! en degré, remplace rlat et rlon & latitude,longitude ! en radian, remplace rlatd et rlond #ifdef ISOVERIF USE isotopes_verif_mod #endif USE yomcst_mod_h 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 return 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) return 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 return 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 geometry_mod, 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 return 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 geometry_mod, only: latitude_deg,longitude_deg #ifdef ISOVERIF USE isotopes_verif_mod #endif USE dimensions_mod, ONLY: iim, jjm, llm, ndm USE yomcst_mod_h 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 k<klev write(*,*) 'Pb subroutine coord_prod_nucl_HTO (kmin>kmax)' 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 return 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 geometry_mod, only: cell_area use dimphy, only: klon,klev #ifdef ISOVERIF USE isotopes_verif_mod #endif USE yomcst_mod_h 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<klev)' write(*,*) 'kmin_HTO devrait etre plus petit que kmax_HTO' write(*,*) 'kmin_HTO,kmax_HTO',kmin_jessai,kmax_jessai write(*,*) 'ixt,i,k',ixt,j,k write(*,*) 'coord_HTO', coord_jessai stop endif if ((prod_nucl_tmp(j,k).le.0.).or. & & (prod_nucl(ixt,j,k).le.0.)) then write(*,*) 'Pb subroutine calcul_prod_nucl_HTO (k<klev)' write(*,*) 'prod_nucl_tmp(i,k) ou d_xt_prod_nucl devraient etre positifs' write(*,*) 'ixt,i,k',ixt,j,k write(*,*) 'RG, cell_area=', RG, cell_area(j) 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(j,kmin_jessai), paprs(j,kmax_jessai) write(*,*) 'prod_nucl_tmp(i,k)', prod_nucl_tmp(j,k) write(*,*) 'd_xt_prod_nucl(ixt,i,k)',prod_nucl(ixt,j,k) stop endif #endif enddo else ! si kmin = klev (et donc kmax = klev si tout va bien) do k=kmin_jessai,kmax_jessai prod_nucl_tmp(j,k) = & & (P_jessai/day_sec)/( & & (paprs(j,kmin_jessai)-paprs(j,kmax_jessai+1)) & & /RG*cell_area(j) ) prod_nucl(ixt,j,k)=prod_nucl(ixt,j,k)+prod_nucl_tmp(j,k) #ifdef ISOVERIF if ((kmin_jessai.ne.kmax_jessai).and. & & (kmin_jessai.ne.klev)) then write(*,*) 'Pb subroutine calcul_prod_nucl_HTO (k=klev)' write(*,*) 'kmin_HTO et kmax_HTO devraient etre egaux a klev' write(*,*) 'kmin_HTO,kmax_HTO',kmin_jessai,kmax_jessai write(*,*) 'ixt,i,k',ixt,j,k write(*,*) 'coord_HTO', coord_jessai stop endif if ((prod_nucl_tmp(j,k).le.0.).or. & & (prod_nucl(ixt,j,k).le.0.)) then write(*,*) 'Pb subroutine calcul_prod_nucl_HTO (k=klev)' write(*,*) 'prod_nucl_tmp(i,k) ou d_xt_prod_nucl devraient etre positifs' write(*,*) 'ixt,i,k',ixt,j,k write(*,*) 'RG, cell_area(i)', RG, cell_area(j) 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+1)', & & paprs(j,kmin_jessai), paprs(j,kmax_jessai+1) write(*,*) 'prod_nucl_tmp(i,k)', prod_nucl_tmp(j,k) write(*,*) 'd_xt_prod_nucl(ixt,i,k)',prod_nucl(ixt,j,k) stop endif #endif enddo endif !#ifdef ISOVERIF ! do i=1,klon ! do k=1,klev ! write(*,*) 'controle calcul_prod_nucl_HTO' !ok ! write(*,*) 'call if ok_prod_nucl_tritium, iso_HTO, nbombe>=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 return 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 return 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 return 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 enddo enddo 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 enddo enddo end subroutine together END MODULE isotopes_routines_mod #endif