3 SUBROUTINE readaerosol_interp(id_aero, itap, pdtphys, r_day, first, pplay, paprs, t_seri, mass_out, pi_mass_out, load_src)
16 USE dimphy, ONLY : klev,klon
19 USE aero_mod, ONLY : naero_spc, name_aero
31 include
"dimensions.h"
36 INTEGER,
INTENT(IN) :: id_aero
37 INTEGER,
INTENT(IN) :: itap
39 REAL,
INTENT(IN) :: r_day
40 LOGICAL,
INTENT(IN) :: first
41 REAL,
DIMENSION(klon,klev),
INTENT(IN) ::
pplay
42 REAL,
DIMENSION(klon,klev+1),
INTENT(IN):: paprs
43 REAL,
DIMENSION(klon,klev),
INTENT(IN) :: t_seri
47 REAL,
INTENT(OUT) :: mass_out(klon,
klev)
48 REAL,
INTENT(OUT) :: pi_mass_out(klon,
klev)
49 REAL,
INTENT(OUT) :: load_src(klon)
54 INTEGER :: iday, iyr, lmt_pas
58 INTEGER :: pi_klev_src
59 INTEGER,
SAVE :: klev_src
64 REAL,
DIMENSION(klon) :: psurf_day, pi_psurf_day
65 REAL,
DIMENSION(klon) :: pi_load_src
66 REAL,
DIMENSION(klon) :: load_tgt, load_tgt_test
67 REAL,
DIMENSION(klon,klev) :: delp
69 REAL,
ALLOCATABLE,
DIMENSION(:,:) :: pplay_src
70 REAL,
ALLOCATABLE,
DIMENSION(:,:) :: tmp1, tmp2
71 REAL,
ALLOCATABLE,
DIMENSION(:,:,:,:),
SAVE :: var_year
72 REAL,
ALLOCATABLE,
DIMENSION(:,:,:,:),
SAVE :: pi_var_year
74 REAL,
ALLOCATABLE,
DIMENSION(:,:,:),
SAVE :: var_day
75 REAL,
ALLOCATABLE,
DIMENSION(:,:,:),
SAVE :: pi_var_day
77 REAL,
ALLOCATABLE,
DIMENSION(:,:,:),
SAVE :: psurf_year, pi_psurf_year
79 REAL,
ALLOCATABLE,
DIMENSION(:,:,:),
SAVE :: load_year, pi_load_year
82 REAL,
DIMENSION(:,:,:),
POINTER :: pt_tmp
83 REAL,
POINTER,
DIMENSION(:),
SAVE :: pt_ap, pt_b
85 INTEGER,
SAVE :: nbr_tsteps
86 REAL,
DIMENSION(14),
SAVE :: month_len, month_start, month_mid
92 LOGICAL,
SAVE :: vert_interp
93 LOGICAL,
SAVE :: debug=.false.
95 CHARACTER(len=8) :: type
96 CHARACTER(len=8) :: filename
106 IF(mpi_rank == 0 .AND. debug )
then
107 print*,
'CONTROL PANEL REGARDING TIME STEPING'
124 IF(mod(itap-1,nint(86400./
pdtphys)) == 0)
THEN
130 IF(mpi_rank == 0 .AND. debug)
then
132 oldnewday = (r_day-
REAL(iday) < 0.02)
135 print*,
'r_day-REAL(iday) =',r_day-
REAL(iday)
138 print*,
'lmt_pas =',lmt_pas
140 print*,
'r_day =',r_day
141 print*,
'day_cur =',day_cur
142 print*,
'mth_cur =',mth_cur
143 print*,
'year_cur =',year_cur
144 print*,
'NINT(86400./pdtphys) =',nint(86400./
pdtphys)
145 print*,
'MOD(0,1) =',mod(0,1)
146 print*,
'lnewday =',lnewday
147 print*,
'OLDNEWDAY =',oldnewday
150 IF (.NOT.
ALLOCATED(var_day))
THEN
151 ALLOCATE( var_day(klon,
klev, naero_spc), stat=ierr)
152 IF (ierr /= 0) CALL
abort_gcm(
'readaerosol_interp',
'pb in allocation 1',1)
153 ALLOCATE( pi_var_day(klon,
klev, naero_spc), stat=ierr)
154 IF (ierr /= 0) CALL
abort_gcm(
'readaerosol_interp',
'pb in allocation 2',1)
156 ALLOCATE( psurf_year(klon, 12, naero_spc), pi_psurf_year(klon, 12, naero_spc), stat=ierr)
157 IF (ierr /= 0) CALL
abort_gcm(
'readaerosol_interp',
'pb in allocation 3',1)
159 ALLOCATE( load_year(klon, 12, naero_spc), pi_load_year(klon, 12, naero_spc), stat=ierr)
160 IF (ierr /= 0) CALL
abort_gcm(
'readaerosol_interp',
'pb in allocation 4',1)
173 IF ( (first .OR. iday==0) .AND. lnewday )
THEN
179 IF (aer_type==
'preind' .OR. aer_type==
'actuel' .OR. aer_type==
'annuel' .OR. aer_type==
'scenario')
THEN
183 ELSE IF (aer_type ==
'mix1')
THEN
185 IF (name_aero(id_aero) ==
'SO4')
THEN
192 ELSE IF (aer_type ==
'mix2')
THEN
194 IF (name_aero(id_aero) ==
'SO4')
THEN
201 ELSE IF (aer_type ==
'mix3')
THEN
203 IF (name_aero(id_aero) ==
'SO4')
THEN
211 CALL
abort_gcm(
'readaerosol_interp',
'this aer_type not supported',1)
214 CALL
readaerosol(name_aero(id_aero), type, filename, iyr, klev_src, pt_ap, pt_b, pt_tmp, &
215 psurf_year(:,:,id_aero), load_year(:,:,id_aero))
216 IF (.NOT.
ALLOCATED(var_year))
THEN
217 ALLOCATE(var_year(klon, klev_src, 12, naero_spc), stat=ierr)
218 IF (ierr /= 0) CALL
abort_gcm(
'readaerosol_interp',
'pb in allocation 5',1)
220 var_year(:,:,:,id_aero) = pt_tmp(:,:,:)
224 CALL
readaerosol(name_aero(id_aero), type, filename, iyr, pi_klev_src, pt_ap, pt_b, pt_tmp, &
225 pi_psurf_year(:,:,id_aero), pi_load_year(:,:,id_aero))
229 IF (pi_klev_src /= klev_src)
THEN
230 WRITE(
lunout,*)
'Error! All forcing files for the same aerosol must have the same vertical dimension'
231 WRITE(
lunout,*)
'Aerosol : ', name_aero(id_aero)
232 CALL
abort_gcm(
'readaerosol_interp',
'Differnt vertical axes in aerosol forcing files',1)
235 IF (.NOT.
ALLOCATED(pi_var_year))
THEN
236 ALLOCATE(pi_var_year(klon, klev_src, 12, naero_spc), stat=ierr)
237 IF (ierr /= 0) CALL
abort_gcm(
'readaerosol_interp',
'pb in allocation 6',1)
239 pi_var_year(:,:,:,id_aero) = pt_tmp(:,:,:)
242 CALL
writefield_phy(
'var_year_jan',var_year(:,:,1,id_aero),klev_src)
243 CALL
writefield_phy(
'var_year_dec',var_year(:,:,12,id_aero),klev_src)
247 CALL
writefield_phy(
'pi_load_year_src',pi_load_year(:,:,id_aero),1)
254 IF (psurf_year(1,1,id_aero)==not_valid .OR. pi_psurf_year(1,1,id_aero)==not_valid )
THEN
256 vert_interp = .false.
259 IF ( psurf_year(1,1,id_aero) /= pi_psurf_year(1,1,id_aero) )
THEN
260 WRITE(
lunout,*)
'Warning! All forcing files for the same aerosol must have the same structure'
261 CALL
abort_gcm(
'readaerosol_interp',
'The aerosol files have not the same format',1)
264 IF (
klev /= klev_src)
THEN
265 WRITE(
lunout,*)
'Old format of aerosol file do not allowed vertical interpolation'
266 CALL
abort_gcm(
'readaerosol_interp',
'Old aerosol file not possible',1)
276 month_len(
i) =
REAL(ioget_mon_len(year_cur,
i-1))
277 CALL
ymds2ju(year_cur,
i-1, 1, 0.0, month_start(
i))
279 month_len(1) =
REAL(ioget_mon_len(year_cur-1, 12))
280 CALL
ymds2ju(year_cur-1, 12, 1, 0.0, month_start(1))
281 month_len(14) =
REAL(ioget_mon_len(year_cur+1, 1))
282 CALL
ymds2ju(year_cur+1, 1, 1, 0.0, month_start(14))
283 month_mid(:) = month_start(:) + month_len(:)/2.
286 write(
lunout,*)
' month_len = ',month_len
287 write(
lunout,*)
' month_mid = ',month_mid
305 IF (nbr_tsteps == 12)
then
306 IF (jday < month_mid(
im+1))
THEN
308 day2 = month_mid(im2+1)
317 day2 = month_mid(
im+1)
318 day1 = month_mid(im2+1)
324 ELSE IF (nbr_tsteps == 14)
then
326 IF (jday < month_mid(
im))
THEN
329 day2 = month_mid(im2)
335 day1 = month_mid(im2)
338 CALL
abort_gcm(
'readaerosol_interp',
'number of months undefined',1)
341 write(
lunout,*)
' jDay, day1, day2, im, im2 = ', jday,
day1, day2,
im, im2
346 ALLOCATE(tmp1(klon,klev_src), tmp2(klon,klev_src),stat=ierr)
347 IF (ierr /= 0) CALL
abort_gcm(
'readaerosol_interp',
'pb in allocation 7',1)
349 ALLOCATE(pplay_src(klon,klev_src), stat=ierr)
350 IF (ierr /= 0) CALL
abort_gcm(
'readaerosol_interp',
'pb in allocation 8',1)
356 var_year(
i,
k,im2,id_aero) - (jday-day2)/(
day1-day2) * &
357 (var_year(
i,
k,im2,id_aero) - var_year(
i,
k,
im,id_aero))
360 pi_var_year(
i,
k,im2,id_aero) - (jday-day2)/(
day1-day2) * &
361 (pi_var_year(
i,
k,im2,id_aero) - pi_var_year(
i,
k,
im,id_aero))
368 psurf_year(
i,im2,id_aero) - (jday-day2)/(
day1-day2) * &
369 (psurf_year(
i,im2,id_aero) - psurf_year(
i,
im,id_aero))
372 pi_psurf_year(
i,im2,id_aero) - (jday-day2)/(
day1-day2) * &
373 (pi_psurf_year(
i,im2,id_aero) - pi_psurf_year(
i,
im,id_aero))
379 load_year(
i,im2,id_aero) - (jday-day2)/(
day1-day2) * &
380 (load_year(
i,im2,id_aero) - load_year(
i,
im,id_aero))
383 pi_load_year(
i,im2,id_aero) - (jday-day2)/(
day1-day2) * &
384 (pi_load_year(
i,im2,id_aero) - pi_load_year(
i,
im,id_aero))
392 IF (vert_interp)
THEN
400 pplay_src(
i,
k)= pt_ap(
k) + pt_b(
k)*psurf_day(
i)
413 CALL
pres2lev(tmp1(:,:), var_day(:,:,id_aero), klev_src,
klev, pplay_src,
pplay, &
425 delp(
i,
k) = paprs(
i,
k) - paprs(
i,
k+1)
434 volm = var_day(
i,
k,id_aero)*1.e-9/zrho
435 load_tgt(
i) = load_tgt(
i) + 1/rg * volm *delp(
i,
k)
442 var_day(
i,
k,id_aero) = var_day(
i,
k,id_aero)*load_src(
i)/load_tgt(
i)
447 load_tgt_test(:) = 0.
451 volm = var_day(
i,
k,id_aero)*1.e-9/zrho
452 load_tgt_test(
i) = load_tgt_test(
i) + 1/rg * volm*delp(
i,
k)
467 pplay_src(
i,
k)= pt_ap(
k) + pt_b(
k)*pi_psurf_day(
i)
477 CALL
pres2lev(tmp2(:,:), pi_var_day(:,:,id_aero), klev_src,
klev, pplay_src,
pplay, &
491 volm = pi_var_day(
i,
k,id_aero)*1.e-9/zrho
492 load_tgt(
i) = load_tgt(
i) + 1/rg * volm * delp(
i,
k)
498 pi_var_day(
i,
k,id_aero) = pi_var_day(
i,
k,id_aero)*pi_load_src(
i)/load_tgt(
i)
503 load_tgt_test(:) = 0.
507 volm = pi_var_day(
i,
k,id_aero)*1.e-9/zrho
508 load_tgt_test(
i) = load_tgt_test(
i) + 1/rg * volm * delp(
i,
k)
520 var_day(:,:,id_aero) = tmp1(:,:)
521 pi_var_day(:,:,id_aero) = tmp2(:,:)
527 DEALLOCATE(tmp1, tmp2, pplay_src, stat=ierr)
533 IF (minval(var_day(:,:,id_aero)) < 0.)
THEN
537 IF (var_day(
i,
k,id_aero) < 0.)
THEN
538 IF (jday-day2 < 0.)
WRITE(
lunout,*)
'jDay-day2=',jday-day2
539 IF (var_year(
i,
k,im2,id_aero) - var_year(
i,
k,
im,id_aero) < 0.)
THEN
540 WRITE(
lunout,*) trim(name_aero(id_aero)),
'(i,k,im2)-', &
541 trim(name_aero(id_aero)),
'(i,k,im)=', &
542 var_year(
i,
k,im2,id_aero) - var_year(
i,
k,
im,id_aero)
544 WRITE(
lunout,*)
'stop for aerosol : ',name_aero(id_aero)
545 WRITE(
lunout,*)
'day1, day2, jDay = ',
day1, day2, jday
546 CALL
abort_gcm(
'readaerosol_interp',
'Error in interpolation 1',1)
552 IF (minval(pi_var_day(:,:,id_aero)) < 0. )
THEN
556 IF (pi_var_day(
i,
k,id_aero) < 0.)
THEN
557 IF (jday-day2 < 0.)
WRITE(
lunout,*)
'jDay-day2=',jday-day2
558 IF (pi_var_year(
i,
k,im2,id_aero) - pi_var_year(
i,
k,
im,id_aero) < 0.)
THEN
559 WRITE(
lunout,*) trim(name_aero(id_aero)),
'(i,k,im2)-', &
560 trim(name_aero(id_aero)),
'(i,k,im)=', &
561 pi_var_year(
i,
k,im2,id_aero) - pi_var_year(
i,
k,
im,id_aero)
564 WRITE(
lunout,*)
'stop for aerosol : ',name_aero(id_aero)
565 CALL
abort_gcm(
'readaerosol_interp',
'Error in interpolation 2',1)
578 mass_out(:,:) = var_day(:,:,id_aero)
579 pi_mass_out(:,:) = pi_var_day(:,:,id_aero)