68 use write_data,
only : write_fv3_atm_header_netcdf, &
69 write_fv3_atm_bndy_data_netcdf, &
70 write_fv3_atm_data_netcdf
112 integer,
intent(in) :: localpet
114 integer :: isrctermprocessing
117 type(esmf_regridmethod_flag) :: method
118 type(esmf_routehandle) :: regrid_bl
120 real(esmf_kind_r8),
parameter :: p0=101325.0
121 real(esmf_kind_r8),
parameter :: rd = 287.058
122 real(esmf_kind_r8),
parameter :: grav = 9.81
123 real(esmf_kind_r8),
parameter :: lapse = -6.5e-03
125 real(esmf_kind_r8),
parameter :: exponent = rd*lapse/grav
126 real(esmf_kind_r8),
parameter :: one_over_exponent = 1.0 / exponent
128 real(esmf_kind_r8),
pointer :: psptr(:,:), tempptr(:,:,:)
152 isrctermprocessing = 1
156 print*,
"- CALL FieldSMMStore FOR ATMOSPHERIC FIELDS." 161 routehandle=regrid_bl, &
162 srctermprocessing=isrctermprocessing, rc=rc)
163 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
168 print*,
"- CALL FieldRegridStore FOR ATMOSPHERIC FIELDS." 170 method=esmf_regridmethod_bilinear
174 polemethod=esmf_polemethod_allavg, &
175 srctermprocessing=isrctermprocessing, &
176 routehandle=regrid_bl, &
177 regridmethod=method, rc=rc)
178 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
183 print*,
"- CALL Field_Regrid FOR TEMPERATURE." 186 routehandle=regrid_bl, &
187 termorderflag=esmf_termorder_srcseq, &
189 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
192 print*,
"- CALL Field_Regrid FOR PRESSURE." 195 routehandle=regrid_bl, &
196 termorderflag=esmf_termorder_srcseq, &
198 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
202 print*,
"- CALL Field_Regrid FOR TRACER ", trim(
tracers(n))
205 routehandle=regrid_bl, &
206 termorderflag=esmf_termorder_srcseq, rc=rc)
207 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
212 print*,
"- CALL Field_Regrid FOR VERTICAL VELOCITY." 215 routehandle=regrid_bl, &
216 termorderflag=esmf_termorder_srcseq, rc=rc)
217 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
221 print*,
"- CALL FieldGet FOR INPUT GRID VERTICAL VEL." 223 farrayptr=tempptr, rc=rc)
224 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
227 print*,
"MIN MAX W INPUT = ", minval(tempptr), maxval(tempptr)
230 print*,
"- CALL FieldGet FOR VERTICAL VEL B4ADJ." 232 farrayptr=tempptr, rc=rc)
233 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
236 print*,
"MIN MAX W B4ADJ = ", minval(tempptr), maxval(tempptr)
239 print*,
"- CALL FieldGet FOR INPUT SURFACE PRESSURE." 241 farrayptr=psptr, rc=rc)
242 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
249 psptr = (psptr/p0)**exponent
251 print*,
"- CALL Field_Regrid FOR SURFACE PRESSURE." 254 routehandle=regrid_bl, &
255 termorderflag=esmf_termorder_srcseq, &
257 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
261 print*,
"- CALL FieldGet FOR INPUT SURFACE PRESSURE B4ADJ." 263 farrayptr=psptr, rc=rc)
264 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
267 psptr = p0 * psptr**one_over_exponent
269 print*,
"- CALL Field_Regrid FOR TERRAIN." 272 routehandle=regrid_bl, &
273 termorderflag=esmf_termorder_srcseq, &
275 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
278 print*,
"- CALL Field_Regrid FOR 3-D WIND." 281 routehandle=regrid_bl, &
282 termorderflag=esmf_termorder_srcseq, rc=rc)
283 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
286 print*,
"- CALL FieldRegridRelease." 287 call esmf_fieldregridrelease(routehandle=regrid_bl, rc=rc)
288 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
341 isrctermprocessing = 1
342 method=esmf_regridmethod_bilinear
344 print*,
"- CALL FieldRegridStore FOR 3D-WIND WEST EDGE." 347 polemethod=esmf_polemethod_allavg, &
348 srctermprocessing=isrctermprocessing, &
349 routehandle=regrid_bl, &
350 extrapmethod=esmf_extrapmethod_nearest_stod, &
351 regridmethod=method, rc=rc)
352 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
355 print*,
"- CALL Field_Regrid FOR 3-D WIND WEST EDGE." 358 routehandle=regrid_bl, &
359 termorderflag=esmf_termorder_srcseq, rc=rc)
360 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
363 print*,
"- CALL FieldRegridRelease." 364 call esmf_fieldregridrelease(routehandle=regrid_bl, rc=rc)
365 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
368 isrctermprocessing = 1
369 method=esmf_regridmethod_bilinear
371 print*,
"- CALL FieldRegridStore FOR 3D-WIND SOUTH EDGE." 374 polemethod=esmf_polemethod_allavg, &
375 srctermprocessing=isrctermprocessing, &
376 routehandle=regrid_bl, &
377 extrapmethod=esmf_extrapmethod_nearest_stod, &
378 regridmethod=method, rc=rc)
379 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
382 print*,
"- CALL Field_Regrid FOR 3-D WIND SOUTH EDGE." 385 routehandle=regrid_bl, &
386 termorderflag=esmf_termorder_srcseq, rc=rc)
387 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
390 print*,
"- CALL FieldRegridRelease." 391 call esmf_fieldregridrelease(routehandle=regrid_bl, rc=rc)
392 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
408 call vintg_thomp_mp_climo
415 call write_fv3_atm_header_netcdf(localpet)
416 if (
regional <= 1)
call write_fv3_atm_data_netcdf(localpet)
417 if (
regional >= 1)
call write_fv3_atm_bndy_data_netcdf(localpet)
441 print*,
"- CALL FieldCreate FOR TARGET GRID TRACER BEFORE ADJUSTMENT ", trim(
tracers(n))
443 typekind=esmf_typekind_r8, &
444 staggerloc=esmf_staggerloc_center, &
445 ungriddedlbound=(/1/), &
447 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
451 print*,
"- CALL FieldCreate FOR TARGET GRID TEMPERATURE BEFORE ADJUSTMENT." 453 typekind=esmf_typekind_r8, &
454 staggerloc=esmf_staggerloc_center, &
455 ungriddedlbound=(/1/), &
457 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
460 print*,
"- CALL FieldCreate FOR TARGET GRID PRESSURE BEFORE ADJUSTMENT." 462 typekind=esmf_typekind_r8, &
463 staggerloc=esmf_staggerloc_center, &
464 ungriddedlbound=(/1/), &
466 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
469 print*,
"- CALL FieldCreate FOR TARGET GRID VERTICAL VELOCITY BEFORE ADJUSTMENT." 471 typekind=esmf_typekind_r8, &
472 staggerloc=esmf_staggerloc_center, &
473 ungriddedlbound=(/1/), &
475 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
478 print*,
"- CALL FieldCreate FOR TARGET GRID UNSTAGGERED WINDS BEFORE ADJUSTMENT." 480 typekind=esmf_typekind_r8, &
481 staggerloc=esmf_staggerloc_center, &
482 ungriddedlbound=(/1,1/), &
484 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
487 print*,
"- CALL FieldCreate FOR TARGET TERRAIN." 489 typekind=esmf_typekind_r8, &
490 staggerloc=esmf_staggerloc_center, rc=rc)
491 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
494 print*,
"- CALL FieldCreate FOR TARGET SURFACE PRESSURE BEFORE ADJUSTMENT." 496 typekind=esmf_typekind_r8, &
497 staggerloc=esmf_staggerloc_center, rc=rc)
498 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
515 print*,
"- CALL FieldCreate FOR TARGET GRID TRACERS ", trim(
tracers(n))
517 typekind=esmf_typekind_r8, &
518 staggerloc=esmf_staggerloc_center, &
519 ungriddedlbound=(/1/), &
521 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
525 print*,
"- CALL FieldCreate FOR TARGET GRID TEMPERATURE." 527 typekind=esmf_typekind_r8, &
528 staggerloc=esmf_staggerloc_center, &
529 ungriddedlbound=(/1/), &
531 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
534 print*,
"- CALL FieldCreate FOR TARGET GRID PRESSURE." 536 typekind=esmf_typekind_r8, &
537 staggerloc=esmf_staggerloc_center, &
538 ungriddedlbound=(/1/), &
540 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
543 print*,
"- CALL FieldCreate FOR TARGET GRID VERTICAL VELOCITY." 545 typekind=esmf_typekind_r8, &
546 staggerloc=esmf_staggerloc_center, &
547 ungriddedlbound=(/1/), &
549 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
552 print*,
"- CALL FieldCreate FOR TARGET GRID DELP." 554 typekind=esmf_typekind_r8, &
555 staggerloc=esmf_staggerloc_center, &
556 ungriddedlbound=(/1/), &
558 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
561 print*,
"- CALL FieldCreate FOR TARGET HEIGHT." 563 typekind=esmf_typekind_r8, &
564 staggerloc=esmf_staggerloc_center, &
565 ungriddedlbound=(/1/), &
567 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
570 print*,
"- CALL FieldCreate FOR TARGET UNSTAGGERED 3D-WIND." 572 typekind=esmf_typekind_r8, &
573 staggerloc=esmf_staggerloc_center, &
574 ungriddedlbound=(/1,1/), &
576 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
579 print*,
"- CALL FieldCreate FOR TARGET U_S." 581 typekind=esmf_typekind_r8, &
582 staggerloc=esmf_staggerloc_edge2, &
583 ungriddedlbound=(/1/), &
585 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
588 print*,
"- CALL FieldCreate FOR TARGET V_S." 590 typekind=esmf_typekind_r8, &
591 staggerloc=esmf_staggerloc_edge2, &
592 ungriddedlbound=(/1/), &
594 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
597 print*,
"- CALL FieldCreate FOR TARGET 3D-WIND_S." 599 typekind=esmf_typekind_r8, &
600 staggerloc=esmf_staggerloc_edge2, &
601 ungriddedlbound=(/1,1/), &
603 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
606 print*,
"- CALL FieldCreate FOR TARGET U_W." 608 typekind=esmf_typekind_r8, &
609 staggerloc=esmf_staggerloc_edge1, &
610 ungriddedlbound=(/1/), &
612 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
615 print*,
"- CALL FieldCreate FOR TARGET V_W." 617 typekind=esmf_typekind_r8, &
618 staggerloc=esmf_staggerloc_edge1, &
619 ungriddedlbound=(/1/), &
621 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
624 print*,
"- CALL FieldCreate FOR TARGET 3D-WIND_W." 626 typekind=esmf_typekind_r8, &
627 staggerloc=esmf_staggerloc_edge1, &
628 ungriddedlbound=(/1,1/), &
630 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
633 print*,
"- CALL FieldCreate FOR TARGET SURFACE PRESSURE." 635 typekind=esmf_typekind_r8, &
636 staggerloc=esmf_staggerloc_center, rc=rc)
637 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
649 integer :: clb(4), cub(4)
650 integer :: i, j, k, rc
652 real(esmf_kind_r8),
pointer :: latptr(:,:)
653 real(esmf_kind_r8),
pointer :: lonptr(:,:)
654 real(esmf_kind_r8),
pointer :: uptr(:,:,:)
655 real(esmf_kind_r8),
pointer :: vptr(:,:,:)
656 real(esmf_kind_r8),
pointer :: windptr(:,:,:,:)
657 real(esmf_kind_r8) :: latrad, lonrad
663 print*,
'- CONVERT WINDS.' 665 print*,
"- CALL FieldGet FOR 3-D WIND_S." 667 computationallbound=clb, &
668 computationalubound=cub, &
669 farrayptr=windptr, rc=rc)
670 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
673 print*,
"- CALL FieldGet FOR U_S." 675 farrayptr=uptr, rc=rc)
676 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
679 print*,
"- CALL FieldGet FOR V_S." 681 farrayptr=vptr, rc=rc)
682 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
685 print*,
"- CALL FieldGet FOR LATITUDE_S." 687 farrayptr=latptr, rc=rc)
688 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
691 print*,
"- CALL FieldGet FOR LONGITUDE_S." 693 farrayptr=lonptr, rc=rc)
694 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
697 do i = clb(1), cub(1)
698 do j = clb(2), cub(2)
699 latrad = latptr(i,j) * acos(-1.) / 180.0
700 lonrad = lonptr(i,j) * acos(-1.) / 180.0
701 do k = clb(3), cub(3)
702 uptr(i,j,k) = windptr(i,j,k,1) * cos(lonrad) + windptr(i,j,k,2) * sin(lonrad)
703 vptr(i,j,k) = -windptr(i,j,k,1) * sin(latrad) * sin(lonrad) + &
704 windptr(i,j,k,2) * sin(latrad) * cos(lonrad) + &
705 windptr(i,j,k,3) * cos(latrad)
711 print*,
"- CALL FieldGet FOR 3-D WIND_W." 713 computationallbound=clb, &
714 computationalubound=cub, &
715 farrayptr=windptr, rc=rc)
716 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
719 print*,
"- CALL FieldGet FOR U_W." 721 farrayptr=uptr, rc=rc)
722 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
725 print*,
"- CALL FieldGet FOR V_W." 727 farrayptr=vptr, rc=rc)
728 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
731 print*,
"- CALL FieldGet FOR LATITUDE_W." 733 farrayptr=latptr, rc=rc)
734 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
737 print*,
"- CALL FieldGet FOR LONGITUDE_W." 739 farrayptr=lonptr, rc=rc)
740 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
743 do i = clb(1), cub(1)
744 do j = clb(2), cub(2)
745 latrad = latptr(i,j) * acos(-1.) / 180.0
746 lonrad = lonptr(i,j) * acos(-1.) / 180.0
747 do k = clb(3), cub(3)
748 uptr(i,j,k) = windptr(i,j,k,1) * cos(lonrad) + windptr(i,j,k,2) * sin(lonrad)
749 vptr(i,j,k) = -windptr(i,j,k,1) * sin(latrad) * sin(lonrad) + &
750 windptr(i,j,k,2) * sin(latrad) * cos(lonrad) + &
751 windptr(i,j,k,3) * cos(latrad)
789 subroutine newpr1(localpet)
792 integer,
intent(in) :: localpet
794 integer :: idsl, idvc, rc
795 integer :: i, j, k, clb(3), cub(3)
797 real(esmf_kind_r8),
parameter :: rd=287.05
798 real(esmf_kind_r8),
parameter :: cp=1004.6
799 real(esmf_kind_r8),
parameter :: rocp=rd/cp
800 real(esmf_kind_r8),
parameter :: rocp1=rocp+1
801 real(esmf_kind_r8),
parameter :: rocpr=1/rocp
803 real(esmf_kind_r8),
pointer :: delp_ptr(:,:,:)
804 real(esmf_kind_r8),
pointer :: pptr(:,:,:)
805 real(esmf_kind_r8),
pointer :: psptr(:,:)
806 real(esmf_kind_r8) :: ak, bk
807 real(esmf_kind_r8),
allocatable :: pi(:,:,:)
809 print*,
"COMPUTE 3-D PRESSURE FROM ADJUSTED SURFACE PRESSURE." 814 print*,
"- CALL FieldGet FOR 3-D PRES." 816 computationallbound=clb, &
817 computationalubound=cub, &
818 farrayptr=pptr, rc=rc)
819 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
822 print*,
"- CALL FieldGet FOR DELP." 824 computationallbound=clb, &
825 computationalubound=cub, &
826 farrayptr=delp_ptr, rc=rc)
827 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
830 print*,
"- CALL FieldGet FOR SURFACE PRESSURE AFTER ADJUSTMENT" 832 farrayptr=psptr, rc=rc)
833 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
836 allocate(pi(clb(1):cub(1),clb(2):cub(2),1:
levp1_target))
844 pi(i,j,k) = ak + bk*psptr(i,j)
851 delp_ptr(i,j,k) = pi(i,j,k) - pi(i,j,k+1)
863 pptr(i,j,k) = (pi(i,j,k)+pi(i,j,k+1))/2.0
871 pptr(i,j,k) = ((pi(i,j,k)**rocp1-pi(i,j,k+1)**rocp1)/ &
872 (rocp1*(pi(i,j,k)-pi(i,j,k+1))))**rocpr
880 if (localpet == 0)
then 881 print*,
'new pres ',pptr(clb(1),clb(2),:)
882 print*,
'delp ',delp_ptr(clb(1),clb(2),:)
900 subroutine newps(localpet)
904 integer,
intent(in) :: localpet
905 integer :: i, j, k, ii
906 integer :: clb(3), cub(3), ls, rc
908 real(esmf_kind_r8),
pointer :: pptr(:,:,:)
909 real(esmf_kind_r8),
pointer :: psptr(:,:)
910 real(esmf_kind_r8),
pointer :: psnewptr(:,:)
911 real(esmf_kind_r8),
pointer :: tptr(:,:,:)
912 real(esmf_kind_r8),
pointer :: qptr(:,:,:)
913 real(esmf_kind_r8),
pointer :: zsptr(:,:)
914 real(esmf_kind_r8),
pointer :: zsnewptr(:,:)
915 real(esmf_kind_r8),
allocatable :: zu(:,:)
916 real(esmf_kind_r8),
parameter :: beta=-6.5e-3
917 real(esmf_kind_r8),
parameter :: epsilon=1.e-9
918 real(esmf_kind_r8),
parameter :: g=9.80665
919 real(esmf_kind_r8),
parameter :: rd=287.05
920 real(esmf_kind_r8),
parameter :: rv=461.50
921 real(esmf_kind_r8),
parameter :: gor=g/rd
922 real(esmf_kind_r8),
parameter :: fv=rv/rd-1.
923 real(esmf_kind_r8) :: ftv, fgam, apu, fz0
924 real(esmf_kind_r8) :: atvu, atv, fz1, fp0
925 real(esmf_kind_r8) :: apd, azd, agam, azu
926 real(esmf_kind_r8) :: atvd, fp1, gamma, pu
927 real(esmf_kind_r8) :: tvu, pd, tvd
928 real(esmf_kind_r8) :: at, aq, ap, az
930 ftv(at,aq)=at*(1+fv*aq)
931 fgam(apu,atvu,apd,atvd)=-gor*log(atvd/atvu)/log(apd/apu)
932 fz0(ap,atv,azd,apd)=azd+atv/gor*log(apd/ap)
933 fz1(ap,atv,azd,apd,agam)=azd-atv/agam*((apd/ap)**(-agam/gor)-1)
934 fp0(az,azu,apu,atvu)=apu*exp(-gor/atvu*(az-azu))
935 fp1(az,azu,apu,atvu,agam)=apu*(1+agam/atvu*(az-azu))**(-gor/agam)
937 print*,
"- ADJUST SURFACE PRESSURE FOR NEW TERRAIN." 939 print*,
"- CALL FieldGet FOR 3-D PRES." 941 computationallbound=clb, &
942 computationalubound=cub, &
943 farrayptr=pptr, rc=rc)
944 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
948 print*,
'old pres ',pptr(clb(1),clb(2),:)
951 print*,
"- CALL FieldGet FOR TEMPERATURE" 953 farrayptr=tptr, rc=rc)
954 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
960 if (trim(
tracers(ii)) ==
"sphum")
exit 963 print*,
"- CALL FieldGet FOR SPECIFIC HUMIDITY" 965 farrayptr=qptr, rc=rc)
966 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
969 print*,
"- CALL FieldGet FOR SURFACE PRESSURE BEFORE ADJUSTMENT" 971 farrayptr=psptr, rc=rc)
972 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
975 print*,
"- CALL FieldGet FOR SURFACE PRESSURE AFTER ADJUSTMENT" 977 farrayptr=psnewptr, rc=rc)
978 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
981 print*,
"- CALL FieldGet FOR OLD TERRAIN" 983 farrayptr=zsptr, rc=rc)
984 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
987 print*,
"- CALL FieldGet FOR NEW TERRAIN" 989 farrayptr=zsnewptr, rc=rc)
990 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
993 allocate(zu(clb(1):cub(1),clb(2):cub(2)))
1010 tvu=ftv(tptr(i,j,k),qptr(i,j,k))
1011 zu(i,j)=fz1(pu,tvu,zsptr(i,j),psptr(i,j),gamma)
1012 if(zsnewptr(i,j).le.zu(i,j))
then 1014 tvu=ftv(tptr(i,j,k),qptr(i,j,k))
1015 if(abs(gamma).gt.epsilon)
then 1016 psnewptr(i,j)=fp1(zsnewptr(i,j),zu(i,j),pu,tvu,gamma)
1018 psnewptr(i,j)=fp0(zsnewptr(i,j),zu(i,j),pu,tvu)
1035 if(psnewptr(i,j).eq.0)
then 1037 tvu=ftv(tptr(i,j,k),qptr(i,j,k))
1039 tvd=ftv(tptr(i,j,k-1),qptr(i,j,k-1))
1040 gamma=fgam(pu,tvu,pd,tvd)
1041 if(abs(gamma).gt.epsilon)
then 1042 zu(i,j)=fz1(pu,tvu,zu(i,j),pd,gamma)
1044 zu(i,j)=fz0(pu,tvu,zu(i,j),pd)
1046 if(zsnewptr(i,j).le.zu(i,j))
then 1047 if(abs(gamma).gt.epsilon)
then 1048 psnewptr(i,j)=fp1(zsnewptr(i,j),zu(i,j),pu,tvu,gamma)
1050 psnewptr(i,j)=fp0(zsnewptr(i,j),zu(i,j),pu,tvu)
1070 if(psnewptr(i,j).eq.0)
then 1072 tvu=ftv(tptr(i,j,k),qptr(i,j,k))
1073 psnewptr(i,j)=fp0(zsnewptr(i,j),zu(i,j),pu,tvu)
1081 if (localpet == 0)
then 1086 print*,
'sfcp adjust ',(zsnewptr(i,j)-zsptr(i,j)), psptr(i,j),psnewptr(i,j)
1091 end subroutine newps 1100 integer :: istat, n, k
1105 if (istat /= 0)
then 1110 if (istat /= 0)
then 1118 if (istat /= 0)
then 1136 integer :: isrctermprocessing, rc
1138 type(esmf_regridmethod_flag) :: method
1139 type(esmf_routehandle) :: regrid_bl
1141 isrctermprocessing=1
1143 print*,
"- CALL FieldCreate FOR TARGET GRID THOMP CLIMO QNIFA BEFORE ADJUSTMENT." 1145 typekind=esmf_typekind_r8, &
1146 staggerloc=esmf_staggerloc_center, &
1147 ungriddedlbound=(/1/), &
1149 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1152 print*,
"- CALL FieldCreate FOR TARGET GRID THOMP CLIMO QNWFA BEFORE ADJUSTMENT." 1154 typekind=esmf_typekind_r8, &
1155 staggerloc=esmf_staggerloc_center, &
1156 ungriddedlbound=(/1/), &
1158 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1161 print*,
"- CALL FieldCreate FOR TARGET GRID THOMP CLIMO PRESSURE BEFORE ADJUSTMENT." 1163 typekind=esmf_typekind_r8, &
1164 staggerloc=esmf_staggerloc_center, &
1165 ungriddedlbound=(/1/), &
1167 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1170 print*,
"- CALL FieldCreate FOR TARGET GRID THOMP CLIMO QNIFA." 1172 typekind=esmf_typekind_r8, &
1173 staggerloc=esmf_staggerloc_center, &
1174 ungriddedlbound=(/1/), &
1176 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1179 print*,
"- CALL FieldCreate FOR TARGET GRID THOMP CLIMO QNWFA." 1181 typekind=esmf_typekind_r8, &
1182 staggerloc=esmf_staggerloc_center, &
1183 ungriddedlbound=(/1/), &
1185 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1188 print*,
"- CALL FieldRegridStore FOR THOMPSON CLIMO FIELDS." 1190 method=esmf_regridmethod_bilinear
1194 polemethod=esmf_polemethod_allavg, &
1195 srctermprocessing=isrctermprocessing, &
1196 routehandle=regrid_bl, &
1197 regridmethod=method, rc=rc)
1198 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1201 print*,
"- CALL Field_Regrid FOR THOMP CLIMO QNIFA." 1204 routehandle=regrid_bl, &
1205 termorderflag=esmf_termorder_srcseq, rc=rc)
1206 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1209 print*,
"- CALL Field_Regrid FOR THOMP CLIMO QNWFA." 1212 routehandle=regrid_bl, &
1213 termorderflag=esmf_termorder_srcseq, rc=rc)
1214 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1217 print*,
"- CALL Field_Regrid FOR THOMP PRESSURE." 1220 routehandle=regrid_bl, &
1221 termorderflag=esmf_termorder_srcseq, rc=rc)
1222 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1225 print*,
"- CALL FieldRegridRelease." 1226 call esmf_fieldregridrelease(routehandle=regrid_bl, rc=rc)
1227 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1244 SUBROUTINE vintg_thomp_mp_climo
1248 INTEGER :: CLB(3), CUB(3), RC
1249 INTEGER :: IM, KM1, KM2, NT
1252 REAL(ESMF_KIND_R8),
ALLOCATABLE :: Z1(:,:,:), Z2(:,:,:)
1253 REAL(ESMF_KIND_R8),
ALLOCATABLE :: C1(:,:,:,:),C2(:,:,:,:)
1255 REAL(ESMF_KIND_R8),
POINTER :: QNIFA1PTR(:,:,:)
1256 REAL(ESMF_KIND_R8),
POINTER :: QNIFA2PTR(:,:,:)
1257 REAL(ESMF_KIND_R8),
POINTER :: QNWFA1PTR(:,:,:)
1258 REAL(ESMF_KIND_R8),
POINTER :: QNWFA2PTR(:,:,:)
1259 REAL(ESMF_KIND_R8),
POINTER :: P1PTR(:,:,:)
1260 REAL(ESMF_KIND_R8),
POINTER :: P2PTR(:,:,:)
1262 print*,
"- VERTICALY INTERPOLATE THOMP MP CLIMO TRACERS." 1264 print*,
"- CALL FieldGet FOR 3-D THOMP PRES." 1266 computationallbound=clb, &
1267 computationalubound=cub, &
1268 farrayptr=p1ptr, rc=rc)
1269 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1279 ALLOCATE(z2(clb(1):cub(1),clb(2):cub(2),
lev_target))
1281 ALLOCATE(c2(clb(1):cub(1),clb(2):cub(2),
lev_target,nt))
1285 print*,
"- CALL FieldGet FOR 3-D ADJUSTED PRESS" 1287 farrayptr=p2ptr, rc=rc)
1288 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1296 print*,
"- CALL FieldGet FOR qnifa before vertical adjustment." 1298 farrayptr=qnifa1ptr, rc=rc)
1299 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1302 c1(:,:,:,1) = qnifa1ptr(:,:,:)
1304 print*,
"- CALL FieldGet FOR qnwfa before vertical adjustment." 1306 farrayptr=qnwfa1ptr, rc=rc)
1307 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1310 c1(:,:,:,2) = qnwfa1ptr(:,:,:)
1318 im = (cub(1)-clb(1)+1) * (cub(2)-clb(2)+1)
1322 CALL terp3(im,1,1,1,1,nt,(im*km1),(im*km2), &
1323 km1,im,im,z1,c1,km2,im,im,z2,c2)
1325 print*,
"- CALL FieldGet FOR ADJUSTED climo qnifa." 1327 farrayptr=qnifa2ptr, rc=rc)
1328 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1331 print*,
"- CALL FieldGet FOR ADJUSTED climo qnwfa." 1333 farrayptr=qnwfa2ptr, rc=rc)
1334 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1340 qnifa2ptr(i,j,k) = c2(i,j,k,1)
1341 qnwfa2ptr(i,j,k) = c2(i,j,k,2)
1346 DEALLOCATE (z1, z2, c1, c2)
1352 END SUBROUTINE vintg_thomp_mp_climo
1367 SUBROUTINE vintg_wam (YEAR,MONTH,DAY,HOUR)
1373 INTEGER,
INTENT(IN) :: YEAR,MONTH,DAY,HOUR
1375 REAL(ESMF_KIND_R8),
PARAMETER :: AMO = 15.9994
1376 REAL(ESMF_KIND_R8),
PARAMETER :: AMO2 = 31.999
1377 REAL(ESMF_KIND_R8),
PARAMETER :: AMN2 = 28.013
1379 REAL(ESMF_KIND_R8) :: COE,WFUN(10),DEGLAT,HOLD
1380 REAL(ESMF_KIND_R8) :: SUMMASS,QVMASS,O3MASS
1381 INTEGER :: I, J, K, II, CLB(3), CUB(3), RC, KREF
1382 INTEGER :: IDAT(8),JDOW,JDAY,ICDAY
1384 REAL(ESMF_KIND_R8),
ALLOCATABLE :: TEMP(:),ON(:),O2N(:),N2N(:),PRMB(:)
1386 REAL(ESMF_KIND_R8),
POINTER :: LATPTR(:,:)
1387 REAL(ESMF_KIND_R8),
POINTER :: P1PTR(:,:,:)
1388 REAL(ESMF_KIND_R8),
POINTER :: P2PTR(:,:,:)
1389 REAL(ESMF_KIND_R8),
POINTER :: DZDT2PTR(:,:,:)
1390 REAL(ESMF_KIND_R8),
POINTER :: T2PTR(:,:,:)
1391 REAL(ESMF_KIND_R8),
POINTER :: Q2PTR(:,:,:)
1392 REAL(ESMF_KIND_R8),
POINTER :: QVPTR(:,:,:)
1393 REAL(ESMF_KIND_R8),
POINTER :: QOPTR(:,:,:)
1394 REAL(ESMF_KIND_R8),
POINTER :: O2PTR(:,:,:)
1395 REAL(ESMF_KIND_R8),
POINTER :: O3PTR(:,:,:)
1396 REAL(ESMF_KIND_R8),
POINTER :: WIND2PTR(:,:,:,:)
1400 print*,
"VINTG_WAM:- VERTICALY EXTEND FIELDS FOR WAM COLD START." 1411 CALL w3doxdat(idat,jdow,icday,jday)
1412 print *,
"VINTG_WAM: WAM START DATE FOR ICDAY=",icday
1416 wfun(k) = (k-1.0) / 9.0
1426 print*,
"VINTG_WAM:- CALL FieldGet FOR 3-D PRES." 1428 computationallbound=clb, &
1429 computationalubound=cub, &
1430 farrayptr=p1ptr, rc=rc)
1431 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1436 print*,
"VINTG_WAM:- CALL FieldGet FOR 3-D ADJUSTED PRESS" 1438 farrayptr=p2ptr, rc=rc)
1439 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1444 print*,
"VINTG_WAM - CALL FieldGet FOR LATITUDE_S." 1446 farrayptr=latptr, rc=rc)
1447 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1452 print*,
"VINTG_WAM:- CALL FieldGet FOR 3-D ADJUSTED TEMP." 1454 farrayptr=t2ptr, rc=rc)
1455 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1459 print*,
"VINTG_WAM:- CALL FieldGet FOR ADJUSTED VERTICAL VELOCITY." 1461 farrayptr=dzdt2ptr, rc=rc)
1462 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1466 print*,
"VINTG_WAM:- CALL FieldGet FOR 3-D ADJUSTED WIND." 1468 farrayptr=wind2ptr, rc=rc)
1469 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1479 IF(p2ptr(i,j,k).le.p1ptr(i,j,
lev_input))
THEN 1488 coe = p2ptr(i,j,k) / p2ptr(i,j,kref)
1489 wind2ptr(i,j,k,1) = coe*wind2ptr(i,j,k,1)
1490 wind2ptr(i,j,k,2) = coe*wind2ptr(i,j,k,2)
1491 wind2ptr(i,j,k,3) = coe*wind2ptr(i,j,k,3)
1492 dzdt2ptr(i,j,k) = coe*dzdt2ptr(i,j,k)
1503 print*,
"VINTG_WAM:- CALL FieldGet FOR 3-D TRACER ", trim(
tracers(ii))
1505 farrayptr=q2ptr, rc=rc)
1506 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1512 IF(p2ptr(i,j,k).le.p1ptr(i,j,
lev_input))
THEN 1520 coe = min(1.0, p2ptr(i,j,k) / p2ptr(i,j,kref) )
1521 q2ptr(i,j,k) = coe * q2ptr(i,j,k)
1526 IF (trim(
tracers(ii)) ==
"sphum") qvptr => q2ptr
1527 IF (trim(
tracers(ii)) ==
"spo" ) qoptr => q2ptr
1528 IF (trim(
tracers(ii)) ==
"spo2" ) o2ptr => q2ptr
1529 IF (trim(
tracers(ii)) ==
"spo3" ) o3ptr => q2ptr
1539 deglat = latptr(i,j)
1541 prmb(k) = p2ptr(i,j,k) * 0.01
1546 summass = on(k)*amo+o2n(k)*amo2+n2n(k)*amn2
1547 qvmass = summass*qvptr(i,j,k)/(1.-qvptr(i,j,k))
1548 summass = summass+qvmass
1549 o3mass = summass*o3ptr(i,j,k)
1550 summass = summass+o3mass
1551 hold = 1.0 / summass
1552 qoptr(i,j,k) = on(k)*amo *hold
1553 o2ptr(i,j,k) = o2n(k)*amo2*hold
1554 o3ptr(i,j,k) = o3mass * hold
1555 qvptr(i,j,k) = qvmass * hold
1559 IF(p2ptr(i,j,k).le.p1ptr(i,j,
lev_input))
THEN 1567 t2ptr(i,j,k) = temp(k)
1570 t2ptr(i,j,k) = wfun(k-kref+11) * temp(k) + &
1571 (1.- wfun(k-kref+11)) * t2ptr(i,j,k)
1576 DEALLOCATE (temp, prmb, on, o2n, n2n)
1578 END SUBROUTINE vintg_wam
1598 REAL(ESMF_KIND_R8),
PARAMETER :: DLTDZ=-6.5e-3*287.05/9.80665
1599 REAL(ESMF_KIND_R8),
PARAMETER :: DLPVDRT=-2.5e6/461.50
1600 REAL(ESMF_KIND_R8),
PARAMETER :: ONE = 1.0_esmf_kind_r8
1602 INTEGER :: I, J, K, CLB(3), CUB(3), RC
1603 INTEGER :: IM, KM1, KM2, NT, II
1605 REAL(ESMF_KIND_R8) :: DZ
1606 REAL(ESMF_KIND_R8),
ALLOCATABLE :: Z1(:,:,:), Z2(:,:,:)
1607 REAL(ESMF_KIND_R8),
ALLOCATABLE :: C1(:,:,:,:),C2(:,:,:,:)
1609 REAL(ESMF_KIND_R8),
POINTER :: P1PTR(:,:,:)
1610 REAL(ESMF_KIND_R8),
POINTER :: P2PTR(:,:,:)
1611 REAL(ESMF_KIND_R8),
POINTER :: DZDT1PTR(:,:,:)
1612 REAL(ESMF_KIND_R8),
POINTER :: DZDT2PTR(:,:,:)
1613 REAL(ESMF_KIND_R8),
POINTER :: T1PTR(:,:,:)
1614 REAL(ESMF_KIND_R8),
POINTER :: T2PTR(:,:,:)
1615 REAL(ESMF_KIND_R8),
POINTER :: Q1PTR(:,:,:)
1616 REAL(ESMF_KIND_R8),
POINTER :: Q2PTR(:,:,:)
1617 REAL(ESMF_KIND_R8),
POINTER :: WIND1PTR(:,:,:,:)
1618 REAL(ESMF_KIND_R8),
POINTER :: WIND2PTR(:,:,:,:)
1625 print*,
"- VERTICALY INTERPOLATE FIELDS." 1627 print*,
"- CALL FieldGet FOR 3-D PRES." 1629 computationallbound=clb, &
1630 computationalubound=cub, &
1631 farrayptr=p1ptr, rc=rc)
1632 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1641 ALLOCATE(z1(clb(1):cub(1),clb(2):cub(2),
lev_input))
1642 ALLOCATE(z2(clb(1):cub(1),clb(2):cub(2),
lev_target))
1648 print*,
"- CALL FieldGet FOR 3-D ADJUSTED PRESS" 1650 farrayptr=p2ptr, rc=rc)
1651 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1656 print*,
"- CALL FieldGet FOR 3-D WIND." 1658 farrayptr=wind1ptr, rc=rc)
1659 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1662 c1(:,:,:,1) = wind1ptr(:,:,:,1)
1663 c1(:,:,:,2) = wind1ptr(:,:,:,2)
1664 c1(:,:,:,3) = wind1ptr(:,:,:,3)
1666 print*,
"- CALL FieldGet FOR VERTICAL VELOCITY." 1668 farrayptr=dzdt1ptr, rc=rc)
1669 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1672 c1(:,:,:,4) = dzdt1ptr(:,:,:)
1673 print*,
"MIN MAX W TARGETB4 IN VINTG = ", minval(dzdt1ptr(:,:,:)), maxval(dzdt1ptr(:,:,:))
1675 print*,
"- CALL FieldGet FOR 3-D TEMP." 1677 farrayptr=t1ptr, rc=rc)
1678 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1681 c1(:,:,:,5) = t1ptr(:,:,:)
1685 print*,
"- CALL FieldGet FOR 3-D TRACERS ", trim(
tracers(i))
1687 farrayptr=q1ptr, rc=rc)
1688 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1691 c1(:,:,:,5+i) = q1ptr(:,:,:)
1701 im = (cub(1)-clb(1)+1) * (cub(2)-clb(2)+1)
1706 CALL terp3(im,1,1,1,1,4+nt,(im*km1),(im*km2), &
1707 km1,im,im,z1,c1,km2,im,im,z2,c2)
1714 print*,
"- CALL FieldGet FOR 3-D ADJUSTED TEMP." 1716 farrayptr=t2ptr, rc=rc)
1717 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1720 print*,
"- CALL FieldGet FOR ADJUSTED VERTICAL VELOCITY." 1722 farrayptr=dzdt2ptr, rc=rc)
1723 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1726 print*,
"- CALL FieldGet FOR 3-D ADJUSTED WIND." 1728 farrayptr=wind2ptr, rc=rc)
1729 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1735 wind2ptr(i,j,k,1)=c2(i,j,k,1)
1736 wind2ptr(i,j,k,2)=c2(i,j,k,2)
1737 wind2ptr(i,j,k,3)=c2(i,j,k,3)
1738 dzdt2ptr(i,j,k)=c2(i,j,k,4)
1739 dz=z2(i,j,k)-z1(i,j,1)
1741 t2ptr(i,j,k)=c2(i,j,k,5)
1743 t2ptr(i,j,k)=c1(i,j,1,5)*exp(dltdz*dz)
1751 print*,
"- CALL FieldGet FOR 3-D TRACER ", trim(
tracers(ii))
1753 farrayptr=q2ptr, rc=rc)
1754 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
1757 IF (trim(
tracers(ii)) ==
"sphum")
THEN 1762 dz=z2(i,j,k)-z1(i,j,1)
1764 q2ptr(i,j,k) = c2(i,j,k,5+ii)
1766 q2ptr(i,j,k) = c1(i,j,1,5+ii)*exp(dlpvdrt*(one/t2ptr(i,j,k)-one/t1ptr(i,j,1))-dz)
1777 q2ptr(i,j,k) = c2(i,j,k,5+ii)
1786 DEALLOCATE (z1, z2, c1, c2)
1788 END SUBROUTINE vintg
1826 SUBROUTINE terp3(IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2, &
1827 KM1,KXZ1,KXQ1,Z1,Q1,KM2,KXZ2,KXQ2,Z2,Q2)
1829 INTEGER IM,IXZ1,IXQ1,IXZ2,IXQ2,NM,NXQ1,NXQ2
1830 INTEGER KM1,KXZ1,KXQ1,KM2,KXZ2,KXQ2
1833 REAL(ESMF_KIND_R8),
PARAMETER :: ONE = 1.0_esmf_kind_r8
1834 REAL(ESMF_KIND_R8) :: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1)
1835 REAL(ESMF_KIND_R8) :: Q1(1+(IM-1)*IXQ1+(KM1-1)*KXQ1+(NM-1)*NXQ1)
1836 REAL(ESMF_KIND_R8) :: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2)
1837 REAL(ESMF_KIND_R8) :: Q2(1+(IM-1)*IXQ2+(KM2-1)*KXQ2+(NM-1)*NXQ2)
1839 REAL(ESMF_KIND_R8) :: FFA(IM),FFB(IM),FFC(IM),FFD(IM)
1840 REAL(ESMF_KIND_R8) :: GGA(IM),GGB(IM),GGC(IM),GGD(IM)
1841 REAL(ESMF_KIND_R8) :: Z1A,Z1B,Z1C,Z1D,Q1A,Q1B,Q1C,Q1D,Z2S,Q2S
1846 CALL rsearch(im,km1,ixz1,kxz1,z1,km2,ixz2,kxz2,z2,1,im,k1s)
1860 IF(k1.EQ.1.OR.k1.EQ.km1-1)
THEN 1861 z2s=z2(1+(i-1)*ixz2+(k2-1)*kxz2)
1862 z1a=z1(1+(i-1)*ixz1+(k1-1)*kxz1)
1863 z1b=z1(1+(i-1)*ixz1+(k1+0)*kxz1)
1864 ffa(i)=(z2s-z1b)/(z1a-z1b)
1865 ffb(i)=(z2s-z1a)/(z1b-z1a)
1866 gga(i)=one/(z1a-z1b)
1867 ggb(i)=one/(z1b-z1a)
1868 ELSEIF(k1.GT.1.AND.k1.LT.km1-1)
THEN 1869 z2s=z2(1+(i-1)*ixz2+(k2-1)*kxz2)
1870 z1a=z1(1+(i-1)*ixz1+(k1-2)*kxz1)
1871 z1b=z1(1+(i-1)*ixz1+(k1-1)*kxz1)
1872 z1c=z1(1+(i-1)*ixz1+(k1+0)*kxz1)
1873 z1d=z1(1+(i-1)*ixz1+(k1+1)*kxz1)
1874 ffa(i)=(z2s-z1b)/(z1a-z1b)* &
1875 (z2s-z1c)/(z1a-z1c)* &
1877 ffb(i)=(z2s-z1a)/(z1b-z1a)* &
1878 (z2s-z1c)/(z1b-z1c)* &
1880 ffc(i)=(z2s-z1a)/(z1c-z1a)* &
1881 (z2s-z1b)/(z1c-z1b)* &
1883 ffd(i)=(z2s-z1a)/(z1d-z1a)* &
1884 (z2s-z1b)/(z1d-z1b)* &
1886 gga(i)= one/(z1a-z1b)* &
1887 (z2s-z1c)/(z1a-z1c)* &
1888 (z2s-z1d)/(z1a-z1d)+ &
1889 (z2s-z1b)/(z1a-z1b)* &
1891 (z2s-z1d)/(z1a-z1d)+ &
1892 (z2s-z1b)/(z1a-z1b)* &
1893 (z2s-z1c)/(z1a-z1c)* &
1895 ggb(i)= one/(z1b-z1a)* &
1896 (z2s-z1c)/(z1b-z1c)* &
1897 (z2s-z1d)/(z1b-z1d)+ &
1898 (z2s-z1a)/(z1b-z1a)* &
1900 (z2s-z1d)/(z1b-z1d)+ &
1901 (z2s-z1a)/(z1b-z1a)* &
1902 (z2s-z1c)/(z1b-z1c)* &
1904 ggc(i)= one/(z1c-z1a)* &
1905 (z2s-z1b)/(z1c-z1b)* &
1906 (z2s-z1d)/(z1c-z1d)+ &
1907 (z2s-z1a)/(z1c-z1a)* &
1909 (z2s-z1d)/(z1c-z1d)+ &
1910 (z2s-z1a)/(z1c-z1a)* &
1911 (z2s-z1b)/(z1c-z1b)* &
1913 ggd(i)= one/(z1d-z1a)* &
1914 (z2s-z1b)/(z1d-z1b)* &
1915 (z2s-z1c)/(z1d-z1c)+ &
1916 (z2s-z1a)/(z1d-z1a)* &
1918 (z2s-z1c)/(z1d-z1c)+ &
1919 (z2s-z1a)/(z1d-z1a)* &
1920 (z2s-z1b)/(z1d-z1b)* &
1930 q2s=q1(1+(i-1)*ixq1+(n-1)*nxq1)
1932 ELSEIF(k1.EQ.km1)
THEN 1933 q2s=q1(1+(i-1)*ixq1+(km1-1)*kxq1+(n-1)*nxq1)
1935 ELSEIF(k1.EQ.1.OR.k1.EQ.km1-1)
THEN 1936 q1a=q1(1+(i-1)*ixq1+(k1-1)*kxq1+(n-1)*nxq1)
1937 q1b=q1(1+(i-1)*ixq1+(k1+0)*kxq1+(n-1)*nxq1)
1938 q2s=ffa(i)*q1a+ffb(i)*q1b
1941 q1a=q1(1+(i-1)*ixq1+(k1-2)*kxq1+(n-1)*nxq1)
1942 q1b=q1(1+(i-1)*ixq1+(k1-1)*kxq1+(n-1)*nxq1)
1943 q1c=q1(1+(i-1)*ixq1+(k1+0)*kxq1+(n-1)*nxq1)
1944 q1d=q1(1+(i-1)*ixq1+(k1+1)*kxq1+(n-1)*nxq1)
1945 q2s=ffa(i)*q1a+ffb(i)*q1b+ffc(i)*q1c+ffd(i)*q1d
1947 IF(q2s.LT.min(q1b,q1c))
THEN 1950 ELSEIF(q2s.GT.max(q1b,q1c))
THEN 1955 q2(1+(i-1)*ixq2+(k2-1)*kxq2+(n-1)*nxq2)=q2s
1962 END SUBROUTINE terp3
2020 SUBROUTINE rsearch(IM,KM1,IXZ1,KXZ1,Z1,KM2,IXZ2,KXZ2,Z2,IXL2,KXL2,L2)
2023 INTEGER,
INTENT(IN) :: IM,KM1,IXZ1,KXZ1,KM2,IXZ2,KXZ2,IXL2,KXL2
2024 INTEGER,
INTENT(OUT) :: L2(1+(IM-1)*IXL2+(KM2-1)*KXL2)
2026 REAL(ESMF_KIND_R8),
INTENT(IN) :: Z1(1+(IM-1)*IXZ1+(KM1-1)*KXZ1)
2027 REAL(ESMF_KIND_R8),
INTENT(IN) :: Z2(1+(IM-1)*IXZ2+(KM2-1)*KXZ2)
2031 REAL(ESMF_KIND_R8) :: Z
2037 IF (z1(1+(i-1)*ixz1).LE.z1(1+(i-1)*ixz1+(km1-1)*kxz1))
THEN 2040 z=z2(1+(i-1)*ixz2+(k2-1)*kxz2)
2043 IF(z.LT.z1(1+(i-1)*ixz1+l*kxz1))
EXIT 2047 l2(1+(i-1)*ixl2+(k2-1)*kxl2)=l
2052 z=z2(1+(i-1)*ixz2+(k2-1)*kxz2)
2055 IF(z.GT.z1(1+(i-1)*ixz1+l*kxz1))
EXIT 2059 l2(1+(i-1)*ixl2+(k2-1)*kxl2)=l
2064 END SUBROUTINE rsearch
2072 integer :: i,ii, j,k, rc, clb(2), cub(2)
2074 real(esmf_kind_r8),
allocatable :: pe0(:), pn0(:)
2075 real(esmf_kind_r8),
pointer :: psptr(:,:)
2076 real(esmf_kind_r8),
pointer :: zhsfcptr(:,:)
2077 real(esmf_kind_r8),
pointer :: zhptr(:,:,:)
2078 real(esmf_kind_r8),
pointer :: tptr(:,:,:)
2079 real(esmf_kind_r8),
pointer :: qptr(:,:,:)
2080 real(esmf_kind_r8) :: ak, bk, zvir, grd
2081 real(esmf_kind_r8),
parameter :: grav = 9.80665
2082 real(esmf_kind_r8),
parameter :: rdgas = 287.05
2083 real(esmf_kind_r8),
parameter :: rvgas = 461.50
2085 print*,
"- COMPUTE HEIGHT" 2087 print*,
"- CALL FieldGet FOR SURFACE PRESSURE" 2089 computationallbound=clb, &
2090 computationalubound=cub, &
2091 farrayptr=psptr, rc=rc)
2092 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
2095 print*,
"- CALL FieldGet FOR TERRAIN HEIGHT" 2097 farrayptr=zhsfcptr, rc=rc)
2098 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
2101 print*,
"- CALL FieldGet FOR HEIGHT" 2103 farrayptr=zhptr, rc=rc)
2104 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
2107 print*,
"- CALL FieldGet FOR TEMPERATURE" 2109 farrayptr=tptr, rc=rc)
2110 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
2114 if (trim(
tracers(ii)) ==
"sphum")
exit 2117 print*,
"- CALL FieldGet FOR SPECIFIC HUMIDITY" 2119 farrayptr=qptr, rc=rc)
2120 if(esmf_logfounderror(rctocheck=rc,msg=esmf_logerr_passthru,line=__line__,file=__file__)) &
2124 zvir = rvgas/rdgas - 1.0_esmf_kind_r8
2129 do j = clb(2), cub(2)
2130 do i = clb(1), cub(1)
2137 pe0(k) = ak + bk*psptr(i,j)
2138 pn0(k) = log(pe0(k))
2141 zhptr(i,j,1) = zhsfcptr(i,j)
2144 zhptr(i,j,k) = zhptr(i,j,k-1)+tptr(i,j,k-1)*(1.+zvir*qptr(i,j,k-1))* &
2145 (pn0(k-1)-pn0(k))/grd
2151 deallocate(pe0, pn0)
2164 print*,
"- DESTROY TARGET GRID ATMOSPHERIC BEFORE ADJUSTMENT FIELDS." 2191 print*,
"- DESTROY LOCAL TARGET GRID ATMOSPHERIC FIELDS." subroutine compute_zh
Compute vertical level height.
subroutine newps(localpet)
Computes adjusted surface pressure given a new terrain height.
This module contains code to read the setup namelist file, handle the varmap file for GRIB2 data...
integer, public num_tracers_input
Number of atmospheric tracers in input file.
type(esmf_field), public v_w_target_grid
V-wind, 'west' edge of grid cell.
integer, public lev_thomp_mp_climo
number of vert lvls of Thompson climo data
type(esmf_field), public longitude_w_target_grid
longitude of 'west' edge of grid box, target grid
subroutine cleanup_target_atm_b4adj_data
Cleanup atmospheric field (before adjustment) objects.
subroutine create_atm_esmf_fields
Create target grid field objects.
type(esmf_field) wind_target_grid
3-d wind, grid box center
integer, public cycle_mon
Cycle month.
type(esmf_field) temp_b4adj_target_grid
temp before vert adj
integer, public regional
For regional target grids.
type(esmf_field), public qnifa_climo_input_grid
number concentration of ice friendly nuclei.
character(len=20), dimension(max_tracers), public tracers
Name of each atmos tracer to be processed.
real(esmf_kind_r8), dimension(:,:), allocatable, public vcoord_target
Vertical coordinate.
subroutine, public atmosphere_driver(localpet)
Driver routine to process for atmospheric fields.
type(esmf_field), public qnwfa_climo_input_grid
number concentration of water friendly nuclei.
integer, public cycle_year
Cycle year.
subroutine, public read_thomp_mp_climo_data
Read Thompson climatological MP data file and time interpolate data to current cycle time...
subroutine, public read_vcoord_info
Reads model vertical coordinate definition file (as specified by namelist variable vcoord_file_target...
type(esmf_field), public longitude_s_target_grid
longitude of 'south' edge of grid box, target grid
Sets up the ESMF grid objects for the input data grid and target FV3 grid.
type(esmf_field), public qnifa_climo_target_grid
Number concentration of ice friendly aerosols.
integer, public cycle_day
Cycle day.
type(esmf_field), public latitude_s_target_grid
latitude of 'south' edge of grid box, target grid
type(esmf_field), public zh_target_grid
3-d height.
type(esmf_field) pres_b4adj_target_grid
3-d pres before terrain adj
type(esmf_grid), public target_grid
target grid esmf grid object.
type(esmf_field), public latitude_w_target_grid
latitude of 'west' edge of grid box, target grid
type(esmf_field), public delp_target_grid
Pressure thickness.
integer, public lev_target
Number of vertical levels.
Module to read the Thompson climatological MP data file and set up the associated esmf field and grid...
subroutine cleanup_all_target_atm_data
Cleanup target grid atmospheric field objects.
logical, public wam_cold_start
When true, cold start for whole atmosphere model.
subroutine horiz_interp_thomp_mp_climo
Horizontally interpolate thompson microphysics data to the target model grid.
character(len=500), public vcoord_file_target_grid
Vertical coordinate definition file.
Module to hold variables and ESMF fields associated with the target grid atmospheric data...
subroutine newpr1(localpet)
Computes 3-D pressure given an adjusted surface pressure.
subroutine convert_winds
Convert 3-d component winds to u and v.
type(esmf_field) pres_target_grid
3-d pressure
type(esmf_field) terrain_interp_to_target_grid
Input grid terrain interpolated to target grid.
type(esmf_field) wind_b4adj_target_grid
3-d wind before vert adj
character(len=500), public atm_weight_file
File containing pre-computed weights to horizontally interpolate atmospheric fields.
type(esmf_field), public qnwfa_climo_target_grid
Number concentration of water friendly aerosols.
type(esmf_field), public v_s_target_grid
V-wind, 'south' edge of grid cell.
type(esmf_field) thomp_pres_climo_b4adj_target_grid
pressure of each level on target grid
integer, public nvcoord_target
Number of vertical coordinate variables.
subroutine error_handler(string, rc)
General error handler.
type(esmf_field), public u_s_target_grid
U-wind, 'south' edge of grid cell.
type(esmf_field), public ps_target_grid
Surface pressure.
type(esmf_field), dimension(:), allocatable tracers_b4adj_target_grid
tracers before vert adj
type(esmf_field), public u_w_target_grid
U-wind, 'west' edge of grid cell.
subroutine gettemp(iday, nday, xlat, nlat, pr, np, temp, n_o, n_o2, n_n2)
Entry routine to get WAM needed temperature and composition profiles.
type(esmf_field), public thomp_pres_climo_input_grid
3-d pressure of the Thompson climo data points
Process atmospheric fields.
type(esmf_field) wind_w_target_grid
3-d wind, 'west' edge
subroutine, public cleanup_thomp_mp_climo_input_data
Free up memory associated with this module.
integer, public num_tracers
Number of atmospheric tracers to be processed.
type(esmf_field), public terrain_target_grid
terrain height target grid
type(esmf_field) ps_b4adj_target_grid
sfc pres before terrain adj
type(esmf_field), public temp_target_grid
Temperautre.
integer, public levp1_target
Number of vertical levels plus 1.
logical, public use_thomp_mp_climo
When true, read and process Thompson MP climatological tracers.
type(esmf_field), dimension(:), allocatable, public tracers_target_grid
Tracers.
integer, public cycle_hour
Cycle hour.
type(esmf_field) wind_s_target_grid
3-d wind, 'south' edge
type(esmf_field), public dzdt_target_grid
Vertical velocity.
type(esmf_field) qnifa_climo_b4adj_target_grid
number concentration of ice friendly aerosols before vert adj
subroutine, public cleanup_atmosphere_target_data
Free up memory for fields and variables in this module.
subroutine create_atm_b4adj_esmf_fields
Create target grid field objects to hold data before vertical interpolation.
type(esmf_field) dzdt_b4adj_target_grid
vertical vel before vert adj
type(esmf_field) qnwfa_climo_b4adj_target_grid
number concentration of water friendly aerosols before vert adj