<p><b>fanglin.yang@noaa.gov</b> 2012-05-10 17:40:46 -0600 (Thu, 10 May 2012)</p><p>reorganize structure 05-10-2012<br>
</p><hr noshade><pre><font color="gray">Modified: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/GFS_Initialize.f
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/GFS_Initialize.f 2012-05-10 23:36:12 UTC (rev 1894)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/GFS_Initialize.f 2012-05-10 23:40:46 UTC (rev 1895)
@@ -26,33 +26,52 @@
!!USES:
!
!fy USE GFS_GetCf_ESMFMod
- USE MACHINE, ONLY : kind_io4, kind_phys
- USE namelist_def, ONLY : ndsl, nst_fcst
+!fy USE MACHINE, ONLY : kind_io4, kind_phys
+!fy USE namelist_def, ONLY : ndsl, nst_fcst
!fy use gfsio_module , only : gfsio_init
- use module_ras , only : nrcmax, fix_ncld_hr
- use gfs_internalstate_module
+!fy use module_ras , only : nrcmax, fix_ncld_hr
+ use machine
+ use resol_def
+ use layout1
+ use vert_def
+ use date_def
+ use gg_def
+ use coordinate_def
+ use namelist_def
+ use mpi_def
+ use ozne_def
+ use Sfc_Flx_ESMFMod
+ use Nst_Var_ESMFMod
+ use d3d_def
+ use gfsmisc_def
+! use cmp_comm , only : Coupler_id
+
+
IMPLICIT none
CONTAINS
!=============================================================================================
!fy SUBROUTINE GFS_Initialize(gcGFS, gis, clock, rc)
- SUBROUTINE GFS_Initialize(me,fhour,levs_mpas,ncell,xlon,xlat, &
- lats_node_r,dt_mpas,nlunit,gfs_namelist,gis)
+ SUBROUTINE GFS_Initialize(me,fhour,levs_mpas,ncell,xlon_mpas,xlat_mpas, &
+ lats_node_r,dt_mpas,nlunit,gfs_namelist)
!=============================================================================================
- integer(kind=kind_io4), intent(in) :: me !me=0 is master task
- integer(kind=kind_io4), intent(in) :: levs_mpas !MPAS vertical layers
- integer(kind=kind_io4), intent(in) :: ncell !MPAS number of cells for each task
- integer(kind=kind_io4), intent(in) :: nlunit !unit to read gfs_namelist
- integer, intent(in) :: lats_node_r !latitude points, 1 for MPAS
- real(kind=kind_phys), intent(in) :: dt_mpas !MPAS timestep in seconds
- real(kind=kind_phys), intent(in) :: fhour !MPAS forecast time
- real(kind=kind_phys), intent(in) :: xlon(ncell) !MPAS cell longitude
- real(kind=kind_phys), intent(in) :: xlat(ncell) !MPAS cell latitude
+ integer(kind=kind_io4), intent(in) :: me !me=0 is master task
+ integer(kind=kind_io4), intent(in) :: levs_mpas !MPAS vertical layers
+ integer(kind=kind_io4), intent(in) :: ncell !MPAS number of cells for each task
+ integer(kind=kind_io4), intent(in) :: nlunit !unit to read gfs_namelist
+ integer, intent(in) :: lats_node_r !latitude points, 1 for MPAS
+ real(kind=kind_phys), intent(in) :: dt_mpas !MPAS timestep in seconds
+ real(kind=kind_phys), intent(in) :: fhour !MPAS forecast time
+ real(kind=kind_phys), intent(in) :: xlon_mpas(ncell) !MPAS cell longitude
+ real(kind=kind_phys), intent(in) :: xlat_mpas(ncell) !MPAS cell latitude
character (len=*), intent(in) :: gfs_namelist
+ TYPE(Sfc_Var_Data) :: sfc_fld
+ TYPE(Flx_Var_Data) :: flx_fld
+ TYPE(Nst_Var_Data) :: nst_fld
! This subroutine set up the internal state variables,
! allocate internal state arrays for initializing the GFS system.
@@ -60,7 +79,7 @@
!fy TYPE(ESMF_VM) :: vm_local ! ESMF virtual machine
!fy TYPE(ESMF_GridComp), INTENT(inout) :: gcGFS
- TYPE(GFS_InternalState), POINTER, INTENT(inout) :: gis
+!fy TYPE(GFS_InternalState), POINTER, INTENT(inout) :: gis
!fy TYPE(ESMF_Clock), INTENT(inout) :: clock
! INTEGER, INTENT(out) :: rc
!fy INTEGER, DIMENSION(mpi_status_size) :: status
@@ -95,46 +114,56 @@
!fy npe_single_member = gis%npe_single_member
!fy print *,' npe_single_member=',npe_single_member
- CALL COMPNS(gis%DELTIM,gis%IRET, &
-! gis%ntrac, gis%nxpt, gis%nypt, gis%jintmx, gis%jcap, &
- gis%ntrac, gis%jcapg, gis%jcap, &
- gis%levs, gis%levr, gis%lonf, gis%lonr, gis%latg, gis%latr,&
- gis%ntoz, gis%ntcw, gis%ncld, gis%lsoil, gis%nmtvr, &
-!fy gis%num_p3d, gis%num_p2d, me, gis%nam_gfs%nlunit, gis%nam_gfs%gfs_namelist)
- gis%num_p3d, gis%num_p2d, me, nlunit, gfs_namelist)
+!fy CALL COMPNS(gis%DELTIM,gis%IRET, &
+!fy! gis%ntrac, gis%nxpt, gis%nypt, gis%jintmx, gis%jcap, &
+!fy gis%ntrac, gis%jcapg, gis%jcap, &
+!fy gis%levs, gis%levr, gis%lonf, gis%lonr, gis%latg, gis%latr,&
+!fy gis%ntoz, gis%ntcw, gis%ncld, gis%lsoil, gis%nmtvr, &
+!fy gis%num_p3d, gis%num_p2d, me, gis%nam_gfs%nlunit, gis%nam_gfs%gfs_namelist)
+ CALL COMPNS(DELTIM,IRET, &
+ ntrac, jcapg, jcap, &
+ levs, levr, lonf, lonr, latg, latr, &
+ ntoz, ntcw, ncld, lsoil, nmtvr, &
+ num_p3d, num_p2d, me, nlunit, gfs_namelist)
+
!---------------
!--for MPAS use ncell points for each task
- gis%lonr=ncell
- gis%latr=1 !lat dimention is meaningless for MPAS cells
- gis%deltim=dt_mpas
- if(levs_mpas.ne.gis%levs) gis%levs=levs_mpas
+ if(lonr.ne.ncell) lonr=ncell
+ if(ngptc.gt.lonr) ngptc=lonr
+ if(levs_mpas.ne.levs) levs=levs_mpas
+ latr=1 !lat dimention is not used for MPAS cells
+ deltim=dt_mpas
+ ipt_lats_node_r=1
+ if(latg.lt.1) latg=880 !total latitudinal points, not really used
+
!---------------
!
CALL set_soilveg(me,nlunit)
- call set_tracer_const(gis%ntrac,me,nlunit)
+!fy call set_tracer_const(gis%ntrac,me,nlunit)
+ call set_tracer_const(ntrac,me,nlunit)
!
- ntrac = gis%ntrac
-! nxpt = gis%nxpt
-! nypt = gis%nypt
-! jintmx = gis%jintmx
- jcapg = gis%jcapg
- jcap = gis%jcap
- levs = gis%levs
- levr = gis%levr
- lonf = gis%lonf
- lonr = gis%lonr
- latg = gis%latg
- latr = gis%latr
- ntoz = gis%ntoz
- ntcw = gis%ntcw
- ncld = gis%ncld
- lsoil = gis%lsoil
- nmtvr = gis%nmtvr
- num_p3d = gis%num_p3d
- num_p2d = gis%num_p2d
+!fy ntrac = gis%ntrac
+!fy! nxpt = gis%nxpt
+!fy! nypt = gis%nypt
+!fy! jintmx = gis%jintmx
+!fy jcapg = gis%jcapg
+!fy jcap = gis%jcap
+!fy levs = gis%levs
+!fy levr = gis%levr
+!fy lonf = gis%lonf
+!fy lonr = gis%lonr
+!fy latg = gis%latg
+!fy latr = gis%latr
+!fy ntoz = gis%ntoz
+!fy ntcw = gis%ntcw
+!fy ncld = gis%ncld
+!fy lsoil = gis%lsoil
+!fy nmtvr = gis%nmtvr
+!fy num_p3d = gis%num_p3d
+!fy num_p2d = gis%num_p2d
!fy if (gis%nam_gfs%Total_Member <= 1) then
!fy ens_nam=' '
!fy else
@@ -150,7 +179,7 @@
if (levs .gt. 99) ivsupa = 200509
!
levh = ntrac*levs
- gis%levh = levh ! Added by Weiyu
+!fy gis%levh = levh ! Added by Weiyu
! latgd = latg+ 2*jintmx
latgd = latg
jcap1 = jcap+1
@@ -204,11 +233,14 @@
!
if (ntrac-ncld-1 > 0) then
- allocate ( gis%fscav(ntrac-ncld-1), stat = ierr )
- gis%fscav = 0.0
+!fy allocate ( gis%fscav(ntrac-ncld-1), stat = ierr )
+!fy gis%fscav = 0.0
+ allocate ( fscav(ntrac-ncld-1), stat = ierr )
+ fscav = 0.0
endif
- gis%lnt2 = lnt2
+!fy gis%lnt2 = lnt2
+ lnt2 = lnt2
!fy allocate(lat1s_a(0:jcap))
!fy allocate(lat1s_r(0:jcap))
@@ -226,6 +258,11 @@
allocate(sinlat_r(latr))
allocate(coslat_r(latr))
+!---for MPAS
+ allocate(sinlat_r2(lonr,latr))
+ allocate(coslat_r2(lonr,latr))
+!---for MPAS
+
!fy allocate(am(levs,levs))
!fy allocate(bm(levs,levs))
!fy allocate(cm(levs,levs))
@@ -284,8 +321,8 @@
!fy d_m =444444444.
!
- allocate(z(lnt2))
- allocate(z_r(lnt2))
+!fy allocate(z(lnt2))
+!fy allocate(z_r(lnt2))
!
nfluxes = 153
!fy allocate(fmm(lonr*latr,nfluxes),lbmm(lonr*latr,nfluxes))
@@ -293,9 +330,9 @@
!
!fy allocate(gis%LONSPERLAT(latg))
+!fy allocate(gis%lonsperlar(latr))
+ allocate(lonsperlar(latr))
- allocate(gis%lonsperlar(latr))
-
!fy if ( .not. ndsl ) then
!***********************************************************************
!fy if (redgg_a) then
@@ -339,13 +376,14 @@
!fy endif
!fy endif
- gis%lonsperlar = lonr !for MPAS
+ lonsperlar = lonr !for MPAS
!***********************************************************************
!
if (ras) then
if (fix_ncld_hr) then
! nrcm = min(nrcmax, levs-1) * (gis%deltim/1200) + 0.50001
- nrcm = min(nrcmax, levs-1) * (gis%deltim/1200) + 0.10001
+!fy nrcm = min(nrcmax, levs-1) * (gis%deltim/1200) + 0.10001
+ nrcm = min(nrcmax, levs-1) * (deltim/1200) + 0.10001
! nrcm = min(nrcmax, levs-1) * min(1.0,gis%deltim/360) + 0.1
else
nrcm = min(nrcmax, levs-1)
@@ -398,7 +436,8 @@
! pl_pres(:) = log(0.1*pl_pres(:)) ! Natural log of pres in cbars
pl_pres(:) = log(100.0*pl_pres(:)) ! Natural log of pres in Pa
!
- allocate(gis%OZPLIN(LATSOZP,LEVOZP,pl_coeff,timeoz)) !OZONE P-L coeffcients
+!fy allocate(gis%OZPLIN(LATSOZP,LEVOZP,pl_coeff,timeoz)) !OZONE P-L coeffcients
+ allocate(OZPLIN(LATSOZP,LEVOZP,pl_coeff,timeoz)) !OZONE P-L coeffcients
! endif
!
!
@@ -456,32 +495,32 @@
kwrq = 3*levs+0*levh+2 ! rqe/o_ls
!
- gis%P_GZ = 0*LEVS+0*LEVH+1 ! GZE/O(LNTE/OD,2),
- gis%P_ZEM = 0*LEVS+0*LEVH+2 ! ZEME/O(LNTE/OD,2,LEVS),
- gis%P_DIM = 1*LEVS+0*LEVH+2 ! DIME/O(LNTE/OD,2,LEVS),
- gis%P_TEM = 2*LEVS+0*LEVH+2 ! TEME/O(LNTE/OD,2,LEVS),
- gis%P_RM = 3*LEVS+0*LEVH+2 ! RME/O(LNTE/OD,2,LEVH),
- gis%P_QM = 3*LEVS+1*LEVH+2 ! QME/O(LNTE/OD,2),
- gis%P_ZE = 3*LEVS+1*LEVH+3 ! ZEE/O(LNTE/OD,2,LEVS),
- gis%P_DI = 4*LEVS+1*LEVH+3 ! DIE/O(LNTE/OD,2,LEVS),
- gis%P_TE = 5*LEVS+1*LEVH+3 ! TEE/O(LNTE/OD,2,LEVS),
- gis%P_RQ = 6*LEVS+1*LEVH+3 ! RQE/O(LNTE/OD,2,LEVH),
- gis%P_Q = 6*LEVS+2*LEVH+3 ! QE/O(LNTE/OD,2),
- gis%P_DLAM= 6*LEVS+2*LEVH+4 ! DPDLAME/O(LNTE/OD,2),
- gis%P_DPHI= 6*LEVS+2*LEVH+5 ! DPDPHIE/O(LNTE/OD,2),
- gis%P_ULN = 6*LEVS+2*LEVH+6 ! ULNE/O(LNTE/OD,2,LEVS),
- gis%P_VLN = 7*LEVS+2*LEVH+6 ! VLNE/O(LNTE/OD,2,LEVS),
- gis%P_W = 8*LEVS+2*LEVH+6 ! WE/O(LNTE/OD,2,LEVS),
- gis%P_X = 9*LEVS+2*LEVH+6 ! XE/O(LNTE/OD,2,LEVS),
- gis%P_Y =10*LEVS+2*LEVH+6 ! YE/O(LNTE/OD,2,LEVS),
- gis%P_RT =11*LEVS+2*LEVH+6 ! RTE/O(LNTE/OD,2,LEVH),
- gis%P_ZQ =11*LEVS+3*LEVH+6 ! ZQE/O(LNTE/OD,2)
+!fy gis%P_GZ = 0*LEVS+0*LEVH+1 ! GZE/O(LNTE/OD,2),
+!fy gis%P_ZEM = 0*LEVS+0*LEVH+2 ! ZEME/O(LNTE/OD,2,LEVS),
+!fy gis%P_DIM = 1*LEVS+0*LEVH+2 ! DIME/O(LNTE/OD,2,LEVS),
+!fy gis%P_TEM = 2*LEVS+0*LEVH+2 ! TEME/O(LNTE/OD,2,LEVS),
+!fy gis%P_RM = 3*LEVS+0*LEVH+2 ! RME/O(LNTE/OD,2,LEVH),
+!fy gis%P_QM = 3*LEVS+1*LEVH+2 ! QME/O(LNTE/OD,2),
+!fy gis%P_ZE = 3*LEVS+1*LEVH+3 ! ZEE/O(LNTE/OD,2,LEVS),
+!fy gis%P_DI = 4*LEVS+1*LEVH+3 ! DIE/O(LNTE/OD,2,LEVS),
+!fy gis%P_TE = 5*LEVS+1*LEVH+3 ! TEE/O(LNTE/OD,2,LEVS),
+!fy gis%P_RQ = 6*LEVS+1*LEVH+3 ! RQE/O(LNTE/OD,2,LEVH),
+!fy gis%P_Q = 6*LEVS+2*LEVH+3 ! QE/O(LNTE/OD,2),
+!fy gis%P_DLAM= 6*LEVS+2*LEVH+4 ! DPDLAME/O(LNTE/OD,2),
+!fy gis%P_DPHI= 6*LEVS+2*LEVH+5 ! DPDPHIE/O(LNTE/OD,2),
+!fy gis%P_ULN = 6*LEVS+2*LEVH+6 ! ULNE/O(LNTE/OD,2,LEVS),
+!fy gis%P_VLN = 7*LEVS+2*LEVH+6 ! VLNE/O(LNTE/OD,2,LEVS),
+!fy gis%P_W = 8*LEVS+2*LEVH+6 ! WE/O(LNTE/OD,2,LEVS),
+!fy gis%P_X = 9*LEVS+2*LEVH+6 ! XE/O(LNTE/OD,2,LEVS),
+!fy gis%P_Y =10*LEVS+2*LEVH+6 ! YE/O(LNTE/OD,2,LEVS),
+!fy gis%P_RT =11*LEVS+2*LEVH+6 ! RTE/O(LNTE/OD,2,LEVH),
+!fy gis%P_ZQ =11*LEVS+3*LEVH+6 ! ZQE/O(LNTE/OD,2)
!C
- gis%LOTS = 5*LEVS+1*LEVH+3
- gis%LOTD = 6*LEVS+2*LEVH+0
- gis%LOTA = 3*LEVS+1*LEVH+1
+!fy gis%LOTS = 5*LEVS+1*LEVH+3
+!fy gis%LOTD = 6*LEVS+2*LEVH+0
+!fy gis%LOTA = 3*LEVS+1*LEVH+1
!C
- allocate(gis%TEE1(LEVS))
+!fy allocate(gis%TEE1(LEVS))
! gis%LSLAG=.FALSE. ! IF FALSE EULERIAN SCHEME =.true. for semilag
@@ -554,10 +593,14 @@
!fy endif
!fy endif
!C
- gis%CONS0 = 0.0D0
- gis%CONS0P5 = 0.5D0
- gis%CONS1200 = 1200.D0
- gis%CONS3600 = 3600.D0
+!fy gis%CONS0 = 0.0D0
+!fy gis%CONS0P5 = 0.5D0
+!fy gis%CONS1200 = 1200.D0
+!fy gis%CONS3600 = 3600.D0
+ CONS0 = 0.0D0
+ CONS0P5 = 0.5D0
+ CONS1200 = 1200.D0
+ CONS3600 = 3600.D0
!C
!fy if (liope) then
!fy if (icolor.eq.2) then
@@ -591,13 +634,15 @@
!fy ALLOCATE ( gis%GLOBAL_LATS_A(LATG) )
!C
!fy ALLOCATE ( gis%LATS_NODES_R(NODES) )
- ALLOCATE ( gis%GLOBAL_LATS_R(LATR) )
+!fy ALLOCATE ( gis%GLOBAL_LATS_R(LATR) )
+ ALLOCATE ( GLOBAL_LATS_R(LATR) )
!C
! ALLOCATE ( gis%LATS_NODES_EXT(NODES) )
! ALLOCATE ( gis%GLOBAL_LATS_EXT(LATG+2*JINTMX+2*NYPT*(NODES-1)) )
!C
!C
- gis%IPRINT = 0
+!fy gis%IPRINT = 0
+ IPRINT = 0
! gis%LATS_NODES_EXT = 0
! For creating the ESMF interface state with the GFS
@@ -739,13 +784,21 @@
!fy ALLOCATE ( gis%PLNEW_R(LEN_TRIE_LS,LATR2) )
!fy ALLOCATE ( gis%PLNOW_R(LEN_TRIO_LS,LATR2) )
!C
- gis%MAXSTP=36
+!fy gis%MAXSTP=36
+ MAXSTP=36
-
- IF(ME.EQ.0) PRINT*,'FROM COMPNS : IRET=',gis%IRET,' NSOUT=',NSOUT, &
+!fy IF(ME.EQ.0) PRINT*,'FROM COMPNS : IRET=',gis%IRET,' NSOUT=',NSOUT, &
+!fy ' NSSWR=',NSSWR,' NSLWR=',NSLWR,' NSZER=',NSZER,' NSRES=',NSRES, &
+!fy ' NSDFI=',NSDFI,' NSCYC=',NSCYC,' RAS=',RAS
+!fy IF(gis%IRET.NE.0) THEN
+!fy IF(ME.EQ.0) PRINT *,' INCOMPATIBLE NAMELIST - ABORTED IN MAIN'
+!fy CALL MPI_QUIT(13)
+!fy ENDIF
+
+ IF(ME.EQ.0) PRINT*,'FROM COMPNS : IRET=',IRET,' NSOUT=',NSOUT, &
' NSSWR=',NSSWR,' NSLWR=',NSLWR,' NSZER=',NSZER,' NSRES=',NSRES, &
' NSDFI=',NSDFI,' NSCYC=',NSCYC,' RAS=',RAS
- IF(gis%IRET.NE.0) THEN
+ IF(IRET.NE.0) THEN
IF(ME.EQ.0) PRINT *,' INCOMPATIBLE NAMELIST - ABORTED IN MAIN'
CALL MPI_QUIT(13)
ENDIF
@@ -773,29 +826,43 @@
!fy gis%PLNEV_R,gis%PLNOD_R,gis%PDDEV_R,gis%PDDOD_R, &
!fy gis%PLNEW_R,gis%PLNOW_R,gis%colat1)
!!
- call sfcvar_aldata(lonr,lats_node_r,lsoil,gis%sfc_fld,ierr)
- call flxvar_aldata(lonr,lats_node_r,gis%flx_fld,ierr)
+!fy call sfcvar_aldata(lonr,lats_node_r,lsoil,gis%sfc_fld,ierr)
+!fy call flxvar_aldata(lonr,lats_node_r,gis%flx_fld,ierr)
+ call sfcvar_aldata(lonr,lats_node_r,lsoil,sfc_fld,ierr)
+ call flxvar_aldata(lonr,lats_node_r,flx_fld,ierr)
!li added 05/31/2007 (for oceanic component)
! Modified by Moorthi
!fy call nstvar_aldata(lonr,lats_node_r,gis%nam_gfs%nst_fld,ierr)
- ALLOCATE ( gis%XLON(LONR,LATS_NODE_R))
- ALLOCATE ( gis%XLAT(LONR,LATS_NODE_R))
- ALLOCATE ( gis%COSZDG(LONR,LATS_NODE_R))
- ALLOCATE ( gis%SFALB(LONR,LATS_NODE_R))
- ALLOCATE ( gis%HPRIME(LONR,NMTVR,LATS_NODE_R))
- ALLOCATE ( gis%FLUXR(LONR,nfxr,LATS_NODE_R))
+!fy ALLOCATE ( gis%XLON(LONR,LATS_NODE_R))
+!fy ALLOCATE ( gis%XLAT(LONR,LATS_NODE_R))
+!fy ALLOCATE ( gis%COSZDG(LONR,LATS_NODE_R))
+!fy ALLOCATE ( gis%SFALB(LONR,LATS_NODE_R))
+!fy ALLOCATE ( gis%HPRIME(LONR,NMTVR,LATS_NODE_R))
+!fy ALLOCATE ( gis%FLUXR(LONR,nfxr,LATS_NODE_R))
+ ALLOCATE ( XLON(LONR,LATS_NODE_R))
+ ALLOCATE ( XLAT(LONR,LATS_NODE_R))
+ ALLOCATE ( COSZDG(LONR,LATS_NODE_R))
+ ALLOCATE ( SFALB(LONR,LATS_NODE_R))
+ ALLOCATE ( HPRIME(LONR,NMTVR,LATS_NODE_R))
+ ALLOCATE ( FLUXR(LONR,nfxr,LATS_NODE_R))
+
! gis%NBLCK = LONR/NGPTC + 1
- ALLOCATE ( gis%SWH(LONR,LEVS,LATS_NODE_R))
- ALLOCATE ( gis%HLW(LONR,LEVS,LATS_NODE_R))
-
- ALLOCATE (gis%JINDX1(LATS_NODE_R),gis%JINDX2(LATS_NODE_R))
- ALLOCATE (gis%DDY(LATS_NODE_R))
+!fy ALLOCATE ( gis%SWH(LONR,LEVS,LATS_NODE_R))
+!fy ALLOCATE ( gis%HLW(LONR,LEVS,LATS_NODE_R))
+!fy ALLOCATE (gis%JINDX1(LATS_NODE_R),gis%JINDX2(LATS_NODE_R))
+!fy ALLOCATE (gis%DDY(LATS_NODE_R))
+!fy allocate (gis%phy_f3d(LONR,LEVS,num_p3d,lats_node_r))
+!fy allocate (gis%phy_f2d(lonr,num_p2d,lats_node_r))
!
- allocate (gis%phy_f3d(LONR,LEVS,num_p3d,lats_node_r))
- allocate (gis%phy_f2d(lonr,num_p2d,lats_node_r))
+ ALLOCATE ( SWH(LONR,LEVS,LATS_NODE_R))
+ ALLOCATE ( HLW(LONR,LEVS,LATS_NODE_R))
+ ALLOCATE (JINDX1(LATS_NODE_R),JINDX2(LATS_NODE_R))
+ ALLOCATE (DDY(LATS_NODE_R))
+ allocate (phy_f3d(LONR,LEVS,num_p3d,lats_node_r))
+ allocate (phy_f2d(lonr,num_p2d,lats_node_r))
!
call d3d_init(lonr,lats_node_r,levs,pl_coeff,ldiag3d,lggfs3d)
@@ -812,10 +879,10 @@
!fy if (num_p3d > 0) gis%phy_f3d = 0.0
!fy if (num_p2d > 0) gis%phy_f2d = 0.0
!fy endif
- if (num_p3d > 0) gis%phy_f3d = 0.0
- if (num_p2d > 0) gis%phy_f2d = 0.0
+ if (num_p3d > 0) phy_f3d = 0.0
+ if (num_p2d > 0) phy_f2d = 0.0
!!
- CALL countperf(0,18,0.)
+!fy CALL countperf(0,18,0.)
!!
! Modified by Weiyu.
!-------------------
@@ -849,7 +916,7 @@
! ELSE
! ILAT=LATS_NODE_A
! ENDIF
- CALL countperf(1,15,0.)
+!fy CALL countperf(1,15,0.)
!!
!C......................................................................
!C
@@ -893,7 +960,8 @@
!fy ,' sfc_ini=',gis%nam_gfs%sfc_ini
!fy print *,' nst_ini=',gis%nam_gfs%nst_ini
!fy CALL countperf(0,18,0.)
- gis%pdryini = 0.0
+!fy gis%pdryini = 0.0
+ pdryini = 0.0
!fy CALL spect_fields(gis%n1, gis%n2, &
!fy gis%PDRYINI, gis%TRIE_LS, gis%TRIO_LS, &
!fy gis%LS_NODE, gis%LS_NODES, gis%MAX_LS_NODES, &
@@ -904,14 +972,16 @@
!fy gis%nam_gfs%sig_ini, gis%nam_gfs%sig_ini2)
!!
- gis%LONSPERLAR=ncell !MAPS
- gis%GLOBAL_LATS_R=1 !MPAS
+!----added for MPAS
+ LONSPERLAR=ncell !MAPS
+ GLOBAL_LATS_R=1 !MPAS
do j=1,LATS_NODE_R
do i=1,ncell
- gis%XLON(LONR,LATS_NODE_R)=xlon(i)
- gis%XLAT(LONR,LATS_NODE_R)=xlat(i)
+ XLON(LONR,LATS_NODE_R)=xlon_mpas(i)
+ XLAT(LONR,LATS_NODE_R)=xlat_mpas(i)
enddo
enddo
+!----for MPAS
!fy????????????????????????????????? needed
!fy if(.not.adiab)then
@@ -1039,17 +1109,20 @@
! zero fluxes and diagnostics
!fy CALL countperf(0,14,0.)
!
- gis%zhour = fhour
- gis%FLUXR = 0.
+!fy gis%zhour = fhour
+!fy gis%FLUXR = 0.
+ zhour = fhour
+ FLUXR = 0.
!
- call flx_init(gis%flx_fld,ierr)
+!fy call flx_init(gis%flx_fld,ierr)
+ call flx_init(flx_fld,ierr)
!
call d3d_zero(ldiag3d,lggfs3d)
! if (ldiag3d) then
! call d3d_zero
! endif
- CALL countperf(1,14,0.)
+!fy CALL countperf(1,14,0.)
!
END SUBROUTINE GFS_Initialize
!
Deleted: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/GFS_Initialize_ESMFMod.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/GFS_Initialize_ESMFMod.f_gfs 2012-05-10 23:36:12 UTC (rev 1894)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/GFS_Initialize_ESMFMod.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -1,1579 +0,0 @@
-
-! !MODULE: GFS_Initialize_ESMFMod --- Initialize module of the ESMF
-! gridded component of the GFS system.
-!
-! !DESCRIPTION: GFS gridded component initialize module.
-!
-! !REVISION HISTORY:
-!
-! November 2004 Weiyu Yang Initial code.
-! January 2006 S. Moorthi Update to the new GFS version
-! August 2006 H. Juang Add option to run generalized coordinates
-! December 2006 S. Moorthi GFSIO included
-! February 2008 Weiyu Yang Modified for the ESMF 3.1.0 version, fixed bug for runDuration.
-! Oct 18 2010 S. Moorthi Added fscav initialization
-! March 8 2011 H. Juang Add option to run NDSL, which is the
-! non-iterating dimensionally-splitted semi-
-! Lagrangian advection for entire dynamics
-!
-!
-! !INTERFACE:
-!
- MODULE GFS_Initialize_ESMFMod
-
-!
-!!USES:
-!
- USE GFS_GetCf_ESMFMod
- USE MACHINE, ONLY : kind_io4
- USE namelist_def, ONLY : ndsl, nst_fcst
- use gfsio_module , only : gfsio_init
- use module_ras , only : nrcmax, fix_ncld_hr
-
- IMPLICIT none
-
- CONTAINS
-
- SUBROUTINE GFS_Initialize(gcGFS, gis, clock, rc)
-
-! This subroutine set up the internal state variables,
-! allocate internal state arrays for initializing the GFS system.
-!----------------------------------------------------------------
-
- TYPE(ESMF_VM) :: vm_local ! ESMF virtual machine
- TYPE(ESMF_GridComp), INTENT(inout) :: gcGFS
- TYPE(GFS_InternalState), POINTER, INTENT(inout) :: gis
- TYPE(ESMF_Clock), INTENT(inout) :: clock
- INTEGER, INTENT(out) :: rc
- INTEGER, DIMENSION(mpi_status_size) :: status
-
- TYPE(ESMF_TimeInterval) :: timeStep
- TYPE(ESMF_TimeInterval) :: runDuration
- TYPE(ESMF_Time) :: startTime
- TYPE(ESMF_Time) :: stopTime
- TYPE(ESMF_Time) :: currTime
- INTEGER :: timeStep_sec
- INTEGER :: runDuration_hour
- INTEGER :: ifhmax
- INTEGER :: rc1 = ESMF_SUCCESS
- INTEGER :: ierr, jerr
- INTEGER :: yyc, mmc, ddc, hhc, minsc
-!
-!DHOU 01/11/2008, added these two variables
-!INTEGER :: lvlw, npe_single_member
- INTEGER :: npe_single_member
-
- INTEGER :: l, ilat, locl, ikey, nrank_all, nfluxes
- INTEGER :: i,j,k
- real (kind=kind_io4) blatc4
- real (kind=kind_io4), allocatable :: pl_lat4(:), pl_pres4(:), pl_time4(:)
-
-! Set up parameters of MPI communications.
-! Use ESMF utility to get PE identification and total number of PEs.
-!-------------------------------------------------------------------
- me = gis%me
- NODES = gis%nodes
- nlunit = gis%nam_gfs%nlunit
-
- npe_single_member = gis%npe_single_member
- print *,' npe_single_member=',npe_single_member
- CALL COMPNS(gis%DELTIM,gis%IRET, &
-! gis%ntrac, gis%nxpt, gis%nypt, gis%jintmx, gis%jcap, &
- gis%ntrac, gis%jcapg, gis%jcap, &
- gis%levs, gis%levr, gis%lonf, gis%lonr, gis%latg, gis%latr,&
- gis%ntoz, gis%ntcw, gis%ncld, gis%lsoil, gis%nmtvr, &
- gis%num_p3d, gis%num_p2d, me, gis%nam_gfs%nlunit, gis%nam_gfs%gfs_namelist)
-!
- CALL set_soilveg(me,gis%nam_gfs%nlunit)
- call set_tracer_const(gis%ntrac,me,gis%nam_gfs%nlunit) ! hmhj
-!
-
- ntrac = gis%ntrac
-! nxpt = gis%nxpt
-! nypt = gis%nypt
-! jintmx = gis%jintmx
- jcapg = gis%jcapg
- jcap = gis%jcap
- levs = gis%levs
- levr = gis%levr
- lonf = gis%lonf
- lonr = gis%lonr
- latg = gis%latg
- latr = gis%latr
- ntoz = gis%ntoz
- ntcw = gis%ntcw
- ncld = gis%ncld
- lsoil = gis%lsoil
- nmtvr = gis%nmtvr
- num_p3d = gis%num_p3d
- num_p2d = gis%num_p2d
- if (gis%nam_gfs%Total_Member <= 1) then
- ens_nam=' '
- else
- write(ens_nam,'("_",I2.2)') gis%nam_gfs%Member_Id
- endif
-!
-! ivssfc = 200501
- ivssfc = 200509
- ivssfc_restart = 200509
- if (ivssfc .gt. ivssfc_restart) ivssfc_restart = ivssfc
- ivsnst = 200907
- ivsupa = 0
- if (levs .gt. 99) ivsupa = 200509
-!
- levh = ntrac*levs
- gis%levh = levh ! Added by Weiyu
-! latgd = latg+ 2*jintmx
- latgd = latg
- jcap1 = jcap+1
- jcap2 = jcap+2
- latg2 = latg/2
- latr2 = latr/2
- levm1 = levs-1
- levp1 = levs+1
-!jfe parameter ( lonfx = lonf+2 )
-! lonfx = lonf + 1 + 2*nxpt+1
- lonrx = lonr+2
- lnt = jcap2*jcap1/2
- lnuv = jcap2*jcap1
- lnt2 = 2*lnt
- lnt22 = 2*lnt+1
- lnte = (jcap2/2)*((jcap2/2)+1)-1
- lnto = (jcap2/2)*((jcap2/2)+1)-(jcap2/2)
- lnted = lnte
- lntod = lnto
-
-! ngrids_sfcc = 32+LSOIL*3
-! ngrids_sfcc = 29+LSOIL*3 ! No CV, CVB, CVT!
- ngrids_sfcc = 32+LSOIL*3 ! No CV, CVB, CVT! includes T2M, Q2M, TISFC
-!*RADFLX*
-!* ngrids_flx = 66+30 ! additional fields (most related to land surface)
-! ngrids_flx = 66+43 ! additional fields (land surface + rad flux)
-
-!hchuang code change
-! soilw0_10cm, TMP2m, USTAR, HPBLsfc, U10m, V10m, SFCRsfc, ORO
-! array names : gsoil, gtmp2m, gustar, gpblh, gu10m, gv10m, gzorl, goro
-
- if (climate) then
- ngrids_flx = 66+36+8 ! additional 8 gocart avg output fields
- else
- ngrids_flx = 66+43+8 ! additional 8 gocart avg output fields
- endif
-
- if (nst_fcst > 0) then ! For NST model
-! ngrids_nst = 19 ! oceanic fields (for diurnal warming and sub-layer)
- nr_nst = 10 ! oceanic fields: for diurnal warming model run
- nf_nst = 9 ! oceanic fields: for GSI analysis
- ngrids_nst = nr_nst + nf_nst ! oceanic fields (for diurnal warming and sub-layer)
- else
- ngrids_nst = 0
- endif
-
-!*RADFLX*
-!* nfxr = 27
- nfxr = 33
- ngrids_gg = 2+LEVS*(4+ntrac)
-
-!
- if (ntrac-ncld-1 > 0) then
- allocate ( gis%fscav(ntrac-ncld-1), stat = ierr )
- gis%fscav = 0.0
- endif
-
- gis%lnt2 = lnt2
-
- allocate(lat1s_a(0:jcap))
- allocate(lat1s_r(0:jcap))
-! allocate(lon_dims_a(latgd))
-! allocate(lon_dims_ext(latgd))
-!my allocate(lon_dims_r(latgd))
-! allocate(lon_dims_r(latr))
-
- allocate(colrad_a(latg2))
- allocate(wgt_a(latg2))
- allocate(wgtcs_a(latg2))
- allocate(rcs2_a(latg2))
- allocate(sinlat_a(latg2))
-
- allocate(colrad_r(latr))
- allocate(wgt_r(latr2))
- allocate(wgtcs_r(latr2))
- allocate(rcs2_r(latr2))
- allocate(sinlat_r(latr))
- allocate(coslat_r(latr))
-
- allocate(am(levs,levs))
- allocate(bm(levs,levs))
- allocate(cm(levs,levs))
- allocate(dm(levs,levs,jcap1))
- allocate(tor(levs))
- allocate(si(levp1))
- allocate(sik(levp1))
- allocate(sl(levs))
- allocate(slk(levs))
- allocate(del(levs))
- allocate(rdel2(levs))
- allocate(ci(levp1))
- allocate(cl(levs))
- allocate(tov(levs))
- allocate(sv(levs))
-
- allocate(AK5(LEVP1))
- allocate(BK5(LEVP1))
- allocate(CK5(LEVP1)) ! hmhj
- allocate(THREF(LEVP1)) ! hmhj
- allocate(CK(LEVS))
- allocate(DBK(LEVS))
- allocate(bkl(LEVS))
- allocate(AMHYB(LEVS,LEVS))
- allocate(BMHYB(LEVS,LEVS))
- allocate(SVHYB(LEVS))
- allocate(tor_hyb(LEVS))
- allocate(D_HYB_m(levs,levs,jcap1))
- allocate(dm205_hyb(jcap1,levs,levs))
-
-!sela added for semilag grid computations
- allocate(AM_slg(LEVS,LEVS))
- allocate(BM_slg(LEVS,LEVS))
- allocate(SV_slg(LEVS))
- allocate(tor_slg(LEVS))
- allocate(sv_ecm(LEVS))
- allocate(D_slg_m(levs,levs,jcap1))
-
-!sela added for semilag grid computations
- allocate(yecm(LEVS,LEVS))
- allocate(tecm(LEVS,LEVS))
- allocate(y_ecm(LEVS,LEVS))
- allocate(t_ecm(LEVS,LEVS))
-!sela added for semilag grid computations
-
- allocate(spdmax(levs))
-
-! allocate(buf_sig(lnt2,3*levs+2),buff_grid(lonr,latr),
-! allocate(buf_sig(lnt2,3*levs+2),
-! & buff_mult(lonr,latr,ngrids_sfc))
-! allocate(buf_sig_n(lnt2,levs,ntrac))
- allocate(buff_mult(lonr,latr,ngrids_sfcc+ngrids_nst))
- if (gfsio_out) then
- allocate(buff_multg(lonr*latr,ngrids_gg))
- endif
-
-! allocate(LBASDZ(4,2,levs),LBASIZ(4,2,LEVS),DETAI(levp1), &
-! DETAM(levs),ETAMID(levs),ETAINT(levp1), &
-! SINLAMG(lonf,latg2),COSLAMG(lonf,latg2))
-!
-
- allocate(tor_sig(levs), d_m(levs,levs,jcap1), &
- dm205(jcap1,levs,levs))
- dm205=555555555.
- d_m =444444444.
-!
-
- allocate(z(lnt2))
- allocate(z_r(lnt2))
-!
- nfluxes = 153
- allocate(fmm(lonr*latr,nfluxes),lbmm(lonr*latr,nfluxes))
- allocate(ibufm(50,nfluxes),rbufm(50,nfluxes))
-
-!
- allocate(gis%LONSPERLAT(latg))
-
- allocate(gis%lonsperlar(latr))
-
- if ( .not. ndsl ) then
-!***********************************************************************
- if (redgg_a) then
-
- if (lingg_a) then
- call set_lonsgg_redgg_lin(gis%lonsperlat,latg,me)
- else
- call set_lonsgg_redgg_quad(gis%lonsperlat,latg,me)
- endif
-
- else ! next, for full grid.
-
- if (lingg_a) then
- call set_lonsgg_fullgg_lin(gis%lonsperlat,latg,me)
- else
- call set_lonsgg_fullgg_quad(gis%lonsperlat,latg,me)
- endif
-
- endif
-!***********************************************************************
- if (redgg_b) then
- if (lingg_b) then
- call set_lonsgg_redgg_lin(gis%lonsperlar,latr,me)
- else
- call set_lonsgg_redgg_quad(gis%lonsperlar,latr,me)
- endif
- else ! next, for full loopb and r grids.
- if (lingg_b) then
- call set_lonsgg_fullgg_lin(gis%lonsperlar,latr,me)
- else
- call set_lonsgg_fullgg_quad(gis%lonsperlar,latr,me)
- endif
- endif
-!***********************************************************************
- else
- if (num_reduce == 0) then
- gis%lonsperlat = lonf
- gis%lonsperlar = lonr
- else
- call set_lonsgg(gis%lonsperlat,gis%lonsperlar,num_reduce,me)
- endif
- endif
-!***********************************************************************
-!
- if (ras) then
- if (fix_ncld_hr) then
-! nrcm = min(nrcmax, levs-1) * (gis%deltim/1200) + 0.50001
- nrcm = min(nrcmax, levs-1) * (gis%deltim/1200) + 0.10001
-! nrcm = min(nrcmax, levs-1) * min(1.0,gis%deltim/360) + 0.1
- else
- nrcm = min(nrcmax, levs-1)
- endif
-! nrcm = max(nrcmax, nint((nrcmax*gis%deltim)/600.0))
- else
- nrcm = 1
- endif
-!
-! if (.not. adiab) then
- if (ntoz .le. 0) then ! Diagnostic ozone
- rewind (kozc)
- read (kozc,end=101) latsozc, levozc, timeozc, blatc4
- 101 if (levozc .lt. 10 .or. levozc .gt. 100) then
- rewind (kozc)
- levozc = 17
- latsozc = 18
- blatc = -85.0
- else
- blatc = blatc4
- endif
- latsozp = 2
- levozp = 1
- timeoz = 1
- pl_coeff = 0
- else ! Prognostic Ozone
- rewind (kozpl)
- read (kozpl) pl_coeff, latsozp, levozp, timeoz
- allocate (pl_lat(latsozp), pl_pres(levozp),pl_time(timeoz+1))
- allocate (pl_lat4(latsozp), pl_pres4(levozp),pl_time4(timeoz+1))
- rewind (kozpl)
- read (kozpl) pl_coeff, latsozp, levozp, timeoz, pl_lat4, pl_pres4, &
- pl_time4
- pl_pres(:) = pl_pres4(:)
- pl_lat(:) = pl_lat4(:)
- pl_time(:) = pl_time4(:)
- latsozc = 2
- blatc = 0.0
- endif
- dphiozc = -(blatc+blatc)/(latsozc-1)
-!
- if (me .eq. 0) then
- print *,' latsozp=',latsozp,' levozp=',levozp,' timeoz=',timeoz
- print *,' latsozc=',latsozc,' levozc=',levozc,' timeozc=', &
- timeozc, 'dphiozc=',dphiozc
- print *,' pl_lat=',pl_lat
- print *,' pl_pres=',pl_pres
- print *,' pl_time=',pl_time
- endif
-! pl_pres(:) = log(0.1*pl_pres(:)) ! Natural log of pres in cbars
- pl_pres(:) = log(100.0*pl_pres(:)) ! Natural log of pres in Pa
-!
- allocate(gis%OZPLIN(LATSOZP,LEVOZP,pl_coeff,timeoz)) !OZONE P-L coeffcients
-! endif
-!
-!
- P_GZ = 0*LEVS+0*LEVH+1 ! GZE/O(LNTE/OD,2),
- P_ZEM = 0*LEVS+0*LEVH+2 ! ZEME/O(LNTE/OD,2,LEVS),
- P_DIM = 1*LEVS+0*LEVH+2 ! DIME/O(LNTE/OD,2,LEVS),
- P_TEM = 2*LEVS+0*LEVH+2 ! TEME/O(LNTE/OD,2,LEVS),
- P_QM = 3*LEVS+0*LEVH+2 ! QME/O(LNTE/OD,2),
- P_ZE = 3*LEVS+0*LEVH+3 ! ZEE/O(LNTE/OD,2,LEVS),
- P_DI = 4*LEVS+0*LEVH+3 ! DIE/O(LNTE/OD,2,LEVS),
- P_TE = 5*LEVS+0*LEVH+3 ! TEE/O(LNTE/OD,2,LEVS),
- P_Q = 6*LEVS+0*LEVH+3 ! QE/O(LNTE/OD,2),
- P_DLAM= 6*LEVS+0*LEVH+4 ! DPDLAME/O(LNTE/OD,2),
- P_DPHI= 6*LEVS+0*LEVH+5 ! DPDPHIE/O(LNTE/OD,2),
- P_ULN = 6*LEVS+0*LEVH+6 ! ULNE/O(LNTE/OD,2,LEVS),
- P_VLN = 7*LEVS+0*LEVH+6 ! VLNE/O(LNTE/OD,2,LEVS),
- P_W = 8*LEVS+0*LEVH+6 ! WE/O(LNTE/OD,2,LEVS),
- P_X = 9*LEVS+0*LEVH+6 ! XE/O(LNTE/OD,2,LEVS),
- P_Y =10*LEVS+0*LEVH+6 ! YE/O(LNTE/OD,2,LEVS),
- P_ZQ =11*LEVS+0*LEVH+6 ! ZQE/O(LNTE/OD,2)
- P_RT =11*LEVS+0*LEVH+7 ! RTE/O(LNTE/OD,2,LEVH),
- P_RM =11*LEVS+1*LEVH+7 ! RME/O(LNTE/OD,2,LEVH),
- P_RQ =11*LEVS+2*LEVH+7 ! RQE/O(LNTE/OD,2,LEVH),
-!
-!**********************Current operational as of May 2009***********
-! P_GZ = 0*LEVS+0*LEVH+1 ! GZE/O(LNTE/OD,2),
-! P_ZEM = 0*LEVS+0*LEVH+2 ! ZEME/O(LNTE/OD,2,LEVS),
-! P_DIM = 1*LEVS+0*LEVH+2 ! DIME/O(LNTE/OD,2,LEVS),
-! P_TEM = 2*LEVS+0*LEVH+2 ! TEME/O(LNTE/OD,2,LEVS),
-! P_RM = 3*LEVS+0*LEVH+2 ! RME/O(LNTE/OD,2,LEVH),
-! P_QM = 3*LEVS+1*LEVH+2 ! QME/O(LNTE/OD,2),
-! P_ZE = 3*LEVS+1*LEVH+3 ! ZEE/O(LNTE/OD,2,LEVS),
-! P_DI = 4*LEVS+1*LEVH+3 ! DIE/O(LNTE/OD,2,LEVS),
-! P_TE = 5*LEVS+1*LEVH+3 ! TEE/O(LNTE/OD,2,LEVS),
-! P_RQ = 6*LEVS+1*LEVH+3 ! RQE/O(LNTE/OD,2,LEVH),
-! P_Q = 6*LEVS+2*LEVH+3 ! QE/O(LNTE/OD,2),
-! P_DLAM= 6*LEVS+2*LEVH+4 ! DPDLAME/O(LNTE/OD,2),
-! P_DPHI= 6*LEVS+2*LEVH+5 ! DPDPHIE/O(LNTE/OD,2),
-! P_ULN = 6*LEVS+2*LEVH+6 ! ULNE/O(LNTE/OD,2,LEVS),
-! P_VLN = 7*LEVS+2*LEVH+6 ! VLNE/O(LNTE/OD,2,LEVS),
-! P_W = 8*LEVS+2*LEVH+6 ! WE/O(LNTE/OD,2,LEVS),
-! P_X = 9*LEVS+2*LEVH+6 ! XE/O(LNTE/OD,2,LEVS),
-! P_Y =10*LEVS+2*LEVH+6 ! YE/O(LNTE/OD,2,LEVS),
-! P_RT =11*LEVS+2*LEVH+6 ! RTE/O(LNTE/OD,2,LEVH),
-! P_ZQ =11*LEVS+3*LEVH+6 ! ZQE/O(LNTE/OD,2)
-!**********************Current operational as of May 2009***********
-!C
- LOTS = 5*LEVS+1*LEVH+3
- LOTD = 6*LEVS+2*LEVH+0
- LOTA = 3*LEVS+1*LEVH+1
-!
- kwq = 0*levs+0*levh+1 ! qe/o_ls
- kwte = 0*levs+0*levh+2 ! tee/o_ls
- kwdz = 1*levs+0*levh+2 ! die/o_ls zee/o_ls
- kwrq = 3*levs+0*levh+2 ! rqe/o_ls
-
-!
- gis%P_GZ = 0*LEVS+0*LEVH+1 ! GZE/O(LNTE/OD,2),
- gis%P_ZEM = 0*LEVS+0*LEVH+2 ! ZEME/O(LNTE/OD,2,LEVS),
- gis%P_DIM = 1*LEVS+0*LEVH+2 ! DIME/O(LNTE/OD,2,LEVS),
- gis%P_TEM = 2*LEVS+0*LEVH+2 ! TEME/O(LNTE/OD,2,LEVS),
- gis%P_RM = 3*LEVS+0*LEVH+2 ! RME/O(LNTE/OD,2,LEVH),
- gis%P_QM = 3*LEVS+1*LEVH+2 ! QME/O(LNTE/OD,2),
- gis%P_ZE = 3*LEVS+1*LEVH+3 ! ZEE/O(LNTE/OD,2,LEVS),
- gis%P_DI = 4*LEVS+1*LEVH+3 ! DIE/O(LNTE/OD,2,LEVS),
- gis%P_TE = 5*LEVS+1*LEVH+3 ! TEE/O(LNTE/OD,2,LEVS),
- gis%P_RQ = 6*LEVS+1*LEVH+3 ! RQE/O(LNTE/OD,2,LEVH),
- gis%P_Q = 6*LEVS+2*LEVH+3 ! QE/O(LNTE/OD,2),
- gis%P_DLAM= 6*LEVS+2*LEVH+4 ! DPDLAME/O(LNTE/OD,2),
- gis%P_DPHI= 6*LEVS+2*LEVH+5 ! DPDPHIE/O(LNTE/OD,2),
- gis%P_ULN = 6*LEVS+2*LEVH+6 ! ULNE/O(LNTE/OD,2,LEVS),
- gis%P_VLN = 7*LEVS+2*LEVH+6 ! VLNE/O(LNTE/OD,2,LEVS),
- gis%P_W = 8*LEVS+2*LEVH+6 ! WE/O(LNTE/OD,2,LEVS),
- gis%P_X = 9*LEVS+2*LEVH+6 ! XE/O(LNTE/OD,2,LEVS),
- gis%P_Y =10*LEVS+2*LEVH+6 ! YE/O(LNTE/OD,2,LEVS),
- gis%P_RT =11*LEVS+2*LEVH+6 ! RTE/O(LNTE/OD,2,LEVH),
- gis%P_ZQ =11*LEVS+3*LEVH+6 ! ZQE/O(LNTE/OD,2)
-!C
- gis%LOTS = 5*LEVS+1*LEVH+3
- gis%LOTD = 6*LEVS+2*LEVH+0
- gis%LOTA = 3*LEVS+1*LEVH+1
-!C
- allocate(gis%TEE1(LEVS))
-
-! gis%LSLAG=.FALSE. ! IF FALSE EULERIAN SCHEME =.true. for semilag
-
-!
-!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
-!!
-!! Create IO communicator and comp communicator
-!!
-!sela LIOPE=.FALSE.
-!! LIOPE=.TRUE.
- IF (me == 0) write(*,*) 'IO OPTION ,LIOPE :',LIOPE
-!
- CALL ESMF_VMGetCurrent(vm_local, rc = ierr)
- CALL ESMF_VMGet(vm_local, mpiCommunicator = MPI_COMM_ALL, &
- peCount = nodes, rc = ierr)
-!
- CALL MPI_COMM_DUP(MPI_COMM_ALL, MPI_COMM_ALL_DUP, ierr)
- CALL MPI_Barrier (MPI_COMM_ALL_DUP, ierr)
-
- IF (NODES == 1) THEN
- LIOPE=.FALSE.
- write(*,*) 'IO OPTION RESET:,LIOPE :',LIOPE
- ENDIF
- IF (LIOPE) THEN
-! CALL MPI_COMM_SPLIT(MPI_COMM_WORLD,1,1,MPI_COMM_ALL,ierr)
- CALL MPI_COMM_RANK(MPI_COMM_ALL_DUP,nrank_all,ierr)
- icolor = 1
- ikey = 1
- nodes_comp = nodes-1
- if (nrank_all == nodes-1) then
-!! IO server
- write(*,*) 'IO server task'
- icolor = 2
- gis%kcolor = MPI_UNDEFINED
- CALL MPI_COMM_SPLIT(MPI_COMM_ALL_DUP,icolor,ikey,MC_IO,ierr)
- CALL MPI_COMM_SPLIT(MPI_COMM_ALL_DUP,gis%kcolor,ikey,MC_COMP,ierr)
- else
-!sela write(*,*) 'COMPUTE SERVER TASK '
- icolor = MPI_UNDEFINED
- gis%kcolor = 1
- CALL MPI_COMM_SPLIT(MPI_COMM_ALL_DUP,gis%kcolor,ikey,MC_COMP,ierr)
- CALL MPI_COMM_SPLIT(MPI_COMM_ALL_DUP,icolor,ikey,MC_IO,ierr)
- CALL MPI_COMM_SIZE(MC_COMP,NODES,IERR)
- endif
- ELSE
- icolor = 2
- MC_COMP = MPI_COMM_ALL_DUP
- nodes_comp = nodes
- ENDIF
-!!
-!C
- CALL f_hpminit(ME,"EVOD") !jjt hpm stuff
-!C
- CALL f_hpmstart(25,"GET_LS_GFTLONS")
-!C
- if(me.eq.0) then
- call w3tagb('gsm ',0000,0000,0000,'np23 ')
- endif
-!!
- CALL synchro
- CALL init_countperf(latg)
-!$$$ time0=timer()
-!jfe CALL countperf(0,15,0.)
-!
- if (me.eq.0) then
- PRINT 100, JCAP,LEVS
-100 FORMAT (' SMF ',I3,I3,' CREATED AUGUST 2000 EV OD RI ')
- PRINT*,'NUMBER OF THREADS IS ',NUM_PARTHDS()
- if (liope) then
- PRINT*,'NUMBER OF MPI PROCS IS ',NODES
- PRINT*,'NUMBER OF MPI IO PROCS IS 1 (nodes)'
- else
- PRINT*,'NUMBER OF MPI PROCS IS ',NODES
- endif
- endif
-!C
- gis%CONS0 = 0.0D0
- gis%CONS0P5 = 0.5D0
- gis%CONS1200 = 1200.D0
- gis%CONS3600 = 3600.D0
-!C
- if (liope) then
- if (icolor.eq.2) then
- LS_DIM = JCAP1
- else
- LS_DIM = (JCAP1-1)/NODES+1
- endif
- else
- LS_DIM = (JCAP1-1)/NODES+1
- endif
-!!
-!C
-!CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
-!C
-!C
-! For creating the ESMF interface state with the GFS
-! internal parallel structure. Weiyu.
-!---------------------------------------------------
- ALLOCATE(gis%TRIE_LS_SIZE (npe_single_member))
- ALLOCATE(gis%TRIO_LS_SIZE (npe_single_member))
- ALLOCATE(gis%TRIEO_LS_SIZE (npe_single_member))
- ALLOCATE(gis%LS_MAX_NODE_GLOBAL(npe_single_member))
- ALLOCATE(gis%LS_NODE_GLOBAL (LS_DIM*3, npe_single_member))
-!---------------------------------------------------
-
- ALLOCATE ( gis%LS_NODE (LS_DIM*3) )
- ALLOCATE ( gis%LS_NODES(LS_DIM,NODES) )
- ALLOCATE ( gis%MAX_LS_NODES(NODES) )
-!C
- ALLOCATE ( gis%LATS_NODES_A(NODES) )
- ALLOCATE ( gis%GLOBAL_LATS_A(LATG) )
-!C
- ALLOCATE ( gis%LATS_NODES_R(NODES) )
- ALLOCATE ( gis%GLOBAL_LATS_R(LATR) )
-!C
-! ALLOCATE ( gis%LATS_NODES_EXT(NODES) )
-! ALLOCATE ( gis%GLOBAL_LATS_EXT(LATG+2*JINTMX+2*NYPT*(NODES-1)) )
-!C
-!C
- gis%IPRINT = 0
-! gis%LATS_NODES_EXT = 0
-
-! For creating the ESMF interface state with the GFS
-! internal parallel structure. Weiyu.
-!---------------------------------------------------
- gis%LS_NODE_GLOBAL = 0
- gis%LS_MAX_NODE_GLOBAL = 0
- gis%TRIEO_TOTAL_SIZE = 0
-
- DO i = 1, npe_single_member
- CALL GET_LS_NODE(i-1, gis%LS_NODE_GLOBAL(1, i), &
- gis%LS_MAX_NODE_GLOBAL(i), gis%IPRINT)
- gis%TRIE_LS_SIZE(i) = 0
- gis%TRIO_LS_SIZE(i) = 0
- DO LOCL = 1, gis%LS_MAX_NODE_GLOBAL(i)
- gis%LS_NODE_GLOBAL(LOCL+ LS_DIM, i) = gis%TRIE_LS_SIZE(i)
- gis%LS_NODE_GLOBAL(LOCL+ 2*LS_DIM, i) = gis%TRIO_LS_SIZE(i)
-
- L = gis%LS_NODE_GLOBAL(LOCL, i)
-
- gis%TRIE_LS_SIZE(i) = gis%TRIE_LS_SIZE(i) + (JCAP+3-L)/2
- gis%TRIO_LS_SIZE(i) = gis%TRIO_LS_SIZE(i) + (JCAP+2-L)/2
- END DO
- gis%TRIEO_LS_SIZE(i) = gis%TRIE_LS_SIZE(i) + gis%TRIO_LS_SIZE(i) + 3
- gis%TRIEO_TOTAL_SIZE = gis%TRIEO_TOTAL_SIZE + gis%TRIEO_LS_SIZE(i)
- END DO
-
- DO i = 1, 3*LS_DIM
- gis%LS_NODE(i) = gis%LS_NODE_GLOBAL(i, me+1)
- END DO
-
- LS_MAX_NODE = gis%LS_MAX_NODE_GLOBAL(me+1)
- LEN_TRIE_LS = gis%TRIE_LS_SIZE (me+1)
- LEN_TRIO_LS = gis%TRIO_LS_SIZE (me+1)
- IF(LIOPE) THEN
- IF(me == 0) CALL mpi_send(gis%TRIE_LS_SIZE, &
- npe_single_member, &
- mpi_integer, &
- npe_single_member-1, &
- 900, &
- MPI_COMM_ALL_DUP, &
- ierr)
- IF(me == npe_single_member-1) &
- CALL mpi_recv(gis%TRIE_LS_SIZE, &
- npe_single_member, &
- mpi_integer, &
- 0, &
- 900, &
- MPI_COMM_ALL_DUP, &
- status, &
- ierr)
- IF(me == 0) CALL mpi_send(gis%TRIO_LS_SIZE, &
- npe_single_member, &
- mpi_integer, &
- npe_single_member-1, &
- 900, &
- MPI_COMM_ALL_DUP, &
- ierr)
- IF(me == npe_single_member-1) &
- CALL mpi_recv(gis%TRIO_LS_SIZE, &
- npe_single_member, &
- mpi_integer, &
- 0, &
- 900, &
- MPI_COMM_ALL_DUP, &
- status, &
- ierr)
- IF(me == 0) CALL mpi_send(gis%TRIEO_LS_SIZE, &
- npe_single_member, &
- mpi_integer, &
- npe_single_member-1, &
- 900, &
- MPI_COMM_ALL_DUP, &
- ierr)
- IF(me == npe_single_member-1) &
- CALL mpi_recv(gis%TRIEO_LS_SIZE, &
- npe_single_member, &
- mpi_integer, &
- 0, &
- 900, &
- MPI_COMM_ALL_DUP, &
- status, &
- ierr)
- IF(me == 0) CALL mpi_send(gis%TRIEO_TOTAL_SIZE,&
- 1, &
- mpi_integer, &
- npe_single_member-1, &
- 900, &
- MPI_COMM_ALL_DUP, &
- ierr)
- IF(me == npe_single_member-1) &
- CALL mpi_recv(gis%TRIEO_TOTAL_SIZE,&
- 1, &
- mpi_integer, &
- 0, &
- 900, &
- MPI_COMM_ALL_DUP, &
- status, &
- ierr)
- END IF
-!-----------------------------------------------------------
-
-!! CALL GET_LS_NODE( ME, gis%LS_NODE, LS_MAX_NODE, gis%IPRINT )
-!C
-!C
-!! LEN_TRIE_LS=0
-!! LEN_TRIO_LS=0
-!! DO LOCL=1,LS_MAX_NODE
-!! gis%LS_NODE(LOCL+ LS_DIM)=LEN_TRIE_LS
-!! gis%LS_NODE(LOCL+2*LS_DIM)=LEN_TRIO_LS
-!! L=gis%LS_NODE(LOCL)
-!! LEN_TRIE_LS=LEN_TRIE_LS+(JCAP+3-L)/2
-!! LEN_TRIO_LS=LEN_TRIO_LS+(JCAP+2-L)/2
-!! ENDDO
-!C
-!C
- ALLOCATE ( gis%EPSE (LEN_TRIE_LS) )
- ALLOCATE ( gis%EPSO (LEN_TRIO_LS) )
- ALLOCATE ( gis%EPSEDN(LEN_TRIE_LS) )
- ALLOCATE ( gis%EPSODN(LEN_TRIO_LS) )
-!C
- ALLOCATE ( gis%SNNP1EV(LEN_TRIE_LS) )
- ALLOCATE ( gis%SNNP1OD(LEN_TRIO_LS) )
-!C
- ALLOCATE ( gis%NDEXEV(LEN_TRIE_LS) )
- ALLOCATE ( gis%NDEXOD(LEN_TRIO_LS) )
-!C
- ALLOCATE ( gis%PLNEV_A(LEN_TRIE_LS,LATG2) )
- ALLOCATE ( gis%PLNOD_A(LEN_TRIO_LS,LATG2) )
- ALLOCATE ( gis%PDDEV_A(LEN_TRIE_LS,LATG2) )
- ALLOCATE ( gis%PDDOD_A(LEN_TRIO_LS,LATG2) )
- ALLOCATE ( gis%PLNEW_A(LEN_TRIE_LS,LATG2) )
- ALLOCATE ( gis%PLNOW_A(LEN_TRIO_LS,LATG2) )
-!C
- ALLOCATE ( gis%PLNEV_R(LEN_TRIE_LS,LATR2) )
- ALLOCATE ( gis%PLNOD_R(LEN_TRIO_LS,LATR2) )
- ALLOCATE ( gis%PDDEV_R(LEN_TRIE_LS,LATR2) )
- ALLOCATE ( gis%PDDOD_R(LEN_TRIO_LS,LATR2) )
- ALLOCATE ( gis%PLNEW_R(LEN_TRIE_LS,LATR2) )
- ALLOCATE ( gis%PLNOW_R(LEN_TRIO_LS,LATR2) )
-!C
- gis%MAXSTP=36
-
-
- IF(ME.EQ.0) PRINT*,'FROM COMPNS : IRET=',gis%IRET,' NSOUT=',NSOUT, &
- ' NSSWR=',NSSWR,' NSLWR=',NSLWR,' NSZER=',NSZER,' NSRES=',NSRES, &
- ' NSDFI=',NSDFI,' NSCYC=',NSCYC,' RAS=',RAS
- IF(gis%IRET.NE.0) THEN
- IF(ME.EQ.0) PRINT *,' INCOMPATIBLE NAMELIST - ABORTED IN MAIN'
- CALL MPI_QUIT(13)
- ENDIF
-!!
-! IF PREDICTED OZON IS DESIRED SET JO3=2
- JO3 = 2 !USING PREDICTED OZONE IN RADIATION.
-!C
-!! gis%LATS_NODES_EXT = 0
-
- CALL GETCON(gis%NGES,gis%NRADR,gis%NRADF,gis%NNMOD, &
- gis%N3,gis%N4,gis%NFLPS,gis%NSIGI,gis%NSIGS,gis%NSFCI, &
- gis%NZNLI,gis%NSFCF,gis%NZNLF,gis%NSFCS,gis%NZNLS, &
- gis%NDGI,gis%NDGF,gis%NGPKEN, &
- gis%MODS,gis%NITER,gis%INI,gis%NSTEP,gis%NFILES, &
- gis%KSOUT,gis%IFGES,gis%IBRAD, &
- gis%LS_NODE,gis%LS_NODES,gis%MAX_LS_NODES, &
- gis%LATS_NODES_A,gis%GLOBAL_LATS_A, &
- gis%LONSPERLAT, &
- gis%LATS_NODES_R,gis%GLOBAL_LATS_R, &
- gis%LONSPERLAR, &
-! gis%LATS_NODES_EXT,gis%GLOBAL_LATS_EXT, &
- gis%EPSE,gis%EPSO,gis%EPSEDN,gis%EPSODN, &
- gis%SNNP1EV,gis%SNNP1OD,gis%NDEXEV,gis%NDEXOD, &
- gis%PLNEV_A,gis%PLNOD_A,gis%PDDEV_A,gis%PDDOD_A, &
- gis%PLNEW_A,gis%PLNOW_A, &
- gis%PLNEV_R,gis%PLNOD_R,gis%PDDEV_R,gis%PDDOD_R, &
- gis%PLNEW_R,gis%PLNOW_R,gis%colat1)
-!!
- call sfcvar_aldata(lonr,lats_node_r,lsoil,gis%sfc_fld,ierr)
- call flxvar_aldata(lonr,lats_node_r,gis%flx_fld,ierr)
-
-
-!li, added 05/31/2007 (for oceanic component)
- IF (me == 0) write(*,*) ' in "GFS_Initialize_ESMFMod,lonr,lats_node_r,nr_nst,nf_nst : ',lonr,lats_node_r,nr_nst,nf_nst
-! Modified by Moorthi
- call nstvar_aldata(lonr,lats_node_r,gis%nst_fld,ierr)
-
- ALLOCATE ( gis%XLON(LONR,LATS_NODE_R))
- ALLOCATE ( gis%XLAT(LONR,LATS_NODE_R))
- ALLOCATE ( gis%COSZDG(LONR,LATS_NODE_R))
- ALLOCATE ( gis%SFALB(LONR,LATS_NODE_R))
- ALLOCATE ( gis%HPRIME(LONR,NMTVR,LATS_NODE_R))
- ALLOCATE ( gis%FLUXR(LONR,nfxr,LATS_NODE_R))
-
-! gis%NBLCK = LONR/NGPTC + 1
- ALLOCATE ( gis%SWH(LONR,LEVS,LATS_NODE_R))
- ALLOCATE ( gis%HLW(LONR,LEVS,LATS_NODE_R))
-
- ALLOCATE (gis%JINDX1(LATS_NODE_R),gis%JINDX2(LATS_NODE_R))
- ALLOCATE (gis%DDY(LATS_NODE_R))
-!
- allocate (gis%phy_f3d(LONR,LEVS,num_p3d,lats_node_r))
- allocate (gis%phy_f2d(lonr,num_p2d,lats_node_r))
-!
- call d3d_init(lonr,lats_node_r,levs,pl_coeff,ldiag3d,lggfs3d)
-
-! if (ldiag3d) then
-! call d3d_init(ngptc,gis%nblck,lonr,lats_node_r,levs,pl_coeff)
-! else
-! call d3d_init(1,gis%nblck,1,lats_node_r,1,pl_coeff) ! Needs allocation
-! endif
- if (gfsio_out .or. gfsio_in) then
- call gfsio_init(ierr)
- endif
-
- if (icolor /= 2 .or. .not. liope) then
- if (num_p3d > 0) gis%phy_f3d = 0.0
- if (num_p2d > 0) gis%phy_f2d = 0.0
- endif
- if (num_p2d .gt. 0) gis%phy_f2d = 0.0
-!!
- CALL countperf(0,18,0.)
-!!
-! Modified by Weiyu.
-!-------------------
- if (.NOT.LIOPE.or.icolor.ne.2) then
-!!
- CALL countperf(0,15,0.)
- ALLOCATE ( gis%TRIE_LS(LEN_TRIE_LS,2,11*LEVS+3*LEVH+6) )
- ALLOCATE ( gis%TRIO_LS(LEN_TRIO_LS,2,11*LEVS+3*LEVH+6) )
-
-! For Ensemble forecast requirement, add two more arrays to save to
-! initial conditions. Weiyu.
-!------------------------------------------------------------------
- ALLOCATE ( gis%TRIE_LS_INI(LEN_TRIE_LS,2,11*LEVS+3*LEVH+6) )
- ALLOCATE ( gis%TRIO_LS_INI(LEN_TRIO_LS,2,11*LEVS+3*LEVH+6) )
-
-!C
- ALLOCATE ( gis%SYN_LS_A(4*LS_DIM,gis%LOTS,LATG2) )
- ALLOCATE ( gis%DYN_LS_A(4*LS_DIM,gis%LOTD,LATG2) )
-!C
-! ALLOCATE ( gis%SYN_GR_A_1(LONFX*gis%LOTS,LATS_DIM_EXT) )
-! ALLOCATE ( gis%SYN_GR_A_2(LONFX*gis%LOTS,LATS_DIM_EXT) )
-! ALLOCATE ( gis%DYN_GR_A_1(LONFX*gis%LOTD,LATS_DIM_EXT) )
-! ALLOCATE ( gis%DYN_GR_A_2(LONFX*gis%LOTD,LATS_DIM_EXT) )
-! ALLOCATE ( gis%ANL_GR_A_1(LONFX*gis%LOTA,LATS_DIM_EXT) )
-! ALLOCATE ( gis%ANL_GR_A_2(LONFX*gis%LOTA,LATS_DIM_EXT) )
-!!
- endif !(.NOT.LIOPE.or.icolor.ne.2)
-!!
- if (me == 0) then
- PRINT*, ' LATS_DIM_A=', LATS_DIM_A, ' LATS_NODE_A=', LATS_NODE_A
-! PRINT*, ' LATS_DIM_EXT=', LATS_DIM_EXT, &
-! ' LATS_NODE_EXT=', LATS_NODE_EXT
- PRINT*, ' LATS_DIM_R=', LATS_DIM_R, ' LATS_NODE_R=', LATS_NODE_R
- endif
-!
- ILAT=LATS_NODE_A
-
-! IF (gis%LSLAG) THEN
-! ILAT=LATS_NODE_EXT
-! ELSE
-! ILAT=LATS_NODE_A
-! ENDIF
- CALL countperf(1,15,0.)
-!!
-!C......................................................................
-!C
- CALL countperf(0,15,0.)
- CALL f_hpmstop(25)
-!C
-! WRITE(*,*) 'NUMBER OF LATITUDES EXT. :',LATS_NODE_EXT, &
-! LATS_DIM_EXT,LATS_NODE_A
-!!
-!JFE ALLOCATE (LATLOCAL(LATGD,0:NODES-1))
-!JFE ALLOCATE (LBASIY(4,2,LATS_NODE_EXT))
-!JFE ALLOCATE (PHI(LATS_NODE_EXT))
-!JFE ALLOCATE (DPHI(LATS_NODE_EXT))
-!JFE ALLOCATE (DLAM(LATS_NODE_EXT))
-!JFE ALLOCATE (LAMEXT(LONFX,LATS_NODE_EXT))
-!JFE ALLOCATE (LAM(LONFX,LATS_NODE_A+1))
-!JFE ALLOCATE (LAMMP(LONF,LEVS,LATS_NODE_A))
-!JFE ALLOCATE (SIGMP(LONF,LEVS,LATS_NODE_A))
-!JFE ALLOCATE (PHIMP(LONF,LEVS,LATS_NODE_A))
-!!
-!JFE ALLOCATE (LATSINPE(LATS_NODE_A))
-!JFE JPT=0
-!JFE DO NODE=1,NODES
-!JFE IF ( LATS_NODES_A(NODE) .GT. 0 .AND.ME+1.EQ.NODE) THEN
-!JFE DO JCOUNT=1,LATS_NODES_A(NODE)
-!JFE LATSINPE(JCOUNT)=GLOBAL_LATS_A(JPT+JCOUNT)
-!JFE ENDDO
-!JFE ENDIF
-!JFE JPT=JPT+LATS_NODES_A(NODE)
-!JFE ENDDO
-!!
-!JFE IF (LSLAG) THEN
-!JFE CALL SULAG(LAM,DLAM,LAMEXT,LATLOCAL,PHI,DPHI,DPHIBR,PHIBS,
-!JFE & LBASIY,LAMMP,PHIMP,SIGMP,gis%LONSPERLAT,
-!JFE & IPRINT,LATSINPE)
-!JFE ENDIF
-!C
- CALL countperf(1,15,0.)
-!!
- print *,' sig_ini=',gis%nam_gfs%sig_ini,' sig_ini2=',gis%nam_gfs%sig_ini2 &
- ,' sfc_ini=',gis%nam_gfs%sfc_ini
- print *,' nst_ini=',gis%nam_gfs%nst_ini
- CALL countperf(0,18,0.)
- gis%pdryini = 0.0
- CALL spect_fields(gis%n1, gis%n2, &
- gis%PDRYINI, gis%TRIE_LS, gis%TRIO_LS, &
- gis%LS_NODE, gis%LS_NODES, gis%MAX_LS_NODES, &
- gis%SNNP1EV, gis%SNNP1OD, gis%phy_f3d, gis%phy_f2d, &
- gis%global_lats_r, gis%lonsperlar, &
- gis%epse, gis%epso, gis%plnev_r, gis%plnod_r, &
- gis%plnew_r, gis%plnow_r, gis%lats_nodes_r,&
- gis%nam_gfs%sig_ini, gis%nam_gfs%sig_ini2)
-!!
- if(.not.adiab)then
- CALL fix_fields(gis%LONSPERLAR,gis%GLOBAL_LATS_R, &
- gis%XLON,gis%XLAT,gis%sfc_fld,gis%nst_fld, &
- gis%HPRIME,gis%JINDX1,gis%JINDX2,gis%DDY, &
- gis%OZPLIN,gis%nam_gfs%sfc_ini,gis%nam_gfs%nst_ini)
- CALL countperf(1,18,0.)
- endif
-
-
-! if ( me == 72 ) then
-! do j = 1, lats_node_r
-! do i = 1, lonr
-! if ( gis%dt_warm(i,j) > 0.8 ) then
-! write(*,'(a,11F11.2)') 'Initial nstr : ', &
-! gis%ifd(i,j),gis%time_old(i,j),gis%time_ins(i,j),gis%I_Sw(i,j), &
-! gis%I_Q(i,j),gis%I_Qrain(i,j),gis%I_M(i,j),gis%I_Tau(i,j), &
-! gis%I_Sw_Zw(i,j),gis%I_Q_Ts(i,j),gis%I_M_Ts(i,j)
-! write(*,'(a,9F10.5)') 'Initial nstf : ', &
-! gis%Tref(i,j),gis%dt_cool(i,j),gis%z_c(i,j),gis%dt_warm(i,j),gis%z_w(i,j), &
-! gis%c_0(i,j),gis%c_d(i,j),gis%w_0(i,j),gis%w_d(i,j)
-! endif
-! enddo
-! enddo
-! endif
-
-
-!
-! Apply the diurnal warming & sub-layer cooling (TSEA: foundation/reference temperature)
-!
-
-! if ( .not. tr_analysis ) then
-! gis%nst_fld%Tref(:,:) = gis%sfc_fld%TSEA(:,:) ! necessary only when Tr analysis unavailable
-! endif
-
-! if ( nst_fcst > 0 ) then
-! do j = 1, lats_node_r
-! do i = 1, lonr
-! if ( gis%sfc_fld%SLMSK(i,j) == 0.0 ) then
-! gis%sfc_fld%TSEA(i,j) = gis%nst_fld%Tref(i,j) &
-! + gis%nst_fld%dt_warm(i,j) - gis%nst_fld%dt_cool(i,j)
-! endif
-! enddo
-! enddo
-! endif
-
-
-!!
- tov = 0.0
- if (.not. (hybrid.or.gen_coord_hybrid) ) then ! hmhj
- call setsig(si,ci,del,sl,cl,rdel2,tov,me)
- am = -8888888.
- bm = -7777777.
- call amhmtm(del,sv,am)
- CALL BMDI_sig(ci,bm)
- endif
-!C
- CALL f_hpmstart(26,"STEP1")
-!C
-!!
- CALL countperf(1,18,0.)
-!!
- CALL countperf(0,15,0.)
-
-! Modified by Weiyu Yang to fix the bug related to the "runDuration".
-!--------------------------------------------------------------------
- CALL ESMF_ClockGet(clock, timeStep = timeStep, &
- startTime = startTime, &
- currTime = currTime, &
- rc = rc1)
-
- runDuration_hour = NINT(FHMAX) - NINT(FHINI)
- CALL ESMF_TimeIntervalSet(runDuration, h = runDuration_hour, rc = rc1)
-
-!wy CALL ESMF_ClockGet(clock, timeStep = timeStep, &
-!wy runDuration = runDuration, &
-!wy startTime = startTime, &
-!wy currTime = currTime, &
-!wy rc = rc1)
-
-!
-! currTime = startTime
-!
-! CALL ESMF_TimeIntervalGet(timeStep, s = timeStep_sec, rc = rc1)
-
-! print *,' timestep_sec=',timestep_sec,' rc1=',rc1
-
-!wy CALL ESMF_TimeIntervalGet(runDuration, h = runDuration_hour, rc = rc1)
-
-! print *,' runduration_hour=',runduration_hour,' rc1=',rc1
-!
-!Moor ifhmax = NINT(gis%nam_gfs%FHMAX)
- ifhmax = NINT(FHMAX)
- IF(runDuration_hour <= 0 .OR. &
- ifhmax /= 0 .AND. &
- ifhmax <= gis%kfhour + runDuration_hour) THEN
-!Moor gis%nam_gfs%FHMAX = MAX(gis%nam_gfs%FHMAX, REAL(gis%kfhour))
-! ,, ifhmax = NINT(gis%nam_gfs%FHMAX)
- ifhmax = NINT(FHMAX)
-! ,, runDuration_hour = ifhmax - gis%kfhour
- runDuration_hour = NINT(FHMAX) - NINT(FHINI)
- CALL ESMF_TimeIntervalSet(runDuration, h = runDuration_hour, rc = rc1)
-! print *,' runduration_hour=',runduration_hour,' rc1=',rc1
- END IF
- if (runDuration_hour < 0) then
- print *,' FHINI=',FHINI, ' > FHMAX=',FHMAX,' JOB ABORTED'
- call mpi_quit(444)
- endif
-! stopTime = startTime + runDuration
- stopTime = currTime + runDuration
-
- CALL ESMF_ClockSet(clock, stopTime = stopTime, &
-! currTime = currTime, &
- rc = rc1)
-!
- CALL ESMF_TimeIntervalGet(timeStep, s = timeStep_sec, rc = rc1)
-
- if (me == 0) print *,' timestep_sec=',timestep_sec,' rc1=',rc1
-!!
- IF (me.eq.0) THEN
- CALL out_para(REAL(timeStep_sec))
- ENDIF
-!!
- IF (me.eq.0) THEN
- PRINT *,' THE GSM WILL FORECAST ',runDuration_hour,' HOURS', &
- ' FROM HOUR ',gis%kfhour,' TO HOUR ',runDuration_hour+gis%kfhour
- ENDIF
-!
-!
-!CALL ESMF_TimeGet (stopTime, yy = yyc, mm = mmc, dd = ddc, h = hhc, &
-! m = minsc, rc = rc1)
-!PRINT*, ' In Initialize , stopTime=', yyc, mmc, ddc, hhc, minsc
-!
-
-!
- CALL synchro
- CALL countperf(1,15,0.)
-!
-! zero fluxes and diagnostics
- CALL countperf(0,14,0.)
-!
- gis%zhour = fhour
- gis%FLUXR = 0.
-!
- call flx_init(gis%flx_fld,ierr)
-!
- call d3d_zero(ldiag3d,lggfs3d)
-
-! if (ldiag3d) then
-! call d3d_zero
-! endif
- CALL countperf(1,14,0.)
-!
- END SUBROUTINE GFS_Initialize
-!
- SUBROUTINE set_lonsgg(lonsperlat,lonsperlar,num_reduce,me)
- use resol_def, only : jcapg
- use reduce_lons_grid_module, only : reduce_grid ! hmhj
- integer num_reduce, me ! hmhj
- integer lonsperlat(latg),lonsperlar(latr)
-
- integer lonsperlat_62(94),lonsperlar_62(94)
- integer lonsperlat_126(190),lonsperlar_126(190)
- integer lonsperlat_170(256),lonsperlar_170(256)
- integer lonsperlat_190(288),lonsperlar_190(288)
- integer lonsperlat_254(384),lonsperlar_254(384)
- integer lonsperlat_382(576),lonsperlar_382(576)
- integer lonsperlat_510(766),lonsperlar_510(766)
- integer lonsperlat_574(880),lonsperlar_574(880)
- integer lonsperlat_764(1152),lonsperlar_764(1152)
-
- data lonsperlat_62/ &
- 30, 30, 30, 40, 48, 56, 60, 72, 72, 80, 90, 90, &
- 96, 110, 110, 120, 120, 128, 144, 144, 144, 144, 154, 160, &
- 160, 168, 168, 180, 180, 180, 180, 180, 180, 192, 192, 192, &
- 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 47*0/
-
- data lonsperlar_62/ &
- 30, 30, 30, 40, 48, 56, 60, 72, 72, 80, 90, 90, &
- 96, 110, 110, 120, 120, 128, 144, 144, 144, 144, 154, 160, &
- 160, 168, 168, 180, 180, 180, 180, 180, 180, 192, 192, 192, &
- 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 47*0/
-
- data lonsperlat_126 / &
- 30, 30, 36, 48, 56, 60, 72, 72, 80, 90, &
- 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
- 160, 180, 180, 180, 192, 192, 210, 210, 220, 220, &
- 240, 240, 240, 240, 240, 252, 256, 280, 280, 280, &
- 280, 288, 288, 288, 288, 308, 308, 308, 320, 320, &
- 320, 320, 330, 330, 360, 360, 360, 360, 360, 360, &
- 360, 360, 360, 360, 360, 360, 384, 384, 384, 384, &
- 384, 384, 384, 384, 384, 384, 384, 384, 384, 384, &
- 384, 384, 384, 384, 384, 384, 384, 384, 384, 384, &
- 384, 384, 384, 384, 384, 95*0 /
-
- data lonsperlar_126 / &
- 30, 30, 36, 48, 56, 60, 72, 72, 80, 90, &
- 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
- 160, 180, 180, 180, 192, 192, 210, 210, 220, 220, &
- 240, 240, 240, 240, 240, 252, 256, 280, 280, 280, &
- 280, 288, 288, 288, 288, 308, 308, 308, 320, 320, &
- 320, 320, 330, 330, 360, 360, 360, 360, 360, 360, &
- 360, 360, 360, 360, 360, 360, 384, 384, 384, 384, &
- 384, 384, 384, 384, 384, 384, 384, 384, 384, 384, &
- 384, 384, 384, 384, 384, 384, 384, 384, 384, 384, &
- 384, 384, 384, 384, 384, 95*0 /
-
- data lonsperlat_170 / &
- 48, 48, 48, 48, 48, 56, 60, 72, 72, 80, 90, 96, &
- 110, 110, 120, 120, 128, 144, 144, 144, 154, 160, 168, 180, &
- 180, 180, 192, 210, 210, 220, 220, 240, 240, 240, 240, 240, &
- 252, 256, 280, 280, 280, 288, 288, 288, 308, 308, 320, 320, &
- 320, 320, 330, 360, 360, 360, 360, 360, 360, 360, 384, 384, &
- 384, 384, 384, 384, 420, 420, 420, 440, 440, 440, 440, 440, &
- 440, 440, 440, 440, 462, 462, 462, 462, 462, 480, 480, 480, &
- 480, 480, 480, 480, 480, 480, 480, 480, 504, 504, 504, 504, &
- 504, 504, 504, 504, 504, 512, 512, 512, 512, 512, 512, 512, &
- 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, &
- 512, 512, 512, 512, 512, 512, 512, 512, 128*0 /
-
- data lonsperlar_170 / &
- 48, 48, 48, 48, 48, 56, 60, 72, 72, 80, 90, 96, &
- 110, 110, 120, 120, 128, 144, 144, 144, 154, 160, 168, 180, &
- 180, 180, 192, 210, 210, 220, 220, 240, 240, 240, 240, 240, &
- 252, 256, 280, 280, 280, 288, 288, 288, 308, 308, 320, 320, &
- 320, 320, 330, 360, 360, 360, 360, 360, 360, 360, 384, 384, &
- 384, 384, 384, 384, 420, 420, 420, 440, 440, 440, 440, 440, &
- 440, 440, 440, 440, 462, 462, 462, 462, 462, 480, 480, 480, &
- 480, 480, 480, 480, 480, 480, 480, 480, 504, 504, 504, 504, &
- 504, 504, 504, 504, 504, 512, 512, 512, 512, 512, 512, 512, &
- 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, &
- 512, 512, 512, 512, 512, 512, 512, 512, 128*0 /
-
- data lonsperlat_190 / &
- 64, 64, 64, 64, 64, 64, 64, 70, 80, 84, &
- 88, 110, 110, 110, 120, 126, 132, 140, 144, 154, &
- 160, 168, 176, 176, 192, 192, 198, 210, 210, 220, &
- 220, 240, 240, 240, 252, 252, 256, 264, 280, 280, &
- 280, 288, 308, 308, 308, 320, 320, 320, 330, 336, &
- 352, 352, 352, 352, 360, 384, 384, 384, 384, 384, &
- 396, 396, 420, 420, 420, 420, 420, 440, 440, 440, &
- 440, 440, 448, 448, 462, 462, 462, 480, 480, 480, &
- 480, 480, 504, 504, 504, 504, 504, 504, 504, 512, &
- 512, 528, 528, 528, 528, 528, 528, 560, 560, 560, &
- 560, 560, 560, 560, 560, 560, 560, 560, 560, 560, &
- 560, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
- 576, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
- 576, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
- 576, 576, 576, 576, 144* 0/
-!
- data lonsperlar_190 / &
- 64, 64, 64, 64, 64, 64, 64, 70, 80, 84, &
- 88, 110, 110, 110, 120, 126, 132, 140, 144, 154, &
- 160, 168, 176, 176, 192, 192, 198, 210, 210, 220, &
- 220, 240, 240, 240, 252, 252, 256, 264, 280, 280, &
- 280, 288, 308, 308, 308, 320, 320, 320, 330, 336, &
- 352, 352, 352, 352, 360, 384, 384, 384, 384, 384, &
- 396, 396, 420, 420, 420, 420, 420, 440, 440, 440, &
- 440, 440, 448, 448, 462, 462, 462, 480, 480, 480, &
- 480, 480, 504, 504, 504, 504, 504, 504, 504, 512, &
- 512, 528, 528, 528, 528, 528, 528, 560, 560, 560, &
- 560, 560, 560, 560, 560, 560, 560, 560, 560, 560, &
- 560, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
- 576, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
- 576, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
- 576, 576, 576, 576, 144* 0/
-
- data lonsperlat_254 / &
- 64, 64, 64, 64, 64, 64, 72, 72, 80, 90, &
- 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
- 168, 180, 180, 180, 192, 192, 210, 220, 220, 240, &
- 240, 240, 240, 252, 256, 280, 280, 280, 288, 288, &
- 288, 308, 308, 320, 320, 320, 330, 360, 360, 360, &
- 360, 360, 360, 384, 384, 384, 384, 420, 420, 420, &
- 440, 440, 440, 440, 440, 440, 462, 462, 462, 480, &
- 480, 480, 480, 480, 480, 504, 504, 504, 504, 512, &
- 512, 560, 560, 560, 560, 560, 560, 576, 576, 576, &
- 576, 576, 576, 576, 576, 616, 616, 616, 616, 616, &
- 616, 640, 640, 640, 640, 640, 640, 640, 640, 640, &
- 640, 660, 660, 660, 720, 720, 720, 720, 720, 720, &
- 720, 720, 720, 720, 720, 720, 720, 720, 720, 720, &
- 720, 720, 720, 720, 720, 720, 720, 720, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 192*0/
-
- data lonsperlar_254 / &
- 64, 64, 64, 64, 64, 64, 72, 72, 80, 90, &
- 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
- 168, 180, 180, 180, 192, 192, 210, 220, 220, 240, &
- 240, 240, 240, 252, 256, 280, 280, 280, 288, 288, &
- 288, 308, 308, 320, 320, 320, 330, 360, 360, 360, &
- 360, 360, 360, 384, 384, 384, 384, 420, 420, 420, &
- 440, 440, 440, 440, 440, 440, 462, 462, 462, 480, &
- 480, 480, 480, 480, 480, 504, 504, 504, 504, 512, &
- 512, 560, 560, 560, 560, 560, 560, 576, 576, 576, &
- 576, 576, 576, 576, 576, 616, 616, 616, 616, 616, &
- 616, 640, 640, 640, 640, 640, 640, 640, 640, 640, &
- 640, 660, 660, 660, 720, 720, 720, 720, 720, 720, &
- 720, 720, 720, 720, 720, 720, 720, 720, 720, 720, &
- 720, 720, 720, 720, 720, 720, 720, 720, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
- 768, 768, 192*0/
-
- data lonsperlat_382 / &
- 64, 64, 64, 64, 64, 64, 64, 70, 80, 84, &
- 88, 96, 110, 110, 120, 126, 132, 140, 144, 154, &
- 160, 168, 176, 180, 192, 192, 198, 210, 220, 220, &
- 224, 240, 240, 252, 252, 256, 264, 280, 280, 280, &
- 288, 308, 308, 308, 320, 320, 330, 336, 352, 352, &
- 352, 360, 384, 384, 384, 384, 396, 396, 420, 420, &
- 420, 420, 440, 440, 440, 448, 448, 462, 462, 480, &
- 480, 480, 504, 504, 504, 504, 512, 528, 528, 528, &
- 560, 560, 560, 560, 560, 560, 576, 576, 616, 616, &
- 616, 616, 616, 616, 616, 616, 630, 630, 640, 640, &
- 660, 660, 660, 660, 672, 672, 704, 704, 704, 704, &
- 704, 704, 720, 720, 720, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 792, 792, 792, 792, 792, &
- 840, 840, 840, 840, 840, 840, 840, 840, 840, 840, &
- 880, 880, 880, 880, 880, 880, 880, 880, 880, 880, &
- 896, 896, 896, 896, 924, 924, 924, 924, 924, 924, &
- 960, 960, 960, 960, 960, 960, 960, 960, 960, 960, &
- 990, 990, 990, 990, 990, 990, 990, 990,1008,1008, &
- 1008,1008,1008,1008,1024,1024,1024,1024,1024,1024, &
- 1056,1056,1056,1056,1056,1056,1056,1056,1056,1056, &
- 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
- 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
- 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
- 1120,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152, 288* 0/
-
- data lonsperlar_382 / &
- 64, 64, 64, 64, 64, 64, 64, 70, 80, 84, &
- 88, 96, 110, 110, 120, 126, 132, 140, 144, 154, &
- 160, 168, 176, 180, 192, 192, 198, 210, 220, 220, &
- 224, 240, 240, 252, 252, 256, 264, 280, 280, 280, &
- 288, 308, 308, 308, 320, 320, 330, 336, 352, 352, &
- 352, 360, 384, 384, 384, 384, 396, 396, 420, 420, &
- 420, 420, 440, 440, 440, 448, 448, 462, 462, 480, &
- 480, 480, 504, 504, 504, 504, 512, 528, 528, 528, &
- 560, 560, 560, 560, 560, 560, 576, 576, 616, 616, &
- 616, 616, 616, 616, 616, 616, 630, 630, 640, 640, &
- 660, 660, 660, 660, 672, 672, 704, 704, 704, 704, &
- 704, 704, 720, 720, 720, 768, 768, 768, 768, 768, &
- 768, 768, 768, 768, 768, 792, 792, 792, 792, 792, &
- 840, 840, 840, 840, 840, 840, 840, 840, 840, 840, &
- 880, 880, 880, 880, 880, 880, 880, 880, 880, 880, &
- 896, 896, 896, 896, 924, 924, 924, 924, 924, 924, &
- 960, 960, 960, 960, 960, 960, 960, 960, 960, 960, &
- 990, 990, 990, 990, 990, 990, 990, 990,1008,1008, &
- 1008,1008,1008,1008,1024,1024,1024,1024,1024,1024, &
- 1056,1056,1056,1056,1056,1056,1056,1056,1056,1056, &
- 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
- 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
- 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
- 1120,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
- 1152,1152,1152,1152,1152,1152,1152,1152, 288* 0/
-
- data lonsperlat_510 / &
- 64, 64, 64, 64, 64, 64, 72, 72, 80, 90, &
- 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
- 168, 180, 180, 180, 192, 210, 210, 220, 220, 240, &
- 240, 240, 240, 252, 256, 280, 280, 288, 288, 288, &
- 308, 308, 320, 320, 320, 330, 360, 360, 360, 360, &
- 360, 384, 384, 384, 384, 420, 420, 440, 440, 440, &
- 440, 440, 440, 462, 462, 462, 480, 480, 480, 480, &
- 504, 504, 504, 504, 512, 512, 560, 560, 560, 560, &
- 576, 576, 576, 576, 576, 576, 616, 616, 616, 616, &
- 640, 640, 640, 640, 640, 640, 640, 660, 720, 720, &
- 720, 720, 720, 720, 720, 720, 720, 720, 720, 720, &
- 720, 768, 768, 768, 768, 768, 768, 768, 768, 840, &
- 840, 840, 840, 840, 840, 840, 840, 880, 880, 880, &
- 880, 880, 880, 880, 880, 880, 880, 924, 924, 924, &
- 924, 924, 924, 924, 960, 960, 960, 960, 960, 960, &
- 960, 960, 960, 960, 960, 990, 990, 990, 1008, 1008, &
- 1008, 1008, 1008, 1024, 1024, 1024, 1024, 1024, 1120, 1120, &
- 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, &
- 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, &
- 1152, 1152, 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, &
- 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1260, 1260, &
- 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, &
- 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1320, &
- 1320, 1320, 1320, 1386, 1386, 1386, 1386, 1386, 1386, 1386, &
- 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, &
- 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
- 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
- 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
- 1440, 1440, 1440, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 383*0/
-
- data lonsperlar_510 / &
- 64, 64, 64, 64, 64, 64, 72, 72, 80, 90, &
- 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
- 168, 180, 180, 180, 192, 210, 210, 220, 220, 240, &
- 240, 240, 240, 252, 256, 280, 280, 288, 288, 288, &
- 308, 308, 320, 320, 320, 330, 360, 360, 360, 360, &
- 360, 384, 384, 384, 384, 420, 420, 440, 440, 440, &
- 440, 440, 440, 462, 462, 462, 480, 480, 480, 480, &
- 504, 504, 504, 504, 512, 512, 560, 560, 560, 560, &
- 576, 576, 576, 576, 576, 576, 616, 616, 616, 616, &
- 640, 640, 640, 640, 640, 640, 640, 660, 720, 720, &
- 720, 720, 720, 720, 720, 720, 720, 720, 720, 720, &
- 720, 768, 768, 768, 768, 768, 768, 768, 768, 840, &
- 840, 840, 840, 840, 840, 840, 840, 880, 880, 880, &
- 880, 880, 880, 880, 880, 880, 880, 924, 924, 924, &
- 924, 924, 924, 924, 960, 960, 960, 960, 960, 960, &
- 960, 960, 960, 960, 960, 990, 990, 990, 1008, 1008, &
- 1008, 1008, 1008, 1024, 1024, 1024, 1024, 1024, 1120, 1120, &
- 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, &
- 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, &
- 1152, 1152, 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, &
- 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1260, 1260, &
- 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, &
- 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1320, &
- 1320, 1320, 1320, 1386, 1386, 1386, 1386, 1386, 1386, 1386, &
- 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, &
- 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
- 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
- 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
- 1440, 1440, 1440, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 383*0/
-
- data lonsperlat_574 / &
- 18, 28, 32, 42, 48, 56, 64, 72, 80, 84, &
- 90, 110, 110, 110, 120, 126, 132, 140, 144, 154, &
- 160, 168, 176, 176, 192, 192, 198, 210, 210, 220, &
- 224, 240, 240, 252, 252, 256, 264, 280, 280, 288, &
- 288, 308, 308, 308, 320, 320, 330, 330, 352, 352, &
- 352, 360, 384, 384, 384, 384, 396, 396, 420, 420, &
- 420, 420, 440, 440, 440, 448, 462, 462, 462, 480, &
- 480, 480, 504, 504, 504, 504, 512, 528, 528, 528, &
- 560, 560, 560, 560, 560, 576, 576, 576, 616, 616, &
- 616, 616, 616, 616, 630, 630, 630, 640, 660, 660, &
- 660, 660, 672, 672, 704, 704, 704, 704, 704, 720, &
- 720, 720, 768, 768, 768, 768, 768, 768, 768, 768, &
- 770, 792, 792, 792, 792, 840, 840, 840, 840, 840, &
- 840, 840, 840, 880, 880, 880, 880, 880, 880, 880, &
- 896, 896, 896, 896, 924, 924, 924, 924, 924, 960, &
- 960, 960, 960, 960, 960, 960, 990, 990, 990, 990, &
- 990, 1008, 1008, 1008, 1008, 1024, 1024, 1024, 1056, 1056, &
- 1056, 1056, 1056, 1056, 1120, 1120, 1120, 1120, 1120, 1120, &
- 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1152, 1152, 1152, &
- 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, 1232, 1232, &
- 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, &
- 1232, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1280, 1280, &
- 1280, 1280, 1280, 1320, 1320, 1320, 1320, 1320, 1320, 1320, &
- 1320, 1320, 1344, 1344, 1344, 1344, 1344, 1344, 1386, 1386, &
- 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1408, &
- 1408, 1408, 1408, 1408, 1440, 1440, 1440, 1440, 1440, 1440, &
- 1440, 1440, 1440, 1440, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1584, 1584, 1584, 1584, 1584, 1584, &
- 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, &
- 1584, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 440*0/
-
- data lonsperlar_574 / &
- 18, 28, 32, 42, 48, 56, 64, 72, 80, 84, &
- 90, 110, 110, 110, 120, 126, 132, 140, 144, 154, &
- 160, 168, 176, 176, 192, 192, 198, 210, 210, 220, &
- 224, 240, 240, 252, 252, 256, 264, 280, 280, 288, &
- 288, 308, 308, 308, 320, 320, 330, 330, 352, 352, &
- 352, 360, 384, 384, 384, 384, 396, 396, 420, 420, &
- 420, 420, 440, 440, 440, 448, 462, 462, 462, 480, &
- 480, 480, 504, 504, 504, 504, 512, 528, 528, 528, &
- 560, 560, 560, 560, 560, 576, 576, 576, 616, 616, &
- 616, 616, 616, 616, 630, 630, 630, 640, 660, 660, &
- 660, 660, 672, 672, 704, 704, 704, 704, 704, 720, &
- 720, 720, 768, 768, 768, 768, 768, 768, 768, 768, &
- 770, 792, 792, 792, 792, 840, 840, 840, 840, 840, &
- 840, 840, 840, 880, 880, 880, 880, 880, 880, 880, &
- 896, 896, 896, 896, 924, 924, 924, 924, 924, 960, &
- 960, 960, 960, 960, 960, 960, 990, 990, 990, 990, &
- 990, 1008, 1008, 1008, 1008, 1024, 1024, 1024, 1056, 1056, &
- 1056, 1056, 1056, 1056, 1120, 1120, 1120, 1120, 1120, 1120, &
- 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1152, 1152, 1152, &
- 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, 1232, 1232, &
- 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, &
- 1232, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1280, 1280, &
- 1280, 1280, 1280, 1320, 1320, 1320, 1320, 1320, 1320, 1320, &
- 1320, 1320, 1344, 1344, 1344, 1344, 1344, 1344, 1386, 1386, &
- 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1408, &
- 1408, 1408, 1408, 1408, 1440, 1440, 1440, 1440, 1440, 1440, &
- 1440, 1440, 1440, 1440, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1584, 1584, 1584, 1584, 1584, 1584, &
- 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, &
- 1584, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 440*0/
-! T764
- data lonsperlat_764 / &
- 18, 22, 30, 40, 44, 56, 60, 66, 72, 80, &
- 88, 96, 110, 110, 112, 120, 126, 132, 140, 154, &
- 154, 160, 168, 176, 180, 192, 192, 198, 210, 220, &
- 220, 224, 240, 240, 252, 252, 256, 264, 280, 280, &
- 288, 308, 308, 308, 308, 320, 330, 330, 336, 352, &
- 352, 360, 360, 384, 384, 384, 396, 396, 420, 420, &
- 420, 420, 440, 440, 440, 448, 448, 462, 462, 480, &
- 480, 480, 504, 504, 504, 504, 512, 528, 528, 560, &
- 560, 560, 560, 560, 576, 576, 576, 616, 616, 616, &
- 616, 616, 616, 616, 630, 630, 640, 660, 660, 660, &
- 660, 672, 672, 704, 704, 704, 704, 704, 720, 720, &
- 720, 768, 768, 768, 768, 768, 768, 768, 770, 792, &
- 792, 792, 840, 840, 840, 840, 840, 840, 840, 840, &
- 840, 880, 880, 880, 880, 880, 880, 896, 896, 896, &
- 924, 924, 924, 924, 924, 960, 960, 960, 960, 960, &
- 960, 990, 990, 990, 990, 990, 1008, 1008, 1008, 1024, &
- 1024, 1024, 1056, 1056, 1056, 1056, 1056, 1056, 1120, 1120, &
- 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1152, &
- 1152, 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, 1232, &
- 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, &
- 1260, 1260, 1260, 1260, 1260, 1280, 1280, 1280, 1280, 1320, &
- 1320, 1320, 1320, 1320, 1320, 1320, 1344, 1344, 1344, 1344, &
- 1344, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1408, &
- 1408, 1408, 1408, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
- 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
- 1680, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
- 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1848, 1848, &
- 1848, 1848, 1848, 1848, 1848, 1848, 1848, 1848, 1848, 1848, &
- 1848, 1848, 1848, 1920, 1920, 1920, 1920, 1920, 1920, 1920, &
- 1920, 1920, 1920, 1920, 1920, 1920, 1920, 1920, 1920, 1920, &
- 1920, 1920, 1980, 1980, 1980, 1980, 1980, 1980, 1980, 1980, &
- 1980, 1980, 1980, 1980, 1980, 1980, 1980, 1980, 1980, 1980, &
- 2016, 2016, 2016, 2016, 2016, 2016, 2016, 2016, 2016, 2016, &
- 2016, 2048, 2048, 2048, 2048, 2048, 2048, 2048, 2048, 2048, &
- 2048, 2048, 2112, 2112, 2112, 2112, 2112, 2112, 2112, 2112, &
- 2112, 2112, 2112, 2112, 2112, 2112, 2112, 2112, 2112, 2112, &
- 2112, 2112, 2112, 2112, 2112, 2240, 2240, 2240, 2240, 2240, &
- 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
- 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
- 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
- 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
- 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
- 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
- 2304, 2304, 2304, 2304, 2304, 2304, 576*0/
-
- integer i
- if (num_reduce < 0) then
- if (jcapg .eq. 62) then
- lonsperlat=lonsperlat_62
- lonsperlar=lonsperlar_62
- endif
- if (jcapg .eq. 126) then
- lonsperlat=lonsperlat_126
- lonsperlar=lonsperlar_126
- endif
- if (jcapg .eq. 170) then
- lonsperlat=lonsperlat_170
- lonsperlar=lonsperlar_170
- endif
- if (jcapg .eq. 190) then
- lonsperlat=lonsperlat_190
- lonsperlar=lonsperlar_190
- endif
- if (jcapg .eq. 254) then
- lonsperlat=lonsperlat_254
- lonsperlar=lonsperlar_254
- endif
- if (jcapg .eq. 382) then
- lonsperlat=lonsperlat_382
- lonsperlar=lonsperlar_382
- endif
- if (jcapg .eq. 510) then
- lonsperlat=lonsperlat_510
- lonsperlar=lonsperlar_510
- endif
- if (jcapg .eq. 574) then
- lonsperlat=lonsperlat_574
- lonsperlar=lonsperlar_574
- endif
- if (jcapg == 764) then
- lonsperlat=lonsperlat_764
- lonsperlar=lonsperlat_764
- endif
- endif
-
- if (jcapg .ne. 62 .and. jcapg .ne. 126 .and. jcapg .ne. 170 .and. &
- jcapg .ne. 190 .and. jcapg .ne. 254 .and. jcapg .ne. 382 .and. &
- jcapg .ne. 510 .and. jcapg .ne. 574 .and. jcapg .ne. 764) then
-! print*,' Resolution not supported - lonsperlar/lonsperlat &
-! &data is needed in read_lonsgg '
-! stop 55
-! compute reduced grid using juang 2003
- if ( me == 0 ) then
- print*,' Non Standard Resolution - lonsperlar/lonsperlat', &
- ' computed locally'
- endif
- call reduce_grid (abs(num_reduce),jcapg,latg,lonsperlat) ! hmhj
- lonsperlar=lonsperlat ! hmhj
- if ( me == 0 ) then
- print*,' Reduced grid is computed - lonsperlar/lonsperlat ' ! hmhj
- endif
- endif
-
- if ( me == 0 ) then
- print*,' jcapg = ',jcapg
- print*,'min,max of lonsperlat = ',minval(lonsperlat), &
- maxval(lonsperlat)
- print*,'min,max of lonsperlar = ',minval(lonsperlar), &
- maxval(lonsperlar)
- endif
- END SUBROUTINE set_lonsgg
-
- END MODULE GFS_Initialize_ESMFMod
Deleted: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/GFS_InternalState_ESMFMod.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/GFS_InternalState_ESMFMod.f_gfs 2012-05-10 23:36:12 UTC (rev 1894)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/GFS_InternalState_ESMFMod.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -1,327 +0,0 @@
-!
-! !MODULE: GFS_InternalState_ESMFMod --- Internal state definition of the
-! ESMF gridded component of the GFS system.
-!
-! !DESCRIPTION: GFS_InternalState_ESMFMod --- Define the GFS internal state used to
-! create the ESMF internal state.
-!---------------------------------------------------------------------------
-! !REVISION HISTORY:
-!
-! November 2004 Weiyu Yang Initial code.
-! May 2005 Weiyu Yang for the updated GFS version.
-! February 2006 Shrinivas Moorthi updated for the new version of GFS
-! September2006 Weiyu Yang For the ensemble run couple version.
-! April 2009 Shrinivas Moorthi merge GEFS and generalized GFS versions
-!
-! !INTERFACE:
-!
- MODULE GFS_InternalState_ESMFMod
-
-!!USES:
-!------
- USE ESMF_Mod
-!USE nam_mrf_NAMSFC_NameList_ESMFMod
- USE NameList_ESMFMod
-
- USE MACHINE, ONLY: kind_rad, kind_phys, kind_io4, kind_evod
-!USE resol_def ! Wei yu's version did not have this why?
- USE layout1
- USE gg_def
- USE vert_def
- USE sig_io
- USE date_def
- USE namelist_def
- USE namelist_soilveg
- USE mpi_def
-!!!!!! USE semi_lag_def
- USE coordinate_def ! hmhj
- USE tracer_const ! hmhj
- USE matrix_sig_def
- use module_ras , only : nrcmax
- use ozne_def
- use d3d_def
- use Sfc_Flx_ESMFMod
- use Nst_Var_ESMFMod
-
- IMPLICIT none
-
- TYPE GFS_InternalState
-
-! TYPE(nam_gfs_Namelist) :: nam_gfs
-! TYPE(SOIL_VEG_NameList) :: SOIL_VEG
-! TYPE(NAMSFC_NameList) :: NAMSFC
- TYPE(nam_gfs_NameList) :: nam_gfs
- TYPE(ESMF_State_Namelist) :: ESMF_Sta_List
-
- TYPE(Sfc_Var_Data) :: sfc_fld
- TYPE(Flx_Var_Data) :: flx_fld
-
- TYPE(Nst_Var_Data) :: nst_fld
-
- INTEGER :: me, mm1, nodes
- INTEGER :: lonr_s, latr_s, lnt2_s
- INTEGER :: lnt2, grid4_i1(2)
- integer :: grib_inp
- INTEGER :: npe_single_member
-
- REAL(KIND = kind_io4), DIMENSION(:, :), POINTER :: &
- z_im, ps_im, vor_im, div_im, temp_im, q_im, oz_im, scld_im, &
- z_ex, ps_ex, vor_ex, div_ex, temp_ex, q_ex, oz_ex, scld_ex
-
- REAL(KIND = kind_evod), DIMENSION(:, :), POINTER :: trieo_ls_im
- REAL(KIND = kind_evod), DIMENSION(:, :), POINTER :: write_work8
- REAL(KIND = kind_evod), DIMENSION(:, :), POINTER :: write_work8_ini
-
-!
-! idate1_im and idate1_ex: (1) --- bfhour (integer), (2) - (5) --- idate.
-!-------------------------------------------------------------------------
-!
- INTEGER, DIMENSION(:, :), POINTER :: idate1_im, idate1_ex
-
- REAL(KIND = kind_io4), DIMENSION(:, :), POINTER :: &
- orography_im, t_skin_im, snow_depth_im, &
- deep_soil_t_im, roughness_im, conv_cloud_cover_im, &
- conv_cloud_base_im, conv_cloud_top_im, albedo_visible_scattered_im,&
- albedo_visible_beam_im, albedo_nearIR_scattered_im, albedo_nearIR_beam_im, &
- sea_level_ice_mask_im, vegetation_cover_im, canopy_water_im, &
- m10_wind_fraction_im, vegetation_type_im, soil_type_im, &
- zeneith_angle_facsf_im, zeneith_angle_facwf_im, uustar_im, &
- ffmm_im, ffhh_im, sea_ice_thickness_im, &
- sea_ice_concentration_im, tprcp_im, srflag_im, &
- actual_snow_depth_im, vegetation_cover_min_im, vegetation_cover_max_im, &
- slope_type_im, snow_albedo_max_im, &
-
-! MOdified by Weiyu (DHOU, 04/04/2008).
-!-------------------
- soil_t_im1, soil_t_im2, soil_t_im3, soil_mois_im1, soil_mois_im2, soil_mois_im3, &
- liquid_soil_moisture_im1, liquid_soil_moisture_im2, liquid_soil_moisture_im3, &
-
- orography_ex, t_skin_ex, snow_depth_ex, &
- deep_soil_t_ex, roughness_ex, conv_cloud_cover_ex, &
- conv_cloud_base_ex, conv_cloud_top_ex, albedo_visible_scattered_ex,&
- albedo_visible_beam_ex, albedo_nearIR_scattered_ex, albedo_nearIR_beam_ex, &
- sea_level_ice_mask_ex, vegetation_cover_ex, canopy_water_ex, &
- m10_wind_fraction_ex, vegetation_type_ex, soil_type_ex, &
- zeneith_angle_facsf_ex, zeneith_angle_facwf_ex, uustar_ex, &
- ffmm_ex, ffhh_ex, sea_ice_thickness_ex, &
- sea_ice_concentration_ex, tprcp_ex, srflag_ex, &
- actual_snow_depth_ex, vegetation_cover_min_ex, vegetation_cover_max_ex, &
- slope_type_ex, snow_albedo_max_ex
-
- REAL(KIND = kind_io4), DIMENSION(:, :, :), POINTER :: &
- soil_mois_im, soil_t_im, soil_mois_ex, soil_t_ex, &
- liquid_soil_moisture_im, liquid_soil_moisture_ex
-
-! To represent the trie_ls and trio_ls in the ESMF states, add levh. Weiyu.
-!--------------------------------------------------------------------------
-
-! INTEGER ntrac,nxpt,nypt,jintmx,jcap,levs,levh,lonf,lonr,latg,latr
- INTEGER ntrac,jcapg,jcap,levs,levh,lonf,lonr,latg,latr
- INTEGER ntoz, ntcw, ncld, lsoil, nmtvr, num_p3d, num_p2d,levr
-
- CHARACTER(16) :: CFHOUR1
-
- INTEGER :: KDT
- REAL :: DELTIM
-
-! For creating the ESMF interface state with the GFS
-! internal parallel structure. Weiyu.
-!---------------------------------------------------
- INTEGER :: TRIEO_TOTAL_SIZE
- INTEGER, ALLOCATABLE, DIMENSION(:) :: TRIE_LS_SIZE, TRIO_LS_SIZE
- INTEGER, ALLOCATABLE, DIMENSION(:) :: TRIEO_LS_SIZE
- INTEGER, ALLOCATABLE, DIMENSION(:) :: LS_MAX_NODE_GLOBAL
- INTEGER, ALLOCATABLE, DIMENSION(:, :) :: LS_NODE_GLOBAL
-
-! For flexible choose the time interval of the tendency time difference.
-!-----------------------------------------------------------------------
- INTEGER :: advanceCount_SetUp
-
- CHARACTER(ESMF_MAXSTR) :: TRIEO_STATE_NAME
- CHARACTER(ESMF_MAXSTR) :: TRIEO_STINI_NAME
-
- INTEGER ,ALLOCATABLE :: LONSPERLAT (:)
- INTEGER ,ALLOCATABLE :: lonsperlar (:)
- INTEGER ,ALLOCATABLE :: LS_NODE (:)
- INTEGER ,ALLOCATABLE :: LS_NODES (:, :)
- INTEGER ,ALLOCATABLE :: MAX_LS_NODES (:)
-
- INTEGER ,ALLOCATABLE :: LATS_NODES_A (:)
- INTEGER ,ALLOCATABLE :: GLOBAL_LATS_A (:)
-! INTEGER ,ALLOCATABLE :: LATS_NODES_EXT (:)
-! INTEGER ,ALLOCATABLE :: GLOBAL_LATS_EXT(:)
-
- INTEGER ,ALLOCATABLE :: LATS_NODES_R (:)
- INTEGER ,ALLOCATABLE :: GLOBAL_LATS_R (:)
-
- real(kind=kind_phys) ,allocatable :: fscav(:)
-
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: EPSE (:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: EPSO (:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: EPSEDN(:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: EPSODN(:)
-
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SNNP1EV(:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SNNP1OD(:)
-
- INTEGER ,ALLOCATABLE :: NDEXEV(:)
- INTEGER ,ALLOCATABLE :: NDEXOD(:)
-
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNEV_A(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNOD_A(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PDDEV_A(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PDDOD_A(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNEW_A(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNOW_A(:,:)
-
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNEV_R(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNOD_R(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PDDEV_R(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PDDOD_R(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNEW_R(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNOW_R(:,:)
-
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: TRIE_LS(:,:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: TRIO_LS(:,:,:)
-
-! For Ensemble forecast requirement, add two more arrays to save the
-! initial conditions. Weiyu.
-!------------------------------------------------------------------
- REAL(KIND=KIND_EVOD) , POINTER :: TRIE_LS_INI(:,:,:)
- REAL(KIND=KIND_EVOD) , POINTER :: TRIO_LS_INI(:,:,:)
-
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SYN_LS_A(:,:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DYN_LS_A(:,:,:)
-
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SYN_GR_A_1(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SYN_GR_A_2(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DYN_GR_A_1(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DYN_GR_A_2(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: ANL_GR_A_1(:,:)
- REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: ANL_GR_A_2(:,:)
-
- REAL(KIND=KIND_RAD) ,ALLOCATABLE :: XLON(:,:),XLAT(:,:)
- REAL(KIND=KIND_RAD) ,ALLOCATABLE :: COSZDG(:,:)
- REAL(KIND=KIND_RAD) ,ALLOCATABLE :: sfalb(:,:)
- REAL(KIND=KIND_RAD) ,ALLOCATABLE :: HPRIME(:,:,:)
- REAL(KIND=KIND_RAD) ,ALLOCATABLE :: SWH(:,:,:),HLW(:,:,:)
- REAL(KIND=KIND_RAD) ,ALLOCATABLE :: FLUXR(:,:,:)
-!!
-
-! REAL(KIND=KIND_RAD) ,ALLOCATABLE :: phy_f3d(:,:,:,:,:)
- REAL(KIND=KIND_RAD) ,ALLOCATABLE :: phy_f3d(:,:,:,:)
- REAL(KIND=KIND_RAD) ,ALLOCATABLE :: phy_f2d(:,:,:)
-
-!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: LBASIY(:,:,:)
-!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PHI(:)
-!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DPHI(:)
-!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DLAM(:),LAMEXT(:,:),LAM(:,:)
-!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: LAMMP(:,:,:)
-!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PHIMP(:,:,:)
-!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SIGMP(:,:,:)
-!!
-! FOR OZONE PRODUCTION AND DISTRUCTION RATES:(INPUT THROU FIXIO_R)
- INTEGER LEV,LEVMAX
-!!$$$ PARAMETER (LATS18=18, LEV46=46)
-!!$$$ REAL POZ(LEV46),PHOUR
-!!$$$ REAL OZPRDIN(LATS18,LEV46,36) !OZON PRODUCTION RATE
-!!$$$ REAL OZDISIN(LATS18,LEV46,36) !OZON DISTUCTION RATE
- real phour
- INTEGER :: KFHOUR
- real, allocatable :: poz(:),ozplin(:,:,:,:)
-! FOR OZONE INTERPOLATION:
- INTEGER,ALLOCATABLE:: JINDX1(:),JINDX2(:)
-!
- REAL (KIND=KIND_PHYS) PDRYINI
- REAL,ALLOCATABLE:: DDY(:)
- REAL(KIND=KIND_EVOD) SLAG,SDEC,CDEC
-!!
-!JFE INTEGER,ALLOCATABLE :: LATSINPE(:)
-!JFE INTEGER,ALLOCATABLE :: LATLOCAL(:,:)
-
- INTEGER INIT,JCOUNT,JPT,NODE
- INTEGER IBMSIGN
- INTEGER LON_DIM,ILAT
-
- real(kind=kind_evod) colat1
-!!
- REAL(KIND=KIND_EVOD) RONE
- REAL(KIND=KIND_EVOD) RLONS_LAT
- REAL(KIND=KIND_EVOD) SCALE_IBM
-
- INTEGER P_GZ,P_ZEM,P_DIM,P_TEM,P_RM,P_QM
- INTEGER P_ZE,P_DI,P_TE,P_RQ,P_Q,P_DLAM,P_DPHI,P_ULN,P_VLN
- INTEGER P_W,P_X,P_Y,P_RT,P_ZQ
-!C OLD COMMON /COMFSPEC/
-!!$$$ PARAMETER(P_GZ = 0*LEVS+0*LEVH+1, ! GZE/O(LNTE/OD,2),
-!!$$$ X P_ZEM = 0*LEVS+0*LEVH+2, ! ZEME/O(LNTE/OD,2,LEVS),
-!!$$$ X P_DIM = 1*LEVS+0*LEVH+2, ! DIME/O(LNTE/OD,2,LEVS),
-!!$$$ X P_TEM = 2*LEVS+0*LEVH+2, ! TEME/O(LNTE/OD,2,LEVS),
-!!$$$ X P_RM = 3*LEVS+0*LEVH+2, ! RME/O(LNTE/OD,2,LEVH),
-!!$$$ X P_QM = 3*LEVS+1*LEVH+2, ! QME/O(LNTE/OD,2),
-!!$$$ X P_ZE = 3*LEVS+1*LEVH+3, ! ZEE/O(LNTE/OD,2,LEVS),
-!!$$$ X P_DI = 4*LEVS+1*LEVH+3, ! DIE/O(LNTE/OD,2,LEVS),
-!!$$$ X P_TE = 5*LEVS+1*LEVH+3, ! TEE/O(LNTE/OD,2,LEVS),
-!!$$$ X P_RQ = 6*LEVS+1*LEVH+3, ! RQE/O(LNTE/OD,2,LEVH),
-!!$$$ X P_Q = 6*LEVS+2*LEVH+3, ! QE/O(LNTE/OD,2),
-!!$$$ X P_DLAM= 6*LEVS+2*LEVH+4, ! DPDLAME/O(LNTE/OD,2),
-!!$$$ X P_DPHI= 6*LEVS+2*LEVH+5, ! DPDPHIE/O(LNTE/OD,2),
-!!$$$ X P_ULN = 6*LEVS+2*LEVH+6, ! ULNE/O(LNTE/OD,2,LEVS),
-!!$$$ X P_VLN = 7*LEVS+2*LEVH+6, ! VLNE/O(LNTE/OD,2,LEVS),
-!!$$$ X P_W = 8*LEVS+2*LEVH+6, ! WE/O(LNTE/OD,2,LEVS),
-!!$$$ X P_X = 9*LEVS+2*LEVH+6, ! XE/O(LNTE/OD,2,LEVS),
-!!$$$ X P_Y =10*LEVS+2*LEVH+6, ! YE/O(LNTE/OD,2,LEVS),
-!!$$$ X P_RT =11*LEVS+2*LEVH+6, ! RTE/O(LNTE/OD,2,LEVH),
-!!$$$ X P_ZQ =11*LEVS+3*LEVH+6) ! ZQE/O(LNTE/OD,2)
-
- INTEGER LOTS,LOTD,LOTA
-
-!!$$$ PARAMETER ( LOTS = 5*LEVS+1*LEVH+3 )
-!!$$$ PARAMETER ( LOTD = 6*LEVS+2*LEVH+0 )
-!!$$$ PARAMETER ( LOTA = 3*LEVS+1*LEVH+1 )
-
- INTEGER IBRAD,IFGES,IHOUR,INI,J,JDT,KSOUT,MAXSTP
- INTEGER mdt,idt,timetot,timer,time0
- INTEGER MODS,N1,N2,N3,N4,NDGF,NDGI,NFILES,NFLPS
- INTEGER n1hyb, n2hyb
- INTEGER NGES,NGPKEN,NITER,NNMOD,NRADF,NRADR
- INTEGER NSFCF,NSFCI,NSFCS,NSIGI,NSIGS,NSTEP
-! INTEGER NZNLF,NZNLI,NZNLS,ID,IRET,NSOUT
- INTEGER NZNLF,NZNLI,NZNLS,ID,IRET,NSOUT,kdt_switch
-
- INTEGER IERR,IPRINT,K,L,LOCL,N
- INTEGER LAN,LAT
-
- REAL(KIND=KIND_EVOD) CHOUR
- REAL(KIND=KIND_EVOD) zhour
- LOGICAL LSOUT
- LOGICAL SPS
-!DHOU 05/28/2008, add SPS for applying stochastic or not
- INTEGER HOUTASPS
-!DHOU 09/08/2008, add HOUTASPS for time (iintegration hour) of output after SPS
-
- REAL(KIND=KIND_EVOD),ALLOCATABLE :: TEE1(:)
-
-!JFE REAL(KIND=KIND_EVOD) PHIBS,DPHIBR
-
-!!$$$ INTEGER INDLSEV,JBASEV
-!!$$$ INTEGER INDLSOD,JBASOD
-
-
- INTEGER ikey,nrank_all,kcolor
-
- REAL(KIND=KIND_EVOD) CONS0P5,CONS1200,CONS3600 !CONSTANT
- REAL(KIND=KIND_EVOD) CONS0 !CONSTANT
-
- LOGICAL LSLAG
-
- END TYPE GFS_InternalState
-
-! This state is supported by C pointer not F90 pointer, thus
-! need this wrap.
-!-----------------------------------------------------------
- TYPE GFS_wrap
- TYPE (GFS_InternalState), POINTER :: Int_State
- END TYPE GFS_wrap
-
- END MODULE GFS_InternalState_ESMFMod
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/Makefile.ibm
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/Makefile.ibm (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/Makefile.ibm 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,671 @@
+FINCS = -I/nwprod/lib/incmod/esmf_3_1_0rp2
+FINCM = -I/nwprod/lib/incmod/w3_d
+
+ARCH = -qarch=pwr6 -qtune=pwr6 -qcache=auto -qnohot
+PGSZ = -bdatapsize:64K -bstackpsize:64K -btextpsize:4K
+
+OPTS = -g -qsuffix=cpp=f -O3 -qrealsize=8 -qstrict -qxlf77=leadzero -qmaxmem=-1 -qnolm -qsmp=noauto -qnosave $(ARCH)
+OPTS90 = -qsuffix=cpp=f -O3 -qrealsize=8 -qstrict -qxlf77=leadzero -qmaxmem=-1 -qnolm -qsmp=noauto -qnosave $(ARCH)
+OPTS90A = -qsuffix=cpp=f -O3 -qrealsize=8 -qstrict -qxlf77=leadzero -qmaxmem=-1 -qnolm -qsmp=noauto -qnosave $(ARCH)
+ FFLAG90 = $(OPTS90) $(FINCS) $(FINCM) -qfree -NS2048
+ FFLAG90A = $(OPTS90A) $(FINCS) -qfree -NS2048
+ FFLAGS = $(OPTS) $(TRAPS) -qfixed
+ FFLAGX = $(OPTS) $(TRAPS) -qfixed
+ FFLAGIO = $(OPTS) $(TRAPS) -qfixed
+ FFLAGY = $(OPTS) -qfixed
+ FFLAGM = $(OPTS) $(FINCS) $(TRAPS) $(DEBUG) -NS2048 -qfixed
+ FFLAGM2 = $(OPTS) $(FINCS) $(FINCM) $(TRAPS) $(DEBUG) -NS2048 -qfixed
+ FFLAGM3 = $(OPTS) $(FINCS) $(TRAPS) $(DEBUG) -NS2048 -qfree
+ FFLAGSF = -g -O3 -qnosave -qfree=f90 -qcheck
+ FFLAGSI = -g -O3 -qnosave -qfree=f90
+ FFLAGB = -g -O3 -qnosave -qfixed
+
+ LDR = mpxlf95_r -qsmp=noauto
+LDFLAGS = -lessl_r -lmass -qsmp=noauto
+
+ESMFLIB = /nwprod/lib
+LDFLAGS = -lessl_r -lmass -qsmp=noauto ${ESMFLIB}/libesmf_3_1_0rp2.a $(PGSZ)
+LIBS = -lC -L /nwprod/lib/ -l w3_d -l bacio_4 -lsp_d
+
+.SUFFIXES: .o .f .F .h
+#
+# *****************************************************************
+#
+#OBJS0 = \
+## NameList_ESMFMod.o \
+# Sfc_Var_ESMFMod.o \
+# Nst_Var_ESMFMod.o
+
+# GFS_ESMFStateAddGetMod.o
+# GFS_Standalone_ESMF_ENS.o
+# GFS_InputFile2ImportState.o
+
+
+OBJ_MOD = machine.o \
+ iounitdef.o \
+ physcons.o \
+ funcphys.o \
+ progtm_module.o \
+ rascnvv2.o \
+ resol_def.o \
+ gg_def.o \
+ vert_def.o \
+ sig_io.o \
+ date_def.o \
+ layout1.o \
+ layout_grid_tracers.o \
+ namelist_def.o \
+ namelist_soilveg.o \
+ coordinate_def.o \
+ tracer_const_h-new.o \
+ mpi_def.o \
+ sfcio_module.o \
+ d3d_def.o \
+ gfsmisc_def.o \
+ nstio_module.o \
+ module_nst_parameters.o \
+ module_nst_water_prop.o \
+ module_nst_model.o \
+ calpreciptype.o \
+ module_bfmicrophysics.o \
+ mersenne_twister.o \
+ Sfc_Var_ESMFMod.o \
+ Nst_Var_ESMFMod.o \
+ NameList_ESMFMod.o \
+ GFS_Initialize.o
+
+
+
+OBJS = \
+ gcycle.o\
+ compns.o\
+ fix_fields.o\
+ dotstep.o \
+ mpi_quit.o
+
+
+#OBJS_PORT = \
+#fftpack.o \
+#four2grid.fftpack.o \
+#noblas.o\
+#funcphys_subsx.o\
+
+OBJS_RAD = \
+ radlw_param.o \
+ radlw_datatb.o \
+ radlw_main.o \
+ radsw_param.o \
+ radsw_datatb.o \
+ radsw_main.o \
+ radiation_astronomy.o \
+ radiation_aerosols.o \
+ radiation_gases.o \
+ radiation_clouds.o \
+ radiation_surface.o \
+ gloopr.o \
+ gloopb.o \
+ grrad.o
+
+#
+#gloopb.o
+#gbphys_adv_hyb_gc.o
+#gbphys_adv_hyb_gc_h-new.o
+OBJS_PHY= \
+ ozinterp.o \
+ ozphys.o \
+ gbphys.o \
+ dcyc2.o \
+ dcyc2.pre.rad.o \
+ set_soilveg.o \
+ sfc_drv.o \
+ sfc_land.o \
+ progt2.o \
+ sfc_sice.o \
+ sfc_ocean.o \
+ sfc_nst.o \
+ sfc_diff.o \
+ sfc_diag.o \
+ sflx.o \
+ moninp.o \
+ moninp1.o \
+ moninq.o \
+ moninq1.o \
+ tridi2t3.o \
+ gwdps.o \
+ gwdc.o \
+ sascnv.o \
+ sascnvn.o \
+ cnvc90.o \
+ shalcv.o \
+ shalcv_opr.o \
+ shalcnv.o \
+ lrgsclr.o \
+ gscond.o \
+ precpd.o \
+ mstadb.o \
+ mstadbtn.o \
+ mstcnv.o \
+ get_prs.o \
+ gsmddrive.o
+
+#omegtes.o \
+#omegtes_gc.o \
+#omegas.o \
+#hyb2sig.o \
+#hyb2press.o \
+#hyb2press_gc.o \
+#sig2press.o
+
+
+OBJS_IO= \
+ sfcsub.o
+
+#read_fix.o \
+#gribit.o \
+#wrt3d.o \
+#wrt3d_hyb.o \
+#wrtg3d.o \
+#wrtg3d_hyb.o \
+#wrtsfc.o \
+#para_fixio_w.o \
+#para_nstio_w.o \
+#treadeo.io.o \
+#treadeo.gfsio.o \
+#grid_to_spec.o \
+#spect_to_grid.o \
+#spect_tv_enthalpy_ps.o\
+#setsig.o \
+#twriteeo.o \
+#bafrio.o \
+#spect_send.o \
+#spect_write.o
+
+
+OBJS_CC= cmp.comm.o \
+ atm.comm.o
+#mpi_more.o \
+#cmp.comm.o \
+#tiles.o
+
+SRC = $(OBJS0:.o=.f) $(OBJ_MOD:.o=.f) $(OBJS:.o=.f) $(OBJS_RAD:.o=.f) $(OBJS_PHY:.o=.f) $(OBJS_IO:.o=.f) $(OBJS_CC:.o=.f)
+#
+INCS = f_hpm.h mpi_inc.h function2
+
+#
+# *****************************************************************
+#
+all: model-mpi
+
+model-mpi: $(OBJ_MOD) $(OBJS_CC) $(OBJS0) $(OBJS) $(OBJS_PHY) $(OBJS_RAD) $(OBJS_IO)
+ $(LDR) $(LDFLAGS) -o $(EXEC) $(OBJ_MOD) $(OBJS_CC) $(OBJS0) $(OBJS) $(OBJS_PHY) $(OBJS_RAD) $(OBJS_IO) $(LIBS)
+
+clean:
+ rm -f $(OBJ_MOD) $(OBJS0) $(OBJS) $(OBJS_RAD) $(OBJS_PHY) $(OBJS_IO) *.mod
+
+tar:
+ tar -cvf tar.gfs.r4r8 $(SRC) $(INCS) $(COMS) $(OBJS_PORT:.o=.f) lonsper* res* xx* Makefile* ini.* scr.* m*real_?
+
+.F.o:
+ $(F77) $(FFLAGS) -c -d $<
+ #$(F77) $(FFLAGS) -c -d -WF,-DCLR:${RASV} $<
+.f.o:
+ $(F77) $(FFLAGS) -c $<
+
+
+omegas.o: omegas.f
+ $(F77) $(FFLAGM) -c omegas.f
+
+#
+# *****************************************************************
+#
+cnvc90.o: cnvc90.f
+ $(F77) $(FFLAGM) -c cnvc90.f
+
+calpreciptype.o: calpreciptype.f
+ $(F77) $(FFLAGM3) -c calpreciptype.f
+
+dcyc2.o: dcyc2.f
+ $(F77) $(FFLAGM) -c dcyc2.f
+
+dcyc2.pre.rad.o: dcyc2.pre.rad.f
+ $(F77) $(FFLAGM) -c dcyc2.pre.rad.f
+
+digifilt.o: digifilt.f
+ $(F77) $(FFLAGX) -c digifilt.f
+
+funcphys_subsx.o: funcphys_subsx.f
+ $(F77) $(FFLAGM) -c funcphys_subsx.f
+
+gbphys_adv_hyb_gc.o: gbphys_adv_hyb_gc.f
+ $(F77) $(FFLAGM) -c gbphys_adv_hyb_gc.f
+
+gbphys_adv_hyb_gc_h-new.o: gbphys_adv_hyb_gc_h-new.f
+ $(F77) $(FFLAGM) -c gbphys_adv_hyb_gc_h-new.f
+
+#gbphys_call.o: gbphys_call.f
+# $(F77) $(FFLAGM) -c gbphys_call.f
+
+gbphys.o: gbphys.f
+ $(F77) $(FFLAGM) -c gbphys.f
+
+get_prs.o: get_prs.f
+ $(F77) $(FFLAGM) -c get_prs.f
+
+gscond.o: gscond.f
+ $(F77) $(FFLAGM) -c gscond.f
+
+gsmddrive.o: gsmddrive.f
+ $(F77) $(FFLAGM) -c gsmddrive.f
+
+reduce_lons_grid_module.o: reduce_lons_grid_module.f
+ $(F77) $(FFLAGM) -c reduce_lons_grid_module.f
+
+module_bfmicrophysics.o: module_bfmicrophysics.f
+ $(F77) $(FFLAGM) -c module_bfmicrophysics.f
+
+gwdps.o: gwdps.f
+ $(F77) $(FFLAGM) -c gwdps.f
+
+gwdc.o: gwdc.f
+ $(F77) $(FFLAGM) -c gwdc.f
+
+hyb2press_gc.o: hyb2press_gc.f
+ $(F77) $(FFLAGM) -c hyb2press_gc.f
+
+hyb2press.o: hyb2press.f
+ $(F77) $(FFLAGM) -c hyb2press.f
+
+hyb2sig.o: hyb2sig.f
+ $(F77) $(FFLAGM) -c hyb2sig.f
+
+lrgsclr.o: lrgsclr.f
+ $(F77) $(FFLAGM) -c lrgsclr.f
+
+moninp.o: moninp.f
+ $(F77) $(FFLAGM) -c moninp.f
+
+moninp1.o: moninp1.f
+ $(F77) $(FFLAGM) -c moninp1.f
+
+moninq.o: moninq.f
+ $(F77) $(FFLAGM) -c moninq.f
+
+moninq1.o: moninq1.f
+ $(F77) $(FFLAGM) -c moninq1.f
+
+mstadb.o: mstadb.f
+ $(F77) $(FFLAGM) -c mstadb.f
+
+mstadbtn.o: mstadbtn.f
+ $(F77) $(FFLAGM) -c mstadbtn.f
+
+mstcnv.o: mstcnv.f
+ $(F77) $(FFLAGM) -c mstcnv.f
+
+omegtes_gc.o: omegtes_gc.f
+ $(F77) $(FFLAGM) -c omegtes_gc.f
+
+omegtes.o: omegtes.f
+ $(F77) $(FFLAGM) -c omegtes.f
+
+ozinterp.o: ozinterp.f
+ $(F77) $(FFLAGM) -c ozinterp.f
+
+ozphys.o: ozphys.f
+ $(F77) $(FFLAGM) -c ozphys.f
+
+precpd.o: precpd.f
+ $(F77) $(FFLAGM) -c precpd.f
+
+rascnvv2.o: rascnvv2.f
+ $(F77) $(FFLAGM) -c rascnvv2.f
+
+sfc_sice.o: sfc_sice.f
+ $(F77) $(FFLAGM) -c sfc_sice.f
+
+set_soilveg.o: set_soilveg.f
+ $(F77) $(FFLAGM) -c set_soilveg.f
+
+namelist_soilveg.o: namelist_soilveg.f
+ $(F77) $(FFLAGM) -c namelist_soilveg.f
+
+sfc_land.o: sfc_land.f
+ $(F77) $(FFLAGM) -c sfc_land.f
+
+progt2.o: progt2.f
+ $(F77) $(FFLAGM) -c progt2.f
+
+sfc_drv.o: sfc_drv.f
+ $(F77) $(FFLAGM) -c sfc_drv.f
+
+sflx.o: sflx.f
+ $(F77) $(FFLAGM) -c sflx.f
+
+sfc_ocean.o: sfc_ocean.f
+ $(F77) $(FFLAGM) -c sfc_ocean.f
+
+sfc_nst.o: sfc_nst.f
+ $(F77) $(FFLAGM) -c sfc_nst.f
+
+sfc_diff.o: sfc_diff.f
+ $(F77) $(FFLAGM) -c sfc_diff.f
+
+sfc_diag.o: sfc_diag.f
+ $(F77) $(FFLAGM) -c sfc_diag.f
+
+sascnv.o: sascnv.f
+ $(F77) $(FFLAGM) -c sascnv.f
+
+sascnvn.o: sascnvn.f
+ $(F77) $(FFLAGM) -c sascnvn.f
+
+tridi2t3.o: tridi2t3.f
+ $(F77) $(FFLAGM) -c tridi2t3.f
+
+shalcv.o: shalcv.f
+ $(F77) $(FFLAGM) -c shalcv.f
+
+shalcv_opr.o: shalcv_opr.f
+ $(F77) $(FFLAGM) -c shalcv_opr.f
+
+shalcnv.o: shalcnv.f
+ $(F77) $(FFLAGM) -c shalcnv.f
+
+sig2press.o: sig2press.f
+ $(F77) $(FFLAGM) -c sig2press.f
+
+# *****************************************************************
+
+radlw_param.o: radlw_param.f
+ $(F77) $(FFLAGM) -c radlw_param.f
+
+
+radlw_datatb.o: radlw_datatb.f
+ $(F77) $(FFLAGM) -c radlw_datatb.f
+
+
+radlw_main.o: radlw_main.f
+ $(F77) $(FFLAGM2) -c radlw_main.f
+
+radsw_param.o: radsw_param.f
+ $(F77) $(FFLAGM) -c radsw_param.f
+
+radsw_datatb.o: radsw_datatb.f
+ $(F77) $(FFLAGM) -c radsw_datatb.f
+
+radsw_main.o: radsw_main.f
+ $(F77) $(FFLAGM2) -c radsw_main.f
+
+radiation_astronomy.o: radiation_astronomy.f
+ $(F77) $(FFLAGM) -c radiation_astronomy.f
+
+radiation_aerosols.o: radiation_aerosols.f
+ $(F77) $(FFLAGM) -c radiation_aerosols.f
+
+radiation_gases.o: radiation_gases.f
+ $(F77) $(FFLAGM) -c radiation_gases.f
+
+radiation_clouds.o: radiation_clouds.f
+ $(F77) $(FFLAGM) -c radiation_clouds.f
+
+radiation_surface.o: radiation_surface.f
+ $(F77) $(FFLAGM) -c radiation_surface.f
+
+grrad.o: grrad.f
+ $(F77) $(FFLAGM) -c grrad.f
+
+progtm_module.o: progtm_module.f
+ $(F77) $(FFLAGM) -c progtm_module.f
+
+machine.o: machine.f
+ $(F77) $(FFLAGM) -c machine.f
+
+num_parthds.o: num_parthds.f
+ $(F77) $(FFLAGM) -c num_parthds.f
+
+kinds.o: GEFS_Cpl_Cal_Sto_Coef.fd/kinds.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/kinds.f90
+
+peuc.o: GEFS_Cpl_Cal_Sto_Coef.fd/peuc.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/peuc.f90
+
+pran.o: GEFS_Cpl_Cal_Sto_Coef.fd/pran.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/pran.f90
+
+prana.o: GEFS_Cpl_Cal_Sto_Coef.fd/prana.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/prana.f90
+
+#
+# *****************************************************************
+#
+physcons.o: physcons.f
+ $(F77) $(FFLAG90) -c physcons.f
+
+iounitdef.o: iounitdef.f
+ $(F77) $(FFLAG90) -c iounitdef.f
+
+funcphys.o: funcphys.f
+ $(F77) $(FFLAG90) -c funcphys.f
+
+sfcio_module.o: sfcio_module.f
+ $(F77) $(FFLAGSF) -c sfcio_module.f
+
+sigio_module.o: sigio_module.f
+ $(F77) $(FFLAGSI) -c sigio_module.f
+
+gfsio_def.o: gfsio_def.f
+ $(F77) $(FFLAGSI) -c gfsio_def.f
+
+gfsio_module.o: gfsio_module.f
+ $(F77) $(FFLAGSI) -c gfsio_module.f
+
+sigio_r_module.o: sigio_r_module.f
+ $(F77) $(FFLAGSI) -c sigio_r_module.f
+
+bafrio.o: bafrio.f
+ $(F77) $(FFLAGB) -c bafrio.f
+
+#
+#sigdas.io.o: sigdas.io.f
+## $(F77) $(FFLAGIO) -c sigdas.io.f
+
+read_fix.o: read_fix.f
+ $(F77) $(FFLAGX) -c read_fix.f
+
+softcount.o: softcount.f
+ $(F77) $(FFLAGX) -c softcount.f
+
+gloopr.o: gloopr.f
+ $(F77) $(FFLAGM2) -c gloopr.f
+
+gloopb.o: gloopb.f
+ $(F77) $(FFLAGM2) -c gloopb.f
+
+sfcsub.o: sfcsub.f
+ $(F77) $(FFLAGM) -c sfcsub.f
+
+gcycle.o: gcycle.f
+ $(F77) $(FFLAGM) -c gcycle.f
+
+getaer.o: getaer.f
+ $(F77) $(FFLAGIO) -c getaer.f
+
+wrt3d.o: wrt3d.f
+ $(F77) $(FFLAGIO) -c wrt3d.f
+
+gribit.o: gribit.f
+ $(F77) $(FFLAGIO) -c gribit.f
+
+wrtsfc.o: wrtsfc.f
+ $(F77) $(FFLAGIO) -c wrtsfc.f
+
+para_fixio_w.o: para_fixio_w.f
+ $(F77) $(FFLAGIO) -c para_fixio_w.f
+
+para_nstio_w.o: para_nstio_w.f
+ $(F77) $(FFLAGIO) -c para_nstio_w.f
+
+#para_fixio_all_w.o: para_fixio_all_w.f
+# $(F77) $(FFLAGIO) -c para_fixio_all_w.f
+
+#para_fixio_iop_w.o: para_fixio_iop_w.f
+# $(F77) $(FFLAGIO) -c para_fixio_iop_w.f
+
+#conrad.o: conrad.f
+# $(F77) $(FFLAGIO) -c conrad.f
+
+#crhtab.o: crhtab.f
+# $(F77) $(FFLAGIO) -c crhtab.f
+
+treadeo.io.o: treadeo.io.f
+ $(F77) $(FFLAGIO) -c treadeo.io.f
+
+treadeo.gfsio.o: treadeo.gfsio.f
+ $(F77) $(FFLAGIO) -c treadeo.gfsio.f
+
+twriteeo.o: twriteeo.f
+ $(F77) $(FFLAGIO) -c twriteeo.f
+
+spect_send.o: spect_send.f
+ $(F77) $(FFLAGIO) -c spect_send.f
+
+spect_write.o: spect_write.f
+ $(F77) $(FFLAGIO) -c spect_write.f
+
+spect_to_grid.o: spect_to_grid.f
+ $(F77) $(FFLAGIO) -c spect_to_grid.f
+
+spect_tv_enthalpy_ps.o: spect_tv_enthalpy_ps.f
+ $(F77) $(FFLAGIO) -c spect_tv_enthalpy_ps.f
+
+grid_to_spec.o: grid_to_spec.f
+ $(F77) $(FFLAGIO) -c grid_to_spec.f
+
+wrtout.o: wrtout.f
+ $(F77) $(FFLAGIO) -c wrtout.f
+
+nstio_module.o: nstio_module.f
+ $(F77) $(FFLAG90) -c nstio_module.f
+
+module_nst_parameters.o: module_nst_parameters.f
+ $(F77) $(FFLAG90) -c module_nst_parameters.f
+
+module_nst_water_prop.o: module_nst_water_prop.f
+ $(F77) $(FFLAG90) -c module_nst_water_prop.f
+
+module_nst_model.o: module_nst_model.f
+ $(F77) $(FFLAG90) -c module_nst_model.f
+
+NameList_ESMFMod.o: NameList_ESMFMod.f
+ $(F77) $(FFLAG90) -c NameList_ESMFMod.f
+
+Sfc_Var_ESMFMod.o: Sfc_Var_ESMFMod.f
+ $(F77) $(FFLAG90) -c Sfc_Var_ESMFMod.f
+
+Nst_Var_ESMFMod.o: Nst_Var_ESMFMod.f
+ $(F77) $(FFLAG90) -c Nst_Var_ESMFMod.f
+
+Lib_ESMFStateAddGetMod.o: Lib_ESMFStateAddGetMod.f
+ $(F77) $(FFLAG90) -c Lib_ESMFStateAddGetMod.f
+
+#GFS_ESMFStateAddGetMod.o: GFS_ESMFStateAddGetMod.f
+# $(F77) $(FFLAG90) -c GFS_ESMFStateAddGetMod.f
+
+GFS_InternalState_ESMFMod.o: GFS_InternalState_ESMFMod.f
+ $(F77) $(FFLAG90) -c GFS_InternalState_ESMFMod.f
+
+GFS_ESMFStateMod.o: GFS_ESMFStateMod.f
+ $(F77) $(FFLAG90) -c GFS_ESMFStateMod.f
+
+GFS_ErrMsgMod.o: GFS_ErrMsgMod.f
+ $(F77) $(FFLAG90) -c GFS_ErrMsgMod.f
+
+GFS_GetCf_ESMFMod.o: GFS_GetCf_ESMFMod.f
+ $(F77) $(FFLAG90) -c GFS_GetCf_ESMFMod.f
+
+GFS_ESMFMod.o: GFS_ESMFMod.f
+ $(F77) $(FFLAG90) -c GFS_ESMFMod.f
+
+#GFS_Grid_fnl_ESMFMod.o: GFS_Grid_fnl_ESMFMod.f
+ #$(F77) $(FFLAG90A) -c GFS_Grid_fnl_ESMFMod.f
+
+GFS_GridComp_ESMFMod.o: GFS_GridComp_ESMFMod.f
+ $(F77) $(FFLAG90A) -c GFS_GridComp_ESMFMod.f
+
+#GFS_Initialize_ESMFMod.o: GFS_Initialize_ESMFMod.f
+# $(F77) $(FFLAG90) -c GFS_Initialize_ESMFMod.f
+
+GFS_Initialize.o: GFS_Initialize.f
+ $(F77) $(FFLAG90) -c GFS_Initialize.f
+
+GFS_Run_ESMFMod.o: GFS_Run_ESMFMod.f
+ $(F77) $(FFLAG90) -c GFS_Run_ESMFMod.f
+
+GFS_Finalize_ESMFMod.o: GFS_Finalize_ESMFMod.f
+ $(F77) $(FFLAG90) -c GFS_Finalize_ESMFMod.f
+
+GFS_InputFile2ImportState.o: GFS_InputFile2ImportState.f
+ $(F77) $(FFLAG90) -c GFS_InputFile2ImportState.f
+
+#GFS_Standalone_ESMF_ENS.o: GFS_Standalone_ESMF_ENS.f
+# $(F77) $(FFLAG90) -c GFS_Standalone_ESMF_ENS.f
+
+GFS_ESMF.o: GFS_ESMF.f
+ $(F77) $(FFLAG90) -c GFS_ESMF.f
+
+Grid_ESMFCreate.o: Grid_ESMFCreate.f
+ $(F77) $(FFLAG90) -c Grid_ESMFCreate.f
+
+StartTimeGet_ESMF.o: StartTimeGet_ESMF.f
+ $(F77) $(FFLAG90) -c StartTimeGet_ESMF.f
+
+Ensemble_sub.o: Ensemble_sub.f
+ $(F77) $(FFLAG90) -c Ensemble_sub.f
+
+mpi_more.o: mpi_more.f
+ $(F77) $(FFLAGS) -c mpi_more.f
+
+cmp.comm.o: cmp.comm.f
+ $(F77) $(FFLAGS) -c cmp.comm.f
+
+atm.comm.o: atm.comm.f
+ $(F77) $(FFLAGS) -c atm.comm.f
+
+tiles.o: tiles.f
+ $(F77) $(FFLAGS) -c tiles.f
+
+GEFS_Cpl_InternalState_ESMFMod.o: GEFS_Cpl_InternalState_ESMFMod.f
+ $(F77) $(FFLAG90) -c GEFS_Cpl_InternalState_ESMFMod.f
+
+GEFS_CplState_ESMFMod.o: GEFS_CplState_ESMFMod.f
+ $(F77) $(FFLAG90) -c GEFS_CplState_ESMFMod.f
+
+GEFS_Sto_Per_Scheme.o: GEFS_Sto_Per_Scheme.f
+ $(F77) $(FFLAG90) -c GEFS_Sto_Per_Scheme.f
+
+GEFS_Cpl_Run_ESMFMod.o: GEFS_Cpl_Run_ESMFMod.f
+ $(F77) $(FFLAG90) -c GEFS_Cpl_Run_ESMFMod.f
+
+GEFS_Cpl_ESMFMod.o: GEFS_Cpl_ESMFMod.f
+ $(F77) $(FFLAG90) -c GEFS_Cpl_ESMFMod.f
+
+GEFS_CplComp_ESMFMod.o: GEFS_CplComp_ESMFMod.f
+ $(F77) $(FFLAG90) -c GEFS_CplComp_ESMFMod.f
+
+GFS_AddParameterToStateMod.o: GFS_AddParameterToStateMod.f
+ $(F77) $(FFLAG90) -c GFS_AddParameterToStateMod.f
+
+GEFS_Sto_Per_Scheme_Step1.o: GEFS_Sto_Per_Scheme_Step1.f
+ $(F77) $(FFLAG90) -c GEFS_Sto_Per_Scheme_Step1.f
+
+GEFS_Sto_Per_Scheme_Step2.o: GEFS_Sto_Per_Scheme_Step2.f
+ $(F77) $(FFLAG90) -c GEFS_Sto_Per_Scheme_Step2.f
+
+GEFS_GetParameterFromStateMod.o: GEFS_GetParameterFromStateMod.f
+ $(F77) $(FFLAG90) -c GEFS_GetParameterFromStateMod.f
+
+Cal_Sto_Coef.o: GEFS_Cpl_Cal_Sto_Coef.fd/Cal_Sto_Coef.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/Cal_Sto_Coef.f90
+
+GEFS_bcst_global.o: GEFS_bcst_global.f
+ $(F77) $(FFLAG90) -c GEFS_bcst_global.f
Property changes on: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/Makefile.ibm
___________________________________________________________________
Added: svn:executable
+ *
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/Makefile.jet
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/Makefile.jet (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/Makefile.jet 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,678 @@
+
+EXEC = global_fcst
+F77= mpif90
+F90= mpif90
+LIBDIR=/scratch2/portfolios/NCEPDEV/global/save/Shrinivas.Moorthi/para/lib
+
+#
+ FINCS = -I /scratch2/portfolios/NCEPDEV/global/save/Shrinivas.Moorthi/para/lib/incmod/esmf_3_1_0rp2
+ FINCM = -I /scratch2/portfolios/NCEPDEV/global/save/Shrinivas.Moorthi/para/lib/nwprod/incmod/w3lib-2.0_d
+
+ ARCH =
+ PGSZ =
+
+ OPTS = -O3 -convert big_endian -traceback -r8
+ OPTS90 = -O3 -convert big_endian -traceback -r8
+ OPTS90A = -O3 -convert big_endian -traceback -r8
+
+ FFLAG90 = $(OPTS90) $(FINCS) -free
+ FFLAG90A = $(OPTS90A) $(FINCS) -free
+ FFLAGS = $(OPTS) $(TRAPS)
+ FFLAGX = $(OPTS) $(TRAPS)
+ FFLAGIO = $(OPTS) $(TRAPS)
+ FFLAGY = $(OPTS)
+ FFLAGM = $(OPTS) $(FINCS) $(TRAPS) $(DEBUG)
+ FFLAGM2 = $(OPTS) $(FINCS) $(FINCM) $(TRAPS) $(DEBUG)
+ FFLAGM3 = $(OPTS) $(FINCS) $(TRAPS) $(DEBUG) -free
+ FFLAG_SER = -O3 -convert big_endian -traceback -r8
+
+ FFLAGSF = -O3 -convert big_endian -traceback -FR
+ FFLAGSI = -O3 -convert big_endian -traceback -FR
+ FFLAGB = -O3 -convert big_endian -traceback
+
+ LDR = mpif90
+
+ LDFLAGS =
+##LIBS = -L$(MKL) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core -lstdc++ -limf -lm -lrt -ldl -L$(LIBDIR) -lsp_d -lw3lib-2.0_d -lbacio_4 -lesmf_3_1_0rp2 -threads
+##LIBS = -lstdc++ -limf -lm -lrt -ldl -threads -L$(LIBDIR) -lsp_d -lw3lib-2.0_d -lbacio_4 -lesmf_3_1_0rp2 -lsfcio_4 -lsigio_4 -L${MPICH}/lib -lmpichcxx -mkl=sequential \
+## -L$(MKL) -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core -lguide
+
+LIBS = -L$(MKL) -lmkl_intel_lp64 -lmkl_core -lmkl_intel_thread -lguide -L$(LIBDIR) -lesmf_3_1_0rp2 -lbacio_4 -lsp_d -lw3lib-2.0_d -lrt -lstdc++
+
+
+.SUFFIXES: .o .f .F .h
+#
+# *****************************************************************
+#
+#OBJS0 = \
+# NameList_ESMFMod.o \
+# Sfc_Var_ESMFMod.o \
+# Nst_Var_ESMFMod.o
+
+OBJ_MOD = machine.o \
+ iounitdef.o \
+ physcons.o \
+ funcphys.o \
+ progtm_module.o \
+ rascnvv2.o \
+ resol_def.o \
+ gg_def.o \
+ vert_def.o \
+ sig_io.o \
+ date_def.o \
+ layout1.o \
+ layout_grid_tracers.o \
+ namelist_def.o \
+ namelist_soilveg.o \
+ coordinate_def.o \
+ tracer_const_h-new.o \
+ mpi_def.o \
+ sfcio_module.o \
+ d3d_def.o \
+ gfsmisc_def.o \
+ nstio_module.o \
+ module_nst_parameters.o \
+ module_nst_water_prop.o \
+ module_nst_model.o \
+ calpreciptype.o \
+ module_bfmicrophysics.o \
+ mersenne_twister.o \
+ Sfc_Var_ESMFMod.o \
+ Nst_Var_ESMFMod.o \
+ NameList_ESMFMod.o \
+ GFS_Initialize.o
+
+OBJS = \
+ gcycle.o\
+ compns.o\
+ fix_fields.o\
+ dotstep.o \
+ mpi_quit.o
+
+#OBJS_PORT = \
+# fftpack.o \
+# four2grid.fftpack.o \
+# noblas.o\
+# funcphys_subsx.o\
+
+OBJS_RAD = \
+ radlw_param.o \
+ radlw_datatb.o \
+ radlw_main.o \
+ radsw_param.o \
+ radsw_datatb.o \
+ radsw_main.o \
+ radiation_astronomy.o \
+ radiation_aerosols.o \
+ radiation_gases.o \
+ radiation_clouds.o \
+ radiation_surface.o \
+ grrad.o \
+ gloopb.o \
+ gloopr.o
+
+#
+# astronomy.o \
+## funcphys_subs.o
+
+
+# gloopb.o \
+OBJS_PHY= \
+ ozinterp.o \
+ ozphys.o \
+ gbphys.o \
+ dcyc2.o \
+ dcyc2.pre.rad.o \
+ set_soilveg.o \
+ sfc_drv.o \
+ sfc_land.o \
+ progt2.o \
+ sfc_sice.o \
+ sfc_ocean.o \
+ sfc_nst.o \
+ sfc_diff.o \
+ sfc_diag.o \
+ sflx.o \
+ moninp.o \
+ moninp1.o \
+ moninq.o \
+ moninq1.o \
+ tridi2t3.o \
+ gwdps.o \
+ gwdc.o \
+ sascnv.o \
+ sascnvn.o \
+ cnvc90.o \
+ shalcv.o \
+ shalcv_opr.o \
+ shalcnv.o \
+ lrgsclr.o \
+ gscond.o \
+ precpd.o \
+ mstadb.o \
+ mstadbtn.o \
+ mstcnv.o \
+ get_prs.o \
+ gsmddrive.o
+
+# gbphys_call.o \
+###funcphys_subsx.o only srt gpxs was called in fix_fields -table not used
+
+OBJS_IO= \
+ sfcsub.o
+
+# read_fix.o \
+# gribit.o \
+# wrt3d.o \
+# wrt3d_hyb.o \
+# wrtg3d.o \
+# wrtg3d_hyb.o \
+# wrtsfc.o \
+# para_fixio_w.o \
+# para_nstio_w.o \
+# treadeo.io.o \
+# treadeo.gfsio.o \
+# grid_to_spec.o \
+# spect_to_grid.o \
+# spect_tv_enthalpy_ps.o\
+# setsig.o \
+# twriteeo.o \
+# bafrio.o \
+# spect_send.o \
+# spect_write.o
+
+
+OBJS_CC= cmp.comm.o \
+ atm.comm.o
+# mpi_more.o \
+# tiles.o
+
+SRC = $(OBJS0:.o=.f) $(OBJ_MOD:.o=.f) $(OBJS:.o=.f) $(OBJS_RAD:.o=.f) $(OBJS_PHY:.o=.f) $(OBJS_IO:.o=.f) $(OBJS_CC:.o=.f)
+#
+INCS = f_hpm.h mpi_inc.h function2
+
+#
+# *****************************************************************
+#
+all: model-mpi
+
+model-mpi: $(OBJ_MOD) $(OBJS_CC) $(OBJS0) $(OBJS) $(OBJS_PHY) $(OBJS_RAD) $(OBJS_IO)
+ $(LDR) -o $(EXEC) $(OBJ_MOD) $(OBJS_CC) $(OBJS0) $(OBJS) $(OBJS_PHY) $(OBJS_RAD) $(OBJS_IO) $(LIBS) $(LDFLAGS)
+
+clean:
+ rm -f $(OBJ_MOD) $(OBJS0) $(OBJS) $(OBJS_RAD) $(OBJS_PHY) $(OBJS_IO) *.mod
+
+tar:
+ tar -cvf tar.gfs.r4r8 $(SRC) $(INCS) $(COMS) $(OBJS_PORT:.o=.f) lonsper* res* xx* Makefile* ini.* scr.* m*real_?
+
+.F.o:
+ $(F77) $(FFLAGS) -c -d $<
+ #$(F77) $(FFLAGS) -c -d -WF,-DCLR:${RASV} $<
+.f.o:
+ $(F77) $(FFLAGS) -c $<
+
+
+omegas.o: omegas.f
+ $(F77) $(FFLAGM) -c omegas.f
+
+#
+# *****************************************************************
+#
+cnvc90.o: cnvc90.f
+ $(F77) $(FFLAGM) -c cnvc90.f
+
+calpreciptype.o: calpreciptype.f
+ $(F77) $(FFLAGM3) -c calpreciptype.f
+
+dcyc2.o: dcyc2.f
+ $(F77) $(FFLAGM) -c dcyc2.f
+
+dcyc2.pre.rad.o: dcyc2.pre.rad.f
+ $(F77) $(FFLAGM) -c dcyc2.pre.rad.f
+
+digifilt.o: digifilt.f
+ $(F77) $(FFLAGX) -c digifilt.f
+
+funcphys_subsx.o: funcphys_subsx.f
+ $(F77) $(FFLAGM) -c funcphys_subsx.f
+
+gbphys_adv_hyb_gc.o: gbphys_adv_hyb_gc.f
+ $(F77) $(FFLAGM) -c gbphys_adv_hyb_gc.f
+
+gbphys_adv_hyb_gc_h-new.o: gbphys_adv_hyb_gc_h-new.f
+ $(F77) $(FFLAGM) -c gbphys_adv_hyb_gc_h-new.f
+
+#gbphys_call.o: gbphys_call.f
+# $(F77) $(FFLAGM) -c gbphys_call.f
+
+gbphys.o: gbphys.f
+ $(F77) $(FFLAGM) -c gbphys.f
+
+get_prs.o: get_prs.f
+ $(F77) $(FFLAGM) -c get_prs.f
+
+filtr1eo.o: filtr1eo.f
+ $(F77) $(FFLAG_SER) -c filtr1eo.f
+
+filtr2eo.o: filtr2eo.f
+ $(F77) $(FFLAG_SER) -c filtr2eo.f
+
+gscond.o: gscond.f
+ $(F77) $(FFLAGM) -c gscond.f
+
+gsmddrive.o: gsmddrive.f
+ $(F77) $(FFLAGM) -c gsmddrive.f
+
+reduce_lons_grid_module.o: reduce_lons_grid_module.f
+ $(F77) $(FFLAGM) -c reduce_lons_grid_module.f
+
+module_bfmicrophysics.o: module_bfmicrophysics.f
+ $(F77) $(FFLAGM) -c module_bfmicrophysics.f
+
+gwdps.o: gwdps.f
+ $(F77) $(FFLAGM) -c gwdps.f
+
+gwdc.o: gwdc.f
+ $(F77) $(FFLAGM) -c gwdc.f
+
+hyb2press_gc.o: hyb2press_gc.f
+ $(F77) $(FFLAGM) -c hyb2press_gc.f
+
+hyb2press.o: hyb2press.f
+ $(F77) $(FFLAGM) -c hyb2press.f
+
+hyb2sig.o: hyb2sig.f
+ $(F77) $(FFLAGM) -c hyb2sig.f
+
+lrgsclr.o: lrgsclr.f
+ $(F77) $(FFLAGM) -c lrgsclr.f
+
+moninp.o: moninp.f
+ $(F77) $(FFLAGM) -c moninp.f
+
+moninp1.o: moninp1.f
+ $(F77) $(FFLAGM) -c moninp1.f
+
+moninq.o: moninq.f
+ $(F77) $(FFLAGM) -c moninq.f
+
+moninq1.o: moninq1.f
+ $(F77) $(FFLAGM) -c moninq1.f
+
+mstadb.o: mstadb.f
+ $(F77) $(FFLAGM) -c mstadb.f
+
+mstadbtn.o: mstadbtn.f
+ $(F77) $(FFLAGM) -c mstadbtn.f
+
+mstcnv.o: mstcnv.f
+ $(F77) $(FFLAGM) -c mstcnv.f
+
+omegtes_gc.o: omegtes_gc.f
+ $(F77) $(FFLAGM) -c omegtes_gc.f
+
+omegtes.o: omegtes.f
+ $(F77) $(FFLAGM) -c omegtes.f
+
+ozinterp.o: ozinterp.f
+ $(F77) $(FFLAGM) -c ozinterp.f
+
+ozphys.o: ozphys.f
+ $(F77) $(FFLAGM) -c ozphys.f
+
+precpd.o: precpd.f
+ $(F77) $(FFLAGM) -c precpd.f
+
+rascnvv2.o: rascnvv2.f
+ $(F77) $(FFLAGM) -c rascnvv2.f
+
+sfc_sice.o: sfc_sice.f
+ $(F77) $(FFLAGM) -c sfc_sice.f
+
+set_soilveg.o: set_soilveg.f
+ $(F77) $(FFLAGM) -c set_soilveg.f
+
+namelist_soilveg.o: namelist_soilveg.f
+ $(F77) $(FFLAGM) -c namelist_soilveg.f
+
+sfc_land.o: sfc_land.f
+ $(F77) $(FFLAGM) -c sfc_land.f
+
+progt2.o: progt2.f
+ $(F77) $(FFLAGM) -c progt2.f
+
+sfc_drv.o: sfc_drv.f
+ $(F77) $(FFLAGM) -c sfc_drv.f
+
+sflx.o: sflx.f
+ $(F77) $(FFLAGM) -c sflx.f
+
+sfc_ocean.o: sfc_ocean.f
+ $(F77) $(FFLAGM) -c sfc_ocean.f
+
+sfc_nst.o: sfc_nst.f
+ $(F77) $(FFLAGM) -c sfc_nst.f
+
+sfc_diff.o: sfc_diff.f
+ $(F77) $(FFLAGM) -c sfc_diff.f
+
+sfc_diag.o: sfc_diag.f
+ $(F77) $(FFLAGM) -c sfc_diag.f
+
+sascnv.o: sascnv.f
+ $(F77) $(FFLAGM) -c sascnv.f
+
+sascnvn.o: sascnvn.f
+ $(F77) $(FFLAGM) -c sascnvn.f
+
+tridi2t3.o: tridi2t3.f
+ $(F77) $(FFLAGM) -c tridi2t3.f
+
+shalcv.o: shalcv.f
+ $(F77) $(FFLAGM) -c shalcv.f
+
+shalcv_opr.o: shalcv_opr.f
+ $(F77) $(FFLAGM) -c shalcv_opr.f
+
+shalcnv.o: shalcnv.f
+ $(F77) $(FFLAGM) -c shalcnv.f
+
+sig2press.o: sig2press.f
+ $(F77) $(FFLAGM) -c sig2press.f
+
+# *****************************************************************
+
+radlw_param.o: radlw_param.f
+ $(F77) $(FFLAGM) -c radlw_param.f
+
+
+radlw_datatb.o: radlw_datatb.f
+ $(F77) $(FFLAGM) -c radlw_datatb.f
+
+
+radlw_main.o: radlw_main.f
+ $(F77) $(FFLAGM2) -c radlw_main.f
+
+radsw_param.o: radsw_param.f
+ $(F77) $(FFLAGM) -c radsw_param.f
+
+radsw_datatb.o: radsw_datatb.f
+ $(F77) $(FFLAGM) -c radsw_datatb.f
+
+radsw_main.o: radsw_main.f
+ $(F77) $(FFLAGM2) -c radsw_main.f
+
+radiation_astronomy.o: radiation_astronomy.f
+ $(F77) $(FFLAGM) -c radiation_astronomy.f
+
+radiation_aerosols.o: radiation_aerosols.f
+ $(F77) $(FFLAGM) -c radiation_aerosols.f
+
+radiation_gases.o: radiation_gases.f
+ $(F77) $(FFLAGM) -c radiation_gases.f
+
+radiation_clouds.o: radiation_clouds.f
+ $(F77) $(FFLAGM) -c radiation_clouds.f
+
+radiation_surface.o: radiation_surface.f
+ $(F77) $(FFLAGM) -c radiation_surface.f
+
+grrad.o: grrad.f
+ $(F77) $(FFLAGM) -c grrad.f
+
+progtm_module.o: progtm_module.f
+ $(F77) $(FFLAGM) -c progtm_module.f
+
+machine.o: machine.f
+ $(F77) $(FFLAGM) -c machine.f
+
+num_parthds.o: num_parthds.f
+ $(F77) $(FFLAGM) -c num_parthds.f
+
+kinds.o: GEFS_Cpl_Cal_Sto_Coef.fd/kinds.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/kinds.f90
+
+peuc.o: GEFS_Cpl_Cal_Sto_Coef.fd/peuc.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/peuc.f90
+
+pran.o: GEFS_Cpl_Cal_Sto_Coef.fd/pran.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/pran.f90
+
+prana.o: GEFS_Cpl_Cal_Sto_Coef.fd/prana.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/prana.f90
+
+#
+# *****************************************************************
+#
+physcons.o: physcons.f
+ $(F77) $(FFLAG90) -c physcons.f
+
+iounitdef.o: iounitdef.f
+ $(F77) $(FFLAG90) -c iounitdef.f
+
+funcphys.o: funcphys.f
+ $(F77) $(FFLAG90) -c funcphys.f
+
+sfcio_module.o: sfcio_module.f
+ $(F77) $(FFLAGSF) -c sfcio_module.f
+
+sigio_module.o: sigio_module.f
+ $(F77) $(FFLAGSI) -c sigio_module.f
+
+gfsio_def.o: gfsio_def.f
+ $(F77) $(FFLAGSI) -c gfsio_def.f
+
+gfsio_module.o: gfsio_module.f
+ $(F77) $(FFLAGSI) -c gfsio_module.f
+
+sigio_r_module.o: sigio_r_module.f
+ $(F77) $(FFLAGSI) -c sigio_r_module.f
+
+bafrio.o: bafrio.f
+ $(F77) $(FFLAGB) -c bafrio.f
+
+#
+#sigdas.io.o: sigdas.io.f
+## $(F77) $(FFLAGIO) -c sigdas.io.f
+
+read_fix.o: read_fix.f
+ $(F77) $(FFLAGX) -c read_fix.f
+
+softcount.o: softcount.f
+ $(F77) $(FFLAGX) -c softcount.f
+
+gloopr.o: gloopr.f
+ $(F77) $(FFLAG_SER) -c gloopr.f
+
+gloopb.o: gloopb.f
+ $(F77) $(FFLAGM2) -c gloopb.f
+
+sfcsub.o: sfcsub.f
+ $(F77) $(FFLAG_SER) -c sfcsub.f
+
+gcycle.o: gcycle.f
+ $(F77) $(FFLAGM) -c gcycle.f
+
+getaer.o: getaer.f
+ $(F77) $(FFLAGIO) -c getaer.f
+
+wrt3d.o: wrt3d.f
+ $(F77) $(FFLAGIO) -c wrt3d.f
+
+gribit.o: gribit.f
+ $(F77) $(FFLAGIO) -c gribit.f
+
+wrtsfc.o: wrtsfc.f
+ $(F77) $(FFLAGIO) -c wrtsfc.f
+
+para_fixio_w.o: para_fixio_w.f
+ $(F77) $(FFLAGIO) -c para_fixio_w.f
+
+para_nstio_w.o: para_nstio_w.f
+ $(F77) $(FFLAGIO) -c para_nstio_w.f
+
+#para_fixio_all_w.o: para_fixio_all_w.f
+# $(F77) $(FFLAGIO) -c para_fixio_all_w.f
+
+#para_fixio_iop_w.o: para_fixio_iop_w.f
+# $(F77) $(FFLAGIO) -c para_fixio_iop_w.f
+
+#conrad.o: conrad.f
+# $(F77) $(FFLAGIO) -c conrad.f
+
+#crhtab.o: crhtab.f
+# $(F77) $(FFLAGIO) -c crhtab.f
+
+treadeo.io.o: treadeo.io.f
+ $(F77) $(FFLAGIO) -c treadeo.io.f
+
+treadeo.gfsio.o: treadeo.gfsio.f
+ $(F77) $(FFLAGIO) -c treadeo.gfsio.f
+
+twriteeo.o: twriteeo.f
+ $(F77) $(FFLAGIO) -c twriteeo.f
+
+spect_send.o: spect_send.f
+ $(F77) $(FFLAGIO) -c spect_send.f
+
+spect_write.o: spect_write.f
+ $(F77) $(FFLAGIO) -c spect_write.f
+
+spect_to_grid.o: spect_to_grid.f
+ $(F77) $(FFLAGIO) -c spect_to_grid.f
+
+spect_tv_enthalpy_ps.o: spect_tv_enthalpy_ps.f
+ $(F77) $(FFLAGIO) -c spect_tv_enthalpy_ps.f
+
+grid_to_spec.o: grid_to_spec.f
+ $(F77) $(FFLAGIO) -c grid_to_spec.f
+
+wrtout.o: wrtout.f
+ $(F77) $(FFLAGIO) -c wrtout.f
+
+nstio_module.o: nstio_module.f
+ $(F77) $(FFLAG90) -c nstio_module.f
+
+module_nst_parameters.o: module_nst_parameters.f
+ $(F77) $(FFLAG90) -c module_nst_parameters.f
+
+module_nst_water_prop.o: module_nst_water_prop.f
+ $(F77) $(FFLAG90) -c module_nst_water_prop.f
+
+module_nst_model.o: module_nst_model.f
+ $(F77) $(FFLAG90) -c module_nst_model.f
+
+NameList_ESMFMod.o: NameList_ESMFMod.f
+ $(F77) $(FFLAG90) -c NameList_ESMFMod.f
+
+Sfc_Var_ESMFMod.o: Sfc_Var_ESMFMod.f
+ $(F77) $(FFLAG90) -c Sfc_Var_ESMFMod.f
+
+Nst_Var_ESMFMod.o: Nst_Var_ESMFMod.f
+ $(F77) $(FFLAG90) -c Nst_Var_ESMFMod.f
+
+Lib_ESMFStateAddGetMod.o: Lib_ESMFStateAddGetMod.f
+ $(F77) $(FFLAG90) -c Lib_ESMFStateAddGetMod.f
+
+#GFS_ESMFStateAddGetMod.o: GFS_ESMFStateAddGetMod.f
+# $(F77) $(FFLAG90) -c GFS_ESMFStateAddGetMod.f
+
+GFS_InternalState_ESMFMod.o: GFS_InternalState_ESMFMod.f
+ $(F77) $(FFLAG90) -c GFS_InternalState_ESMFMod.f
+
+GFS_ESMFStateMod.o: GFS_ESMFStateMod.f
+ $(F77) $(FFLAG90) -c GFS_ESMFStateMod.f
+
+GFS_ErrMsgMod.o: GFS_ErrMsgMod.f
+ $(F77) $(FFLAG90) -c GFS_ErrMsgMod.f
+
+GFS_GetCf_ESMFMod.o: GFS_GetCf_ESMFMod.f cmp.comm.o atm.comm.o
+ $(F77) $(FFLAG90) -c GFS_GetCf_ESMFMod.f
+
+GFS_ESMFMod.o: GFS_ESMFMod.f
+ $(F77) $(FFLAG90) -c GFS_ESMFMod.f
+
+#GFS_Grid_fnl_ESMFMod.o: GFS_Grid_fnl_ESMFMod.f
+ #$(F77) $(FFLAG90A) -c GFS_Grid_fnl_ESMFMod.f
+
+GFS_GridComp_ESMFMod.o: GFS_GridComp_ESMFMod.f
+ $(F77) $(FFLAG90A) -c GFS_GridComp_ESMFMod.f
+
+#GFS_Initialize_ESMFMod.o: GFS_Initialize_ESMFMod.f
+# $(F77) $(FFLAG90) -c GFS_Initialize_ESMFMod.f
+GFS_Initialize.o: GFS_Initialize.f
+ $(F77) $(FFLAG90) -c GFS_Initialize.f
+
+GFS_Run_ESMFMod.o: GFS_Run_ESMFMod.f
+ $(F77) $(FFLAG90) -c GFS_Run_ESMFMod.f
+
+GFS_Finalize_ESMFMod.o: GFS_Finalize_ESMFMod.f
+ $(F77) $(FFLAG90) -c GFS_Finalize_ESMFMod.f
+
+GFS_InputFile2ImportState.o: GFS_InputFile2ImportState.f
+ $(F77) $(FFLAG90) -c GFS_InputFile2ImportState.f
+
+#GFS_Standalone_ESMF_ENS.o: GFS_Standalone_ESMF_ENS.f
+# $(F77) $(FFLAG90) -c GFS_Standalone_ESMF_ENS.f
+
+GFS_ESMF.o: GFS_ESMF.f
+ $(F77) $(FFLAG90) -c GFS_ESMF.f
+
+Grid_ESMFCreate.o: Grid_ESMFCreate.f
+ $(F77) $(FFLAG90) -c Grid_ESMFCreate.f
+
+StartTimeGet_ESMF.o: StartTimeGet_ESMF.f
+ $(F77) $(FFLAG90) -c StartTimeGet_ESMF.f
+
+Ensemble_sub.o: Ensemble_sub.f
+ $(F77) $(FFLAG90) -c Ensemble_sub.f
+
+mpi_more.o: mpi_more.f
+ $(F77) $(FFLAGS) -c mpi_more.f
+
+cmp.comm.o: cmp.comm.f
+ $(F77) $(FFLAGS) -c cmp.comm.f
+
+atm.comm.o: atm.comm.f
+ $(F77) $(FFLAGS) -c atm.comm.f
+
+tiles.o: tiles.f
+ $(F77) $(FFLAGS) -c tiles.f
+
+#GEFS_Cpl_InternalState_ESMFMod.o: GEFS_Cpl_InternalState_ESMFMod.f
+# $(F77) $(FFLAG90) -c GEFS_Cpl_InternalState_ESMFMod.f
+GEFS_Cpl_InternalState.o: GEFS_Cpl_InternalState.f
+ $(F77) $(FFLAG90) -c GEFS_Cpl_InternalState.f
+
+GEFS_CplState_ESMFMod.o: GEFS_CplState_ESMFMod.f
+ $(F77) $(FFLAG90) -c GEFS_CplState_ESMFMod.f
+
+GEFS_Sto_Per_Scheme.o: GEFS_Sto_Per_Scheme.f
+ $(F77) $(FFLAG90) -c GEFS_Sto_Per_Scheme.f
+
+GEFS_Cpl_Run_ESMFMod.o: GEFS_Cpl_Run_ESMFMod.f
+ $(F77) $(FFLAG90) -c GEFS_Cpl_Run_ESMFMod.f
+
+GEFS_Cpl_ESMFMod.o: GEFS_Cpl_ESMFMod.f
+ $(F77) $(FFLAG90) -c GEFS_Cpl_ESMFMod.f
+
+GEFS_CplComp_ESMFMod.o: GEFS_CplComp_ESMFMod.f
+ $(F77) $(FFLAG90) -c GEFS_CplComp_ESMFMod.f
+
+GFS_AddParameterToStateMod.o: GFS_AddParameterToStateMod.f
+ $(F77) $(FFLAG90) -c GFS_AddParameterToStateMod.f
+
+GEFS_Sto_Per_Scheme_Step1.o: GEFS_Sto_Per_Scheme_Step1.f
+ $(F77) $(FFLAG90) -c GEFS_Sto_Per_Scheme_Step1.f
+
+GEFS_Sto_Per_Scheme_Step2.o: GEFS_Sto_Per_Scheme_Step2.f
+ $(F77) $(FFLAG90) -c GEFS_Sto_Per_Scheme_Step2.f
+
+GEFS_GetParameterFromStateMod.o: GEFS_GetParameterFromStateMod.f
+ $(F77) $(FFLAG90) -c GEFS_GetParameterFromStateMod.f
+
+Cal_Sto_Coef.o: GEFS_Cpl_Cal_Sto_Coef.fd/Cal_Sto_Coef.f90
+ $(F90) $(FFLAG90) -c GEFS_Cpl_Cal_Sto_Coef.fd/Cal_Sto_Coef.f90
+
+GEFS_bcst_global.o: GEFS_bcst_global.f
+ $(F77) $(FFLAG90) -c GEFS_bcst_global.f
Property changes on: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/Makefile.jet
___________________________________________________________________
Added: svn:executable
+ *
Modified: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/dotstep.f
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/dotstep.f 2012-05-10 23:36:12 UTC (rev 1894)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/dotstep.f 2012-05-10 23:40:46 UTC (rev 1895)
@@ -3,7 +3,7 @@
!
!=========================================================================
SUBROUTINE do_tstep_gfs(sfc_mpas,air_mpas,dt_mpas,
- & kdt_mpas,fhour_mpas,date_mpas,levs_mpas,
+ & kdt_mpas,fhour_mpas,idate_mpas,levs_mpas,
& ncell_mpas,nsfc_mpas,nair_mpas,xlat_mpas,
& xlon_mpas,nodes_mpas,node0_mpas,nlunit_mpas,
& gfs_namelist_mpas)
@@ -27,10 +27,10 @@
use Sfc_Flx_ESMFMod
use Nst_Var_ESMFMod
use d3d_def
+ use gfsmisc_def
use cmp_comm , only : Coupler_id
use GFS_Initialize_module
- use gfs_internalstate_module
!---------------------------------------------------------------------
IMPLICIT NONE
@@ -38,39 +38,18 @@
TYPE(Sfc_Var_Data) :: sfc_fld
TYPE(Flx_Var_Data) :: flx_fld
TYPE(Nst_Var_Data) :: nst_fld
- TYPE(GFS_InternalState), POINTER :: gis ! the internal state pointer.
!!
- real, parameter:: rlapse=0.65e-2, omz1=10.0
- integer :: IERR,I,J,K,L,LOCL,N,kdt
- integer :: iprint
+!! real(kind_phys), parameter :: pi=3.1415926535897931
+ integer :: IERR,I,J,K,L,LOCL,N
real*8 :: dt_warm, tem1, tem2
- real(kind=kind_evod) :: deltim,phour,zhour
- real(kind=kind_evod) :: slag,sdec,cdec,batah
- real(kind=kind_phys) :: pdryini
- logical :: lsout
-
- integer, allocatable :: lonsperlar(:)
- integer, allocatable :: jindx1(:),jindx2(:)
- real, allocatable :: ozplin(:,:,:,:) !OZONE PL Coeff
-
- real (kind=kind_rad), allocatable ::
- & xlat(:,:), xlon(:,:),
- & coszdg(:,:), hprime(:,:,:),
- & fluxr(:,:,:), sfalb(:,:), swh(:,:,:), hlw(:,:,:)
- real (kind=kind_phys), allocatable ::
- & phy_f3d(:,:,:,:), phy_f2d(:,:,:), ddy(:), fscav(:)
- real(kind=kind_evod), allocatable ::
- & global_times_b(:,:), global_times_r(:,:)
-
integer ifirst
data ifirst /1/
save ifirst
-
!-----mpas related fileds--------
integer(kind=kind_io4) :: kdt_mpas,levs_mpas,ncell_mpas,
& nodes_mpas,node0_mpas,nlunit_mpas,nsfc_mpas,nair_mpas
- integer(kind=kind_io4) :: date_mpas(4)
+ integer(kind=kind_io4) :: idate_mpas(4)
character(len=*) :: gfs_namelist_mpas
real(kind=kind_phys) :: dt_mpas,fhour_mpas
@@ -78,52 +57,63 @@
real(kind=kind_phys) :: xlon_mpas(ncell_mpas)
real(kind=kind_phys) :: sfc_mpas(nsfc_mpas,ncell_mpas)
real(kind=kind_phys) :: air_mpas(nair_mpas,ncell_mpas,levs_mpas)
+
+! --mp_pi : model interface level pressure in centibar
+! --mp_pl : model integer layer pressure in centibar
+! --mp_u : model layer zonal wind m/s
+! --mp_v : model layer meridional wind m/s
+! --mp_w : model layer vertical velocity in centibar/sec
+! --mp_t : model layer temperature in K
+! --mp_q : model layer specific humidity in gm/gm
+! --mp_tr : model layer tracer (ozne and cloud water) mass mixing ratio
+ real (kind=kind_phys), allocatable :: mp_pi(:,:,:), mp_pl(:,:,:),
+ & mp_u(:,:,:),mp_v(:,:,:),mp_w(:,:,:),
+ & mp_t(:,:,:),mp_q(:,:,:), mp_tr(:,:,:,:)
!-----mpas related fileds--------
!****************************************************************************
- INTEGER :: INDLSEV,JBASEV, INDLSOD,JBASOD
- include 'function2'
-!
-!
-!------------------------------------------------------------
+
!--at initial time to allocate GFS-related model arrays,
!--to read in GFS namelist file and set up running parameters,
!--and to read in most static boundary conditions.
-
- lats_node_r=1 !for MPAS use 1-D block for each node
- kdt=kdt_mpas
- nodes=nodes_mpas
- me=node0_mpas
- fhour=fhour_mpas
- phour=fhour_mpas
-
if(ifirst > 0) then
+!--GFS initial condition date, 1-hour,2-month,3-day,4-year
+ do j=1,4
+ idate(j)=idate_mpas(j)
+ enddo
+ lats_node_r=1 !for MPAS use 1-D block for each task
+
call GFS_Initialize(node0_mpas,fhour_mpas,levs_mpas,ncell_mpas,
& xlon_mpas,xlat_mpas,lats_node_r,dt_mpas,nlunit_mpas,
- & gfs_namelist_mpas,gis)
+ & gfs_namelist_mpas)
- allocate ( lonsperlar(latr) )
- allocate ( xlon(lonr,lats_node_r),
- & xlat(lonr,lats_node_r),
- & coszdg(lonr,lats_node_r),
- & hprime(lonr,nmtvr,lats_node_r),
- & fluxr(lonr,NFXR,lats_node_r),
- & sfalb(lonr,lats_node_r),
- & swh(lonr,levs,lats_node_r),
- & hlw(lonr,levs,lats_node_r) )
- allocate (
- & phy_f3d(LONR,LEVS,num_p3d,lats_node_r),
- & phy_f2d(lonr,num_p2d,lats_node_r),
- & ddy(lats_node_r), fscav(ntrac-ncld-1) )
-
- allocate ( jindx1(lats_node_r),jindx2(lats_node_r) )
- allocate ( ozplin(latsozp, levozp,pl_coeff,timeoz) )
- allocate ( global_times_b(latr,nodes),
- & global_times_r(latr,nodes) )
-
+ nodes=nodes_mpas
+ me=node0_mpas
+ do j=1,latr
+ do i=1,lonr
+ sinlat_r2(i,j)=sin(xlat_mpas(i))
+ coslat_r2(i,j)=cos(xlat_mpas(i)) !xlat_mpas in radian
+ enddo
+ enddo
ifirst=0
endif
+
+ kdt=kdt_mpas
+ fhour=fhour_mpas
+ phour=fhour_mpas
+
+!-----exchange surface and atmosphere state variables between MPAS and GFS
+ allocate ( mp_pi(lonr,levp1,lats_node_r) )
+ allocate ( mp_pl(lonr,levs,lats_node_r) )
+ allocate ( mp_u(lonr,levs,lats_node_r) )
+ allocate ( mp_v(lonr,levs,lats_node_r) )
+ allocate ( mp_t(lonr,levs,lats_node_r) )
+ allocate ( mp_w(lonr,levs,lats_node_r) )
+ allocate ( mp_q(lonr,levs,lats_node_r) )
+ allocate ( mp_tr(lonr,levs,ntrac-1,lats_node_r) )
+
+
!------------------------------------------------------------
!! if(.not. adiab) then
@@ -183,36 +173,40 @@
if (lsswr .or. lslwr) then ! Radiation Call!
if(.not. adiab) then
- call gloopr
- & (phour,
- & xlon,xlat,coszdg,flx_fld%coszen,
- & sfc_fld%slmsk,sfc_fld%sheleg,sfc_fld%SNCOVR,
- & sfc_fld%SNOALB,sfc_fld%ZORL,sfc_fld%TSEA,
- & HPRIME,SFALB,sfc_fld%ALVSF,sfc_fld%ALNSF,
- & sfc_fld%ALVWF,sfc_fld%ALNWF,sfc_fld%FACSF,
- & sfc_fld%FACWF,sfc_fld%CV,sfc_fld%CVT ,
- & sfc_fld%CVB,SWH,HLW,flx_fld%SFCNSW,flx_fld%SFCDLW,
- & sfc_fld%FICE,sfc_fld%TISFC,flx_fld%SFCDSW,
- & flx_fld%sfcemis, ! yth 4/09
- & flx_fld%TSFLW,FLUXR,phy_f3d,SLAG,SDEC,CDEC,KDT,
- & global_times_r)
- endif ! second if.not.adiab
+ call gloopr
+!---input
+ & (phour,kdt,lonsperlar,global_lats_r,xlon,xlat,
+ & sfc_fld%slmsk,sfc_fld%sheleg,
+ & sfc_fld%zorl, sfc_fld%tsea,
+ & sfc_fld%alvsf, sfc_fld%alnsf, sfc_fld%alvwf,
+ & sfc_fld%alnwf, sfc_fld%facsf, sfc_fld%facwf,
+ & sfc_fld%cv, sfc_fld%cvt, sfc_fld%cvb, sfc_fld%FICE,
+ & sfc_fld%tisfc, sfc_fld%sncovr, sfc_fld%snoalb,
+ & hprime,phy_f3d,
+ & mp_pi,mp_pl,mp_t,mp_q,mp_w,mp_tr,
+!--in and out
+ & fluxr,
+!--output
+ & swh,hlw,
+ & coszdg, flx_fld%coszen, flx_fld%sfcnsw,
+ & flx_fld%sfcdlw, flx_fld%tsflw,
+ & flx_fld%sfcdsw, sfalb, flx_fld%sfcemis,
+ & slag,sdec,cdec)
+ endif
endif !sswr .or. lslwr
-!set to zero for every timestep
- global_times_b = 0.0
-
if(.not. adiab) then
call gloopb
- & (lonsperlar,
- & deltim,phour,sfc_fld, flx_fld, nst_fld, SFALB,
- & xlon,
+ & (phour,kdt,deltim,lonsperlar,global_lats_r,
+ & lsout,fscav,xlon,xlat,
+ & sfc_fld, flx_fld, nst_fld, sfalb,
& swh,hlw,hprime,slag,sdec,cdec,
- & ozplin,jindx1,jindx2,ddy,pdryini,
- & phy_f3d, phy_f2d, gis%xlat,kdt,
- & global_times_b,batah,lsout,fscav)
- endif ! not.adiab
+ & ozplin,jindx1,jindx2,ddy,
+ & phy_f3d, phy_f2d,
+ & mp_pi,mp_pl,mp_t,mp_q,mp_u,
+ & mp_v,mp_w,mp_tr)
+ endif
!
IF (mod(kdt,nszer) == 0 .and. lsout) THEN
@@ -227,5 +221,8 @@
ENDIF
!
+ deallocate (mp_pi,mp_pl,mp_t,mp_u,mp_v,mp_w)
+ deallocate (mp_q,mp_tr)
+
RETURN
END
Deleted: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/dotstep_tracers.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/dotstep_tracers.f_gfs 2012-05-10 23:36:12 UTC (rev 1894)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/dotstep_tracers.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -1,1073 +0,0 @@
- SUBROUTINE do_tstep(deltim,kdt,PHOUR,
- & TRIE_LS,TRIO_LS,
- & LS_NODE,LS_NODES,MAX_LS_NODES,
- & LATS_NODES_A,GLOBAL_LATS_A,
- & LONSPERLAT,
- & LATS_NODES_R,GLOBAL_LATS_R,
- & LONSPERLAR,
-! & LATS_NODES_EXT,GLOBAL_LATS_EXT,
- & EPSE,EPSO,EPSEDN,EPSODN,
- & SNNP1EV,SNNP1OD,NDEXEV,NDEXOD,
- & PLNEV_A,PLNOD_A,PDDEV_A,PDDOD_A,
- & PLNEW_A,PLNOW_A,
- & PLNEV_R,PLNOD_R,PDDEV_R,PDDOD_R,
- & PLNEW_R,PLNOW_R,
- & SYN_LS_A,DYN_LS_A,
-! & SYN_GR_A_1,DYN_GR_A_1,ANL_GR_A_1,
-! & SYN_GR_A_2,DYN_GR_A_2,ANL_GR_A_2,
- & XLON,XLAT,COSZDG, sfc_fld, flx_fld, nst_fld,
- & HPRIME,SWH,HLW,FLUXR,SFALB,SLAG,SDEC,CDEC,
- & OZPLIN,JINDX1,JINDX2,DDY,PDRYINI,
- & phy_f3d, phy_f2d,
- & ZHOUR,N1,N4,LSOUT,COLAT1,CFHOUR1,SPS,fscav)
-!!
-#include "f_hpm.h"
- use machine , only : kind_evod,kind_phys,kind_rad
- use resol_def , only : latg,latg2,latr,latr2,levh,levs,
- & lonr,lotd,lots,lsoil,nfxr,nmtvr,
- & ntoz,ntrac,ncld,num_p2d,num_p3d,
- & p_di,p_dim,p_q,p_qm,p_rm,p_rq,
- & p_rt,p_te,p_tem,p_uln,p_vln,
- & p_w,p_x,p_y,p_ze,p_zem,p_zq,lonf
- use layout1 , only : ipt_lats_node_r,lats_node_r,
- & len_trie_ls,len_trio_ls,
- & ls_dim,ls_max_node,
- & me,me_l_0,nodes,lats_dim_a,
- . ipt_lats_node_a,lats_node_a
- use vert_def , only : am,bm,si,sl,sv,tov
- use date_def , only : fhour,idate,shour,spdmax
- use namelist_def , only : adiab,ens_nam,fhcyc,filta,
- & gen_coord_hybrid,gg_tracers,
- & hybrid, igen,explicit,mom4ice,
- & ldiag3d,lsfwd,lslwr,lsswr,
- & lggfs3d,fhgoc3d,ialb,nst_fcst,
- & ngptc,nscyc,nsres,nszer,semilag,
- & sl_epsln
- use mpi_def , only : icolor,kind_mpi,liope,
- & mc_comp,mpi_r_mpi
- use ozne_def , only : latsozp,levozp,pl_coeff,timeoz
-
- use layout_grid_tracers , only : rg1_a,rg2_a,rg3_a
-
-
- use Sfc_Flx_ESMFMod
- use Nst_Var_ESMFMod
- use d3d_def
-
- use cmp_comm , only : Coupler_id
-
- IMPLICIT NONE
-!!
- TYPE(Sfc_Var_Data) :: sfc_fld
- TYPE(Flx_Var_Data) :: flx_fld
- TYPE(Nst_Var_Data) :: nst_fld
- integer lat
- CHARACTER(16) :: CFHOUR1
- INTEGER,INTENT(IN) :: LONSPERLAT(LATG),N1,N4
-!!
- REAL(KIND=KIND_EVOD),INTENT(IN) :: deltim,PHOUR
- REAL(KIND=KIND_EVOD),INTENT(INOUT) :: ZHOUR
-
- integer ifirst
- data ifirst /1/
- save ifirst
-!
- real, allocatable :: gzie_ln(:,:),gzio_ln(:,:),factor_b2t_ref(:)
- save gzie_ln,gzio_ln,factor_b2t_ref
-
- REAL(KIND=KIND_EVOD) TRIE_LS(LEN_TRIE_LS,2,11*LEVS+3*LEVH+6)
- REAL(KIND=KIND_EVOD) TRIO_LS(LEN_TRIO_LS,2,11*LEVS+3*LEVH+6)
-!!
- integer ls_node(ls_dim,3)
-!!
-! ls_node(1,1) ... ls_node(ls_max_node,1) : values of L
-! ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
-! ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
-!!
- INTEGER LS_NODES(LS_DIM,NODES)
- INTEGER MAX_LS_NODES(NODES)
- INTEGER LATS_NODES_A(NODES)
-! INTEGER LATS_NODES_EXT(NODES)
- INTEGER GLOBAL_LATS_A(LATG)
-! INTEGER GLOBAL_LATS_EXT(LATG+2*JINTMX+2*NYPT*(NODES-1))
- INTEGER LATS_NODES_R(NODES)
- INTEGER GLOBAL_LATS_R(LATR)
- INTEGER LONSPERLAR(LATR)
-!
- integer lats_nodes_r_old(nodes)
- integer global_lats_r_old(latr)
- logical ifshuff
-!
- real(kind=kind_evod) colat1
- REAL(KIND=KIND_EVOD) EPSE(LEN_TRIE_LS)
- REAL(KIND=KIND_EVOD) EPSO(LEN_TRIO_LS)
- REAL(KIND=KIND_EVOD) EPSEDN(LEN_TRIE_LS)
- REAL(KIND=KIND_EVOD) EPSODN(LEN_TRIO_LS)
- REAL(KIND=KIND_EVOD) SNNP1EV(LEN_TRIE_LS)
- REAL(KIND=KIND_EVOD) SNNP1OD(LEN_TRIO_LS)
- INTEGER NDEXEV(LEN_TRIE_LS)
- INTEGER NDEXOD(LEN_TRIO_LS)
- REAL(KIND=KIND_EVOD) PLNEV_A(LEN_TRIE_LS,LATG2)
- REAL(KIND=KIND_EVOD) PLNOD_A(LEN_TRIO_LS,LATG2)
- REAL(KIND=KIND_EVOD) PDDEV_A(LEN_TRIE_LS,LATG2)
- REAL(KIND=KIND_EVOD) PDDOD_A(LEN_TRIO_LS,LATG2)
- REAL(KIND=KIND_EVOD) PLNEW_A(LEN_TRIE_LS,LATG2)
- REAL(KIND=KIND_EVOD) PLNOW_A(LEN_TRIO_LS,LATG2)
- REAL(KIND=KIND_EVOD) PLNEV_R(LEN_TRIE_LS,LATR2)
- REAL(KIND=KIND_EVOD) PLNOD_R(LEN_TRIO_LS,LATR2)
- REAL(KIND=KIND_EVOD) PDDEV_R(LEN_TRIE_LS,LATR2)
- REAL(KIND=KIND_EVOD) PDDOD_R(LEN_TRIO_LS,LATR2)
- REAL(KIND=KIND_EVOD) PLNEW_R(LEN_TRIE_LS,LATR2)
- REAL(KIND=KIND_EVOD) PLNOW_R(LEN_TRIO_LS,LATR2)
- REAL(KIND=KIND_EVOD) SYN_LS_A(4*LS_DIM,LOTS,LATG2)
- REAL(KIND=KIND_EVOD) DYN_LS_A(4*LS_DIM,LOTD,LATG2)
-
-! REAL(KIND=KIND_EVOD) SYN_GR_A_1(LONFX*LOTS,LATS_DIM_EXT)
-! REAL(KIND=KIND_EVOD) DYN_GR_A_1(LONFX*LOTD,LATS_DIM_EXT)
-! REAL(KIND=KIND_EVOD) ANL_GR_A_1(LONFX*LOTA,LATS_DIM_EXT)
-! REAL(KIND=KIND_EVOD) SYN_GR_A_2(LONFX*LOTS,LATS_DIM_EXT)
-! REAL(KIND=KIND_EVOD) DYN_GR_A_2(LONFX*LOTD,LATS_DIM_EXT)
-! REAL(KIND=KIND_EVOD) ANL_GR_A_2(LONFX*LOTA,LATS_DIM_EXT)
-!!
- REAL (KIND=KIND_RAD) XLON(LONR,LATS_NODE_R),
- & XLAT(LONR,LATS_NODE_R),
- & COSZDG(LONR,LATS_NODE_R),
- & HPRIME(LONR,NMTVR,LATS_NODE_R),
- & FLUXR(LONR,nfxr,LATS_NODE_R),
- & SFALB(LONR,LATS_NODE_R),
- & SWH(LONR,LEVS,LATS_NODE_R),
- & HLW(LONR,LEVS,LATS_NODE_R)
-
- REAL (kind=kind_phys)
- & phy_f3d(LONR,LEVS,num_p3d,lats_node_r),
- & phy_f2d(lonr,num_p2d,lats_node_r),
-!
- & DDY(LATS_NODE_R), fscav(ntrac-ncld-1)
-
- INTEGER JINDX1(LATS_NODE_R),JINDX2(LATS_NODE_R)
-!!
- INTEGER LEV,LEVMAX
- REAL OZPLIN(LATSOZP,LEVOZP,pl_coeff,timeoz) !OZONE PL Coeff
- REAL (KIND=KIND_PHYS) PDRYINI
- REAL(KIND=KIND_EVOD) SLAG,SDEC,CDEC
-!
-!****************************************************************************
-!$$$ INTEGER P_GZ,P_ZEM,P_DIM,P_TEM,P_RM,P_QM
-!$$$ INTEGER P_ZE,P_DI,P_TE,P_RQ,P_Q,P_DLAM,P_DPHI,P_ULN,P_VLN
-!$$$ INTEGER P_W,P_X,P_Y,P_RT,P_ZQ
-!$$$ PARAMETER(P_GZ = 0*LEVS+0*LEVH+1, ! GZE/O(LNTE/OD,2),
-!$$$ X P_ZEM = 0*LEVS+0*LEVH+2, ! ZEME/O(LNTE/OD,2,LEVS),
-!$$$ X P_DIM = 1*LEVS+0*LEVH+2, ! DIME/O(LNTE/OD,2,LEVS),
-!$$$ X P_TEM = 2*LEVS+0*LEVH+2, ! TEME/O(LNTE/OD,2,LEVS),
-!$$$ X P_RM = 3*LEVS+0*LEVH+2, ! RME/O(LNTE/OD,2,LEVH),
-!$$$ X P_QM = 3*LEVS+1*LEVH+2, ! QME/O(LNTE/OD,2),
-!$$$ X P_ZE = 3*LEVS+1*LEVH+3, ! ZEE/O(LNTE/OD,2,LEVS),
-!$$$ X P_DI = 4*LEVS+1*LEVH+3, ! DIE/O(LNTE/OD,2,LEVS),
-!$$$ X P_TE = 5*LEVS+1*LEVH+3, ! TEE/O(LNTE/OD,2,LEVS),
-!$$$ X P_RQ = 6*LEVS+1*LEVH+3, ! RQE/O(LNTE/OD,2,LEVH),
-!$$$ X P_Q = 6*LEVS+2*LEVH+3, ! QE/O(LNTE/OD,2),
-!$$$ X P_DLAM= 6*LEVS+2*LEVH+4, ! DPDLAME/O(LNTE/OD,2),
-!$$$ X P_DPHI= 6*LEVS+2*LEVH+5, ! DPDPHIE/O(LNTE/OD,2),
-!$$$ X P_ULN = 6*LEVS+2*LEVH+6, ! ULNE/O(LNTE/OD,2,LEVS),
-!$$$ X P_VLN = 7*LEVS+2*LEVH+6, ! VLNE/O(LNTE/OD,2,LEVS),
-!$$$ X P_W = 8*LEVS+2*LEVH+6, ! WE/O(LNTE/OD,2,LEVS),
-!$$$ X P_X = 9*LEVS+2*LEVH+6, ! XE/O(LNTE/OD,2,LEVS),
-!$$$ X P_Y =10*LEVS+2*LEVH+6, ! YE/O(LNTE/OD,2,LEVS),
-!$$$ X P_RT =11*LEVS+2*LEVH+6, ! RTE/O(LNTE/OD,2,LEVH),
-!$$$ X P_ZQ =11*LEVS+3*LEVH+6) ! ZQE/O(LNTE/OD,2)
-!****************************************************************************
- INTEGER kdt, IERR,J,K,L,LOCL,N
- real(kind=kind_evod) batah
- REAL(KIND=kind_mpi) coef00m(LEVS,ntrac)! temp. ozone clwater
- REAL(KIND=kind_evod) coef00(LEVS,ntrac) ! temp. ozone clwater
- INTEGER INDLSEV,JBASEV
- INTEGER INDLSOD,JBASOD
- integer iprint
- include 'function2'
-
- LOGICAL LSOUT, SPS
-!
- real, PARAMETER:: RLAPSE=0.65E-2, omz1=10.0
-!
-! timings
- real(kind=kind_evod) global_times_a(latg,nodes)
- &, global_times_b(latr,nodes)
- &, global_times_r(latr,nodes)
- integer tag,ireq1,ireq2,i
- real*8 rtc ,timer1,timer2,dt_warm, tem1, tem2
-!
-! if(ifirst == 1)then
-! allocate ( factor_b2t_ref(levs), gzie_ln(len_trie_ls,2),
-! & gzio_ln(len_trio_ls,2) )
-! ifirst=0
-! endif
-!
- SHOUR = SHOUR + deltim
-
-!-> Coupling insertion
- call ATM_DBG2(kdt,PHOUR,ZHOUR,SHOUR,3)
- CALL ATM_TSTEP_INIT(kdt)
-!<- Coupling insertion
-
- if (.NOT. LIOPE .or. icolor.ne.2) then
-!
-! print *,' in do tstep SEMILAG=',semilag,' kdt=',kdt
-
- if (semilag) then ! Joe Sela's Semi-Lagrangian Code
-
-! batah = 0.
-! batah = 1. ! Commented by Moorthi 11/23/2010
- batah = 1.0 + sl_epsln ! Moorthi
-
- if(ifirst == 1) then
- allocate ( factor_b2t_ref(levs), gzie_ln(len_trie_ls,2),
- & gzio_ln(len_trio_ls,2) )
- call get_cd_hyb_slg(deltim,batah)
-
- CALL deldifs(
- . TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
- X TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
- X TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1), ! hmhj
- X TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
- X TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
- X TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1), ! hmhj
- X deltim,SL,LS_NODE,coef00,0,hybrid, ! hmhj
- & gen_coord_hybrid)
-
- ifirst=0
- endif
-! if(kdt < 24) print*,'entering dotstep deltim=', deltim,
-! & ' kdt=',kdt
- global_times_a = 0.
- timer1 = rtc()
- call gloopa_hyb_slg
- & (deltim,trie_ls,trio_ls,gzie_ln,gzio_ln,
- & ls_node,ls_nodes,max_ls_nodes,
- & lats_nodes_a,global_lats_a,
- & lonsperlat,
- & epse,epso,epsedn,epsodn,
- & snnp1ev,snnp1od,ndexev,ndexod,
- & plnev_a,plnod_a,pddev_a,pddod_a,plnew_a,plnow_a,
- & global_times_a,kdt,batah,lsout)
- timer2 = rtc()
-
-! if (kdt.lt.4)then
-! print*,' gloopa timer = ',timer2-timer1,' kdt=',kdt
-! endif
-
- if(.not. adiab) then ! first if.not.adiab
- if (nscyc > 0 .and. mod(kdt,nscyc) == 1) then
-! if (me == 0) print*,' calling gcycle at kdt=',kdt
- CALL gcycle(me,LATS_NODE_R,LONSPERLAR,global_lats_r,
- & ipt_lats_node_r,idate,fhour,fhcyc,
- & XLON ,XLAT , sfc_fld, ialb)
- endif
-!
- if (num_p3d == 3) then ! Ferrier Microphysics initialization
- call init_micro(deltim,lonr,levs,num_p3d,lats_node_r,
- & phy_f3d(1,1,1,1), fhour, me)
- endif
- endif ! first if.not.adiab
-
-!
-!-> Coupling insertion
-
- ! lgetSSTICE_cc must be defined by this moment. It used to be an argument
- ! to ATM_GETSST, accessible here via USE SURFACE_cc. Now it is defined in
- ! ATM_TSTEP_INIT called above, and the USE is removed. (Even in the earlier
- ! version lgetSSTICE_cc did not have to be an actual argumnent, since
- ! it is in the module SURFACE_cc USEd by ATM_GETSST.)
-
- call ATM_GETSSTICE(sfc_fld%TSEA,sfc_fld%TISFC,sfc_fld%FICE,
- & sfc_fld%HICE,sfc_fld%SHELEG,sfc_fld%SLMSK,
- & sfc_fld%ORO,kdt)
-
-!<- Coupling insertion
-
-!
- if (nst_fcst > 1) then ! update TSEA
- if (Coupler_id < 0 .or. .not. mom4ice) then ! Standalone mode
- do j = 1, lats_node_r
- do i = 1, lonr
- if (sfc_fld%slmsk(i,j) == 0 ) then
- dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j))
- & / nst_fld%xz(i,j)
- sfc_fld%TSEA(i,j) = nst_fld%tref(i,j)
- & + dt_warm - nst_fld%dt_cool(i,j)
- & - sfc_fld%oro(i,j)*rlapse
- endif
- enddo
- enddo
- else ! Coupled to MOM4 OM
- tem1 = 0.5 / omz1
- do j = 1, lats_node_r
- do i = 1, lonr
- if (sfc_fld%slmsk(i,j) == 0 ) then
- tem2 = 1.0 / nst_fld%xz(i,j)
- sfc_fld%tsea(i,j) = sfc_fld%tsea(i,j)
- & + sfc_fld%oro(i,j)*rlapse
- dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j)) * tem2
-
- if ( nst_fld%xz(i,j) > omz1) then
- nst_fld%tref(i,j) = sfc_fld%tsea(i,j)
- & - (1.0-0.5*omz1*tem2) * dt_warm
- & + nst_fld%z_c(i,j)*nst_fld%dt_cool(i,j)*tem1
- else
- nst_fld%tref(i,j) = sfc_fld%tsea(i,j)
- & - (nst_fld%xz(i,j)*dt_warm
- & - nst_fld%z_c(i,j)*nst_fld%dt_cool(i,j))*tem1
- endif
- sfc_fld%TSEA(i,j) = nst_fld%tref(i,j)
- & + dt_warm - nst_fld%dt_cool(i,j)
- & - sfc_fld%oro(i,j)*rlapse
- endif
- enddo
- enddo
- endif
- endif
-
- global_times_r = 0.0
-
- if (lsswr .or. lslwr) then ! radiation call!
- if(.not. adiab) then ! second if.not.adiab
- call gloopr
- & (trie_ls,trio_ls,
- & ls_node,ls_nodes,max_ls_nodes,
- & lats_nodes_a,global_lats_a,
- & lats_nodes_r,global_lats_r,
- & lonsperlar,
- & epse,epso,epsedn,epsodn,
- & snnp1ev,snnp1od,plnev_r,plnod_r,
- & pddev_r,pddod_r,
- & phour,
- & xlon,xlat,coszdg,flx_fld%coszen,
- & sfc_fld%slmsk,sfc_fld%sheleg,sfc_fld%SNCOVR,
- & sfc_fld%SNOALB,sfc_fld%ZORL,sfc_fld%TSEA,
- & HPRIME,SFALB,sfc_fld%ALVSF,sfc_fld%ALNSF,
- & sfc_fld%ALVWF,sfc_fld%ALNWF,sfc_fld%FACSF,
- & sfc_fld%FACWF,sfc_fld%CV,sfc_fld%CVT ,
- & sfc_fld%CVB,SWH,HLW,flx_fld%SFCNSW,flx_fld%SFCDLW,
- & sfc_fld%FICE,sfc_fld%TISFC,flx_fld%SFCDSW,
- & flx_fld%sfcemis, ! yth 4/09
- & flx_fld%TSFLW,FLUXR,phy_f3d,SLAG,SDEC,CDEC,KDT,
- & global_times_r)
-! if (iprint == 1) print*,' me = fin gloopr ',me
- endif ! second if.not.adiab
- endif !sswr .or. lslwr
-
-! if (iprint .eq. 1) print*,' me = beg gloopb ',me
-! if(kdt < 4)then
-! print*,' deltim in if(kdt.lt.4)=',deltim
-! endif
-
-!$omp parallel do private(locl)
- do locl=1,ls_max_node
- call sicdife_hyb_slg(trie_ls(1,1,p_x ), trie_ls(1,1,p_y ),
- x trie_ls(1,1,p_zq ), deltim/2.,
- x trie_ls(1,1,p_uln), trie_ls(1,1,p_vln),
- x ls_node,snnp1ev,ndexev,locl,batah)
- call sicdifo_hyb_slg(trio_ls(1,1,p_x ), trio_ls(1,1,p_y ),
- x trio_ls(1,1,p_zq ), deltim/2.,
- x trio_ls(1,1,p_uln), trio_ls(1,1,p_vln),
- x ls_node,snnp1od,ndexod,locl,batah)
- enddo
- do j=1,len_trie_ls
- trie_ls(j,1,p_zq ) = trie_ls(j,1,p_zq)-gzie_ln(j,1)
- trie_ls(j,2,p_zq ) = trie_ls(j,2,p_zq)-gzie_ln(j,2)
- enddo
- do j=1,len_trio_ls
- trio_ls(j,1,p_zq ) = trio_ls(j,1,p_zq)-gzio_ln(j,1)
- trio_ls(j,2,p_zq ) = trio_ls(j,2,p_zq)-gzio_ln(j,2)
- enddo
-!save n-1 values for diffusion, not really part of samilag scheme
- do j=1,len_trie_ls
- trie_ls(j,1,p_qm ) = trie_ls(j,1,p_zq)
- trie_ls(j,2,p_qm ) = trie_ls(j,2,p_zq)
- enddo
- do j=1,len_trio_ls
- trio_ls(j,1,p_qm ) = trio_ls(j,1,p_zq)
- trio_ls(j,2,p_qm ) = trio_ls(j,2,p_zq)
- enddo
-
- do k=1,levs
- do j=1,len_trie_ls
- trie_ls(j,1,p_tem+k-1) = trie_ls(j,1,p_y+k-1)
- trie_ls(j,2,p_tem+k-1) = trie_ls(j,2,p_y+k-1)
- enddo
- enddo
- do k=1,levs
- do j=1,len_trio_ls
- trio_ls(j,1,p_tem+k-1) = trio_ls(j,1,p_y+k-1)
- trio_ls(j,2,p_tem+k-1) = trio_ls(j,2,p_y+k-1)
- enddo
- enddo
-!--------------------------------------------------------
- coef00(:,:) = 0.0
- IF ( ME .EQ. ME_L_0 ) THEN
- DO LOCL=1,LS_MAX_NODE
- l = ls_node(locl,1)
- jbasev = ls_node(locl,2)
- IF ( L == 0 ) THEN
- N = 0
-! 1 Corresponds to temperature, 2 corresponds to ozon, 3 to clwater
- DO K=1,LEVS
- coef00(K,1) = TRIE_LS(INDLSEV(N,L),1,P_Y +K-1)
- if (ntoz .gt. 1 .and. ! hmhj
- & .not. (hybrid.or.gen_coord_hybrid)) then ! hmhj
- coef00(K,ntoz) = TRIE_LS(INDLSEV(N,L),1,
- & (ntoz-1)*levs+P_rt+K-1)
- endif
- ENDDO
- ENDIF
- END DO
- END IF
-
- coef00m = coef00
- CALL MPI_BCAST(coef00m,levs*ntrac,MPI_R_MPI,ME_L_0,MC_COMP,
- & IERR)
- coef00=coef00m
- if( gen_coord_hybrid ) then ! hmhj
- call updown_gc(sl,coef00(1,1)) ! hmhj
- else ! hmhj
- call updown(sl,coef00(1,1))
- endif ! hmhj
- if (ntoz .gt. 1 .and. .not. (hybrid.or.gen_coord_hybrid)) then ! hmhj
- call updown(sl,coef00(1,ntoz))
- endif
- if (gg_tracers) then
-!$omp parallel do shared(TRIE_LS,TRIO_LS)
-!$omp+shared(deltim,SL,LS_NODE,coef00,hybrid)
- do k=1,levs
- CALL deldifs_tracers(
- . TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
- X TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
- X TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1),
- X TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
- X TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
- X TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1),
- X deltim,SL,LS_NODE,coef00,k,hybrid,
- & gen_coord_hybrid)
- enddo
- else
-!
-!$omp parallel do shared(TRIE_LS,TRIO_LS)
-!$omp+shared(deltim,SL,LS_NODE,coef00,hybrid)
- do k=1,levs
- CALL deldifs(
- & TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
- & TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
- & TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1),
- & TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
- & TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
- & TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1),
- & deltim,SL,LS_NODE,coef00,k,hybrid,
- & gen_coord_hybrid)
- enddo
- endif
-!--------------------------------------------------------
- do j=1,len_trie_ls
- trie_ls(j,1,p_q ) = trie_ls(j,1,p_zq)
- trie_ls(j,2,p_q ) = trie_ls(j,2,p_zq)
- enddo
- do j=1,len_trio_ls
- trio_ls(j,1,p_q ) = trio_ls(j,1,p_zq)
- trio_ls(j,2,p_q ) = trio_ls(j,2,p_zq)
- enddo
-! if (iprint .eq. 1) print*,' me = beg gloopb ',me
- timer1 = rtc()
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-! add impadj_slg to gloopb with batah, and set timetsteps to deltim
-! add impadj_slg to gloopb with batah, and set timetsteps to deltim
-! add impadj_slg to gloopb with batah, and set timetsteps to deltim
-! add impadj_slg to gloopb with batah, and set timetsteps to deltim
-! add impadj_slg to gloopb with batah, and set timetsteps to deltim
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
- global_times_b = 0.0
- if(.not. adiab) then ! third if.not.adiab
- call gloopb
- & (trie_ls,trio_ls,
- & ls_node,ls_nodes,max_ls_nodes,
- & lats_nodes_a,global_lats_a,
- & lats_nodes_r,global_lats_r,
- & lonsperlar,
- & epse,epso,epsedn,epsodn,
- & snnp1ev,snnp1od,ndexev,ndexod,
- & plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r,
- & deltim,phour,sfc_fld, flx_fld, nst_fld, SFALB,
- & xlon,
- & swh,hlw,hprime,slag,sdec,cdec,
- & ozplin,jindx1,jindx2,ddy,pdryini,
- & phy_f3d, phy_f2d, xlat,kdt,
- & global_times_b,batah,lsout,fscav)
- endif ! third if.not.adiab
-
-!!$omp parallel do shared(trie_ls,ndexev,trio_ls,ndexod)
-!!$omp+shared(sl,spdmax,deltim,ls_node)
-! do k=1,levs
-!sela call damp_speed(trie_ls(1,1,p_x+k-1), trie_ls(1,1,p_w +k-1),
-!selax trie_ls(1,1,p_y+k-1), trie_ls(1,1,p_rt+k-1),
-!selax ndexev,
-!selax trio_ls(1,1,p_x+k-1), trio_ls(1,1,p_w +k-1),
-!selax trio_ls(1,1,p_y+k-1), trio_ls(1,1,p_rt+k-1),
-!selax ndexod,
-!selax sl,spdmax(k),deltim,ls_node)
-! enddo
-
- do k=1,levs
- do j=1,len_trie_ls
- trie_ls(j,1,p_di+k-1) = trie_ls(j,1,p_x+k-1)
- trie_ls(j,2,p_di+k-1) = trie_ls(j,2,p_x+k-1)
- trie_ls(j,1,p_ze+k-1) = trie_ls(j,1,p_w+k-1)
- trie_ls(j,2,p_ze+k-1) = trie_ls(j,2,p_w+k-1)
- trie_ls(j,1,p_te+k-1) = trie_ls(j,1,p_y+k-1)
- trie_ls(j,2,p_te+k-1) = trie_ls(j,2,p_y+k-1)
- enddo
- enddo
- do k=1,levs
- do j=1,len_trio_ls
- trio_ls(j,1,p_di+k-1) = trio_ls(j,1,p_x+k-1)
- trio_ls(j,2,p_di+k-1) = trio_ls(j,2,p_x+k-1)
- trio_ls(j,1,p_ze+k-1) = trio_ls(j,1,p_w+k-1)
- trio_ls(j,2,p_ze+k-1) = trio_ls(j,2,p_w+k-1)
- trio_ls(j,1,p_te+k-1) = trio_ls(j,1,p_y+k-1)
- trio_ls(j,2,p_te+k-1) = trio_ls(j,2,p_y+k-1)
- enddo
- enddo
- if(.not. gg_tracers)then
- do k=1,levh
- do j=1,len_trie_ls
- trie_ls(j,1,p_rq+k-1) = trie_ls(j,1,p_rt+k-1)
- trie_ls(j,2,p_rq+k-1) = trie_ls(j,2,p_rt+k-1)
- enddo
- enddo
- do k=1,levh
- do j=1,len_trio_ls
- trio_ls(j,1,p_rq+k-1) = trio_ls(j,1,p_rt+k-1)
- trio_ls(j,2,p_rq+k-1) = trio_ls(j,2,p_rt+k-1)
- enddo
- enddo
- endif ! if(.not.gg_tracers)
-!
-!----------------------------------------------------------
- else ! Eulerian Dynamics
-!----------------------------------------------------------
-!!
- if(ifirst == 1) then
- CALL deldifs(
- & TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
- & TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
- & TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1), ! hmhj
- & TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
- & TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
- & TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1), ! hmhj
- & deltim,SL,LS_NODE,coef00,0,hybrid, ! hmhj
- & gen_coord_hybrid)
-
- ifirst=0
- endif
- global_times_a=0.
-
-! print *,' Eulerian dynamics callling GLOOPA for kdt=',kdt
-
- CALL GLOOPA
- & (deltim,TRIE_LS,TRIO_LS,
- & LS_NODE,LS_NODES,MAX_LS_NODES,
- & LATS_NODES_A,GLOBAL_LATS_A,
- & LONSPERLAT,
- & EPSE,EPSO,EPSEDN,EPSODN,
- & SNNP1EV,SNNP1OD,NDEXEV,NDEXOD,
- & PLNEV_A,PLNOD_A,PDDEV_A,PDDOD_A,PLNEW_A,PLNOW_A,
- & global_times_a,kdt)
-
-!
-!
- iprint = 0
-! if (iprint .eq. 1) print*,' fin gloopa kdt = ',kdt
-!
-!my gather lat timings for load balancing
-!sela if (reshuff_lats_a .and. kdt .eq. 5) then
-!sela call redist_lats_a(kdt,global_times_a,
-!selax lats_nodes_a,global_lats_a,
-!selax lonsperlat,
-!selax lats_nodes_ext,global_lats_ext,iprint)
-!sela endif
-!----------------------------------------------------------
-
-!
- if(.not. adiab) then
- if (nscyc > 0 .and. mod(kdt,nscyc) == 1) then
- CALL gcycle(me,LATS_NODE_R,LONSPERLAR,global_lats_r,
- & ipt_lats_node_r,idate,fhour,fhcyc,
- & XLON ,XLAT , sfc_fld, ialb)
- endif
-!
- if (num_p3d == 3) then ! Ferrier Microphysics initialization
- call init_micro(deltim,lonr,levs,num_p3d,lats_node_r,
- & phy_f3d(1,1,1,1), fhour, me)
- endif
- endif
-!
-!-> Coupling insertion
-
- ! lgetSSTICE_cc must be defined by this moment. It used to be an argument
- ! to ATM_GETSST, accessible here via USE SURFACE_cc. Now it is defined in
- ! ATM_TSTEP_INIT called above, and the USE is removed. (Even in the earlier
- ! version lgetSSTICE_cc did not have to be an actual argumnent, since
- ! it is in the module SURFACE_cc USEd by ATM_GETSST.)
-
-! call ATM_GETSST(sfc_fld%TSEA,sfc_fld%SLMSK,sfc_fld%ORO)
- call ATM_GETSSTICE(sfc_fld%TSEA,sfc_fld%TISFC,sfc_fld%FICE,
- & sfc_fld%HICE,sfc_fld%SHELEG,sfc_fld%SLMSK,
- & sfc_fld%ORO,kdt)
-
-!<- Coupling insertion
-
-!
- if (nst_fcst > 1) then ! update TSEA
- if (Coupler_id < 0 .or. .not. mom4ice) then ! Standalone mode
- do j = 1, lats_node_r
- do i = 1, lonr
- if (sfc_fld%slmsk(i,j) == 0 ) then
- dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j))
- & / nst_fld%xz(i,j)
- sfc_fld%TSEA(i,j) = nst_fld%tref(i,j)
- & + dt_warm - nst_fld%dt_cool(i,j)
- & - sfc_fld%oro(i,j)*rlapse
- endif
- enddo
- enddo
- else ! Coupled to MOM4 OM
- tem1 = 0.5 / omz1
- do j = 1, lats_node_r
- do i = 1, lonr
- if (sfc_fld%slmsk(i,j) == 0 ) then
- tem2 = 1.0 / nst_fld%xz(i,j)
- sfc_fld%tsea(i,j) = sfc_fld%tsea(i,j)
- & + sfc_fld%oro(i,j)*rlapse
- dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j)) * tem2
-
- if ( nst_fld%xz(i,j) > omz1) then
- nst_fld%tref(i,j) = sfc_fld%tsea(i,j)
- & - (1.0-0.5*omz1*tem2) * dt_warm
- & + nst_fld%z_c(i,j)*nst_fld%dt_cool(i,j)*tem1
- else
- nst_fld%tref(i,j) = sfc_fld%tsea(i,j)
- & - (nst_fld%xz(i,j)*dt_warm
- & - nst_fld%z_c(i,j)*nst_fld%dt_cool(i,j))*tem1
- endif
- sfc_fld%TSEA(i,j) = nst_fld%tref(i,j)
- & + dt_warm - nst_fld%dt_cool(i,j)
- & - sfc_fld%oro(i,j)*rlapse
- endif
- enddo
- enddo
- endif
- endif
-
-! do j = 1, lats_node_r
-! do i = 1, lonr
-! if (sfc_fld%slmsk(i,j) == 0 ) then
-! dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j))
-! & / nst_fld%xz(i,j)
-! sfc_fld%TSEA(i,j) = sfc_fld%TSEA(i,j)
-! & + dt_warm - nst_fld%dt_cool(i,j)
-! endif
-! enddo
-! enddo
-! endif
-
-
-!sela if (me.eq.0) PRINT*,'COMPLETED GLOOPA IN do_tstep'
-
- global_times_r = 0.0 !my set to zero for every timestep
-
- if (lsswr .or. lslwr) then ! Radiation Call!
- if(.not. adiab) then
-
-! if(.not.adiab .and. kdt > 1) then
-! print *,' before calling GLOOPR kdt=',kdt
-
- call gloopr
- & (trie_ls,trio_ls,
- & ls_node,ls_nodes,max_ls_nodes,
- & lats_nodes_a,global_lats_a,
- & lats_nodes_r,global_lats_r,
- & lonsperlar,
- & epse,epso,epsedn,epsodn,
- & snnp1ev,snnp1od,plnev_r,plnod_r,
- & pddev_r,pddod_r,
- & phour,
- & xlon,xlat,coszdg,flx_fld%coszen,
- & sfc_fld%slmsk,sfc_fld%sheleg,sfc_fld%SNCOVR,
- & sfc_fld%SNOALB,sfc_fld%ZORL,sfc_fld%TSEA,
- & HPRIME,SFALB,sfc_fld%ALVSF,sfc_fld%ALNSF,
- & sfc_fld%ALVWF,sfc_fld%ALNWF,sfc_fld%FACSF,
- & sfc_fld%FACWF,sfc_fld%CV,sfc_fld%CVT ,
- & sfc_fld%CVB,SWH,HLW,flx_fld%SFCNSW,flx_fld%SFCDLW,
- & sfc_fld%FICE,sfc_fld%TISFC,flx_fld%SFCDSW,
- & flx_fld%sfcemis, ! yth 4/09
- & flx_fld%TSFLW,FLUXR,phy_f3d,SLAG,SDEC,CDEC,KDT,
- & global_times_r)
- endif ! second if.not.adiab
- endif !sswr .or. lslwr
-
-! if (me == 0) then
-! print *,' aft gloopr HLW45=',hlw(1,:,45)
-! print *,' aft gloopr SWH45=',swh(1,:,45)
-! endif
-!!
-! print *,' finished GLOOPR at kdt=',kdt
-! call mpi_quit(1111)
-
- if( .not. explicit ) then ! hmhj
-!
- if( gen_coord_hybrid ) then ! hmhj
-
-!$omp parallel do private(locl)
- do locl=1,ls_max_node ! hmhj
- call sicdife_hyb_gc(
- & trie_ls(1,1,P_dim), trie_ls(1,1,P_tem), ! hmhj
- & trie_ls(1,1,P_qm ), trie_ls(1,1,P_x ), ! hmhj
- & trie_ls(1,1,P_y ), trie_ls(1,1,P_zq ), ! hmhj
- & trie_ls(1,1,P_di ), trie_ls(1,1,P_te ), ! hmhj
- & trie_ls(1,1,P_q ),deltim, ! hmhj
- & trie_ls(1,1,P_uln), trie_ls(1,1,P_vln), ! hmhj
- & ls_node,snnp1ev,ndexev,locl) ! hmhj
-
- call sicdifo_hyb_gc(
- & trio_ls(1,1,P_dim), trio_ls(1,1,P_tem), ! hmhj
- & trio_ls(1,1,P_qm ), trio_ls(1,1,P_x ), ! hmhj
- & trio_ls(1,1,P_y ), trio_ls(1,1,P_zq ), ! hmhj
- & trio_ls(1,1,P_di ), trio_ls(1,1,P_te ), ! hmhj
- & trio_ls(1,1,P_q ),deltim, ! hmhj
- & trio_ls(1,1,P_uln), trio_ls(1,1,P_vln), ! hmhj
- & ls_node,snnp1od,ndexod,locl) ! hmhj
- enddo ! hmhj
-
- else if(hybrid)then ! hmhj
-
-! print *,' calling sicdife_hyb at kdt=',kdt
-!$omp parallel do private(locl)
- do locl=1,ls_max_node
- call sicdife_hyb(
- & trie_ls(1,1,P_dim), trie_ls(1,1,P_tem),
- & trie_ls(1,1,P_qm ), trie_ls(1,1,P_x ),
- & trie_ls(1,1,P_y ), trie_ls(1,1,P_zq ),
- & trie_ls(1,1,P_di ), trie_ls(1,1,P_te ),
- & trie_ls(1,1,P_q ),deltim,
- & trie_ls(1,1,P_uln), trie_ls(1,1,P_vln),
- & ls_node,snnp1ev,ndexev,locl)
-
- call sicdifo_hyb(
- & trio_ls(1,1,P_dim), trio_ls(1,1,P_tem),
- & trio_ls(1,1,P_qm ), trio_ls(1,1,P_x ),
- & trio_ls(1,1,P_y ), trio_ls(1,1,P_zq ),
- & trio_ls(1,1,P_di ), trio_ls(1,1,P_te ),
- & trio_ls(1,1,P_q ),deltim,
- & trio_ls(1,1,P_uln), trio_ls(1,1,P_vln),
- & ls_node,snnp1od,ndexod,locl)
- enddo
-
-! print *,' after calling sicdife_hyb at kdt=',kdt
- else ! hybrid
-
-!$omp parallel do private(locl)
- do locl=1,ls_max_node
- CALL SICDIFE_sig(
- & TRIE_LS(1,1,P_DIM), TRIE_LS(1,1,P_TEM),
- & TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X ),
- & TRIE_LS(1,1,P_Y ), TRIE_LS(1,1,P_ZQ ),
- & AM,BM,TOV,SV,deltim,
- & TRIE_LS(1,1,P_ULN), TRIE_LS(1,1,P_VLN),
- & LS_NODE,SNNP1EV,NDEXEV,locl,TRIE_LS(1,1,P_DI))
-
- CALL SICDIFO_sig(
- & TRIO_LS(1,1,P_DIM), TRIO_LS(1,1,P_TEM),
- & TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X ),
- & TRIO_LS(1,1,P_Y ), TRIO_LS(1,1,P_ZQ ),
- & AM,BM,TOV,SV,deltim,
- & TRIO_LS(1,1,P_ULN), TRIO_LS(1,1,P_VLN),
- & LS_NODE,SNNP1OD,NDEXOD,locl,TRIO_LS(1,1,P_DI))
- enddo
- endif ! hybrid
-
- endif ! not explicit ! hmhj
-
-!
-!----------------------------------------------------------
-!sela if (.NOT.LIOPE.or.icolor.ne.2) then
-!sela print*,'liope=',liope,' icolor=',icolor,' after loopa'
-!sela CALL RMS_spect(TRIE_LS(1,1,P_zq ), TRIE_LS(1,1,P_x ),
-!selaX TRIE_LS(1,1,P_y ), TRIE_LS(1,1,P_w ),
-!selaX TRIE_LS(1,1,P_Rt ),
-!selaX TRIO_LS(1,1,P_zq ), TRIO_LS(1,1,P_x ),
-!selaX TRIO_LS(1,1,P_y ), TRIO_LS(1,1,P_w ),
-!selaX TRIO_LS(1,1,P_Rt ),
-!selaX LS_NODES,MAX_LS_NODES)
-!sela endif
-!----------------------------------------------------------
-
-! hmhj compute coef00 for all, even for hybrid mode
-
- coef00(:,:) = 0.0
- IF ( ME .EQ. ME_L_0 ) THEN
- DO LOCL=1,LS_MAX_NODE
- l = ls_node(locl,1)
- jbasev = ls_node(locl,2)
- IF ( L == 0 ) THEN
- N = 0
-! 1 Corresponds to temperature, 2 corresponds to ozone, 3 to cloud condensate
- DO K=1,LEVS
- coef00(K,1) = TRIE_LS(INDLSEV(N,L),1,P_Y +K-1)
-! if (ntoz .gt. 1) then
- if (ntoz .gt. 1 .and. ! hmhj
- & .not. (hybrid.or.gen_coord_hybrid)) then ! hmhj
- coef00(K,ntoz) = TRIE_LS(INDLSEV(N,L),1,
- & (ntoz-1)*levs+P_rt+K-1)
- endif
- ENDDO
- ENDIF
- END DO
- END IF
- coef00m = coef00
- CALL MPI_BCAST(coef00m,levs*ntrac,MPI_R_MPI,ME_L_0,MC_COMP,
- & IERR)
- coef00=coef00m
- if( gen_coord_hybrid ) then ! hmhj
- call updown_gc(sl,coef00(1,1)) ! hmhj
- else ! hmhj
- call updown(sl,coef00(1,1))
- endif ! hmhj
-! if (ntoz > 1) call updown(sl,coef00(1,ntoz))
- if (ntoz > 1 .and. .not. (hybrid.or.gen_coord_hybrid)) then ! hmhj
- call updown(sl,coef00(1,ntoz))
- endif
-
-! print *,' calling deldifs at kdt=',kdt
-!
-!$omp parallel do shared(TRIE_LS,TRIO_LS)
-!$omp+shared(deltim,SL,LS_NODE,coef00,hybrid,gen_coord_hybrid)
- do k=1,levs
- CALL deldifs(TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
- X TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
- X TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1), ! hmhj
- X TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
- X TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
- X TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1), ! hmhj
- X deltim,SL,LS_NODE,coef00,k,hybrid, ! hmhj
- & gen_coord_hybrid) ! hmhj
- enddo
-! print *,' after calling deldifs at kdt=',kdt
-!
-!
-!-------------------------------------------
- if(.not.lsfwd)then
-!-------------------------------------------
- CALL FILTR1EO(TRIE_LS(1,1,P_TEM), TRIE_LS(1,1,P_TE ),
- & TRIE_LS(1,1,P_Y ), TRIE_LS(1,1,P_DIM),
- & TRIE_LS(1,1,P_DI ), TRIE_LS(1,1,P_X ),
- & TRIE_LS(1,1,P_ZEM), TRIE_LS(1,1,P_ZE ),
- & TRIE_LS(1,1,P_W ), TRIE_LS(1,1,P_RM ),
- & TRIE_LS(1,1,P_RQ ), TRIE_LS(1,1,P_RT ),
- & TRIO_LS(1,1,P_TEM), TRIO_LS(1,1,P_TE ),
- & TRIO_LS(1,1,P_Y ), TRIO_LS(1,1,P_DIM),
- & TRIO_LS(1,1,P_DI ), TRIO_LS(1,1,P_X ),
- & TRIO_LS(1,1,P_ZEM), TRIO_LS(1,1,P_ZE ),
- & TRIO_LS(1,1,P_W ), TRIO_LS(1,1,P_RM ),
- & TRIO_LS(1,1,P_RQ ), TRIO_LS(1,1,P_RT ),
- & FILTA,LS_NODE)
-
- CALL countperf(0,13,0.)
- DO J=1,LEN_TRIE_LS
- TRIE_LS(J,1,P_QM) = TRIE_LS(J,1,P_Q )
- TRIE_LS(J,2,P_QM) = TRIE_LS(J,2,P_Q )
- TRIE_LS(J,1,P_Q ) = TRIE_LS(J,1,P_ZQ)
- TRIE_LS(J,2,P_Q ) = TRIE_LS(J,2,P_ZQ)
- ENDDO
- DO J=1,LEN_TRIO_LS
- TRIO_LS(J,1,P_QM) = TRIO_LS(J,1,P_Q )
- TRIO_LS(J,2,P_QM) = TRIO_LS(J,2,P_Q )
- TRIO_LS(J,1,P_Q ) = TRIO_LS(J,1,P_ZQ)
- TRIO_LS(J,2,P_Q ) = TRIO_LS(J,2,P_ZQ)
- ENDDO
- CALL countperf(1,13,0.)
-
-!-------------------------------------------
- else
-!-------------------------------------------
- CALL countperf(0,13,0.)
- DO J=1,LEN_TRIE_LS
- TRIE_LS(J,1,P_Q) = TRIE_LS(J,1,P_ZQ)
- TRIE_LS(J,2,P_Q) = TRIE_LS(J,2,P_ZQ)
- ENDDO
- DO J=1,LEN_TRIO_LS
- TRIO_LS(J,1,P_Q) = TRIO_LS(J,1,P_ZQ)
- TRIO_LS(J,2,P_Q) = TRIO_LS(J,2,P_ZQ)
- ENDDO
- CALL countperf(1,13,0.)
-!-------------------------------------------
- endif
-!
-!-------------------------------------------
-! if (iprint .eq. 1) print*,' me = beg gloopb ',me
-!my set to zero for every timestep
- global_times_b = 0.0
-
- if(.not. adiab) then
-
-! print *,' before calling GLOOPB kdt=',kdt
- call gloopb
- & (trie_ls,trio_ls,
- & ls_node,ls_nodes,max_ls_nodes,
- & lats_nodes_a,global_lats_a,
- & lats_nodes_r,global_lats_r,
- & lonsperlar,
- & epse,epso,epsedn,epsodn,
- & snnp1ev,snnp1od,ndexev,ndexod,
- & plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r,
- & deltim,phour,sfc_fld, flx_fld, nst_fld, SFALB,
- & xlon,
- & swh,hlw,hprime,slag,sdec,cdec,
- & ozplin,jindx1,jindx2,ddy,pdryini,
- & phy_f3d, phy_f2d, xlat,kdt,
- & global_times_b,batah,lsout,fscav)
-!
-! if (kdt .eq. 1) call mpi_quit(222)
- endif ! not.adiab
-
-! print *,' after calling GLOOPB kdt=',kdt
-!
-!!$omp parallel do shared(TRIE_LS,NDEXEV,TRIO_LS,NDEXOD)
-!!$omp+shared(SL,SPDMAX,deltim,LS_NODE)
-!$omp parallel do private(k)
- do k=1,levs
- CALL damp_speed(TRIE_LS(1,1,P_X+k-1), TRIE_LS(1,1,P_W +k-1),
- & TRIE_LS(1,1,P_Y+k-1), TRIE_LS(1,1,P_RT+k-1),
- & NDEXEV,
- & TRIO_LS(1,1,P_X+k-1), TRIO_LS(1,1,P_W +k-1),
- & TRIO_LS(1,1,P_Y+k-1), TRIO_LS(1,1,P_RT+k-1),
- & NDEXOD,
- & SL,SPDMAX(k),deltim,LS_NODE)
- enddo
-!
-!--------------------------------------------
- if(.not. lsfwd)then
-!--------------------------------------------
- CALL FILTR2EO(TRIE_LS(1,1,P_TEM), TRIE_LS(1,1,P_TE ),
- & TRIE_LS(1,1,P_Y ), TRIE_LS(1,1,P_DIM),
- & TRIE_LS(1,1,P_DI ), TRIE_LS(1,1,P_X ),
- & TRIE_LS(1,1,P_ZEM), TRIE_LS(1,1,P_ZE ),
- & TRIE_LS(1,1,P_W ), TRIE_LS(1,1,P_RM ),
- & TRIE_LS(1,1,P_RQ ), TRIE_LS(1,1,P_RT ),
- & TRIO_LS(1,1,P_TEM), TRIO_LS(1,1,P_TE ),
- & TRIO_LS(1,1,P_Y ), TRIO_LS(1,1,P_DIM),
- & TRIO_LS(1,1,P_DI ), TRIO_LS(1,1,P_X ),
- & TRIO_LS(1,1,P_ZEM), TRIO_LS(1,1,P_ZE ),
- & TRIO_LS(1,1,P_W ), TRIO_LS(1,1,P_RM ),
- & TRIO_LS(1,1,P_RQ ), TRIO_LS(1,1,P_RT ),
- & FILTA,LS_NODE)
-!--------------------------------------------
- else
-!--------------------------------------------
- CALL countperf(0,13,0.)
- DO K=1,LEVS
- DO J=1,LEN_TRIE_LS
- TRIE_LS(J,1,P_DI+K-1) = TRIE_LS(J,1,P_X+K-1)
- TRIE_LS(J,2,P_DI+K-1) = TRIE_LS(J,2,P_X+K-1)
- TRIE_LS(J,1,P_ZE+K-1) = TRIE_LS(J,1,P_W+K-1)
- TRIE_LS(J,2,P_ZE+K-1) = TRIE_LS(J,2,P_W+K-1)
- TRIE_LS(J,1,P_TE+K-1) = TRIE_LS(J,1,P_Y+K-1)
- TRIE_LS(J,2,P_TE+K-1) = TRIE_LS(J,2,P_Y+K-1)
- ENDDO
- ENDDO
- DO K=1,LEVS
- DO J=1,LEN_TRIO_LS
- TRIO_LS(J,1,P_DI+K-1) = TRIO_LS(J,1,P_X+K-1)
- TRIO_LS(J,2,P_DI+K-1) = TRIO_LS(J,2,P_X+K-1)
- TRIO_LS(J,1,P_ZE+K-1) = TRIO_LS(J,1,P_W+K-1)
- TRIO_LS(J,2,P_ZE+K-1) = TRIO_LS(J,2,P_W+K-1)
- TRIO_LS(J,1,P_TE+K-1) = TRIO_LS(J,1,P_Y+K-1)
- TRIO_LS(J,2,P_TE+K-1) = TRIO_LS(J,2,P_Y+K-1)
- ENDDO
- ENDDO
- DO K=1,LEVH
- DO J=1,LEN_TRIE_LS
- TRIE_LS(J,1,P_RQ+K-1) = TRIE_LS(J,1,P_RT+K-1)
- TRIE_LS(J,2,P_RQ+K-1) = TRIE_LS(J,2,P_RT+K-1)
- ENDDO
- ENDDO
- DO K=1,LEVH
- DO J=1,LEN_TRIO_LS
- TRIO_LS(J,1,P_RQ+K-1) = TRIO_LS(J,1,P_RT+K-1)
- TRIO_LS(J,2,P_RQ+K-1) = TRIO_LS(J,2,P_RT+K-1)
- ENDDO
- ENDDO
- CALL countperf(1,13,0.)
-!--------------------------------------------
- endif
-! if (kdt .eq. 2) call mpi_quit(444)
-!!
- endif ! if (semilag) then loop
-
- endif !.NOT.LIOPE.or.icolor.ne.2
-!
-!--------------------------------------------
-!--------------------------------------------
- IF (lsout) THEN
-!!
- CALL f_hpmstart(32,"TWRITEEO")
-!!
- CALL countperf(0,18,0.)
-!
- CALL WRTOUT(PHOUR,FHOUR,ZHOUR,IDATE,
- & TRIE_LS,TRIO_LS,
- & SL,SI,
- & ls_node,LS_NODES,MAX_LS_NODES,
- & sfc_fld, flx_fld, nst_fld,
- & fluxr,pdryini,
- & lats_nodes_r,global_lats_r,lonsperlar,
- & COLAT1,CFHOUR1,pl_coeff,
- & epsedn,epsodn,snnp1ev,snnp1od,plnev_r,plnod_r,
- & plnew_r,plnow_r,'SIG.F','SFC.F','FLX.F')
-
-
-! endif
-!
- CALL f_hpmstop(32)
-!!
- CALL countperf(1,18,0.)
-!!
-!!
- IF (mod(kdt,nsres) == 0 .and. (.not. SPS)) THEN
-!!
- CALL wrt_restart(TRIE_LS,TRIO_LS,
- & sfc_fld, nst_fld,
- & SI,SL,fhour,idate,
- & igen,pdryini,
- x ls_node,ls_nodes,max_ls_nodes,
- & global_lats_r,lonsperlar,SNNP1EV,SNNP1OD,
- & phy_f3d, phy_f2d, ngptc, adiab, ens_nam,
- & nst_fcst,'SIGR1','SIGR2','SFCR','NSTR')
-!
- ENDIF
- ENDIF ! if ls_out
-!
- IF (mod(kdt,nszer) == 0 .and. lsout) THEN
- call flx_init(flx_fld,ierr)
- zhour = fhour
- FLUXR = 0.
-!
- if (ldiag3d .or. lggfs3d) then
- call d3d_zero(ldiag3d,lggfs3d)
- if (fhour >= fhgoc3d) lggfs3d = .false.
- endif
- ENDIF
-!
-! Coupling insertion->
- CALL ATM_SENDFLUXES(sfc_fld%SLMSK)
-!<- Coupling insertion
-
- RETURN
- END
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/GFS_Initialize_ESMFMod.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/GFS_Initialize_ESMFMod.f_gfs (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/GFS_Initialize_ESMFMod.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,1579 @@
+
+! !MODULE: GFS_Initialize_ESMFMod --- Initialize module of the ESMF
+! gridded component of the GFS system.
+!
+! !DESCRIPTION: GFS gridded component initialize module.
+!
+! !REVISION HISTORY:
+!
+! November 2004 Weiyu Yang Initial code.
+! January 2006 S. Moorthi Update to the new GFS version
+! August 2006 H. Juang Add option to run generalized coordinates
+! December 2006 S. Moorthi GFSIO included
+! February 2008 Weiyu Yang Modified for the ESMF 3.1.0 version, fixed bug for runDuration.
+! Oct 18 2010 S. Moorthi Added fscav initialization
+! March 8 2011 H. Juang Add option to run NDSL, which is the
+! non-iterating dimensionally-splitted semi-
+! Lagrangian advection for entire dynamics
+!
+!
+! !INTERFACE:
+!
+ MODULE GFS_Initialize_ESMFMod
+
+!
+!!USES:
+!
+ USE GFS_GetCf_ESMFMod
+ USE MACHINE, ONLY : kind_io4
+ USE namelist_def, ONLY : ndsl, nst_fcst
+ use gfsio_module , only : gfsio_init
+ use module_ras , only : nrcmax, fix_ncld_hr
+
+ IMPLICIT none
+
+ CONTAINS
+
+ SUBROUTINE GFS_Initialize(gcGFS, gis, clock, rc)
+
+! This subroutine set up the internal state variables,
+! allocate internal state arrays for initializing the GFS system.
+!----------------------------------------------------------------
+
+ TYPE(ESMF_VM) :: vm_local ! ESMF virtual machine
+ TYPE(ESMF_GridComp), INTENT(inout) :: gcGFS
+ TYPE(GFS_InternalState), POINTER, INTENT(inout) :: gis
+ TYPE(ESMF_Clock), INTENT(inout) :: clock
+ INTEGER, INTENT(out) :: rc
+ INTEGER, DIMENSION(mpi_status_size) :: status
+
+ TYPE(ESMF_TimeInterval) :: timeStep
+ TYPE(ESMF_TimeInterval) :: runDuration
+ TYPE(ESMF_Time) :: startTime
+ TYPE(ESMF_Time) :: stopTime
+ TYPE(ESMF_Time) :: currTime
+ INTEGER :: timeStep_sec
+ INTEGER :: runDuration_hour
+ INTEGER :: ifhmax
+ INTEGER :: rc1 = ESMF_SUCCESS
+ INTEGER :: ierr, jerr
+ INTEGER :: yyc, mmc, ddc, hhc, minsc
+!
+!DHOU 01/11/2008, added these two variables
+!INTEGER :: lvlw, npe_single_member
+ INTEGER :: npe_single_member
+
+ INTEGER :: l, ilat, locl, ikey, nrank_all, nfluxes
+ INTEGER :: i,j,k
+ real (kind=kind_io4) blatc4
+ real (kind=kind_io4), allocatable :: pl_lat4(:), pl_pres4(:), pl_time4(:)
+
+! Set up parameters of MPI communications.
+! Use ESMF utility to get PE identification and total number of PEs.
+!-------------------------------------------------------------------
+ me = gis%me
+ NODES = gis%nodes
+ nlunit = gis%nam_gfs%nlunit
+
+ npe_single_member = gis%npe_single_member
+ print *,' npe_single_member=',npe_single_member
+ CALL COMPNS(gis%DELTIM,gis%IRET, &
+! gis%ntrac, gis%nxpt, gis%nypt, gis%jintmx, gis%jcap, &
+ gis%ntrac, gis%jcapg, gis%jcap, &
+ gis%levs, gis%levr, gis%lonf, gis%lonr, gis%latg, gis%latr,&
+ gis%ntoz, gis%ntcw, gis%ncld, gis%lsoil, gis%nmtvr, &
+ gis%num_p3d, gis%num_p2d, me, gis%nam_gfs%nlunit, gis%nam_gfs%gfs_namelist)
+!
+ CALL set_soilveg(me,gis%nam_gfs%nlunit)
+ call set_tracer_const(gis%ntrac,me,gis%nam_gfs%nlunit) ! hmhj
+!
+
+ ntrac = gis%ntrac
+! nxpt = gis%nxpt
+! nypt = gis%nypt
+! jintmx = gis%jintmx
+ jcapg = gis%jcapg
+ jcap = gis%jcap
+ levs = gis%levs
+ levr = gis%levr
+ lonf = gis%lonf
+ lonr = gis%lonr
+ latg = gis%latg
+ latr = gis%latr
+ ntoz = gis%ntoz
+ ntcw = gis%ntcw
+ ncld = gis%ncld
+ lsoil = gis%lsoil
+ nmtvr = gis%nmtvr
+ num_p3d = gis%num_p3d
+ num_p2d = gis%num_p2d
+ if (gis%nam_gfs%Total_Member <= 1) then
+ ens_nam=' '
+ else
+ write(ens_nam,'("_",I2.2)') gis%nam_gfs%Member_Id
+ endif
+!
+! ivssfc = 200501
+ ivssfc = 200509
+ ivssfc_restart = 200509
+ if (ivssfc .gt. ivssfc_restart) ivssfc_restart = ivssfc
+ ivsnst = 200907
+ ivsupa = 0
+ if (levs .gt. 99) ivsupa = 200509
+!
+ levh = ntrac*levs
+ gis%levh = levh ! Added by Weiyu
+! latgd = latg+ 2*jintmx
+ latgd = latg
+ jcap1 = jcap+1
+ jcap2 = jcap+2
+ latg2 = latg/2
+ latr2 = latr/2
+ levm1 = levs-1
+ levp1 = levs+1
+!jfe parameter ( lonfx = lonf+2 )
+! lonfx = lonf + 1 + 2*nxpt+1
+ lonrx = lonr+2
+ lnt = jcap2*jcap1/2
+ lnuv = jcap2*jcap1
+ lnt2 = 2*lnt
+ lnt22 = 2*lnt+1
+ lnte = (jcap2/2)*((jcap2/2)+1)-1
+ lnto = (jcap2/2)*((jcap2/2)+1)-(jcap2/2)
+ lnted = lnte
+ lntod = lnto
+
+! ngrids_sfcc = 32+LSOIL*3
+! ngrids_sfcc = 29+LSOIL*3 ! No CV, CVB, CVT!
+ ngrids_sfcc = 32+LSOIL*3 ! No CV, CVB, CVT! includes T2M, Q2M, TISFC
+!*RADFLX*
+!* ngrids_flx = 66+30 ! additional fields (most related to land surface)
+! ngrids_flx = 66+43 ! additional fields (land surface + rad flux)
+
+!hchuang code change
+! soilw0_10cm, TMP2m, USTAR, HPBLsfc, U10m, V10m, SFCRsfc, ORO
+! array names : gsoil, gtmp2m, gustar, gpblh, gu10m, gv10m, gzorl, goro
+
+ if (climate) then
+ ngrids_flx = 66+36+8 ! additional 8 gocart avg output fields
+ else
+ ngrids_flx = 66+43+8 ! additional 8 gocart avg output fields
+ endif
+
+ if (nst_fcst > 0) then ! For NST model
+! ngrids_nst = 19 ! oceanic fields (for diurnal warming and sub-layer)
+ nr_nst = 10 ! oceanic fields: for diurnal warming model run
+ nf_nst = 9 ! oceanic fields: for GSI analysis
+ ngrids_nst = nr_nst + nf_nst ! oceanic fields (for diurnal warming and sub-layer)
+ else
+ ngrids_nst = 0
+ endif
+
+!*RADFLX*
+!* nfxr = 27
+ nfxr = 33
+ ngrids_gg = 2+LEVS*(4+ntrac)
+
+!
+ if (ntrac-ncld-1 > 0) then
+ allocate ( gis%fscav(ntrac-ncld-1), stat = ierr )
+ gis%fscav = 0.0
+ endif
+
+ gis%lnt2 = lnt2
+
+ allocate(lat1s_a(0:jcap))
+ allocate(lat1s_r(0:jcap))
+! allocate(lon_dims_a(latgd))
+! allocate(lon_dims_ext(latgd))
+!my allocate(lon_dims_r(latgd))
+! allocate(lon_dims_r(latr))
+
+ allocate(colrad_a(latg2))
+ allocate(wgt_a(latg2))
+ allocate(wgtcs_a(latg2))
+ allocate(rcs2_a(latg2))
+ allocate(sinlat_a(latg2))
+
+ allocate(colrad_r(latr))
+ allocate(wgt_r(latr2))
+ allocate(wgtcs_r(latr2))
+ allocate(rcs2_r(latr2))
+ allocate(sinlat_r(latr))
+ allocate(coslat_r(latr))
+
+ allocate(am(levs,levs))
+ allocate(bm(levs,levs))
+ allocate(cm(levs,levs))
+ allocate(dm(levs,levs,jcap1))
+ allocate(tor(levs))
+ allocate(si(levp1))
+ allocate(sik(levp1))
+ allocate(sl(levs))
+ allocate(slk(levs))
+ allocate(del(levs))
+ allocate(rdel2(levs))
+ allocate(ci(levp1))
+ allocate(cl(levs))
+ allocate(tov(levs))
+ allocate(sv(levs))
+
+ allocate(AK5(LEVP1))
+ allocate(BK5(LEVP1))
+ allocate(CK5(LEVP1)) ! hmhj
+ allocate(THREF(LEVP1)) ! hmhj
+ allocate(CK(LEVS))
+ allocate(DBK(LEVS))
+ allocate(bkl(LEVS))
+ allocate(AMHYB(LEVS,LEVS))
+ allocate(BMHYB(LEVS,LEVS))
+ allocate(SVHYB(LEVS))
+ allocate(tor_hyb(LEVS))
+ allocate(D_HYB_m(levs,levs,jcap1))
+ allocate(dm205_hyb(jcap1,levs,levs))
+
+!sela added for semilag grid computations
+ allocate(AM_slg(LEVS,LEVS))
+ allocate(BM_slg(LEVS,LEVS))
+ allocate(SV_slg(LEVS))
+ allocate(tor_slg(LEVS))
+ allocate(sv_ecm(LEVS))
+ allocate(D_slg_m(levs,levs,jcap1))
+
+!sela added for semilag grid computations
+ allocate(yecm(LEVS,LEVS))
+ allocate(tecm(LEVS,LEVS))
+ allocate(y_ecm(LEVS,LEVS))
+ allocate(t_ecm(LEVS,LEVS))
+!sela added for semilag grid computations
+
+ allocate(spdmax(levs))
+
+! allocate(buf_sig(lnt2,3*levs+2),buff_grid(lonr,latr),
+! allocate(buf_sig(lnt2,3*levs+2),
+! & buff_mult(lonr,latr,ngrids_sfc))
+! allocate(buf_sig_n(lnt2,levs,ntrac))
+ allocate(buff_mult(lonr,latr,ngrids_sfcc+ngrids_nst))
+ if (gfsio_out) then
+ allocate(buff_multg(lonr*latr,ngrids_gg))
+ endif
+
+! allocate(LBASDZ(4,2,levs),LBASIZ(4,2,LEVS),DETAI(levp1), &
+! DETAM(levs),ETAMID(levs),ETAINT(levp1), &
+! SINLAMG(lonf,latg2),COSLAMG(lonf,latg2))
+!
+
+ allocate(tor_sig(levs), d_m(levs,levs,jcap1), &
+ dm205(jcap1,levs,levs))
+ dm205=555555555.
+ d_m =444444444.
+!
+
+ allocate(z(lnt2))
+ allocate(z_r(lnt2))
+!
+ nfluxes = 153
+ allocate(fmm(lonr*latr,nfluxes),lbmm(lonr*latr,nfluxes))
+ allocate(ibufm(50,nfluxes),rbufm(50,nfluxes))
+
+!
+ allocate(gis%LONSPERLAT(latg))
+
+ allocate(gis%lonsperlar(latr))
+
+ if ( .not. ndsl ) then
+!***********************************************************************
+ if (redgg_a) then
+
+ if (lingg_a) then
+ call set_lonsgg_redgg_lin(gis%lonsperlat,latg,me)
+ else
+ call set_lonsgg_redgg_quad(gis%lonsperlat,latg,me)
+ endif
+
+ else ! next, for full grid.
+
+ if (lingg_a) then
+ call set_lonsgg_fullgg_lin(gis%lonsperlat,latg,me)
+ else
+ call set_lonsgg_fullgg_quad(gis%lonsperlat,latg,me)
+ endif
+
+ endif
+!***********************************************************************
+ if (redgg_b) then
+ if (lingg_b) then
+ call set_lonsgg_redgg_lin(gis%lonsperlar,latr,me)
+ else
+ call set_lonsgg_redgg_quad(gis%lonsperlar,latr,me)
+ endif
+ else ! next, for full loopb and r grids.
+ if (lingg_b) then
+ call set_lonsgg_fullgg_lin(gis%lonsperlar,latr,me)
+ else
+ call set_lonsgg_fullgg_quad(gis%lonsperlar,latr,me)
+ endif
+ endif
+!***********************************************************************
+ else
+ if (num_reduce == 0) then
+ gis%lonsperlat = lonf
+ gis%lonsperlar = lonr
+ else
+ call set_lonsgg(gis%lonsperlat,gis%lonsperlar,num_reduce,me)
+ endif
+ endif
+!***********************************************************************
+!
+ if (ras) then
+ if (fix_ncld_hr) then
+! nrcm = min(nrcmax, levs-1) * (gis%deltim/1200) + 0.50001
+ nrcm = min(nrcmax, levs-1) * (gis%deltim/1200) + 0.10001
+! nrcm = min(nrcmax, levs-1) * min(1.0,gis%deltim/360) + 0.1
+ else
+ nrcm = min(nrcmax, levs-1)
+ endif
+! nrcm = max(nrcmax, nint((nrcmax*gis%deltim)/600.0))
+ else
+ nrcm = 1
+ endif
+!
+! if (.not. adiab) then
+ if (ntoz .le. 0) then ! Diagnostic ozone
+ rewind (kozc)
+ read (kozc,end=101) latsozc, levozc, timeozc, blatc4
+ 101 if (levozc .lt. 10 .or. levozc .gt. 100) then
+ rewind (kozc)
+ levozc = 17
+ latsozc = 18
+ blatc = -85.0
+ else
+ blatc = blatc4
+ endif
+ latsozp = 2
+ levozp = 1
+ timeoz = 1
+ pl_coeff = 0
+ else ! Prognostic Ozone
+ rewind (kozpl)
+ read (kozpl) pl_coeff, latsozp, levozp, timeoz
+ allocate (pl_lat(latsozp), pl_pres(levozp),pl_time(timeoz+1))
+ allocate (pl_lat4(latsozp), pl_pres4(levozp),pl_time4(timeoz+1))
+ rewind (kozpl)
+ read (kozpl) pl_coeff, latsozp, levozp, timeoz, pl_lat4, pl_pres4, &
+ pl_time4
+ pl_pres(:) = pl_pres4(:)
+ pl_lat(:) = pl_lat4(:)
+ pl_time(:) = pl_time4(:)
+ latsozc = 2
+ blatc = 0.0
+ endif
+ dphiozc = -(blatc+blatc)/(latsozc-1)
+!
+ if (me .eq. 0) then
+ print *,' latsozp=',latsozp,' levozp=',levozp,' timeoz=',timeoz
+ print *,' latsozc=',latsozc,' levozc=',levozc,' timeozc=', &
+ timeozc, 'dphiozc=',dphiozc
+ print *,' pl_lat=',pl_lat
+ print *,' pl_pres=',pl_pres
+ print *,' pl_time=',pl_time
+ endif
+! pl_pres(:) = log(0.1*pl_pres(:)) ! Natural log of pres in cbars
+ pl_pres(:) = log(100.0*pl_pres(:)) ! Natural log of pres in Pa
+!
+ allocate(gis%OZPLIN(LATSOZP,LEVOZP,pl_coeff,timeoz)) !OZONE P-L coeffcients
+! endif
+!
+!
+ P_GZ = 0*LEVS+0*LEVH+1 ! GZE/O(LNTE/OD,2),
+ P_ZEM = 0*LEVS+0*LEVH+2 ! ZEME/O(LNTE/OD,2,LEVS),
+ P_DIM = 1*LEVS+0*LEVH+2 ! DIME/O(LNTE/OD,2,LEVS),
+ P_TEM = 2*LEVS+0*LEVH+2 ! TEME/O(LNTE/OD,2,LEVS),
+ P_QM = 3*LEVS+0*LEVH+2 ! QME/O(LNTE/OD,2),
+ P_ZE = 3*LEVS+0*LEVH+3 ! ZEE/O(LNTE/OD,2,LEVS),
+ P_DI = 4*LEVS+0*LEVH+3 ! DIE/O(LNTE/OD,2,LEVS),
+ P_TE = 5*LEVS+0*LEVH+3 ! TEE/O(LNTE/OD,2,LEVS),
+ P_Q = 6*LEVS+0*LEVH+3 ! QE/O(LNTE/OD,2),
+ P_DLAM= 6*LEVS+0*LEVH+4 ! DPDLAME/O(LNTE/OD,2),
+ P_DPHI= 6*LEVS+0*LEVH+5 ! DPDPHIE/O(LNTE/OD,2),
+ P_ULN = 6*LEVS+0*LEVH+6 ! ULNE/O(LNTE/OD,2,LEVS),
+ P_VLN = 7*LEVS+0*LEVH+6 ! VLNE/O(LNTE/OD,2,LEVS),
+ P_W = 8*LEVS+0*LEVH+6 ! WE/O(LNTE/OD,2,LEVS),
+ P_X = 9*LEVS+0*LEVH+6 ! XE/O(LNTE/OD,2,LEVS),
+ P_Y =10*LEVS+0*LEVH+6 ! YE/O(LNTE/OD,2,LEVS),
+ P_ZQ =11*LEVS+0*LEVH+6 ! ZQE/O(LNTE/OD,2)
+ P_RT =11*LEVS+0*LEVH+7 ! RTE/O(LNTE/OD,2,LEVH),
+ P_RM =11*LEVS+1*LEVH+7 ! RME/O(LNTE/OD,2,LEVH),
+ P_RQ =11*LEVS+2*LEVH+7 ! RQE/O(LNTE/OD,2,LEVH),
+!
+!**********************Current operational as of May 2009***********
+! P_GZ = 0*LEVS+0*LEVH+1 ! GZE/O(LNTE/OD,2),
+! P_ZEM = 0*LEVS+0*LEVH+2 ! ZEME/O(LNTE/OD,2,LEVS),
+! P_DIM = 1*LEVS+0*LEVH+2 ! DIME/O(LNTE/OD,2,LEVS),
+! P_TEM = 2*LEVS+0*LEVH+2 ! TEME/O(LNTE/OD,2,LEVS),
+! P_RM = 3*LEVS+0*LEVH+2 ! RME/O(LNTE/OD,2,LEVH),
+! P_QM = 3*LEVS+1*LEVH+2 ! QME/O(LNTE/OD,2),
+! P_ZE = 3*LEVS+1*LEVH+3 ! ZEE/O(LNTE/OD,2,LEVS),
+! P_DI = 4*LEVS+1*LEVH+3 ! DIE/O(LNTE/OD,2,LEVS),
+! P_TE = 5*LEVS+1*LEVH+3 ! TEE/O(LNTE/OD,2,LEVS),
+! P_RQ = 6*LEVS+1*LEVH+3 ! RQE/O(LNTE/OD,2,LEVH),
+! P_Q = 6*LEVS+2*LEVH+3 ! QE/O(LNTE/OD,2),
+! P_DLAM= 6*LEVS+2*LEVH+4 ! DPDLAME/O(LNTE/OD,2),
+! P_DPHI= 6*LEVS+2*LEVH+5 ! DPDPHIE/O(LNTE/OD,2),
+! P_ULN = 6*LEVS+2*LEVH+6 ! ULNE/O(LNTE/OD,2,LEVS),
+! P_VLN = 7*LEVS+2*LEVH+6 ! VLNE/O(LNTE/OD,2,LEVS),
+! P_W = 8*LEVS+2*LEVH+6 ! WE/O(LNTE/OD,2,LEVS),
+! P_X = 9*LEVS+2*LEVH+6 ! XE/O(LNTE/OD,2,LEVS),
+! P_Y =10*LEVS+2*LEVH+6 ! YE/O(LNTE/OD,2,LEVS),
+! P_RT =11*LEVS+2*LEVH+6 ! RTE/O(LNTE/OD,2,LEVH),
+! P_ZQ =11*LEVS+3*LEVH+6 ! ZQE/O(LNTE/OD,2)
+!**********************Current operational as of May 2009***********
+!C
+ LOTS = 5*LEVS+1*LEVH+3
+ LOTD = 6*LEVS+2*LEVH+0
+ LOTA = 3*LEVS+1*LEVH+1
+!
+ kwq = 0*levs+0*levh+1 ! qe/o_ls
+ kwte = 0*levs+0*levh+2 ! tee/o_ls
+ kwdz = 1*levs+0*levh+2 ! die/o_ls zee/o_ls
+ kwrq = 3*levs+0*levh+2 ! rqe/o_ls
+
+!
+ gis%P_GZ = 0*LEVS+0*LEVH+1 ! GZE/O(LNTE/OD,2),
+ gis%P_ZEM = 0*LEVS+0*LEVH+2 ! ZEME/O(LNTE/OD,2,LEVS),
+ gis%P_DIM = 1*LEVS+0*LEVH+2 ! DIME/O(LNTE/OD,2,LEVS),
+ gis%P_TEM = 2*LEVS+0*LEVH+2 ! TEME/O(LNTE/OD,2,LEVS),
+ gis%P_RM = 3*LEVS+0*LEVH+2 ! RME/O(LNTE/OD,2,LEVH),
+ gis%P_QM = 3*LEVS+1*LEVH+2 ! QME/O(LNTE/OD,2),
+ gis%P_ZE = 3*LEVS+1*LEVH+3 ! ZEE/O(LNTE/OD,2,LEVS),
+ gis%P_DI = 4*LEVS+1*LEVH+3 ! DIE/O(LNTE/OD,2,LEVS),
+ gis%P_TE = 5*LEVS+1*LEVH+3 ! TEE/O(LNTE/OD,2,LEVS),
+ gis%P_RQ = 6*LEVS+1*LEVH+3 ! RQE/O(LNTE/OD,2,LEVH),
+ gis%P_Q = 6*LEVS+2*LEVH+3 ! QE/O(LNTE/OD,2),
+ gis%P_DLAM= 6*LEVS+2*LEVH+4 ! DPDLAME/O(LNTE/OD,2),
+ gis%P_DPHI= 6*LEVS+2*LEVH+5 ! DPDPHIE/O(LNTE/OD,2),
+ gis%P_ULN = 6*LEVS+2*LEVH+6 ! ULNE/O(LNTE/OD,2,LEVS),
+ gis%P_VLN = 7*LEVS+2*LEVH+6 ! VLNE/O(LNTE/OD,2,LEVS),
+ gis%P_W = 8*LEVS+2*LEVH+6 ! WE/O(LNTE/OD,2,LEVS),
+ gis%P_X = 9*LEVS+2*LEVH+6 ! XE/O(LNTE/OD,2,LEVS),
+ gis%P_Y =10*LEVS+2*LEVH+6 ! YE/O(LNTE/OD,2,LEVS),
+ gis%P_RT =11*LEVS+2*LEVH+6 ! RTE/O(LNTE/OD,2,LEVH),
+ gis%P_ZQ =11*LEVS+3*LEVH+6 ! ZQE/O(LNTE/OD,2)
+!C
+ gis%LOTS = 5*LEVS+1*LEVH+3
+ gis%LOTD = 6*LEVS+2*LEVH+0
+ gis%LOTA = 3*LEVS+1*LEVH+1
+!C
+ allocate(gis%TEE1(LEVS))
+
+! gis%LSLAG=.FALSE. ! IF FALSE EULERIAN SCHEME =.true. for semilag
+
+!
+!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+!!
+!! Create IO communicator and comp communicator
+!!
+!sela LIOPE=.FALSE.
+!! LIOPE=.TRUE.
+ IF (me == 0) write(*,*) 'IO OPTION ,LIOPE :',LIOPE
+!
+ CALL ESMF_VMGetCurrent(vm_local, rc = ierr)
+ CALL ESMF_VMGet(vm_local, mpiCommunicator = MPI_COMM_ALL, &
+ peCount = nodes, rc = ierr)
+!
+ CALL MPI_COMM_DUP(MPI_COMM_ALL, MPI_COMM_ALL_DUP, ierr)
+ CALL MPI_Barrier (MPI_COMM_ALL_DUP, ierr)
+
+ IF (NODES == 1) THEN
+ LIOPE=.FALSE.
+ write(*,*) 'IO OPTION RESET:,LIOPE :',LIOPE
+ ENDIF
+ IF (LIOPE) THEN
+! CALL MPI_COMM_SPLIT(MPI_COMM_WORLD,1,1,MPI_COMM_ALL,ierr)
+ CALL MPI_COMM_RANK(MPI_COMM_ALL_DUP,nrank_all,ierr)
+ icolor = 1
+ ikey = 1
+ nodes_comp = nodes-1
+ if (nrank_all == nodes-1) then
+!! IO server
+ write(*,*) 'IO server task'
+ icolor = 2
+ gis%kcolor = MPI_UNDEFINED
+ CALL MPI_COMM_SPLIT(MPI_COMM_ALL_DUP,icolor,ikey,MC_IO,ierr)
+ CALL MPI_COMM_SPLIT(MPI_COMM_ALL_DUP,gis%kcolor,ikey,MC_COMP,ierr)
+ else
+!sela write(*,*) 'COMPUTE SERVER TASK '
+ icolor = MPI_UNDEFINED
+ gis%kcolor = 1
+ CALL MPI_COMM_SPLIT(MPI_COMM_ALL_DUP,gis%kcolor,ikey,MC_COMP,ierr)
+ CALL MPI_COMM_SPLIT(MPI_COMM_ALL_DUP,icolor,ikey,MC_IO,ierr)
+ CALL MPI_COMM_SIZE(MC_COMP,NODES,IERR)
+ endif
+ ELSE
+ icolor = 2
+ MC_COMP = MPI_COMM_ALL_DUP
+ nodes_comp = nodes
+ ENDIF
+!!
+!C
+ CALL f_hpminit(ME,"EVOD") !jjt hpm stuff
+!C
+ CALL f_hpmstart(25,"GET_LS_GFTLONS")
+!C
+ if(me.eq.0) then
+ call w3tagb('gsm ',0000,0000,0000,'np23 ')
+ endif
+!!
+ CALL synchro
+ CALL init_countperf(latg)
+!$$$ time0=timer()
+!jfe CALL countperf(0,15,0.)
+!
+ if (me.eq.0) then
+ PRINT 100, JCAP,LEVS
+100 FORMAT (' SMF ',I3,I3,' CREATED AUGUST 2000 EV OD RI ')
+ PRINT*,'NUMBER OF THREADS IS ',NUM_PARTHDS()
+ if (liope) then
+ PRINT*,'NUMBER OF MPI PROCS IS ',NODES
+ PRINT*,'NUMBER OF MPI IO PROCS IS 1 (nodes)'
+ else
+ PRINT*,'NUMBER OF MPI PROCS IS ',NODES
+ endif
+ endif
+!C
+ gis%CONS0 = 0.0D0
+ gis%CONS0P5 = 0.5D0
+ gis%CONS1200 = 1200.D0
+ gis%CONS3600 = 3600.D0
+!C
+ if (liope) then
+ if (icolor.eq.2) then
+ LS_DIM = JCAP1
+ else
+ LS_DIM = (JCAP1-1)/NODES+1
+ endif
+ else
+ LS_DIM = (JCAP1-1)/NODES+1
+ endif
+!!
+!C
+!CXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
+!C
+!C
+! For creating the ESMF interface state with the GFS
+! internal parallel structure. Weiyu.
+!---------------------------------------------------
+ ALLOCATE(gis%TRIE_LS_SIZE (npe_single_member))
+ ALLOCATE(gis%TRIO_LS_SIZE (npe_single_member))
+ ALLOCATE(gis%TRIEO_LS_SIZE (npe_single_member))
+ ALLOCATE(gis%LS_MAX_NODE_GLOBAL(npe_single_member))
+ ALLOCATE(gis%LS_NODE_GLOBAL (LS_DIM*3, npe_single_member))
+!---------------------------------------------------
+
+ ALLOCATE ( gis%LS_NODE (LS_DIM*3) )
+ ALLOCATE ( gis%LS_NODES(LS_DIM,NODES) )
+ ALLOCATE ( gis%MAX_LS_NODES(NODES) )
+!C
+ ALLOCATE ( gis%LATS_NODES_A(NODES) )
+ ALLOCATE ( gis%GLOBAL_LATS_A(LATG) )
+!C
+ ALLOCATE ( gis%LATS_NODES_R(NODES) )
+ ALLOCATE ( gis%GLOBAL_LATS_R(LATR) )
+!C
+! ALLOCATE ( gis%LATS_NODES_EXT(NODES) )
+! ALLOCATE ( gis%GLOBAL_LATS_EXT(LATG+2*JINTMX+2*NYPT*(NODES-1)) )
+!C
+!C
+ gis%IPRINT = 0
+! gis%LATS_NODES_EXT = 0
+
+! For creating the ESMF interface state with the GFS
+! internal parallel structure. Weiyu.
+!---------------------------------------------------
+ gis%LS_NODE_GLOBAL = 0
+ gis%LS_MAX_NODE_GLOBAL = 0
+ gis%TRIEO_TOTAL_SIZE = 0
+
+ DO i = 1, npe_single_member
+ CALL GET_LS_NODE(i-1, gis%LS_NODE_GLOBAL(1, i), &
+ gis%LS_MAX_NODE_GLOBAL(i), gis%IPRINT)
+ gis%TRIE_LS_SIZE(i) = 0
+ gis%TRIO_LS_SIZE(i) = 0
+ DO LOCL = 1, gis%LS_MAX_NODE_GLOBAL(i)
+ gis%LS_NODE_GLOBAL(LOCL+ LS_DIM, i) = gis%TRIE_LS_SIZE(i)
+ gis%LS_NODE_GLOBAL(LOCL+ 2*LS_DIM, i) = gis%TRIO_LS_SIZE(i)
+
+ L = gis%LS_NODE_GLOBAL(LOCL, i)
+
+ gis%TRIE_LS_SIZE(i) = gis%TRIE_LS_SIZE(i) + (JCAP+3-L)/2
+ gis%TRIO_LS_SIZE(i) = gis%TRIO_LS_SIZE(i) + (JCAP+2-L)/2
+ END DO
+ gis%TRIEO_LS_SIZE(i) = gis%TRIE_LS_SIZE(i) + gis%TRIO_LS_SIZE(i) + 3
+ gis%TRIEO_TOTAL_SIZE = gis%TRIEO_TOTAL_SIZE + gis%TRIEO_LS_SIZE(i)
+ END DO
+
+ DO i = 1, 3*LS_DIM
+ gis%LS_NODE(i) = gis%LS_NODE_GLOBAL(i, me+1)
+ END DO
+
+ LS_MAX_NODE = gis%LS_MAX_NODE_GLOBAL(me+1)
+ LEN_TRIE_LS = gis%TRIE_LS_SIZE (me+1)
+ LEN_TRIO_LS = gis%TRIO_LS_SIZE (me+1)
+ IF(LIOPE) THEN
+ IF(me == 0) CALL mpi_send(gis%TRIE_LS_SIZE, &
+ npe_single_member, &
+ mpi_integer, &
+ npe_single_member-1, &
+ 900, &
+ MPI_COMM_ALL_DUP, &
+ ierr)
+ IF(me == npe_single_member-1) &
+ CALL mpi_recv(gis%TRIE_LS_SIZE, &
+ npe_single_member, &
+ mpi_integer, &
+ 0, &
+ 900, &
+ MPI_COMM_ALL_DUP, &
+ status, &
+ ierr)
+ IF(me == 0) CALL mpi_send(gis%TRIO_LS_SIZE, &
+ npe_single_member, &
+ mpi_integer, &
+ npe_single_member-1, &
+ 900, &
+ MPI_COMM_ALL_DUP, &
+ ierr)
+ IF(me == npe_single_member-1) &
+ CALL mpi_recv(gis%TRIO_LS_SIZE, &
+ npe_single_member, &
+ mpi_integer, &
+ 0, &
+ 900, &
+ MPI_COMM_ALL_DUP, &
+ status, &
+ ierr)
+ IF(me == 0) CALL mpi_send(gis%TRIEO_LS_SIZE, &
+ npe_single_member, &
+ mpi_integer, &
+ npe_single_member-1, &
+ 900, &
+ MPI_COMM_ALL_DUP, &
+ ierr)
+ IF(me == npe_single_member-1) &
+ CALL mpi_recv(gis%TRIEO_LS_SIZE, &
+ npe_single_member, &
+ mpi_integer, &
+ 0, &
+ 900, &
+ MPI_COMM_ALL_DUP, &
+ status, &
+ ierr)
+ IF(me == 0) CALL mpi_send(gis%TRIEO_TOTAL_SIZE,&
+ 1, &
+ mpi_integer, &
+ npe_single_member-1, &
+ 900, &
+ MPI_COMM_ALL_DUP, &
+ ierr)
+ IF(me == npe_single_member-1) &
+ CALL mpi_recv(gis%TRIEO_TOTAL_SIZE,&
+ 1, &
+ mpi_integer, &
+ 0, &
+ 900, &
+ MPI_COMM_ALL_DUP, &
+ status, &
+ ierr)
+ END IF
+!-----------------------------------------------------------
+
+!! CALL GET_LS_NODE( ME, gis%LS_NODE, LS_MAX_NODE, gis%IPRINT )
+!C
+!C
+!! LEN_TRIE_LS=0
+!! LEN_TRIO_LS=0
+!! DO LOCL=1,LS_MAX_NODE
+!! gis%LS_NODE(LOCL+ LS_DIM)=LEN_TRIE_LS
+!! gis%LS_NODE(LOCL+2*LS_DIM)=LEN_TRIO_LS
+!! L=gis%LS_NODE(LOCL)
+!! LEN_TRIE_LS=LEN_TRIE_LS+(JCAP+3-L)/2
+!! LEN_TRIO_LS=LEN_TRIO_LS+(JCAP+2-L)/2
+!! ENDDO
+!C
+!C
+ ALLOCATE ( gis%EPSE (LEN_TRIE_LS) )
+ ALLOCATE ( gis%EPSO (LEN_TRIO_LS) )
+ ALLOCATE ( gis%EPSEDN(LEN_TRIE_LS) )
+ ALLOCATE ( gis%EPSODN(LEN_TRIO_LS) )
+!C
+ ALLOCATE ( gis%SNNP1EV(LEN_TRIE_LS) )
+ ALLOCATE ( gis%SNNP1OD(LEN_TRIO_LS) )
+!C
+ ALLOCATE ( gis%NDEXEV(LEN_TRIE_LS) )
+ ALLOCATE ( gis%NDEXOD(LEN_TRIO_LS) )
+!C
+ ALLOCATE ( gis%PLNEV_A(LEN_TRIE_LS,LATG2) )
+ ALLOCATE ( gis%PLNOD_A(LEN_TRIO_LS,LATG2) )
+ ALLOCATE ( gis%PDDEV_A(LEN_TRIE_LS,LATG2) )
+ ALLOCATE ( gis%PDDOD_A(LEN_TRIO_LS,LATG2) )
+ ALLOCATE ( gis%PLNEW_A(LEN_TRIE_LS,LATG2) )
+ ALLOCATE ( gis%PLNOW_A(LEN_TRIO_LS,LATG2) )
+!C
+ ALLOCATE ( gis%PLNEV_R(LEN_TRIE_LS,LATR2) )
+ ALLOCATE ( gis%PLNOD_R(LEN_TRIO_LS,LATR2) )
+ ALLOCATE ( gis%PDDEV_R(LEN_TRIE_LS,LATR2) )
+ ALLOCATE ( gis%PDDOD_R(LEN_TRIO_LS,LATR2) )
+ ALLOCATE ( gis%PLNEW_R(LEN_TRIE_LS,LATR2) )
+ ALLOCATE ( gis%PLNOW_R(LEN_TRIO_LS,LATR2) )
+!C
+ gis%MAXSTP=36
+
+
+ IF(ME.EQ.0) PRINT*,'FROM COMPNS : IRET=',gis%IRET,' NSOUT=',NSOUT, &
+ ' NSSWR=',NSSWR,' NSLWR=',NSLWR,' NSZER=',NSZER,' NSRES=',NSRES, &
+ ' NSDFI=',NSDFI,' NSCYC=',NSCYC,' RAS=',RAS
+ IF(gis%IRET.NE.0) THEN
+ IF(ME.EQ.0) PRINT *,' INCOMPATIBLE NAMELIST - ABORTED IN MAIN'
+ CALL MPI_QUIT(13)
+ ENDIF
+!!
+! IF PREDICTED OZON IS DESIRED SET JO3=2
+ JO3 = 2 !USING PREDICTED OZONE IN RADIATION.
+!C
+!! gis%LATS_NODES_EXT = 0
+
+ CALL GETCON(gis%NGES,gis%NRADR,gis%NRADF,gis%NNMOD, &
+ gis%N3,gis%N4,gis%NFLPS,gis%NSIGI,gis%NSIGS,gis%NSFCI, &
+ gis%NZNLI,gis%NSFCF,gis%NZNLF,gis%NSFCS,gis%NZNLS, &
+ gis%NDGI,gis%NDGF,gis%NGPKEN, &
+ gis%MODS,gis%NITER,gis%INI,gis%NSTEP,gis%NFILES, &
+ gis%KSOUT,gis%IFGES,gis%IBRAD, &
+ gis%LS_NODE,gis%LS_NODES,gis%MAX_LS_NODES, &
+ gis%LATS_NODES_A,gis%GLOBAL_LATS_A, &
+ gis%LONSPERLAT, &
+ gis%LATS_NODES_R,gis%GLOBAL_LATS_R, &
+ gis%LONSPERLAR, &
+! gis%LATS_NODES_EXT,gis%GLOBAL_LATS_EXT, &
+ gis%EPSE,gis%EPSO,gis%EPSEDN,gis%EPSODN, &
+ gis%SNNP1EV,gis%SNNP1OD,gis%NDEXEV,gis%NDEXOD, &
+ gis%PLNEV_A,gis%PLNOD_A,gis%PDDEV_A,gis%PDDOD_A, &
+ gis%PLNEW_A,gis%PLNOW_A, &
+ gis%PLNEV_R,gis%PLNOD_R,gis%PDDEV_R,gis%PDDOD_R, &
+ gis%PLNEW_R,gis%PLNOW_R,gis%colat1)
+!!
+ call sfcvar_aldata(lonr,lats_node_r,lsoil,gis%sfc_fld,ierr)
+ call flxvar_aldata(lonr,lats_node_r,gis%flx_fld,ierr)
+
+
+!li, added 05/31/2007 (for oceanic component)
+ IF (me == 0) write(*,*) ' in "GFS_Initialize_ESMFMod,lonr,lats_node_r,nr_nst,nf_nst : ',lonr,lats_node_r,nr_nst,nf_nst
+! Modified by Moorthi
+ call nstvar_aldata(lonr,lats_node_r,gis%nst_fld,ierr)
+
+ ALLOCATE ( gis%XLON(LONR,LATS_NODE_R))
+ ALLOCATE ( gis%XLAT(LONR,LATS_NODE_R))
+ ALLOCATE ( gis%COSZDG(LONR,LATS_NODE_R))
+ ALLOCATE ( gis%SFALB(LONR,LATS_NODE_R))
+ ALLOCATE ( gis%HPRIME(LONR,NMTVR,LATS_NODE_R))
+ ALLOCATE ( gis%FLUXR(LONR,nfxr,LATS_NODE_R))
+
+! gis%NBLCK = LONR/NGPTC + 1
+ ALLOCATE ( gis%SWH(LONR,LEVS,LATS_NODE_R))
+ ALLOCATE ( gis%HLW(LONR,LEVS,LATS_NODE_R))
+
+ ALLOCATE (gis%JINDX1(LATS_NODE_R),gis%JINDX2(LATS_NODE_R))
+ ALLOCATE (gis%DDY(LATS_NODE_R))
+!
+ allocate (gis%phy_f3d(LONR,LEVS,num_p3d,lats_node_r))
+ allocate (gis%phy_f2d(lonr,num_p2d,lats_node_r))
+!
+ call d3d_init(lonr,lats_node_r,levs,pl_coeff,ldiag3d,lggfs3d)
+
+! if (ldiag3d) then
+! call d3d_init(ngptc,gis%nblck,lonr,lats_node_r,levs,pl_coeff)
+! else
+! call d3d_init(1,gis%nblck,1,lats_node_r,1,pl_coeff) ! Needs allocation
+! endif
+ if (gfsio_out .or. gfsio_in) then
+ call gfsio_init(ierr)
+ endif
+
+ if (icolor /= 2 .or. .not. liope) then
+ if (num_p3d > 0) gis%phy_f3d = 0.0
+ if (num_p2d > 0) gis%phy_f2d = 0.0
+ endif
+ if (num_p2d .gt. 0) gis%phy_f2d = 0.0
+!!
+ CALL countperf(0,18,0.)
+!!
+! Modified by Weiyu.
+!-------------------
+ if (.NOT.LIOPE.or.icolor.ne.2) then
+!!
+ CALL countperf(0,15,0.)
+ ALLOCATE ( gis%TRIE_LS(LEN_TRIE_LS,2,11*LEVS+3*LEVH+6) )
+ ALLOCATE ( gis%TRIO_LS(LEN_TRIO_LS,2,11*LEVS+3*LEVH+6) )
+
+! For Ensemble forecast requirement, add two more arrays to save to
+! initial conditions. Weiyu.
+!------------------------------------------------------------------
+ ALLOCATE ( gis%TRIE_LS_INI(LEN_TRIE_LS,2,11*LEVS+3*LEVH+6) )
+ ALLOCATE ( gis%TRIO_LS_INI(LEN_TRIO_LS,2,11*LEVS+3*LEVH+6) )
+
+!C
+ ALLOCATE ( gis%SYN_LS_A(4*LS_DIM,gis%LOTS,LATG2) )
+ ALLOCATE ( gis%DYN_LS_A(4*LS_DIM,gis%LOTD,LATG2) )
+!C
+! ALLOCATE ( gis%SYN_GR_A_1(LONFX*gis%LOTS,LATS_DIM_EXT) )
+! ALLOCATE ( gis%SYN_GR_A_2(LONFX*gis%LOTS,LATS_DIM_EXT) )
+! ALLOCATE ( gis%DYN_GR_A_1(LONFX*gis%LOTD,LATS_DIM_EXT) )
+! ALLOCATE ( gis%DYN_GR_A_2(LONFX*gis%LOTD,LATS_DIM_EXT) )
+! ALLOCATE ( gis%ANL_GR_A_1(LONFX*gis%LOTA,LATS_DIM_EXT) )
+! ALLOCATE ( gis%ANL_GR_A_2(LONFX*gis%LOTA,LATS_DIM_EXT) )
+!!
+ endif !(.NOT.LIOPE.or.icolor.ne.2)
+!!
+ if (me == 0) then
+ PRINT*, ' LATS_DIM_A=', LATS_DIM_A, ' LATS_NODE_A=', LATS_NODE_A
+! PRINT*, ' LATS_DIM_EXT=', LATS_DIM_EXT, &
+! ' LATS_NODE_EXT=', LATS_NODE_EXT
+ PRINT*, ' LATS_DIM_R=', LATS_DIM_R, ' LATS_NODE_R=', LATS_NODE_R
+ endif
+!
+ ILAT=LATS_NODE_A
+
+! IF (gis%LSLAG) THEN
+! ILAT=LATS_NODE_EXT
+! ELSE
+! ILAT=LATS_NODE_A
+! ENDIF
+ CALL countperf(1,15,0.)
+!!
+!C......................................................................
+!C
+ CALL countperf(0,15,0.)
+ CALL f_hpmstop(25)
+!C
+! WRITE(*,*) 'NUMBER OF LATITUDES EXT. :',LATS_NODE_EXT, &
+! LATS_DIM_EXT,LATS_NODE_A
+!!
+!JFE ALLOCATE (LATLOCAL(LATGD,0:NODES-1))
+!JFE ALLOCATE (LBASIY(4,2,LATS_NODE_EXT))
+!JFE ALLOCATE (PHI(LATS_NODE_EXT))
+!JFE ALLOCATE (DPHI(LATS_NODE_EXT))
+!JFE ALLOCATE (DLAM(LATS_NODE_EXT))
+!JFE ALLOCATE (LAMEXT(LONFX,LATS_NODE_EXT))
+!JFE ALLOCATE (LAM(LONFX,LATS_NODE_A+1))
+!JFE ALLOCATE (LAMMP(LONF,LEVS,LATS_NODE_A))
+!JFE ALLOCATE (SIGMP(LONF,LEVS,LATS_NODE_A))
+!JFE ALLOCATE (PHIMP(LONF,LEVS,LATS_NODE_A))
+!!
+!JFE ALLOCATE (LATSINPE(LATS_NODE_A))
+!JFE JPT=0
+!JFE DO NODE=1,NODES
+!JFE IF ( LATS_NODES_A(NODE) .GT. 0 .AND.ME+1.EQ.NODE) THEN
+!JFE DO JCOUNT=1,LATS_NODES_A(NODE)
+!JFE LATSINPE(JCOUNT)=GLOBAL_LATS_A(JPT+JCOUNT)
+!JFE ENDDO
+!JFE ENDIF
+!JFE JPT=JPT+LATS_NODES_A(NODE)
+!JFE ENDDO
+!!
+!JFE IF (LSLAG) THEN
+!JFE CALL SULAG(LAM,DLAM,LAMEXT,LATLOCAL,PHI,DPHI,DPHIBR,PHIBS,
+!JFE & LBASIY,LAMMP,PHIMP,SIGMP,gis%LONSPERLAT,
+!JFE & IPRINT,LATSINPE)
+!JFE ENDIF
+!C
+ CALL countperf(1,15,0.)
+!!
+ print *,' sig_ini=',gis%nam_gfs%sig_ini,' sig_ini2=',gis%nam_gfs%sig_ini2 &
+ ,' sfc_ini=',gis%nam_gfs%sfc_ini
+ print *,' nst_ini=',gis%nam_gfs%nst_ini
+ CALL countperf(0,18,0.)
+ gis%pdryini = 0.0
+ CALL spect_fields(gis%n1, gis%n2, &
+ gis%PDRYINI, gis%TRIE_LS, gis%TRIO_LS, &
+ gis%LS_NODE, gis%LS_NODES, gis%MAX_LS_NODES, &
+ gis%SNNP1EV, gis%SNNP1OD, gis%phy_f3d, gis%phy_f2d, &
+ gis%global_lats_r, gis%lonsperlar, &
+ gis%epse, gis%epso, gis%plnev_r, gis%plnod_r, &
+ gis%plnew_r, gis%plnow_r, gis%lats_nodes_r,&
+ gis%nam_gfs%sig_ini, gis%nam_gfs%sig_ini2)
+!!
+ if(.not.adiab)then
+ CALL fix_fields(gis%LONSPERLAR,gis%GLOBAL_LATS_R, &
+ gis%XLON,gis%XLAT,gis%sfc_fld,gis%nst_fld, &
+ gis%HPRIME,gis%JINDX1,gis%JINDX2,gis%DDY, &
+ gis%OZPLIN,gis%nam_gfs%sfc_ini,gis%nam_gfs%nst_ini)
+ CALL countperf(1,18,0.)
+ endif
+
+
+! if ( me == 72 ) then
+! do j = 1, lats_node_r
+! do i = 1, lonr
+! if ( gis%dt_warm(i,j) > 0.8 ) then
+! write(*,'(a,11F11.2)') 'Initial nstr : ', &
+! gis%ifd(i,j),gis%time_old(i,j),gis%time_ins(i,j),gis%I_Sw(i,j), &
+! gis%I_Q(i,j),gis%I_Qrain(i,j),gis%I_M(i,j),gis%I_Tau(i,j), &
+! gis%I_Sw_Zw(i,j),gis%I_Q_Ts(i,j),gis%I_M_Ts(i,j)
+! write(*,'(a,9F10.5)') 'Initial nstf : ', &
+! gis%Tref(i,j),gis%dt_cool(i,j),gis%z_c(i,j),gis%dt_warm(i,j),gis%z_w(i,j), &
+! gis%c_0(i,j),gis%c_d(i,j),gis%w_0(i,j),gis%w_d(i,j)
+! endif
+! enddo
+! enddo
+! endif
+
+
+!
+! Apply the diurnal warming & sub-layer cooling (TSEA: foundation/reference temperature)
+!
+
+! if ( .not. tr_analysis ) then
+! gis%nst_fld%Tref(:,:) = gis%sfc_fld%TSEA(:,:) ! necessary only when Tr analysis unavailable
+! endif
+
+! if ( nst_fcst > 0 ) then
+! do j = 1, lats_node_r
+! do i = 1, lonr
+! if ( gis%sfc_fld%SLMSK(i,j) == 0.0 ) then
+! gis%sfc_fld%TSEA(i,j) = gis%nst_fld%Tref(i,j) &
+! + gis%nst_fld%dt_warm(i,j) - gis%nst_fld%dt_cool(i,j)
+! endif
+! enddo
+! enddo
+! endif
+
+
+!!
+ tov = 0.0
+ if (.not. (hybrid.or.gen_coord_hybrid) ) then ! hmhj
+ call setsig(si,ci,del,sl,cl,rdel2,tov,me)
+ am = -8888888.
+ bm = -7777777.
+ call amhmtm(del,sv,am)
+ CALL BMDI_sig(ci,bm)
+ endif
+!C
+ CALL f_hpmstart(26,"STEP1")
+!C
+!!
+ CALL countperf(1,18,0.)
+!!
+ CALL countperf(0,15,0.)
+
+! Modified by Weiyu Yang to fix the bug related to the "runDuration".
+!--------------------------------------------------------------------
+ CALL ESMF_ClockGet(clock, timeStep = timeStep, &
+ startTime = startTime, &
+ currTime = currTime, &
+ rc = rc1)
+
+ runDuration_hour = NINT(FHMAX) - NINT(FHINI)
+ CALL ESMF_TimeIntervalSet(runDuration, h = runDuration_hour, rc = rc1)
+
+!wy CALL ESMF_ClockGet(clock, timeStep = timeStep, &
+!wy runDuration = runDuration, &
+!wy startTime = startTime, &
+!wy currTime = currTime, &
+!wy rc = rc1)
+
+!
+! currTime = startTime
+!
+! CALL ESMF_TimeIntervalGet(timeStep, s = timeStep_sec, rc = rc1)
+
+! print *,' timestep_sec=',timestep_sec,' rc1=',rc1
+
+!wy CALL ESMF_TimeIntervalGet(runDuration, h = runDuration_hour, rc = rc1)
+
+! print *,' runduration_hour=',runduration_hour,' rc1=',rc1
+!
+!Moor ifhmax = NINT(gis%nam_gfs%FHMAX)
+ ifhmax = NINT(FHMAX)
+ IF(runDuration_hour <= 0 .OR. &
+ ifhmax /= 0 .AND. &
+ ifhmax <= gis%kfhour + runDuration_hour) THEN
+!Moor gis%nam_gfs%FHMAX = MAX(gis%nam_gfs%FHMAX, REAL(gis%kfhour))
+! ,, ifhmax = NINT(gis%nam_gfs%FHMAX)
+ ifhmax = NINT(FHMAX)
+! ,, runDuration_hour = ifhmax - gis%kfhour
+ runDuration_hour = NINT(FHMAX) - NINT(FHINI)
+ CALL ESMF_TimeIntervalSet(runDuration, h = runDuration_hour, rc = rc1)
+! print *,' runduration_hour=',runduration_hour,' rc1=',rc1
+ END IF
+ if (runDuration_hour < 0) then
+ print *,' FHINI=',FHINI, ' > FHMAX=',FHMAX,' JOB ABORTED'
+ call mpi_quit(444)
+ endif
+! stopTime = startTime + runDuration
+ stopTime = currTime + runDuration
+
+ CALL ESMF_ClockSet(clock, stopTime = stopTime, &
+! currTime = currTime, &
+ rc = rc1)
+!
+ CALL ESMF_TimeIntervalGet(timeStep, s = timeStep_sec, rc = rc1)
+
+ if (me == 0) print *,' timestep_sec=',timestep_sec,' rc1=',rc1
+!!
+ IF (me.eq.0) THEN
+ CALL out_para(REAL(timeStep_sec))
+ ENDIF
+!!
+ IF (me.eq.0) THEN
+ PRINT *,' THE GSM WILL FORECAST ',runDuration_hour,' HOURS', &
+ ' FROM HOUR ',gis%kfhour,' TO HOUR ',runDuration_hour+gis%kfhour
+ ENDIF
+!
+!
+!CALL ESMF_TimeGet (stopTime, yy = yyc, mm = mmc, dd = ddc, h = hhc, &
+! m = minsc, rc = rc1)
+!PRINT*, ' In Initialize , stopTime=', yyc, mmc, ddc, hhc, minsc
+!
+
+!
+ CALL synchro
+ CALL countperf(1,15,0.)
+!
+! zero fluxes and diagnostics
+ CALL countperf(0,14,0.)
+!
+ gis%zhour = fhour
+ gis%FLUXR = 0.
+!
+ call flx_init(gis%flx_fld,ierr)
+!
+ call d3d_zero(ldiag3d,lggfs3d)
+
+! if (ldiag3d) then
+! call d3d_zero
+! endif
+ CALL countperf(1,14,0.)
+!
+ END SUBROUTINE GFS_Initialize
+!
+ SUBROUTINE set_lonsgg(lonsperlat,lonsperlar,num_reduce,me)
+ use resol_def, only : jcapg
+ use reduce_lons_grid_module, only : reduce_grid ! hmhj
+ integer num_reduce, me ! hmhj
+ integer lonsperlat(latg),lonsperlar(latr)
+
+ integer lonsperlat_62(94),lonsperlar_62(94)
+ integer lonsperlat_126(190),lonsperlar_126(190)
+ integer lonsperlat_170(256),lonsperlar_170(256)
+ integer lonsperlat_190(288),lonsperlar_190(288)
+ integer lonsperlat_254(384),lonsperlar_254(384)
+ integer lonsperlat_382(576),lonsperlar_382(576)
+ integer lonsperlat_510(766),lonsperlar_510(766)
+ integer lonsperlat_574(880),lonsperlar_574(880)
+ integer lonsperlat_764(1152),lonsperlar_764(1152)
+
+ data lonsperlat_62/ &
+ 30, 30, 30, 40, 48, 56, 60, 72, 72, 80, 90, 90, &
+ 96, 110, 110, 120, 120, 128, 144, 144, 144, 144, 154, 160, &
+ 160, 168, 168, 180, 180, 180, 180, 180, 180, 192, 192, 192, &
+ 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 47*0/
+
+ data lonsperlar_62/ &
+ 30, 30, 30, 40, 48, 56, 60, 72, 72, 80, 90, 90, &
+ 96, 110, 110, 120, 120, 128, 144, 144, 144, 144, 154, 160, &
+ 160, 168, 168, 180, 180, 180, 180, 180, 180, 192, 192, 192, &
+ 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 192, 47*0/
+
+ data lonsperlat_126 / &
+ 30, 30, 36, 48, 56, 60, 72, 72, 80, 90, &
+ 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
+ 160, 180, 180, 180, 192, 192, 210, 210, 220, 220, &
+ 240, 240, 240, 240, 240, 252, 256, 280, 280, 280, &
+ 280, 288, 288, 288, 288, 308, 308, 308, 320, 320, &
+ 320, 320, 330, 330, 360, 360, 360, 360, 360, 360, &
+ 360, 360, 360, 360, 360, 360, 384, 384, 384, 384, &
+ 384, 384, 384, 384, 384, 384, 384, 384, 384, 384, &
+ 384, 384, 384, 384, 384, 384, 384, 384, 384, 384, &
+ 384, 384, 384, 384, 384, 95*0 /
+
+ data lonsperlar_126 / &
+ 30, 30, 36, 48, 56, 60, 72, 72, 80, 90, &
+ 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
+ 160, 180, 180, 180, 192, 192, 210, 210, 220, 220, &
+ 240, 240, 240, 240, 240, 252, 256, 280, 280, 280, &
+ 280, 288, 288, 288, 288, 308, 308, 308, 320, 320, &
+ 320, 320, 330, 330, 360, 360, 360, 360, 360, 360, &
+ 360, 360, 360, 360, 360, 360, 384, 384, 384, 384, &
+ 384, 384, 384, 384, 384, 384, 384, 384, 384, 384, &
+ 384, 384, 384, 384, 384, 384, 384, 384, 384, 384, &
+ 384, 384, 384, 384, 384, 95*0 /
+
+ data lonsperlat_170 / &
+ 48, 48, 48, 48, 48, 56, 60, 72, 72, 80, 90, 96, &
+ 110, 110, 120, 120, 128, 144, 144, 144, 154, 160, 168, 180, &
+ 180, 180, 192, 210, 210, 220, 220, 240, 240, 240, 240, 240, &
+ 252, 256, 280, 280, 280, 288, 288, 288, 308, 308, 320, 320, &
+ 320, 320, 330, 360, 360, 360, 360, 360, 360, 360, 384, 384, &
+ 384, 384, 384, 384, 420, 420, 420, 440, 440, 440, 440, 440, &
+ 440, 440, 440, 440, 462, 462, 462, 462, 462, 480, 480, 480, &
+ 480, 480, 480, 480, 480, 480, 480, 480, 504, 504, 504, 504, &
+ 504, 504, 504, 504, 504, 512, 512, 512, 512, 512, 512, 512, &
+ 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, &
+ 512, 512, 512, 512, 512, 512, 512, 512, 128*0 /
+
+ data lonsperlar_170 / &
+ 48, 48, 48, 48, 48, 56, 60, 72, 72, 80, 90, 96, &
+ 110, 110, 120, 120, 128, 144, 144, 144, 154, 160, 168, 180, &
+ 180, 180, 192, 210, 210, 220, 220, 240, 240, 240, 240, 240, &
+ 252, 256, 280, 280, 280, 288, 288, 288, 308, 308, 320, 320, &
+ 320, 320, 330, 360, 360, 360, 360, 360, 360, 360, 384, 384, &
+ 384, 384, 384, 384, 420, 420, 420, 440, 440, 440, 440, 440, &
+ 440, 440, 440, 440, 462, 462, 462, 462, 462, 480, 480, 480, &
+ 480, 480, 480, 480, 480, 480, 480, 480, 504, 504, 504, 504, &
+ 504, 504, 504, 504, 504, 512, 512, 512, 512, 512, 512, 512, &
+ 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, 512, &
+ 512, 512, 512, 512, 512, 512, 512, 512, 128*0 /
+
+ data lonsperlat_190 / &
+ 64, 64, 64, 64, 64, 64, 64, 70, 80, 84, &
+ 88, 110, 110, 110, 120, 126, 132, 140, 144, 154, &
+ 160, 168, 176, 176, 192, 192, 198, 210, 210, 220, &
+ 220, 240, 240, 240, 252, 252, 256, 264, 280, 280, &
+ 280, 288, 308, 308, 308, 320, 320, 320, 330, 336, &
+ 352, 352, 352, 352, 360, 384, 384, 384, 384, 384, &
+ 396, 396, 420, 420, 420, 420, 420, 440, 440, 440, &
+ 440, 440, 448, 448, 462, 462, 462, 480, 480, 480, &
+ 480, 480, 504, 504, 504, 504, 504, 504, 504, 512, &
+ 512, 528, 528, 528, 528, 528, 528, 560, 560, 560, &
+ 560, 560, 560, 560, 560, 560, 560, 560, 560, 560, &
+ 560, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
+ 576, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
+ 576, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
+ 576, 576, 576, 576, 144* 0/
+!
+ data lonsperlar_190 / &
+ 64, 64, 64, 64, 64, 64, 64, 70, 80, 84, &
+ 88, 110, 110, 110, 120, 126, 132, 140, 144, 154, &
+ 160, 168, 176, 176, 192, 192, 198, 210, 210, 220, &
+ 220, 240, 240, 240, 252, 252, 256, 264, 280, 280, &
+ 280, 288, 308, 308, 308, 320, 320, 320, 330, 336, &
+ 352, 352, 352, 352, 360, 384, 384, 384, 384, 384, &
+ 396, 396, 420, 420, 420, 420, 420, 440, 440, 440, &
+ 440, 440, 448, 448, 462, 462, 462, 480, 480, 480, &
+ 480, 480, 504, 504, 504, 504, 504, 504, 504, 512, &
+ 512, 528, 528, 528, 528, 528, 528, 560, 560, 560, &
+ 560, 560, 560, 560, 560, 560, 560, 560, 560, 560, &
+ 560, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
+ 576, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
+ 576, 576, 576, 576, 576, 576, 576, 576, 576, 576, &
+ 576, 576, 576, 576, 144* 0/
+
+ data lonsperlat_254 / &
+ 64, 64, 64, 64, 64, 64, 72, 72, 80, 90, &
+ 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
+ 168, 180, 180, 180, 192, 192, 210, 220, 220, 240, &
+ 240, 240, 240, 252, 256, 280, 280, 280, 288, 288, &
+ 288, 308, 308, 320, 320, 320, 330, 360, 360, 360, &
+ 360, 360, 360, 384, 384, 384, 384, 420, 420, 420, &
+ 440, 440, 440, 440, 440, 440, 462, 462, 462, 480, &
+ 480, 480, 480, 480, 480, 504, 504, 504, 504, 512, &
+ 512, 560, 560, 560, 560, 560, 560, 576, 576, 576, &
+ 576, 576, 576, 576, 576, 616, 616, 616, 616, 616, &
+ 616, 640, 640, 640, 640, 640, 640, 640, 640, 640, &
+ 640, 660, 660, 660, 720, 720, 720, 720, 720, 720, &
+ 720, 720, 720, 720, 720, 720, 720, 720, 720, 720, &
+ 720, 720, 720, 720, 720, 720, 720, 720, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 192*0/
+
+ data lonsperlar_254 / &
+ 64, 64, 64, 64, 64, 64, 72, 72, 80, 90, &
+ 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
+ 168, 180, 180, 180, 192, 192, 210, 220, 220, 240, &
+ 240, 240, 240, 252, 256, 280, 280, 280, 288, 288, &
+ 288, 308, 308, 320, 320, 320, 330, 360, 360, 360, &
+ 360, 360, 360, 384, 384, 384, 384, 420, 420, 420, &
+ 440, 440, 440, 440, 440, 440, 462, 462, 462, 480, &
+ 480, 480, 480, 480, 480, 504, 504, 504, 504, 512, &
+ 512, 560, 560, 560, 560, 560, 560, 576, 576, 576, &
+ 576, 576, 576, 576, 576, 616, 616, 616, 616, 616, &
+ 616, 640, 640, 640, 640, 640, 640, 640, 640, 640, &
+ 640, 660, 660, 660, 720, 720, 720, 720, 720, 720, &
+ 720, 720, 720, 720, 720, 720, 720, 720, 720, 720, &
+ 720, 720, 720, 720, 720, 720, 720, 720, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 768, 768, 192*0/
+
+ data lonsperlat_382 / &
+ 64, 64, 64, 64, 64, 64, 64, 70, 80, 84, &
+ 88, 96, 110, 110, 120, 126, 132, 140, 144, 154, &
+ 160, 168, 176, 180, 192, 192, 198, 210, 220, 220, &
+ 224, 240, 240, 252, 252, 256, 264, 280, 280, 280, &
+ 288, 308, 308, 308, 320, 320, 330, 336, 352, 352, &
+ 352, 360, 384, 384, 384, 384, 396, 396, 420, 420, &
+ 420, 420, 440, 440, 440, 448, 448, 462, 462, 480, &
+ 480, 480, 504, 504, 504, 504, 512, 528, 528, 528, &
+ 560, 560, 560, 560, 560, 560, 576, 576, 616, 616, &
+ 616, 616, 616, 616, 616, 616, 630, 630, 640, 640, &
+ 660, 660, 660, 660, 672, 672, 704, 704, 704, 704, &
+ 704, 704, 720, 720, 720, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 792, 792, 792, 792, 792, &
+ 840, 840, 840, 840, 840, 840, 840, 840, 840, 840, &
+ 880, 880, 880, 880, 880, 880, 880, 880, 880, 880, &
+ 896, 896, 896, 896, 924, 924, 924, 924, 924, 924, &
+ 960, 960, 960, 960, 960, 960, 960, 960, 960, 960, &
+ 990, 990, 990, 990, 990, 990, 990, 990,1008,1008, &
+ 1008,1008,1008,1008,1024,1024,1024,1024,1024,1024, &
+ 1056,1056,1056,1056,1056,1056,1056,1056,1056,1056, &
+ 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
+ 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
+ 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
+ 1120,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152, 288* 0/
+
+ data lonsperlar_382 / &
+ 64, 64, 64, 64, 64, 64, 64, 70, 80, 84, &
+ 88, 96, 110, 110, 120, 126, 132, 140, 144, 154, &
+ 160, 168, 176, 180, 192, 192, 198, 210, 220, 220, &
+ 224, 240, 240, 252, 252, 256, 264, 280, 280, 280, &
+ 288, 308, 308, 308, 320, 320, 330, 336, 352, 352, &
+ 352, 360, 384, 384, 384, 384, 396, 396, 420, 420, &
+ 420, 420, 440, 440, 440, 448, 448, 462, 462, 480, &
+ 480, 480, 504, 504, 504, 504, 512, 528, 528, 528, &
+ 560, 560, 560, 560, 560, 560, 576, 576, 616, 616, &
+ 616, 616, 616, 616, 616, 616, 630, 630, 640, 640, &
+ 660, 660, 660, 660, 672, 672, 704, 704, 704, 704, &
+ 704, 704, 720, 720, 720, 768, 768, 768, 768, 768, &
+ 768, 768, 768, 768, 768, 792, 792, 792, 792, 792, &
+ 840, 840, 840, 840, 840, 840, 840, 840, 840, 840, &
+ 880, 880, 880, 880, 880, 880, 880, 880, 880, 880, &
+ 896, 896, 896, 896, 924, 924, 924, 924, 924, 924, &
+ 960, 960, 960, 960, 960, 960, 960, 960, 960, 960, &
+ 990, 990, 990, 990, 990, 990, 990, 990,1008,1008, &
+ 1008,1008,1008,1008,1024,1024,1024,1024,1024,1024, &
+ 1056,1056,1056,1056,1056,1056,1056,1056,1056,1056, &
+ 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
+ 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
+ 1120,1120,1120,1120,1120,1120,1120,1120,1120,1120, &
+ 1120,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152,1152,1152, &
+ 1152,1152,1152,1152,1152,1152,1152,1152, 288* 0/
+
+ data lonsperlat_510 / &
+ 64, 64, 64, 64, 64, 64, 72, 72, 80, 90, &
+ 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
+ 168, 180, 180, 180, 192, 210, 210, 220, 220, 240, &
+ 240, 240, 240, 252, 256, 280, 280, 288, 288, 288, &
+ 308, 308, 320, 320, 320, 330, 360, 360, 360, 360, &
+ 360, 384, 384, 384, 384, 420, 420, 440, 440, 440, &
+ 440, 440, 440, 462, 462, 462, 480, 480, 480, 480, &
+ 504, 504, 504, 504, 512, 512, 560, 560, 560, 560, &
+ 576, 576, 576, 576, 576, 576, 616, 616, 616, 616, &
+ 640, 640, 640, 640, 640, 640, 640, 660, 720, 720, &
+ 720, 720, 720, 720, 720, 720, 720, 720, 720, 720, &
+ 720, 768, 768, 768, 768, 768, 768, 768, 768, 840, &
+ 840, 840, 840, 840, 840, 840, 840, 880, 880, 880, &
+ 880, 880, 880, 880, 880, 880, 880, 924, 924, 924, &
+ 924, 924, 924, 924, 960, 960, 960, 960, 960, 960, &
+ 960, 960, 960, 960, 960, 990, 990, 990, 1008, 1008, &
+ 1008, 1008, 1008, 1024, 1024, 1024, 1024, 1024, 1120, 1120, &
+ 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, &
+ 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, &
+ 1152, 1152, 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, &
+ 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1260, 1260, &
+ 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, &
+ 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1320, &
+ 1320, 1320, 1320, 1386, 1386, 1386, 1386, 1386, 1386, 1386, &
+ 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, &
+ 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
+ 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
+ 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
+ 1440, 1440, 1440, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 383*0/
+
+ data lonsperlar_510 / &
+ 64, 64, 64, 64, 64, 64, 72, 72, 80, 90, &
+ 96, 110, 110, 120, 120, 128, 144, 144, 154, 160, &
+ 168, 180, 180, 180, 192, 210, 210, 220, 220, 240, &
+ 240, 240, 240, 252, 256, 280, 280, 288, 288, 288, &
+ 308, 308, 320, 320, 320, 330, 360, 360, 360, 360, &
+ 360, 384, 384, 384, 384, 420, 420, 440, 440, 440, &
+ 440, 440, 440, 462, 462, 462, 480, 480, 480, 480, &
+ 504, 504, 504, 504, 512, 512, 560, 560, 560, 560, &
+ 576, 576, 576, 576, 576, 576, 616, 616, 616, 616, &
+ 640, 640, 640, 640, 640, 640, 640, 660, 720, 720, &
+ 720, 720, 720, 720, 720, 720, 720, 720, 720, 720, &
+ 720, 768, 768, 768, 768, 768, 768, 768, 768, 840, &
+ 840, 840, 840, 840, 840, 840, 840, 880, 880, 880, &
+ 880, 880, 880, 880, 880, 880, 880, 924, 924, 924, &
+ 924, 924, 924, 924, 960, 960, 960, 960, 960, 960, &
+ 960, 960, 960, 960, 960, 990, 990, 990, 1008, 1008, &
+ 1008, 1008, 1008, 1024, 1024, 1024, 1024, 1024, 1120, 1120, &
+ 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, &
+ 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, 1152, &
+ 1152, 1152, 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, &
+ 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1260, 1260, &
+ 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1260, &
+ 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1280, 1320, &
+ 1320, 1320, 1320, 1386, 1386, 1386, 1386, 1386, 1386, 1386, &
+ 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, &
+ 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
+ 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
+ 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
+ 1440, 1440, 1440, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 383*0/
+
+ data lonsperlat_574 / &
+ 18, 28, 32, 42, 48, 56, 64, 72, 80, 84, &
+ 90, 110, 110, 110, 120, 126, 132, 140, 144, 154, &
+ 160, 168, 176, 176, 192, 192, 198, 210, 210, 220, &
+ 224, 240, 240, 252, 252, 256, 264, 280, 280, 288, &
+ 288, 308, 308, 308, 320, 320, 330, 330, 352, 352, &
+ 352, 360, 384, 384, 384, 384, 396, 396, 420, 420, &
+ 420, 420, 440, 440, 440, 448, 462, 462, 462, 480, &
+ 480, 480, 504, 504, 504, 504, 512, 528, 528, 528, &
+ 560, 560, 560, 560, 560, 576, 576, 576, 616, 616, &
+ 616, 616, 616, 616, 630, 630, 630, 640, 660, 660, &
+ 660, 660, 672, 672, 704, 704, 704, 704, 704, 720, &
+ 720, 720, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 770, 792, 792, 792, 792, 840, 840, 840, 840, 840, &
+ 840, 840, 840, 880, 880, 880, 880, 880, 880, 880, &
+ 896, 896, 896, 896, 924, 924, 924, 924, 924, 960, &
+ 960, 960, 960, 960, 960, 960, 990, 990, 990, 990, &
+ 990, 1008, 1008, 1008, 1008, 1024, 1024, 1024, 1056, 1056, &
+ 1056, 1056, 1056, 1056, 1120, 1120, 1120, 1120, 1120, 1120, &
+ 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1152, 1152, 1152, &
+ 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, 1232, 1232, &
+ 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, &
+ 1232, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1280, 1280, &
+ 1280, 1280, 1280, 1320, 1320, 1320, 1320, 1320, 1320, 1320, &
+ 1320, 1320, 1344, 1344, 1344, 1344, 1344, 1344, 1386, 1386, &
+ 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1408, &
+ 1408, 1408, 1408, 1408, 1440, 1440, 1440, 1440, 1440, 1440, &
+ 1440, 1440, 1440, 1440, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1584, 1584, 1584, 1584, 1584, 1584, &
+ 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, &
+ 1584, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 440*0/
+
+ data lonsperlar_574 / &
+ 18, 28, 32, 42, 48, 56, 64, 72, 80, 84, &
+ 90, 110, 110, 110, 120, 126, 132, 140, 144, 154, &
+ 160, 168, 176, 176, 192, 192, 198, 210, 210, 220, &
+ 224, 240, 240, 252, 252, 256, 264, 280, 280, 288, &
+ 288, 308, 308, 308, 320, 320, 330, 330, 352, 352, &
+ 352, 360, 384, 384, 384, 384, 396, 396, 420, 420, &
+ 420, 420, 440, 440, 440, 448, 462, 462, 462, 480, &
+ 480, 480, 504, 504, 504, 504, 512, 528, 528, 528, &
+ 560, 560, 560, 560, 560, 576, 576, 576, 616, 616, &
+ 616, 616, 616, 616, 630, 630, 630, 640, 660, 660, &
+ 660, 660, 672, 672, 704, 704, 704, 704, 704, 720, &
+ 720, 720, 768, 768, 768, 768, 768, 768, 768, 768, &
+ 770, 792, 792, 792, 792, 840, 840, 840, 840, 840, &
+ 840, 840, 840, 880, 880, 880, 880, 880, 880, 880, &
+ 896, 896, 896, 896, 924, 924, 924, 924, 924, 960, &
+ 960, 960, 960, 960, 960, 960, 990, 990, 990, 990, &
+ 990, 1008, 1008, 1008, 1008, 1024, 1024, 1024, 1056, 1056, &
+ 1056, 1056, 1056, 1056, 1120, 1120, 1120, 1120, 1120, 1120, &
+ 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1152, 1152, 1152, &
+ 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, 1232, 1232, &
+ 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, &
+ 1232, 1260, 1260, 1260, 1260, 1260, 1260, 1260, 1280, 1280, &
+ 1280, 1280, 1280, 1320, 1320, 1320, 1320, 1320, 1320, 1320, &
+ 1320, 1320, 1344, 1344, 1344, 1344, 1344, 1344, 1386, 1386, &
+ 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1408, &
+ 1408, 1408, 1408, 1408, 1440, 1440, 1440, 1440, 1440, 1440, &
+ 1440, 1440, 1440, 1440, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1584, 1584, 1584, 1584, 1584, 1584, &
+ 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, &
+ 1584, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 440*0/
+! T764
+ data lonsperlat_764 / &
+ 18, 22, 30, 40, 44, 56, 60, 66, 72, 80, &
+ 88, 96, 110, 110, 112, 120, 126, 132, 140, 154, &
+ 154, 160, 168, 176, 180, 192, 192, 198, 210, 220, &
+ 220, 224, 240, 240, 252, 252, 256, 264, 280, 280, &
+ 288, 308, 308, 308, 308, 320, 330, 330, 336, 352, &
+ 352, 360, 360, 384, 384, 384, 396, 396, 420, 420, &
+ 420, 420, 440, 440, 440, 448, 448, 462, 462, 480, &
+ 480, 480, 504, 504, 504, 504, 512, 528, 528, 560, &
+ 560, 560, 560, 560, 576, 576, 576, 616, 616, 616, &
+ 616, 616, 616, 616, 630, 630, 640, 660, 660, 660, &
+ 660, 672, 672, 704, 704, 704, 704, 704, 720, 720, &
+ 720, 768, 768, 768, 768, 768, 768, 768, 770, 792, &
+ 792, 792, 840, 840, 840, 840, 840, 840, 840, 840, &
+ 840, 880, 880, 880, 880, 880, 880, 896, 896, 896, &
+ 924, 924, 924, 924, 924, 960, 960, 960, 960, 960, &
+ 960, 990, 990, 990, 990, 990, 1008, 1008, 1008, 1024, &
+ 1024, 1024, 1056, 1056, 1056, 1056, 1056, 1056, 1120, 1120, &
+ 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1120, 1152, &
+ 1152, 1152, 1152, 1152, 1152, 1232, 1232, 1232, 1232, 1232, &
+ 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, 1232, &
+ 1260, 1260, 1260, 1260, 1260, 1280, 1280, 1280, 1280, 1320, &
+ 1320, 1320, 1320, 1320, 1320, 1320, 1344, 1344, 1344, 1344, &
+ 1344, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1386, 1408, &
+ 1408, 1408, 1408, 1440, 1440, 1440, 1440, 1440, 1440, 1440, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, 1536, &
+ 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, 1584, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, 1680, &
+ 1680, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, 1760, &
+ 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1792, 1848, 1848, &
+ 1848, 1848, 1848, 1848, 1848, 1848, 1848, 1848, 1848, 1848, &
+ 1848, 1848, 1848, 1920, 1920, 1920, 1920, 1920, 1920, 1920, &
+ 1920, 1920, 1920, 1920, 1920, 1920, 1920, 1920, 1920, 1920, &
+ 1920, 1920, 1980, 1980, 1980, 1980, 1980, 1980, 1980, 1980, &
+ 1980, 1980, 1980, 1980, 1980, 1980, 1980, 1980, 1980, 1980, &
+ 2016, 2016, 2016, 2016, 2016, 2016, 2016, 2016, 2016, 2016, &
+ 2016, 2048, 2048, 2048, 2048, 2048, 2048, 2048, 2048, 2048, &
+ 2048, 2048, 2112, 2112, 2112, 2112, 2112, 2112, 2112, 2112, &
+ 2112, 2112, 2112, 2112, 2112, 2112, 2112, 2112, 2112, 2112, &
+ 2112, 2112, 2112, 2112, 2112, 2240, 2240, 2240, 2240, 2240, &
+ 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
+ 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
+ 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
+ 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
+ 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, &
+ 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2240, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, 2304, &
+ 2304, 2304, 2304, 2304, 2304, 2304, 576*0/
+
+ integer i
+ if (num_reduce < 0) then
+ if (jcapg .eq. 62) then
+ lonsperlat=lonsperlat_62
+ lonsperlar=lonsperlar_62
+ endif
+ if (jcapg .eq. 126) then
+ lonsperlat=lonsperlat_126
+ lonsperlar=lonsperlar_126
+ endif
+ if (jcapg .eq. 170) then
+ lonsperlat=lonsperlat_170
+ lonsperlar=lonsperlar_170
+ endif
+ if (jcapg .eq. 190) then
+ lonsperlat=lonsperlat_190
+ lonsperlar=lonsperlar_190
+ endif
+ if (jcapg .eq. 254) then
+ lonsperlat=lonsperlat_254
+ lonsperlar=lonsperlar_254
+ endif
+ if (jcapg .eq. 382) then
+ lonsperlat=lonsperlat_382
+ lonsperlar=lonsperlar_382
+ endif
+ if (jcapg .eq. 510) then
+ lonsperlat=lonsperlat_510
+ lonsperlar=lonsperlar_510
+ endif
+ if (jcapg .eq. 574) then
+ lonsperlat=lonsperlat_574
+ lonsperlar=lonsperlar_574
+ endif
+ if (jcapg == 764) then
+ lonsperlat=lonsperlat_764
+ lonsperlar=lonsperlat_764
+ endif
+ endif
+
+ if (jcapg .ne. 62 .and. jcapg .ne. 126 .and. jcapg .ne. 170 .and. &
+ jcapg .ne. 190 .and. jcapg .ne. 254 .and. jcapg .ne. 382 .and. &
+ jcapg .ne. 510 .and. jcapg .ne. 574 .and. jcapg .ne. 764) then
+! print*,' Resolution not supported - lonsperlar/lonsperlat &
+! &data is needed in read_lonsgg '
+! stop 55
+! compute reduced grid using juang 2003
+ if ( me == 0 ) then
+ print*,' Non Standard Resolution - lonsperlar/lonsperlat', &
+ ' computed locally'
+ endif
+ call reduce_grid (abs(num_reduce),jcapg,latg,lonsperlat) ! hmhj
+ lonsperlar=lonsperlat ! hmhj
+ if ( me == 0 ) then
+ print*,' Reduced grid is computed - lonsperlar/lonsperlat ' ! hmhj
+ endif
+ endif
+
+ if ( me == 0 ) then
+ print*,' jcapg = ',jcapg
+ print*,'min,max of lonsperlat = ',minval(lonsperlat), &
+ maxval(lonsperlat)
+ print*,'min,max of lonsperlar = ',minval(lonsperlar), &
+ maxval(lonsperlar)
+ endif
+ END SUBROUTINE set_lonsgg
+
+ END MODULE GFS_Initialize_ESMFMod
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/GFS_InternalState_ESMFMod.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/GFS_InternalState_ESMFMod.f_gfs (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/GFS_InternalState_ESMFMod.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,327 @@
+!
+! !MODULE: GFS_InternalState_ESMFMod --- Internal state definition of the
+! ESMF gridded component of the GFS system.
+!
+! !DESCRIPTION: GFS_InternalState_ESMFMod --- Define the GFS internal state used to
+! create the ESMF internal state.
+!---------------------------------------------------------------------------
+! !REVISION HISTORY:
+!
+! November 2004 Weiyu Yang Initial code.
+! May 2005 Weiyu Yang for the updated GFS version.
+! February 2006 Shrinivas Moorthi updated for the new version of GFS
+! September2006 Weiyu Yang For the ensemble run couple version.
+! April 2009 Shrinivas Moorthi merge GEFS and generalized GFS versions
+!
+! !INTERFACE:
+!
+ MODULE GFS_InternalState_ESMFMod
+
+!!USES:
+!------
+ USE ESMF_Mod
+!USE nam_mrf_NAMSFC_NameList_ESMFMod
+ USE NameList_ESMFMod
+
+ USE MACHINE, ONLY: kind_rad, kind_phys, kind_io4, kind_evod
+!USE resol_def ! Wei yu's version did not have this why?
+ USE layout1
+ USE gg_def
+ USE vert_def
+ USE sig_io
+ USE date_def
+ USE namelist_def
+ USE namelist_soilveg
+ USE mpi_def
+!!!!!! USE semi_lag_def
+ USE coordinate_def ! hmhj
+ USE tracer_const ! hmhj
+ USE matrix_sig_def
+ use module_ras , only : nrcmax
+ use ozne_def
+ use d3d_def
+ use Sfc_Flx_ESMFMod
+ use Nst_Var_ESMFMod
+
+ IMPLICIT none
+
+ TYPE GFS_InternalState
+
+! TYPE(nam_gfs_Namelist) :: nam_gfs
+! TYPE(SOIL_VEG_NameList) :: SOIL_VEG
+! TYPE(NAMSFC_NameList) :: NAMSFC
+ TYPE(nam_gfs_NameList) :: nam_gfs
+ TYPE(ESMF_State_Namelist) :: ESMF_Sta_List
+
+ TYPE(Sfc_Var_Data) :: sfc_fld
+ TYPE(Flx_Var_Data) :: flx_fld
+
+ TYPE(Nst_Var_Data) :: nst_fld
+
+ INTEGER :: me, mm1, nodes
+ INTEGER :: lonr_s, latr_s, lnt2_s
+ INTEGER :: lnt2, grid4_i1(2)
+ integer :: grib_inp
+ INTEGER :: npe_single_member
+
+ REAL(KIND = kind_io4), DIMENSION(:, :), POINTER :: &
+ z_im, ps_im, vor_im, div_im, temp_im, q_im, oz_im, scld_im, &
+ z_ex, ps_ex, vor_ex, div_ex, temp_ex, q_ex, oz_ex, scld_ex
+
+ REAL(KIND = kind_evod), DIMENSION(:, :), POINTER :: trieo_ls_im
+ REAL(KIND = kind_evod), DIMENSION(:, :), POINTER :: write_work8
+ REAL(KIND = kind_evod), DIMENSION(:, :), POINTER :: write_work8_ini
+
+!
+! idate1_im and idate1_ex: (1) --- bfhour (integer), (2) - (5) --- idate.
+!-------------------------------------------------------------------------
+!
+ INTEGER, DIMENSION(:, :), POINTER :: idate1_im, idate1_ex
+
+ REAL(KIND = kind_io4), DIMENSION(:, :), POINTER :: &
+ orography_im, t_skin_im, snow_depth_im, &
+ deep_soil_t_im, roughness_im, conv_cloud_cover_im, &
+ conv_cloud_base_im, conv_cloud_top_im, albedo_visible_scattered_im,&
+ albedo_visible_beam_im, albedo_nearIR_scattered_im, albedo_nearIR_beam_im, &
+ sea_level_ice_mask_im, vegetation_cover_im, canopy_water_im, &
+ m10_wind_fraction_im, vegetation_type_im, soil_type_im, &
+ zeneith_angle_facsf_im, zeneith_angle_facwf_im, uustar_im, &
+ ffmm_im, ffhh_im, sea_ice_thickness_im, &
+ sea_ice_concentration_im, tprcp_im, srflag_im, &
+ actual_snow_depth_im, vegetation_cover_min_im, vegetation_cover_max_im, &
+ slope_type_im, snow_albedo_max_im, &
+
+! MOdified by Weiyu (DHOU, 04/04/2008).
+!-------------------
+ soil_t_im1, soil_t_im2, soil_t_im3, soil_mois_im1, soil_mois_im2, soil_mois_im3, &
+ liquid_soil_moisture_im1, liquid_soil_moisture_im2, liquid_soil_moisture_im3, &
+
+ orography_ex, t_skin_ex, snow_depth_ex, &
+ deep_soil_t_ex, roughness_ex, conv_cloud_cover_ex, &
+ conv_cloud_base_ex, conv_cloud_top_ex, albedo_visible_scattered_ex,&
+ albedo_visible_beam_ex, albedo_nearIR_scattered_ex, albedo_nearIR_beam_ex, &
+ sea_level_ice_mask_ex, vegetation_cover_ex, canopy_water_ex, &
+ m10_wind_fraction_ex, vegetation_type_ex, soil_type_ex, &
+ zeneith_angle_facsf_ex, zeneith_angle_facwf_ex, uustar_ex, &
+ ffmm_ex, ffhh_ex, sea_ice_thickness_ex, &
+ sea_ice_concentration_ex, tprcp_ex, srflag_ex, &
+ actual_snow_depth_ex, vegetation_cover_min_ex, vegetation_cover_max_ex, &
+ slope_type_ex, snow_albedo_max_ex
+
+ REAL(KIND = kind_io4), DIMENSION(:, :, :), POINTER :: &
+ soil_mois_im, soil_t_im, soil_mois_ex, soil_t_ex, &
+ liquid_soil_moisture_im, liquid_soil_moisture_ex
+
+! To represent the trie_ls and trio_ls in the ESMF states, add levh. Weiyu.
+!--------------------------------------------------------------------------
+
+! INTEGER ntrac,nxpt,nypt,jintmx,jcap,levs,levh,lonf,lonr,latg,latr
+ INTEGER ntrac,jcapg,jcap,levs,levh,lonf,lonr,latg,latr
+ INTEGER ntoz, ntcw, ncld, lsoil, nmtvr, num_p3d, num_p2d,levr
+
+ CHARACTER(16) :: CFHOUR1
+
+ INTEGER :: KDT
+ REAL :: DELTIM
+
+! For creating the ESMF interface state with the GFS
+! internal parallel structure. Weiyu.
+!---------------------------------------------------
+ INTEGER :: TRIEO_TOTAL_SIZE
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: TRIE_LS_SIZE, TRIO_LS_SIZE
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: TRIEO_LS_SIZE
+ INTEGER, ALLOCATABLE, DIMENSION(:) :: LS_MAX_NODE_GLOBAL
+ INTEGER, ALLOCATABLE, DIMENSION(:, :) :: LS_NODE_GLOBAL
+
+! For flexible choose the time interval of the tendency time difference.
+!-----------------------------------------------------------------------
+ INTEGER :: advanceCount_SetUp
+
+ CHARACTER(ESMF_MAXSTR) :: TRIEO_STATE_NAME
+ CHARACTER(ESMF_MAXSTR) :: TRIEO_STINI_NAME
+
+ INTEGER ,ALLOCATABLE :: LONSPERLAT (:)
+ INTEGER ,ALLOCATABLE :: lonsperlar (:)
+ INTEGER ,ALLOCATABLE :: LS_NODE (:)
+ INTEGER ,ALLOCATABLE :: LS_NODES (:, :)
+ INTEGER ,ALLOCATABLE :: MAX_LS_NODES (:)
+
+ INTEGER ,ALLOCATABLE :: LATS_NODES_A (:)
+ INTEGER ,ALLOCATABLE :: GLOBAL_LATS_A (:)
+! INTEGER ,ALLOCATABLE :: LATS_NODES_EXT (:)
+! INTEGER ,ALLOCATABLE :: GLOBAL_LATS_EXT(:)
+
+ INTEGER ,ALLOCATABLE :: LATS_NODES_R (:)
+ INTEGER ,ALLOCATABLE :: GLOBAL_LATS_R (:)
+
+ real(kind=kind_phys) ,allocatable :: fscav(:)
+
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: EPSE (:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: EPSO (:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: EPSEDN(:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: EPSODN(:)
+
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SNNP1EV(:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SNNP1OD(:)
+
+ INTEGER ,ALLOCATABLE :: NDEXEV(:)
+ INTEGER ,ALLOCATABLE :: NDEXOD(:)
+
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNEV_A(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNOD_A(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PDDEV_A(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PDDOD_A(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNEW_A(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNOW_A(:,:)
+
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNEV_R(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNOD_R(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PDDEV_R(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PDDOD_R(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNEW_R(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PLNOW_R(:,:)
+
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: TRIE_LS(:,:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: TRIO_LS(:,:,:)
+
+! For Ensemble forecast requirement, add two more arrays to save the
+! initial conditions. Weiyu.
+!------------------------------------------------------------------
+ REAL(KIND=KIND_EVOD) , POINTER :: TRIE_LS_INI(:,:,:)
+ REAL(KIND=KIND_EVOD) , POINTER :: TRIO_LS_INI(:,:,:)
+
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SYN_LS_A(:,:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DYN_LS_A(:,:,:)
+
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SYN_GR_A_1(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SYN_GR_A_2(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DYN_GR_A_1(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DYN_GR_A_2(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: ANL_GR_A_1(:,:)
+ REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: ANL_GR_A_2(:,:)
+
+ REAL(KIND=KIND_RAD) ,ALLOCATABLE :: XLON(:,:),XLAT(:,:)
+ REAL(KIND=KIND_RAD) ,ALLOCATABLE :: COSZDG(:,:)
+ REAL(KIND=KIND_RAD) ,ALLOCATABLE :: sfalb(:,:)
+ REAL(KIND=KIND_RAD) ,ALLOCATABLE :: HPRIME(:,:,:)
+ REAL(KIND=KIND_RAD) ,ALLOCATABLE :: SWH(:,:,:),HLW(:,:,:)
+ REAL(KIND=KIND_RAD) ,ALLOCATABLE :: FLUXR(:,:,:)
+!!
+
+! REAL(KIND=KIND_RAD) ,ALLOCATABLE :: phy_f3d(:,:,:,:,:)
+ REAL(KIND=KIND_RAD) ,ALLOCATABLE :: phy_f3d(:,:,:,:)
+ REAL(KIND=KIND_RAD) ,ALLOCATABLE :: phy_f2d(:,:,:)
+
+!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: LBASIY(:,:,:)
+!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PHI(:)
+!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DPHI(:)
+!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: DLAM(:),LAMEXT(:,:),LAM(:,:)
+!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: LAMMP(:,:,:)
+!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: PHIMP(:,:,:)
+!JFE REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: SIGMP(:,:,:)
+!!
+! FOR OZONE PRODUCTION AND DISTRUCTION RATES:(INPUT THROU FIXIO_R)
+ INTEGER LEV,LEVMAX
+!!$$$ PARAMETER (LATS18=18, LEV46=46)
+!!$$$ REAL POZ(LEV46),PHOUR
+!!$$$ REAL OZPRDIN(LATS18,LEV46,36) !OZON PRODUCTION RATE
+!!$$$ REAL OZDISIN(LATS18,LEV46,36) !OZON DISTUCTION RATE
+ real phour
+ INTEGER :: KFHOUR
+ real, allocatable :: poz(:),ozplin(:,:,:,:)
+! FOR OZONE INTERPOLATION:
+ INTEGER,ALLOCATABLE:: JINDX1(:),JINDX2(:)
+!
+ REAL (KIND=KIND_PHYS) PDRYINI
+ REAL,ALLOCATABLE:: DDY(:)
+ REAL(KIND=KIND_EVOD) SLAG,SDEC,CDEC
+!!
+!JFE INTEGER,ALLOCATABLE :: LATSINPE(:)
+!JFE INTEGER,ALLOCATABLE :: LATLOCAL(:,:)
+
+ INTEGER INIT,JCOUNT,JPT,NODE
+ INTEGER IBMSIGN
+ INTEGER LON_DIM,ILAT
+
+ real(kind=kind_evod) colat1
+!!
+ REAL(KIND=KIND_EVOD) RONE
+ REAL(KIND=KIND_EVOD) RLONS_LAT
+ REAL(KIND=KIND_EVOD) SCALE_IBM
+
+ INTEGER P_GZ,P_ZEM,P_DIM,P_TEM,P_RM,P_QM
+ INTEGER P_ZE,P_DI,P_TE,P_RQ,P_Q,P_DLAM,P_DPHI,P_ULN,P_VLN
+ INTEGER P_W,P_X,P_Y,P_RT,P_ZQ
+!C OLD COMMON /COMFSPEC/
+!!$$$ PARAMETER(P_GZ = 0*LEVS+0*LEVH+1, ! GZE/O(LNTE/OD,2),
+!!$$$ X P_ZEM = 0*LEVS+0*LEVH+2, ! ZEME/O(LNTE/OD,2,LEVS),
+!!$$$ X P_DIM = 1*LEVS+0*LEVH+2, ! DIME/O(LNTE/OD,2,LEVS),
+!!$$$ X P_TEM = 2*LEVS+0*LEVH+2, ! TEME/O(LNTE/OD,2,LEVS),
+!!$$$ X P_RM = 3*LEVS+0*LEVH+2, ! RME/O(LNTE/OD,2,LEVH),
+!!$$$ X P_QM = 3*LEVS+1*LEVH+2, ! QME/O(LNTE/OD,2),
+!!$$$ X P_ZE = 3*LEVS+1*LEVH+3, ! ZEE/O(LNTE/OD,2,LEVS),
+!!$$$ X P_DI = 4*LEVS+1*LEVH+3, ! DIE/O(LNTE/OD,2,LEVS),
+!!$$$ X P_TE = 5*LEVS+1*LEVH+3, ! TEE/O(LNTE/OD,2,LEVS),
+!!$$$ X P_RQ = 6*LEVS+1*LEVH+3, ! RQE/O(LNTE/OD,2,LEVH),
+!!$$$ X P_Q = 6*LEVS+2*LEVH+3, ! QE/O(LNTE/OD,2),
+!!$$$ X P_DLAM= 6*LEVS+2*LEVH+4, ! DPDLAME/O(LNTE/OD,2),
+!!$$$ X P_DPHI= 6*LEVS+2*LEVH+5, ! DPDPHIE/O(LNTE/OD,2),
+!!$$$ X P_ULN = 6*LEVS+2*LEVH+6, ! ULNE/O(LNTE/OD,2,LEVS),
+!!$$$ X P_VLN = 7*LEVS+2*LEVH+6, ! VLNE/O(LNTE/OD,2,LEVS),
+!!$$$ X P_W = 8*LEVS+2*LEVH+6, ! WE/O(LNTE/OD,2,LEVS),
+!!$$$ X P_X = 9*LEVS+2*LEVH+6, ! XE/O(LNTE/OD,2,LEVS),
+!!$$$ X P_Y =10*LEVS+2*LEVH+6, ! YE/O(LNTE/OD,2,LEVS),
+!!$$$ X P_RT =11*LEVS+2*LEVH+6, ! RTE/O(LNTE/OD,2,LEVH),
+!!$$$ X P_ZQ =11*LEVS+3*LEVH+6) ! ZQE/O(LNTE/OD,2)
+
+ INTEGER LOTS,LOTD,LOTA
+
+!!$$$ PARAMETER ( LOTS = 5*LEVS+1*LEVH+3 )
+!!$$$ PARAMETER ( LOTD = 6*LEVS+2*LEVH+0 )
+!!$$$ PARAMETER ( LOTA = 3*LEVS+1*LEVH+1 )
+
+ INTEGER IBRAD,IFGES,IHOUR,INI,J,JDT,KSOUT,MAXSTP
+ INTEGER mdt,idt,timetot,timer,time0
+ INTEGER MODS,N1,N2,N3,N4,NDGF,NDGI,NFILES,NFLPS
+ INTEGER n1hyb, n2hyb
+ INTEGER NGES,NGPKEN,NITER,NNMOD,NRADF,NRADR
+ INTEGER NSFCF,NSFCI,NSFCS,NSIGI,NSIGS,NSTEP
+! INTEGER NZNLF,NZNLI,NZNLS,ID,IRET,NSOUT
+ INTEGER NZNLF,NZNLI,NZNLS,ID,IRET,NSOUT,kdt_switch
+
+ INTEGER IERR,IPRINT,K,L,LOCL,N
+ INTEGER LAN,LAT
+
+ REAL(KIND=KIND_EVOD) CHOUR
+ REAL(KIND=KIND_EVOD) zhour
+ LOGICAL LSOUT
+ LOGICAL SPS
+!DHOU 05/28/2008, add SPS for applying stochastic or not
+ INTEGER HOUTASPS
+!DHOU 09/08/2008, add HOUTASPS for time (iintegration hour) of output after SPS
+
+ REAL(KIND=KIND_EVOD),ALLOCATABLE :: TEE1(:)
+
+!JFE REAL(KIND=KIND_EVOD) PHIBS,DPHIBR
+
+!!$$$ INTEGER INDLSEV,JBASEV
+!!$$$ INTEGER INDLSOD,JBASOD
+
+
+ INTEGER ikey,nrank_all,kcolor
+
+ REAL(KIND=KIND_EVOD) CONS0P5,CONS1200,CONS3600 !CONSTANT
+ REAL(KIND=KIND_EVOD) CONS0 !CONSTANT
+
+ LOGICAL LSLAG
+
+ END TYPE GFS_InternalState
+
+! This state is supported by C pointer not F90 pointer, thus
+! need this wrap.
+!-----------------------------------------------------------
+ TYPE GFS_wrap
+ TYPE (GFS_InternalState), POINTER :: Int_State
+ END TYPE GFS_wrap
+
+ END MODULE GFS_InternalState_ESMFMod
Property changes on: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/GFS_InternalState_ESMFMod.f_gfs
___________________________________________________________________
Added: svn:executable
+ *
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/dotstep_tracers.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/dotstep_tracers.f_gfs (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/dotstep_tracers.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,1073 @@
+ SUBROUTINE do_tstep(deltim,kdt,PHOUR,
+ & TRIE_LS,TRIO_LS,
+ & LS_NODE,LS_NODES,MAX_LS_NODES,
+ & LATS_NODES_A,GLOBAL_LATS_A,
+ & LONSPERLAT,
+ & LATS_NODES_R,GLOBAL_LATS_R,
+ & LONSPERLAR,
+! & LATS_NODES_EXT,GLOBAL_LATS_EXT,
+ & EPSE,EPSO,EPSEDN,EPSODN,
+ & SNNP1EV,SNNP1OD,NDEXEV,NDEXOD,
+ & PLNEV_A,PLNOD_A,PDDEV_A,PDDOD_A,
+ & PLNEW_A,PLNOW_A,
+ & PLNEV_R,PLNOD_R,PDDEV_R,PDDOD_R,
+ & PLNEW_R,PLNOW_R,
+ & SYN_LS_A,DYN_LS_A,
+! & SYN_GR_A_1,DYN_GR_A_1,ANL_GR_A_1,
+! & SYN_GR_A_2,DYN_GR_A_2,ANL_GR_A_2,
+ & XLON,XLAT,COSZDG, sfc_fld, flx_fld, nst_fld,
+ & HPRIME,SWH,HLW,FLUXR,SFALB,SLAG,SDEC,CDEC,
+ & OZPLIN,JINDX1,JINDX2,DDY,PDRYINI,
+ & phy_f3d, phy_f2d,
+ & ZHOUR,N1,N4,LSOUT,COLAT1,CFHOUR1,SPS,fscav)
+!!
+#include "f_hpm.h"
+ use machine , only : kind_evod,kind_phys,kind_rad
+ use resol_def , only : latg,latg2,latr,latr2,levh,levs,
+ & lonr,lotd,lots,lsoil,nfxr,nmtvr,
+ & ntoz,ntrac,ncld,num_p2d,num_p3d,
+ & p_di,p_dim,p_q,p_qm,p_rm,p_rq,
+ & p_rt,p_te,p_tem,p_uln,p_vln,
+ & p_w,p_x,p_y,p_ze,p_zem,p_zq,lonf
+ use layout1 , only : ipt_lats_node_r,lats_node_r,
+ & len_trie_ls,len_trio_ls,
+ & ls_dim,ls_max_node,
+ & me,me_l_0,nodes,lats_dim_a,
+ . ipt_lats_node_a,lats_node_a
+ use vert_def , only : am,bm,si,sl,sv,tov
+ use date_def , only : fhour,idate,shour,spdmax
+ use namelist_def , only : adiab,ens_nam,fhcyc,filta,
+ & gen_coord_hybrid,gg_tracers,
+ & hybrid, igen,explicit,mom4ice,
+ & ldiag3d,lsfwd,lslwr,lsswr,
+ & lggfs3d,fhgoc3d,ialb,nst_fcst,
+ & ngptc,nscyc,nsres,nszer,semilag,
+ & sl_epsln
+ use mpi_def , only : icolor,kind_mpi,liope,
+ & mc_comp,mpi_r_mpi
+ use ozne_def , only : latsozp,levozp,pl_coeff,timeoz
+
+ use layout_grid_tracers , only : rg1_a,rg2_a,rg3_a
+
+
+ use Sfc_Flx_ESMFMod
+ use Nst_Var_ESMFMod
+ use d3d_def
+
+ use cmp_comm , only : Coupler_id
+
+ IMPLICIT NONE
+!!
+ TYPE(Sfc_Var_Data) :: sfc_fld
+ TYPE(Flx_Var_Data) :: flx_fld
+ TYPE(Nst_Var_Data) :: nst_fld
+ integer lat
+ CHARACTER(16) :: CFHOUR1
+ INTEGER,INTENT(IN) :: LONSPERLAT(LATG),N1,N4
+!!
+ REAL(KIND=KIND_EVOD),INTENT(IN) :: deltim,PHOUR
+ REAL(KIND=KIND_EVOD),INTENT(INOUT) :: ZHOUR
+
+ integer ifirst
+ data ifirst /1/
+ save ifirst
+!
+ real, allocatable :: gzie_ln(:,:),gzio_ln(:,:),factor_b2t_ref(:)
+ save gzie_ln,gzio_ln,factor_b2t_ref
+
+ REAL(KIND=KIND_EVOD) TRIE_LS(LEN_TRIE_LS,2,11*LEVS+3*LEVH+6)
+ REAL(KIND=KIND_EVOD) TRIO_LS(LEN_TRIO_LS,2,11*LEVS+3*LEVH+6)
+!!
+ integer ls_node(ls_dim,3)
+!!
+! ls_node(1,1) ... ls_node(ls_max_node,1) : values of L
+! ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
+! ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
+!!
+ INTEGER LS_NODES(LS_DIM,NODES)
+ INTEGER MAX_LS_NODES(NODES)
+ INTEGER LATS_NODES_A(NODES)
+! INTEGER LATS_NODES_EXT(NODES)
+ INTEGER GLOBAL_LATS_A(LATG)
+! INTEGER GLOBAL_LATS_EXT(LATG+2*JINTMX+2*NYPT*(NODES-1))
+ INTEGER LATS_NODES_R(NODES)
+ INTEGER GLOBAL_LATS_R(LATR)
+ INTEGER LONSPERLAR(LATR)
+!
+ integer lats_nodes_r_old(nodes)
+ integer global_lats_r_old(latr)
+ logical ifshuff
+!
+ real(kind=kind_evod) colat1
+ REAL(KIND=KIND_EVOD) EPSE(LEN_TRIE_LS)
+ REAL(KIND=KIND_EVOD) EPSO(LEN_TRIO_LS)
+ REAL(KIND=KIND_EVOD) EPSEDN(LEN_TRIE_LS)
+ REAL(KIND=KIND_EVOD) EPSODN(LEN_TRIO_LS)
+ REAL(KIND=KIND_EVOD) SNNP1EV(LEN_TRIE_LS)
+ REAL(KIND=KIND_EVOD) SNNP1OD(LEN_TRIO_LS)
+ INTEGER NDEXEV(LEN_TRIE_LS)
+ INTEGER NDEXOD(LEN_TRIO_LS)
+ REAL(KIND=KIND_EVOD) PLNEV_A(LEN_TRIE_LS,LATG2)
+ REAL(KIND=KIND_EVOD) PLNOD_A(LEN_TRIO_LS,LATG2)
+ REAL(KIND=KIND_EVOD) PDDEV_A(LEN_TRIE_LS,LATG2)
+ REAL(KIND=KIND_EVOD) PDDOD_A(LEN_TRIO_LS,LATG2)
+ REAL(KIND=KIND_EVOD) PLNEW_A(LEN_TRIE_LS,LATG2)
+ REAL(KIND=KIND_EVOD) PLNOW_A(LEN_TRIO_LS,LATG2)
+ REAL(KIND=KIND_EVOD) PLNEV_R(LEN_TRIE_LS,LATR2)
+ REAL(KIND=KIND_EVOD) PLNOD_R(LEN_TRIO_LS,LATR2)
+ REAL(KIND=KIND_EVOD) PDDEV_R(LEN_TRIE_LS,LATR2)
+ REAL(KIND=KIND_EVOD) PDDOD_R(LEN_TRIO_LS,LATR2)
+ REAL(KIND=KIND_EVOD) PLNEW_R(LEN_TRIE_LS,LATR2)
+ REAL(KIND=KIND_EVOD) PLNOW_R(LEN_TRIO_LS,LATR2)
+ REAL(KIND=KIND_EVOD) SYN_LS_A(4*LS_DIM,LOTS,LATG2)
+ REAL(KIND=KIND_EVOD) DYN_LS_A(4*LS_DIM,LOTD,LATG2)
+
+! REAL(KIND=KIND_EVOD) SYN_GR_A_1(LONFX*LOTS,LATS_DIM_EXT)
+! REAL(KIND=KIND_EVOD) DYN_GR_A_1(LONFX*LOTD,LATS_DIM_EXT)
+! REAL(KIND=KIND_EVOD) ANL_GR_A_1(LONFX*LOTA,LATS_DIM_EXT)
+! REAL(KIND=KIND_EVOD) SYN_GR_A_2(LONFX*LOTS,LATS_DIM_EXT)
+! REAL(KIND=KIND_EVOD) DYN_GR_A_2(LONFX*LOTD,LATS_DIM_EXT)
+! REAL(KIND=KIND_EVOD) ANL_GR_A_2(LONFX*LOTA,LATS_DIM_EXT)
+!!
+ REAL (KIND=KIND_RAD) XLON(LONR,LATS_NODE_R),
+ & XLAT(LONR,LATS_NODE_R),
+ & COSZDG(LONR,LATS_NODE_R),
+ & HPRIME(LONR,NMTVR,LATS_NODE_R),
+ & FLUXR(LONR,nfxr,LATS_NODE_R),
+ & SFALB(LONR,LATS_NODE_R),
+ & SWH(LONR,LEVS,LATS_NODE_R),
+ & HLW(LONR,LEVS,LATS_NODE_R)
+
+ REAL (kind=kind_phys)
+ & phy_f3d(LONR,LEVS,num_p3d,lats_node_r),
+ & phy_f2d(lonr,num_p2d,lats_node_r),
+!
+ & DDY(LATS_NODE_R), fscav(ntrac-ncld-1)
+
+ INTEGER JINDX1(LATS_NODE_R),JINDX2(LATS_NODE_R)
+!!
+ INTEGER LEV,LEVMAX
+ REAL OZPLIN(LATSOZP,LEVOZP,pl_coeff,timeoz) !OZONE PL Coeff
+ REAL (KIND=KIND_PHYS) PDRYINI
+ REAL(KIND=KIND_EVOD) SLAG,SDEC,CDEC
+!
+!****************************************************************************
+!$$$ INTEGER P_GZ,P_ZEM,P_DIM,P_TEM,P_RM,P_QM
+!$$$ INTEGER P_ZE,P_DI,P_TE,P_RQ,P_Q,P_DLAM,P_DPHI,P_ULN,P_VLN
+!$$$ INTEGER P_W,P_X,P_Y,P_RT,P_ZQ
+!$$$ PARAMETER(P_GZ = 0*LEVS+0*LEVH+1, ! GZE/O(LNTE/OD,2),
+!$$$ X P_ZEM = 0*LEVS+0*LEVH+2, ! ZEME/O(LNTE/OD,2,LEVS),
+!$$$ X P_DIM = 1*LEVS+0*LEVH+2, ! DIME/O(LNTE/OD,2,LEVS),
+!$$$ X P_TEM = 2*LEVS+0*LEVH+2, ! TEME/O(LNTE/OD,2,LEVS),
+!$$$ X P_RM = 3*LEVS+0*LEVH+2, ! RME/O(LNTE/OD,2,LEVH),
+!$$$ X P_QM = 3*LEVS+1*LEVH+2, ! QME/O(LNTE/OD,2),
+!$$$ X P_ZE = 3*LEVS+1*LEVH+3, ! ZEE/O(LNTE/OD,2,LEVS),
+!$$$ X P_DI = 4*LEVS+1*LEVH+3, ! DIE/O(LNTE/OD,2,LEVS),
+!$$$ X P_TE = 5*LEVS+1*LEVH+3, ! TEE/O(LNTE/OD,2,LEVS),
+!$$$ X P_RQ = 6*LEVS+1*LEVH+3, ! RQE/O(LNTE/OD,2,LEVH),
+!$$$ X P_Q = 6*LEVS+2*LEVH+3, ! QE/O(LNTE/OD,2),
+!$$$ X P_DLAM= 6*LEVS+2*LEVH+4, ! DPDLAME/O(LNTE/OD,2),
+!$$$ X P_DPHI= 6*LEVS+2*LEVH+5, ! DPDPHIE/O(LNTE/OD,2),
+!$$$ X P_ULN = 6*LEVS+2*LEVH+6, ! ULNE/O(LNTE/OD,2,LEVS),
+!$$$ X P_VLN = 7*LEVS+2*LEVH+6, ! VLNE/O(LNTE/OD,2,LEVS),
+!$$$ X P_W = 8*LEVS+2*LEVH+6, ! WE/O(LNTE/OD,2,LEVS),
+!$$$ X P_X = 9*LEVS+2*LEVH+6, ! XE/O(LNTE/OD,2,LEVS),
+!$$$ X P_Y =10*LEVS+2*LEVH+6, ! YE/O(LNTE/OD,2,LEVS),
+!$$$ X P_RT =11*LEVS+2*LEVH+6, ! RTE/O(LNTE/OD,2,LEVH),
+!$$$ X P_ZQ =11*LEVS+3*LEVH+6) ! ZQE/O(LNTE/OD,2)
+!****************************************************************************
+ INTEGER kdt, IERR,J,K,L,LOCL,N
+ real(kind=kind_evod) batah
+ REAL(KIND=kind_mpi) coef00m(LEVS,ntrac)! temp. ozone clwater
+ REAL(KIND=kind_evod) coef00(LEVS,ntrac) ! temp. ozone clwater
+ INTEGER INDLSEV,JBASEV
+ INTEGER INDLSOD,JBASOD
+ integer iprint
+ include 'function2'
+
+ LOGICAL LSOUT, SPS
+!
+ real, PARAMETER:: RLAPSE=0.65E-2, omz1=10.0
+!
+! timings
+ real(kind=kind_evod) global_times_a(latg,nodes)
+ &, global_times_b(latr,nodes)
+ &, global_times_r(latr,nodes)
+ integer tag,ireq1,ireq2,i
+ real*8 rtc ,timer1,timer2,dt_warm, tem1, tem2
+!
+! if(ifirst == 1)then
+! allocate ( factor_b2t_ref(levs), gzie_ln(len_trie_ls,2),
+! & gzio_ln(len_trio_ls,2) )
+! ifirst=0
+! endif
+!
+ SHOUR = SHOUR + deltim
+
+!-> Coupling insertion
+ call ATM_DBG2(kdt,PHOUR,ZHOUR,SHOUR,3)
+ CALL ATM_TSTEP_INIT(kdt)
+!<- Coupling insertion
+
+ if (.NOT. LIOPE .or. icolor.ne.2) then
+!
+! print *,' in do tstep SEMILAG=',semilag,' kdt=',kdt
+
+ if (semilag) then ! Joe Sela's Semi-Lagrangian Code
+
+! batah = 0.
+! batah = 1. ! Commented by Moorthi 11/23/2010
+ batah = 1.0 + sl_epsln ! Moorthi
+
+ if(ifirst == 1) then
+ allocate ( factor_b2t_ref(levs), gzie_ln(len_trie_ls,2),
+ & gzio_ln(len_trio_ls,2) )
+ call get_cd_hyb_slg(deltim,batah)
+
+ CALL deldifs(
+ . TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
+ X TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
+ X TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1), ! hmhj
+ X TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
+ X TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
+ X TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1), ! hmhj
+ X deltim,SL,LS_NODE,coef00,0,hybrid, ! hmhj
+ & gen_coord_hybrid)
+
+ ifirst=0
+ endif
+! if(kdt < 24) print*,'entering dotstep deltim=', deltim,
+! & ' kdt=',kdt
+ global_times_a = 0.
+ timer1 = rtc()
+ call gloopa_hyb_slg
+ & (deltim,trie_ls,trio_ls,gzie_ln,gzio_ln,
+ & ls_node,ls_nodes,max_ls_nodes,
+ & lats_nodes_a,global_lats_a,
+ & lonsperlat,
+ & epse,epso,epsedn,epsodn,
+ & snnp1ev,snnp1od,ndexev,ndexod,
+ & plnev_a,plnod_a,pddev_a,pddod_a,plnew_a,plnow_a,
+ & global_times_a,kdt,batah,lsout)
+ timer2 = rtc()
+
+! if (kdt.lt.4)then
+! print*,' gloopa timer = ',timer2-timer1,' kdt=',kdt
+! endif
+
+ if(.not. adiab) then ! first if.not.adiab
+ if (nscyc > 0 .and. mod(kdt,nscyc) == 1) then
+! if (me == 0) print*,' calling gcycle at kdt=',kdt
+ CALL gcycle(me,LATS_NODE_R,LONSPERLAR,global_lats_r,
+ & ipt_lats_node_r,idate,fhour,fhcyc,
+ & XLON ,XLAT , sfc_fld, ialb)
+ endif
+!
+ if (num_p3d == 3) then ! Ferrier Microphysics initialization
+ call init_micro(deltim,lonr,levs,num_p3d,lats_node_r,
+ & phy_f3d(1,1,1,1), fhour, me)
+ endif
+ endif ! first if.not.adiab
+
+!
+!-> Coupling insertion
+
+ ! lgetSSTICE_cc must be defined by this moment. It used to be an argument
+ ! to ATM_GETSST, accessible here via USE SURFACE_cc. Now it is defined in
+ ! ATM_TSTEP_INIT called above, and the USE is removed. (Even in the earlier
+ ! version lgetSSTICE_cc did not have to be an actual argumnent, since
+ ! it is in the module SURFACE_cc USEd by ATM_GETSST.)
+
+ call ATM_GETSSTICE(sfc_fld%TSEA,sfc_fld%TISFC,sfc_fld%FICE,
+ & sfc_fld%HICE,sfc_fld%SHELEG,sfc_fld%SLMSK,
+ & sfc_fld%ORO,kdt)
+
+!<- Coupling insertion
+
+!
+ if (nst_fcst > 1) then ! update TSEA
+ if (Coupler_id < 0 .or. .not. mom4ice) then ! Standalone mode
+ do j = 1, lats_node_r
+ do i = 1, lonr
+ if (sfc_fld%slmsk(i,j) == 0 ) then
+ dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j))
+ & / nst_fld%xz(i,j)
+ sfc_fld%TSEA(i,j) = nst_fld%tref(i,j)
+ & + dt_warm - nst_fld%dt_cool(i,j)
+ & - sfc_fld%oro(i,j)*rlapse
+ endif
+ enddo
+ enddo
+ else ! Coupled to MOM4 OM
+ tem1 = 0.5 / omz1
+ do j = 1, lats_node_r
+ do i = 1, lonr
+ if (sfc_fld%slmsk(i,j) == 0 ) then
+ tem2 = 1.0 / nst_fld%xz(i,j)
+ sfc_fld%tsea(i,j) = sfc_fld%tsea(i,j)
+ & + sfc_fld%oro(i,j)*rlapse
+ dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j)) * tem2
+
+ if ( nst_fld%xz(i,j) > omz1) then
+ nst_fld%tref(i,j) = sfc_fld%tsea(i,j)
+ & - (1.0-0.5*omz1*tem2) * dt_warm
+ & + nst_fld%z_c(i,j)*nst_fld%dt_cool(i,j)*tem1
+ else
+ nst_fld%tref(i,j) = sfc_fld%tsea(i,j)
+ & - (nst_fld%xz(i,j)*dt_warm
+ & - nst_fld%z_c(i,j)*nst_fld%dt_cool(i,j))*tem1
+ endif
+ sfc_fld%TSEA(i,j) = nst_fld%tref(i,j)
+ & + dt_warm - nst_fld%dt_cool(i,j)
+ & - sfc_fld%oro(i,j)*rlapse
+ endif
+ enddo
+ enddo
+ endif
+ endif
+
+ global_times_r = 0.0
+
+ if (lsswr .or. lslwr) then ! radiation call!
+ if(.not. adiab) then ! second if.not.adiab
+ call gloopr
+ & (trie_ls,trio_ls,
+ & ls_node,ls_nodes,max_ls_nodes,
+ & lats_nodes_a,global_lats_a,
+ & lats_nodes_r,global_lats_r,
+ & lonsperlar,
+ & epse,epso,epsedn,epsodn,
+ & snnp1ev,snnp1od,plnev_r,plnod_r,
+ & pddev_r,pddod_r,
+ & phour,
+ & xlon,xlat,coszdg,flx_fld%coszen,
+ & sfc_fld%slmsk,sfc_fld%sheleg,sfc_fld%SNCOVR,
+ & sfc_fld%SNOALB,sfc_fld%ZORL,sfc_fld%TSEA,
+ & HPRIME,SFALB,sfc_fld%ALVSF,sfc_fld%ALNSF,
+ & sfc_fld%ALVWF,sfc_fld%ALNWF,sfc_fld%FACSF,
+ & sfc_fld%FACWF,sfc_fld%CV,sfc_fld%CVT ,
+ & sfc_fld%CVB,SWH,HLW,flx_fld%SFCNSW,flx_fld%SFCDLW,
+ & sfc_fld%FICE,sfc_fld%TISFC,flx_fld%SFCDSW,
+ & flx_fld%sfcemis, ! yth 4/09
+ & flx_fld%TSFLW,FLUXR,phy_f3d,SLAG,SDEC,CDEC,KDT,
+ & global_times_r)
+! if (iprint == 1) print*,' me = fin gloopr ',me
+ endif ! second if.not.adiab
+ endif !sswr .or. lslwr
+
+! if (iprint .eq. 1) print*,' me = beg gloopb ',me
+! if(kdt < 4)then
+! print*,' deltim in if(kdt.lt.4)=',deltim
+! endif
+
+!$omp parallel do private(locl)
+ do locl=1,ls_max_node
+ call sicdife_hyb_slg(trie_ls(1,1,p_x ), trie_ls(1,1,p_y ),
+ x trie_ls(1,1,p_zq ), deltim/2.,
+ x trie_ls(1,1,p_uln), trie_ls(1,1,p_vln),
+ x ls_node,snnp1ev,ndexev,locl,batah)
+ call sicdifo_hyb_slg(trio_ls(1,1,p_x ), trio_ls(1,1,p_y ),
+ x trio_ls(1,1,p_zq ), deltim/2.,
+ x trio_ls(1,1,p_uln), trio_ls(1,1,p_vln),
+ x ls_node,snnp1od,ndexod,locl,batah)
+ enddo
+ do j=1,len_trie_ls
+ trie_ls(j,1,p_zq ) = trie_ls(j,1,p_zq)-gzie_ln(j,1)
+ trie_ls(j,2,p_zq ) = trie_ls(j,2,p_zq)-gzie_ln(j,2)
+ enddo
+ do j=1,len_trio_ls
+ trio_ls(j,1,p_zq ) = trio_ls(j,1,p_zq)-gzio_ln(j,1)
+ trio_ls(j,2,p_zq ) = trio_ls(j,2,p_zq)-gzio_ln(j,2)
+ enddo
+!save n-1 values for diffusion, not really part of samilag scheme
+ do j=1,len_trie_ls
+ trie_ls(j,1,p_qm ) = trie_ls(j,1,p_zq)
+ trie_ls(j,2,p_qm ) = trie_ls(j,2,p_zq)
+ enddo
+ do j=1,len_trio_ls
+ trio_ls(j,1,p_qm ) = trio_ls(j,1,p_zq)
+ trio_ls(j,2,p_qm ) = trio_ls(j,2,p_zq)
+ enddo
+
+ do k=1,levs
+ do j=1,len_trie_ls
+ trie_ls(j,1,p_tem+k-1) = trie_ls(j,1,p_y+k-1)
+ trie_ls(j,2,p_tem+k-1) = trie_ls(j,2,p_y+k-1)
+ enddo
+ enddo
+ do k=1,levs
+ do j=1,len_trio_ls
+ trio_ls(j,1,p_tem+k-1) = trio_ls(j,1,p_y+k-1)
+ trio_ls(j,2,p_tem+k-1) = trio_ls(j,2,p_y+k-1)
+ enddo
+ enddo
+!--------------------------------------------------------
+ coef00(:,:) = 0.0
+ IF ( ME .EQ. ME_L_0 ) THEN
+ DO LOCL=1,LS_MAX_NODE
+ l = ls_node(locl,1)
+ jbasev = ls_node(locl,2)
+ IF ( L == 0 ) THEN
+ N = 0
+! 1 Corresponds to temperature, 2 corresponds to ozon, 3 to clwater
+ DO K=1,LEVS
+ coef00(K,1) = TRIE_LS(INDLSEV(N,L),1,P_Y +K-1)
+ if (ntoz .gt. 1 .and. ! hmhj
+ & .not. (hybrid.or.gen_coord_hybrid)) then ! hmhj
+ coef00(K,ntoz) = TRIE_LS(INDLSEV(N,L),1,
+ & (ntoz-1)*levs+P_rt+K-1)
+ endif
+ ENDDO
+ ENDIF
+ END DO
+ END IF
+
+ coef00m = coef00
+ CALL MPI_BCAST(coef00m,levs*ntrac,MPI_R_MPI,ME_L_0,MC_COMP,
+ & IERR)
+ coef00=coef00m
+ if( gen_coord_hybrid ) then ! hmhj
+ call updown_gc(sl,coef00(1,1)) ! hmhj
+ else ! hmhj
+ call updown(sl,coef00(1,1))
+ endif ! hmhj
+ if (ntoz .gt. 1 .and. .not. (hybrid.or.gen_coord_hybrid)) then ! hmhj
+ call updown(sl,coef00(1,ntoz))
+ endif
+ if (gg_tracers) then
+!$omp parallel do shared(TRIE_LS,TRIO_LS)
+!$omp+shared(deltim,SL,LS_NODE,coef00,hybrid)
+ do k=1,levs
+ CALL deldifs_tracers(
+ . TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
+ X TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
+ X TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1),
+ X TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
+ X TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
+ X TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1),
+ X deltim,SL,LS_NODE,coef00,k,hybrid,
+ & gen_coord_hybrid)
+ enddo
+ else
+!
+!$omp parallel do shared(TRIE_LS,TRIO_LS)
+!$omp+shared(deltim,SL,LS_NODE,coef00,hybrid)
+ do k=1,levs
+ CALL deldifs(
+ & TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
+ & TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
+ & TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1),
+ & TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
+ & TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
+ & TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1),
+ & deltim,SL,LS_NODE,coef00,k,hybrid,
+ & gen_coord_hybrid)
+ enddo
+ endif
+!--------------------------------------------------------
+ do j=1,len_trie_ls
+ trie_ls(j,1,p_q ) = trie_ls(j,1,p_zq)
+ trie_ls(j,2,p_q ) = trie_ls(j,2,p_zq)
+ enddo
+ do j=1,len_trio_ls
+ trio_ls(j,1,p_q ) = trio_ls(j,1,p_zq)
+ trio_ls(j,2,p_q ) = trio_ls(j,2,p_zq)
+ enddo
+! if (iprint .eq. 1) print*,' me = beg gloopb ',me
+ timer1 = rtc()
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! add impadj_slg to gloopb with batah, and set timetsteps to deltim
+! add impadj_slg to gloopb with batah, and set timetsteps to deltim
+! add impadj_slg to gloopb with batah, and set timetsteps to deltim
+! add impadj_slg to gloopb with batah, and set timetsteps to deltim
+! add impadj_slg to gloopb with batah, and set timetsteps to deltim
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+ global_times_b = 0.0
+ if(.not. adiab) then ! third if.not.adiab
+ call gloopb
+ & (trie_ls,trio_ls,
+ & ls_node,ls_nodes,max_ls_nodes,
+ & lats_nodes_a,global_lats_a,
+ & lats_nodes_r,global_lats_r,
+ & lonsperlar,
+ & epse,epso,epsedn,epsodn,
+ & snnp1ev,snnp1od,ndexev,ndexod,
+ & plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r,
+ & deltim,phour,sfc_fld, flx_fld, nst_fld, SFALB,
+ & xlon,
+ & swh,hlw,hprime,slag,sdec,cdec,
+ & ozplin,jindx1,jindx2,ddy,pdryini,
+ & phy_f3d, phy_f2d, xlat,kdt,
+ & global_times_b,batah,lsout,fscav)
+ endif ! third if.not.adiab
+
+!!$omp parallel do shared(trie_ls,ndexev,trio_ls,ndexod)
+!!$omp+shared(sl,spdmax,deltim,ls_node)
+! do k=1,levs
+!sela call damp_speed(trie_ls(1,1,p_x+k-1), trie_ls(1,1,p_w +k-1),
+!selax trie_ls(1,1,p_y+k-1), trie_ls(1,1,p_rt+k-1),
+!selax ndexev,
+!selax trio_ls(1,1,p_x+k-1), trio_ls(1,1,p_w +k-1),
+!selax trio_ls(1,1,p_y+k-1), trio_ls(1,1,p_rt+k-1),
+!selax ndexod,
+!selax sl,spdmax(k),deltim,ls_node)
+! enddo
+
+ do k=1,levs
+ do j=1,len_trie_ls
+ trie_ls(j,1,p_di+k-1) = trie_ls(j,1,p_x+k-1)
+ trie_ls(j,2,p_di+k-1) = trie_ls(j,2,p_x+k-1)
+ trie_ls(j,1,p_ze+k-1) = trie_ls(j,1,p_w+k-1)
+ trie_ls(j,2,p_ze+k-1) = trie_ls(j,2,p_w+k-1)
+ trie_ls(j,1,p_te+k-1) = trie_ls(j,1,p_y+k-1)
+ trie_ls(j,2,p_te+k-1) = trie_ls(j,2,p_y+k-1)
+ enddo
+ enddo
+ do k=1,levs
+ do j=1,len_trio_ls
+ trio_ls(j,1,p_di+k-1) = trio_ls(j,1,p_x+k-1)
+ trio_ls(j,2,p_di+k-1) = trio_ls(j,2,p_x+k-1)
+ trio_ls(j,1,p_ze+k-1) = trio_ls(j,1,p_w+k-1)
+ trio_ls(j,2,p_ze+k-1) = trio_ls(j,2,p_w+k-1)
+ trio_ls(j,1,p_te+k-1) = trio_ls(j,1,p_y+k-1)
+ trio_ls(j,2,p_te+k-1) = trio_ls(j,2,p_y+k-1)
+ enddo
+ enddo
+ if(.not. gg_tracers)then
+ do k=1,levh
+ do j=1,len_trie_ls
+ trie_ls(j,1,p_rq+k-1) = trie_ls(j,1,p_rt+k-1)
+ trie_ls(j,2,p_rq+k-1) = trie_ls(j,2,p_rt+k-1)
+ enddo
+ enddo
+ do k=1,levh
+ do j=1,len_trio_ls
+ trio_ls(j,1,p_rq+k-1) = trio_ls(j,1,p_rt+k-1)
+ trio_ls(j,2,p_rq+k-1) = trio_ls(j,2,p_rt+k-1)
+ enddo
+ enddo
+ endif ! if(.not.gg_tracers)
+!
+!----------------------------------------------------------
+ else ! Eulerian Dynamics
+!----------------------------------------------------------
+!!
+ if(ifirst == 1) then
+ CALL deldifs(
+ & TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
+ & TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
+ & TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1), ! hmhj
+ & TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
+ & TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
+ & TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1), ! hmhj
+ & deltim,SL,LS_NODE,coef00,0,hybrid, ! hmhj
+ & gen_coord_hybrid)
+
+ ifirst=0
+ endif
+ global_times_a=0.
+
+! print *,' Eulerian dynamics callling GLOOPA for kdt=',kdt
+
+ CALL GLOOPA
+ & (deltim,TRIE_LS,TRIO_LS,
+ & LS_NODE,LS_NODES,MAX_LS_NODES,
+ & LATS_NODES_A,GLOBAL_LATS_A,
+ & LONSPERLAT,
+ & EPSE,EPSO,EPSEDN,EPSODN,
+ & SNNP1EV,SNNP1OD,NDEXEV,NDEXOD,
+ & PLNEV_A,PLNOD_A,PDDEV_A,PDDOD_A,PLNEW_A,PLNOW_A,
+ & global_times_a,kdt)
+
+!
+!
+ iprint = 0
+! if (iprint .eq. 1) print*,' fin gloopa kdt = ',kdt
+!
+!my gather lat timings for load balancing
+!sela if (reshuff_lats_a .and. kdt .eq. 5) then
+!sela call redist_lats_a(kdt,global_times_a,
+!selax lats_nodes_a,global_lats_a,
+!selax lonsperlat,
+!selax lats_nodes_ext,global_lats_ext,iprint)
+!sela endif
+!----------------------------------------------------------
+
+!
+ if(.not. adiab) then
+ if (nscyc > 0 .and. mod(kdt,nscyc) == 1) then
+ CALL gcycle(me,LATS_NODE_R,LONSPERLAR,global_lats_r,
+ & ipt_lats_node_r,idate,fhour,fhcyc,
+ & XLON ,XLAT , sfc_fld, ialb)
+ endif
+!
+ if (num_p3d == 3) then ! Ferrier Microphysics initialization
+ call init_micro(deltim,lonr,levs,num_p3d,lats_node_r,
+ & phy_f3d(1,1,1,1), fhour, me)
+ endif
+ endif
+!
+!-> Coupling insertion
+
+ ! lgetSSTICE_cc must be defined by this moment. It used to be an argument
+ ! to ATM_GETSST, accessible here via USE SURFACE_cc. Now it is defined in
+ ! ATM_TSTEP_INIT called above, and the USE is removed. (Even in the earlier
+ ! version lgetSSTICE_cc did not have to be an actual argumnent, since
+ ! it is in the module SURFACE_cc USEd by ATM_GETSST.)
+
+! call ATM_GETSST(sfc_fld%TSEA,sfc_fld%SLMSK,sfc_fld%ORO)
+ call ATM_GETSSTICE(sfc_fld%TSEA,sfc_fld%TISFC,sfc_fld%FICE,
+ & sfc_fld%HICE,sfc_fld%SHELEG,sfc_fld%SLMSK,
+ & sfc_fld%ORO,kdt)
+
+!<- Coupling insertion
+
+!
+ if (nst_fcst > 1) then ! update TSEA
+ if (Coupler_id < 0 .or. .not. mom4ice) then ! Standalone mode
+ do j = 1, lats_node_r
+ do i = 1, lonr
+ if (sfc_fld%slmsk(i,j) == 0 ) then
+ dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j))
+ & / nst_fld%xz(i,j)
+ sfc_fld%TSEA(i,j) = nst_fld%tref(i,j)
+ & + dt_warm - nst_fld%dt_cool(i,j)
+ & - sfc_fld%oro(i,j)*rlapse
+ endif
+ enddo
+ enddo
+ else ! Coupled to MOM4 OM
+ tem1 = 0.5 / omz1
+ do j = 1, lats_node_r
+ do i = 1, lonr
+ if (sfc_fld%slmsk(i,j) == 0 ) then
+ tem2 = 1.0 / nst_fld%xz(i,j)
+ sfc_fld%tsea(i,j) = sfc_fld%tsea(i,j)
+ & + sfc_fld%oro(i,j)*rlapse
+ dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j)) * tem2
+
+ if ( nst_fld%xz(i,j) > omz1) then
+ nst_fld%tref(i,j) = sfc_fld%tsea(i,j)
+ & - (1.0-0.5*omz1*tem2) * dt_warm
+ & + nst_fld%z_c(i,j)*nst_fld%dt_cool(i,j)*tem1
+ else
+ nst_fld%tref(i,j) = sfc_fld%tsea(i,j)
+ & - (nst_fld%xz(i,j)*dt_warm
+ & - nst_fld%z_c(i,j)*nst_fld%dt_cool(i,j))*tem1
+ endif
+ sfc_fld%TSEA(i,j) = nst_fld%tref(i,j)
+ & + dt_warm - nst_fld%dt_cool(i,j)
+ & - sfc_fld%oro(i,j)*rlapse
+ endif
+ enddo
+ enddo
+ endif
+ endif
+
+! do j = 1, lats_node_r
+! do i = 1, lonr
+! if (sfc_fld%slmsk(i,j) == 0 ) then
+! dt_warm = (nst_fld%xt(i,j)+nst_fld%xt(i,j))
+! & / nst_fld%xz(i,j)
+! sfc_fld%TSEA(i,j) = sfc_fld%TSEA(i,j)
+! & + dt_warm - nst_fld%dt_cool(i,j)
+! endif
+! enddo
+! enddo
+! endif
+
+
+!sela if (me.eq.0) PRINT*,'COMPLETED GLOOPA IN do_tstep'
+
+ global_times_r = 0.0 !my set to zero for every timestep
+
+ if (lsswr .or. lslwr) then ! Radiation Call!
+ if(.not. adiab) then
+
+! if(.not.adiab .and. kdt > 1) then
+! print *,' before calling GLOOPR kdt=',kdt
+
+ call gloopr
+ & (trie_ls,trio_ls,
+ & ls_node,ls_nodes,max_ls_nodes,
+ & lats_nodes_a,global_lats_a,
+ & lats_nodes_r,global_lats_r,
+ & lonsperlar,
+ & epse,epso,epsedn,epsodn,
+ & snnp1ev,snnp1od,plnev_r,plnod_r,
+ & pddev_r,pddod_r,
+ & phour,
+ & xlon,xlat,coszdg,flx_fld%coszen,
+ & sfc_fld%slmsk,sfc_fld%sheleg,sfc_fld%SNCOVR,
+ & sfc_fld%SNOALB,sfc_fld%ZORL,sfc_fld%TSEA,
+ & HPRIME,SFALB,sfc_fld%ALVSF,sfc_fld%ALNSF,
+ & sfc_fld%ALVWF,sfc_fld%ALNWF,sfc_fld%FACSF,
+ & sfc_fld%FACWF,sfc_fld%CV,sfc_fld%CVT ,
+ & sfc_fld%CVB,SWH,HLW,flx_fld%SFCNSW,flx_fld%SFCDLW,
+ & sfc_fld%FICE,sfc_fld%TISFC,flx_fld%SFCDSW,
+ & flx_fld%sfcemis, ! yth 4/09
+ & flx_fld%TSFLW,FLUXR,phy_f3d,SLAG,SDEC,CDEC,KDT,
+ & global_times_r)
+ endif ! second if.not.adiab
+ endif !sswr .or. lslwr
+
+! if (me == 0) then
+! print *,' aft gloopr HLW45=',hlw(1,:,45)
+! print *,' aft gloopr SWH45=',swh(1,:,45)
+! endif
+!!
+! print *,' finished GLOOPR at kdt=',kdt
+! call mpi_quit(1111)
+
+ if( .not. explicit ) then ! hmhj
+!
+ if( gen_coord_hybrid ) then ! hmhj
+
+!$omp parallel do private(locl)
+ do locl=1,ls_max_node ! hmhj
+ call sicdife_hyb_gc(
+ & trie_ls(1,1,P_dim), trie_ls(1,1,P_tem), ! hmhj
+ & trie_ls(1,1,P_qm ), trie_ls(1,1,P_x ), ! hmhj
+ & trie_ls(1,1,P_y ), trie_ls(1,1,P_zq ), ! hmhj
+ & trie_ls(1,1,P_di ), trie_ls(1,1,P_te ), ! hmhj
+ & trie_ls(1,1,P_q ),deltim, ! hmhj
+ & trie_ls(1,1,P_uln), trie_ls(1,1,P_vln), ! hmhj
+ & ls_node,snnp1ev,ndexev,locl) ! hmhj
+
+ call sicdifo_hyb_gc(
+ & trio_ls(1,1,P_dim), trio_ls(1,1,P_tem), ! hmhj
+ & trio_ls(1,1,P_qm ), trio_ls(1,1,P_x ), ! hmhj
+ & trio_ls(1,1,P_y ), trio_ls(1,1,P_zq ), ! hmhj
+ & trio_ls(1,1,P_di ), trio_ls(1,1,P_te ), ! hmhj
+ & trio_ls(1,1,P_q ),deltim, ! hmhj
+ & trio_ls(1,1,P_uln), trio_ls(1,1,P_vln), ! hmhj
+ & ls_node,snnp1od,ndexod,locl) ! hmhj
+ enddo ! hmhj
+
+ else if(hybrid)then ! hmhj
+
+! print *,' calling sicdife_hyb at kdt=',kdt
+!$omp parallel do private(locl)
+ do locl=1,ls_max_node
+ call sicdife_hyb(
+ & trie_ls(1,1,P_dim), trie_ls(1,1,P_tem),
+ & trie_ls(1,1,P_qm ), trie_ls(1,1,P_x ),
+ & trie_ls(1,1,P_y ), trie_ls(1,1,P_zq ),
+ & trie_ls(1,1,P_di ), trie_ls(1,1,P_te ),
+ & trie_ls(1,1,P_q ),deltim,
+ & trie_ls(1,1,P_uln), trie_ls(1,1,P_vln),
+ & ls_node,snnp1ev,ndexev,locl)
+
+ call sicdifo_hyb(
+ & trio_ls(1,1,P_dim), trio_ls(1,1,P_tem),
+ & trio_ls(1,1,P_qm ), trio_ls(1,1,P_x ),
+ & trio_ls(1,1,P_y ), trio_ls(1,1,P_zq ),
+ & trio_ls(1,1,P_di ), trio_ls(1,1,P_te ),
+ & trio_ls(1,1,P_q ),deltim,
+ & trio_ls(1,1,P_uln), trio_ls(1,1,P_vln),
+ & ls_node,snnp1od,ndexod,locl)
+ enddo
+
+! print *,' after calling sicdife_hyb at kdt=',kdt
+ else ! hybrid
+
+!$omp parallel do private(locl)
+ do locl=1,ls_max_node
+ CALL SICDIFE_sig(
+ & TRIE_LS(1,1,P_DIM), TRIE_LS(1,1,P_TEM),
+ & TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X ),
+ & TRIE_LS(1,1,P_Y ), TRIE_LS(1,1,P_ZQ ),
+ & AM,BM,TOV,SV,deltim,
+ & TRIE_LS(1,1,P_ULN), TRIE_LS(1,1,P_VLN),
+ & LS_NODE,SNNP1EV,NDEXEV,locl,TRIE_LS(1,1,P_DI))
+
+ CALL SICDIFO_sig(
+ & TRIO_LS(1,1,P_DIM), TRIO_LS(1,1,P_TEM),
+ & TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X ),
+ & TRIO_LS(1,1,P_Y ), TRIO_LS(1,1,P_ZQ ),
+ & AM,BM,TOV,SV,deltim,
+ & TRIO_LS(1,1,P_ULN), TRIO_LS(1,1,P_VLN),
+ & LS_NODE,SNNP1OD,NDEXOD,locl,TRIO_LS(1,1,P_DI))
+ enddo
+ endif ! hybrid
+
+ endif ! not explicit ! hmhj
+
+!
+!----------------------------------------------------------
+!sela if (.NOT.LIOPE.or.icolor.ne.2) then
+!sela print*,'liope=',liope,' icolor=',icolor,' after loopa'
+!sela CALL RMS_spect(TRIE_LS(1,1,P_zq ), TRIE_LS(1,1,P_x ),
+!selaX TRIE_LS(1,1,P_y ), TRIE_LS(1,1,P_w ),
+!selaX TRIE_LS(1,1,P_Rt ),
+!selaX TRIO_LS(1,1,P_zq ), TRIO_LS(1,1,P_x ),
+!selaX TRIO_LS(1,1,P_y ), TRIO_LS(1,1,P_w ),
+!selaX TRIO_LS(1,1,P_Rt ),
+!selaX LS_NODES,MAX_LS_NODES)
+!sela endif
+!----------------------------------------------------------
+
+! hmhj compute coef00 for all, even for hybrid mode
+
+ coef00(:,:) = 0.0
+ IF ( ME .EQ. ME_L_0 ) THEN
+ DO LOCL=1,LS_MAX_NODE
+ l = ls_node(locl,1)
+ jbasev = ls_node(locl,2)
+ IF ( L == 0 ) THEN
+ N = 0
+! 1 Corresponds to temperature, 2 corresponds to ozone, 3 to cloud condensate
+ DO K=1,LEVS
+ coef00(K,1) = TRIE_LS(INDLSEV(N,L),1,P_Y +K-1)
+! if (ntoz .gt. 1) then
+ if (ntoz .gt. 1 .and. ! hmhj
+ & .not. (hybrid.or.gen_coord_hybrid)) then ! hmhj
+ coef00(K,ntoz) = TRIE_LS(INDLSEV(N,L),1,
+ & (ntoz-1)*levs+P_rt+K-1)
+ endif
+ ENDDO
+ ENDIF
+ END DO
+ END IF
+ coef00m = coef00
+ CALL MPI_BCAST(coef00m,levs*ntrac,MPI_R_MPI,ME_L_0,MC_COMP,
+ & IERR)
+ coef00=coef00m
+ if( gen_coord_hybrid ) then ! hmhj
+ call updown_gc(sl,coef00(1,1)) ! hmhj
+ else ! hmhj
+ call updown(sl,coef00(1,1))
+ endif ! hmhj
+! if (ntoz > 1) call updown(sl,coef00(1,ntoz))
+ if (ntoz > 1 .and. .not. (hybrid.or.gen_coord_hybrid)) then ! hmhj
+ call updown(sl,coef00(1,ntoz))
+ endif
+
+! print *,' calling deldifs at kdt=',kdt
+!
+!$omp parallel do shared(TRIE_LS,TRIO_LS)
+!$omp+shared(deltim,SL,LS_NODE,coef00,hybrid,gen_coord_hybrid)
+ do k=1,levs
+ CALL deldifs(TRIE_LS(1,1,P_RT+k-1), TRIE_LS(1,1,P_W+k-1),
+ X TRIE_LS(1,1,P_QM ), TRIE_LS(1,1,P_X+k-1),
+ X TRIE_LS(1,1,P_Y +k-1), TRIE_LS(1,1,P_TEM+k-1), ! hmhj
+ X TRIO_LS(1,1,P_RT+k-1), TRIO_LS(1,1,P_W+k-1),
+ X TRIO_LS(1,1,P_QM ), TRIO_LS(1,1,P_X+k-1),
+ X TRIO_LS(1,1,P_Y +k-1), TRIO_LS(1,1,P_TEM+k-1), ! hmhj
+ X deltim,SL,LS_NODE,coef00,k,hybrid, ! hmhj
+ & gen_coord_hybrid) ! hmhj
+ enddo
+! print *,' after calling deldifs at kdt=',kdt
+!
+!
+!-------------------------------------------
+ if(.not.lsfwd)then
+!-------------------------------------------
+ CALL FILTR1EO(TRIE_LS(1,1,P_TEM), TRIE_LS(1,1,P_TE ),
+ & TRIE_LS(1,1,P_Y ), TRIE_LS(1,1,P_DIM),
+ & TRIE_LS(1,1,P_DI ), TRIE_LS(1,1,P_X ),
+ & TRIE_LS(1,1,P_ZEM), TRIE_LS(1,1,P_ZE ),
+ & TRIE_LS(1,1,P_W ), TRIE_LS(1,1,P_RM ),
+ & TRIE_LS(1,1,P_RQ ), TRIE_LS(1,1,P_RT ),
+ & TRIO_LS(1,1,P_TEM), TRIO_LS(1,1,P_TE ),
+ & TRIO_LS(1,1,P_Y ), TRIO_LS(1,1,P_DIM),
+ & TRIO_LS(1,1,P_DI ), TRIO_LS(1,1,P_X ),
+ & TRIO_LS(1,1,P_ZEM), TRIO_LS(1,1,P_ZE ),
+ & TRIO_LS(1,1,P_W ), TRIO_LS(1,1,P_RM ),
+ & TRIO_LS(1,1,P_RQ ), TRIO_LS(1,1,P_RT ),
+ & FILTA,LS_NODE)
+
+ CALL countperf(0,13,0.)
+ DO J=1,LEN_TRIE_LS
+ TRIE_LS(J,1,P_QM) = TRIE_LS(J,1,P_Q )
+ TRIE_LS(J,2,P_QM) = TRIE_LS(J,2,P_Q )
+ TRIE_LS(J,1,P_Q ) = TRIE_LS(J,1,P_ZQ)
+ TRIE_LS(J,2,P_Q ) = TRIE_LS(J,2,P_ZQ)
+ ENDDO
+ DO J=1,LEN_TRIO_LS
+ TRIO_LS(J,1,P_QM) = TRIO_LS(J,1,P_Q )
+ TRIO_LS(J,2,P_QM) = TRIO_LS(J,2,P_Q )
+ TRIO_LS(J,1,P_Q ) = TRIO_LS(J,1,P_ZQ)
+ TRIO_LS(J,2,P_Q ) = TRIO_LS(J,2,P_ZQ)
+ ENDDO
+ CALL countperf(1,13,0.)
+
+!-------------------------------------------
+ else
+!-------------------------------------------
+ CALL countperf(0,13,0.)
+ DO J=1,LEN_TRIE_LS
+ TRIE_LS(J,1,P_Q) = TRIE_LS(J,1,P_ZQ)
+ TRIE_LS(J,2,P_Q) = TRIE_LS(J,2,P_ZQ)
+ ENDDO
+ DO J=1,LEN_TRIO_LS
+ TRIO_LS(J,1,P_Q) = TRIO_LS(J,1,P_ZQ)
+ TRIO_LS(J,2,P_Q) = TRIO_LS(J,2,P_ZQ)
+ ENDDO
+ CALL countperf(1,13,0.)
+!-------------------------------------------
+ endif
+!
+!-------------------------------------------
+! if (iprint .eq. 1) print*,' me = beg gloopb ',me
+!my set to zero for every timestep
+ global_times_b = 0.0
+
+ if(.not. adiab) then
+
+! print *,' before calling GLOOPB kdt=',kdt
+ call gloopb
+ & (trie_ls,trio_ls,
+ & ls_node,ls_nodes,max_ls_nodes,
+ & lats_nodes_a,global_lats_a,
+ & lats_nodes_r,global_lats_r,
+ & lonsperlar,
+ & epse,epso,epsedn,epsodn,
+ & snnp1ev,snnp1od,ndexev,ndexod,
+ & plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r,
+ & deltim,phour,sfc_fld, flx_fld, nst_fld, SFALB,
+ & xlon,
+ & swh,hlw,hprime,slag,sdec,cdec,
+ & ozplin,jindx1,jindx2,ddy,pdryini,
+ & phy_f3d, phy_f2d, xlat,kdt,
+ & global_times_b,batah,lsout,fscav)
+!
+! if (kdt .eq. 1) call mpi_quit(222)
+ endif ! not.adiab
+
+! print *,' after calling GLOOPB kdt=',kdt
+!
+!!$omp parallel do shared(TRIE_LS,NDEXEV,TRIO_LS,NDEXOD)
+!!$omp+shared(SL,SPDMAX,deltim,LS_NODE)
+!$omp parallel do private(k)
+ do k=1,levs
+ CALL damp_speed(TRIE_LS(1,1,P_X+k-1), TRIE_LS(1,1,P_W +k-1),
+ & TRIE_LS(1,1,P_Y+k-1), TRIE_LS(1,1,P_RT+k-1),
+ & NDEXEV,
+ & TRIO_LS(1,1,P_X+k-1), TRIO_LS(1,1,P_W +k-1),
+ & TRIO_LS(1,1,P_Y+k-1), TRIO_LS(1,1,P_RT+k-1),
+ & NDEXOD,
+ & SL,SPDMAX(k),deltim,LS_NODE)
+ enddo
+!
+!--------------------------------------------
+ if(.not. lsfwd)then
+!--------------------------------------------
+ CALL FILTR2EO(TRIE_LS(1,1,P_TEM), TRIE_LS(1,1,P_TE ),
+ & TRIE_LS(1,1,P_Y ), TRIE_LS(1,1,P_DIM),
+ & TRIE_LS(1,1,P_DI ), TRIE_LS(1,1,P_X ),
+ & TRIE_LS(1,1,P_ZEM), TRIE_LS(1,1,P_ZE ),
+ & TRIE_LS(1,1,P_W ), TRIE_LS(1,1,P_RM ),
+ & TRIE_LS(1,1,P_RQ ), TRIE_LS(1,1,P_RT ),
+ & TRIO_LS(1,1,P_TEM), TRIO_LS(1,1,P_TE ),
+ & TRIO_LS(1,1,P_Y ), TRIO_LS(1,1,P_DIM),
+ & TRIO_LS(1,1,P_DI ), TRIO_LS(1,1,P_X ),
+ & TRIO_LS(1,1,P_ZEM), TRIO_LS(1,1,P_ZE ),
+ & TRIO_LS(1,1,P_W ), TRIO_LS(1,1,P_RM ),
+ & TRIO_LS(1,1,P_RQ ), TRIO_LS(1,1,P_RT ),
+ & FILTA,LS_NODE)
+!--------------------------------------------
+ else
+!--------------------------------------------
+ CALL countperf(0,13,0.)
+ DO K=1,LEVS
+ DO J=1,LEN_TRIE_LS
+ TRIE_LS(J,1,P_DI+K-1) = TRIE_LS(J,1,P_X+K-1)
+ TRIE_LS(J,2,P_DI+K-1) = TRIE_LS(J,2,P_X+K-1)
+ TRIE_LS(J,1,P_ZE+K-1) = TRIE_LS(J,1,P_W+K-1)
+ TRIE_LS(J,2,P_ZE+K-1) = TRIE_LS(J,2,P_W+K-1)
+ TRIE_LS(J,1,P_TE+K-1) = TRIE_LS(J,1,P_Y+K-1)
+ TRIE_LS(J,2,P_TE+K-1) = TRIE_LS(J,2,P_Y+K-1)
+ ENDDO
+ ENDDO
+ DO K=1,LEVS
+ DO J=1,LEN_TRIO_LS
+ TRIO_LS(J,1,P_DI+K-1) = TRIO_LS(J,1,P_X+K-1)
+ TRIO_LS(J,2,P_DI+K-1) = TRIO_LS(J,2,P_X+K-1)
+ TRIO_LS(J,1,P_ZE+K-1) = TRIO_LS(J,1,P_W+K-1)
+ TRIO_LS(J,2,P_ZE+K-1) = TRIO_LS(J,2,P_W+K-1)
+ TRIO_LS(J,1,P_TE+K-1) = TRIO_LS(J,1,P_Y+K-1)
+ TRIO_LS(J,2,P_TE+K-1) = TRIO_LS(J,2,P_Y+K-1)
+ ENDDO
+ ENDDO
+ DO K=1,LEVH
+ DO J=1,LEN_TRIE_LS
+ TRIE_LS(J,1,P_RQ+K-1) = TRIE_LS(J,1,P_RT+K-1)
+ TRIE_LS(J,2,P_RQ+K-1) = TRIE_LS(J,2,P_RT+K-1)
+ ENDDO
+ ENDDO
+ DO K=1,LEVH
+ DO J=1,LEN_TRIO_LS
+ TRIO_LS(J,1,P_RQ+K-1) = TRIO_LS(J,1,P_RT+K-1)
+ TRIO_LS(J,2,P_RQ+K-1) = TRIO_LS(J,2,P_RT+K-1)
+ ENDDO
+ ENDDO
+ CALL countperf(1,13,0.)
+!--------------------------------------------
+ endif
+! if (kdt .eq. 2) call mpi_quit(444)
+!!
+ endif ! if (semilag) then loop
+
+ endif !.NOT.LIOPE.or.icolor.ne.2
+!
+!--------------------------------------------
+!--------------------------------------------
+ IF (lsout) THEN
+!!
+ CALL f_hpmstart(32,"TWRITEEO")
+!!
+ CALL countperf(0,18,0.)
+!
+ CALL WRTOUT(PHOUR,FHOUR,ZHOUR,IDATE,
+ & TRIE_LS,TRIO_LS,
+ & SL,SI,
+ & ls_node,LS_NODES,MAX_LS_NODES,
+ & sfc_fld, flx_fld, nst_fld,
+ & fluxr,pdryini,
+ & lats_nodes_r,global_lats_r,lonsperlar,
+ & COLAT1,CFHOUR1,pl_coeff,
+ & epsedn,epsodn,snnp1ev,snnp1od,plnev_r,plnod_r,
+ & plnew_r,plnow_r,'SIG.F','SFC.F','FLX.F')
+
+
+! endif
+!
+ CALL f_hpmstop(32)
+!!
+ CALL countperf(1,18,0.)
+!!
+!!
+ IF (mod(kdt,nsres) == 0 .and. (.not. SPS)) THEN
+!!
+ CALL wrt_restart(TRIE_LS,TRIO_LS,
+ & sfc_fld, nst_fld,
+ & SI,SL,fhour,idate,
+ & igen,pdryini,
+ x ls_node,ls_nodes,max_ls_nodes,
+ & global_lats_r,lonsperlar,SNNP1EV,SNNP1OD,
+ & phy_f3d, phy_f2d, ngptc, adiab, ens_nam,
+ & nst_fcst,'SIGR1','SIGR2','SFCR','NSTR')
+!
+ ENDIF
+ ENDIF ! if ls_out
+!
+ IF (mod(kdt,nszer) == 0 .and. lsout) THEN
+ call flx_init(flx_fld,ierr)
+ zhour = fhour
+ FLUXR = 0.
+!
+ if (ldiag3d .or. lggfs3d) then
+ call d3d_zero(ldiag3d,lggfs3d)
+ if (fhour >= fhgoc3d) lggfs3d = .false.
+ endif
+ ENDIF
+!
+! Coupling insertion->
+ CALL ATM_SENDFLUXES(sfc_fld%SLMSK)
+!<- Coupling insertion
+
+ RETURN
+ END
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/gloopb.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/gloopb.f_gfs (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/gloopb.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,1939 @@
+ subroutine gloopb
+ x (trie_ls,trio_ls,
+ x ls_node,ls_nodes,max_ls_nodes,
+ x lats_nodes_a,global_lats_a,
+ x lats_nodes_r,global_lats_r,
+ x lonsperlar,
+ x epse,epso,epsedn,epsodn,
+ x snnp1ev,snnp1od,ndexev,ndexod,
+ x plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r,
+ & tstep,phour,sfc_fld, flx_fld, nst_fld, SFALB,
+ & xlon,
+ & swh,hlw,hprime,slag,sdec,cdec,
+ & ozplin,jindx1,jindx2,ddy,pdryini,
+ & phy_f3d, phy_f2d,xlat,kdt,
+ & global_times_b,batah,lsout,fscav)
+!!
+#include "f_hpm.h"
+!!
+ use machine , only : kind_evod,kind_phys,kind_rad
+ use resol_def , only : jcap,jcap1,latg,latr,latr2,
+ & levh,levp1,levs,lnt2,
+ & lonf,lonr,lonrx,lota,lotd,lots,
+ & lsoil,ncld,nmtvr,nrcm,ntcw,ntoz,
+ & ntrac,num_p2d,num_p3d,
+ & p_di,p_dlam,p_dphi,p_q,
+ & p_rq,p_rt,p_te,p_uln,p_vln,
+ & p_w,p_x,p_y,p_ze,p_zq,
+ & thermodyn_id,sfcpress_id,nfxr
+
+ use layout1 , only : ipt_lats_node_r,
+ & lat1s_r,lats_dim_r,
+ & lats_node_a,lats_node_r,
+ & len_trie_ls,len_trio_ls,
+ & lon_dim_r,ls_dim,ls_max_node,
+ & me,me_l_0,nodes
+ use layout_grid_tracers , only : rg1_a,rg2_a,rg3_a,xhalo,
+ & rg1_h,rg2_h,rg3_h,yhalo
+ use gg_def , only : coslat_r,rcs2_r,sinlat_r,wgt_r
+ use vert_def , only : am,bm,del,si,sik,sl,slk,sv
+ use date_def , only : fhour,idate
+ use namelist_def , only : crtrh,fhswr,flgmin,
+ & gen_coord_hybrid,gg_tracers,
+ & hybrid,ldiag3d,lscca,lsfwd,
+ & lsm,lssav,lsswr,ncw,ngptc,
+ & old_monin,pre_rad,random_clds,
+ & ras,semilag,shuff_lats_r,
+ & sashal,ctei_rm,mom4ice,newsas,
+ & ccwf,cnvgwd,lggfs3d,trans_trac,
+ & mstrat,cal_pre,nst_fcst,
+ & dlqf,moist_adj,cdmbgwd,
+ & bkgd_vdif_m, bkgd_vdif_h,
+ & bkgd_vdif_s,shal_cnv,
+ & psautco, prautco, evpco, wminco
+ use coordinate_def , only : ak5,bk5,vertcoord_id ! hmhj
+ use bfilt_def , only : bfilte,bfilto
+ use module_ras , only : ras_init
+ use physcons , only : grav => con_g,
+ & rerth => con_rerth, ! hmhj
+ & fv => con_fvirt, ! mjr
+ & rvrdm1 => con_FVirt,
+ & rd => con_rd
+ use ozne_def , only : latsozp,levozp,
+ & pl_coeff,pl_pres,timeoz
+!-> Coupling insertion
+ USE SURFACE_cc
+!<- Coupling insertion
+
+ use Sfc_Flx_ESMFMod
+ use Nst_Var_ESMFMod
+ use mersenne_twister
+ use d3d_def
+ use tracer_const
+!
+ include 'mpif.h'
+ implicit none
+!
+ TYPE(Sfc_Var_Data) :: sfc_fld
+ TYPE(Flx_Var_Data) :: flx_fld
+ TYPE(Nst_Var_Data) :: nst_fld
+!
+ real(kind=kind_phys), PARAMETER :: RLAPSE=0.65E-2
+ real(kind=kind_evod), parameter :: cons_0=0.0, cons_24=24.0
+ &, cons_99=99.0, cons_1p0d9=1.0E9
+
+
+!$$$ integer n1rac, n2rac,nlons_v(ngptc)
+!$$$ parameter (n1rac=ntrac-ntshft-1, n2rac=n1rac+1)
+!
+! integer id,njeff,istrt,lon,kdt
+ integer id,njeff, lon,kdt
+!!
+ real(kind=kind_evod) save_qe_ls(len_trie_ls,2)
+ real(kind=kind_evod) save_qo_ls(len_trio_ls,2)
+
+ real(kind=kind_evod) sum_k_rqchange_ls(len_trie_ls,2)
+ real(kind=kind_evod) sum_k_rqchango_ls(len_trio_ls,2)
+!!
+ real(kind=kind_evod) trie_ls(len_trie_ls,2,11*levs+3*levh+6)
+ real(kind=kind_evod) trio_ls(len_trio_ls,2,11*levs+3*levh+6)
+ real(kind=kind_evod) trie_ls_rqt(len_trie_ls,2,levs)
+ real(kind=kind_evod) trio_ls_rqt(len_trio_ls,2,levs)
+ real(kind=kind_evod) trie_ls_sfc(len_trie_ls,2) ! hmhj
+ real(kind=kind_evod) trio_ls_sfc(len_trio_ls,2) ! hmhj
+!!
+ real(kind=kind_phys) typdel(levs), batah
+ real(kind=kind_phys) prsl(ngptc,levs)
+ real(kind=kind_phys) prslk(ngptc,levs),dpshc(ngptc)
+ real(kind=kind_phys) prsi(ngptc,levs+1),phii(ngptc,levs+1)
+ real(kind=kind_phys) prsik(ngptc,levs+1),phil(ngptc,levs)
+!!
+ real (kind=kind_phys) gu(ngptc,levs), gv1(ngptc,levs)
+ real (kind=kind_phys) ugrd(ngptc,levs),vgrd(ngptc,levs)
+ real (kind=kind_phys) gphi(ngptc), glam(ngptc)
+ real (kind=kind_phys) gq(ngptc), gt(ngptc,levs), pgr(ngptc)
+ real (kind=kind_phys) gr(ngptc,levs,ntrac)
+ real (kind=kind_phys) gd(ngptc,levs)
+ real (kind=kind_phys) adt(ngptc,levs), adr(ngptc,levs,ntrac)
+ real (kind=kind_phys) adu(ngptc,levs), adv(ngptc,levs)
+ real (kind=kind_phys) gtv(ngptc,levs) ! hmhj
+ real (kind=kind_phys) gtvx(ngptc,levs), gtvy(ngptc,levs) ! hmhj
+ real (kind=kind_phys) sumq(ngptc,levs), xcp(ngptc,levs)
+!
+ real (kind=kind_phys) dt3dt_v(ngptc,levs,6),
+ & dq3dt_v(ngptc,levs,5+pl_coeff),
+ & du3dt_v(ngptc,levs,4),
+ & dv3dt_v(ngptc,levs,4)
+ &, upd_mf_v(ngptc,levs), dwn_mf_v(ngptc,levs)
+ &, det_mf_v(ngptc,levs)
+ &, dkh_v(ngptc,LEVS), rnp_v(ngptc,levs)
+!!
+ real(kind=kind_evod) gq_save(lonr,lats_dim_r)
+!!
+ real (kind=kind_rad) slag,sdec,cdec,phour
+ real (kind=kind_rad) xlon(lonr,lats_node_r)
+ real (kind=kind_rad) xlat(lonr,lats_node_r)
+ real (kind=kind_rad) coszdg(lonr,lats_node_r),
+ & hprime(lonr,nmtvr,lats_node_r),
+! & fluxr(lonr,nfxr,lats_node_r),
+ & sfalb(lonr,lats_node_r)
+ real (kind=kind_rad) swh(lonr,levs,lats_node_r)
+ real (kind=kind_rad) hlw(lonr,levs,lats_node_r)
+!!
+ real (kind=kind_phys)
+ & phy_f3d(lonr,levs,num_p3d,lats_node_r),
+ & phy_f2d(lonr,num_p2d,lats_node_r), fscav(ntrac-ncld-1)
+!
+!
+ real (kind=kind_phys) exp,dtphys,dtp,dtf,sumed(2)
+ real (kind=kind_evod) tstep
+ real (kind=kind_phys) pdryini,sigshc,rk
+!!
+ integer ls_node(ls_dim,3)
+cc
+! ls_node(1,1) ... ls_node(ls_max_node,1) : values of l
+! ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
+! ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
+cc
+ integer ls_nodes(ls_dim,nodes)
+cc
+ integer max_ls_nodes(nodes)
+ integer lats_nodes_a(nodes)
+ integer lats_nodes_r(nodes)
+cc
+ integer global_lats_a(latg)
+ integer global_lats_r(latr)
+ integer lonsperlar(latr)
+ integer dimg
+cc
+ real(kind=kind_evod) epse(len_trie_ls)
+ real(kind=kind_evod) epso(len_trio_ls)
+ real(kind=kind_evod) epsedn(len_trie_ls)
+ real(kind=kind_evod) epsodn(len_trio_ls)
+cc
+ real(kind=kind_evod) snnp1ev(len_trie_ls)
+ real(kind=kind_evod) snnp1od(len_trio_ls)
+cc
+ integer ndexev(len_trie_ls)
+ integer ndexod(len_trio_ls)
+cc
+ real(kind=kind_evod) plnev_r(len_trie_ls,latr2)
+ real(kind=kind_evod) plnod_r(len_trio_ls,latr2)
+ real(kind=kind_evod) pddev_r(len_trie_ls,latr2)
+ real(kind=kind_evod) pddod_r(len_trio_ls,latr2)
+ real(kind=kind_evod) plnew_r(len_trie_ls,latr2)
+ real(kind=kind_evod) plnow_r(len_trio_ls,latr2)
+cc
+c$$$ integer lots,lotd,lota
+ integer lotn
+c$$$cc
+c$$$ parameter ( lots = 5*levs+1*levh+3 )
+c$$$ parameter ( lotd = 6*levs+2*levh+0 )
+c$$$ parameter ( lota = 3*levs+1*levh+1 )
+cc
+ real(kind=kind_evod) for_gr_r_1(lonrx,lots,lats_dim_r)
+ real(kind=kind_evod) dyn_gr_r_1(lonrx,lotd,lats_dim_r) ! hmhj
+ real(kind=kind_evod) bak_gr_r_1(lonrx,lota,lats_dim_r)
+cc
+! real(kind=kind_evod) for_gr_r_2(lonrx*lots,lats_dim_r)
+! real(kind=kind_evod) dyn_gr_r_2(lonrx*lotd,lats_dim_r) ! hmhj
+! real(kind=kind_evod) bak_gr_r_2(lonrx*lota,lats_dim_r)
+!
+ real(kind=kind_evod) for_gr_r_2(lonr,lots,lats_dim_r)
+ real(kind=kind_evod) dyn_gr_r_2(lonr,lotd,lats_dim_r) ! hmhj
+ real(kind=kind_evod) bak_gr_r_2(lonr,lota,lats_dim_r)
+cc
+ integer i,ierr,iter,j,k,kap,kar,kat,kau,kav,ksq,jj,kk
+ integer kst,kdtphi,kdtlam ! hmhj
+ integer l,lan,lan0,lat,lmax,locl,ii,lonrbm
+! integer lon_dim,lons_lat,n,node
+ integer lons_lat,n,node
+ integer nsphys
+!
+ real(kind=kind_evod) pwatg(latr),pwatj(lats_node_r),
+ & pwatp,ptotg(latr),sumwa,sumto,
+ & ptotj(lats_node_r),pcorr,pdryg,
+ & solhr,clstp
+cc
+ integer ipt_ls ! hmhj
+ real(kind=kind_evod) reall ! hmhj
+ real(kind=kind_evod) rlcs2(jcap1) ! hmhj
+
+ real(kind=kind_evod) typical_pgr
+c
+!timers______________________________________________________---
+
+ real*8 rtc ,timer1,timer2
+ real(kind=kind_evod) global_times_b(latr,nodes)
+
+!timers______________________________________________________---
+cc
+cc
+c$$$ parameter(ksq =0*levs+0*levh+1,
+c$$$ x ksplam =0*levs+0*levh+2,
+c$$$ x kspphi =0*levs+0*levh+3,
+c$$$ x ksu =0*levs+0*levh+4,
+c$$$ x ksv =1*levs+0*levh+4,
+c$$$ x ksz =2*levs+0*levh+4,
+c$$$ x ksd =3*levs+0*levh+4,
+c$$$ x kst =4*levs+0*levh+4,
+c$$$ x ksr =5*levs+0*levh+4)
+cc
+c$$$ parameter(kdtphi =0*levs+0*levh+1,
+c$$$ x kdrphi =1*levs+0*levh+1,
+c$$$ x kdtlam =1*levs+1*levh+1,
+c$$$ x kdrlam =2*levs+1*levh+1,
+c$$$ x kdulam =2*levs+2*levh+1,
+c$$$ x kdvlam =3*levs+2*levh+1,
+c$$$ x kduphi =4*levs+2*levh+1,
+c$$$ x kdvphi =5*levs+2*levh+1)
+cc
+c$$$ parameter(kau =0*levs+0*levh+1,
+c$$$ x kav =1*levs+0*levh+1,
+c$$$ x kat =2*levs+0*levh+1,
+c$$$ x kar =3*levs+0*levh+1,
+c$$$ x kap =3*levs+1*levh+1)
+cc
+cc
+c$$$ integer p_gz,p_zem,p_dim,p_tem,p_rm,p_qm
+c$$$ integer p_ze,p_di,p_te,p_rq,p_q,p_dlam,p_dphi,p_uln,p_vln
+c$$$ integer p_w,p_x,p_y,p_rt,p_zq
+c$$$cc
+c$$$cc old common /comfspec/
+c$$$ parameter(p_gz = 0*levs+0*levh+1, ! gze/o(lnte/od,2),
+c$$$ x p_zem = 0*levs+0*levh+2, ! zeme/o(lnte/od,2,levs),
+c$$$ x p_dim = 1*levs+0*levh+2, ! dime/o(lnte/od,2,levs),
+c$$$ x p_tem = 2*levs+0*levh+2, ! teme/o(lnte/od,2,levs),
+c$$$ x p_rm = 3*levs+0*levh+2, ! rme/o(lnte/od,2,levh),
+c$$$ x p_qm = 3*levs+1*levh+2, ! qme/o(lnte/od,2),
+c$$$ x p_ze = 3*levs+1*levh+3, ! zee/o(lnte/od,2,levs),
+c$$$ x p_di = 4*levs+1*levh+3, ! die/o(lnte/od,2,levs),
+c$$$ x p_te = 5*levs+1*levh+3, ! tee/o(lnte/od,2,levs),
+c$$$ x p_rq = 6*levs+1*levh+3, ! rqe/o(lnte/od,2,levh),
+c$$$ x p_q = 6*levs+2*levh+3, ! qe/o(lnte/od,2),
+c$$$ x p_dlam= 6*levs+2*levh+4, ! dpdlame/o(lnte/od,2),
+c$$$ x p_dphi= 6*levs+2*levh+5, ! dpdphie/o(lnte/od,2),
+c$$$ x p_uln = 6*levs+2*levh+6, ! ulne/o(lnte/od,2,levs),
+c$$$ x p_vln = 7*levs+2*levh+6, ! vlne/o(lnte/od,2,levs),
+c$$$ x p_w = 8*levs+2*levh+6, ! we/o(lnte/od,2,levs),
+c$$$ x p_x = 9*levs+2*levh+6, ! xe/o(lnte/od,2,levs),
+c$$$ x p_y =10*levs+2*levh+6, ! ye/o(lnte/od,2,levs),
+c$$$ x p_rt =11*levs+2*levh+6, ! rte/o(lnte/od,2,levh),
+c$$$ x p_zq =11*levs+3*levh+6) ! zqe/o(lnte/od,2)
+cc
+cc
+ integer indlsev,jbasev,n0
+ integer indlsod,jbasod
+cc
+ include 'function2'
+cc
+ real(kind=kind_evod) cons0,cons2 !constant
+cc
+ logical lsout
+ logical, parameter :: flipv = .true.
+cc
+! for nasa/nrl ozone production and distruction rates:(input through fixio)
+ real ozplin(latsozp,levozp,pl_coeff,timeoz)
+ integer jindx1(lats_node_r),jindx2(lats_node_r)!for ozone interpolaton
+ real ddy(lats_node_r) !for ozone interpolaton
+ real ozplout(levozp,lats_node_r,pl_coeff)
+!Moor real ozplout(lonr,levozp,pl_coeff,lats_node_r)
+!!
+ real(kind=kind_phys), allocatable :: acv(:,:),acvb(:,:),acvt(:,:)
+ save acv,acvb,acvt
+!!
+! integer, parameter :: maxran=5000
+! integer, parameter :: maxran=3000
+ integer, parameter :: maxran=6000, maxsub=6, maxrs=maxran/maxsub
+ type (random_stat) :: stat(maxrs)
+ real (kind=kind_phys), allocatable, save :: rannum_tank(:,:,:)
+ real (kind=kind_phys) :: rannum(lonr*latr)
+ integer iseed, nrc, seed0, kss, ksr, indxr(nrcm), iseedl
+ integer nf0,nf1,ind,nt,indod,indev
+ real(kind=kind_evod) fd2, wrk(1), wrk2(nrcm)
+
+ logical first,ladj
+ parameter (ladj=.true.)
+ data first/.true./
+! save krsize, first, nrnd,seed0
+ save first, seed0
+!!
+ integer nlons_v(ngptc)
+ real(kind=kind_phys) smc_v(ngptc,lsoil),stc_v(ngptc,lsoil)
+ &, slc_v(ngptc,lsoil)
+ &, swh_v(ngptc,levs), hlw_v(ngptc,levs)
+ &, vvel(ngptc,levs)
+ &, hprime_v(ngptc,nmtvr)
+ real(kind=kind_phys) phy_f3dv(ngptc,LEVS,num_p3d),
+ & phy_f2dv(ngptc,num_p2d)
+ &, rannum_v(ngptc,nrcm)
+ real(kind=kind_phys) sinlat_v(ngptc),coslat_v(ngptc)
+ &, ozplout_v(ngptc,levozp,pl_coeff)
+ real (kind=kind_rad) rqtk(ngptc), rcs2_lan, rcs_lan
+! real (kind=kind_rad) rcs_v(ngptc), rqtk(ngptc), rcs2_lan
+!
+!--------------------------------------------------------------------
+! print *,' in gloopb vertcoord_id =',vertcoord_id
+
+! real(kind=kind_evod) sinlat_v(lonr),coslat_v(lonr),rcs2_v(lonr)
+! real(kind=kind_phys) dpshc(lonr)
+ real (kind=kind_rad) work1, qmin, tem
+ parameter (qmin=1.0e-10)
+ integer ksd,ksplam,kspphi
+ integer ksu,ksv,ksz,item,jtem,ktem,ltem,mtem
+
+!
+! --- for debug test use
+ real (kind=kind_phys) :: temlon, temlat, alon, alat
+ integer :: ipt
+ logical :: lprnt
+!
+!
+ ksq =0*levs+0*levh+1
+ ksplam =0*levs+0*levh+2
+ kspphi =0*levs+0*levh+3
+ ksu =0*levs+0*levh+4
+ ksv =1*levs+0*levh+4
+ ksz =2*levs+0*levh+4
+ ksd =3*levs+0*levh+4
+ kst =4*levs+0*levh+4
+ ksr =5*levs+0*levh+4
+!
+ kau =0*levs+0*levh+1
+ kav =1*levs+0*levh+1
+ kat =2*levs+0*levh+1
+ kap =3*levs+0*levh+1
+ kar =3*levs+0*levh+2
+!
+! ksq = 0*levs + 0*levh + 1
+! kst = 4*levs + 0*levh + 4 ! hmhj
+ kdtphi = 0*levs + 0*levh + 1 ! hmhj
+ kdtlam = 1*levs+1*levh+1 ! hmhj
+!
+c$$$ kau =0*levs+0*levh+1
+c$$$ kav =1*levs+0*levh+1
+c$$$ kat =2*levs+0*levh+1
+c$$$ kar =3*levs+0*levh+1
+c$$$ kap =3*levs+1*levh+1
+cc
+cc--------------------------------------------------------------------
+cc
+ save_qe_ls(:,:) = trie_ls(:,:,p_q)
+ save_qo_ls(:,:) = trio_ls(:,:,p_q)
+
+
+!
+ if (first) then
+ allocate (bfilte(lnt2),bfilto(lnt2))
+!
+! initializations for the gloopb filter
+! *************************************
+ nf0 = (jcap+1)*2/3 ! highest wavenumber gloopb filter keeps fully
+ nf1 = (jcap+1) ! lowest wavenumber gloopb filter removes fully
+ fd2 = 1./(nf1-nf0)**2
+ do locl=1,ls_max_node
+ l = ls_node(locl,1)
+ jbasev = ls_node(locl,2)
+!sela if (l.eq.0) then
+!sela n0=2
+!sela else
+!sela n0=l
+!sela endif
+!
+!sela indev = indlsev(n0,l)
+ indev = indlsev(l,l)
+!sela do n=n0,jcap1,2
+!mjr do n=l,jcap1,2
+ do n=l,jcap,2
+ bfilte(indev) = max(1.-fd2*max(n-nf0,0)**2,cons_0) !constant
+ indev = indev + 1
+ enddo
+ if (mod(L,2).eq.mod(jcap+1,2)) bfilte(indev) = 1.
+ enddo
+!!
+ do locl=1,ls_max_node
+ l = ls_node(locl,1)
+ jbasod = ls_node(locl,3)
+ indod = indlsod(l+1,l)
+!mjr do n=l+1,jcap1,2
+ do n=l+1,jcap,2
+ bfilto(indod) = max(1.-fd2*max(n-nf0,0)**2,cons_0) !constant
+ indod = indod+1
+ enddo
+ if (mod(L,2).ne.mod(jcap+1,2)) bfilto(indod) = 1.
+ enddo
+!!
+! call random_seed(size=krsize)
+! if (me.eq.0) print *,' krsize=',krsize
+! allocate (nrnd(krsize))
+ allocate (acv(lonr,lats_node_r))
+ allocate (acvb(lonr,lats_node_r))
+ allocate (acvt(lonr,lats_node_r))
+!
+ seed0 = idate(1) + idate(2) + idate(3) + idate(4)
+
+
+ call random_setseed(seed0)
+ call random_number(wrk)
+ seed0 = seed0 + nint(wrk(1)*1000.0)
+!
+ if (.not. newsas) then ! random number needed for RAS and old SAS
+ if (random_clds) then ! create random number tank
+! -------------------------
+ if (.not. allocated(rannum_tank))
+ & allocate (rannum_tank(lonr,maxran,lats_node_r))
+! lonrb2 = lonr / 2
+ lonrbm = lonr / maxsub
+ if (me == 0) write(0,*)' maxran=',maxran,' maxrs=',maxrs,
+ & 'maxsub=',maxsub,' lonrbm=',lonrbm
+!$OMP parallel do private(nrc,iseedl,rannum,lat,i,j,k,ii,jj,kk)
+ do nrc=1,maxrs
+ iseedl = seed0 + nrc - 1
+ call random_setseed(iseedl,stat(nrc))
+ call random_number(rannum,stat(nrc))
+ do j=1,lats_node_r
+ lat = global_lats_r(ipt_lats_node_r-1+j)
+ jj = (lat-1)*lonr
+ do k=1,maxsub
+ kk = k - 1
+ do i=1,lonr
+ ii = kk*lonrbm + i
+ if (ii > lonr) ii = ii - lonr
+ rannum_tank(i,nrc+kk*maxrs,j) = rannum(ii+jj)
+ enddo
+ enddo
+ enddo
+ enddo
+ endif
+ endif
+!
+ if (me .eq. 0) then
+ print *,' seed0=',seed0,' idate=',idate,' wrk=',wrk
+ if (num_p3d .eq. 3) print *,' USING Ferrier-MICROPHYSICS'
+ if (num_p3d .eq. 4) print *,' USING ZHAO-MICROPHYSICS'
+ endif
+ if (fhour .eq. 0.0) then
+ do j=1,lats_node_r
+ do i=1,lonr
+! phy_f2d(i,j,num_p2d) = 0.0
+ phy_f2d(i,num_p2d,j) = 0.0
+ enddo
+ enddo
+ endif
+
+ if (ras) call ras_init(levs, me)
+
+ first = .false.
+ endif ! if (first) done
+!
+! print *,' after if(first) before if semilag'
+
+ if (semilag) then
+ dtp = tstep
+ dtf = tstep
+ else
+ dtphys = 3600.
+ nsphys = max(int((tstep+tstep)/dtphys+0.9999),1)
+ dtp = (tstep+tstep)/nsphys
+ dtf = 0.5*dtp
+ endif
+!
+ if(lsfwd) dtf = dtp
+!
+ solhr = mod(phour+idate(1),cons_24)
+
+! ************** Ken Campana Stuff ********************************
+!... set switch for saving convective clouds
+ if(lscca.and.lsswr) then
+ clstp = 1100+min(fhswr,fhour,cons_99) !initialize,accumulate,convert
+ elseif(lscca) then
+ clstp = 0100+min(fhswr,fhour,cons_99) !accumulate,convert
+ elseif(lsswr) then
+ clstp = 1100 !initialize,accumulate
+ else
+ clstp = 0100 !accumulate
+ endif
+! ************** Ken Campana Stuff ********************************
+!
+!
+ iseed = mod(100.0*sqrt(fhour*3600),cons_1p0d9) + 1 + seed0
+
+
+ if (.not. newsas) then ! random number needed for RAS and old SAS
+ if (random_clds) then
+ call random_setseed(iseed)
+ call random_number(wrk2)
+ do nrc=1,nrcm
+ indxr(nrc) = max(1, min(nint(wrk2(nrc)*maxran)+1,maxran))
+ enddo
+ endif
+ endif
+!
+! doing ozone i/o and latitudinal interpolation to local gauss lats
+! ifozphys=.true.
+
+ if (ntoz .gt. 0) then
+ call ozinterpol(me,lats_node_r,lats_node_r,idate,fhour,
+ & jindx1,jindx2,ozplin,ozplout,ddy)
+
+!Moor call ozinterpol(lats_node_r,lats_node_r,idate,fhour,
+! & jindx1,jindx2,ozplin,ozplout,ddy,
+! & global_lats_r,lonsperlar)
+ endif
+
+! if (me == 0) write(0,*)' after ozinterpol'
+!!
+c ----------------------------------------------------
+cc................................................................
+cc
+cc
+ call f_hpmstart(41,"gb delnpe")
+ call delnpe(trie_ls(1,1,p_zq ),
+ x trio_ls(1,1,p_dphi),
+ x trie_ls(1,1,p_dlam),
+ x epse,epso,ls_node)
+ call f_hpmstop(41)
+cc
+ call f_hpmstart(42,"gb delnpo")
+ call delnpo(trio_ls(1,1,p_zq ),
+ x trie_ls(1,1,p_dphi),
+ x trio_ls(1,1,p_dlam),
+ x epse,epso,ls_node)
+ call f_hpmstop(42)
+cc
+cc
+ call f_hpmstart(43,"gb dezouv dozeuv")
+!$OMP parallel do shared(trie_ls,trio_ls)
+!$OMP+shared(epsedn,epsodn,snnp1ev,snnp1od,ls_node)
+!$OMP+private(k)
+ do k=1,levs
+ call dezouv(trie_ls(1,1,p_x +k-1), trio_ls(1,1,p_w +k-1),
+ x trie_ls(1,1,p_uln+k-1), trio_ls(1,1,p_vln+k-1),
+ x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
+cc
+ call dozeuv(trio_ls(1,1,p_x +k-1), trie_ls(1,1,p_w +k-1),
+ x trio_ls(1,1,p_uln+k-1), trie_ls(1,1,p_vln+k-1),
+ x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
+ enddo
+ call f_hpmstop(43)
+cc
+! call mpi_barrier (mpi_comm_world,ierr)
+cc
+ call countperf(0,4,0.)
+ call synctime()
+ call countperf(1,4,0.)
+!!
+ dimg=0
+ call countperf(0,1,0.)
+cc
+! call f_hpmstart(48,"gb syn_ls2lats")
+cc
+! call f_hpmstop(48)
+cc
+ call f_hpmstart(49,"gb sumfln")
+cc
+ call sumfln_slg_gg(trie_ls(1,1,p_q),
+ x trio_ls(1,1,p_q),
+ x lat1s_r,
+ x plnev_r,plnod_r,
+ x 5*levs+3,ls_node,latr2,
+ x lats_dim_r,lots,for_gr_r_1,
+ x ls_nodes,max_ls_nodes,
+ x lats_nodes_r,global_lats_r,
+!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
+ x lats_node_r,ipt_lats_node_r,lon_dim_r,
+ x lonsperlar,lonrx,latr,0)
+!!
+ if(.not.gg_tracers)then
+ call sumfln_slg_gg(trie_ls(1,1,p_rt),
+ x trio_ls(1,1,p_rt),
+ x lat1s_r,
+ x plnev_r,plnod_r,
+ x levh,ls_node,latr2,
+ x lats_dim_r,lots,for_gr_r_1,
+ x ls_nodes,max_ls_nodes,
+ x lats_nodes_r,global_lats_r,
+!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
+ x lats_node_r,ipt_lats_node_r,lon_dim_r,
+ x lonsperlar,lonrx,latr,5*levs+3)
+ endif ! if(.not.gg_tracers)then
+cc
+ call f_hpmstop(49)
+cc
+ call countperf(1,1,0.)
+cc
+! print *,' in GLOOPB after second sumfln'
+cc
+ pwatg = 0.
+ ptotg = 0.
+
+!--------------------
+! if( vertcoord_id == 3. ) then ! For sigms/p/theta
+!--------------------
+ call countperf(0,11,0.)
+ CALL countperf(0,1,0.) ! hmhj
+ call f_hpmstart(50,"gb sumder2") ! hmhj
+!
+ do lan=1,lats_node_r
+ timer1=rtc()
+ lat = global_lats_r(ipt_lats_node_r-1+lan)
+ lmax = min(jcap,lonsperlar(lat)/2)
+ if ( (lmax+1)*2+1 .le. lonsperlar(lat)+2 ) then
+ do k=levs+1,4*levs+2*levh
+ do i = (lmax+1)*2+1, lonsperlar(lat)+2
+ dyn_gr_r_1(i,k,lan) = cons0 !constant
+ enddo
+ enddo
+ endif
+ enddo
+!
+ call sumder2_slg(trie_ls(1,1,P_te), ! hmhj
+ x trio_ls(1,1,P_te), ! hmhj
+ x lat1s_r, ! hmhj
+ x pddev_r,pddod_r, ! hmhj
+ x levs,ls_node,latr2, ! hmhj
+ x lats_dim_r,lotd, ! hmhj
+ x dyn_gr_r_1, ! hmhj
+ x ls_nodes,max_ls_nodes, ! hmhj
+ x lats_nodes_r,global_lats_r, ! hmhj
+!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r, ! hmhj
+ x lats_node_r,ipt_lats_node_r,lon_dim_r, ! hmhj
+ x lonsperlar,lonrx,latr,0) ! hmhj
+!
+ call f_hpmstop(50) ! hmhj
+ CALL countperf(1,1,0.)
+! -----------------
+! endif
+! -----------------
+cc
+ do lan=1,lats_node_r
+ timer1=rtc()
+! if (me == 0) print *,' In lan loop lan=', lan
+cc
+
+ lat = global_lats_r(ipt_lats_node_r-1+lan)
+! lon_dim = lon_dims_r(lan)
+cc
+ lons_lat = lonsperlar(lat)
+!-----------------------------------------
+! if( vertcoord_id == 3. ) then
+!-----------------------------------------
+
+!! calculate t rq u v zonal derivs. by multiplication with i*l
+!! note rlcs2=rcs2*L/rerth
+
+ lmax = min(jcap,lons_lat/2) ! hmhj
+!
+ ipt_ls=min(lat,latr-lat+1) ! hmhj
+
+ do i=1,lmax+1 ! hmhj
+ if ( ipt_ls .ge. lat1s_r(i-1) ) then ! hmhj
+ reall=i-1 ! hmhj
+ rlcs2(i)=reall*rcs2_r(ipt_ls)/rerth ! hmhj
+ else ! hmhj
+ rlcs2(i)=cons0 !constant ! hmhj
+ endif ! hmhj
+ enddo ! hmhj
+!
+!$omp parallel do private(k,i)
+ do k=1,levs ! hmhj
+ do i=1,lmax+1 ! hmhj
+!
+! d(t)/d(lam) ! hmhj
+ dyn_gr_r_1(2*i-1,(kdtlam-1+k),lan)= ! hmhj
+ x -for_gr_r_1(2*i ,(kst -1+k),lan)*rlcs2(i) ! hmhj
+ dyn_gr_r_1(2*i ,(kdtlam-1+k),lan)= ! hmhj
+ x for_gr_r_1(2*i-1,(kst -1+k),lan)*rlcs2(i) ! hmhj
+ enddo ! hmhj
+ enddo ! hmhj
+! -----------------------
+! endif
+! -----------------------
+
+! print *,' in GLOOPB before four_to_grid'
+cc
+ call countperf(0,6,0.)
+ call four_to_grid(for_gr_r_1(1,1,lan),for_gr_r_2(1,1,lan),
+!mjr & lon_dim ,lon_dim ,lons_lat,5*levs+3)
+ & lon_dim_r,lon_dim_r-2,lons_lat,5*levs+3)
+
+ if(.not.gg_tracers)then
+ CALL FOUR_TO_GRID(for_gr_r_1(1,ksr,lan),
+ & for_gr_r_2(1,ksr,lan),
+!mjr & lon_dim ,lon_dim ,lons_lat,levh)
+ & lon_dim_r,lon_dim_r-2,lons_lat,levh)
+ else ! gg_tracers
+ if (.not.shuff_lats_r) then
+! set for_gr_r_2 to rg1_a rg2_a rg3_a from gloopa
+ do k=1,levs
+ do i=1,min(lonf,lons_lat)
+ for_gr_r_2(i,ksr-1+k ,lan)=
+ & rg1_a(i,k,lats_node_a+1-lan)
+ for_gr_r_2(i,ksr-1+k+ levs,lan)=
+ & rg2_a(i,k,lats_node_a+1-lan)
+ for_gr_r_2(i,ksr-1+k+2*levs,lan)=
+ & rg3_a(i,k,lats_node_a+1-lan)
+ enddo
+ enddo
+ endif ! not shuff_lats_r
+ endif ! gg_tracers
+
+! print *,' in GLOOPB after four_to_grid '
+! ----------------------------------
+! if( vertcoord_id == 3. ) then
+! ----------------------------------
+ CALL FOUR_TO_GRID(dyn_gr_r_1(1,kdtphi,lan), ! hmhj
+ & dyn_gr_r_2(1,kdtphi,lan), ! hmhj
+!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
+ & lon_dim_r,lon_dim_r-2,lons_lat,levs) ! hmhj
+ CALL FOUR_TO_GRID(dyn_gr_r_1(1,kdtlam,lan), ! hmhj
+ & dyn_gr_r_2(1,kdtlam,lan), ! hmhj
+!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
+ & lon_dim_r,lon_dim_r-2,lons_lat,levs) ! hmhj
+! ----------------------------
+! endif
+! ---------------------------
+ call countperf(1,6,0.)
+!
+ timer2 = rtc()
+ global_times_b(lat,me+1) = timer2-timer1
+c$$$ print*,'timeloopb',me,timer1,timer2,global_times_b(lat,me+1)
+!!
+ enddo !lan
+cc
+
+ if(gg_tracers .and. shuff_lats_r) then
+! print*,' gloopb mpi_tracers_a_to_b shuff_lats_r',shuff_lats_r
+ call mpi_tracers_a_to_b(
+ x rg1_a,rg2_a,rg3_a,lats_nodes_a,global_lats_a,
+ x for_gr_r_2(1,1,1),
+ x lats_nodes_r,global_lats_r,ksr,0)
+ endif ! gg_tracers .and. shuff_lats_r
+
+ call f_hpmstart(51,"gb lat_loop2")
+
+ do lan=1,lats_node_r
+
+!
+ lat = global_lats_r(ipt_lats_node_r-1+lan)
+cc
+! lon_dim = lon_dims_r(lan)
+ lons_lat = lonsperlar(lat)
+ pwatp = 0.
+ rcs2_lan = rcs2_r(min(lat,latr-lat+1))
+ rcs_lan = sqrt(rcs2_lan)
+
+!$omp parallel do schedule(dynamic,1) private(lon)
+!$omp+private(sumq,xcp,hprime_v,swh_v,hlw_v,stc_v,smc_v,slc_v)
+!$omp+private(nlons_v,sinlat_v,coslat_v,ozplout_v,rannum_v)
+!$omp+private(prslk,prsl,prsik,prsi,phil,phii,dpshc,work1,tem)
+!$omp+private(gu,gv1,gd,gq,gphi,glam,gt,gtv,gr,vvel,gtvx,gtvy)
+!$omp+private(adt,adr,adu,adv,pgr,ugrd,vgrd,rqtk)
+!!$omp+private(adt,adr,adu,adv,pgr,rcs_v,ugrd,vgrd,rqtk)
+!$omp+private(phy_f3dv,phy_f2dv)
+!$omp+private(dt3dt_v,dq3dt_v,du3dt_v,dv3dt_v,upd_mf_v,dwn_mf_v)
+!$omp+private(det_mf_v,dkh_v,rnp_v)
+!$omp+private(njeff,item,jtem,ktem,i,j,k,n,kss)
+!!!$omp+private(temlon,temlat,lprnt,ipt)
+ do lon=1,lons_lat,ngptc
+!!
+ njeff = min(ngptc,lons_lat-lon+1)
+!!
+! lprnt = .false.
+!
+! --- ... for debug test
+! alon = 236.25
+! alat = 56.189
+! alon = 26.25
+! alat = 6.66
+! ipt = 0
+! do i = 1, njeff
+! item = lon + i - 1
+! temlon = xlon(item,lan) * 57.29578
+! if (temlon < 0.0) temlon = temlon + 360.0
+! temlat = xlat(item,lan) * 57.29578
+! lprnt = abs(temlon-alon) < 1.1 .and. abs(temlat-alat) < 1.1
+! & .and. kdt > 0
+! if ( lprnt ) then
+! ipt = i
+! exit
+! endif
+! enddo
+! lprnt = .false.
+!!
+ do k = 1, LEVS
+ do j = 1, njeff
+ jtem = lon-1+j
+ gu (j,k) = for_gr_r_2(jtem,KSU-1+k,lan)
+ gv1(j,k) = for_gr_r_2(jtem,KSV-1+k,lan)
+ gd (j,k) = for_gr_r_2(jtem,KSD-1+k,lan)
+ enddo
+ enddo
+!
+! p in cb by finite difference from henry juang not ln(p) ! hmhj
+ if(.not.gen_coord_hybrid) then ! hmhj
+ do j=1,njeff
+ item = lon+j-1
+ for_gr_r_2(item,ksq,lan) = exp(for_gr_r_2(item,ksq,lan))
+ enddo
+ endif ! .not.gen_coord_hybrid ! hmhj
+ do i=1,njeff
+ item = lon+i-1
+ gq(i) = for_gr_r_2(item,ksq,lan)
+ gphi(i) = for_gr_r_2(item,kspphi,lan)
+ glam(i) = for_gr_r_2(item,ksplam,lan)
+ enddo
+! Tracers
+ do n=1,ntrac
+ do k=1,levs
+ item = KSR-1+k+(n-1)*levs
+ do j=1,njeff
+ gr(j,k,n) = for_gr_r_2(lon-1+j,item,lan)
+ enddo
+ enddo
+ enddo
+
+!
+! For omega in gen_coord_hybrid ! hmhj
+! the same variables for thermodyn_id=3 for enthalpy ! hmhj
+ if( gen_coord_hybrid ) then
+ do k=1,levs ! hmhj
+ do j=1,njeff ! hmhj
+ gtv(j,k) = for_gr_r_2(lon-1+j,kst-1+k,lan)
+ enddo
+ enddo
+! --------------------------------------
+ if( vertcoord_id.eq.3. ) then
+! --------------------------------------
+ do k=1,levs ! hmhj
+ do j=1,NJEFF ! hmhj
+ jtem = lon-1+j
+ gtvx(j,k) = dyn_gr_r_2(jtem,kdtlam-1+k,lan)
+ gtvy(j,k) = dyn_gr_r_2(jtem,kdtphi-1+k,lan)
+ enddo ! hmhj
+ enddo
+! -----------------------------
+ endif
+! -----------------------------
+ if( thermodyn_id.eq.3 ) then ! hmhj
+! get dry temperature from enthalpy ! hmhj
+ do k=1,levs
+ do j=1,njeff
+ sumq(j,k) = 0.0
+ xcp(j,k) = 0.0
+ enddo
+ enddo
+ do n=1,ntrac ! hmhj
+ if( cpi(n).ne.0.0 ) then ! hmhj
+ kss = ksr+(n-1)*levs ! hmhj
+ do k=1,levs ! hmhj
+ ktem = kss+k-1
+ do j=1,njeff ! hmhj
+ sumq(j,k) = sumq(j,k) + gr(j,k,n) ! hmhj
+ xcp(j,k) = xcp(j,k) + cpi(n)*gr(j,k,n) ! hmhj
+ enddo ! hmhj
+ enddo ! hmhj
+ endif ! hmhj
+ enddo ! hmhj
+ do k=1,levs ! hmhj
+ do j=1,njeff ! hmhj
+ work1 = (1.-sumq(j,k))*cpi(0) + xcp(j,k) ! hmhj
+ gt(j,k) = gtv(j,k) / work1 ! hmhj
+ enddo ! hmhj
+ enddo ! hmhj
+! get dry temperature from virtual temperature ! hmhj
+ else if( thermodyn_id.le.1 ) then ! hmhj
+ do k=1,levs
+ do j=1,njeff
+ gt(j,k) = gtv(j,k) / (1.0 + fv*max(gr(j,k,1),qmin))
+ enddo
+ enddo
+ else
+! get dry temperature from dry temperature ! hmhj
+ do k=1,levs ! hmhj
+ do j=1,njeff ! hmhj
+ gt(j,k) = gtv(j,k) ! hmhj
+ enddo ! hmhj
+ enddo
+ endif ! if(thermodyn_id.eq.3)
+ else
+ do k=1,levs
+ do j=1,njeff
+ gt(j,k) = for_gr_r_2(lon+j-1,kst+k-1,lan)
+ & / (1.0 + fv*max(gr(j,k,1),qmin))
+ enddo
+ enddo
+
+ endif ! if(gen_coord_hybrid)
+!
+ do j=1,njeff
+ item = lon+j-1
+ gq_save(item,lan) = for_gr_r_2(item,ksq,lan)
+ enddo
+!
+! if (lprnt) then
+! print *,' gq=',gq(ipt),' gphi=',gphi(ipt),glam(ipt)
+! print *,' gd=',gd(ipt,:)
+! print *,' gu=',gu(ipt,:)
+! print *,' gv1=',gv1(ipt,:)
+! endif
+! hmhj for gen_coord_hybrid
+ if( gen_coord_hybrid ) then ! hmhj
+
+ call hyb2press_gc(njeff,ngptc,gq, gtv, prsi,prsl ! hmhj
+ &, prsik, prslk)
+! call omegtes_gc(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)), ! hmhj
+ call omegtes_gc(njeff,ngptc,rcs2_lan, ! hmhj
+ & gq,gphi,glam,gtv,gtvx,gtvy,gd,gu,gv1,vvel) ! hmhj
+ elseif( hybrid )then ! hmhj
+! vertical structure variables: del,si,sl
+
+! if (lprnt) print *,' ipt=',ipt,' ugrb=',gu(ipt,levs),
+! &' vgrb=',gv1(ipt,levs),' lon=',lon
+! &,' xlon=',xlon(lon+ipt-1,lan),' xlat=',xlat(lon+ipt-1,lan)
+
+ call hyb2press(njeff,ngptc,gq, prsi, prsl,prsik,prslk)
+! call omegtes(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)),
+ call omegtes(njeff,ngptc,rcs2_lan,
+ & gq,gphi,glam,gd,gu,gv1,vvel)
+! & gq,gphi,glam,gd,gu,gv1,vvel,lprnt,ipt)
+
+! if (lprnt) then
+! print *,' vvel=',vvel(ipt,:)
+! call mpi_quit(9999)
+! endif
+ else ! for sigma coordinate
+ call sig2press(njeff,ngptc,gq,sl,si,slk,sik,
+ & prsi,prsl,prsik,prslk)
+ call omegast3(njeff,ngptc,levs,
+ & gphi,glam,gu,gv1,gd,del,rcs2_lan,vvel,gq,sl)
+! & gphi,glam,gu,gv1,gd,del,
+! & rcs2_r(min(lat,latr-lat+1)),vvel,gq,sl)
+
+ endif
+!
+ do i=1,njeff
+ phil(i,levs) = 0.0 ! forces calculation of geopotential in gbphys
+ pgr(i) = gq(i) * 1000.0 ! Convert from kPa to Pa for physics
+ prsi(i,1) = pgr(i)
+ dpshc(i) = 0.3 * prsi(i,1)
+!
+ nlons_v(i) = lons_lat
+ sinlat_v(i) = sinlat_r(lat)
+ coslat_v(i) = coslat_r(lat)
+! rcs_v(i) = sqrt(rcs2_lan)
+! rcs_v(i) = sqrt(rcs2_r(min(lat,latr-lat+1)))
+ enddo
+ do k=1,levs
+ do i=1,njeff
+ ugrd(i,k) = gu(i,k) * rcs_lan
+ vgrd(i,k) = gv1(i,k) * rcs_lan
+! ugrd(i,k) = gu(i,k) * rcs_v(i)
+! vgrd(i,k) = gv1(i,k) * rcs_v(i)
+ prsl(i,k) = prsl(i,k) * 1000.0
+ prsi(i,k+1) = prsi(i,k+1) * 1000.0
+ vvel(i,k) = vvel(i,k) * 1000.0 ! Convert from Cb/s to Pa/s
+ enddo
+ enddo
+ if (gen_coord_hybrid .and. thermodyn_id == 3) then
+ do i=1,ngptc
+ prslk(i,1) = 0.0 ! forces calculation of geopotential in gbphys
+ prsik(i,1) = 0.0 ! forces calculation of geopotential in gbphys
+ enddo
+ endif
+!
+ if (ntoz .gt. 0) then
+ do j=1,pl_coeff
+ do k=1,levozp
+ do i=1,ngptc
+!Moorthi ozplout_v(i,k,j) = ozplout(lon+i-1,k,j,lan)
+ ozplout_v(i,k,j) = ozplout(k,lan,j)
+ enddo
+ enddo
+ enddo
+ endif
+ do k=1,lsoil
+ do i=1,njeff
+ item = lon+i-1
+ smc_v(i,k) = sfc_fld%smc(item,k,lan)
+ stc_v(i,k) = sfc_fld%stc(item,k,lan)
+ slc_v(i,k) = sfc_fld%slc(item,k,lan)
+ enddo
+ enddo
+ do k=1,nmtvr
+ do i=1,njeff
+ hprime_v(i,k) = hprime(lon+i-1,k,lan)
+ enddo
+ enddo
+!!
+ do j=1,num_p3d
+ do k=1,levs
+ do i=1,njeff
+ phy_f3dv(i,k,j) = phy_f3d(lon+i-1,k,j,lan)
+ enddo
+ enddo
+ enddo
+ do j=1,num_p2d
+ do i=1,njeff
+ phy_f2dv(i,j) = phy_f2d(lon+i-1,j,lan)
+ enddo
+ enddo
+ if (.not. newsas) then
+ if (random_clds) then
+ do j=1,nrcm
+ do i=1,njeff
+ rannum_v(i,j) = rannum_tank(lon+i-1,indxr(j),lan)
+ enddo
+ enddo
+ else
+ do j=1,nrcm
+ do i=1,njeff
+ rannum_v(i,j) = 0.6 ! This is useful for debugging
+ enddo
+ enddo
+ endif
+ endif
+ do k=1,levs
+ do i=1,njeff
+ item = lon+i-1
+ swh_v(i,k) = swh(item,k,lan)
+ hlw_v(i,k) = hlw(item,k,lan)
+ enddo
+ enddo
+ if (ldiag3d) then
+ do n=1,6
+ do k=1,levs
+ do i=1,njeff
+ dt3dt_v(i,k,n) = dt3dt(lon+i-1,k,n,lan)
+ enddo
+ enddo
+ enddo
+ do n=1,4
+ do k=1,levs
+ do i=1,njeff
+ du3dt_v(i,k,n) = du3dt(lon+i-1,k,n,lan)
+ dv3dt_v(i,k,n) = dv3dt(lon+i-1,k,n,lan)
+ enddo
+ enddo
+ enddo
+ endif
+ if (ldiag3d .or. lggfs3d) then
+ do n=1,5+pl_coeff
+ do k=1,levs
+ do i=1,njeff
+ dq3dt_v(i,k,n) = dq3dt(lon+i-1,k,n,lan)
+ enddo
+ enddo
+ enddo
+ do k=1,levs
+ do i=1,njeff
+ upd_mf_v(i,k) = upd_mf(lon+i-1,k,lan)
+ dwn_mf_v(i,k) = dwn_mf(lon+i-1,k,lan)
+ det_mf_v(i,k) = det_mf(lon+i-1,k,lan)
+ enddo
+ enddo
+ endif
+ if (lggfs3d) then
+ do k=1,levs
+ do i=1,njeff
+ dkh_v(i,k) = dkh(lon+i-1,k,lan)
+ rnp_v(i,k) = rnp(lon+i-1,k,lan)
+ enddo
+ enddo
+ endif
+!
+! write(0,*)' calling gbphys kdt=',kdt,' lon=',lon,' lan=',lan
+! &,' nlons_v=',ntoz,ntcw,nmtvr,lonr,latr,jcap,ras
+! &,' tisfc=',sfc_fld%tisfc(lon,lan)
+! print *,' temp=',for_gr_r_2(lon,kst,lan)
+!
+ call gbphys &
+! --- inputs:
+ & ( njeff,ngptc,levs,lsoil,lsm,ntrac,ncld,ntoz,ntcw, &
+ & nmtvr,nrcm,levozp,lonr,latr,jcap,num_p3d,num_p2d, &
+ & kdt,lat,me,pl_coeff,nlons_v,ncw,flgmin,crtrh,cdmbgwd, &
+ & ccwf,dlqf,ctei_rm,clstp,dtp,dtf,fhour,solhr, &
+ & slag,sdec,cdec,sinlat_v,coslat_v,pgr,ugrd,vgrd, &
+ & gt,gr,vvel,prsi,prsl,prslk,prsik,phii,phil, &
+ & rannum_v,ozplout_v,pl_pres,dpshc, &
+ & hprime_v, xlon(lon,lan),xlat(lon,lan), &
+ & sfc_fld%slope (lon,lan), sfc_fld%shdmin(lon,lan), &
+ & sfc_fld%shdmax(lon,lan), sfc_fld%snoalb(lon,lan), &
+ & sfc_fld%tg3 (lon,lan), sfc_fld%slmsk (lon,lan), &
+ & sfc_fld%vfrac (lon,lan), sfc_fld%vtype (lon,lan), &
+ & sfc_fld%stype (lon,lan), sfc_fld%uustar(lon,lan), &
+ & sfc_fld%oro (lon,lan), flx_fld%coszen(lon,lan), &
+ & flx_fld%sfcdsw(lon,lan), flx_fld%sfcnsw(lon,lan), &
+ & flx_fld%sfcdlw(lon,lan), flx_fld%tsflw (lon,lan), &
+ & flx_fld%sfcemis(lon,lan), sfalb(lon,lan), &
+ & swh_v, hlw_v, &
+ & ras,pre_rad,ldiag3d,lggfs3d,lssav,lssav_cc, &
+ & bkgd_vdif_m,bkgd_vdif_h,bkgd_vdif_s,psautco,prautco, evpco, &
+ & wminco, &
+ & flipv,old_monin,cnvgwd,shal_cnv,sashal,newsas,cal_pre, &
+ & mom4ice,mstrat,trans_trac,nst_fcst,moist_adj,fscav, &
+ & thermodyn_id, sfcpress_id, gen_coord_hybrid, &
+! --- input/outputs:
+ & sfc_fld%hice (lon,lan), sfc_fld%fice (lon,lan), &
+ & sfc_fld%tisfc (lon,lan), sfc_fld%tsea (lon,lan), &
+ & sfc_fld%tprcp (lon,lan), sfc_fld%cv (lon,lan), &
+ & sfc_fld%cvb (lon,lan), sfc_fld%cvt (lon,lan), &
+ & sfc_fld%srflag(lon,lan), sfc_fld%snwdph(lon,lan), &
+ & sfc_fld%sheleg(lon,lan), sfc_fld%sncovr(lon,lan), &
+ & sfc_fld%zorl (lon,lan), sfc_fld%canopy(lon,lan), &
+ & sfc_fld%ffmm (lon,lan), sfc_fld%ffhh (lon,lan), &
+ & sfc_fld%f10m (lon,lan), flx_fld%srunoff(lon,lan), &
+ & flx_fld%evbsa (lon,lan), flx_fld%evcwa (lon,lan), &
+ & flx_fld%snohfa(lon,lan), flx_fld%transa(lon,lan), &
+ & flx_fld%sbsnoa(lon,lan), flx_fld%snowca(lon,lan), &
+ & flx_fld%soilm (lon,lan), flx_fld%tmpmin(lon,lan), &
+ & flx_fld%tmpmax(lon,lan), flx_fld%dusfc (lon,lan), &
+ & flx_fld%dvsfc (lon,lan), flx_fld%dtsfc (lon,lan), &
+ & flx_fld%dqsfc (lon,lan), flx_fld%geshem(lon,lan), &
+ & flx_fld%gflux (lon,lan), flx_fld%dlwsfc(lon,lan), &
+ & flx_fld%ulwsfc(lon,lan), flx_fld%suntim(lon,lan), &
+ & flx_fld%runoff(lon,lan), flx_fld%ep (lon,lan), &
+ & flx_fld%cldwrk(lon,lan), flx_fld%dugwd (lon,lan), &
+ & flx_fld%dvgwd (lon,lan), flx_fld%psmean(lon,lan), &
+ & flx_fld%bengsh(lon,lan), flx_fld%spfhmin(lon,lan), &
+ & flx_fld%spfhmax(lon,lan), &
+ & dt3dt_v, dq3dt_v, du3dt_v, dv3dt_v, &
+ & acv(lon,lan), acvb(lon,lan), acvt(lon,lan), &
+ & slc_v, smc_v, stc_v, &
+ & upd_mf_v, dwn_mf_v, det_mf_v, dkh_v, rnp_v, &
+ & phy_f3dv, phy_f2dv, &
+ & DLWSFC_cc(lon,lan), ULWSFC_cc(lon,lan), &
+ & DTSFC_cc(lon,lan), SWSFC_cc(lon,lan), &
+ & DUSFC_cc(lon,lan), DVSFC_cc(lon,lan), &
+ & DQSFC_cc(lon,lan), PRECR_cc(lon,lan), &
+
+ & nst_fld%xt(lon,lan), nst_fld%xs(lon,lan), &
+ & nst_fld%xu(lon,lan), nst_fld%xv(lon,lan), &
+ & nst_fld%xz(lon,lan), nst_fld%zm(lon,lan), &
+ & nst_fld%xtts(lon,lan), nst_fld%xzts(lon,lan), &
+ & nst_fld%d_conv(lon,lan), nst_fld%ifd(lon,lan), &
+ & nst_fld%dt_cool(lon,lan), nst_fld%Qrain(lon,lan), &
+! --- outputs:
+ & adt, adr, adu, adv, &
+ & sfc_fld%t2m (lon,lan), sfc_fld%q2m (lon,lan), &
+ & flx_fld%u10m (lon,lan), flx_fld%v10m (lon,lan), &
+ & flx_fld%zlvl (lon,lan), flx_fld%psurf (lon,lan), &
+ & flx_fld%hpbl (lon,lan), flx_fld%pwat (lon,lan), &
+ & flx_fld%t1 (lon,lan), flx_fld%q1 (lon,lan), &
+ & flx_fld%u1 (lon,lan), flx_fld%v1 (lon,lan), &
+ & flx_fld%chh (lon,lan), flx_fld%cmm (lon,lan), &
+ & flx_fld%dlwsfci(lon,lan), flx_fld%ulwsfci(lon,lan), &
+ & flx_fld%dswsfci(lon,lan), flx_fld%uswsfci(lon,lan), &
+ & flx_fld%dtsfci(lon,lan), flx_fld%dqsfci(lon,lan), &
+ & flx_fld%gfluxi(lon,lan), flx_fld%epi (lon,lan), &
+ & flx_fld%smcwlt2(lon,lan), flx_fld%smcref2(lon,lan), &
+!hchuang code change [+3L] 11/12/2007 : add 2D
+ & flx_fld%gsoil(lon,lan), flx_fld%gtmp2m(lon,lan), &
+ & flx_fld%gustar(lon,lan), flx_fld%gpblh(lon,lan), &
+ & flx_fld%gu10m(lon,lan), flx_fld%gv10m(lon,lan), &
+ & flx_fld%gzorl(lon,lan), flx_fld%goro(lon,lan), &
+
+ & XMU_cc(lon,lan), DLW_cc(lon,lan), DSW_cc(lon,lan), &
+ & SNW_cc(lon,lan), LPREC_cc(lon,lan), &
+
+ & nst_fld%Tref(lon,lan), nst_fld%z_c(lon,lan), &
+ & nst_fld%c_0 (lon,lan), nst_fld%c_d(lon,lan), &
+ & nst_fld%w_0 (lon,lan), nst_fld%w_d(lon,lan), &
+ & rqtk &! rqtkD
+! & bak_gr_r_2(lon,kap,lan), &! rqtkD
+ & )
+!!
+ do k=1,levs
+ do i=1,njeff
+ item = lon + i - 1
+ bak_gr_r_2(item,kau+k-1,lan) = adu(i,k) * rcs_lan
+ bak_gr_r_2(item,kav+k-1,lan) = adv(i,k) * rcs_lan
+! bak_gr_r_2(item,kau+k-1,lan) = adu(i,k) * rcs_v(i)
+! bak_gr_r_2(item,kav+k-1,lan) = adv(i,k) * rcs_v(i)
+ bak_gr_r_2(item,kat+k-1,lan) = adt(i,k)
+ enddo
+ enddo
+ do n=1,ntrac
+ do k=1,levs
+ ktem = kar+k-1+(n-1)*levs
+ do i=1,njeff
+ item = lon + i - 1
+ bak_gr_r_2(item,ktem,lan) = adr(i,k,n)
+ enddo
+ enddo
+ enddo
+ if (gg_tracers) then
+ do i=1,njeff
+ bak_gr_r_2(lon+i-1,kap,lan) = rqtk(i)
+ enddo
+ else
+ do i=1,njeff
+ bak_gr_r_2(lon+i-1,kap,lan) = 0.0
+ enddo
+ endif
+!!
+!<-- cpl insertion: instantanious variables
+ do i=1,njeff
+ item = lon+i-1
+ U_BOT_cc(item,lan) = adu(i,1)
+ V_BOT_cc(item,lan) = adv(i,1)
+ Q_BOT_cc(item,lan) = adr(i,1,1)
+ P_BOT_cc(item,lan) = prsl(i,1)
+ P_SURF_cc(item,lan) = prsi(i,1)
+ enddo
+
+ do i=1,njeff
+ item = lon+i-1
+ T_BOT_cc(item,lan) = adt(i,1)
+ tem = adt(i,1)*(1+RVRDM1*adr(i,1,1))
+ Z_BOT_cc(item,lan) = -(RD/grav)*tem
+ & * LOG(prsl(i,1)/prsi(i,1))
+!
+ ffmm_cc(item,lan) = sfc_fld%ffmm(item,lan)
+ ffhh_cc(item,lan) = sfc_fld%ffhh(item,lan)
+ if (sfc_fld%SLMSK(item,lan) .lt. 0.01) then
+ T_SFC_cc(item,lan) = sfc_fld%tsea(item,lan)
+ & + sfc_fld%oro(item,lan)*RLAPSE
+ else
+ T_SFC_cc(item,lan) = sfc_fld%tsea(item,lan)
+ end if
+ FICE_SFC_cc(item,lan) = sfc_fld%fice(item,lan)
+ HICE_SFC_cc(item,lan) = sfc_fld%hice(item,lan)
+ & * sfc_fld%fice(item,lan)
+ enddo
+! do i=istrt,istrt+njeff-1
+! if (ffmm_cc(i,lan).LT.1.0) print *,'ffmm_cc<1',ffmm_cc(i,lan)
+! if (ffhh_cc(i,lan).LT.1.0) print *,'ffhh_cc<1',ffmm_cc(i,lan)
+! enddo
+! if (me .eq. 0) then
+! call atm_maxmin(njeff,1,LPREC_cc(lon,lan),
+! > 'in gbphys_call, LPREC_cc')
+! print *,'after cpl,istrt=',istrt,'istrt+njeff-1=',
+! > istrt+njeff-1,'lan=',lan
+! endif
+!--> cpl insertion
+
+ if( gen_coord_hybrid .and. thermodyn_id.eq.3 ) then ! hmhj
+
+! convert dry temperature to enthalpy ! hmhj
+ do k=1,levs
+ do j=1,njeff
+ item = lon+j-1
+ sumq(j,k) = 0.0
+ xcp(j,k) = 0.0
+ enddo
+ enddo
+ do i=1,ntrac ! hmhj
+ kss = kar+(i-1)*levs
+ if( cpi(i).ne.0.0 ) then ! hmhj
+ do k=1,levs ! hmhj
+ ktem = kss+k-1
+ do j=1,njeff ! hmhj
+ item = lon+j-1
+ work1 = bak_gr_r_2(item,ktem,lan) ! hmhj
+ sumq(j,k) = sumq(j,k) + work1 ! hmhj
+ xcp(j,k) = xcp(j,k) + cpi(i)*work1 ! hmhj
+ enddo ! hmhj
+ enddo ! hmhj
+ endif ! hmhj
+ enddo ! hmhj
+ do k=1,levs ! hmhj
+ ktem = kat+k-1
+ do j=1,njeff ! hmhj
+ item = lon+j-1
+ work1 = (1.-sumq(j,k))*cpi(0) + xcp(j,k) ! hmhj
+ bak_gr_r_2(item,ktem,lan) = bak_gr_r_2(item,ktem,lan)
+ & * work1 ! hmhj
+ adt(j,k) = adt(j,k)*work1
+ enddo ! hmhj
+ enddo ! hmhj
+
+ else ! hmhj
+
+! convert dry temperture to virtual temperature ! hmhj
+ do k=1,levs ! hmhj
+ ktem = kar+k-1
+ jtem = kat+k-1
+ do j=1,njeff ! hmhj
+ item = lon+j-1
+ work1 = 1.0 + fv * max(bak_gr_r_2(item,ktem,lan),qmin) ! hmhj
+ bak_gr_r_2(item,jtem,lan) = bak_gr_r_2(item,jtem,lan)
+ & * work1 ! hmhj
+ adt(j,k) = adt(j,k)*work1
+ enddo ! hmhj
+ enddo ! hmhj
+
+ endif
+ if( gen_coord_hybrid .and. vertcoord_id == 3. ) then ! hmhj
+ prsi = prsi * 0.001 ! Convert from Pa to kPa
+ if( thermodyn_id == 3. ) then ! hmhj
+ call gbphys_adv_h(njeff,ngptc,dtf,gtv,gu,gv1,gr , gq, ! hmhj
+ & adt,adu,adv,adr,prsi )
+! call gbphys_adv_h(njeff,ngptc,dtf,
+! & for_gr_r_2(lon,kst,lan),
+! & for_gr_r_2(lon,ksu,lan),
+! & for_gr_r_2(lon,ksv,lan),
+! & for_gr_r_2(lon,ksr,lan),
+! & for_gr_r_2(lon,ksq,lan),
+! & bak_gr_r_2(lon,kat,lan),
+! & bak_gr_r_2(lon,kau,lan),
+! & bak_gr_r_2(lon,kav,lan),
+! & bak_gr_r_2(lon,kar,lan),
+! & prsi )
+ else
+ call gbphys_adv(njeff,ngptc,dtf,gtv,gu,gv1,gr,gq, ! hmhj
+ & adt,adu,adv,adr,prsi )
+! call gbphys_adv(njeff,ngptc,dtf,
+! & for_gr_r_2(lon,kst,lan),
+! & for_gr_r_2(lon,ksu,lan),
+! & for_gr_r_2(lon,ksv,lan),
+! & for_gr_r_2(lon,ksr,lan),
+! & for_gr_r_2(lon,ksq,lan),
+! & bak_gr_r_2(lon,kat,lan),
+! & bak_gr_r_2(lon,kau,lan),
+! & bak_gr_r_2(lon,kav,lan),
+! & bak_gr_r_2(lon,kar,lan),
+! & prsi )
+ endif ! hmhj
+ endif ! hmhj
+!!
+ do k=1,lsoil
+ do i=1,njeff
+ item = lon + i - 1
+ sfc_fld%smc(item,k,lan) = smc_v(i,k)
+ sfc_fld%stc(item,k,lan) = stc_v(i,k)
+ sfc_fld%slc(item,k,lan) = slc_v(i,k)
+ enddo
+ enddo
+!!
+ do j=1,num_p3d
+ do k=1,levs
+ do i=1,njeff
+ phy_f3d(lon+i-1,k,j,lan) = phy_f3dv(i,k,j)
+ enddo
+ enddo
+ enddo
+ do j=1,num_p2d
+ do i=1,njeff
+ phy_f2d(lon+i-1,j,lan) = phy_f2dv(i,j)
+ enddo
+ enddo
+!
+ if (ldiag3d) then
+ do n=1,6
+ do k=1,levs
+ do i=1,njeff
+ dt3dt(lon+i-1,k,n,lan) = dt3dt_v(i,k,n)
+ enddo
+ enddo
+ enddo
+ do n=1,4
+ do k=1,levs
+ do i=1,njeff
+ du3dt(lon+i-1,k,n,lan) = du3dt_v(i,k,n)
+ dv3dt(lon+i-1,k,n,lan) = dv3dt_v(i,k,n)
+ enddo
+ enddo
+ enddo
+ endif
+ if (ldiag3d .or. lggfs3d) then
+ do n=1,5+pl_coeff
+ do k=1,levs
+ do i=1,njeff
+ dq3dt(lon+i-1,k,n,lan) = dq3dt_v(i,k,n)
+ enddo
+ enddo
+ enddo
+ do k=1,levs
+ do i=1,njeff
+ upd_mf(lon+i-1,k,lan) = upd_mf_v(i,k)
+ dwn_mf(lon+i-1,k,lan) = dwn_mf_v(i,k)
+ det_mf(lon+i-1,k,lan) = det_mf_v(i,k)
+ enddo
+ enddo
+ endif
+ if (lggfs3d) then
+ do k=1,levs
+ do i=1,njeff
+ dkh(lon+i-1,k,lan) = dkh_v(i,k)
+ rnp(lon+i-1,k,lan) = rnp_v(i,k)
+ enddo
+ enddo
+ endif
+!
+ enddo ! lon loop
+!
+!
+! CALL dscal(LEVS*lonr,rcs2_v,bak_gr_r_2(1,kau,lan),1)
+! CALL dscal(LEVS*lonr,rcs2_v,bak_gr_r_2(1,kav,lan),1)
+!
+!
+ ptotj(lan) = 0.
+ do j=1,lons_lat
+ ptotj(lan) = ptotj(lan) + gq_save(j,lan)
+ pwatp = pwatp + flx_fld%pwat(j,lan)
+! print *,' kdt=',kdt,' pwatp=',pwatp,' pwat=',flx_fld%pwat(j,lan)
+! &,' j=',j
+ enddo
+ pwatj(lan) = pwatp*grav/(2.*lonsperlar(lat)*1.e3)
+ ptotj(lan) = ptotj(lan)/(2.*lonsperlar(lat))
+!!
+!!
+c$$$ if (kdt.eq.1) then
+c$$$ do j=1,lons_lat
+c$$$ do i=1,levs
+c$$$ write(8700+lat,*)
+c$$$ & bak_gr_r_2(j,kat-1+i,lan),i,j
+c$$$ write(8800+lat,*)
+c$$$ & bak_gr_r_2(j,kar-1+i,lan),i,j
+c$$$ write(8900+lat,*)
+c$$$ & bak_gr_r_2(j,kau-1+i,lan),i,j
+c$$$ write(8100+lat,*)
+c$$$ & bak_gr_r_2(j,kav-1+i,lan),i,j
+c$$$ write(8200+lat,*)
+c$$$ & bak_gr_r_2(j,kar-1+i+levs,lan),i,j
+c$$$ write(8300+lat,*)
+c$$$ & bak_gr_r_2(j,kar-1+i+2*levs,lan),i,j
+c$$$ enddo
+c$$$ enddo
+c$$$ endif
+!!
+ enddo ! lan loop
+!
+ call f_hpmstop(51)
+!
+! lotn=3*levs+1*levh
+!
+ do lan=1,lats_node_r ! four_to_grid lan loop
+!
+ lat = global_lats_r(ipt_lats_node_r-1+lan)
+! lon_dim = lon_dims_r(lan)
+ lons_lat = lonsperlar(lat)
+!
+ call countperf(0,6,0.)
+!
+ call grid_to_four(bak_gr_r_2(1,1,lan),bak_gr_r_1(1,1,lan),
+ & lon_dim_r-2,lon_dim_r,lons_lat,3*levs+1)
+!
+ if (.not. gg_tracers .or. lsout) then
+ call grid_to_four(bak_gr_r_2(1,kar,lan),
+ & bak_gr_r_1(1,kar,lan),
+ & lon_dim_r-2,lon_dim_r,lons_lat,levh)
+ endif
+ call countperf(1,6,0.)
+
+ if (gg_tracers) then
+ if (.not.shuff_lats_r) then
+ item = lats_node_a + 1 - lan + yhalo
+ do k=1,levs
+ jtem = levs + 1 - k
+ ktem = kar - 1 + k
+ do i=1,min(lonf,lons_lat)
+ rg1_h(xhalo+i,jtem,item) = bak_gr_r_2(i,ktem,lan)
+ rg2_h(xhalo+i,jtem,item) = bak_gr_r_2(i,ktem+levs,lan)
+ rg3_h(xhalo+i,jtem,item) = bak_gr_r_2(i,ktem+2*levs,lan)
+
+c$$$ if (kdt .eq. 1) write(888,*) 'rg1_h, = ',
+c$$$ . i,k,lan, rg1_h(xhalo+i,levs+1-k,lats_node_a+1-lan+yhalo)
+ enddo
+ enddo
+ endif ! .not.shuff_lats_r
+ endif ! gg_tracers
+!
+ enddo ! fin four_to_grid lan loop
+!
+ if (gg_tracers .and. shuff_lats_r) then
+! print*,' gloopb mpi_tracers_b_to_a shuff_lats_r',shuff_lats_r
+ccmr call mpi_barrier (mc_comp,ierr)
+ call mpi_tracers_b_to_a(
+ & bak_gr_r_2(1,1,1),
+ & lats_nodes_r,global_lats_r,
+ & rg1_h,rg2_h,rg3_h,lats_nodes_a,global_lats_a,kar,0)
+ endif ! gg_tracers .and. shuff_lats_r
+
+ call countperf(1,11,0.)
+!!
+ call countperf(0,4,0.)
+ call synctime()
+ call countperf(1,4,0.)
+!!
+ call excha(lats_nodes_r,global_lats_r,ptotj,pwatj,ptotg,pwatg)
+ sumwa = 0.
+ sumto = 0.
+ do lat=1,latr
+ sumto = sumto + wgt_r(min(lat,latr-lat+1))*ptotg(lat)
+ sumwa = sumwa + wgt_r(min(lat,latr-lat+1))*pwatg(lat)
+! print *,' kdt=',kdt,' lat=',lat,' sumwa=',sumwa,' sumto=',sumto,
+! &' ptotg=',ptotg(lat),' pwatg=',pwatg(lat)
+ enddo
+cjfe
+cjfe write(70+me,*) sumto,sumwa,kdt
+ pdryg = sumto - sumwa
+!!
+ if(pdryini == 0.) pdryini = pdryg
+
+ if( gen_coord_hybrid ) then ! hmhj
+ pcorr = (pdryini-pdryg) * sqrt(2.) ! hmhj
+ else ! hmhj
+ pcorr = (pdryini-pdryg) / sumto * sqrt(2.)
+ endif ! hmhj
+!!
+! call f_hpmstart(53,"gb lats2ls")
+cc
+cc
+ call countperf(0,1,0.)
+cc
+! call f_hpmstop(53)
+!!
+! call f_hpmstart(54,"gb fl2eov")
+! call f_hpmstop(54)
+!
+ call f_hpmstart(52,"gb four2fln")
+!
+ call four2fln_gg(lats_dim_r,lota,3*levs+1,bak_gr_r_1,
+ x ls_nodes,max_ls_nodes,
+!mjr x lats_nodes_r,global_lats_r,lon_dims_r,
+ x lats_nodes_r,global_lats_r,lon_dim_r,
+ x lats_node_r,ipt_lats_node_r,
+ x lat1s_r,lonrx,latr,latr2,
+ x trie_ls(1,1,p_ze), trio_ls(1,1,p_ze),
+ x plnew_r, plnow_r,
+ x ls_node,0,
+ x 2*levs+1,3*levs+1)
+
+ sum_k_rqchange_ls(:,:) = trie_ls(:,:,p_q)
+ sum_k_rqchango_ls(:,:) = trio_ls(:,:,p_q)
+
+ trie_ls(:,:,p_q) = save_qe_ls(:,:)
+ trio_ls(:,:,p_q) = save_qo_ls(:,:)
+cc
+ if (.not. gg_tracers .or.lsout ) then
+ call four2fln_gg(lats_dim_r,lota,levh,bak_gr_r_1,
+ x ls_nodes,max_ls_nodes,
+!mjr x lats_nodes_r,global_lats_r,lon_dims_r,
+ x lats_nodes_r,global_lats_r,lon_dim_r,
+ x lats_node_r,ipt_lats_node_r,
+ x lat1s_r,lonrx,latr,latr2,
+ x trie_ls(1,1,p_rq), trio_ls(1,1,p_rq),
+ x plnew_r, plnow_r,
+ x ls_node,3*levs+1,
+ x 1,levh)
+ endif
+!
+ call f_hpmstop(52)
+!
+ call f_hpmstart(55,"gb uveodz uvoedz")
+!
+!$OMP parallel do shared(trie_ls,trio_ls)
+!$OMP+shared(epse,epso,ls_node)
+!$OMP+private(k)
+ do k=1,levs
+ call uveodz(trie_ls(1,1,p_ze +k-1), trio_ls(1,1,p_di +k-1),
+ x trie_ls(1,1,p_uln+k-1), trio_ls(1,1,p_vln+k-1),
+ x epse,epso,ls_node)
+cc
+ call uvoedz(trio_ls(1,1,p_ze +k-1), trie_ls(1,1,p_di +k-1),
+ x trio_ls(1,1,p_uln+k-1), trie_ls(1,1,p_vln+k-1),
+ x epse,epso,ls_node)
+ enddo
+ call f_hpmstop(55)
+!
+!.............................................................
+ do k=1,levs
+ ktem = p_w + k - 1
+ jtem = p_vln + k - 1
+ do i=1,len_trie_ls
+ trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + bfilte(i)*
+ & (trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
+
+ trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + bfilte(i)*
+ & (trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
+ enddo
+ do i=1,len_trio_ls
+ trio_ls(i,1,ktem) = trio_ls(i,1,ktem) + bfilto(i)*
+ & (trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
+
+ trio_ls(i,2,ktem) = trio_ls(i,2,ktem) + bfilto(i)*
+ & (trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
+ enddo
+ enddo
+cc.............................................................
+ if(.not.gg_tracers)then
+ do k=1,levs
+ ktem = p_rt + k - 1
+ jtem = p_rq + k - 1
+ do i=1,len_trie_ls
+ tem = bfilte(i)*(trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
+ trie_ls_rqt(i,1,k) = tem
+ trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + tem
+!
+ tem = bfilte(i)*(trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
+ trie_ls_rqt(i,2,k) = tem
+ trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + tem
+ enddo
+!!
+ do i=1,len_trio_ls
+ tem = bfilto(i)*(trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
+ trio_ls_rqt(i,1,k) = tem
+ trio_ls(i,1,ktem) = trio_ls(i,1,ktem) + tem
+!
+ tem = bfilto(i)*(trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
+ trio_ls_rqt(i,2,k) = tem
+ trio_ls(i,2,p_rt+k-1) = trio_ls(i,2,ktem) + tem
+ enddo
+ enddo
+!
+!!.............................................................
+!
+ do nt=2,ntrac
+ do k=levs*(nt-2)+1,levs*(nt-1)
+ ktem = p_rt + levs + k - 1
+ jtem = p_rq + levs + k - 1
+ do i=1,len_trie_ls
+ trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + bfilte(i)*
+ & (trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
+ trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + bfilte(i)*
+ & (trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
+ enddo
+ do i=1,len_trio_ls
+ trio_ls(i,1,ktem) = trio_ls(i,1,ktem) + bfilto(i)*
+ & (trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
+ trio_ls(i,2,ktem) = trio_ls(i,2,ktem) + bfilto(i)*
+ & (trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
+ enddo
+ enddo
+ enddo
+ endif ! if(.not.gg_tracers)
+!!
+!----------------------------------------------------------------------
+!!
+ if(hybrid)then
+
+! get some sigma distribution and compute typdel from it.
+
+ typical_pgr=85.
+!sela si(k)=(ak5(k)+bk5(k)*typical_pgr)/typical_pgr !ak(k) bk(k) go top to botto
+ do k=1,levp1
+ si(levs+2-k) = ak5(k)/typical_pgr + bk5(k)
+ enddo
+ endif
+
+ DO k=1,LEVS
+ typDEL(k)= SI(k)-SI(k+1)
+ ENDDO
+
+!----------------------------------------------------------------------
+
+ if (ladj) then
+ trie_ls(:,:,p_zq) = 0.
+ trio_ls(:,:,p_zq) = 0.
+ if (me == me_l_0) then
+ trie_ls(1,1,p_zq) = pcorr
+ endif
+!!
+ if( gen_coord_hybrid ) then ! hmhj
+ trie_ls_sfc = 0.0 ! hmhj
+ trio_ls_sfc = 0.0 ! hmhj
+ do k=1,levs ! hmhj
+ do i=1,len_trie_ls ! hmhj
+ trie_ls_sfc(i,1) = trie_ls_sfc(i,1)
+ & + typdel(k)*trie_ls_rqt(i,1,k) ! hmhj
+ trie_ls_sfc(i,2) = trie_ls_sfc(i,2)
+ & + typdel(k)*trie_ls_rqt(i,2,k) ! hmhj
+ enddo ! hmhj
+ do i=1,len_trio_ls ! hmhj
+ trio_ls_sfc(i,1) = trio_ls_sfc(i,1)
+ & + typdel(k)*trio_ls_rqt(i,1,k) ! hmhj
+ trio_ls_sfc(i,2) = trio_ls_sfc(i,2)
+ & + typdel(k)*trio_ls_rqt(i,2,k) ! hmhj
+ enddo ! hmhj
+ enddo ! hmhj
+
+ do i=1,len_trie_ls ! hmhj
+ trie_ls(i,1,p_zq) = trie_ls(i,1,p_zq) ! hmhj
+ & + trie_ls(i,1,p_q )*trie_ls_sfc(i,1) ! hmhj
+ trie_ls(i,2,p_zq) = trie_ls(i,2,p_zq) ! hmhj
+ & + trie_ls(i,2,p_q )*trie_ls_sfc(i,2) ! hmhj
+ enddo
+ do i=1,len_trio_ls ! hmhj
+ trio_ls(i,1,p_zq) = trio_ls(i,1,p_zq) ! hmhj
+ & + trio_ls(i,1,p_q )*trio_ls_sfc(i,1) ! hmhj
+ trio_ls(i,2,p_zq) = trio_ls(i,2,p_zq) ! hmhj
+ & + trio_ls(i,2,p_q )*trio_ls_sfc(i,2) ! hmhj
+ enddo
+
+ else ! For hybrid or sigma coordinate
+
+ if(gg_tracers)then
+ do i=1,len_trie_ls
+ trie_ls(i,1,p_zq) = trie_ls(i,1,p_zq)
+ & + sum_k_rqchange_ls(i,1)
+ trie_ls(i,2,p_zq) = trie_ls(i,2,p_zq)
+ & + sum_k_rqchange_ls(i,2)
+ enddo
+ do i=1,len_trio_ls
+ trio_ls(i,1,p_zq) = trio_ls(i,1,p_zq)
+ & + sum_k_rqchango_ls(i,1)
+ trio_ls(i,2,p_zq) = trio_ls(i,2,p_zq)
+ & + sum_k_rqchango_ls(i,2)
+ enddo
+ else
+ do k=1,levs
+ do i=1,len_trie_ls
+ trie_ls(i,1,p_zq) = trie_ls(i,1,p_zq)
+ & + typdel(k)*trie_ls_rqt(i,1,k)
+ trie_ls(i,2,p_zq) = trie_ls(i,2,p_zq)
+ & + typdel(k)*trie_ls_rqt(i,2,k)
+ enddo
+ do i=1,len_trio_ls
+ trio_ls(i,1,p_zq) = trio_ls(i,1,p_zq)
+ & + typdel(k)*trio_ls_rqt(i,1,k)
+ trio_ls(i,2,p_zq) = trio_ls(i,2,p_zq)
+ & + typdel(k)*trio_ls_rqt(i,2,k)
+ enddo
+ enddo
+ endif !fin if(gg_tracers)
+
+ endif !fin if (gen_coord_hybrid) ! hmhj
+!!
+ do k=1,levs
+ item = p_di+k-1
+ jtem = p_uln+k-1
+ ktem = p_x+k-1
+ ltem = p_te+k-1
+ mtem = p_y+k-1
+
+ do i=1,len_trie_ls
+ trie_ls(i,1,item) = bfilte(i)
+ & * (trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
+ trie_ls(i,1,ltem) = bfilte(i)
+ & * (trie_ls(i,1,ltem)-trie_ls(i,1,mtem))
+ trie_ls(i,2,item) = bfilte(i)
+ & * (trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
+ trie_ls(i,2,ltem) = bfilte(i)
+ & * (trie_ls(i,2,ltem)-trie_ls(i,2,mtem))
+ enddo
+ do i=1,len_trio_ls
+ trio_ls(i,1,item) = bfilto(i)
+ & * (trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
+ trio_ls(i,1,ltem) = bfilto(i)
+ & * (trio_ls(i,1,ltem)-trio_ls(i,1,mtem))
+ trio_ls(i,2,item) = bfilto(i)
+ & * (trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
+ trio_ls(i,2,ltem) = bfilto(i)
+ & * (trio_ls(i,2,ltem)-trio_ls(i,2,mtem))
+ enddo
+ enddo
+
+!---------------------------------------------------------
+ if( gen_coord_hybrid ) then ! hmhj
+
+!$OMP parallel do private(locl)
+ do locl=1,ls_max_node ! hmhj
+
+ call impadje_hyb_gc(trie_ls(1,1,p_x),trie_ls(1,1,p_y), ! hmhj
+ & trie_ls(1,1,p_q),trie_ls(1,1,p_di), ! hmhj
+ & trie_ls(1,1,p_te),trie_ls(1,1,p_zq), ! hmhj
+ & tstep, ! hmhj
+ & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln), ! hmhj
+ & snnp1ev,ndexev,ls_node,locl) ! hmhj
+!!
+ call impadjo_hyb_gc(trio_ls(1,1,p_x),trio_ls(1,1,p_y), ! hmhj
+ & trio_ls(1,1,p_q),trio_ls(1,1,p_di), ! hmhj
+ & trio_ls(1,1,p_te),trio_ls(1,1,p_zq), ! hmhj
+ & tstep, ! hmhj
+ & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln), ! hmhj
+ & snnp1od,ndexod,ls_node,locl) ! hmhj
+ enddo ! hmhj
+ elseif(hybrid) then ! for sigma/p hybrid coordinate ! hmhj
+ if (.not. semilag) then ! for Eulerian hybrid case
+
+
+!$OMP parallel do private(locl)
+ do locl=1,ls_max_node
+ call impadje_hyb(trie_ls(1,1,p_x),trie_ls(1,1,p_y),
+ & trie_ls(1,1,p_q),trie_ls(1,1,p_di),
+ & trie_ls(1,1,p_te),trie_ls(1,1,p_zq),
+ & tstep,
+ & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln),
+ & snnp1ev,ndexev,ls_node,locl)
+!!
+ call impadjo_hyb(trio_ls(1,1,p_x),trio_ls(1,1,p_y),
+ & trio_ls(1,1,p_q),trio_ls(1,1,p_di),
+ & trio_ls(1,1,p_te),trio_ls(1,1,p_zq),
+ & tstep,
+ & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln),
+ & snnp1od,ndexod,ls_node,locl)
+ enddo
+ else ! for semi-Lagrangian hybrid case
+!$OMP parallel do private(locl)
+ do locl=1,ls_max_node
+
+
+ call impadje_slg(trie_ls(1,1,p_x),trie_ls(1,1,p_y),
+ & trie_ls(1,1,p_q),trie_ls(1,1,p_di),
+ & trie_ls(1,1,p_te),trie_ls(1,1,p_zq),
+ & tstep,
+ & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln),
+ & snnp1ev,ndexev,ls_node,locl,batah)
+!!
+ call impadjo_slg(trio_ls(1,1,p_x),trio_ls(1,1,p_y),
+ & trio_ls(1,1,p_q),trio_ls(1,1,p_di),
+ & trio_ls(1,1,p_te),trio_ls(1,1,p_zq),
+ & tstep,
+ & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln),
+ & snnp1od,ndexod,ls_node,locl,batah)
+ enddo
+ endif
+
+ else ! massadj in sigma coordinate
+
+ call countperf(0,9,0.)
+!$OMP parallel do private(locl)
+ do locl=1,ls_max_node
+ call impadje(trie_ls(1,1,p_x),trie_ls(1,1,p_y),
+ & trie_ls(1,1,p_q),trie_ls(1,1,p_di),
+ & trie_ls(1,1,p_te),trie_ls(1,1,p_zq),
+ & am,bm,sv,tstep,
+ & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln),
+ & snnp1ev,ndexev,ls_node,locl)
+!!
+ call impadjo(trio_ls(1,1,p_x),trio_ls(1,1,p_y),
+ & trio_ls(1,1,p_q),trio_ls(1,1,p_di),
+ & trio_ls(1,1,p_te),trio_ls(1,1,p_zq),
+ & am,bm,sv,tstep,
+ & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln),
+ & snnp1od,ndexod,ls_node,locl)
+ enddo
+
+ call countperf(1,9,0.)
+
+ endif ! fin massadj in sigma
+!---------------------------------------------------------
+
+ else ! fin massadj, following is with no masadj
+ DO k=1,LEVS
+ del(k) = typDEL(k) ! sela 4.5.07
+ ENDDO
+ if (me == me_l_0) then
+ trie_ls(1,1,p_q) = trie_ls(1,1,p_q) + pcorr
+ endif
+!
+! testing mass correction on sep 25
+!!
+ if(gg_tracers)then
+ do i=1,len_trie_ls
+ trie_ls(i,1,p_q) = trie_ls(i,1,p_q) + sum_k_rqchange_ls(i,1)
+ trie_ls(i,2,p_q) = trie_ls(i,2,p_q) + sum_k_rqchange_ls(i,2)
+ enddo
+ do i=1,len_trio_ls
+ trio_ls(i,1,p_q) = trio_ls(i,1,p_q) + sum_k_rqchango_ls(i,1)
+ trio_ls(i,2,p_q) = trio_ls(i,2,p_q) + sum_k_rqchango_ls(i,2)
+ enddo
+ else
+ do k=1,levs
+ do i=1,len_trie_ls
+ trie_ls(i,1,p_q)=trie_ls(i,1,p_q)+del(k)*trie_ls_rqt(i,1,k)
+ trie_ls(i,2,p_q)=trie_ls(i,2,p_q)+del(k)*trie_ls_rqt(i,2,k)
+ enddo
+ do i=1,len_trio_ls
+ trio_ls(i,1,p_q)=trio_ls(i,1,p_q)+del(k)*trio_ls_rqt(i,1,k)
+ trio_ls(i,2,p_q)=trio_ls(i,2,p_q)+del(k)*trio_ls_rqt(i,2,k)
+ enddo
+ enddo
+ endif
+!
+! testing mass correction on sep 25
+!
+ do k=1,levs
+ item = p_di+k-1
+ jtem = p_uln+k-1
+ ktem = p_x+k-1
+ ltem = p_te+k-1
+ mtem = p_y+k-1
+ do i=1,len_trie_ls
+ trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + bfilte(i)
+ & *(trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
+ trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + bfilte(i)
+ & *(trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
+ trie_ls(i,1,mtem) = trie_ls(i,1,mtem) + bfilte(i)
+ & *(trie_ls(i,1,ltem)-trie_ls(i,1,mtem))
+ trie_ls(i,2,mtem) = trie_ls(i,2,mtem) + bfilte(i)
+ & *(trie_ls(i,2,ltem)-trie_ls(i,2,mtem))
+ enddo
+
+ do i=1,len_trio_ls
+ trio_ls(i,1,ktem) = trio_ls(i,1,ktem)+bfilto(i)
+ & *(trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
+ trio_ls(i,2,ktem) = trio_ls(i,2,ktem) + bfilto(i)
+ & *(trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
+ trio_ls(i,1,mtem) = trio_ls(i,1,mtem) + bfilto(i)
+ & *(trio_ls(i,1,ltem)-trio_ls(i,1,mtem))
+ trio_ls(i,2,mtem) = trio_ls(i,2,mtem) + bfilto(i)
+ & *(trio_ls(i,2,ltem)-trio_ls(i,2,mtem))
+ enddo
+ enddo
+ endif ! fin no ladj (i.e. no massadj)
+!!
+ return
+ end
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/gloopr.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/gloopr.f_gfs (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/gloopr.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,1163 @@
+ subroutine gloopr
+ x (trie_ls,trio_ls,
+ x ls_node,ls_nodes,max_ls_nodes,
+ x lats_nodes_a,global_lats_a,
+ x lats_nodes_r,global_lats_r,
+ x lonsperlar,
+ x epse,epso,epsedn,epsodn,
+ x snnp1ev,snnp1od, plnev_r,plnod_r,
+ x pddev_r,pddod_r,
+! x snnp1ev,snnp1od,ndexev,ndexod,
+! x plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r,
+ x phour,
+ & xlon,xlat,coszdg,COSZEN,
+ & SLMSK,SHELEG,SNCOVR,SNOALB,ZORL,TSEA,HPRIME,
+!lu [+1L]: extract snow-free albedo (SFALB)
+ + SFALB,
+ & ALVSF,ALNSF ,ALVWF ,ALNWF,FACSF ,FACWF,CV,CVT ,
+ & CVB ,SWH,HLW,SFCNSW,SFCDLW,
+ & FICE ,TISFC, SFCDSW, sfcemis, ! FOR SEA-ICE - XW Nov04
+ & TSFLW,FLUXR , phy_f3d,slag,sdec,cdec,KDT,
+ & global_times_r)
+!!
+#include "f_hpm.h"
+!
+ USE MACHINE , ONLY : kind_phys
+ USE FUNCPHYS , ONLY : fpkap
+ USE PHYSCONS, FV => con_fvirt, rerth => con_rerth ! hmhj
+
+ use module_radiation_driver, only : radinit, grrad
+ use module_radiation_astronomy,only : astronomy
+!
+!! --- for optional spectral band heating outputs
+!! use module_radsw_parameters, only : NBDSW
+!! use module_radlw_parameters, only : NBDLW
+!
+ use resol_def
+ use layout1
+ use layout_grid_tracers
+ use gg_def
+ use vert_def
+ use date_def
+ use namelist_def
+ use coordinate_def ! hmhj
+ use tracer_const ! hmhj
+ use d3d_def , only : cldcov
+ use mersenne_twister, only : random_setseed, random_index, &
+ & random_stat
+!
+ implicit none
+ include 'mpif.h'
+!
+ real (kind=kind_phys), parameter :: QMIN =1.0e-10
+ real (kind=kind_evod), parameter :: Typical_pgr = 95.0
+ real (kind=kind_evod), parameter :: cons0 = 0.0, cons2 = 2.0
+!
+! --- ... inputs:
+ integer, intent(in) :: ls_node(LS_DIM,3), ls_nodes(LS_DIM,NODES), &
+ & max_ls_nodes(NODES), lats_nodes_r(NODES), &
+ & global_lats_r(LATR), lonsperlar(LATR)
+
+ integer, intent(in) :: lats_nodes_a(nodes), global_lats_a(latg)
+
+
+ real(kind=kind_evod), dimension(LEN_TRIE_LS), intent(in) :: &
+ & epse, epsedn, snnp1ev
+
+ real(kind=kind_evod), dimension(LEN_TRIO_LS), intent(in) :: &
+ & epso, epsodn, snnp1od
+
+ real(kind=kind_evod), intent(in) :: plnev_r(LEN_TRIE_LS, LATR2)
+ real(kind=kind_evod), intent(in) :: plnod_r(LEN_TRIO_LS, LATR2)
+
+ real (kind=kind_phys), dimension(LONR,LATS_NODE_R), intent(in) :: &
+ & xlon, xlat, slmsk, sheleg, zorl, tsea, &
+ & alvsf, alnsf, alvwf, alnwf, facsf, facwf, &
+ & cv, cvt, cvb, FICE, tisfc, sncovr, snoalb
+
+ real (kind=kind_phys), intent(in) :: &
+ & hprime(LONR,NMTVR,LATS_NODE_R), phour, &
+ & phy_f3d(LONR,LEVS,NUM_P3D,LATS_NODE_R)
+!
+! --- ... input and output:
+ real(kind=kind_evod), intent(inout) :: &
+ & trie_ls(LEN_TRIE_LS,2,11*LEVS+3*LEVH+6), &
+ & trio_ls(LEN_TRIO_LS,2,11*LEVS+3*LEVH+6)
+ integer ipt_ls ! hmhj
+ real(kind=kind_evod) reall ! hmhj
+ real(kind=kind_evod) rlcs2(jcap1) ! hmhj
+
+
+ real (kind=kind_phys), intent(inout) :: &
+ & fluxr (LONR,NFXR,LATS_NODE_R)
+
+! --- ... inputs but not used anymore:
+ real(kind=kind_evod), intent(in) :: pddev_r(LEN_TRIE_LS,LATR2), &
+ & pddod_r(LEN_TRIO_LS,LATR2) &
+! & plnew_r(LEN_TRIE_LS,LATR2), &
+! & plnow_r(LEN_TRIO_LS,LATR2)
+! & syn_ls_r(4*LS_DIM,LOTS,LATR2)
+
+! integer, intent(in) :: ndexev(LEN_TRIE_LS), ndexod(LEN_TRIO_LS)
+ integer, intent(in) :: KDT
+! --- ... outputs:
+ real(kind=kind_evod), intent(inout) :: &
+ & global_times_r(LATR,NODES)
+ real(kind=kind_evod) :: &
+ & for_gr_r_1(LONRX,LOTS,LATS_DIM_R), &
+ & dyn_gr_r_1(lonrx,lotd,lats_dim_r), ! hmhj
+!mjr & for_gr_r_2(LONRX,LOTS,LATS_DIM_R),
+ & for_gr_r_2(LONR ,LOTS,LATS_DIM_R),
+!mjr & dyn_gr_r_2(lonrx,lotd,lats_dim_r) ! hmhj
+ & dyn_gr_r_2(lonr ,lotd,lats_dim_r) ! hmhj
+
+ real (kind=kind_phys), intent(out) :: &
+ & swh(LONR,LEVS,LATS_NODE_R), &
+ & hlw(LONR,LEVS,LATS_NODE_R)
+
+ real (kind=kind_phys),dimension(LONR,LATS_NODE_R), intent(out) :: &
+ & coszdg, coszen, sfcnsw, sfcdlw, tsflw, &
+ & sfcdsw, SFALB, sfcemis
+
+ real (kind=kind_phys), intent(out) :: slag, sdec, cdec
+
+!! --- ... optional spectral band heating rates
+!! real (kind=kind_phys), optional, intent(out) :: &
+!! & htrswb(NGPTC,LEVS,NBDSW,NBLCK,LATS_NODE_R), &
+!! & htrlwb(NGPTC,LEVS,NBDLW,NBLCK,LATS_NODE_R)
+
+! --- ... locals:
+! real(kind=kind_phys) :: prsl(NGPTC,LEVS), prdel(NGPTC,LEVS), &
+ real(kind=kind_phys) :: prsl(NGPTC,LEVS), prslk(NGPTC,LEVS), &
+ & prsi(NGPTC,LEVP1), prsik(NGPTC,LEVP1), &
+ & hlw_v(NGPTC,LEVS), swh_v(NGPTC,LEVS)
+
+ real (kind=kind_phys) :: si_loc(LEVR+1)
+
+ real (kind=kind_phys) :: &
+! & gu(NGPTC,LEVS), gv1(NGPTC,LEVS), &
+! & gt(NGPTC,LEVR), gd (NGPTC,LEVS), &
+ & gt(NGPTC,LEVR), gq(NGPTC), &
+ & gr(NGPTC,LEVR), gr1(NGPTC,LEVR,NTRAC-1), &
+! & gphi(NGPTC), glam(NGPTC), gq(NGPTC), &
+ & gtv(NGPTC,LEVR)
+! & sumq(NGPTC,LEVR), xcp(NGPTC,LEVR), &! hmhj
+! & gtv(NGPTC,LEVR), gtvx(NGPTC,LEVR), &! hmhj
+! & gtvy(NGPTC,LEVR) ! hmhj
+! &, vvel(ngptc,levs)
+
+ real (kind=kind_phys), allocatable :: sumq(:,:), xcp(:,:), &
+ & gtvx(:,:), gtvy(:,:), &
+! & gd(:,:), &
+ & vvel(:,:), gd(:,:), &
+ & gu(:,:), gv1(:,:), &
+ & gphi(:), glam(:)
+
+ real (kind=kind_phys) :: f_ice(NGPTC,LEVS), f_rain(NGPTC,LEVS), &
+ & r_rime(NGPTC,LEVS)
+
+ real (kind=kind_phys) :: cldcov_v(NGPTC,LEVS), fluxr_v(NGPTC,NFXR)
+ real (kind=kind_phys) :: flgmin_v(ngptc), work1, work2
+
+ real (kind=kind_phys) :: rinc(5), dtsw, dtlw, solcon, raddt
+
+ real (kind=kind_phys), save :: facoz
+
+! integer :: njeff, lon, lan, lat, iblk, lon_dim, lons_lat, istrt
+ integer :: njeff, lon, lan, lat, lons_lat
+ integer :: idat(8), jdat(8), DAYS(13), iday, imon, midmon, id
+ integer :: lmax
+
+! --- variables used for random number generator (thread safe mode)
+ type (random_stat) :: stat
+ integer :: numrdm(LONR*LATR*2), ixseed(LONR,LATS_NODE_R,2)
+ integer :: ipseed, icsdlw(NGPTC), icsdsw(NGPTC)
+ integer, parameter :: ipsdlim = 1.0e8 ! upper limit for random seeds
+
+ integer, save :: icwp, k1oz, k2oz, midm, midp, ipsd0
+
+! --- number of days in a month
+ data DAYS / 31,28,31,30,31,30,31,31,30,31,30,31,30 /
+
+! --- ... control parameters:
+! (some of the them may be moved into model namelist)
+
+! --- ICTM=yyyy#, controls time sensitive external data (e.g. CO2, solcon, aerosols, etc)
+! integer, parameter :: ICTM = -2 ! same as ICTM=0, but add seasonal cycle from
+! ! climatology. no extrapolation.
+! integer, parameter :: ICTM = -1 ! use user provided external data set for the
+! ! forecast time. no extrapolation.
+! integer, parameter :: ICTM = 0 ! use data at initial cond time, if not
+! ! available, use latest, no extrapolation.
+!! integer, parameter :: ICTM = 1 ! use data at the forecast time, if not
+! ! available, use latest and extrapolation.
+! integer, parameter :: ICTM =yyyy0 ! use yyyy data for the forecast time,
+! ! no further data extrapolation.
+! integer, parameter :: ICTM =yyyy1 ! use yyyy data for the fcst. if needed, do
+! ! extrapolation to match the fcst time.
+
+! --- ISOL controls solar constant data source
+!! integer, parameter :: ISOL = 0 ! use prescribed solar constant
+! integer, parameter :: ISOL = 1 ! use varying solar const with 11-yr cycle
+
+! --- ICO2 controls co2 data source for radiation
+! integer, parameter :: ICO2 = 0 ! prescribed global mean value (old opernl)
+!! integer, parameter :: ICO2 = 1 ! use obs co2 annual mean value only
+! integer, parameter :: ICO2 = 2 ! use obs co2 monthly data with 2-d variation
+
+! --- IALB controls surface albedo for sw radiation
+!! integer, parameter :: IALB = 0 ! use climatology alb, based on sfc type
+! integer, parameter :: IALB = 1 ! use modis derived alb (to be developed)
+
+! --- IEMS controls surface emissivity and sfc air/ground temp for lw radiation
+! ab: 2-digit control flags. a-for sfc temperature; b-for emissivity
+!! integer, parameter :: IEMS = 00 ! same air/ground temp; fixed emis = 1.0
+!! integer, parameter :: IEMS = 01 ! same air/ground temp; varying veg typ based emis
+!! integer, parameter :: IEMS = 10 ! diff air/ground temp; fixed emis = 1.0
+!! integer, parameter :: IEMS = 11 ! diff air/ground temp; varying veg typ based emis
+
+! --- IAER controls aerosols scheme selections
+! Old definition
+! integer, parameter :: IAER = 1 ! opac climatology, without volc forcing
+! integer, parameter :: IAER =11 ! opac climatology, with volcanic forcing
+! integer, parameter :: IAER = 2 ! gocart prognostic, without volc forcing
+! integer, parameter :: IAER =12 ! gocart prognostic, with volcanic forcing
+! New definition in this code IAER = abc (a:volcanic; b:lw; c:sw)
+! b, c values: (0:none; 1:opac; 2:gocart)
+! IAER = 0 --> no aerosol effect at all (volc, sw, lw)
+! = 1 --> only tropospheric sw aerosols, no trop-lw and volc
+! = 10 --> only tropospheric lw aerosols, no trop-sw and volc
+! = 11 --> both trop-sw and trop-lw aerosols, no volc
+! = 100 --> only strato-volc aeros, no trop-sw and trop-lw
+! = 101 --> only sw aeros (trop + volc), no lw aeros
+! = 110 --> only lw aeros (trop + volc), no sw aeros
+! = 111 --> both sw and lw aeros (trop + volc)
+!
+
+! --- IOVR controls cloud overlapping method in radiation:
+! integer, parameter :: IOVR_SW = 0 ! sw: random overlap clouds
+!! integer, parameter :: IOVR_SW = 1 ! sw: max-random overlap clouds
+
+! integer, parameter :: IOVR_LW = 0 ! lw: random overlap clouds
+!! integer, parameter :: IOVR_LW = 1 ! lw: max-random overlap clouds
+
+! --- ISUBC controls sub-column cloud approximation in radiation:
+! integer, parameter :: ISUBC_SW = 0 ! sw: without sub-col clds approx
+! integer, parameter :: ISUBC_SW = 1 ! sw: sub-col clds with prescribed seeds
+! integer, parameter :: ISUBC_SW = 2 ! sw: sub-col clds with random seeds
+
+! integer, parameter :: ISUBC_LW = 0 ! lw: without sub-col clds approx
+! integer, parameter :: ISUBC_LW = 1 ! lw: sub-col clds with prescribed seeds
+! integer, parameter :: ISUBC_LW = 2 ! lw: sub-col clds with random seeds
+
+! --- iflip indicates model vertical index direction:
+! integer, parameter :: IFLIP = 0 ! virtical profile index from top to bottom
+ integer, parameter :: IFLIP = 1 ! virtical profile index from bottom to top
+!
+! The following parameters are from gbphys
+!
+ real (kind=kind_phys), parameter :: dxmax=-16.118095651, &
+ & dxmin=-9.800790154, dxinv=1.0/(dxmax-dxmin)
+
+ integer :: kr, kt, kd, kq, ku, kv, ierr, dimg, kx, ky
+ integer :: i, j, k, n
+ integer :: kdtphi,kdtlam,ks ! hmhj
+
+ logical :: change
+ logical, save :: first, sas_shal
+ data first / .true. /
+!
+! --- for debug test use
+ real (kind=kind_phys) :: temlon, temlat, alon, alat
+ integer :: ipt
+ logical :: lprnt
+
+! --- timers:
+ real*8 :: rtc, timer1, timer2
+!
+!===> *** ... begin here
+!
+!!
+!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L
+!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
+!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
+!!
+!$$$ integer lots,lotd,lota
+!$$$cc
+!$$$ parameter ( lots = 5*levs+1*levh+3 )
+!$$$ parameter ( lotd = 6*levs+2*levh+0 )
+!$$$ parameter ( lota = 3*levs+1*levh+1 )
+!!
+!!
+ integer kap,kar,kat,kau,kav,kdrlam
+ integer ksd,ksplam,kspphi,ksq,ksr,kst
+ integer ksu,ksv,ksz,node,item,jtem
+!!
+! real(kind=kind_evod) spdlat(levs,lats_dim_r)
+!Moor real(kind=kind_phys) slk(levs)
+! real(kind=kind_evod) spdmax_node (levs)
+! real(kind=kind_evod) spdmax_nodes(levs,nodes)
+!!
+!!
+!!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
+!!
+!!
+!!................................................................
+!! syn(1, 0*levs+0*levh+1, lan) ze
+!! syn(1, 1*levs+0*levh+1, lan) di
+!! syn(1, 2*levs+0*levh+1, lan) te
+!! syn(1, 3*levs+0*levh+1, lan) rq
+!! syn(1, 3*levs+1*levh+1, lan) q
+!! syn(1, 3*levs+1*levh+2, lan) dpdlam
+!! syn(1, 3*levs+1*levh+3, lan) dpdphi
+!! syn(1, 3*levs+1*levh+4, lan) uln
+!! syn(1, 4*levs+1*levh+4, lan) vln
+!!................................................................
+!! dyn(1, 0*levs+0*levh+1, lan) d(t)/d(phi)
+!! dyn(1, 1*levs+0*levh+1, lan) d(rq)/d(phi)
+!! dyn(1, 1*levs+1*levh+1, lan) d(t)/d(lam)
+!! dyn(1, 2*levs+1*levh+1, lan) d(rq)/d(lam)
+!! dyn(1, 2*levs+2*levh+1, lan) d(u)/d(lam)
+!! dyn(1, 3*levs+2*levh+1, lan) d(v)/d(lam)
+!! dyn(1, 4*levs+2*levh+1, lan) d(u)/d(phi)
+!! dyn(1, 5*levs+2*levh+1, lan) d(v)/d(phi)
+!!................................................................
+!! anl(1, 0*levs+0*levh+1, lan) w dudt
+!! anl(1, 1*levs+0*levh+1, lan) x dvdt
+!! anl(1, 2*levs+0*levh+1, lan) y dtdt
+!! anl(1, 3*levs+0*levh+1, lan) rt drdt
+!! anl(1, 3*levs+1*levh+1, lan) z dqdt
+!!................................................................
+!!
+!!
+!$$$ parameter(ksz =0*levs+0*levh+1,
+!$$$ x ksd =1*levs+0*levh+1,
+!$$$ x kst =2*levs+0*levh+1,
+!$$$ x ksr =3*levs+0*levh+1,
+!$$$ x ksq =3*levs+1*levh+1,
+!$$$ x ksplam =3*levs+1*levh+2,
+!$$$ x kspphi =3*levs+1*levh+3,
+!$$$ x ksu =3*levs+1*levh+4,
+!$$$ x ksv =4*levs+1*levh+4)
+!!
+!$$$ parameter(kdtphi =0*levs+0*levh+1,
+!$$$ x kdrphi =1*levs+0*levh+1,
+!$$$ x kdtlam =1*levs+1*levh+1,
+!$$$ x kdrlam =2*levs+1*levh+1,
+!$$$ x kdulam =2*levs+2*levh+1,
+!$$$ x kdvlam =3*levs+2*levh+1,
+!$$$ x kduphi =4*levs+2*levh+1,
+!$$$ x kdvphi =5*levs+2*levh+1)
+!!
+!$$$ parameter(kau =0*levs+0*levh+1,
+!$$$ x kav =1*levs+0*levh+1,
+!$$$ x kat =2*levs+0*levh+1,
+!$$$ x kar =3*levs+0*levh+1,
+!$$$ x kap =3*levs+1*levh+1)
+!!
+!!
+!$$$ integer P_gz,P_zem,P_dim,P_tem,P_rm,P_qm
+!$$$ integer P_ze,P_di,P_te,P_rq,P_q,P_dlam,P_dphi,P_uln,P_vln
+!$$$ integer P_w,P_x,P_y,P_rt,P_zq
+!$$$cc
+!$$$cc old common /comfspec/
+!$$$ parameter(P_gz = 0*levs+0*levh+1, ! gze/o(lnte/od,2),
+!$$$ x P_zem = 0*levs+0*levh+2, ! zeme/o(lnte/od,2,levs),
+!$$$ x P_dim = 1*levs+0*levh+2, ! dime/o(lnte/od,2,levs),
+!$$$ x P_tem = 2*levs+0*levh+2, ! teme/o(lnte/od,2,levs),
+!$$$ x P_rm = 3*levs+0*levh+2, ! rme/o(lnte/od,2,levh),
+!$$$ x P_qm = 3*levs+1*levh+2, ! qme/o(lnte/od,2),
+!$$$ x P_ze = 3*levs+1*levh+3, ! zee/o(lnte/od,2,levs),
+!$$$ x P_di = 4*levs+1*levh+3, ! die/o(lnte/od,2,levs),
+!$$$ x P_te = 5*levs+1*levh+3, ! tee/o(lnte/od,2,levs),
+!$$$ x P_rq = 6*levs+1*levh+3, ! rqe/o(lnte/od,2,levh),
+!$$$ x P_q = 6*levs+2*levh+3, ! qe/o(lnte/od,2),
+!$$$ x P_dlam= 6*levs+2*levh+4, ! dpdlame/o(lnte/od,2),
+!$$$ x P_dphi= 6*levs+2*levh+5, ! dpdphie/o(lnte/od,2),
+!$$$ x P_uln = 6*levs+2*levh+6, ! ulne/o(lnte/od,2,levs),
+!$$$ x P_vln = 7*levs+2*levh+6, ! vlne/o(lnte/od,2,levs),
+!$$$ x P_w = 8*levs+2*levh+6, ! we/o(lnte/od,2,levs),
+!$$$ x P_x = 9*levs+2*levh+6, ! xe/o(lnte/od,2,levs),
+!$$$ x P_y =10*levs+2*levh+6, ! ye/o(lnte/od,2,levs),
+!$$$ x P_rt =11*levs+2*levh+6, ! rte/o(lnte/od,2,levh),
+!$$$ x P_zq =11*levs+3*levh+6) ! zqe/o(lnte/od,2)
+!!
+!!
+! print *,' in gloopr vertcoord_id =',vertcoord_id
+
+!
+ ksz =0*levs+0*levh+1
+ ksd =1*levs+0*levh+1
+ kst =2*levs+0*levh+1
+ ksq =3*levs+0*levh+1
+ ksplam =3*levs+0*levh+2
+ kspphi =3*levs+0*levh+3
+ ksu =3*levs+0*levh+4
+ ksv =4*levs+0*levh+4
+ ksr =5*levs+0*levh+4
+
+ kdtphi =0*levs+0*levh+1 ! hmhj
+ kdtlam =1*levs+1*levh+1 ! hmhj
+!!
+ idat = 0
+ idat(1) = idate(4)
+ idat(2) = idate(2)
+ idat(3) = idate(3)
+ idat(5) = idate(1)
+ rinc = 0.
+ rinc(2) = fhour
+ call w3movdat(rinc, idat, jdat)
+!
+ if (ntoz .le. 0) then ! Climatological Ozone!
+!
+! if(me .eq. 0) WRITE (6,989) jdat(1),jdat(2),jdat(3),jdat(5)
+! 989 FORMAT(' UPDATING OZONE FOR ', I4,I3,I3,I3)
+!
+ IDAY = jdat(3)
+ IMON = jdat(2)
+ MIDMON = DAYS(IMON)/2 + 1
+ CHANGE = FIRST .OR.
+ & ( (IDAY .EQ. MIDMON) .AND. (jdat(5).EQ.0) )
+!
+ IF (CHANGE) THEN
+ IF (IDAY .LT. MIDMON) THEN
+ K1OZ = MOD(IMON+10,12) + 1
+ MIDM = DAYS(K1OZ)/2 + 1
+ K2OZ = IMON
+ MIDP = DAYS(K1OZ) + MIDMON
+ ELSE
+ K1OZ = IMON
+ MIDM = MIDMON
+ K2OZ = MOD(IMON,12) + 1
+ MIDP = DAYS(K2OZ)/2 + 1 + DAYS(K1OZ)
+ ENDIF
+ ENDIF
+!
+ IF (IDAY .LT. MIDMON) THEN
+ ID = IDAY + DAYS(K1OZ)
+ ELSE
+ ID = IDAY
+ ENDIF
+ FACOZ = real (ID-MIDM) / real (MIDP-MIDM)
+ endif
+!
+ if (first) then
+ sas_shal = sashal .and. (.not. ras)
+!
+ if( hybrid.or.gen_coord_hybrid ) then ! hmhj
+
+ if( gen_coord_hybrid ) then ! hmhj
+ si_loc(levr+1) = si(levp1) ! hmhj
+ do k=1,levr ! hmhj
+ si_loc(k) = si(k) ! hmhj
+ enddo ! hmhj
+ else ! hmhj
+! --- get some sigma distribution for radiation-cloud initialization
+!sela si(k)=(ak5(k)+bk5(k)*Typical_pgr)/Typical_pgr !ak(k) bk(k) go top to botto
+ si_loc(levr+1)= ak5(1)/typical_pgr+bk5(1)
+ do k=1,levr
+ si_loc(levr+1-k)= ak5(levp1-levr+k)/typical_pgr
+ & + bk5(levp1-levr+k)
+ enddo
+ endif
+ else
+ do k = 1, levr
+ si_loc(k) = si(k)
+ enddo
+ si_loc(levr+1) = si(levp1)
+ endif ! end_if_hybrid
+
+! --- determin prognostic/diagnostic cloud scheme
+
+ icwp = 0
+ if (NTCW > 0) icwp = 1
+
+ if( thermodyn_id.eq.3 ) then
+ if (.not. allocated(xcp)) allocate (xcp(ngptc,levr))
+ if (.not. allocated(sumq)) allocate (sumq(ngptc,levr))
+ endif
+ if( ntcw <= 0 ) then
+ if( gen_coord_hybrid .and. vertcoord_id == 3.) then
+ if (.not. allocated(gtvx)) allocate (gtvx(ngptc,levs))
+ if (.not. allocated(gtvy)) allocate (gtvy(ngptc,levs))
+ endif
+ if (.not. allocated(gu)) allocate (gu(ngptc,levs))
+ if (.not. allocated(gv1)) allocate (gv1(ngptc,levs))
+ if (.not. allocated(gd)) allocate (gd(ngptc,levs))
+ if (.not. allocated(vvel)) allocate (vvel(ngptc,levs))
+ if (.not. allocated(gphi)) allocate (gphi(ngptc))
+ if (.not. allocated(glam)) allocate (glam(ngptc))
+ endif
+
+! --- generate initial permutation seed for random number generator
+
+ if ( ISUBC_LW==2 .or. ISUBC_SW==2 ) then
+ ipsd0 = 17*idate(1) + 43*idate(2) + 37*idate(3) + 23*idate(4)
+ if ( me == 0 ) then
+ print *,' Radiation sub-cloud initial seed =',ipsd0, &
+ & ' idate =',idate
+ endif
+ endif
+
+ first = .false.
+
+ endif ! end_if_first
+!
+!===> *** ... radiation initialization
+!
+ dtsw = 3600.0 * fhswr
+ dtlw = 3600.0 * fhlwr
+ raddt = min(dtsw, dtlw)
+
+ call radinit &
+! --- input:
+ & ( si_loc, LEVR, IFLIP, idat, jdat, ICTM, ISOL, ICO2, &
+ & IAER, IALB, IEMS, ICWP, NUM_P3D, ISUBC_SW, ISUBC_LW, &
+ & IOVR_SW, IOVR_LW, me )
+! --- output: ( none )
+
+!
+!===> *** ... astronomy for sw radiation calculation.
+!
+! print *,' calling astronomy'
+ call astronomy &
+! --- inputs:
+ & ( lonsperlar, global_lats_r, sinlat_r, coslat_r, xlon, &
+! & fhswr, jdat, deltim, &
+ & fhswr, jdat, &
+ & LONR, LATS_NODE_R, LATR, IPT_LATS_NODE_R, lsswr, me, &
+! --- outputs:
+ & solcon, slag, sdec, cdec, coszen, coszdg &
+ & )
+! print *,' returned from astro'
+
+!
+!===> *** ... generate 2-d random seeds array for sub-grid cloud-radiation
+!
+ if ( ISUBC_LW==2 .or. ISUBC_SW==2 ) then
+ ipseed = mod(nint(100.0*sqrt(fhour*3600)), ipsdlim) + 1 + ipsd0
+
+ call random_setseed &
+! --- inputs:
+ & ( ipseed, &
+! --- outputs:
+ & stat &
+ & )
+ call random_index &
+! --- inputs:
+ & ( ipsdlim, &
+! --- outputs:
+ & numrdm, stat &
+ & )
+
+ do k = 1, 2
+ do j = 1, lats_node_r
+ lat = global_lats_r(ipt_lats_node_r-1+j)
+
+ do i = 1, LONR
+ ixseed(i,j,k) = numrdm(i+(lat-1)*LONR+(k-1)*LATR)
+ enddo
+ enddo
+ enddo
+ endif
+
+!
+!===> *** ... spectrum to grid transformation for radiation calculation.
+! -----------------------------------
+!!
+ call f_hpmstart(61,"gr delnpe")
+ call delnpe(trie_ls(1,1,P_q ),
+ x trio_ls(1,1,P_dphi),
+ x trie_ls(1,1,P_dlam),
+ x epse,epso,ls_node)
+ call f_hpmstop(61)
+!!
+ call f_hpmstart(62,"gr delnpo")
+ call delnpo(trio_ls(1,1,P_q ),
+ x trie_ls(1,1,P_dphi),
+ x trio_ls(1,1,P_dlam),
+ x epse,epso,ls_node)
+ call f_hpmstop(62)
+!!
+! print *,' after delnpeo'
+!!
+ call f_hpmstart(63,"gr dezouv dozeuv")
+!
+!$omp parallel do shared(trie_ls,trio_ls)
+!$omp+shared(epsedn,epsodn,snnp1ev,snnp1od,ls_node)
+!$omp+private(k)
+ do k=1,levs
+ call dezouv(trie_ls(1,1,P_di +k-1), trio_ls(1,1,P_ze +k-1),
+ x trie_ls(1,1,P_uln+k-1), trio_ls(1,1,P_vln+k-1),
+ x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
+!!
+ call dozeuv(trio_ls(1,1,P_di +k-1), trie_ls(1,1,P_ze +k-1),
+ x trio_ls(1,1,P_uln+k-1), trie_ls(1,1,P_vln+k-1),
+ x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
+ enddo
+ call f_hpmstop(63)
+!!
+!sela print*,'completed call to dztouv'
+!!
+!!mr call mpi_barrier (mpi_comm_world,ierr)
+!!
+ CALL countperf(0,5,0.)
+ CALL synctime()
+ CALL countperf(1,5,0.)
+!!
+ dimg=0
+ CALL countperf(0,1,0.)
+!!
+ call f_hpmstart(67,"gr sumfln")
+!!
+!sela print*,'begining call to sumfln'
+
+ call sumfln_slg_gg(trie_ls(1,1,P_ze),
+ x trio_ls(1,1,P_ze),
+ x lat1s_r,
+ x plnev_r,plnod_r,
+ x 5*levs+3,ls_node,latr2,
+ x lats_dim_r,lots,for_gr_r_1,
+ x ls_nodes,max_ls_nodes,
+ x lats_nodes_r,global_lats_r,
+!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
+ x lats_node_r,ipt_lats_node_r,lon_dim_r,
+ x lonsperlar,lonrx,latr,0)
+!
+ if(.not. gg_tracers) then
+! tracers grid values will be set from layout_grid_traces
+ call sumfln_slg_gg(trie_ls(1,1,P_rq),
+ x trio_ls(1,1,P_rq),
+ x lat1s_r,
+ x plnev_r,plnod_r,
+ x levh,ls_node,latr2,
+ x lats_dim_r,lots,for_gr_r_1,
+ x ls_nodes,max_ls_nodes,
+ x lats_nodes_r,global_lats_r,
+!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
+ x lats_node_r,ipt_lats_node_r,lon_dim_r,
+ x lonsperlar,lonrx,latr,5*levs+3)
+ endif
+
+! print*,'completed call to sumfln'
+!sela print*,'completed call to sumfln'
+ call f_hpmstop(67)
+!!
+ CALL countperf(1,1,0.)
+!!
+! -----------------------------------
+ if( vertcoord_id == 3. ) then
+! -----------------------------------
+ CALL countperf(0,1,0.) ! hmhj
+!
+ call f_hpmstart(68,"gr sumder2") ! hmhj
+!
+ do lan=1,lats_node_r
+ lat = global_lats_r(ipt_lats_node_r-1+lan)
+ lmax = min(jcap,lonsperlar(lat)/2)
+ if ( (lmax+1)*2+1 .le. lonsperlar(lat)+2 ) then
+ do k=levs+1,4*levs+2*levh
+ do i = (lmax+1)*2+1, lonsperlar(lat)+2
+ dyn_gr_r_1(i,k,lan) = cons0 !constant
+ enddo
+ enddo
+ endif
+ enddo
+!
+ call sumder2_slg(trie_ls(1,1,P_te), ! hmhj
+ x trio_ls(1,1,P_te), ! hmhj
+ x lat1s_r, ! hmhj
+ x pddev_r,pddod_r, ! hmhj
+ x levs,ls_node,latr2, ! hmhj
+ x lats_dim_r,lotd, ! hmhj
+ x dyn_gr_r_1, ! hmhj
+ x ls_nodes,max_ls_nodes, ! hmhj
+ x lats_nodes_r,global_lats_r, ! hmhj
+!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r, ! hmhj
+ x lats_node_r,ipt_lats_node_r,lon_dim_r, ! hmhj
+ x lonsperlar,lonrx,latr,0) ! hmhj
+!
+ call f_hpmstop(68) ! hmhj
+!
+ CALL countperf(1,1,0.) ! hmhj
+! --------------------------------
+ endif ! vertcoord_id=3
+! --------------------------------
+!
+
+!!mr call mpi_barrier (mpi_comm_world,ierr)
+
+ if(gg_tracers .and. shuff_lats_r) then
+ print*,' gloopr mpi_tracers_a_to_b shuff_lats_r',shuff_lats_r
+ call mpi_tracers_a_to_b(
+ x rg1_a,rg2_a,rg3_a,lats_nodes_a,global_lats_a,
+ x for_gr_r_2(1,1,1),
+ x lats_nodes_r,global_lats_r,ksr,0)
+ endif ! gg_tracers .and. shuff_lats_r
+
+ do lan=1,lats_node_r
+ timer1 = rtc()
+!!
+ lat = global_lats_r(ipt_lats_node_r-1+lan)
+!!
+! lon_dim = lon_dims_r(lan)
+!!
+ lons_lat = lonsperlar(lat)
+
+! -------------------------------------------------------
+ if( gen_coord_hybrid .and. vertcoord_id.eq.3. ) then
+! -------------------------------------------------------
+!
+ lmax = min(jcap,lons_lat/2) ! hmhj
+ ipt_ls = min(lat,latr-lat+1) ! hmhj
+
+ do i=1,lmax+1 ! hmhj
+ if ( ipt_ls .ge. lat1s_r(i-1) ) then ! hmhj
+ reall = i-1 ! hmhj
+ rlcs2(i) = reall*rcs2_r(ipt_ls)/rerth ! hmhj
+ else ! hmhj
+ rlcs2(i) = cons0 !constant ! hmhj
+ endif ! hmhj
+ enddo ! hmhj
+!
+!$omp parallel do private(k,i,item,jtem)
+ do k=1,levs ! hmhj
+ item = kdtlam-1+k
+ jtem = kst -1+K
+ do i=1,lmax+1 ! hmhj
+!
+! d(t)/d(lam) ! hmhj
+ dyn_gr_r_1(i+i-1,item,lan) = -for_gr_r_1(i+i,jtem,lan)
+ & * rlcs2(i) ! hmhj
+ dyn_gr_r_1(i+i,item,lan) = for_gr_r_1(i+i-1,jtem,lan)
+ & * rlcs2(i) ! hmhj
+ enddo ! hmhj
+ enddo ! hmhj
+! --------------------
+ endif ! gc and vertcoord_id=3
+! ---------------------
+!
+!!
+ CALL countperf(0,6,0.)
+!sela print*,' beginning call four2grid',lan
+! print*,' beginning call four2grid',lan
+ CALL FOUR_TO_GRID(for_gr_r_1(1,1,lan),for_gr_r_2(1,1,lan),
+!mjr & lon_dim ,lon_dim ,lons_lat,5*levs+3)
+ & lon_dim_r,lonr,lons_lat,5*levs+3)
+
+! print*,' after first call four2grid',lan
+ if(gg_tracers)then
+!
+! set tracers grid values from layout_grid_tracers
+!
+ if (.not.shuff_lats_r) then
+! set for_gr_r_2 to rg1_a rg2_a rg3_a from gloopa
+ do k=1,levs
+ item = KSR - 1 + k
+ jtem = lats_node_a+1-lan
+ do i=1,min(lonf,lons_lat)
+ for_gr_r_2(i,item ,lan) = rg1_a(i,k,jtem)
+ for_gr_r_2(i,item+ levs,lan) = rg2_a(i,k,jtem)
+ for_gr_r_2(i,item+2*levs,lan) = rg3_a(i,k,jtem)
+ enddo
+ enddo
+ endif ! not shuff_lats_r
+
+ else
+! print *,' begin second call to FOUR_TO_GRID in gloopr'
+ CALL FOUR_TO_GRID(for_gr_r_1(1,KSR,lan),
+ & for_gr_r_2(1,KSR,lan),
+!mjr & lon_dim ,lon_dim ,lons_lat,levh)
+ & lon_dim_r,lonr,lons_lat,levh)
+ endif
+! print *,' after second call to FOUR_TO_GRID in gloopr'
+
+! -------------------------------------------------------
+ if( gen_coord_hybrid.and.vertcoord_id.eq.3. ) then ! hmhj
+! -------------------------------------------------------
+ CALL FOUR_TO_GRID(dyn_gr_r_1(1,1,lan),dyn_gr_r_2(1,1,lan), ! hmhj
+!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
+ & lon_dim_r,lonr,lons_lat,levs) ! hmhj
+ CALL FOUR_TO_GRID(dyn_gr_r_1(1,KDTLAM,lan), ! hmhj
+ & dyn_gr_r_2(1,KDTLAM,lan), ! hmhj
+!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
+ & lon_dim_r,lonr,lons_lat,levs) ! hmhj
+! -------------------------
+ endif ! gc and vertcoord_id=3
+! -------------------------
+
+! print*,' completed call four2grid lan=',lan
+!sela print*,' completed call four2grid lan=',lan
+ CALL countperf(1,6,0.)
+!!
+ if( .not. gen_coord_hybrid ) then ! hmhj
+
+ do k = 1, LEVS
+ item = KSR-1+k
+ jtem = KST-1+k
+ do j = 1, lons_lat
+ if (for_gr_r_2(j,item,lan) <= qmin) then
+ for_gr_r_2(j,item,lan) = qmin
+ endif
+ for_gr_r_2(j,jtem,lan) = for_gr_r_2(j,jtem,lan)
+ & / (1.0 + FV*for_gr_r_2(j,item,lan))
+ enddo
+ enddo
+! print *,' now do sfc pressure for lan=',lan
+ do j = 1, lons_lat
+ for_gr_r_2(j,KSQ,lan) = exp( for_gr_r_2(j,KSQ,lan) )
+ enddo
+! print *,' after sfc pressure for lan=',lan
+
+ endif ! hmhj
+!
+ timer2 = rtc()
+ global_times_r(lat,me+1) = timer2 - timer1
+
+!$$$ print*,'timeloopr',me,timer1,timer2,global_times_r(lat,me+1)
+
+!!
+ enddo !lan
+!
+ call f_hpmstart(69,"gr lat_loop2")
+!
+!===> *** ... starting latitude loop
+!
+ do lan=1,lats_node_r
+!
+ lat = global_lats_r(ipt_lats_node_r-1+lan)
+!
+ lons_lat = lonsperlar(lat)
+
+!!
+!$omp parallel do schedule(dynamic,1) private(lon,i,j,k)
+!$omp+private(vvel,gu,gv1,gd,gt,gr,gr1,gq,gphi,glam)
+!$omp+private(gtv,gtvx,gtvy,sumq,xcp)
+!$omp+private(cldcov_v,fluxr_v,f_ice,f_rain,r_rime)
+!$omp+private(prslk,prsl,prsik,prsi,flgmin_v,hlw_v,swh_v)
+!$omp+private(njeff,n,item,jtem,ks,work1,work2)
+!$omp+private(icsdsw,icsdlw)
+!$omp+private(lprnt,ipt)
+!!!$omp+private(temlon,temlat,lprnt,ipt)
+
+ DO lon=1,lons_lat,NGPTC
+!!
+ NJEFF = MIN(NGPTC,lons_lat-lon+1)
+!!
+ lprnt = .false.
+!
+! --- ... for debug test
+! alon = 236.25
+! alat = 56.189
+! alon = 97.5
+! alat = -6.66
+! ipt = 0
+! do i = 1, njeff
+! item = lon + i - 1
+! temlon = xlon(item,lan) * 57.29578
+! if (temlon < 0.0) temlon = temlon + 360.0
+! temlat = xlat(item,lan) * 57.29578
+! lprnt = abs(temlon-alon) < 1.1 .and. abs(temlat-alat) < 1.1
+! & .and. kdt > 0
+! if ( lprnt ) then
+! ipt = i
+! print *,' ipt=',ipt,' lon=',lon,' lan=',lan
+! exit
+! endif
+! enddo
+! lprnt = .false.
+!!
+ if (ntcw <= 0) then
+ do k = 1, LEVS
+ do j = 1, njeff
+ jtem = lon-1+j
+ gu (j,k) = for_gr_r_2(jtem,KSU-1+k,lan)
+ gv1(j,k) = for_gr_r_2(jtem,KSV-1+k,lan)
+ gd (j,k) = for_gr_r_2(jtem,KSD-1+k,lan)
+ enddo
+ enddo
+ endif
+
+ if( gen_coord_hybrid ) then ! hmhj
+ do k=1,levr ! hmhj
+ do j=1,NJEFF ! hmhj
+ jtem = lon-1+j
+ gtv (j,k) = for_gr_r_2(jtem,KST-1+k,lan)
+ gr (j,k) = max(qmin, for_gr_r_2(jtem,KSR-1+k,lan))
+! gt (j,k) = gtv(j,k) / (1.+fv*gr(j,k))
+ enddo ! hmhj
+ enddo
+! --------------------------------------
+ if( vertcoord_id == 3. .and. ntcw <= 0 ) then
+! --------------------------------------
+ do k=1,levs ! hmhj
+ do j=1,NJEFF ! hmhj
+ jtem = lon-1+j
+ gtvx(j,k) = dyn_gr_r_2(jtem,KDTLAM-1+k,lan)
+ gtvy(j,k) = dyn_gr_r_2(jtem,KDTPHI-1+k,lan)
+ enddo ! hmhj
+ enddo
+! -----------------------------
+ endif
+! -----------------------------
+ if( thermodyn_id.eq.3 ) then ! get dry temperature from enthalpy
+ do k=1,levr ! hmhj
+ do j=1,njeff ! hmhj
+ sumq(j,k) = 0.0 ! hmhj
+ xcp(j,k) = 0.0 ! hmhj
+ enddo
+ enddo
+ do i=1,ntrac ! hmhj
+ if( cpi(i).ne.0.0 ) then ! hmhj
+ ks = ksr+(i-1)*levs ! hmhj
+ do k=1,levr ! hmhj
+ item = ks-1+k
+ do j=1,njeff ! hmhj
+ jtem = lon-1+j
+ sumq(j,k) = sumq(j,k) + for_gr_r_2(jtem,item,lan) ! hmhj
+ xcp(j,k) = xcp(j,k)
+ & + cpi(i)*for_gr_r_2(jtem,item,lan) ! hmhj
+ enddo ! hmhj
+ enddo ! hmhj
+ endif ! hmhj
+ enddo ! hmhj
+ do k=1,levr ! hmhj
+ do j=1,njeff ! hmhj
+ xcp(j,k) = (1.-sumq(j,k))*cpi(0) + xcp(j,k) ! hmhj
+ gt(j,k) = gtv(j,k) / xcp(j,k) ! hmhj
+ enddo ! hmhj
+ enddo ! hmhj
+ else if( thermodyn_id.le.1 ) then ! hmhj
+! get dry temperature from virtual temperature ! hmhj
+ do k=1,levr ! hmhj
+ do j=1,njeff ! hmhj
+ gt(j,k) = gtv(j,k) / (1.+fv*gr(j,k)) ! hmhj
+ enddo ! hmhj
+ enddo ! hmhj
+ else
+! get dry temperature from dry temperature ! hmhj
+ do k=1,levr ! hmhj
+ do j=1,njeff ! hmhj
+ gt(j,k) = gtv(j,k) ! hmhj
+ enddo ! hmhj
+ enddo
+ endif
+
+ else ! hmhj
+!
+ do k = 1, levr
+ do j = 1, njeff
+ jtem = lon-1+j
+ gt(j,k) = for_gr_r_2(jtem,KST-1+k,lan)
+ gr(j,k) = for_gr_r_2(jtem,KSR-1+k,lan)
+ enddo
+ enddo
+
+ endif
+!
+! Remaining tracers
+!
+ do n = 1, NTRAC-1
+ do k = 1, LEVR
+ item = KSR-1+k+n*levs
+ do j = 1, njeff
+ gr1(j,k,n) = for_gr_r_2(lon-1+j,item,lan)
+ enddo
+ enddo
+ enddo
+ if (ntcw > 0) then
+ do j = 1, njeff
+ gq (j) = for_gr_r_2(lon-1+j,KSQ,lan)
+ enddo
+ else
+ do j = 1, njeff
+ jtem = lon-1+j
+ gq (j) = for_gr_r_2(jtem,KSQ ,lan)
+ gphi(j) = for_gr_r_2(jtem,KSPPHI,lan)
+ glam(j) = for_gr_r_2(jtem,KSPLAM,lan)
+ enddo
+ endif
+!!
+! --- vertical structure variables: del,si,sl,prslk,prdel
+!
+ if( gen_coord_hybrid ) then ! hmhj
+ call hyb2press_gc(njeff,ngptc,gq,gtv,prsi,prsl,prsik,prslk) ! hmhj
+ if (ntcw <= 0)
+ & call omegtes_gc(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)), ! hmhj
+ & gq,gphi,glam,gtv,gtvx,gtvy,gd,gu,gv1,vvel) ! hmhj
+ elseif (hybrid) then
+ call hyb2press(njeff,ngptc,gq, prsi, prsl,prsik, prslk)
+ if (ntcw <= 0)
+ & call omegtes(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)),
+ & gq,gphi,glam,gd,gu,gv1,vvel)
+! & gq,gphi,glam,gd,gu,gv1,vvel,ngptc,lprnt,ipt)
+ else
+ call sig2press(njeff,ngptc,gq,sl,si,slk,sik,
+ & prsi,prsl,prsik,prslk)
+ CALL countperf(0,12,0.)
+ if (ntcw <= 0)
+ & call omegast3(njeff,ngptc,levs,
+ & gphi,glam,gu,gv1,gd,del,
+ & rcs2_r(min(lat,latr-lat+1)),vvel,gq,sl)
+ endif
+!.....
+ if (levr .lt. levs) then
+ do j=1,njeff
+ prsi(j,levr+1) = prsi(j,levp1)
+ prsl(j,levr) = (prsi(j,levp1) + prsi(j,levr)) * 0.5
+ prsik(j,levr+1) = prslk(j,levp1)
+ prslk(j,levr) = fpkap(prsl(j,levr)*1000.0)
+ enddo
+ endif
+!
+ do k=1,nfxr
+ do j=1,njeff
+ fluxr_v(j,k) = fluxr(lon+j-1,k,lan)
+ enddo
+ enddo
+!
+ if (num_p3d == 3) then
+ do k = 1, LEVR
+ do j = 1, njeff
+ jtem = lon+j-1
+ f_ice (j,k) = phy_f3d(jtem,k,1,lan)
+ f_rain(j,k) = phy_f3d(jtem,k,2,lan)
+ r_rime(j,k) = phy_f3d(jtem,k,3,lan)
+ enddo
+ enddo
+
+ work1 = (log(coslat_r(lat) / (lons_lat*latg)) - dxmin)*dxinv
+ work1 = max(0.0, min(1.0,work1))
+ work2 = flgmin(1)*work1 + flgmin(2)*(1.0-work1)
+ do j=1,njeff
+ flgmin_v(j) = work2
+ enddo
+ else
+ do j=1,njeff
+ flgmin_v(j) = 0.0
+ enddo
+ endif
+
+! *** ... assign random seeds for sw and lw radiations
+
+ if ( ISUBC_LW==2 .or. ISUBC_SW==2 ) then
+ do j = 1, njeff
+ icsdsw(j) = ixseed(lon+j-1,lan,1)
+ icsdlw(j) = ixseed(lon+j-1,lan,2)
+ enddo
+ endif
+!
+! *** ... calling radiation driver
+
+!
+! lprnt = me .eq. 0 .and. kdt .ge. 120
+! if (lprnt) then
+! if (kdt .gt. 85) then
+! print *,' calling grrad for me=',me,' lan=',lan,' lat=',lat
+! &,' num_p3d=',num_p3d
+! if (lan == 47) print *,' gt=',gt(1,:)
+! if (kdt > 3) call mpi_quit(5555)
+
+!
+
+ call grrad &
+! --- inputs:
+ & ( prsi,prsl,prslk,gt,gr,gr1,vvel,slmsk(lon,lan), &
+ & xlon(lon,lan),xlat(lon,lan),tsea(lon,lan), &
+ & sheleg(lon,lan),sncovr(lon,lan),snoalb(lon,lan), &
+ & zorl(lon,lan),hprime(lon,1,lan), &
+ & alvsf(lon,lan),alnsf(lon,lan),alvwf(lon,lan), &
+ & alnwf(lon,lan),facsf(lon,lan),facwf(lon,lan), &
+ ! fice FOR SEA-ICE XW Nov04
+ & fice(lon,lan),tisfc(lon,lan), &
+ & solcon,coszen(lon,lan),coszdg(lon,lan),k1oz,k2oz,facoz, &
+ & cv(lon,lan),cvt(lon,lan),cvb(lon,lan), &
+ & IOVR_SW,IOVR_LW,f_ice,f_rain,r_rime,flgmin_v, &
+ & icsdsw,icsdlw,NUM_P3D,NTCW-1,NCLD,NTOZ-1,NTRAC-1,NFXR, &
+ & dtlw,dtsw,lsswr,lslwr,lssav,sas_shal,norad_precip, &
+ & crick_proof, ccnorm, &
+ & ngptc,njeff,LEVR,IFLIP, me, lprnt,ipt,kdt, &
+! & ngptc,njeff,LEVR,IFLIP, me, lprnt, &
+! --- outputs:
+ & swh_v,sfcnsw(lon,lan),sfcdsw(lon,lan), &
+ & sfalb(lon,lan), &
+ & hlw_v,sfcdlw(lon,lan),tsflw(lon,lan), &
+ & sfcemis(lon,lan),cldcov_v, &
+! --- input/output:
+ & fluxr_v &
+ & )
+!
+!
+! if (lprnt) print *,' returned from grrad for me=',me,' lan=',
+! &lan,' lat=',lat,' kdt=',kdt
+! print *,' end gloopr HLW=',hlw(lon,:,lan),' lan=',lan
+!
+! if (lprnt) print *,' swh_vg=',swh_v(ipt,:)
+!
+!
+ if (lssav) then
+ if (ldiag3d .or. lggfs3d) then
+ do k=1,levr
+ do j=1,njeff
+ cldcov(lon+j-1,k,lan) = cldcov(lon+j-1,k,lan) &
+ & + cldcov_v(j,k) * raddt
+ enddo
+ enddo
+ endif
+ endif
+ do k=1,nfxr
+ do j=1,njeff
+ fluxr(lon+j-1,k,lan) = fluxr_v(j,k)
+ enddo
+ enddo
+ if (lslwr) then
+ do k=1,levr
+ do j=1,njeff
+ jtem = lon + j - 1
+ hlw(jtem,k,lan) = hlw_v(j,k)
+ swh(jtem,k,lan) = swh_v(j,k)
+ enddo
+ enddo
+ if (levr .lt. levs) then
+ do k=levr+1,levs
+ do j=1,njeff
+ jtem = lon + j - 1
+ hlw(jtem,k,lan) = hlw_v(j,levr)
+ swh(jtem,k,lan) = swh_v(j,levr)
+ enddo
+ enddo
+ endif
+ endif
+!
+! if (lat == 45 .and. me == 0 .and. lon == 1) then
+! print *,' after grrad hlw_v=',hlw_v(1,:)
+! print *,' after grrad swh_v=',swh_v(1,:)
+! endif
+! if (lprnt) print *,' hlwg=',hlw(lon+ipt-1,:,lan)
+! if (lprnt) print *,' swhg=',swh(lon+ipt-1,:,lan)
+! if (lprnt) print *,' swh_vg=',swh_v(ipt,:)
+
+!$$$ write(2900+lat,*) ' ilon = ',istrt
+c$$$ write(2900+lat,'("swh",T16,"hlw")')
+!$$$ do k=1,levs
+!$$$ write(2900+lat,
+!$$$ . '(e10.3,T16,e10.3,T31,e10.3)')
+!$$$ . swh(1,k,iblk,lan),hlw(1,k,iblk,lan)
+!$$$ enddo
+
+!!
+! print *,' completed grrad for lan=',lan,' istrt=',istrt
+ CALL countperf(1,12,0.)
+ ENDDO
+!
+ enddo
+!!
+ call f_hpmstop(69)
+!!
+ CALL countperf(0,5,0.)
+ CALL synctime()
+ CALL countperf(1,5,0.)
+!sela print*,'completed gloopr_v kdt=',kdt
+!!
+ return
+ end subroutine gloopr
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/radiation_astronomy.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/radiation_astronomy.f_gfs (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gfscode_unchanged/radiation_astronomy.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,804 @@
+!!!!! ========================================================== !!!!!
+!!!!! 'module_radiation_astronomy' description !!!!!
+!!!!! ========================================================== !!!!!
+! !
+! set up astronomy quantities for solar radiation calculations. !
+! !
+! in module 'module_radiation_astronomy', externally accessable !
+! subroutines are listed below: !
+! !
+! 'solinit' -- read in solar constant !
+! input: !
+! ( ISOL, iyear, iydat, me ) !
+! output: !
+! ( none ) !
+! !
+! 'astronomy' -- get astronomy related quantities !
+! input: !
+! ( lons_lar,glb_lats_r,sinlat,coslat,xlon, !
+!! fhswr,jdate,deltim, !
+! fhswr,jdate, !
+! LON2,LATD,LATR,IPT_LATR, lsswr, me) !
+! output: !
+! ( solcon,slag,sdec,cdec,coszen,coszdg) !
+! !
+! !
+! external modules referenced: !
+! 'module machine' in 'machine.f' !
+! 'module physcons' in 'physcons.f !
+! !
+! program history log: !
+! may-06-1977 --- ray orzol, created at gfdl !
+! jul-07-1989 --- kenneth campana !
+! may-15-1998 --- mark iredell y2k compliance !
+! dec-15-2003 --- yu-tai hou combined compjd and fcstim and !
+! rewrite in fortran 90 compatable form !
+! feb-15-2006 --- yu-tai hou add 11-yr solar constant cycle !
+! mar-19-2009 --- yu-tai hou modified solinit for climate !
+! hindcast situation. !
+! !
+!!!!! ========================================================== !!!!!
+!!!!! end descriptions !!!!!
+!!!!! ========================================================== !!!!!
+
+
+
+!========================================!
+ module module_radiation_astronomy !
+!........................................!
+!
+ use machine, only : kind_phys
+ use physcons, only : con_solr, con_pi
+ use module_iounitdef, only : NIRADSF
+!
+ implicit none
+!
+ private
+
+! --- parameter constants
+ real (kind=kind_phys), parameter :: degrad = 180.0/con_pi
+ real (kind=kind_phys), parameter :: tpi = 2.0 * con_pi
+ real (kind=kind_phys), parameter :: hpi = 0.5 * con_pi
+
+! --- module variables:
+ real (kind=kind_phys), public :: solc0
+
+ public solinit, astronomy
+
+
+! =================
+ contains
+! =================
+
+!-----------------------------------
+ subroutine solinit &
+!...................................
+
+! --- inputs:
+ & ( ISOL, iyear, iydat, me )
+! --- outputs: ( none )
+
+! =================================================================== !
+! !
+! read in solar constant value for a given year !
+! !
+! inputs: !
+! ISOL - =0: use fixed solar constant in "physcon" !
+! =1: use 11-year cycle solar constant from table !
+! iyear - year of the requested data (for ISOL=1 only) !
+! iydat - usually =iyear. if not, it is for hindcast mode, and it !
+! is usually the init cond time and serves as the upper !
+! limit of data can be used. !
+! me - print message control flag !
+! !
+! outputs: (to module variable) !
+! ( none ) !
+! !
+! module variable: !
+! solc0 - solar constant (w/m**2) 1 !
+! !
+! usage: call solinit !
+! !
+! subprograms called: none !
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- input:
+ integer, intent(in) :: ISOL, iyear, iydat, me
+
+! --- output: ( none )
+
+! --- local:
+ real (kind=kind_phys):: smean, solc1
+ integer :: i, iyr, iyr1, iyr2, jyr
+ logical :: file_exist
+ character :: cline*60, cfile0*26
+
+ data cfile0 / 'solarconstantdata.txt' /
+
+!===> ... begin here
+
+ if ( ISOL == 0 ) then
+ solc0 = con_solr
+
+ if ( me == 0 ) then
+ print *,' - Using fixed solar constant =', solc0
+ endif
+
+ return
+ endif
+
+! --- ... check to see if the solar constant data file existed
+
+ inquire (file=cfile0, exist=file_exist)
+ if ( .not. file_exist ) then
+ solc0 = con_solr
+
+ if ( me == 0 ) then
+ print *,' - Using varying solar constant with 11-year cycle'
+ print *,' Requested solar data file "',cfile0, &
+ & '" not found!'
+ print *,' Using the default solar constant value =',solc0, &
+ & ' instead!!'
+ endif
+ else
+ iyr = iyear
+
+ open (NIRADSF,file=cfile0,form='formatted',status='old')
+ rewind NIRADSF
+
+ read (NIRADSF, 24) iyr1, iyr2, smean, cline
+ 24 format(i4,2x,i4,f8.2,a60)
+
+! --- ... check if there is a upper year limit put on the data table
+
+ if ( iyear /= iydat ) then
+ if ( iydat-iyr1 < 11 ) then ! need data range at least 11 years
+ ! to perform 11-year cycle approx
+ if ( me == 0 ) then
+ print *,' - Using varying solar constant with 11-year', &
+ & ' cycle'
+ print *,' *** the requested year',iyear,' and upper ', &
+ & 'limit',iydat,' do not fit the range of data ', &
+ & 'table of iyr1, iyr2 =',iyr1,iyr2
+ print *,' USE FIXED SOLAR CONSTANT=',con_solr
+ endif
+
+ solc0 = con_solr
+ return
+
+ elseif ( iydat < iyr2 ) then
+
+! --- ... because the usage limit put on the historical data table,
+! skip those unused data records at first
+
+ i = iyr2
+ Lab_dowhile0 : do while ( i > iydat )
+! read (NIRADSF,26) jyr, solc1
+! 26 format(i4,f8.2)
+ read (NIRADSF,*) jyr, solc1
+ i = i - 1
+ enddo Lab_dowhile0
+
+ iyr2 = iydat ! next record will serve the upper limit
+
+ endif ! end if_iydat_block
+ endif ! end if_iyear_block
+
+ if ( me == 0 ) then
+ print *,' - Using varying solar constant with 11-year cycle'
+ print *,' Opened solar constant data file: ',cfile0
+!check print *, iyr1, iyr2, smean, cline
+ endif
+
+ if ( iyr < iyr1 ) then
+ Lab_dowhile1 : do while ( iyr < iyr1 )
+ iyr = iyr + 11
+ enddo Lab_dowhile1
+
+ if ( me == 0 ) then
+ print *,' *** Year',iyear,' out of table range!', &
+ & iyr1, iyr2
+ print *,' Using the 11-cycle year (',iyr,' ) value.'
+ endif
+ elseif ( iyr > iyr2 ) then
+ Lab_dowhile2 : do while ( iyr > iyr2 )
+ iyr = iyr - 11
+ enddo Lab_dowhile2
+
+ if ( me == 0 ) then
+ print *,' *** Year',iyear,' out of given table range!', &
+ & iyr1, iyr2
+ print *,' Using the 11-cycle year (',iyr,' ) value.'
+ endif
+ endif
+
+! --- ... locate the right record year of data
+
+ i = iyr2
+ Lab_dowhile3 : do while ( i >= iyr1 )
+! read (NIRADSF,26) jyr, solc1
+! 26 format(i4,f8.2)
+ read (NIRADSF,*) jyr, solc1
+
+ if ( i == iyr .and. iyr == jyr ) then
+ solc0 = smean + solc1
+ if (me == 0) then
+ print *,' CHECK: Solar constant data for year',iyr, &
+ & solc1, solc0
+ endif
+ exit Lab_dowhile3
+ else
+!check if (me == 0) print *,' Skip solar const data for year',i
+ i = i - 1
+ endif
+ enddo Lab_dowhile3
+
+ close ( NIRADSF )
+ endif ! end if_file_exist_block
+
+!
+ return
+!...................................
+ end subroutine solinit
+!-----------------------------------
+
+
+!-----------------------------------
+ subroutine astronomy &
+!...................................
+
+! --- inputs:
+ & ( lons_lar,glb_lats_r,sinlat,coslat,xlon, &
+! & fhswr,jdate,deltim, &
+ & fhswr,jdate, &
+ & LON2,LATD,LATR,IPT_LATR, lsswr, me, &
+! --- outputs:
+ & solcon,slag,sdec,cdec,coszen,coszdg &
+ & )
+
+! =================================================================== !
+! !
+! astronomy computes solar parameters at forecast time !
+! !
+! inputs: dimension !
+! lons_lar - num of grid pts on a given lat circle (LATR)!
+! glb_lats_r - index for global latitudes (LATR)!
+! sinlat,coslat - sin and cos of latitude (LATR)!
+! xlon - longitude in radians (LON2*LATD)!
+! fhswr - sw radiation calling interval in hour !
+! jdate - current forecast date and time (8) !
+! (yr, mon, day, t-zone, hr, min, sec, mil-sec) !
+!! deltim - duration of model integration time step in seconds !
+! LON2,LATD,LATR- dimensions for longitude/latitude directions !
+! IPT_LATR - latitude index location indecator !
+! lsswr - logical control flag for sw radiation call !
+! me - integer control flag for diagnostic print out !
+! !
+! outputs: !
+! solcon - sun-earth distance adjusted solar constant (w/m2) !
+! slag - equation of time in radians !
+! sdec, cdec - sin and cos of the solar declination angle !
+! coszen - avg of cosz for daytime only (LON2,LATD)!
+! coszdg - avg of cosz over entire sw call interval(LON2,LATD)!
+! !
+! !
+! external functions called: iw3jdn !
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- input:
+ integer, intent(in) :: LON2, LATD, LATR, IPT_LATR, me
+ integer, intent(in) :: lons_lar(:), glb_lats_r(:), jdate(:)
+
+ logical, intent(in) :: lsswr
+
+ real (kind=kind_phys), intent(in) :: sinlat(:), coslat(:), &
+ & xlon(:,:), fhswr
+! & xlon(:,:), fhswr, deltim
+
+! --- output:
+ real (kind=kind_phys), intent(out) :: solcon, slag, sdec, cdec, &
+ & coszen(:,:), coszdg(:,:)
+
+! --- locals:
+ real (kind=kind_phys), parameter :: f24 = 24.0 ! hours/day
+ real (kind=kind_phys), parameter :: f1440 = 1440.0 ! minutes/day
+
+ real (kind=kind_phys) :: solhr, fjd, fjd1, dlt, r1, alp, solc
+
+ integer :: jd, jd1, iyear, imon, iday, ihr, imin
+ integer :: iw3jdn
+
+!===> ... begin here
+
+ iyear = jdate(1)
+ imon = jdate(2)
+ iday = jdate(3)
+ ihr = jdate(5)
+ imin = jdate(6)
+
+! --- ... calculate forecast julian day and fraction of julian day
+
+ jd1 = iw3jdn(iyear,imon,iday)
+
+! --- ... unlike in normal applications, where day starts from 0 hr,
+! in astronomy applications, day stats from noon.
+
+ if (ihr < 12) then
+ jd1 = jd1 - 1
+! fjd1= 0.5 + float(ihr)/f24 ! use next line if imin > 0
+ fjd1= 0.5 + float(ihr)/f24 + float(imin)/f1440
+ else
+! fjd1= float(ihr - 12)/f24 ! use next line if imin > 0
+ fjd1= float(ihr - 12)/f24 + float(imin)/f1440
+ endif
+
+ fjd1 = fjd1 + jd1
+
+ jd = int(fjd1)
+ fjd = fjd1 - jd
+
+ if (lsswr) then
+
+! --- ... hour of forecast time
+
+ solhr = mod( float(ihr), f24 )
+
+ call solar &
+! --- inputs:
+ & ( jd,fjd, &
+! --- outputs:
+ & r1,dlt,alp,slag,sdec,cdec &
+ & )
+
+! if (me == 0) print*,'in astronomy completed sr solar'
+
+ call coszmn &
+! --- inputs:
+ & ( lons_lar,glb_lats_r,xlon,sinlat,coslat, &
+! & fhswr,deltim,solhr,sdec,cdec,slag, &
+ & fhswr,solhr,sdec,cdec,slag, &
+ & LON2,LATD,IPT_LATR, &
+! --- outputs:
+ & coszen,coszdg &
+ & )
+
+! if (me == 0) print*,'in astronomy completed sr coszmn'
+
+! --- ... calculate sun-earth distance adjustment factor appropriate for date
+
+ solcon = solc0 / (r1*r1)
+
+ endif
+
+! --- ... diagnostic print out
+
+ if (me == 0) then
+
+ call prtime &
+! --- inputs:
+ & ( jd, fjd, dlt, alp, r1, slag, solcon &
+! --- outputs: ( none )
+ & )
+
+ endif
+
+!
+ return
+!...................................
+ end subroutine astronomy
+!-----------------------------------
+
+
+!-----------------------------------
+ subroutine solar &
+!...................................
+
+! --- inputs:
+ & ( jd,fjd, &
+! --- outputs:
+ & r1,dlt,alp,slag,sdec,cdec &
+ & )
+
+! =================================================================== !
+! !
+! solar computes radius vector, declination and right ascension of !
+! sun, and equation of time. !
+! !
+! inputs: !
+! jd - julian day !
+! fjd - fraction of the julian day !
+! !
+! outputs: !
+! r1 - earth-sun radius vector !
+! dlt - declination of sun in radians !
+! alp - right ascension of sun in radians !
+! slag - equation of time in radians !
+! sdec - sine of declination angle !
+! cdec - cosine of declination angle !
+! !
+! usage: call solar !
+! !
+! external subroutines called: none !
+! !
+! program history log: !
+! mar-xx-1989 --- kenneth campana, patterner after original gfdl !
+! code but no calculation of latitude mean cos !
+! solar zenith angle. !
+! fall -1988 --- hualu pan, updated to limit iterations in newton!
+! method and also ccr reduced to avoid non- !
+! convergence. !
+! dec-15-2003 --- yu-tai hou, updated to make fortran 90 compatable!
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- inputs:
+ real (kind=kind_phys), intent(in) :: fjd
+ integer, intent(in) :: jd
+
+! --- outputs:
+ real (kind=kind_phys), intent(out) :: r1, dlt,alp,slag,sdec,cdec
+
+! --- locals:
+ real (kind=kind_phys), parameter :: cyear = 365.25 ! days of year
+ real (kind=kind_phys), parameter :: ccr = 1.3e-6 ! iteration limit
+ real (kind=kind_phys), parameter :: tpp = 1.55 ! days between epoch and
+ ! perihelion passage of 1900
+ real (kind=kind_phys), parameter :: svt6 = 78.035 ! days between perihelion passage
+ ! and march equinox of 1900
+ integer, parameter :: jdor = 2415020 ! jd of epoch which is january
+ ! 0, 1900 at 12 hours ut
+
+ real (kind=kind_phys) :: dat, t1, year, tyear, ec, angin, ador, &
+ & deleqn, sni, tini, er, qq, e1, ep, cd, eq, date, em, &
+ & cr, w1, tst, sun
+
+ integer :: jdoe, iter
+
+!===> ... begin here
+
+! --- ... computes time in julian centuries after epoch
+
+ t1 = float(jd - jdor) / 36525.0
+
+! --- ... computes length of anomalistic and tropical years (minus 365 days)
+
+ year = 0.25964134e0 + 0.304e-5 * t1
+ tyear= 0.24219879E0 - 0.614e-5 * t1
+
+! --- ... computes orbit eccentricity and angle of earth's inclination from t
+
+ ec = 0.01675104e0 - (0.418e-4 + 0.126e-6 * t1) * t1
+ angin= 23.452294e0 - (0.0130125e0 + 0.164e-5 * t1) * t1
+
+ ador = jdor
+ jdoe = ador + (svt6 * cyear) / (year - tyear)
+
+! --- ... deleqn is updated svt6 for current date
+
+ deleqn= float(jdoe - jd) * (year - tyear) / cyear
+ year = year + 365.0
+ sni = sin( angin / degrad )
+ tini = 1.0 / tan( angin / degrad )
+ er = sqrt( (1.0 + ec) / (1.0 - ec) )
+ qq = deleqn * tpi / year
+
+! --- ... determine true anomaly at equinox
+
+ e1 = 1.0
+ cd = 1.0
+ iter = 0
+
+ lab_do_1 : do while ( cd > ccr )
+
+ ep = e1 - (e1 - ec*sin(e1) - qq) / (1.0 - ec*cos(e1))
+ cd = abs(e1 - ep)
+ e1 = ep
+ iter = iter + 1
+
+ if (iter > 10) then
+ write(6,*) ' ITERATION COUNT FOR LOOP 32 =', iter
+ write(6,*) ' E, EP, CD =', e1, ep, cd
+ exit lab_do_1
+ endif
+
+ enddo lab_do_1
+
+ eq = 2.0 * atan( er * tan( 0.5*e1 ) )
+
+! --- ... date is days since last perihelion passage
+
+ dat = float(jd - jdor) - tpp + fjd
+ date = mod(dat, year)
+
+! --- ... solve orbit equations by newton's method
+
+ em = tpi * date / year
+ e1 = 1.0
+ cr = 1.0
+ iter = 0
+
+ lab_do_2 : do while ( cr > ccr )
+
+ ep = e1 - (e1 - ec*sin(e1) - em) / (1.0 - ec*cos(e1))
+ cr = abs(e1 - ep)
+ e1 = ep
+ iter = iter + 1
+
+ if (iter > 10) then
+ write(6,*) ' ITERATION COUNT FOR LOOP 31 =', iter
+ exit lab_do_2
+ endif
+
+ enddo lab_do_2
+
+ w1 = 2.0 * atan( er * tan( 0.5*e1 ) )
+
+ r1 = 1.0 - ec*cos(e1)
+
+ sdec = sni * sin(w1 - eq)
+ cdec = sqrt( 1.0 - sdec*sdec )
+
+ dlt = asin( sdec )
+ alp = asin( tan(dlt)*tini )
+
+ tst = cos( w1 - eq )
+ if (tst < 0.0) alp = con_pi - alp
+ if (alp < 0.0) alp = alp + tpi
+
+ sun = tpi * (date - deleqn) / year
+ if (sun < 0.0) sun = sun + tpi
+ slag = sun - alp - 0.03255e0
+
+!
+ return
+!...................................
+ end subroutine solar
+!-----------------------------------
+
+
+!-----------------------------------
+ subroutine coszmn &
+!...................................
+
+! --- inputs:
+ & ( lons_lar,glb_lats_r,xlon,sinlat,coslat, &
+! & dtswav,deltim,solhr,sdec,cdec,slag, &
+ & dtswav,solhr,sdec,cdec,slag, &
+ & NLON2,LATD,IPT_LATR, &
+! --- outputs:
+ & coszen,coszdg &
+ & )
+
+! =================================================================== !
+! !
+! coszmn computes mean cos solar zenith angle over 'dtswav' hours. !
+! !
+! inputs: !
+! lons_lar - num of grid pts on a given lat circle !
+! glb_lats_r - index for global latitude !
+! xlon - longitude in radians !
+! sinlat,coslat - sin and cos of latitude !
+! dtswav - sw radiation calling interval in hour !
+!! deltim - duration of model integration time step in second !
+! solhr - time after 00z in hours !
+! sdec, cdec - sin and cos of the solar declination angle !
+! slag - equation of time !
+! NLON2,LATD - dimensions for longitude/latitude directions !
+! IPT_LATR - latitude index location indecator !
+! !
+! outputs: !
+! coszen - average of cosz for daytime only in sw call interval
+! coszdg - average of cosz over entire sw call interval !
+! !
+! usage: call comzmn !
+! !
+! external subroutines called: none !
+! !
+! program history log: !
+! 05-28-2004 yu-tai hou - modified for gfs hybrid model !
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- inputs:
+ integer, intent(in) :: NLON2, LATD, IPT_LATR
+ integer, intent(in) :: lons_lar(:), glb_lats_r(:)
+
+ real (kind=kind_phys), intent(in) :: sinlat(:), coslat(:), &
+ & xlon(:,:), dtswav, solhr, sdec, cdec, slag
+! & xlon(:,:), dtswav, deltim, solhr, sdec, cdec, slag
+
+! --- outputs:
+ real (kind=kind_phys), intent(out) :: coszen(:,:), coszdg(:,:)
+
+! --- locals:
+ real (kind=kind_phys) :: coszn(NLON2), pid12, cns, ss, cc
+
+ integer :: istsun(NLON2), nstp, istp, nlon, nlnsp, i, it, j, lat
+
+!===> ... begin here
+
+ nlon = NLON2 / 2
+
+ nstp = 6 ! number of cosz calc per fcst hour
+! nstp = max(6, min(10, nint(3600.0/deltim) )) ! for better time step sync
+ istp = nint( dtswav*nstp ) ! total num of calc in dtswav interval
+
+! pid12 = con_pi / 12.0 ! angle per hour
+ pid12 = (2.0 * asin(1.0)) / 12.0
+
+ do j = 1, LATD
+ lat = glb_lats_r(IPT_LATR-1+j)
+ nlnsp = lons_lar(lat)
+
+ do i = 1, NLON2
+ coszen(i,j) = 0.0
+ istsun(i) = 0
+ enddo
+
+ do it = 1, istp
+ cns = pid12 * (solhr - 12.0 + float(it-1)/float(nstp)) + slag
+ ss = sinlat(lat) * sdec
+ cc = coslat(lat) * cdec
+
+ do i = 1, nlnsp
+ coszn(i) = ss + cc * cos(cns + xlon(i,j))
+ coszen(i,j) = coszen(i,j) + max(0.0, coszn(i))
+ if (coszn(i) > 0.0001) istsun(i) = istsun(i) + 1
+ enddo
+ enddo
+
+! --- ... compute time averages
+
+ do i = 1, NLON2
+ coszdg(i,j) = coszen(i,j) / float(istp)
+ if (istsun(i) > 0) coszen(i,j) = coszen(i,j) / istsun(i)
+ enddo
+ enddo
+
+!
+ return
+!...................................
+ end subroutine coszmn
+!-----------------------------------
+
+
+!-----------------------------------
+ subroutine prtime &
+!...................................
+
+! --- inputs:
+ & ( jd, fjd, dlt, alp, r1, slag, solc &
+! --- outputs: ( none )
+ & )
+
+! =================================================================== !
+! !
+! prtime prints out forecast date, time, and astronomy quantities. !
+! !
+! inputs: !
+! jd - forecast julian day !
+! fjd - forecast fraction of julian day !
+! dlt - declination angle of sun in radians !
+! alp - right ascension of sun in radians !
+! r1 - earth-sun radius vector in meter !
+! slag - equation of time in radians !
+! solc - solar constant in w/m^2 !
+! !
+! outputs: ( none ) !
+! !
+! usage: call prtime !
+! !
+! external subroutines called: w3fs26 !
+! !
+! program history log: !
+! jun-07-1977 --- robert white (gfdl) !
+! jul-07-1989 --- kenneth campana !
+! may-15-1998 --- mark iredell y2k compliance !
+! dec-18-2003 --- yu-tai hou combine cdate and prtime and !
+! rewrite in fortran 90 compatable form !
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- inputs:
+ integer, intent(in) :: jd
+
+ real (kind=kind_phys), intent(in) :: fjd, dlt, alp, r1, slag, solc
+
+! --- outputs: ( none )
+
+! --- locals:
+ real (kind=kind_phys), parameter :: sixty = 60.0
+
+ character(LEN=1), parameter :: sign = '-'
+ character(LEN=1), parameter :: sigb = ' '
+
+ character(LEN=1) :: dsig
+ character(LEN=4) :: month(12)
+
+ data month / 'JAN.','FEB.','MAR.','APR.','MAY ','JUNE', &
+ & 'JULY','AUG.','SEP.','OCT.','NOV ','DEC.' /
+
+ integer :: iday, imon, iyear, ihr, ltd, ltm, &
+ & ihalp, iyy, jda, mfjd, idaywk, idayyr
+ real (kind=kind_phys) :: xmin, dltd, dltm, dlts, halp, ymin, &
+ & asec, eqt, eqsec
+
+!===> ... begin here
+
+! --- ... get forecast hour and minute from fraction of julian day
+
+ if (fjd >= 0.5) then
+ jda = jd + 1
+ mfjd= nint( fjd*1440.0 )
+ ihr = mfjd / 60 - 12
+ xmin= float(mfjd) - (ihr + 12)*sixty
+ else
+ jda = jd
+ mfjd= nint( fjd*1440.0 )
+ ihr = mfjd / 60 + 12
+ xmin= float(mfjd) - (ihr - 12)*sixty
+ endif
+
+! --- ... get forecast year, month, and day from julian day
+
+ call w3fs26(jda, iyear,imon,iday, idaywk,idayyr)
+
+! -- ... compute solar parameters
+
+ dltd = degrad * dlt
+ ltd = dltd
+ dltm = sixty * (abs(dltd) - abs(float(ltd)))
+ ltm = dltm
+ dlts = sixty * (dltm - float(ltm))
+
+ if ((dltd < 0.0) .and. (ltd == 0.0)) then
+ dsig = sign
+ else
+ dsig = sigb
+ endif
+
+ halp = 6.0 * alp / hpi
+ ihalp= halp
+ ymin = abs(halp - float(ihalp)) * sixty
+ iyy = ymin
+ asec = (ymin - float(iyy)) * sixty
+
+ eqt = 228.55735 * slag
+ eqsec= sixty * eqt
+
+ print 101, iday, month(imon), iyear, ihr, xmin, jd, fjd
+ 101 format('0 FORECAST DATE',9x,i3,a5,i6,' AT',i3,' HRS',f6.2,' MINS'/&
+ & ' JULIAN DAY',12x,i8,2x,'PLUS',f11.6)
+
+ print 102, r1, halp, ihalp, iyy, asec
+ 102 format(' RADIUS VECTOR',9x,f10.7/' RIGHT ASCENSION OF SUN', &
+ & f12.7,' HRS, OR',i4,' HRS',i4,' MINS',f6.1,' SECS')
+
+ print 103, dltd, dsig, ltd, ltm, dlts, eqt, eqsec, slag, solc
+ 103 format(' DECLINATION OF THE SUN',f12.7,' DEGS, OR ',a1,i3, &
+ & ' DEGS',i4,' MINS',f6.1,' SECS'/' EQUATION OF TIME',6x, &
+ & f12.7,' MINS, OR',f10.2,' SECS, OR',f9.6,' RADIANS'/ &
+ & ' SOLAR CONSTANT',8X,F12.7,' (DISTANCE AJUSTED)'//)
+
+!
+ return
+!...................................
+ end subroutine prtime
+!-----------------------------------
+
+!
+!...........................................!
+ end module module_radiation_astronomy !
+!===========================================!
Modified: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopb.f
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopb.f 2012-05-10 23:36:12 UTC (rev 1894)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopb.f 2012-05-10 23:40:46 UTC (rev 1895)
@@ -1,49 +1,34 @@
+!--modeified for MPAS, Fanglin Yang, May 2012
+!
subroutine gloopb
- x (trie_ls,trio_ls,
- x ls_node,ls_nodes,max_ls_nodes,
- x lats_nodes_a,global_lats_a,
- x lats_nodes_r,global_lats_r,
- x lonsperlar,
- x epse,epso,epsedn,epsodn,
- x snnp1ev,snnp1od,ndexev,ndexod,
- x plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r,
- & tstep,phour,sfc_fld, flx_fld, nst_fld, SFALB,
- & xlon,
+ & (phour,kdt,tstep,lonsperlar, global_lats_r,
+ & lsout,fscav,xlon,xlat,
+ & sfc_fld, flx_fld, nst_fld, sfalb,
& swh,hlw,hprime,slag,sdec,cdec,
- & ozplin,jindx1,jindx2,ddy,pdryini,
- & phy_f3d, phy_f2d,xlat,kdt,
- & global_times_b,batah,lsout,fscav)
+ & ozplin,jindx1,jindx2,ddy,
+ & phy_f3d, phy_f2d,
+ & mp_pi,mp_pl,mp_t,mp_q,mp_u,
+ & mp_v,mp_w,mp_tr)
!!
#include "f_hpm.h"
!!
use machine , only : kind_evod,kind_phys,kind_rad
- use resol_def , only : jcap,jcap1,latg,latr,latr2,
- & levh,levp1,levs,lnt2,
- & lonf,lonr,lonrx,lota,lotd,lots,
+ use resol_def , only : jcap,latr,levs,lonr,
& lsoil,ncld,nmtvr,nrcm,ntcw,ntoz,
& ntrac,num_p2d,num_p3d,
- & p_di,p_dlam,p_dphi,p_q,
- & p_rq,p_rt,p_te,p_uln,p_vln,
- & p_w,p_x,p_y,p_ze,p_zq,
& thermodyn_id,sfcpress_id,nfxr
use layout1 , only : ipt_lats_node_r,
& lat1s_r,lats_dim_r,
& lats_node_a,lats_node_r,
- & len_trie_ls,len_trio_ls,
- & lon_dim_r,ls_dim,ls_max_node,
- & me,me_l_0,nodes
- use layout_grid_tracers , only : rg1_a,rg2_a,rg3_a,xhalo,
- & rg1_h,rg2_h,rg3_h,yhalo
+ & me,nodes
use gg_def , only : coslat_r,rcs2_r,sinlat_r,wgt_r
- use vert_def , only : am,bm,del,si,sik,sl,slk,sv
use date_def , only : fhour,idate
use namelist_def , only : crtrh,fhswr,flgmin,
- & gen_coord_hybrid,gg_tracers,
+ & gen_coord_hybrid,ras,
& hybrid,ldiag3d,lscca,lsfwd,
& lsm,lssav,lsswr,ncw,ngptc,
& old_monin,pre_rad,random_clds,
- & ras,semilag,shuff_lats_r,
& sashal,ctei_rm,mom4ice,newsas,
& ccwf,cnvgwd,lggfs3d,trans_trac,
& mstrat,cal_pre,nst_fcst,
@@ -51,58 +36,78 @@
& bkgd_vdif_m, bkgd_vdif_h,
& bkgd_vdif_s,shal_cnv,
& psautco, prautco, evpco, wminco
- use coordinate_def , only : ak5,bk5,vertcoord_id ! hmhj
- use bfilt_def , only : bfilte,bfilto
use module_ras , only : ras_init
use physcons , only : grav => con_g,
- & rerth => con_rerth, ! hmhj
- & fv => con_fvirt, ! mjr
- & rvrdm1 => con_FVirt,
- & rd => con_rd
+ & rerth => con_rerth,
+ & fv => con_fvirt,
+ & rvrdm1 => con_FVirt,
+ & rd => con_rd,
+ & con_rocp
use ozne_def , only : latsozp,levozp,
& pl_coeff,pl_pres,timeoz
-!-> Coupling insertion
- USE SURFACE_cc
-!<- Coupling insertion
+ use gfsmisc_def, only : sinlat_r2, coslat_r2
use Sfc_Flx_ESMFMod
use Nst_Var_ESMFMod
use mersenne_twister
use d3d_def
use tracer_const
-!
- include 'mpif.h'
+
+!-> Coupling insertion
+ USE SURFACE_cc
+!<- Coupling insertion
+
+!-------------------------------------------------------
+!-------------------------------------------------------
implicit none
+ include 'mpif.h'
!
+!---input and output variables
TYPE(Sfc_Var_Data) :: sfc_fld
TYPE(Flx_Var_Data) :: flx_fld
TYPE(Nst_Var_Data) :: nst_fld
-!
- real(kind=kind_phys), PARAMETER :: RLAPSE=0.65E-2
- real(kind=kind_evod), parameter :: cons_0=0.0, cons_24=24.0
- &, cons_99=99.0, cons_1p0d9=1.0E9
-
-!$$$ integer n1rac, n2rac,nlons_v(ngptc)
-!$$$ parameter (n1rac=ntrac-ntshft-1, n2rac=n1rac+1)
-!
-! integer id,njeff,istrt,lon,kdt
- integer id,njeff, lon,kdt
+ integer global_lats_r(latr)
+ integer lonsperlar(latr)
+ real (kind=kind_rad) slag,sdec,cdec,phour
+ real (kind=kind_rad) xlon(lonr,lats_node_r)
+ real (kind=kind_rad) xlat(lonr,lats_node_r)
+ real (kind=kind_rad) coszdg(lonr,lats_node_r),
+ & hprime(lonr,nmtvr,lats_node_r),
+! & fluxr(lonr,nfxr,lats_node_r),
+ & sfalb(lonr,lats_node_r)
+ real (kind=kind_rad) swh(lonr,levs,lats_node_r)
+ real (kind=kind_rad) hlw(lonr,levs,lats_node_r)
!!
- real(kind=kind_evod) save_qe_ls(len_trie_ls,2)
- real(kind=kind_evod) save_qo_ls(len_trio_ls,2)
+ real (kind=kind_phys)
+ & phy_f3d(lonr,levs,num_p3d,lats_node_r),
+ & phy_f2d(lonr,num_p2d,lats_node_r), fscav(ntrac-ncld-1)
- real(kind=kind_evod) sum_k_rqchange_ls(len_trie_ls,2)
- real(kind=kind_evod) sum_k_rqchango_ls(len_trio_ls,2)
-!!
- real(kind=kind_evod) trie_ls(len_trie_ls,2,11*levs+3*levh+6)
- real(kind=kind_evod) trio_ls(len_trio_ls,2,11*levs+3*levh+6)
- real(kind=kind_evod) trie_ls_rqt(len_trie_ls,2,levs)
- real(kind=kind_evod) trio_ls_rqt(len_trio_ls,2,levs)
- real(kind=kind_evod) trie_ls_sfc(len_trie_ls,2) ! hmhj
- real(kind=kind_evod) trio_ls_sfc(len_trio_ls,2) ! hmhj
-!!
- real(kind=kind_phys) typdel(levs), batah
+! --mp_pi : model interface level pressure in centibar
+! --mp_pl : model integer layer pressure in centibar
+! --mp_u : model layer zonal wind in m/s
+! --mp_v : model layer meridional wind in m/s
+! --mp_w : model layer vertical velocity in centibar/sec
+! --mp_t : model layer temperature in K
+! --mp_q : model layer specific humidity in gm/gm
+! --mp_tr : model layer tracer (ozne and cloud water) mass mixing ratio
+ real (kind=kind_phys) ::
+ & mp_pi(lonr,levs+1,lats_node_r) ,
+ & mp_pl(lonr,levs,lats_node_r) ,
+ & mp_t(lonr,levs,lats_node_r) ,
+ & mp_q(lonr,levs,lats_node_r) ,
+ & mp_u(lonr,levs,lats_node_r) ,
+ & mp_v(lonr,levs,lats_node_r) ,
+ & mp_w(lonr,levs,lats_node_r) ,
+ & mp_tr(lonr,levs,ntrac-1,lats_node_r)
+
+ real(kind=kind_evod) gq_save(lonr,lats_dim_r)
+
+
+!----local variables
+ real(kind=kind_evod), parameter :: cons_24=24.0
+ &, cons_99=99.0, cons_1p0d9=1.0E9
+!
real(kind=kind_phys) prsl(ngptc,levs)
real(kind=kind_phys) prslk(ngptc,levs),dpshc(ngptc)
real(kind=kind_phys) prsi(ngptc,levs+1),phii(ngptc,levs+1)
@@ -110,14 +115,11 @@
!!
real (kind=kind_phys) gu(ngptc,levs), gv1(ngptc,levs)
real (kind=kind_phys) ugrd(ngptc,levs),vgrd(ngptc,levs)
- real (kind=kind_phys) gphi(ngptc), glam(ngptc)
real (kind=kind_phys) gq(ngptc), gt(ngptc,levs), pgr(ngptc)
real (kind=kind_phys) gr(ngptc,levs,ntrac)
real (kind=kind_phys) gd(ngptc,levs)
real (kind=kind_phys) adt(ngptc,levs), adr(ngptc,levs,ntrac)
real (kind=kind_phys) adu(ngptc,levs), adv(ngptc,levs)
- real (kind=kind_phys) gtv(ngptc,levs) ! hmhj
- real (kind=kind_phys) gtvx(ngptc,levs), gtvy(ngptc,levs) ! hmhj
real (kind=kind_phys) sumq(ngptc,levs), xcp(ngptc,levs)
!
real (kind=kind_phys) dt3dt_v(ngptc,levs,6),
@@ -127,85 +129,17 @@
&, upd_mf_v(ngptc,levs), dwn_mf_v(ngptc,levs)
&, det_mf_v(ngptc,levs)
&, dkh_v(ngptc,LEVS), rnp_v(ngptc,levs)
-!!
- real(kind=kind_evod) gq_save(lonr,lats_dim_r)
-!!
- real (kind=kind_rad) slag,sdec,cdec,phour
- real (kind=kind_rad) xlon(lonr,lats_node_r)
- real (kind=kind_rad) xlat(lonr,lats_node_r)
- real (kind=kind_rad) coszdg(lonr,lats_node_r),
- & hprime(lonr,nmtvr,lats_node_r),
-! & fluxr(lonr,nfxr,lats_node_r),
- & sfalb(lonr,lats_node_r)
- real (kind=kind_rad) swh(lonr,levs,lats_node_r)
- real (kind=kind_rad) hlw(lonr,levs,lats_node_r)
-!!
- real (kind=kind_phys)
- & phy_f3d(lonr,levs,num_p3d,lats_node_r),
- & phy_f2d(lonr,num_p2d,lats_node_r), fscav(ntrac-ncld-1)
!
-!
real (kind=kind_phys) exp,dtphys,dtp,dtf,sumed(2)
real (kind=kind_evod) tstep
real (kind=kind_phys) pdryini,sigshc,rk
!!
- integer ls_node(ls_dim,3)
-cc
-! ls_node(1,1) ... ls_node(ls_max_node,1) : values of l
-! ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
-! ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
-cc
- integer ls_nodes(ls_dim,nodes)
-cc
- integer max_ls_nodes(nodes)
- integer lats_nodes_a(nodes)
- integer lats_nodes_r(nodes)
-cc
- integer global_lats_a(latg)
- integer global_lats_r(latr)
- integer lonsperlar(latr)
+ integer id,njeff,lon,kdt
integer dimg
-cc
- real(kind=kind_evod) epse(len_trie_ls)
- real(kind=kind_evod) epso(len_trio_ls)
- real(kind=kind_evod) epsedn(len_trie_ls)
- real(kind=kind_evod) epsodn(len_trio_ls)
-cc
- real(kind=kind_evod) snnp1ev(len_trie_ls)
- real(kind=kind_evod) snnp1od(len_trio_ls)
-cc
- integer ndexev(len_trie_ls)
- integer ndexod(len_trio_ls)
-cc
- real(kind=kind_evod) plnev_r(len_trie_ls,latr2)
- real(kind=kind_evod) plnod_r(len_trio_ls,latr2)
- real(kind=kind_evod) pddev_r(len_trie_ls,latr2)
- real(kind=kind_evod) pddod_r(len_trio_ls,latr2)
- real(kind=kind_evod) plnew_r(len_trie_ls,latr2)
- real(kind=kind_evod) plnow_r(len_trio_ls,latr2)
-cc
-c$$$ integer lots,lotd,lota
- integer lotn
-c$$$cc
-c$$$ parameter ( lots = 5*levs+1*levh+3 )
-c$$$ parameter ( lotd = 6*levs+2*levh+0 )
-c$$$ parameter ( lota = 3*levs+1*levh+1 )
-cc
- real(kind=kind_evod) for_gr_r_1(lonrx,lots,lats_dim_r)
- real(kind=kind_evod) dyn_gr_r_1(lonrx,lotd,lats_dim_r) ! hmhj
- real(kind=kind_evod) bak_gr_r_1(lonrx,lota,lats_dim_r)
-cc
-! real(kind=kind_evod) for_gr_r_2(lonrx*lots,lats_dim_r)
-! real(kind=kind_evod) dyn_gr_r_2(lonrx*lotd,lats_dim_r) ! hmhj
-! real(kind=kind_evod) bak_gr_r_2(lonrx*lota,lats_dim_r)
-!
- real(kind=kind_evod) for_gr_r_2(lonr,lots,lats_dim_r)
- real(kind=kind_evod) dyn_gr_r_2(lonr,lotd,lats_dim_r) ! hmhj
- real(kind=kind_evod) bak_gr_r_2(lonr,lota,lats_dim_r)
-cc
+
integer i,ierr,iter,j,k,kap,kar,kat,kau,kav,ksq,jj,kk
integer kst,kdtphi,kdtlam ! hmhj
- integer l,lan,lan0,lat,lmax,locl,ii,lonrbm
+ integer l,lan,lat,lmax,locl,ii,lonrbm
! integer lon_dim,lons_lat,n,node
integer lons_lat,n,node
integer nsphys
@@ -214,84 +148,11 @@
& pwatp,ptotg(latr),sumwa,sumto,
& ptotj(lats_node_r),pcorr,pdryg,
& solhr,clstp
-cc
- integer ipt_ls ! hmhj
- real(kind=kind_evod) reall ! hmhj
- real(kind=kind_evod) rlcs2(jcap1) ! hmhj
-
- real(kind=kind_evod) typical_pgr
-c
-!timers______________________________________________________---
-
- real*8 rtc ,timer1,timer2
- real(kind=kind_evod) global_times_b(latr,nodes)
-
-!timers______________________________________________________---
-cc
-cc
-c$$$ parameter(ksq =0*levs+0*levh+1,
-c$$$ x ksplam =0*levs+0*levh+2,
-c$$$ x kspphi =0*levs+0*levh+3,
-c$$$ x ksu =0*levs+0*levh+4,
-c$$$ x ksv =1*levs+0*levh+4,
-c$$$ x ksz =2*levs+0*levh+4,
-c$$$ x ksd =3*levs+0*levh+4,
-c$$$ x kst =4*levs+0*levh+4,
-c$$$ x ksr =5*levs+0*levh+4)
-cc
-c$$$ parameter(kdtphi =0*levs+0*levh+1,
-c$$$ x kdrphi =1*levs+0*levh+1,
-c$$$ x kdtlam =1*levs+1*levh+1,
-c$$$ x kdrlam =2*levs+1*levh+1,
-c$$$ x kdulam =2*levs+2*levh+1,
-c$$$ x kdvlam =3*levs+2*levh+1,
-c$$$ x kduphi =4*levs+2*levh+1,
-c$$$ x kdvphi =5*levs+2*levh+1)
-cc
-c$$$ parameter(kau =0*levs+0*levh+1,
-c$$$ x kav =1*levs+0*levh+1,
-c$$$ x kat =2*levs+0*levh+1,
-c$$$ x kar =3*levs+0*levh+1,
-c$$$ x kap =3*levs+1*levh+1)
-cc
-cc
-c$$$ integer p_gz,p_zem,p_dim,p_tem,p_rm,p_qm
-c$$$ integer p_ze,p_di,p_te,p_rq,p_q,p_dlam,p_dphi,p_uln,p_vln
-c$$$ integer p_w,p_x,p_y,p_rt,p_zq
-c$$$cc
-c$$$cc old common /comfspec/
-c$$$ parameter(p_gz = 0*levs+0*levh+1, ! gze/o(lnte/od,2),
-c$$$ x p_zem = 0*levs+0*levh+2, ! zeme/o(lnte/od,2,levs),
-c$$$ x p_dim = 1*levs+0*levh+2, ! dime/o(lnte/od,2,levs),
-c$$$ x p_tem = 2*levs+0*levh+2, ! teme/o(lnte/od,2,levs),
-c$$$ x p_rm = 3*levs+0*levh+2, ! rme/o(lnte/od,2,levh),
-c$$$ x p_qm = 3*levs+1*levh+2, ! qme/o(lnte/od,2),
-c$$$ x p_ze = 3*levs+1*levh+3, ! zee/o(lnte/od,2,levs),
-c$$$ x p_di = 4*levs+1*levh+3, ! die/o(lnte/od,2,levs),
-c$$$ x p_te = 5*levs+1*levh+3, ! tee/o(lnte/od,2,levs),
-c$$$ x p_rq = 6*levs+1*levh+3, ! rqe/o(lnte/od,2,levh),
-c$$$ x p_q = 6*levs+2*levh+3, ! qe/o(lnte/od,2),
-c$$$ x p_dlam= 6*levs+2*levh+4, ! dpdlame/o(lnte/od,2),
-c$$$ x p_dphi= 6*levs+2*levh+5, ! dpdphie/o(lnte/od,2),
-c$$$ x p_uln = 6*levs+2*levh+6, ! ulne/o(lnte/od,2,levs),
-c$$$ x p_vln = 7*levs+2*levh+6, ! vlne/o(lnte/od,2,levs),
-c$$$ x p_w = 8*levs+2*levh+6, ! we/o(lnte/od,2,levs),
-c$$$ x p_x = 9*levs+2*levh+6, ! xe/o(lnte/od,2,levs),
-c$$$ x p_y =10*levs+2*levh+6, ! ye/o(lnte/od,2,levs),
-c$$$ x p_rt =11*levs+2*levh+6, ! rte/o(lnte/od,2,levh),
-c$$$ x p_zq =11*levs+3*levh+6) ! zqe/o(lnte/od,2)
-cc
-cc
- integer indlsev,jbasev,n0
- integer indlsod,jbasod
-cc
- include 'function2'
-cc
real(kind=kind_evod) cons0,cons2 !constant
-cc
+
logical lsout
logical, parameter :: flipv = .true.
-cc
+
! for nasa/nrl ozone production and distruction rates:(input through fixio)
real ozplin(latsozp,levozp,pl_coeff,timeoz)
integer jindx1(lats_node_r),jindx2(lats_node_r)!for ozone interpolaton
@@ -302,8 +163,6 @@
real(kind=kind_phys), allocatable :: acv(:,:),acvb(:,:),acvt(:,:)
save acv,acvb,acvt
!!
-! integer, parameter :: maxran=5000
-! integer, parameter :: maxran=3000
integer, parameter :: maxran=6000, maxsub=6, maxrs=maxran/maxsub
type (random_stat) :: stat(maxrs)
real (kind=kind_phys), allocatable, save :: rannum_tank(:,:,:)
@@ -315,7 +174,6 @@
logical first,ladj
parameter (ladj=.true.)
data first/.true./
-! save krsize, first, nrnd,seed0
save first, seed0
!!
integer nlons_v(ngptc)
@@ -329,11 +187,10 @@
&, rannum_v(ngptc,nrcm)
real(kind=kind_phys) sinlat_v(ngptc),coslat_v(ngptc)
&, ozplout_v(ngptc,levozp,pl_coeff)
- real (kind=kind_rad) rqtk(ngptc), rcs2_lan, rcs_lan
-! real (kind=kind_rad) rcs_v(ngptc), rqtk(ngptc), rcs2_lan
+ real (kind=kind_rad) rqtk(ngptc)
+! real (kind=kind_rad) rcs_v(ngptc), rqtk(ngptc)
!
!--------------------------------------------------------------------
-! print *,' in gloopb vertcoord_id =',vertcoord_id
! real(kind=kind_evod) sinlat_v(lonr),coslat_v(lonr),rcs2_v(lonr)
! real(kind=kind_phys) dpshc(lonr)
@@ -341,7 +198,6 @@
parameter (qmin=1.0e-10)
integer ksd,ksplam,kspphi
integer ksu,ksv,ksz,item,jtem,ktem,ltem,mtem
-
!
! --- for debug test use
real (kind=kind_phys) :: temlon, temlat, alon, alat
@@ -349,90 +205,15 @@
logical :: lprnt
!
!
- ksq =0*levs+0*levh+1
- ksplam =0*levs+0*levh+2
- kspphi =0*levs+0*levh+3
- ksu =0*levs+0*levh+4
- ksv =1*levs+0*levh+4
- ksz =2*levs+0*levh+4
- ksd =3*levs+0*levh+4
- kst =4*levs+0*levh+4
- ksr =5*levs+0*levh+4
-!
- kau =0*levs+0*levh+1
- kav =1*levs+0*levh+1
- kat =2*levs+0*levh+1
- kap =3*levs+0*levh+1
- kar =3*levs+0*levh+2
-!
-! ksq = 0*levs + 0*levh + 1
-! kst = 4*levs + 0*levh + 4 ! hmhj
- kdtphi = 0*levs + 0*levh + 1 ! hmhj
- kdtlam = 1*levs+1*levh+1 ! hmhj
-!
-c$$$ kau =0*levs+0*levh+1
-c$$$ kav =1*levs+0*levh+1
-c$$$ kat =2*levs+0*levh+1
-c$$$ kar =3*levs+0*levh+1
-c$$$ kap =3*levs+1*levh+1
-cc
-cc--------------------------------------------------------------------
-cc
- save_qe_ls(:,:) = trie_ls(:,:,p_q)
- save_qo_ls(:,:) = trio_ls(:,:,p_q)
-
-
-!
+!----------------------
if (first) then
- allocate (bfilte(lnt2),bfilto(lnt2))
-!
-! initializations for the gloopb filter
-! *************************************
- nf0 = (jcap+1)*2/3 ! highest wavenumber gloopb filter keeps fully
- nf1 = (jcap+1) ! lowest wavenumber gloopb filter removes fully
- fd2 = 1./(nf1-nf0)**2
- do locl=1,ls_max_node
- l = ls_node(locl,1)
- jbasev = ls_node(locl,2)
-!sela if (l.eq.0) then
-!sela n0=2
-!sela else
-!sela n0=l
-!sela endif
-!
-!sela indev = indlsev(n0,l)
- indev = indlsev(l,l)
-!sela do n=n0,jcap1,2
-!mjr do n=l,jcap1,2
- do n=l,jcap,2
- bfilte(indev) = max(1.-fd2*max(n-nf0,0)**2,cons_0) !constant
- indev = indev + 1
- enddo
- if (mod(L,2).eq.mod(jcap+1,2)) bfilte(indev) = 1.
- enddo
-!!
- do locl=1,ls_max_node
- l = ls_node(locl,1)
- jbasod = ls_node(locl,3)
- indod = indlsod(l+1,l)
-!mjr do n=l+1,jcap1,2
- do n=l+1,jcap,2
- bfilto(indod) = max(1.-fd2*max(n-nf0,0)**2,cons_0) !constant
- indod = indod+1
- enddo
- if (mod(L,2).ne.mod(jcap+1,2)) bfilto(indod) = 1.
- enddo
-!!
-! call random_seed(size=krsize)
-! if (me.eq.0) print *,' krsize=',krsize
-! allocate (nrnd(krsize))
+!----------------------
+
allocate (acv(lonr,lats_node_r))
allocate (acvb(lonr,lats_node_r))
allocate (acvt(lonr,lats_node_r))
!
seed0 = idate(1) + idate(2) + idate(3) + idate(4)
-
-
call random_setseed(seed0)
call random_number(wrk)
seed0 = seed0 + nint(wrk(1)*1000.0)
@@ -484,19 +265,14 @@
if (ras) call ras_init(levs, me)
first = .false.
+!----------------------
endif ! if (first) done
+!----------------------
!
-! print *,' after if(first) before if semilag'
-
- if (semilag) then
- dtp = tstep
- dtf = tstep
- else
dtphys = 3600.
nsphys = max(int((tstep+tstep)/dtphys+0.9999),1)
dtp = (tstep+tstep)/nsphys
dtf = 0.5*dtp
- endif
!
if(lsfwd) dtf = dtp
!
@@ -543,458 +319,64 @@
! if (me == 0) write(0,*)' after ozinterpol'
!!
-c ----------------------------------------------------
-cc................................................................
-cc
-cc
- call f_hpmstart(41,"gb delnpe")
- call delnpe(trie_ls(1,1,p_zq ),
- x trio_ls(1,1,p_dphi),
- x trie_ls(1,1,p_dlam),
- x epse,epso,ls_node)
- call f_hpmstop(41)
-cc
- call f_hpmstart(42,"gb delnpo")
- call delnpo(trio_ls(1,1,p_zq ),
- x trie_ls(1,1,p_dphi),
- x trio_ls(1,1,p_dlam),
- x epse,epso,ls_node)
- call f_hpmstop(42)
-cc
-cc
- call f_hpmstart(43,"gb dezouv dozeuv")
-!$OMP parallel do shared(trie_ls,trio_ls)
-!$OMP+shared(epsedn,epsodn,snnp1ev,snnp1od,ls_node)
-!$OMP+private(k)
- do k=1,levs
- call dezouv(trie_ls(1,1,p_x +k-1), trio_ls(1,1,p_w +k-1),
- x trie_ls(1,1,p_uln+k-1), trio_ls(1,1,p_vln+k-1),
- x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
-cc
- call dozeuv(trio_ls(1,1,p_x +k-1), trie_ls(1,1,p_w +k-1),
- x trio_ls(1,1,p_uln+k-1), trie_ls(1,1,p_vln+k-1),
- x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
- enddo
- call f_hpmstop(43)
-cc
-! call mpi_barrier (mpi_comm_world,ierr)
-cc
- call countperf(0,4,0.)
- call synctime()
- call countperf(1,4,0.)
-!!
- dimg=0
- call countperf(0,1,0.)
-cc
-! call f_hpmstart(48,"gb syn_ls2lats")
-cc
-! call f_hpmstop(48)
-cc
- call f_hpmstart(49,"gb sumfln")
-cc
- call sumfln_slg_gg(trie_ls(1,1,p_q),
- x trio_ls(1,1,p_q),
- x lat1s_r,
- x plnev_r,plnod_r,
- x 5*levs+3,ls_node,latr2,
- x lats_dim_r,lots,for_gr_r_1,
- x ls_nodes,max_ls_nodes,
- x lats_nodes_r,global_lats_r,
-!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
- x lats_node_r,ipt_lats_node_r,lon_dim_r,
- x lonsperlar,lonrx,latr,0)
-!!
- if(.not.gg_tracers)then
- call sumfln_slg_gg(trie_ls(1,1,p_rt),
- x trio_ls(1,1,p_rt),
- x lat1s_r,
- x plnev_r,plnod_r,
- x levh,ls_node,latr2,
- x lats_dim_r,lots,for_gr_r_1,
- x ls_nodes,max_ls_nodes,
- x lats_nodes_r,global_lats_r,
-!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
- x lats_node_r,ipt_lats_node_r,lon_dim_r,
- x lonsperlar,lonrx,latr,5*levs+3)
- endif ! if(.not.gg_tracers)then
-cc
- call f_hpmstop(49)
-cc
- call countperf(1,1,0.)
-cc
-! print *,' in GLOOPB after second sumfln'
-cc
pwatg = 0.
ptotg = 0.
-!--------------------
-! if( vertcoord_id == 3. ) then ! For sigms/p/theta
-!--------------------
- call countperf(0,11,0.)
- CALL countperf(0,1,0.) ! hmhj
- call f_hpmstart(50,"gb sumder2") ! hmhj
-!
- do lan=1,lats_node_r
- timer1=rtc()
- lat = global_lats_r(ipt_lats_node_r-1+lan)
- lmax = min(jcap,lonsperlar(lat)/2)
- if ( (lmax+1)*2+1 .le. lonsperlar(lat)+2 ) then
- do k=levs+1,4*levs+2*levh
- do i = (lmax+1)*2+1, lonsperlar(lat)+2
- dyn_gr_r_1(i,k,lan) = cons0 !constant
- enddo
- enddo
- endif
- enddo
-!
- call sumder2_slg(trie_ls(1,1,P_te), ! hmhj
- x trio_ls(1,1,P_te), ! hmhj
- x lat1s_r, ! hmhj
- x pddev_r,pddod_r, ! hmhj
- x levs,ls_node,latr2, ! hmhj
- x lats_dim_r,lotd, ! hmhj
- x dyn_gr_r_1, ! hmhj
- x ls_nodes,max_ls_nodes, ! hmhj
- x lats_nodes_r,global_lats_r, ! hmhj
-!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r, ! hmhj
- x lats_node_r,ipt_lats_node_r,lon_dim_r, ! hmhj
- x lonsperlar,lonrx,latr,0) ! hmhj
-!
- call f_hpmstop(50) ! hmhj
- CALL countperf(1,1,0.)
-! -----------------
-! endif
-! -----------------
-cc
do lan=1,lats_node_r
- timer1=rtc()
-! if (me == 0) print *,' In lan loop lan=', lan
-cc
-
lat = global_lats_r(ipt_lats_node_r-1+lan)
-! lon_dim = lon_dims_r(lan)
-cc
lons_lat = lonsperlar(lat)
-!-----------------------------------------
-! if( vertcoord_id == 3. ) then
-!-----------------------------------------
-
-!! calculate t rq u v zonal derivs. by multiplication with i*l
-!! note rlcs2=rcs2*L/rerth
-
- lmax = min(jcap,lons_lat/2) ! hmhj
-!
- ipt_ls=min(lat,latr-lat+1) ! hmhj
-
- do i=1,lmax+1 ! hmhj
- if ( ipt_ls .ge. lat1s_r(i-1) ) then ! hmhj
- reall=i-1 ! hmhj
- rlcs2(i)=reall*rcs2_r(ipt_ls)/rerth ! hmhj
- else ! hmhj
- rlcs2(i)=cons0 !constant ! hmhj
- endif ! hmhj
- enddo ! hmhj
-!
-!$omp parallel do private(k,i)
- do k=1,levs ! hmhj
- do i=1,lmax+1 ! hmhj
-!
-! d(t)/d(lam) ! hmhj
- dyn_gr_r_1(2*i-1,(kdtlam-1+k),lan)= ! hmhj
- x -for_gr_r_1(2*i ,(kst -1+k),lan)*rlcs2(i) ! hmhj
- dyn_gr_r_1(2*i ,(kdtlam-1+k),lan)= ! hmhj
- x for_gr_r_1(2*i-1,(kst -1+k),lan)*rlcs2(i) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
-! -----------------------
-! endif
-! -----------------------
-
-! print *,' in GLOOPB before four_to_grid'
-cc
- call countperf(0,6,0.)
- call four_to_grid(for_gr_r_1(1,1,lan),for_gr_r_2(1,1,lan),
-!mjr & lon_dim ,lon_dim ,lons_lat,5*levs+3)
- & lon_dim_r,lon_dim_r-2,lons_lat,5*levs+3)
-
- if(.not.gg_tracers)then
- CALL FOUR_TO_GRID(for_gr_r_1(1,ksr,lan),
- & for_gr_r_2(1,ksr,lan),
-!mjr & lon_dim ,lon_dim ,lons_lat,levh)
- & lon_dim_r,lon_dim_r-2,lons_lat,levh)
- else ! gg_tracers
- if (.not.shuff_lats_r) then
-! set for_gr_r_2 to rg1_a rg2_a rg3_a from gloopa
- do k=1,levs
- do i=1,min(lonf,lons_lat)
- for_gr_r_2(i,ksr-1+k ,lan)=
- & rg1_a(i,k,lats_node_a+1-lan)
- for_gr_r_2(i,ksr-1+k+ levs,lan)=
- & rg2_a(i,k,lats_node_a+1-lan)
- for_gr_r_2(i,ksr-1+k+2*levs,lan)=
- & rg3_a(i,k,lats_node_a+1-lan)
- enddo
- enddo
- endif ! not shuff_lats_r
- endif ! gg_tracers
-
-! print *,' in GLOOPB after four_to_grid '
-! ----------------------------------
-! if( vertcoord_id == 3. ) then
-! ----------------------------------
- CALL FOUR_TO_GRID(dyn_gr_r_1(1,kdtphi,lan), ! hmhj
- & dyn_gr_r_2(1,kdtphi,lan), ! hmhj
-!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
- & lon_dim_r,lon_dim_r-2,lons_lat,levs) ! hmhj
- CALL FOUR_TO_GRID(dyn_gr_r_1(1,kdtlam,lan), ! hmhj
- & dyn_gr_r_2(1,kdtlam,lan), ! hmhj
-!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
- & lon_dim_r,lon_dim_r-2,lons_lat,levs) ! hmhj
-! ----------------------------
-! endif
-! ---------------------------
- call countperf(1,6,0.)
-!
- timer2 = rtc()
- global_times_b(lat,me+1) = timer2-timer1
-c$$$ print*,'timeloopb',me,timer1,timer2,global_times_b(lat,me+1)
-!!
- enddo !lan
-cc
-
- if(gg_tracers .and. shuff_lats_r) then
-! print*,' gloopb mpi_tracers_a_to_b shuff_lats_r',shuff_lats_r
- call mpi_tracers_a_to_b(
- x rg1_a,rg2_a,rg3_a,lats_nodes_a,global_lats_a,
- x for_gr_r_2(1,1,1),
- x lats_nodes_r,global_lats_r,ksr,0)
- endif ! gg_tracers .and. shuff_lats_r
-
- call f_hpmstart(51,"gb lat_loop2")
-
- do lan=1,lats_node_r
-
-!
- lat = global_lats_r(ipt_lats_node_r-1+lan)
-cc
-! lon_dim = lon_dims_r(lan)
- lons_lat = lonsperlar(lat)
pwatp = 0.
- rcs2_lan = rcs2_r(min(lat,latr-lat+1))
- rcs_lan = sqrt(rcs2_lan)
!$omp parallel do schedule(dynamic,1) private(lon)
!$omp+private(sumq,xcp,hprime_v,swh_v,hlw_v,stc_v,smc_v,slc_v)
!$omp+private(nlons_v,sinlat_v,coslat_v,ozplout_v,rannum_v)
!$omp+private(prslk,prsl,prsik,prsi,phil,phii,dpshc,work1,tem)
-!$omp+private(gu,gv1,gd,gq,gphi,glam,gt,gtv,gr,vvel,gtvx,gtvy)
+!$omp+private(gu,gv1,gd,gq,gt,gtv,gr,vvel)
!$omp+private(adt,adr,adu,adv,pgr,ugrd,vgrd,rqtk)
-!!$omp+private(adt,adr,adu,adv,pgr,rcs_v,ugrd,vgrd,rqtk)
!$omp+private(phy_f3dv,phy_f2dv)
!$omp+private(dt3dt_v,dq3dt_v,du3dt_v,dv3dt_v,upd_mf_v,dwn_mf_v)
!$omp+private(det_mf_v,dkh_v,rnp_v)
!$omp+private(njeff,item,jtem,ktem,i,j,k,n,kss)
-!!!$omp+private(temlon,temlat,lprnt,ipt)
+
do lon=1,lons_lat,ngptc
!!
njeff = min(ngptc,lons_lat-lon+1)
!!
! lprnt = .false.
-!
-! --- ... for debug test
-! alon = 236.25
-! alat = 56.189
-! alon = 26.25
-! alat = 6.66
-! ipt = 0
-! do i = 1, njeff
-! item = lon + i - 1
-! temlon = xlon(item,lan) * 57.29578
-! if (temlon < 0.0) temlon = temlon + 360.0
-! temlat = xlat(item,lan) * 57.29578
-! lprnt = abs(temlon-alon) < 1.1 .and. abs(temlat-alat) < 1.1
-! & .and. kdt > 0
-! if ( lprnt ) then
-! ipt = i
-! exit
-! endif
-! enddo
-! lprnt = .false.
-!!
- do k = 1, LEVS
- do j = 1, njeff
- jtem = lon-1+j
- gu (j,k) = for_gr_r_2(jtem,KSU-1+k,lan)
- gv1(j,k) = for_gr_r_2(jtem,KSV-1+k,lan)
- gd (j,k) = for_gr_r_2(jtem,KSD-1+k,lan)
- enddo
- enddo
-!
-! p in cb by finite difference from henry juang not ln(p) ! hmhj
- if(.not.gen_coord_hybrid) then ! hmhj
- do j=1,njeff
- item = lon+j-1
- for_gr_r_2(item,ksq,lan) = exp(for_gr_r_2(item,ksq,lan))
- enddo
- endif ! .not.gen_coord_hybrid ! hmhj
- do i=1,njeff
- item = lon+i-1
- gq(i) = for_gr_r_2(item,ksq,lan)
- gphi(i) = for_gr_r_2(item,kspphi,lan)
- glam(i) = for_gr_r_2(item,ksplam,lan)
- enddo
-! Tracers
- do n=1,ntrac
- do k=1,levs
- item = KSR-1+k+(n-1)*levs
- do j=1,njeff
- gr(j,k,n) = for_gr_r_2(lon-1+j,item,lan)
- enddo
- enddo
- enddo
-!
-! For omega in gen_coord_hybrid ! hmhj
-! the same variables for thermodyn_id=3 for enthalpy ! hmhj
- if( gen_coord_hybrid ) then
- do k=1,levs ! hmhj
- do j=1,njeff ! hmhj
- gtv(j,k) = for_gr_r_2(lon-1+j,kst-1+k,lan)
- enddo
- enddo
-! --------------------------------------
- if( vertcoord_id.eq.3. ) then
-! --------------------------------------
- do k=1,levs ! hmhj
- do j=1,NJEFF ! hmhj
- jtem = lon-1+j
- gtvx(j,k) = dyn_gr_r_2(jtem,kdtlam-1+k,lan)
- gtvy(j,k) = dyn_gr_r_2(jtem,kdtphi-1+k,lan)
- enddo ! hmhj
- enddo
-! -----------------------------
- endif
-! -----------------------------
- if( thermodyn_id.eq.3 ) then ! hmhj
-! get dry temperature from enthalpy ! hmhj
- do k=1,levs
- do j=1,njeff
- sumq(j,k) = 0.0
- xcp(j,k) = 0.0
- enddo
- enddo
- do n=1,ntrac ! hmhj
- if( cpi(n).ne.0.0 ) then ! hmhj
- kss = ksr+(n-1)*levs ! hmhj
- do k=1,levs ! hmhj
- ktem = kss+k-1
- do j=1,njeff ! hmhj
- sumq(j,k) = sumq(j,k) + gr(j,k,n) ! hmhj
- xcp(j,k) = xcp(j,k) + cpi(n)*gr(j,k,n) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- endif ! hmhj
- enddo ! hmhj
- do k=1,levs ! hmhj
- do j=1,njeff ! hmhj
- work1 = (1.-sumq(j,k))*cpi(0) + xcp(j,k) ! hmhj
- gt(j,k) = gtv(j,k) / work1 ! hmhj
- enddo ! hmhj
- enddo ! hmhj
-! get dry temperature from virtual temperature ! hmhj
- else if( thermodyn_id.le.1 ) then ! hmhj
- do k=1,levs
- do j=1,njeff
- gt(j,k) = gtv(j,k) / (1.0 + fv*max(gr(j,k,1),qmin))
- enddo
- enddo
- else
-! get dry temperature from dry temperature ! hmhj
- do k=1,levs ! hmhj
- do j=1,njeff ! hmhj
- gt(j,k) = gtv(j,k) ! hmhj
- enddo ! hmhj
- enddo
- endif ! if(thermodyn_id.eq.3)
- else
- do k=1,levs
- do j=1,njeff
- gt(j,k) = for_gr_r_2(lon+j-1,kst+k-1,lan)
- & / (1.0 + fv*max(gr(j,k,1),qmin))
- enddo
- enddo
-
- endif ! if(gen_coord_hybrid)
-!
- do j=1,njeff
- item = lon+j-1
- gq_save(item,lan) = for_gr_r_2(item,ksq,lan)
+ do k=1,levs+1
+ do j=1,njeff
+ jtem = lon-1+j
+ prsi(j,k) = mp_pi(jtem,k,lan) *1000.0 !from cb to Pa
+ prsik(j,k) = (1.e0-5*prsi(j,k))**con_rocp
+ enddo
+ enddo
+ do k=1,levs
+ do j=1,njeff
+ jtem = lon-1+j
+ vvel(j,k) = mp_w(jtem,k,lan) *1000.0 !from cb/s to pa/s
+ prsl(j,k) = mp_pl(jtem,k,lan) *1000.0 !from cb to pa
+ prslk(j,k) = (1.0e-5*prsl(j,k))**con_rocp
+ ugrd(j,k) = mp_u(jtem,k,lan)
+ vgrd(j,k) = mp_v(jtem,k,lan)
+ gt(j,k) = mp_t(jtem,k,lan)
+ gr(j,k,1) = mp_q(jtem,k,lan)
+ do n=1,ntrac-1
+ gr(j,k,n+1) = mp_tr(jtem,k,n,lan)
enddo
-!
-! if (lprnt) then
-! print *,' gq=',gq(ipt),' gphi=',gphi(ipt),glam(ipt)
-! print *,' gd=',gd(ipt,:)
-! print *,' gu=',gu(ipt,:)
-! print *,' gv1=',gv1(ipt,:)
-! endif
-! hmhj for gen_coord_hybrid
- if( gen_coord_hybrid ) then ! hmhj
+ enddo
+ enddo
- call hyb2press_gc(njeff,ngptc,gq, gtv, prsi,prsl ! hmhj
- &, prsik, prslk)
-! call omegtes_gc(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)), ! hmhj
- call omegtes_gc(njeff,ngptc,rcs2_lan, ! hmhj
- & gq,gphi,glam,gtv,gtvx,gtvy,gd,gu,gv1,vvel) ! hmhj
- elseif( hybrid )then ! hmhj
-! vertical structure variables: del,si,sl
-
-! if (lprnt) print *,' ipt=',ipt,' ugrb=',gu(ipt,levs),
-! &' vgrb=',gv1(ipt,levs),' lon=',lon
-! &,' xlon=',xlon(lon+ipt-1,lan),' xlat=',xlat(lon+ipt-1,lan)
-
- call hyb2press(njeff,ngptc,gq, prsi, prsl,prsik,prslk)
-! call omegtes(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)),
- call omegtes(njeff,ngptc,rcs2_lan,
- & gq,gphi,glam,gd,gu,gv1,vvel)
-! & gq,gphi,glam,gd,gu,gv1,vvel,lprnt,ipt)
-
-! if (lprnt) then
-! print *,' vvel=',vvel(ipt,:)
-! call mpi_quit(9999)
-! endif
- else ! for sigma coordinate
- call sig2press(njeff,ngptc,gq,sl,si,slk,sik,
- & prsi,prsl,prsik,prslk)
- call omegast3(njeff,ngptc,levs,
- & gphi,glam,gu,gv1,gd,del,rcs2_lan,vvel,gq,sl)
-! & gphi,glam,gu,gv1,gd,del,
-! & rcs2_r(min(lat,latr-lat+1)),vvel,gq,sl)
-
- endif
-!
- do i=1,njeff
- phil(i,levs) = 0.0 ! forces calculation of geopotential in gbphys
- pgr(i) = gq(i) * 1000.0 ! Convert from kPa to Pa for physics
- prsi(i,1) = pgr(i)
+ do i=1,njeff
+ phil(i,levs) = 0.0 ! forces calculation of geopotential in gbphys
+ pgr(i) = prsi(i,1)
dpshc(i) = 0.3 * prsi(i,1)
-!
nlons_v(i) = lons_lat
- sinlat_v(i) = sinlat_r(lat)
- coslat_v(i) = coslat_r(lat)
-! rcs_v(i) = sqrt(rcs2_lan)
-! rcs_v(i) = sqrt(rcs2_r(min(lat,latr-lat+1)))
+ sinlat_v(i) = sinlat_r2(lon,lat)
+ coslat_v(i) = coslat_r2(lon,lat)
enddo
- do k=1,levs
- do i=1,njeff
- ugrd(i,k) = gu(i,k) * rcs_lan
- vgrd(i,k) = gv1(i,k) * rcs_lan
-! ugrd(i,k) = gu(i,k) * rcs_v(i)
-! vgrd(i,k) = gv1(i,k) * rcs_v(i)
- prsl(i,k) = prsl(i,k) * 1000.0
- prsi(i,k+1) = prsi(i,k+1) * 1000.0
- vvel(i,k) = vvel(i,k) * 1000.0 ! Convert from Cb/s to Pa/s
- enddo
- enddo
+
+!
if (gen_coord_hybrid .and. thermodyn_id == 3) then
do i=1,ngptc
prslk(i,1) = 0.0 ! forces calculation of geopotential in gbphys
@@ -1200,163 +582,33 @@
& nst_fld%c_0 (lon,lan), nst_fld%c_d(lon,lan), &
& nst_fld%w_0 (lon,lan), nst_fld%w_d(lon,lan), &
& rqtk &! rqtkD
-! & bak_gr_r_2(lon,kap,lan), &! rqtkD
& )
!!
- do k=1,levs
- do i=1,njeff
- item = lon + i - 1
- bak_gr_r_2(item,kau+k-1,lan) = adu(i,k) * rcs_lan
- bak_gr_r_2(item,kav+k-1,lan) = adv(i,k) * rcs_lan
-! bak_gr_r_2(item,kau+k-1,lan) = adu(i,k) * rcs_v(i)
-! bak_gr_r_2(item,kav+k-1,lan) = adv(i,k) * rcs_v(i)
- bak_gr_r_2(item,kat+k-1,lan) = adt(i,k)
- enddo
- enddo
- do n=1,ntrac
- do k=1,levs
- ktem = kar+k-1+(n-1)*levs
- do i=1,njeff
- item = lon + i - 1
- bak_gr_r_2(item,ktem,lan) = adr(i,k,n)
- enddo
- enddo
- enddo
- if (gg_tracers) then
- do i=1,njeff
- bak_gr_r_2(lon+i-1,kap,lan) = rqtk(i)
- enddo
- else
- do i=1,njeff
- bak_gr_r_2(lon+i-1,kap,lan) = 0.0
- enddo
- endif
!!
-!<-- cpl insertion: instantanious variables
- do i=1,njeff
- item = lon+i-1
- U_BOT_cc(item,lan) = adu(i,1)
- V_BOT_cc(item,lan) = adv(i,1)
- Q_BOT_cc(item,lan) = adr(i,1,1)
- P_BOT_cc(item,lan) = prsl(i,1)
- P_SURF_cc(item,lan) = prsi(i,1)
- enddo
+ prsi = prsi * 0.001 ! Convert from Pa to kPa
- do i=1,njeff
- item = lon+i-1
- T_BOT_cc(item,lan) = adt(i,1)
- tem = adt(i,1)*(1+RVRDM1*adr(i,1,1))
- Z_BOT_cc(item,lan) = -(RD/grav)*tem
- & * LOG(prsl(i,1)/prsi(i,1))
-!
- ffmm_cc(item,lan) = sfc_fld%ffmm(item,lan)
- ffhh_cc(item,lan) = sfc_fld%ffhh(item,lan)
- if (sfc_fld%SLMSK(item,lan) .lt. 0.01) then
- T_SFC_cc(item,lan) = sfc_fld%tsea(item,lan)
- & + sfc_fld%oro(item,lan)*RLAPSE
- else
- T_SFC_cc(item,lan) = sfc_fld%tsea(item,lan)
- end if
- FICE_SFC_cc(item,lan) = sfc_fld%fice(item,lan)
- HICE_SFC_cc(item,lan) = sfc_fld%hice(item,lan)
- & * sfc_fld%fice(item,lan)
+!---prepare output
+ do k=1,levs+1
+ do j=1,njeff
+ jtem = lon-1+j
+ mp_pi(jtem,k,lan)=0.001*prsi(j,k) !convert from pa to cb
+ enddo
+ enddo
+ do k=1,levs
+ do j=1,njeff
+ jtem = lon-1+j
+ mp_w(jtem,k,lan) = 0.001*vvel(j,k) !from pa/s to cb/s
+ mp_pl(jtem,k,lan) = 0.001*prsl(j,k) !convert from pa to cb
+ mp_u(jtem,k,lan) = ugrd(j,k)
+ mp_v(jtem,k,lan) = vgrd(j,k)
+ mp_t(jtem,k,lan) = gt(j,k)
+ mp_q(jtem,k,lan) = gr(j,k,1) !specific humidity
+ do n=1,ntrac-1
+ mp_tr(jtem,k,n,lan) = gr(j,k,n+1)
enddo
-! do i=istrt,istrt+njeff-1
-! if (ffmm_cc(i,lan).LT.1.0) print *,'ffmm_cc<1',ffmm_cc(i,lan)
-! if (ffhh_cc(i,lan).LT.1.0) print *,'ffhh_cc<1',ffmm_cc(i,lan)
-! enddo
-! if (me .eq. 0) then
-! call atm_maxmin(njeff,1,LPREC_cc(lon,lan),
-! > 'in gbphys_call, LPREC_cc')
-! print *,'after cpl,istrt=',istrt,'istrt+njeff-1=',
-! > istrt+njeff-1,'lan=',lan
-! endif
-!--> cpl insertion
+ enddo
+ enddo
- if( gen_coord_hybrid .and. thermodyn_id.eq.3 ) then ! hmhj
-
-! convert dry temperature to enthalpy ! hmhj
- do k=1,levs
- do j=1,njeff
- item = lon+j-1
- sumq(j,k) = 0.0
- xcp(j,k) = 0.0
- enddo
- enddo
- do i=1,ntrac ! hmhj
- kss = kar+(i-1)*levs
- if( cpi(i).ne.0.0 ) then ! hmhj
- do k=1,levs ! hmhj
- ktem = kss+k-1
- do j=1,njeff ! hmhj
- item = lon+j-1
- work1 = bak_gr_r_2(item,ktem,lan) ! hmhj
- sumq(j,k) = sumq(j,k) + work1 ! hmhj
- xcp(j,k) = xcp(j,k) + cpi(i)*work1 ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- endif ! hmhj
- enddo ! hmhj
- do k=1,levs ! hmhj
- ktem = kat+k-1
- do j=1,njeff ! hmhj
- item = lon+j-1
- work1 = (1.-sumq(j,k))*cpi(0) + xcp(j,k) ! hmhj
- bak_gr_r_2(item,ktem,lan) = bak_gr_r_2(item,ktem,lan)
- & * work1 ! hmhj
- adt(j,k) = adt(j,k)*work1
- enddo ! hmhj
- enddo ! hmhj
-
- else ! hmhj
-
-! convert dry temperture to virtual temperature ! hmhj
- do k=1,levs ! hmhj
- ktem = kar+k-1
- jtem = kat+k-1
- do j=1,njeff ! hmhj
- item = lon+j-1
- work1 = 1.0 + fv * max(bak_gr_r_2(item,ktem,lan),qmin) ! hmhj
- bak_gr_r_2(item,jtem,lan) = bak_gr_r_2(item,jtem,lan)
- & * work1 ! hmhj
- adt(j,k) = adt(j,k)*work1
- enddo ! hmhj
- enddo ! hmhj
-
- endif
- if( gen_coord_hybrid .and. vertcoord_id == 3. ) then ! hmhj
- prsi = prsi * 0.001 ! Convert from Pa to kPa
- if( thermodyn_id == 3. ) then ! hmhj
- call gbphys_adv_h(njeff,ngptc,dtf,gtv,gu,gv1,gr , gq, ! hmhj
- & adt,adu,adv,adr,prsi )
-! call gbphys_adv_h(njeff,ngptc,dtf,
-! & for_gr_r_2(lon,kst,lan),
-! & for_gr_r_2(lon,ksu,lan),
-! & for_gr_r_2(lon,ksv,lan),
-! & for_gr_r_2(lon,ksr,lan),
-! & for_gr_r_2(lon,ksq,lan),
-! & bak_gr_r_2(lon,kat,lan),
-! & bak_gr_r_2(lon,kau,lan),
-! & bak_gr_r_2(lon,kav,lan),
-! & bak_gr_r_2(lon,kar,lan),
-! & prsi )
- else
- call gbphys_adv(njeff,ngptc,dtf,gtv,gu,gv1,gr,gq, ! hmhj
- & adt,adu,adv,adr,prsi )
-! call gbphys_adv(njeff,ngptc,dtf,
-! & for_gr_r_2(lon,kst,lan),
-! & for_gr_r_2(lon,ksu,lan),
-! & for_gr_r_2(lon,ksv,lan),
-! & for_gr_r_2(lon,ksr,lan),
-! & for_gr_r_2(lon,ksq,lan),
-! & bak_gr_r_2(lon,kat,lan),
-! & bak_gr_r_2(lon,kau,lan),
-! & bak_gr_r_2(lon,kav,lan),
-! & bak_gr_r_2(lon,kar,lan),
-! & prsi )
- endif ! hmhj
- endif ! hmhj
-!!
do k=1,lsoil
do i=1,njeff
item = lon + i - 1
@@ -1421,519 +673,24 @@
enddo
endif
!
+!---------------------------
enddo ! lon loop
+!---------------------------
!
!
-! CALL dscal(LEVS*lonr,rcs2_v,bak_gr_r_2(1,kau,lan),1)
-! CALL dscal(LEVS*lonr,rcs2_v,bak_gr_r_2(1,kav,lan),1)
-!
-!
- ptotj(lan) = 0.
- do j=1,lons_lat
- ptotj(lan) = ptotj(lan) + gq_save(j,lan)
- pwatp = pwatp + flx_fld%pwat(j,lan)
+! ptotj(lan) = 0.
+! do j=1,lons_lat
+! ptotj(lan) = ptotj(lan) + gq_save(j,lan)
+! pwatp = pwatp + flx_fld%pwat(j,lan)
! print *,' kdt=',kdt,' pwatp=',pwatp,' pwat=',flx_fld%pwat(j,lan)
! &,' j=',j
- enddo
- pwatj(lan) = pwatp*grav/(2.*lonsperlar(lat)*1.e3)
- ptotj(lan) = ptotj(lan)/(2.*lonsperlar(lat))
-!!
-!!
-c$$$ if (kdt.eq.1) then
-c$$$ do j=1,lons_lat
-c$$$ do i=1,levs
-c$$$ write(8700+lat,*)
-c$$$ & bak_gr_r_2(j,kat-1+i,lan),i,j
-c$$$ write(8800+lat,*)
-c$$$ & bak_gr_r_2(j,kar-1+i,lan),i,j
-c$$$ write(8900+lat,*)
-c$$$ & bak_gr_r_2(j,kau-1+i,lan),i,j
-c$$$ write(8100+lat,*)
-c$$$ & bak_gr_r_2(j,kav-1+i,lan),i,j
-c$$$ write(8200+lat,*)
-c$$$ & bak_gr_r_2(j,kar-1+i+levs,lan),i,j
-c$$$ write(8300+lat,*)
-c$$$ & bak_gr_r_2(j,kar-1+i+2*levs,lan),i,j
-c$$$ enddo
-c$$$ enddo
-c$$$ endif
-!!
+! enddo
+! pwatj(lan) = pwatp*grav/(2.*lonsperlar(lat)*1.e3)
+! ptotj(lan) = ptotj(lan)/(2.*lonsperlar(lat))
+
+!---------------------------
enddo ! lan loop
-!
- call f_hpmstop(51)
-!
-! lotn=3*levs+1*levh
-!
- do lan=1,lats_node_r ! four_to_grid lan loop
-!
- lat = global_lats_r(ipt_lats_node_r-1+lan)
-! lon_dim = lon_dims_r(lan)
- lons_lat = lonsperlar(lat)
-!
- call countperf(0,6,0.)
-!
- call grid_to_four(bak_gr_r_2(1,1,lan),bak_gr_r_1(1,1,lan),
- & lon_dim_r-2,lon_dim_r,lons_lat,3*levs+1)
-!
- if (.not. gg_tracers .or. lsout) then
- call grid_to_four(bak_gr_r_2(1,kar,lan),
- & bak_gr_r_1(1,kar,lan),
- & lon_dim_r-2,lon_dim_r,lons_lat,levh)
- endif
- call countperf(1,6,0.)
+!---------------------------
- if (gg_tracers) then
- if (.not.shuff_lats_r) then
- item = lats_node_a + 1 - lan + yhalo
- do k=1,levs
- jtem = levs + 1 - k
- ktem = kar - 1 + k
- do i=1,min(lonf,lons_lat)
- rg1_h(xhalo+i,jtem,item) = bak_gr_r_2(i,ktem,lan)
- rg2_h(xhalo+i,jtem,item) = bak_gr_r_2(i,ktem+levs,lan)
- rg3_h(xhalo+i,jtem,item) = bak_gr_r_2(i,ktem+2*levs,lan)
-
-c$$$ if (kdt .eq. 1) write(888,*) 'rg1_h, = ',
-c$$$ . i,k,lan, rg1_h(xhalo+i,levs+1-k,lats_node_a+1-lan+yhalo)
- enddo
- enddo
- endif ! .not.shuff_lats_r
- endif ! gg_tracers
-!
- enddo ! fin four_to_grid lan loop
-!
- if (gg_tracers .and. shuff_lats_r) then
-! print*,' gloopb mpi_tracers_b_to_a shuff_lats_r',shuff_lats_r
-ccmr call mpi_barrier (mc_comp,ierr)
- call mpi_tracers_b_to_a(
- & bak_gr_r_2(1,1,1),
- & lats_nodes_r,global_lats_r,
- & rg1_h,rg2_h,rg3_h,lats_nodes_a,global_lats_a,kar,0)
- endif ! gg_tracers .and. shuff_lats_r
-
- call countperf(1,11,0.)
-!!
- call countperf(0,4,0.)
- call synctime()
- call countperf(1,4,0.)
-!!
- call excha(lats_nodes_r,global_lats_r,ptotj,pwatj,ptotg,pwatg)
- sumwa = 0.
- sumto = 0.
- do lat=1,latr
- sumto = sumto + wgt_r(min(lat,latr-lat+1))*ptotg(lat)
- sumwa = sumwa + wgt_r(min(lat,latr-lat+1))*pwatg(lat)
-! print *,' kdt=',kdt,' lat=',lat,' sumwa=',sumwa,' sumto=',sumto,
-! &' ptotg=',ptotg(lat),' pwatg=',pwatg(lat)
- enddo
-cjfe
-cjfe write(70+me,*) sumto,sumwa,kdt
- pdryg = sumto - sumwa
-!!
- if(pdryini == 0.) pdryini = pdryg
-
- if( gen_coord_hybrid ) then ! hmhj
- pcorr = (pdryini-pdryg) * sqrt(2.) ! hmhj
- else ! hmhj
- pcorr = (pdryini-pdryg) / sumto * sqrt(2.)
- endif ! hmhj
-!!
-! call f_hpmstart(53,"gb lats2ls")
-cc
-cc
- call countperf(0,1,0.)
-cc
-! call f_hpmstop(53)
-!!
-! call f_hpmstart(54,"gb fl2eov")
-! call f_hpmstop(54)
-!
- call f_hpmstart(52,"gb four2fln")
-!
- call four2fln_gg(lats_dim_r,lota,3*levs+1,bak_gr_r_1,
- x ls_nodes,max_ls_nodes,
-!mjr x lats_nodes_r,global_lats_r,lon_dims_r,
- x lats_nodes_r,global_lats_r,lon_dim_r,
- x lats_node_r,ipt_lats_node_r,
- x lat1s_r,lonrx,latr,latr2,
- x trie_ls(1,1,p_ze), trio_ls(1,1,p_ze),
- x plnew_r, plnow_r,
- x ls_node,0,
- x 2*levs+1,3*levs+1)
-
- sum_k_rqchange_ls(:,:) = trie_ls(:,:,p_q)
- sum_k_rqchango_ls(:,:) = trio_ls(:,:,p_q)
-
- trie_ls(:,:,p_q) = save_qe_ls(:,:)
- trio_ls(:,:,p_q) = save_qo_ls(:,:)
-cc
- if (.not. gg_tracers .or.lsout ) then
- call four2fln_gg(lats_dim_r,lota,levh,bak_gr_r_1,
- x ls_nodes,max_ls_nodes,
-!mjr x lats_nodes_r,global_lats_r,lon_dims_r,
- x lats_nodes_r,global_lats_r,lon_dim_r,
- x lats_node_r,ipt_lats_node_r,
- x lat1s_r,lonrx,latr,latr2,
- x trie_ls(1,1,p_rq), trio_ls(1,1,p_rq),
- x plnew_r, plnow_r,
- x ls_node,3*levs+1,
- x 1,levh)
- endif
-!
- call f_hpmstop(52)
-!
- call f_hpmstart(55,"gb uveodz uvoedz")
-!
-!$OMP parallel do shared(trie_ls,trio_ls)
-!$OMP+shared(epse,epso,ls_node)
-!$OMP+private(k)
- do k=1,levs
- call uveodz(trie_ls(1,1,p_ze +k-1), trio_ls(1,1,p_di +k-1),
- x trie_ls(1,1,p_uln+k-1), trio_ls(1,1,p_vln+k-1),
- x epse,epso,ls_node)
-cc
- call uvoedz(trio_ls(1,1,p_ze +k-1), trie_ls(1,1,p_di +k-1),
- x trio_ls(1,1,p_uln+k-1), trie_ls(1,1,p_vln+k-1),
- x epse,epso,ls_node)
- enddo
- call f_hpmstop(55)
-!
-!.............................................................
- do k=1,levs
- ktem = p_w + k - 1
- jtem = p_vln + k - 1
- do i=1,len_trie_ls
- trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + bfilte(i)*
- & (trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
-
- trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + bfilte(i)*
- & (trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,ktem) = trio_ls(i,1,ktem) + bfilto(i)*
- & (trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
-
- trio_ls(i,2,ktem) = trio_ls(i,2,ktem) + bfilto(i)*
- & (trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- enddo
- enddo
-cc.............................................................
- if(.not.gg_tracers)then
- do k=1,levs
- ktem = p_rt + k - 1
- jtem = p_rq + k - 1
- do i=1,len_trie_ls
- tem = bfilte(i)*(trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
- trie_ls_rqt(i,1,k) = tem
- trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + tem
-!
- tem = bfilte(i)*(trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- trie_ls_rqt(i,2,k) = tem
- trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + tem
- enddo
-!!
- do i=1,len_trio_ls
- tem = bfilto(i)*(trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
- trio_ls_rqt(i,1,k) = tem
- trio_ls(i,1,ktem) = trio_ls(i,1,ktem) + tem
-!
- tem = bfilto(i)*(trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- trio_ls_rqt(i,2,k) = tem
- trio_ls(i,2,p_rt+k-1) = trio_ls(i,2,ktem) + tem
- enddo
- enddo
-!
-!!.............................................................
-!
- do nt=2,ntrac
- do k=levs*(nt-2)+1,levs*(nt-1)
- ktem = p_rt + levs + k - 1
- jtem = p_rq + levs + k - 1
- do i=1,len_trie_ls
- trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + bfilte(i)*
- & (trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
- trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + bfilte(i)*
- & (trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,ktem) = trio_ls(i,1,ktem) + bfilto(i)*
- & (trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
- trio_ls(i,2,ktem) = trio_ls(i,2,ktem) + bfilto(i)*
- & (trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- enddo
- enddo
- enddo
- endif ! if(.not.gg_tracers)
-!!
-!----------------------------------------------------------------------
-!!
- if(hybrid)then
-
-! get some sigma distribution and compute typdel from it.
-
- typical_pgr=85.
-!sela si(k)=(ak5(k)+bk5(k)*typical_pgr)/typical_pgr !ak(k) bk(k) go top to botto
- do k=1,levp1
- si(levs+2-k) = ak5(k)/typical_pgr + bk5(k)
- enddo
- endif
-
- DO k=1,LEVS
- typDEL(k)= SI(k)-SI(k+1)
- ENDDO
-
-!----------------------------------------------------------------------
-
- if (ladj) then
- trie_ls(:,:,p_zq) = 0.
- trio_ls(:,:,p_zq) = 0.
- if (me == me_l_0) then
- trie_ls(1,1,p_zq) = pcorr
- endif
-!!
- if( gen_coord_hybrid ) then ! hmhj
- trie_ls_sfc = 0.0 ! hmhj
- trio_ls_sfc = 0.0 ! hmhj
- do k=1,levs ! hmhj
- do i=1,len_trie_ls ! hmhj
- trie_ls_sfc(i,1) = trie_ls_sfc(i,1)
- & + typdel(k)*trie_ls_rqt(i,1,k) ! hmhj
- trie_ls_sfc(i,2) = trie_ls_sfc(i,2)
- & + typdel(k)*trie_ls_rqt(i,2,k) ! hmhj
- enddo ! hmhj
- do i=1,len_trio_ls ! hmhj
- trio_ls_sfc(i,1) = trio_ls_sfc(i,1)
- & + typdel(k)*trio_ls_rqt(i,1,k) ! hmhj
- trio_ls_sfc(i,2) = trio_ls_sfc(i,2)
- & + typdel(k)*trio_ls_rqt(i,2,k) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
-
- do i=1,len_trie_ls ! hmhj
- trie_ls(i,1,p_zq) = trie_ls(i,1,p_zq) ! hmhj
- & + trie_ls(i,1,p_q )*trie_ls_sfc(i,1) ! hmhj
- trie_ls(i,2,p_zq) = trie_ls(i,2,p_zq) ! hmhj
- & + trie_ls(i,2,p_q )*trie_ls_sfc(i,2) ! hmhj
- enddo
- do i=1,len_trio_ls ! hmhj
- trio_ls(i,1,p_zq) = trio_ls(i,1,p_zq) ! hmhj
- & + trio_ls(i,1,p_q )*trio_ls_sfc(i,1) ! hmhj
- trio_ls(i,2,p_zq) = trio_ls(i,2,p_zq) ! hmhj
- & + trio_ls(i,2,p_q )*trio_ls_sfc(i,2) ! hmhj
- enddo
-
- else ! For hybrid or sigma coordinate
-
- if(gg_tracers)then
- do i=1,len_trie_ls
- trie_ls(i,1,p_zq) = trie_ls(i,1,p_zq)
- & + sum_k_rqchange_ls(i,1)
- trie_ls(i,2,p_zq) = trie_ls(i,2,p_zq)
- & + sum_k_rqchange_ls(i,2)
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,p_zq) = trio_ls(i,1,p_zq)
- & + sum_k_rqchango_ls(i,1)
- trio_ls(i,2,p_zq) = trio_ls(i,2,p_zq)
- & + sum_k_rqchango_ls(i,2)
- enddo
- else
- do k=1,levs
- do i=1,len_trie_ls
- trie_ls(i,1,p_zq) = trie_ls(i,1,p_zq)
- & + typdel(k)*trie_ls_rqt(i,1,k)
- trie_ls(i,2,p_zq) = trie_ls(i,2,p_zq)
- & + typdel(k)*trie_ls_rqt(i,2,k)
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,p_zq) = trio_ls(i,1,p_zq)
- & + typdel(k)*trio_ls_rqt(i,1,k)
- trio_ls(i,2,p_zq) = trio_ls(i,2,p_zq)
- & + typdel(k)*trio_ls_rqt(i,2,k)
- enddo
- enddo
- endif !fin if(gg_tracers)
-
- endif !fin if (gen_coord_hybrid) ! hmhj
-!!
- do k=1,levs
- item = p_di+k-1
- jtem = p_uln+k-1
- ktem = p_x+k-1
- ltem = p_te+k-1
- mtem = p_y+k-1
-
- do i=1,len_trie_ls
- trie_ls(i,1,item) = bfilte(i)
- & * (trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
- trie_ls(i,1,ltem) = bfilte(i)
- & * (trie_ls(i,1,ltem)-trie_ls(i,1,mtem))
- trie_ls(i,2,item) = bfilte(i)
- & * (trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- trie_ls(i,2,ltem) = bfilte(i)
- & * (trie_ls(i,2,ltem)-trie_ls(i,2,mtem))
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,item) = bfilto(i)
- & * (trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
- trio_ls(i,1,ltem) = bfilto(i)
- & * (trio_ls(i,1,ltem)-trio_ls(i,1,mtem))
- trio_ls(i,2,item) = bfilto(i)
- & * (trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- trio_ls(i,2,ltem) = bfilto(i)
- & * (trio_ls(i,2,ltem)-trio_ls(i,2,mtem))
- enddo
- enddo
-
-!---------------------------------------------------------
- if( gen_coord_hybrid ) then ! hmhj
-
-!$OMP parallel do private(locl)
- do locl=1,ls_max_node ! hmhj
-
- call impadje_hyb_gc(trie_ls(1,1,p_x),trie_ls(1,1,p_y), ! hmhj
- & trie_ls(1,1,p_q),trie_ls(1,1,p_di), ! hmhj
- & trie_ls(1,1,p_te),trie_ls(1,1,p_zq), ! hmhj
- & tstep, ! hmhj
- & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln), ! hmhj
- & snnp1ev,ndexev,ls_node,locl) ! hmhj
-!!
- call impadjo_hyb_gc(trio_ls(1,1,p_x),trio_ls(1,1,p_y), ! hmhj
- & trio_ls(1,1,p_q),trio_ls(1,1,p_di), ! hmhj
- & trio_ls(1,1,p_te),trio_ls(1,1,p_zq), ! hmhj
- & tstep, ! hmhj
- & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln), ! hmhj
- & snnp1od,ndexod,ls_node,locl) ! hmhj
- enddo ! hmhj
- elseif(hybrid) then ! for sigma/p hybrid coordinate ! hmhj
- if (.not. semilag) then ! for Eulerian hybrid case
-
-
-!$OMP parallel do private(locl)
- do locl=1,ls_max_node
- call impadje_hyb(trie_ls(1,1,p_x),trie_ls(1,1,p_y),
- & trie_ls(1,1,p_q),trie_ls(1,1,p_di),
- & trie_ls(1,1,p_te),trie_ls(1,1,p_zq),
- & tstep,
- & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln),
- & snnp1ev,ndexev,ls_node,locl)
-!!
- call impadjo_hyb(trio_ls(1,1,p_x),trio_ls(1,1,p_y),
- & trio_ls(1,1,p_q),trio_ls(1,1,p_di),
- & trio_ls(1,1,p_te),trio_ls(1,1,p_zq),
- & tstep,
- & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln),
- & snnp1od,ndexod,ls_node,locl)
- enddo
- else ! for semi-Lagrangian hybrid case
-!$OMP parallel do private(locl)
- do locl=1,ls_max_node
-
-
- call impadje_slg(trie_ls(1,1,p_x),trie_ls(1,1,p_y),
- & trie_ls(1,1,p_q),trie_ls(1,1,p_di),
- & trie_ls(1,1,p_te),trie_ls(1,1,p_zq),
- & tstep,
- & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln),
- & snnp1ev,ndexev,ls_node,locl,batah)
-!!
- call impadjo_slg(trio_ls(1,1,p_x),trio_ls(1,1,p_y),
- & trio_ls(1,1,p_q),trio_ls(1,1,p_di),
- & trio_ls(1,1,p_te),trio_ls(1,1,p_zq),
- & tstep,
- & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln),
- & snnp1od,ndexod,ls_node,locl,batah)
- enddo
- endif
-
- else ! massadj in sigma coordinate
-
- call countperf(0,9,0.)
-!$OMP parallel do private(locl)
- do locl=1,ls_max_node
- call impadje(trie_ls(1,1,p_x),trie_ls(1,1,p_y),
- & trie_ls(1,1,p_q),trie_ls(1,1,p_di),
- & trie_ls(1,1,p_te),trie_ls(1,1,p_zq),
- & am,bm,sv,tstep,
- & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln),
- & snnp1ev,ndexev,ls_node,locl)
-!!
- call impadjo(trio_ls(1,1,p_x),trio_ls(1,1,p_y),
- & trio_ls(1,1,p_q),trio_ls(1,1,p_di),
- & trio_ls(1,1,p_te),trio_ls(1,1,p_zq),
- & am,bm,sv,tstep,
- & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln),
- & snnp1od,ndexod,ls_node,locl)
- enddo
-
- call countperf(1,9,0.)
-
- endif ! fin massadj in sigma
-!---------------------------------------------------------
-
- else ! fin massadj, following is with no masadj
- DO k=1,LEVS
- del(k) = typDEL(k) ! sela 4.5.07
- ENDDO
- if (me == me_l_0) then
- trie_ls(1,1,p_q) = trie_ls(1,1,p_q) + pcorr
- endif
-!
-! testing mass correction on sep 25
-!!
- if(gg_tracers)then
- do i=1,len_trie_ls
- trie_ls(i,1,p_q) = trie_ls(i,1,p_q) + sum_k_rqchange_ls(i,1)
- trie_ls(i,2,p_q) = trie_ls(i,2,p_q) + sum_k_rqchange_ls(i,2)
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,p_q) = trio_ls(i,1,p_q) + sum_k_rqchango_ls(i,1)
- trio_ls(i,2,p_q) = trio_ls(i,2,p_q) + sum_k_rqchango_ls(i,2)
- enddo
- else
- do k=1,levs
- do i=1,len_trie_ls
- trie_ls(i,1,p_q)=trie_ls(i,1,p_q)+del(k)*trie_ls_rqt(i,1,k)
- trie_ls(i,2,p_q)=trie_ls(i,2,p_q)+del(k)*trie_ls_rqt(i,2,k)
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,p_q)=trio_ls(i,1,p_q)+del(k)*trio_ls_rqt(i,1,k)
- trio_ls(i,2,p_q)=trio_ls(i,2,p_q)+del(k)*trio_ls_rqt(i,2,k)
- enddo
- enddo
- endif
-!
-! testing mass correction on sep 25
-!
- do k=1,levs
- item = p_di+k-1
- jtem = p_uln+k-1
- ktem = p_x+k-1
- ltem = p_te+k-1
- mtem = p_y+k-1
- do i=1,len_trie_ls
- trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + bfilte(i)
- & *(trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
- trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + bfilte(i)
- & *(trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- trie_ls(i,1,mtem) = trie_ls(i,1,mtem) + bfilte(i)
- & *(trie_ls(i,1,ltem)-trie_ls(i,1,mtem))
- trie_ls(i,2,mtem) = trie_ls(i,2,mtem) + bfilte(i)
- & *(trie_ls(i,2,ltem)-trie_ls(i,2,mtem))
- enddo
-
- do i=1,len_trio_ls
- trio_ls(i,1,ktem) = trio_ls(i,1,ktem)+bfilto(i)
- & *(trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
- trio_ls(i,2,ktem) = trio_ls(i,2,ktem) + bfilto(i)
- & *(trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- trio_ls(i,1,mtem) = trio_ls(i,1,mtem) + bfilto(i)
- & *(trio_ls(i,1,ltem)-trio_ls(i,1,mtem))
- trio_ls(i,2,mtem) = trio_ls(i,2,mtem) + bfilto(i)
- & *(trio_ls(i,2,ltem)-trio_ls(i,2,mtem))
- enddo
- enddo
- endif ! fin no ladj (i.e. no massadj)
-!!
return
end
Deleted: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopb.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopb.f_gfs 2012-05-10 23:36:12 UTC (rev 1894)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopb.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -1,1939 +0,0 @@
- subroutine gloopb
- x (trie_ls,trio_ls,
- x ls_node,ls_nodes,max_ls_nodes,
- x lats_nodes_a,global_lats_a,
- x lats_nodes_r,global_lats_r,
- x lonsperlar,
- x epse,epso,epsedn,epsodn,
- x snnp1ev,snnp1od,ndexev,ndexod,
- x plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r,
- & tstep,phour,sfc_fld, flx_fld, nst_fld, SFALB,
- & xlon,
- & swh,hlw,hprime,slag,sdec,cdec,
- & ozplin,jindx1,jindx2,ddy,pdryini,
- & phy_f3d, phy_f2d,xlat,kdt,
- & global_times_b,batah,lsout,fscav)
-!!
-#include "f_hpm.h"
-!!
- use machine , only : kind_evod,kind_phys,kind_rad
- use resol_def , only : jcap,jcap1,latg,latr,latr2,
- & levh,levp1,levs,lnt2,
- & lonf,lonr,lonrx,lota,lotd,lots,
- & lsoil,ncld,nmtvr,nrcm,ntcw,ntoz,
- & ntrac,num_p2d,num_p3d,
- & p_di,p_dlam,p_dphi,p_q,
- & p_rq,p_rt,p_te,p_uln,p_vln,
- & p_w,p_x,p_y,p_ze,p_zq,
- & thermodyn_id,sfcpress_id,nfxr
-
- use layout1 , only : ipt_lats_node_r,
- & lat1s_r,lats_dim_r,
- & lats_node_a,lats_node_r,
- & len_trie_ls,len_trio_ls,
- & lon_dim_r,ls_dim,ls_max_node,
- & me,me_l_0,nodes
- use layout_grid_tracers , only : rg1_a,rg2_a,rg3_a,xhalo,
- & rg1_h,rg2_h,rg3_h,yhalo
- use gg_def , only : coslat_r,rcs2_r,sinlat_r,wgt_r
- use vert_def , only : am,bm,del,si,sik,sl,slk,sv
- use date_def , only : fhour,idate
- use namelist_def , only : crtrh,fhswr,flgmin,
- & gen_coord_hybrid,gg_tracers,
- & hybrid,ldiag3d,lscca,lsfwd,
- & lsm,lssav,lsswr,ncw,ngptc,
- & old_monin,pre_rad,random_clds,
- & ras,semilag,shuff_lats_r,
- & sashal,ctei_rm,mom4ice,newsas,
- & ccwf,cnvgwd,lggfs3d,trans_trac,
- & mstrat,cal_pre,nst_fcst,
- & dlqf,moist_adj,cdmbgwd,
- & bkgd_vdif_m, bkgd_vdif_h,
- & bkgd_vdif_s,shal_cnv,
- & psautco, prautco, evpco, wminco
- use coordinate_def , only : ak5,bk5,vertcoord_id ! hmhj
- use bfilt_def , only : bfilte,bfilto
- use module_ras , only : ras_init
- use physcons , only : grav => con_g,
- & rerth => con_rerth, ! hmhj
- & fv => con_fvirt, ! mjr
- & rvrdm1 => con_FVirt,
- & rd => con_rd
- use ozne_def , only : latsozp,levozp,
- & pl_coeff,pl_pres,timeoz
-!-> Coupling insertion
- USE SURFACE_cc
-!<- Coupling insertion
-
- use Sfc_Flx_ESMFMod
- use Nst_Var_ESMFMod
- use mersenne_twister
- use d3d_def
- use tracer_const
-!
- include 'mpif.h'
- implicit none
-!
- TYPE(Sfc_Var_Data) :: sfc_fld
- TYPE(Flx_Var_Data) :: flx_fld
- TYPE(Nst_Var_Data) :: nst_fld
-!
- real(kind=kind_phys), PARAMETER :: RLAPSE=0.65E-2
- real(kind=kind_evod), parameter :: cons_0=0.0, cons_24=24.0
- &, cons_99=99.0, cons_1p0d9=1.0E9
-
-
-!$$$ integer n1rac, n2rac,nlons_v(ngptc)
-!$$$ parameter (n1rac=ntrac-ntshft-1, n2rac=n1rac+1)
-!
-! integer id,njeff,istrt,lon,kdt
- integer id,njeff, lon,kdt
-!!
- real(kind=kind_evod) save_qe_ls(len_trie_ls,2)
- real(kind=kind_evod) save_qo_ls(len_trio_ls,2)
-
- real(kind=kind_evod) sum_k_rqchange_ls(len_trie_ls,2)
- real(kind=kind_evod) sum_k_rqchango_ls(len_trio_ls,2)
-!!
- real(kind=kind_evod) trie_ls(len_trie_ls,2,11*levs+3*levh+6)
- real(kind=kind_evod) trio_ls(len_trio_ls,2,11*levs+3*levh+6)
- real(kind=kind_evod) trie_ls_rqt(len_trie_ls,2,levs)
- real(kind=kind_evod) trio_ls_rqt(len_trio_ls,2,levs)
- real(kind=kind_evod) trie_ls_sfc(len_trie_ls,2) ! hmhj
- real(kind=kind_evod) trio_ls_sfc(len_trio_ls,2) ! hmhj
-!!
- real(kind=kind_phys) typdel(levs), batah
- real(kind=kind_phys) prsl(ngptc,levs)
- real(kind=kind_phys) prslk(ngptc,levs),dpshc(ngptc)
- real(kind=kind_phys) prsi(ngptc,levs+1),phii(ngptc,levs+1)
- real(kind=kind_phys) prsik(ngptc,levs+1),phil(ngptc,levs)
-!!
- real (kind=kind_phys) gu(ngptc,levs), gv1(ngptc,levs)
- real (kind=kind_phys) ugrd(ngptc,levs),vgrd(ngptc,levs)
- real (kind=kind_phys) gphi(ngptc), glam(ngptc)
- real (kind=kind_phys) gq(ngptc), gt(ngptc,levs), pgr(ngptc)
- real (kind=kind_phys) gr(ngptc,levs,ntrac)
- real (kind=kind_phys) gd(ngptc,levs)
- real (kind=kind_phys) adt(ngptc,levs), adr(ngptc,levs,ntrac)
- real (kind=kind_phys) adu(ngptc,levs), adv(ngptc,levs)
- real (kind=kind_phys) gtv(ngptc,levs) ! hmhj
- real (kind=kind_phys) gtvx(ngptc,levs), gtvy(ngptc,levs) ! hmhj
- real (kind=kind_phys) sumq(ngptc,levs), xcp(ngptc,levs)
-!
- real (kind=kind_phys) dt3dt_v(ngptc,levs,6),
- & dq3dt_v(ngptc,levs,5+pl_coeff),
- & du3dt_v(ngptc,levs,4),
- & dv3dt_v(ngptc,levs,4)
- &, upd_mf_v(ngptc,levs), dwn_mf_v(ngptc,levs)
- &, det_mf_v(ngptc,levs)
- &, dkh_v(ngptc,LEVS), rnp_v(ngptc,levs)
-!!
- real(kind=kind_evod) gq_save(lonr,lats_dim_r)
-!!
- real (kind=kind_rad) slag,sdec,cdec,phour
- real (kind=kind_rad) xlon(lonr,lats_node_r)
- real (kind=kind_rad) xlat(lonr,lats_node_r)
- real (kind=kind_rad) coszdg(lonr,lats_node_r),
- & hprime(lonr,nmtvr,lats_node_r),
-! & fluxr(lonr,nfxr,lats_node_r),
- & sfalb(lonr,lats_node_r)
- real (kind=kind_rad) swh(lonr,levs,lats_node_r)
- real (kind=kind_rad) hlw(lonr,levs,lats_node_r)
-!!
- real (kind=kind_phys)
- & phy_f3d(lonr,levs,num_p3d,lats_node_r),
- & phy_f2d(lonr,num_p2d,lats_node_r), fscav(ntrac-ncld-1)
-!
-!
- real (kind=kind_phys) exp,dtphys,dtp,dtf,sumed(2)
- real (kind=kind_evod) tstep
- real (kind=kind_phys) pdryini,sigshc,rk
-!!
- integer ls_node(ls_dim,3)
-cc
-! ls_node(1,1) ... ls_node(ls_max_node,1) : values of l
-! ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
-! ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
-cc
- integer ls_nodes(ls_dim,nodes)
-cc
- integer max_ls_nodes(nodes)
- integer lats_nodes_a(nodes)
- integer lats_nodes_r(nodes)
-cc
- integer global_lats_a(latg)
- integer global_lats_r(latr)
- integer lonsperlar(latr)
- integer dimg
-cc
- real(kind=kind_evod) epse(len_trie_ls)
- real(kind=kind_evod) epso(len_trio_ls)
- real(kind=kind_evod) epsedn(len_trie_ls)
- real(kind=kind_evod) epsodn(len_trio_ls)
-cc
- real(kind=kind_evod) snnp1ev(len_trie_ls)
- real(kind=kind_evod) snnp1od(len_trio_ls)
-cc
- integer ndexev(len_trie_ls)
- integer ndexod(len_trio_ls)
-cc
- real(kind=kind_evod) plnev_r(len_trie_ls,latr2)
- real(kind=kind_evod) plnod_r(len_trio_ls,latr2)
- real(kind=kind_evod) pddev_r(len_trie_ls,latr2)
- real(kind=kind_evod) pddod_r(len_trio_ls,latr2)
- real(kind=kind_evod) plnew_r(len_trie_ls,latr2)
- real(kind=kind_evod) plnow_r(len_trio_ls,latr2)
-cc
-c$$$ integer lots,lotd,lota
- integer lotn
-c$$$cc
-c$$$ parameter ( lots = 5*levs+1*levh+3 )
-c$$$ parameter ( lotd = 6*levs+2*levh+0 )
-c$$$ parameter ( lota = 3*levs+1*levh+1 )
-cc
- real(kind=kind_evod) for_gr_r_1(lonrx,lots,lats_dim_r)
- real(kind=kind_evod) dyn_gr_r_1(lonrx,lotd,lats_dim_r) ! hmhj
- real(kind=kind_evod) bak_gr_r_1(lonrx,lota,lats_dim_r)
-cc
-! real(kind=kind_evod) for_gr_r_2(lonrx*lots,lats_dim_r)
-! real(kind=kind_evod) dyn_gr_r_2(lonrx*lotd,lats_dim_r) ! hmhj
-! real(kind=kind_evod) bak_gr_r_2(lonrx*lota,lats_dim_r)
-!
- real(kind=kind_evod) for_gr_r_2(lonr,lots,lats_dim_r)
- real(kind=kind_evod) dyn_gr_r_2(lonr,lotd,lats_dim_r) ! hmhj
- real(kind=kind_evod) bak_gr_r_2(lonr,lota,lats_dim_r)
-cc
- integer i,ierr,iter,j,k,kap,kar,kat,kau,kav,ksq,jj,kk
- integer kst,kdtphi,kdtlam ! hmhj
- integer l,lan,lan0,lat,lmax,locl,ii,lonrbm
-! integer lon_dim,lons_lat,n,node
- integer lons_lat,n,node
- integer nsphys
-!
- real(kind=kind_evod) pwatg(latr),pwatj(lats_node_r),
- & pwatp,ptotg(latr),sumwa,sumto,
- & ptotj(lats_node_r),pcorr,pdryg,
- & solhr,clstp
-cc
- integer ipt_ls ! hmhj
- real(kind=kind_evod) reall ! hmhj
- real(kind=kind_evod) rlcs2(jcap1) ! hmhj
-
- real(kind=kind_evod) typical_pgr
-c
-!timers______________________________________________________---
-
- real*8 rtc ,timer1,timer2
- real(kind=kind_evod) global_times_b(latr,nodes)
-
-!timers______________________________________________________---
-cc
-cc
-c$$$ parameter(ksq =0*levs+0*levh+1,
-c$$$ x ksplam =0*levs+0*levh+2,
-c$$$ x kspphi =0*levs+0*levh+3,
-c$$$ x ksu =0*levs+0*levh+4,
-c$$$ x ksv =1*levs+0*levh+4,
-c$$$ x ksz =2*levs+0*levh+4,
-c$$$ x ksd =3*levs+0*levh+4,
-c$$$ x kst =4*levs+0*levh+4,
-c$$$ x ksr =5*levs+0*levh+4)
-cc
-c$$$ parameter(kdtphi =0*levs+0*levh+1,
-c$$$ x kdrphi =1*levs+0*levh+1,
-c$$$ x kdtlam =1*levs+1*levh+1,
-c$$$ x kdrlam =2*levs+1*levh+1,
-c$$$ x kdulam =2*levs+2*levh+1,
-c$$$ x kdvlam =3*levs+2*levh+1,
-c$$$ x kduphi =4*levs+2*levh+1,
-c$$$ x kdvphi =5*levs+2*levh+1)
-cc
-c$$$ parameter(kau =0*levs+0*levh+1,
-c$$$ x kav =1*levs+0*levh+1,
-c$$$ x kat =2*levs+0*levh+1,
-c$$$ x kar =3*levs+0*levh+1,
-c$$$ x kap =3*levs+1*levh+1)
-cc
-cc
-c$$$ integer p_gz,p_zem,p_dim,p_tem,p_rm,p_qm
-c$$$ integer p_ze,p_di,p_te,p_rq,p_q,p_dlam,p_dphi,p_uln,p_vln
-c$$$ integer p_w,p_x,p_y,p_rt,p_zq
-c$$$cc
-c$$$cc old common /comfspec/
-c$$$ parameter(p_gz = 0*levs+0*levh+1, ! gze/o(lnte/od,2),
-c$$$ x p_zem = 0*levs+0*levh+2, ! zeme/o(lnte/od,2,levs),
-c$$$ x p_dim = 1*levs+0*levh+2, ! dime/o(lnte/od,2,levs),
-c$$$ x p_tem = 2*levs+0*levh+2, ! teme/o(lnte/od,2,levs),
-c$$$ x p_rm = 3*levs+0*levh+2, ! rme/o(lnte/od,2,levh),
-c$$$ x p_qm = 3*levs+1*levh+2, ! qme/o(lnte/od,2),
-c$$$ x p_ze = 3*levs+1*levh+3, ! zee/o(lnte/od,2,levs),
-c$$$ x p_di = 4*levs+1*levh+3, ! die/o(lnte/od,2,levs),
-c$$$ x p_te = 5*levs+1*levh+3, ! tee/o(lnte/od,2,levs),
-c$$$ x p_rq = 6*levs+1*levh+3, ! rqe/o(lnte/od,2,levh),
-c$$$ x p_q = 6*levs+2*levh+3, ! qe/o(lnte/od,2),
-c$$$ x p_dlam= 6*levs+2*levh+4, ! dpdlame/o(lnte/od,2),
-c$$$ x p_dphi= 6*levs+2*levh+5, ! dpdphie/o(lnte/od,2),
-c$$$ x p_uln = 6*levs+2*levh+6, ! ulne/o(lnte/od,2,levs),
-c$$$ x p_vln = 7*levs+2*levh+6, ! vlne/o(lnte/od,2,levs),
-c$$$ x p_w = 8*levs+2*levh+6, ! we/o(lnte/od,2,levs),
-c$$$ x p_x = 9*levs+2*levh+6, ! xe/o(lnte/od,2,levs),
-c$$$ x p_y =10*levs+2*levh+6, ! ye/o(lnte/od,2,levs),
-c$$$ x p_rt =11*levs+2*levh+6, ! rte/o(lnte/od,2,levh),
-c$$$ x p_zq =11*levs+3*levh+6) ! zqe/o(lnte/od,2)
-cc
-cc
- integer indlsev,jbasev,n0
- integer indlsod,jbasod
-cc
- include 'function2'
-cc
- real(kind=kind_evod) cons0,cons2 !constant
-cc
- logical lsout
- logical, parameter :: flipv = .true.
-cc
-! for nasa/nrl ozone production and distruction rates:(input through fixio)
- real ozplin(latsozp,levozp,pl_coeff,timeoz)
- integer jindx1(lats_node_r),jindx2(lats_node_r)!for ozone interpolaton
- real ddy(lats_node_r) !for ozone interpolaton
- real ozplout(levozp,lats_node_r,pl_coeff)
-!Moor real ozplout(lonr,levozp,pl_coeff,lats_node_r)
-!!
- real(kind=kind_phys), allocatable :: acv(:,:),acvb(:,:),acvt(:,:)
- save acv,acvb,acvt
-!!
-! integer, parameter :: maxran=5000
-! integer, parameter :: maxran=3000
- integer, parameter :: maxran=6000, maxsub=6, maxrs=maxran/maxsub
- type (random_stat) :: stat(maxrs)
- real (kind=kind_phys), allocatable, save :: rannum_tank(:,:,:)
- real (kind=kind_phys) :: rannum(lonr*latr)
- integer iseed, nrc, seed0, kss, ksr, indxr(nrcm), iseedl
- integer nf0,nf1,ind,nt,indod,indev
- real(kind=kind_evod) fd2, wrk(1), wrk2(nrcm)
-
- logical first,ladj
- parameter (ladj=.true.)
- data first/.true./
-! save krsize, first, nrnd,seed0
- save first, seed0
-!!
- integer nlons_v(ngptc)
- real(kind=kind_phys) smc_v(ngptc,lsoil),stc_v(ngptc,lsoil)
- &, slc_v(ngptc,lsoil)
- &, swh_v(ngptc,levs), hlw_v(ngptc,levs)
- &, vvel(ngptc,levs)
- &, hprime_v(ngptc,nmtvr)
- real(kind=kind_phys) phy_f3dv(ngptc,LEVS,num_p3d),
- & phy_f2dv(ngptc,num_p2d)
- &, rannum_v(ngptc,nrcm)
- real(kind=kind_phys) sinlat_v(ngptc),coslat_v(ngptc)
- &, ozplout_v(ngptc,levozp,pl_coeff)
- real (kind=kind_rad) rqtk(ngptc), rcs2_lan, rcs_lan
-! real (kind=kind_rad) rcs_v(ngptc), rqtk(ngptc), rcs2_lan
-!
-!--------------------------------------------------------------------
-! print *,' in gloopb vertcoord_id =',vertcoord_id
-
-! real(kind=kind_evod) sinlat_v(lonr),coslat_v(lonr),rcs2_v(lonr)
-! real(kind=kind_phys) dpshc(lonr)
- real (kind=kind_rad) work1, qmin, tem
- parameter (qmin=1.0e-10)
- integer ksd,ksplam,kspphi
- integer ksu,ksv,ksz,item,jtem,ktem,ltem,mtem
-
-!
-! --- for debug test use
- real (kind=kind_phys) :: temlon, temlat, alon, alat
- integer :: ipt
- logical :: lprnt
-!
-!
- ksq =0*levs+0*levh+1
- ksplam =0*levs+0*levh+2
- kspphi =0*levs+0*levh+3
- ksu =0*levs+0*levh+4
- ksv =1*levs+0*levh+4
- ksz =2*levs+0*levh+4
- ksd =3*levs+0*levh+4
- kst =4*levs+0*levh+4
- ksr =5*levs+0*levh+4
-!
- kau =0*levs+0*levh+1
- kav =1*levs+0*levh+1
- kat =2*levs+0*levh+1
- kap =3*levs+0*levh+1
- kar =3*levs+0*levh+2
-!
-! ksq = 0*levs + 0*levh + 1
-! kst = 4*levs + 0*levh + 4 ! hmhj
- kdtphi = 0*levs + 0*levh + 1 ! hmhj
- kdtlam = 1*levs+1*levh+1 ! hmhj
-!
-c$$$ kau =0*levs+0*levh+1
-c$$$ kav =1*levs+0*levh+1
-c$$$ kat =2*levs+0*levh+1
-c$$$ kar =3*levs+0*levh+1
-c$$$ kap =3*levs+1*levh+1
-cc
-cc--------------------------------------------------------------------
-cc
- save_qe_ls(:,:) = trie_ls(:,:,p_q)
- save_qo_ls(:,:) = trio_ls(:,:,p_q)
-
-
-!
- if (first) then
- allocate (bfilte(lnt2),bfilto(lnt2))
-!
-! initializations for the gloopb filter
-! *************************************
- nf0 = (jcap+1)*2/3 ! highest wavenumber gloopb filter keeps fully
- nf1 = (jcap+1) ! lowest wavenumber gloopb filter removes fully
- fd2 = 1./(nf1-nf0)**2
- do locl=1,ls_max_node
- l = ls_node(locl,1)
- jbasev = ls_node(locl,2)
-!sela if (l.eq.0) then
-!sela n0=2
-!sela else
-!sela n0=l
-!sela endif
-!
-!sela indev = indlsev(n0,l)
- indev = indlsev(l,l)
-!sela do n=n0,jcap1,2
-!mjr do n=l,jcap1,2
- do n=l,jcap,2
- bfilte(indev) = max(1.-fd2*max(n-nf0,0)**2,cons_0) !constant
- indev = indev + 1
- enddo
- if (mod(L,2).eq.mod(jcap+1,2)) bfilte(indev) = 1.
- enddo
-!!
- do locl=1,ls_max_node
- l = ls_node(locl,1)
- jbasod = ls_node(locl,3)
- indod = indlsod(l+1,l)
-!mjr do n=l+1,jcap1,2
- do n=l+1,jcap,2
- bfilto(indod) = max(1.-fd2*max(n-nf0,0)**2,cons_0) !constant
- indod = indod+1
- enddo
- if (mod(L,2).ne.mod(jcap+1,2)) bfilto(indod) = 1.
- enddo
-!!
-! call random_seed(size=krsize)
-! if (me.eq.0) print *,' krsize=',krsize
-! allocate (nrnd(krsize))
- allocate (acv(lonr,lats_node_r))
- allocate (acvb(lonr,lats_node_r))
- allocate (acvt(lonr,lats_node_r))
-!
- seed0 = idate(1) + idate(2) + idate(3) + idate(4)
-
-
- call random_setseed(seed0)
- call random_number(wrk)
- seed0 = seed0 + nint(wrk(1)*1000.0)
-!
- if (.not. newsas) then ! random number needed for RAS and old SAS
- if (random_clds) then ! create random number tank
-! -------------------------
- if (.not. allocated(rannum_tank))
- & allocate (rannum_tank(lonr,maxran,lats_node_r))
-! lonrb2 = lonr / 2
- lonrbm = lonr / maxsub
- if (me == 0) write(0,*)' maxran=',maxran,' maxrs=',maxrs,
- & 'maxsub=',maxsub,' lonrbm=',lonrbm
-!$OMP parallel do private(nrc,iseedl,rannum,lat,i,j,k,ii,jj,kk)
- do nrc=1,maxrs
- iseedl = seed0 + nrc - 1
- call random_setseed(iseedl,stat(nrc))
- call random_number(rannum,stat(nrc))
- do j=1,lats_node_r
- lat = global_lats_r(ipt_lats_node_r-1+j)
- jj = (lat-1)*lonr
- do k=1,maxsub
- kk = k - 1
- do i=1,lonr
- ii = kk*lonrbm + i
- if (ii > lonr) ii = ii - lonr
- rannum_tank(i,nrc+kk*maxrs,j) = rannum(ii+jj)
- enddo
- enddo
- enddo
- enddo
- endif
- endif
-!
- if (me .eq. 0) then
- print *,' seed0=',seed0,' idate=',idate,' wrk=',wrk
- if (num_p3d .eq. 3) print *,' USING Ferrier-MICROPHYSICS'
- if (num_p3d .eq. 4) print *,' USING ZHAO-MICROPHYSICS'
- endif
- if (fhour .eq. 0.0) then
- do j=1,lats_node_r
- do i=1,lonr
-! phy_f2d(i,j,num_p2d) = 0.0
- phy_f2d(i,num_p2d,j) = 0.0
- enddo
- enddo
- endif
-
- if (ras) call ras_init(levs, me)
-
- first = .false.
- endif ! if (first) done
-!
-! print *,' after if(first) before if semilag'
-
- if (semilag) then
- dtp = tstep
- dtf = tstep
- else
- dtphys = 3600.
- nsphys = max(int((tstep+tstep)/dtphys+0.9999),1)
- dtp = (tstep+tstep)/nsphys
- dtf = 0.5*dtp
- endif
-!
- if(lsfwd) dtf = dtp
-!
- solhr = mod(phour+idate(1),cons_24)
-
-! ************** Ken Campana Stuff ********************************
-!... set switch for saving convective clouds
- if(lscca.and.lsswr) then
- clstp = 1100+min(fhswr,fhour,cons_99) !initialize,accumulate,convert
- elseif(lscca) then
- clstp = 0100+min(fhswr,fhour,cons_99) !accumulate,convert
- elseif(lsswr) then
- clstp = 1100 !initialize,accumulate
- else
- clstp = 0100 !accumulate
- endif
-! ************** Ken Campana Stuff ********************************
-!
-!
- iseed = mod(100.0*sqrt(fhour*3600),cons_1p0d9) + 1 + seed0
-
-
- if (.not. newsas) then ! random number needed for RAS and old SAS
- if (random_clds) then
- call random_setseed(iseed)
- call random_number(wrk2)
- do nrc=1,nrcm
- indxr(nrc) = max(1, min(nint(wrk2(nrc)*maxran)+1,maxran))
- enddo
- endif
- endif
-!
-! doing ozone i/o and latitudinal interpolation to local gauss lats
-! ifozphys=.true.
-
- if (ntoz .gt. 0) then
- call ozinterpol(me,lats_node_r,lats_node_r,idate,fhour,
- & jindx1,jindx2,ozplin,ozplout,ddy)
-
-!Moor call ozinterpol(lats_node_r,lats_node_r,idate,fhour,
-! & jindx1,jindx2,ozplin,ozplout,ddy,
-! & global_lats_r,lonsperlar)
- endif
-
-! if (me == 0) write(0,*)' after ozinterpol'
-!!
-c ----------------------------------------------------
-cc................................................................
-cc
-cc
- call f_hpmstart(41,"gb delnpe")
- call delnpe(trie_ls(1,1,p_zq ),
- x trio_ls(1,1,p_dphi),
- x trie_ls(1,1,p_dlam),
- x epse,epso,ls_node)
- call f_hpmstop(41)
-cc
- call f_hpmstart(42,"gb delnpo")
- call delnpo(trio_ls(1,1,p_zq ),
- x trie_ls(1,1,p_dphi),
- x trio_ls(1,1,p_dlam),
- x epse,epso,ls_node)
- call f_hpmstop(42)
-cc
-cc
- call f_hpmstart(43,"gb dezouv dozeuv")
-!$OMP parallel do shared(trie_ls,trio_ls)
-!$OMP+shared(epsedn,epsodn,snnp1ev,snnp1od,ls_node)
-!$OMP+private(k)
- do k=1,levs
- call dezouv(trie_ls(1,1,p_x +k-1), trio_ls(1,1,p_w +k-1),
- x trie_ls(1,1,p_uln+k-1), trio_ls(1,1,p_vln+k-1),
- x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
-cc
- call dozeuv(trio_ls(1,1,p_x +k-1), trie_ls(1,1,p_w +k-1),
- x trio_ls(1,1,p_uln+k-1), trie_ls(1,1,p_vln+k-1),
- x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
- enddo
- call f_hpmstop(43)
-cc
-! call mpi_barrier (mpi_comm_world,ierr)
-cc
- call countperf(0,4,0.)
- call synctime()
- call countperf(1,4,0.)
-!!
- dimg=0
- call countperf(0,1,0.)
-cc
-! call f_hpmstart(48,"gb syn_ls2lats")
-cc
-! call f_hpmstop(48)
-cc
- call f_hpmstart(49,"gb sumfln")
-cc
- call sumfln_slg_gg(trie_ls(1,1,p_q),
- x trio_ls(1,1,p_q),
- x lat1s_r,
- x plnev_r,plnod_r,
- x 5*levs+3,ls_node,latr2,
- x lats_dim_r,lots,for_gr_r_1,
- x ls_nodes,max_ls_nodes,
- x lats_nodes_r,global_lats_r,
-!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
- x lats_node_r,ipt_lats_node_r,lon_dim_r,
- x lonsperlar,lonrx,latr,0)
-!!
- if(.not.gg_tracers)then
- call sumfln_slg_gg(trie_ls(1,1,p_rt),
- x trio_ls(1,1,p_rt),
- x lat1s_r,
- x plnev_r,plnod_r,
- x levh,ls_node,latr2,
- x lats_dim_r,lots,for_gr_r_1,
- x ls_nodes,max_ls_nodes,
- x lats_nodes_r,global_lats_r,
-!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
- x lats_node_r,ipt_lats_node_r,lon_dim_r,
- x lonsperlar,lonrx,latr,5*levs+3)
- endif ! if(.not.gg_tracers)then
-cc
- call f_hpmstop(49)
-cc
- call countperf(1,1,0.)
-cc
-! print *,' in GLOOPB after second sumfln'
-cc
- pwatg = 0.
- ptotg = 0.
-
-!--------------------
-! if( vertcoord_id == 3. ) then ! For sigms/p/theta
-!--------------------
- call countperf(0,11,0.)
- CALL countperf(0,1,0.) ! hmhj
- call f_hpmstart(50,"gb sumder2") ! hmhj
-!
- do lan=1,lats_node_r
- timer1=rtc()
- lat = global_lats_r(ipt_lats_node_r-1+lan)
- lmax = min(jcap,lonsperlar(lat)/2)
- if ( (lmax+1)*2+1 .le. lonsperlar(lat)+2 ) then
- do k=levs+1,4*levs+2*levh
- do i = (lmax+1)*2+1, lonsperlar(lat)+2
- dyn_gr_r_1(i,k,lan) = cons0 !constant
- enddo
- enddo
- endif
- enddo
-!
- call sumder2_slg(trie_ls(1,1,P_te), ! hmhj
- x trio_ls(1,1,P_te), ! hmhj
- x lat1s_r, ! hmhj
- x pddev_r,pddod_r, ! hmhj
- x levs,ls_node,latr2, ! hmhj
- x lats_dim_r,lotd, ! hmhj
- x dyn_gr_r_1, ! hmhj
- x ls_nodes,max_ls_nodes, ! hmhj
- x lats_nodes_r,global_lats_r, ! hmhj
-!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r, ! hmhj
- x lats_node_r,ipt_lats_node_r,lon_dim_r, ! hmhj
- x lonsperlar,lonrx,latr,0) ! hmhj
-!
- call f_hpmstop(50) ! hmhj
- CALL countperf(1,1,0.)
-! -----------------
-! endif
-! -----------------
-cc
- do lan=1,lats_node_r
- timer1=rtc()
-! if (me == 0) print *,' In lan loop lan=', lan
-cc
-
- lat = global_lats_r(ipt_lats_node_r-1+lan)
-! lon_dim = lon_dims_r(lan)
-cc
- lons_lat = lonsperlar(lat)
-!-----------------------------------------
-! if( vertcoord_id == 3. ) then
-!-----------------------------------------
-
-!! calculate t rq u v zonal derivs. by multiplication with i*l
-!! note rlcs2=rcs2*L/rerth
-
- lmax = min(jcap,lons_lat/2) ! hmhj
-!
- ipt_ls=min(lat,latr-lat+1) ! hmhj
-
- do i=1,lmax+1 ! hmhj
- if ( ipt_ls .ge. lat1s_r(i-1) ) then ! hmhj
- reall=i-1 ! hmhj
- rlcs2(i)=reall*rcs2_r(ipt_ls)/rerth ! hmhj
- else ! hmhj
- rlcs2(i)=cons0 !constant ! hmhj
- endif ! hmhj
- enddo ! hmhj
-!
-!$omp parallel do private(k,i)
- do k=1,levs ! hmhj
- do i=1,lmax+1 ! hmhj
-!
-! d(t)/d(lam) ! hmhj
- dyn_gr_r_1(2*i-1,(kdtlam-1+k),lan)= ! hmhj
- x -for_gr_r_1(2*i ,(kst -1+k),lan)*rlcs2(i) ! hmhj
- dyn_gr_r_1(2*i ,(kdtlam-1+k),lan)= ! hmhj
- x for_gr_r_1(2*i-1,(kst -1+k),lan)*rlcs2(i) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
-! -----------------------
-! endif
-! -----------------------
-
-! print *,' in GLOOPB before four_to_grid'
-cc
- call countperf(0,6,0.)
- call four_to_grid(for_gr_r_1(1,1,lan),for_gr_r_2(1,1,lan),
-!mjr & lon_dim ,lon_dim ,lons_lat,5*levs+3)
- & lon_dim_r,lon_dim_r-2,lons_lat,5*levs+3)
-
- if(.not.gg_tracers)then
- CALL FOUR_TO_GRID(for_gr_r_1(1,ksr,lan),
- & for_gr_r_2(1,ksr,lan),
-!mjr & lon_dim ,lon_dim ,lons_lat,levh)
- & lon_dim_r,lon_dim_r-2,lons_lat,levh)
- else ! gg_tracers
- if (.not.shuff_lats_r) then
-! set for_gr_r_2 to rg1_a rg2_a rg3_a from gloopa
- do k=1,levs
- do i=1,min(lonf,lons_lat)
- for_gr_r_2(i,ksr-1+k ,lan)=
- & rg1_a(i,k,lats_node_a+1-lan)
- for_gr_r_2(i,ksr-1+k+ levs,lan)=
- & rg2_a(i,k,lats_node_a+1-lan)
- for_gr_r_2(i,ksr-1+k+2*levs,lan)=
- & rg3_a(i,k,lats_node_a+1-lan)
- enddo
- enddo
- endif ! not shuff_lats_r
- endif ! gg_tracers
-
-! print *,' in GLOOPB after four_to_grid '
-! ----------------------------------
-! if( vertcoord_id == 3. ) then
-! ----------------------------------
- CALL FOUR_TO_GRID(dyn_gr_r_1(1,kdtphi,lan), ! hmhj
- & dyn_gr_r_2(1,kdtphi,lan), ! hmhj
-!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
- & lon_dim_r,lon_dim_r-2,lons_lat,levs) ! hmhj
- CALL FOUR_TO_GRID(dyn_gr_r_1(1,kdtlam,lan), ! hmhj
- & dyn_gr_r_2(1,kdtlam,lan), ! hmhj
-!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
- & lon_dim_r,lon_dim_r-2,lons_lat,levs) ! hmhj
-! ----------------------------
-! endif
-! ---------------------------
- call countperf(1,6,0.)
-!
- timer2 = rtc()
- global_times_b(lat,me+1) = timer2-timer1
-c$$$ print*,'timeloopb',me,timer1,timer2,global_times_b(lat,me+1)
-!!
- enddo !lan
-cc
-
- if(gg_tracers .and. shuff_lats_r) then
-! print*,' gloopb mpi_tracers_a_to_b shuff_lats_r',shuff_lats_r
- call mpi_tracers_a_to_b(
- x rg1_a,rg2_a,rg3_a,lats_nodes_a,global_lats_a,
- x for_gr_r_2(1,1,1),
- x lats_nodes_r,global_lats_r,ksr,0)
- endif ! gg_tracers .and. shuff_lats_r
-
- call f_hpmstart(51,"gb lat_loop2")
-
- do lan=1,lats_node_r
-
-!
- lat = global_lats_r(ipt_lats_node_r-1+lan)
-cc
-! lon_dim = lon_dims_r(lan)
- lons_lat = lonsperlar(lat)
- pwatp = 0.
- rcs2_lan = rcs2_r(min(lat,latr-lat+1))
- rcs_lan = sqrt(rcs2_lan)
-
-!$omp parallel do schedule(dynamic,1) private(lon)
-!$omp+private(sumq,xcp,hprime_v,swh_v,hlw_v,stc_v,smc_v,slc_v)
-!$omp+private(nlons_v,sinlat_v,coslat_v,ozplout_v,rannum_v)
-!$omp+private(prslk,prsl,prsik,prsi,phil,phii,dpshc,work1,tem)
-!$omp+private(gu,gv1,gd,gq,gphi,glam,gt,gtv,gr,vvel,gtvx,gtvy)
-!$omp+private(adt,adr,adu,adv,pgr,ugrd,vgrd,rqtk)
-!!$omp+private(adt,adr,adu,adv,pgr,rcs_v,ugrd,vgrd,rqtk)
-!$omp+private(phy_f3dv,phy_f2dv)
-!$omp+private(dt3dt_v,dq3dt_v,du3dt_v,dv3dt_v,upd_mf_v,dwn_mf_v)
-!$omp+private(det_mf_v,dkh_v,rnp_v)
-!$omp+private(njeff,item,jtem,ktem,i,j,k,n,kss)
-!!!$omp+private(temlon,temlat,lprnt,ipt)
- do lon=1,lons_lat,ngptc
-!!
- njeff = min(ngptc,lons_lat-lon+1)
-!!
-! lprnt = .false.
-!
-! --- ... for debug test
-! alon = 236.25
-! alat = 56.189
-! alon = 26.25
-! alat = 6.66
-! ipt = 0
-! do i = 1, njeff
-! item = lon + i - 1
-! temlon = xlon(item,lan) * 57.29578
-! if (temlon < 0.0) temlon = temlon + 360.0
-! temlat = xlat(item,lan) * 57.29578
-! lprnt = abs(temlon-alon) < 1.1 .and. abs(temlat-alat) < 1.1
-! & .and. kdt > 0
-! if ( lprnt ) then
-! ipt = i
-! exit
-! endif
-! enddo
-! lprnt = .false.
-!!
- do k = 1, LEVS
- do j = 1, njeff
- jtem = lon-1+j
- gu (j,k) = for_gr_r_2(jtem,KSU-1+k,lan)
- gv1(j,k) = for_gr_r_2(jtem,KSV-1+k,lan)
- gd (j,k) = for_gr_r_2(jtem,KSD-1+k,lan)
- enddo
- enddo
-!
-! p in cb by finite difference from henry juang not ln(p) ! hmhj
- if(.not.gen_coord_hybrid) then ! hmhj
- do j=1,njeff
- item = lon+j-1
- for_gr_r_2(item,ksq,lan) = exp(for_gr_r_2(item,ksq,lan))
- enddo
- endif ! .not.gen_coord_hybrid ! hmhj
- do i=1,njeff
- item = lon+i-1
- gq(i) = for_gr_r_2(item,ksq,lan)
- gphi(i) = for_gr_r_2(item,kspphi,lan)
- glam(i) = for_gr_r_2(item,ksplam,lan)
- enddo
-! Tracers
- do n=1,ntrac
- do k=1,levs
- item = KSR-1+k+(n-1)*levs
- do j=1,njeff
- gr(j,k,n) = for_gr_r_2(lon-1+j,item,lan)
- enddo
- enddo
- enddo
-
-!
-! For omega in gen_coord_hybrid ! hmhj
-! the same variables for thermodyn_id=3 for enthalpy ! hmhj
- if( gen_coord_hybrid ) then
- do k=1,levs ! hmhj
- do j=1,njeff ! hmhj
- gtv(j,k) = for_gr_r_2(lon-1+j,kst-1+k,lan)
- enddo
- enddo
-! --------------------------------------
- if( vertcoord_id.eq.3. ) then
-! --------------------------------------
- do k=1,levs ! hmhj
- do j=1,NJEFF ! hmhj
- jtem = lon-1+j
- gtvx(j,k) = dyn_gr_r_2(jtem,kdtlam-1+k,lan)
- gtvy(j,k) = dyn_gr_r_2(jtem,kdtphi-1+k,lan)
- enddo ! hmhj
- enddo
-! -----------------------------
- endif
-! -----------------------------
- if( thermodyn_id.eq.3 ) then ! hmhj
-! get dry temperature from enthalpy ! hmhj
- do k=1,levs
- do j=1,njeff
- sumq(j,k) = 0.0
- xcp(j,k) = 0.0
- enddo
- enddo
- do n=1,ntrac ! hmhj
- if( cpi(n).ne.0.0 ) then ! hmhj
- kss = ksr+(n-1)*levs ! hmhj
- do k=1,levs ! hmhj
- ktem = kss+k-1
- do j=1,njeff ! hmhj
- sumq(j,k) = sumq(j,k) + gr(j,k,n) ! hmhj
- xcp(j,k) = xcp(j,k) + cpi(n)*gr(j,k,n) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- endif ! hmhj
- enddo ! hmhj
- do k=1,levs ! hmhj
- do j=1,njeff ! hmhj
- work1 = (1.-sumq(j,k))*cpi(0) + xcp(j,k) ! hmhj
- gt(j,k) = gtv(j,k) / work1 ! hmhj
- enddo ! hmhj
- enddo ! hmhj
-! get dry temperature from virtual temperature ! hmhj
- else if( thermodyn_id.le.1 ) then ! hmhj
- do k=1,levs
- do j=1,njeff
- gt(j,k) = gtv(j,k) / (1.0 + fv*max(gr(j,k,1),qmin))
- enddo
- enddo
- else
-! get dry temperature from dry temperature ! hmhj
- do k=1,levs ! hmhj
- do j=1,njeff ! hmhj
- gt(j,k) = gtv(j,k) ! hmhj
- enddo ! hmhj
- enddo
- endif ! if(thermodyn_id.eq.3)
- else
- do k=1,levs
- do j=1,njeff
- gt(j,k) = for_gr_r_2(lon+j-1,kst+k-1,lan)
- & / (1.0 + fv*max(gr(j,k,1),qmin))
- enddo
- enddo
-
- endif ! if(gen_coord_hybrid)
-!
- do j=1,njeff
- item = lon+j-1
- gq_save(item,lan) = for_gr_r_2(item,ksq,lan)
- enddo
-!
-! if (lprnt) then
-! print *,' gq=',gq(ipt),' gphi=',gphi(ipt),glam(ipt)
-! print *,' gd=',gd(ipt,:)
-! print *,' gu=',gu(ipt,:)
-! print *,' gv1=',gv1(ipt,:)
-! endif
-! hmhj for gen_coord_hybrid
- if( gen_coord_hybrid ) then ! hmhj
-
- call hyb2press_gc(njeff,ngptc,gq, gtv, prsi,prsl ! hmhj
- &, prsik, prslk)
-! call omegtes_gc(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)), ! hmhj
- call omegtes_gc(njeff,ngptc,rcs2_lan, ! hmhj
- & gq,gphi,glam,gtv,gtvx,gtvy,gd,gu,gv1,vvel) ! hmhj
- elseif( hybrid )then ! hmhj
-! vertical structure variables: del,si,sl
-
-! if (lprnt) print *,' ipt=',ipt,' ugrb=',gu(ipt,levs),
-! &' vgrb=',gv1(ipt,levs),' lon=',lon
-! &,' xlon=',xlon(lon+ipt-1,lan),' xlat=',xlat(lon+ipt-1,lan)
-
- call hyb2press(njeff,ngptc,gq, prsi, prsl,prsik,prslk)
-! call omegtes(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)),
- call omegtes(njeff,ngptc,rcs2_lan,
- & gq,gphi,glam,gd,gu,gv1,vvel)
-! & gq,gphi,glam,gd,gu,gv1,vvel,lprnt,ipt)
-
-! if (lprnt) then
-! print *,' vvel=',vvel(ipt,:)
-! call mpi_quit(9999)
-! endif
- else ! for sigma coordinate
- call sig2press(njeff,ngptc,gq,sl,si,slk,sik,
- & prsi,prsl,prsik,prslk)
- call omegast3(njeff,ngptc,levs,
- & gphi,glam,gu,gv1,gd,del,rcs2_lan,vvel,gq,sl)
-! & gphi,glam,gu,gv1,gd,del,
-! & rcs2_r(min(lat,latr-lat+1)),vvel,gq,sl)
-
- endif
-!
- do i=1,njeff
- phil(i,levs) = 0.0 ! forces calculation of geopotential in gbphys
- pgr(i) = gq(i) * 1000.0 ! Convert from kPa to Pa for physics
- prsi(i,1) = pgr(i)
- dpshc(i) = 0.3 * prsi(i,1)
-!
- nlons_v(i) = lons_lat
- sinlat_v(i) = sinlat_r(lat)
- coslat_v(i) = coslat_r(lat)
-! rcs_v(i) = sqrt(rcs2_lan)
-! rcs_v(i) = sqrt(rcs2_r(min(lat,latr-lat+1)))
- enddo
- do k=1,levs
- do i=1,njeff
- ugrd(i,k) = gu(i,k) * rcs_lan
- vgrd(i,k) = gv1(i,k) * rcs_lan
-! ugrd(i,k) = gu(i,k) * rcs_v(i)
-! vgrd(i,k) = gv1(i,k) * rcs_v(i)
- prsl(i,k) = prsl(i,k) * 1000.0
- prsi(i,k+1) = prsi(i,k+1) * 1000.0
- vvel(i,k) = vvel(i,k) * 1000.0 ! Convert from Cb/s to Pa/s
- enddo
- enddo
- if (gen_coord_hybrid .and. thermodyn_id == 3) then
- do i=1,ngptc
- prslk(i,1) = 0.0 ! forces calculation of geopotential in gbphys
- prsik(i,1) = 0.0 ! forces calculation of geopotential in gbphys
- enddo
- endif
-!
- if (ntoz .gt. 0) then
- do j=1,pl_coeff
- do k=1,levozp
- do i=1,ngptc
-!Moorthi ozplout_v(i,k,j) = ozplout(lon+i-1,k,j,lan)
- ozplout_v(i,k,j) = ozplout(k,lan,j)
- enddo
- enddo
- enddo
- endif
- do k=1,lsoil
- do i=1,njeff
- item = lon+i-1
- smc_v(i,k) = sfc_fld%smc(item,k,lan)
- stc_v(i,k) = sfc_fld%stc(item,k,lan)
- slc_v(i,k) = sfc_fld%slc(item,k,lan)
- enddo
- enddo
- do k=1,nmtvr
- do i=1,njeff
- hprime_v(i,k) = hprime(lon+i-1,k,lan)
- enddo
- enddo
-!!
- do j=1,num_p3d
- do k=1,levs
- do i=1,njeff
- phy_f3dv(i,k,j) = phy_f3d(lon+i-1,k,j,lan)
- enddo
- enddo
- enddo
- do j=1,num_p2d
- do i=1,njeff
- phy_f2dv(i,j) = phy_f2d(lon+i-1,j,lan)
- enddo
- enddo
- if (.not. newsas) then
- if (random_clds) then
- do j=1,nrcm
- do i=1,njeff
- rannum_v(i,j) = rannum_tank(lon+i-1,indxr(j),lan)
- enddo
- enddo
- else
- do j=1,nrcm
- do i=1,njeff
- rannum_v(i,j) = 0.6 ! This is useful for debugging
- enddo
- enddo
- endif
- endif
- do k=1,levs
- do i=1,njeff
- item = lon+i-1
- swh_v(i,k) = swh(item,k,lan)
- hlw_v(i,k) = hlw(item,k,lan)
- enddo
- enddo
- if (ldiag3d) then
- do n=1,6
- do k=1,levs
- do i=1,njeff
- dt3dt_v(i,k,n) = dt3dt(lon+i-1,k,n,lan)
- enddo
- enddo
- enddo
- do n=1,4
- do k=1,levs
- do i=1,njeff
- du3dt_v(i,k,n) = du3dt(lon+i-1,k,n,lan)
- dv3dt_v(i,k,n) = dv3dt(lon+i-1,k,n,lan)
- enddo
- enddo
- enddo
- endif
- if (ldiag3d .or. lggfs3d) then
- do n=1,5+pl_coeff
- do k=1,levs
- do i=1,njeff
- dq3dt_v(i,k,n) = dq3dt(lon+i-1,k,n,lan)
- enddo
- enddo
- enddo
- do k=1,levs
- do i=1,njeff
- upd_mf_v(i,k) = upd_mf(lon+i-1,k,lan)
- dwn_mf_v(i,k) = dwn_mf(lon+i-1,k,lan)
- det_mf_v(i,k) = det_mf(lon+i-1,k,lan)
- enddo
- enddo
- endif
- if (lggfs3d) then
- do k=1,levs
- do i=1,njeff
- dkh_v(i,k) = dkh(lon+i-1,k,lan)
- rnp_v(i,k) = rnp(lon+i-1,k,lan)
- enddo
- enddo
- endif
-!
-! write(0,*)' calling gbphys kdt=',kdt,' lon=',lon,' lan=',lan
-! &,' nlons_v=',ntoz,ntcw,nmtvr,lonr,latr,jcap,ras
-! &,' tisfc=',sfc_fld%tisfc(lon,lan)
-! print *,' temp=',for_gr_r_2(lon,kst,lan)
-!
- call gbphys &
-! --- inputs:
- & ( njeff,ngptc,levs,lsoil,lsm,ntrac,ncld,ntoz,ntcw, &
- & nmtvr,nrcm,levozp,lonr,latr,jcap,num_p3d,num_p2d, &
- & kdt,lat,me,pl_coeff,nlons_v,ncw,flgmin,crtrh,cdmbgwd, &
- & ccwf,dlqf,ctei_rm,clstp,dtp,dtf,fhour,solhr, &
- & slag,sdec,cdec,sinlat_v,coslat_v,pgr,ugrd,vgrd, &
- & gt,gr,vvel,prsi,prsl,prslk,prsik,phii,phil, &
- & rannum_v,ozplout_v,pl_pres,dpshc, &
- & hprime_v, xlon(lon,lan),xlat(lon,lan), &
- & sfc_fld%slope (lon,lan), sfc_fld%shdmin(lon,lan), &
- & sfc_fld%shdmax(lon,lan), sfc_fld%snoalb(lon,lan), &
- & sfc_fld%tg3 (lon,lan), sfc_fld%slmsk (lon,lan), &
- & sfc_fld%vfrac (lon,lan), sfc_fld%vtype (lon,lan), &
- & sfc_fld%stype (lon,lan), sfc_fld%uustar(lon,lan), &
- & sfc_fld%oro (lon,lan), flx_fld%coszen(lon,lan), &
- & flx_fld%sfcdsw(lon,lan), flx_fld%sfcnsw(lon,lan), &
- & flx_fld%sfcdlw(lon,lan), flx_fld%tsflw (lon,lan), &
- & flx_fld%sfcemis(lon,lan), sfalb(lon,lan), &
- & swh_v, hlw_v, &
- & ras,pre_rad,ldiag3d,lggfs3d,lssav,lssav_cc, &
- & bkgd_vdif_m,bkgd_vdif_h,bkgd_vdif_s,psautco,prautco, evpco, &
- & wminco, &
- & flipv,old_monin,cnvgwd,shal_cnv,sashal,newsas,cal_pre, &
- & mom4ice,mstrat,trans_trac,nst_fcst,moist_adj,fscav, &
- & thermodyn_id, sfcpress_id, gen_coord_hybrid, &
-! --- input/outputs:
- & sfc_fld%hice (lon,lan), sfc_fld%fice (lon,lan), &
- & sfc_fld%tisfc (lon,lan), sfc_fld%tsea (lon,lan), &
- & sfc_fld%tprcp (lon,lan), sfc_fld%cv (lon,lan), &
- & sfc_fld%cvb (lon,lan), sfc_fld%cvt (lon,lan), &
- & sfc_fld%srflag(lon,lan), sfc_fld%snwdph(lon,lan), &
- & sfc_fld%sheleg(lon,lan), sfc_fld%sncovr(lon,lan), &
- & sfc_fld%zorl (lon,lan), sfc_fld%canopy(lon,lan), &
- & sfc_fld%ffmm (lon,lan), sfc_fld%ffhh (lon,lan), &
- & sfc_fld%f10m (lon,lan), flx_fld%srunoff(lon,lan), &
- & flx_fld%evbsa (lon,lan), flx_fld%evcwa (lon,lan), &
- & flx_fld%snohfa(lon,lan), flx_fld%transa(lon,lan), &
- & flx_fld%sbsnoa(lon,lan), flx_fld%snowca(lon,lan), &
- & flx_fld%soilm (lon,lan), flx_fld%tmpmin(lon,lan), &
- & flx_fld%tmpmax(lon,lan), flx_fld%dusfc (lon,lan), &
- & flx_fld%dvsfc (lon,lan), flx_fld%dtsfc (lon,lan), &
- & flx_fld%dqsfc (lon,lan), flx_fld%geshem(lon,lan), &
- & flx_fld%gflux (lon,lan), flx_fld%dlwsfc(lon,lan), &
- & flx_fld%ulwsfc(lon,lan), flx_fld%suntim(lon,lan), &
- & flx_fld%runoff(lon,lan), flx_fld%ep (lon,lan), &
- & flx_fld%cldwrk(lon,lan), flx_fld%dugwd (lon,lan), &
- & flx_fld%dvgwd (lon,lan), flx_fld%psmean(lon,lan), &
- & flx_fld%bengsh(lon,lan), flx_fld%spfhmin(lon,lan), &
- & flx_fld%spfhmax(lon,lan), &
- & dt3dt_v, dq3dt_v, du3dt_v, dv3dt_v, &
- & acv(lon,lan), acvb(lon,lan), acvt(lon,lan), &
- & slc_v, smc_v, stc_v, &
- & upd_mf_v, dwn_mf_v, det_mf_v, dkh_v, rnp_v, &
- & phy_f3dv, phy_f2dv, &
- & DLWSFC_cc(lon,lan), ULWSFC_cc(lon,lan), &
- & DTSFC_cc(lon,lan), SWSFC_cc(lon,lan), &
- & DUSFC_cc(lon,lan), DVSFC_cc(lon,lan), &
- & DQSFC_cc(lon,lan), PRECR_cc(lon,lan), &
-
- & nst_fld%xt(lon,lan), nst_fld%xs(lon,lan), &
- & nst_fld%xu(lon,lan), nst_fld%xv(lon,lan), &
- & nst_fld%xz(lon,lan), nst_fld%zm(lon,lan), &
- & nst_fld%xtts(lon,lan), nst_fld%xzts(lon,lan), &
- & nst_fld%d_conv(lon,lan), nst_fld%ifd(lon,lan), &
- & nst_fld%dt_cool(lon,lan), nst_fld%Qrain(lon,lan), &
-! --- outputs:
- & adt, adr, adu, adv, &
- & sfc_fld%t2m (lon,lan), sfc_fld%q2m (lon,lan), &
- & flx_fld%u10m (lon,lan), flx_fld%v10m (lon,lan), &
- & flx_fld%zlvl (lon,lan), flx_fld%psurf (lon,lan), &
- & flx_fld%hpbl (lon,lan), flx_fld%pwat (lon,lan), &
- & flx_fld%t1 (lon,lan), flx_fld%q1 (lon,lan), &
- & flx_fld%u1 (lon,lan), flx_fld%v1 (lon,lan), &
- & flx_fld%chh (lon,lan), flx_fld%cmm (lon,lan), &
- & flx_fld%dlwsfci(lon,lan), flx_fld%ulwsfci(lon,lan), &
- & flx_fld%dswsfci(lon,lan), flx_fld%uswsfci(lon,lan), &
- & flx_fld%dtsfci(lon,lan), flx_fld%dqsfci(lon,lan), &
- & flx_fld%gfluxi(lon,lan), flx_fld%epi (lon,lan), &
- & flx_fld%smcwlt2(lon,lan), flx_fld%smcref2(lon,lan), &
-!hchuang code change [+3L] 11/12/2007 : add 2D
- & flx_fld%gsoil(lon,lan), flx_fld%gtmp2m(lon,lan), &
- & flx_fld%gustar(lon,lan), flx_fld%gpblh(lon,lan), &
- & flx_fld%gu10m(lon,lan), flx_fld%gv10m(lon,lan), &
- & flx_fld%gzorl(lon,lan), flx_fld%goro(lon,lan), &
-
- & XMU_cc(lon,lan), DLW_cc(lon,lan), DSW_cc(lon,lan), &
- & SNW_cc(lon,lan), LPREC_cc(lon,lan), &
-
- & nst_fld%Tref(lon,lan), nst_fld%z_c(lon,lan), &
- & nst_fld%c_0 (lon,lan), nst_fld%c_d(lon,lan), &
- & nst_fld%w_0 (lon,lan), nst_fld%w_d(lon,lan), &
- & rqtk &! rqtkD
-! & bak_gr_r_2(lon,kap,lan), &! rqtkD
- & )
-!!
- do k=1,levs
- do i=1,njeff
- item = lon + i - 1
- bak_gr_r_2(item,kau+k-1,lan) = adu(i,k) * rcs_lan
- bak_gr_r_2(item,kav+k-1,lan) = adv(i,k) * rcs_lan
-! bak_gr_r_2(item,kau+k-1,lan) = adu(i,k) * rcs_v(i)
-! bak_gr_r_2(item,kav+k-1,lan) = adv(i,k) * rcs_v(i)
- bak_gr_r_2(item,kat+k-1,lan) = adt(i,k)
- enddo
- enddo
- do n=1,ntrac
- do k=1,levs
- ktem = kar+k-1+(n-1)*levs
- do i=1,njeff
- item = lon + i - 1
- bak_gr_r_2(item,ktem,lan) = adr(i,k,n)
- enddo
- enddo
- enddo
- if (gg_tracers) then
- do i=1,njeff
- bak_gr_r_2(lon+i-1,kap,lan) = rqtk(i)
- enddo
- else
- do i=1,njeff
- bak_gr_r_2(lon+i-1,kap,lan) = 0.0
- enddo
- endif
-!!
-!<-- cpl insertion: instantanious variables
- do i=1,njeff
- item = lon+i-1
- U_BOT_cc(item,lan) = adu(i,1)
- V_BOT_cc(item,lan) = adv(i,1)
- Q_BOT_cc(item,lan) = adr(i,1,1)
- P_BOT_cc(item,lan) = prsl(i,1)
- P_SURF_cc(item,lan) = prsi(i,1)
- enddo
-
- do i=1,njeff
- item = lon+i-1
- T_BOT_cc(item,lan) = adt(i,1)
- tem = adt(i,1)*(1+RVRDM1*adr(i,1,1))
- Z_BOT_cc(item,lan) = -(RD/grav)*tem
- & * LOG(prsl(i,1)/prsi(i,1))
-!
- ffmm_cc(item,lan) = sfc_fld%ffmm(item,lan)
- ffhh_cc(item,lan) = sfc_fld%ffhh(item,lan)
- if (sfc_fld%SLMSK(item,lan) .lt. 0.01) then
- T_SFC_cc(item,lan) = sfc_fld%tsea(item,lan)
- & + sfc_fld%oro(item,lan)*RLAPSE
- else
- T_SFC_cc(item,lan) = sfc_fld%tsea(item,lan)
- end if
- FICE_SFC_cc(item,lan) = sfc_fld%fice(item,lan)
- HICE_SFC_cc(item,lan) = sfc_fld%hice(item,lan)
- & * sfc_fld%fice(item,lan)
- enddo
-! do i=istrt,istrt+njeff-1
-! if (ffmm_cc(i,lan).LT.1.0) print *,'ffmm_cc<1',ffmm_cc(i,lan)
-! if (ffhh_cc(i,lan).LT.1.0) print *,'ffhh_cc<1',ffmm_cc(i,lan)
-! enddo
-! if (me .eq. 0) then
-! call atm_maxmin(njeff,1,LPREC_cc(lon,lan),
-! > 'in gbphys_call, LPREC_cc')
-! print *,'after cpl,istrt=',istrt,'istrt+njeff-1=',
-! > istrt+njeff-1,'lan=',lan
-! endif
-!--> cpl insertion
-
- if( gen_coord_hybrid .and. thermodyn_id.eq.3 ) then ! hmhj
-
-! convert dry temperature to enthalpy ! hmhj
- do k=1,levs
- do j=1,njeff
- item = lon+j-1
- sumq(j,k) = 0.0
- xcp(j,k) = 0.0
- enddo
- enddo
- do i=1,ntrac ! hmhj
- kss = kar+(i-1)*levs
- if( cpi(i).ne.0.0 ) then ! hmhj
- do k=1,levs ! hmhj
- ktem = kss+k-1
- do j=1,njeff ! hmhj
- item = lon+j-1
- work1 = bak_gr_r_2(item,ktem,lan) ! hmhj
- sumq(j,k) = sumq(j,k) + work1 ! hmhj
- xcp(j,k) = xcp(j,k) + cpi(i)*work1 ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- endif ! hmhj
- enddo ! hmhj
- do k=1,levs ! hmhj
- ktem = kat+k-1
- do j=1,njeff ! hmhj
- item = lon+j-1
- work1 = (1.-sumq(j,k))*cpi(0) + xcp(j,k) ! hmhj
- bak_gr_r_2(item,ktem,lan) = bak_gr_r_2(item,ktem,lan)
- & * work1 ! hmhj
- adt(j,k) = adt(j,k)*work1
- enddo ! hmhj
- enddo ! hmhj
-
- else ! hmhj
-
-! convert dry temperture to virtual temperature ! hmhj
- do k=1,levs ! hmhj
- ktem = kar+k-1
- jtem = kat+k-1
- do j=1,njeff ! hmhj
- item = lon+j-1
- work1 = 1.0 + fv * max(bak_gr_r_2(item,ktem,lan),qmin) ! hmhj
- bak_gr_r_2(item,jtem,lan) = bak_gr_r_2(item,jtem,lan)
- & * work1 ! hmhj
- adt(j,k) = adt(j,k)*work1
- enddo ! hmhj
- enddo ! hmhj
-
- endif
- if( gen_coord_hybrid .and. vertcoord_id == 3. ) then ! hmhj
- prsi = prsi * 0.001 ! Convert from Pa to kPa
- if( thermodyn_id == 3. ) then ! hmhj
- call gbphys_adv_h(njeff,ngptc,dtf,gtv,gu,gv1,gr , gq, ! hmhj
- & adt,adu,adv,adr,prsi )
-! call gbphys_adv_h(njeff,ngptc,dtf,
-! & for_gr_r_2(lon,kst,lan),
-! & for_gr_r_2(lon,ksu,lan),
-! & for_gr_r_2(lon,ksv,lan),
-! & for_gr_r_2(lon,ksr,lan),
-! & for_gr_r_2(lon,ksq,lan),
-! & bak_gr_r_2(lon,kat,lan),
-! & bak_gr_r_2(lon,kau,lan),
-! & bak_gr_r_2(lon,kav,lan),
-! & bak_gr_r_2(lon,kar,lan),
-! & prsi )
- else
- call gbphys_adv(njeff,ngptc,dtf,gtv,gu,gv1,gr,gq, ! hmhj
- & adt,adu,adv,adr,prsi )
-! call gbphys_adv(njeff,ngptc,dtf,
-! & for_gr_r_2(lon,kst,lan),
-! & for_gr_r_2(lon,ksu,lan),
-! & for_gr_r_2(lon,ksv,lan),
-! & for_gr_r_2(lon,ksr,lan),
-! & for_gr_r_2(lon,ksq,lan),
-! & bak_gr_r_2(lon,kat,lan),
-! & bak_gr_r_2(lon,kau,lan),
-! & bak_gr_r_2(lon,kav,lan),
-! & bak_gr_r_2(lon,kar,lan),
-! & prsi )
- endif ! hmhj
- endif ! hmhj
-!!
- do k=1,lsoil
- do i=1,njeff
- item = lon + i - 1
- sfc_fld%smc(item,k,lan) = smc_v(i,k)
- sfc_fld%stc(item,k,lan) = stc_v(i,k)
- sfc_fld%slc(item,k,lan) = slc_v(i,k)
- enddo
- enddo
-!!
- do j=1,num_p3d
- do k=1,levs
- do i=1,njeff
- phy_f3d(lon+i-1,k,j,lan) = phy_f3dv(i,k,j)
- enddo
- enddo
- enddo
- do j=1,num_p2d
- do i=1,njeff
- phy_f2d(lon+i-1,j,lan) = phy_f2dv(i,j)
- enddo
- enddo
-!
- if (ldiag3d) then
- do n=1,6
- do k=1,levs
- do i=1,njeff
- dt3dt(lon+i-1,k,n,lan) = dt3dt_v(i,k,n)
- enddo
- enddo
- enddo
- do n=1,4
- do k=1,levs
- do i=1,njeff
- du3dt(lon+i-1,k,n,lan) = du3dt_v(i,k,n)
- dv3dt(lon+i-1,k,n,lan) = dv3dt_v(i,k,n)
- enddo
- enddo
- enddo
- endif
- if (ldiag3d .or. lggfs3d) then
- do n=1,5+pl_coeff
- do k=1,levs
- do i=1,njeff
- dq3dt(lon+i-1,k,n,lan) = dq3dt_v(i,k,n)
- enddo
- enddo
- enddo
- do k=1,levs
- do i=1,njeff
- upd_mf(lon+i-1,k,lan) = upd_mf_v(i,k)
- dwn_mf(lon+i-1,k,lan) = dwn_mf_v(i,k)
- det_mf(lon+i-1,k,lan) = det_mf_v(i,k)
- enddo
- enddo
- endif
- if (lggfs3d) then
- do k=1,levs
- do i=1,njeff
- dkh(lon+i-1,k,lan) = dkh_v(i,k)
- rnp(lon+i-1,k,lan) = rnp_v(i,k)
- enddo
- enddo
- endif
-!
- enddo ! lon loop
-!
-!
-! CALL dscal(LEVS*lonr,rcs2_v,bak_gr_r_2(1,kau,lan),1)
-! CALL dscal(LEVS*lonr,rcs2_v,bak_gr_r_2(1,kav,lan),1)
-!
-!
- ptotj(lan) = 0.
- do j=1,lons_lat
- ptotj(lan) = ptotj(lan) + gq_save(j,lan)
- pwatp = pwatp + flx_fld%pwat(j,lan)
-! print *,' kdt=',kdt,' pwatp=',pwatp,' pwat=',flx_fld%pwat(j,lan)
-! &,' j=',j
- enddo
- pwatj(lan) = pwatp*grav/(2.*lonsperlar(lat)*1.e3)
- ptotj(lan) = ptotj(lan)/(2.*lonsperlar(lat))
-!!
-!!
-c$$$ if (kdt.eq.1) then
-c$$$ do j=1,lons_lat
-c$$$ do i=1,levs
-c$$$ write(8700+lat,*)
-c$$$ & bak_gr_r_2(j,kat-1+i,lan),i,j
-c$$$ write(8800+lat,*)
-c$$$ & bak_gr_r_2(j,kar-1+i,lan),i,j
-c$$$ write(8900+lat,*)
-c$$$ & bak_gr_r_2(j,kau-1+i,lan),i,j
-c$$$ write(8100+lat,*)
-c$$$ & bak_gr_r_2(j,kav-1+i,lan),i,j
-c$$$ write(8200+lat,*)
-c$$$ & bak_gr_r_2(j,kar-1+i+levs,lan),i,j
-c$$$ write(8300+lat,*)
-c$$$ & bak_gr_r_2(j,kar-1+i+2*levs,lan),i,j
-c$$$ enddo
-c$$$ enddo
-c$$$ endif
-!!
- enddo ! lan loop
-!
- call f_hpmstop(51)
-!
-! lotn=3*levs+1*levh
-!
- do lan=1,lats_node_r ! four_to_grid lan loop
-!
- lat = global_lats_r(ipt_lats_node_r-1+lan)
-! lon_dim = lon_dims_r(lan)
- lons_lat = lonsperlar(lat)
-!
- call countperf(0,6,0.)
-!
- call grid_to_four(bak_gr_r_2(1,1,lan),bak_gr_r_1(1,1,lan),
- & lon_dim_r-2,lon_dim_r,lons_lat,3*levs+1)
-!
- if (.not. gg_tracers .or. lsout) then
- call grid_to_four(bak_gr_r_2(1,kar,lan),
- & bak_gr_r_1(1,kar,lan),
- & lon_dim_r-2,lon_dim_r,lons_lat,levh)
- endif
- call countperf(1,6,0.)
-
- if (gg_tracers) then
- if (.not.shuff_lats_r) then
- item = lats_node_a + 1 - lan + yhalo
- do k=1,levs
- jtem = levs + 1 - k
- ktem = kar - 1 + k
- do i=1,min(lonf,lons_lat)
- rg1_h(xhalo+i,jtem,item) = bak_gr_r_2(i,ktem,lan)
- rg2_h(xhalo+i,jtem,item) = bak_gr_r_2(i,ktem+levs,lan)
- rg3_h(xhalo+i,jtem,item) = bak_gr_r_2(i,ktem+2*levs,lan)
-
-c$$$ if (kdt .eq. 1) write(888,*) 'rg1_h, = ',
-c$$$ . i,k,lan, rg1_h(xhalo+i,levs+1-k,lats_node_a+1-lan+yhalo)
- enddo
- enddo
- endif ! .not.shuff_lats_r
- endif ! gg_tracers
-!
- enddo ! fin four_to_grid lan loop
-!
- if (gg_tracers .and. shuff_lats_r) then
-! print*,' gloopb mpi_tracers_b_to_a shuff_lats_r',shuff_lats_r
-ccmr call mpi_barrier (mc_comp,ierr)
- call mpi_tracers_b_to_a(
- & bak_gr_r_2(1,1,1),
- & lats_nodes_r,global_lats_r,
- & rg1_h,rg2_h,rg3_h,lats_nodes_a,global_lats_a,kar,0)
- endif ! gg_tracers .and. shuff_lats_r
-
- call countperf(1,11,0.)
-!!
- call countperf(0,4,0.)
- call synctime()
- call countperf(1,4,0.)
-!!
- call excha(lats_nodes_r,global_lats_r,ptotj,pwatj,ptotg,pwatg)
- sumwa = 0.
- sumto = 0.
- do lat=1,latr
- sumto = sumto + wgt_r(min(lat,latr-lat+1))*ptotg(lat)
- sumwa = sumwa + wgt_r(min(lat,latr-lat+1))*pwatg(lat)
-! print *,' kdt=',kdt,' lat=',lat,' sumwa=',sumwa,' sumto=',sumto,
-! &' ptotg=',ptotg(lat),' pwatg=',pwatg(lat)
- enddo
-cjfe
-cjfe write(70+me,*) sumto,sumwa,kdt
- pdryg = sumto - sumwa
-!!
- if(pdryini == 0.) pdryini = pdryg
-
- if( gen_coord_hybrid ) then ! hmhj
- pcorr = (pdryini-pdryg) * sqrt(2.) ! hmhj
- else ! hmhj
- pcorr = (pdryini-pdryg) / sumto * sqrt(2.)
- endif ! hmhj
-!!
-! call f_hpmstart(53,"gb lats2ls")
-cc
-cc
- call countperf(0,1,0.)
-cc
-! call f_hpmstop(53)
-!!
-! call f_hpmstart(54,"gb fl2eov")
-! call f_hpmstop(54)
-!
- call f_hpmstart(52,"gb four2fln")
-!
- call four2fln_gg(lats_dim_r,lota,3*levs+1,bak_gr_r_1,
- x ls_nodes,max_ls_nodes,
-!mjr x lats_nodes_r,global_lats_r,lon_dims_r,
- x lats_nodes_r,global_lats_r,lon_dim_r,
- x lats_node_r,ipt_lats_node_r,
- x lat1s_r,lonrx,latr,latr2,
- x trie_ls(1,1,p_ze), trio_ls(1,1,p_ze),
- x plnew_r, plnow_r,
- x ls_node,0,
- x 2*levs+1,3*levs+1)
-
- sum_k_rqchange_ls(:,:) = trie_ls(:,:,p_q)
- sum_k_rqchango_ls(:,:) = trio_ls(:,:,p_q)
-
- trie_ls(:,:,p_q) = save_qe_ls(:,:)
- trio_ls(:,:,p_q) = save_qo_ls(:,:)
-cc
- if (.not. gg_tracers .or.lsout ) then
- call four2fln_gg(lats_dim_r,lota,levh,bak_gr_r_1,
- x ls_nodes,max_ls_nodes,
-!mjr x lats_nodes_r,global_lats_r,lon_dims_r,
- x lats_nodes_r,global_lats_r,lon_dim_r,
- x lats_node_r,ipt_lats_node_r,
- x lat1s_r,lonrx,latr,latr2,
- x trie_ls(1,1,p_rq), trio_ls(1,1,p_rq),
- x plnew_r, plnow_r,
- x ls_node,3*levs+1,
- x 1,levh)
- endif
-!
- call f_hpmstop(52)
-!
- call f_hpmstart(55,"gb uveodz uvoedz")
-!
-!$OMP parallel do shared(trie_ls,trio_ls)
-!$OMP+shared(epse,epso,ls_node)
-!$OMP+private(k)
- do k=1,levs
- call uveodz(trie_ls(1,1,p_ze +k-1), trio_ls(1,1,p_di +k-1),
- x trie_ls(1,1,p_uln+k-1), trio_ls(1,1,p_vln+k-1),
- x epse,epso,ls_node)
-cc
- call uvoedz(trio_ls(1,1,p_ze +k-1), trie_ls(1,1,p_di +k-1),
- x trio_ls(1,1,p_uln+k-1), trie_ls(1,1,p_vln+k-1),
- x epse,epso,ls_node)
- enddo
- call f_hpmstop(55)
-!
-!.............................................................
- do k=1,levs
- ktem = p_w + k - 1
- jtem = p_vln + k - 1
- do i=1,len_trie_ls
- trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + bfilte(i)*
- & (trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
-
- trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + bfilte(i)*
- & (trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,ktem) = trio_ls(i,1,ktem) + bfilto(i)*
- & (trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
-
- trio_ls(i,2,ktem) = trio_ls(i,2,ktem) + bfilto(i)*
- & (trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- enddo
- enddo
-cc.............................................................
- if(.not.gg_tracers)then
- do k=1,levs
- ktem = p_rt + k - 1
- jtem = p_rq + k - 1
- do i=1,len_trie_ls
- tem = bfilte(i)*(trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
- trie_ls_rqt(i,1,k) = tem
- trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + tem
-!
- tem = bfilte(i)*(trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- trie_ls_rqt(i,2,k) = tem
- trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + tem
- enddo
-!!
- do i=1,len_trio_ls
- tem = bfilto(i)*(trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
- trio_ls_rqt(i,1,k) = tem
- trio_ls(i,1,ktem) = trio_ls(i,1,ktem) + tem
-!
- tem = bfilto(i)*(trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- trio_ls_rqt(i,2,k) = tem
- trio_ls(i,2,p_rt+k-1) = trio_ls(i,2,ktem) + tem
- enddo
- enddo
-!
-!!.............................................................
-!
- do nt=2,ntrac
- do k=levs*(nt-2)+1,levs*(nt-1)
- ktem = p_rt + levs + k - 1
- jtem = p_rq + levs + k - 1
- do i=1,len_trie_ls
- trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + bfilte(i)*
- & (trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
- trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + bfilte(i)*
- & (trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,ktem) = trio_ls(i,1,ktem) + bfilto(i)*
- & (trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
- trio_ls(i,2,ktem) = trio_ls(i,2,ktem) + bfilto(i)*
- & (trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- enddo
- enddo
- enddo
- endif ! if(.not.gg_tracers)
-!!
-!----------------------------------------------------------------------
-!!
- if(hybrid)then
-
-! get some sigma distribution and compute typdel from it.
-
- typical_pgr=85.
-!sela si(k)=(ak5(k)+bk5(k)*typical_pgr)/typical_pgr !ak(k) bk(k) go top to botto
- do k=1,levp1
- si(levs+2-k) = ak5(k)/typical_pgr + bk5(k)
- enddo
- endif
-
- DO k=1,LEVS
- typDEL(k)= SI(k)-SI(k+1)
- ENDDO
-
-!----------------------------------------------------------------------
-
- if (ladj) then
- trie_ls(:,:,p_zq) = 0.
- trio_ls(:,:,p_zq) = 0.
- if (me == me_l_0) then
- trie_ls(1,1,p_zq) = pcorr
- endif
-!!
- if( gen_coord_hybrid ) then ! hmhj
- trie_ls_sfc = 0.0 ! hmhj
- trio_ls_sfc = 0.0 ! hmhj
- do k=1,levs ! hmhj
- do i=1,len_trie_ls ! hmhj
- trie_ls_sfc(i,1) = trie_ls_sfc(i,1)
- & + typdel(k)*trie_ls_rqt(i,1,k) ! hmhj
- trie_ls_sfc(i,2) = trie_ls_sfc(i,2)
- & + typdel(k)*trie_ls_rqt(i,2,k) ! hmhj
- enddo ! hmhj
- do i=1,len_trio_ls ! hmhj
- trio_ls_sfc(i,1) = trio_ls_sfc(i,1)
- & + typdel(k)*trio_ls_rqt(i,1,k) ! hmhj
- trio_ls_sfc(i,2) = trio_ls_sfc(i,2)
- & + typdel(k)*trio_ls_rqt(i,2,k) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
-
- do i=1,len_trie_ls ! hmhj
- trie_ls(i,1,p_zq) = trie_ls(i,1,p_zq) ! hmhj
- & + trie_ls(i,1,p_q )*trie_ls_sfc(i,1) ! hmhj
- trie_ls(i,2,p_zq) = trie_ls(i,2,p_zq) ! hmhj
- & + trie_ls(i,2,p_q )*trie_ls_sfc(i,2) ! hmhj
- enddo
- do i=1,len_trio_ls ! hmhj
- trio_ls(i,1,p_zq) = trio_ls(i,1,p_zq) ! hmhj
- & + trio_ls(i,1,p_q )*trio_ls_sfc(i,1) ! hmhj
- trio_ls(i,2,p_zq) = trio_ls(i,2,p_zq) ! hmhj
- & + trio_ls(i,2,p_q )*trio_ls_sfc(i,2) ! hmhj
- enddo
-
- else ! For hybrid or sigma coordinate
-
- if(gg_tracers)then
- do i=1,len_trie_ls
- trie_ls(i,1,p_zq) = trie_ls(i,1,p_zq)
- & + sum_k_rqchange_ls(i,1)
- trie_ls(i,2,p_zq) = trie_ls(i,2,p_zq)
- & + sum_k_rqchange_ls(i,2)
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,p_zq) = trio_ls(i,1,p_zq)
- & + sum_k_rqchango_ls(i,1)
- trio_ls(i,2,p_zq) = trio_ls(i,2,p_zq)
- & + sum_k_rqchango_ls(i,2)
- enddo
- else
- do k=1,levs
- do i=1,len_trie_ls
- trie_ls(i,1,p_zq) = trie_ls(i,1,p_zq)
- & + typdel(k)*trie_ls_rqt(i,1,k)
- trie_ls(i,2,p_zq) = trie_ls(i,2,p_zq)
- & + typdel(k)*trie_ls_rqt(i,2,k)
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,p_zq) = trio_ls(i,1,p_zq)
- & + typdel(k)*trio_ls_rqt(i,1,k)
- trio_ls(i,2,p_zq) = trio_ls(i,2,p_zq)
- & + typdel(k)*trio_ls_rqt(i,2,k)
- enddo
- enddo
- endif !fin if(gg_tracers)
-
- endif !fin if (gen_coord_hybrid) ! hmhj
-!!
- do k=1,levs
- item = p_di+k-1
- jtem = p_uln+k-1
- ktem = p_x+k-1
- ltem = p_te+k-1
- mtem = p_y+k-1
-
- do i=1,len_trie_ls
- trie_ls(i,1,item) = bfilte(i)
- & * (trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
- trie_ls(i,1,ltem) = bfilte(i)
- & * (trie_ls(i,1,ltem)-trie_ls(i,1,mtem))
- trie_ls(i,2,item) = bfilte(i)
- & * (trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- trie_ls(i,2,ltem) = bfilte(i)
- & * (trie_ls(i,2,ltem)-trie_ls(i,2,mtem))
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,item) = bfilto(i)
- & * (trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
- trio_ls(i,1,ltem) = bfilto(i)
- & * (trio_ls(i,1,ltem)-trio_ls(i,1,mtem))
- trio_ls(i,2,item) = bfilto(i)
- & * (trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- trio_ls(i,2,ltem) = bfilto(i)
- & * (trio_ls(i,2,ltem)-trio_ls(i,2,mtem))
- enddo
- enddo
-
-!---------------------------------------------------------
- if( gen_coord_hybrid ) then ! hmhj
-
-!$OMP parallel do private(locl)
- do locl=1,ls_max_node ! hmhj
-
- call impadje_hyb_gc(trie_ls(1,1,p_x),trie_ls(1,1,p_y), ! hmhj
- & trie_ls(1,1,p_q),trie_ls(1,1,p_di), ! hmhj
- & trie_ls(1,1,p_te),trie_ls(1,1,p_zq), ! hmhj
- & tstep, ! hmhj
- & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln), ! hmhj
- & snnp1ev,ndexev,ls_node,locl) ! hmhj
-!!
- call impadjo_hyb_gc(trio_ls(1,1,p_x),trio_ls(1,1,p_y), ! hmhj
- & trio_ls(1,1,p_q),trio_ls(1,1,p_di), ! hmhj
- & trio_ls(1,1,p_te),trio_ls(1,1,p_zq), ! hmhj
- & tstep, ! hmhj
- & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln), ! hmhj
- & snnp1od,ndexod,ls_node,locl) ! hmhj
- enddo ! hmhj
- elseif(hybrid) then ! for sigma/p hybrid coordinate ! hmhj
- if (.not. semilag) then ! for Eulerian hybrid case
-
-
-!$OMP parallel do private(locl)
- do locl=1,ls_max_node
- call impadje_hyb(trie_ls(1,1,p_x),trie_ls(1,1,p_y),
- & trie_ls(1,1,p_q),trie_ls(1,1,p_di),
- & trie_ls(1,1,p_te),trie_ls(1,1,p_zq),
- & tstep,
- & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln),
- & snnp1ev,ndexev,ls_node,locl)
-!!
- call impadjo_hyb(trio_ls(1,1,p_x),trio_ls(1,1,p_y),
- & trio_ls(1,1,p_q),trio_ls(1,1,p_di),
- & trio_ls(1,1,p_te),trio_ls(1,1,p_zq),
- & tstep,
- & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln),
- & snnp1od,ndexod,ls_node,locl)
- enddo
- else ! for semi-Lagrangian hybrid case
-!$OMP parallel do private(locl)
- do locl=1,ls_max_node
-
-
- call impadje_slg(trie_ls(1,1,p_x),trie_ls(1,1,p_y),
- & trie_ls(1,1,p_q),trie_ls(1,1,p_di),
- & trie_ls(1,1,p_te),trie_ls(1,1,p_zq),
- & tstep,
- & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln),
- & snnp1ev,ndexev,ls_node,locl,batah)
-!!
- call impadjo_slg(trio_ls(1,1,p_x),trio_ls(1,1,p_y),
- & trio_ls(1,1,p_q),trio_ls(1,1,p_di),
- & trio_ls(1,1,p_te),trio_ls(1,1,p_zq),
- & tstep,
- & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln),
- & snnp1od,ndexod,ls_node,locl,batah)
- enddo
- endif
-
- else ! massadj in sigma coordinate
-
- call countperf(0,9,0.)
-!$OMP parallel do private(locl)
- do locl=1,ls_max_node
- call impadje(trie_ls(1,1,p_x),trie_ls(1,1,p_y),
- & trie_ls(1,1,p_q),trie_ls(1,1,p_di),
- & trie_ls(1,1,p_te),trie_ls(1,1,p_zq),
- & am,bm,sv,tstep,
- & trie_ls(1,1,p_uln),trie_ls(1,1,p_vln),
- & snnp1ev,ndexev,ls_node,locl)
-!!
- call impadjo(trio_ls(1,1,p_x),trio_ls(1,1,p_y),
- & trio_ls(1,1,p_q),trio_ls(1,1,p_di),
- & trio_ls(1,1,p_te),trio_ls(1,1,p_zq),
- & am,bm,sv,tstep,
- & trio_ls(1,1,p_uln),trio_ls(1,1,p_vln),
- & snnp1od,ndexod,ls_node,locl)
- enddo
-
- call countperf(1,9,0.)
-
- endif ! fin massadj in sigma
-!---------------------------------------------------------
-
- else ! fin massadj, following is with no masadj
- DO k=1,LEVS
- del(k) = typDEL(k) ! sela 4.5.07
- ENDDO
- if (me == me_l_0) then
- trie_ls(1,1,p_q) = trie_ls(1,1,p_q) + pcorr
- endif
-!
-! testing mass correction on sep 25
-!!
- if(gg_tracers)then
- do i=1,len_trie_ls
- trie_ls(i,1,p_q) = trie_ls(i,1,p_q) + sum_k_rqchange_ls(i,1)
- trie_ls(i,2,p_q) = trie_ls(i,2,p_q) + sum_k_rqchange_ls(i,2)
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,p_q) = trio_ls(i,1,p_q) + sum_k_rqchango_ls(i,1)
- trio_ls(i,2,p_q) = trio_ls(i,2,p_q) + sum_k_rqchango_ls(i,2)
- enddo
- else
- do k=1,levs
- do i=1,len_trie_ls
- trie_ls(i,1,p_q)=trie_ls(i,1,p_q)+del(k)*trie_ls_rqt(i,1,k)
- trie_ls(i,2,p_q)=trie_ls(i,2,p_q)+del(k)*trie_ls_rqt(i,2,k)
- enddo
- do i=1,len_trio_ls
- trio_ls(i,1,p_q)=trio_ls(i,1,p_q)+del(k)*trio_ls_rqt(i,1,k)
- trio_ls(i,2,p_q)=trio_ls(i,2,p_q)+del(k)*trio_ls_rqt(i,2,k)
- enddo
- enddo
- endif
-!
-! testing mass correction on sep 25
-!
- do k=1,levs
- item = p_di+k-1
- jtem = p_uln+k-1
- ktem = p_x+k-1
- ltem = p_te+k-1
- mtem = p_y+k-1
- do i=1,len_trie_ls
- trie_ls(i,1,ktem) = trie_ls(i,1,ktem) + bfilte(i)
- & *(trie_ls(i,1,jtem)-trie_ls(i,1,ktem))
- trie_ls(i,2,ktem) = trie_ls(i,2,ktem) + bfilte(i)
- & *(trie_ls(i,2,jtem)-trie_ls(i,2,ktem))
- trie_ls(i,1,mtem) = trie_ls(i,1,mtem) + bfilte(i)
- & *(trie_ls(i,1,ltem)-trie_ls(i,1,mtem))
- trie_ls(i,2,mtem) = trie_ls(i,2,mtem) + bfilte(i)
- & *(trie_ls(i,2,ltem)-trie_ls(i,2,mtem))
- enddo
-
- do i=1,len_trio_ls
- trio_ls(i,1,ktem) = trio_ls(i,1,ktem)+bfilto(i)
- & *(trio_ls(i,1,jtem)-trio_ls(i,1,ktem))
- trio_ls(i,2,ktem) = trio_ls(i,2,ktem) + bfilto(i)
- & *(trio_ls(i,2,jtem)-trio_ls(i,2,ktem))
- trio_ls(i,1,mtem) = trio_ls(i,1,mtem) + bfilto(i)
- & *(trio_ls(i,1,ltem)-trio_ls(i,1,mtem))
- trio_ls(i,2,mtem) = trio_ls(i,2,mtem) + bfilto(i)
- & *(trio_ls(i,2,ltem)-trio_ls(i,2,mtem))
- enddo
- enddo
- endif ! fin no ladj (i.e. no massadj)
-!!
- return
- end
Modified: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopr.f
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopr.f 2012-05-10 23:36:12 UTC (rev 1894)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopr.f 2012-05-10 23:40:46 UTC (rev 1895)
@@ -1,18 +1,27 @@
+!---modified from GFS gloopr.f for use in MPAS model
+!---vertical index is from surafce to top.
+!---Fanglin Yang, May 2012
+
subroutine gloopr
- x (phour,xlon,xlat,coszdg,COSZEN,
- & SLMSK,SHELEG,SNCOVR,SNOALB,ZORL,TSEA,HPRIME,
-!lu [+1L]: extract snow-free albedo (SFALB)
- + SFALB,
- & ALVSF,ALNSF ,ALVWF ,ALNWF,FACSF ,FACWF,CV,CVT ,
- & CVB ,SWH,HLW,SFCNSW,SFCDLW,
- & FICE ,TISFC, SFCDSW, sfcemis, ! FOR SEA-ICE - XW Nov04
- & TSFLW,FLUXR , phy_f3d,slag,sdec,cdec,KDT)
+!---input
+ & (phour,kdt,lonsperlar,global_lats_r,xlon,xlat,
+ & slmsk,sheleg, zorl, tsea,
+ & alvsf, alnsf, alvwf, alnwf, facsf, facwf,
+ & cv, cvt, cvb, fice, tisfc, sncovr, snoalb,
+ & hprime,phy_f3d,
+ & mp_pi,mp_pl,mp_t,mp_q,mp_w,mp_tr,
+!--in and out
+ & fluxr,
+!--output
+ & swh,hlw,
+ & coszdg, coszen, sfcnsw, sfcdlw, tsflw,
+ & sfcdsw, sfalb, sfcemis,
+ & slag,sdec,cdec)
!!
#include "f_hpm.h"
!
- USE MACHINE , ONLY : kind_phys
- USE FUNCPHYS , ONLY : fpkap
- USE PHYSCONS, FV => con_fvirt, rerth => con_rerth ! hmhj
+ use machine , only : kind_phys
+ use physcons , only : con_rocp
use module_radiation_driver, only : radinit, grrad
use module_radiation_astronomy,only : astronomy
@@ -23,7 +32,9 @@
!
use resol_def
use layout1
+ use gg_def
use vert_def
+ use gfsmisc_def, only : sinlat_r2, coslat_r2
use date_def
use namelist_def
use d3d_def , only : cldcov
@@ -34,34 +45,44 @@
include 'mpif.h'
!
real (kind=kind_phys), parameter :: QMIN =1.0e-10
- real (kind=kind_evod), parameter :: Typical_pgr = 95.0
- real (kind=kind_evod), parameter :: cons0 = 0.0, cons2 = 2.0
!
! --- ... inputs:
- real (kind=kind_phys), dimension(LONR,LATS_NODE_R), intent(in) :: &
+ integer, intent(in) :: kdt
+ integer, intent(in) :: lonsperlar(latr),global_lats_r(latr)
+ real (kind=kind_phys), dimension(lonr,lats_node_r), intent(in) :: &
& xlon, xlat, slmsk, sheleg, zorl, tsea, &
& alvsf, alnsf, alvwf, alnwf, facsf, facwf, &
& cv, cvt, cvb, FICE, tisfc, sncovr, snoalb
-
real (kind=kind_phys), intent(in) :: &
- & hprime(LONR,NMTVR,LATS_NODE_R), phour, &
- & phy_f3d(LONR,LEVS,NUM_P3D,LATS_NODE_R)
+ & hprime(lonr,nmtvr,lats_node_r), phour, &
+ & phy_f3d(lonr,levs,num_p3d,lats_node_r)
+
+! --mp_pi : model interface level pressure in centibar
+! --mp_pl : model integer layer pressure in centibar
+! --mp_w : model layer vertical velocity in centibar/sec
+! --mp_t : model layer temperature in K
+! --mp_q : model layer specific humidity in gm/gm
+! --mp_tr : model layer tracer (ozne and cloud water) mass mixing ratio
+ real (kind=kind_phys), intent(in) ::
+ & mp_pi(lonr,levp1,lats_node_r) ,
+ & mp_pl(lonr,levs,lats_node_r) ,
+ & mp_t(lonr,levs,lats_node_r) ,
+ & mp_w(lonr,levs,lats_node_r) ,
+ & mp_q(lonr,levs,lats_node_r) ,
+ & mp_tr(lonr,levs,ntrac-1,lats_node_r)
+
!
! --- ... input and output:
real (kind=kind_phys), intent(inout) :: &
& fluxr (LONR,NFXR,LATS_NODE_R)
- integer, intent(in) :: KDT
-
! --- ... outputs:
real (kind=kind_phys), intent(out) :: &
& swh(LONR,LEVS,LATS_NODE_R), &
& hlw(LONR,LEVS,LATS_NODE_R)
-
real (kind=kind_phys),dimension(LONR,LATS_NODE_R), intent(out) :: &
& coszdg, coszen, sfcnsw, sfcdlw, tsflw, &
- & sfcdsw, SFALB, sfcemis
-
+ & sfcdsw, sfalb, sfcemis
real (kind=kind_phys), intent(out) :: slag, sdec, cdec
!! --- ... optional spectral band heating rates
@@ -70,23 +91,21 @@
!! & htrlwb(NGPTC,LEVS,NBDLW,NBLCK,LATS_NODE_R)
! --- ... locals:
- real(kind=kind_phys) :: prsl(NGPTC,LEVS), prslk(NGPTC,LEVS), &
- & prsi(NGPTC,LEVP1), prsik(NGPTC,LEVP1), &
- & hlw_v(NGPTC,LEVS), swh_v(NGPTC,LEVS)
+! --prsi : model level pressure in centipar
+! --prsl : model layer mean pressure in centibar
+! --gt : model layer mean temperature in k
+! --gr : layer specific humidity in gm/gm
+! --gr1 : layer tracer (ozne and cloud water) mass mixing ratio
+! --vvel : layer mean vertical velocity in centibar/sec
+ real (kind=kind_phys) :: prsi(NGPTC,levp1),prsl(NGPTC,levs), &
+ & prslk(NGPTC,levs),gt(NGPTC,levs), &
+ & gr(NGPTC,levs),vvel(NGPTC,levs), &
+ & gr1(NGPTC,levs,ntrac-1)
+ real(kind=kind_phys) :: hlw_v(NGPTC,LEVS), swh_v(NGPTC,LEVS)
+
real (kind=kind_phys) :: si_loc(LEVR+1)
- real (kind=kind_phys) :: &
- & gt(NGPTC,LEVR), gq(NGPTC), &
- & gr(NGPTC,LEVR), gr1(NGPTC,LEVR,NTRAC-1), &
- & gtv(NGPTC,LEVR)
-
- real (kind=kind_phys), allocatable :: sumq(:,:), xcp(:,:), &
- & gtvx(:,:), gtvy(:,:), &
- & vvel(:,:), gd(:,:), &
- & gu(:,:), gv1(:,:), &
- & gphi(:), glam(:)
-
real (kind=kind_phys) :: f_ice(NGPTC,LEVS), f_rain(NGPTC,LEVS), &
& r_rime(NGPTC,LEVS)
@@ -205,9 +224,6 @@
integer :: ipt
logical :: lprnt
-! --- timers:
- real*8 :: rtc, timer1, timer2
-!
!===> *** ... begin here
!
!!
@@ -263,51 +279,15 @@
if (first) then
sas_shal = sashal .and. (.not. ras)
!
- if( hybrid.or.gen_coord_hybrid ) then ! hmhj
+!--a reference sigma for radiation initilization, k from surfce to top
+ do k = 1, levr+1
+ si_loc(k) = mp_pi(1,k,1)/mp_pi(1,1,1)
+ enddo
- if( gen_coord_hybrid ) then ! hmhj
- si_loc(levr+1) = si(levp1) ! hmhj
- do k=1,levr ! hmhj
- si_loc(k) = si(k) ! hmhj
- enddo ! hmhj
- else ! hmhj
-! --- get some sigma distribution for radiation-cloud initialization
-!sela si(k)=(ak5(k)+bk5(k)*Typical_pgr)/Typical_pgr !ak(k) bk(k) go top to botto
- si_loc(levr+1)= ak5(1)/typical_pgr+bk5(1)
- do k=1,levr
- si_loc(levr+1-k)= ak5(levp1-levr+k)/typical_pgr
- & + bk5(levp1-levr+k)
- enddo
- endif
- else
- do k = 1, levr
- si_loc(k) = si(k)
- enddo
- si_loc(levr+1) = si(levp1)
- endif ! end_if_hybrid
-
! --- determin prognostic/diagnostic cloud scheme
-
icwp = 0
if (NTCW > 0) icwp = 1
- if( thermodyn_id.eq.3 ) then
- if (.not. allocated(xcp)) allocate (xcp(ngptc,levr))
- if (.not. allocated(sumq)) allocate (sumq(ngptc,levr))
- endif
- if( ntcw <= 0 ) then
- if( gen_coord_hybrid .and. vertcoord_id == 3.) then
- if (.not. allocated(gtvx)) allocate (gtvx(ngptc,levs))
- if (.not. allocated(gtvy)) allocate (gtvy(ngptc,levs))
- endif
- if (.not. allocated(gu)) allocate (gu(ngptc,levs))
- if (.not. allocated(gv1)) allocate (gv1(ngptc,levs))
- if (.not. allocated(gd)) allocate (gd(ngptc,levs))
- if (.not. allocated(vvel)) allocate (vvel(ngptc,levs))
- if (.not. allocated(gphi)) allocate (gphi(ngptc))
- if (.not. allocated(glam)) allocate (glam(ngptc))
- endif
-
! --- generate initial permutation seed for random number generator
if ( ISUBC_LW==2 .or. ISUBC_SW==2 ) then
@@ -341,8 +321,7 @@
! print *,' calling astronomy'
call astronomy &
! --- inputs:
- & ( lonsperlar, global_lats_r, sinlat_r, coslat_r, xlon, &
-! & fhswr, jdat, deltim, &
+ & ( lonsperlar, global_lats_r, sinlat_r2, coslat_r2, xlon, &
& fhswr, jdat, &
& LONR, LATS_NODE_R, LATR, IPT_LATS_NODE_R, lsswr, me, &
! --- outputs:
@@ -371,8 +350,7 @@
do k = 1, 2
do j = 1, lats_node_r
-! lat = global_lats_r(ipt_lats_node_r-1+j)
-
+ lat = global_lats_r(ipt_lats_node_r-1+j)
do i = 1, LONR
lat =xlat(i,j)
ixseed(i,j,k) = numrdm(i+(lat-1)*LONR+(k-1)*LATR)
@@ -382,341 +360,71 @@
endif
!
-!!
- do i = 1, LONR
- do lan=1,lats_node_r
-!!
-! lat = global_lats_r(ipt_lats_node_r-1+lan)
- lat = xlat(i,j)
- lon = xlon(i,j)
- lons_lat=LONR
-!!
-! lon_dim = lon_dims_r(lan)
-!!
- lons_lat = lonsperlar(lat)
-
-! -------------------------------------------------------
- if( gen_coord_hybrid .and. vertcoord_id.eq.3. ) then
-! -------------------------------------------------------
!
- lmax = min(jcap,lons_lat/2) ! hmhj
- ipt_ls = min(lat,latr-lat+1) ! hmhj
-
- do i=1,lmax+1 ! hmhj
- if ( ipt_ls .ge. lat1s_r(i-1) ) then ! hmhj
- reall = i-1 ! hmhj
- rlcs2(i) = reall*rcs2_r(ipt_ls)/rerth ! hmhj
- else ! hmhj
- rlcs2(i) = cons0 !constant ! hmhj
- endif ! hmhj
- enddo ! hmhj
-!
-!$omp parallel do private(k,i,item,jtem)
- do k=1,levs ! hmhj
- item = kdtlam-1+k
- jtem = kst -1+K
- do i=1,lmax+1 ! hmhj
-!
-! d(t)/d(lam) ! hmhj
- dyn_gr_r_1(i+i-1,item,lan) = -for_gr_r_1(i+i,jtem,lan)
- & * rlcs2(i) ! hmhj
- dyn_gr_r_1(i+i,item,lan) = for_gr_r_1(i+i-1,jtem,lan)
- & * rlcs2(i) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
-! --------------------
- endif ! gc and vertcoord_id=3
-! ---------------------
-!
-!!
- CALL countperf(0,6,0.)
-!sela print*,' beginning call four2grid',lan
-! print*,' beginning call four2grid',lan
- CALL FOUR_TO_GRID(for_gr_r_1(1,1,lan),for_gr_r_2(1,1,lan),
-!mjr & lon_dim ,lon_dim ,lons_lat,5*levs+3)
- & lon_dim_r,lonr,lons_lat,5*levs+3)
-
-! print*,' after first call four2grid',lan
- if(gg_tracers)then
-!
-! set tracers grid values from layout_grid_tracers
-!
- if (.not.shuff_lats_r) then
-! set for_gr_r_2 to rg1_a rg2_a rg3_a from gloopa
- do k=1,levs
- item = KSR - 1 + k
- jtem = lats_node_a+1-lan
- do i=1,min(lonf,lons_lat)
- for_gr_r_2(i,item ,lan) = rg1_a(i,k,jtem)
- for_gr_r_2(i,item+ levs,lan) = rg2_a(i,k,jtem)
- for_gr_r_2(i,item+2*levs,lan) = rg3_a(i,k,jtem)
- enddo
- enddo
- endif ! not shuff_lats_r
-
- else
-! print *,' begin second call to FOUR_TO_GRID in gloopr'
- CALL FOUR_TO_GRID(for_gr_r_1(1,KSR,lan),
- & for_gr_r_2(1,KSR,lan),
-!mjr & lon_dim ,lon_dim ,lons_lat,levh)
- & lon_dim_r,lonr,lons_lat,levh)
- endif
-! print *,' after second call to FOUR_TO_GRID in gloopr'
-
-! -------------------------------------------------------
- if( gen_coord_hybrid.and.vertcoord_id.eq.3. ) then ! hmhj
-! -------------------------------------------------------
- CALL FOUR_TO_GRID(dyn_gr_r_1(1,1,lan),dyn_gr_r_2(1,1,lan), ! hmhj
-!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
- & lon_dim_r,lonr,lons_lat,levs) ! hmhj
- CALL FOUR_TO_GRID(dyn_gr_r_1(1,KDTLAM,lan), ! hmhj
- & dyn_gr_r_2(1,KDTLAM,lan), ! hmhj
-!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
- & lon_dim_r,lonr,lons_lat,levs) ! hmhj
-! -------------------------
- endif ! gc and vertcoord_id=3
-! -------------------------
-
-! print*,' completed call four2grid lan=',lan
-!sela print*,' completed call four2grid lan=',lan
- CALL countperf(1,6,0.)
-!!
- if( .not. gen_coord_hybrid ) then ! hmhj
-
- do k = 1, LEVS
- item = KSR-1+k
- jtem = KST-1+k
- do j = 1, lons_lat
- if (for_gr_r_2(j,item,lan) <= qmin) then
- for_gr_r_2(j,item,lan) = qmin
- endif
- for_gr_r_2(j,jtem,lan) = for_gr_r_2(j,jtem,lan)
- & / (1.0 + FV*for_gr_r_2(j,item,lan))
- enddo
- enddo
-! print *,' now do sfc pressure for lan=',lan
- do j = 1, lons_lat
- for_gr_r_2(j,KSQ,lan) = exp( for_gr_r_2(j,KSQ,lan) )
- enddo
-! print *,' after sfc pressure for lan=',lan
-
- endif ! hmhj
-!
-!!
- enddo !lan
-!
- call f_hpmstart(69,"gr lat_loop2")
-!
!===> *** ... starting latitude loop
-!
+!--------------------
do lan=1,lats_node_r
-!
- lat = global_lats_r(ipt_lats_node_r-1+lan)
-!
- lons_lat = lonsperlar(lat)
+ lat = global_lats_r(ipt_lats_node_r-1+j)
+ lons_lat = lonsperlar(lan)
+
!!
!$omp parallel do schedule(dynamic,1) private(lon,i,j,k)
-!$omp+private(vvel,gu,gv1,gd,gt,gr,gr1,gq,gphi,glam)
-!$omp+private(gtv,gtvx,gtvy,sumq,xcp)
+!$omp+private(vvel,gt,gr,gr1)
!$omp+private(cldcov_v,fluxr_v,f_ice,f_rain,r_rime)
!$omp+private(prslk,prsl,prsik,prsi,flgmin_v,hlw_v,swh_v)
!$omp+private(njeff,n,item,jtem,ks,work1,work2)
!$omp+private(icsdsw,icsdlw)
!$omp+private(lprnt,ipt)
-!!!$omp+private(temlon,temlat,lprnt,ipt)
- DO lon=1,lons_lat,NGPTC
-!!
- NJEFF = MIN(NGPTC,lons_lat-lon+1)
-!!
- lprnt = .false.
+ do lon=1,lons_lat,ngptc
+!--------------------
+ NJEFF = MIN(ngptc,lons_lat-lon+1)
+ lprnt = .false.
+ ipt=lon !diagnostic printout point
!
-! --- ... for debug test
-! alon = 236.25
-! alat = 56.189
-! alon = 97.5
-! alat = -6.66
-! ipt = 0
-! do i = 1, njeff
-! item = lon + i - 1
-! temlon = xlon(item,lan) * 57.29578
-! if (temlon < 0.0) temlon = temlon + 360.0
-! temlat = xlat(item,lan) * 57.29578
-! lprnt = abs(temlon-alon) < 1.1 .and. abs(temlat-alat) < 1.1
-! & .and. kdt > 0
-! if ( lprnt ) then
-! ipt = i
-! print *,' ipt=',ipt,' lon=',lon,' lan=',lan
-! exit
-! endif
-! enddo
-! lprnt = .false.
-!!
- if (ntcw <= 0) then
- do k = 1, LEVS
- do j = 1, njeff
- jtem = lon-1+j
- gu (j,k) = for_gr_r_2(jtem,KSU-1+k,lan)
- gv1(j,k) = for_gr_r_2(jtem,KSV-1+k,lan)
- gd (j,k) = for_gr_r_2(jtem,KSD-1+k,lan)
- enddo
- enddo
- endif
+ do k=1,levr+1
+ do j=1,njeff
+ jtem = lon-1+j
+ prsi(j,k)=mp_pi(jtem,k,lan)
+ enddo
+ enddo
+ do k=1,levr
+ do j=1,njeff
+ jtem = lon-1+j
+ prsl(j,k)=mp_pl(jtem,k,lan)
+ gt(j,k)=mp_t(jtem,k,lan)
+ gr(j,k)=mp_q(jtem,k,lan)
+ vvel(j,k)=mp_w(jtem,k,lan)
+ prslk(j,k) = (0.01*prsl(j,k))**con_rocp
+ do n=1,ntrac-1
+ gr1(j,k,n)=mp_tr(jtem,k,n,lan)
+ enddo
+ enddo
+ enddo
- if( gen_coord_hybrid ) then ! hmhj
- do k=1,levr ! hmhj
- do j=1,NJEFF ! hmhj
- jtem = lon-1+j
- gtv (j,k) = for_gr_r_2(jtem,KST-1+k,lan)
- gr (j,k) = max(qmin, for_gr_r_2(jtem,KSR-1+k,lan))
-! gt (j,k) = gtv(j,k) / (1.+fv*gr(j,k))
- enddo ! hmhj
- enddo
-! --------------------------------------
- if( vertcoord_id == 3. .and. ntcw <= 0 ) then
-! --------------------------------------
- do k=1,levs ! hmhj
- do j=1,NJEFF ! hmhj
- jtem = lon-1+j
- gtvx(j,k) = dyn_gr_r_2(jtem,KDTLAM-1+k,lan)
- gtvy(j,k) = dyn_gr_r_2(jtem,KDTPHI-1+k,lan)
- enddo ! hmhj
- enddo
-! -----------------------------
- endif
-! -----------------------------
- if( thermodyn_id.eq.3 ) then ! get dry temperature from enthalpy
- do k=1,levr ! hmhj
- do j=1,njeff ! hmhj
- sumq(j,k) = 0.0 ! hmhj
- xcp(j,k) = 0.0 ! hmhj
- enddo
- enddo
- do i=1,ntrac ! hmhj
- if( cpi(i).ne.0.0 ) then ! hmhj
- ks = ksr+(i-1)*levs ! hmhj
- do k=1,levr ! hmhj
- item = ks-1+k
- do j=1,njeff ! hmhj
- jtem = lon-1+j
- sumq(j,k) = sumq(j,k) + for_gr_r_2(jtem,item,lan) ! hmhj
- xcp(j,k) = xcp(j,k)
- & + cpi(i)*for_gr_r_2(jtem,item,lan) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- endif ! hmhj
- enddo ! hmhj
- do k=1,levr ! hmhj
- do j=1,njeff ! hmhj
- xcp(j,k) = (1.-sumq(j,k))*cpi(0) + xcp(j,k) ! hmhj
- gt(j,k) = gtv(j,k) / xcp(j,k) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- else if( thermodyn_id.le.1 ) then ! hmhj
-! get dry temperature from virtual temperature ! hmhj
- do k=1,levr ! hmhj
- do j=1,njeff ! hmhj
- gt(j,k) = gtv(j,k) / (1.+fv*gr(j,k)) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- else
-! get dry temperature from dry temperature ! hmhj
- do k=1,levr ! hmhj
- do j=1,njeff ! hmhj
- gt(j,k) = gtv(j,k) ! hmhj
- enddo ! hmhj
- enddo
- endif
-
- else ! hmhj
+ do k=1,nfxr
+ do j=1,njeff
+ fluxr_v(j,k) = fluxr(lon+j-1,k,lan)
+ enddo
+ enddo
!
- do k = 1, levr
- do j = 1, njeff
- jtem = lon-1+j
- gt(j,k) = for_gr_r_2(jtem,KST-1+k,lan)
- gr(j,k) = for_gr_r_2(jtem,KSR-1+k,lan)
- enddo
- enddo
-
- endif
-!
-! Remaining tracers
-!
- do n = 1, NTRAC-1
- do k = 1, LEVR
- item = KSR-1+k+n*levs
- do j = 1, njeff
- gr1(j,k,n) = for_gr_r_2(lon-1+j,item,lan)
- enddo
- enddo
- enddo
- if (ntcw > 0) then
- do j = 1, njeff
- gq (j) = for_gr_r_2(lon-1+j,KSQ,lan)
- enddo
- else
- do j = 1, njeff
- jtem = lon-1+j
- gq (j) = for_gr_r_2(jtem,KSQ ,lan)
- gphi(j) = for_gr_r_2(jtem,KSPPHI,lan)
- glam(j) = for_gr_r_2(jtem,KSPLAM,lan)
- enddo
- endif
-!!
-! --- vertical structure variables: del,si,sl,prslk,prdel
-!
- if( gen_coord_hybrid ) then ! hmhj
- call hyb2press_gc(njeff,ngptc,gq,gtv,prsi,prsl,prsik,prslk) ! hmhj
- if (ntcw <= 0)
- & call omegtes_gc(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)), ! hmhj
- & gq,gphi,glam,gtv,gtvx,gtvy,gd,gu,gv1,vvel) ! hmhj
- elseif (hybrid) then
- call hyb2press(njeff,ngptc,gq, prsi, prsl,prsik, prslk)
- if (ntcw <= 0)
- & call omegtes(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)),
- & gq,gphi,glam,gd,gu,gv1,vvel)
-! & gq,gphi,glam,gd,gu,gv1,vvel,ngptc,lprnt,ipt)
- else
- call sig2press(njeff,ngptc,gq,sl,si,slk,sik,
- & prsi,prsl,prsik,prslk)
- CALL countperf(0,12,0.)
- if (ntcw <= 0)
- & call omegast3(njeff,ngptc,levs,
- & gphi,glam,gu,gv1,gd,del,
- & rcs2_r(min(lat,latr-lat+1)),vvel,gq,sl)
- endif
-!.....
- if (levr .lt. levs) then
- do j=1,njeff
- prsi(j,levr+1) = prsi(j,levp1)
- prsl(j,levr) = (prsi(j,levp1) + prsi(j,levr)) * 0.5
- prsik(j,levr+1) = prslk(j,levp1)
- prslk(j,levr) = fpkap(prsl(j,levr)*1000.0)
- enddo
- endif
-!
- do k=1,nfxr
- do j=1,njeff
- fluxr_v(j,k) = fluxr(lon+j-1,k,lan)
- enddo
- enddo
-!
if (num_p3d == 3) then
do k = 1, LEVR
do j = 1, njeff
- jtem = lon+j-1
+ jtem = lon-1+j
f_ice (j,k) = phy_f3d(jtem,k,1,lan)
f_rain(j,k) = phy_f3d(jtem,k,2,lan)
r_rime(j,k) = phy_f3d(jtem,k,3,lan)
enddo
enddo
- work1 = (log(coslat_r(lat) / (lons_lat*latg)) - dxmin)*dxinv
+ work1=(log(coslat_r2(lon,lat)/(lons_lat*latg))-dxmin)*dxinv
work1 = max(0.0, min(1.0,work1))
work2 = flgmin(1)*work1 + flgmin(2)*(1.0-work1)
do j=1,njeff
- flgmin_v(j) = work2
+! flgmin_v(j) = work2
+ flgmin_v(j) = 0.0
enddo
else
do j=1,njeff
@@ -734,18 +442,7 @@
endif
!
! *** ... calling radiation driver
-
!
-! lprnt = me .eq. 0 .and. kdt .ge. 120
-! if (lprnt) then
-! if (kdt .gt. 85) then
-! print *,' calling grrad for me=',me,' lan=',lan,' lat=',lat
-! &,' num_p3d=',num_p3d
-! if (lan == 47) print *,' gt=',gt(1,:)
-! if (kdt > 3) call mpi_quit(5555)
-
-!
-
call grrad &
! --- inputs:
& ( prsi,prsl,prslk,gt,gr,gr1,vvel,slmsk(lon,lan), &
@@ -754,7 +451,6 @@
& zorl(lon,lan),hprime(lon,1,lan), &
& alvsf(lon,lan),alnsf(lon,lan),alvwf(lon,lan), &
& alnwf(lon,lan),facsf(lon,lan),facwf(lon,lan), &
- ! fice FOR SEA-ICE XW Nov04
& fice(lon,lan),tisfc(lon,lan), &
& solcon,coszen(lon,lan),coszdg(lon,lan),k1oz,k2oz,facoz, &
& cv(lon,lan),cvt(lon,lan),cvb(lon,lan), &
@@ -815,35 +511,12 @@
endif
endif
!
-! if (lat == 45 .and. me == 0 .and. lon == 1) then
-! print *,' after grrad hlw_v=',hlw_v(1,:)
-! print *,' after grrad swh_v=',swh_v(1,:)
-! endif
-! if (lprnt) print *,' hlwg=',hlw(lon+ipt-1,:,lan)
-! if (lprnt) print *,' swhg=',swh(lon+ipt-1,:,lan)
-! if (lprnt) print *,' swh_vg=',swh_v(ipt,:)
-
-!$$$ write(2900+lat,*) ' ilon = ',istrt
-c$$$ write(2900+lat,'("swh",T16,"hlw")')
-!$$$ do k=1,levs
-!$$$ write(2900+lat,
-!$$$ . '(e10.3,T16,e10.3,T31,e10.3)')
-!$$$ . swh(1,k,iblk,lan),hlw(1,k,iblk,lan)
-!$$$ enddo
-
!!
! print *,' completed grrad for lan=',lan,' istrt=',istrt
- CALL countperf(1,12,0.)
- ENDDO
-!
- enddo
-!!
- call f_hpmstop(69)
-!!
- CALL countperf(0,5,0.)
- CALL synctime()
- CALL countperf(1,5,0.)
-!sela print*,'completed gloopr_v kdt=',kdt
-!!
+!--------------------
+ enddo !end lon loop
+ enddo !end lan loop
+!--------------------
+
return
end subroutine gloopr
Deleted: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopr.f_gfs
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopr.f_gfs 2012-05-10 23:36:12 UTC (rev 1894)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/gloopr.f_gfs 2012-05-10 23:40:46 UTC (rev 1895)
@@ -1,1163 +0,0 @@
- subroutine gloopr
- x (trie_ls,trio_ls,
- x ls_node,ls_nodes,max_ls_nodes,
- x lats_nodes_a,global_lats_a,
- x lats_nodes_r,global_lats_r,
- x lonsperlar,
- x epse,epso,epsedn,epsodn,
- x snnp1ev,snnp1od, plnev_r,plnod_r,
- x pddev_r,pddod_r,
-! x snnp1ev,snnp1od,ndexev,ndexod,
-! x plnev_r,plnod_r,pddev_r,pddod_r,plnew_r,plnow_r,
- x phour,
- & xlon,xlat,coszdg,COSZEN,
- & SLMSK,SHELEG,SNCOVR,SNOALB,ZORL,TSEA,HPRIME,
-!lu [+1L]: extract snow-free albedo (SFALB)
- + SFALB,
- & ALVSF,ALNSF ,ALVWF ,ALNWF,FACSF ,FACWF,CV,CVT ,
- & CVB ,SWH,HLW,SFCNSW,SFCDLW,
- & FICE ,TISFC, SFCDSW, sfcemis, ! FOR SEA-ICE - XW Nov04
- & TSFLW,FLUXR , phy_f3d,slag,sdec,cdec,KDT,
- & global_times_r)
-!!
-#include "f_hpm.h"
-!
- USE MACHINE , ONLY : kind_phys
- USE FUNCPHYS , ONLY : fpkap
- USE PHYSCONS, FV => con_fvirt, rerth => con_rerth ! hmhj
-
- use module_radiation_driver, only : radinit, grrad
- use module_radiation_astronomy,only : astronomy
-!
-!! --- for optional spectral band heating outputs
-!! use module_radsw_parameters, only : NBDSW
-!! use module_radlw_parameters, only : NBDLW
-!
- use resol_def
- use layout1
- use layout_grid_tracers
- use gg_def
- use vert_def
- use date_def
- use namelist_def
- use coordinate_def ! hmhj
- use tracer_const ! hmhj
- use d3d_def , only : cldcov
- use mersenne_twister, only : random_setseed, random_index, &
- & random_stat
-!
- implicit none
- include 'mpif.h'
-!
- real (kind=kind_phys), parameter :: QMIN =1.0e-10
- real (kind=kind_evod), parameter :: Typical_pgr = 95.0
- real (kind=kind_evod), parameter :: cons0 = 0.0, cons2 = 2.0
-!
-! --- ... inputs:
- integer, intent(in) :: ls_node(LS_DIM,3), ls_nodes(LS_DIM,NODES), &
- & max_ls_nodes(NODES), lats_nodes_r(NODES), &
- & global_lats_r(LATR), lonsperlar(LATR)
-
- integer, intent(in) :: lats_nodes_a(nodes), global_lats_a(latg)
-
-
- real(kind=kind_evod), dimension(LEN_TRIE_LS), intent(in) :: &
- & epse, epsedn, snnp1ev
-
- real(kind=kind_evod), dimension(LEN_TRIO_LS), intent(in) :: &
- & epso, epsodn, snnp1od
-
- real(kind=kind_evod), intent(in) :: plnev_r(LEN_TRIE_LS, LATR2)
- real(kind=kind_evod), intent(in) :: plnod_r(LEN_TRIO_LS, LATR2)
-
- real (kind=kind_phys), dimension(LONR,LATS_NODE_R), intent(in) :: &
- & xlon, xlat, slmsk, sheleg, zorl, tsea, &
- & alvsf, alnsf, alvwf, alnwf, facsf, facwf, &
- & cv, cvt, cvb, FICE, tisfc, sncovr, snoalb
-
- real (kind=kind_phys), intent(in) :: &
- & hprime(LONR,NMTVR,LATS_NODE_R), phour, &
- & phy_f3d(LONR,LEVS,NUM_P3D,LATS_NODE_R)
-!
-! --- ... input and output:
- real(kind=kind_evod), intent(inout) :: &
- & trie_ls(LEN_TRIE_LS,2,11*LEVS+3*LEVH+6), &
- & trio_ls(LEN_TRIO_LS,2,11*LEVS+3*LEVH+6)
- integer ipt_ls ! hmhj
- real(kind=kind_evod) reall ! hmhj
- real(kind=kind_evod) rlcs2(jcap1) ! hmhj
-
-
- real (kind=kind_phys), intent(inout) :: &
- & fluxr (LONR,NFXR,LATS_NODE_R)
-
-! --- ... inputs but not used anymore:
- real(kind=kind_evod), intent(in) :: pddev_r(LEN_TRIE_LS,LATR2), &
- & pddod_r(LEN_TRIO_LS,LATR2) &
-! & plnew_r(LEN_TRIE_LS,LATR2), &
-! & plnow_r(LEN_TRIO_LS,LATR2)
-! & syn_ls_r(4*LS_DIM,LOTS,LATR2)
-
-! integer, intent(in) :: ndexev(LEN_TRIE_LS), ndexod(LEN_TRIO_LS)
- integer, intent(in) :: KDT
-! --- ... outputs:
- real(kind=kind_evod), intent(inout) :: &
- & global_times_r(LATR,NODES)
- real(kind=kind_evod) :: &
- & for_gr_r_1(LONRX,LOTS,LATS_DIM_R), &
- & dyn_gr_r_1(lonrx,lotd,lats_dim_r), ! hmhj
-!mjr & for_gr_r_2(LONRX,LOTS,LATS_DIM_R),
- & for_gr_r_2(LONR ,LOTS,LATS_DIM_R),
-!mjr & dyn_gr_r_2(lonrx,lotd,lats_dim_r) ! hmhj
- & dyn_gr_r_2(lonr ,lotd,lats_dim_r) ! hmhj
-
- real (kind=kind_phys), intent(out) :: &
- & swh(LONR,LEVS,LATS_NODE_R), &
- & hlw(LONR,LEVS,LATS_NODE_R)
-
- real (kind=kind_phys),dimension(LONR,LATS_NODE_R), intent(out) :: &
- & coszdg, coszen, sfcnsw, sfcdlw, tsflw, &
- & sfcdsw, SFALB, sfcemis
-
- real (kind=kind_phys), intent(out) :: slag, sdec, cdec
-
-!! --- ... optional spectral band heating rates
-!! real (kind=kind_phys), optional, intent(out) :: &
-!! & htrswb(NGPTC,LEVS,NBDSW,NBLCK,LATS_NODE_R), &
-!! & htrlwb(NGPTC,LEVS,NBDLW,NBLCK,LATS_NODE_R)
-
-! --- ... locals:
-! real(kind=kind_phys) :: prsl(NGPTC,LEVS), prdel(NGPTC,LEVS), &
- real(kind=kind_phys) :: prsl(NGPTC,LEVS), prslk(NGPTC,LEVS), &
- & prsi(NGPTC,LEVP1), prsik(NGPTC,LEVP1), &
- & hlw_v(NGPTC,LEVS), swh_v(NGPTC,LEVS)
-
- real (kind=kind_phys) :: si_loc(LEVR+1)
-
- real (kind=kind_phys) :: &
-! & gu(NGPTC,LEVS), gv1(NGPTC,LEVS), &
-! & gt(NGPTC,LEVR), gd (NGPTC,LEVS), &
- & gt(NGPTC,LEVR), gq(NGPTC), &
- & gr(NGPTC,LEVR), gr1(NGPTC,LEVR,NTRAC-1), &
-! & gphi(NGPTC), glam(NGPTC), gq(NGPTC), &
- & gtv(NGPTC,LEVR)
-! & sumq(NGPTC,LEVR), xcp(NGPTC,LEVR), &! hmhj
-! & gtv(NGPTC,LEVR), gtvx(NGPTC,LEVR), &! hmhj
-! & gtvy(NGPTC,LEVR) ! hmhj
-! &, vvel(ngptc,levs)
-
- real (kind=kind_phys), allocatable :: sumq(:,:), xcp(:,:), &
- & gtvx(:,:), gtvy(:,:), &
-! & gd(:,:), &
- & vvel(:,:), gd(:,:), &
- & gu(:,:), gv1(:,:), &
- & gphi(:), glam(:)
-
- real (kind=kind_phys) :: f_ice(NGPTC,LEVS), f_rain(NGPTC,LEVS), &
- & r_rime(NGPTC,LEVS)
-
- real (kind=kind_phys) :: cldcov_v(NGPTC,LEVS), fluxr_v(NGPTC,NFXR)
- real (kind=kind_phys) :: flgmin_v(ngptc), work1, work2
-
- real (kind=kind_phys) :: rinc(5), dtsw, dtlw, solcon, raddt
-
- real (kind=kind_phys), save :: facoz
-
-! integer :: njeff, lon, lan, lat, iblk, lon_dim, lons_lat, istrt
- integer :: njeff, lon, lan, lat, lons_lat
- integer :: idat(8), jdat(8), DAYS(13), iday, imon, midmon, id
- integer :: lmax
-
-! --- variables used for random number generator (thread safe mode)
- type (random_stat) :: stat
- integer :: numrdm(LONR*LATR*2), ixseed(LONR,LATS_NODE_R,2)
- integer :: ipseed, icsdlw(NGPTC), icsdsw(NGPTC)
- integer, parameter :: ipsdlim = 1.0e8 ! upper limit for random seeds
-
- integer, save :: icwp, k1oz, k2oz, midm, midp, ipsd0
-
-! --- number of days in a month
- data DAYS / 31,28,31,30,31,30,31,31,30,31,30,31,30 /
-
-! --- ... control parameters:
-! (some of the them may be moved into model namelist)
-
-! --- ICTM=yyyy#, controls time sensitive external data (e.g. CO2, solcon, aerosols, etc)
-! integer, parameter :: ICTM = -2 ! same as ICTM=0, but add seasonal cycle from
-! ! climatology. no extrapolation.
-! integer, parameter :: ICTM = -1 ! use user provided external data set for the
-! ! forecast time. no extrapolation.
-! integer, parameter :: ICTM = 0 ! use data at initial cond time, if not
-! ! available, use latest, no extrapolation.
-!! integer, parameter :: ICTM = 1 ! use data at the forecast time, if not
-! ! available, use latest and extrapolation.
-! integer, parameter :: ICTM =yyyy0 ! use yyyy data for the forecast time,
-! ! no further data extrapolation.
-! integer, parameter :: ICTM =yyyy1 ! use yyyy data for the fcst. if needed, do
-! ! extrapolation to match the fcst time.
-
-! --- ISOL controls solar constant data source
-!! integer, parameter :: ISOL = 0 ! use prescribed solar constant
-! integer, parameter :: ISOL = 1 ! use varying solar const with 11-yr cycle
-
-! --- ICO2 controls co2 data source for radiation
-! integer, parameter :: ICO2 = 0 ! prescribed global mean value (old opernl)
-!! integer, parameter :: ICO2 = 1 ! use obs co2 annual mean value only
-! integer, parameter :: ICO2 = 2 ! use obs co2 monthly data with 2-d variation
-
-! --- IALB controls surface albedo for sw radiation
-!! integer, parameter :: IALB = 0 ! use climatology alb, based on sfc type
-! integer, parameter :: IALB = 1 ! use modis derived alb (to be developed)
-
-! --- IEMS controls surface emissivity and sfc air/ground temp for lw radiation
-! ab: 2-digit control flags. a-for sfc temperature; b-for emissivity
-!! integer, parameter :: IEMS = 00 ! same air/ground temp; fixed emis = 1.0
-!! integer, parameter :: IEMS = 01 ! same air/ground temp; varying veg typ based emis
-!! integer, parameter :: IEMS = 10 ! diff air/ground temp; fixed emis = 1.0
-!! integer, parameter :: IEMS = 11 ! diff air/ground temp; varying veg typ based emis
-
-! --- IAER controls aerosols scheme selections
-! Old definition
-! integer, parameter :: IAER = 1 ! opac climatology, without volc forcing
-! integer, parameter :: IAER =11 ! opac climatology, with volcanic forcing
-! integer, parameter :: IAER = 2 ! gocart prognostic, without volc forcing
-! integer, parameter :: IAER =12 ! gocart prognostic, with volcanic forcing
-! New definition in this code IAER = abc (a:volcanic; b:lw; c:sw)
-! b, c values: (0:none; 1:opac; 2:gocart)
-! IAER = 0 --> no aerosol effect at all (volc, sw, lw)
-! = 1 --> only tropospheric sw aerosols, no trop-lw and volc
-! = 10 --> only tropospheric lw aerosols, no trop-sw and volc
-! = 11 --> both trop-sw and trop-lw aerosols, no volc
-! = 100 --> only strato-volc aeros, no trop-sw and trop-lw
-! = 101 --> only sw aeros (trop + volc), no lw aeros
-! = 110 --> only lw aeros (trop + volc), no sw aeros
-! = 111 --> both sw and lw aeros (trop + volc)
-!
-
-! --- IOVR controls cloud overlapping method in radiation:
-! integer, parameter :: IOVR_SW = 0 ! sw: random overlap clouds
-!! integer, parameter :: IOVR_SW = 1 ! sw: max-random overlap clouds
-
-! integer, parameter :: IOVR_LW = 0 ! lw: random overlap clouds
-!! integer, parameter :: IOVR_LW = 1 ! lw: max-random overlap clouds
-
-! --- ISUBC controls sub-column cloud approximation in radiation:
-! integer, parameter :: ISUBC_SW = 0 ! sw: without sub-col clds approx
-! integer, parameter :: ISUBC_SW = 1 ! sw: sub-col clds with prescribed seeds
-! integer, parameter :: ISUBC_SW = 2 ! sw: sub-col clds with random seeds
-
-! integer, parameter :: ISUBC_LW = 0 ! lw: without sub-col clds approx
-! integer, parameter :: ISUBC_LW = 1 ! lw: sub-col clds with prescribed seeds
-! integer, parameter :: ISUBC_LW = 2 ! lw: sub-col clds with random seeds
-
-! --- iflip indicates model vertical index direction:
-! integer, parameter :: IFLIP = 0 ! virtical profile index from top to bottom
- integer, parameter :: IFLIP = 1 ! virtical profile index from bottom to top
-!
-! The following parameters are from gbphys
-!
- real (kind=kind_phys), parameter :: dxmax=-16.118095651, &
- & dxmin=-9.800790154, dxinv=1.0/(dxmax-dxmin)
-
- integer :: kr, kt, kd, kq, ku, kv, ierr, dimg, kx, ky
- integer :: i, j, k, n
- integer :: kdtphi,kdtlam,ks ! hmhj
-
- logical :: change
- logical, save :: first, sas_shal
- data first / .true. /
-!
-! --- for debug test use
- real (kind=kind_phys) :: temlon, temlat, alon, alat
- integer :: ipt
- logical :: lprnt
-
-! --- timers:
- real*8 :: rtc, timer1, timer2
-!
-!===> *** ... begin here
-!
-!!
-!cmr ls_node(1,1) ... ls_node(ls_max_node,1) : values of L
-!cmr ls_node(1,2) ... ls_node(ls_max_node,2) : values of jbasev
-!cmr ls_node(1,3) ... ls_node(ls_max_node,3) : values of jbasod
-!!
-!$$$ integer lots,lotd,lota
-!$$$cc
-!$$$ parameter ( lots = 5*levs+1*levh+3 )
-!$$$ parameter ( lotd = 6*levs+2*levh+0 )
-!$$$ parameter ( lota = 3*levs+1*levh+1 )
-!!
-!!
- integer kap,kar,kat,kau,kav,kdrlam
- integer ksd,ksplam,kspphi,ksq,ksr,kst
- integer ksu,ksv,ksz,node,item,jtem
-!!
-! real(kind=kind_evod) spdlat(levs,lats_dim_r)
-!Moor real(kind=kind_phys) slk(levs)
-! real(kind=kind_evod) spdmax_node (levs)
-! real(kind=kind_evod) spdmax_nodes(levs,nodes)
-!!
-!!
-!!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
-!!
-!!
-!!................................................................
-!! syn(1, 0*levs+0*levh+1, lan) ze
-!! syn(1, 1*levs+0*levh+1, lan) di
-!! syn(1, 2*levs+0*levh+1, lan) te
-!! syn(1, 3*levs+0*levh+1, lan) rq
-!! syn(1, 3*levs+1*levh+1, lan) q
-!! syn(1, 3*levs+1*levh+2, lan) dpdlam
-!! syn(1, 3*levs+1*levh+3, lan) dpdphi
-!! syn(1, 3*levs+1*levh+4, lan) uln
-!! syn(1, 4*levs+1*levh+4, lan) vln
-!!................................................................
-!! dyn(1, 0*levs+0*levh+1, lan) d(t)/d(phi)
-!! dyn(1, 1*levs+0*levh+1, lan) d(rq)/d(phi)
-!! dyn(1, 1*levs+1*levh+1, lan) d(t)/d(lam)
-!! dyn(1, 2*levs+1*levh+1, lan) d(rq)/d(lam)
-!! dyn(1, 2*levs+2*levh+1, lan) d(u)/d(lam)
-!! dyn(1, 3*levs+2*levh+1, lan) d(v)/d(lam)
-!! dyn(1, 4*levs+2*levh+1, lan) d(u)/d(phi)
-!! dyn(1, 5*levs+2*levh+1, lan) d(v)/d(phi)
-!!................................................................
-!! anl(1, 0*levs+0*levh+1, lan) w dudt
-!! anl(1, 1*levs+0*levh+1, lan) x dvdt
-!! anl(1, 2*levs+0*levh+1, lan) y dtdt
-!! anl(1, 3*levs+0*levh+1, lan) rt drdt
-!! anl(1, 3*levs+1*levh+1, lan) z dqdt
-!!................................................................
-!!
-!!
-!$$$ parameter(ksz =0*levs+0*levh+1,
-!$$$ x ksd =1*levs+0*levh+1,
-!$$$ x kst =2*levs+0*levh+1,
-!$$$ x ksr =3*levs+0*levh+1,
-!$$$ x ksq =3*levs+1*levh+1,
-!$$$ x ksplam =3*levs+1*levh+2,
-!$$$ x kspphi =3*levs+1*levh+3,
-!$$$ x ksu =3*levs+1*levh+4,
-!$$$ x ksv =4*levs+1*levh+4)
-!!
-!$$$ parameter(kdtphi =0*levs+0*levh+1,
-!$$$ x kdrphi =1*levs+0*levh+1,
-!$$$ x kdtlam =1*levs+1*levh+1,
-!$$$ x kdrlam =2*levs+1*levh+1,
-!$$$ x kdulam =2*levs+2*levh+1,
-!$$$ x kdvlam =3*levs+2*levh+1,
-!$$$ x kduphi =4*levs+2*levh+1,
-!$$$ x kdvphi =5*levs+2*levh+1)
-!!
-!$$$ parameter(kau =0*levs+0*levh+1,
-!$$$ x kav =1*levs+0*levh+1,
-!$$$ x kat =2*levs+0*levh+1,
-!$$$ x kar =3*levs+0*levh+1,
-!$$$ x kap =3*levs+1*levh+1)
-!!
-!!
-!$$$ integer P_gz,P_zem,P_dim,P_tem,P_rm,P_qm
-!$$$ integer P_ze,P_di,P_te,P_rq,P_q,P_dlam,P_dphi,P_uln,P_vln
-!$$$ integer P_w,P_x,P_y,P_rt,P_zq
-!$$$cc
-!$$$cc old common /comfspec/
-!$$$ parameter(P_gz = 0*levs+0*levh+1, ! gze/o(lnte/od,2),
-!$$$ x P_zem = 0*levs+0*levh+2, ! zeme/o(lnte/od,2,levs),
-!$$$ x P_dim = 1*levs+0*levh+2, ! dime/o(lnte/od,2,levs),
-!$$$ x P_tem = 2*levs+0*levh+2, ! teme/o(lnte/od,2,levs),
-!$$$ x P_rm = 3*levs+0*levh+2, ! rme/o(lnte/od,2,levh),
-!$$$ x P_qm = 3*levs+1*levh+2, ! qme/o(lnte/od,2),
-!$$$ x P_ze = 3*levs+1*levh+3, ! zee/o(lnte/od,2,levs),
-!$$$ x P_di = 4*levs+1*levh+3, ! die/o(lnte/od,2,levs),
-!$$$ x P_te = 5*levs+1*levh+3, ! tee/o(lnte/od,2,levs),
-!$$$ x P_rq = 6*levs+1*levh+3, ! rqe/o(lnte/od,2,levh),
-!$$$ x P_q = 6*levs+2*levh+3, ! qe/o(lnte/od,2),
-!$$$ x P_dlam= 6*levs+2*levh+4, ! dpdlame/o(lnte/od,2),
-!$$$ x P_dphi= 6*levs+2*levh+5, ! dpdphie/o(lnte/od,2),
-!$$$ x P_uln = 6*levs+2*levh+6, ! ulne/o(lnte/od,2,levs),
-!$$$ x P_vln = 7*levs+2*levh+6, ! vlne/o(lnte/od,2,levs),
-!$$$ x P_w = 8*levs+2*levh+6, ! we/o(lnte/od,2,levs),
-!$$$ x P_x = 9*levs+2*levh+6, ! xe/o(lnte/od,2,levs),
-!$$$ x P_y =10*levs+2*levh+6, ! ye/o(lnte/od,2,levs),
-!$$$ x P_rt =11*levs+2*levh+6, ! rte/o(lnte/od,2,levh),
-!$$$ x P_zq =11*levs+3*levh+6) ! zqe/o(lnte/od,2)
-!!
-!!
-! print *,' in gloopr vertcoord_id =',vertcoord_id
-
-!
- ksz =0*levs+0*levh+1
- ksd =1*levs+0*levh+1
- kst =2*levs+0*levh+1
- ksq =3*levs+0*levh+1
- ksplam =3*levs+0*levh+2
- kspphi =3*levs+0*levh+3
- ksu =3*levs+0*levh+4
- ksv =4*levs+0*levh+4
- ksr =5*levs+0*levh+4
-
- kdtphi =0*levs+0*levh+1 ! hmhj
- kdtlam =1*levs+1*levh+1 ! hmhj
-!!
- idat = 0
- idat(1) = idate(4)
- idat(2) = idate(2)
- idat(3) = idate(3)
- idat(5) = idate(1)
- rinc = 0.
- rinc(2) = fhour
- call w3movdat(rinc, idat, jdat)
-!
- if (ntoz .le. 0) then ! Climatological Ozone!
-!
-! if(me .eq. 0) WRITE (6,989) jdat(1),jdat(2),jdat(3),jdat(5)
-! 989 FORMAT(' UPDATING OZONE FOR ', I4,I3,I3,I3)
-!
- IDAY = jdat(3)
- IMON = jdat(2)
- MIDMON = DAYS(IMON)/2 + 1
- CHANGE = FIRST .OR.
- & ( (IDAY .EQ. MIDMON) .AND. (jdat(5).EQ.0) )
-!
- IF (CHANGE) THEN
- IF (IDAY .LT. MIDMON) THEN
- K1OZ = MOD(IMON+10,12) + 1
- MIDM = DAYS(K1OZ)/2 + 1
- K2OZ = IMON
- MIDP = DAYS(K1OZ) + MIDMON
- ELSE
- K1OZ = IMON
- MIDM = MIDMON
- K2OZ = MOD(IMON,12) + 1
- MIDP = DAYS(K2OZ)/2 + 1 + DAYS(K1OZ)
- ENDIF
- ENDIF
-!
- IF (IDAY .LT. MIDMON) THEN
- ID = IDAY + DAYS(K1OZ)
- ELSE
- ID = IDAY
- ENDIF
- FACOZ = real (ID-MIDM) / real (MIDP-MIDM)
- endif
-!
- if (first) then
- sas_shal = sashal .and. (.not. ras)
-!
- if( hybrid.or.gen_coord_hybrid ) then ! hmhj
-
- if( gen_coord_hybrid ) then ! hmhj
- si_loc(levr+1) = si(levp1) ! hmhj
- do k=1,levr ! hmhj
- si_loc(k) = si(k) ! hmhj
- enddo ! hmhj
- else ! hmhj
-! --- get some sigma distribution for radiation-cloud initialization
-!sela si(k)=(ak5(k)+bk5(k)*Typical_pgr)/Typical_pgr !ak(k) bk(k) go top to botto
- si_loc(levr+1)= ak5(1)/typical_pgr+bk5(1)
- do k=1,levr
- si_loc(levr+1-k)= ak5(levp1-levr+k)/typical_pgr
- & + bk5(levp1-levr+k)
- enddo
- endif
- else
- do k = 1, levr
- si_loc(k) = si(k)
- enddo
- si_loc(levr+1) = si(levp1)
- endif ! end_if_hybrid
-
-! --- determin prognostic/diagnostic cloud scheme
-
- icwp = 0
- if (NTCW > 0) icwp = 1
-
- if( thermodyn_id.eq.3 ) then
- if (.not. allocated(xcp)) allocate (xcp(ngptc,levr))
- if (.not. allocated(sumq)) allocate (sumq(ngptc,levr))
- endif
- if( ntcw <= 0 ) then
- if( gen_coord_hybrid .and. vertcoord_id == 3.) then
- if (.not. allocated(gtvx)) allocate (gtvx(ngptc,levs))
- if (.not. allocated(gtvy)) allocate (gtvy(ngptc,levs))
- endif
- if (.not. allocated(gu)) allocate (gu(ngptc,levs))
- if (.not. allocated(gv1)) allocate (gv1(ngptc,levs))
- if (.not. allocated(gd)) allocate (gd(ngptc,levs))
- if (.not. allocated(vvel)) allocate (vvel(ngptc,levs))
- if (.not. allocated(gphi)) allocate (gphi(ngptc))
- if (.not. allocated(glam)) allocate (glam(ngptc))
- endif
-
-! --- generate initial permutation seed for random number generator
-
- if ( ISUBC_LW==2 .or. ISUBC_SW==2 ) then
- ipsd0 = 17*idate(1) + 43*idate(2) + 37*idate(3) + 23*idate(4)
- if ( me == 0 ) then
- print *,' Radiation sub-cloud initial seed =',ipsd0, &
- & ' idate =',idate
- endif
- endif
-
- first = .false.
-
- endif ! end_if_first
-!
-!===> *** ... radiation initialization
-!
- dtsw = 3600.0 * fhswr
- dtlw = 3600.0 * fhlwr
- raddt = min(dtsw, dtlw)
-
- call radinit &
-! --- input:
- & ( si_loc, LEVR, IFLIP, idat, jdat, ICTM, ISOL, ICO2, &
- & IAER, IALB, IEMS, ICWP, NUM_P3D, ISUBC_SW, ISUBC_LW, &
- & IOVR_SW, IOVR_LW, me )
-! --- output: ( none )
-
-!
-!===> *** ... astronomy for sw radiation calculation.
-!
-! print *,' calling astronomy'
- call astronomy &
-! --- inputs:
- & ( lonsperlar, global_lats_r, sinlat_r, coslat_r, xlon, &
-! & fhswr, jdat, deltim, &
- & fhswr, jdat, &
- & LONR, LATS_NODE_R, LATR, IPT_LATS_NODE_R, lsswr, me, &
-! --- outputs:
- & solcon, slag, sdec, cdec, coszen, coszdg &
- & )
-! print *,' returned from astro'
-
-!
-!===> *** ... generate 2-d random seeds array for sub-grid cloud-radiation
-!
- if ( ISUBC_LW==2 .or. ISUBC_SW==2 ) then
- ipseed = mod(nint(100.0*sqrt(fhour*3600)), ipsdlim) + 1 + ipsd0
-
- call random_setseed &
-! --- inputs:
- & ( ipseed, &
-! --- outputs:
- & stat &
- & )
- call random_index &
-! --- inputs:
- & ( ipsdlim, &
-! --- outputs:
- & numrdm, stat &
- & )
-
- do k = 1, 2
- do j = 1, lats_node_r
- lat = global_lats_r(ipt_lats_node_r-1+j)
-
- do i = 1, LONR
- ixseed(i,j,k) = numrdm(i+(lat-1)*LONR+(k-1)*LATR)
- enddo
- enddo
- enddo
- endif
-
-!
-!===> *** ... spectrum to grid transformation for radiation calculation.
-! -----------------------------------
-!!
- call f_hpmstart(61,"gr delnpe")
- call delnpe(trie_ls(1,1,P_q ),
- x trio_ls(1,1,P_dphi),
- x trie_ls(1,1,P_dlam),
- x epse,epso,ls_node)
- call f_hpmstop(61)
-!!
- call f_hpmstart(62,"gr delnpo")
- call delnpo(trio_ls(1,1,P_q ),
- x trie_ls(1,1,P_dphi),
- x trio_ls(1,1,P_dlam),
- x epse,epso,ls_node)
- call f_hpmstop(62)
-!!
-! print *,' after delnpeo'
-!!
- call f_hpmstart(63,"gr dezouv dozeuv")
-!
-!$omp parallel do shared(trie_ls,trio_ls)
-!$omp+shared(epsedn,epsodn,snnp1ev,snnp1od,ls_node)
-!$omp+private(k)
- do k=1,levs
- call dezouv(trie_ls(1,1,P_di +k-1), trio_ls(1,1,P_ze +k-1),
- x trie_ls(1,1,P_uln+k-1), trio_ls(1,1,P_vln+k-1),
- x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
-!!
- call dozeuv(trio_ls(1,1,P_di +k-1), trie_ls(1,1,P_ze +k-1),
- x trio_ls(1,1,P_uln+k-1), trie_ls(1,1,P_vln+k-1),
- x epsedn,epsodn,snnp1ev,snnp1od,ls_node)
- enddo
- call f_hpmstop(63)
-!!
-!sela print*,'completed call to dztouv'
-!!
-!!mr call mpi_barrier (mpi_comm_world,ierr)
-!!
- CALL countperf(0,5,0.)
- CALL synctime()
- CALL countperf(1,5,0.)
-!!
- dimg=0
- CALL countperf(0,1,0.)
-!!
- call f_hpmstart(67,"gr sumfln")
-!!
-!sela print*,'begining call to sumfln'
-
- call sumfln_slg_gg(trie_ls(1,1,P_ze),
- x trio_ls(1,1,P_ze),
- x lat1s_r,
- x plnev_r,plnod_r,
- x 5*levs+3,ls_node,latr2,
- x lats_dim_r,lots,for_gr_r_1,
- x ls_nodes,max_ls_nodes,
- x lats_nodes_r,global_lats_r,
-!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
- x lats_node_r,ipt_lats_node_r,lon_dim_r,
- x lonsperlar,lonrx,latr,0)
-!
- if(.not. gg_tracers) then
-! tracers grid values will be set from layout_grid_traces
- call sumfln_slg_gg(trie_ls(1,1,P_rq),
- x trio_ls(1,1,P_rq),
- x lat1s_r,
- x plnev_r,plnod_r,
- x levh,ls_node,latr2,
- x lats_dim_r,lots,for_gr_r_1,
- x ls_nodes,max_ls_nodes,
- x lats_nodes_r,global_lats_r,
-!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r,
- x lats_node_r,ipt_lats_node_r,lon_dim_r,
- x lonsperlar,lonrx,latr,5*levs+3)
- endif
-
-! print*,'completed call to sumfln'
-!sela print*,'completed call to sumfln'
- call f_hpmstop(67)
-!!
- CALL countperf(1,1,0.)
-!!
-! -----------------------------------
- if( vertcoord_id == 3. ) then
-! -----------------------------------
- CALL countperf(0,1,0.) ! hmhj
-!
- call f_hpmstart(68,"gr sumder2") ! hmhj
-!
- do lan=1,lats_node_r
- lat = global_lats_r(ipt_lats_node_r-1+lan)
- lmax = min(jcap,lonsperlar(lat)/2)
- if ( (lmax+1)*2+1 .le. lonsperlar(lat)+2 ) then
- do k=levs+1,4*levs+2*levh
- do i = (lmax+1)*2+1, lonsperlar(lat)+2
- dyn_gr_r_1(i,k,lan) = cons0 !constant
- enddo
- enddo
- endif
- enddo
-!
- call sumder2_slg(trie_ls(1,1,P_te), ! hmhj
- x trio_ls(1,1,P_te), ! hmhj
- x lat1s_r, ! hmhj
- x pddev_r,pddod_r, ! hmhj
- x levs,ls_node,latr2, ! hmhj
- x lats_dim_r,lotd, ! hmhj
- x dyn_gr_r_1, ! hmhj
- x ls_nodes,max_ls_nodes, ! hmhj
- x lats_nodes_r,global_lats_r, ! hmhj
-!mjr x lats_node_r,ipt_lats_node_r,lon_dims_r, ! hmhj
- x lats_node_r,ipt_lats_node_r,lon_dim_r, ! hmhj
- x lonsperlar,lonrx,latr,0) ! hmhj
-!
- call f_hpmstop(68) ! hmhj
-!
- CALL countperf(1,1,0.) ! hmhj
-! --------------------------------
- endif ! vertcoord_id=3
-! --------------------------------
-!
-
-!!mr call mpi_barrier (mpi_comm_world,ierr)
-
- if(gg_tracers .and. shuff_lats_r) then
- print*,' gloopr mpi_tracers_a_to_b shuff_lats_r',shuff_lats_r
- call mpi_tracers_a_to_b(
- x rg1_a,rg2_a,rg3_a,lats_nodes_a,global_lats_a,
- x for_gr_r_2(1,1,1),
- x lats_nodes_r,global_lats_r,ksr,0)
- endif ! gg_tracers .and. shuff_lats_r
-
- do lan=1,lats_node_r
- timer1 = rtc()
-!!
- lat = global_lats_r(ipt_lats_node_r-1+lan)
-!!
-! lon_dim = lon_dims_r(lan)
-!!
- lons_lat = lonsperlar(lat)
-
-! -------------------------------------------------------
- if( gen_coord_hybrid .and. vertcoord_id.eq.3. ) then
-! -------------------------------------------------------
-!
- lmax = min(jcap,lons_lat/2) ! hmhj
- ipt_ls = min(lat,latr-lat+1) ! hmhj
-
- do i=1,lmax+1 ! hmhj
- if ( ipt_ls .ge. lat1s_r(i-1) ) then ! hmhj
- reall = i-1 ! hmhj
- rlcs2(i) = reall*rcs2_r(ipt_ls)/rerth ! hmhj
- else ! hmhj
- rlcs2(i) = cons0 !constant ! hmhj
- endif ! hmhj
- enddo ! hmhj
-!
-!$omp parallel do private(k,i,item,jtem)
- do k=1,levs ! hmhj
- item = kdtlam-1+k
- jtem = kst -1+K
- do i=1,lmax+1 ! hmhj
-!
-! d(t)/d(lam) ! hmhj
- dyn_gr_r_1(i+i-1,item,lan) = -for_gr_r_1(i+i,jtem,lan)
- & * rlcs2(i) ! hmhj
- dyn_gr_r_1(i+i,item,lan) = for_gr_r_1(i+i-1,jtem,lan)
- & * rlcs2(i) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
-! --------------------
- endif ! gc and vertcoord_id=3
-! ---------------------
-!
-!!
- CALL countperf(0,6,0.)
-!sela print*,' beginning call four2grid',lan
-! print*,' beginning call four2grid',lan
- CALL FOUR_TO_GRID(for_gr_r_1(1,1,lan),for_gr_r_2(1,1,lan),
-!mjr & lon_dim ,lon_dim ,lons_lat,5*levs+3)
- & lon_dim_r,lonr,lons_lat,5*levs+3)
-
-! print*,' after first call four2grid',lan
- if(gg_tracers)then
-!
-! set tracers grid values from layout_grid_tracers
-!
- if (.not.shuff_lats_r) then
-! set for_gr_r_2 to rg1_a rg2_a rg3_a from gloopa
- do k=1,levs
- item = KSR - 1 + k
- jtem = lats_node_a+1-lan
- do i=1,min(lonf,lons_lat)
- for_gr_r_2(i,item ,lan) = rg1_a(i,k,jtem)
- for_gr_r_2(i,item+ levs,lan) = rg2_a(i,k,jtem)
- for_gr_r_2(i,item+2*levs,lan) = rg3_a(i,k,jtem)
- enddo
- enddo
- endif ! not shuff_lats_r
-
- else
-! print *,' begin second call to FOUR_TO_GRID in gloopr'
- CALL FOUR_TO_GRID(for_gr_r_1(1,KSR,lan),
- & for_gr_r_2(1,KSR,lan),
-!mjr & lon_dim ,lon_dim ,lons_lat,levh)
- & lon_dim_r,lonr,lons_lat,levh)
- endif
-! print *,' after second call to FOUR_TO_GRID in gloopr'
-
-! -------------------------------------------------------
- if( gen_coord_hybrid.and.vertcoord_id.eq.3. ) then ! hmhj
-! -------------------------------------------------------
- CALL FOUR_TO_GRID(dyn_gr_r_1(1,1,lan),dyn_gr_r_2(1,1,lan), ! hmhj
-!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
- & lon_dim_r,lonr,lons_lat,levs) ! hmhj
- CALL FOUR_TO_GRID(dyn_gr_r_1(1,KDTLAM,lan), ! hmhj
- & dyn_gr_r_2(1,KDTLAM,lan), ! hmhj
-!mjr & lon_dim ,lon_dim ,lons_lat,levs) ! hmhj
- & lon_dim_r,lonr,lons_lat,levs) ! hmhj
-! -------------------------
- endif ! gc and vertcoord_id=3
-! -------------------------
-
-! print*,' completed call four2grid lan=',lan
-!sela print*,' completed call four2grid lan=',lan
- CALL countperf(1,6,0.)
-!!
- if( .not. gen_coord_hybrid ) then ! hmhj
-
- do k = 1, LEVS
- item = KSR-1+k
- jtem = KST-1+k
- do j = 1, lons_lat
- if (for_gr_r_2(j,item,lan) <= qmin) then
- for_gr_r_2(j,item,lan) = qmin
- endif
- for_gr_r_2(j,jtem,lan) = for_gr_r_2(j,jtem,lan)
- & / (1.0 + FV*for_gr_r_2(j,item,lan))
- enddo
- enddo
-! print *,' now do sfc pressure for lan=',lan
- do j = 1, lons_lat
- for_gr_r_2(j,KSQ,lan) = exp( for_gr_r_2(j,KSQ,lan) )
- enddo
-! print *,' after sfc pressure for lan=',lan
-
- endif ! hmhj
-!
- timer2 = rtc()
- global_times_r(lat,me+1) = timer2 - timer1
-
-!$$$ print*,'timeloopr',me,timer1,timer2,global_times_r(lat,me+1)
-
-!!
- enddo !lan
-!
- call f_hpmstart(69,"gr lat_loop2")
-!
-!===> *** ... starting latitude loop
-!
- do lan=1,lats_node_r
-!
- lat = global_lats_r(ipt_lats_node_r-1+lan)
-!
- lons_lat = lonsperlar(lat)
-
-!!
-!$omp parallel do schedule(dynamic,1) private(lon,i,j,k)
-!$omp+private(vvel,gu,gv1,gd,gt,gr,gr1,gq,gphi,glam)
-!$omp+private(gtv,gtvx,gtvy,sumq,xcp)
-!$omp+private(cldcov_v,fluxr_v,f_ice,f_rain,r_rime)
-!$omp+private(prslk,prsl,prsik,prsi,flgmin_v,hlw_v,swh_v)
-!$omp+private(njeff,n,item,jtem,ks,work1,work2)
-!$omp+private(icsdsw,icsdlw)
-!$omp+private(lprnt,ipt)
-!!!$omp+private(temlon,temlat,lprnt,ipt)
-
- DO lon=1,lons_lat,NGPTC
-!!
- NJEFF = MIN(NGPTC,lons_lat-lon+1)
-!!
- lprnt = .false.
-!
-! --- ... for debug test
-! alon = 236.25
-! alat = 56.189
-! alon = 97.5
-! alat = -6.66
-! ipt = 0
-! do i = 1, njeff
-! item = lon + i - 1
-! temlon = xlon(item,lan) * 57.29578
-! if (temlon < 0.0) temlon = temlon + 360.0
-! temlat = xlat(item,lan) * 57.29578
-! lprnt = abs(temlon-alon) < 1.1 .and. abs(temlat-alat) < 1.1
-! & .and. kdt > 0
-! if ( lprnt ) then
-! ipt = i
-! print *,' ipt=',ipt,' lon=',lon,' lan=',lan
-! exit
-! endif
-! enddo
-! lprnt = .false.
-!!
- if (ntcw <= 0) then
- do k = 1, LEVS
- do j = 1, njeff
- jtem = lon-1+j
- gu (j,k) = for_gr_r_2(jtem,KSU-1+k,lan)
- gv1(j,k) = for_gr_r_2(jtem,KSV-1+k,lan)
- gd (j,k) = for_gr_r_2(jtem,KSD-1+k,lan)
- enddo
- enddo
- endif
-
- if( gen_coord_hybrid ) then ! hmhj
- do k=1,levr ! hmhj
- do j=1,NJEFF ! hmhj
- jtem = lon-1+j
- gtv (j,k) = for_gr_r_2(jtem,KST-1+k,lan)
- gr (j,k) = max(qmin, for_gr_r_2(jtem,KSR-1+k,lan))
-! gt (j,k) = gtv(j,k) / (1.+fv*gr(j,k))
- enddo ! hmhj
- enddo
-! --------------------------------------
- if( vertcoord_id == 3. .and. ntcw <= 0 ) then
-! --------------------------------------
- do k=1,levs ! hmhj
- do j=1,NJEFF ! hmhj
- jtem = lon-1+j
- gtvx(j,k) = dyn_gr_r_2(jtem,KDTLAM-1+k,lan)
- gtvy(j,k) = dyn_gr_r_2(jtem,KDTPHI-1+k,lan)
- enddo ! hmhj
- enddo
-! -----------------------------
- endif
-! -----------------------------
- if( thermodyn_id.eq.3 ) then ! get dry temperature from enthalpy
- do k=1,levr ! hmhj
- do j=1,njeff ! hmhj
- sumq(j,k) = 0.0 ! hmhj
- xcp(j,k) = 0.0 ! hmhj
- enddo
- enddo
- do i=1,ntrac ! hmhj
- if( cpi(i).ne.0.0 ) then ! hmhj
- ks = ksr+(i-1)*levs ! hmhj
- do k=1,levr ! hmhj
- item = ks-1+k
- do j=1,njeff ! hmhj
- jtem = lon-1+j
- sumq(j,k) = sumq(j,k) + for_gr_r_2(jtem,item,lan) ! hmhj
- xcp(j,k) = xcp(j,k)
- & + cpi(i)*for_gr_r_2(jtem,item,lan) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- endif ! hmhj
- enddo ! hmhj
- do k=1,levr ! hmhj
- do j=1,njeff ! hmhj
- xcp(j,k) = (1.-sumq(j,k))*cpi(0) + xcp(j,k) ! hmhj
- gt(j,k) = gtv(j,k) / xcp(j,k) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- else if( thermodyn_id.le.1 ) then ! hmhj
-! get dry temperature from virtual temperature ! hmhj
- do k=1,levr ! hmhj
- do j=1,njeff ! hmhj
- gt(j,k) = gtv(j,k) / (1.+fv*gr(j,k)) ! hmhj
- enddo ! hmhj
- enddo ! hmhj
- else
-! get dry temperature from dry temperature ! hmhj
- do k=1,levr ! hmhj
- do j=1,njeff ! hmhj
- gt(j,k) = gtv(j,k) ! hmhj
- enddo ! hmhj
- enddo
- endif
-
- else ! hmhj
-!
- do k = 1, levr
- do j = 1, njeff
- jtem = lon-1+j
- gt(j,k) = for_gr_r_2(jtem,KST-1+k,lan)
- gr(j,k) = for_gr_r_2(jtem,KSR-1+k,lan)
- enddo
- enddo
-
- endif
-!
-! Remaining tracers
-!
- do n = 1, NTRAC-1
- do k = 1, LEVR
- item = KSR-1+k+n*levs
- do j = 1, njeff
- gr1(j,k,n) = for_gr_r_2(lon-1+j,item,lan)
- enddo
- enddo
- enddo
- if (ntcw > 0) then
- do j = 1, njeff
- gq (j) = for_gr_r_2(lon-1+j,KSQ,lan)
- enddo
- else
- do j = 1, njeff
- jtem = lon-1+j
- gq (j) = for_gr_r_2(jtem,KSQ ,lan)
- gphi(j) = for_gr_r_2(jtem,KSPPHI,lan)
- glam(j) = for_gr_r_2(jtem,KSPLAM,lan)
- enddo
- endif
-!!
-! --- vertical structure variables: del,si,sl,prslk,prdel
-!
- if( gen_coord_hybrid ) then ! hmhj
- call hyb2press_gc(njeff,ngptc,gq,gtv,prsi,prsl,prsik,prslk) ! hmhj
- if (ntcw <= 0)
- & call omegtes_gc(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)), ! hmhj
- & gq,gphi,glam,gtv,gtvx,gtvy,gd,gu,gv1,vvel) ! hmhj
- elseif (hybrid) then
- call hyb2press(njeff,ngptc,gq, prsi, prsl,prsik, prslk)
- if (ntcw <= 0)
- & call omegtes(njeff,ngptc,rcs2_r(min(lat,latr-lat+1)),
- & gq,gphi,glam,gd,gu,gv1,vvel)
-! & gq,gphi,glam,gd,gu,gv1,vvel,ngptc,lprnt,ipt)
- else
- call sig2press(njeff,ngptc,gq,sl,si,slk,sik,
- & prsi,prsl,prsik,prslk)
- CALL countperf(0,12,0.)
- if (ntcw <= 0)
- & call omegast3(njeff,ngptc,levs,
- & gphi,glam,gu,gv1,gd,del,
- & rcs2_r(min(lat,latr-lat+1)),vvel,gq,sl)
- endif
-!.....
- if (levr .lt. levs) then
- do j=1,njeff
- prsi(j,levr+1) = prsi(j,levp1)
- prsl(j,levr) = (prsi(j,levp1) + prsi(j,levr)) * 0.5
- prsik(j,levr+1) = prslk(j,levp1)
- prslk(j,levr) = fpkap(prsl(j,levr)*1000.0)
- enddo
- endif
-!
- do k=1,nfxr
- do j=1,njeff
- fluxr_v(j,k) = fluxr(lon+j-1,k,lan)
- enddo
- enddo
-!
- if (num_p3d == 3) then
- do k = 1, LEVR
- do j = 1, njeff
- jtem = lon+j-1
- f_ice (j,k) = phy_f3d(jtem,k,1,lan)
- f_rain(j,k) = phy_f3d(jtem,k,2,lan)
- r_rime(j,k) = phy_f3d(jtem,k,3,lan)
- enddo
- enddo
-
- work1 = (log(coslat_r(lat) / (lons_lat*latg)) - dxmin)*dxinv
- work1 = max(0.0, min(1.0,work1))
- work2 = flgmin(1)*work1 + flgmin(2)*(1.0-work1)
- do j=1,njeff
- flgmin_v(j) = work2
- enddo
- else
- do j=1,njeff
- flgmin_v(j) = 0.0
- enddo
- endif
-
-! *** ... assign random seeds for sw and lw radiations
-
- if ( ISUBC_LW==2 .or. ISUBC_SW==2 ) then
- do j = 1, njeff
- icsdsw(j) = ixseed(lon+j-1,lan,1)
- icsdlw(j) = ixseed(lon+j-1,lan,2)
- enddo
- endif
-!
-! *** ... calling radiation driver
-
-!
-! lprnt = me .eq. 0 .and. kdt .ge. 120
-! if (lprnt) then
-! if (kdt .gt. 85) then
-! print *,' calling grrad for me=',me,' lan=',lan,' lat=',lat
-! &,' num_p3d=',num_p3d
-! if (lan == 47) print *,' gt=',gt(1,:)
-! if (kdt > 3) call mpi_quit(5555)
-
-!
-
- call grrad &
-! --- inputs:
- & ( prsi,prsl,prslk,gt,gr,gr1,vvel,slmsk(lon,lan), &
- & xlon(lon,lan),xlat(lon,lan),tsea(lon,lan), &
- & sheleg(lon,lan),sncovr(lon,lan),snoalb(lon,lan), &
- & zorl(lon,lan),hprime(lon,1,lan), &
- & alvsf(lon,lan),alnsf(lon,lan),alvwf(lon,lan), &
- & alnwf(lon,lan),facsf(lon,lan),facwf(lon,lan), &
- ! fice FOR SEA-ICE XW Nov04
- & fice(lon,lan),tisfc(lon,lan), &
- & solcon,coszen(lon,lan),coszdg(lon,lan),k1oz,k2oz,facoz, &
- & cv(lon,lan),cvt(lon,lan),cvb(lon,lan), &
- & IOVR_SW,IOVR_LW,f_ice,f_rain,r_rime,flgmin_v, &
- & icsdsw,icsdlw,NUM_P3D,NTCW-1,NCLD,NTOZ-1,NTRAC-1,NFXR, &
- & dtlw,dtsw,lsswr,lslwr,lssav,sas_shal,norad_precip, &
- & crick_proof, ccnorm, &
- & ngptc,njeff,LEVR,IFLIP, me, lprnt,ipt,kdt, &
-! & ngptc,njeff,LEVR,IFLIP, me, lprnt, &
-! --- outputs:
- & swh_v,sfcnsw(lon,lan),sfcdsw(lon,lan), &
- & sfalb(lon,lan), &
- & hlw_v,sfcdlw(lon,lan),tsflw(lon,lan), &
- & sfcemis(lon,lan),cldcov_v, &
-! --- input/output:
- & fluxr_v &
- & )
-!
-!
-! if (lprnt) print *,' returned from grrad for me=',me,' lan=',
-! &lan,' lat=',lat,' kdt=',kdt
-! print *,' end gloopr HLW=',hlw(lon,:,lan),' lan=',lan
-!
-! if (lprnt) print *,' swh_vg=',swh_v(ipt,:)
-!
-!
- if (lssav) then
- if (ldiag3d .or. lggfs3d) then
- do k=1,levr
- do j=1,njeff
- cldcov(lon+j-1,k,lan) = cldcov(lon+j-1,k,lan) &
- & + cldcov_v(j,k) * raddt
- enddo
- enddo
- endif
- endif
- do k=1,nfxr
- do j=1,njeff
- fluxr(lon+j-1,k,lan) = fluxr_v(j,k)
- enddo
- enddo
- if (lslwr) then
- do k=1,levr
- do j=1,njeff
- jtem = lon + j - 1
- hlw(jtem,k,lan) = hlw_v(j,k)
- swh(jtem,k,lan) = swh_v(j,k)
- enddo
- enddo
- if (levr .lt. levs) then
- do k=levr+1,levs
- do j=1,njeff
- jtem = lon + j - 1
- hlw(jtem,k,lan) = hlw_v(j,levr)
- swh(jtem,k,lan) = swh_v(j,levr)
- enddo
- enddo
- endif
- endif
-!
-! if (lat == 45 .and. me == 0 .and. lon == 1) then
-! print *,' after grrad hlw_v=',hlw_v(1,:)
-! print *,' after grrad swh_v=',swh_v(1,:)
-! endif
-! if (lprnt) print *,' hlwg=',hlw(lon+ipt-1,:,lan)
-! if (lprnt) print *,' swhg=',swh(lon+ipt-1,:,lan)
-! if (lprnt) print *,' swh_vg=',swh_v(ipt,:)
-
-!$$$ write(2900+lat,*) ' ilon = ',istrt
-c$$$ write(2900+lat,'("swh",T16,"hlw")')
-!$$$ do k=1,levs
-!$$$ write(2900+lat,
-!$$$ . '(e10.3,T16,e10.3,T31,e10.3)')
-!$$$ . swh(1,k,iblk,lan),hlw(1,k,iblk,lan)
-!$$$ enddo
-
-!!
-! print *,' completed grrad for lan=',lan,' istrt=',istrt
- CALL countperf(1,12,0.)
- ENDDO
-!
- enddo
-!!
- call f_hpmstop(69)
-!!
- CALL countperf(0,5,0.)
- CALL synctime()
- CALL countperf(1,5,0.)
-!sela print*,'completed gloopr_v kdt=',kdt
-!!
- return
- end subroutine gloopr
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/makefile.sh_ibm
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/makefile.sh_ibm (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/makefile.sh_ibm 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,24 @@
+#!/bin/ksh
+set -x
+sorc_dir=$(pwd)
+sorc_gfs=${sorc_dir}/physics_gfs
+exec_dir=$sorc_dir
+mkdir -p $exec_dir
+#
+make_dir=/ptmp/$LOGNAME/$(basename $sorc_dir)
+mkdir -p $make_dir
+cd $make_dir
+cd $make_dir || exit 99
+[ $? -ne 0 ] && exit 8
+#
+ rm $make_dir/*.o
+ rm $make_dir/*.mod
+ cp $sorc_dir/*.f .
+ cp $sorc_gfs/*.f .
+
+ export EXEC="$exec_dir/global_fcst"
+
+ export F77=mpxlf95_r
+ export F90=mpxlf95_r
+#
+ make -f Makefile.ibm
Property changes on: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/makefile.sh_ibm
___________________________________________________________________
Added: svn:executable
+ *
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/makefile.sh_jet
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/makefile.sh_jet (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/makefile.sh_jet 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,26 @@
+#!/bin/ksh
+set -x
+sorc_dir=$(pwd)
+sorc_gfs=${sorc_dir}/physics_gfs
+exec_dir=$sorc_dir
+mkdir -p $exec_dir
+#
+make_dir=/ptmp/$LOGNAME/$(basename $sorc_dir)
+mkdir -p $make_dir
+cd $make_dir
+cd $make_dir || exit 99
+[ $? -ne 0 ] && exit 8
+#
+ rm $make_dir/*.o
+ rm $make_dir/*.mod
+ cp $sorc_dir/*.f .
+ cp $sorc_gfs/*.f .
+
+ export EXEC="$exec_dir/global_fcst"
+
+ export F77=mpif90
+ export F90=mpif90
+ export FCC=mpicc
+ export CFLAGS=LINUX
+#
+ make -f Makefile.jet
Property changes on: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/makefile.sh_jet
___________________________________________________________________
Added: svn:executable
+ *
Added: branches/atmos_physics_gfs/src/core_atmos_physics_gfs/radiation_astronomy.f
===================================================================
--- branches/atmos_physics_gfs/src/core_atmos_physics_gfs/radiation_astronomy.f (rev 0)
+++ branches/atmos_physics_gfs/src/core_atmos_physics_gfs/radiation_astronomy.f 2012-05-10 23:40:46 UTC (rev 1895)
@@ -0,0 +1,804 @@
+!!!!! ========================================================== !!!!!
+!!!!! 'module_radiation_astronomy' description !!!!!
+!!!!! ========================================================== !!!!!
+! !
+! set up astronomy quantities for solar radiation calculations. !
+! !
+! in module 'module_radiation_astronomy', externally accessable !
+! subroutines are listed below: !
+! !
+! 'solinit' -- read in solar constant !
+! input: !
+! ( ISOL, iyear, iydat, me ) !
+! output: !
+! ( none ) !
+! !
+! 'astronomy' -- get astronomy related quantities !
+! input: !
+! ( lons_lar,glb_lats_r,sinlat,coslat,xlon, !
+!! fhswr,jdate,deltim, !
+! fhswr,jdate, !
+! LON2,LATD,LATR,IPT_LATR, lsswr, me) !
+! output: !
+! ( solcon,slag,sdec,cdec,coszen,coszdg) !
+! !
+! !
+! external modules referenced: !
+! 'module machine' in 'machine.f' !
+! 'module physcons' in 'physcons.f !
+! !
+! program history log: !
+! may-06-1977 --- ray orzol, created at gfdl !
+! jul-07-1989 --- kenneth campana !
+! may-15-1998 --- mark iredell y2k compliance !
+! dec-15-2003 --- yu-tai hou combined compjd and fcstim and !
+! rewrite in fortran 90 compatable form !
+! feb-15-2006 --- yu-tai hou add 11-yr solar constant cycle !
+! mar-19-2009 --- yu-tai hou modified solinit for climate !
+! hindcast situation. !
+! !
+!!!!! ========================================================== !!!!!
+!!!!! end descriptions !!!!!
+!!!!! ========================================================== !!!!!
+
+
+
+!========================================!
+ module module_radiation_astronomy !
+!........................................!
+!
+ use machine, only : kind_phys
+ use physcons, only : con_solr, con_pi
+ use module_iounitdef, only : NIRADSF
+!
+ implicit none
+!
+ private
+
+! --- parameter constants
+ real (kind=kind_phys), parameter :: degrad = 180.0/con_pi
+ real (kind=kind_phys), parameter :: tpi = 2.0 * con_pi
+ real (kind=kind_phys), parameter :: hpi = 0.5 * con_pi
+
+! --- module variables:
+ real (kind=kind_phys), public :: solc0
+
+ public solinit, astronomy
+
+
+! =================
+ contains
+! =================
+
+!-----------------------------------
+ subroutine solinit &
+!...................................
+
+! --- inputs:
+ & ( ISOL, iyear, iydat, me )
+! --- outputs: ( none )
+
+! =================================================================== !
+! !
+! read in solar constant value for a given year !
+! !
+! inputs: !
+! ISOL - =0: use fixed solar constant in "physcon" !
+! =1: use 11-year cycle solar constant from table !
+! iyear - year of the requested data (for ISOL=1 only) !
+! iydat - usually =iyear. if not, it is for hindcast mode, and it !
+! is usually the init cond time and serves as the upper !
+! limit of data can be used. !
+! me - print message control flag !
+! !
+! outputs: (to module variable) !
+! ( none ) !
+! !
+! module variable: !
+! solc0 - solar constant (w/m**2) 1 !
+! !
+! usage: call solinit !
+! !
+! subprograms called: none !
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- input:
+ integer, intent(in) :: ISOL, iyear, iydat, me
+
+! --- output: ( none )
+
+! --- local:
+ real (kind=kind_phys):: smean, solc1
+ integer :: i, iyr, iyr1, iyr2, jyr
+ logical :: file_exist
+ character :: cline*60, cfile0*26
+
+ data cfile0 / 'solarconstantdata.txt' /
+
+!===> ... begin here
+
+ if ( ISOL == 0 ) then
+ solc0 = con_solr
+
+ if ( me == 0 ) then
+ print *,' - Using fixed solar constant =', solc0
+ endif
+
+ return
+ endif
+
+! --- ... check to see if the solar constant data file existed
+
+ inquire (file=cfile0, exist=file_exist)
+ if ( .not. file_exist ) then
+ solc0 = con_solr
+
+ if ( me == 0 ) then
+ print *,' - Using varying solar constant with 11-year cycle'
+ print *,' Requested solar data file "',cfile0, &
+ & '" not found!'
+ print *,' Using the default solar constant value =',solc0, &
+ & ' instead!!'
+ endif
+ else
+ iyr = iyear
+
+ open (NIRADSF,file=cfile0,form='formatted',status='old')
+ rewind NIRADSF
+
+ read (NIRADSF, 24) iyr1, iyr2, smean, cline
+ 24 format(i4,2x,i4,f8.2,a60)
+
+! --- ... check if there is a upper year limit put on the data table
+
+ if ( iyear /= iydat ) then
+ if ( iydat-iyr1 < 11 ) then ! need data range at least 11 years
+ ! to perform 11-year cycle approx
+ if ( me == 0 ) then
+ print *,' - Using varying solar constant with 11-year', &
+ & ' cycle'
+ print *,' *** the requested year',iyear,' and upper ', &
+ & 'limit',iydat,' do not fit the range of data ', &
+ & 'table of iyr1, iyr2 =',iyr1,iyr2
+ print *,' USE FIXED SOLAR CONSTANT=',con_solr
+ endif
+
+ solc0 = con_solr
+ return
+
+ elseif ( iydat < iyr2 ) then
+
+! --- ... because the usage limit put on the historical data table,
+! skip those unused data records at first
+
+ i = iyr2
+ Lab_dowhile0 : do while ( i > iydat )
+! read (NIRADSF,26) jyr, solc1
+! 26 format(i4,f8.2)
+ read (NIRADSF,*) jyr, solc1
+ i = i - 1
+ enddo Lab_dowhile0
+
+ iyr2 = iydat ! next record will serve the upper limit
+
+ endif ! end if_iydat_block
+ endif ! end if_iyear_block
+
+ if ( me == 0 ) then
+ print *,' - Using varying solar constant with 11-year cycle'
+ print *,' Opened solar constant data file: ',cfile0
+!check print *, iyr1, iyr2, smean, cline
+ endif
+
+ if ( iyr < iyr1 ) then
+ Lab_dowhile1 : do while ( iyr < iyr1 )
+ iyr = iyr + 11
+ enddo Lab_dowhile1
+
+ if ( me == 0 ) then
+ print *,' *** Year',iyear,' out of table range!', &
+ & iyr1, iyr2
+ print *,' Using the 11-cycle year (',iyr,' ) value.'
+ endif
+ elseif ( iyr > iyr2 ) then
+ Lab_dowhile2 : do while ( iyr > iyr2 )
+ iyr = iyr - 11
+ enddo Lab_dowhile2
+
+ if ( me == 0 ) then
+ print *,' *** Year',iyear,' out of given table range!', &
+ & iyr1, iyr2
+ print *,' Using the 11-cycle year (',iyr,' ) value.'
+ endif
+ endif
+
+! --- ... locate the right record year of data
+
+ i = iyr2
+ Lab_dowhile3 : do while ( i >= iyr1 )
+! read (NIRADSF,26) jyr, solc1
+! 26 format(i4,f8.2)
+ read (NIRADSF,*) jyr, solc1
+
+ if ( i == iyr .and. iyr == jyr ) then
+ solc0 = smean + solc1
+ if (me == 0) then
+ print *,' CHECK: Solar constant data for year',iyr, &
+ & solc1, solc0
+ endif
+ exit Lab_dowhile3
+ else
+!check if (me == 0) print *,' Skip solar const data for year',i
+ i = i - 1
+ endif
+ enddo Lab_dowhile3
+
+ close ( NIRADSF )
+ endif ! end if_file_exist_block
+
+!
+ return
+!...................................
+ end subroutine solinit
+!-----------------------------------
+
+
+!-----------------------------------
+ subroutine astronomy &
+!...................................
+
+! --- inputs:
+ & ( lons_lar,glb_lats_r,sinlat,coslat,xlon, &
+! & fhswr,jdate,deltim, &
+ & fhswr,jdate, &
+ & LON2,LATD,LATR,IPT_LATR, lsswr, me, &
+! --- outputs:
+ & solcon,slag,sdec,cdec,coszen,coszdg &
+ & )
+
+! =================================================================== !
+! !
+! astronomy computes solar parameters at forecast time !
+! !
+! inputs: dimension !
+! lons_lar - num of grid pts on a given lat circle (LATR)!
+! glb_lats_r - index for global latitudes (LATR)!
+! sinlat,coslat - sin and cos of latitude (LON2,LATR)!
+! xlon - longitude in radians (LON2*LATD)!
+! fhswr - sw radiation calling interval in hour !
+! jdate - current forecast date and time (8) !
+! (yr, mon, day, t-zone, hr, min, sec, mil-sec) !
+!! deltim - duration of model integration time step in seconds !
+! LON2,LATD,LATR- dimensions for longitude/latitude directions !
+! IPT_LATR - latitude index location indecator !
+! lsswr - logical control flag for sw radiation call !
+! me - integer control flag for diagnostic print out !
+! !
+! outputs: !
+! solcon - sun-earth distance adjusted solar constant (w/m2) !
+! slag - equation of time in radians !
+! sdec, cdec - sin and cos of the solar declination angle !
+! coszen - avg of cosz for daytime only (LON2,LATD)!
+! coszdg - avg of cosz over entire sw call interval(LON2,LATD)!
+! !
+! !
+! external functions called: iw3jdn !
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- input:
+ integer, intent(in) :: LON2, LATD, LATR, IPT_LATR, me
+ integer, intent(in) :: lons_lar(:), glb_lats_r(:), jdate(:)
+
+ logical, intent(in) :: lsswr
+
+ real (kind=kind_phys), intent(in) :: sinlat(:,:), coslat(:,:), &
+ & xlon(:,:), fhswr
+! & xlon(:,:), fhswr, deltim
+
+! --- output:
+ real (kind=kind_phys), intent(out) :: solcon, slag, sdec, cdec, &
+ & coszen(:,:), coszdg(:,:)
+
+! --- locals:
+ real (kind=kind_phys), parameter :: f24 = 24.0 ! hours/day
+ real (kind=kind_phys), parameter :: f1440 = 1440.0 ! minutes/day
+
+ real (kind=kind_phys) :: solhr, fjd, fjd1, dlt, r1, alp, solc
+
+ integer :: jd, jd1, iyear, imon, iday, ihr, imin
+ integer :: iw3jdn
+
+!===> ... begin here
+
+ iyear = jdate(1)
+ imon = jdate(2)
+ iday = jdate(3)
+ ihr = jdate(5)
+ imin = jdate(6)
+
+! --- ... calculate forecast julian day and fraction of julian day
+
+ jd1 = iw3jdn(iyear,imon,iday)
+
+! --- ... unlike in normal applications, where day starts from 0 hr,
+! in astronomy applications, day stats from noon.
+
+ if (ihr < 12) then
+ jd1 = jd1 - 1
+! fjd1= 0.5 + float(ihr)/f24 ! use next line if imin > 0
+ fjd1= 0.5 + float(ihr)/f24 + float(imin)/f1440
+ else
+! fjd1= float(ihr - 12)/f24 ! use next line if imin > 0
+ fjd1= float(ihr - 12)/f24 + float(imin)/f1440
+ endif
+
+ fjd1 = fjd1 + jd1
+
+ jd = int(fjd1)
+ fjd = fjd1 - jd
+
+ if (lsswr) then
+
+! --- ... hour of forecast time
+
+ solhr = mod( float(ihr), f24 )
+
+ call solar &
+! --- inputs:
+ & ( jd,fjd, &
+! --- outputs:
+ & r1,dlt,alp,slag,sdec,cdec &
+ & )
+
+! if (me == 0) print*,'in astronomy completed sr solar'
+
+ call coszmn &
+! --- inputs:
+ & ( lons_lar,glb_lats_r,xlon,sinlat,coslat, &
+! & fhswr,deltim,solhr,sdec,cdec,slag, &
+ & fhswr,solhr,sdec,cdec,slag, &
+ & LON2,LATD,IPT_LATR, &
+! --- outputs:
+ & coszen,coszdg &
+ & )
+
+! if (me == 0) print*,'in astronomy completed sr coszmn'
+
+! --- ... calculate sun-earth distance adjustment factor appropriate for date
+
+ solcon = solc0 / (r1*r1)
+
+ endif
+
+! --- ... diagnostic print out
+
+ if (me == 0) then
+
+ call prtime &
+! --- inputs:
+ & ( jd, fjd, dlt, alp, r1, slag, solcon &
+! --- outputs: ( none )
+ & )
+
+ endif
+
+!
+ return
+!...................................
+ end subroutine astronomy
+!-----------------------------------
+
+
+!-----------------------------------
+ subroutine solar &
+!...................................
+
+! --- inputs:
+ & ( jd,fjd, &
+! --- outputs:
+ & r1,dlt,alp,slag,sdec,cdec &
+ & )
+
+! =================================================================== !
+! !
+! solar computes radius vector, declination and right ascension of !
+! sun, and equation of time. !
+! !
+! inputs: !
+! jd - julian day !
+! fjd - fraction of the julian day !
+! !
+! outputs: !
+! r1 - earth-sun radius vector !
+! dlt - declination of sun in radians !
+! alp - right ascension of sun in radians !
+! slag - equation of time in radians !
+! sdec - sine of declination angle !
+! cdec - cosine of declination angle !
+! !
+! usage: call solar !
+! !
+! external subroutines called: none !
+! !
+! program history log: !
+! mar-xx-1989 --- kenneth campana, patterner after original gfdl !
+! code but no calculation of latitude mean cos !
+! solar zenith angle. !
+! fall -1988 --- hualu pan, updated to limit iterations in newton!
+! method and also ccr reduced to avoid non- !
+! convergence. !
+! dec-15-2003 --- yu-tai hou, updated to make fortran 90 compatable!
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- inputs:
+ real (kind=kind_phys), intent(in) :: fjd
+ integer, intent(in) :: jd
+
+! --- outputs:
+ real (kind=kind_phys), intent(out) :: r1, dlt,alp,slag,sdec,cdec
+
+! --- locals:
+ real (kind=kind_phys), parameter :: cyear = 365.25 ! days of year
+ real (kind=kind_phys), parameter :: ccr = 1.3e-6 ! iteration limit
+ real (kind=kind_phys), parameter :: tpp = 1.55 ! days between epoch and
+ ! perihelion passage of 1900
+ real (kind=kind_phys), parameter :: svt6 = 78.035 ! days between perihelion passage
+ ! and march equinox of 1900
+ integer, parameter :: jdor = 2415020 ! jd of epoch which is january
+ ! 0, 1900 at 12 hours ut
+
+ real (kind=kind_phys) :: dat, t1, year, tyear, ec, angin, ador, &
+ & deleqn, sni, tini, er, qq, e1, ep, cd, eq, date, em, &
+ & cr, w1, tst, sun
+
+ integer :: jdoe, iter
+
+!===> ... begin here
+
+! --- ... computes time in julian centuries after epoch
+
+ t1 = float(jd - jdor) / 36525.0
+
+! --- ... computes length of anomalistic and tropical years (minus 365 days)
+
+ year = 0.25964134e0 + 0.304e-5 * t1
+ tyear= 0.24219879E0 - 0.614e-5 * t1
+
+! --- ... computes orbit eccentricity and angle of earth's inclination from t
+
+ ec = 0.01675104e0 - (0.418e-4 + 0.126e-6 * t1) * t1
+ angin= 23.452294e0 - (0.0130125e0 + 0.164e-5 * t1) * t1
+
+ ador = jdor
+ jdoe = ador + (svt6 * cyear) / (year - tyear)
+
+! --- ... deleqn is updated svt6 for current date
+
+ deleqn= float(jdoe - jd) * (year - tyear) / cyear
+ year = year + 365.0
+ sni = sin( angin / degrad )
+ tini = 1.0 / tan( angin / degrad )
+ er = sqrt( (1.0 + ec) / (1.0 - ec) )
+ qq = deleqn * tpi / year
+
+! --- ... determine true anomaly at equinox
+
+ e1 = 1.0
+ cd = 1.0
+ iter = 0
+
+ lab_do_1 : do while ( cd > ccr )
+
+ ep = e1 - (e1 - ec*sin(e1) - qq) / (1.0 - ec*cos(e1))
+ cd = abs(e1 - ep)
+ e1 = ep
+ iter = iter + 1
+
+ if (iter > 10) then
+ write(6,*) ' ITERATION COUNT FOR LOOP 32 =', iter
+ write(6,*) ' E, EP, CD =', e1, ep, cd
+ exit lab_do_1
+ endif
+
+ enddo lab_do_1
+
+ eq = 2.0 * atan( er * tan( 0.5*e1 ) )
+
+! --- ... date is days since last perihelion passage
+
+ dat = float(jd - jdor) - tpp + fjd
+ date = mod(dat, year)
+
+! --- ... solve orbit equations by newton's method
+
+ em = tpi * date / year
+ e1 = 1.0
+ cr = 1.0
+ iter = 0
+
+ lab_do_2 : do while ( cr > ccr )
+
+ ep = e1 - (e1 - ec*sin(e1) - em) / (1.0 - ec*cos(e1))
+ cr = abs(e1 - ep)
+ e1 = ep
+ iter = iter + 1
+
+ if (iter > 10) then
+ write(6,*) ' ITERATION COUNT FOR LOOP 31 =', iter
+ exit lab_do_2
+ endif
+
+ enddo lab_do_2
+
+ w1 = 2.0 * atan( er * tan( 0.5*e1 ) )
+
+ r1 = 1.0 - ec*cos(e1)
+
+ sdec = sni * sin(w1 - eq)
+ cdec = sqrt( 1.0 - sdec*sdec )
+
+ dlt = asin( sdec )
+ alp = asin( tan(dlt)*tini )
+
+ tst = cos( w1 - eq )
+ if (tst < 0.0) alp = con_pi - alp
+ if (alp < 0.0) alp = alp + tpi
+
+ sun = tpi * (date - deleqn) / year
+ if (sun < 0.0) sun = sun + tpi
+ slag = sun - alp - 0.03255e0
+
+!
+ return
+!...................................
+ end subroutine solar
+!-----------------------------------
+
+
+!-----------------------------------
+ subroutine coszmn &
+!...................................
+
+! --- inputs:
+ & ( lons_lar,glb_lats_r,xlon,sinlat,coslat, &
+! & dtswav,deltim,solhr,sdec,cdec,slag, &
+ & dtswav,solhr,sdec,cdec,slag, &
+ & NLON2,LATD,IPT_LATR, &
+! --- outputs:
+ & coszen,coszdg &
+ & )
+
+! =================================================================== !
+! !
+! coszmn computes mean cos solar zenith angle over 'dtswav' hours. !
+! !
+! inputs: !
+! lons_lar - num of grid pts on a given lat circle !
+! glb_lats_r - index for global latitude !
+! xlon - longitude in radians !
+! sinlat,coslat - sin and cos of latitude !
+! dtswav - sw radiation calling interval in hour !
+!! deltim - duration of model integration time step in second !
+! solhr - time after 00z in hours !
+! sdec, cdec - sin and cos of the solar declination angle !
+! slag - equation of time !
+! NLON2,LATD - dimensions for longitude/latitude directions !
+! IPT_LATR - latitude index location indecator !
+! !
+! outputs: !
+! coszen - average of cosz for daytime only in sw call interval
+! coszdg - average of cosz over entire sw call interval !
+! !
+! usage: call comzmn !
+! !
+! external subroutines called: none !
+! !
+! program history log: !
+! 05-28-2004 yu-tai hou - modified for gfs hybrid model !
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- inputs:
+ integer, intent(in) :: NLON2, LATD, IPT_LATR
+ integer, intent(in) :: lons_lar(:), glb_lats_r(:)
+
+ real (kind=kind_phys), intent(in) :: sinlat(:,:), coslat(:,:), &
+ & xlon(:,:), dtswav, solhr, sdec, cdec, slag
+! & xlon(:,:), dtswav, deltim, solhr, sdec, cdec, slag
+
+! --- outputs:
+ real (kind=kind_phys), intent(out) :: coszen(:,:), coszdg(:,:)
+
+! --- locals:
+ real (kind=kind_phys) :: coszn(NLON2), pid12, cns, ss, cc
+
+ integer :: istsun(NLON2), nstp, istp, nlon, nlnsp, i, it,j,lat,lon
+
+!===> ... begin here
+
+ nlon = NLON2 / 2
+
+ nstp = 6 ! number of cosz calc per fcst hour
+! nstp = max(6, min(10, nint(3600.0/deltim) )) ! for better time step sync
+ istp = nint( dtswav*nstp ) ! total num of calc in dtswav interval
+
+! pid12 = con_pi / 12.0 ! angle per hour
+ pid12 = (2.0 * asin(1.0)) / 12.0
+
+ do j = 1, LATD
+ lat = glb_lats_r(IPT_LATR-1+j)
+ nlnsp = lons_lar(lat)
+
+ do i = 1, NLON2
+ istsun(i) = 0
+ coszen(i,j) = 0.0
+ enddo
+
+ do i = 1, nlnsp
+ do it = 1, istp
+ cns = pid12 * (solhr - 12.0 + float(it-1)/float(nstp)) + slag
+ ss = sinlat(i,lat) * sdec
+ cc = coslat(i,lat) * cdec
+
+ coszn(i) = ss + cc * cos(cns + xlon(i,j))
+ coszen(i,j) = coszen(i,j) + max(0.0, coszn(i))
+ if (coszn(i) > 0.0001) istsun(i) = istsun(i) + 1
+ enddo
+ enddo
+
+! --- ... compute time averages
+
+ do i = 1, NLON2
+ coszdg(i,j) = coszen(i,j) / float(istp)
+ if (istsun(i) > 0) coszen(i,j) = coszen(i,j) / istsun(i)
+ enddo
+ enddo
+
+!
+ return
+!...................................
+ end subroutine coszmn
+!-----------------------------------
+
+
+!-----------------------------------
+ subroutine prtime &
+!...................................
+
+! --- inputs:
+ & ( jd, fjd, dlt, alp, r1, slag, solc &
+! --- outputs: ( none )
+ & )
+
+! =================================================================== !
+! !
+! prtime prints out forecast date, time, and astronomy quantities. !
+! !
+! inputs: !
+! jd - forecast julian day !
+! fjd - forecast fraction of julian day !
+! dlt - declination angle of sun in radians !
+! alp - right ascension of sun in radians !
+! r1 - earth-sun radius vector in meter !
+! slag - equation of time in radians !
+! solc - solar constant in w/m^2 !
+! !
+! outputs: ( none ) !
+! !
+! usage: call prtime !
+! !
+! external subroutines called: w3fs26 !
+! !
+! program history log: !
+! jun-07-1977 --- robert white (gfdl) !
+! jul-07-1989 --- kenneth campana !
+! may-15-1998 --- mark iredell y2k compliance !
+! dec-18-2003 --- yu-tai hou combine cdate and prtime and !
+! rewrite in fortran 90 compatable form !
+! !
+! =================================================================== !
+!
+ implicit none
+
+! --- inputs:
+ integer, intent(in) :: jd
+
+ real (kind=kind_phys), intent(in) :: fjd, dlt, alp, r1, slag, solc
+
+! --- outputs: ( none )
+
+! --- locals:
+ real (kind=kind_phys), parameter :: sixty = 60.0
+
+ character(LEN=1), parameter :: sign = '-'
+ character(LEN=1), parameter :: sigb = ' '
+
+ character(LEN=1) :: dsig
+ character(LEN=4) :: month(12)
+
+ data month / 'JAN.','FEB.','MAR.','APR.','MAY ','JUNE', &
+ & 'JULY','AUG.','SEP.','OCT.','NOV ','DEC.' /
+
+ integer :: iday, imon, iyear, ihr, ltd, ltm, &
+ & ihalp, iyy, jda, mfjd, idaywk, idayyr
+ real (kind=kind_phys) :: xmin, dltd, dltm, dlts, halp, ymin, &
+ & asec, eqt, eqsec
+
+!===> ... begin here
+
+! --- ... get forecast hour and minute from fraction of julian day
+
+ if (fjd >= 0.5) then
+ jda = jd + 1
+ mfjd= nint( fjd*1440.0 )
+ ihr = mfjd / 60 - 12
+ xmin= float(mfjd) - (ihr + 12)*sixty
+ else
+ jda = jd
+ mfjd= nint( fjd*1440.0 )
+ ihr = mfjd / 60 + 12
+ xmin= float(mfjd) - (ihr - 12)*sixty
+ endif
+
+! --- ... get forecast year, month, and day from julian day
+
+ call w3fs26(jda, iyear,imon,iday, idaywk,idayyr)
+
+! -- ... compute solar parameters
+
+ dltd = degrad * dlt
+ ltd = dltd
+ dltm = sixty * (abs(dltd) - abs(float(ltd)))
+ ltm = dltm
+ dlts = sixty * (dltm - float(ltm))
+
+ if ((dltd < 0.0) .and. (ltd == 0.0)) then
+ dsig = sign
+ else
+ dsig = sigb
+ endif
+
+ halp = 6.0 * alp / hpi
+ ihalp= halp
+ ymin = abs(halp - float(ihalp)) * sixty
+ iyy = ymin
+ asec = (ymin - float(iyy)) * sixty
+
+ eqt = 228.55735 * slag
+ eqsec= sixty * eqt
+
+ print 101, iday, month(imon), iyear, ihr, xmin, jd, fjd
+ 101 format('0 FORECAST DATE',9x,i3,a5,i6,' AT',i3,' HRS',f6.2,' MINS'/&
+ & ' JULIAN DAY',12x,i8,2x,'PLUS',f11.6)
+
+ print 102, r1, halp, ihalp, iyy, asec
+ 102 format(' RADIUS VECTOR',9x,f10.7/' RIGHT ASCENSION OF SUN', &
+ & f12.7,' HRS, OR',i4,' HRS',i4,' MINS',f6.1,' SECS')
+
+ print 103, dltd, dsig, ltd, ltm, dlts, eqt, eqsec, slag, solc
+ 103 format(' DECLINATION OF THE SUN',f12.7,' DEGS, OR ',a1,i3, &
+ & ' DEGS',i4,' MINS',f6.1,' SECS'/' EQUATION OF TIME',6x, &
+ & f12.7,' MINS, OR',f10.2,' SECS, OR',f9.6,' RADIANS'/ &
+ & ' SOLAR CONSTANT',8X,F12.7,' (DISTANCE AJUSTED)'//)
+
+!
+ return
+!...................................
+ end subroutine prtime
+!-----------------------------------
+
+!
+!...........................................!
+ end module module_radiation_astronomy !
+!===========================================!
</font>
</pre>