! $Id: read_pstoke.f90 5270 2024-10-24 11:55:38Z abarral $ SUBROUTINE read_pstoke(irec, zrec, zklono, zklevo, airefi, phisfi, t, mfu, & mfd, en_u, de_u, en_d, de_d, coefh, fm_therm, en_therm, frac_impa, & frac_nucl, pyu1, pyv1, ftsol, psrf) ! ****************************************************************************** ! Frederic HOURDIN, Abderrahmane IDELKADI ! Lecture des parametres physique stockes online necessaires pour ! recalculer offline le transport de traceurs sur une grille 2x plus fine ! que ! celle online ! A FAIRE : une seule routine au lieu de 2 (lectflux, redecoupe)! ! ****************************************************************************** USE netcdf USE dimphy USE indice_sol_mod USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev IMPLICIT NONE INTEGER klono, klevo, imo, jmo ! PARAMETER (imo=iim/2, jmo=(jjm+1)/2) ! PARAMETER (klono=(jmo-1)*imo+2, klevo=llm) REAL :: phisfi(((nbp_lat/2)-1)*(nbp_lon/2)+2) !phisfi(klono) REAL,ALLOCATABLE :: phisfi2(:,:) !phisfi2(imo,jmo+1) REAL,ALLOCATABLE :: airefi2(:,:) !airefi2(imo, jmo+1) REAL :: mfu(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) ! mfu(klono, klevo) REAL :: mfd(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) ! mfd(klono, klevo) REAL :: en_u(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !en_u(klono, klevo) REAL :: de_u(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !de_u(klono, klevo) REAL :: en_d(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !en_d(klono, klevo) REAL :: de_d(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !de_d(klono, klevo) REAL :: coefh(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !coefh(klono, klevo) REAL :: fm_therm(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !fm_therm(klono, klevo) REAL :: en_therm(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !en_therm(klono, klevo) REAL,ALLOCATABLE :: mfu2(:,:,:) !mfu2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: mfd2(:,:,:) !mfd2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: en_u2(:,:,:) !en_u2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: de_u2(:,:,:) !de_u2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: en_d2(:,:,:) !en_d2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: de_d2(:,:,:) !de_d2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: coefh2(:,:,:) !coefh2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: fm_therm2(:,:,:) !fm_therm2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: en_therm2(:,:,:) !en_therm2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: pl(:) !pl(klevo) INTEGER irec INTEGER xid, yid, zid, tid REAL zrec, zklono, zklevo, zim, zjm INTEGER ncrec, ncklono, ncklevo, ncim, ncjm REAL :: airefi(((nbp_lat/2)-1)*(nbp_lon/2)+2) !airefi(klono) CHARACTER *20 namedim ! !! attention !! ! attention il y a aussi le pb de def klono ! dim de phis?? REAL :: frac_impa(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !frac_impa(klono, klevo) REAL :: frac_nucl(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !frac_nucl(klono, klevo) REAL,ALLOCATABLE :: frac_impa2(:,:,:) !frac_impa2(imo, jmo+1, klevo) REAL,ALLOCATABLE :: frac_nucl2(:,:,:) !frac_nucl2(imo, jmo+1, klevo) REAL :: pyu1(((nbp_lat/2)-1)*(nbp_lon/2)+2) !pyu1(klono) REAL :: pyv1(((nbp_lat/2)-1)*(nbp_lon/2)+2) !pyv1(klono) REAL,ALLOCATABLE :: pyu12(:,:), pyv12(:,:) !pyu12(imo, jmo+1), pyv12(imo, jmo+1) REAL :: ftsol(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !ftsol(klono, nbsrf) REAL :: psrf(((nbp_lat/2)-1)*(nbp_lon/2)+2,nbp_lev) !psrf(klono, nbsrf) REAL,ALLOCATABLE :: ftsol1(:),ftsol2(:) !ftsol1(klono), ftsol2(klono) REAL,ALLOCATABLE :: ftsol3(:),ftsol4(:) !ftsol3(klono), ftsol4(klono) REAL,ALLOCATABLE :: psrf1(:), psrf2(:) !psrf1(klono), psrf2(klono) REAL,ALLOCATABLE :: psrf3(:), psrf4(:) !psrf3(klono), psrf4(klono) REAL,ALLOCATABLE :: ftsol12(:,:) !ftsol12(imo, jmo+1) REAL,ALLOCATABLE :: ftsol22(:,:) !ftsol22(imo, jmo+1) REAL,ALLOCATABLE :: ftsol32(:,:) !ftsol32(imo, jmo+1) REAL,ALLOCATABLE :: ftsol42(:,:) !ftsol42(imo, jmo+1) REAL,ALLOCATABLE :: psrf12(:,:) !psrf12(imo, jmo+1) REAL,ALLOCATABLE :: psrf22(:,:) !psrf22(imo, jmo+1) REAL,ALLOCATABLE :: psrf32(:,:) !psrf32(imo, jmo+1) REAL,ALLOCATABLE :: psrf42(:,:) !psrf42(imo, jmo+1) REAL :: t(((nbp_lon/2)-1)*(nbp_lat/2)+2,nbp_lev) !t(klono, klevo) REAL,ALLOCATABLE :: t2(:,:,:) !t2(imo, jmo+1, klevo) INTEGER,SAVE :: ncidp INTEGER,SAVE :: varidt INTEGER,SAVE :: varidmfu, varidmfd, varidps, varidenu, variddeu INTEGER,SAVE :: varidend, varidded, varidch, varidfi, varidfn INTEGER,SAVE :: varidfmth, varidenth INTEGER,SAVE :: varidyu1, varidyv1, varidpl, varidai, varididvt INTEGER,SAVE :: varidfts1, varidfts2, varidfts3, varidfts4 INTEGER,SAVE :: varidpsr1, varidpsr2, varidpsr3, varidpsr4 INTEGER l, i INTEGER start(4), count(4), status REAL rcode LOGICAL,SAVE :: first=.TRUE. ! Allocate arrays imo=nbp_lon/2 jmo=nbp_lat/2 klono=(jmo-1)*imo+2 klevo=nbp_lev ALLOCATE(phisfi2(imo,jmo+1)) ALLOCATE(airefi2(imo, jmo+1)) ALLOCATE(mfu2(imo, jmo+1, klevo)) ALLOCATE(mfd2(imo, jmo+1, klevo)) ALLOCATE(en_u2(imo, jmo+1, klevo)) ALLOCATE(de_u2(imo, jmo+1, klevo)) ALLOCATE(en_d2(imo, jmo+1, klevo)) ALLOCATE(de_d2(imo, jmo+1, klevo)) ALLOCATE(coefh2(imo, jmo+1, klevo)) ALLOCATE(fm_therm2(imo, jmo+1, klevo)) ALLOCATE(en_therm2(imo, jmo+1, klevo)) ALLOCATE(pl(klevo)) ALLOCATE(frac_impa2(imo, jmo+1, klevo)) ALLOCATE(frac_nucl2(imo, jmo+1, klevo)) ALLOCATE(pyu12(imo, jmo+1), pyv12(imo, jmo+1)) ALLOCATE(ftsol1(klono), ftsol2(klono)) ALLOCATE(ftsol3(klono), ftsol4(klono)) ALLOCATE(psrf1(klono), psrf2(klono)) ALLOCATE(psrf3(klono), psrf4(klono)) ALLOCATE(ftsol12(imo, jmo+1)) ALLOCATE(ftsol22(imo, jmo+1)) ALLOCATE(ftsol32(imo, jmo+1)) ALLOCATE(ftsol42(imo, jmo+1)) ALLOCATE(psrf12(imo, jmo+1)) ALLOCATE(psrf22(imo, jmo+1)) ALLOCATE(psrf32(imo, jmo+1)) ALLOCATE(psrf42(imo, jmo+1)) ALLOCATE(t2(imo, jmo+1, klevo)) ! --------------------------------------------- ! Initialisation de la lecture des fichiers ! --------------------------------------------- IF (irec==0) THEN rcode = nf90_open('phystoke.nc', nf90_nowrite, ncidp) rcode = nf90_inq_varid(ncidp, 'phis', varidps) PRINT *, 'ncidp,varidps', ncidp, varidps rcode = nf90_inq_varid(ncidp, 'sig_s', varidpl) PRINT *, 'ncidp,varidpl', ncidp, varidpl rcode = nf90_inq_varid(ncidp, 'aire', varidai) PRINT *, 'ncidp,varidai', ncidp, varidai ! A FAIRE: Es-il necessaire de stocke t? rcode = nf90_inq_varid(ncidp, 't', varidt) PRINT *, 'ncidp,varidt', ncidp, varidt rcode = nf90_inq_varid(ncidp, 'mfu', varidmfu) PRINT *, 'ncidp,varidmfu', ncidp, varidmfu rcode = nf90_inq_varid(ncidp, 'mfd', varidmfd) PRINT *, 'ncidp,varidmfd', ncidp, varidmfd rcode = nf90_inq_varid(ncidp, 'en_u', varidenu) PRINT *, 'ncidp,varidenu', ncidp, varidenu rcode = nf90_inq_varid(ncidp, 'de_u', variddeu) PRINT *, 'ncidp,variddeu', ncidp, variddeu rcode = nf90_inq_varid(ncidp, 'en_d', varidend) PRINT *, 'ncidp,varidend', ncidp, varidend rcode = nf90_inq_varid(ncidp, 'de_d', varidded) PRINT *, 'ncidp,varidded', ncidp, varidded rcode = nf90_inq_varid(ncidp, 'coefh', varidch) PRINT *, 'ncidp,varidch', ncidp, varidch ! abder (pour thermiques) rcode = nf90_inq_varid(ncidp, 'fm_th', varidfmth) PRINT *, 'ncidp,varidfmth', ncidp, varidfmth rcode = nf90_inq_varid(ncidp, 'en_th', varidenth) PRINT *, 'ncidp,varidenth', ncidp, varidenth rcode = nf90_inq_varid(ncidp, 'frac_impa', varidfi) PRINT *, 'ncidp,varidfi', ncidp, varidfi rcode = nf90_inq_varid(ncidp, 'frac_nucl', varidfn) PRINT *, 'ncidp,varidfn', ncidp, varidfn rcode = nf90_inq_varid(ncidp, 'pyu1', varidyu1) PRINT *, 'ncidp,varidyu1', ncidp, varidyu1 rcode = nf90_inq_varid(ncidp, 'pyv1', varidyv1) PRINT *, 'ncidp,varidyv1', ncidp, varidyv1 rcode = nf90_inq_varid(ncidp, 'ftsol1', varidfts1) PRINT *, 'ncidp,varidfts1', ncidp, varidfts1 rcode = nf90_inq_varid(ncidp, 'ftsol2', varidfts2) PRINT *, 'ncidp,varidfts2', ncidp, varidfts2 rcode = nf90_inq_varid(ncidp, 'ftsol3', varidfts3) PRINT *, 'ncidp,varidfts3', ncidp, varidfts3 rcode = nf90_inq_varid(ncidp, 'ftsol4', varidfts4) PRINT *, 'ncidp,varidfts4', ncidp, varidfts4 rcode = nf90_inq_varid(ncidp, 'psrf1', varidpsr1) PRINT *, 'ncidp,varidpsr1', ncidp, varidpsr1 rcode = nf90_inq_varid(ncidp, 'psrf2', varidpsr2) PRINT *, 'ncidp,varidpsr2', ncidp, varidpsr2 rcode = nf90_inq_varid(ncidp, 'psrf3', varidpsr3) PRINT *, 'ncidp,varidpsr3', ncidp, varidpsr3 rcode = nf90_inq_varid(ncidp, 'psrf4', varidpsr4) PRINT *, 'ncidp,varidpsr4', ncidp, varidpsr4 ! ID pour les dimensions status = nf90_inq_dimid(ncidp, 'y', yid) status = nf90_inq_dimid(ncidp, 'x', xid) status = nf90_inq_dimid(ncidp, 'sig_s', zid) status = nf90_inq_dimid(ncidp, 'time_counter', tid) ! lecture des dimensions status = nf90_inquire_dimension(ncidp, yid, namedim, ncjm) status = nf90_inquire_dimension(ncidp, xid, namedim, ncim) status = nf90_inquire_dimension(ncidp, zid, namedim, ncklevo) status = nf90_inquire_dimension(ncidp, tid, namedim, ncrec) zrec = ncrec zklevo = ncklevo zim = ncim zjm = ncjm zklono = zim*(zjm-2) + 2 WRITE (*, *) 'read_pstoke : zrec = ', zrec WRITE (*, *) 'read_pstoke : zklevo = ', zklevo WRITE (*, *) 'read_pstoke : zim = ', zim WRITE (*, *) 'read_pstoke : zjm = ', zjm WRITE (*, *) 'read_pstoke : zklono = ', zklono ! niveaux de pression status = nf90_get_var(ncidp, varidpl, pl, [1], [ncklevo]) ! lecture de aire et phis start(1) = 1 start(2) = 1 start(3) = 1 start(4) = 0 count(1) = zim count(2) = zjm count(3) = 1 count(4) = 0 ! phis status = nf90_get_var(ncidp, varidps, phisfi2, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, phisfi2, phisfi) ! aire status = nf90_get_var(ncidp, varidai, airefi2, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, airefi2, airefi) ELSE PRINT *, 'ok1' ! --------------------- ! lecture des champs ! --------------------- PRINT *, 'WARNING!!! Il n y a pas de test de coherence' PRINT *, 'sur le nombre de niveaux verticaux dans le fichier nc' start(1) = 1 start(2) = 1 start(3) = 1 start(4) = irec count(1) = zim count(2) = zjm count(3) = zklevo count(4) = 1 ! *** Lessivage****************************************************** ! frac_impa status = nf90_get_var(ncidp, varidfi, frac_impa2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, frac_impa2, frac_impa) ! frac_nucl status = nf90_get_var(ncidp, varidfn, frac_nucl2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, frac_nucl2, frac_nucl) ! *** Temperature ****************************************************** ! abder t status = nf90_get_var(ncidp, varidt, t2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, t2, t) ! *** Flux pour le calcul de la convection TIEDTK *********************** ! mfu status = nf90_get_var(ncidp, varidmfu, mfu2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, mfu2, mfu) ! mfd status = nf90_get_var(ncidp, varidmfd, mfd2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, mfd2, mfd) ! en_u status = nf90_get_var(ncidp, varidenu, en_u2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, en_u2, en_u) ! de_u status = nf90_get_var(ncidp, variddeu, de_u2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, de_u2, de_u) ! en_d status = nf90_get_var(ncidp, varidend, en_d2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, en_d2, en_d) ! de_d status = nf90_get_var(ncidp, varidded, de_d2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, de_d2, de_d) ! **** Coeffecient du mellange ! turbulent********************************** ! coefh status = nf90_get_var(ncidp, varidch, coefh2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, coefh2, coefh) ! *** Flux ascendant et entrant pour les ! Thermiques************************ ! abder thermiques status = nf90_get_var(ncidp, varidfmth, fm_therm2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, fm_therm2, fm_therm) status = nf90_get_var(ncidp, varidenth, en_therm2, start, count) CALL gr_ecrit_fi(klevo, klono, imo, jmo+1, en_therm2, en_therm) ! *** Vitesses aux sol ! ****************************************************** start(3) = irec start(4) = 0 count(3) = 1 count(4) = 0 ! pyu1 status = nf90_get_var(ncidp, varidyu1, pyu12, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, pyu12, pyu1) ! pyv1 status = nf90_get_var(ncidp, varidyv1, pyv12, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, pyv12, pyv1) ! *** Temperature au sol ******************************************** ! ftsol1 status = nf90_get_var(ncidp, varidfts1, ftsol12, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol12, ftsol1) ! ftsol2 status = nf90_get_var(ncidp, varidfts2, ftsol22, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol22, ftsol2) ! ftsol3 status = nf90_get_var(ncidp, varidfts3, ftsol32, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol32, ftsol3) ! ftsol4 status = nf90_get_var(ncidp, varidfts4, ftsol42, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, ftsol42, ftsol4) ! *** Nature du sol ************************************************** ! psrf1 status = nf90_get_var(ncidp, varidpsr1, psrf12, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf12, psrf1) ! psrf2 status = nf90_get_var(ncidp, varidpsr2, psrf22, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf22, psrf2) ! psrf3 status = nf90_get_var(ncidp, varidpsr3, psrf32, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf32, psrf3) ! psrf4 status = nf90_get_var(ncidp, varidpsr4, psrf42, start, count) CALL gr_ecrit_fi(1, klono, imo, jmo+1, psrf42, psrf4) DO i = 1, klono psrf(i, 1) = psrf1(i) psrf(i, 2) = psrf2(i) psrf(i, 3) = psrf3(i) psrf(i, 4) = psrf4(i) ftsol(i, 1) = ftsol1(i) ftsol(i, 2) = ftsol2(i) ftsol(i, 3) = ftsol3(i) ftsol(i, 4) = ftsol4(i) END DO END IF RETURN END SUBROUTINE read_pstoke