C C $Header$ C MODULE startvar ! ! ! There are three ways to access data from the database of atmospheric data which ! can be used to initialize the model. This depends on the type of field which needs ! to be extracted. In any case the call should come after a restget and should be of the type : ! CALL startget(...) ! ! We will details the possible arguments to startget here : ! ! - A 2D variable on the dynamical grid : ! CALL startget(varname, iml, jml, lon_in, lat_in, champ, val_ex, jml2, lon_in2, lat_in2, interbar ) ! ! - A 1D variable on the physical grid : ! CALL startget(varname, iml, jml, lon_in, lat_in, nbindex, champ, val_exp, jml2, lon_in2, lat_in2, interbar ) ! ! ! - A 3D variable on the dynamical grid : ! CALL startget(varname, iml, jml, lon_in, lat_in, lml, pls, workvar, champ, val_exp, jml2, lon_in2, lat_in2, interbar ) ! ! ! There is special constraint on the atmospheric data base except that the ! the data needs to be in netCDF and the variables should have the the following ! names in the file : ! ! 'RELIEF' : High resolution orography ! 'ST' : Surface temperature ! 'CDSW' : Soil moisture ! 'Z' : Surface geopotential ! 'SP' : Surface pressure ! 'U' : East ward wind ! 'V' : Northward wind ! 'TEMP' : Temperature ! 'R' : Relative humidity ! USE ioipsl ! ! IMPLICIT NONE ! ! PRIVATE PUBLIC startget ! ! INTERFACE startget MODULE PROCEDURE startget_phys2d, startget_phys1d, startget_dyn END INTERFACE ! INTEGER, SAVE :: fid_phys, fid_dyn INTEGER, SAVE :: iml_phys, iml_rel, iml_dyn INTEGER, SAVE :: jml_phys, jml_rel, jml_dyn INTEGER, SAVE :: llm_dyn, ttm_dyn REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: lon_phys, lon_rug, . lon_alb, lon_rel, lon_dyn REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: lat_phys, lat_rug, . lat_alb, lat_rel, lat_dyn REAL, ALLOCATABLE, SAVE, DIMENSION (:) :: levdyn_ini REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: relief, zstd, zsig, . zgam, zthe, zpic, zval REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: rugo, masque, phis ! REAL, ALLOCATABLE, SAVE, DIMENSION (:,:) :: tsol, qsol, psol_dyn REAL, ALLOCATABLE, SAVE, DIMENSION (:,:,:) :: var_ana3d ! CONTAINS ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! SUBROUTINE startget_phys2d(varname, iml, jml, lon_in, lat_in, . champ, val_exp, jml2, lon_in2, lat_in2 , interbar ) ! ! There is a big mess with the size in logitude, should it be iml or iml+1. ! I have chosen to use the iml+1 as an argument to this routine and we declare ! internaly smaler fields when needed. This needs to be cleared once and for all in LMDZ. ! A convention is required. ! ! CHARACTER*(*), INTENT(in) :: varname INTEGER, INTENT(in) :: iml, jml ,jml2 REAL, INTENT(in) :: lon_in(iml), lat_in(jml) REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) REAL, INTENT(inout) :: champ(iml,jml) REAL, INTENT(in) :: val_exp LOGICAL interbar ! ! This routine only works if the variable does not exist or is constant ! IF ( MINVAL(champ(:,:)).EQ.MAXVAL(champ(:,:)) .AND. .MINVAL(champ(:,:)).EQ.val_exp ) THEN ! SELECTCASE(varname) ! CASE ('relief') ! ! If we do not have the orography we need to get it ! IF ( .NOT.ALLOCATED(relief)) THEN ! CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2,lon_in2,lat_in2, interbar ) ! ENDIF ! IF (SIZE(relief) .NE. SIZE(champ)) THEN ! WRITE(*,*) 'STARTVAR module has been', .' initialized to the wrong size' STOP ! ENDIF ! champ(:,:) = relief(:,:) ! CASE ('rugosite') ! ! If we do not have the orography we need to get it ! IF ( .NOT.ALLOCATED(rugo)) THEN ! CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2,lon_in2,lat_in2 , interbar ) ! ENDIF ! IF (SIZE(rugo) .NE. SIZE(champ)) THEN ! WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ! ENDIF ! champ(:,:) = rugo(:,:) ! CASE ('masque') ! ! If we do not have the orography we need to get it ! IF ( .NOT.ALLOCATED(masque)) THEN ! CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2,lon_in2,lat_in2 , interbar ) ! ENDIF ! IF (SIZE(masque) .NE. SIZE(champ)) THEN ! WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ! ENDIF ! champ(:,:) = masque(:,:) ! CASE ('surfgeo') ! ! If we do not have the orography we need to get it ! IF ( .NOT.ALLOCATED(phis)) THEN ! CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2,lon_in2, lat_in2 , interbar ) ! ENDIF ! IF (SIZE(phis) .NE. SIZE(champ)) THEN ! WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ! ENDIF ! champ(:,:) = phis(:,:) ! CASE ('psol') ! ! If we do not have the orography we need to get it ! IF ( .NOT.ALLOCATED(psol_dyn)) THEN ! CALL start_init_dyn( iml, jml, lon_in, lat_in, . jml2,lon_in2, lat_in2 , interbar ) ! ENDIF ! IF (SIZE(psol_dyn) .NE. SIZE(champ)) THEN ! WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ! ENDIF ! champ(:,:) = psol_dyn(:,:) ! CASE DEFAULT ! WRITE(*,*) 'startget_phys2d' WRITE(*,*) 'No rule is present to extract variable', . varname(:LEN_TRIM(varname)),' from any data set' STOP ! END SELECT ! ELSE ! ! There are a few fields we might need if we need to interpolate 3D filed. Thus if they come through here we ! will catch them ! SELECTCASE(varname) ! CASE ('surfgeo') ! IF ( .NOT.ALLOCATED(phis)) THEN ALLOCATE(phis(iml,jml)) ENDIF ! IF (SIZE(phis) .NE. SIZE(champ)) THEN ! WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ! ENDIF ! phis(:,:) = champ(:,:) ! END SELECT ! ENDIF ! END SUBROUTINE startget_phys2d ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! SUBROUTINE start_init_orog ( iml,jml,lon_in, lat_in,jml2,lon_in2 , , lat_in2 , interbar ) ! INTEGER, INTENT(in) :: iml, jml, jml2 REAL, INTENT(in) :: lon_in(iml), lat_in(jml) REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) LOGICAL interbar ! ! LOCAL ! LOGICAL interbar2 REAL :: lev(1), date, dt,chmin,chmax INTEGER :: itau(1), fid INTEGER :: llm_tmp, ttm_tmp INTEGER :: i, j INTEGER :: iret CHARACTER*25 title REAL, ALLOCATABLE :: relief_hi(:,:) REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) REAL, ALLOCATABLE :: tmp_var(:,:) INTEGER, ALLOCATABLE :: tmp_int(:,:) ! CHARACTER*120 :: orogfname LOGICAL :: check=.TRUE. ! ! orogfname = 'Relief.nc' ! IF ( check ) WRITE(*,*) 'Reading the high resolution orography' ! CALL flininfo(orogfname,iml_rel, jml_rel, llm_tmp, ttm_tmp, fid) ! ALLOCATE (lat_rel(iml_rel,jml_rel), stat=iret) ALLOCATE (lon_rel(iml_rel,jml_rel), stat=iret) ALLOCATE (relief_hi(iml_rel,jml_rel), stat=iret) ! CALL flinopen(orogfname, .FALSE., iml_rel, jml_rel, .llm_tmp, lon_rel, lat_rel, lev, ttm_tmp, . itau, date, dt, fid) ! CALL flinget(fid, 'RELIEF', iml_rel, jml_rel, llm_tmp, . ttm_tmp, 1, 1, relief_hi) ! CALL flinclo(fid) ! ! In case we have a file which is in degrees we do the transformation ! ALLOCATE(lon_rad(iml_rel)) ALLOCATE(lon_ini(iml_rel)) IF ( MAXVAL(lon_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN lon_ini(:) = lon_rel(:,1) * 2.0 * ASIN(1.0) / 180.0 ELSE lon_ini(:) = lon_rel(:,1) ENDIF ALLOCATE(lat_rad(jml_rel)) ALLOCATE(lat_ini(jml_rel)) IF ( MAXVAL(lat_rel(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN lat_ini(:) = lat_rel(1,:) * 2.0 * ASIN(1.0) / 180.0 ELSE lat_ini(:) = lat_rel(1,:) ENDIF ! ! title='RELIEF' interbar2 = .FALSE. CALL conf_dat2d(title,iml_rel, jml_rel, lon_ini, lat_ini, . lon_rad, lat_rad, relief_hi , interbar2 ) IF ( check ) WRITE(*,*) 'Computes all the parameters needed', .' for the gravity wave drag code' ! ! Allocate the data we need to put in the interpolated fields ! ! RELIEF: orographie moyenne ALLOCATE(relief(iml,jml)) ! zphi : orographie moyenne ALLOCATE(phis(iml,jml)) ! zstd: deviation standard de l'orographie sous-maille ALLOCATE(zstd(iml,jml)) ! zsig: pente de l'orographie sous-maille ALLOCATE(zsig(iml,jml)) ! zgam: anisotropy de l'orographie sous maille ALLOCATE(zgam(iml,jml)) ! zthe: orientation de l'axe oriente dans la direction ! de plus grande pente de l'orographie sous maille ALLOCATE(zthe(iml,jml)) ! zpic: hauteur pics de la SSO ALLOCATE(zpic(iml,jml)) ! zval: hauteur vallees de la SSO ALLOCATE(zval(iml,jml)) ! masque : Masque terre ocean ALLOCATE(tmp_int(iml,jml)) ALLOCATE(masque(iml,jml)) ! CALL grid_noro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, . iml-1, jml, lon_in, lat_in, . phis, relief, zstd, zsig, zgam, zthe, zpic, zval, masque) phis = phis * 9.81 ! ! masque(:,:) = FLOAT(tmp_int(:,:)) ! ! Compute surface roughness ! IF ( check ) WRITE(*,*) .'Compute surface roughness induced by the orography' ! ALLOCATE(rugo(iml,jml)) ALLOCATE(tmp_var(iml-1,jml)) ! CALL rugsoro(iml_rel, jml_rel, lon_rad, lat_rad, relief_hi, . iml-1, jml, lon_in, lat_in, tmp_var) ! DO j = 1, jml DO i = 1, iml-1 rugo(i,j) = tmp_var(i,j) ENDDO rugo(iml,j) = tmp_var(1,j) ENDDO c cc *** rugo n'est pas utilise pour l'instant ****** ! ! Build land-sea mask ! ! RETURN ! END SUBROUTINE start_init_orog ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! SUBROUTINE startget_phys1d(varname, iml, jml, lon_in, .lat_in, nbindex, champ, val_exp ,jml2, lon_in2, lat_in2,interbar) ! CHARACTER*(*), INTENT(in) :: varname INTEGER, INTENT(in) :: iml, jml, nbindex, jml2 REAL, INTENT(in) :: lon_in(iml), lat_in(jml) REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) REAL, INTENT(inout) :: champ(nbindex) REAL, INTENT(in) :: val_exp LOGICAL interbar ! ! ! This routine only works if the variable does not exist or is constant ! IF ( MINVAL(champ(:)).EQ.MAXVAL(champ(:)) .AND. .MINVAL(champ(:)).EQ.val_exp ) THEN SELECTCASE(varname) CASE ('tsol') IF ( .NOT.ALLOCATED(tsol)) THEN CALL start_init_phys( iml, jml, lon_in, lat_in, . jml2, lon_in2, lat_in2, interbar ) ENDIF IF ( SIZE(tsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex, tsol, champ) CASE ('qsol') IF ( .NOT.ALLOCATED(qsol)) THEN CALL start_init_phys( iml, jml, lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF ( SIZE(qsol) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex, qsol, champ) CASE ('psol') IF ( .NOT.ALLOCATED(psol_dyn)) THEN CALL start_init_dyn( iml, jml, lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF (SIZE(psol_dyn) .NE. SIZE(lon_in)*SIZE(lat_in)) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex, psol_dyn, champ) ! PB ajout pour masque terre mer fractionneiare CASE ('zmasq') IF (.NOT. ALLOCATED(masque) ) THEN CALL start_init_orog ( iml, jml,lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF ( SIZE(masque) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex, masque, champ) CASE ('zmea') IF ( .NOT.ALLOCATED(relief)) THEN CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF ( SIZE(relief) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex, relief, champ) CASE ('zstd') IF ( .NOT.ALLOCATED(zstd)) THEN CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF ( SIZE(zstd) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex,zstd, champ) CASE ('zsig') IF ( .NOT.ALLOCATED(zsig)) THEN CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF ( SIZE(zsig) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex,zsig, champ) CASE ('zgam') IF ( .NOT.ALLOCATED(zgam)) THEN CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF ( SIZE(zgam) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex,zgam, champ) CASE ('zthe') IF ( .NOT.ALLOCATED(zthe)) THEN CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF ( SIZE(zthe) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex,zthe, champ) CASE ('zpic') IF ( .NOT.ALLOCATED(zpic)) THEN CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF ( SIZE(zpic) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex,zpic, champ) CASE ('zval') IF ( .NOT.ALLOCATED(zval)) THEN CALL start_init_orog( iml, jml, lon_in, lat_in, . jml2, lon_in2,lat_in2 , interbar ) ENDIF IF ( SIZE(zval) .NE. SIZE(lon_in)*SIZE(lat_in) ) THEN WRITE(*,*) . 'STARTVAR module has been initialized to the wrong size' STOP ENDIF CALL gr_dyn_fi(1, iml, jml, nbindex,zval, champ) CASE ('rads') champ(:) = 0.0 CASE ('snow') champ(:) = 0.0 CASE ('deltat') champ(:) = 0.0 CASE ('rugmer') champ(:) = 0.001 CASE ('agsno') champ(:) = 50.0 CASE DEFAULT WRITE(*,*) 'startget_phys1d' WRITE(*,*) 'No rule is present to extract variable ', . varname(:LEN_TRIM(varname)),' from any data set' STOP END SELECT ELSE ! ! If we see tsol we catch it as we may need it for a 3D interpolation ! SELECTCASE(varname) CASE ('tsol') IF ( .NOT.ALLOCATED(tsol)) THEN ALLOCATE(tsol(SIZE(lon_in),SIZE(lat_in) )) ENDIF CALL gr_fi_dyn(1, iml, jml, nbindex, champ, tsol) END SELECT ENDIF END SUBROUTINE startget_phys1d !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! SUBROUTINE start_init_phys( iml, jml, lon_in, lat_in, jml2, . lon_in2, lat_in2 , interbar ) ! INTEGER, INTENT(in) :: iml, jml ,jml2 REAL, INTENT(in) :: lon_in(iml), lat_in(jml) REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) LOGICAL interbar ! ! LOCAL ! REAL :: lev(1), date, dt INTEGER :: itau(1) INTEGER :: llm_tmp, ttm_tmp INTEGER :: i, j ! CHARACTER*25 title CHARACTER*120 :: physfname LOGICAL :: check=.TRUE. ! REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:) ! physfname = 'ECPHY.nc' ! IF ( check ) WRITE(*,*) 'Opening the surface analysis' ! CALL flininfo(physfname, iml_phys, jml_phys, llm_tmp, . ttm_tmp, fid_phys) ! ! ALLOCATE (lat_phys(iml_phys,jml_phys)) ALLOCATE (lon_phys(iml_phys,jml_phys)) ! CALL flinopen(physfname, .FALSE., iml_phys, jml_phys, . llm_tmp, lon_phys, lat_phys, lev, ttm_tmp, . itau, date, dt, fid_phys) ! ! Allocate the space we will need to get the data out of this file ! ALLOCATE(var_ana(iml_phys, jml_phys)) ! ! In case we have a file which is in degrees we do the transformation ! ALLOCATE(lon_rad(iml_phys)) ALLOCATE(lon_ini(iml_phys)) IF ( MAXVAL(lon_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN lon_ini(:) = lon_phys(:,1) * 2.0 * ASIN(1.0) / 180.0 ELSE lon_ini(:) = lon_phys(:,1) ENDIF ALLOCATE(lat_rad(jml_phys)) ALLOCATE(lat_ini(jml_phys)) IF ( MAXVAL(lat_phys(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN lat_ini(:) = lat_phys(1,:) * 2.0 * ASIN(1.0) / 180.0 ELSE lat_ini(:) = lat_phys(1,:) ENDIF ! ! We get the two standard varibales ! Surface temperature ! ALLOCATE(tsol(iml,jml)) ALLOCATE(tmp_var(iml-1,jml)) ! ! CALL flinget(fid_phys, 'ST', iml_phys, jml_phys, .llm_tmp, ttm_tmp, 1, 1, var_ana) title='ST' CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, . lon_rad, lat_rad, var_ana , interbar ) IF ( interbar ) THEN WRITE(6,*) '-------------------------------------------------', ,'--------------' WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', , ' pour ST $$$ ' WRITE(6,*) '-------------------------------------------------', ,'--------------' CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad , , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var ) ELSE CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad, . var_ana, iml-1, jml, lon_in, lat_in, tmp_var ) ENDIF CALL gr_int_dyn(tmp_var, tsol, iml-1, jml) ! ! Soil moisture ! ALLOCATE(qsol(iml,jml)) CALL flinget(fid_phys, 'CDSW', iml_phys, jml_phys, . llm_tmp, ttm_tmp, 1, 1, var_ana) title='CDSW' CALL conf_dat2d(title,iml_phys, jml_phys, lon_ini, lat_ini, . lon_rad, lat_rad, var_ana, interbar ) IF ( interbar ) THEN WRITE(6,*) '-------------------------------------------------', ,'--------------' WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', , ' pour CDSW $$$ ' WRITE(6,*) '-------------------------------------------------', ,'--------------' CALL inter_barxy ( iml_phys,jml_phys -1,lon_rad,lat_rad , , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var ) ELSE CALL grille_m(iml_phys, jml_phys, lon_rad, lat_rad, . var_ana, iml-1, jml, lon_in, lat_in, tmp_var ) ENDIF c CALL gr_int_dyn(tmp_var, qsol, iml-1, jml) ! CALL flinclo(fid_phys) ! END SUBROUTINE start_init_phys ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! SUBROUTINE startget_dyn(varname, iml, jml, lon_in, lat_in, . lml, pls, workvar, champ, val_exp,jml2, lon_in2, lat_in2 , , interbar ) ! ! ARGUMENTS ! CHARACTER*(*), INTENT(in) :: varname INTEGER, INTENT(in) :: iml, jml, lml, jml2 REAL, INTENT(in) :: lon_in(iml), lat_in(jml) REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) REAL, INTENT(in) :: pls(iml, jml, lml) REAL, INTENT(in) :: workvar(iml, jml, lml) REAL, INTENT(inout) :: champ(iml, jml, lml) REAL, INTENT(in) :: val_exp LOGICAL interbar ! ! LOCAL ! INTEGER :: il, ij, ii REAL :: xppn, xpps ! #include "dimensions.h" #include "paramet.h" #include "comgeom2.h" #include "comconst.h" ! ! This routine only works if the variable does not exist or is constant ! IF ( MINVAL(champ(:,:,:)).EQ.MAXVAL(champ(:,:,:)) .AND. . MINVAL(champ(:,:,:)).EQ.val_exp ) THEN ! SELECTCASE(varname) CASE ('u') IF ( .NOT.ALLOCATED(psol_dyn)) THEN CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , . lon_in2,lat_in2 , interbar ) ENDIF CALL start_inter_3d('U', iml, jml, lml, lon_in, . lat_in, jml2, lon_in2, lat_in2, pls, champ,interbar ) DO il=1,lml DO ij=1,jml DO ii=1,iml-1 champ(ii,ij,il) = champ(ii,ij,il) * cu(ii,ij) ENDDO champ(iml,ij, il) = champ(1,ij, il) ENDDO ENDDO CASE ('v') IF ( .NOT.ALLOCATED(psol_dyn)) THEN CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2, . lon_in2, lat_in2 , interbar ) ENDIF CALL start_inter_3d('V', iml, jml, lml, lon_in, . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) DO il=1,lml DO ij=1,jml DO ii=1,iml-1 champ(ii,ij,il) = champ(ii,ij,il) * cv(ii,ij) ENDDO champ(iml,ij, il) = champ(1,ij, il) ENDDO ENDDO CASE ('t') IF ( .NOT.ALLOCATED(psol_dyn)) THEN CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , . lon_in2, lat_in2 ,interbar ) ENDIF CALL start_inter_3d('TEMP', iml, jml, lml, lon_in, . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) CASE ('tpot') IF ( .NOT.ALLOCATED(psol_dyn)) THEN CALL start_init_dyn( iml, jml, lon_in, lat_in , jml2 , . lon_in2, lat_in2 , interbar ) ENDIF CALL start_inter_3d('TEMP', iml, jml, lml, lon_in, . lat_in, jml2, lon_in2, lat_in2, pls, champ, interbar ) IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) . THEN DO il=1,lml DO ij=1,jml DO ii=1,iml-1 champ(ii,ij,il) = champ(ii,ij,il) * cpp . / workvar(ii,ij,il) ENDDO champ(iml,ij,il) = champ(1,ij,il) ENDDO ENDDO DO il=1,lml xppn = SUM(aire(:,1)*champ(:,1,il))/apoln xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols champ(:,1,il) = xppn champ(:,jml,il) = xpps ENDDO ELSE WRITE(*,*)'Could not compute potential temperature as the' WRITE(*,*)'Exner function is missing or constant.' STOP ENDIF CASE ('q') IF ( .NOT.ALLOCATED(psol_dyn)) THEN CALL start_init_dyn( iml, jml, lon_in, lat_in, jml2 , . lon_in2, lat_in2 , interbar ) ENDIF CALL start_inter_3d('R', iml, jml, lml, lon_in, lat_in, . jml2, lon_in2, lat_in2, pls, champ, interbar ) IF ( MINVAL(workvar(:,:,:)) .NE. MAXVAL(workvar(:,:,:)) ) . THEN DO il=1,lml DO ij=1,jml DO ii=1,iml-1 champ(ii,ij,il) = 0.01 * champ(ii,ij,il) * . workvar(ii,ij,il) ENDDO champ(iml,ij,il) = champ(1,ij,il) ENDDO ENDDO WHERE ( champ .LT. 0.) champ = 1.0E-10 DO il=1,lml xppn = SUM(aire(:,1)*champ(:,1,il))/apoln xpps = SUM(aire(:,jml)*champ(:,jml,il))/apols champ(:,1,il) = xppn champ(:,jml,il) = xpps ENDDO ELSE WRITE(*,*)'Could not compute specific humidity as the' WRITE(*,*)'saturated humidity is missing or constant.' STOP ENDIF CASE DEFAULT WRITE(*,*) 'startget_dyn' WRITE(*,*) 'No rule is present to extract variable ', . varname(:LEN_TRIM(varname)),' from any data set' STOP END SELECT ENDIF END SUBROUTINE startget_dyn ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! SUBROUTINE start_init_dyn( iml, jml, lon_in, lat_in,jml2,lon_in2 , , lat_in2 , interbar ) ! INTEGER, INTENT(in) :: iml, jml, jml2 REAL, INTENT(in) :: lon_in(iml), lat_in(jml) REAL, INTENT(in) :: lon_in2(iml), lat_in2(jml2) LOGICAL interbar ! ! LOCAL ! REAL :: lev(1), date, dt INTEGER :: itau(1) INTEGER :: i, j integer :: iret ! CHARACTER*120 :: physfname LOGICAL :: check=.TRUE. ! REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) REAL, ALLOCATABLE :: var_ana(:,:), tmp_var(:,:), z(:,:) REAL, ALLOCATABLE :: xppn(:), xpps(:) LOGICAL :: allo ! ! #include "dimensions.h" #include "paramet.h" #include "comgeom2.h" CHARACTER*25 title ! physfname = 'ECDYN.nc' ! IF ( check ) WRITE(*,*) 'Opening the surface analysis' ! CALL flininfo(physfname, iml_dyn, jml_dyn, llm_dyn, . ttm_dyn, fid_dyn) IF ( check ) WRITE(*,*) 'Values read: ', iml_dyn, jml_dyn, . llm_dyn, ttm_dyn ! ALLOCATE (lat_dyn(iml_dyn,jml_dyn), stat=iret) ALLOCATE (lon_dyn(iml_dyn,jml_dyn), stat=iret) ALLOCATE (levdyn_ini(llm_dyn), stat=iret) ! CALL flinopen(physfname, .FALSE., iml_dyn, jml_dyn, llm_dyn, . lon_dyn, lat_dyn, levdyn_ini, ttm_dyn, . itau, date, dt, fid_dyn) ! allo = allocated (var_ana) if (allo) then DEALLOCATE(var_ana, stat=iret) endif ALLOCATE(var_ana(iml_dyn, jml_dyn), stat=iret) allo = allocated (lon_rad) if (allo) then DEALLOCATE(lon_rad, stat=iret) endif ALLOCATE(lon_rad(iml_dyn), stat=iret) ALLOCATE(lon_ini(iml_dyn)) IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0 ELSE lon_ini(:) = lon_dyn(:,1) ENDIF ALLOCATE(lat_rad(jml_dyn)) ALLOCATE(lat_ini(jml_dyn)) IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0 ELSE lat_ini(:) = lat_dyn(1,:) ENDIF ! ALLOCATE(z(iml, jml)) ALLOCATE(tmp_var(iml-1,jml)) ! CALL flinget(fid_dyn, 'Z', iml_dyn, jml_dyn, 0, ttm_dyn, . 1, 1, var_ana) c title='Z' CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini, . lon_rad, lat_rad, var_ana, interbar ) c IF ( interbar ) THEN WRITE(6,*) '-------------------------------------------------', ,'--------------' WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', , ' pour Z $$$ ' WRITE(6,*) '-------------------------------------------------', ,'--------------' CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad , , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) ELSE CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana, . iml-1, jml, lon_in, lat_in, tmp_var) ENDIF CALL gr_int_dyn(tmp_var, z, iml-1, jml) ! ALLOCATE(psol_dyn(iml, jml)) ! CALL flinget(fid_dyn, 'SP', iml_dyn, jml_dyn, 0, ttm_dyn, . 1, 1, var_ana) title='SP' CALL conf_dat2d( title,iml_dyn, jml_dyn,lon_ini, lat_ini, . lon_rad, lat_rad, var_ana, interbar ) IF ( interbar ) THEN WRITE(6,*) '-------------------------------------------------', ,'--------------' WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', , ' pour SP $$$ ' WRITE(6,*) '-------------------------------------------------', ,'--------------' CALL inter_barxy ( iml_dyn,jml_dyn -1,lon_rad,lat_rad , , var_ana, iml-1, jml-1, lon_in2, lat_in2, jml, tmp_var) ELSE CALL grille_m(iml_dyn, jml_dyn , lon_rad, lat_rad, var_ana, . iml-1, jml, lon_in, lat_in, tmp_var ) ENDIF CALL gr_int_dyn(tmp_var, psol_dyn, iml-1, jml) ! IF ( .NOT.ALLOCATED(tsol)) THEN ! These variables may have been allocated by the need to ! create a start field for them or by the varibale ! coming out of the restart file. In case we dor have it we will initialize it. ! CALL start_init_phys( iml, jml, lon_in, lat_in,jml2,lon_in2, . lat_in2 , interbar ) ELSE IF ( SIZE(tsol) .NE. SIZE(psol_dyn) ) THEN WRITE(*,*) 'start_init_dyn :' WRITE(*,*) 'The temperature field we have does not ', . 'have the right size' STOP ENDIF ENDIF IF ( .NOT.ALLOCATED(phis)) THEN ! ! These variables may have been allocated by the need to create a start field for them or by the varibale ! coming out of the restart file. In case we dor have it we will initialize it. ! CALL start_init_orog( iml, jml, lon_in, lat_in, jml2, lon_in2 , . lat_in2 , interbar ) ! ELSE ! IF (SIZE(phis) .NE. SIZE(psol_dyn)) THEN ! WRITE(*,*) 'start_init_dyn :' WRITE(*,*) 'The orography field we have does not ', . ' have the right size' STOP ENDIF ! ENDIF ! ! PSOL is computed in Pascals ! ! DO j = 1, jml DO i = 1, iml-1 psol_dyn(i,j) = psol_dyn(i,j)*(1.0+(z(i,j)-phis(i,j)) . /287.0/tsol(i,j)) ENDDO psol_dyn(iml,j) = psol_dyn(1,j) ENDDO ! ! ALLOCATE(xppn(iml-1)) ALLOCATE(xpps(iml-1)) ! DO i = 1, iml-1 xppn(i) = aire( i,1) * psol_dyn( i,1) xpps(i) = aire( i,jml) * psol_dyn( i,jml) ENDDO ! DO i = 1, iml psol_dyn(i,1 ) = SUM(xppn)/apoln psol_dyn(i,jml) = SUM(xpps)/apols ENDDO ! RETURN ! END SUBROUTINE start_init_dyn ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! SUBROUTINE start_inter_3d(varname, iml, jml, lml, lon_in, . lat_in, jml2, lon_in2, lat_in2, pls_in, var3d, interbar ) ! ! This subroutine gets a variables from a 3D file and does the interpolations needed ! ! ! ARGUMENTS ! CHARACTER*(*) :: varname INTEGER :: iml, jml, lml, jml2 REAL :: lon_in(iml), lat_in(jml), pls_in(iml, jml, lml) REAL :: lon_in2(iml) , lat_in2(jml2) REAL :: var3d(iml, jml, lml) LOGICAL interbar real chmin,chmax ! ! LOCAL ! CHARACTER*25 title INTEGER :: ii, ij, il, jsort,i,j,l REAL :: bx, by REAL, ALLOCATABLE :: lon_rad(:), lat_rad(:) REAL, ALLOCATABLE :: lon_ini(:), lat_ini(:) , lev_dyn(:) REAL, ALLOCATABLE :: var_tmp2d(:,:), var_tmp3d(:,:,:) REAL, ALLOCATABLE :: ax(:), ay(:), yder(:) REAL, ALLOCATABLE :: varrr(:,:,:) INTEGER, ALLOCATABLE :: lind(:) ! LOGICAL :: check = .TRUE. ! IF ( .NOT. ALLOCATED(var_ana3d)) THEN ALLOCATE(var_ana3d(iml_dyn, jml_dyn, llm_dyn)) ENDIF ALLOCATE(varrr(iml_dyn, jml_dyn, llm_dyn)) ! ! IF ( check) WRITE(*,*) 'Going into flinget to extract the 3D ', . ' field.', fid_dyn IF ( check) WRITE(*,*) fid_dyn, varname, iml_dyn, jml_dyn, . llm_dyn,ttm_dyn ! CALL flinget(fid_dyn, varname, iml_dyn, jml_dyn, llm_dyn, . ttm_dyn, 1, 1, var_ana3d) ! IF ( check) WRITE(*,*) 'Allocating space for the interpolation', . iml, jml, llm_dyn ! ALLOCATE(lon_rad(iml_dyn)) ALLOCATE(lon_ini(iml_dyn)) IF ( MAXVAL(lon_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN lon_ini(:) = lon_dyn(:,1) * 2.0 * ASIN(1.0) / 180.0 ELSE lon_ini(:) = lon_dyn(:,1) ENDIF ALLOCATE(lat_rad(jml_dyn)) ALLOCATE(lat_ini(jml_dyn)) ALLOCATE(lev_dyn(llm_dyn)) IF ( MAXVAL(lat_dyn(:,:)) .GT. 2.0 * ASIN(1.0) ) THEN lat_ini(:) = lat_dyn(1,:) * 2.0 * ASIN(1.0) / 180.0 ELSE lat_ini(:) = lat_dyn(1,:) ENDIF ! CALL conf_dat3d ( varname,iml_dyn, jml_dyn, llm_dyn, lon_ini, . lat_ini, levdyn_ini, lon_rad, lat_rad, lev_dyn, var_ana3d , , interbar ) ALLOCATE(var_tmp2d(iml-1, jml)) ALLOCATE(var_tmp3d(iml, jml, llm_dyn)) ALLOCATE(ax(llm_dyn)) ALLOCATE(ay(llm_dyn)) ALLOCATE(yder(llm_dyn)) ALLOCATE(lind(llm_dyn)) ! DO il=1,llm_dyn ! IF( interbar ) THEN IF( il.EQ.1 ) THEN WRITE(6,*) '-------------------------------------------------', ,'--------------' WRITE(6,*) '$$$ Utilisation de l interpolation barycentrique ', , ' pour ', varname WRITE(6,*) '-------------------------------------------------', ,'--------------' ENDIF CALL inter_barxy ( iml_dyn, jml_dyn -1,lon_rad, lat_rad, , var_ana3d(:,:,il),iml-1, jml2, lon_in2, lat_in2,jml,var_tmp2d ) ELSE CALL grille_m(iml_dyn, jml_dyn, lon_rad, lat_rad, . var_ana3d(:,:,il), iml-1, jml, lon_in, lat_in, var_tmp2d ) ENDIF ! CALL gr_int_dyn(var_tmp2d, var_tmp3d(:,:,il), iml-1, jml) ! ENDDO ! DO il=1,llm_dyn lind(il) = llm_dyn-il+1 ENDDO ! c c ... Pour l'interpolation verticale ,on interpole du haut de l'atmosphere c vers le sol ... c DO ij=1,jml DO ii=1,iml-1 ! ax(:) = lev_dyn(lind(:)) ay(:) = var_tmp3d(ii, ij, lind(:)) ! CALL SPLINE(ax, ay, llm_dyn, 1.e30, 1.e30, yder) ! DO il=1,lml bx = pls_in(ii, ij, il) CALL SPLINT(ax, ay, yder, llm_dyn, bx, by) var3d(ii, ij, il) = by ENDDO ! ENDDO var3d(iml, ij, :) = var3d(1, ij, :) ENDDO do il=1,lml call minmax(iml*jml,var3d(1,1,il),chmin,chmax) SELECTCASE(varname) CASE('U') WRITE(*,*) ' U min max l ',il,chmin,chmax CASE('V') WRITE(*,*) ' V min max l ',il,chmin,chmax CASE('TEMP') WRITE(*,*) ' TEMP min max l ',il,chmin,chmax CASE('R') WRITE(*,*) ' R min max l ',il,chmin,chmax END SELECT enddo DEALLOCATE(lon_rad) DEALLOCATE(lat_rad) DEALLOCATE(var_tmp2d) DEALLOCATE(var_tmp3d) DEALLOCATE(ax) DEALLOCATE(ay) DEALLOCATE(yder) DEALLOCATE(lind) ! RETURN ! END SUBROUTINE start_inter_3d ! END MODULE startvar