! ! $Id: mod_1D_cases_read.F90 2373 2015-10-13 17:28:01Z jyg $ ! MODULE mod_1D_cases_read_std !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !Declarations specifiques au cas standard character*80 :: fich_cas ! Discr?tisation integer nlev_cas, nt_cas real zzs_cas,pp_cas !profils environnementaux real, allocatable:: ppforc_cas(:,:),plev_cas(:,:) !profils initiaux real, allocatable:: zzforc_cas(:,:) real, allocatable:: qt0_cas(:),qv0_cas(:),ql0_cas(:),qi0_cas(:),tke_cas(:) real, allocatable:: rt0_cas(:),rv0_cas(:),rl0_cas(:),ri0_cas(:),rh0_cas(:) real, allocatable:: temp0_cas(:),theta0_cas(:), thetal0_cas(:) real, allocatable:: u0_cas(:),v0_cas(:),w_cas(:,:),omega_cas(:,:),ug_cas(:,:), vg_cas(:,:) real, allocatable:: t_cas(:),theta_cas(:), thl_cas(:),u_cas(:),v_cas(:) !advections et nudging real, allocatable:: uadv_cas(:,:),vadv_cas(:,:) real, allocatable:: tadv_cas(:,:),thadv_cas(:,:),thladv_cas(:,:) real, allocatable:: qtadv_cas(:,:),qvadv_cas(:,:) real, allocatable:: rtadv_cas(:,:),rvadv_cas(:,:) real, allocatable:: trad_cas(:,:),thrad_cas(:,:),thlrad_cas(:,:) real, allocatable:: temp_nudg_cas(:,:),th_nudg_cas(:,:),thl_nudg_cas(:,:) real, allocatable:: qv_nudg_cas(:,:),qt_nudg_cas(:,:) real, allocatable:: rv_nudg_cas(:,:),rt_nudg_cas(:,:) real, allocatable:: u_nudg_cas(:,:),v_nudg_cas(:,:) ! flux real, allocatable:: lat_cas(:),sens_cas(:),ustar_cas(:) real, allocatable:: ts_cas(:),ps_cas(:),ps_forc_cas(:) real, allocatable:: wpthetap_cas(:),wpqvp_cas(:),wpqtp_cas(:),wprvp_cas(:),wprtp_cas(:) !champs interpoles real, allocatable:: plev_prof_cas(:) real, allocatable:: plev_forc_prof_cas(:) real, allocatable:: pforc_prof_cas(:) real, allocatable:: t_prof_cas(:),th_prof_cas(:),thl_prof_cas(:) real, allocatable:: qt_prof_cas(:),qv_prof_cas(:),ql_prof_cas(:),qi_prof_cas(:) real, allocatable:: rh_prof_cas(:) real, allocatable:: rt_prof_cas(:),rv_prof_cas(:),rl_prof_cas(:),ri_prof_cas(:) real, allocatable:: u_prof_cas(:),v_prof_cas(:),w_prof_cas(:),omega_prof_cas(:) real, allocatable:: ug_prof_cas(:),vg_prof_cas(:) real, allocatable:: uadv_prof_cas(:),vadv_prof_cas(:),tadv_prof_cas(:),thadv_prof_cas(:),thladv_prof_cas(:) real, allocatable:: qtadv_prof_cas(:),qvadv_prof_cas(:),rtadv_prof_cas(:),rvadv_prof_cas(:) real, allocatable:: temp_nudg_prof_cas(:), th_nudg_prof_cas(:), thl_nudg_prof_cas(:) real, allocatable:: qv_nudg_prof_cas(:), qt_nudg_prof_cas(:), rv_nudg_prof_cas(:), rt_nudg_prof_cas(:) real, allocatable:: u_nudg_prof_cas(:),v_nudg_prof_cas(:) real, allocatable:: trad_prof_cas(:),thrad_prof_cas(:),thlrad_prof_cas(:) real lat_prof_cas,sens_prof_cas,ts_prof_cas,ps_prof_cas,ps_forc_prof_cas,ustar_prof_cas,tke_prof_cas real wpqtp_prof_cas,wpqvp_prof_cas,wprtp_prof_cas,wprvp_prof_cas,wpthetap_prof_cas ! real o3_cas,orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough,rugos_cas,sand_cas,clay_cas CONTAINS !********************************************************************************************** SUBROUTINE read_SCM_cas implicit none #include "netcdf.inc" #include "date_cas.h" INTEGER nid,rid,ierr INTEGER ii,jj,timeid REAL, ALLOCATABLE :: time_val(:) print*,'ON EST VRAIMENT LA' fich_cas='cas.nc' print*,'fich_cas ',fich_cas ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid) print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid if (ierr.NE.NF_NOERR) then write(*,*) 'ERROR: GROS Pb opening forcings nc file ' write(*,*) NF_STRERROR(ierr) stop "" endif !....................................................................... ierr=NF_INQ_DIMID(nid,'lat',rid) IF (ierr.NE.NF_NOERR) THEN print*, 'Oh probleme lecture dimension lat' ENDIF ierr=NF_INQ_DIMLEN(nid,rid,ii) print*,'OK1 read2: nid,rid,lat',nid,rid,ii !....................................................................... ierr=NF_INQ_DIMID(nid,'lon',rid) IF (ierr.NE.NF_NOERR) THEN print*, 'Oh probleme lecture dimension lon' ENDIF ierr=NF_INQ_DIMLEN(nid,rid,jj) print*,'OK2 read2: nid,rid,lat',nid,rid,jj !....................................................................... ierr=NF_INQ_DIMID(nid,'lev',rid) IF (ierr.NE.NF_NOERR) THEN print*, 'Oh probleme lecture dimension nlev' ENDIF ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas) print*,'OK3 read2: nid,rid,nlev_cas',nid,rid,nlev_cas IF ( .NOT. ( nlev_cas > 10 .AND. nlev_cas < 200000 )) THEN print*,'Valeur de nlev_cas peu probable' STOP ENDIF !....................................................................... ierr=NF_INQ_DIMID(nid,'time',rid) nt_cas=0 IF (ierr.NE.NF_NOERR) THEN stop 'Oh probleme lecture dimension time' ENDIF ierr=NF_INQ_DIMLEN(nid,rid,nt_cas) print*,'OK4 read2: nid,rid,nt_cas',nid,rid,nt_cas ! Lecture de l'axe des temps print*,'LECTURE DU TEMPS' ierr=NF_INQ_VARID(nid,'time',timeid) if(ierr/=NF_NOERR) then print *,'Variable time manquante dans cas.nc:' ierr=NF_NOERR else allocate(time_val(nt_cas)) #ifdef NC_DOUBLE ierr = NF_GET_VAR_DOUBLE(nid,timeid,time_val) #else ierr = NF_GET_VAR_REAL(nid,timeid,time_val) #endif if(ierr/=NF_NOERR) then print *,'Pb a la lecture de time cas.nc: ' endif endif IF (nt_cas>1) THEN pdt_cas=time_val(2)-time_val(1) ELSE pdt_cas=0. ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! allocate(zzforc_cas(nlev_cas,nt_cas)) allocate(ppforc_cas(nlev_cas,nt_cas)) !profils initiaux allocate(temp0_cas(nlev_cas),theta0_cas(nlev_cas),thetal0_cas(nlev_cas),tke_cas(nlev_cas)) allocate(qt0_cas(nlev_cas),qv0_cas(nlev_cas),ql0_cas(nlev_cas),qi0_cas(nlev_cas),u0_cas(nlev_cas),v0_cas(nlev_cas)) allocate(rt0_cas(nlev_cas),rv0_cas(nlev_cas),rl0_cas(nlev_cas),ri0_cas(nlev_cas),rh0_cas(nlev_cas)) allocate(t_cas(nlev_cas),theta_cas(nlev_cas),thl_cas(nlev_cas),u_cas(nlev_cas),v_cas(nlev_cas)) allocate(w_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas)) allocate(ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas)) !advections et nudging allocate(uadv_cas(nlev_cas,nt_cas),vadv_cas(nlev_cas,nt_cas)) allocate(tadv_cas(nlev_cas,nt_cas),thadv_cas(nlev_cas,nt_cas),thladv_cas(nlev_cas,nt_cas)) allocate(qtadv_cas(nlev_cas,nt_cas),qvadv_cas(nlev_cas,nt_cas)) allocate(rtadv_cas(nlev_cas,nt_cas),rvadv_cas(nlev_cas,nt_cas)) allocate(trad_cas(nlev_cas,nt_cas),thrad_cas(nlev_cas,nt_cas),thlrad_cas(nlev_cas,nt_cas)) allocate(temp_nudg_cas(nlev_cas,nt_cas),th_nudg_cas(nlev_cas,nt_cas),thl_nudg_cas(nlev_cas,nt_cas)) allocate(qv_nudg_cas(nlev_cas,nt_cas),qt_nudg_cas(nlev_cas,nt_cas)) allocate(rv_nudg_cas(nlev_cas,nt_cas),rt_nudg_cas(nlev_cas,nt_cas)) allocate(u_nudg_cas(nlev_cas,nt_cas),v_nudg_cas(nlev_cas,nt_cas)) ! flux allocate(lat_cas(nt_cas),sens_cas(nt_cas),ustar_cas(nt_cas)) allocate(ts_cas(nt_cas),ps_cas(nt_cas),ps_forc_cas(nt_cas)) allocate(wpthetap_cas(nt_cas),wpqvp_cas(nt_cas),wpqtp_cas(nt_cas),wprvp_cas(nt_cas),wprtp_cas(nt_cas)) !champs interpoles allocate(plev_prof_cas(nlev_cas)) allocate(t_prof_cas(nlev_cas)) allocate(th_prof_cas(nlev_cas)) allocate(thl_prof_cas(nlev_cas)) allocate(qt_prof_cas(nlev_cas)) allocate(qv_prof_cas(nlev_cas)) allocate(ql_prof_cas(nlev_cas)) allocate(qi_prof_cas(nlev_cas)) allocate(rh_prof_cas(nlev_cas)) allocate(rt_prof_cas(nlev_cas)) allocate(rv_prof_cas(nlev_cas)) allocate(rl_prof_cas(nlev_cas)) allocate(ri_prof_cas(nlev_cas)) allocate(u_prof_cas(nlev_cas)) allocate(v_prof_cas(nlev_cas)) allocate(w_prof_cas(nlev_cas)) allocate(omega_prof_cas(nlev_cas)) allocate(ug_prof_cas(nlev_cas)) allocate(vg_prof_cas(nlev_cas)) allocate(temp_nudg_prof_cas(nlev_cas),th_nudg_prof_cas(nlev_cas),thl_nudg_prof_cas(nlev_cas)) allocate(qt_nudg_prof_cas(nlev_cas),qv_nudg_prof_cas(nlev_cas),rt_nudg_prof_cas(nlev_cas),rv_nudg_prof_cas(nlev_cas)) allocate(u_nudg_prof_cas(nlev_cas),v_nudg_prof_cas(nlev_cas)) print*,'Allocations OK' CALL read_SCM(nid,nlev_cas,nt_cas, & & zzs_cas,pp_cas,zzforc_cas,ppforc_cas,temp0_cas,theta0_cas,thetal0_cas,qt0_cas,qv0_cas,ql0_cas,qi0_cas, & & rh0_cas,rt0_cas,rv0_cas,rl0_cas,ri0_cas, & & u0_cas,v0_cas,w_cas,omega_cas,ug_cas,vg_cas,uadv_cas,vadv_cas,tadv_cas,thadv_cas,thladv_cas, & & qvadv_cas,qtadv_cas,rvadv_cas,rtadv_cas, & & temp_nudg_cas,th_nudg_cas,thl_nudg_cas,qv_nudg_cas,qt_nudg_cas,rv_nudg_cas,rt_nudg_cas,u_nudg_cas,v_nudg_cas, & & trad_cas,thrad_cas,thlrad_cas,tke_cas,sens_cas,lat_cas,ts_cas,ps_cas,ps_forc_cas,ustar_cas, & & wpthetap_cas,wpqvp_cas,wpqtp_cas,wprvp_cas,wprtp_cas) print*,'read_SCM cas OK' do ii=1,nlev_cas print*,'apres read2_SCM, plev_cas=',ii,ppforc_cas(ii,1) !print*,'apres read_SCM, plev_cas=',ii,omega_cas(ii,nt_cas/2+1) enddo END SUBROUTINE read_SCM_cas !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SUBROUTINE deallocate2_1D_cases deallocate(zzforc_cas) deallocate(ppforc_cas) !profils initiaux deallocate(temp0_cas,theta0_cas,thetal0_cas) deallocate(qt0_cas,qv0_cas,ql0_cas,qi0_cas,u0_cas,v0_cas) deallocate(rt0_cas,rv0_cas,rl0_cas,ri0_cas,rh0_cas,tke_cas) deallocate(t_cas,theta_cas,thl_cas,u_cas,v_cas) deallocate(w_cas,omega_cas) deallocate(ug_cas,vg_cas) !advections et nudging deallocate(uadv_cas,vadv_cas) deallocate(tadv_cas,thadv_cas,thladv_cas) deallocate(qtadv_cas,qvadv_cas) deallocate(rtadv_cas,rvadv_cas) deallocate(trad_cas,thrad_cas,thlrad_cas) deallocate(temp_nudg_cas,th_nudg_cas,thl_nudg_cas) deallocate(qv_nudg_cas,qt_nudg_cas) deallocate(rv_nudg_cas,rt_nudg_cas) deallocate(u_nudg_cas,v_nudg_cas) ! flux deallocate(lat_cas,sens_cas,ustar_cas) deallocate(ts_cas,ps_cas,ps_forc_cas) deallocate(wpthetap_cas,wpqvp_cas,wpqtp_cas,wprvp_cas,wprtp_cas) !champs interpoles deallocate (plev_prof_cas) deallocate (t_prof_cas) deallocate (th_prof_cas) deallocate (thl_prof_cas) deallocate (qt_prof_cas) deallocate (qv_prof_cas) deallocate (ql_prof_cas) deallocate (qi_prof_cas) deallocate (rh_prof_cas) deallocate (rt_prof_cas) deallocate (rv_prof_cas) deallocate (rl_prof_cas) deallocate (ri_prof_cas) deallocate (u_prof_cas) deallocate (v_prof_cas) deallocate (w_prof_cas) deallocate (omega_prof_cas) deallocate (ug_prof_cas) deallocate (vg_prof_cas) deallocate (temp_nudg_prof_cas,th_nudg_prof_cas,thl_nudg_prof_cas) deallocate (qt_nudg_prof_cas,qv_nudg_prof_cas,rt_nudg_prof_cas,rv_nudg_prof_cas) deallocate (u_nudg_prof_cas,v_nudg_prof_cas) END SUBROUTINE deallocate2_1D_cases !===================================================================== SUBROUTINE read_SCM(nid,nlevel,ntime, & & zzs,pp,zzforc,ppforc,temp0,theta0,thetal0,qt0,qv0,ql0,qi0,rh0,rt0,rv0,rl0,ri0, & & u0,v0,w,omega,ug,vg,uadv,vadv,tadv,thadv,thladv,qvadv,qtadv,rvadv,rtadv, & & temp_nudg,th_nudg,thl_nudg,qv_nudg,qt_nudg,rv_nudg,rt_nudg,u_nudg,v_nudg, & & trad,thrad,thlrad,tke,sens,flat,ts,ps,ps_forc,ustar, & & wpthetap,wpqvp,wpqtp,wprvp,wprtp) !program reading forcing of the case study implicit none #include "netcdf.inc" #include "compar1d_std.h" integer ntime,nlevel,k,t real zzs,zzforc(nlevel,ntime) real pp,ppforc(nlevel,ntime) !profils initiaux real temp0(nlevel),theta0(nlevel),thetal0(nlevel),tke(nlevel) real temp(nlevel,ntime),qv(nlevel,ntime),ql(nlevel,ntime),qi(nlevel,ntime),u(nlevel,ntime),v(nlevel,ntime) real qt0(nlevel),qv0(nlevel),ql0(nlevel),qi0(nlevel),u0(nlevel),v0(nlevel) real rt0(nlevel),rv0(nlevel),rl0(nlevel),ri0(nlevel),rh0(nlevel) real w(nlevel,ntime),omega(nlevel,ntime) real ug(nlevel,ntime),vg(nlevel,ntime) !advections et nudging real uadv(nlevel,ntime),vadv(nlevel,ntime) real tadv(nlevel,ntime),thadv(nlevel,ntime),thladv(nlevel,ntime) real qtadv(nlevel,ntime),qvadv(nlevel,ntime) real rtadv(nlevel,ntime),rvadv(nlevel,ntime) real trad(nlevel,ntime),thrad(nlevel,ntime),thlrad(nlevel,ntime) real temp_nudg(nlevel,ntime),th_nudg(nlevel,ntime),thl_nudg(nlevel,ntime) real qv_nudg(nlevel,ntime),qt_nudg(nlevel,ntime) real rv_nudg(nlevel,ntime),rt_nudg(nlevel,ntime) real u_nudg(nlevel,ntime),v_nudg(nlevel,ntime) ! flux real flat(ntime),sens(ntime),ustar(ntime) real ts(ntime),ps(ntime),ps_forc(ntime) real wpthetap(ntime),wpqvp(ntime),wpqtp(ntime),wprtp(ntime),wprvp(ntime) real resul(nlevel,ntime),resul1(nlevel),resul2(ntime),resul3 integer nid, ierr,ierr1,ierr2,rid,i integer nbvar3d parameter(nbvar3d=55) integer var3didin(nbvar3d),missing_var(nbvar3d) character*14 name_var(1:nbvar3d) data name_var/ & ! coordonnees pression (n niveaux) profils intiaux #1-#15 & 'qt','qv','ql','qi','rt','rv','rl','ri', & & 'rh','temp','theta','thetal','u','v','tke', & ! coordonnees pression (n niveaux) + temps #16-#42 & 'height_forc','pressure_forc','w','omega','ug','vg','u_adv','v_adv', & & 'temp_adv','theta_adv','thetal_adv','qt_adv','qv_adv','rt_adv','rv_adv', & & 'temp_rad','theta_rad','thetal_rad','temp_nudging','theta_nudging','thetal_nudging', & & 'qv_nudging','qt_nudging','rv_nudging','rt_nudging','u_nudging','v_nudging', & ! coordonnees temps #43-#53 & 'sfc_sens_flx','sfc_lat_flx','ts','ps','ps_forc','ustar', & & 'wpthetap','wpqvp','wpqtp','wprtp','wprvp', & ! scalaires #54-55 & 'height','pressure'/ !----------------------------------------------------------------------- ! Checking availability of variable #i in the cas.nc file ! missing_var=1 if the variable is missing !----------------------------------------------------------------------- do i=1,nbvar3d missing_var(i)=0. ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) if(ierr/=NF_NOERR) then print *,'Variable manquante dans cas.nc:',i,name_var(i) ierr=NF_NOERR missing_var(i)=1 else !----------------------------------------------------------------------- ! Activating keys depending on the presence of specific variables in cas.nc !----------------------------------------------------------------------- if ( 1 == 1 ) THEN if ( name_var(i) == 'temp_nudging' .and. nint(nudging_temp)==0) stop 'Nudging inconsistency temp' if ( name_var(i) == 'theta_nudging' .and. nint(nudging_theta)==0) stop 'Nudging inconsistency theta' if ( name_var(i) == 'thetal_nudging' .and. nint(nudging_thetal)==0) stop 'Nudging inconsistency thetal' if ( name_var(i) == 'qv_nudging' .and. nint(nudging_qv)==0) stop 'Nudging inconsistency qv' if ( name_var(i) == 'qt_nudging' .and. nint(nudging_qt)==0) stop 'Nudging inconsistency qt' if ( name_var(i) == 'rv_nudging' .and. nint(nudging_rv)==0) stop 'Nudging inconsistency rv' if ( name_var(i) == 'rt_nudging' .and. nint(nudging_rt)==0) stop 'Nudging inconsistency rt' if ( name_var(i) == 'u_nudging' .and. nint(nudging_u)==0) stop 'Nudging inconsistency u' if ( name_var(i) == 'v_nudging' .and. nint(nudging_u)==0) stop 'Nudging inconsistency v' ELSE print*,'GUIDAGE : CONSISTENCY CHECK DEACTIVATED FOR TESTS of SANDU/REF' ENDIF !----------------------------------------------------------------------- ! Reading 1D (N) vertical varialbes (nlevel,lat,lon) !----------------------------------------------------------------------- if(i.LE.15) then #ifdef NC_DOUBLE ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul1) #else ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul1) #endif print *,'read2_cas(resul1), on a lu ',i,name_var(i) if(ierr/=NF_NOERR) then print *,'Pb a la lecture de cas.nc: ',name_var(i) stop "getvarup" endif print*,'Lecture de la variable #i ',i,name_var(i),minval(resul1),maxval(resul1) !----------------------------------------------------------------------- ! Reading 2D tim-vertical variables (time,nlevel,lat,lon) ! TBD : seems to be the same as above. !----------------------------------------------------------------------- else if(i.ge.16.and.i.LE.42) then #ifdef NC_DOUBLE ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul) #else ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul) #endif print *,'read2_cas(resul), on a lu ',i,name_var(i) if(ierr/=NF_NOERR) then print *,'Pb a la lecture de cas.nc: ',name_var(i) stop "getvarup" endif print*,'Lecture de la variable #i ',i,name_var(i),minval(resul),maxval(resul) !----------------------------------------------------------------------- ! Reading 1D time variables (time,lat,lon) !----------------------------------------------------------------------- else if (i.gt.43.and.i.LE.53) then #ifdef NC_DOUBLE ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul2) #else ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul2) #endif print *,'read2_cas(resul2), on a lu ',i,name_var(i) if(ierr/=NF_NOERR) then print *,'Pb a la lecture de cas.nc: ',name_var(i) stop "getvarup" endif print*,'Lecture de la variable #i ',i,name_var(i),minval(resul2),maxval(resul2) !----------------------------------------------------------------------- ! Reading scalar variables (t0,lat,lon) !----------------------------------------------------------------------- else #ifdef NC_DOUBLE ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul3) #else ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul3) #endif print *,'read2_cas(resul3), on a lu ',i,name_var(i) if(ierr/=NF_NOERR) then print *,'Pb a la lecture de cas.nc: ',name_var(i) stop "getvarup" endif print*,'Lecture de la variable #i ',i,name_var(i),resul3 endif endif !----------------------------------------------------------------------- ! Attributing variables !----------------------------------------------------------------------- select case(i) case(1) ; qt0 =resul1 case(2) ; qv0 =resul1 case(3) ; ql0 =resul1 case(4) ; qi0 =resul1 case(5) ; rt0 =resul1 case(6) ; rv0 =resul1 case(7) ; rl0 =resul1 case(8) ; ri0 =resul1 case(9) ; rh0 =resul1 case(10) ; temp0 =resul1 case(11) ; theta0 =resul1 case(12) ; thetal0 =resul1 case(13) ; u0 =resul1 case(14) ; v0 =resul1 case(15) ; tke =resul1 case(16) ; zzforc =resul ! donnees indexees en nlevel,time case(17) ; ppforc =resul case(18) ; w =resul case(19) ; omega =resul case(20) ; ug =resul case(21) ; vg =resul case(22) ; uadv =resul case(23) ; vadv =resul case(24) ; tadv =resul case(25) ; thadv =resul case(26) ; thladv =resul case(27) ; qtadv =resul case(28) ; qvadv =resul case(29) ; rtadv =resul case(30) ; rvadv =resul case(31) ; trad =resul case(32) ; thrad =resul case(33) ; thlrad =resul case(34) ; temp_nudg =resul case(35) ; th_nudg =resul case(36) ; thl_nudg =resul case(37) ; qv_nudg =resul case(38) ; qt_nudg =resul case(39) ; rv_nudg =resul case(40) ; rt_nudg =resul case(41) ; u_nudg =resul case(42) ; v_nudg =resul case(43) ; sens =resul2 ! donnees indexees en time seulement case(44) ; flat =resul2 case(45) ; ts =resul2 case(46) ; ps =resul2 case(47) ; ps_forc =resul2 case(48) ; ustar =resul2 case(49) ; wpthetap =resul2 case(50) ; wpqvp =resul2 case(51) ; wpqtp =resul2 case(52) ; wprvp =resul2 case(53) ; wprtp =resul2 case(54) ; zzs =resul3 ! scalaires case(55) ; pp =resul3 end select resul=0. resul1=0. resul2=0. resul3=0. enddo ! print*,'Lecture de la variable APRES ,sens ',minval(sens),maxval(sens) ! print*,'Lecture de la variable APRES ,flat ',minval(flat),maxval(flat) !CR:ATTENTION EN ATTENTE DE REGLER LA QUESTION DU PAS DE TEMPS INITIAL ! do t=1,ntime ! do k=1,nlevel ! temp(k,t)=temp0(k) ! qv(k,t)=qv0(k) ! ql(k,t)=ql0(k) ! qi(k,t)=qi0(k) ! u(k,t)=u0(k) ! v(k,t)=v0(k) ! !tke(k,t)=tke0(k) ! enddo ! enddo !!!! TRAVAIL : EN FONCTION DES DECISIONS SUR LA SPECIFICATION DE W !!!omega=-vitw*pres*rg/(rd*temp) !----------------------------------------------------------------------- return END SUBROUTINE read_SCM !====================================================================== !====================================================================== !********************************************************************************************** SUBROUTINE interp_case_time_std(day,day1,annee_ref & & ,nt_cas,nlev_cas & & ,ts_cas,ps_cas,ps_forc_cas,plev_cas,ppforc_cas,t_cas,th_cas,thl_cas & & ,qt_cas,qv_cas,ql_cas,qi_cas & & ,rt_cas,rv_cas,rl_cas,ri_cas,rh_cas & & ,u_cas,v_cas,w_cas,omega_cas,ug_cas,vg_cas & & ,temp_nudg_cas,th_nudg_cas,thl_nudg_cas,qt_nudg_cas,qv_nudg_cas & & ,rt_nudg_cas,rv_nudg_cas,u_nudg_cas,v_nudg_cas & & ,uadv_cas,vadv_cas,tadv_cas,thadv_cas,thladv_cas & & ,qtadv_cas,qvadv_cas,rtadv_cas,rvadv_cas & & ,trad_cas,thrad_cas,thlrad_cas & & ,tke_cas,lat_cas,sens_cas,ustar_cas & & ,wpthetap_cas,wpqtp_cas,wpqvp_cas,wprtp_cas,wprvp_cas & ! & ,ts_prof_cas,ps_prof_cas,ps_forc_prof_cas,plev_prof_cas,pforc_prof_cas& & ,t_prof_cas,th_prof_cas,thl_prof_cas & & ,qt_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas & & ,rt_prof_cas,rv_prof_cas,rl_prof_cas,ri_prof_cas,rh_prof_cas & & ,u_prof_cas,v_prof_cas,w_prof_cas,omega_prof_cas & & ,ug_prof_cas,vg_prof_cas & & ,temp_nudg_prof_cas,th_nudg_prof_cas,thl_nudg_prof_cas & & ,qt_nudg_prof_cas,qv_nudg_prof_cas & & ,rt_nudg_prof_cas,rv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas & & ,uadv_prof_cas,vadv_prof_cas,tadv_prof_cas,thadv_prof_cas,thladv_prof_cas& & ,qtadv_prof_cas,qvadv_prof_cas,rtadv_prof_cas,rvadv_prof_cas & & ,trad_prof_cas,thrad_prof_cas,thlrad_prof_cas & & ,tke_prof_cas,lat_prof_cas,sens_prof_cas,ustar_prof_cas & & ,wpthetap_prof_cas,wpqtp_prof_cas,wpqvp_prof_cas,wprtp_prof_cas,wprvp_prof_cas) implicit none !--------------------------------------------------------------------------------------- ! Time interpolation of a 2D field to the timestep corresponding to day ! ! day: current julian day (e.g. 717538.2) ! day1: first day of the simulation ! nt_cas: total nb of data in the forcing ! pdt_cas: total time interval (in sec) between 2 forcing data !--------------------------------------------------------------------------------------- #include "compar1d_std.h" #include "date_cas.h" ! inputs: integer annee_ref integer nt_cas,nlev_cas real day, day1,day_cas real ts_cas(nt_cas),ps_cas(nt_cas),ps_forc_cas(nt_cas) real plev_cas(nlev_cas,nt_cas),ppforc_cas(nt_cas) real t_cas(nlev_cas,nt_cas),th_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas) real qt_cas(nlev_cas,nt_cas),qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas),qi_cas(nlev_cas,nt_cas) real rt_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas),rl_cas(nlev_cas,nt_cas),ri_cas(nlev_cas,nt_cas) real rh_cas(nlev_cas,nt_cas),u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas) real w_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas) real ug_cas(nlev_cas,nt_cas),vg_cas(nlev_cas,nt_cas) real temp_nudg_cas(nlev_cas,nt_cas),th_nudg_cas(nlev_cas,nt_cas),thl_nudg_cas(nlev_cas,nt_cas) real qt_nudg_cas(nlev_cas,nt_cas),qv_nudg_cas(nlev_cas,nt_cas) real rt_nudg_cas(nlev_cas,nt_cas),rv_nudg_cas(nlev_cas,nt_cas) real u_nudg_cas(nlev_cas,nt_cas),v_nudg_cas(nlev_cas,nt_cas) real uadv_cas(nlev_cas,nt_cas),vadv_cas(nlev_cas,nt_cas) real tadv_cas(nlev_cas,nt_cas),thadv_cas(nlev_cas,nt_cas),thladv_cas(nlev_cas,nt_cas) real qtadv_cas(nlev_cas,nt_cas),qvadv_cas(nlev_cas,nt_cas) real rtadv_cas(nlev_cas,nt_cas),rvadv_cas(nlev_cas,nt_cas) real trad_cas(nlev_cas,nt_cas),thrad_cas(nlev_cas,nt_cas),thlrad_cas(nlev_cas,nt_cas) real lat_cas(nt_cas),sens_cas(nt_cas),tke_cas(nt_cas) real wpthetap_cas(nt_cas),wpqtp_cas(nt_cas),wpqvp_cas(nt_cas) real ustar_cas(nt_cas),wprtp_cas(nt_cas),wprvp_cas(nt_cas) ! output: real plev_prof_cas(nlev_cas),pforc_prof_cas(nt_cas) real t_prof_cas(nlev_cas),th_prof_cas(nlev_cas),thl_prof_cas(nlev_cas) real qt_prof_cas(nlev_cas),qv_prof_cas(nlev_cas),ql_prof_cas(nlev_cas),qi_prof_cas(nlev_cas) real rt_prof_cas(nlev_cas),rv_prof_cas(nlev_cas),rl_prof_cas(nlev_cas),ri_prof_cas(nlev_cas) real rh_prof_cas(nlev_cas),u_prof_cas(nlev_cas),v_prof_cas(nlev_cas) real w_prof_cas(nlev_cas),omega_prof_cas(nlev_cas) real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas) real temp_nudg_prof_cas(nlev_cas),th_nudg_prof_cas(nlev_cas),thl_nudg_prof_cas(nlev_cas) real qt_nudg_prof_cas(nlev_cas),qv_nudg_prof_cas(nlev_cas) real rt_nudg_prof_cas(nlev_cas),rv_nudg_prof_cas(nlev_cas) real u_nudg_prof_cas(nlev_cas),v_nudg_prof_cas(nlev_cas) real uadv_prof_cas(nlev_cas),vadv_prof_cas(nlev_cas) real tadv_prof_cas(nlev_cas),thadv_prof_cas(nlev_cas),thladv_prof_cas(nlev_cas) real qtadv_prof_cas(nlev_cas),qvadv_prof_cas(nlev_cas) real rtadv_prof_cas(nlev_cas),rvadv_prof_cas(nlev_cas) real trad_prof_cas(nlev_cas),thrad_prof_cas(nlev_cas),thlrad_prof_cas(nlev_cas) real lat_prof_cas,sens_prof_cas,tke_prof_cas real ts_prof_cas,ps_prof_cas,ps_forc_prof_cas real wpthetap_prof_cas,wpqtp_prof_cas,wpqvp_prof_cas real ustar_prof_cas,wprtp_prof_cas,wprvp_prof_cas ! local: integer it_cas1, it_cas2,k real timeit,time_cas1,time_cas2,frac print*,'Check time',day1,day_ju_ini_cas,day_deb+1,pdt_cas ! do k=1,nlev_cas ! print*,'debut de interp_case_time, plev_cas=',k,plev_cas(k,1) ! enddo ! On teste si la date du cas AMMA est correcte. ! C est pour memoire car en fait les fichiers .def ! sont censes etre corrects. ! A supprimer a terme (MPL 20150623) ! if ((forcing_type.eq.10).and.(1.eq.0)) then ! Check that initial day of the simulation consistent with AMMA case: ! if (annee_ref.ne.2006) then ! print*,'Pour AMMA, annee_ref doit etre 2006' ! print*,'Changer annee_ref dans run.def' ! stop ! endif ! if (annee_ref.eq.2006 .and. day1.lt.day_cas) then ! print*,'AMMA a debute le 10 juillet 2006',day1,day_cas ! print*,'Changer dayref dans run.def' ! stop ! endif ! if (annee_ref.eq.2006 .and. day1.gt.day_cas+1) then ! print*,'AMMA a fini le 11 juillet' ! print*,'Changer dayref ou nday dans run.def' ! stop ! endif ! endif ! Determine timestep relative to the 1st day: ! timeit=(day-day1)*86400. ! if (annee_ref.eq.1992) then ! timeit=(day-day_cas)*86400. ! else ! timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 1992 ! endif timeit=(day-day_ju_ini_cas)*86400 print *,'day=',day print *,'day_ju_ini_cas=',day_ju_ini_cas print *,'pdt_cas=',pdt_cas print *,'timeit=',timeit print *,'nt_cas=',nt_cas ! Determine the closest observation times: ! it_cas1=INT(timeit/pdt_cas)+1 ! it_cas2=it_cas1 + 1 ! time_cas1=(it_cas1-1)*pdt_cas ! time_cas2=(it_cas2-1)*pdt_cas it_cas1=INT(timeit/pdt_cas)+1 IF (it_cas1 .EQ. nt_cas) THEN it_cas2=it_cas1 ELSE it_cas2=it_cas1 + 1 ENDIF time_cas1=(it_cas1-1)*pdt_cas time_cas2=(it_cas2-1)*pdt_cas ! print *,'timeit,pdt_cas,nt_cas=',timeit,pdt_cas,nt_cas ! print *,'it_cas1,it_cas2,time_cas1,time_cas2=',it_cas1,it_cas2,time_cas1,time_cas2 if (it_cas1 .gt. nt_cas) then write(*,*) 'PB-stop: day, day_ju_ini_cas,it_cas1, it_cas2, timeit: ' & & ,day,day_ju_ini_cas,it_cas1,it_cas2,timeit stop endif ! time interpolation: IF (it_cas1 .EQ. it_cas2) THEN frac=0. ELSE frac=(time_cas2-timeit)/(time_cas2-time_cas1) frac=max(frac,0.0) ENDIF lat_prof_cas = lat_cas(it_cas2) & & -frac*(lat_cas(it_cas2)-lat_cas(it_cas1)) sens_prof_cas = sens_cas(it_cas2) & & -frac*(sens_cas(it_cas2)-sens_cas(it_cas1)) tke_prof_cas = tke_cas(it_cas2) & & -frac*(tke_cas(it_cas2)-tke_cas(it_cas1)) ts_prof_cas = ts_cas(it_cas2) & & -frac*(ts_cas(it_cas2)-ts_cas(it_cas1)) ps_prof_cas = ps_cas(it_cas2) & & -frac*(ps_cas(it_cas2)-ps_cas(it_cas1)) ps_forc_prof_cas = ps_forc_cas(it_cas2) & & -frac*(ps_forc_cas(it_cas2)-ps_forc_cas(it_cas1)) ustar_prof_cas = ustar_cas(it_cas2) & & -frac*(ustar_cas(it_cas2)-ustar_cas(it_cas1)) wpthetap_prof_cas = wpthetap_cas(it_cas2) & & -frac*(wpthetap_cas(it_cas2)-wpthetap_cas(it_cas1)) wpqtp_prof_cas = wpqtp_cas(it_cas2) & & -frac*(wpqtp_cas(it_cas2)-wpqtp_cas(it_cas1)) wpqvp_prof_cas = wpqvp_cas(it_cas2) & & -frac*(wpqvp_cas(it_cas2)-wpqvp_cas(it_cas1)) wprtp_prof_cas = wprtp_cas(it_cas2) & & -frac*(wprtp_cas(it_cas2)-wprtp_cas(it_cas1)) wprvp_prof_cas = wprvp_cas(it_cas2) & & -frac*(wprvp_cas(it_cas2)-wprvp_cas(it_cas1)) do k=1,nlev_cas plev_prof_cas(k) = plev_cas(k,it_cas2) & & -frac*(plev_cas(k,it_cas2)-plev_cas(k,it_cas1)) t_prof_cas(k) = t_cas(k,it_cas2) & & -frac*(t_cas(k,it_cas2)-t_cas(k,it_cas1)) !print *,'k,frac,plev_cas1,plev_cas2=',k,frac,plev_cas(k,it_cas1),plev_cas(k,it_cas2) th_prof_cas(k) = th_cas(k,it_cas2) & & -frac*(th_cas(k,it_cas2)-th_cas(k,it_cas1)) thl_prof_cas(k) = thl_cas(k,it_cas2) & & -frac*(thl_cas(k,it_cas2)-thl_cas(k,it_cas1)) qt_prof_cas(k) = qt_cas(k,it_cas2) & & -frac*(qt_cas(k,it_cas2)-qt_cas(k,it_cas1)) qv_prof_cas(k) = qv_cas(k,it_cas2) & & -frac*(qv_cas(k,it_cas2)-qv_cas(k,it_cas1)) ql_prof_cas(k) = ql_cas(k,it_cas2) & & -frac*(ql_cas(k,it_cas2)-ql_cas(k,it_cas1)) qi_prof_cas(k) = qi_cas(k,it_cas2) & & -frac*(qi_cas(k,it_cas2)-qi_cas(k,it_cas1)) rt_prof_cas(k) = rt_cas(k,it_cas2) & & -frac*(rt_cas(k,it_cas2)-rt_cas(k,it_cas1)) rv_prof_cas(k) = rv_cas(k,it_cas2) & & -frac*(rv_cas(k,it_cas2)-rv_cas(k,it_cas1)) rl_prof_cas(k) = rl_cas(k,it_cas2) & & -frac*(rl_cas(k,it_cas2)-rl_cas(k,it_cas1)) ri_prof_cas(k) = ri_cas(k,it_cas2) & & -frac*(ri_cas(k,it_cas2)-ri_cas(k,it_cas1)) rh_prof_cas(k) = rh_cas(k,it_cas2) & & -frac*(rh_cas(k,it_cas2)-rh_cas(k,it_cas1)) u_prof_cas(k) = u_cas(k,it_cas2) & & -frac*(u_cas(k,it_cas2)-u_cas(k,it_cas1)) v_prof_cas(k) = v_cas(k,it_cas2) & & -frac*(v_cas(k,it_cas2)-v_cas(k,it_cas1)) w_prof_cas(k) = w_cas(k,it_cas2) & & -frac*(w_cas(k,it_cas2)-w_cas(k,it_cas1)) omega_prof_cas(k) = omega_cas(k,it_cas2) & & -frac*(omega_cas(k,it_cas2)-omega_cas(k,it_cas1)) ug_prof_cas(k) = ug_cas(k,it_cas2) & & -frac*(ug_cas(k,it_cas2)-ug_cas(k,it_cas1)) vg_prof_cas(k) = vg_cas(k,it_cas2) & & -frac*(vg_cas(k,it_cas2)-vg_cas(k,it_cas1)) temp_nudg_prof_cas(k) = temp_nudg_cas(k,it_cas2) & & -frac*(temp_nudg_cas(k,it_cas2)-temp_nudg_cas(k,it_cas1)) th_nudg_prof_cas(k) = th_nudg_cas(k,it_cas2) & & -frac*(th_nudg_cas(k,it_cas2)-th_nudg_cas(k,it_cas1)) thl_nudg_prof_cas(k) = thl_nudg_cas(k,it_cas2) & & -frac*(thl_nudg_cas(k,it_cas2)-thl_nudg_cas(k,it_cas1)) qt_nudg_prof_cas(k) = qt_nudg_cas(k,it_cas2) & & -frac*(qt_nudg_cas(k,it_cas2)-qt_nudg_cas(k,it_cas1)) qv_nudg_prof_cas(k) = qv_nudg_cas(k,it_cas2) & & -frac*(qv_nudg_cas(k,it_cas2)-qv_nudg_cas(k,it_cas1)) rt_nudg_prof_cas(k) = rt_nudg_cas(k,it_cas2) & & -frac*(rt_nudg_cas(k,it_cas2)-rt_nudg_cas(k,it_cas1)) rv_nudg_prof_cas(k) = rv_nudg_cas(k,it_cas2) & & -frac*(rv_nudg_cas(k,it_cas2)-rv_nudg_cas(k,it_cas1)) u_nudg_prof_cas(k) = u_nudg_cas(k,it_cas2) & & -frac*(u_nudg_cas(k,it_cas2)-u_nudg_cas(k,it_cas1)) v_nudg_prof_cas(k) = v_nudg_cas(k,it_cas2) & & -frac*(v_nudg_cas(k,it_cas2)-v_nudg_cas(k,it_cas1)) uadv_prof_cas(k) = uadv_cas(k,it_cas2) & & -frac*(uadv_cas(k,it_cas2)-uadv_cas(k,it_cas1)) vadv_prof_cas(k) = vadv_cas(k,it_cas2) & & -frac*(vadv_cas(k,it_cas2)-vadv_cas(k,it_cas1)) tadv_prof_cas(k) = tadv_cas(k,it_cas2) & & -frac*(tadv_cas(k,it_cas2)-tadv_cas(k,it_cas1)) thadv_prof_cas(k) = thadv_cas(k,it_cas2) & & -frac*(thadv_cas(k,it_cas2)-thadv_cas(k,it_cas1)) thladv_prof_cas(k) = thladv_cas(k,it_cas2) & & -frac*(thladv_cas(k,it_cas2)-thladv_cas(k,it_cas1)) qtadv_prof_cas(k) = qtadv_cas(k,it_cas2) & & -frac*(qtadv_cas(k,it_cas2)-qtadv_cas(k,it_cas1)) qvadv_prof_cas(k) = qvadv_cas(k,it_cas2) & & -frac*(qvadv_cas(k,it_cas2)-qvadv_cas(k,it_cas1)) rtadv_prof_cas(k) = rtadv_cas(k,it_cas2) & & -frac*(rtadv_cas(k,it_cas2)-rtadv_cas(k,it_cas1)) rvadv_prof_cas(k) = rvadv_cas(k,it_cas2) & & -frac*(rvadv_cas(k,it_cas2)-rvadv_cas(k,it_cas1)) trad_prof_cas(k) = trad_cas(k,it_cas2) & & -frac*(trad_cas(k,it_cas2)-trad_cas(k,it_cas1)) thrad_prof_cas(k) = thrad_cas(k,it_cas2) & & -frac*(thrad_cas(k,it_cas2)-thrad_cas(k,it_cas1)) thlrad_prof_cas(k) = thlrad_cas(k,it_cas2) & & -frac*(thlrad_cas(k,it_cas2)-thlrad_cas(k,it_cas1)) enddo return END SUBROUTINE interp_case_time_std !********************************************************************************************** !===================================================================== SUBROUTINE interp_case_vertical_std(nlev_cas & & ,plev_prof_cas,t_prof_cas,th_prof_cas,thl_prof_cas & & ,qt_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas & & ,rt_prof_cas,rv_prof_cas,rl_prof_cas,ri_prof_cas,rh_prof_cas & & ,u_prof_cas,v_prof_cas,w_prof_cas,omega_prof_cas & & ,ug_prof_cas,vg_prof_cas & & ,temp_nudg_prof_cas,th_nudg_prof_cas,thl_nudg_prof_cas & & ,qt_nudg_prof_cas,qv_nudg_prof_cas & & ,rt_nudg_prof_cas,rv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas & & ,uadv_prof_cas,vadv_prof_cas,tadv_prof_cas,thadv_prof_cas,thladv_prof_cas & & ,qtadv_prof_cas,qvadv_prof_cas,rtadv_prof_cas,rvadv_prof_cas & & ,trad_prof_cas,thrad_prof_cas,thlrad_prof_cas & ! & ,plev_mod_cas,t_mod_cas,th_mod_cas,thl_mod_cas & & ,qt_mod_cas,qv_mod_cas,ql_mod_cas,qi_mod_cas & & ,rt_mod_cas,rv_mod_cas,rl_mod_cas,ri_mod_cas,rh_mod_cas & & ,u_mod_cas,v_mod_cas,w_mod_cas,omega_mod_cas & & ,ug_mod_cas,vg_mod_cas & & ,temp_nudg_mod_cas,th_nudg_mod_cas,thl_nudg_mod_cas & & ,qt_nudg_mod_cas,qv_nudg_mod_cas & & ,rt_nudg_mod_cas,rv_nudg_mod_cas,u_nudg_mod_cas,v_nudg_mod_cas & & ,uadv_mod_cas,vadv_mod_cas,tadv_mod_cas,thadv_mod_cas,thladv_mod_cas & & ,qtadv_mod_cas,qvadv_mod_cas,rtadv_mod_cas,rvadv_mod_cas & & ,trad_mod_cas,thrad_mod_cas,thlrad_mod_cas) implicit none #include "YOMCST.h" #include "dimensions.h" !------------------------------------------------------------------------- ! Vertical interpolation of generic case forcing data onto mod_casel levels !------------------------------------------------------------------------- integer nlevmax parameter (nlevmax=41) integer nlev_cas,mxcalc ! real play(llm), plev_prof(nlevmax) ! real t_prof(nlevmax),q_prof(nlevmax) ! real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax) ! real ht_prof(nlevmax),vt_prof(nlevmax) ! real hq_prof(nlevmax),vq_prof(nlevmax) real plev_prof_cas(nlev_cas) real t_prof_cas(nlev_cas),th_prof_cas(nlev_cas),thl_prof_cas(nlev_cas) real qt_prof_cas(nlev_cas),qv_prof_cas(nlev_cas),ql_prof_cas(nlev_cas),qi_prof_cas(nlev_cas) real rt_prof_cas(nlev_cas),rv_prof_cas(nlev_cas),rl_prof_cas(nlev_cas),ri_prof_cas(nlev_cas) real rh_prof_cas(nlev_cas) real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas),w_prof_cas(nlev_cas),omega_prof_cas(nlev_cas) real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas) real temp_nudg_prof_cas(nlev_cas),th_nudg_prof_cas(nlev_cas),thl_nudg_prof_cas(nlev_cas) real qt_nudg_prof_cas(nlev_cas),qv_nudg_prof_cas(nlev_cas) real rt_nudg_prof_cas(nlev_cas),rv_nudg_prof_cas(nlev_cas) real u_nudg_prof_cas(nlev_cas),v_nudg_prof_cas(nlev_cas) real uadv_prof_cas(nlev_cas),vadv_prof_cas(nlev_cas) real tadv_prof_cas(nlev_cas),thadv_prof_cas(nlev_cas),thladv_prof_cas(nlev_cas) real qtadv_prof_cas(nlev_cas),qvadv_prof_cas(nlev_cas) real rtadv_prof_cas(nlev_cas),rvadv_prof_cas(nlev_cas) real trad_prof_cas(nlev_cas),thrad_prof_cas(nlev_cas),thlrad_prof_cas(nlev_cas) real play(llm),plev_mod_cas(llm),t_mod_cas(llm),th_mod_cas(llm),thl_mod_cas(llm) real qt_mod_cas(llm),qv_mod_cas(llm),ql_mod_cas(llm),qi_mod_cas(llm) real rt_mod_cas(llm),rv_mod_cas(llm),rl_mod_cas(llm),ri_mod_cas(llm) real rh_mod_cas(llm) real u_mod_cas(llm),v_mod_cas(llm),w_mod_cas(llm),omega_mod_cas(llm) real ug_mod_cas(llm),vg_mod_cas(llm) real temp_nudg_mod_cas(llm),th_nudg_mod_cas(llm),thl_nudg_mod_cas(llm) real qt_nudg_mod_cas(llm),qv_nudg_mod_cas(llm) real rt_nudg_mod_cas(llm),rv_nudg_mod_cas(llm),u_nudg_mod_cas(llm),v_nudg_mod_cas(llm) real uadv_mod_cas(llm),vadv_mod_cas(llm) real tadv_mod_cas(llm),thadv_mod_cas(llm),thladv_mod_cas(llm) real qtadv_mod_cas(llm),qvadv_mod_cas(llm) real rtadv_mod_cas(llm),rvadv_mod_cas(llm) real trad_mod_cas(llm),thrad_mod_cas(llm),thlrad_mod_cas(llm) integer l,k,k1,k2 real frac,frac1,frac2,fact ! do l = 1, llm ! print *,'debut interp, play=',l,play(l) ! enddo ! do l = 1, nlev_cas ! print *,'debut interp, plev_prof_cas=',l,play(l),plev_prof_cas(l) ! enddo do l = 1, llm if (play(l).ge.plev_prof_cas(nlev_cas)) then mxcalc=l ! print *,'debut interp, mxcalc=',mxcalc k1=0 k2=0 if (play(l).le.plev_prof_cas(1)) then do k = 1, nlev_cas-1 if (play(l).le.plev_prof_cas(k).and. play(l).gt.plev_prof_cas(k+1)) then k1=k k2=k+1 endif enddo if (k1.eq.0 .or. k2.eq.0) then write(*,*) 'PB! k1, k2 = ',k1,k2 write(*,*) 'l,play(l) = ',l,play(l)/100 do k = 1, nlev_cas-1 write(*,*) 'k,plev_prof_cas(k) = ',k,plev_prof_cas(k)/100 enddo endif frac = (plev_prof_cas(k2)-play(l))/(plev_prof_cas(k2)-plev_prof_cas(k1)) t_mod_cas(l)= t_prof_cas(k2) - frac*(t_prof_cas(k2)-t_prof_cas(k1)) th_mod_cas(l)= th_prof_cas(k2) - frac*(th_prof_cas(k2)-th_prof_cas(k1)) if(th_mod_cas(l).NE.0) t_mod_cas(l)= th_mod_cas(l)*(play(l)/100000.)**(RD/RCPD) thl_mod_cas(l)= thl_prof_cas(k2) - frac*(thl_prof_cas(k2)-thl_prof_cas(k1)) qt_mod_cas(l)= qt_prof_cas(k2) - frac*(qt_prof_cas(k2)-qt_prof_cas(k1)) qv_mod_cas(l)= qv_prof_cas(k2) - frac*(qv_prof_cas(k2)-qv_prof_cas(k1)) ql_mod_cas(l)= ql_prof_cas(k2) - frac*(ql_prof_cas(k2)-ql_prof_cas(k1)) qi_mod_cas(l)= qi_prof_cas(k2) - frac*(qi_prof_cas(k2)-qi_prof_cas(k1)) rt_mod_cas(l)= rt_prof_cas(k2) - frac*(rt_prof_cas(k2)-rt_prof_cas(k1)) rv_mod_cas(l)= rv_prof_cas(k2) - frac*(rv_prof_cas(k2)-rv_prof_cas(k1)) rl_mod_cas(l)= rl_prof_cas(k2) - frac*(rl_prof_cas(k2)-rl_prof_cas(k1)) ri_mod_cas(l)= ri_prof_cas(k2) - frac*(ri_prof_cas(k2)-ri_prof_cas(k1)) rh_mod_cas(l)= rh_prof_cas(k2) - frac*(rh_prof_cas(k2)-rh_prof_cas(k1)) u_mod_cas(l)= u_prof_cas(k2) - frac*(u_prof_cas(k2)-u_prof_cas(k1)) v_mod_cas(l)= v_prof_cas(k2) - frac*(v_prof_cas(k2)-v_prof_cas(k1)) w_mod_cas(l)= w_prof_cas(k2) - frac*(w_prof_cas(k2)-w_prof_cas(k1)) omega_mod_cas(l)= omega_prof_cas(k2) - frac*(omega_prof_cas(k2)-omega_prof_cas(k1)) ug_mod_cas(l)= ug_prof_cas(k2) - frac*(ug_prof_cas(k2)-ug_prof_cas(k1)) vg_mod_cas(l)= vg_prof_cas(k2) - frac*(vg_prof_cas(k2)-vg_prof_cas(k1)) temp_nudg_mod_cas(l)= temp_nudg_prof_cas(k2) - frac*(temp_nudg_prof_cas(k2)-temp_nudg_prof_cas(k1)) th_nudg_mod_cas(l)= th_nudg_prof_cas(k2) - frac*(th_nudg_prof_cas(k2)-th_nudg_prof_cas(k1)) thl_nudg_mod_cas(l)= thl_nudg_prof_cas(k2) - frac*(thl_nudg_prof_cas(k2)-thl_nudg_prof_cas(k1)) qt_nudg_mod_cas(l)= qt_nudg_prof_cas(k2) - frac*(qt_nudg_prof_cas(k2)-qt_nudg_prof_cas(k1)) qv_nudg_mod_cas(l)= qv_nudg_prof_cas(k2) - frac*(qv_nudg_prof_cas(k2)-qv_nudg_prof_cas(k1)) rt_nudg_mod_cas(l)= rt_nudg_prof_cas(k2) - frac*(rt_nudg_prof_cas(k2)-rt_nudg_prof_cas(k1)) rv_nudg_mod_cas(l)= rv_nudg_prof_cas(k2) - frac*(rv_nudg_prof_cas(k2)-rv_nudg_prof_cas(k1)) u_nudg_mod_cas(l)= u_nudg_prof_cas(k2) - frac*(u_nudg_prof_cas(k2)-u_nudg_prof_cas(k1)) v_nudg_mod_cas(l)= v_nudg_prof_cas(k2) - frac*(v_nudg_prof_cas(k2)-v_nudg_prof_cas(k1)) uadv_mod_cas(l)= uadv_prof_cas(k2) - frac*(uadv_prof_cas(k2)-uadv_prof_cas(k1)) vadv_mod_cas(l)= vadv_prof_cas(k2) - frac*(vadv_prof_cas(k2)-vadv_prof_cas(k1)) tadv_mod_cas(l)= tadv_prof_cas(k2) - frac*(tadv_prof_cas(k2)-tadv_prof_cas(k1)) thadv_mod_cas(l)= thadv_prof_cas(k2) - frac*(thadv_prof_cas(k2)-thadv_prof_cas(k1)) thladv_mod_cas(l)= thladv_prof_cas(k2) - frac*(thladv_prof_cas(k2)-thladv_prof_cas(k1)) qtadv_mod_cas(l)= qtadv_prof_cas(k2) - frac*(qtadv_prof_cas(k2)-qtadv_prof_cas(k1)) qvadv_mod_cas(l)= qvadv_prof_cas(k2) - frac*(qvadv_prof_cas(k2)-qvadv_prof_cas(k1)) rtadv_mod_cas(l)= rtadv_prof_cas(k2) - frac*(rtadv_prof_cas(k2)-rtadv_prof_cas(k1)) rvadv_mod_cas(l)= rvadv_prof_cas(k2) - frac*(rvadv_prof_cas(k2)-rvadv_prof_cas(k1)) trad_mod_cas(l)= trad_prof_cas(k2) - frac*(trad_prof_cas(k2)-trad_prof_cas(k1)) thrad_mod_cas(l)= thrad_prof_cas(k2) - frac*(thrad_prof_cas(k2)-thrad_prof_cas(k1)) thlrad_mod_cas(l)= thlrad_prof_cas(k2) - frac*(thlrad_prof_cas(k2)-thlrad_prof_cas(k1)) else !play>plev_prof_cas(1) k1=1 k2=2 print *,'interp_vert, k1,k2=',plev_prof_cas(k1),plev_prof_cas(k2) frac1 = (play(l)-plev_prof_cas(k2))/(plev_prof_cas(k1)-plev_prof_cas(k2)) frac2 = (play(l)-plev_prof_cas(k1))/(plev_prof_cas(k1)-plev_prof_cas(k2)) t_mod_cas(l)= frac1*t_prof_cas(k1) - frac2*t_prof_cas(k2) th_mod_cas(l)= frac1*th_prof_cas(k1) - frac2*th_prof_cas(k2) if(th_mod_cas(l).NE.0) t_mod_cas(l)= th_mod_cas(l)*(play(l)/100000.)**(RD/RCPD) thl_mod_cas(l)= frac1*thl_prof_cas(k1) - frac2*thl_prof_cas(k2) qt_mod_cas(l)= frac1*qt_prof_cas(k1) - frac2*qt_prof_cas(k2) qv_mod_cas(l)= frac1*qv_prof_cas(k1) - frac2*qv_prof_cas(k2) ql_mod_cas(l)= frac1*ql_prof_cas(k1) - frac2*ql_prof_cas(k2) qi_mod_cas(l)= frac1*qi_prof_cas(k1) - frac2*qi_prof_cas(k2) rt_mod_cas(l)= frac1*rt_prof_cas(k1) - frac2*rt_prof_cas(k2) rv_mod_cas(l)= frac1*rv_prof_cas(k1) - frac2*rv_prof_cas(k2) rl_mod_cas(l)= frac1*rl_prof_cas(k1) - frac2*rl_prof_cas(k2) ri_mod_cas(l)= frac1*ri_prof_cas(k1) - frac2*ri_prof_cas(k2) rh_mod_cas(l)= frac1*rh_prof_cas(k1) - frac2*rh_prof_cas(k2) u_mod_cas(l)= frac1*u_prof_cas(k1) - frac2*u_prof_cas(k2) v_mod_cas(l)= frac1*v_prof_cas(k1) - frac2*v_prof_cas(k2) w_mod_cas(l)= frac1*w_prof_cas(k1) - frac2*w_prof_cas(k2) omega_mod_cas(l)= frac1*omega_prof_cas(k1) - frac2*omega_prof_cas(k2) ug_mod_cas(l)= frac1*ug_prof_cas(k1) - frac2*ug_prof_cas(k2) vg_mod_cas(l)= frac1*vg_prof_cas(k1) - frac2*vg_prof_cas(k2) temp_nudg_mod_cas(l)= frac1*temp_nudg_prof_cas(k1) - frac2*temp_nudg_prof_cas(k2) th_nudg_mod_cas(l)= frac1*th_nudg_prof_cas(k1) - frac2*th_nudg_prof_cas(k2) thl_nudg_mod_cas(l)= frac1*thl_nudg_prof_cas(k1) - frac2*thl_nudg_prof_cas(k2) qt_nudg_mod_cas(l)= frac1*qt_nudg_prof_cas(k1) - frac2*qt_nudg_prof_cas(k2) qv_nudg_mod_cas(l)= frac1*qv_nudg_prof_cas(k1) - frac2*qv_nudg_prof_cas(k2) rt_nudg_mod_cas(l)= frac1*rt_nudg_prof_cas(k1) - frac2*rt_nudg_prof_cas(k2) rv_nudg_mod_cas(l)= frac1*rv_nudg_prof_cas(k1) - frac2*rv_nudg_prof_cas(k2) u_nudg_mod_cas(l)= frac1*u_nudg_prof_cas(k1) - frac2*u_nudg_prof_cas(k2) v_nudg_mod_cas(l)= frac1*v_nudg_prof_cas(k1) - frac2*v_nudg_prof_cas(k2) uadv_mod_cas(l)= frac1*uadv_prof_cas(k1) - frac2*uadv_prof_cas(k2) vadv_mod_cas(l)= frac1*vadv_prof_cas(k1) - frac2*vadv_prof_cas(k2) tadv_mod_cas(l)= frac1*tadv_prof_cas(k1) - frac2*tadv_prof_cas(k2) thadv_mod_cas(l)= frac1*thadv_prof_cas(k1) - frac2*thadv_prof_cas(k2) thladv_mod_cas(l)= frac1*thladv_prof_cas(k1) - frac2*thladv_prof_cas(k2) qtadv_mod_cas(l)= frac1*qtadv_prof_cas(k1) - frac2*qtadv_prof_cas(k2) qvadv_mod_cas(l)= frac1*qvadv_prof_cas(k1) - frac2*qvadv_prof_cas(k2) rtadv_mod_cas(l)= frac1*rtadv_prof_cas(k1) - frac2*rtadv_prof_cas(k2) rvadv_mod_cas(l)= frac1*rvadv_prof_cas(k1) - frac2*rvadv_prof_cas(k2) trad_mod_cas(l)= frac1*trad_prof_cas(k1) - frac2*trad_prof_cas(k2) thrad_mod_cas(l)= frac1*thrad_prof_cas(k1) - frac2*thrad_prof_cas(k2) thlrad_mod_cas(l)= frac1*thlrad_prof_cas(k1) - frac2*thlrad_prof_cas(k2) endif ! play.le.plev_prof_cas(1) else ! above max altitude of forcing file !jyg fact=20.*(plev_prof_cas(nlev_cas)-play(l))/plev_prof_cas(nlev_cas) !jyg fact = max(fact,0.) !jyg fact = exp(-fact) !jyg t_mod_cas(l)= t_prof_cas(nlev_cas) !jyg th_mod_cas(l)= th_prof_cas(nlev_cas) !jyg thl_mod_cas(l)= thl_prof_cas(nlev_cas) !jyg qt_mod_cas(l)= qt_prof_cas(nlev_cas)*fact !jyg qv_mod_cas(l)= qv_prof_cas(nlev_cas)*fact !jyg ql_mod_cas(l)= ql_prof_cas(nlev_cas)*fact !jyg qi_mod_cas(l)= qi_prof_cas(nlev_cas)*fact !jyg rt_mod_cas(l)= rt_prof_cas(nlev_cas)*fact !jyg rv_mod_cas(l)= rv_prof_cas(nlev_cas)*fact !jyg rl_mod_cas(l)= rl_prof_cas(nlev_cas)*fact !jyg ri_mod_cas(l)= ri_prof_cas(nlev_cas)*fact !jyg rh_mod_cas(l)= rh_prof_cas(nlev_cas)*fact !jyg u_mod_cas(l)= u_prof_cas(nlev_cas)*fact !jyg v_mod_cas(l)= v_prof_cas(nlev_cas)*fact !jyg w_mod_cas(l)= 0.0 !jyg omega_mod_cas(l)= 0.0 !jyg ug_mod_cas(l)= ug_prof_cas(nlev_cas) !jyg vg_mod_cas(l)= vg_prof_cas(nlev_cas) !jyg temp_nudg_mod_cas(l)= temp_nudg_prof_cas(nlev_cas) !jyg th_nudg_mod_cas(l)= th_nudg_prof_cas(nlev_cas) !jyg thl_nudg_mod_cas(l)= thl_nudg_prof_cas(nlev_cas) !jyg qt_nudg_mod_cas(l)= qt_nudg_prof_cas(nlev_cas) !jyg qv_nudg_mod_cas(l)= qv_nudg_prof_cas(nlev_cas) !jyg rt_nudg_mod_cas(l)= rt_nudg_prof_cas(nlev_cas) !jyg rv_nudg_mod_cas(l)= rv_nudg_prof_cas(nlev_cas) !jyg u_nudg_mod_cas(l)= u_nudg_prof_cas(nlev_cas) !jyg v_nudg_mod_cas(l)= v_nudg_prof_cas(nlev_cas) !jyg uadv_mod_cas(l)= uadv_prof_cas(nlev_cas) !jyg vadv_mod_cas(l)= vadv_prof_cas(nlev_cas) !jyg tadv_mod_cas(l)= tadv_prof_cas(nlev_cas) !jyg thadv_mod_cas(l)= thadv_prof_cas(nlev_cas) !jyg thladv_mod_cas(l)= thladv_prof_cas(nlev_cas) !jyg qtadv_mod_cas(l)= qtadv_prof_cas(nlev_cas) !jyg qvadv_mod_cas(l)= qvadv_prof_cas(nlev_cas) !jyg rtadv_mod_cas(l)= rtadv_prof_cas(nlev_cas) !jyg rvadv_mod_cas(l)= rvadv_prof_cas(nlev_cas) !jyg trad_mod_cas(l)= trad_prof_cas(nlev_cas)*fact !jyg thrad_mod_cas(l)= thrad_prof_cas(nlev_cas)*fact !jyg thlrad_mod_cas(l)= thlrad_prof_cas(nlev_cas)*fact !jyg endif ! play enddo ! l return end SUBROUTINE interp_case_vertical_std !***************************************************************************** END MODULE mod_1D_cases_read_std