51 USE modd_topodyn, ONLY : ccat, nncat, xrtop_d2, nmesht, xdxt
53 xxi, xyi, nmaski, nmaskt, nnpix,&
54 nnbv_in_mesh, xbv_in_mesh, xtotbv_in_mesh
65 USE modi_read_nam_pgd_topd
68 USE modi_make_mask_topd_to_isba
69 USE modi_make_mask_isba_to_topd
70 USE modi_write_file_masktopd
75 USE yomhook
,ONLY : lhook, dr_hook
76 USE parkind1
,ONLY : jprb
84 TYPE(isba_t
),
INTENT(INOUT) :: i
89 CHARACTER(LEN=*),
INTENT(IN) :: hprogram
91 CHARACTER(LEN=50),
DIMENSION(NNCAT) :: cname
93 INTEGER :: jj,ji,jk,jwrk
94 INTEGER :: jcat,jmesh,jpix
99 REAL,
DIMENSION(:),
ALLOCATABLE :: zxi, zyi
100 REAL,
DIMENSION(:),
ALLOCATABLE :: zdxi, zdyi
101 REAL,
DIMENSION(:),
ALLOCATABLE :: zxn, zyn
102 REAL,
DIMENSION(:),
ALLOCATABLE :: zlat,zlon
103 REAL,
DIMENSION(:),
ALLOCATABLE :: zdtav
106 REAL :: zlonmin,zlonmax
107 REAL :: zlatmin,zlatmax
117 REAL,
DIMENSION(:),
ALLOCATABLE :: zf_param,zc_depth_ratio
118 REAL(KIND=JPRB) :: zhook_handle
120 IF (lhook) CALL dr_hook(
'PGD_TOPD',0,zhook_handle)
126 IF (lcoupl_topd .AND. (i%CISBA/=
'3-L'.AND. i%CISBA/=
'DIF')) &
127 CALL
abor1_sfx(
"PGD_TOPD: coupling with topmodel only runs with CISBA=3-L or CISBA=DIF ")
131 IF (lcoupl_topd)
THEN
133 WRITE(iluout,*)
'Debut pgd_topd'
137 WRITE(iluout,*)
'NNCAT',nncat
150 ALLOCATE(nmaskt(nncat,nmesht))
153 IF(ug%CGRID.EQ.
'CONF PROJ')
THEN
155 WRITE(iluout,*)
'GRILLE PROJ CONF (application Cevennes)'
160 ALLOCATE(zxi(u%NDIM_FULL))
161 ALLOCATE(zyi(u%NDIM_FULL))
165 ALLOCATE(zdxi(u%NDIM_FULL))
166 ALLOCATE(zdyi(u%NDIM_FULL))
169 pbeta=zbeta,plator=zlator,plonor=zlonor, &
170 kimax=nimax,kjmax=njmax,px=zxi,py=zyi, &
173 imeshl = (nimax+1)*(njmax+1)
177 ALLOCATE(zxn(imeshl))
178 ALLOCATE(zyn(imeshl))
181 zxn(jj) = zxi(jj) - zdxi(jj)/2.
183 zxn(nimax+1) = zxi(nimax) + zdxi(nimax)/2.
186 jwrk = (jj-1)*(nimax+1)+1
188 zyn(jwrk) = zyi(ji) - zdyi(ji)/2.
191 jj = ((njmax+1)-1)*(nimax+1)+1
192 ji = (njmax-1)*nimax+1
193 zyn(jj) = zyi(ji) + zdyi(ji)/2.
202 jk = (ji-1)*(nimax+1)+jj
209 jk = (ji-1)*(nimax+1)+jj
210 jwrk = (ji-1)*(nimax+1)+1
217 ALLOCATE(zlat(imeshl))
218 ALLOCATE(zlon(imeshl))
219 CALL
latlon_conf_proj(zlat0,zlon0,zrpk,zbeta,zlator,zlonor,zxn,zyn,zlat,zlon)
226 ELSE IF(ug%CGRID.EQ.
'LONLAT REG')
THEN
228 WRITE(iluout,*)
'GRILLE LONLAT REG (application AMMA)'
230 ALLOCATE(zxi(u%NDIM_FULL))
231 ALLOCATE(zyi(u%NDIM_FULL))
235 platmin=zlatmin,platmax=zlatmax,klon=nimax,klat=njmax, &
236 kl=il,plon=zxi,plat=zyi)
238 imeshl=(nimax+1)*(njmax+1)
240 ALLOCATE(zlon(imeshl))
241 ALLOCATE(zlat(imeshl))
242 ALLOCATE(zdxi(u%NDIM_FULL))
243 ALLOCATE(zdyi(u%NDIM_FULL))
245 zdxi(:)=(zlonmax-zlonmin)/(nimax-1)
246 zdyi(:)=(zlatmax-zlatmin)/(njmax-1)
249 zlon(jj) = zxi(jj) - zdxi(jj)/2.
251 zlon(nimax+1) = zxi(nimax) + zdxi(nimax)/2.
254 jwrk=(jj-1)*(nimax+1)+1
256 zlat(jwrk) = zyi(ji) - zdyi(ji)/2.
259 jj=((njmax+1)-1)*(nimax+1)+1
261 zlat(jj) = zyi(ji) + zdyi(ji)/2.
270 jk = (ji-1)*(nimax+1)+jj
277 jk=(ji-1)*(nimax+1)+jj
278 jwrk=(ji-1)*(nimax+1)+1
284 ELSE IF (ug%CGRID==
'IGN')
THEN
285 WRITE(iluout,*)
'GRILLE IGN (application Bulgarie)'
286 ALLOCATE(zxn(u%NDIM_FULL))
287 ALLOCATE(zyn(u%NDIM_FULL))
289 kl=il,px=zxn,py=zyn,kdimx=nimax)
291 ALLOCATE(zlat(imeshl))
292 ALLOCATE(zlon(imeshl))
297 WRITE(iluout,*)
'ERREUR: TYPE DE GRILLE NON GERE PAR LE CODE'
298 CALL
abor1_sfx(
"PGD_TOPD: TYPE DE GRILLE NON GERE PAR LE CODE")
305 ALLOCATE(xxi(imeshl))
306 ALLOCATE(xyi(imeshl))
308 IF (ug%CGRID/=
'IGN')
THEN
309 CALL
xy_ign(5,xxi,xyi,zlat,zlon)
326 ALLOCATE(nnpix(u%NDIM_FULL))
329 nnpix(jj) = count(nmaskt(:,:)==jj)
344 ALLOCATE(nnbv_in_mesh(u%NDIM_FULL,nncat))
345 ALLOCATE(xbv_in_mesh(u%NDIM_FULL,nncat))
346 ALLOCATE(xtotbv_in_mesh(u%NDIM_FULL))
348 xtotbv_in_mesh(:) = 0.0
350 DO jmesh=1,u%NDIM_FULL
351 xbv_in_mesh(jmesh,:)=0.0
353 nnbv_in_mesh(jmesh,jcat) = count(nmaski(jmesh,jcat,:)/=nundef)
354 xbv_in_mesh(jmesh,jcat) =
REAL(nnbv_in_mesh(jmesh,jcat))*xdxt(jcat)**2
355 xtotbv_in_mesh(jmesh) = xtotbv_in_mesh(jmesh) + xbv_in_mesh(jmesh,jcat)
359 ALLOCATE (zf_param(u%NDIM_FULL))
360 ALLOCATE (zc_depth_ratio(u%NDIM_FULL))
363 zc_depth_ratio(:) = 0.
365 DO jmesh=1,u%NDIM_FULL
366 IF ( xtotbv_in_mesh(jmesh)/=0. )
THEN
367 zf_param(jmesh) = zf_param(jmesh) + xf_param_bv(jcat)*xbv_in_mesh(jmesh,jcat)/xtotbv_in_mesh(jmesh)
368 zc_depth_ratio(jmesh) = zc_depth_ratio(jmesh) + xc_depth_ratio_bv(jcat)*xbv_in_mesh(jmesh,jcat)/xtotbv_in_mesh(jmesh)
381 CALL
open_file(
'ASCII ',nunit,
'carte_f_dc.txt',
'FORMATTED',haction=
'WRITE')
382 DO jmesh=1,u%NDIM_FULL
383 WRITE(nunit,*) zf_param(jmesh),zc_depth_ratio(jmesh)
388 DEALLOCATE(zc_depth_ratio)
390 WRITE(iluout,*)
'Couplage avec TOPMODEL active'
394 WRITE(iluout,*)
'Pas de couplage avec TOPMODEL'
398 IF (lhook) CALL dr_hook(
'PGD_TOPD',1,zhook_handle)
subroutine xy_ign(KLAMBERT, PX, PY, PLAT, PLON)
subroutine pgd_topd(I, UG, U, USS, HPROGRAM)
subroutine topd_to_isba_slope(USS, KI)
subroutine read_nam_pgd_topd(HPROGRAM, OCOUPL_TOPD, HCAT, PF_PARAM_BV, PC_DEPTH_RATIO_BV)
subroutine get_gridtype_ign(PGRID_PAR, KLAMBERT, KL, PX, PY, PDX, PDY, KDIMX, KDIMY, PXALL, PYALL)
subroutine latlon_ign(KLAMBERT, PX, PY, PLAT, PLON)
subroutine abor1_sfx(YTEXT)
subroutine latlon_conf_proj(PLAT0, PLON0, PRPK, PBETA, PLATOR, PLONOR, PX, PY, PLAT, PLON)
subroutine make_mask_isba_to_topd(KI)
subroutine init_topd_pgd(HPROGRAM)
subroutine close_file(HPROGRAM, KUNIT)
subroutine get_luout(HPROGRAM, KLUOUT)
subroutine make_mask_topd_to_isba(UG, KI)
subroutine get_gridtype_conf_proj(PGRID_PAR, PLAT0, PLON0, PRPK, PBETA, PLATOR, PLONOR, KIMAX, KJMAX, PX, PY, PDX, PDY, KL)
subroutine write_file_masktopd(KI)
subroutine get_gridtype_lonlat_reg(PGRID_PAR, PLONMIN, PLONMAX, PLATMIN, PLATMAX, KLON, KLAT, KL, PLON, PLAT)
subroutine open_file(HPROGRAM, KUNIT, HFILE, HFORM, HACTION, HACCESS, KRECL)