Index: DZ6/trunk/libf/dyn3d/covnat.F90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/covnat.F90 (revision 5311) +++ (revision ) @@ -1,48 +1,0 @@ -! -! $Header$ -! -SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat ) - USE comgeom_mod_h - USE dimensions_mod, ONLY: iim, jjm, llm, ndm - USE paramet_mod_h - IMPLICIT NONE - - !======================================================================= - ! - ! Auteur: F Hourdin Phu LeVan - ! ------- - ! - ! Objet: - ! ------ - ! - ! ********************************************************************* - ! calcul des compos. naturelles a partir des comp.covariantes - ! ******************************************************************** - ! - !======================================================================= - - INTEGER :: klevel - REAL :: ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) - REAL :: unat( ip1jmp1,klevel ), vnat( ip1jm,klevel ) - INTEGER :: l,ij - - - DO l = 1,klevel - DO ij = 1, iip1 - unat (ij,l) =0. - END DO - - DO ij = iip2, ip1jm - unat( ij,l ) = ucov( ij,l ) / cu(ij) - ENDDO - DO ij = ip1jm+1, ip1jmp1 - unat (ij,l) =0. - END DO - - DO ij = 1,ip1jm - vnat( ij,l ) = vcov( ij,l ) / cv(ij) - ENDDO - - ENDDO - RETURN -END SUBROUTINE covnat Index: /LMDZ6/trunk/libf/dyn3d/covnat.f90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/covnat.f90 (revision 5312) +++ /LMDZ6/trunk/libf/dyn3d/covnat.f90 (revision 5312) @@ -0,0 +1,48 @@ +! +! $Header$ +! +SUBROUTINE covnat (klevel,ucov, vcov, unat, vnat ) + USE comgeom_mod_h + USE dimensions_mod, ONLY: iim, jjm, llm, ndm + USE paramet_mod_h + IMPLICIT NONE + + !======================================================================= + ! + ! Auteur: F Hourdin Phu LeVan + ! ------- + ! + ! Objet: + ! ------ + ! + ! ********************************************************************* + ! calcul des compos. naturelles a partir des comp.covariantes + ! ******************************************************************** + ! + !======================================================================= + + INTEGER :: klevel + REAL :: ucov( ip1jmp1,klevel ), vcov( ip1jm,klevel ) + REAL :: unat( ip1jmp1,klevel ), vnat( ip1jm,klevel ) + INTEGER :: l,ij + + + DO l = 1,klevel + DO ij = 1, iip1 + unat (ij,l) =0. + END DO + + DO ij = iip2, ip1jm + unat( ij,l ) = ucov( ij,l ) / cu(ij) + ENDDO + DO ij = ip1jm+1, ip1jmp1 + unat (ij,l) =0. + END DO + + DO ij = 1,ip1jm + vnat( ij,l ) = vcov( ij,l ) / cv(ij) + ENDDO + + ENDDO + RETURN +END SUBROUTINE covnat Index: DZ6/trunk/libf/dyn3d/dudv1.F90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/dudv1.F90 (revision 5311) +++ (revision ) @@ -1,55 +1,0 @@ -! -! $Header$ -! -SUBROUTINE dudv1 ( vorpot, pbaru, pbarv, du, dv ) - USE dimensions_mod, ONLY: iim, jjm, llm, ndm -USE paramet_mod_h -IMPLICIT NONE - ! - !----------------------------------------------------------------------- - ! - ! Auteur: P. Le Van - ! ------- - ! - ! Objet: - ! ------ - ! calcul du terme de rotation - ! ce terme est ajoute a d(ucov)/dt et a d(vcov)/dt .. - ! vorpot, pbaru et pbarv sont des arguments d'entree pour le s-pg .. - ! du et dv sont des arguments de sortie pour le s-pg .. - ! - !----------------------------------------------------------------------- - - - - - REAL :: vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) , & - pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm ) - INTEGER :: l,ij - ! - ! - DO l = 1,llm - ! - DO ij = iip2, ip1jm - 1 - du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * & - ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + & - pbarv( ij , l) + pbarv(ij+ 1 , l) ) - END DO - ! - DO ij = 1, ip1jm - 1 - dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * & - ( pbaru(ij, l) + pbaru(ij+1 , l) + & - pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) - END DO - ! - ! .... correction pour dv( 1,j,l ) ..... - ! .... dv(1,j,l)= dv(iip1,j,l) .... - ! - !DIR$ IVDEP - DO ij = 1, ip1jm, iip1 - dv( ij,l ) = dv( ij + iim, l ) - END DO - ! - END DO - RETURN -END SUBROUTINE dudv1 Index: /LMDZ6/trunk/libf/dyn3d/dudv1.f90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/dudv1.f90 (revision 5312) +++ /LMDZ6/trunk/libf/dyn3d/dudv1.f90 (revision 5312) @@ -0,0 +1,55 @@ +! +! $Header$ +! +SUBROUTINE dudv1 ( vorpot, pbaru, pbarv, du, dv ) + USE dimensions_mod, ONLY: iim, jjm, llm, ndm +USE paramet_mod_h +IMPLICIT NONE + ! + !----------------------------------------------------------------------- + ! + ! Auteur: P. Le Van + ! ------- + ! + ! Objet: + ! ------ + ! calcul du terme de rotation + ! ce terme est ajoute a d(ucov)/dt et a d(vcov)/dt .. + ! vorpot, pbaru et pbarv sont des arguments d'entree pour le s-pg .. + ! du et dv sont des arguments de sortie pour le s-pg .. + ! + !----------------------------------------------------------------------- + + + + + REAL :: vorpot( ip1jm,llm ) ,pbaru( ip1jmp1,llm ) , & + pbarv( ip1jm,llm ) ,du( ip1jmp1,llm ) ,dv( ip1jm,llm ) + INTEGER :: l,ij + ! + ! + DO l = 1,llm + ! + DO ij = iip2, ip1jm - 1 + du( ij,l ) = 0.125 *( vorpot(ij-iip1, l) + vorpot( ij, l) ) * & + ( pbarv(ij-iip1, l) + pbarv(ij-iim, l) + & + pbarv( ij , l) + pbarv(ij+ 1 , l) ) + END DO + ! + DO ij = 1, ip1jm - 1 + dv( ij+1,l ) = - 0.125 *( vorpot(ij, l) + vorpot(ij+1, l) ) * & + ( pbaru(ij, l) + pbaru(ij+1 , l) + & + pbaru(ij+iip1, l) + pbaru(ij+iip2, l) ) + END DO + ! + ! .... correction pour dv( 1,j,l ) ..... + ! .... dv(1,j,l)= dv(iip1,j,l) .... + ! + !DIR$ IVDEP + DO ij = 1, ip1jm, iip1 + dv( ij,l ) = dv( ij + iim, l ) + END DO + ! + END DO + RETURN +END SUBROUTINE dudv1 Index: DZ6/trunk/libf/dyn3d/leapfrog.F90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/leapfrog.F90 (revision 5311) +++ (revision ) @@ -1,852 +1,0 @@ -! -! $Id$ -! -! -! -SUBROUTINE leapfrog(ucov,vcov,teta,ps,masse,phis,q,time_0) - !IM : pour sortir les param. du modele dans un fis. netcdf 110106 - USE iniprint_mod_h - USE comgeom_mod_h - USE comdissnew_mod_h - use IOIPSL - USE infotrac, ONLY: nqtot, isoCheck - USE guide_mod, ONLY : guide_main - USE write_field, ONLY: writefield - USE control_mod, ONLY: nday, day_step, planet_type, offline, & - iconser, iphysiq, iperiod, dissip_period, & - iecri, ip_ebil_dyn, ok_dynzon, ok_dyn_ins, & - periodav, ok_dyn_ave, output_grads_dyn - use exner_hyb_m, only: exner_hyb - use exner_milieu_m, only: exner_milieu - USE comvert_mod, ONLY: ap,bp,pressure_exner,presnivs - USE comconst_mod, ONLY: cpp, dtphys, dtvr, pi, ihf - USE logic_mod, ONLY: iflag_phys,ok_guide,forward,leapf,apphys, & - statcl,conser,apdiss,purmats,ok_strato - USE temps_mod, ONLY: jD_ref,jH_ref,itaufin,day_ini,day_ref, & - start_time,dt - USE strings_mod, ONLY: msg - USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS - USE dimensions_mod, ONLY: iim, jjm, llm, ndm - USE paramet_mod_h - USE academic_mod_h, ONLY: tetarappel, knewt_t, knewt_g, clat4 - IMPLICIT NONE - - ! ...... Version du 10/01/98 .......... - - ! avec coordonnees verticales hybrides - ! avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) - - !======================================================================= - ! - ! Auteur: P. Le Van /L. Fairhead/F.Hourdin - ! ------- - ! - ! Objet: - ! ------ - ! - ! GCM LMD nouvelle grille - ! - !======================================================================= - ! - ! ... Dans inigeom , nouveaux calculs pour les elongations cu , cv - ! et possibilite d'appeler une fonction f(y) a derivee tangente - ! hyperbolique a la place de la fonction a derivee sinusoidale. - - ! ... Possibilite de choisir le shema pour l'advection de - ! q , en modifiant iadv dans traceur.def (10/02) . - ! - ! Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) - ! Pour Van-Leer iadv=10 - ! - !----------------------------------------------------------------------- - ! Declarations: - ! ------------- - - REAL,INTENT(IN) :: time_0 ! not used - - ! dynamical variables: - REAL,INTENT(INOUT) :: ucov(ip1jmp1,llm) ! zonal covariant wind - REAL,INTENT(INOUT) :: vcov(ip1jm,llm) ! meridional covariant wind - REAL,INTENT(INOUT) :: teta(ip1jmp1,llm) ! potential temperature - REAL,INTENT(INOUT) :: ps(ip1jmp1) ! surface pressure (Pa) - REAL,INTENT(INOUT) :: masse(ip1jmp1,llm) ! air mass - REAL,INTENT(INOUT) :: phis(ip1jmp1) ! geopotentiat at the surface - REAL,INTENT(INOUT) :: q(ip1jmp1,llm,nqtot) ! advected tracers - - REAL :: p (ip1jmp1,llmp1 ) ! interlayer pressure - REAL :: pks(ip1jmp1) ! exner at the surface - REAL :: pk(ip1jmp1,llm) ! exner at mid-layer - REAL :: pkf(ip1jmp1,llm) ! filtered exner at mid-layer - REAL :: phi(ip1jmp1,llm) ! geopotential - REAL :: w(ip1jmp1,llm) ! vertical velocity - - real :: zqmin,zqmax - - ! variables dynamiques intermediaire pour le transport - REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse - - ! variables dynamiques au pas -1 - REAL :: vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) - REAL :: tetam1(ip1jmp1,llm),psm1(ip1jmp1) - REAL :: massem1(ip1jmp1,llm) - - ! tendances dynamiques - REAL :: dv(ip1jm,llm),du(ip1jmp1,llm) - REAL :: dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqtot),dp(ip1jmp1) - - ! tendances de la dissipation - REAL :: dvdis(ip1jm,llm),dudis(ip1jmp1,llm) - REAL :: dtetadis(ip1jmp1,llm) - - ! tendances physiques - REAL :: dvfi(ip1jm,llm),dufi(ip1jmp1,llm) - REAL :: dtetafi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqtot),dpfi(ip1jmp1) - - ! variables pour le fichier histoire - REAL :: dtav ! intervalle de temps elementaire - - REAL :: tppn(iim),tpps(iim),tpn,tps - ! - INTEGER :: itau,itaufinp1,iav - ! INTEGER iday ! jour julien - REAL :: time - - REAL :: SSUM - ! REAL finvmaold(ip1jmp1,llm) - - !ym LOGICAL lafin - LOGICAL :: lafin=.false. - INTEGER :: ij,iq,l - INTEGER :: ik - - real :: time_step, t_wrt, t_ops - - ! REAL rdayvrai,rdaym_ini - ! jD_cur: jour julien courant - ! jH_cur: heure julienne courante - REAL :: jD_cur, jH_cur - INTEGER :: an, mois, jour - REAL :: secondes - - LOGICAL :: first,callinigrads - !IM : pour sortir les param. du modele dans un fis. netcdf 110106 - save first - data first/.true./ - real :: dt_cum - character(len=10) :: infile - integer :: zan, tau0, thoriid - integer :: nid_ctesGCM - save nid_ctesGCM - real :: degres - real :: rlong(iip1), rlatg(jjp1) - real :: zx_tmp_2d(iip1,jjp1) - integer :: ndex2d(iip1*jjp1) - logical :: ok_sync - parameter (ok_sync = .true.) - logical :: physic - - data callinigrads/.true./ - character(len=10) :: string10 - - REAL :: flxw(ip1jmp1,llm) ! flux de masse verticale - - !+jld variables test conservation energie - REAL :: ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) - ! Tendance de la temp. potentiel d (theta)/ d t due a la - ! tansformation d'energie cinetique en energie thermique - ! cree par la dissipation - REAL :: dtetaecdt(ip1jmp1,llm) - REAL :: vcont(ip1jm,llm),ucont(ip1jmp1,llm) - REAL :: vnat(ip1jm,llm),unat(ip1jmp1,llm) - REAL :: d_h_vcol, d_qt, d_qw, d_ql, d_ec - CHARACTER(len=15) :: ztit - !IM INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag. - !IM SAVE ip_ebil_dyn - !IM DATA ip_ebil_dyn/0/ - !-jld - - character(len=80) :: dynhist_file, dynhistave_file - character(len=*),parameter :: modname="leapfrog" - character(len=80) :: abort_message - - logical :: dissip_conservative - save dissip_conservative - data dissip_conservative/.true./ - - LOGICAL :: prem - save prem - DATA prem/.true./ - INTEGER :: testita - PARAMETER (testita = 9) - - logical , parameter :: flag_verif = .false. - - - integer :: itau_w ! pas de temps ecriture = itap + itau_phy - - - if (nday>=0) then - itaufin = nday*day_step - else - itaufin = -nday - endif - itaufinp1 = itaufin +1 - itau = 0 - physic=.true. - if (iflag_phys==0.or.iflag_phys==2) physic=.false. - - ! iday = day_ini+itau/day_step - ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 - ! IF(time.GT.1.) THEN - ! time = time-1. - ! iday = iday+1 - ! ENDIF - - - !----------------------------------------------------------------------- - ! On initialise la pression et la fonction d'Exner : - ! -------------------------------------------------- - - dq(:,:,:)=0. - CALL pression ( ip1jmp1, ap, bp, ps, p ) - if (pressure_exner) then - CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf ) - else - CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) - endif - - !----------------------------------------------------------------------- - ! Debut de l'integration temporelle: - ! ---------------------------------- - - 1 CONTINUE ! Matsuno Forward step begins here - - ! date: (NB: date remains unchanged for Backward step) - ! ----- - - jD_cur = jD_ref + day_ini - day_ref + & - (itau+1)/day_step - jH_cur = jH_ref + start_time + & - mod(itau+1,day_step)/float(day_step) - jD_cur = jD_cur + int(jH_cur) - jH_cur = jH_cur - int(jH_cur) - - call check_isotopes_seq(q,ip1jmp1,'leapfrog 321') - - if (ok_guide) then - call guide_main(itau,ucov,vcov,teta,q,masse,ps) - endif - - - - ! - ! IF( MOD( itau, 10* day_step ).EQ.0 ) THEN - ! CALL test_period ( ucov,vcov,teta,q,p,phis ) - ! PRINT *,' ---- Test_period apres continue OK ! -----', itau - ! ENDIF - ! - - ! Save fields obtained at previous time step as '...m1' - CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 ) - CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 ) - CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 ) - CALL SCOPY( ijp1llm,masse, 1, massem1, 1 ) - CALL SCOPY( ip1jmp1, ps , 1, psm1 , 1 ) - - forward = .TRUE. - leapf = .FALSE. - dt = dtvr - - ! ... P.Le Van .26/04/94 .... - ! Ehouarn: finvmaold is actually not used - ! CALL SCOPY ( ijp1llm, masse, 1, finvmaold, 1 ) - ! CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) - - call check_isotopes_seq(q,ip1jmp1,'leapfrog 400') - - 2 CONTINUE ! Matsuno backward or leapfrog step begins here - - !----------------------------------------------------------------------- - - ! date: (NB: only leapfrog step requires recomputing date) - ! ----- - - IF (leapf) THEN - jD_cur = jD_ref + day_ini - day_ref + & - (itau+1)/day_step - jH_cur = jH_ref + start_time + & - mod(itau+1,day_step)/float(day_step) - jD_cur = jD_cur + int(jH_cur) - jH_cur = jH_cur - int(jH_cur) - ENDIF - - - ! gestion des appels de la physique et des dissipations: - ! ------------------------------------------------------ - ! - ! ... P.Le Van ( 6/02/95 ) .... - - apphys = .FALSE. - statcl = .FALSE. - conser = .FALSE. - apdiss = .FALSE. - - IF( purmats ) THEN - ! ! Purely Matsuno time stepping - IF( MOD(itau,iconser) .EQ.0.AND. forward ) conser = .TRUE. - IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward ) & - apdiss = .TRUE. - IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward & - .and. physic ) apphys = .TRUE. - ELSE - ! ! Leapfrog/Matsuno time stepping - IF( MOD(itau ,iconser) .EQ. 0 ) conser = .TRUE. - IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward ) & - apdiss = .TRUE. - IF( MOD(itau+1,iphysiq).EQ.0.AND.physic ) apphys=.TRUE. - END IF - - ! Ehouarn: for Shallow Water case (ie: 1 vertical layer), - ! supress dissipation step - if (llm.eq.1) then - apdiss=.false. - endif - - - call check_isotopes_seq(q,ip1jmp1,'leapfrog 589') - - !----------------------------------------------------------------------- - ! calcul des tendances dynamiques: - ! -------------------------------- - - ! ! compute geopotential phi() - CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) - - time = jD_cur + jH_cur - CALL caldyn & - ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , & - phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time ) - - - !----------------------------------------------------------------------- - ! calcul des tendances advection des traceurs (dont l'humidite) - ! ------------------------------------------------------------- - - call check_isotopes_seq(q,ip1jmp1, & - 'leapfrog 686: avant caladvtrac') - - IF( forward.OR. leapf ) THEN - ! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step - CALL caladvtrac(q,pbaru,pbarv, & - p, masse, dq, teta, & - flxw, pk) - ! !write(*,*) 'caladvtrac 346' - - - IF (offline) THEN - !maf stokage du flux de masse pour traceurs OFF-LINE - - CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, & - dtvr, itau) - - - - ENDIF ! of IF (offline) - ! - ENDIF ! of IF( forward.OR. leapf ) - - - !----------------------------------------------------------------------- - ! integrations dynamique et traceurs: - ! ---------------------------------- - - CALL msg('720', modname, isoCheck) - call check_isotopes_seq(q,ip1jmp1,'leapfrog 756') - - CALL integrd ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 , & - dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ) - ! $ finvmaold ) - - CALL msg('724', modname, isoCheck) - call check_isotopes_seq(q,ip1jmp1,'leapfrog 762') - - ! .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) - ! - !----------------------------------------------------------------------- - ! calcul des tendances physiques: - ! ------------------------------- - ! ######## P.Le Van ( Modif le 6/02/95 ) ########### - ! - IF( purmats ) THEN - IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE. - ELSE - IF( itau+1.EQ. itaufin ) lafin = .TRUE. - ENDIF - ! - ! - IF( apphys ) THEN - ! - ! ....... Ajout P.Le Van ( 17/04/96 ) ........... - ! - - CALL pression ( ip1jmp1, ap, bp, ps, p ) - if (pressure_exner) then - CALL exner_hyb( ip1jmp1, ps, p,pks, pk, pkf ) - else - CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) - endif - - ! Appel a geopot ajoute le 2014/05/08 pour garantir la convergence numerique - ! avec dyn3dmem - CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) - - ! rdaym_ini = itau * dtvr / daysec - ! rdayvrai = rdaym_ini + day_ini - ! jD_cur = jD_ref + day_ini - day_ref - ! $ + int (itau * dtvr / daysec) - ! jH_cur = jH_ref + & - ! & (itau * dtvr / daysec - int(itau * dtvr / daysec)) - jD_cur = jD_ref + day_ini - day_ref + & - (itau+1)/day_step - - IF (planet_type .eq."generic") THEN - ! ! AS: we make jD_cur to be pday - jD_cur = int(day_ini + itau/day_step) - ENDIF - - jH_cur = jH_ref + start_time + & - mod(itau+1,day_step)/float(day_step) - jD_cur = jD_cur + int(jH_cur) - jH_cur = jH_cur - int(jH_cur) - ! write(lunout,*)'itau, jD_cur = ', itau, jD_cur, jH_cur - ! call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes) - ! write(lunout,*)'current date = ',an, mois, jour, secondes - - ! rajout debug - ! lafin = .true. - - - ! Inbterface avec les routines de phylmd (phymars ... ) - ! ----------------------------------------------------- - - !+jld - - ! Diagnostique de conservation de l'energie : initialisation - IF (ip_ebil_dyn.ge.1 ) THEN - ztit='bil dyn' - ! Ehouarn: be careful, diagedyn is Earth-specific! - IF (planet_type.eq."earth") THEN - CALL diagedyn(ztit,2,1,1,dtphys & - , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) - ENDIF - ENDIF ! of IF (ip_ebil_dyn.ge.1 ) - !-jld - - !IM decommenter les 6 lignes suivantes pour sortir quelques parametres dynamiques de LMDZ - !IM uncomment next 6 lines to get some parameters for LMDZ dynamics - ! IF (first) THEN - ! first=.false. - !INCLUDE "ini_paramLMDZ_dyn.h" - ! ENDIF - ! - !INCLUDE "write_paramLMDZ_dyn.h" - -IF (CPPKEY_PHYS) THEN - CALL calfis( lafin , jD_cur, jH_cur, & - ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , & - du,dv,dteta,dq, & - flxw,dufi,dvfi,dtetafi,dqfi,dpfi ) -END IF - ! ajout des tendances physiques: - ! ------------------------------ - CALL addfi( dtphys, leapf, forward , & - ucov, vcov, teta , q ,ps , & - dufi, dvfi, dtetafi , dqfi ,dpfi ) - ! ! since addfi updates ps(), also update p(), masse() and pk() - CALL pression (ip1jmp1,ap,bp,ps,p) - CALL massdair(p,masse) - if (pressure_exner) then - CALL exner_hyb(ip1jmp1,ps,p,pks,pk,pkf) - else - CALL exner_milieu(ip1jmp1,ps,p,pks,pk,pkf) - endif - - IF (ok_strato) THEN - CALL top_bound( vcov,ucov,teta,masse,dtphys) - ENDIF - - ! - ! Diagnostique de conservation de l'energie : difference - IF (ip_ebil_dyn.ge.1 ) THEN - ztit='bil phys' - IF (planet_type.eq."earth") THEN - CALL diagedyn(ztit,2,1,1,dtphys & - , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) - ENDIF - ENDIF ! of IF (ip_ebil_dyn.ge.1 ) - - ENDIF ! of IF( apphys ) - - IF(iflag_phys.EQ.2) THEN ! "Newtonian" case - ! Academic case : Simple friction and Newtonan relaxation - ! ------------------------------------------------------- - DO l=1,llm - DO ij=1,ip1jmp1 - teta(ij,l)=teta(ij,l)-dtvr* & - (teta(ij,l)-tetarappel(ij,l))*(knewt_g+knewt_t(l)*clat4(ij)) - ENDDO - ENDDO ! of DO l=1,llm - - if (planet_type.eq."giant") then - ! ! add an intrinsic heat flux at the base of the atmosphere - teta(:,1)=teta(:,1)+dtvr*aire(:)*ihf/cpp/masse(:,1) - endif - - call friction(ucov,vcov,dtvr) - - ! ! Sponge layer (if any) - IF (ok_strato) THEN - ! dufi(:,:)=0. - ! dvfi(:,:)=0. - ! dtetafi(:,:)=0. - ! dqfi(:,:,:)=0. - ! dpfi(:)=0. - ! CALL top_bound(vcov,ucov,teta,masse,dufi,dvfi,dtetafi) - CALL top_bound( vcov,ucov,teta,masse,dtvr) - ! CALL addfi( dtvr, leapf, forward , - ! $ ucov, vcov, teta , q ,ps , - ! $ dufi, dvfi, dtetafi , dqfi ,dpfi ) - ENDIF ! of IF (ok_strato) - ENDIF ! of IF (iflag_phys.EQ.2) - - - !-jld - - CALL pression ( ip1jmp1, ap, bp, ps, p ) - if (pressure_exner) then - CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf ) - else - CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) - endif - CALL massdair(p,masse) - - call check_isotopes_seq(q,ip1jmp1,'leapfrog 1196') - - !----------------------------------------------------------------------- - ! dissipation horizontale et verticale des petites echelles: - ! ---------------------------------------------------------- - - IF(apdiss) THEN - - - ! calcul de l'energie cinetique avant dissipation - call covcont(llm,ucov,vcov,ucont,vcont) - call enercin(vcov,ucov,vcont,ucont,ecin0) - - ! dissipation - CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dtetadis) - ucov=ucov+dudis - vcov=vcov+dvdis - ! teta=teta+dtetadis - - - !------------------------------------------------------------------------ - if (dissip_conservative) then - ! On rajoute la tendance due a la transform. Ec -> E therm. cree - ! lors de la dissipation - call covcont(llm,ucov,vcov,ucont,vcont) - call enercin(vcov,ucov,vcont,ucont,ecin) - dtetaecdt= (ecin0-ecin)/ pk - ! teta=teta+dtetaecdt - dtetadis=dtetadis+dtetaecdt - endif - teta=teta+dtetadis - !------------------------------------------------------------------------ - - - ! ....... P. Le Van ( ajout le 17/04/96 ) ........... - ! ... Calcul de la valeur moyenne, unique de h aux poles ..... - ! - - DO l = 1, llm - DO ij = 1,iim - tppn(ij) = aire( ij ) * teta( ij ,l) - tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) - ENDDO - tpn = SSUM(iim,tppn,1)/apoln - tps = SSUM(iim,tpps,1)/apols - - DO ij = 1, iip1 - teta( ij ,l) = tpn - teta(ij+ip1jm,l) = tps - ENDDO - ENDDO - - if (1 == 0) then - !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics - !!! 2) should probably not be here anyway - !!! but are kept for those who would want to revert to previous behaviour - DO ij = 1,iim - tppn(ij) = aire( ij ) * ps ( ij ) - tpps(ij) = aire(ij+ip1jm) * ps (ij+ip1jm) - ENDDO - tpn = SSUM(iim,tppn,1)/apoln - tps = SSUM(iim,tpps,1)/apols - - DO ij = 1, iip1 - ps( ij ) = tpn - ps(ij+ip1jm) = tps - ENDDO - endif ! of if (1 == 0) - - END IF ! of IF(apdiss) - - ! ajout debug - ! IF( lafin ) then - ! abort_message = 'Simulation finished' - ! call abort_gcm(modname,abort_message,0) - ! ENDIF - - ! ******************************************************************** - ! ******************************************************************** - ! .... fin de l'integration dynamique et physique pour le pas itau .. - ! ******************************************************************** - ! ******************************************************************** - - ! preparation du pas d'integration suivant ...... - - call check_isotopes_seq(q,ip1jmp1,'leapfrog 1509') - - IF ( .NOT.purmats ) THEN - ! ........................................................ - ! .............. schema matsuno + leapfrog .............. - ! ........................................................ - - IF(forward.OR. leapf) THEN - itau= itau + 1 - ! iday= day_ini+itau/day_step - ! time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 - ! IF(time.GT.1.) THEN - ! time = time-1. - ! iday = iday+1 - ! ENDIF - ENDIF - - - IF( itau.EQ. itaufinp1 ) then - if (flag_verif) then - write(79,*) 'ucov',ucov - write(80,*) 'vcov',vcov - write(81,*) 'teta',teta - write(82,*) 'ps',ps - write(83,*) 'q',q - WRITE(85,*) 'q1 = ',q(:,:,1) - WRITE(86,*) 'q3 = ',q(:,:,3) - endif - - abort_message = 'Simulation finished' - - call abort_gcm(modname,abort_message,0) - ENDIF - !----------------------------------------------------------------------- - ! ecriture du fichier histoire moyenne: - ! ------------------------------------- - - IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN - IF(itau.EQ.itaufin) THEN - iav=1 - ELSE - iav=0 - ENDIF - - ! ! Ehouarn: re-compute geopotential for outputs - CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) - - IF (ok_dynzon) THEN - CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav, & - ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) - - END IF - IF (ok_dyn_ave) THEN - CALL writedynav(itau,vcov, & - ucov,teta,pk,phi,q,masse,ps,phis) - - ENDIF - - ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin)) - - call check_isotopes_seq(q,ip1jmp1,'leapfrog 1584') - - !----------------------------------------------------------------------- - ! ecriture de la bande histoire: - ! ------------------------------ - - IF( MOD(itau,iecri).EQ.0) THEN - ! ! Ehouarn: output only during LF or Backward Matsuno - if (leapf.or.(.not.leapf.and.(.not.forward))) then - CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) - unat=0. - do l=1,llm - unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) - vnat(:,l)=vcov(:,l)/cv(:) - enddo - if (ok_dyn_ins) then - ! write(lunout,*) "leapfrog: call writehist, itau=",itau - CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis) - ! call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/))) - ! call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/))) - ! call WriteField('teta',reshape(teta,(/iip1,jmp1,llm/))) - ! call WriteField('ps',reshape(ps,(/iip1,jmp1/))) - ! call WriteField('masse',reshape(masse,(/iip1,jmp1,llm/))) - endif ! of if (ok_dyn_ins) - - ! For some Grads outputs of fields - if (output_grads_dyn) then -INCLUDE "write_grads_dyn.h" - endif - endif ! of if (leapf.or.(.not.leapf.and.(.not.forward))) - ENDIF ! of IF(MOD(itau,iecri).EQ.0) - - IF(itau.EQ.itaufin) THEN - - - ! if (planet_type.eq."earth") then - ! Write an Earth-format restart file - CALL dynredem1("restart.nc",start_time, & - vcov,ucov,teta,q,masse,ps) - ! endif ! of if (planet_type.eq."earth") - - CLOSE(99) - if (ok_guide) then - ! ! set ok_guide to false to avoid extra output - ! ! in following forward step - ok_guide=.false. - endif - ! !!! Ehouarn: Why not stop here and now? - ENDIF ! of IF (itau.EQ.itaufin) - - !----------------------------------------------------------------------- - ! gestion de l'integration temporelle: - ! ------------------------------------ - - IF( MOD(itau,iperiod).EQ.0 ) THEN - GO TO 1 - ELSE IF ( MOD(itau-1,iperiod).EQ. 0 ) THEN - - IF( forward ) THEN - ! fin du pas forward et debut du pas backward - - forward = .FALSE. - leapf = .FALSE. - GO TO 2 - - ELSE - ! fin du pas backward et debut du premier pas leapfrog - - leapf = .TRUE. - dt = 2.*dtvr - GO TO 2 - END IF ! of IF (forward) - ELSE - - ! ...... pas leapfrog ..... - - leapf = .TRUE. - dt = 2.*dtvr - GO TO 2 - END IF ! of IF (MOD(itau,iperiod).EQ.0) - ! ! ELSEIF (MOD(itau-1,iperiod).EQ.0) - - ELSE ! of IF (.not.purmats) - - call check_isotopes_seq(q,ip1jmp1,'leapfrog 1664') - - ! ........................................................ - ! .............. schema matsuno ............... - ! ........................................................ - IF( forward ) THEN - - itau = itau + 1 - ! iday = day_ini+itau/day_step - ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 - ! - ! IF(time.GT.1.) THEN - ! time = time-1. - ! iday = iday+1 - ! ENDIF - - forward = .FALSE. - IF( itau.EQ. itaufinp1 ) then - abort_message = 'Simulation finished' - call abort_gcm(modname,abort_message,0) - ENDIF - GO TO 2 - - ELSE ! of IF(forward) i.e. backward step - - call check_isotopes_seq(q,ip1jmp1,'leapfrog 1698') - - IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN - IF(itau.EQ.itaufin) THEN - iav=1 - ELSE - iav=0 - ENDIF - - ! ! Ehouarn: re-compute geopotential for outputs - CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) - - IF (ok_dynzon) THEN - CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav, & - ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) - - ENDIF - IF (ok_dyn_ave) THEN - CALL writedynav(itau,vcov, & - ucov,teta,pk,phi,q,masse,ps,phis) - - ENDIF - - ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) - - IF(MOD(itau,iecri ).EQ.0) THEN - ! IF(MOD(itau,iecri*day_step).EQ.0) THEN - CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) - unat=0. - do l=1,llm - unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) - vnat(:,l)=vcov(:,l)/cv(:) - enddo - if (ok_dyn_ins) then - ! write(lunout,*) "leapfrog: call writehist (b)", - ! & itau,iecri - CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis) - endif ! of if (ok_dyn_ins) - - ! For some Grads outputs - if (output_grads_dyn) then -INCLUDE "write_grads_dyn.h" - endif - - ENDIF ! of IF(MOD(itau,iecri ).EQ.0) - - IF(itau.EQ.itaufin) THEN - ! if (planet_type.eq."earth") then - CALL dynredem1("restart.nc",start_time, & - vcov,ucov,teta,q,masse,ps) - ! endif ! of if (planet_type.eq."earth") - if (ok_guide) then - ! ! set ok_guide to false to avoid extra output - ! ! in following forward step - ok_guide=.false. - endif - ENDIF ! of IF(itau.EQ.itaufin) - - forward = .TRUE. - GO TO 1 - - ENDIF ! of IF (forward) - - END IF ! of IF(.not.purmats) - -END SUBROUTINE leapfrog Index: /LMDZ6/trunk/libf/dyn3d/leapfrog.f90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/leapfrog.f90 (revision 5312) +++ /LMDZ6/trunk/libf/dyn3d/leapfrog.f90 (revision 5312) @@ -0,0 +1,852 @@ +! +! $Id$ +! +! +! +SUBROUTINE leapfrog(ucov,vcov,teta,ps,masse,phis,q,time_0) + !IM : pour sortir les param. du modele dans un fis. netcdf 110106 + USE iniprint_mod_h + USE comgeom_mod_h + USE comdissnew_mod_h + use IOIPSL + USE infotrac, ONLY: nqtot, isoCheck + USE guide_mod, ONLY : guide_main + USE write_field, ONLY: writefield + USE control_mod, ONLY: nday, day_step, planet_type, offline, & + iconser, iphysiq, iperiod, dissip_period, & + iecri, ip_ebil_dyn, ok_dynzon, ok_dyn_ins, & + periodav, ok_dyn_ave, output_grads_dyn + use exner_hyb_m, only: exner_hyb + use exner_milieu_m, only: exner_milieu + USE comvert_mod, ONLY: ap,bp,pressure_exner,presnivs + USE comconst_mod, ONLY: cpp, dtphys, dtvr, pi, ihf + USE logic_mod, ONLY: iflag_phys,ok_guide,forward,leapf,apphys, & + statcl,conser,apdiss,purmats,ok_strato + USE temps_mod, ONLY: jD_ref,jH_ref,itaufin,day_ini,day_ref, & + start_time,dt + USE strings_mod, ONLY: msg + USE lmdz_cppkeys_wrapper, ONLY: CPPKEY_PHYS + USE dimensions_mod, ONLY: iim, jjm, llm, ndm + USE paramet_mod_h + USE academic_mod_h, ONLY: tetarappel, knewt_t, knewt_g, clat4 + IMPLICIT NONE + + ! ...... Version du 10/01/98 .......... + + ! avec coordonnees verticales hybrides + ! avec nouveaux operat. dissipation * ( gradiv2,divgrad2,nxgraro2 ) + + !======================================================================= + ! + ! Auteur: P. Le Van /L. Fairhead/F.Hourdin + ! ------- + ! + ! Objet: + ! ------ + ! + ! GCM LMD nouvelle grille + ! + !======================================================================= + ! + ! ... Dans inigeom , nouveaux calculs pour les elongations cu , cv + ! et possibilite d'appeler une fonction f(y) a derivee tangente + ! hyperbolique a la place de la fonction a derivee sinusoidale. + + ! ... Possibilite de choisir le shema pour l'advection de + ! q , en modifiant iadv dans traceur.def (10/02) . + ! + ! Pour Van-Leer + Vapeur d'eau saturee, iadv(1)=4. (F.Codron,10/99) + ! Pour Van-Leer iadv=10 + ! + !----------------------------------------------------------------------- + ! Declarations: + ! ------------- + + REAL,INTENT(IN) :: time_0 ! not used + + ! dynamical variables: + REAL,INTENT(INOUT) :: ucov(ip1jmp1,llm) ! zonal covariant wind + REAL,INTENT(INOUT) :: vcov(ip1jm,llm) ! meridional covariant wind + REAL,INTENT(INOUT) :: teta(ip1jmp1,llm) ! potential temperature + REAL,INTENT(INOUT) :: ps(ip1jmp1) ! surface pressure (Pa) + REAL,INTENT(INOUT) :: masse(ip1jmp1,llm) ! air mass + REAL,INTENT(INOUT) :: phis(ip1jmp1) ! geopotentiat at the surface + REAL,INTENT(INOUT) :: q(ip1jmp1,llm,nqtot) ! advected tracers + + REAL :: p (ip1jmp1,llmp1 ) ! interlayer pressure + REAL :: pks(ip1jmp1) ! exner at the surface + REAL :: pk(ip1jmp1,llm) ! exner at mid-layer + REAL :: pkf(ip1jmp1,llm) ! filtered exner at mid-layer + REAL :: phi(ip1jmp1,llm) ! geopotential + REAL :: w(ip1jmp1,llm) ! vertical velocity + + real :: zqmin,zqmax + + ! variables dynamiques intermediaire pour le transport + REAL :: pbaru(ip1jmp1,llm),pbarv(ip1jm,llm) !flux de masse + + ! variables dynamiques au pas -1 + REAL :: vcovm1(ip1jm,llm),ucovm1(ip1jmp1,llm) + REAL :: tetam1(ip1jmp1,llm),psm1(ip1jmp1) + REAL :: massem1(ip1jmp1,llm) + + ! tendances dynamiques + REAL :: dv(ip1jm,llm),du(ip1jmp1,llm) + REAL :: dteta(ip1jmp1,llm),dq(ip1jmp1,llm,nqtot),dp(ip1jmp1) + + ! tendances de la dissipation + REAL :: dvdis(ip1jm,llm),dudis(ip1jmp1,llm) + REAL :: dtetadis(ip1jmp1,llm) + + ! tendances physiques + REAL :: dvfi(ip1jm,llm),dufi(ip1jmp1,llm) + REAL :: dtetafi(ip1jmp1,llm),dqfi(ip1jmp1,llm,nqtot),dpfi(ip1jmp1) + + ! variables pour le fichier histoire + REAL :: dtav ! intervalle de temps elementaire + + REAL :: tppn(iim),tpps(iim),tpn,tps + ! + INTEGER :: itau,itaufinp1,iav + ! INTEGER iday ! jour julien + REAL :: time + + REAL :: SSUM + ! REAL finvmaold(ip1jmp1,llm) + + !ym LOGICAL lafin + LOGICAL :: lafin=.false. + INTEGER :: ij,iq,l + INTEGER :: ik + + real :: time_step, t_wrt, t_ops + + ! REAL rdayvrai,rdaym_ini + ! jD_cur: jour julien courant + ! jH_cur: heure julienne courante + REAL :: jD_cur, jH_cur + INTEGER :: an, mois, jour + REAL :: secondes + + LOGICAL :: first,callinigrads + !IM : pour sortir les param. du modele dans un fis. netcdf 110106 + save first + data first/.true./ + real :: dt_cum + character(len=10) :: infile + integer :: zan, tau0, thoriid + integer :: nid_ctesGCM + save nid_ctesGCM + real :: degres + real :: rlong(iip1), rlatg(jjp1) + real :: zx_tmp_2d(iip1,jjp1) + integer :: ndex2d(iip1*jjp1) + logical :: ok_sync + parameter (ok_sync = .true.) + logical :: physic + + data callinigrads/.true./ + character(len=10) :: string10 + + REAL :: flxw(ip1jmp1,llm) ! flux de masse verticale + + !+jld variables test conservation energie + REAL :: ecin(ip1jmp1,llm),ecin0(ip1jmp1,llm) + ! Tendance de la temp. potentiel d (theta)/ d t due a la + ! tansformation d'energie cinetique en energie thermique + ! cree par la dissipation + REAL :: dtetaecdt(ip1jmp1,llm) + REAL :: vcont(ip1jm,llm),ucont(ip1jmp1,llm) + REAL :: vnat(ip1jm,llm),unat(ip1jmp1,llm) + REAL :: d_h_vcol, d_qt, d_qw, d_ql, d_ec + CHARACTER(len=15) :: ztit + !IM INTEGER ip_ebil_dyn ! PRINT level for energy conserv. diag. + !IM SAVE ip_ebil_dyn + !IM DATA ip_ebil_dyn/0/ + !-jld + + character(len=80) :: dynhist_file, dynhistave_file + character(len=*),parameter :: modname="leapfrog" + character(len=80) :: abort_message + + logical :: dissip_conservative + save dissip_conservative + data dissip_conservative/.true./ + + LOGICAL :: prem + save prem + DATA prem/.true./ + INTEGER :: testita + PARAMETER (testita = 9) + + logical , parameter :: flag_verif = .false. + + + integer :: itau_w ! pas de temps ecriture = itap + itau_phy + + + if (nday>=0) then + itaufin = nday*day_step + else + itaufin = -nday + endif + itaufinp1 = itaufin +1 + itau = 0 + physic=.true. + if (iflag_phys==0.or.iflag_phys==2) physic=.false. + + ! iday = day_ini+itau/day_step + ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 + ! IF(time.GT.1.) THEN + ! time = time-1. + ! iday = iday+1 + ! ENDIF + + + !----------------------------------------------------------------------- + ! On initialise la pression et la fonction d'Exner : + ! -------------------------------------------------- + + dq(:,:,:)=0. + CALL pression ( ip1jmp1, ap, bp, ps, p ) + if (pressure_exner) then + CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf ) + else + CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) + endif + + !----------------------------------------------------------------------- + ! Debut de l'integration temporelle: + ! ---------------------------------- + + 1 CONTINUE ! Matsuno Forward step begins here + + ! date: (NB: date remains unchanged for Backward step) + ! ----- + + jD_cur = jD_ref + day_ini - day_ref + & + (itau+1)/day_step + jH_cur = jH_ref + start_time + & + mod(itau+1,day_step)/float(day_step) + jD_cur = jD_cur + int(jH_cur) + jH_cur = jH_cur - int(jH_cur) + + call check_isotopes_seq(q,ip1jmp1,'leapfrog 321') + + if (ok_guide) then + call guide_main(itau,ucov,vcov,teta,q,masse,ps) + endif + + + + ! + ! IF( MOD( itau, 10* day_step ).EQ.0 ) THEN + ! CALL test_period ( ucov,vcov,teta,q,p,phis ) + ! PRINT *,' ---- Test_period apres continue OK ! -----', itau + ! ENDIF + ! + + ! Save fields obtained at previous time step as '...m1' + CALL SCOPY( ijmllm ,vcov , 1, vcovm1 , 1 ) + CALL SCOPY( ijp1llm,ucov , 1, ucovm1 , 1 ) + CALL SCOPY( ijp1llm,teta , 1, tetam1 , 1 ) + CALL SCOPY( ijp1llm,masse, 1, massem1, 1 ) + CALL SCOPY( ip1jmp1, ps , 1, psm1 , 1 ) + + forward = .TRUE. + leapf = .FALSE. + dt = dtvr + + ! ... P.Le Van .26/04/94 .... + ! Ehouarn: finvmaold is actually not used + ! CALL SCOPY ( ijp1llm, masse, 1, finvmaold, 1 ) + ! CALL filtreg ( finvmaold ,jjp1, llm, -2,2, .TRUE., 1 ) + + call check_isotopes_seq(q,ip1jmp1,'leapfrog 400') + + 2 CONTINUE ! Matsuno backward or leapfrog step begins here + + !----------------------------------------------------------------------- + + ! date: (NB: only leapfrog step requires recomputing date) + ! ----- + + IF (leapf) THEN + jD_cur = jD_ref + day_ini - day_ref + & + (itau+1)/day_step + jH_cur = jH_ref + start_time + & + mod(itau+1,day_step)/float(day_step) + jD_cur = jD_cur + int(jH_cur) + jH_cur = jH_cur - int(jH_cur) + ENDIF + + + ! gestion des appels de la physique et des dissipations: + ! ------------------------------------------------------ + ! + ! ... P.Le Van ( 6/02/95 ) .... + + apphys = .FALSE. + statcl = .FALSE. + conser = .FALSE. + apdiss = .FALSE. + + IF( purmats ) THEN + ! ! Purely Matsuno time stepping + IF( MOD(itau,iconser) .EQ.0.AND. forward ) conser = .TRUE. + IF( MOD(itau,dissip_period ).EQ.0.AND..NOT.forward ) & + apdiss = .TRUE. + IF( MOD(itau,iphysiq ).EQ.0.AND..NOT.forward & + .and. physic ) apphys = .TRUE. + ELSE + ! ! Leapfrog/Matsuno time stepping + IF( MOD(itau ,iconser) .EQ. 0 ) conser = .TRUE. + IF( MOD(itau+1,dissip_period).EQ.0 .AND. .NOT. forward ) & + apdiss = .TRUE. + IF( MOD(itau+1,iphysiq).EQ.0.AND.physic ) apphys=.TRUE. + END IF + + ! Ehouarn: for Shallow Water case (ie: 1 vertical layer), + ! supress dissipation step + if (llm.eq.1) then + apdiss=.false. + endif + + + call check_isotopes_seq(q,ip1jmp1,'leapfrog 589') + + !----------------------------------------------------------------------- + ! calcul des tendances dynamiques: + ! -------------------------------- + + ! ! compute geopotential phi() + CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) + + time = jD_cur + jH_cur + CALL caldyn & + ( itau,ucov,vcov,teta,ps,masse,pk,pkf,phis , & + phi,conser,du,dv,dteta,dp,w, pbaru,pbarv, time ) + + + !----------------------------------------------------------------------- + ! calcul des tendances advection des traceurs (dont l'humidite) + ! ------------------------------------------------------------- + + call check_isotopes_seq(q,ip1jmp1, & + 'leapfrog 686: avant caladvtrac') + + IF( forward.OR. leapf ) THEN + ! Ehouarn: NB: fields sent to advtrac are those at the beginning of the time step + CALL caladvtrac(q,pbaru,pbarv, & + p, masse, dq, teta, & + flxw, pk) + ! !write(*,*) 'caladvtrac 346' + + + IF (offline) THEN + !maf stokage du flux de masse pour traceurs OFF-LINE + + CALL fluxstokenc(pbaru,pbarv,masse,teta,phi,phis, & + dtvr, itau) + + + + ENDIF ! of IF (offline) + ! + ENDIF ! of IF( forward.OR. leapf ) + + + !----------------------------------------------------------------------- + ! integrations dynamique et traceurs: + ! ---------------------------------- + + CALL msg('720', modname, isoCheck) + call check_isotopes_seq(q,ip1jmp1,'leapfrog 756') + + CALL integrd ( nqtot,vcovm1,ucovm1,tetam1,psm1,massem1 , & + dv,du,dteta,dq,dp,vcov,ucov,teta,q,ps,masse,phis ) + ! $ finvmaold ) + + CALL msg('724', modname, isoCheck) + call check_isotopes_seq(q,ip1jmp1,'leapfrog 762') + + ! .P.Le Van (26/04/94 ajout de finvpold dans l'appel d'integrd) + ! + !----------------------------------------------------------------------- + ! calcul des tendances physiques: + ! ------------------------------- + ! ######## P.Le Van ( Modif le 6/02/95 ) ########### + ! + IF( purmats ) THEN + IF( itau.EQ.itaufin.AND..NOT.forward ) lafin = .TRUE. + ELSE + IF( itau+1.EQ. itaufin ) lafin = .TRUE. + ENDIF + ! + ! + IF( apphys ) THEN + ! + ! ....... Ajout P.Le Van ( 17/04/96 ) ........... + ! + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + if (pressure_exner) then + CALL exner_hyb( ip1jmp1, ps, p,pks, pk, pkf ) + else + CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) + endif + + ! Appel a geopot ajoute le 2014/05/08 pour garantir la convergence numerique + ! avec dyn3dmem + CALL geopot ( ip1jmp1, teta , pk , pks, phis , phi ) + + ! rdaym_ini = itau * dtvr / daysec + ! rdayvrai = rdaym_ini + day_ini + ! jD_cur = jD_ref + day_ini - day_ref + ! $ + int (itau * dtvr / daysec) + ! jH_cur = jH_ref + & + ! & (itau * dtvr / daysec - int(itau * dtvr / daysec)) + jD_cur = jD_ref + day_ini - day_ref + & + (itau+1)/day_step + + IF (planet_type .eq."generic") THEN + ! ! AS: we make jD_cur to be pday + jD_cur = int(day_ini + itau/day_step) + ENDIF + + jH_cur = jH_ref + start_time + & + mod(itau+1,day_step)/float(day_step) + jD_cur = jD_cur + int(jH_cur) + jH_cur = jH_cur - int(jH_cur) + ! write(lunout,*)'itau, jD_cur = ', itau, jD_cur, jH_cur + ! call ju2ymds(jD_cur+jH_cur, an, mois, jour, secondes) + ! write(lunout,*)'current date = ',an, mois, jour, secondes + + ! rajout debug + ! lafin = .true. + + + ! Inbterface avec les routines de phylmd (phymars ... ) + ! ----------------------------------------------------- + + !+jld + + ! Diagnostique de conservation de l'energie : initialisation + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil dyn' + ! Ehouarn: be careful, diagedyn is Earth-specific! + IF (planet_type.eq."earth") THEN + CALL diagedyn(ztit,2,1,1,dtphys & + , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + ENDIF ! of IF (ip_ebil_dyn.ge.1 ) + !-jld + + !IM decommenter les 6 lignes suivantes pour sortir quelques parametres dynamiques de LMDZ + !IM uncomment next 6 lines to get some parameters for LMDZ dynamics + ! IF (first) THEN + ! first=.false. + !INCLUDE "ini_paramLMDZ_dyn.h" + ! ENDIF + ! + !INCLUDE "write_paramLMDZ_dyn.h" + +IF (CPPKEY_PHYS) THEN + CALL calfis( lafin , jD_cur, jH_cur, & + ucov,vcov,teta,q,masse,ps,p,pk,phis,phi , & + du,dv,dteta,dq, & + flxw,dufi,dvfi,dtetafi,dqfi,dpfi ) +END IF + ! ajout des tendances physiques: + ! ------------------------------ + CALL addfi( dtphys, leapf, forward , & + ucov, vcov, teta , q ,ps , & + dufi, dvfi, dtetafi , dqfi ,dpfi ) + ! ! since addfi updates ps(), also update p(), masse() and pk() + CALL pression (ip1jmp1,ap,bp,ps,p) + CALL massdair(p,masse) + if (pressure_exner) then + CALL exner_hyb(ip1jmp1,ps,p,pks,pk,pkf) + else + CALL exner_milieu(ip1jmp1,ps,p,pks,pk,pkf) + endif + + IF (ok_strato) THEN + CALL top_bound( vcov,ucov,teta,masse,dtphys) + ENDIF + + ! + ! Diagnostique de conservation de l'energie : difference + IF (ip_ebil_dyn.ge.1 ) THEN + ztit='bil phys' + IF (planet_type.eq."earth") THEN + CALL diagedyn(ztit,2,1,1,dtphys & + , ucov , vcov , ps, p ,pk , teta , q(:,:,1), q(:,:,2)) + ENDIF + ENDIF ! of IF (ip_ebil_dyn.ge.1 ) + + ENDIF ! of IF( apphys ) + + IF(iflag_phys.EQ.2) THEN ! "Newtonian" case + ! Academic case : Simple friction and Newtonan relaxation + ! ------------------------------------------------------- + DO l=1,llm + DO ij=1,ip1jmp1 + teta(ij,l)=teta(ij,l)-dtvr* & + (teta(ij,l)-tetarappel(ij,l))*(knewt_g+knewt_t(l)*clat4(ij)) + ENDDO + ENDDO ! of DO l=1,llm + + if (planet_type.eq."giant") then + ! ! add an intrinsic heat flux at the base of the atmosphere + teta(:,1)=teta(:,1)+dtvr*aire(:)*ihf/cpp/masse(:,1) + endif + + call friction(ucov,vcov,dtvr) + + ! ! Sponge layer (if any) + IF (ok_strato) THEN + ! dufi(:,:)=0. + ! dvfi(:,:)=0. + ! dtetafi(:,:)=0. + ! dqfi(:,:,:)=0. + ! dpfi(:)=0. + ! CALL top_bound(vcov,ucov,teta,masse,dufi,dvfi,dtetafi) + CALL top_bound( vcov,ucov,teta,masse,dtvr) + ! CALL addfi( dtvr, leapf, forward , + ! $ ucov, vcov, teta , q ,ps , + ! $ dufi, dvfi, dtetafi , dqfi ,dpfi ) + ENDIF ! of IF (ok_strato) + ENDIF ! of IF (iflag_phys.EQ.2) + + + !-jld + + CALL pression ( ip1jmp1, ap, bp, ps, p ) + if (pressure_exner) then + CALL exner_hyb( ip1jmp1, ps, p, pks, pk, pkf ) + else + CALL exner_milieu( ip1jmp1, ps, p, pks, pk, pkf ) + endif + CALL massdair(p,masse) + + call check_isotopes_seq(q,ip1jmp1,'leapfrog 1196') + + !----------------------------------------------------------------------- + ! dissipation horizontale et verticale des petites echelles: + ! ---------------------------------------------------------- + + IF(apdiss) THEN + + + ! calcul de l'energie cinetique avant dissipation + call covcont(llm,ucov,vcov,ucont,vcont) + call enercin(vcov,ucov,vcont,ucont,ecin0) + + ! dissipation + CALL dissip(vcov,ucov,teta,p,dvdis,dudis,dtetadis) + ucov=ucov+dudis + vcov=vcov+dvdis + ! teta=teta+dtetadis + + + !------------------------------------------------------------------------ + if (dissip_conservative) then + ! On rajoute la tendance due a la transform. Ec -> E therm. cree + ! lors de la dissipation + call covcont(llm,ucov,vcov,ucont,vcont) + call enercin(vcov,ucov,vcont,ucont,ecin) + dtetaecdt= (ecin0-ecin)/ pk + ! teta=teta+dtetaecdt + dtetadis=dtetadis+dtetaecdt + endif + teta=teta+dtetadis + !------------------------------------------------------------------------ + + + ! ....... P. Le Van ( ajout le 17/04/96 ) ........... + ! ... Calcul de la valeur moyenne, unique de h aux poles ..... + ! + + DO l = 1, llm + DO ij = 1,iim + tppn(ij) = aire( ij ) * teta( ij ,l) + tpps(ij) = aire(ij+ip1jm) * teta(ij+ip1jm,l) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + teta( ij ,l) = tpn + teta(ij+ip1jm,l) = tps + ENDDO + ENDDO + + if (1 == 0) then + !!! Ehouarn: lines here 1) kill 1+1=2 in the dynamics + !!! 2) should probably not be here anyway + !!! but are kept for those who would want to revert to previous behaviour + DO ij = 1,iim + tppn(ij) = aire( ij ) * ps ( ij ) + tpps(ij) = aire(ij+ip1jm) * ps (ij+ip1jm) + ENDDO + tpn = SSUM(iim,tppn,1)/apoln + tps = SSUM(iim,tpps,1)/apols + + DO ij = 1, iip1 + ps( ij ) = tpn + ps(ij+ip1jm) = tps + ENDDO + endif ! of if (1 == 0) + + END IF ! of IF(apdiss) + + ! ajout debug + ! IF( lafin ) then + ! abort_message = 'Simulation finished' + ! call abort_gcm(modname,abort_message,0) + ! ENDIF + + ! ******************************************************************** + ! ******************************************************************** + ! .... fin de l'integration dynamique et physique pour le pas itau .. + ! ******************************************************************** + ! ******************************************************************** + + ! preparation du pas d'integration suivant ...... + + call check_isotopes_seq(q,ip1jmp1,'leapfrog 1509') + + IF ( .NOT.purmats ) THEN + ! ........................................................ + ! .............. schema matsuno + leapfrog .............. + ! ........................................................ + + IF(forward.OR. leapf) THEN + itau= itau + 1 + ! iday= day_ini+itau/day_step + ! time= REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 + ! IF(time.GT.1.) THEN + ! time = time-1. + ! iday = iday+1 + ! ENDIF + ENDIF + + + IF( itau.EQ. itaufinp1 ) then + if (flag_verif) then + write(79,*) 'ucov',ucov + write(80,*) 'vcov',vcov + write(81,*) 'teta',teta + write(82,*) 'ps',ps + write(83,*) 'q',q + WRITE(85,*) 'q1 = ',q(:,:,1) + WRITE(86,*) 'q3 = ',q(:,:,3) + endif + + abort_message = 'Simulation finished' + + call abort_gcm(modname,abort_message,0) + ENDIF + !----------------------------------------------------------------------- + ! ecriture du fichier histoire moyenne: + ! ------------------------------------- + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF + + ! ! Ehouarn: re-compute geopotential for outputs + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + + IF (ok_dynzon) THEN + CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav, & + ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) + + END IF + IF (ok_dyn_ave) THEN + CALL writedynav(itau,vcov, & + ucov,teta,pk,phi,q,masse,ps,phis) + + ENDIF + + ENDIF ! of IF((MOD(itau,iperiod).EQ.0).OR.(itau.EQ.itaufin)) + + call check_isotopes_seq(q,ip1jmp1,'leapfrog 1584') + + !----------------------------------------------------------------------- + ! ecriture de la bande histoire: + ! ------------------------------ + + IF( MOD(itau,iecri).EQ.0) THEN + ! ! Ehouarn: output only during LF or Backward Matsuno + if (leapf.or.(.not.leapf.and.(.not.forward))) then + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + unat=0. + do l=1,llm + unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) + vnat(:,l)=vcov(:,l)/cv(:) + enddo + if (ok_dyn_ins) then + ! write(lunout,*) "leapfrog: call writehist, itau=",itau + CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis) + ! call WriteField('ucov',reshape(ucov,(/iip1,jmp1,llm/))) + ! call WriteField('vcov',reshape(vcov,(/iip1,jjm,llm/))) + ! call WriteField('teta',reshape(teta,(/iip1,jmp1,llm/))) + ! call WriteField('ps',reshape(ps,(/iip1,jmp1/))) + ! call WriteField('masse',reshape(masse,(/iip1,jmp1,llm/))) + endif ! of if (ok_dyn_ins) + + ! For some Grads outputs of fields + if (output_grads_dyn) then +INCLUDE "write_grads_dyn.h" + endif + endif ! of if (leapf.or.(.not.leapf.and.(.not.forward))) + ENDIF ! of IF(MOD(itau,iecri).EQ.0) + + IF(itau.EQ.itaufin) THEN + + + ! if (planet_type.eq."earth") then + ! Write an Earth-format restart file + CALL dynredem1("restart.nc",start_time, & + vcov,ucov,teta,q,masse,ps) + ! endif ! of if (planet_type.eq."earth") + + CLOSE(99) + if (ok_guide) then + ! ! set ok_guide to false to avoid extra output + ! ! in following forward step + ok_guide=.false. + endif + ! !!! Ehouarn: Why not stop here and now? + ENDIF ! of IF (itau.EQ.itaufin) + + !----------------------------------------------------------------------- + ! gestion de l'integration temporelle: + ! ------------------------------------ + + IF( MOD(itau,iperiod).EQ.0 ) THEN + GO TO 1 + ELSE IF ( MOD(itau-1,iperiod).EQ. 0 ) THEN + + IF( forward ) THEN + ! fin du pas forward et debut du pas backward + + forward = .FALSE. + leapf = .FALSE. + GO TO 2 + + ELSE + ! fin du pas backward et debut du premier pas leapfrog + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF ! of IF (forward) + ELSE + + ! ...... pas leapfrog ..... + + leapf = .TRUE. + dt = 2.*dtvr + GO TO 2 + END IF ! of IF (MOD(itau,iperiod).EQ.0) + ! ! ELSEIF (MOD(itau-1,iperiod).EQ.0) + + ELSE ! of IF (.not.purmats) + + call check_isotopes_seq(q,ip1jmp1,'leapfrog 1664') + + ! ........................................................ + ! .............. schema matsuno ............... + ! ........................................................ + IF( forward ) THEN + + itau = itau + 1 + ! iday = day_ini+itau/day_step + ! time = REAL(itau-(iday-day_ini)*day_step)/day_step+time_0 + ! + ! IF(time.GT.1.) THEN + ! time = time-1. + ! iday = iday+1 + ! ENDIF + + forward = .FALSE. + IF( itau.EQ. itaufinp1 ) then + abort_message = 'Simulation finished' + call abort_gcm(modname,abort_message,0) + ENDIF + GO TO 2 + + ELSE ! of IF(forward) i.e. backward step + + call check_isotopes_seq(q,ip1jmp1,'leapfrog 1698') + + IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) THEN + IF(itau.EQ.itaufin) THEN + iav=1 + ELSE + iav=0 + ENDIF + + ! ! Ehouarn: re-compute geopotential for outputs + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + + IF (ok_dynzon) THEN + CALL bilan_dyn(2,dtvr*iperiod,dtvr*day_step*periodav, & + ps,masse,pk,pbaru,pbarv,teta,phi,ucov,vcov,q) + + ENDIF + IF (ok_dyn_ave) THEN + CALL writedynav(itau,vcov, & + ucov,teta,pk,phi,q,masse,ps,phis) + + ENDIF + + ENDIF ! of IF(MOD(itau,iperiod).EQ.0 .OR. itau.EQ.itaufin) + + IF(MOD(itau,iecri ).EQ.0) THEN + ! IF(MOD(itau,iecri*day_step).EQ.0) THEN + CALL geopot(ip1jmp1,teta,pk,pks,phis,phi) + unat=0. + do l=1,llm + unat(iip2:ip1jm,l)=ucov(iip2:ip1jm,l)/cu(iip2:ip1jm) + vnat(:,l)=vcov(:,l)/cv(:) + enddo + if (ok_dyn_ins) then + ! write(lunout,*) "leapfrog: call writehist (b)", + ! & itau,iecri + CALL writehist(itau,vcov,ucov,teta,phi,q,masse,ps,phis) + endif ! of if (ok_dyn_ins) + + ! For some Grads outputs + if (output_grads_dyn) then +INCLUDE "write_grads_dyn.h" + endif + + ENDIF ! of IF(MOD(itau,iecri ).EQ.0) + + IF(itau.EQ.itaufin) THEN + ! if (planet_type.eq."earth") then + CALL dynredem1("restart.nc",start_time, & + vcov,ucov,teta,q,masse,ps) + ! endif ! of if (planet_type.eq."earth") + if (ok_guide) then + ! ! set ok_guide to false to avoid extra output + ! ! in following forward step + ok_guide=.false. + endif + ENDIF ! of IF(itau.EQ.itaufin) + + forward = .TRUE. + GO TO 1 + + ENDIF ! of IF (forward) + + END IF ! of IF(.not.purmats) + +END SUBROUTINE leapfrog Index: DZ6/trunk/libf/dyn3d/tetaleveli1j.F90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/tetaleveli1j.F90 (revision 5311) +++ (revision ) @@ -1,141 +1,0 @@ -!================================================================ -!================================================================ -SUBROUTINE tetaleveli1j(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) - !================================================================ - !================================================================ - - ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique - ! USE dimphy - USE dimensions_mod, ONLY: iim, jjm, llm, ndm -USE paramet_mod_h -IMPLICIT none - - - !ccccINCLUDE "dimphy.h" - - !================================================================ - ! - ! Interpoler des champs 3-D u, v et g du modele a un niveau de - ! pression donnee (pres) - ! - ! INPUT: ilon ----- nombre de points - ! ilev ----- nombre de couches - ! lnew ----- true si on doit reinitialiser les poids - ! pgcm ----- pressions modeles - ! pres ----- pression vers laquelle on interpolle - ! Qgcm ----- champ GCM - ! Qpres ---- champ interpolle au niveau pres - ! - !================================================================ - ! - ! arguments : - ! ----------- - - INTEGER :: ilon, ilev - logical :: lnew - - REAL :: pgcm(ilon,ilev) - REAL :: Qgcm(ilon,ilev) - real :: pres - REAL :: Qpres(ilon) - - ! local : - ! ------- - - !IM 211004 - ! INTEGER lt(klon), lb(klon) - ! REAL ptop, pbot, aist(klon), aisb(klon) - ! - - ! - INTEGER :: lt(ip1jm), lb(ip1jm) - REAL :: ptop, pbot, aist(ip1jm), aisb(ip1jm) - !MI 211004 - save lt,lb,ptop,pbot,aist,aisb - - INTEGER :: i, k - ! - ! PRINT*,'tetalevel pres=',pres - !===================================================================== - if (lnew) then - ! on r�initialise les r�indicages et les poids - !===================================================================== - - - ! Chercher les 2 couches les plus proches du niveau a obtenir - ! - ! Eventuellement, faire l'extrapolation a partir des deux couches - ! les plus basses ou les deux couches les plus hautes: - DO i = 1, ilon - !IM IF ( ABS(pres-pgcm(i,ilev) ) .LT. - IF ( ABS(pres-pgcm(i,ilev) ) .GT. & - ABS(pres-pgcm(i,1)) ) THEN - lt(i) = ilev ! 2 - lb(i) = ilev-1 ! 1 - ELSE - lt(i) = 2 - lb(i) = 1 - ENDIF - !IM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', - !IM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) - END DO - DO k = 1, ilev-1 - DO i = 1, ilon - pbot = pgcm(i,k) - ptop = pgcm(i,k+1) - !IM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN - IF (ptop.GE.pres .AND. pbot.LE.pres) THEN - lt(i) = k+1 - lb(i) = k - ENDIF - END DO - END DO - ! - ! Interpolation lineaire: - ! - DO i = 1, ilon - ! interpolation en logarithme de pression: - ! - ! ... Modif . P. Le Van ( 20/01/98) .... - ! Modif Fr�d�ric Hourdin (3/01/02) - - IF(pgcm(i,lb(i)).EQ.0.OR. & - pgcm(i,lt(i)).EQ.0.) THEN - ! - PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), & - lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres - ! - ENDIF - ! - aist(i) = LOG( pgcm(i,lb(i))/ pres ) & - / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) - aisb(i) = LOG( pres / pgcm(i,lt(i)) ) & - / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) - enddo - - - endif ! lnew - - !====================================================================== - ! inteprollation - !====================================================================== - - do i=1,ilon - Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) - !IM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), - !IM $ Qgcm(i,lt(i)),aist(i),Qpres(i) - enddo - ! - ! Je mets les vents a zero quand je rencontre une montagne - do i = 1, ilon - !IM if (pgcm(i,1).LT.pres) THEN - if (pgcm(i,1).GT.pres) THEN - ! Qpres(i)=1e33 - Qpres(i)=1e+20 - !IM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres - endif - enddo - - ! - RETURN -END SUBROUTINE tetaleveli1j Index: /LMDZ6/trunk/libf/dyn3d/tetaleveli1j.f90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/tetaleveli1j.f90 (revision 5312) +++ /LMDZ6/trunk/libf/dyn3d/tetaleveli1j.f90 (revision 5312) @@ -0,0 +1,141 @@ +!================================================================ +!================================================================ +SUBROUTINE tetaleveli1j(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) + !================================================================ + !================================================================ + + ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique + ! USE dimphy + USE dimensions_mod, ONLY: iim, jjm, llm, ndm +USE paramet_mod_h +IMPLICIT none + + + !ccccINCLUDE "dimphy.h" + + !================================================================ + ! + ! Interpoler des champs 3-D u, v et g du modele a un niveau de + ! pression donnee (pres) + ! + ! INPUT: ilon ----- nombre de points + ! ilev ----- nombre de couches + ! lnew ----- true si on doit reinitialiser les poids + ! pgcm ----- pressions modeles + ! pres ----- pression vers laquelle on interpolle + ! Qgcm ----- champ GCM + ! Qpres ---- champ interpolle au niveau pres + ! + !================================================================ + ! + ! arguments : + ! ----------- + + INTEGER :: ilon, ilev + logical :: lnew + + REAL :: pgcm(ilon,ilev) + REAL :: Qgcm(ilon,ilev) + real :: pres + REAL :: Qpres(ilon) + + ! local : + ! ------- + + !IM 211004 + ! INTEGER lt(klon), lb(klon) + ! REAL ptop, pbot, aist(klon), aisb(klon) + ! + + ! + INTEGER :: lt(ip1jm), lb(ip1jm) + REAL :: ptop, pbot, aist(ip1jm), aisb(ip1jm) + !MI 211004 + save lt,lb,ptop,pbot,aist,aisb + + INTEGER :: i, k + ! + ! PRINT*,'tetalevel pres=',pres + !===================================================================== + if (lnew) then + ! on r�initialise les r�indicages et les poids + !===================================================================== + + + ! Chercher les 2 couches les plus proches du niveau a obtenir + ! + ! Eventuellement, faire l'extrapolation a partir des deux couches + ! les plus basses ou les deux couches les plus hautes: + DO i = 1, ilon + !IM IF ( ABS(pres-pgcm(i,ilev) ) .LT. + IF ( ABS(pres-pgcm(i,ilev) ) .GT. & + ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF + !IM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', + !IM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) + END DO + DO k = 1, ilev-1 + DO i = 1, ilon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) + !IM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + IF (ptop.GE.pres .AND. pbot.LE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + END DO + END DO + ! + ! Interpolation lineaire: + ! + DO i = 1, ilon + ! interpolation en logarithme de pression: + ! + ! ... Modif . P. Le Van ( 20/01/98) .... + ! Modif Fr�d�ric Hourdin (3/01/02) + + IF(pgcm(i,lb(i)).EQ.0.OR. & + pgcm(i,lt(i)).EQ.0.) THEN + ! + PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), & + lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres + ! + ENDIF + ! + aist(i) = LOG( pgcm(i,lb(i))/ pres ) & + / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) & + / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + + !====================================================================== + ! inteprollation + !====================================================================== + + do i=1,ilon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) + !IM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), + !IM $ Qgcm(i,lt(i)),aist(i),Qpres(i) + enddo + ! + ! Je mets les vents a zero quand je rencontre une montagne + do i = 1, ilon + !IM if (pgcm(i,1).LT.pres) THEN + if (pgcm(i,1).GT.pres) THEN + ! Qpres(i)=1e33 + Qpres(i)=1e+20 + !IM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres + endif + enddo + + ! + RETURN +END SUBROUTINE tetaleveli1j Index: DZ6/trunk/libf/dyn3d/tetaleveli1j1.F90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/tetaleveli1j1.F90 (revision 5311) +++ (revision ) @@ -1,141 +1,0 @@ -!================================================================ -!================================================================ -SUBROUTINE tetaleveli1j1(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) - !================================================================ - !================================================================ - - ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique - ! USE dimphy - USE dimensions_mod, ONLY: iim, jjm, llm, ndm -USE paramet_mod_h -IMPLICIT none - - - !cccINCLUDE "dimphy.h" - - !================================================================ - ! - ! Interpoler des champs 3-D u, v et g du modele a un niveau de - ! pression donnee (pres) - ! - ! INPUT: ilon ----- nombre de points - ! ilev ----- nombre de couches - ! lnew ----- true si on doit reinitialiser les poids - ! pgcm ----- pressions modeles - ! pres ----- pression vers laquelle on interpolle - ! Qgcm ----- champ GCM - ! Qpres ---- champ interpolle au niveau pres - ! - !================================================================ - ! - ! arguments : - ! ----------- - - INTEGER :: ilon, ilev - logical :: lnew - - REAL :: pgcm(ilon,ilev) - REAL :: Qgcm(ilon,ilev) - real :: pres - REAL :: Qpres(ilon) - - ! local : - ! ------- - - !IM 211004 - ! INTEGER lt(klon), lb(klon) - ! REAL ptop, pbot, aist(klon), aisb(klon) - ! - - ! - INTEGER :: lt(ip1jmp1), lb(ip1jmp1) - REAL :: ptop, pbot, aist(ip1jmp1), aisb(ip1jmp1) - !MI 211004 - save lt,lb,ptop,pbot,aist,aisb - - INTEGER :: i, k - ! - ! PRINT*,'tetalevel pres=',pres - !===================================================================== - if (lnew) then - ! on r�initialise les r�indicages et les poids - !===================================================================== - - - ! Chercher les 2 couches les plus proches du niveau a obtenir - ! - ! Eventuellement, faire l'extrapolation a partir des deux couches - ! les plus basses ou les deux couches les plus hautes: - DO i = 1, ilon - !IM IF ( ABS(pres-pgcm(i,ilev) ) .LT. - IF ( ABS(pres-pgcm(i,ilev) ) .GT. & - ABS(pres-pgcm(i,1)) ) THEN - lt(i) = ilev ! 2 - lb(i) = ilev-1 ! 1 - ELSE - lt(i) = 2 - lb(i) = 1 - ENDIF - !IM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', - !IM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) - END DO - DO k = 1, ilev-1 - DO i = 1, ilon - pbot = pgcm(i,k) - ptop = pgcm(i,k+1) - !IM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN - IF (ptop.GE.pres .AND. pbot.LE.pres) THEN - lt(i) = k+1 - lb(i) = k - ENDIF - END DO - END DO - ! - ! Interpolation lineaire: - ! - DO i = 1, ilon - ! interpolation en logarithme de pression: - ! - ! ... Modif . P. Le Van ( 20/01/98) .... - ! Modif Fr�d�ric Hourdin (3/01/02) - - IF(pgcm(i,lb(i)).EQ.0.OR. & - pgcm(i,lt(i)).EQ.0.) THEN - ! - PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), & - lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres - ! - ENDIF - ! - aist(i) = LOG( pgcm(i,lb(i))/ pres ) & - / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) - aisb(i) = LOG( pres / pgcm(i,lt(i)) ) & - / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) - enddo - - - endif ! lnew - - !====================================================================== - ! inteprollation - !====================================================================== - - do i=1,ilon - Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) - !IM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), - !IM $ Qgcm(i,lt(i)),aist(i),Qpres(i) - enddo - ! - ! Je mets les vents a zero quand je rencontre une montagne - do i = 1, ilon - !IM if (pgcm(i,1).LT.pres) THEN - if (pgcm(i,1).GT.pres) THEN - ! Qpres(i)=1e33 - Qpres(i)=1e+20 - !IM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres - endif - enddo - - ! - RETURN -END SUBROUTINE tetaleveli1j1 Index: /LMDZ6/trunk/libf/dyn3d/tetaleveli1j1.f90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/tetaleveli1j1.f90 (revision 5312) +++ /LMDZ6/trunk/libf/dyn3d/tetaleveli1j1.f90 (revision 5312) @@ -0,0 +1,141 @@ +!================================================================ +!================================================================ +SUBROUTINE tetaleveli1j1(ilon,ilev,lnew,pgcm,pres,Qgcm,Qpres) + !================================================================ + !================================================================ + + ! FH 2008/05/09 On elimine toutes les clefs physiques dans la dynamique + ! USE dimphy + USE dimensions_mod, ONLY: iim, jjm, llm, ndm +USE paramet_mod_h +IMPLICIT none + + + !cccINCLUDE "dimphy.h" + + !================================================================ + ! + ! Interpoler des champs 3-D u, v et g du modele a un niveau de + ! pression donnee (pres) + ! + ! INPUT: ilon ----- nombre de points + ! ilev ----- nombre de couches + ! lnew ----- true si on doit reinitialiser les poids + ! pgcm ----- pressions modeles + ! pres ----- pression vers laquelle on interpolle + ! Qgcm ----- champ GCM + ! Qpres ---- champ interpolle au niveau pres + ! + !================================================================ + ! + ! arguments : + ! ----------- + + INTEGER :: ilon, ilev + logical :: lnew + + REAL :: pgcm(ilon,ilev) + REAL :: Qgcm(ilon,ilev) + real :: pres + REAL :: Qpres(ilon) + + ! local : + ! ------- + + !IM 211004 + ! INTEGER lt(klon), lb(klon) + ! REAL ptop, pbot, aist(klon), aisb(klon) + ! + + ! + INTEGER :: lt(ip1jmp1), lb(ip1jmp1) + REAL :: ptop, pbot, aist(ip1jmp1), aisb(ip1jmp1) + !MI 211004 + save lt,lb,ptop,pbot,aist,aisb + + INTEGER :: i, k + ! + ! PRINT*,'tetalevel pres=',pres + !===================================================================== + if (lnew) then + ! on r�initialise les r�indicages et les poids + !===================================================================== + + + ! Chercher les 2 couches les plus proches du niveau a obtenir + ! + ! Eventuellement, faire l'extrapolation a partir des deux couches + ! les plus basses ou les deux couches les plus hautes: + DO i = 1, ilon + !IM IF ( ABS(pres-pgcm(i,ilev) ) .LT. + IF ( ABS(pres-pgcm(i,ilev) ) .GT. & + ABS(pres-pgcm(i,1)) ) THEN + lt(i) = ilev ! 2 + lb(i) = ilev-1 ! 1 + ELSE + lt(i) = 2 + lb(i) = 1 + ENDIF + !IM PRINT*,'i, ABS(pres-pgcm),ABS(pres-pgcm)', + !IM .i, ABS(pres-pgcm(i,ilev)),ABS(pres-pgcm(i,1)) + END DO + DO k = 1, ilev-1 + DO i = 1, ilon + pbot = pgcm(i,k) + ptop = pgcm(i,k+1) + !IM IF (ptop.LE.pres .AND. pbot.GE.pres) THEN + IF (ptop.GE.pres .AND. pbot.LE.pres) THEN + lt(i) = k+1 + lb(i) = k + ENDIF + END DO + END DO + ! + ! Interpolation lineaire: + ! + DO i = 1, ilon + ! interpolation en logarithme de pression: + ! + ! ... Modif . P. Le Van ( 20/01/98) .... + ! Modif Fr�d�ric Hourdin (3/01/02) + + IF(pgcm(i,lb(i)).EQ.0.OR. & + pgcm(i,lt(i)).EQ.0.) THEN + ! + PRINT*,'i,lb,lt,2pgcm,pres',i,lb(i), & + lt(i),pgcm(i,lb(i)),pgcm(i,lt(i)),pres + ! + ENDIF + ! + aist(i) = LOG( pgcm(i,lb(i))/ pres ) & + / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i)) ) + aisb(i) = LOG( pres / pgcm(i,lt(i)) ) & + / LOG( pgcm(i,lb(i))/ pgcm(i,lt(i))) + enddo + + + endif ! lnew + + !====================================================================== + ! inteprollation + !====================================================================== + + do i=1,ilon + Qpres(i)= Qgcm(i,lb(i))*aisb(i)+Qgcm(i,lt(i))*aist(i) + !IM PRINT*,'i,Qgcm,Qpres',i,Qgcm(i,lb(i)),aisb(i), + !IM $ Qgcm(i,lt(i)),aist(i),Qpres(i) + enddo + ! + ! Je mets les vents a zero quand je rencontre une montagne + do i = 1, ilon + !IM if (pgcm(i,1).LT.pres) THEN + if (pgcm(i,1).GT.pres) THEN + ! Qpres(i)=1e33 + Qpres(i)=1e+20 + !IM PRINT*,'i,pgcm(i,1),pres =',i,pgcm(i,1),pres + endif + enddo + + ! + RETURN +END SUBROUTINE tetaleveli1j1 Index: DZ6/trunk/libf/dyn3d/top_bound.F90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/top_bound.F90 (revision 5311) +++ (revision ) @@ -1,201 +1,0 @@ -! -! $Id$ -! -SUBROUTINE top_bound(vcov,ucov,teta,masse,dt) - - USE iniprint_mod_h -USE comgeom2_mod_h - USE comdissipn_mod_h -USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound, & - tau_top_bound - USE comvert_mod, ONLY: presnivs, preff, scaleheight - - USE dimensions_mod, ONLY: iim, jjm, llm, ndm -USE paramet_mod_h -IMPLICIT NONE - ! - - - - - ! .. DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO, - ! F. LOTT DEC. 2006 - ! ( 10/12/06 ) - - !======================================================================= - ! - ! Auteur: F. LOTT - ! ------- - ! - ! Objet: - ! ------ - ! - ! Dissipation lin�aire (ex top_bound de la physique) - ! - !======================================================================= - - ! top_bound sponge layer model: - ! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t) - ! where Am is the zonal average of the field (or zero), and lambda the inverse - ! of the characteristic quenching/relaxation time scale - ! Thus, assuming Am to be time-independent, field at time t+dt is given by: - ! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t)) - ! Moreover lambda can be a function of model level (see below), and relaxation - ! can be toward the average zonal field or just zero (see below). - - ! NB: top_bound sponge is only called from leapfrog if ok_strato=.true. - - ! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod) - ! iflag_top_bound=0 for no sponge - ! iflag_top_bound=1 for sponge over 4 topmost layers - ! iflag_top_bound=2 for sponge from top to ~1% of top layer pressure - ! mode_top_bound=0: no relaxation - ! mode_top_bound=1: u and v relax towards 0 - ! mode_top_bound=2: u and v relax towards their zonal mean - ! mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean - ! tau_top_bound : inverse of charactericstic relaxation time scale at - ! the topmost layer (Hz) - - - - ! Arguments: - ! ---------- - - real,intent(inout) :: ucov(iip1,jjp1,llm) ! covariant zonal wind - real,intent(inout) :: vcov(iip1,jjm,llm) ! covariant meridional wind - real,intent(inout) :: teta(iip1,jjp1,llm) ! potential temperature - real,intent(in) :: masse(iip1,jjp1,llm) ! mass of atmosphere - real,intent(in) :: dt ! time step (s) of sponge model - - ! Local: - ! ------ - - REAL :: massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm - REAL :: uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm) - - integer :: i - REAL,SAVE :: rdamp(llm) ! quenching coefficient - real,save :: lambda(llm) ! inverse or quenching time scale (Hz) - - LOGICAL,SAVE :: first=.true. - - INTEGER :: j,l - - if (iflag_top_bound.eq.0) return - - if (first) then - if (iflag_top_bound.eq.1) then - ! sponge quenching over the topmost 4 atmospheric layers - lambda(:)=0. - lambda(llm)=tau_top_bound - lambda(llm-1)=tau_top_bound/2. - lambda(llm-2)=tau_top_bound/4. - lambda(llm-3)=tau_top_bound/8. - else if (iflag_top_bound.eq.2) then - ! sponge quenching over topmost layers down to pressures which are - ! higher than 100 times the topmost layer pressure - lambda(:)=tau_top_bound & - *max(presnivs(llm)/presnivs(:)-0.01,0.) - endif - - ! quenching coefficient rdamp(:) - ! rdamp(:)=dt*lambda(:) ! Explicit Euler approx. - rdamp(:)=1.-exp(-lambda(:)*dt) - - write(lunout,*)'TOP_BOUND mode',mode_top_bound - write(lunout,*)'Sponge layer coefficients' - write(lunout,*)'p (Pa) z(km) tau(s) 1./tau (Hz)' - do l=1,llm - if (rdamp(l).ne.0.) then - write(lunout,'(6(1pe12.4,1x))') & - presnivs(l),log(preff/presnivs(l))*scaleheight, & - 1./lambda(l),lambda(l) - endif - enddo - first=.false. - endif ! of if (first) - - CALL massbar(masse,massebx,masseby) - - ! ! compute zonal average of vcov and u - if (mode_top_bound.ge.2) then - do l=1,llm - do j=1,jjm - vzon(j,l)=0. - zm=0. - do i=1,iim - ! NB: we can work using vcov zonal mean rather than v since the - ! cv coefficient (which relates the two) only varies with latitudes - vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l) - zm=zm+masseby(i,j,l) - enddo - vzon(j,l)=vzon(j,l)/zm - enddo - enddo - - do l=1,llm - do j=2,jjm ! excluding poles - uzon(j,l)=0. - zm=0. - do i=1,iim - uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j) - zm=zm+massebx(i,j,l) - enddo - uzon(j,l)=uzon(j,l)/zm - enddo - enddo - else ! ucov and vcov will relax towards 0 - vzon(:,:)=0. - uzon(:,:)=0. - endif ! of if (mode_top_bound.ge.2) - - ! ! compute zonal average of potential temperature, if necessary - if (mode_top_bound.ge.3) then - do l=1,llm - do j=2,jjm ! excluding poles - zm=0. - tzon(j,l)=0. - do i=1,iim - tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l) - zm=zm+masse(i,j,l) - enddo - tzon(j,l)=tzon(j,l)/zm - enddo - enddo - endif ! of if (mode_top_bound.ge.3) - - if (mode_top_bound.ge.1) then - ! ! Apply sponge quenching on vcov: - do l=1,llm - do i=1,iip1 - do j=1,jjm - vcov(i,j,l)=vcov(i,j,l) & - -rdamp(l)*(vcov(i,j,l)-vzon(j,l)) - enddo - enddo - enddo - - ! ! Apply sponge quenching on ucov: - do l=1,llm - do i=1,iip1 - do j=2,jjm ! excluding poles - ucov(i,j,l)=ucov(i,j,l) & - -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l)) - enddo - enddo - enddo - endif ! of if (mode_top_bound.ge.1) - - if (mode_top_bound.ge.3) then - ! ! Apply sponge quenching on teta: - do l=1,llm - do i=1,iip1 - do j=2,jjm ! excluding poles - teta(i,j,l)=teta(i,j,l) & - -rdamp(l)*(teta(i,j,l)-tzon(j,l)) - enddo - enddo - enddo - endif ! of if (mode_top_bound.ge.3) - -END SUBROUTINE top_bound Index: /LMDZ6/trunk/libf/dyn3d/top_bound.f90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/top_bound.f90 (revision 5312) +++ /LMDZ6/trunk/libf/dyn3d/top_bound.f90 (revision 5312) @@ -0,0 +1,201 @@ +! +! $Id$ +! +SUBROUTINE top_bound(vcov,ucov,teta,masse,dt) + + USE iniprint_mod_h +USE comgeom2_mod_h + USE comdissipn_mod_h +USE comconst_mod, ONLY: iflag_top_bound, mode_top_bound, & + tau_top_bound + USE comvert_mod, ONLY: presnivs, preff, scaleheight + + USE dimensions_mod, ONLY: iim, jjm, llm, ndm +USE paramet_mod_h +IMPLICIT NONE + ! + + + + + ! .. DISSIPATION LINEAIRE A HAUT NIVEAU, RUN MESO, + ! F. LOTT DEC. 2006 + ! ( 10/12/06 ) + + !======================================================================= + ! + ! Auteur: F. LOTT + ! ------- + ! + ! Objet: + ! ------ + ! + ! Dissipation lin�aire (ex top_bound de la physique) + ! + !======================================================================= + + ! top_bound sponge layer model: + ! Quenching is modeled as: A(t)=Am+A0*exp(-lambda*t) + ! where Am is the zonal average of the field (or zero), and lambda the inverse + ! of the characteristic quenching/relaxation time scale + ! Thus, assuming Am to be time-independent, field at time t+dt is given by: + ! A(t+dt)=A(t)-(A(t)-Am)*(1-exp(-lambda*t)) + ! Moreover lambda can be a function of model level (see below), and relaxation + ! can be toward the average zonal field or just zero (see below). + + ! NB: top_bound sponge is only called from leapfrog if ok_strato=.true. + + ! sponge parameters: (loaded/set in conf_gcm.F ; stored in comconst_mod) + ! iflag_top_bound=0 for no sponge + ! iflag_top_bound=1 for sponge over 4 topmost layers + ! iflag_top_bound=2 for sponge from top to ~1% of top layer pressure + ! mode_top_bound=0: no relaxation + ! mode_top_bound=1: u and v relax towards 0 + ! mode_top_bound=2: u and v relax towards their zonal mean + ! mode_top_bound=3: u,v and pot. temp. relax towards their zonal mean + ! tau_top_bound : inverse of charactericstic relaxation time scale at + ! the topmost layer (Hz) + + + + ! Arguments: + ! ---------- + + real,intent(inout) :: ucov(iip1,jjp1,llm) ! covariant zonal wind + real,intent(inout) :: vcov(iip1,jjm,llm) ! covariant meridional wind + real,intent(inout) :: teta(iip1,jjp1,llm) ! potential temperature + real,intent(in) :: masse(iip1,jjp1,llm) ! mass of atmosphere + real,intent(in) :: dt ! time step (s) of sponge model + + ! Local: + ! ------ + + REAL :: massebx(iip1,jjp1,llm),masseby(iip1,jjm,llm),zm + REAL :: uzon(jjp1,llm),vzon(jjm,llm),tzon(jjp1,llm) + + integer :: i + REAL,SAVE :: rdamp(llm) ! quenching coefficient + real,save :: lambda(llm) ! inverse or quenching time scale (Hz) + + LOGICAL,SAVE :: first=.true. + + INTEGER :: j,l + + if (iflag_top_bound.eq.0) return + + if (first) then + if (iflag_top_bound.eq.1) then + ! sponge quenching over the topmost 4 atmospheric layers + lambda(:)=0. + lambda(llm)=tau_top_bound + lambda(llm-1)=tau_top_bound/2. + lambda(llm-2)=tau_top_bound/4. + lambda(llm-3)=tau_top_bound/8. + else if (iflag_top_bound.eq.2) then + ! sponge quenching over topmost layers down to pressures which are + ! higher than 100 times the topmost layer pressure + lambda(:)=tau_top_bound & + *max(presnivs(llm)/presnivs(:)-0.01,0.) + endif + + ! quenching coefficient rdamp(:) + ! rdamp(:)=dt*lambda(:) ! Explicit Euler approx. + rdamp(:)=1.-exp(-lambda(:)*dt) + + write(lunout,*)'TOP_BOUND mode',mode_top_bound + write(lunout,*)'Sponge layer coefficients' + write(lunout,*)'p (Pa) z(km) tau(s) 1./tau (Hz)' + do l=1,llm + if (rdamp(l).ne.0.) then + write(lunout,'(6(1pe12.4,1x))') & + presnivs(l),log(preff/presnivs(l))*scaleheight, & + 1./lambda(l),lambda(l) + endif + enddo + first=.false. + endif ! of if (first) + + CALL massbar(masse,massebx,masseby) + + ! ! compute zonal average of vcov and u + if (mode_top_bound.ge.2) then + do l=1,llm + do j=1,jjm + vzon(j,l)=0. + zm=0. + do i=1,iim + ! NB: we can work using vcov zonal mean rather than v since the + ! cv coefficient (which relates the two) only varies with latitudes + vzon(j,l)=vzon(j,l)+vcov(i,j,l)*masseby(i,j,l) + zm=zm+masseby(i,j,l) + enddo + vzon(j,l)=vzon(j,l)/zm + enddo + enddo + + do l=1,llm + do j=2,jjm ! excluding poles + uzon(j,l)=0. + zm=0. + do i=1,iim + uzon(j,l)=uzon(j,l)+massebx(i,j,l)*ucov(i,j,l)/cu(i,j) + zm=zm+massebx(i,j,l) + enddo + uzon(j,l)=uzon(j,l)/zm + enddo + enddo + else ! ucov and vcov will relax towards 0 + vzon(:,:)=0. + uzon(:,:)=0. + endif ! of if (mode_top_bound.ge.2) + + ! ! compute zonal average of potential temperature, if necessary + if (mode_top_bound.ge.3) then + do l=1,llm + do j=2,jjm ! excluding poles + zm=0. + tzon(j,l)=0. + do i=1,iim + tzon(j,l)=tzon(j,l)+teta(i,j,l)*masse(i,j,l) + zm=zm+masse(i,j,l) + enddo + tzon(j,l)=tzon(j,l)/zm + enddo + enddo + endif ! of if (mode_top_bound.ge.3) + + if (mode_top_bound.ge.1) then + ! ! Apply sponge quenching on vcov: + do l=1,llm + do i=1,iip1 + do j=1,jjm + vcov(i,j,l)=vcov(i,j,l) & + -rdamp(l)*(vcov(i,j,l)-vzon(j,l)) + enddo + enddo + enddo + + ! ! Apply sponge quenching on ucov: + do l=1,llm + do i=1,iip1 + do j=2,jjm ! excluding poles + ucov(i,j,l)=ucov(i,j,l) & + -rdamp(l)*(ucov(i,j,l)-cu(i,j)*uzon(j,l)) + enddo + enddo + enddo + endif ! of if (mode_top_bound.ge.1) + + if (mode_top_bound.ge.3) then + ! ! Apply sponge quenching on teta: + do l=1,llm + do i=1,iip1 + do j=2,jjm ! excluding poles + teta(i,j,l)=teta(i,j,l) & + -rdamp(l)*(teta(i,j,l)-tzon(j,l)) + enddo + enddo + enddo + endif ! of if (mode_top_bound.ge.3) + +END SUBROUTINE top_bound Index: DZ6/trunk/libf/dyn3d/wrgrads.F90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/wrgrads.F90 (revision 5311) +++ (revision ) @@ -1,131 +1,0 @@ -! -! $Header$ -! -subroutine wrgrads(if,nl,field,name,titlevar) - USE gradsdef_mod_h - implicit none - - ! Declarations - ! if indice du fichier - ! nl nombre de couches - ! field champ - ! name petit nom - ! titlevar Titre - - ! arguments - integer :: if,nl - real :: field(imx*jmx*lmx) - - integer, parameter:: wp = selected_real_kind(p=6, r=36) - real(wp) field4(imx*jmx*lmx) - - character(len=10) :: name,file - character(len=10) :: titlevar - - ! local - - integer :: im,jm,lm,i,j,l,iv,iii,iji,iif,ijf - - logical :: writectl - - - writectl=.false. - - ! print*,if,iid(if),jid(if),ifd(if),jfd(if) - iii=iid(if) - iji=jid(if) - iif=ifd(if) - ijf=jfd(if) - im=iif-iii+1 - jm=ijf-iji+1 - lm=lmd(if) - - ! print*,'im,jm,lm,name,firsttime(if)' - ! print*,im,jm,lm,name,firsttime(if) - - if(firsttime(if)) then - if(name.eq.var(1,if)) then - firsttime(if)=.false. - ivar(if)=1 - print*,'fin de l initialiation de l ecriture du fichier' - print*,file - print*,'fichier no: ',if - print*,'unit ',unit(if) - print*,'nvar ',nvar(if) - print*,'vars ',(var(iv,if),iv=1,nvar(if)) - else - ivar(if)=ivar(if)+1 - nvar(if)=ivar(if) - var(ivar(if),if)=name - tvar(ivar(if),if)=trim(titlevar) - nld(ivar(if),if)=nl - ! print*,'initialisation ecriture de ',var(ivar(if),if) - ! print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if) - endif - writectl=.true. - itime(if)=1 - else - ivar(if)=mod(ivar(if),nvar(if))+1 - if (ivar(if).eq.nvar(if)) then - writectl=.true. - itime(if)=itime(if)+1 - endif - - if(var(ivar(if),if).ne.name) then - print*,'Il faut stoker la meme succession de champs a chaque' - print*,'pas de temps' - print*,'fichier no: ',if - print*,'unit ',unit(if) - print*,'nvar ',nvar(if) - print*,'vars ',(var(iv,if),iv=1,nvar(if)) - CALL abort_gcm("wrgrads","problem",1) - endif - endif - - ! print*,'ivar(if),nvar(if),var(ivar(if),if),writectl' - ! print*,ivar(if),nvar(if),var(ivar(if),if),writectl - field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl) - do l=1,nl - irec(if)=irec(if)+1 - ! print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf, - ! s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii - ! s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif - write(unit(if)+1,rec=irec(if)) & - ((field4((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) & - ,i=iii,iif),j=iji,ijf) - enddo - if (writectl) then - - file=fichier(if) - ! WARNING! on reecrase le fichier .ctl a chaque ecriture - open(unit(if),file=trim(file)//'.ctl' & - ,form='formatted',status='unknown') - write(unit(if),'(a5,1x,a40)') & - 'DSET ','^'//trim(file)//'.dat' - - write(unit(if),'(a12)') 'UNDEF 1.0E30' - write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if) - call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF') - call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF') - call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF') - write(unit(if),'(a4,i10,a30)') & - 'TDEF ',itime(if),' LINEAR 02JAN1987 1MO ' - write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if) - do iv=1,nvar(if) - ! print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)' - ! print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if) - write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if) & - ,99,tvar(iv,if) - enddo - write(unit(if),'(a7)') 'ENDVARS' - ! -1000 format(a5,3x,i4,i3,1x,a39) - - close(unit(if)) - - endif ! writectl - - return - -END SUBROUTINE wrgrads - Index: /LMDZ6/trunk/libf/dyn3d/wrgrads.f90 =================================================================== --- /LMDZ6/trunk/libf/dyn3d/wrgrads.f90 (revision 5312) +++ /LMDZ6/trunk/libf/dyn3d/wrgrads.f90 (revision 5312) @@ -0,0 +1,131 @@ +! +! $Header$ +! +subroutine wrgrads(if,nl,field,name,titlevar) + USE gradsdef_mod_h + implicit none + + ! Declarations + ! if indice du fichier + ! nl nombre de couches + ! field champ + ! name petit nom + ! titlevar Titre + + ! arguments + integer :: if,nl + real :: field(imx*jmx*lmx) + + integer, parameter:: wp = selected_real_kind(p=6, r=36) + real(wp) field4(imx*jmx*lmx) + + character(len=10) :: name,file + character(len=10) :: titlevar + + ! local + + integer :: im,jm,lm,i,j,l,iv,iii,iji,iif,ijf + + logical :: writectl + + + writectl=.false. + + ! print*,if,iid(if),jid(if),ifd(if),jfd(if) + iii=iid(if) + iji=jid(if) + iif=ifd(if) + ijf=jfd(if) + im=iif-iii+1 + jm=ijf-iji+1 + lm=lmd(if) + + ! print*,'im,jm,lm,name,firsttime(if)' + ! print*,im,jm,lm,name,firsttime(if) + + if(firsttime(if)) then + if(name.eq.var(1,if)) then + firsttime(if)=.false. + ivar(if)=1 + print*,'fin de l initialiation de l ecriture du fichier' + print*,file + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + else + ivar(if)=ivar(if)+1 + nvar(if)=ivar(if) + var(ivar(if),if)=name + tvar(ivar(if),if)=trim(titlevar) + nld(ivar(if),if)=nl + ! print*,'initialisation ecriture de ',var(ivar(if),if) + ! print*,'if ivar(if) nld ',if,ivar(if),nld(ivar(if),if) + endif + writectl=.true. + itime(if)=1 + else + ivar(if)=mod(ivar(if),nvar(if))+1 + if (ivar(if).eq.nvar(if)) then + writectl=.true. + itime(if)=itime(if)+1 + endif + + if(var(ivar(if),if).ne.name) then + print*,'Il faut stoker la meme succession de champs a chaque' + print*,'pas de temps' + print*,'fichier no: ',if + print*,'unit ',unit(if) + print*,'nvar ',nvar(if) + print*,'vars ',(var(iv,if),iv=1,nvar(if)) + CALL abort_gcm("wrgrads","problem",1) + endif + endif + + ! print*,'ivar(if),nvar(if),var(ivar(if),if),writectl' + ! print*,ivar(if),nvar(if),var(ivar(if),if),writectl + field4(1:imd(if)*jmd(if)*nl)=field(1:imd(if)*jmd(if)*nl) + do l=1,nl + irec(if)=irec(if)+1 + ! print*,'Ecrit rec=',irec(if),iii,iif,iji,ijf, + ! s (l-1)*imd(if)*jmd(if)+(iji-1)*imd(if)+iii + ! s ,(l-1)*imd(if)*jmd(if)+(ijf-1)*imd(if)+iif + write(unit(if)+1,rec=irec(if)) & + ((field4((l-1)*imd(if)*jmd(if)+(j-1)*imd(if)+i) & + ,i=iii,iif),j=iji,ijf) + enddo + if (writectl) then + + file=fichier(if) + ! WARNING! on reecrase le fichier .ctl a chaque ecriture + open(unit(if),file=trim(file)//'.ctl' & + ,form='formatted',status='unknown') + write(unit(if),'(a5,1x,a40)') & + 'DSET ','^'//trim(file)//'.dat' + + write(unit(if),'(a12)') 'UNDEF 1.0E30' + write(unit(if),'(a5,1x,a40)') 'TITLE ',title(if) + call formcoord(unit(if),im,xd(iii,if),1.,.false.,'XDEF') + call formcoord(unit(if),jm,yd(iji,if),1.,.true.,'YDEF') + call formcoord(unit(if),lm,zd(1,if),1.,.false.,'ZDEF') + write(unit(if),'(a4,i10,a30)') & + 'TDEF ',itime(if),' LINEAR 02JAN1987 1MO ' + write(unit(if),'(a4,2x,i5)') 'VARS',nvar(if) + do iv=1,nvar(if) + ! print*,'if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if)' + ! print*,if,var(iv,if),nld(iv,if),nld(iv,if)-1/nld(iv,if) + write(unit(if),1000) var(iv,if),nld(iv,if)-1/nld(iv,if) & + ,99,tvar(iv,if) + enddo + write(unit(if),'(a7)') 'ENDVARS' + ! +1000 format(a5,3x,i4,i3,1x,a39) + + close(unit(if)) + + endif ! writectl + + return + +END SUBROUTINE wrgrads + Index: DZ6/trunk/libf/obsolete/regr1_conserv_m.F90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr1_conserv_m.F90 (revision 5311) +++ (revision ) @@ -1,358 +1,0 @@ -module regr1_conserv_m - - ! Author: Lionel GUEZ - - use assert_eq_m, only: assert_eq - use assert_m, only: assert - use interpolation, only: locate - - implicit none - - interface regr1_conserv - - ! This generic procedure regrids a piecewise linear function (not - ! necessarily continuous) by averaging it. This is a conservative - ! regridding. The regridding operation is done on the first - ! dimension of the input array. Input are positions of cell - ! edges. The target grid should be included in the source grid: - ! no extrapolation is allowed. - - ! The only difference between the procedures is the rank of the - ! first argument. - - ! real, intent(in), rank >= 1:: vs ! (ns, ...) - ! averages of cells of the source grid - ! vs(is, ...) for [xs(is), xs(is + 1)] - - ! real, intent(in):: xs(:) ! (ns + 1) - ! edges of cells of the source grid, in strictly ascending order - - ! real, intent(in):: xt(:) ! (nt + 1) - ! edges of cells of the target grid, in strictly ascending order - - ! real, intent(in), optional, rank >= 1:: slope ! (ns, ...) - ! same rank as vs - ! slopes inside cells of the source grid - ! slope(is, ...) for [xs(is), xs(is + 1)] - ! If not present, slopes are taken equal to 0. The regridding is - ! then first order. - - ! real, intent(out), rank >= 1:: vt(nt, ...) - ! has the same rank as vs and slope - ! averages of cells of the target grid - ! vt(it, ...) for [xt(it), xt(it + 1)] - - ! ns and nt must be >= 1. - - ! See notes for explanations on the algorithm and justification - ! of algorithmic choices. - - module procedure regr11_conserv, regr12_conserv, regr13_conserv, & - regr14_conserv - end interface regr1_conserv - - private - public regr1_conserv - -contains - - subroutine regr11_conserv(vs, xs, xt, vt, slope) - - ! vs and slope have rank 1. - - real, intent(in):: vs(:) - real, intent(in):: xs(:) - real, intent(in):: xt(:) - real, intent(out):: vt(:) - real, intent(in), optional:: slope(:) - - ! Local: - integer is, it, ns, nt - logical slope_present - - !--------------------------------------------- - - ns = assert_eq(size(vs), size(xs) - 1, "regr11_conserv ns") - nt = assert_eq(size(xt) - 1, size(vt), "regr11_conserv nt") - - ! Quick check on sort order: - call assert(xs(1) < xs(2), "regr11_conserv xs bad order") - call assert(xt(1) < xt(2), "regr11_conserv xt bad order") - - call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & - "regr11_conserv extrapolation") - slope_present = present(slope) - - is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation - do it = 1, nt - ! 1 <= is <= ns - ! xs(is) <= xt(it) < xs(is + 1) - if (xt(it + 1) <= xs(is + 1)) then - vt(it) = mean_lin(xt(it), xt(it + 1)) - else - vt(it) = mean_lin(xt(it), xs(is + 1)) * (xs(is + 1) - xt(it)) - is = is + 1 - do while (xs(is + 1) < xt(it + 1)) - ! 1 <= is <= ns - 1 - vt(it) = vt(it) + (xs(is + 1) - xs(is)) * vs(is) - is = is + 1 - end do - ! 1 <= is <= ns - vt(it) = (vt(it) + mean_lin(xs(is), xt(it + 1)) * (xt(it + 1) & - - xs(is))) / (xt(it + 1) - xt(it)) - end if - - if (xs(is + 1) == xt(it + 1)) is = is + 1 - ! 1 <= is <= ns .or. it == nt - end do - - contains - - real function mean_lin(a, b) - - ! mean in [a, b] of the linear function in [xs(is), xs(is + 1)] - - real, intent(in):: a, b - - !--------------------------------------------- - - if (slope_present) then - mean_lin = slope(is) / 2. * (a + b - xs(is) - xs(is + 1)) + vs(is) - else - mean_lin = vs(is) - end if - - end function mean_lin - - end subroutine regr11_conserv - - !******************************************** - - subroutine regr12_conserv(vs, xs, xt, vt, slope) - - ! vs and slope have rank 2. - - real, intent(in):: vs(:, :) - real, intent(in):: xs(:) - real, intent(in):: xt(:) - real, intent(out):: vt(:, :) - real, intent(in), optional:: slope(:, :) - - ! Local: - integer is, it, ns, nt, n2 - logical slope_present - - !--------------------------------------------- - - ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_conserv ns") - nt = assert_eq(size(xt) - 1, size(vt, 1), "regr12_conserv nt") - n2 = assert_eq(size(vs, 2), size(vt, 2), "regr12_conserv n2") - - ! Quick check on sort order: - call assert(xs(1) < xs(2), "regr12_conserv xs bad order") - call assert(xt(1) < xt(2), "regr12_conserv xt bad order") - - call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & - "regr12_conserv extrapolation") - slope_present = present(slope) - - is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation - do it = 1, nt - ! 1 <= is <= ns - ! xs(is) <= xt(it) < xs(is + 1) - if (xt(it + 1) <= xs(is + 1)) then - vt(it, :) = mean_lin(xt(it), xt(it + 1)) - else - vt(it, :) = mean_lin(xt(it), xs(is + 1)) * (xs(is + 1) - xt(it)) - is = is + 1 - do while (xs(is + 1) < xt(it + 1)) - ! 1 <= is <= ns - 1 - vt(it, :) = vt(it, :) + (xs(is + 1) - xs(is)) * vs(is, :) - is = is + 1 - end do - ! 1 <= is <= ns - vt(it, :) = (vt(it, :) + mean_lin(xs(is), xt(it + 1)) * (xt(it + 1) & - - xs(is))) / (xt(it + 1) - xt(it)) - end if - - if (xs(is + 1) == xt(it + 1)) is = is + 1 - ! 1 <= is <= ns .or. it == nt - end do - - contains - - function mean_lin(a, b) - - ! mean in [a, b] of the linear function in [xs(is), xs(is + 1)] - - real, intent(in):: a, b - real mean_lin(n2) - - !--------------------------------------------- - - if (slope_present) then - mean_lin = slope(is, :) / 2. * (a + b - xs(is) - xs(is + 1)) & - + vs(is, :) - else - mean_lin = vs(is, :) - end if - - end function mean_lin - - end subroutine regr12_conserv - - !******************************************** - - subroutine regr13_conserv(vs, xs, xt, vt, slope) - - ! vs and slope have rank 3. - - real, intent(in):: vs(:, :, :) - real, intent(in):: xs(:) - real, intent(in):: xt(:) - real, intent(out):: vt(:, :, :) - real, intent(in), optional:: slope(:, :, :) - - ! Local: - integer is, it, ns, nt, n2, n3 - logical slope_present - - !--------------------------------------------- - - ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_conserv ns") - nt = assert_eq(size(xt) - 1, size(vt, 1), "regr13_conserv nt") - n2 = assert_eq(size(vs, 2), size(vt, 2), "regr13_conserv n2") - n3 = assert_eq(size(vs, 3), size(vt, 3), "regr13_conserv n3") - - ! Quick check on sort order: - call assert(xs(1) < xs(2), "regr13_conserv xs bad order") - call assert(xt(1) < xt(2), "regr13_conserv xt bad order") - - call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & - "regr13_conserv extrapolation") - slope_present = present(slope) - - is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation - do it = 1, nt - ! 1 <= is <= ns - ! xs(is) <= xt(it) < xs(is + 1) - if (xt(it + 1) <= xs(is + 1)) then - vt(it, :, :) = mean_lin(xt(it), xt(it + 1)) - else - vt(it, :, :) = mean_lin(xt(it), xs(is + 1)) * (xs(is + 1) - xt(it)) - is = is + 1 - do while (xs(is + 1) < xt(it + 1)) - ! 1 <= is <= ns - 1 - vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - xs(is)) * vs(is, :, :) - is = is + 1 - end do - ! 1 <= is <= ns - vt(it, :, :) = (vt(it, :, :) + mean_lin(xs(is), xt(it + 1)) & - * (xt(it + 1) - xs(is))) / (xt(it + 1) - xt(it)) - end if - - if (xs(is + 1) == xt(it + 1)) is = is + 1 - ! 1 <= is <= ns .or. it == nt - end do - - contains - - function mean_lin(a, b) - - ! mean in [a, b] of the linear function in [xs(is), xs(is + 1)] - - real, intent(in):: a, b - real mean_lin(n2, n3) - - !--------------------------------------------- - - if (slope_present) then - mean_lin = slope(is, :, :) / 2. * (a + b - xs(is) - xs(is + 1)) & - + vs(is, :, :) - else - mean_lin = vs(is, :, :) - end if - - end function mean_lin - - end subroutine regr13_conserv - - !******************************************** - - subroutine regr14_conserv(vs, xs, xt, vt, slope) - - ! vs and slope have rank 4. - - real, intent(in):: vs(:, :, :, :) - real, intent(in):: xs(:) - real, intent(in):: xt(:) - real, intent(out):: vt(:, :, :, :) - real, intent(in), optional:: slope(:, :, :, :) - - ! Local: - integer is, it, ns, nt, n2, n3, n4 - logical slope_present - - !--------------------------------------------- - - ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_conserv ns") - nt = assert_eq(size(xt) - 1, size(vt, 1), "regr14_conserv nt") - n2 = assert_eq(size(vs, 2), size(vt, 2), "regr14_conserv n2") - n3 = assert_eq(size(vs, 3), size(vt, 3), "regr14_conserv n3") - n4 = assert_eq(size(vs, 4), size(vt, 4), "regr14_conserv n4") - - ! Quick check on sort order: - call assert(xs(1) < xs(2), "regr14_conserv xs bad order") - call assert(xt(1) < xt(2), "regr14_conserv xt bad order") - - call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & - "regr14_conserv extrapolation") - slope_present = present(slope) - - is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation - do it = 1, nt - ! 1 <= is <= ns - ! xs(is) <= xt(it) < xs(is + 1) - if (xt(it + 1) <= xs(is + 1)) then - vt(it, :, :, :) = mean_lin(xt(it), xt(it + 1)) - else - vt(it, :, :, :) = mean_lin(xt(it), xs(is + 1)) * (xs(is + 1) - xt(it)) - is = is + 1 - do while (xs(is + 1) < xt(it + 1)) - ! 1 <= is <= ns - 1 - vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - xs(is)) & - * vs(is, :, :, :) - is = is + 1 - end do - ! 1 <= is <= ns - vt(it, :, :, :) = (vt(it, :, :, :) + mean_lin(xs(is), xt(it + 1)) & - * (xt(it + 1) - xs(is))) / (xt(it + 1) - xt(it)) - end if - - if (xs(is + 1) == xt(it + 1)) is = is + 1 - ! 1 <= is <= ns .or. it == nt - end do - - contains - - function mean_lin(a, b) - - ! mean in [a, b] of the linear function in [xs(is), xs(is + 1)] - - real, intent(in):: a, b - real mean_lin(n2, n3, n4) - - !--------------------------------------------- - - if (slope_present) then - mean_lin = slope(is, :, :, :) / 2. * (a + b - xs(is) - xs(is + 1)) & - + vs(is, :, :, :) - else - mean_lin = vs(is, :, :, :) - end if - - end function mean_lin - - end subroutine regr14_conserv - -end module regr1_conserv_m Index: /LMDZ6/trunk/libf/obsolete/regr1_conserv_m.f90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr1_conserv_m.f90 (revision 5312) +++ /LMDZ6/trunk/libf/obsolete/regr1_conserv_m.f90 (revision 5312) @@ -0,0 +1,358 @@ +module regr1_conserv_m + + ! Author: Lionel GUEZ + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + implicit none + + interface regr1_conserv + + ! This generic procedure regrids a piecewise linear function (not + ! necessarily continuous) by averaging it. This is a conservative + ! regridding. The regridding operation is done on the first + ! dimension of the input array. Input are positions of cell + ! edges. The target grid should be included in the source grid: + ! no extrapolation is allowed. + + ! The only difference between the procedures is the rank of the + ! first argument. + + ! real, intent(in), rank >= 1:: vs ! (ns, ...) + ! averages of cells of the source grid + ! vs(is, ...) for [xs(is), xs(is + 1)] + + ! real, intent(in):: xs(:) ! (ns + 1) + ! edges of cells of the source grid, in strictly ascending order + + ! real, intent(in):: xt(:) ! (nt + 1) + ! edges of cells of the target grid, in strictly ascending order + + ! real, intent(in), optional, rank >= 1:: slope ! (ns, ...) + ! same rank as vs + ! slopes inside cells of the source grid + ! slope(is, ...) for [xs(is), xs(is + 1)] + ! If not present, slopes are taken equal to 0. The regridding is + ! then first order. + + ! real, intent(out), rank >= 1:: vt(nt, ...) + ! has the same rank as vs and slope + ! averages of cells of the target grid + ! vt(it, ...) for [xt(it), xt(it + 1)] + + ! ns and nt must be >= 1. + + ! See notes for explanations on the algorithm and justification + ! of algorithmic choices. + + module procedure regr11_conserv, regr12_conserv, regr13_conserv, & + regr14_conserv + end interface regr1_conserv + + private + public regr1_conserv + +contains + + subroutine regr11_conserv(vs, xs, xt, vt, slope) + + ! vs and slope have rank 1. + + real, intent(in):: vs(:) + real, intent(in):: xs(:) + real, intent(in):: xt(:) + real, intent(out):: vt(:) + real, intent(in), optional:: slope(:) + + ! Local: + integer is, it, ns, nt + logical slope_present + + !--------------------------------------------- + + ns = assert_eq(size(vs), size(xs) - 1, "regr11_conserv ns") + nt = assert_eq(size(xt) - 1, size(vt), "regr11_conserv nt") + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr11_conserv xs bad order") + call assert(xt(1) < xt(2), "regr11_conserv xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr11_conserv extrapolation") + slope_present = present(slope) + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + if (xt(it + 1) <= xs(is + 1)) then + vt(it) = mean_lin(xt(it), xt(it + 1)) + else + vt(it) = mean_lin(xt(it), xs(is + 1)) * (xs(is + 1) - xt(it)) + is = is + 1 + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it) = vt(it) + (xs(is + 1) - xs(is)) * vs(is) + is = is + 1 + end do + ! 1 <= is <= ns + vt(it) = (vt(it) + mean_lin(xs(is), xt(it + 1)) * (xt(it + 1) & + - xs(is))) / (xt(it + 1) - xt(it)) + end if + + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + contains + + real function mean_lin(a, b) + + ! mean in [a, b] of the linear function in [xs(is), xs(is + 1)] + + real, intent(in):: a, b + + !--------------------------------------------- + + if (slope_present) then + mean_lin = slope(is) / 2. * (a + b - xs(is) - xs(is + 1)) + vs(is) + else + mean_lin = vs(is) + end if + + end function mean_lin + + end subroutine regr11_conserv + + !******************************************** + + subroutine regr12_conserv(vs, xs, xt, vt, slope) + + ! vs and slope have rank 2. + + real, intent(in):: vs(:, :) + real, intent(in):: xs(:) + real, intent(in):: xt(:) + real, intent(out):: vt(:, :) + real, intent(in), optional:: slope(:, :) + + ! Local: + integer is, it, ns, nt, n2 + logical slope_present + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_conserv ns") + nt = assert_eq(size(xt) - 1, size(vt, 1), "regr12_conserv nt") + n2 = assert_eq(size(vs, 2), size(vt, 2), "regr12_conserv n2") + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr12_conserv xs bad order") + call assert(xt(1) < xt(2), "regr12_conserv xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr12_conserv extrapolation") + slope_present = present(slope) + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + if (xt(it + 1) <= xs(is + 1)) then + vt(it, :) = mean_lin(xt(it), xt(it + 1)) + else + vt(it, :) = mean_lin(xt(it), xs(is + 1)) * (xs(is + 1) - xt(it)) + is = is + 1 + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :) = vt(it, :) + (xs(is + 1) - xs(is)) * vs(is, :) + is = is + 1 + end do + ! 1 <= is <= ns + vt(it, :) = (vt(it, :) + mean_lin(xs(is), xt(it + 1)) * (xt(it + 1) & + - xs(is))) / (xt(it + 1) - xt(it)) + end if + + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + contains + + function mean_lin(a, b) + + ! mean in [a, b] of the linear function in [xs(is), xs(is + 1)] + + real, intent(in):: a, b + real mean_lin(n2) + + !--------------------------------------------- + + if (slope_present) then + mean_lin = slope(is, :) / 2. * (a + b - xs(is) - xs(is + 1)) & + + vs(is, :) + else + mean_lin = vs(is, :) + end if + + end function mean_lin + + end subroutine regr12_conserv + + !******************************************** + + subroutine regr13_conserv(vs, xs, xt, vt, slope) + + ! vs and slope have rank 3. + + real, intent(in):: vs(:, :, :) + real, intent(in):: xs(:) + real, intent(in):: xt(:) + real, intent(out):: vt(:, :, :) + real, intent(in), optional:: slope(:, :, :) + + ! Local: + integer is, it, ns, nt, n2, n3 + logical slope_present + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_conserv ns") + nt = assert_eq(size(xt) - 1, size(vt, 1), "regr13_conserv nt") + n2 = assert_eq(size(vs, 2), size(vt, 2), "regr13_conserv n2") + n3 = assert_eq(size(vs, 3), size(vt, 3), "regr13_conserv n3") + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr13_conserv xs bad order") + call assert(xt(1) < xt(2), "regr13_conserv xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr13_conserv extrapolation") + slope_present = present(slope) + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + if (xt(it + 1) <= xs(is + 1)) then + vt(it, :, :) = mean_lin(xt(it), xt(it + 1)) + else + vt(it, :, :) = mean_lin(xt(it), xs(is + 1)) * (xs(is + 1) - xt(it)) + is = is + 1 + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - xs(is)) * vs(is, :, :) + is = is + 1 + end do + ! 1 <= is <= ns + vt(it, :, :) = (vt(it, :, :) + mean_lin(xs(is), xt(it + 1)) & + * (xt(it + 1) - xs(is))) / (xt(it + 1) - xt(it)) + end if + + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + contains + + function mean_lin(a, b) + + ! mean in [a, b] of the linear function in [xs(is), xs(is + 1)] + + real, intent(in):: a, b + real mean_lin(n2, n3) + + !--------------------------------------------- + + if (slope_present) then + mean_lin = slope(is, :, :) / 2. * (a + b - xs(is) - xs(is + 1)) & + + vs(is, :, :) + else + mean_lin = vs(is, :, :) + end if + + end function mean_lin + + end subroutine regr13_conserv + + !******************************************** + + subroutine regr14_conserv(vs, xs, xt, vt, slope) + + ! vs and slope have rank 4. + + real, intent(in):: vs(:, :, :, :) + real, intent(in):: xs(:) + real, intent(in):: xt(:) + real, intent(out):: vt(:, :, :, :) + real, intent(in), optional:: slope(:, :, :, :) + + ! Local: + integer is, it, ns, nt, n2, n3, n4 + logical slope_present + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_conserv ns") + nt = assert_eq(size(xt) - 1, size(vt, 1), "regr14_conserv nt") + n2 = assert_eq(size(vs, 2), size(vt, 2), "regr14_conserv n2") + n3 = assert_eq(size(vs, 3), size(vt, 3), "regr14_conserv n3") + n4 = assert_eq(size(vs, 4), size(vt, 4), "regr14_conserv n4") + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr14_conserv xs bad order") + call assert(xt(1) < xt(2), "regr14_conserv xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr14_conserv extrapolation") + slope_present = present(slope) + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + if (xt(it + 1) <= xs(is + 1)) then + vt(it, :, :, :) = mean_lin(xt(it), xt(it + 1)) + else + vt(it, :, :, :) = mean_lin(xt(it), xs(is + 1)) * (xs(is + 1) - xt(it)) + is = is + 1 + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - xs(is)) & + * vs(is, :, :, :) + is = is + 1 + end do + ! 1 <= is <= ns + vt(it, :, :, :) = (vt(it, :, :, :) + mean_lin(xs(is), xt(it + 1)) & + * (xt(it + 1) - xs(is))) / (xt(it + 1) - xt(it)) + end if + + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + contains + + function mean_lin(a, b) + + ! mean in [a, b] of the linear function in [xs(is), xs(is + 1)] + + real, intent(in):: a, b + real mean_lin(n2, n3, n4) + + !--------------------------------------------- + + if (slope_present) then + mean_lin = slope(is, :, :, :) / 2. * (a + b - xs(is) - xs(is + 1)) & + + vs(is, :, :, :) + else + mean_lin = vs(is, :, :, :) + end if + + end function mean_lin + + end subroutine regr14_conserv + +end module regr1_conserv_m Index: DZ6/trunk/libf/obsolete/regr1_lint_m.F90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr1_lint_m.F90 (revision 5311) +++ (revision ) @@ -1,98 +1,0 @@ -! $Id$ -module regr1_lint_m - - ! Author: Lionel GUEZ - - implicit none - - interface regr1_lint - ! Each procedure regrids by linear interpolation. - ! The regridding operation is done on the first dimension of the - ! input array. - ! The difference betwwen the procedures is the rank of the first argument. - module procedure regr11_lint, regr12_lint - end interface - - private - public regr1_lint - -contains - - function regr11_lint(vs, xs, xt) result(vt) - - ! "vs" has rank 1. - - use assert_eq_m, only: assert_eq - use interpolation, only: hunt !!, polint - - real, intent(in):: vs(:) - ! (values of the function at source points "xs") - - real, intent(in):: xs(:) - ! (abscissas of points in source grid, in strictly monotonic order) - - real, intent(in):: xt(:) - ! (abscissas of points in target grid) - - real vt(size(xt)) ! values of the function on the target grid - - ! Variables local to the procedure: - integer is, it, ns - integer is_b ! "is" bound between 1 and "ns - 1" - - !-------------------------------------- - - ns = assert_eq(size(vs), size(xs), "regr11_lint ns") - - is = -1 ! go immediately to bisection on first call to "hunt" - - do it = 1, size(xt) - call hunt(xs, xt(it), is) - is_b = min(max(is, 1), ns - 1) -!! call polint(xs(is_b:is_b+1), vs(is_b:is_b+1), xt(it), vt(it)) - vt(it) = ((xs(is_b+1) - xt(it)) * vs(is_b) & - + (xt(it) - xs(is_b)) * vs(is_b+1)) / (xs(is_b+1) - xs(is_b)) - end do - - end function regr11_lint - - !********************************************************* - - function regr12_lint(vs, xs, xt) result(vt) - - ! "vs" has rank 2. - - use assert_eq_m, only: assert_eq - use interpolation, only: hunt - - real, intent(in):: vs(:, :) - ! (values of the function at source points "xs") - - real, intent(in):: xs(:) - ! (abscissas of points in source grid, in strictly monotonic order) - - real, intent(in):: xt(:) - ! (abscissas of points in target grid) - - real vt(size(xt), size(vs, 2)) ! values of the function on the target grid - - ! Variables local to the procedure: - integer is, it, ns - integer is_b ! "is" bound between 1 and "ns - 1" - - !-------------------------------------- - - ns = assert_eq(size(vs, 1), size(xs), "regr12_lint ns") - - is = -1 ! go immediately to bisection on first call to "hunt" - - do it = 1, size(xt) - call hunt(xs, xt(it), is) - is_b = min(max(is, 1), ns - 1) - vt(it, :) = ((xs(is_b+1) - xt(it)) * vs(is_b, :) & - + (xt(it) - xs(is_b)) * vs(is_b+1, :)) / (xs(is_b+1) - xs(is_b)) - end do - - end function regr12_lint - -end module regr1_lint_m Index: /LMDZ6/trunk/libf/obsolete/regr1_lint_m.f90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr1_lint_m.f90 (revision 5312) +++ /LMDZ6/trunk/libf/obsolete/regr1_lint_m.f90 (revision 5312) @@ -0,0 +1,98 @@ +! $Id$ +module regr1_lint_m + + ! Author: Lionel GUEZ + + implicit none + + interface regr1_lint + ! Each procedure regrids by linear interpolation. + ! The regridding operation is done on the first dimension of the + ! input array. + ! The difference betwwen the procedures is the rank of the first argument. + module procedure regr11_lint, regr12_lint + end interface + + private + public regr1_lint + +contains + + function regr11_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 1. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt !!, polint + + real, intent(in):: vs(:) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(xt)) ! values of the function on the target grid + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs), size(xs), "regr11_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) +!! call polint(xs(is_b:is_b+1), vs(is_b:is_b+1), xt(it), vt(it)) + vt(it) = ((xs(is_b+1) - xt(it)) * vs(is_b) & + + (xt(it) - xs(is_b)) * vs(is_b+1)) / (xs(is_b+1) - xs(is_b)) + end do + + end function regr11_lint + + !********************************************************* + + function regr12_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 2. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt + + real, intent(in):: vs(:, :) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(xt), size(vs, 2)) ! values of the function on the target grid + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs), "regr12_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) + vt(it, :) = ((xs(is_b+1) - xt(it)) * vs(is_b, :) & + + (xt(it) - xs(is_b)) * vs(is_b+1, :)) / (xs(is_b+1) - xs(is_b)) + end do + + end function regr12_lint + +end module regr1_lint_m Index: DZ6/trunk/libf/obsolete/regr1_step_av_m.F90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr1_step_av_m.F90 (revision 5311) +++ (revision ) @@ -1,268 +1,0 @@ -! $Id$ -module regr1_step_av_m - - ! Author: Lionel GUEZ - - implicit none - - interface regr1_step_av - - ! Each procedure regrids a step function by averaging it. - ! The regridding operation is done on the first dimension of the - ! input array. - ! Source grid contains edges of steps. - ! Target grid contains positions of cell edges. - ! The target grid should be included in the source grid: no - ! extrapolation is allowed. - ! The difference between the procedures is the rank of the first argument. - - module procedure regr11_step_av, regr12_step_av, regr13_step_av, & - regr14_step_av - end interface - - private - public regr1_step_av - -contains - - function regr11_step_av(vs, xs, xt) result(vt) - - ! "vs" has rank 1. - - use assert_eq_m, only: assert_eq - use assert_m, only: assert - use interpolation, only: locate - - real, intent(in):: vs(:) ! values of steps on the source grid - ! (Step "is" is between "xs(is)" and "xs(is + 1)".) - - real, intent(in):: xs(:) - ! (edges of of steps on the source grid, in strictly increasing order) - - real, intent(in):: xt(:) - ! (edges of cells of the target grid, in strictly increasing order) - - real vt(size(xt) - 1) ! average values on the target grid - ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) - - ! Variables local to the procedure: - integer is, it, ns, nt - real left_edge - - !--------------------------------------------- - - ns = assert_eq(size(vs), size(xs) - 1, "regr11_step_av ns") - nt = size(xt) - 1 - ! Quick check on sort order: - call assert(xs(1) < xs(2), "regr11_step_av xs bad order") - call assert(xt(1) < xt(2), "regr11_step_av xt bad order") - - call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & - "regr11_step_av extrapolation") - - is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation - do it = 1, nt - ! 1 <= is <= ns - ! xs(is) <= xt(it) < xs(is + 1) - ! Compute "vt(it)": - left_edge = xt(it) - vt(it) = 0. - do while (xs(is + 1) < xt(it + 1)) - ! 1 <= is <= ns - 1 - vt(it) = vt(it) + (xs(is + 1) - left_edge) * vs(is) - is = is + 1 - left_edge = xs(is) - end do - ! 1 <= is <= ns - vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) & - / (xt(it + 1) - xt(it)) - if (xs(is + 1) == xt(it + 1)) is = is + 1 - ! 1 <= is <= ns .or. it == nt - end do - - end function regr11_step_av - - !******************************************** - - function regr12_step_av(vs, xs, xt) result(vt) - - ! "vs" has rank 2. - - use assert_eq_m, only: assert_eq - use assert_m, only: assert - use interpolation, only: locate - - real, intent(in):: vs(:, :) ! values of steps on the source grid - ! (Step "is" is between "xs(is)" and "xs(is + 1)".) - - real, intent(in):: xs(:) - ! (edges of steps on the source grid, in strictly increasing order) - - real, intent(in):: xt(:) - ! (edges of cells of the target grid, in strictly increasing order) - - real vt(size(xt) - 1, size(vs, 2)) ! average values on the target grid - ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) - - ! Variables local to the procedure: - integer is, it, ns, nt - real left_edge - - !--------------------------------------------- - - ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_step_av ns") - nt = size(xt) - 1 - - ! Quick check on sort order: - call assert(xs(1) < xs(2), "regr12_step_av xs bad order") - call assert(xt(1) < xt(2), "regr12_step_av xt bad order") - - call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & - "regr12_step_av extrapolation") - - is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation - do it = 1, nt - ! 1 <= is <= ns - ! xs(is) <= xt(it) < xs(is + 1) - ! Compute "vt(it, :)": - left_edge = xt(it) - vt(it, :) = 0. - do while (xs(is + 1) < xt(it + 1)) - ! 1 <= is <= ns - 1 - vt(it, :) = vt(it, :) + (xs(is + 1) - left_edge) * vs(is, :) - is = is + 1 - left_edge = xs(is) - end do - ! 1 <= is <= ns - vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) & - / (xt(it + 1) - xt(it)) - if (xs(is + 1) == xt(it + 1)) is = is + 1 - ! 1 <= is <= ns .or. it == nt - end do - - end function regr12_step_av - - !******************************************** - - function regr13_step_av(vs, xs, xt) result(vt) - - ! "vs" has rank 3. - - use assert_eq_m, only: assert_eq - use assert_m, only: assert - use interpolation, only: locate - - real, intent(in):: vs(:, :, :) ! values of steps on the source grid - ! (Step "is" is between "xs(is)" and "xs(is + 1)".) - - real, intent(in):: xs(:) - ! (edges of steps on the source grid, in strictly increasing order) - - real, intent(in):: xt(:) - ! (edges of cells of the target grid, in strictly increasing order) - - real vt(size(xt) - 1, size(vs, 2), size(vs, 3)) - ! (average values on the target grid) - ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) - - ! Variables local to the procedure: - integer is, it, ns, nt - real left_edge - - !--------------------------------------------- - - ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_step_av ns") - nt = size(xt) - 1 - - ! Quick check on sort order: - call assert(xs(1) < xs(2), "regr13_step_av xs bad order") - call assert(xt(1) < xt(2), "regr13_step_av xt bad order") - - call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & - "regr13_step_av extrapolation") - - is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation - do it = 1, nt - ! 1 <= is <= ns - ! xs(is) <= xt(it) < xs(is + 1) - ! Compute "vt(it, :, :)": - left_edge = xt(it) - vt(it, :, :) = 0. - do while (xs(is + 1) < xt(it + 1)) - ! 1 <= is <= ns - 1 - vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - left_edge) * vs(is, :, :) - is = is + 1 - left_edge = xs(is) - end do - ! 1 <= is <= ns - vt(it, :, :) = (vt(it, :, :) & - + (xt(it + 1) - left_edge) * vs(is, :, :)) / (xt(it + 1) - xt(it)) - if (xs(is + 1) == xt(it + 1)) is = is + 1 - ! 1 <= is <= ns .or. it == nt - end do - - end function regr13_step_av - - !******************************************** - - function regr14_step_av(vs, xs, xt) result(vt) - - ! "vs" has rank 4. - - use assert_eq_m, only: assert_eq - use assert_m, only: assert - use interpolation, only: locate - - real, intent(in):: vs(:, :, :, :) ! values of steps on the source grid - ! (Step "is" is between "xs(is)" and "xs(is + 1)".) - - real, intent(in):: xs(:) - ! (edges of steps on the source grid, in strictly increasing order) - - real, intent(in):: xt(:) - ! (edges of cells of the target grid, in strictly increasing order) - - real vt(size(xt) - 1, size(vs, 2), size(vs, 3), size(vs, 4)) - ! (average values on the target grid) - ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) - - ! Variables local to the procedure: - integer is, it, ns, nt - real left_edge - - !--------------------------------------------- - - ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_step_av ns") - nt = size(xt) - 1 - - ! Quick check on sort order: - call assert(xs(1) < xs(2), "regr14_step_av xs bad order") - call assert(xt(1) < xt(2), "regr14_step_av xt bad order") - - call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & - "regr14_step_av extrapolation") - - is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation - do it = 1, nt - ! 1 <= is <= ns - ! xs(is) <= xt(it) < xs(is + 1) - ! Compute "vt(it, :, :, :)": - left_edge = xt(it) - vt(it, :, :, :) = 0. - do while (xs(is + 1) < xt(it + 1)) - ! 1 <= is <= ns - 1 - vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - left_edge) & - * vs(is, :, :, :) - is = is + 1 - left_edge = xs(is) - end do - ! 1 <= is <= ns - vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) & - * vs(is, :, :, :)) / (xt(it + 1) - xt(it)) - if (xs(is + 1) == xt(it + 1)) is = is + 1 - ! 1 <= is <= ns .or. it == nt - end do - - end function regr14_step_av - -end module regr1_step_av_m Index: /LMDZ6/trunk/libf/obsolete/regr1_step_av_m.f90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr1_step_av_m.f90 (revision 5312) +++ /LMDZ6/trunk/libf/obsolete/regr1_step_av_m.f90 (revision 5312) @@ -0,0 +1,268 @@ +! $Id$ +module regr1_step_av_m + + ! Author: Lionel GUEZ + + implicit none + + interface regr1_step_av + + ! Each procedure regrids a step function by averaging it. + ! The regridding operation is done on the first dimension of the + ! input array. + ! Source grid contains edges of steps. + ! Target grid contains positions of cell edges. + ! The target grid should be included in the source grid: no + ! extrapolation is allowed. + ! The difference between the procedures is the rank of the first argument. + + module procedure regr11_step_av, regr12_step_av, regr13_step_av, & + regr14_step_av + end interface + + private + public regr1_step_av + +contains + + function regr11_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 1. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1) ! average values on the target grid + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs), size(xs) - 1, "regr11_step_av ns") + nt = size(xt) - 1 + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr11_step_av xs bad order") + call assert(xt(1) < xt(2), "regr11_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr11_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it)": + left_edge = xt(it) + vt(it) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it) = vt(it) + (xs(is + 1) - left_edge) * vs(is) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it) = (vt(it) + (xt(it + 1) - left_edge) * vs(is)) & + / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr11_step_av + + !******************************************** + + function regr12_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 2. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:, :) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1, size(vs, 2)) ! average values on the target grid + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr12_step_av ns") + nt = size(xt) - 1 + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr12_step_av xs bad order") + call assert(xt(1) < xt(2), "regr12_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr12_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it, :)": + left_edge = xt(it) + vt(it, :) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :) = vt(it, :) + (xs(is + 1) - left_edge) * vs(is, :) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it, :) = (vt(it, :) + (xt(it + 1) - left_edge) * vs(is, :)) & + / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr12_step_av + + !******************************************** + + function regr13_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 3. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:, :, :) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1, size(vs, 2), size(vs, 3)) + ! (average values on the target grid) + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr13_step_av ns") + nt = size(xt) - 1 + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr13_step_av xs bad order") + call assert(xt(1) < xt(2), "regr13_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr13_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it, :, :)": + left_edge = xt(it) + vt(it, :, :) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :, :) = vt(it, :, :) + (xs(is + 1) - left_edge) * vs(is, :, :) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it, :, :) = (vt(it, :, :) & + + (xt(it + 1) - left_edge) * vs(is, :, :)) / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr13_step_av + + !******************************************** + + function regr14_step_av(vs, xs, xt) result(vt) + + ! "vs" has rank 4. + + use assert_eq_m, only: assert_eq + use assert_m, only: assert + use interpolation, only: locate + + real, intent(in):: vs(:, :, :, :) ! values of steps on the source grid + ! (Step "is" is between "xs(is)" and "xs(is + 1)".) + + real, intent(in):: xs(:) + ! (edges of steps on the source grid, in strictly increasing order) + + real, intent(in):: xt(:) + ! (edges of cells of the target grid, in strictly increasing order) + + real vt(size(xt) - 1, size(vs, 2), size(vs, 3), size(vs, 4)) + ! (average values on the target grid) + ! (Cell "it" is between "xt(it)" and "xt(it + 1)".) + + ! Variables local to the procedure: + integer is, it, ns, nt + real left_edge + + !--------------------------------------------- + + ns = assert_eq(size(vs, 1), size(xs) - 1, "regr14_step_av ns") + nt = size(xt) - 1 + + ! Quick check on sort order: + call assert(xs(1) < xs(2), "regr14_step_av xs bad order") + call assert(xt(1) < xt(2), "regr14_step_av xt bad order") + + call assert(xs(1) <= xt(1) .and. xt(nt + 1) <= xs(ns + 1), & + "regr14_step_av extrapolation") + + is = locate(xs, xt(1)) ! 1 <= is <= ns, because we forbid extrapolation + do it = 1, nt + ! 1 <= is <= ns + ! xs(is) <= xt(it) < xs(is + 1) + ! Compute "vt(it, :, :, :)": + left_edge = xt(it) + vt(it, :, :, :) = 0. + do while (xs(is + 1) < xt(it + 1)) + ! 1 <= is <= ns - 1 + vt(it, :, :, :) = vt(it, :, :, :) + (xs(is + 1) - left_edge) & + * vs(is, :, :, :) + is = is + 1 + left_edge = xs(is) + end do + ! 1 <= is <= ns + vt(it, :, :, :) = (vt(it, :, :, :) + (xt(it + 1) - left_edge) & + * vs(is, :, :, :)) / (xt(it + 1) - xt(it)) + if (xs(is + 1) == xt(it + 1)) is = is + 1 + ! 1 <= is <= ns .or. it == nt + end do + + end function regr14_step_av + +end module regr1_step_av_m Index: DZ6/trunk/libf/obsolete/regr3_lint_m.F90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr3_lint_m.F90 (revision 5311) +++ (revision ) @@ -1,100 +1,0 @@ -! $Id$ -module regr3_lint_m - - ! Author: Lionel GUEZ - - implicit none - - interface regr3_lint - ! Each procedure regrids by linear interpolation. - ! The regridding operation is done on the third dimension of the - ! input array. - ! The difference betwwen the procedures is the rank of the first argument. - module procedure regr33_lint, regr34_lint - end interface - - private - public regr3_lint - -contains - - function regr33_lint(vs, xs, xt) result(vt) - - ! "vs" has rank 3. - - use assert_eq_m, only: assert_eq - use interpolation, only: hunt - - real, intent(in):: vs(:, :, :) - ! (values of the function at source points "xs") - - real, intent(in):: xs(:) - ! (abscissas of points in source grid, in strictly monotonic order) - - real, intent(in):: xt(:) - ! (abscissas of points in target grid) - - real vt(size(vs, 1), size(vs, 2), size(xt)) - ! (values of the function on the target grid) - - ! Variables local to the procedure: - integer is, it, ns - integer is_b ! "is" bound between 1 and "ns - 1" - - !-------------------------------------- - - ns = assert_eq(size(vs, 3), size(xs), "regr33_lint ns") - - is = -1 ! go immediately to bisection on first call to "hunt" - - do it = 1, size(xt) - call hunt(xs, xt(it), is) - is_b = min(max(is, 1), ns - 1) - vt(:, :, it) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b) & - + (xt(it) - xs(is_b)) * vs(:, :, is_b+1)) / (xs(is_b+1) - xs(is_b)) - end do - - end function regr33_lint - - !********************************************************* - - function regr34_lint(vs, xs, xt) result(vt) - - ! "vs" has rank 4. - - use assert_eq_m, only: assert_eq - use interpolation, only: hunt - - real, intent(in):: vs(:, :, :, :) - ! (values of the function at source points "xs") - - real, intent(in):: xs(:) - ! (abscissas of points in source grid, in strictly monotonic order) - - real, intent(in):: xt(:) - ! (abscissas of points in target grid) - - real vt(size(vs, 1), size(vs, 2), size(xt), size(vs, 4)) - ! (values of the function on the target grid) - - ! Variables local to the procedure: - integer is, it, ns - integer is_b ! "is" bound between 1 and "ns - 1" - - !-------------------------------------- - - ns = assert_eq(size(vs, 3), size(xs), "regr34_lint ns") - - is = -1 ! go immediately to bisection on first call to "hunt" - - do it = 1, size(xt) - call hunt(xs, xt(it), is) - is_b = min(max(is, 1), ns - 1) - vt(:, :, it, :) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b, :) & - + (xt(it) - xs(is_b)) * vs(:, :, is_b+1, :)) & - / (xs(is_b+1) - xs(is_b)) - end do - - end function regr34_lint - -end module regr3_lint_m Index: /LMDZ6/trunk/libf/obsolete/regr3_lint_m.f90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr3_lint_m.f90 (revision 5312) +++ /LMDZ6/trunk/libf/obsolete/regr3_lint_m.f90 (revision 5312) @@ -0,0 +1,100 @@ +! $Id$ +module regr3_lint_m + + ! Author: Lionel GUEZ + + implicit none + + interface regr3_lint + ! Each procedure regrids by linear interpolation. + ! The regridding operation is done on the third dimension of the + ! input array. + ! The difference betwwen the procedures is the rank of the first argument. + module procedure regr33_lint, regr34_lint + end interface + + private + public regr3_lint + +contains + + function regr33_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 3. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt + + real, intent(in):: vs(:, :, :) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(vs, 1), size(vs, 2), size(xt)) + ! (values of the function on the target grid) + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs, 3), size(xs), "regr33_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) + vt(:, :, it) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b) & + + (xt(it) - xs(is_b)) * vs(:, :, is_b+1)) / (xs(is_b+1) - xs(is_b)) + end do + + end function regr33_lint + + !********************************************************* + + function regr34_lint(vs, xs, xt) result(vt) + + ! "vs" has rank 4. + + use assert_eq_m, only: assert_eq + use interpolation, only: hunt + + real, intent(in):: vs(:, :, :, :) + ! (values of the function at source points "xs") + + real, intent(in):: xs(:) + ! (abscissas of points in source grid, in strictly monotonic order) + + real, intent(in):: xt(:) + ! (abscissas of points in target grid) + + real vt(size(vs, 1), size(vs, 2), size(xt), size(vs, 4)) + ! (values of the function on the target grid) + + ! Variables local to the procedure: + integer is, it, ns + integer is_b ! "is" bound between 1 and "ns - 1" + + !-------------------------------------- + + ns = assert_eq(size(vs, 3), size(xs), "regr34_lint ns") + + is = -1 ! go immediately to bisection on first call to "hunt" + + do it = 1, size(xt) + call hunt(xs, xt(it), is) + is_b = min(max(is, 1), ns - 1) + vt(:, :, it, :) = ((xs(is_b+1) - xt(it)) * vs(:, :, is_b, :) & + + (xt(it) - xs(is_b)) * vs(:, :, is_b+1, :)) & + / (xs(is_b+1) - xs(is_b)) + end do + + end function regr34_lint + +end module regr3_lint_m Index: DZ6/trunk/libf/obsolete/regr_lat_time_climoz_m.F90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr_lat_time_climoz_m.F90 (revision 5311) +++ (revision ) @@ -1,450 +1,0 @@ -! $Id$ -module regr_lat_time_climoz_m - - ! Author: Lionel GUEZ - - implicit none - - private - public regr_lat_time_climoz - -contains - - subroutine regr_lat_time_climoz(read_climoz) - - ! "regr_lat_time_climoz" stands for "regrid latitude time - ! climatology ozone". - - ! This procedure reads a climatology of ozone from a NetCDF file, - ! regrids it in latitude and time, and writes the regridded field - ! to a new NetCDF file. - - ! The input field depends on time, pressure level and latitude. - - ! If the input field has missing values, they must be signaled by - ! the "missing_value" attribute. - - ! We assume that the input field is a step function of latitude - ! and that the input latitude coordinate gives the centers of steps. - ! Regridding in latitude is made by averaging, with a cosine of - ! latitude factor. - ! The target LMDZ latitude grid is the "scalar" grid: "rlatu". - ! The values of "rlatu" are taken to be the centers of intervals. - - ! We assume that in the input file: - - ! -- Latitude is in degrees. - - ! -- Latitude and pressure are strictly monotonic (as all NetCDF - ! coordinate variables should be). - - ! -- The time coordinate is in ascending order (even though we do - ! not use its values). - ! The input file may contain either values for 12 months or values - ! for 14 months. - ! If there are 14 months then we assume that we have (in that order): - ! December, January, February, ..., November, December, January - - ! -- Missing values are contiguous, at the bottom of - ! the vertical domain and at the latitudinal boundaries. - - ! If values are all missing at a given latitude and date, then we - ! replace those missing values by values at the closest latitude, - ! equatorward, with valid values. - ! Then, at each latitude and each date, the missing values are replaced - ! by the lowest valid value above missing values. - - ! Regridding in time is by linear interpolation. - ! Monthly values are processed to get daily values, on the basis - ! of a 360-day calendar. - ! If there are 14 months, we use the first December value to - ! interpolate values between January 1st and mid-January. - ! We use the last January value to interpolate values between - ! mid-December and end of December. - ! If there are only 12 months in the input file then we assume - ! periodicity for interpolation at the beginning and at the end of the - ! year. - - use mod_grid_phy_lmdz, ONLY : nbp_lat - use regr1_conserv_m, only: regr1_conserv - use regr3_lint_m, only: regr3_lint - use netcdf95, only: handle_err, nf95_close, nf95_get_att, nf95_gw_var, & - nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, nf95_open, & - nf95_put_var - use netcdf, only: nf90_get_att, nf90_get_var, nf90_noerr, nf90_nowrite - use assert_m, only: assert - use regular_lonlat_mod, only : boundslat_reg, south - use nrtype, only: pi - use slopes_m, only: slopes - - integer, intent(in):: read_climoz ! read ozone climatology - ! Allowed values are 1 and 2 - ! 1: read a single ozone climatology that will be used day and night - ! 2: read two ozone climatologies, the average day and night - ! climatology and the daylight climatology - - ! Variables local to the procedure: - - integer n_plev ! number of pressure levels in the input data - integer n_lat ! number of latitudes in the input data - integer n_month ! number of months in the input data - - real, pointer:: latitude(:) - ! (of input data, converted to rad, sorted in strictly ascending order) - - real, allocatable:: sin_lat_in_edg(:) - ! (sine of edges of latitude intervals for input data, in rad, in strictly - ! ascending order) - - real, pointer:: plev(:) - ! pressure levels of input data, sorted in strictly ascending - ! order, converted to hPa - - logical desc_lat ! latitude in descending order in the input file - logical desc_plev ! pressure levels in descending order in the input file - - real, allocatable:: o3_in(:, :, :, :) - ! (n_lat, n_plev, n_month, read_climoz) - ! ozone climatologies from the input file - ! "o3_in(j, k, :, :)" is at latitude "latitude(j)" and pressure - ! level "plev(k)". - ! Third dimension is month index, first value may be December or January. - ! "o3_in(:, :, :, 1)" is for the day- night average, "o3_in(:, :, :, 2)" - ! is for daylight. - - real missing_value - - real, allocatable:: o3_regr_lat(:, :, :, :) - ! (nbp_lat, n_plev, 0:13, read_climoz) - ! mean of "o3_in" over a latitude interval of LMDZ - ! First dimension is latitude interval. - ! The latitude interval for "o3_regr_lat(j,:, :, :)" contains "rlatu(j)". - ! If "j" is between 2 and "nbp_lat - 1" then the interval is: - ! [rlatv(j), rlatv(j-1)] - ! If "j" is 1 or "nbp_lat" then the interval is: - ! [rlatv(1), pi / 2] - ! or: - ! [- pi / 2, rlatv(nbp_lat - 1)] - ! respectively. - ! "o3_regr_lat(:, k, :, :)" is for pressure level "plev(k)". - ! Third dimension is month number, 1 for January. - ! "o3_regr_lat(:, :, :, 1)" is average day and night, - ! "o3_regr_lat(:, :, :, 2)" is for daylight. - - real, allocatable:: o3_out(:, :, :, :) - ! (nbp_lat, n_plev, 360, read_climoz) - ! regridded ozone climatology - ! "o3_out(j, k, l, :)" is at latitude "rlatu(j)", pressure - ! level "plev(k)" and date "January 1st 0h" + "tmidday(l)", in a - ! 360-day calendar. - ! "o3_out(:, :, :, 1)" is average day and night, - ! "o3_out(:, :, :, 2)" is for daylight. - - integer j, k, l,m - - ! For NetCDF: - integer ncid_in, ncid_out ! IDs for input and output files - integer varid_plev, varid_time, varid, ncerr, dimid - character(len=80) press_unit ! pressure unit - - integer varid_in(read_climoz), varid_out(read_climoz) - ! index 1 is for average ozone day and night, index 2 is for - ! daylight ozone. - - real, parameter:: tmidmonth(0:13) = (/(-15. + 30. * l, l = 0, 13)/) - ! (time to middle of month, in days since January 1st 0h, in a - ! 360-day calendar) - ! (We add values -15 and 375 so that, for example, day 3 of the year is - ! interpolated between the December and the January value.) - - real, parameter:: tmidday(360) = (/(l + 0.5, l = 0, 359)/) - ! (time to middle of day, in days since January 1st 0h, in a - ! 360-day calendar) - - !--------------------------------- - - print *, "Call sequence information: regr_lat_time_climoz" - call assert(read_climoz == 1 .or. read_climoz == 2, "regr_lat_time_climoz") - - call nf95_open("climoz.nc", nf90_nowrite, ncid_in) - - ! Get coordinates from the input file: - - call nf95_inq_varid(ncid_in, "latitude", varid) - call nf95_gw_var(ncid_in, varid, latitude) - ! Convert from degrees to rad, because we will take the sine of latitude: - latitude = latitude / 180. * pi - n_lat = size(latitude) - ! We need to supply the latitudes to "regr1_conserv" in - ! ascending order, so invert order if necessary: - desc_lat = latitude(1) > latitude(n_lat) - if (desc_lat) latitude = latitude(n_lat:1:-1) - - ! Compute edges of latitude intervals: - allocate(sin_lat_in_edg(n_lat + 1)) - sin_lat_in_edg(1) = - 1. - forall (j = 2:n_lat) sin_lat_in_edg(j) = sin((latitude(j - 1) & - + latitude(j)) / 2.) - sin_lat_in_edg(n_lat + 1) = 1. - deallocate(latitude) ! pointer - - call nf95_inq_varid(ncid_in, "plev", varid) - call nf95_gw_var(ncid_in, varid, plev) - n_plev = size(plev) - ! We only need the pressure coordinate to copy it to the output file. - ! The program "gcm" will assume that pressure levels are in - ! ascending order in the regridded climatology so invert order if - ! necessary: - desc_plev = plev(1) > plev(n_plev) - if (desc_plev) plev = plev(n_plev:1:-1) - call nf95_get_att(ncid_in, varid, "units", press_unit) - if (press_unit == "Pa") then - ! Convert to hPa: - plev = plev / 100. - elseif (press_unit /= "hPa") then - print *, "regr_lat_time_climoz: the only recognized units are Pa " & - // "and hPa." - stop 1 - end if - - ! Create the output file and get the variable IDs: - call prepare_out(ncid_in, n_plev, ncid_out, varid_out, varid_plev, & - varid_time) - - ! Write remaining coordinate variables: - call nf95_put_var(ncid_out, varid_plev, plev) - call nf95_put_var(ncid_out, varid_time, tmidday) - - deallocate(plev) ! pointer - - ! Get the number of months: - call nf95_inq_dimid(ncid_in, "time", dimid) - call nf95_inquire_dimension(ncid_in, dimid, nclen=n_month) - - allocate(o3_in(n_lat, n_plev, n_month, read_climoz)) - - call nf95_inq_varid(ncid_in, "tro3", varid_in(1)) - ncerr = nf90_get_var(ncid_in, varid_in(1), o3_in(:, :, :, 1)) - call handle_err("regr_lat_time_climoz nf90_get_var tro3", ncerr, ncid_in) - - if (read_climoz == 2) then - call nf95_inq_varid(ncid_in, "tro3_daylight", varid_in(2)) - ncerr = nf90_get_var(ncid_in, varid_in(2), o3_in(:, :, :, 2)) - call handle_err("regr_lat_time_climoz nf90_get_var tro3_daylight", & - ncerr, ncid_in, varid_in(2)) - end if - - if (desc_lat) o3_in = o3_in(n_lat:1:-1, :, :, :) - if (desc_plev) o3_in = o3_in(:, n_plev:1:-1, :, :) - - do m = 1, read_climoz - ncerr = nf90_get_att(ncid_in, varid_in(m), "missing_value", & - missing_value) - if (ncerr == nf90_noerr) then - do l = 1, n_month - ! Take care of latitudes where values are all missing: - - ! Next to the south pole: - j = 1 - do while (o3_in(j, 1, l, m) == missing_value) - j = j + 1 - end do - if (j > 1) o3_in(:j-1, :, l, m) = & - spread(o3_in(j, :, l, m), dim=1, ncopies=j-1) - - ! Next to the north pole: - j = n_lat - do while (o3_in(j, 1, l, m) == missing_value) - j = j - 1 - end do - if (j < n_lat) o3_in(j+1:, :, l, m) = & - spread(o3_in(j, :, l, m), dim=1, ncopies=n_lat-j) - - ! Take care of missing values at high pressure: - do j = 1, n_lat - ! Find missing values, starting from top of atmosphere - ! and going down. - ! We have already taken care of latitudes full of - ! missing values so the highest level has a valid value. - k = 2 - do while (o3_in(j, k, l, m) /= missing_value .and. k < n_plev) - k = k + 1 - end do - ! Replace missing values with the valid value at the - ! lowest level above missing values: - if (o3_in(j, k, l, m) == missing_value) & - o3_in(j, k:n_plev, l, m) = o3_in(j, k-1, l, m) - end do - end do - else - print *, "regr_lat_time_climoz: field ", m, & - ", no missing value attribute" - end if - end do - - call nf95_close(ncid_in) - - allocate(o3_regr_lat(nbp_lat, n_plev, 0:13, read_climoz)) - allocate(o3_out(nbp_lat, n_plev, 360, read_climoz)) - - ! Regrid in latitude: - ! We average with respect to sine of latitude, which is - ! equivalent to weighting by cosine of latitude: - if (n_month == 12) then - print *, & - "Found 12 months in ozone climatologies, assuming periodicity..." - call regr1_conserv(o3_in, xs = sin_lat_in_edg, & - xt = (/- 1., sin(boundslat_reg(nbp_lat - 1:1:- 1, south)), 1./), & - vt = o3_regr_lat(nbp_lat:1:- 1, :, 1:12, :), & - slope = slopes(o3_in, sin_lat_in_edg)) - ! (invert order of indices in "o3_regr_lat" because "rlatu" is - ! in descending order) - - ! Duplicate January and December values, in preparation of time - ! interpolation: - o3_regr_lat(:, :, 0, :) = o3_regr_lat(:, :, 12, :) - o3_regr_lat(:, :, 13, :) = o3_regr_lat(:, :, 1, :) - else - print *, "Using 14 months in ozone climatologies..." - call regr1_conserv(o3_in, xs = sin_lat_in_edg, & - xt = (/- 1., sin(boundslat_reg(nbp_lat - 1:1:- 1, south)), 1./), & - vt = o3_regr_lat(nbp_lat:1:- 1, :, :, :), & - slope = slopes(o3_in, sin_lat_in_edg)) - ! (invert order of indices in "o3_regr_lat" because "rlatu" is - ! in descending order) - end if - - ! Regrid in time by linear interpolation: - o3_out = regr3_lint(o3_regr_lat, tmidmonth, tmidday) - - ! Write to file: - do m = 1, read_climoz - call nf95_put_var(ncid_out, varid_out(m), o3_out(nbp_lat:1:-1, :, :, m)) - ! (The order of "rlatu" is inverted in the output file) - end do - - call nf95_close(ncid_out) - - end subroutine regr_lat_time_climoz - - !******************************************** - - subroutine prepare_out(ncid_in, n_plev, ncid_out, varid_out, varid_plev, & - varid_time) - - ! This subroutine creates the NetCDF output file, defines - ! dimensions and variables, and writes one of the coordinate variables. - - use mod_grid_phy_lmdz, ONLY : nbp_lat - use netcdf95, only: nf95_create, nf95_def_dim, nf95_def_var, & - nf95_put_att, nf95_enddef, nf95_copy_att, nf95_put_var - use netcdf, only: nf90_clobber, nf90_float, nf90_global - use nrtype, only: pi - use regular_lonlat_mod, only : lat_reg - - integer, intent(in):: ncid_in, n_plev - integer, intent(out):: ncid_out, varid_plev, varid_time - - integer, intent(out):: varid_out(:) ! dim(1 or 2) - ! "varid_out(1)" is for average ozone day and night, - ! "varid_out(2)" is for daylight ozone. - - ! Variables local to the procedure: - - integer ncerr - integer dimid_rlatu, dimid_plev, dimid_time - integer varid_rlatu - - !--------------------------- - - print *, "Call sequence information: prepare_out" - - call nf95_create("climoz_LMDZ.nc", nf90_clobber, ncid_out) - - ! Dimensions: - call nf95_def_dim(ncid_out, "time", 360, dimid_time) - call nf95_def_dim(ncid_out, "plev", n_plev, dimid_plev) - call nf95_def_dim(ncid_out, "rlatu", nbp_lat, dimid_rlatu) - - ! Define coordinate variables: - - call nf95_def_var(ncid_out, "time", nf90_float, dimid_time, varid_time) - call nf95_put_att(ncid_out, varid_time, "units", "days since 2000-1-1") - call nf95_put_att(ncid_out, varid_time, "calendar", "360_day") - call nf95_put_att(ncid_out, varid_time, "standard_name", "time") - - call nf95_def_var(ncid_out, "plev", nf90_float, dimid_plev, varid_plev) - call nf95_put_att(ncid_out, varid_plev, "units", "millibar") - call nf95_put_att(ncid_out, varid_plev, "standard_name", "air_pressure") - call nf95_put_att(ncid_out, varid_plev, "long_name", "air pressure") - - call nf95_def_var(ncid_out, "rlatu", nf90_float, dimid_rlatu, varid_rlatu) - call nf95_put_att(ncid_out, varid_rlatu, "units", "degrees_north") - call nf95_put_att(ncid_out, varid_rlatu, "standard_name", "latitude") - - ! Define the primary variables: - - call nf95_def_var(ncid_out, "tro3", nf90_float, & - (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(1)) - call nf95_put_att(ncid_out, varid_out(1), "long_name", & - "ozone mole fraction") - call nf95_put_att(ncid_out, varid_out(1), "standard_name", & - "mole_fraction_of_ozone_in_air") - - if (size(varid_out) == 2) then - call nf95_def_var(ncid_out, "tro3_daylight", nf90_float, & - (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(2)) - call nf95_put_att(ncid_out, varid_out(2), "long_name", & - "ozone mole fraction in daylight") - end if - - ! Global attributes: - - ! The following commands, copying attributes, may fail. - ! That is OK. - ! It should just mean that the attribute is not defined in the input file. - - call nf95_copy_att(ncid_in, nf90_global, "Conventions", ncid_out, & - nf90_global, ncerr) - call handle_err_copy_att("Conventions") - - call nf95_copy_att(ncid_in, nf90_global, "title", ncid_out, nf90_global, & - ncerr) - call handle_err_copy_att("title") - - call nf95_copy_att(ncid_in, nf90_global, "institution", ncid_out, & - nf90_global, ncerr) - call handle_err_copy_att("institution") - - call nf95_copy_att(ncid_in, nf90_global, "source", ncid_out, nf90_global, & - ncerr) - call handle_err_copy_att("source") - - call nf95_put_att(ncid_out, nf90_global, "comment", "Regridded for LMDZ") - - call nf95_enddef(ncid_out) - - ! Write one of the coordinate variables: - call nf95_put_var(ncid_out, varid_rlatu, lat_reg(nbp_lat:1:-1) / pi * 180.) - ! (convert from rad to degrees and sort in ascending order) - - contains - - subroutine handle_err_copy_att(att_name) - - use netcdf, only: nf90_noerr, nf90_strerror - - character(len=*), intent(in):: att_name - - !---------------------------------------- - - if (ncerr /= nf90_noerr) then - print *, "regr_lat_time_climoz_m prepare_out nf95_copy_att " & - // att_name // " -- " // trim(nf90_strerror(ncerr)) - end if - - end subroutine handle_err_copy_att - - end subroutine prepare_out - -end module regr_lat_time_climoz_m Index: /LMDZ6/trunk/libf/obsolete/regr_lat_time_climoz_m.f90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr_lat_time_climoz_m.f90 (revision 5312) +++ /LMDZ6/trunk/libf/obsolete/regr_lat_time_climoz_m.f90 (revision 5312) @@ -0,0 +1,450 @@ +! $Id$ +module regr_lat_time_climoz_m + + ! Author: Lionel GUEZ + + implicit none + + private + public regr_lat_time_climoz + +contains + + subroutine regr_lat_time_climoz(read_climoz) + + ! "regr_lat_time_climoz" stands for "regrid latitude time + ! climatology ozone". + + ! This procedure reads a climatology of ozone from a NetCDF file, + ! regrids it in latitude and time, and writes the regridded field + ! to a new NetCDF file. + + ! The input field depends on time, pressure level and latitude. + + ! If the input field has missing values, they must be signaled by + ! the "missing_value" attribute. + + ! We assume that the input field is a step function of latitude + ! and that the input latitude coordinate gives the centers of steps. + ! Regridding in latitude is made by averaging, with a cosine of + ! latitude factor. + ! The target LMDZ latitude grid is the "scalar" grid: "rlatu". + ! The values of "rlatu" are taken to be the centers of intervals. + + ! We assume that in the input file: + + ! -- Latitude is in degrees. + + ! -- Latitude and pressure are strictly monotonic (as all NetCDF + ! coordinate variables should be). + + ! -- The time coordinate is in ascending order (even though we do + ! not use its values). + ! The input file may contain either values for 12 months or values + ! for 14 months. + ! If there are 14 months then we assume that we have (in that order): + ! December, January, February, ..., November, December, January + + ! -- Missing values are contiguous, at the bottom of + ! the vertical domain and at the latitudinal boundaries. + + ! If values are all missing at a given latitude and date, then we + ! replace those missing values by values at the closest latitude, + ! equatorward, with valid values. + ! Then, at each latitude and each date, the missing values are replaced + ! by the lowest valid value above missing values. + + ! Regridding in time is by linear interpolation. + ! Monthly values are processed to get daily values, on the basis + ! of a 360-day calendar. + ! If there are 14 months, we use the first December value to + ! interpolate values between January 1st and mid-January. + ! We use the last January value to interpolate values between + ! mid-December and end of December. + ! If there are only 12 months in the input file then we assume + ! periodicity for interpolation at the beginning and at the end of the + ! year. + + use mod_grid_phy_lmdz, ONLY : nbp_lat + use regr1_conserv_m, only: regr1_conserv + use regr3_lint_m, only: regr3_lint + use netcdf95, only: handle_err, nf95_close, nf95_get_att, nf95_gw_var, & + nf95_inq_dimid, nf95_inq_varid, nf95_inquire_dimension, nf95_open, & + nf95_put_var + use netcdf, only: nf90_get_att, nf90_get_var, nf90_noerr, nf90_nowrite + use assert_m, only: assert + use regular_lonlat_mod, only : boundslat_reg, south + use nrtype, only: pi + use slopes_m, only: slopes + + integer, intent(in):: read_climoz ! read ozone climatology + ! Allowed values are 1 and 2 + ! 1: read a single ozone climatology that will be used day and night + ! 2: read two ozone climatologies, the average day and night + ! climatology and the daylight climatology + + ! Variables local to the procedure: + + integer n_plev ! number of pressure levels in the input data + integer n_lat ! number of latitudes in the input data + integer n_month ! number of months in the input data + + real, pointer:: latitude(:) + ! (of input data, converted to rad, sorted in strictly ascending order) + + real, allocatable:: sin_lat_in_edg(:) + ! (sine of edges of latitude intervals for input data, in rad, in strictly + ! ascending order) + + real, pointer:: plev(:) + ! pressure levels of input data, sorted in strictly ascending + ! order, converted to hPa + + logical desc_lat ! latitude in descending order in the input file + logical desc_plev ! pressure levels in descending order in the input file + + real, allocatable:: o3_in(:, :, :, :) + ! (n_lat, n_plev, n_month, read_climoz) + ! ozone climatologies from the input file + ! "o3_in(j, k, :, :)" is at latitude "latitude(j)" and pressure + ! level "plev(k)". + ! Third dimension is month index, first value may be December or January. + ! "o3_in(:, :, :, 1)" is for the day- night average, "o3_in(:, :, :, 2)" + ! is for daylight. + + real missing_value + + real, allocatable:: o3_regr_lat(:, :, :, :) + ! (nbp_lat, n_plev, 0:13, read_climoz) + ! mean of "o3_in" over a latitude interval of LMDZ + ! First dimension is latitude interval. + ! The latitude interval for "o3_regr_lat(j,:, :, :)" contains "rlatu(j)". + ! If "j" is between 2 and "nbp_lat - 1" then the interval is: + ! [rlatv(j), rlatv(j-1)] + ! If "j" is 1 or "nbp_lat" then the interval is: + ! [rlatv(1), pi / 2] + ! or: + ! [- pi / 2, rlatv(nbp_lat - 1)] + ! respectively. + ! "o3_regr_lat(:, k, :, :)" is for pressure level "plev(k)". + ! Third dimension is month number, 1 for January. + ! "o3_regr_lat(:, :, :, 1)" is average day and night, + ! "o3_regr_lat(:, :, :, 2)" is for daylight. + + real, allocatable:: o3_out(:, :, :, :) + ! (nbp_lat, n_plev, 360, read_climoz) + ! regridded ozone climatology + ! "o3_out(j, k, l, :)" is at latitude "rlatu(j)", pressure + ! level "plev(k)" and date "January 1st 0h" + "tmidday(l)", in a + ! 360-day calendar. + ! "o3_out(:, :, :, 1)" is average day and night, + ! "o3_out(:, :, :, 2)" is for daylight. + + integer j, k, l,m + + ! For NetCDF: + integer ncid_in, ncid_out ! IDs for input and output files + integer varid_plev, varid_time, varid, ncerr, dimid + character(len=80) press_unit ! pressure unit + + integer varid_in(read_climoz), varid_out(read_climoz) + ! index 1 is for average ozone day and night, index 2 is for + ! daylight ozone. + + real, parameter:: tmidmonth(0:13) = (/(-15. + 30. * l, l = 0, 13)/) + ! (time to middle of month, in days since January 1st 0h, in a + ! 360-day calendar) + ! (We add values -15 and 375 so that, for example, day 3 of the year is + ! interpolated between the December and the January value.) + + real, parameter:: tmidday(360) = (/(l + 0.5, l = 0, 359)/) + ! (time to middle of day, in days since January 1st 0h, in a + ! 360-day calendar) + + !--------------------------------- + + print *, "Call sequence information: regr_lat_time_climoz" + call assert(read_climoz == 1 .or. read_climoz == 2, "regr_lat_time_climoz") + + call nf95_open("climoz.nc", nf90_nowrite, ncid_in) + + ! Get coordinates from the input file: + + call nf95_inq_varid(ncid_in, "latitude", varid) + call nf95_gw_var(ncid_in, varid, latitude) + ! Convert from degrees to rad, because we will take the sine of latitude: + latitude = latitude / 180. * pi + n_lat = size(latitude) + ! We need to supply the latitudes to "regr1_conserv" in + ! ascending order, so invert order if necessary: + desc_lat = latitude(1) > latitude(n_lat) + if (desc_lat) latitude = latitude(n_lat:1:-1) + + ! Compute edges of latitude intervals: + allocate(sin_lat_in_edg(n_lat + 1)) + sin_lat_in_edg(1) = - 1. + forall (j = 2:n_lat) sin_lat_in_edg(j) = sin((latitude(j - 1) & + + latitude(j)) / 2.) + sin_lat_in_edg(n_lat + 1) = 1. + deallocate(latitude) ! pointer + + call nf95_inq_varid(ncid_in, "plev", varid) + call nf95_gw_var(ncid_in, varid, plev) + n_plev = size(plev) + ! We only need the pressure coordinate to copy it to the output file. + ! The program "gcm" will assume that pressure levels are in + ! ascending order in the regridded climatology so invert order if + ! necessary: + desc_plev = plev(1) > plev(n_plev) + if (desc_plev) plev = plev(n_plev:1:-1) + call nf95_get_att(ncid_in, varid, "units", press_unit) + if (press_unit == "Pa") then + ! Convert to hPa: + plev = plev / 100. + elseif (press_unit /= "hPa") then + print *, "regr_lat_time_climoz: the only recognized units are Pa " & + // "and hPa." + stop 1 + end if + + ! Create the output file and get the variable IDs: + call prepare_out(ncid_in, n_plev, ncid_out, varid_out, varid_plev, & + varid_time) + + ! Write remaining coordinate variables: + call nf95_put_var(ncid_out, varid_plev, plev) + call nf95_put_var(ncid_out, varid_time, tmidday) + + deallocate(plev) ! pointer + + ! Get the number of months: + call nf95_inq_dimid(ncid_in, "time", dimid) + call nf95_inquire_dimension(ncid_in, dimid, nclen=n_month) + + allocate(o3_in(n_lat, n_plev, n_month, read_climoz)) + + call nf95_inq_varid(ncid_in, "tro3", varid_in(1)) + ncerr = nf90_get_var(ncid_in, varid_in(1), o3_in(:, :, :, 1)) + call handle_err("regr_lat_time_climoz nf90_get_var tro3", ncerr, ncid_in) + + if (read_climoz == 2) then + call nf95_inq_varid(ncid_in, "tro3_daylight", varid_in(2)) + ncerr = nf90_get_var(ncid_in, varid_in(2), o3_in(:, :, :, 2)) + call handle_err("regr_lat_time_climoz nf90_get_var tro3_daylight", & + ncerr, ncid_in, varid_in(2)) + end if + + if (desc_lat) o3_in = o3_in(n_lat:1:-1, :, :, :) + if (desc_plev) o3_in = o3_in(:, n_plev:1:-1, :, :) + + do m = 1, read_climoz + ncerr = nf90_get_att(ncid_in, varid_in(m), "missing_value", & + missing_value) + if (ncerr == nf90_noerr) then + do l = 1, n_month + ! Take care of latitudes where values are all missing: + + ! Next to the south pole: + j = 1 + do while (o3_in(j, 1, l, m) == missing_value) + j = j + 1 + end do + if (j > 1) o3_in(:j-1, :, l, m) = & + spread(o3_in(j, :, l, m), dim=1, ncopies=j-1) + + ! Next to the north pole: + j = n_lat + do while (o3_in(j, 1, l, m) == missing_value) + j = j - 1 + end do + if (j < n_lat) o3_in(j+1:, :, l, m) = & + spread(o3_in(j, :, l, m), dim=1, ncopies=n_lat-j) + + ! Take care of missing values at high pressure: + do j = 1, n_lat + ! Find missing values, starting from top of atmosphere + ! and going down. + ! We have already taken care of latitudes full of + ! missing values so the highest level has a valid value. + k = 2 + do while (o3_in(j, k, l, m) /= missing_value .and. k < n_plev) + k = k + 1 + end do + ! Replace missing values with the valid value at the + ! lowest level above missing values: + if (o3_in(j, k, l, m) == missing_value) & + o3_in(j, k:n_plev, l, m) = o3_in(j, k-1, l, m) + end do + end do + else + print *, "regr_lat_time_climoz: field ", m, & + ", no missing value attribute" + end if + end do + + call nf95_close(ncid_in) + + allocate(o3_regr_lat(nbp_lat, n_plev, 0:13, read_climoz)) + allocate(o3_out(nbp_lat, n_plev, 360, read_climoz)) + + ! Regrid in latitude: + ! We average with respect to sine of latitude, which is + ! equivalent to weighting by cosine of latitude: + if (n_month == 12) then + print *, & + "Found 12 months in ozone climatologies, assuming periodicity..." + call regr1_conserv(o3_in, xs = sin_lat_in_edg, & + xt = (/- 1., sin(boundslat_reg(nbp_lat - 1:1:- 1, south)), 1./), & + vt = o3_regr_lat(nbp_lat:1:- 1, :, 1:12, :), & + slope = slopes(o3_in, sin_lat_in_edg)) + ! (invert order of indices in "o3_regr_lat" because "rlatu" is + ! in descending order) + + ! Duplicate January and December values, in preparation of time + ! interpolation: + o3_regr_lat(:, :, 0, :) = o3_regr_lat(:, :, 12, :) + o3_regr_lat(:, :, 13, :) = o3_regr_lat(:, :, 1, :) + else + print *, "Using 14 months in ozone climatologies..." + call regr1_conserv(o3_in, xs = sin_lat_in_edg, & + xt = (/- 1., sin(boundslat_reg(nbp_lat - 1:1:- 1, south)), 1./), & + vt = o3_regr_lat(nbp_lat:1:- 1, :, :, :), & + slope = slopes(o3_in, sin_lat_in_edg)) + ! (invert order of indices in "o3_regr_lat" because "rlatu" is + ! in descending order) + end if + + ! Regrid in time by linear interpolation: + o3_out = regr3_lint(o3_regr_lat, tmidmonth, tmidday) + + ! Write to file: + do m = 1, read_climoz + call nf95_put_var(ncid_out, varid_out(m), o3_out(nbp_lat:1:-1, :, :, m)) + ! (The order of "rlatu" is inverted in the output file) + end do + + call nf95_close(ncid_out) + + end subroutine regr_lat_time_climoz + + !******************************************** + + subroutine prepare_out(ncid_in, n_plev, ncid_out, varid_out, varid_plev, & + varid_time) + + ! This subroutine creates the NetCDF output file, defines + ! dimensions and variables, and writes one of the coordinate variables. + + use mod_grid_phy_lmdz, ONLY : nbp_lat + use netcdf95, only: nf95_create, nf95_def_dim, nf95_def_var, & + nf95_put_att, nf95_enddef, nf95_copy_att, nf95_put_var + use netcdf, only: nf90_clobber, nf90_float, nf90_global + use nrtype, only: pi + use regular_lonlat_mod, only : lat_reg + + integer, intent(in):: ncid_in, n_plev + integer, intent(out):: ncid_out, varid_plev, varid_time + + integer, intent(out):: varid_out(:) ! dim(1 or 2) + ! "varid_out(1)" is for average ozone day and night, + ! "varid_out(2)" is for daylight ozone. + + ! Variables local to the procedure: + + integer ncerr + integer dimid_rlatu, dimid_plev, dimid_time + integer varid_rlatu + + !--------------------------- + + print *, "Call sequence information: prepare_out" + + call nf95_create("climoz_LMDZ.nc", nf90_clobber, ncid_out) + + ! Dimensions: + call nf95_def_dim(ncid_out, "time", 360, dimid_time) + call nf95_def_dim(ncid_out, "plev", n_plev, dimid_plev) + call nf95_def_dim(ncid_out, "rlatu", nbp_lat, dimid_rlatu) + + ! Define coordinate variables: + + call nf95_def_var(ncid_out, "time", nf90_float, dimid_time, varid_time) + call nf95_put_att(ncid_out, varid_time, "units", "days since 2000-1-1") + call nf95_put_att(ncid_out, varid_time, "calendar", "360_day") + call nf95_put_att(ncid_out, varid_time, "standard_name", "time") + + call nf95_def_var(ncid_out, "plev", nf90_float, dimid_plev, varid_plev) + call nf95_put_att(ncid_out, varid_plev, "units", "millibar") + call nf95_put_att(ncid_out, varid_plev, "standard_name", "air_pressure") + call nf95_put_att(ncid_out, varid_plev, "long_name", "air pressure") + + call nf95_def_var(ncid_out, "rlatu", nf90_float, dimid_rlatu, varid_rlatu) + call nf95_put_att(ncid_out, varid_rlatu, "units", "degrees_north") + call nf95_put_att(ncid_out, varid_rlatu, "standard_name", "latitude") + + ! Define the primary variables: + + call nf95_def_var(ncid_out, "tro3", nf90_float, & + (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(1)) + call nf95_put_att(ncid_out, varid_out(1), "long_name", & + "ozone mole fraction") + call nf95_put_att(ncid_out, varid_out(1), "standard_name", & + "mole_fraction_of_ozone_in_air") + + if (size(varid_out) == 2) then + call nf95_def_var(ncid_out, "tro3_daylight", nf90_float, & + (/dimid_rlatu, dimid_plev, dimid_time/), varid_out(2)) + call nf95_put_att(ncid_out, varid_out(2), "long_name", & + "ozone mole fraction in daylight") + end if + + ! Global attributes: + + ! The following commands, copying attributes, may fail. + ! That is OK. + ! It should just mean that the attribute is not defined in the input file. + + call nf95_copy_att(ncid_in, nf90_global, "Conventions", ncid_out, & + nf90_global, ncerr) + call handle_err_copy_att("Conventions") + + call nf95_copy_att(ncid_in, nf90_global, "title", ncid_out, nf90_global, & + ncerr) + call handle_err_copy_att("title") + + call nf95_copy_att(ncid_in, nf90_global, "institution", ncid_out, & + nf90_global, ncerr) + call handle_err_copy_att("institution") + + call nf95_copy_att(ncid_in, nf90_global, "source", ncid_out, nf90_global, & + ncerr) + call handle_err_copy_att("source") + + call nf95_put_att(ncid_out, nf90_global, "comment", "Regridded for LMDZ") + + call nf95_enddef(ncid_out) + + ! Write one of the coordinate variables: + call nf95_put_var(ncid_out, varid_rlatu, lat_reg(nbp_lat:1:-1) / pi * 180.) + ! (convert from rad to degrees and sort in ascending order) + + contains + + subroutine handle_err_copy_att(att_name) + + use netcdf, only: nf90_noerr, nf90_strerror + + character(len=*), intent(in):: att_name + + !---------------------------------------- + + if (ncerr /= nf90_noerr) then + print *, "regr_lat_time_climoz_m prepare_out nf95_copy_att " & + // att_name // " -- " // trim(nf90_strerror(ncerr)) + end if + + end subroutine handle_err_copy_att + + end subroutine prepare_out + +end module regr_lat_time_climoz_m Index: DZ6/trunk/libf/obsolete/regr_pr_av_m.F90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr_pr_av_m.F90 (revision 5311) +++ (revision ) @@ -1,124 +1,0 @@ -! $Id$ -module regr_pr_av_m - - ! Author: Lionel GUEZ - - implicit none - -contains - - subroutine regr_pr_av(ncid, name, julien, press_in_edg, paprs, v3) - - ! "regr_pr_av" stands for "regrid pressure averaging". - ! In this procedure: - ! -- the root process reads 2D latitude-pressure fields from a - ! NetCDF file, at a given day. - ! -- the fields are packed to the LMDZ horizontal "physics" - ! grid and scattered to all threads of all processes; - ! -- in all the threads of all the processes, the fields are regridded in - ! pressure to the LMDZ vertical grid. - ! We assume that, in the input file, the fields have 3 dimensions: - ! latitude, pressure, julian day. - ! We assume that the input fields are already on the "rlatu" - ! latitudes, except that latitudes are in ascending order in the input - ! file. - ! We assume that all the inputs fields have the same coordinates. - - ! The target vertical LMDZ grid is the grid of layer boundaries. - ! Regridding in pressure is conservative, second order. - - ! All the fields are regridded as a single multi-dimensional array - ! so it saves CPU time to call this procedure once for several NetCDF - ! variables rather than several times, each time for a single - ! NetCDF variable. - - use dimphy, only: klon - use netcdf95, only: nf95_inq_varid, handle_err - use netcdf, only: nf90_get_var - use assert_m, only: assert - use assert_eq_m, only: assert_eq - use regr1_conserv_m, only: regr1_conserv - use slopes_m, only: slopes - use mod_phys_lmdz_mpi_data, only: is_mpi_root - use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, nbp_lev - use mod_phys_lmdz_transfert_para, only: scatter2d - ! (pack to the LMDZ horizontal "physics" grid and scatter) - - integer, intent(in):: ncid ! NetCDF ID of the file - character(len=*), intent(in):: name(:) ! of the NetCDF variables - integer, intent(in):: julien ! jour julien, 1 <= julien <= 360 - - real, intent(in):: press_in_edg(:) - ! edges of pressure intervals for input data, in Pa, in strictly - ! ascending order - - real, intent(in):: paprs(:, :) ! (klon, llm + 1) - ! (pression pour chaque inter-couche, en Pa) - - real, intent(out):: v3(:, :, :) ! (klon, llm, size(name)) - ! regridded fields on the partial "physics" grid - ! "v3(i, k, l)" is at longitude "xlon(i)", latitude - ! "xlat(i)", in pressure interval "[paprs(i, k+1), paprs(i, k)]", - ! for NetCDF variable "name(l)". - - ! Variables local to the procedure: - - integer varid, ncerr ! for NetCDF - - real v1(nbp_lon, nbp_lat, size(press_in_edg) - 1, size(name)) - ! input fields at day "julien", on the global "dynamics" horizontal grid - ! First dimension is for longitude. - ! The values are the same for all longitudes. - ! "v1(:, j, k, l)" is at latitude "rlatu(j)", for - ! pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and - ! NetCDF variable "name(l)". - - real v2(klon, size(press_in_edg) - 1, size(name)) - ! fields scattered to the partial "physics" horizontal grid - ! "v2(i, k, l)" is at longitude "xlon(i)", latitude "xlat(i)", - ! for pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and - ! NetCDF variable "name(l)". - - integer i, n_var - - !-------------------------------------------- - - call assert(size(v3, 1) == klon, size(v3, 2) == nbp_lev, & - "regr_pr_av v3 klon") - n_var = assert_eq(size(name), size(v3, 3), "regr_pr_av v3 n_var") - call assert(shape(paprs) == (/klon, nbp_lev+1/), "regr_pr_av paprs") - - !$omp master - if (is_mpi_root) then - do i = 1, n_var - call nf95_inq_varid(ncid, trim(name(i)), varid) - - ! Get data at the right day from the input file: - ncerr = nf90_get_var(ncid, varid, v1(1, :, :, i), & - start=(/1, 1, julien/)) - call handle_err("regr_pr_av nf90_get_var " // trim(name(i)), ncerr, & - ncid) - end do - - ! Latitudes are in ascending order in the input file while - ! "rlatu" is in descending order so we need to invert order: - v1(1, :, :, :) = v1(1, nbp_lat:1:-1, :, :) - - ! Duplicate on all longitudes: - v1(2:, :, :, :) = spread(v1(1, :, :, :), dim=1, ncopies=nbp_lon-1) - end if - !$omp end master - - call scatter2d(v1, v2) - - ! Regrid in pressure at each horizontal position: - do i = 1, klon - call regr1_conserv(v2(i, :, :), press_in_edg, & - paprs(i, nbp_lev + 1:1:-1), v3(i, nbp_lev:1:-1, :), & - slopes(v2(i, :, :), press_in_edg)) - ! (invert order of indices because "paprs" is in descending order) - end do - - end subroutine regr_pr_av - -end module regr_pr_av_m Index: /LMDZ6/trunk/libf/obsolete/regr_pr_av_m.f90 =================================================================== --- /LMDZ6/trunk/libf/obsolete/regr_pr_av_m.f90 (revision 5312) +++ /LMDZ6/trunk/libf/obsolete/regr_pr_av_m.f90 (revision 5312) @@ -0,0 +1,124 @@ +! $Id$ +module regr_pr_av_m + + ! Author: Lionel GUEZ + + implicit none + +contains + + subroutine regr_pr_av(ncid, name, julien, press_in_edg, paprs, v3) + + ! "regr_pr_av" stands for "regrid pressure averaging". + ! In this procedure: + ! -- the root process reads 2D latitude-pressure fields from a + ! NetCDF file, at a given day. + ! -- the fields are packed to the LMDZ horizontal "physics" + ! grid and scattered to all threads of all processes; + ! -- in all the threads of all the processes, the fields are regridded in + ! pressure to the LMDZ vertical grid. + ! We assume that, in the input file, the fields have 3 dimensions: + ! latitude, pressure, julian day. + ! We assume that the input fields are already on the "rlatu" + ! latitudes, except that latitudes are in ascending order in the input + ! file. + ! We assume that all the inputs fields have the same coordinates. + + ! The target vertical LMDZ grid is the grid of layer boundaries. + ! Regridding in pressure is conservative, second order. + + ! All the fields are regridded as a single multi-dimensional array + ! so it saves CPU time to call this procedure once for several NetCDF + ! variables rather than several times, each time for a single + ! NetCDF variable. + + use dimphy, only: klon + use netcdf95, only: nf95_inq_varid, handle_err + use netcdf, only: nf90_get_var + use assert_m, only: assert + use assert_eq_m, only: assert_eq + use regr1_conserv_m, only: regr1_conserv + use slopes_m, only: slopes + use mod_phys_lmdz_mpi_data, only: is_mpi_root + use mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, nbp_lev + use mod_phys_lmdz_transfert_para, only: scatter2d + ! (pack to the LMDZ horizontal "physics" grid and scatter) + + integer, intent(in):: ncid ! NetCDF ID of the file + character(len=*), intent(in):: name(:) ! of the NetCDF variables + integer, intent(in):: julien ! jour julien, 1 <= julien <= 360 + + real, intent(in):: press_in_edg(:) + ! edges of pressure intervals for input data, in Pa, in strictly + ! ascending order + + real, intent(in):: paprs(:, :) ! (klon, llm + 1) + ! (pression pour chaque inter-couche, en Pa) + + real, intent(out):: v3(:, :, :) ! (klon, llm, size(name)) + ! regridded fields on the partial "physics" grid + ! "v3(i, k, l)" is at longitude "xlon(i)", latitude + ! "xlat(i)", in pressure interval "[paprs(i, k+1), paprs(i, k)]", + ! for NetCDF variable "name(l)". + + ! Variables local to the procedure: + + integer varid, ncerr ! for NetCDF + + real v1(nbp_lon, nbp_lat, size(press_in_edg) - 1, size(name)) + ! input fields at day "julien", on the global "dynamics" horizontal grid + ! First dimension is for longitude. + ! The values are the same for all longitudes. + ! "v1(:, j, k, l)" is at latitude "rlatu(j)", for + ! pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and + ! NetCDF variable "name(l)". + + real v2(klon, size(press_in_edg) - 1, size(name)) + ! fields scattered to the partial "physics" horizontal grid + ! "v2(i, k, l)" is at longitude "xlon(i)", latitude "xlat(i)", + ! for pressure interval "[press_in_edg(k), press_in_edg(k+1)]" and + ! NetCDF variable "name(l)". + + integer i, n_var + + !-------------------------------------------- + + call assert(size(v3, 1) == klon, size(v3, 2) == nbp_lev, & + "regr_pr_av v3 klon") + n_var = assert_eq(size(name), size(v3, 3), "regr_pr_av v3 n_var") + call assert(shape(paprs) == (/klon, nbp_lev+1/), "regr_pr_av paprs") + + !$omp master + if (is_mpi_root) then + do i = 1, n_var + call nf95_inq_varid(ncid, trim(name(i)), varid) + + ! Get data at the right day from the input file: + ncerr = nf90_get_var(ncid, varid, v1(1, :, :, i), & + start=(/1, 1, julien/)) + call handle_err("regr_pr_av nf90_get_var " // trim(name(i)), ncerr, & + ncid) + end do + + ! Latitudes are in ascending order in the input file while + ! "rlatu" is in descending order so we need to invert order: + v1(1, :, :, :) = v1(1, nbp_lat:1:-1, :, :) + + ! Duplicate on all longitudes: + v1(2:, :, :, :) = spread(v1(1, :, :, :), dim=1, ncopies=nbp_lon-1) + end if + !$omp end master + + call scatter2d(v1, v2) + + ! Regrid in pressure at each horizontal position: + do i = 1, klon + call regr1_conserv(v2(i, :, :), press_in_edg, & + paprs(i, nbp_lev + 1:1:-1), v3(i, nbp_lev:1:-1, :), & + slopes(v2(i, :, :), press_in_edg)) + ! (invert order of indices because "paprs" is in descending order) + end do + + end subroutine regr_pr_av + +end module regr_pr_av_m Index: DZ6/trunk/libf/phydev/dimphy.F90 =================================================================== --- /LMDZ6/trunk/libf/phydev/dimphy.F90 (revision 5311) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/dimphy.F90 Index: /LMDZ6/trunk/libf/phydev/dimphy.f90 =================================================================== --- /LMDZ6/trunk/libf/phydev/dimphy.f90 (revision 5312) +++ /LMDZ6/trunk/libf/phydev/dimphy.f90 (revision 5312) @@ -0,0 +1,1 @@ +link ../phylmd/dimphy.f90 Index: DZ6/trunk/libf/phydev/iostart.F90 =================================================================== --- /LMDZ6/trunk/libf/phydev/iostart.F90 (revision 5311) +++ (revision ) @@ -1,1 +1,0 @@ -link ../phylmd/iostart.F90 Index: /LMDZ6/trunk/libf/phydev/iostart.f90 =================================================================== --- /LMDZ6/trunk/libf/phydev/iostart.f90 (revision 5312) +++ /LMDZ6/trunk/libf/phydev/iostart.f90 (revision 5312) @@ -0,0 +1,1 @@ +link ../phylmd/iostart.f90 Index: DZ6/trunk/libf/phylmd/cosp/mod_cosp_simulator.F90 =================================================================== --- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_simulator.F90 (revision 5311) +++ (revision ) @@ -1,247 +1,0 @@ -! (c) British Crown Copyright 2008, the Met Office. -! All rights reserved. -! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_simulator.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -! -! History: -! Jul 2007 - A. Bodas-Salcedo - Initial version -! Jan 2013 - G. Cesana - Add new variables linked to the lidar cloud phase -! - -INCLUDE "cosp_defs.h" -MODULE MOD_COSP_SIMULATOR - USE MOD_COSP_CONSTANTS, ONLY: I_RADAR, I_LIDAR, I_ISCCP, I_MISR, I_MODIS, & - I_RTTOV, I_STATS, tsim - USE MOD_COSP_TYPES - USE MOD_COSP_RADAR - USE MOD_COSP_LIDAR - USE MOD_COSP_ISCCP_SIMULATOR - USE MOD_COSP_MODIS_SIMULATOR - USE MOD_COSP_MISR_SIMULATOR -!#ifdef RTTOV -! USE MOD_COSP_RTTOV_SIMULATOR -!#endif - USE MOD_COSP_STATS - IMPLICIT NONE - -CONTAINS - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!--------------------- SUBROUTINE COSP_SIMULATOR ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!#ifdef RTTOV -!SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) -!#else -SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) -!#endif - - ! Arguments - type(cosp_gridbox),intent(inout) :: gbx ! Grid-box inputs - type(cosp_subgrid),intent(in) :: sgx ! Subgrid inputs - type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors - type(cosp_config),intent(in) :: cfg ! Configuration options - type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats - type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator - type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator - type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator - type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator - type(cosp_modis),intent(inout) :: modis ! Output from MODIS simulator -!#ifdef RTTOV -! type(cosp_rttov),intent(inout) :: rttov ! Output from RTTOV -!#endif - type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator - type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator - ! Local variables - integer :: i,j,k,isim - logical :: inconsistent - ! Timing variables - integer :: t0,t1 - - t0 = 0 - t1 = 0 - - inconsistent=.false. -! do k=1,gbx%Nhydro -! do j=1,gbx%Nlevels -! do i=1,gbx%Npoints -! if ((gbx%mr_hydro(i,j,k)>0.0).and.(gbx%Reff(i,j,k)<=0.0)) inconsistent=.true. -! enddo -! enddo -! enddo -! if (inconsistent) print *, '%%%% COSP_SIMULATOR: inconsistency in mr_hydro and Reff' - - - !+++++++++ Radar model ++++++++++ - isim = I_RADAR - if (cfg%Lradar_sim) then - call system_clock(t0) - call cosp_radar(gbx,sgx,sghydro,sgradar) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ Lidar model ++++++++++ - isim = I_LIDAR - if (cfg%Llidar_sim) then - call system_clock(t0) - call cosp_lidar(gbx,sgx,sghydro,sglidar) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ ISCCP simulator ++++++++++ - isim = I_ISCCP - if (cfg%Lisccp_sim) then - call system_clock(t0) - call cosp_isccp_simulator(gbx,sgx,isccp) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ MISR simulator ++++++++++ - isim = I_MISR - if (cfg%Lmisr_sim) then - call system_clock(t0) - call cosp_misr_simulator(gbx,sgx,misr) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ MODIS simulator ++++++++++ - isim = I_MODIS - if (cfg%Lmodis_sim) then - call system_clock(t0) - call cosp_modis_simulator(gbx,sgx,sghydro,isccp, modis) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ RTTOV ++++++++++ - isim = I_RTTOV -!#ifdef RTTOV -! if (cfg%Lrttov_sim) then -! call system_clock(t0) -! call cosp_rttov_simulator(gbx,rttov) -! call system_clock(t1) -! tsim(isim) = tsim(isim) + (t1 -t0) -! endif -!#endif - - !+++++++++++ Summary statistics +++++++++++ - isim = I_STATS - if (cfg%Lstats) then - call system_clock(t0) - call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++++ Change of units after computation of statistics +++++++++++ - ! This avoids using UDUNITS in CMOR - - ! Cloud fractions from 1 to % -! if (cfg%Lclcalipso) then -! where(stlidar%lidarcld /= R_UNDEF) stlidar%lidarcld = stlidar%lidarcld*100.0 -! endif -! if (cfg%Lcltcalipso.OR.cfg%Lcllcalipso.OR.cfg%Lclmcalipso.OR.cfg%Lclhcalipso) then -! where(stlidar%cldlayer /= R_UNDEF) stlidar%cldlayer = stlidar%cldlayer*100.0 -! endif - if (cfg%Lclcalipso2) then - where(stradar%lidar_only_freq_cloud /= R_UNDEF) stradar%lidar_only_freq_cloud = stradar%lidar_only_freq_cloud*100.0 - endif - - if (cfg%Lcltcalipsoliq.OR.cfg%Lcllcalipsoliq.OR.cfg%Lclmcalipsoliq.OR.cfg%Lclhcalipsoliq.OR. & - cfg%Lcltcalipsoice.OR.cfg%Lcllcalipsoice.OR.cfg%Lclmcalipsoice.OR.cfg%Lclhcalipsoice.OR. & - cfg%Lcltcalipsoun.OR.cfg%Lcllcalipsoun.OR.cfg%Lclmcalipsoun.OR.cfg%Lclhcalipsoun ) then - where(stlidar%cldlayerphase /= R_UNDEF) stlidar%cldlayerphase = stlidar%cldlayerphase*100.0 - endif - if (cfg%Lclcalipsoliq.OR.cfg%Lclcalipsoice.OR.cfg%Lclcalipsoun) then - where(stlidar%lidarcldphase /= R_UNDEF) stlidar%lidarcldphase = stlidar%lidarcldphase*100.0 - endif - if (cfg%Lclcalipsotmp.OR.cfg%Lclcalipsotmpliq.OR.cfg%Lclcalipsotmpice.OR.cfg%Lclcalipsotmpun) then - where(stlidar%lidarcldtmp /= R_UNDEF) stlidar%lidarcldtmp = stlidar%lidarcldtmp*100.0 - endif - - if (cfg%Lcltisccp) then - where(isccp%totalcldarea /= R_UNDEF) isccp%totalcldarea = isccp%totalcldarea*100.0 - endif - if (cfg%Lclisccp) then - where(isccp%fq_isccp /= R_UNDEF) isccp%fq_isccp = isccp%fq_isccp*100.0 - endif - - if (cfg%LclMISR) then - where(misr%fq_MISR /= R_UNDEF) misr%fq_MISR = misr%fq_MISR*100.0 - endif - - if (cfg%Lcltlidarradar) then - where(stradar%radar_lidar_tcc /= R_UNDEF) stradar%radar_lidar_tcc = stradar%radar_lidar_tcc*100.0 - endif - - if (cfg%Lclmodis) then - where(modis%Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) modis%Optical_Thickness_vs_Cloud_Top_Pressure = & - modis%Optical_Thickness_vs_Cloud_Top_Pressure*100.0 - endif - if (cfg%Lcrimodis) then - where(modis%Optical_Thickness_vs_ReffICE /= R_UNDEF) modis%Optical_Thickness_vs_ReffICE = & - modis%Optical_Thickness_vs_ReffICE*100.0 - endif - if (cfg%Lcrlmodis) then - where(modis%Optical_Thickness_vs_ReffLIQ /= R_UNDEF) modis%Optical_Thickness_vs_ReffLIQ = & - modis%Optical_Thickness_vs_ReffLIQ*100.0 - endif - - if (cfg%Lcltmodis) then - where(modis%Cloud_Fraction_Total_Mean /= R_UNDEF) modis%Cloud_Fraction_Total_Mean = modis%Cloud_Fraction_Total_Mean*100.0 - endif - if (cfg%Lclwmodis) then - where(modis%Cloud_Fraction_Water_Mean /= R_UNDEF) modis%Cloud_Fraction_Water_Mean = modis%Cloud_Fraction_Water_Mean*100.0 - endif - if (cfg%Lclimodis) then - where(modis%Cloud_Fraction_Ice_Mean /= R_UNDEF) modis%Cloud_Fraction_Ice_Mean = modis%Cloud_Fraction_Ice_Mean*100.0 - endif - - if (cfg%Lclhmodis) then - where(modis%Cloud_Fraction_High_Mean /= R_UNDEF) modis%Cloud_Fraction_High_Mean = modis%Cloud_Fraction_High_Mean*100.0 - endif - if (cfg%Lclmmodis) then - where(modis%Cloud_Fraction_Mid_Mean /= R_UNDEF) modis%Cloud_Fraction_Mid_Mean = modis%Cloud_Fraction_Mid_Mean*100.0 - endif - if (cfg%Lcllmodis) then - where(modis%Cloud_Fraction_Low_Mean /= R_UNDEF) modis%Cloud_Fraction_Low_Mean = modis%Cloud_Fraction_Low_Mean*100.0 - endif - - ! Change pressure from hPa to Pa. - if (cfg%Lboxptopisccp) then - where(isccp%boxptop /= R_UNDEF) isccp%boxptop = isccp%boxptop*100.0 - endif - if (cfg%Lpctisccp) then - where(isccp%meanptop /= R_UNDEF) isccp%meanptop = isccp%meanptop*100.0 - endif - - -END SUBROUTINE COSP_SIMULATOR - -END MODULE MOD_COSP_SIMULATOR Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_simulator.f90 =================================================================== --- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_simulator.f90 (revision 5312) +++ /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_simulator.f90 (revision 5312) @@ -0,0 +1,247 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_simulator.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jan 2013 - G. Cesana - Add new variables linked to the lidar cloud phase +! + +INCLUDE "cosp_defs.h" +MODULE MOD_COSP_SIMULATOR + USE MOD_COSP_CONSTANTS, ONLY: I_RADAR, I_LIDAR, I_ISCCP, I_MISR, I_MODIS, & + I_RTTOV, I_STATS, tsim + USE MOD_COSP_TYPES + USE MOD_COSP_RADAR + USE MOD_COSP_LIDAR + USE MOD_COSP_ISCCP_SIMULATOR + USE MOD_COSP_MODIS_SIMULATOR + USE MOD_COSP_MISR_SIMULATOR +!#ifdef RTTOV +! USE MOD_COSP_RTTOV_SIMULATOR +!#endif + USE MOD_COSP_STATS + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP_SIMULATOR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!#ifdef RTTOV +!SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) +!#else +SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) +!#endif + + ! Arguments + type(cosp_gridbox),intent(inout) :: gbx ! Grid-box inputs + type(cosp_subgrid),intent(in) :: sgx ! Subgrid inputs + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_modis),intent(inout) :: modis ! Output from MODIS simulator +!#ifdef RTTOV +! type(cosp_rttov),intent(inout) :: rttov ! Output from RTTOV +!#endif + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + ! Local variables + integer :: i,j,k,isim + logical :: inconsistent + ! Timing variables + integer :: t0,t1 + + t0 = 0 + t1 = 0 + + inconsistent=.false. +! do k=1,gbx%Nhydro +! do j=1,gbx%Nlevels +! do i=1,gbx%Npoints +! if ((gbx%mr_hydro(i,j,k)>0.0).and.(gbx%Reff(i,j,k)<=0.0)) inconsistent=.true. +! enddo +! enddo +! enddo +! if (inconsistent) print *, '%%%% COSP_SIMULATOR: inconsistency in mr_hydro and Reff' + + + !+++++++++ Radar model ++++++++++ + isim = I_RADAR + if (cfg%Lradar_sim) then + call system_clock(t0) + call cosp_radar(gbx,sgx,sghydro,sgradar) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ Lidar model ++++++++++ + isim = I_LIDAR + if (cfg%Llidar_sim) then + call system_clock(t0) + call cosp_lidar(gbx,sgx,sghydro,sglidar) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ ISCCP simulator ++++++++++ + isim = I_ISCCP + if (cfg%Lisccp_sim) then + call system_clock(t0) + call cosp_isccp_simulator(gbx,sgx,isccp) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ MISR simulator ++++++++++ + isim = I_MISR + if (cfg%Lmisr_sim) then + call system_clock(t0) + call cosp_misr_simulator(gbx,sgx,misr) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ MODIS simulator ++++++++++ + isim = I_MODIS + if (cfg%Lmodis_sim) then + call system_clock(t0) + call cosp_modis_simulator(gbx,sgx,sghydro,isccp, modis) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ RTTOV ++++++++++ + isim = I_RTTOV +!#ifdef RTTOV +! if (cfg%Lrttov_sim) then +! call system_clock(t0) +! call cosp_rttov_simulator(gbx,rttov) +! call system_clock(t1) +! tsim(isim) = tsim(isim) + (t1 -t0) +! endif +!#endif + + !+++++++++++ Summary statistics +++++++++++ + isim = I_STATS + if (cfg%Lstats) then + call system_clock(t0) + call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++++ Change of units after computation of statistics +++++++++++ + ! This avoids using UDUNITS in CMOR + + ! Cloud fractions from 1 to % +! if (cfg%Lclcalipso) then +! where(stlidar%lidarcld /= R_UNDEF) stlidar%lidarcld = stlidar%lidarcld*100.0 +! endif +! if (cfg%Lcltcalipso.OR.cfg%Lcllcalipso.OR.cfg%Lclmcalipso.OR.cfg%Lclhcalipso) then +! where(stlidar%cldlayer /= R_UNDEF) stlidar%cldlayer = stlidar%cldlayer*100.0 +! endif + if (cfg%Lclcalipso2) then + where(stradar%lidar_only_freq_cloud /= R_UNDEF) stradar%lidar_only_freq_cloud = stradar%lidar_only_freq_cloud*100.0 + endif + + if (cfg%Lcltcalipsoliq.OR.cfg%Lcllcalipsoliq.OR.cfg%Lclmcalipsoliq.OR.cfg%Lclhcalipsoliq.OR. & + cfg%Lcltcalipsoice.OR.cfg%Lcllcalipsoice.OR.cfg%Lclmcalipsoice.OR.cfg%Lclhcalipsoice.OR. & + cfg%Lcltcalipsoun.OR.cfg%Lcllcalipsoun.OR.cfg%Lclmcalipsoun.OR.cfg%Lclhcalipsoun ) then + where(stlidar%cldlayerphase /= R_UNDEF) stlidar%cldlayerphase = stlidar%cldlayerphase*100.0 + endif + if (cfg%Lclcalipsoliq.OR.cfg%Lclcalipsoice.OR.cfg%Lclcalipsoun) then + where(stlidar%lidarcldphase /= R_UNDEF) stlidar%lidarcldphase = stlidar%lidarcldphase*100.0 + endif + if (cfg%Lclcalipsotmp.OR.cfg%Lclcalipsotmpliq.OR.cfg%Lclcalipsotmpice.OR.cfg%Lclcalipsotmpun) then + where(stlidar%lidarcldtmp /= R_UNDEF) stlidar%lidarcldtmp = stlidar%lidarcldtmp*100.0 + endif + + if (cfg%Lcltisccp) then + where(isccp%totalcldarea /= R_UNDEF) isccp%totalcldarea = isccp%totalcldarea*100.0 + endif + if (cfg%Lclisccp) then + where(isccp%fq_isccp /= R_UNDEF) isccp%fq_isccp = isccp%fq_isccp*100.0 + endif + + if (cfg%LclMISR) then + where(misr%fq_MISR /= R_UNDEF) misr%fq_MISR = misr%fq_MISR*100.0 + endif + + if (cfg%Lcltlidarradar) then + where(stradar%radar_lidar_tcc /= R_UNDEF) stradar%radar_lidar_tcc = stradar%radar_lidar_tcc*100.0 + endif + + if (cfg%Lclmodis) then + where(modis%Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) modis%Optical_Thickness_vs_Cloud_Top_Pressure = & + modis%Optical_Thickness_vs_Cloud_Top_Pressure*100.0 + endif + if (cfg%Lcrimodis) then + where(modis%Optical_Thickness_vs_ReffICE /= R_UNDEF) modis%Optical_Thickness_vs_ReffICE = & + modis%Optical_Thickness_vs_ReffICE*100.0 + endif + if (cfg%Lcrlmodis) then + where(modis%Optical_Thickness_vs_ReffLIQ /= R_UNDEF) modis%Optical_Thickness_vs_ReffLIQ = & + modis%Optical_Thickness_vs_ReffLIQ*100.0 + endif + + if (cfg%Lcltmodis) then + where(modis%Cloud_Fraction_Total_Mean /= R_UNDEF) modis%Cloud_Fraction_Total_Mean = modis%Cloud_Fraction_Total_Mean*100.0 + endif + if (cfg%Lclwmodis) then + where(modis%Cloud_Fraction_Water_Mean /= R_UNDEF) modis%Cloud_Fraction_Water_Mean = modis%Cloud_Fraction_Water_Mean*100.0 + endif + if (cfg%Lclimodis) then + where(modis%Cloud_Fraction_Ice_Mean /= R_UNDEF) modis%Cloud_Fraction_Ice_Mean = modis%Cloud_Fraction_Ice_Mean*100.0 + endif + + if (cfg%Lclhmodis) then + where(modis%Cloud_Fraction_High_Mean /= R_UNDEF) modis%Cloud_Fraction_High_Mean = modis%Cloud_Fraction_High_Mean*100.0 + endif + if (cfg%Lclmmodis) then + where(modis%Cloud_Fraction_Mid_Mean /= R_UNDEF) modis%Cloud_Fraction_Mid_Mean = modis%Cloud_Fraction_Mid_Mean*100.0 + endif + if (cfg%Lcllmodis) then + where(modis%Cloud_Fraction_Low_Mean /= R_UNDEF) modis%Cloud_Fraction_Low_Mean = modis%Cloud_Fraction_Low_Mean*100.0 + endif + + ! Change pressure from hPa to Pa. + if (cfg%Lboxptopisccp) then + where(isccp%boxptop /= R_UNDEF) isccp%boxptop = isccp%boxptop*100.0 + endif + if (cfg%Lpctisccp) then + where(isccp%meanptop /= R_UNDEF) isccp%meanptop = isccp%meanptop*100.0 + endif + + +END SUBROUTINE COSP_SIMULATOR + +END MODULE MOD_COSP_SIMULATOR Index: DZ6/trunk/libf/phylmd/cosp/mod_cosp_stats.F90 =================================================================== --- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_stats.F90 (revision 5311) +++ (revision ) @@ -1,304 +1,0 @@ -! (c) British Crown Copyright 2008, the Met Office. -! All rights reserved. -! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_stats.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -! -! History: -! Jul 2007 - A. Bodas-Salcedo - Initial version -! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid -! Oct 2008 - J.-L. Dufresne - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns in COSP_STATS -! Oct 2008 - H. Chepfer - Added PARASOL reflectance arguments -! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations -! Jan 2013 - G. Cesana - Added betaperp and temperature arguments -! - Added phase 3D/3Dtemperature/Map output variables in diag_lidar -! -! -INCLUDE "cosp_defs.h" -MODULE MOD_COSP_STATS - USE MOD_COSP_CONSTANTS - USE MOD_COSP_TYPES - USE MOD_LLNL_STATS - USE MOD_LMD_IPSL_STATS - IMPLICIT NONE - -CONTAINS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------- SUBROUTINE COSP_STATS ------------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_STATS(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) - - ! Input arguments - type(cosp_gridbox),intent(in) :: gbx - type(cosp_subgrid),intent(in) :: sgx - type(cosp_config),intent(in) :: cfg - type(cosp_sgradar),intent(in) :: sgradar - type(cosp_sglidar),intent(in) :: sglidar - type(cosp_vgrid),intent(in) :: vgrid - ! Output arguments - type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics for radar - type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics for lidar - - ! Local variables - integer :: Npoints !# of grid points - integer :: Nlevels !# of levels - integer :: Nhydro !# of hydrometeors - integer :: Ncolumns !# of columns - integer :: Nlr - logical :: ok_lidar_cfad = .false. - real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out - real,dimension(:,:),allocatable :: ph_c,betamol_c - real,dimension(:,:,:),allocatable :: betaperptot_out, temp_in, temp_out - real,dimension(:,:),allocatable :: temp_c - - Npoints = gbx%Npoints - Nlevels = gbx%Nlevels - Nhydro = gbx%Nhydro - Ncolumns = gbx%Ncolumns - Nlr = vgrid%Nlvgrid - - if (cfg%LcfadLidarsr532) ok_lidar_cfad=.true. - - if (vgrid%use_vgrid) then ! Statistics in a different vertical grid - allocate(Ze_out(Npoints,Ncolumns,Nlr),betatot_out(Npoints,Ncolumns,Nlr), & - betamol_in(Npoints,1,Nlevels),betamol_out(Npoints,1,Nlr),betamol_c(Npoints,Nlr), & - ph_in(Npoints,1,Nlevels),ph_out(Npoints,1,Nlr),ph_c(Npoints,Nlr)) - Ze_out = 0.0 - betatot_out = 0.0 - betamol_out= 0.0 - betamol_c = 0.0 - ph_in(:,1,:) = gbx%ph(:,:) - ph_out = 0.0 - ph_c = 0.0 - allocate(betaperptot_out(Npoints,Ncolumns,Nlr),temp_in(Npoints,1,Nlevels),temp_out(Npoints,1,Nlr), & - temp_c(Npoints,Nlr)) - betaperptot_out = 0.0 - temp_in = 0.0 - temp_out = 0.0 - temp_c = 0.0 - - !++++++++++++ Radar CFAD ++++++++++++++++ - if (cfg%Lradar_sim) then - call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sgradar%Ze_tot, & - Nlr,vgrid%zl,vgrid%zu,Ze_out,log_units=.true.) - stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,Ze_out, & - DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) - endif - !++++++++++++ Lidar CFAD ++++++++++++++++ - if (cfg%Llidar_sim) then - betamol_in(:,1,:) = sglidar%beta_mol(:,:) - call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,betamol_in, & - Nlr,vgrid%zl,vgrid%zu,betamol_out) - call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, & - Nlr,vgrid%zl,vgrid%zu,betatot_out) - - temp_in(:,1,:) = gbx%T(:,:) - call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%betaperp_tot, & - Nlr,vgrid%zl,vgrid%zu,betaperptot_out) - call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,temp_in, & - Nlr,vgrid%zl,vgrid%zu,temp_out) - temp_c(:,:) = temp_out(:,1,:) - stlidar%proftemp = temp_c !TIBO - where (stlidar%proftemp < 150.) stlidar%proftemp = R_UNDEF !TIBO - where (stlidar%proftemp > 350.) stlidar%proftemp = R_UNDEF !TIBO - - call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, & - Nlr,vgrid%zl,vgrid%zu,ph_out) - ph_c(:,:) = ph_out(:,1,:) - betamol_c(:,:) = betamol_out(:,1,:) - ! Stats from lidar_stat_summary - call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & - ,temp_c,betatot_out,betaperptot_out,betamol_c,sglidar%refl,gbx%land,ph_c & - ,LIDAR_UNDEF,ok_lidar_cfad & - ,stlidar%cfad_sr,stlidar%srbval & - ,LIDAR_NCAT,LIDAR_NTYPE,stlidar%lidarcld,stlidar%lidarcldtype & !OPAQ - ,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldtype & !OPAQ - ,stlidar%cldlayerphase,stlidar%lidarcldtmp & !OPAQ - ,stlidar%parasolrefl,vgrid%z,stlidar%profSR) !OPAQ !TIBO - endif - - !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ - if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & - temp_c,betatot_out,betaperptot_out,betamol_c,Ze_out, & - stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) - deallocate(temp_in,temp_out,temp_c,betaperptot_out) !TIBO +temp_in - - ! Deallocate arrays at coarse resolution - deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c) - else ! Statistics in model levels - !++++++++++++ Radar CFAD ++++++++++++++++ - if (cfg%Lradar_sim) stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,sgradar%Ze_tot, & - DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) - !++++++++++++ Lidar CFAD ++++++++++++++++ - ! Stats from lidar_stat_summary - if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & - ,sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph & - ,LIDAR_UNDEF,ok_lidar_cfad & - ,stlidar%cfad_sr,stlidar%srbval & - ,LIDAR_NCAT,LIDAR_NTYPE,stlidar%lidarcld,stlidar%lidarcldtype & !OPAQ - ,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldtype & !OPAQ - ,stlidar%cldlayerphase,stlidar%lidarcldtmp & !OPAQ - ,stlidar%parasolrefl,vgrid%z,stlidar%profSR) !OPAQ !TIBO - !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ - if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & - sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sgradar%Ze_tot, & - stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) - endif - ! Replace undef - where (stlidar%cfad_sr == LIDAR_UNDEF) stlidar%cfad_sr = R_UNDEF - where (stlidar%profSR == LIDAR_UNDEF) stlidar%profSR = R_UNDEF !TIBO - where (stlidar%lidarcld == LIDAR_UNDEF) stlidar%lidarcld = R_UNDEF - where (stlidar%lidarcldtype == LIDAR_UNDEF) stlidar%lidarcldtype = R_UNDEF !OPAQ - where (stlidar%cldlayer == LIDAR_UNDEF) stlidar%cldlayer = R_UNDEF - where (stlidar%cldtype == LIDAR_UNDEF) stlidar%cldtype = R_UNDEF !OPAQ - where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF - where (stlidar%cldlayerphase == LIDAR_UNDEF) stlidar%cldlayerphase = R_UNDEF - where (stlidar%lidarcldphase == LIDAR_UNDEF) stlidar%lidarcldphase = R_UNDEF - where (stlidar%lidarcldtmp == LIDAR_UNDEF) stlidar%lidarcldtmp = R_UNDEF - -END SUBROUTINE COSP_STATS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ---------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,Nglevels,newgrid_bot,newgrid_top,r,log_units) - implicit none - ! Input arguments - integer,intent(in) :: Npoints !# of grid points - integer,intent(in) :: Nlevels !# of levels - integer,intent(in) :: Ncolumns !# of columns - real,dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer) - real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer) - real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y ! Variable to be changed to a different grid - integer,intent(in) :: Nglevels !# levels in the new grid - real,dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels [m] - real,dimension(Nglevels),intent(in) :: newgrid_top ! Upper boundary of new levels [m] - logical,optional,intent(in) :: log_units ! log units, need to convert to linear units - ! Output - real,dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid - - ! Local variables - integer :: i,j,k - logical :: lunits - integer :: l - real :: w ! Weight - real :: dbb, dtb, dbt, dtt ! Distances between edges of both grids - integer :: Nw ! Number of weights - real :: wt ! Sum of weights - real,dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid - real :: yp ! Local copy of y at a particular point. - ! This allows for change of units. - - lunits=.false. - if (present(log_units)) lunits=log_units - - r = 0.0 - - do i=1,Npoints - ! Calculate tops and bottoms of new and old grids - oldgrid_bot = zhalf(i,:) - oldgrid_top(1:Nlevels-1) = oldgrid_bot(2:Nlevels) - oldgrid_top(Nlevels) = zfull(i,Nlevels) + zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric - l = 0 ! Index of level in the old grid - ! Loop over levels in the new grid - do k = 1,Nglevels - Nw = 0 ! Number of weigths - wt = 0.0 ! Sum of weights - ! Loop over levels in the old grid and accumulate total for weighted average - do - l = l + 1 - w = 0.0 ! Initialise weight to 0 - ! Distances between edges of both grids - dbb = oldgrid_bot(l) - newgrid_bot(k) - dtb = oldgrid_top(l) - newgrid_bot(k) - dbt = oldgrid_bot(l) - newgrid_top(k) - dtt = oldgrid_top(l) - newgrid_top(k) - if (dbt >= 0.0) exit ! Do next level in the new grid - if (dtb > 0.0) then - if (dbb <= 0.0) then - if (dtt <= 0) then - w = dtb - else - w = newgrid_top(k) - newgrid_bot(k) - endif - else - if (dtt <= 0) then - w = oldgrid_top(l) - oldgrid_bot(l) - else - w = -dbt - endif - endif - ! If layers overlap (w/=0), then accumulate - if (w /= 0.0) then - Nw = Nw + 1 - wt = wt + w - do j=1,Ncolumns - if (lunits) then - if (y(i,j,l) /= R_UNDEF) then - yp = 10.0**(y(i,j,l)/10.0) - else - yp = 0.0 - endif - else - yp = y(i,j,l) - endif - r(i,j,k) = r(i,j,k) + w*yp - enddo - endif - endif - enddo - l = l - 2 - if (l < 1) l = 0 - ! Calculate average in new grid - if (Nw > 0) then - do j=1,Ncolumns - r(i,j,k) = r(i,j,k)/wt - enddo - endif - enddo - enddo - - ! Set points under surface to R_UNDEF, and change to dBZ if necessary - do k=1,Nglevels - do j=1,Ncolumns - do i=1,Npoints - if (newgrid_top(k) > zhalf(i,1)) then ! Level above model bottom level - if (lunits) then - if (r(i,j,k) <= 0.0) then - r(i,j,k) = R_UNDEF - else - r(i,j,k) = 10.0*log10(r(i,j,k)) - endif - endif - else ! Level below surface - r(i,j,k) = R_GROUND - endif - enddo - enddo - enddo - -END SUBROUTINE COSP_CHANGE_VERTICAL_GRID - -END MODULE MOD_COSP_STATS Index: /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_stats.f90 =================================================================== --- /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_stats.f90 (revision 5312) +++ /LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_stats.f90 (revision 5312) @@ -0,0 +1,304 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_stats.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid +! Oct 2008 - J.-L. Dufresne - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns in COSP_STATS +! Oct 2008 - H. Chepfer - Added PARASOL reflectance arguments +! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations +! Jan 2013 - G. Cesana - Added betaperp and temperature arguments +! - Added phase 3D/3Dtemperature/Map output variables in diag_lidar +! +! +INCLUDE "cosp_defs.h" +MODULE MOD_COSP_STATS + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_LLNL_STATS + USE MOD_LMD_IPSL_STATS + IMPLICIT NONE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_STATS ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_STATS(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) + + ! Input arguments + type(cosp_gridbox),intent(in) :: gbx + type(cosp_subgrid),intent(in) :: sgx + type(cosp_config),intent(in) :: cfg + type(cosp_sgradar),intent(in) :: sgradar + type(cosp_sglidar),intent(in) :: sglidar + type(cosp_vgrid),intent(in) :: vgrid + ! Output arguments + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics for radar + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics for lidar + + ! Local variables + integer :: Npoints !# of grid points + integer :: Nlevels !# of levels + integer :: Nhydro !# of hydrometeors + integer :: Ncolumns !# of columns + integer :: Nlr + logical :: ok_lidar_cfad = .false. + real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out + real,dimension(:,:),allocatable :: ph_c,betamol_c + real,dimension(:,:,:),allocatable :: betaperptot_out, temp_in, temp_out + real,dimension(:,:),allocatable :: temp_c + + Npoints = gbx%Npoints + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + Ncolumns = gbx%Ncolumns + Nlr = vgrid%Nlvgrid + + if (cfg%LcfadLidarsr532) ok_lidar_cfad=.true. + + if (vgrid%use_vgrid) then ! Statistics in a different vertical grid + allocate(Ze_out(Npoints,Ncolumns,Nlr),betatot_out(Npoints,Ncolumns,Nlr), & + betamol_in(Npoints,1,Nlevels),betamol_out(Npoints,1,Nlr),betamol_c(Npoints,Nlr), & + ph_in(Npoints,1,Nlevels),ph_out(Npoints,1,Nlr),ph_c(Npoints,Nlr)) + Ze_out = 0.0 + betatot_out = 0.0 + betamol_out= 0.0 + betamol_c = 0.0 + ph_in(:,1,:) = gbx%ph(:,:) + ph_out = 0.0 + ph_c = 0.0 + allocate(betaperptot_out(Npoints,Ncolumns,Nlr),temp_in(Npoints,1,Nlevels),temp_out(Npoints,1,Nlr), & + temp_c(Npoints,Nlr)) + betaperptot_out = 0.0 + temp_in = 0.0 + temp_out = 0.0 + temp_c = 0.0 + + !++++++++++++ Radar CFAD ++++++++++++++++ + if (cfg%Lradar_sim) then + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sgradar%Ze_tot, & + Nlr,vgrid%zl,vgrid%zu,Ze_out,log_units=.true.) + stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,Ze_out, & + DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) + endif + !++++++++++++ Lidar CFAD ++++++++++++++++ + if (cfg%Llidar_sim) then + betamol_in(:,1,:) = sglidar%beta_mol(:,:) + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,betamol_in, & + Nlr,vgrid%zl,vgrid%zu,betamol_out) + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, & + Nlr,vgrid%zl,vgrid%zu,betatot_out) + + temp_in(:,1,:) = gbx%T(:,:) + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%betaperp_tot, & + Nlr,vgrid%zl,vgrid%zu,betaperptot_out) + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,temp_in, & + Nlr,vgrid%zl,vgrid%zu,temp_out) + temp_c(:,:) = temp_out(:,1,:) + stlidar%proftemp = temp_c !TIBO + where (stlidar%proftemp < 150.) stlidar%proftemp = R_UNDEF !TIBO + where (stlidar%proftemp > 350.) stlidar%proftemp = R_UNDEF !TIBO + + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, & + Nlr,vgrid%zl,vgrid%zu,ph_out) + ph_c(:,:) = ph_out(:,1,:) + betamol_c(:,:) = betamol_out(:,1,:) + ! Stats from lidar_stat_summary + call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & + ,temp_c,betatot_out,betaperptot_out,betamol_c,sglidar%refl,gbx%land,ph_c & + ,LIDAR_UNDEF,ok_lidar_cfad & + ,stlidar%cfad_sr,stlidar%srbval & + ,LIDAR_NCAT,LIDAR_NTYPE,stlidar%lidarcld,stlidar%lidarcldtype & !OPAQ + ,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldtype & !OPAQ + ,stlidar%cldlayerphase,stlidar%lidarcldtmp & !OPAQ + ,stlidar%parasolrefl,vgrid%z,stlidar%profSR) !OPAQ !TIBO + endif + + !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ + if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & + temp_c,betatot_out,betaperptot_out,betamol_c,Ze_out, & + stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) + deallocate(temp_in,temp_out,temp_c,betaperptot_out) !TIBO +temp_in + + ! Deallocate arrays at coarse resolution + deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c) + else ! Statistics in model levels + !++++++++++++ Radar CFAD ++++++++++++++++ + if (cfg%Lradar_sim) stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,sgradar%Ze_tot, & + DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) + !++++++++++++ Lidar CFAD ++++++++++++++++ + ! Stats from lidar_stat_summary + if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & + ,sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph & + ,LIDAR_UNDEF,ok_lidar_cfad & + ,stlidar%cfad_sr,stlidar%srbval & + ,LIDAR_NCAT,LIDAR_NTYPE,stlidar%lidarcld,stlidar%lidarcldtype & !OPAQ + ,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldtype & !OPAQ + ,stlidar%cldlayerphase,stlidar%lidarcldtmp & !OPAQ + ,stlidar%parasolrefl,vgrid%z,stlidar%profSR) !OPAQ !TIBO + !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ + if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & + sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sgradar%Ze_tot, & + stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) + endif + ! Replace undef + where (stlidar%cfad_sr == LIDAR_UNDEF) stlidar%cfad_sr = R_UNDEF + where (stlidar%profSR == LIDAR_UNDEF) stlidar%profSR = R_UNDEF !TIBO + where (stlidar%lidarcld == LIDAR_UNDEF) stlidar%lidarcld = R_UNDEF + where (stlidar%lidarcldtype == LIDAR_UNDEF) stlidar%lidarcldtype = R_UNDEF !OPAQ + where (stlidar%cldlayer == LIDAR_UNDEF) stlidar%cldlayer = R_UNDEF + where (stlidar%cldtype == LIDAR_UNDEF) stlidar%cldtype = R_UNDEF !OPAQ + where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF + where (stlidar%cldlayerphase == LIDAR_UNDEF) stlidar%cldlayerphase = R_UNDEF + where (stlidar%lidarcldphase == LIDAR_UNDEF) stlidar%lidarcldphase = R_UNDEF + where (stlidar%lidarcldtmp == LIDAR_UNDEF) stlidar%lidarcldtmp = R_UNDEF + +END SUBROUTINE COSP_STATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ---------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,Nglevels,newgrid_bot,newgrid_top,r,log_units) + implicit none + ! Input arguments + integer,intent(in) :: Npoints !# of grid points + integer,intent(in) :: Nlevels !# of levels + integer,intent(in) :: Ncolumns !# of columns + real,dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer) + real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer) + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y ! Variable to be changed to a different grid + integer,intent(in) :: Nglevels !# levels in the new grid + real,dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels [m] + real,dimension(Nglevels),intent(in) :: newgrid_top ! Upper boundary of new levels [m] + logical,optional,intent(in) :: log_units ! log units, need to convert to linear units + ! Output + real,dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid + + ! Local variables + integer :: i,j,k + logical :: lunits + integer :: l + real :: w ! Weight + real :: dbb, dtb, dbt, dtt ! Distances between edges of both grids + integer :: Nw ! Number of weights + real :: wt ! Sum of weights + real,dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid + real :: yp ! Local copy of y at a particular point. + ! This allows for change of units. + + lunits=.false. + if (present(log_units)) lunits=log_units + + r = 0.0 + + do i=1,Npoints + ! Calculate tops and bottoms of new and old grids + oldgrid_bot = zhalf(i,:) + oldgrid_top(1:Nlevels-1) = oldgrid_bot(2:Nlevels) + oldgrid_top(Nlevels) = zfull(i,Nlevels) + zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric + l = 0 ! Index of level in the old grid + ! Loop over levels in the new grid + do k = 1,Nglevels + Nw = 0 ! Number of weigths + wt = 0.0 ! Sum of weights + ! Loop over levels in the old grid and accumulate total for weighted average + do + l = l + 1 + w = 0.0 ! Initialise weight to 0 + ! Distances between edges of both grids + dbb = oldgrid_bot(l) - newgrid_bot(k) + dtb = oldgrid_top(l) - newgrid_bot(k) + dbt = oldgrid_bot(l) - newgrid_top(k) + dtt = oldgrid_top(l) - newgrid_top(k) + if (dbt >= 0.0) exit ! Do next level in the new grid + if (dtb > 0.0) then + if (dbb <= 0.0) then + if (dtt <= 0) then + w = dtb + else + w = newgrid_top(k) - newgrid_bot(k) + endif + else + if (dtt <= 0) then + w = oldgrid_top(l) - oldgrid_bot(l) + else + w = -dbt + endif + endif + ! If layers overlap (w/=0), then accumulate + if (w /= 0.0) then + Nw = Nw + 1 + wt = wt + w + do j=1,Ncolumns + if (lunits) then + if (y(i,j,l) /= R_UNDEF) then + yp = 10.0**(y(i,j,l)/10.0) + else + yp = 0.0 + endif + else + yp = y(i,j,l) + endif + r(i,j,k) = r(i,j,k) + w*yp + enddo + endif + endif + enddo + l = l - 2 + if (l < 1) l = 0 + ! Calculate average in new grid + if (Nw > 0) then + do j=1,Ncolumns + r(i,j,k) = r(i,j,k)/wt + enddo + endif + enddo + enddo + + ! Set points under surface to R_UNDEF, and change to dBZ if necessary + do k=1,Nglevels + do j=1,Ncolumns + do i=1,Npoints + if (newgrid_top(k) > zhalf(i,1)) then ! Level above model bottom level + if (lunits) then + if (r(i,j,k) <= 0.0) then + r(i,j,k) = R_UNDEF + else + r(i,j,k) = 10.0*log10(r(i,j,k)) + endif + endif + else ! Level below surface + r(i,j,k) = R_GROUND + endif + enddo + enddo + enddo + +END SUBROUTINE COSP_CHANGE_VERTICAL_GRID + +END MODULE MOD_COSP_STATS Index: DZ6/trunk/libf/phylmd/cosp/phys_cosp.F90 =================================================================== --- /LMDZ6/trunk/libf/phylmd/cosp/phys_cosp.F90 (revision 5311) +++ (revision ) @@ -1,449 +1,0 @@ -! Simulateur COSP : Cfmip Observation Simulator Package - -! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS -!Idelkadi Abderrahmane Aout-Septembre 2009 First Version -!Idelkadi Abderrahmane Nov 2015 version v1.4.0 - - subroutine phys_cosp( itap,dtime,freq_cosp, & - ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & - ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, & - Nptslmdz,Nlevlmdz,lon,lat, presnivs,overlaplmdz,sunlit, & - ref_liq,ref_ice,fracTerLic,u_wind,v_wind,phis,phi,ph,p,skt,t, & - sh,rh,tca,cca,mr_lsliq,mr_lsice,fl_lsrainI,fl_lssnowI, & - fl_ccrainI,fl_ccsnowI,mr_ozone,dtau_s,dem_s) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!! Inputs : -! itap, !Increment de la physiq -! dtime, !Pas de temps physiq -! overlap, !Overlap type in SCOPS -! Npoints, !Nb de points de la grille physiq -! Nlevels, !Nb de niveaux verticaux -! Ncolumns, !Number of subcolumns -! lon,lat, !Longitudes et latitudes de la grille LMDZ -! ref_liq,ref_ice, !Rayons effectifs des particules liq et ice (en microm) -! fracTerLic, !Fraction terre a convertir en masque -! u_wind,v_wind, !Vents a 10m ??? -! phi, !Geopotentiel -! phis, !Geopotentiel sol -! ph, !pression pour chaque inter-couche -! p, !Pression aux milieux des couches -! skt,t, !Temp au sol et temp 3D -! sh, !Humidite specifique -! rh, !Humidite relatif -! tca, !Fraction nuageuse -! cca !Fraction nuageuse convective -! mr_lsliq, !Liq Cloud water content -! mr_lsice, !Ice Cloud water content -! mr_ccliq, !Convective Cloud Liquid water content -! mr_ccice, !Cloud ice water content -! fl_lsrain, !Large scale precipitation lic -! fl_lssnow, !Large scale precipitation ice -! fl_ccrain, !Convective precipitation lic -! fl_ccsnow, !Convective precipitation ice -! mr_ozone, !Concentration ozone (Kg/Kg) -! dem_s !Cloud optical emissivity -! dtau_s !Cloud optical thickness -! emsfc_lw = 1. !Surface emissivity dans radlwsw.F90 - -!!! Outputs : -! calipso2D, !Lidar Low/heigh/Mean/Total-level Cloud Fraction -! calipso3D, !Lidar Cloud Fraction (532 nm) -! cfadlidar, !Lidar Scattering Ratio CFAD (532 nm) -! parasolrefl, !PARASOL-like mono-directional reflectance -! atb, !Lidar Attenuated Total Backscatter (532 nm) -! betamol, !Lidar Molecular Backscatter (532 nm) -! cfaddbze, !Radar Reflectivity Factor CFAD (94 GHz) -! clcalipso2, !Cloud frequency of occurrence as seen by CALIPSO but not CloudSat -! dbze, !Efective_reflectivity_factor -! cltlidarradar, !Lidar and Radar Total Cloud Fraction -! clMISR, !Cloud Fraction as Calculated by the MISR Simulator -! clisccp2, !Cloud Fraction as Calculated by the ISCCP Simulator -! boxtauisccp, !Optical Depth in Each Column as Calculated by the ISCCP Simulator -! boxptopisccp, !Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator -! tclisccp, !Total Cloud Fraction as Calculated by the ISCCP Simulator -! ctpisccp, !Mean Cloud Top Pressure as Calculated by the ISCCP Simulator -! tauisccp, !Mean Optical Depth as Calculated by the ISCCP Simulator -! albisccp, !Mean Cloud Albedo as Calculated by the ISCCP Simulator -! meantbisccp, !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator -! meantbclrisccp !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator - -!!! AI rajouter les nouvelles sorties -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!! AI rajouter -INCLUDE "cosp_defs.h" - USE MOD_COSP_CONSTANTS - USE MOD_COSP_TYPES - USE MOD_COSP - USE mod_phys_lmdz_para - USE mod_grid_phy_lmdz - use ioipsl - use iophy - use cosp_output_mod - use cosp_output_write_mod -! use MOD_COSP_Modis_Simulator, only : cosp_modis - USE lmdz_xios, ONLY: xios_field_is_active, using_xios - use cosp_read_otputkeys - - IMPLICIT NONE - - ! Local variables - character(len=64),PARAMETER :: cosp_input_nl='cosp_input_nl.txt' - character(len=64),PARAMETER :: cosp_output_nl='cosp_output_nl.txt' - integer, save :: isccp_topheight,isccp_topheight_direction,overlap - integer,save :: Ncolumns ! Number of subcolumns in SCOPS - integer, save :: Npoints ! Number of gridpoints -!$OMP THREADPRIVATE(Npoints) - integer, save :: Nlevels ! Number of levels - Integer :: Nptslmdz,Nlevlmdz ! Nb de points issus de physiq.F - integer, save :: Nlr ! Number of levels in statistical outputs - integer, save :: Npoints_it ! Max number of gridpoints to be processed in one iteration - integer :: i - type(cosp_config),save :: cfg ! Configuration options -!$OMP THREADPRIVATE(cfg) - type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP - type(cosp_subgrid) :: sgx ! Subgrid outputs - type(cosp_sgradar) :: sgradar ! Output from radar simulator - type(cosp_sglidar) :: sglidar ! Output from lidar simulator - type(cosp_isccp) :: isccp ! Output from ISCCP simulator -!! AI rajout modis - type(cosp_modis) :: modis ! Output from MODIS simulator -!! - type(cosp_misr) :: misr ! Output from MISR simulator -!! AI rajout rttovs -! type(cosp_rttov) :: rttov ! Output from RTTOV -!! - type(cosp_vgrid) :: vgrid ! Information on vertical grid of stats - type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator - type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator - - integer :: t0,t1,count_rate,count_max - integer :: Nlon,Nlat - real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw -!$OMP THREADPRIVATE(emsfc_lw) - integer,dimension(RTTOV_MAX_CHANNELS),save :: Channels - real,dimension(RTTOV_MAX_CHANNELS),save :: Surfem - integer, save :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay - integer, save :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type - integer, save :: platform,satellite,Instrument,Nchannels - logical, save :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff - -! Declaration necessaires pour les sorties IOIPSL - integer :: ii - real :: ecrit_day,ecrit_hf,ecrit_mth, missing_val - logical :: ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, ok_all_xml - - logical, save :: debut_cosp=.true. -!$OMP THREADPRIVATE(debut_cosp) - - logical, save :: first_write=.true. -!$OMP THREADPRIVATE(first_write) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM - integer :: overlaplmdz ! overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz) - real,dimension(Nptslmdz,Nlevlmdz) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & - fl_lsrain,fl_lssnow,fl_ccrain,fl_ccsnow,fl_lsgrpl, & - zlev,zlev_half,mr_ozone,radliq,radice,dtau_s,dem_s,ref_liq,ref_ice - real,dimension(Nptslmdz,Nlevlmdz) :: fl_lsrainI,fl_lssnowI,fl_ccrainI,fl_ccsnowI - real,dimension(Nptslmdz) :: lon,lat,skt,fracTerLic,u_wind,v_wind,phis,sunlit - real,dimension(Nlevlmdz) :: presnivs - integer :: itap,k,ip - real :: dtime,freq_cosp - real,dimension(2) :: time_bnds - - double precision :: d_dtime - double precision,dimension(2) :: d_time_bnds - - real,dimension(2,SR_BINS) :: sratio_bounds - real,dimension(SR_BINS) :: sratio_ax - - namelist/COSP_INPUT/overlap,isccp_topheight,isccp_topheight_direction, & - npoints_it,ncolumns,use_vgrid,nlr,csat_vgrid, & - radar_freq,surface_radar,use_mie_tables, & - use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,Naero,Nprmts_max_aero, & - lidar_ice_type,use_precipitation_fluxes,use_reff, & - platform,satellite,Instrument,Nchannels, & - Channels,Surfem,ZenAng,co2,ch4,n2o,co - -!---------------- End of declaration of variables -------------- - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! Read namelist with COSP inputs -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - if (debut_cosp) then - NPoints=Nptslmdz - Nlevels=Nlevlmdz - -! Lecture du namelist input - CALL read_cosp_input - -! Clefs Outputs initialisation - IF (using_xios) THEN - call cosp_outputkeys_init(cfg) - ELSE - call read_cosp_output_nl(itap,cosp_output_nl,cfg) - ENDIF - -!!! call cosp_outputkeys_test(cfg) - print*,' Cles des differents simulateurs cosp a itap :',itap - print*,'Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lmodis_sim,Lrttov_sim,Lstats', & - cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lmodis_sim, & - cfg%Lrttov_sim,cfg%Lstats - - if (overlaplmdz.ne.overlap) then - print*,'Attention overlaplmdz different de overlap lu dans namelist ' - endif - print*,'Fin lecture Namelists, debut_cosp =',debut_cosp - - endif ! debut_cosp - -!!! Ici on modifie les cles logiques pour les outputs selon les champs actives dans les .xml - if ((itap.gt.1).and.(first_write))then - - IF (using_xios) call read_xiosfieldactive(cfg) - - first_write=.false. - - print*,' Cles des differents simulateurs cosp a itap :',itap - print*,'Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lmodis_sim,Lrttov_sim,Lstats', & - cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lmodis_sim, & - cfg%Lrttov_sim,cfg%Lstats - endif - - time_bnds(1) = dtime-dtime/2. - time_bnds(2) = dtime+dtime/2. - - d_time_bnds=time_bnds - d_dtime=dtime - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! Allocate memory for gridbox type -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! AI mars 2017 -! print *, 'Allocating memory for gridbox type...' - -! Surafce emissivity - emsfc_lw = 1. - - call construct_cosp_gridbox(d_dtime,d_time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs, & - do_ray,melt_lay,k2, & - Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & - lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, & - use_precipitation_fluxes,use_reff, & - Platform,Satellite,Instrument,Nchannels,ZenAng, & - channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx) - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! Here code to populate input structure -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -! print *, 'Populating input structure...' - gbx%longitude = lon - gbx%latitude = lat - - gbx%p = p ! - gbx%ph = ph - gbx%zlev = phi/9.81 - - zlev_half(:,1) = phis(:)/9.81 - do k = 2, Nlevels - do ip = 1, Npoints - zlev_half(ip,k) = phi(ip,k)/9.81 + & - (phi(ip,k)-phi(ip,k-1))/9.81 * (ph(ip,k)-p(ip,k)) / (p(ip,k)-p(ip,k-1)) - enddo - enddo - gbx%zlev_half = zlev_half - - gbx%T = T - gbx%q = rh*100. - gbx%sh = sh -! On ne veut pas que cosp distingue les nuages stratiformes et convectifs -! on passe les contenus totaux (conv+strat) - gbx%cca = 0. !convective_cloud_amount (1) - gbx%tca = tca ! total_cloud_amount (1) - gbx%psfc = ph(:,1) !pression de surface - gbx%skt = skt !Skin temperature (K) - - do ip = 1, Npoints - if (fracTerLic(ip).ge.0.5) then - gbx%land(ip) = 1. - else - gbx%land(ip) = 0. - endif - enddo - gbx%mr_ozone = mr_ozone !mass_fraction_of_ozone_in_air (kg/kg) -! A voir l equivalent LMDZ (u10m et v10m) - gbx%u_wind = u_wind !eastward_wind (m s-1) - gbx%v_wind = v_wind !northward_wind - -! sunlit calcule a partir de la fraction d ensoleillement par jour -! do ip = 1, Npoints -! if (sunlit(ip).le.0.) then -! gbx%sunlit(ip)=0. -! else -! gbx%sunlit(ip)=1. -! endif -! enddo - gbx%sunlit=sunlit - -! A voir l equivalent LMDZ - mr_ccliq = 0.0 - mr_ccice = 0.0 - gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq !mixing_ratio_large_scale_cloud_liquid (kg/kg) - gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice !mixing_ratio_large_scale_cloud_ic - gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq !mixing_ratio_convective_cloud_liquid - gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice !mixing_ratio_convective_cloud_ice -! A revoir - fl_lsrain = fl_lsrainI + fl_ccrainI - fl_lssnow = fl_lssnowI + fl_ccsnowI - gbx%rain_ls = fl_lsrain !flux_large_scale_cloud_rain (kg m^-2 s^-1) - gbx%snow_ls = fl_lssnow !flux_large_scale_cloud_snow -! A voir l equivalent LMDZ - fl_lsgrpl=0. - fl_ccsnow = 0. - fl_ccrain = 0. - gbx%grpl_ls = fl_lsgrpl !flux_large_scale_cloud_graupel - gbx%rain_cv = fl_ccrain !flux_convective_cloud_rain - gbx%snow_cv = fl_ccsnow !flux_convective_cloud_snow - - gbx%Reff(:,:,I_LSCLIQ) = ref_liq*1e-6 - gbx%Reff(:,:,I_LSCICE) = ref_ice*1e-6 -!! AI A revoir - gbx%Reff(:,:,I_CVCLIQ) = ref_liq*1e-6 - gbx%Reff(:,:,I_CVCICE) = ref_ice*1e-6 - - ! ISCCP simulator - gbx%dtau_s = dtau_s - gbx%dtau_c = 0. - gbx%dem_s = dem_s - gbx%dem_c = 0. - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! Define new vertical grid -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! print *, 'Defining new vertical grid...' - call construct_cosp_vgrid(gbx,Nlr,use_vgrid,csat_vgrid,vgrid) - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! Allocate memory for other types -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! print *, 'Allocating memory for other types...' - call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx) - call construct_cosp_sgradar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar) - call construct_cosp_radarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar) - call construct_cosp_sglidar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar) - call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar) - call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp) -!! AI rajout - call construct_cosp_modis(cfg,Npoints,modis) -!! - call construct_cosp_misr(cfg,Npoints,misr) -! call construct_cosp_rttov(cfg,Npoints,Nchannels,rttov) - -!+++++++++++++ Open output files and define output files axis !+++++++++++++ - if (debut_cosp) then - - !$OMP MASTER -! print *, ' Open outpts files and define axis' - call cosp_output_open(Nlevlmdz, Ncolumns, presnivs, dtime, freq_cosp, & - ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml, & - ecrit_mth, ecrit_day, ecrit_hf, use_vgrid, vgrid, stlidar) - !$OMP END MASTER - !$OMP BARRIER - endif ! debut_cosp -! else -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! Call simulator -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! print *, 'Calling simulator...' -!! AI -! call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) -!#ifdef RTTOV -! call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) -!#else - if (.NOT. debut_cosp) call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) -!#endif -!! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - -!!!!!!!!!!!!!!!!!! Ecreture des sorties Cosp !!!!!!!!!!!!!!r!!!!!!:!!!!! - -! print *, 'Calling write output' - if (.NOT. debut_cosp) call cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_val, & - cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, & - isccp, misr, modis) -! endif !debut_cosp -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! Deallocate memory in derived types -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! print *, 'Deallocating memory...' - call free_cosp_gridbox(gbx) - call free_cosp_subgrid(sgx) - call free_cosp_sgradar(sgradar) - call free_cosp_radarstats(stradar) - call free_cosp_sglidar(sglidar) - call free_cosp_lidarstats(stlidar) - call free_cosp_isccp(isccp) - call free_cosp_misr(misr) -!! AI - call free_cosp_modis(modis) -! call free_cosp_rttov(rttov) -!! - call free_cosp_vgrid(vgrid) - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! Time in s. Only for testing purposes -! call system_clock(t1,count_rate,count_max) -! print *,(t1-t0)*1.0/count_rate - if (debut_cosp) then - debut_cosp=.false. - endif - - CONTAINS - - SUBROUTINE read_cosp_input - - IF (is_master) THEN - OPEN(10,file=cosp_input_nl,status='old') - READ(10,nml=cosp_input) - CLOSE(10) - ENDIF -!$OMP BARRIER - CALL bcast(overlap) - CALL bcast(isccp_topheight) - CALL bcast(isccp_topheight_direction) - CALL bcast(npoints_it) - CALL bcast(ncolumns) - CALL bcast(use_vgrid) - CALL bcast(nlr) - CALL bcast(csat_vgrid) - CALL bcast(radar_freq) - CALL bcast(surface_radar) - CALL bcast(use_mie_tables) - CALL bcast(use_gas_abs) - CALL bcast(do_ray) - CALL bcast(melt_lay) - CALL bcast(k2) - CALL bcast(Nprmts_max_hydro) - CALL bcast(Naero) - CALL bcast(Nprmts_max_aero) - CALL bcast(lidar_ice_type) - CALL bcast(use_precipitation_fluxes) - CALL bcast(use_reff) - CALL bcast(platform) - CALL bcast(satellite) - CALL bcast(Instrument) - CALL bcast(Nchannels) - CALL bcast(Channels) - CALL bcast(Surfem) - CALL bcast(ZenAng) - CALL bcast(co2) - CALL bcast(ch4) - CALL bcast(n2o) - CALL bcast(co) - - END SUBROUTINE read_cosp_input - -end subroutine phys_cosp Index: /LMDZ6/trunk/libf/phylmd/cosp/phys_cosp.f90 =================================================================== --- /LMDZ6/trunk/libf/phylmd/cosp/phys_cosp.f90 (revision 5312) +++ /LMDZ6/trunk/libf/phylmd/cosp/phys_cosp.f90 (revision 5312) @@ -0,0 +1,449 @@ +! Simulateur COSP : Cfmip Observation Simulator Package + +! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS +!Idelkadi Abderrahmane Aout-Septembre 2009 First Version +!Idelkadi Abderrahmane Nov 2015 version v1.4.0 + + subroutine phys_cosp( itap,dtime,freq_cosp, & + ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & + ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, & + Nptslmdz,Nlevlmdz,lon,lat, presnivs,overlaplmdz,sunlit, & + ref_liq,ref_ice,fracTerLic,u_wind,v_wind,phis,phi,ph,p,skt,t, & + sh,rh,tca,cca,mr_lsliq,mr_lsice,fl_lsrainI,fl_lssnowI, & + fl_ccrainI,fl_ccsnowI,mr_ozone,dtau_s,dem_s) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! Inputs : +! itap, !Increment de la physiq +! dtime, !Pas de temps physiq +! overlap, !Overlap type in SCOPS +! Npoints, !Nb de points de la grille physiq +! Nlevels, !Nb de niveaux verticaux +! Ncolumns, !Number of subcolumns +! lon,lat, !Longitudes et latitudes de la grille LMDZ +! ref_liq,ref_ice, !Rayons effectifs des particules liq et ice (en microm) +! fracTerLic, !Fraction terre a convertir en masque +! u_wind,v_wind, !Vents a 10m ??? +! phi, !Geopotentiel +! phis, !Geopotentiel sol +! ph, !pression pour chaque inter-couche +! p, !Pression aux milieux des couches +! skt,t, !Temp au sol et temp 3D +! sh, !Humidite specifique +! rh, !Humidite relatif +! tca, !Fraction nuageuse +! cca !Fraction nuageuse convective +! mr_lsliq, !Liq Cloud water content +! mr_lsice, !Ice Cloud water content +! mr_ccliq, !Convective Cloud Liquid water content +! mr_ccice, !Cloud ice water content +! fl_lsrain, !Large scale precipitation lic +! fl_lssnow, !Large scale precipitation ice +! fl_ccrain, !Convective precipitation lic +! fl_ccsnow, !Convective precipitation ice +! mr_ozone, !Concentration ozone (Kg/Kg) +! dem_s !Cloud optical emissivity +! dtau_s !Cloud optical thickness +! emsfc_lw = 1. !Surface emissivity dans radlwsw.F90 + +!!! Outputs : +! calipso2D, !Lidar Low/heigh/Mean/Total-level Cloud Fraction +! calipso3D, !Lidar Cloud Fraction (532 nm) +! cfadlidar, !Lidar Scattering Ratio CFAD (532 nm) +! parasolrefl, !PARASOL-like mono-directional reflectance +! atb, !Lidar Attenuated Total Backscatter (532 nm) +! betamol, !Lidar Molecular Backscatter (532 nm) +! cfaddbze, !Radar Reflectivity Factor CFAD (94 GHz) +! clcalipso2, !Cloud frequency of occurrence as seen by CALIPSO but not CloudSat +! dbze, !Efective_reflectivity_factor +! cltlidarradar, !Lidar and Radar Total Cloud Fraction +! clMISR, !Cloud Fraction as Calculated by the MISR Simulator +! clisccp2, !Cloud Fraction as Calculated by the ISCCP Simulator +! boxtauisccp, !Optical Depth in Each Column as Calculated by the ISCCP Simulator +! boxptopisccp, !Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator +! tclisccp, !Total Cloud Fraction as Calculated by the ISCCP Simulator +! ctpisccp, !Mean Cloud Top Pressure as Calculated by the ISCCP Simulator +! tauisccp, !Mean Optical Depth as Calculated by the ISCCP Simulator +! albisccp, !Mean Cloud Albedo as Calculated by the ISCCP Simulator +! meantbisccp, !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +! meantbclrisccp !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator + +!!! AI rajouter les nouvelles sorties +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! AI rajouter +INCLUDE "cosp_defs.h" + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_COSP + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + use ioipsl + use iophy + use cosp_output_mod + use cosp_output_write_mod +! use MOD_COSP_Modis_Simulator, only : cosp_modis + USE lmdz_xios, ONLY: xios_field_is_active, using_xios + use cosp_read_otputkeys + + IMPLICIT NONE + + ! Local variables + character(len=64),PARAMETER :: cosp_input_nl='cosp_input_nl.txt' + character(len=64),PARAMETER :: cosp_output_nl='cosp_output_nl.txt' + integer, save :: isccp_topheight,isccp_topheight_direction,overlap + integer,save :: Ncolumns ! Number of subcolumns in SCOPS + integer, save :: Npoints ! Number of gridpoints +!$OMP THREADPRIVATE(Npoints) + integer, save :: Nlevels ! Number of levels + Integer :: Nptslmdz,Nlevlmdz ! Nb de points issus de physiq.F + integer, save :: Nlr ! Number of levels in statistical outputs + integer, save :: Npoints_it ! Max number of gridpoints to be processed in one iteration + integer :: i + type(cosp_config),save :: cfg ! Configuration options +!$OMP THREADPRIVATE(cfg) + type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP + type(cosp_subgrid) :: sgx ! Subgrid outputs + type(cosp_sgradar) :: sgradar ! Output from radar simulator + type(cosp_sglidar) :: sglidar ! Output from lidar simulator + type(cosp_isccp) :: isccp ! Output from ISCCP simulator +!! AI rajout modis + type(cosp_modis) :: modis ! Output from MODIS simulator +!! + type(cosp_misr) :: misr ! Output from MISR simulator +!! AI rajout rttovs +! type(cosp_rttov) :: rttov ! Output from RTTOV +!! + type(cosp_vgrid) :: vgrid ! Information on vertical grid of stats + type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator + + integer :: t0,t1,count_rate,count_max + integer :: Nlon,Nlat + real,save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw +!$OMP THREADPRIVATE(emsfc_lw) + integer,dimension(RTTOV_MAX_CHANNELS),save :: Channels + real,dimension(RTTOV_MAX_CHANNELS),save :: Surfem + integer, save :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay + integer, save :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type + integer, save :: platform,satellite,Instrument,Nchannels + logical, save :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff + +! Declaration necessaires pour les sorties IOIPSL + integer :: ii + real :: ecrit_day,ecrit_hf,ecrit_mth, missing_val + logical :: ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, ok_all_xml + + logical, save :: debut_cosp=.true. +!$OMP THREADPRIVATE(debut_cosp) + + logical, save :: first_write=.true. +!$OMP THREADPRIVATE(first_write) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM + integer :: overlaplmdz ! overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz) + real,dimension(Nptslmdz,Nlevlmdz) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & + fl_lsrain,fl_lssnow,fl_ccrain,fl_ccsnow,fl_lsgrpl, & + zlev,zlev_half,mr_ozone,radliq,radice,dtau_s,dem_s,ref_liq,ref_ice + real,dimension(Nptslmdz,Nlevlmdz) :: fl_lsrainI,fl_lssnowI,fl_ccrainI,fl_ccsnowI + real,dimension(Nptslmdz) :: lon,lat,skt,fracTerLic,u_wind,v_wind,phis,sunlit + real,dimension(Nlevlmdz) :: presnivs + integer :: itap,k,ip + real :: dtime,freq_cosp + real,dimension(2) :: time_bnds + + double precision :: d_dtime + double precision,dimension(2) :: d_time_bnds + + real,dimension(2,SR_BINS) :: sratio_bounds + real,dimension(SR_BINS) :: sratio_ax + + namelist/COSP_INPUT/overlap,isccp_topheight,isccp_topheight_direction, & + npoints_it,ncolumns,use_vgrid,nlr,csat_vgrid, & + radar_freq,surface_radar,use_mie_tables, & + use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,Naero,Nprmts_max_aero, & + lidar_ice_type,use_precipitation_fluxes,use_reff, & + platform,satellite,Instrument,Nchannels, & + Channels,Surfem,ZenAng,co2,ch4,n2o,co + +!---------------- End of declaration of variables -------------- + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Read namelist with COSP inputs +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + if (debut_cosp) then + NPoints=Nptslmdz + Nlevels=Nlevlmdz + +! Lecture du namelist input + CALL read_cosp_input + +! Clefs Outputs initialisation + IF (using_xios) THEN + call cosp_outputkeys_init(cfg) + ELSE + call read_cosp_output_nl(itap,cosp_output_nl,cfg) + ENDIF + +!!! call cosp_outputkeys_test(cfg) + print*,' Cles des differents simulateurs cosp a itap :',itap + print*,'Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lmodis_sim,Lrttov_sim,Lstats', & + cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lmodis_sim, & + cfg%Lrttov_sim,cfg%Lstats + + if (overlaplmdz.ne.overlap) then + print*,'Attention overlaplmdz different de overlap lu dans namelist ' + endif + print*,'Fin lecture Namelists, debut_cosp =',debut_cosp + + endif ! debut_cosp + +!!! Ici on modifie les cles logiques pour les outputs selon les champs actives dans les .xml + if ((itap.gt.1).and.(first_write))then + + IF (using_xios) call read_xiosfieldactive(cfg) + + first_write=.false. + + print*,' Cles des differents simulateurs cosp a itap :',itap + print*,'Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lmodis_sim,Lrttov_sim,Lstats', & + cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lmodis_sim, & + cfg%Lrttov_sim,cfg%Lstats + endif + + time_bnds(1) = dtime-dtime/2. + time_bnds(2) = dtime+dtime/2. + + d_time_bnds=time_bnds + d_dtime=dtime + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate memory for gridbox type +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! AI mars 2017 +! print *, 'Allocating memory for gridbox type...' + +! Surafce emissivity + emsfc_lw = 1. + + call construct_cosp_gridbox(d_dtime,d_time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs, & + do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & + lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, & + use_precipitation_fluxes,use_reff, & + Platform,Satellite,Instrument,Nchannels,ZenAng, & + channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Here code to populate input structure +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +! print *, 'Populating input structure...' + gbx%longitude = lon + gbx%latitude = lat + + gbx%p = p ! + gbx%ph = ph + gbx%zlev = phi/9.81 + + zlev_half(:,1) = phis(:)/9.81 + do k = 2, Nlevels + do ip = 1, Npoints + zlev_half(ip,k) = phi(ip,k)/9.81 + & + (phi(ip,k)-phi(ip,k-1))/9.81 * (ph(ip,k)-p(ip,k)) / (p(ip,k)-p(ip,k-1)) + enddo + enddo + gbx%zlev_half = zlev_half + + gbx%T = T + gbx%q = rh*100. + gbx%sh = sh +! On ne veut pas que cosp distingue les nuages stratiformes et convectifs +! on passe les contenus totaux (conv+strat) + gbx%cca = 0. !convective_cloud_amount (1) + gbx%tca = tca ! total_cloud_amount (1) + gbx%psfc = ph(:,1) !pression de surface + gbx%skt = skt !Skin temperature (K) + + do ip = 1, Npoints + if (fracTerLic(ip).ge.0.5) then + gbx%land(ip) = 1. + else + gbx%land(ip) = 0. + endif + enddo + gbx%mr_ozone = mr_ozone !mass_fraction_of_ozone_in_air (kg/kg) +! A voir l equivalent LMDZ (u10m et v10m) + gbx%u_wind = u_wind !eastward_wind (m s-1) + gbx%v_wind = v_wind !northward_wind + +! sunlit calcule a partir de la fraction d ensoleillement par jour +! do ip = 1, Npoints +! if (sunlit(ip).le.0.) then +! gbx%sunlit(ip)=0. +! else +! gbx%sunlit(ip)=1. +! endif +! enddo + gbx%sunlit=sunlit + +! A voir l equivalent LMDZ + mr_ccliq = 0.0 + mr_ccice = 0.0 + gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq !mixing_ratio_large_scale_cloud_liquid (kg/kg) + gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice !mixing_ratio_large_scale_cloud_ic + gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq !mixing_ratio_convective_cloud_liquid + gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice !mixing_ratio_convective_cloud_ice +! A revoir + fl_lsrain = fl_lsrainI + fl_ccrainI + fl_lssnow = fl_lssnowI + fl_ccsnowI + gbx%rain_ls = fl_lsrain !flux_large_scale_cloud_rain (kg m^-2 s^-1) + gbx%snow_ls = fl_lssnow !flux_large_scale_cloud_snow +! A voir l equivalent LMDZ + fl_lsgrpl=0. + fl_ccsnow = 0. + fl_ccrain = 0. + gbx%grpl_ls = fl_lsgrpl !flux_large_scale_cloud_graupel + gbx%rain_cv = fl_ccrain !flux_convective_cloud_rain + gbx%snow_cv = fl_ccsnow !flux_convective_cloud_snow + + gbx%Reff(:,:,I_LSCLIQ) = ref_liq*1e-6 + gbx%Reff(:,:,I_LSCICE) = ref_ice*1e-6 +!! AI A revoir + gbx%Reff(:,:,I_CVCLIQ) = ref_liq*1e-6 + gbx%Reff(:,:,I_CVCICE) = ref_ice*1e-6 + + ! ISCCP simulator + gbx%dtau_s = dtau_s + gbx%dtau_c = 0. + gbx%dem_s = dem_s + gbx%dem_c = 0. + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Define new vertical grid +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! print *, 'Defining new vertical grid...' + call construct_cosp_vgrid(gbx,Nlr,use_vgrid,csat_vgrid,vgrid) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Allocate memory for other types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! print *, 'Allocating memory for other types...' + call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx) + call construct_cosp_sgradar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar) + call construct_cosp_radarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar) + call construct_cosp_sglidar(cfg,Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar) + call construct_cosp_lidarstats(cfg,Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar) + call construct_cosp_isccp(cfg,Npoints,Ncolumns,Nlevels,isccp) +!! AI rajout + call construct_cosp_modis(cfg,Npoints,modis) +!! + call construct_cosp_misr(cfg,Npoints,misr) +! call construct_cosp_rttov(cfg,Npoints,Nchannels,rttov) + +!+++++++++++++ Open output files and define output files axis !+++++++++++++ + if (debut_cosp) then + + !$OMP MASTER +! print *, ' Open outpts files and define axis' + call cosp_output_open(Nlevlmdz, Ncolumns, presnivs, dtime, freq_cosp, & + ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml, & + ecrit_mth, ecrit_day, ecrit_hf, use_vgrid, vgrid, stlidar) + !$OMP END MASTER + !$OMP BARRIER + endif ! debut_cosp +! else +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Call simulator +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! print *, 'Calling simulator...' +!! AI +! call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,stradar,stlidar) +!#ifdef RTTOV +! call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) +!#else + if (.NOT. debut_cosp) call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) +!#endif +!! +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!!!!!!!!!!!!!!!!!! Ecreture des sorties Cosp !!!!!!!!!!!!!!r!!!!!!:!!!!! + +! print *, 'Calling write output' + if (.NOT. debut_cosp) call cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_val, & + cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, & + isccp, misr, modis) +! endif !debut_cosp +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Deallocate memory in derived types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! print *, 'Deallocating memory...' + call free_cosp_gridbox(gbx) + call free_cosp_subgrid(sgx) + call free_cosp_sgradar(sgradar) + call free_cosp_radarstats(stradar) + call free_cosp_sglidar(sglidar) + call free_cosp_lidarstats(stlidar) + call free_cosp_isccp(isccp) + call free_cosp_misr(misr) +!! AI + call free_cosp_modis(modis) +! call free_cosp_rttov(rttov) +!! + call free_cosp_vgrid(vgrid) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Time in s. Only for testing purposes +! call system_clock(t1,count_rate,count_max) +! print *,(t1-t0)*1.0/count_rate + if (debut_cosp) then + debut_cosp=.false. + endif + + CONTAINS + + SUBROUTINE read_cosp_input + + IF (is_master) THEN + OPEN(10,file=cosp_input_nl,status='old') + READ(10,nml=cosp_input) + CLOSE(10) + ENDIF +!$OMP BARRIER + CALL bcast(overlap) + CALL bcast(isccp_topheight) + CALL bcast(isccp_topheight_direction) + CALL bcast(npoints_it) + CALL bcast(ncolumns) + CALL bcast(use_vgrid) + CALL bcast(nlr) + CALL bcast(csat_vgrid) + CALL bcast(radar_freq) + CALL bcast(surface_radar) + CALL bcast(use_mie_tables) + CALL bcast(use_gas_abs) + CALL bcast(do_ray) + CALL bcast(melt_lay) + CALL bcast(k2) + CALL bcast(Nprmts_max_hydro) + CALL bcast(Naero) + CALL bcast(Nprmts_max_aero) + CALL bcast(lidar_ice_type) + CALL bcast(use_precipitation_fluxes) + CALL bcast(use_reff) + CALL bcast(platform) + CALL bcast(satellite) + CALL bcast(Instrument) + CALL bcast(Nchannels) + CALL bcast(Channels) + CALL bcast(Surfem) + CALL bcast(ZenAng) + CALL bcast(co2) + CALL bcast(ch4) + CALL bcast(n2o) + CALL bcast(co) + + END SUBROUTINE read_cosp_input + +end subroutine phys_cosp