diff --git a/.circleci/config.yml b/.circleci/config.yml index 03b7678226..6f01249940 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -1,7 +1,7 @@ version: 2.1 # Anchors in case we need to override the defaults from the orb -#baselibs_version: &baselibs_version v8.14.0 +#baselibs_version: &baselibs_version v8.32.0 #bcs_version: &bcs_version v12.0.0 orbs: @@ -21,10 +21,7 @@ workflows: #baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true - # V12 code uses a special branch for now. - fixture_branch: feature/sdrabenh/gcm_v12 - # We comment out this as it will "undo" the fixture_branch - #mepodevelop: true + mepodevelop: true persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra # Run AMIP GCM (1 hour, no ExtData) diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 951124df33..bb430dbbfe 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -21,7 +21,7 @@ jobs: strategy: fail-fast: false matrix: - compiler: [ifort, gfortran-14, gfortran-15] + compiler: [ifort, gfortran-15, ifx] build-type: [Debug] fixture-repo: [GEOS-ESM/GEOSgcm, GEOS-ESM/GEOSldas] include: @@ -37,7 +37,6 @@ jobs: compiler: ${{ matrix.compiler }} cmake-build-type: ${{ matrix.build-type }} fixture-repo: GEOS-ESM/GEOSgcm - fixture-ref: feature/sdrabenh/gcm_v12 spack_build: strategy: @@ -54,6 +53,5 @@ jobs: BUILDCACHE_TOKEN: ${{ secrets.BUILDCACHE_TOKEN }} with: fixture-repo: GEOS-ESM/GEOSgcm - fixture-ref: feature/sdrabenh/gcm_v12 load-fms: true diff --git a/GEOS_GcmGridComp.F90 b/GEOS_GcmGridComp.F90 index d7aa45d4d1..d090d5869e 100644 --- a/GEOS_GcmGridComp.F90 +++ b/GEOS_GcmGridComp.F90 @@ -575,15 +575,15 @@ subroutine SetServices ( GC, RC ) SRC_ID = AGCM, & RC=STATUS ) VERIFY_(STATUS) - endif - call MAPL_AddConnectivity ( GC, & - SHORT_NAME = (/'QLTOT', 'QITOT', 'QRTOT', & - 'QSTOT', 'QGTOT'/), & - DST_ID = AIAU, & - SRC_ID = AGCM, & - RC=STATUS ) - VERIFY_(STATUS) + call MAPL_AddConnectivity ( GC, & + SHORT_NAME = (/'QLTOT', 'QITOT', 'QRTOT', & + 'QSTOT', 'QGTOT'/), & + DST_ID = AIAU, & + SRC_ID = AGCM, & + RC=STATUS ) + VERIFY_(STATUS) + endif if (DO_CICE_THERMO == 2) then call MAPL_AddConnectivity ( GC, & diff --git a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 index 3c2e807059..993e5cbf19 100644 --- a/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 +++ b/GEOSagcm_GridComp/GEOS_AgcmGridComp.F90 @@ -1074,19 +1074,23 @@ subroutine SetServices ( GC, RC ) ! Set internal connections between the childrens IMPORTS and EXPORTS ! ------------------------------------------------------------------ - call MAPL_AddConnectivity ( GC, & - SRC_NAME = (/'U ','V ','TH ','T ', & - 'ZLE ','PS ','TA ','QA ', & - 'US ','VS ', & - 'SPEED ','DZ ','PLE ','W ', & - 'PREF ','TROPP_BLENDED','S ','PLK ', & - 'PV ','TROPK_BLENDED','OMEGA ','PKE '/), & - DST_NAME = (/'U ','V ','TH ','T ', & - 'ZLE ','PS ','TA ','QA ', & - 'UA ','VA ', & - 'SPEED ','DZ ','PLE ','W ', & - 'PREF ','TROPP ','S ','PLK ', & - 'PV ','TROPK ','OMEGA ','PKE '/), & + ! Set the length of the character array constructor to + ! the length of the longest string in the array + call MAPL_AddConnectivity ( GC, & + SRC_NAME = [character(len=15) :: & + 'U', 'V', 'TH', 'T', & + 'ZLE', 'PS', 'TA', 'QA', & + 'US', 'VS', 'WSPD_STABLE300M', & + 'SPEED', 'DZ', 'PLE', 'W', & + 'PREF', 'TROPP_BLENDED', 'S', 'PLK', & + 'PV', 'TROPK_BLENDED', 'OMEGA', 'PKE'], & + DST_NAME = [character(len=15) :: & + 'U', 'V', 'TH', 'T', & + 'ZLE', 'PS', 'TA', 'QA', & + 'UA', 'VA', 'WSPD_STABLE300M', & + 'SPEED', 'DZ', 'PLE', 'W', & + 'PREF', 'TROPP', 'S', 'PLK', & + 'PV', 'TROPK', 'OMEGA', 'PKE'], & DST_ID = PHYS, & SRC_ID = SDYN, & RC=STATUS ) @@ -1623,9 +1627,9 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: TQV => null() real, pointer, dimension(:,:) :: TQI => null() real, pointer, dimension(:,:) :: TQL => null() - real, pointer, dimension(:,:) :: TQR => null() - real, pointer, dimension(:,:) :: TQS => null() - real, pointer, dimension(:,:) :: TQG => null() + real, pointer, dimension(:,:) :: TQR => null() + real, pointer, dimension(:,:) :: TQS => null() + real, pointer, dimension(:,:) :: TQG => null() real, pointer, dimension(:,:) :: TOX => null() real, pointer, dimension(:,:) :: TROPP1 => null() real, pointer, dimension(:,:) :: TROPP2 => null() @@ -2668,11 +2672,11 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, TQL , 'TQL' , rc=STATUS ) VERIFY_(STATUS) - call MAPL_GetPointer ( EXPORT, TQR , 'TQR' , rc=STATUS ) + call MAPL_GetPointer ( EXPORT, TQR , 'TQR' , rc=STATUS ) VERIFY_(STATUS) - call MAPL_GetPointer ( EXPORT, TQS , 'TQS' , rc=STATUS ) + call MAPL_GetPointer ( EXPORT, TQS , 'TQS' , rc=STATUS ) VERIFY_(STATUS) - call MAPL_GetPointer ( EXPORT, TQG , 'TQG' , rc=STATUS ) + call MAPL_GetPointer ( EXPORT, TQG , 'TQG' , rc=STATUS ) VERIFY_(STATUS) call MAPL_GetPointer ( EXPORT, QLTOT , 'QLTOT' , rc=STATUS ) VERIFY_(STATUS) @@ -2828,7 +2832,7 @@ subroutine Run ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Rain ! ------------ if(NAMES(K)=='QRAIN') then - call FILL_Friendly ( Q,DP,QFILL,QINT ) + call FILL_Friendly ( Q,DP,QFILL,QINT ) if(associated(QRFILL)) QRFILL = QRFILL + QFILL if(associated(QTFILL)) QTFILL = QTFILL + QFILL if(associated(DQRDTPHYINT)) DQRDTPHYINT = DQRDTPHYINT + QFILL diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 index a34270591f..adf46ec6ff 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GEOS_GwdGridComp.F90 @@ -260,6 +260,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) real :: NCAR_ET_EFF ! Frontal region efficiency factor real :: NCAR_ET_TAUBGND ! Extratropical background frontal forcing logical :: NCAR_ET_USE_DQCDT + logical :: NCAR_ET_USE_SPEED logical :: NCAR_DC_BERES integer :: GEOS_PGWV real :: NCAR_EFFGWBKG @@ -381,8 +382,16 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, NCAR_BKG_WAVELENGTH, Label="NCAR_BKG_WAVELENGTH:", default=1.e5, _RC) call MAPL_GetResource( MAPL, NCAR_TR_EFF, Label="NCAR_TR_EFF:", default=1.0, _RC) call MAPL_GetResource( MAPL, NCAR_ET_EFF, Label="NCAR_ET_EFF:", default=1.0, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=6.4, _RC) - call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.FALSE., _RC) + + call MAPL_GetResource( MAPL, NCAR_ET_USE_DQCDT, Label="NCAR_ET_USE_DQCDT:", default=.TRUE., _RC) + call MAPL_GetResource( MAPL, NCAR_ET_USE_SPEED, Label="NCAR_ET_USE_SPEED:", default=.FALSE.,_RC) + + ! 1. Default to classic rigid latitude tuning + NCAR_ET_TAUBGND = 6.4 + ! 2. Set baselines for independent runs + if (NCAR_ET_USE_DQCDT .or. NCAR_ET_USE_SPEED) NCAR_ET_TAUBGND = 10.0 + call MAPL_GetResource( MAPL, NCAR_ET_TAUBGND, Label="NCAR_ET_TAUBGND:", default=NCAR_ET_TAUBGND, _RC) + call MAPL_GetResource( MAPL, NCAR_BKG_TNDMAX, Label="NCAR_BKG_TNDMAX:", default=250.0, _RC) NCAR_BKG_TNDMAX = NCAR_BKG_TNDMAX/86400.0 ! Beres DeepCu @@ -397,7 +406,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) self%workspaces(thread)%beres_dc_desc, & NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & - 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, & + 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, NCAR_ET_USE_SPEED, & NCAR_BKG_TNDMAX, NCAR_DC_BERES, & IM*JM_thread, LATS(:,bounds(thread+1)%min:bounds(thread+1)%max)) end do @@ -407,7 +416,7 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) self%workspaces(0)%beres_dc_desc, & NCAR_BKG_PGWV, NCAR_BKG_GW_DC, NCAR_BKG_FCRIT2, & NCAR_BKG_WAVELENGTH, NCAR_DC_BERES_SRC_LEVEL, & - 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, & + 1000.0, .TRUE., NCAR_TR_EFF, NCAR_ET_EFF, NCAR_ET_TAUBGND, NCAR_ET_USE_DQCDT, NCAR_ET_USE_SPEED, & NCAR_BKG_TNDMAX, NCAR_DC_BERES, & IM*JM, LATS ) endif @@ -685,7 +694,9 @@ subroutine Gwd_Driver(RC) !call MAPL_TimerOn(MAPL,"-INTR_NCAR") if ( (self%NCAR_EFFGWORO /= 0.0) .OR. (self%NCAR_EFFGWBKG /= 0.0) ) then DO L=1, LM - TMP3D(:,:,L) = (1.0-CNV_FRC)*(DQLDT(:,:,L)+DQIDT(:,:,L)) + ! Raising the mask to the 4th power aggressively suppresses + ! tendencies in regions with even modest CNV_FRC values + TMP3D(:,:,L) = ((1.0-CNV_FRC)**4) * (DQLDT(:,:,L)+DQIDT(:,:,L)) END DO if(associated(DQCDT_LS)) DQCDT_LS = TMP3D thread = MAPL_get_current_thread() @@ -694,7 +705,7 @@ subroutine Gwd_Driver(RC) workspace%beres_dc_desc, & workspace%beres_band, workspace%oro_band, workspace%rdg_band, & PLE, T, U, V, & - HT_dc, TMP3D, & + HT_dc, TMP3D, WSPD_STABLE300M, & SGH, MXDIS, HWDTH, CLNGT, ANGLL, & ANIXY, GBXAR_TMP, KWVRDG, EFFRDG, PREF, & PMID, PDEL, RPDEL, PILN, ZM, LATS, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc index fb80c1dcd1..09ef41bd12 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/GWD_StateSpecs.rc @@ -20,23 +20,24 @@ category: IMPORT #------------------------------------------------------------------------------------------------------- # VARIABLE | DIMENSIONS | Additional Metadata #------------------------------------------------------------------------------------------------------- - NAME | ALIAS | UNITS | DIMS | VLOC | RESTART | LONG NAME + NAME | ALIAS | UNITS | DIMS | VLOC | RESTART | LONG NAME #------------------------------------------------------------------------------------------------------- - PLE | | Pa | xyz | E | SKIP | air_pressure - T | | K | xyz | C | SKIP | air_temperature - Q | | kg kg-1 | xyz | C | SKIP | specific_humidity - U | | m s-1 | xyz | C | SKIP | eastward_wind - V | | m s-1 | xyz | C | SKIP | northward_wind - PHIS | | m+2 s-2 | xy | N | SKIP | surface geopotential height - SGH | | m | xy | N | SKIP | standard_deviation_of_topography - VARFLT | | m+2 | xy | N | SKIP | variance_of_the_filtered_topography - PREF | | Pa | z | E | SKIP | reference_air_pressure - AREA | | m^2 | xy | N | SKIP | grid_box_area + PLE | | Pa | xyz | E | SKIP | air_pressure + T | | K | xyz | C | SKIP | air_temperature + Q | | kg kg-1 | xyz | C | SKIP | specific_humidity + U | | m s-1 | xyz | C | SKIP | eastward_wind + V | | m s-1 | xyz | C | SKIP | northward_wind + PHIS | | m+2 s-2 | xy | N | SKIP | surface geopotential height + SGH | | m | xy | N | SKIP | standard_deviation_of_topography + VARFLT | | m+2 | xy | N | SKIP | variance_of_the_filtered_topography + PREF | | Pa | z | E | SKIP | reference_air_pressure + AREA | | m^2 | xy | N | SKIP | grid_box_area + WSPD_STABLE300M | | m s-1 | xy | N | SKIP | max_wind_speed_in_stable_cold_surface_layer #-from-moist- - DTDT_DC | HT_dc | K s-1 | xyz | C | | T tendency due to deep convection - DQLDT | | kg kg-1 s-1 | xyz | C | | total_liq_water_tendency_due_to_moist - DQIDT | | kg kg-1 s-1 | xyz | C | | total_ice_water_tendency_due_to_moist - CNV_FRC | | 1 | xy | N | | convective_fraction + DTDT_DC | HT_dc | K s-1 | xyz | C | | T tendency due to deep convection + DQLDT | | kg kg-1 s-1 | xyz | C | | total_liq_water_tendency_due_to_moist + DQIDT | | kg kg-1 s-1 | xyz | C | | total_ice_water_tendency_due_to_moist + CNV_FRC | | 1 | xy | N | | convective_fraction category: EXPORT #------------------------------------------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 index 5b35c7aebb..322406d5ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_convect.F90 @@ -47,6 +47,7 @@ module gw_convect ! Efficiency TR:ET function real, allocatable :: effbck(:) logical :: et_bkg_dqcdt_forcing + logical :: et_bkg_speed_forcing end type BeresSourceDesc @@ -57,7 +58,7 @@ module gw_convect !------------------------------------ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength, & spectrum_source, min_hdepth, storm_shift, eff_tr, eff_et, & - tau_et, et_use_dqcdt, tndmax, & + tau_et, et_use_dqcdt, et_use_speed, tndmax, & active, ncol, lats) #include @@ -69,7 +70,7 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength integer, intent(in) :: pgwv, ncol real, intent(in) :: gw_dc, fcrit2, wavelength real, intent(in) :: spectrum_source, min_hdepth, eff_tr, eff_et, tau_et, tndmax - logical, intent(in) :: storm_shift, active, et_use_dqcdt + logical, intent(in) :: storm_shift, active, et_use_dqcdt, et_use_speed real, intent(in) :: lats(ncol) ! Stuff for Beres convective gravity wave source. @@ -178,24 +179,29 @@ subroutine gw_beres_init (file_name, band, desc, pgwv, gw_dc, fcrit2, wavelength enddo cw = cw*(sum(cw4)/sum(cw)) desc%et_bkg_dqcdt_forcing = et_use_dqcdt + desc%et_bkg_speed_forcing = et_use_speed do i=1,ncol ! include forced background stress in extra tropics ! Determine the background stress at c=0 - ! Include dependence on latitude: - latdeg = lats(i)*rad2deg - if (desc%et_bkg_dqcdt_forcing) then - flat_gw = 0.15 + if (desc%et_bkg_dqcdt_forcing .or. desc%et_bkg_speed_forcing) then + flat_gw = 0.05 ! weak background forcing + desc%taubck(i,:) = tau_et*0.001*flat_gw*cw + ! efficiency function + desc%effbck(i) = eff_tr*cos(lats(i))**2 + & + eff_et*sin(lats(i))**2 else + ! Include dependence on latitude: + latdeg = lats(i)*rad2deg if (ABS(latdeg) < 60.) then flat_gw = max(0.15,0.50*exp(-((abs(latdeg)-60.)/23.)**2)) elseif (ABS(latdeg) >= 60.) then flat_gw = 0.50*exp(-((abs(latdeg)-60.)/70.)**2) endif + desc%taubck(i,:) = tau_et*0.001*flat_gw*cw + ! efficiency function + desc%effbck(i) = eff_tr*cos(lats(i))**2 + & + eff_et*sin(lats(i))**2 endif - desc%taubck(i,:) = tau_et*0.001*flat_gw*cw - ! efficiency function - desc%effbck(i) = eff_tr*cos(lats(i))**2 + & - eff_et*sin(lats(i))**2 enddo deallocate( cw, cw4 ) end if @@ -205,7 +211,7 @@ end subroutine gw_beres_init !------------------------------------ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & netdt, zm, src_level, tend_level, tau, ubm, ubi, xv, yv, & - c, hdepth, maxq0, lats, dqcdt) + c, hdepth, maxq0, dqcdt, speed) !----------------------------------------------------------------------- ! Driver for multiple gravity wave drag parameterization. ! @@ -239,8 +245,6 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & real, intent(in) :: netdt(:,:) ! Midpoint altitudes. real, intent(in) :: zm(ncol,pver) - ! latitudes. - real, intent(in) :: lats(ncol) ! Indices of top gravity wave source level and lowest level where wind ! tendencies are allowed. @@ -260,8 +264,9 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Heating depth [m] and maximum heating in each column. real, intent(out) :: hdepth(ncol), maxq0(ncol) - ! Condensate tendency due to large-scale (kg kg-1 s-1) + ! Frontal and Jet proxy inputs real, intent(in) :: dqcdt(ncol,pver) ! Condensate tendency due to large-scale (kg kg-1 s-1) + real, intent(in) :: speed(ncol) ! Katabatic proxy: Max wind speed in lowest 300m stable layer (m s-1) !---------------------------Local Storage------------------------------- ! Column and level indices. @@ -272,6 +277,7 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & ! Maximum heating rate. real(GW_PRC) :: q0(ncol) + real(GW_PRC) :: moist_mult, dry_mult, phys_mult ! Bottom/top heating range index. integer :: boti(ncol), topi(ncol) @@ -472,31 +478,45 @@ subroutine gw_beres_src(ncol, pver, band, desc, pint, u, v, & else tau(i,:,:) = 0.0 - if (.not. desc%et_bkg_dqcdt_forcing) then - ! use latitudinal dependence - ! include forced background stress in extra tropical large-scale systems - ! Set the phase speeds and wave numbers in the direction of the source wind. - ! Set the source stress magnitude (positive only, note that the sign of the - ! stress is the same as (c-u). - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) + if (desc%et_bkg_dqcdt_forcing .or. desc%et_bkg_speed_forcing) then + ! ----------------------------------------------------------------- + ! Frontal Detection via Combined Physical Proxies + ! 1. DQCDT_LS captures the wet, lifting cores of the storm tracks. + ! 2. SPEED captures dry katabatic winds and broad, windy storm flanks. + ! ----------------------------------------------------------------- + ! Proxy 1: The Moist Condensate (Precipitation) + if (desc%et_bkg_dqcdt_forcing) then + q0(i) = 0.0 + do k = desc%k(i), 1, -1 + if (dqcdt(i,k) > q0(i)) q0(i) = dqcdt(i,k) + end do + ! Scale moist multiplier (using the optimized * 5.e8 factor) + moist_mult = MAX(1.0, MIN(10.0,q0(i) * 5.e8)) + else + moist_mult = 1.0 + endif + ! Proxy 2: The Dry Wind (Katabatic winds) + if (desc%et_bkg_speed_forcing) then + ! A baseline 5 m/s wind yields a 1.0x multiplier (no extra drag). + ! A linear 5 to 25 m/s ramp (1 - 20)x + ! A howling +25 m/s katabatic wind yields 20.0x drag. + dry_mult = MAX(1.0, MIN(20.0,1.0 + (speed(i) - 5.0) * (19.0 / 20.0))) + else + dry_mult = 1.0 + endif + phys_mult = MAX(1.0, moist_mult+dry_mult-1.0) + tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * phys_mult topi(i) = desc%k(i) else - ! Find largest condensate change level, for frontal detection - ! condensate tendencies from microphysics will be negative - q0(i) = 0.0 - do k = desc%k(i), 1, -1 ! tend-level to the surface [avoid convective overlap] - if (dqcdt(i,k) > q0(i)) then ! Find largest positive DQCDT tendency - q0(i) = dqcdt(i,k) - endif - end do + ! use latitudinal dependence ! include forced background stress in extra tropical large-scale systems ! Set the phase speeds and wave numbers in the direction of the source wind. ! Set the source stress magnitude (positive only, note that the sign of the ! stress is the same as (c-u). - tau(i,:,desc%k(i)+1) = desc%taubck(i,:) * MIN(10.0,MAX(1.0,abs(q0(i)/1.e-9))) + tau(i,:,desc%k(i)+1) = desc%taubck(i,:) topi(i) = desc%k(i) endif - + endif enddo @@ -522,8 +542,8 @@ subroutine gw_beres_ifc( band, & ncol, pver, dt, effgw_dp, & u, v, t, pref, pint, delp, rdelp, piln, & zm, zi, nm, ni, rhoi, kvtt, & - netdt,desc,lats, alpha, & - utgw,vtgw,ttgw,flx_heat,dqcdt) + netdt,desc, alpha, & + utgw,vtgw,ttgw,flx_heat,dqcdt,speed) type(BeresSourceDesc), intent(inout) :: desc type(GWBand), intent(in) :: band ! I hate this variable ... it just hides information from view @@ -548,7 +568,6 @@ subroutine gw_beres_ifc( band, & real, intent(in) :: rhoi(ncol,pver+1) ! Interface density (kg m-3). real, intent(in) :: kvtt(ncol,pver+1) ! Molecular thermal diffusivity. - real, intent(in) :: lats(ncol) ! latitudes real, intent(in) :: alpha(:) real, intent(out) :: utgw(ncol,pver) ! zonal wind tendency @@ -557,6 +576,7 @@ subroutine gw_beres_ifc( band, & real, intent(inout) :: flx_heat(ncol) ! Energy change real, intent(in) :: dqcdt(ncol,pver) ! Condensate tendency due to large-scale (kg kg-1 s-1) + real, intent(in) :: speed(ncol) ! max_wind_speed_in_stable_cold_surface_layer_to_300m (m s-1) !---------------------------Local storage------------------------------- @@ -615,7 +635,8 @@ subroutine gw_beres_ifc( band, & ! Determine wave sources for Beres deep scheme call gw_beres_src(ncol, pver, band, desc, pint, & u, v, netdt, zm, src_level, tend_level, tau, & - ubm, ubi, xv, yv, c, hdepth, maxq0, lats, dqcdt=dqcdt) + ubm, ubi, xv, yv, c, hdepth, maxq0, & + dqcdt=dqcdt, speed=speed) ! Solve for the drag profile with convective sources. call gw_drag_prof(ncol, pver, band, pint, delp, rdelp, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 index 49e8f050e1..6c10e00e24 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSgwd_GridComp/ncar_gwd/gw_drag.F90 @@ -58,7 +58,7 @@ module gw_drag_ncar subroutine gw_intr_ncar(pcols, pver, dt, nrdg, & beres_dc_desc, beres_band, oro_band, rdg_band, & pint_dev, t_dev, u_dev, v_dev, & - ht_dc_dev, dqcdt_dev, & + ht_dc_dev, dqcdt_dev, speed_dev, & sgh_dev, mxdis_dev, hwdth_dev, clngt_dev, angll_dev, & anixy_dev, gbxar_dev, kwvrdg_dev, effrdg_dev, pref_dev, & pmid_dev, pdel_dev, rpdel_dev, lnpint_dev, zm_dev, rlat_dev, & @@ -92,6 +92,7 @@ subroutine gw_intr_ncar(pcols, pver, dt, nrdg, real, intent(in ) :: v_dev(pcols,pver) ! meridional wind at layers real, intent(in ) :: ht_dc_dev(pcols,pver) ! DeepCu heating in layers real, intent(in ) :: dqcdt_dev(pcols,pver) ! Condensate tendencies due to large-scale + real, intent(in ) :: speed_dev(pcols,pver) ! max_wind_speed_in_stable_cold_surface_layer_to_300m real, intent(in ) :: sgh_dev(pcols) ! standard deviation of orography !++jtb 01/25/21 New topo vars real, intent(in ) :: mxdis_dev(pcols,nrdg) ! obstacle/ridge height @@ -211,8 +212,8 @@ subroutine gw_intr_ncar(pcols, pver, dt, nrdg, pdel_dev , rpdel_dev, lnpint_dev, & zm_dev, zi, & nm, ni, rhoi, kvtt, & - ht_dc_dev,beres_dc_desc,rlat_dev, alpha, & - utgw, vtgw, ttgw, flx_heat, dqcdt_dev) + ht_dc_dev,beres_dc_desc, alpha, & + utgw, vtgw, ttgw, flx_heat, dqcdt_dev, speed_dev) dudt_gwd_dev = dudt_gwd_dev + utgw dvdt_gwd_dev = dvdt_gwd_dev + vtgw dtdt_gwd_dev = dtdt_gwd_dev + ttgw diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt index 6e6388f309..47431d0d01 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/CMakeLists.txt @@ -67,7 +67,7 @@ endif () esma_add_library (${this} SRCS ${srcs} - DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base ESMF::ESMF BLAS::BLAS LAPACK::LAPACK TYPE SHARED) + DEPENDENCIES GEOS_Shared GMAO_mpeu MAPL Chem_Shared Chem_Base ESMF::ESMF BLAS::BLAS LAPACK::LAPACK OpenMP::OpenMP_Fortran TYPE SHARED) file (GLOB_RECURSE rc_files CONFIGURE_DEPENDS RELATIVE ${CMAKE_CURRENT_SOURCE_DIR} *.rc *.yaml) foreach ( file ${rc_files} ) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 index 910b4cf72a..3fcf052e1e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/ConvPar_GF2020.F90 @@ -48,7 +48,7 @@ MODULE ConvPar_GF2020 INTEGER :: OUTPUT_SOUND = 0 ! Diagnostic profile output flag LOGICAL :: wrtgrads = .FALSE. - INTEGER :: nrec = 0, ntimes = 0 + INTEGER :: ntimes = 0 REAL :: int_time = 0. !============================================================================= @@ -156,6 +156,15 @@ MODULE ConvPar_GF2020 INTEGER :: whoami_all, JCOL + !============================================================================= + ! OPENMP THREAD-PRIVATE STATE + !============================================================================= + !$OMP THREADPRIVATE( & + !$OMP HEI_DOWN_LAND, HEI_DOWN_OCEAN, HEI_UPDF_LAND, HEI_UPDF_OCEAN, & + !$OMP MIN_EDT_LAND, MIN_EDT_OCEAN, MAX_EDT_LAND, MAX_EDT_OCEAN, & + !$OMP FADJ_MASSFLX, USE_EXCESS, & + !$OMP JCOL ) + CONTAINS SUBROUTINE GF2020_INTERFACE( & @@ -774,7 +783,7 @@ SUBROUTINE GF2020_DRV( & INTEGER, DIMENSION(its:ite) :: kpbli, last_ierr INTEGER :: i, j, k, kr, n, itf, jtf, ktf, ispc, zmax, status, imemory, irun, jlx, kk, kss, plume, ii_plume - REAL :: dp, dq, exner, dtdt, PTEN, PQEN, PAPH, ZRHO, PAHFS, PQHFL, ZKHVFL, PGEOH, fixouts, dt_inv + REAL :: dp, dq, exner, dtdt, PTEN, PQEN, PAPH, ZRHO, PAHFS, PQHFL, ZKHVFL, PGEOH, fixouts, dt_inv, min_dist !=========================================================================== ! 2. INITIALIZATION & SETUP @@ -800,6 +809,41 @@ SUBROUTINE GF2020_DRV( & !=========================================================================== ! 3. MAIN HORIZONTAL (J) LOOP !=========================================================================== + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(jts, jtf, its, itf, kts, ktf, kte, dt, ite, dx2d, & + !$OMP conprr, lightn_dens, Tpert_h, Tpert_v, xland, sfc_press, & + !$OMP temp2m, topt, kpbl, lons, lats, zt, press, temp, rvap, & + !$OMP curr_rvap, u, v, dm, om, buoy_exc, rth_advten, rqvften, & + !$OMP rthblten, rqvblten, rthften, ccn_in, cnvfrc, srftype, & + !$OMP stochastic_sig, col_sat, mp_ice, mp_liq, mp_cf, CNV_Tracers, & + !$OMP flip, sflux_t, sflux_r, ADV_TRIGGER, APPLY_SUB_MP, & + !$OMP USE_TRACER_TRANSP, mtp, nmp, SH_MD_DP, & + !$OMP icumulus_gf, cum_hei_down_land, cum_hei_down_ocean, & + !$OMP cum_hei_updf_land, cum_hei_updf_ocean, cum_min_edt_land, & + !$OMP cum_min_edt_ocean, cum_max_edt_land, cum_max_edt_ocean, & + !$OMP cum_fadj_massflx, cum_use_excess, closure_choice, & + !$OMP cum_entr_rate, cum_cap_maxs, FIX_NEGATIVES, USE_MOMENTUM_TRANSP, & + !$OMP CONVECTION_TRACER, do_this_column, & + !$OMP ierr4d, jmin4d, klcl4d, k224d, kbcon4d, ktop4d, kstabi4d, kstabm4d, & + !$OMP cprr4d, xmb4d, edt4d, pwav4d, sigma4d, pcup5d, entr5d, & + !$OMP up_massentr5d, up_massdetr5d, dd_massentr5d, dd_massdetr5d, & + !$OMP zup5d, zdn5d, prup5d, prdn5d, clwup5d, tup5d, conv_cld_fr5d, & + !$OMP sgs_vvel_5d, AA0, AA1, AA2, AA3, AA1_BL, AA1_CIN, TAU_BL, & + !$OMP TAU_DP, TAU_MD, RTHCUTEN, RVCUTEN, RUCUTEN, RQVCUTEN, RQCCUTEN, & + !$OMP REVSU_GF, PRFIL_GF, SUB_MPQL, SUB_MPQI, SUB_MPCF, RCHEMCUTEN, & + !$OMP RBUOYCUTEN) & + !$OMP PRIVATE(j, i, k, kr, n, ii_plume, plume, ispc, zmax, & + !$OMP pten, pqen, paph, zrho, pahfs, pqhfl, zkhvfl, pgeoh, & + !$OMP ztexec, zqexec, last_ierr, fixout_qv, revsu_gf_2d, & + !$OMP prfil_gf_2d, Tpert_2d, temp_tendqv, outt, outu, outv, & + !$OMP outq, outqc, outnice, outnliq, outbuoy, omeg, outmpqi, & + !$OMP outmpql, outmpcf, out_chem, xlandi, psur, tsur, ter11, & + !$OMP kpbli, xlons, xlats, zo, po, temp_old, qv_old, qv_curr, & + !$OMP rhoi, tkeg, rcpg, us, vs, dm2d, buoy_exc2d, temp_new_ADV, & + !$OMP qv_new_ADV, mpqi, mpql, mpcf, se_chem, pbl, h_sfc_flux, & + !$OMP le_sfc_flux, zws, TAU_, temp_new, qv_new, dhdt, & + !$OMP temp_new_BL, qv_new_BL, min_dist, distance, fixouts, cum_ztexec, & + !$OMP cum_zqexec) DO j = jts, jtf JCOL = j @@ -1067,12 +1111,21 @@ SUBROUTINE GF2020_DRV( & if (FIX_NEGATIVES) then DO i = its, itf if(do_this_column(i,j) == 0) cycle + + zmax = kts + min_dist = 99999.0 + do k = kts, ktf temp_tendqv(i,k) = outq(i,k,shal) + outq(i,k,deep) + outq(i,k,mid) distance(k) = qv_curr(i,k) + temp_tendqv(i,k) * dt + + if (distance(k) < min_dist) then + min_dist = distance(k) + zmax = k + end if enddo - if(minval(distance(kts:ktf)) < 0.0) then - zmax = MINLOC(distance(kts:ktf), 1) + + if(min_dist < 0.0) then if(abs(temp_tendqv(i,zmax) * dt) < mintracer) then fixout_qv(i) = 0.999999 else @@ -1334,9 +1387,9 @@ SUBROUTINE CUP_gf( & lambau_dn(:) = lambau_shdn CASE('mid') - z_cloud_top_min = 2500. ! Mid-level cloud - z_cloud_top_max = 5500. ! Capped below upper troposphere - depth_min = 1200. ! Noticeable mid-layer depth + z_cloud_top_min = 2000. ! Mid-level cloud + z_cloud_top_max = 6500. ! Capped below upper troposphere + depth_min = 1000. ! Noticeable mid-layer depth zkbmax = 5000. ! Elevated origin (above cold pools/PBL) zcutdown = 4000. ! Lower mid-levels z_detr = 1000. ! Evaporates in deep sub-cloud layer @@ -1695,7 +1748,8 @@ SUBROUTINE CUP_gf( & cd(i,k) = 0.75e-4 * (1.6 - frh) else ! --- RH dependence --- - rh_fac = max(0.5, min(1.1, 1.15 - 0.7*frh)) + ! Increase lateral mixing to reduce precipitation efficiency and moisten + rh_fac = max(0.5, min(1.3, 1.3 - 0.7*frh)) ! --- vertical scaling --- if (k >= klcl(i)) then z_fac = (qeso_cup(i,k) / qeso_cup(i,klcl(i)))**2.0 @@ -1705,11 +1759,12 @@ SUBROUTINE CUP_gf( & entr_rate(i,k) = entr_rate(i,k) * rh_fac endif entr_rate(i,k) = max(entr_rate(i,k), min_entr_rate) - SELECT CASE(trim(cumulus)) - CASE('deep'); cd(i,k) = 0.10 * entr_rate(i,k) - CASE('mid'); cd(i,k) = 0.50 * entr_rate(i,k) - CASE('shallow'); cd(i,k) = 0.75 * entr_rate(i,k) - END SELECT + ! --- Dynamic Updraft Detrainment (Physically driven by RH) --- + ! Uses incoming cd(i,k) [which is entr_rate_plume] and scales it + ! to shed more water into the environment to moisten the column + ! Drier air (frh -> 0) increases detrainment. + ! Moist air (frh -> 1) decreases detrainment. + cd(i,k) = cd(i,k) * (2.0 - frh) endif enddo ENDDO @@ -1725,29 +1780,22 @@ SUBROUTINE CUP_gf( & use_excess, zqexec, ztexec, x_add_buoy, xland, cnvfrc, itf, ktf, its, ite, kts, kte) !- Setup initial Downdraft Profile Parameters - if (ZERO_DIFF_ENTR == 1) then + if (ZERO_DIFF_ENTR == 1) then mentrd_rate = entr_rate_plume cdd = mentrd_rate sigd(:) = MERGE(1.0, 0.0, DOWNDRAFT) else - !- Scale-aware downdraft switch (matches updraft scaling perfectly) + !- Dynamically scale downdraft mixing using resolution awareness (sig) + ! At coarse resolutions (sig ~ 1), it mixes normally (multiplier ~1.0). + ! At fine resolutions (sig -> 0), the downdraft core is protected (multiplier drops to 0.5). + DO k = kts, kte + DO i = its, itf + if(ierr(i) /= 0) cycle + mentrd_rate(i,k) = entr_rate_plume * max(0.5, sig(i)) + cdd(i,k) = mentrd_rate(i,k) + ENDDO + ENDDO sigd(:) = MERGE(sig(:), 0.0, DOWNDRAFT) - !- Physically-based downdraft lateral mixing (Entrainment/Detrainment) - SELECT CASE(trim(cumulus)) - CASE('deep') - ! Restrict lateral mixing so the downdraft preserves its cold, - ! heavy core and transports moisture/mass forcefully into the lower levels - mentrd_rate = entr_rate_plume * 0.3 ! <--- DECREASED FROM 1.0 - CASE('mid') - ! Optionally reduce this too, or leave at 1.0 if you want mid-level - ! convection to remain leaky - mentrd_rate = entr_rate_plume * 0.5 - CASE('shallow') - mentrd_rate = entr_rate_plume * 0.3 - CASE DEFAULT - mentrd_rate = entr_rate_plume * 0.3 - END SELECT - cdd = mentrd_rate endif !- Update Source Parcels @@ -1871,10 +1919,10 @@ SUBROUTINE CUP_gf( & denom = (zu(i,k-1) - 0.5 * up_massdetro(i,k-1) + up_massentro(i,k-1)) if(denom > 0.0) then hco(i,k) = (hco(i,k-1) * zuo(i,k-1) - 0.5 * up_massdetro(i,k-1) * hco(i,k-1) + up_massentro(i,k-1) * heo(i,k-1)) / denom - if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then - x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) - hco(i,k)= hco(i,k) + x_add*up_massentro(i,k-1)/denom - endif + !if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then + ! x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) + ! hco(i,k)= hco(i,k) + x_add*up_massentro(i,k-1)/denom + !endif else hco(i,k) = hco(i,k-1) endif @@ -1939,12 +1987,11 @@ SUBROUTINE CUP_gf( & if(denom > 0.0 .and. denomU > 0.0) then hc(i,k) = (hc(i,k-1) * zu(i,k-1) - 0.5 * up_massdetr(i,k-1) * hc(i,k-1) + up_massentr(i,k-1) * he(i,k-1)) / denom hco(i,k) = (hco(i,k-1) * zuo(i,k-1) - 0.5 * up_massdetro(i,k-1) * hco(i,k-1) + up_massentro(i,k-1) * heo(i,k-1)) / denom - - if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then - x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) - hco(i,k)= hco(i,k) + x_add*up_massentro(i,k-1)/denom - hc (i,k)= hc (i,k) + x_add*up_massentr (i,k-1)/denom - endif + !if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then + ! x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) + ! hco(i,k)= hco(i,k) + x_add*up_massentro(i,k-1)/denom + ! hc (i,k)= hc (i,k) + x_add*up_massentr (i,k-1)/denom + !endif uc(i,k) = (uc(i,k-1) * zu(i,k-1) - 0.5 * up_massdetru(i,k-1) * uc(i,k-1) + up_massentru(i,k-1) * us(i,k-1) & - pgcon * 0.5 * (zu(i,k) + zu(i,k-1)) * (u_cup(i,k) - u_cup(i,k-1))) / denomU @@ -2143,6 +2190,7 @@ SUBROUTINE CUP_gf( & T_star = MERGE(5.0, 40.0, trim(cumulus) == 'deep') IF(SGS_W_TIMESCALE == 0.0) THEN + ! Option 1: Legacy / Default Method (Bechtold dx scaling) DO i = its, itf if(ierr(i) /= 0) cycle if(xland(i) > 0.99) then @@ -2158,17 +2206,37 @@ SUBROUTINE CUP_gf( & tau_ecmwf(i) = tau_ecmwf(i) * (1. + 1.66 * (dx(i) / 125000.)) ENDDO ELSE + ! Option 2: Dynamic / w_eff Method (Fixed logic, uses GF sig(i) scaling) DO i = its, itf if(ierr(i) /= 0) cycle + + ! 1. Boundary Layer Timescale Calculation umean = (1.0 - xland(i)) * 2.0 + xland(i) * (1.0 + sqrt(0.5 * (US(i,1)**2 + VS(i,1)**2 + US(i,kbcon(i))**2 + VS(i,kbcon(i))**2))) tau_bl(i) = max(1800.0, min(max(zo_cup(i,kbcon(i)) - z1(i), 1.0) / umean, 7200.0)) + ! 2. Dynamic ECMWF Timescale Calculation with GF sig(i) scale-awareness dz = max(zo_cup(i,ktop(i)) - zo_cup(i,kbcon(i)), 1.e-16) w_eff = min(max(vvel1d(i), 0.3), 4.0) tau_ecmwf(i) = (dz / w_eff) * (1.0 + sig(i)) * SGS_W_TIMESCALE - if(trim(cumulus) == 'deep') tau_ecmwf(i) = min(tau_deep, max(7200.0, max(tau_ecmwf(i), dtime))) - if(trim(cumulus) == 'mid') tau_ecmwf(i) = min(tau_mid , max(3600.0, max(tau_ecmwf(i), dtime))) - tau_ecmwf(i) = max(tau_ecmwf(i), tau_bl(i)) + + ! 3. Fix Min/Max Bounding Logic + ! Prevents hardcoding to tau_deep by keeping it between timestep and tau_deep + if(trim(cumulus) == 'deep') then + tau_ecmwf(i) = min(tau_deep, max(dtime, tau_ecmwf(i))) + elseif(trim(cumulus) == 'mid') then + tau_ecmwf(i) = min(tau_mid , max(dtime, tau_ecmwf(i))) + endif + + ! 4. Safely apply tau_bl as a lower limit without overriding tau_deep/tau_mid + ! Prevents a sluggish boundary layer wind from accidentally dragging the timescale to 7200s + if(trim(cumulus) == 'deep') then + tau_ecmwf(i) = max(tau_ecmwf(i), min(tau_bl(i), tau_deep)) + elseif(trim(cumulus) == 'mid') then + tau_ecmwf(i) = max(tau_ecmwf(i), min(tau_bl(i), tau_mid)) + else + tau_ecmwf(i) = max(tau_ecmwf(i), tau_bl(i)) + endif + ENDDO ENDIF @@ -2710,10 +2778,10 @@ SUBROUTINE CUP_gf( & xhc(i,k) = xhc(i,k-1) else xhc(i,k) = (xhc(i,k-1) * xzu(i,k-1) - .5 * up_massdetro(i,k-1) * xhc(i,k-1) + up_massentro(i,k-1) * xhe(i,k-1)) / denom - if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then - x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) - xhc(i,k)= xhc(i,k) + x_add*up_massentro(i,k-1)/denom - endif + !if ( (ZERO_DIFF_ENTR /= 1) .AND. (k == start_level(i) + 1) ) then + ! x_add = (xlv*zqexec(i)+cp*ztexec(i)) + x_add_buoy(i) + ! xhc(i,k)= xhc(i,k) + x_add*up_massentro(i,k-1)/denom + !endif endif xhc(i,k) = xhc(i,k) + xlf * (1. - p_liq_ice(i,k)) * qrco(i,k) enddo @@ -5019,7 +5087,7 @@ SUBROUTINE get_zu_zd_pdf(cumulus, draft,ierr,kb,kt,zu,kts,kte,ktf,kpbli,k22,kbco real , intent(inout) :: zu(kts:kte) character*(*), intent(in) ::draft,cumulus !- local var - integer :: kk,add,i,nrec=0,k,kb_adj,kpbli_adj,level_max_zu,ktarget + integer :: kk,add,i,k,kb_adj,kpbli_adj,level_max_zu,ktarget real :: zumax,ztop_adj,a2,beta, alpha,kratio,tunning,FZU,krmax,dzudk,hei_updf,hei_down real :: zuh(kts:kte),zul(kts:kte), pmaxzu ! pressure height of max zu for deep real, parameter :: px =45./120. ! px sets the pressure level of max zu. its range is from 1 to 120. @@ -5569,7 +5637,7 @@ SUBROUTINE get_zu_zd_pdf_orig(draft,ierr,kb,kt,zs,zuf,ztop,zu,kts,kte,ktf) character*(*), intent(in) ::draft !- local var - integer :: add,i,nrec=0,k,kb_adj + integer :: add,i,k,kb_adj real ::zumax,ztop_adj real ::beta, alpha,kratio,tunning @@ -5672,14 +5740,6 @@ SUBROUTINE get_zu_zd_pdf_orig(draft,ierr,kb,kt,zs,zuf,ztop,zu,kts,kte,ktf) return -!OPEN(19,FILE= 'zu.gra', FORM='unformatted',ACCESS='direct'& -! ,STATUS='unknown',RECL=4) -! DO k = kts,kte -! nrec=nrec+1 -! WRITE(19,REC=nrec) zu(k) -! END DO -!close (19) - END SUBROUTINE get_zu_zd_pdf_orig !------------------------------------------------------------------------------------ SUBROUTINE cup_up_cape(aa0,z,zu,dby,GAMMA_CUP,t_cup, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 index d6c2d1f670..ddd2961e73 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_BACM_1M_InterfaceMod.F90 @@ -15,6 +15,8 @@ module GEOS_BACM_1M_InterfaceMod use GEOS_UtilsMod use GEOSmoist_Process_Library use CLOUDNEW, only: CLDPARAMS, PROGNO_CLOUD + use aer_cloud + use Aer_Actv_Single_Moment implicit none @@ -269,6 +271,20 @@ subroutine BACM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=JASON_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, NN_MIN_ICE, 'NN_MIN_ICE:', DEFAULT= 100.0e6, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, NN_MAX_ICE, 'NN_MAX_ICE:', DEFAULT= 500.0e6, RC=STATUS); VERIFY_(STATUS) + + if (USE_AEROSOL_NN) then + ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there + call aer_cloud_init(use_wnet = .false.) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") + endif + end subroutine BACM_1M_Initialize diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 index 6504faf30c..4d5b01ac0d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GFDL_1M_InterfaceMod.F90 @@ -15,7 +15,7 @@ module GEOS_GFDL_1M_InterfaceMod use GEOS_UtilsMod use GEOS_RadarMod use GEOSmoist_Process_Library - use Aer_Actv_Single_Moment + use aer_cloud use gfdl2_cloud_microphys_mod, only : gfdl_cloud_microphys_init, gfdl_cloud_microphys_driver, ICE_LSC_VFALL_PARAM, ICE_CNV_VFALL_PARAM use gfdl_mp_mod, only : gfdl_mp_init, gfdl_mp_driver, do_ref, do_hail, do_sedi_heat, do_sedi_melt_qi, do_sedi_melt_qs, do_sedi_melt_qg, ifflag @@ -48,7 +48,6 @@ module GEOS_GFDL_1M_InterfaceMod real :: MIN_RH_CRIT, MAX_RH_CRIT, MIN_RH_UNSTABLE, MIN_RH_STABLE real :: TAU_EVAP, CCW_EVAP_EFF real :: TAU_SUBL, CCI_EVAP_EFF - integer :: PDFSHAPE real :: ANV_ICEFALL real :: LS_ICEFALL real :: FAC_RL @@ -63,15 +62,6 @@ module GEOS_GFDL_1M_InterfaceMod logical :: LMELTFRZ_CLDMICRO real :: GFDL_MP_KLID - - logical :: LIQUID_SKIN_SNOW - logical :: LIQUID_SKIN_GRAUPEL - logical :: LIQUID_SKIN_HAIL - - real, PARAMETER :: W_START = 6.0 - real, PARAMETER :: W_FULL = 12.0 - real :: fraction_hail - logical :: REPORT_GFDL_1M_NEGATIVES logical :: GFDL_MP3 @@ -223,19 +213,19 @@ subroutine GFDL_1M_Setup (GC, CF, RC) call MAPL_AddExportSpec(GC, & SHORT_NAME = 'REF_DBZ', & LONG_NAME = 'Simulated_gfdl_radar_reflectivity', & - UNITS = 'dBZ', & + UNITS = 'dBZ', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - + VERIFY_(STATUS) + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'REF_DBZ_MAX', & LONG_NAME = 'Maximum_composite_gfdl_radar_reflectivity', & - UNITS = 'dBZ', & + UNITS = 'dBZ', & DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) + VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'REF_DBZ_1KM', & LONG_NAME = 'Base_1KM_AGL_gfdl_radar_reflectivity', & @@ -260,7 +250,7 @@ subroutine GFDL_1M_Setup (GC, CF, RC) VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_TimerAdd(GC, name="--GFDL_1M", RC=STATUS) + call MAPL_TimerAdd(GC, name="--GFDL_1M",RC=STATUS); VERIFY_(STATUS) VERIFY_(STATUS) end subroutine GFDL_1M_Setup @@ -285,30 +275,11 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) CHARACTER(len=ESMF_MAXSTR) :: errmsg - real :: DBZ_DT - type(ESMF_Calendar) :: calendar - type(ESMF_Time) :: currTime - type(ESMF_Alarm) :: DBZ_RunAlarm - type(ESMF_TimeInterval) :: ringInterval - integer :: LM, year, month, day, hh, mm, ss - - call MAPL_Get(MAPL, LM=LM, RUNALARM=ALARM, RC=STATUS );VERIFY_(STATUS) + call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS );VERIFY_(STATUS) call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) DT_MOIST = DT_R8 - DBZ_DT = max(DT_MOIST,900.0) - call MAPL_GetResource(MAPL, DBZ_DT, 'DBZ_DT:', default=DBZ_DT, RC=STATUS); VERIFY_(STATUS) - ! Get the current time in addition to the calendar - call ESMF_ClockGet(CLOCK, currTime=currTime, calendar=calendar, RC=STATUS); VERIFY_(STATUS) - call ESMF_TimeIntervalSet(ringInterval, S=nint(DBZ_DT), calendar=calendar, RC=STATUS); VERIFY_(STATUS) - ! Add RingTime = currTime to anchor the alarm - DBZ_RunAlarm = ESMF_AlarmCreate(Clock = CLOCK, & - Name = 'DBZ_RunAlarm', & - RingTime = currTime, & - RingInterval = ringInterval, & - Sticky = .false. , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LPHYS_HYDROSTATIC, Label="PHYS_HYDROSTATIC:", default=.TRUE., RC=STATUS) VERIFY_(STATUS) LHYDROSTATIC = LPHYS_HYDROSTATIC @@ -332,18 +303,17 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource(MAPL, REPORT_GFDL_1M_NEGATIVES, 'REPORT_GFDL_1M_NEGATIVES:', default=.FALSE., RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource( MAPL, GFDL_MP3, Label="GFDL_MP3:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (DT_R8 <= 150.0) do_hail = .true. + if (DT_R8 <= 150.0) do_hail = .true. if (DT_R8 <= 150.0) do_sedi_heat = .true. if (DT_R8 <= 150.0) do_sedi_melt_qi = .true. if (DT_R8 <= 150.0) do_sedi_melt_qs = .true. if (DT_R8 <= 150.0) do_sedi_melt_qg = .true. - if (DT_R8 <= 150.0) ifflag = 1 if (GFDL_MP3) then call gfdl_mp_init(LHYDROSTATIC,DT_MOIST) call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_mp v3 in non-generic GC INIT") call MAPL_GetResource( MAPL, do_ref, Label="DO_GFDL_REFLECTIVITY:", default=.TRUE., RC=STATUS); VERIFY_(STATUS) - else + else call gfdl_cloud_microphys_init() call WRITE_PARALLEL ("INITIALIZED GFDL_1M gfdl_cloud_microphys in non-generic GC INIT") do_ref = .false. ! Force to false so MAPL DBZ Calc triggers, as older driver has no DBZ3D @@ -353,21 +323,6 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource( MAPL, SH_MD_DP , 'SH_MD_DP:' , DEFAULT= .TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, DBZ_VAR_INTERCP , 'DBZ_VAR_INTERCP:' , DEFAULT= DBZ_VAR_INTERCP, RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetResource( MAPL, LIQUID_SKIN_SNOW , 'LIQUID_SKIN_SNOW:' , DEFAULT= .FALSE. , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LIQUID_SKIN_GRAUPEL , 'LIQUID_SKIN_GRAUPEL:' , DEFAULT= .FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, LIQUID_SKIN_HAIL , 'LIQUID_SKIN_HAIL:' , DEFAULT= .TRUE. , RC=STATUS); VERIFY_(STATUS) - - refl10cm_allow_wet_graupel = .false. - call MAPL_GetResource( MAPL, refl10cm_allow_wet_graupel , 'refl10cm_allow_wet_graupel:' , & - DEFAULT= refl10cm_allow_wet_graupel, RC=STATUS); VERIFY_(STATUS) - refl10cm_allow_wet_snow = .false. - call MAPL_GetResource( MAPL, refl10cm_allow_wet_snow , 'refl10cm_allow_wet_snow:' , & - DEFAULT= refl10cm_allow_wet_snow, RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetResource( MAPL, constrain_modis_ice, 'constrain_modis_ice:', DEFAULT= .FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, TURNRHCRIT_PARAM, 'TURNRHCRIT:' , DEFAULT= -9999., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RH_CRIT , 'MAX_RH_CRIT:' , DEFAULT= 1.0000, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MIN_RH_UNSTABLE , 'MIN_RH_UNSTABLE:' , DEFAULT= 0.9750, RC=STATUS); VERIFY_(STATUS) @@ -386,9 +341,6 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource( MAPL, MIN_RL , 'MIN_RL:' , DEFAULT= 2.5e-6, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, MAX_RL , 'MAX_RL:' , DEFAULT=60.0e-6, RC=STATUS); VERIFY_(STATUS) - ! USE_BERGERON should be .TRUE. only when USE_AEROSOL_NN is also .TRUE. - call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) - CCW_EVAP_EFF = 4.e-3 call MAPL_GetResource( MAPL, CCW_EVAP_EFF, 'CCW_EVAP_EFF:', DEFAULT= CCW_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) @@ -396,12 +348,20 @@ subroutine GFDL_1M_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource( MAPL, CCI_EVAP_EFF, 'CCI_EVAP_EFF:', DEFAULT= CCI_EVAP_EFF, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 3000.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 2.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 2500.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, GFDL_MP_KLID , 'GFDL_MP_KLID:' , DEFAULT= -999.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=V12_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) - call init_refl10cm() + if (USE_AEROSOL_NN) then + ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there + call aer_cloud_init(use_wnet = .false.) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") + endif + + call MAPL_GetResource( MAPL, GFDL_MP_KLID , 'GFDL_MP_KLID:' , DEFAULT= -999.0, RC=STATUS); VERIFY_(STATUS) end subroutine GFDL_1M_Initialize @@ -438,7 +398,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: PLmb, ZL0 real, allocatable, dimension(:,:,:) :: DZ, DZET, DP, MASS, iMASS real, allocatable, dimension(:,:,:) :: DQST3, QST3 - real, allocatable, dimension(:,:,:) :: DBZ3D, TMP_NACTR + real, allocatable, dimension(:,:,:) :: DBZ3D real, allocatable, dimension(:,:,:) :: DQVDTmic, DQLDTmic, DQRDTmic, DQIDTmic, & DQSDTmic, DQGDTmic, DQADTmic, & DUDTmic, DVDTmic, DTDTmic, DWDTmic @@ -467,7 +427,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PFR_LS, PFS_LS, PFG_LS real, pointer, dimension(:,:,:) :: PDFITERS real, pointer, dimension(:,:,:) :: RHCRIT3D - real, pointer, dimension(:,:,:) :: CNV_PRC3 + real, pointer, dimension(:,:,:) :: CNV_PRC3 real, pointer, dimension(:,:) :: EIS, LTS real, pointer, dimension(:,:) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:,:) :: DBZ @@ -505,7 +465,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) VERIFY_(STATUS) - call MAPL_TimerOn (MAPL,"--GFDL_1M",RC=STATUS) + call MAPL_TimerOn (MAPL,"--GFDL_1M",RC=STATUS); VERIFY_(STATUS) ! Get parameters from generic state. !----------------------------------- @@ -596,11 +556,11 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( DUDTmic(IM,JM,LM ) ) ALLOCATE ( DVDTmic(IM,JM,LM ) ) ALLOCATE ( DTDTmic(IM,JM,LM ) ) - ALLOCATE ( DWDTmic(IM,JM,LM ) ) + ALLOCATE ( DWDTmic(IM,JM,LM ) ) ! 2D Variables ALLOCATE ( TMP2D (IM,JM) ) ! 1D Variables - ALLOCATE ( TMP1D ( LM ) ) + ALLOCATE ( TMP1D ( LM ) ) ! Initialize to clear DBZ DBZ3D = -30.0 @@ -693,7 +653,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ( QICN(I,J,L) < 0.0 ) .OR. ( QICN(I,J,L) /= QICN(I,J,L)) .OR. & ( QRAIN(I,J,L) < 0.0 ) .OR. ( QRAIN(I,J,L) /= QRAIN(I,J,L)) .OR. & ( QSNOW(I,J,L) < 0.0 ) .OR. ( QSNOW(I,J,L) /= QSNOW(I,J,L)) .OR. & - (QGRAUPEL(I,J,L) < 0.0 ) .OR. (QGRAUPEL(I,J,L) /= QGRAUPEL(I,J,L)) ) then + (QGRAUPEL(I,J,L) < 0.0 ) .OR. (QGRAUPEL(I,J,L) /= QGRAUPEL(I,J,L)) ) then print *, "T or Q spike detected : ", T(I,J,L) print *, " On Entry to GFDL : " print *, " Latitude =", LATS(I,J)*180.0/MAPL_PI @@ -709,7 +669,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) end do endif - call MAPL_TimerOn(MAPL,"---CLDMACRO") + call MAPL_TimerOn(MAPL,"---CLDMACRO",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQVDT_macro, 'DQVDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDT_macro, 'DQIDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLDT_macro, 'DQLDT_macro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -763,9 +723,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo endif - + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) then + if (associated(PTR3D)) then !$OMP parallel do default(none) & !$OMP shared(LM, JM, IM, QSNOW, PTR3D, DT_MOIST) & !$OMP private(I, J, L) @@ -804,7 +764,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! evap/subl/pdf call MAPL_GetPointer(EXPORT, RHCRIT3D, 'RHCRIT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - + !$OMP parallel do default(none) & !$OMP shared(LM, JM, IM, Q, T, QLLS, QILS, CLLS, QLCN, QICN, CLCN, KLID, & !$OMP facEIS_2d, minrhcrit_2d, turnrhcrit_2d, MAX_RH_CRIT, PLmb, PLEmb, & @@ -820,15 +780,15 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & REMOVE_CLOUDS=(L < KLID) ) - + ! Use Slingo-Ritter (1985) formulation for critical relative humidity ! Ensure the max is never lower than the min safe_max_rh_crit = MAX(MAX_RH_CRIT, minrhcrit_2d(I,J)) - if (PLmb(i,j,l) .le. turnrhcrit_2d(I,J)) then + if (PLmb(i,j,l) .le. turnrhcrit_2d(I,J)) then MIN_RH_CRIT = minrhcrit_2d(I,J) else if (L .eq. LM) then MIN_RH_CRIT = safe_max_rh_crit - else + else x_norm = (PLmb(i,j,l) - turnrhcrit_2d(I,J)) / (PLEmb(i,j,LM) - turnrhcrit_2d(I,J)) ! Cubic smoothstep S-curve: x^2 * (3 - 2x) MIN_RH_CRIT = minrhcrit_2d(I,J) + (safe_max_rh_crit - minrhcrit_2d(I,J)) * & @@ -837,7 +797,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) ! ----------------------------------------------------------------- ! Scale-Aware Blending for RHCRIT ! ----------------------------------------------------------------- - RHCRIT = MAX_RH_CRIT + (MIN_RH_CRIT-MAX_RH_CRIT)*SQRT(SQRT(AREA(I,J)/1.e10)) + RHCRIT = MAX_RH_CRIT + (MIN_RH_CRIT-MAX_RH_CRIT)*SQRT(SQRT(AREA(I,J)/1.e10)) ! limit ALPHA to < 30% ALPHA = max(0.0,min(0.30, (1.0-RHCRIT))) ! fill RHCRIT export @@ -882,7 +842,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) if (LMELTFRZ_CLDMACRO) then ! meltfrz new condensates call MELTFRZ ( DT_MOIST , & - CNV_FRC(I,J) , & + 1.0 , & ! since we are explicitly operating on CN types pass CNV_FRC always as 1.0 SRF_TYPE(I,J), & T(I,J,L) , & QLCN(I,J,L) , & @@ -927,7 +887,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif ! cleanup clouds after cldmacro call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & - QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & + QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), & REMOVE_CLOUDS=(L < KLID) ) end do ! IM loop end do ! JM loop @@ -937,7 +897,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) deallocate(facEIS_2d, minrhcrit_2d, turnrhcrit_2d) ! Get fill negative export pointers if requested -! ---------------------------------------------- +! ---------------------------------------------- call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_CLDMACRO', RC=STATUS); VERIFY_(STATUS) @@ -953,9 +913,9 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call FILLQ2ZERO( QLCN , MASS, DT=DT_MOIST, DQDT=DQLCNDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) call FILLQ2ZERO( QILS , MASS, DT=DT_MOIST, DQDT=DQILSDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) call FILLQ2ZERO( QICN , MASS, DT=DT_MOIST, DQDT=DQICNDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQRDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQSDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) - call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQGDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QRAIN , MASS, DT=DT_MOIST, DQDT= DQRDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QSNOW , MASS, DT=DT_MOIST, DQDT= DQSDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) + call FILLQ2ZERO( QGRAUPEL, MASS, DT=DT_MOIST, DQDT= DQGDT_FILL, VM=VMG, RC=STATUS); VERIFY_(STATUS) ! Update macrophysics tendencies !$OMP parallel do default(none) & @@ -980,7 +940,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo enddo - call MAPL_TimerOff(MAPL,"---CLDMACRO") + call MAPL_TimerOff(MAPL,"---CLDMACRO",RC=STATUS); VERIFY_(STATUS) if (DEBUG_TQ_ERRORS) then do L = 1, LM @@ -1003,14 +963,14 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) print *, " CLLS=", CLLS(I,J,L), " CLCN=", CLCN(I,J,L) print *, " QV=", Q(I,J,L), " QLLS=", QLLS(I,J,L), " QLCN=", QLCN(I,J,L) print *, " QILS=", QILS(I,J,L), " QICN=", QICN(I,J,L) - print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) + print *, " QR=", QRAIN(I,J,L), " QS=", QSNOW(I,J,L), " QG=", QGRAUPEL(I,J,L) endif enddo enddo enddo endif - call MAPL_TimerOn(MAPL,"---CLDMICRO") + call MAPL_TimerOn(MAPL,"---CLDMICRO",RC=STATUS); VERIFY_(STATUS) ! Zero-out microphysics tendencies call MAPL_GetPointer(EXPORT, DQVDT_micro, 'DQVDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQIDT_micro, 'DQIDT_micro' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -1114,7 +1074,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo if (do_ref) then - call MAPL_TimerOn(MAPL,"---CLD_REF_DBZ") + call MAPL_TimerOn(MAPL,"---CLD_REF_DBZ",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ , 'REF_DBZ' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_MAX , 'REF_DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DBZ_1KM , 'REF_DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) @@ -1129,19 +1089,19 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) endif if (associated(DBZ_1KM)) then call cs_interpolator(1, IM, 1, JM, LM, DBZ3D, 1000., ZLE0, DBZ_1KM, -20.) - endif + endif if (associated(DBZ_TOP)) then DBZ_TOP=MAPL_UNDEF DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 + DO L=LM,1,-1 if (ZLE0(i,j,l) >= 25000.) continue if (DBZ3D(i,j,l) >= 18.5 ) then DBZ_TOP(I,J) = ZLE0(I,J,L) exit - endif + endif END DO END DO ; END DO - endif + endif if (associated(DBZ_M10C)) then DBZ_M10C=MAPL_UNDEF DO J=1,JM ; DO I=1,IM @@ -1154,7 +1114,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) END DO END DO ; END DO endif - call MAPL_TimerOff(MAPL,"---CLD_REF_DBZ") + call MAPL_TimerOff(MAPL,"---CLD_REF_DBZ",RC=STATUS); VERIFY_(STATUS) endif else call gfdl_cloud_microphys_driver( & @@ -1236,7 +1196,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo ! Get fill negative export pointers if requested - ! ---------------------------------------------- + ! ---------------------------------------------- call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLLSDT_FILL, 'DQLLSDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, DQLCNDT_FILL, 'DQLCNDT_FILL_CLDMICRO', RC=STATUS); VERIFY_(STATUS) @@ -1307,14 +1267,14 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) tmp_val = MIN(1.0, MAX(QLCN(I,J,L) / MAX(RAD_QL(I,J,L), 1.E-8), 0.0)) PFL_AN(I,J,L) = (PFL_LS(I,J,L) + PFR_LS(I,J,L)) * tmp_val PFL_LS(I,J,L) = (PFL_LS(I,J,L) + PFR_LS(I,J,L)) - PFL_AN(I,J,L) - + tmp_val = MIN(1.0, MAX(QICN(I,J,L) / MAX(RAD_QI(I,J,L), 1.E-8), 0.0)) PFI_AN(I,J,L) = (PFI_LS(I,J,L) + PFS_LS(I,J,L) + PFG_LS(I,J,L)) * tmp_val PFI_LS(I,J,L) = (PFI_LS(I,J,L) + PFS_LS(I,J,L) + PFG_LS(I,J,L)) - PFI_AN(I,J,L) ! MeltFreeze and FixUp if (LMELTFRZ_CLDMICRO) then - call MELTFRZ(DT_MOIST, CNV_FRC(I,J), SRF_TYPE(I,J), T(I,J,L), QLCN(I,J,L), QICN(I,J,L)) + call MELTFRZ(DT_MOIST, CNV_FRC(I,J), SRF_TYPE(I,J), T(I,J,L), QLCN(I,J,L), QICN(I,J,L)) call MELTFRZ(DT_MOIST, CNV_FRC(I,J), SRF_TYPE(I,J), T(I,J,L), QLLS(I,J,L), QILS(I,J,L)) call FIX_UP_CLOUDS(Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), & QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L), REMOVE_CLOUDS=(L < KLID)) @@ -1381,7 +1341,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo enddo enddo - call MAPL_TimerOff(MAPL,"---CLDMICRO") + call MAPL_TimerOff(MAPL,"---CLDMICRO",RC=STATUS); VERIFY_(STATUS) if (DEBUG_TQ_ERRORS) then do L = 1, LM @@ -1412,7 +1372,7 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) enddo endif - call MAPL_TimerOn(MAPL,"---CLDDIAGS") + call MAPL_TimerOn(MAPL,"---CLDDIAGS",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR3D, 'DQRL', RC=STATUS); VERIFY_(STATUS) if(associated(PTR3D)) PTR3D = DQRDT_macro + DQRDT_micro @@ -1425,147 +1385,12 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DVDT_macro+DVDT_micro,PTR3D) endif - ! Compute DBZ radar reflectivity - call ESMF_ClockGetAlarm(clock, 'DBZ_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) - alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetPointer(EXPORT, NACTR, 'NACTR', RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, PTR2D, 'REFL10CM_MAX', RC=STATUS); VERIFY_(STATUS) - - ! 1. If the user explicitly requested NACTR export, fill it every time (or whenever needed) - if (associated(NACTR)) then - NACTR = 1.e8 * QRAIN**0.8 - endif - - ! 2. Handle the reflectivity alarm - if (alarm_is_ringing) then - call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) - - ! Only compute if the user actually requested the reflectivity output - if (associated(PTR2D)) then - call MAPL_TimerOn(MAPL,"---CLD_REFL10CM") - rand1 = 0.0 - TMP3D = 0.0 - - ! If NACTR wasn't associated, we still need it for calc_refl10cm! - ! We can use TMP3D to temporarily hold NACTR if needed, or if calc_refl10cm - ! requires it as a distinct array, use a locally allocated TMP_NACTR array. - ! Assuming TMP_NACTR is an allocatable 3D array defined at the top: - - if (.not. associated(NACTR)) then - ! Fill a local temporary array to pass into the subroutine - ALLOCATE ( TMP_NACTR(IM,JM,LM) ) - TMP_NACTR = 1.e8 * QRAIN**0.8 - endif - - DO J=1,JM ; DO I=1,IM - ! Pass either the Export pointer (if associated) or the local temporary array - if (associated(NACTR)) then - call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & - T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) - else - call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), TMP_NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & - T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) - endif - END DO ; END DO - - if (.not. associated(NACTR)) then - DEALLOCATE ( TMP_NACTR ) - endif - - PTR2D = -9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - - call MAPL_TimerOff(MAPL,"---CLD_REFL10CM") - endif - endif - - call MAPL_TimerOn(MAPL,"---CLD_CALCDBZ") - call MAPL_GetPointer(EXPORT, DBZ , 'DBZ' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) - if ( (associated(DBZ) .OR. & - associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) ) then - allocate ( qg_col(LM) ) - allocate ( qh_col(LM) ) - allocate ( prs_col(LM) ) - allocate ( dbz_col(LM) ) - !$OMP parallel do default(none) & - !$OMP shared(IM, JM, LM, W, QGRAUPEL, PLmb, T, Q, QRAIN, QSNOW, & - !$OMP DBZ_VAR_INTERCP, LIQUID_SKIN_SNOW, LIQUID_SKIN_GRAUPEL, LIQUID_SKIN_HAIL, DBZ3D) & - !$OMP private(I, J, L, fraction_hail, qg_col, qh_col, prs_col, dbz_col) - DO J = 1, JM - DO I = 1, IM - ! 1. Prepare the 1D column data for this specific (I,J) location - DO L = 1, LM - ! Calculate a fraction between 0.0 and 1.0 based on updraft W - fraction_hail = MAX(0.0, MIN(1.0, (W(I,J,L) - W_START) / (W_FULL - W_START))) - ! Partition the mass into 1D thread-private columns - qh_col(L) = QGRAUPEL(I,J,L) * fraction_hail - qg_col(L) = QGRAUPEL(I,J,L) * (1.0 - fraction_hail) - ! Pre-multiply pressure for the function - prs_col(L) = 100.0 * PLmb(I,J,L) - END DO - ! 2. Call the newly refactored 1D column function - ! Note: We pass 1D array slices like T(I,J,:) directly. - dbz_col = compute_radar_reflectivity( & - PRS = prs_col, & - TMK = T(I,J,:), & - QVP = Q(I,J,:), & - QRAIN = QRAIN(I,J,:), & - QSNOW = QSNOW(I,J,:), & - QGRAUPEL = qg_col, & - QHAIL = qh_col, & - disable_variable_intercept_params = (DBZ_VAR_INTERCP == 0), & - liqskin_snow = LIQUID_SKIN_SNOW, & - liqskin_graupel = LIQUID_SKIN_GRAUPEL, & - liqskin_hail = LIQUID_SKIN_HAIL) - ! 3. Store the returned column back into the 3D state - DO L = 1, LM - DBZ3D(I,J,L) = dbz_col(L) - END DO - END DO - END DO - end if - if (associated(DBZ)) DBZ = DBZ3D - if (associated(DBZ_MAX)) then - DBZ_MAX=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),DBZ3D(I,J,L)) - END DO ; END DO ; END DO - endif - if (associated(DBZ_1KM)) then - call cs_interpolator(1, IM, 1, JM, LM, DBZ3D, 1000., ZLE0, DBZ_1KM, -20.) - endif - if (associated(DBZ_TOP)) then - DBZ_TOP=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (DBZ3D(i,j,l) >= 18.5 ) then - DBZ_TOP(I,J) = ZLE0(I,J,L) - exit - endif - END DO - END DO ; END DO - endif - if (associated(DBZ_M10C)) then - DBZ_M10C=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (T(i,j,l) <= MAPL_TICE-10.0) then - DBZ_M10C(I,J) = DBZ3D(I,J,L) - exit - endif - END DO - END DO ; END DO - endif - call MAPL_TimerOff(MAPL,"---CLD_CALCDBZ") + ! Call the shared radar diagnostics routine + call MAPL_TimerOn(MAPL,"---RADAR_DIAGS",RC=STATUS); VERIFY_(STATUS) + call compute_radar_diagnostics(EXPORT, CLOCK, IM, JM, LM, & + Q, QRAIN, QSNOW, QGRAUPEL, T, PLmb, W, ZLE0, & + STATUS); VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"---RADAR_DIAGS",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QRAIN @@ -1582,11 +1407,10 @@ subroutine GFDL_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, PTR2D, 'IWP', RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = SUM( ( QICN+QILS+QSNOW+QGRAUPEL ) *MASS , 3 ) - call MAPL_TimerOff(MAPL,"---CLDDIAGS") - + call MAPL_TimerOff(MAPL,"---CLDDIAGS",RC=STATUS); VERIFY_(STATUS) endif ! USE_PYMOIST_GFDL1M - call MAPL_TimerOff(MAPL,"--GFDL_1M",RC=STATUS) + call MAPL_TimerOff(MAPL,"--GFDL_1M",RC=STATUS); VERIFY_(STATUS) end subroutine GFDL_1M_Run diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 index 69f640feea..ca1c45f0e4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_GF_InterfaceMod.F90 @@ -41,7 +41,6 @@ module GEOS_GF_InterfaceMod logical :: FIX_CNV_CLOUD logical :: REPORT_GF_NEGATIVES integer :: ZERO_DIFF_TAU - integer :: ZERO_DIFF_AUTOCONV integer :: ZERO_DIFF_VGRID integer :: ZERO_DIFF_OTHER logical :: USE_PYMOIST_GF2020 @@ -158,7 +157,6 @@ subroutine GF_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource(MAPL, ZERO_DIFF_VVEL , 'ZERO_DIFF_VVEL:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_ENTR , 'ZERO_DIFF_ENTR:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_TAU , 'ZERO_DIFF_TAU:' ,default= 1, RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, ZERO_DIFF_AUTOCONV , 'ZERO_DIFF_AUTOCONV:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_VGRID , 'ZERO_DIFF_VGRID:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_OTHER , 'ZERO_DIFF_OTHER:' ,default= 1, RC=STATUS );VERIFY_(STATUS) else @@ -167,7 +165,6 @@ subroutine GF_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource(MAPL, ZERO_DIFF_VVEL , 'ZERO_DIFF_VVEL:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_ENTR , 'ZERO_DIFF_ENTR:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_TAU , 'ZERO_DIFF_TAU:' ,default= 0, RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, ZERO_DIFF_AUTOCONV , 'ZERO_DIFF_AUTOCONV:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_VGRID , 'ZERO_DIFF_VGRID:' ,default= 0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, ZERO_DIFF_OTHER , 'ZERO_DIFF_OTHER:' ,default= 0, RC=STATUS );VERIFY_(STATUS) endif @@ -192,34 +189,31 @@ subroutine GF_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 6.0e-4,RC=STATUS );VERIFY_(STATUS) else call MAPL_GetResource(MAPL, MIN_ENTR_RATE , 'MIN_ENTR_RATE:' ,default= 0.1e-4,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.0e-4,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, CUM_ENTR_RATE(DEEP) , 'ENTR_DP:' ,default= 1.2e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(MID) , 'ENTR_MD:' ,default= 9.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_ENTR_RATE(SHAL) , 'ENTR_SH:' ,default= 1.0e-3,RC=STATUS );VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, AUTOCONV , 'AUTOCONV:' ,default= 1, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, C0_DEEP , 'C0_DEEP:' ,default= 2.0e-3,RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, C0_MID , 'C0_MID:' ,default= 2.0e-3,RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, C0_MID , 'C0_MID:' ,default= 0.5e-3,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, C0_SHAL , 'C0_SHAL:' ,default= 0.0 ,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, QRC_CRIT_OCN , 'QRC_CRIT_OCN:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, QRC_CRIT_LND , 'QRC_CRIT_LND:' ,default= 2.0e-4,RC=STATUS );VERIFY_(STATUS) - if (INT(ZERO_DIFF_AUTOCONV) == 0) then - ! C1: Explicit cloud condensate detrainment rate [m^-1]. - ! Controls how much suspended liquid/ice is forcibly shed into the grid-scale environment. - ! Default (1.0e-3) favors convective precipitation; increasing (e.g., 2.0e-3 to 3.0e-3) shifts - ! moisture to host microphysics, where evaporation can moisten the 700-300 mb free troposphere. - call MAPL_GetResource(MAPL, C1 , 'C1:' ,default= 3.0e-3,RC=STATUS );VERIFY_(STATUS) - else - call MAPL_GetResource(MAPL, C1 , 'C1:' ,default= 1.0e-3,RC=STATUS );VERIFY_(STATUS) - endif + ! C1: Explicit cloud condensate detrainment rate [m^-1]. + ! Controls how much suspended liquid/ice is forcibly shed into the grid-scale environment. + ! Default (1.0e-3) favors convective precipitation; increasing (e.g., 2.0e-3 to 3.0e-3) shifts + ! moisture to host microphysics, where evaporation can moisten the 700-300 mb free troposphere. + ! Caution: impact may inadvertantly flatten the ITCZ too much + call MAPL_GetResource(MAPL, C1 , 'C1:' ,default= 1.5e-3,RC=STATUS );VERIFY_(STATUS) if (INT(ZERO_DIFF_TAU) == 0) then call MAPL_GetResource(MAPL, GF_MIN_AREA , 'GF_MIN_AREA:' ,default= 0.0, RC=STATUS );VERIFY_(STATUS) SGS_W_TIMESCALE = 1.0 ! factor for adjusting GF2020 timescales call MAPL_GetResource(MAPL, SGS_W_TIMESCALE , 'SGS_W_TIMESCALE:' ,default= SGS_W_TIMESCALE, RC=STATUS );VERIFY_(STATUS) ! These are UPPER bounds for new GF timescales - call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 7200., RC=STATUS );VERIFY_(STATUS) - call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default=10800., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_MID , 'TAU_MID:' ,default= 3600., RC=STATUS );VERIFY_(STATUS) + call MAPL_GetResource(MAPL, TAU_DEEP , 'TAU_DEEP:' ,default= 5400., RC=STATUS );VERIFY_(STATUS) ! FADJ_MASSFLX is a fractional mass flux tuning factor (1.0 is no reduction) in low CAPE environments call MAPL_GetResource(MAPL, CUM_FADJ_MASSFLX(DEEP) , 'FADJ_MASSFLX_DP:' ,default= 1.0, RC=STATUS );VERIFY_(STATUS) call MAPL_GetResource(MAPL, CUM_FADJ_MASSFLX(SHAL) , 'FADJ_MASSFLX_SH:' ,default= 0.5, RC=STATUS );VERIFY_(STATUS) @@ -401,7 +395,8 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) integer :: IM,JM,LM real, pointer, dimension(:,:) :: LONS real, pointer, dimension(:,:) :: LATS - real :: minrhx + real :: minrhx, fqi_local, tmp_local + logical :: ptr_is_assoc ! Internals real, pointer, dimension(:,:,:) :: Q, QLLS, QLCN, CLLS, CLCN, QILS, QICN @@ -572,16 +567,48 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( SEEDCNV(IM,JM) ) ALLOCATE ( TMP2D (IM,JM) ) - ! derived quantaties ! Derived States - PL = 0.5*(PLE(:,:,0:LM-1) + PLE(:,:,1:LM)) - PK = (PL/MAPL_P00)**(MAPL_KAPPA) - DO L=0,LM - ZLE0(:,:,L)= ZLE(:,:,L) - ZLE(:,:,LM) ! Edge Height (m) above the surface - END DO - ZL0 = 0.5*(ZLE0(:,:,0:LM-1) + ZLE0(:,:,1:LM) ) ! Layer Height (m) above the surface - TH = T/PK - MASS = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) )/MAPL_GRAV + !-------------------------------------------------------------- + + ! 1. Top-of-atmosphere edge (L = 0) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, ZLE0, ZLE) & + !$OMP PRIVATE(I, J) + do J = 1, JM + !DIR$ IVDEP + do I = 1, IM + ZLE0(I,J,0) = ZLE(I,J,0) - ZLE(I,J,LM) + end do + end do + !$OMP END PARALLEL DO + + ! 2. Remaining edges and all layer variables (L = 1 to LM) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, ZLE0, ZLE, PL, PLE, PK, & + !$OMP ZL0, TH, T, MASS) & + !$OMP PRIVATE(I, J, L) + do L = 1, LM + do J = 1, JM + !DIR$ IVDEP + do I = 1, IM + + ! Edge variables + ZLE0(I,J,L) = ZLE(I,J,L) - ZLE(I,J,LM) + + ! Layer variables + PL(I,J,L) = 0.5 * (PLE(I,J,L-1) + PLE(I,J,L)) + PK(I,J,L) = (PL(I,J,L) / MAPL_P00)**(MAPL_KAPPA) + + ZL0(I,J,L) = 0.5 * (ZLE0(I,J,L-1) + ZLE0(I,J,L)) + + TH(I,J,L) = T(I,J,L) / PK(I,J,L) + + MASS(I,J,L) = (PLE(I,J,L) - PLE(I,J,L-1)) / MAPL_GRAV + + end do + end do + end do + !$OMP END PARALLEL DO call ESMF_ClockGetAlarm(clock, 'GF_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) @@ -736,42 +763,78 @@ subroutine GF_Run (GC, IMPORT, EXPORT, CLOCK, RC) ,REVSU, PRFIL) ENDIF - ! update DeepCu QL/QI/CF tendencies - fQi = ice_fraction( T+DTDT_DC*GF_DT, CNV_FRC, SRF_TYPE ) - TMP3D = CNV_DQCDT/MASS - DQLDT_DC = (1.0-fQi)*TMP3D - DQIDT_DC = fQi *TMP3D - DQADT_DC = MFD_DC*SCLM_DEEP/MASS - ! evap/subl and precip fluxes - do L=1,LM - !--- sublimation/evaporation tendencies (kg/kg/s) - RSU_CN (:,:,L) = REVSU(:,:,L)* fQi(:,:,L) - REV_CN (:,:,L) = REVSU(:,:,L)*(1.0-fQi(:,:,L)) - !--- preciptation fluxes (kg/kg/s) - PFI_CN (:,:,L) = PRFIL(:,:,L)* fQi(:,:,L) - PFL_CN (:,:,L) = PRFIL(:,:,L)*(1.0-fQi(:,:,L)) - enddo - ! Export - call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_FICE', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = fQi - call MAPL_GetPointer(EXPORT, PTR3D, 'DQRC', RC=STATUS); VERIFY_(STATUS) - if(associated(PTR3D)) PTR3D = CNV_PRC3 / GF_DT - call MAPL_GetPointer(EXPORT, PTR2D, 'CCWP', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = SUM( CNV_QC*MASS , 3 ) - - endif ! alarm_is_ringing + + call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_FICE', RC=STATUS); VERIFY_(STATUS) + ptr_is_assoc = associated(PTR3D) + + ! Update DeepCu QL/QI/CF tendencies, evap/subl and precip fluxes + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, T, DTDT_DC, GF_DT, CNV_FRC, SRF_TYPE, & + !$OMP CNV_DQCDT, MASS, DQLDT_DC, DQIDT_DC, DQADT_DC, & + !$OMP MFD_DC, SCLM_DEEP, RSU_CN, REVSU, REV_CN, & + !$OMP PFI_CN, PRFIL, PFL_CN, ptr_is_assoc, PTR3D) & + !$OMP PRIVATE(I, J, L, fQi_local, tmp_local) + do L = 1, LM + do J = 1, JM + !DIR$ IVDEP + do I = 1, IM + ! 1. Calculate local ice fraction and tmp scalar + fQi_local = ice_fraction(T(I,J,L) + DTDT_DC(I,J,L) * GF_DT, CNV_FRC(I,J), SRF_TYPE(I,J)) + tmp_local = CNV_DQCDT(I,J,L) / MASS(I,J,L) + + ! Fill the exported 3D pointer if associated + if (ptr_is_assoc) PTR3D(I,J,L) = fQi_local + + ! 2. Update DeepCu QL/QI/CF tendencies + DQLDT_DC(I,J,L) = (1.0 - fQi_local) * tmp_local + DQIDT_DC(I,J,L) = fQi_local * tmp_local + DQADT_DC(I,J,L) = MFD_DC(I,J,L) * SCLM_DEEP / MASS(I,J,L) + + ! 3. Evap/subl and precip fluxes (kg/kg/s) + RSU_CN(I,J,L) = REVSU(I,J,L) * fQi_local + REV_CN(I,J,L) = REVSU(I,J,L) * (1.0 - fQi_local) + + PFI_CN(I,J,L) = PRFIL(I,J,L) * fQi_local + PFL_CN(I,J,L) = PRFIL(I,J,L) * (1.0 - fQi_local) + end do + end do + end do + !$OMP END PARALLEL DO + + ! Other Exports + call MAPL_GetPointer(EXPORT, PTR3D, 'DQRC', RC=STATUS); VERIFY_(STATUS) + if(associated(PTR3D)) PTR3D = CNV_PRC3 / GF_DT + call MAPL_GetPointer(EXPORT, PTR2D, 'CCWP', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = SUM( CNV_QC*MASS , 3 ) + + endif ! Alarm ringing endif ! USE_PYMOIST_GF2020 - ! add tendencies to the moist import state - U = U + DUDT_DC*MOIST_DT - V = V + DVDT_DC*MOIST_DT - Q = Q + DQVDT_DC*MOIST_DT - T = T + DTDT_DC*MOIST_DT - ! add QI/QL/CL tendencies - QLCN = QLCN + DQLDT_DC*MOIST_DT - QICN = QICN + DQIDT_DC*MOIST_DT - CLCN = MAX(MIN(CLCN + DQADT_DC*MOIST_DT, 1.0), 0.0) + ! Add tendencies to the moist import state + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, U, DUDT_DC, MOIST_DT, V, DVDT_DC, Q, DQVDT_DC, & + !$OMP T, DTDT_DC, QLCN, DQLDT_DC, QICN, DQIDT_DC, CLCN, DQADT_DC) & + !$OMP PRIVATE(I, J, L) + do L = 1, LM + do J = 1, JM + !DIR$ IVDEP + do I = 1, IM + U(I,J,L) = U(I,J,L) + DUDT_DC(I,J,L) * MOIST_DT + V(I,J,L) = V(I,J,L) + DVDT_DC(I,J,L) * MOIST_DT + Q(I,J,L) = Q(I,J,L) + DQVDT_DC(I,J,L) * MOIST_DT + T(I,J,L) = T(I,J,L) + DTDT_DC(I,J,L) * MOIST_DT + + ! Add QI/QL/CL tendencies + QLCN(I,J,L) = QLCN(I,J,L) + DQLDT_DC(I,J,L) * MOIST_DT + QICN(I,J,L) = QICN(I,J,L) + DQIDT_DC(I,J,L) * MOIST_DT + CLCN(I,J,L) = MAX(0.0, MIN(CLCN(I,J,L) + DQADT_DC(I,J,L) * MOIST_DT, 1.0)) + end do + end do + end do + !$OMP END PARALLEL DO ! Cleanup negative water species ! ------------------------------ diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 index 3578d7ce13..9076c811c7 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MGB2_2M_InterfaceMod.F90 @@ -55,7 +55,6 @@ module GEOS_MGB2_2M_InterfaceMod real :: MINRHCRIT real :: CCW_EVAP_EFF real :: CCI_EVAP_EFF - integer :: PDFSHAPE real :: MIN_RL real :: MAX_RL real :: FAC_RI @@ -64,7 +63,6 @@ module GEOS_MGB2_2M_InterfaceMod real :: MAX_RI logical :: USE_AV_V logical :: SECOND_HYSTPDF, DO_UPD_CLD - logical :: USE_NCLOUD_CLIM logical :: MAKE_SNOW_ICE @@ -79,7 +77,7 @@ module GEOS_MGB2_2M_InterfaceMod DTST, RHC_STRAT_SCALE - INTEGER :: WSUB_OPTION, ST_OPTION, ITER_METHOD + INTEGER :: ST_OPTION, ITER_METHOD public :: MGB2_2M_Setup, MGB2_2M_Initialize, MGB2_2M_Run public :: MGVERSION @@ -100,6 +98,9 @@ subroutine MGB2_2M_Setup (GC, CF, RC) call ESMF_ConfigGetAttribute( CF, MGVERSION, Label="MGVERSION:", default=3, __RC__) + call MAPL_GetResource( CF, WSUB_OPTION, 'WSUB_OPTION:', DEFAULT= 1 , __RC__) !0- param 1- Use Wsub climatology 2-Wnet + call MAPL_GetResource( CF, USE_NCLOUD_CLIM, 'USE_NCLOUD_CLIM:', DEFAULT= .FALSE., __RC__) !0- param 1- Use Wsub climatology 2-Wnet + ! !INTERNAL STATE: FRIENDLIES%QV = "DYNAMICS:TURBULENCE:CHEMISTRY:ANALYSIS" @@ -418,8 +419,6 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource(MAPL, MUI_CST, 'MUI_CST:', DEFAULT= -1. ,__RC__) !value of the dispersion exponent in ice size dist. call MAPL_GetResource(MAPL, SED_STEP_SC, 'SED_STEP_SC:', DEFAULT= 1. ,__RC__) !scales the number of sedimentation substeps - call MAPL_GetResource(MAPL, WSUB_OPTION, 'WSUB_OPTION:', DEFAULT= 1 , __RC__) !0- param 1- Use Wsub climatology 2-Wnet - call MAPL_GetResource(MAPL, USE_NCLOUD_CLIM, 'USE_NCLOUD_CLIM:', DEFAULT= .FALSE., __RC__) !0- param 1- Use Wsub climatology 2-Wnet call MAPL_GetResource(MAPL, SECOND_HYSTPDF, 'SECOND_HYSTPDF:', DEFAULT= .FALSE. ,RC=STATUS) !TRUE to call hyspdf after the microphysics call MAPL_GetResource(MAPL, ITER_METHOD, 'ITER_METHOD:', DEFAULT= 1 ,RC=STATUS) !iteration method in hystpdf 1-Fixed point 2-Bisection call MAPL_GetResource(MAPL, DO_UPD_CLD, 'DO_UPD_CLD:', DEFAULT= .TRUE. ,RC=STATUS) !Udate cloud fraction after micro using top hat approx @@ -459,8 +458,12 @@ subroutine MGB2_2M_Initialize (MAPL, RC) use_wnet = .TRUE. call WRITE_PARALLEL ('Using Wnet***************') end if - + + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) + call aer_cloud_init(use_wnet) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") call WRITE_PARALLEL ("INITIALIZED MGB2_2M microphysics in non-generic GC INIT") @@ -473,7 +476,8 @@ subroutine MGB2_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 1500.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_EXP, 'CNV_FRACTION_EXP:', DEFAULT= 1.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, DBZ_LIQUID_SKIN , 'DBZ_LIQUID_SKIN:' , DEFAULT= 0 , RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=V12_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) end subroutine MGB2_2M_Initialize @@ -534,7 +538,6 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:,:) :: PFI_LS, PFI_AN real, pointer, dimension(:,:,:) :: PDF_A, PDFITERS real, pointer, dimension(:,:,:) :: RHCRIT - real, pointer, dimension(:,: ) :: DBZ_MAX, DBZ_1KM, DBZ_TOP, DBZ_M10C real, pointer, dimension(:,:,:) :: PTR3D real, pointer, dimension(:,: ) :: PTR2D #ifdef PDFDIAG @@ -2605,82 +2608,12 @@ subroutine MGB2_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) DVDT_macro+DVDT_micro,PTR3D) endif - ! Compute DBZ radar reflectivity - call MAPL_GetPointer(EXPORT, PTR3D , 'DBZ' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) - - if (associated(PTR3D) .OR. & - associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) then - - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - if (associated(PTR3D)) PTR3D = TMP3D - - if (associated(DBZ_MAX)) then - DBZ_MAX=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - - if (associated(DBZ_1KM)) then - call cs_interpolator(1, IM, 1, JM, LM, TMP3D, 1000., ZLE0, DBZ_1KM, -20.) - endif - - if (associated(DBZ_TOP)) then - DBZ_TOP=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (TMP3D(i,j,l) >= 18.5 ) then - DBZ_TOP(I,J) = ZLE0(I,J,L) - exit - endif - END DO - END DO ; END DO - endif - - if (associated(DBZ_M10C)) then - DBZ_M10C=MAPL_UNDEF - DO J=1,JM ; DO I=1,IM - DO L=LM,1,-1 - if (ZLE0(i,j,l) >= 25000.) continue - if (T(i,j,l) <= MAPL_TICE-10.0) then - DBZ_M10C(I,J) = TMP3D(I,J,L) - exit - endif - END DO - END DO ; END DO - endif - - endif - - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif + ! Call the shared radar diagnostics routine + call MAPL_TimerOn(MAPL,"---RADAR_DIAGS",RC=STATUS); VERIFY_(STATUS) + call compute_radar_diagnostics(EXPORT, CLOCK, IM, JM, LM, & + Q, QRAIN, QSNOW, QGRAUPEL, T, PLmb, W, ZLE0, & + STATUS); VERIFY_(STATUS) + call MAPL_TimerOff(MAPL,"---RADAR_DIAGS",RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QRAIN diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 index ecd9b275c3..25f6cad505 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_MoistGridComp.F90 @@ -28,7 +28,6 @@ module GEOS_MoistGridCompMod use GEOS_GF_InterfaceMod use GEOS_UW_InterfaceMod - use aer_cloud use Aer_Actv_Single_Moment use Lightning_mod, only: HEMCO_FlashRate use GEOSmoist_Process_Library @@ -47,8 +46,8 @@ module GEOS_MoistGridCompMod logical :: LUPDATE_PRECIP_TYPE real :: CCN_OCN real :: CCN_LND - logical :: MOVE_CN_TO_LS - logical :: USE_NCLOUD_CLIM + real :: DETRAIN_INACTIVE_CNV + real :: TAU_DETRAIN_CNV ! !PUBLIC MEMBER FUNCTIONS: @@ -109,8 +108,6 @@ subroutine SetServices ( GC, RC ) logical :: LSHALLOW logical :: LCLDMICR - integer ::PDFSHAPE, WSUB_OPTION - !============================================================================= ! Begin... @@ -183,18 +180,15 @@ subroutine SetServices ( GC, RC ) _ASSERT( LCLDMICR, 'Unsupported Cloud Microphysics Option' ) - call MAPL_GetResource( CF, PDFSHAPE, Label="PDFSHAPE:", default=1, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource( CF, DEBUG_MST, Label="DEBUG_MST:", default=.false., RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource( CF, DEBUG_TQ_ERRORS, Label="DEBUG_TQ_ERRORS:", default=.false., RC=STATUS) ; VERIFY_(STATUS) - !***********Aerosol-Cloud related - - call MAPL_GetResource( CF, USE_NCLOUD_CLIM, Label='USE_NCLOUD_CLIM:', default=.FALSE., RC=STATUS) - VERIFY_(STATUS) - call MAPL_GetResource( CF, WSUB_OPTION, Label='WSUB_OPTION:', default= 1, RC=STATUS) !0- param 1- Use Wsub climatology 2-USE WNET` - VERIFY_(STATUS) - + ! MAT These have to be defined as they are passed into Aer_Activate below and are intent(in) + ! Note: It's possible these aren't *used* if USE_AEROSOL_NN=.TRUE. but they are still passed + ! in so they have to be defined + call MAPL_GetResource( CF, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( CF, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) ! NOTE: Binary restarts expect Q to be the first field in the moist_internal_rst. Thus, ! the first MAPL_AddInternalSpec call must be from the microphysics @@ -553,11 +547,8 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - - if ((adjustl(CLDMICR_OPTION)=="MGB2_2M")) then ! subgrid scale vertical velocity options - - if (WSUB_OPTION .eq. 0) then - + select case (WSUB_OPTION) + case (0) call MAPL_AddImportSpec(GC, & LONG_NAME = 'Blackadar_length_scale_for_scalars', & UNITS = 'm', & @@ -567,61 +558,58 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TAUOROX', & + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TAUOROX', & LONG_NAME = 'surface_eastward_orographic_gravity_wave_stress', & - UNITS = 'N m-2', & - RESTART = MAPL_RestartSkip, & - DIMS = MAPL_DimsHorzOnly, & + UNITS = 'N m-2', & + RESTART = MAPL_RestartSkip, & + DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddImportSpec(GC, & - SHORT_NAME = 'TAUOROY', & + call MAPL_AddImportSpec(GC, & + SHORT_NAME = 'TAUOROY', & LONG_NAME = 'surface_northward_orographic_gravity_wave_stress', & - UNITS = 'N m-2', & - RESTART = MAPL_RestartSkip, & - DIMS = MAPL_DimsHorzOnly, & + UNITS = 'N m-2', & + RESTART = MAPL_RestartSkip, & + DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - - - elseif (WSUB_OPTION .eq. 1) then + VERIFY_(STATUS) - call MAPL_AddImportSpec ( GC, & - SHORT_NAME = 'WSUB_CLIM', & - LONG_NAME = 'stdev in vertical velocity', & - UNITS = 'm s-1', & - RESTART = MAPL_RestartSkip, & ! Read WSUB from a climatology - DIMS = MAPL_DimsHorzVert, & + case (1) + call MAPL_AddImportSpec ( GC, & + SHORT_NAME = 'WSUB_CLIM', & + LONG_NAME = 'stdev in vertical velocity', & + UNITS = 'm s-1', & + RESTART = MAPL_RestartSkip, & ! Read WSUB from a climatology + DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) - VERIFY_(STATUS) - - else + VERIFY_(STATUS) - call MAPL_AddImportSpec ( GC, & - LONG_NAME = 'total_momentum_diffusivity', & - UNITS = 'm+2 s-1', & - SHORT_NAME = 'KM', & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartSkip, & - VLOCATION = MAPL_VLocationEdge, & + case (2) + call MAPL_AddImportSpec ( GC, & + LONG_NAME = 'total_momentum_diffusivity', & + UNITS = 'm+2 s-1', & + SHORT_NAME = 'KM', & + DIMS = MAPL_DimsHorzVert, & + RESTART = MAPL_RestartSkip, & + VLOCATION = MAPL_VLocationEdge, & RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddImportSpec ( GC, & - LONG_NAME = 'Richardson_number_from_Louis', & - UNITS = '1', & - SHORT_NAME = 'RI', & - DIMS = MAPL_DimsHorzVert, & - RESTART = MAPL_RestartSkip, & - VLOCATION = MAPL_VLocationEdge, & + VERIFY_(STATUS) + + call MAPL_AddImportSpec ( GC, & + LONG_NAME = 'Richardson_number_from_Louis', & + UNITS = '1', & + SHORT_NAME = 'RI', & + DIMS = MAPL_DimsHorzVert, & + RESTART = MAPL_RestartSkip, & + VLOCATION = MAPL_VLocationEdge, & RC=STATUS ) VERIFY_(STATUS) - end if - end if + case default + ! Do nothing + end select IF (USE_NCLOUD_CLIM) then call MAPL_AddImportSpec ( GC, & @@ -643,7 +631,6 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) end if - call MAPL_AddImportSpec ( gc, & SHORT_NAME = 'DTDTDYN', & LONG_NAME = 'tendency_of_air_temperature_due_to_dynamics', & @@ -2113,6 +2100,14 @@ subroutine SetServices ( GC, RC ) UNITS = '# m-3', & DIMS = MAPL_DimsHorzVert, & VLOCATION = MAPL_VLocationCenter, RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'REFL10CM_MAX', & + LONG_NAME = 'Maximum_composite_10cm_radar_reflectivity', & + UNITS = 'dBZ', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -2123,38 +2118,6 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationCenter, RC=STATUS ) VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DBZ_MAX_S', & - LONG_NAME = 'Maximum_composite_radar_reflectivity_snow', & - UNITS = 'dBZ', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DBZ_MAX_R', & - LONG_NAME = 'Maximum_composite_radar_reflectivity_rain', & - UNITS = 'dBZ', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'DBZ_MAX_G', & - LONG_NAME = 'Maximum_composite_radar_reflectivity_graupel', & - UNITS = 'dBZ', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - - call MAPL_AddExportSpec(GC, & - SHORT_NAME = 'REFL10CM_MAX', & - LONG_NAME = 'Maximum_composite_10cm_radar_reflectivity', & - UNITS = 'dBZ', & - DIMS = MAPL_DimsHorzOnly, & - VLOCATION = MAPL_VLocationNone, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_AddExportSpec(GC, & SHORT_NAME = 'DBZ_MAX', & LONG_NAME = 'Maximum_composite_radar_reflectivity', & @@ -5600,7 +5563,15 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) type (ESMF_Config) :: CF - logical :: initialize_aer_cloud + type (ESMF_Alarm ) :: ALARM + type (ESMF_TimeInterval) :: TINT + real(ESMF_KIND_R8) :: DT_R8 + real :: DT_MOIST + real :: DBZ_DT + type(ESMF_Calendar) :: calendar + type(ESMF_Time) :: currTime + type(ESMF_Alarm) :: DBZ_RunAlarm + type(ESMF_TimeInterval) :: ringInterval !============================================================================= @@ -5630,26 +5601,8 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetResource( MAPL, LDIAGNOSE_PRECIP_TYPE, Label="DIAGNOSE_PRECIP_TYPE:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, LUPDATE_PRECIP_TYPE, Label="UPDATE_PRECIP_TYPE:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) - - ! If you use MGB2_2M, then aer_cloud_init is done in MGB2_2M_Initialize, otherwise we need to do it here if USE_AEROSOL_NN is true - ! and *not* MG - - initialize_aer_cloud = USE_AEROSOL_NN .AND. (adjustl(CLDMICR_OPTION) /= "MGB2_2M") - - if (initialize_aer_cloud) then - ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there - call aer_cloud_init(use_wnet = .false.) - call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") - endif - ! MAT These have to be defined as they are passed into Aer_Activate below and are intent(in) - ! Note: It's possible these aren't *used* if USE_AEROSOL_NN=.TRUE. but they are still passed - ! in so they have to be defined - call MAPL_GetResource( MAPL, CCN_OCN, 'NCCN_OCN:', DEFAULT= 100., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource( MAPL, CCN_LND, 'NCCN_LND:', DEFAULT= 300., RC=STATUS); VERIFY_(STATUS) - - call MAPL_GetResource( MAPL, MOVE_CN_TO_LS, Label="MOVE_CN_TO_LS:", default=.FALSE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DETRAIN_INACTIVE_CNV, Label="DETRAIN_INACTIVE_CNV:", default=0.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, TAU_DETRAIN_CNV, Label="TAU_DETRAIN_CNV:", default=1800.0, RC=STATUS); VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="RAS" ) call RAS_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CONVPAR_OPTION)=="GF" ) call GF_Initialize(MAPL, CF, CLOCK, IMPORT, EXPORT, RC=STATUS) ; VERIFY_(STATUS) @@ -5659,6 +5612,30 @@ subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="MGB2_2M") call MGB2_2M_Initialize(MAPL, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_Get(MAPL, RUNALARM=ALARM, RC=STATUS );VERIFY_(STATUS) + call ESMF_AlarmGet(ALARM, RingInterval=TINT, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalGet(TINT, S_R8=DT_R8,RC=STATUS); VERIFY_(STATUS) + DT_MOIST = DT_R8 + + DBZ_DT = max(DT_MOIST,900.0) + call MAPL_GetResource(MAPL, DBZ_DT, 'DBZ_DT:', default=DBZ_DT, RC=STATUS); VERIFY_(STATUS) + ! Get the current time in addition to the calendar + call ESMF_ClockGet(CLOCK, currTime=currTime, calendar=calendar, RC=STATUS); VERIFY_(STATUS) + call ESMF_TimeIntervalSet(ringInterval, S=nint(DBZ_DT), calendar=calendar, RC=STATUS); VERIFY_(STATUS) + ! Add RingTime = currTime to anchor the alarm + DBZ_RunAlarm = ESMF_AlarmCreate(Clock = CLOCK, & + Name = 'DBZ_RunAlarm', & + RingTime = currTime-TINT, & + RingInterval = ringInterval, & + Sticky = .false. , RC=STATUS); VERIFY_(STATUS) + call init_refl10cm() + call MAPL_GetResource( MAPL, refl10cm_allow_wet_graupel , 'refl10cm_allow_wet_graupel:' , DEFAULT= .FALSE. , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, refl10cm_allow_wet_snow , 'refl10cm_allow_wet_snow:' , DEFAULT= .FALSE. , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, DBZ_VAR_INTERCP , 'DBZ_VAR_INTERCP:' , DEFAULT= DBZ_VAR_INTERCP, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQUID_SKIN_SNOW , 'LIQUID_SKIN_SNOW:' , DEFAULT= .FALSE. , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQUID_SKIN_GRAUPEL , 'LIQUID_SKIN_GRAUPEL:' , DEFAULT= .FALSE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, LIQUID_SKIN_HAIL , 'LIQUID_SKIN_HAIL:' , DEFAULT= .TRUE. , RC=STATUS); VERIFY_(STATUS) + ! All done !--------- @@ -5709,6 +5686,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real :: DT_MOIST ! Local variables + real :: MFC ! Layer-centered mass flux [kg m-2 s-1] + real :: inactivity_weight ! Scale from 0.0 to 1.0 based on MFC + real :: transfer_rate ! Fraction of mass to transfer this timestep + real :: dq_l ! Liquid mass being transferred + real :: dq_i ! Ice mass being transferred + real :: d_cf ! Cloud fraction being transferred real :: Tmax, KCBLMIN, PMIN_CBL real :: CNV_CAPE_NORM, CNV_CAPE_SCALE real, allocatable, dimension(:,:,:) :: PLEmb, PKE, ZLE0, PK, MASS @@ -5725,7 +5708,6 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: FRLAND, FRLANDICE, FRACI, SNOMAS real, pointer, dimension(:,:) :: SH, TS, EVAP, KPBL real, pointer, dimension(:,:,:) :: KH, TKE, OMEGA - real, pointer, dimension(:,:,:) :: NCPL_CLIM, NCPI_CLIM integer :: n_modes type(ESMF_State) :: AERO type(ESMF_FieldBundle) :: TR @@ -5784,6 +5766,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if ( ESMF_AlarmIsRinging( ALARM, RC=STATUS) ) then + call MAPL_TimerOn(MAPL,"---MOIST_PROLOGUE") + call ESMF_AlarmRingerOff(ALARM, RC=STATUS) ; VERIFY_(STATUS) ! Internal State @@ -5821,21 +5805,18 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(IMPORT, SNOMAS, 'SNOMAS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, SRF_TYPE, 'SRF_TYPE' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (USE_NCLOUD_CLIM) then - call MAPL_GetPointer(IMPORT, NCPL_CLIM, 'NCPL_CLIM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(IMPORT, NCPI_CLIM, 'NCPI_CLIM' , RC=STATUS); VERIFY_(STATUS) - end if - - where ( (FRLANDICE > 0.5) .OR. (FRACI > 0.5) ) - SRF_TYPE = 3.0 ! Ice + where (FRLANDICE > 0.5) + SRF_TYPE = SRF_TYPE_LANDICE + elsewhere (FRACI > 0.5) + SRF_TYPE = SRF_TYPE_ICE elsewhere ( SNOMAS > 0.1 .AND. SNOMAS /= MAPL_UNDEF ) ! NOTE: SNOMAS has UNDEFs so we need to make sure we don't ! allow that to infect this comparison - SRF_TYPE = 2.0 ! Snow + SRF_TYPE = SRF_TYPE_SNOW elsewhere (FRLAND > 0.1) - SRF_TYPE = 1.0 ! Land + SRF_TYPE = SRF_TYPE_LAND elsewhere - SRF_TYPE = 0.0 ! Ocean + SRF_TYPE = SRF_TYPE_OCEAN end where ! Allocatables @@ -5981,8 +5962,12 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, LFC, 'ZLFC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, LNB, 'ZLNB' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, LCL_AGL, 'LCL_AGL', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + + call MAPL_TimerOn(MAPL,"-----BUOYANCY2") call BUOYANCY2( IM, JM, LM, T, Q, QST3, DQST3, DZET, ZL0, PLmb, PLEmb(:,:,LM), & SBCAPE, MLCAPE, MUCAPE, SBCIN, MLCIN, MUCIN, BYNCY, LFC, LNB, LCL_AGL ) + call MAPL_TimerOff(MAPL,"-----BUOYANCY2") + call BUOYANCY( T, Q, QST3, DQST3, DZET, ZL0, BYNCY, CAPE, INHB) ! initialize diagnosed convective fraction @@ -6006,6 +5991,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) endif endif + call MAPL_TimerOff(MAPL,"---MOIST_PROLOGUE") + ! Extract convective tracers from the TR bundle call MAPL_TimerOn (MAPL,"---CONV_TRACERS") call CNV_Tracers_Init(TR, RC) @@ -6014,42 +6001,31 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Get aerosol activation properties call MAPL_TimerOn (MAPL,"---AERO_ACTIVATE") - - if ((USE_AEROSOL_NN) .and. .not. (USE_NCLOUD_CLIM)) then - ! get veritical velocity - if (all(W == 0.0)) then - TMP3D = -OMEGA/(MAPL_GRAV*PLmb*100.0/(MAPL_RGAS*T)) - else - TMP3D = W - endif - ! Pressures in Pa - call Aer_Activation(MAPL, IM,JM,LM, Q, T, PLmb*100.0, PLE, TKE, TMP3D, FRLAND, & - AeroPropsNew, AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6, & - (adjustl(CLDMICR_OPTION)=="MGB2_2M"), __RC__) -! Temporary -! call MAPL_MaxMin('MST: NWFA ', NWFA *1.e-6) -! call MAPL_MaxMin('MST: NACTL ', NACTL*1.e-6) -! call MAPL_MaxMin('MST: NACTI ', NACTI*1.e-6) -! Temporary - + if (USE_NCLOUD_CLIM) then !Setup ND/NI climatology from GiOcean + call MAPL_GetPointer(IMPORT, PTR3D, 'NCPL_CLIM', RC=STATUS); VERIFY_(STATUS) + NACTL = PTR3D + call MAPL_GetPointer(IMPORT, PTR3D, 'NCPI_CLIM', RC=STATUS); VERIFY_(STATUS) + NACTI = PTR3D else - - - if (USE_NCLOUD_CLIM) then !Setup ND/NI climatology from GiOcean - - NACTL = NCPL_CLIM - NACTI = NCPI_CLIM - else - do L=1,LM - NACTL(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 - NACTI(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 - end do - - end if + if (USE_AEROSOL_NN) then + ! get veritical velocity + if (all(W == 0.0)) then + TMP3D = -OMEGA/(MAPL_GRAV*PLmb*100.0/(MAPL_RGAS*T)) + else + TMP3D = W + endif + ! Pressures in Pa + call Aer_Activation(MAPL, IM,JM,LM, Q, T, PLmb*100.0, PLE, TKE, TMP3D, FRLAND, & + AERO, NACTL, NACTI, NWFA, CCN_LND*1.e6, CCN_OCN*1.e6, & + (adjustl(CLDMICR_OPTION)=="MGB2_2M"), __RC__) + else + do L=1,LM + NACTL(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 + NACTI(:,:,L) = (CCN_LND*FRLAND + CCN_OCN*(1.0-FRLAND))*1.e6 ! #/m^3 + end do + endif endif - - call MAPL_GetPointer(EXPORT, PTR3D, 'NCCN_LIQ', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = NACTL*1.e-6 call MAPL_GetPointer(EXPORT, PTR3D, 'NCCN_ICE', RC=STATUS); VERIFY_(STATUS) @@ -6099,6 +6075,8 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) endif endif + call MAPL_TimerOn(MAPL,"---MOIST_EPILOGUE") + ! Mass fluxes ! accumuated over deep and shalow convection call MAPL_GetPointer(EXPORT, PTR3D, 'CNV_MFC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) @@ -6107,22 +6085,33 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) PTR3D = 0.0 if (associated(PTRDC)) PTR3D = PTR3D + PTRDC if (associated(PTRSC)) PTR3D = PTR3D + PTRSC - - if (MOVE_CN_TO_LS) then + if (DETRAIN_INACTIVE_CNV > 0.0) then do L = 1, LM do J = 1, JM do I = 1, IM - if (0.5*(PTR3D(I,J,L)+PTR3D(I,J,L+1)) < 1.e-5) then - ! Move all QL,QI,CL to LS when cnv_mfc is 0.0 - QLLS(I,J,L) = QLLS(I,J,L)+QLCN(I,J,L) - QLCN(I,J,L) = 0.0 - QILS(I,J,L) = QILS(I,J,L)+QICN(I,J,L) - QICN(I,J,L) = 0.0 - CLLS(I,J,L) = CLLS(I,J,L)+CLCN(I,J,L) - CLCN(I,J,L) = 0.0 + ! Calculate local mass flux + MFC = 0.5 * (PTR3D(I,J,L) + PTR3D(I,J,L+1)) + if (MFC < DETRAIN_INACTIVE_CNV) then + ! 1. Calculate a smooth inactivity factor (0.0 at threshold, 1.0 when MFC is 0) + ! 2. Scale it by the timestep vs relaxation time (DT_MOIST / TAU) + inactivity_weight = 1.0 - (MFC / DETRAIN_INACTIVE_CNV) + transfer_rate = inactivity_weight * (DT_MOIST / TAU_DETRAIN_CNV) + ! Bound the rate safely between 0 and 1 + transfer_rate = min(1.0, max(0.0, transfer_rate)) + ! Calculate the exact amounts to transfer this timestep + dq_l = QLCN(I,J,L) * transfer_rate + dq_i = QICN(I,J,L) * transfer_rate + d_cf = CLCN(I,J,L) * transfer_rate + ! Move the Liquid + QLLS(I,J,L) = QLLS(I,J,L) + dq_l + QLCN(I,J,L) = QLCN(I,J,L) - dq_l + ! Move the Ice + QILS(I,J,L) = QILS(I,J,L) + dq_i + QICN(I,J,L) = QICN(I,J,L) - dq_i + ! Move the Cloud Fraction using Random Overlap for the transferred piece + CLLS(I,J,L) = CLLS(I,J,L) + d_cf - (CLLS(I,J,L) * d_cf) + CLCN(I,J,L) = CLCN(I,J,L) - d_cf endif - ! cleanup clouds - call FIX_UP_CLOUDS( Q(I,J,L), T(I,J,L), QLLS(I,J,L), QILS(I,J,L), CLLS(I,J,L), QLCN(I,J,L), QICN(I,J,L), CLCN(I,J,L) ) enddo enddo enddo @@ -6135,11 +6124,15 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(PTRDC)) PTR3D = PTR3D + PTRDC if (associated(PTRSC)) PTR3D = PTR3D + PTRSC + call MAPL_TimerOff(MAPL,"---MOIST_EPILOGUE") + if (adjustl(CLDMICR_OPTION)=="BACM_1M") call BACM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="GFDL_1M") call GFDL_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="THOM_1M") call THOM_1M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) if (adjustl(CLDMICR_OPTION)=="MGB2_2M") call MGB2_2M_Run(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_TimerOn(MAPL,"---MOIST_EPILOGUE") + if (DEBUG_MST) then call MAPL_MaxMin('MST: Q_AF_MP ', Q) call MAPL_MaxMin('MST: T_AF_MP ', T) @@ -6619,7 +6612,9 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR2D, 'LFR_GCC', NotFoundOk=.TRUE., RC=STATUS); VERIFY_(STATUS) if (associated(PTR2D)) PTR2D = 0.0 - else + call MAPL_TimerOff(MAPL,"---MOIST_EPILOGUE") + + else ! Alarm ringing ! Internal State call MAPL_GetPointer(INTERNAL, Q, 'Q' , RC=STATUS); VERIFY_(STATUS) @@ -6676,7 +6671,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetPointer(EXPORT, PTR3D, 'RH2', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = MAX(MIN( Q/GEOS_QSAT (T, PLmb) , 1.02 ),0.0) - endif + endif ! Alarm call MAPL_TimerOff(MAPL,"TOTAL") diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 index 2c79b6b1dc..6a2c5f558f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_NSSL_2M_InterfaceMod.F90 @@ -14,7 +14,7 @@ module GEOS_NSSL_2M_InterfaceMod use MAPL use GEOS_UtilsMod use GEOSmoist_Process_Library - use Aer_Actv_Single_Moment + use aer_cloud use module_mp_nssl_2mom implicit none @@ -48,7 +48,6 @@ module GEOS_NSSL_2M_InterfaceMod real :: TURNRHCRIT_PARAM real :: TAU_EVAP, CCW_EVAP_EFF real :: TAU_SUBL, CCI_EVAP_EFF - integer :: PDFSHAPE real :: ANV_ICEFALL real :: LS_ICEFALL real :: FAC_RL @@ -364,6 +363,17 @@ subroutine NSSL_2M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 200.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 4000.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=V12_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) + + if (USE_AEROSOL_NN) then + ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there + call aer_cloud_init(use_wnet = .false.) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") + endif + end subroutine NSSL_2M_Initialize subroutine NSSL_2M_Run (GC, IMPORT, EXPORT, CLOCK, RC) @@ -1087,31 +1097,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_R' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,QRAIN,0.0*QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_S' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,QSNOW,0.0*QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR2D , 'DBZ_MAX_G' , RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - call CALCDBZ(TMP3D,100*PLmb,T,Q,0.0*QRAIN,0.0*QSNOW,QGRAUPEL,IM,JM,LM,1,0,DBZ_LIQUID_SKIN) - PTR2D=-9999.0 - DO L=1,LM ; DO J=1,JM ; DO I=1,IM - PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) - END DO ; END DO ; END DO - endif - call MAPL_GetPointer(EXPORT, PTR3D, 'QRTOT', RC=STATUS); VERIFY_(STATUS) if (associated(PTR3D)) PTR3D = QRAIN diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 index 54b2deadc9..2cc8837398 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_THOM_1M_InterfaceMod.F90 @@ -14,7 +14,7 @@ module GEOS_THOM_1M_InterfaceMod use MAPL use GEOS_UtilsMod use GEOSmoist_Process_Library - use Aer_Actv_Single_Moment + use aer_cloud use module_mp_thompson implicit none @@ -49,7 +49,6 @@ module GEOS_THOM_1M_InterfaceMod real :: TURNRHCRIT_PARAM real :: CCW_EVAP_EFF real :: CCI_EVAP_EFF - integer :: PDFSHAPE real :: ANV_ICEFALL real :: LS_ICEFALL real :: FAC_RL @@ -289,6 +288,17 @@ subroutine THOM_1M_Initialize (MAPL, RC) call MAPL_GetResource( MAPL, CNV_FRACTION_MIN, 'CNV_FRACTION_MIN:', DEFAULT= 200.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource( MAPL, CNV_FRACTION_MAX, 'CNV_FRACTION_MAX:', DEFAULT= 4000.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, ICE_FRACTION_POLYNOMIAL, Label="ICE_FRACTION_POLYNOMIAL:", default=V12_ICE_POLYNOMIAL, RC=STATUS) ; VERIFY_(STATUS) + + call MAPL_GetResource( MAPL, USE_AEROSOL_NN , 'USE_AEROSOL_NN:' , DEFAULT=USE_AEROSOL_NN, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource( MAPL, USE_BERGERON , 'USE_BERGERON:' , DEFAULT=USE_BERGERON , RC=STATUS); VERIFY_(STATUS) + + if (USE_AEROSOL_NN) then + ! NOTE: For now we hard code in .false. for use_wnet as that is only an option with MG and will be handled there + call aer_cloud_init(use_wnet = .false.) + call WRITE_PARALLEL ("INITIALIZED aer_cloud_init") + endif + end subroutine THOM_1M_Initialize subroutine THOM_1M_Run (GC, IMPORT, EXPORT, CLOCK, RC) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 index 8c7aef153b..e70ff5033c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/GEOS_UW_InterfaceMod.F90 @@ -140,22 +140,21 @@ subroutine UW_Initialize (MAPL, CF, CLOCK, IMPORT, EXPORT, RC) else call MAPL_GetResource(MAPL, SHLWPARAMS%WINDSRCAVG, 'WINDSRCAVG:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE, 'MIXSCALE:' ,DEFAULT=3000.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%MIXSCALE_HR, 'MIXSCALE_HR:' ,DEFAULT=3000.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=0.9e-3, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%CRIQC, 'CRIQC:' ,DEFAULT=3.0e-3, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%THLSRC_FAC, 'THLSRC_FAC:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%QTSRC_FAC, 'QTSRC_FAC:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%QTSRCHGT, 'QTSRCHGT:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE_HR, 'RKFRE_HR:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE, 'RKFRE:' ,DEFAULT= 1.5, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKFRE_HR, 'RKFRE_HR:' ,DEFAULT= 0.75, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RKM, 'RKM:' ,DEFAULT= 8.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RKM_HR, 'RKM_HR:' ,DEFAULT= 12.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RMAXFRAC, 'RMAXFRAC:' ,DEFAULT= 0.1, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RMAXFRAC, 'RMAXFRAC:' ,DEFAULT= 0.25, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%RMAXFRAC_HR, 'RMAXFRAC_HR:' ,DEFAULT= 0.1, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%FRC_RASN, 'FRC_RASN:' ,DEFAULT= 0.0, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 3.0, RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, SHLWPARAMS%RPEN, 'RPEN:' ,DEFAULT= 1.5, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SCLM_SHALLOW, 'SCLM_SHALLOW:' ,DEFAULT= 1.0, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%NITER_XC, 'NITER_XC:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) - call MAPL_GetResource(MAPL, USE_EIS, 'UW_USE_EIS:' ,DEFAULT=.FALSE.,RC=STATUS) ; VERIFY_(STATUS) + call MAPL_GetResource(MAPL, USE_EIS, 'UW_USE_EIS:' ,DEFAULT=.TRUE., RC=STATUS) ; VERIFY_(STATUS) endif call MAPL_GetResource(MAPL, SHLWPARAMS%ITER_CIN, 'ITER_CIN:' ,DEFAULT=2, RC=STATUS) ; VERIFY_(STATUS) call MAPL_GetResource(MAPL, SHLWPARAMS%USE_CINCIN, 'USE_CINCIN:' ,DEFAULT=1, RC=STATUS) ; VERIFY_(STATUS) @@ -197,6 +196,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, allocatable, dimension(:,:,:) :: ZLE0, ZL0 real, allocatable, dimension(:,:,:) :: PL, PK, PKE, DP real, allocatable, dimension(:,:,:) :: MASS + real, allocatable, dimension(:,:,:) :: DQLDT_SC_, DQIDT_SC_ real, allocatable, dimension(:,:) :: RKM2D, RKFRE, MIX2D, RMAXFRAC2D real, allocatable, dimension(:,:,:) :: TMP3D @@ -215,7 +215,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real, pointer, dimension(:,:) :: TPERT_SC, QPERT_SC, LTS, EIS real, pointer, dimension(:,:) :: CBMF_SC, PLCL_SC, PLFC_SC, & PINV_SC, PREL_SC, PBUP_SC, & - CLDTOP_SC + CLDTOP_SC, SC_QT, SC_MSE #ifdef UWDIAG real, pointer, dimension(:,:) :: CIN_SC, CNT_SC, CNB_SC, & WLCL_SC, QTSRC_SC, THLSRC_SC, & @@ -241,7 +241,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) type (ESMF_TimeInterval) :: TINT real(ESMF_KIND_R8) :: DT_R8 real :: UW_DT, MOIST_DT - real :: SIG + real :: DX, SIG, mix2d_phys type(ESMF_Alarm) :: alarm logical :: alarm_is_ringing type( ESMF_VM ) :: VMG @@ -251,6 +251,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real :: fac_eis ! Estimated enversion strength 0:1 factor real :: rkfre_base ! Base fractional entrainment rate before EIS modification real :: rkm_base ! Base momentum entrainment rate before EIS modification + real :: rkm_scale_fac real :: mix2d_base ! Base mixing length scale before EIS modification real :: rmaxfrac_base ! Base maximum updraft area fraction before EIS modification real :: eis_rkfre_factor ! EIS modification factor for RKFRE [0-1] @@ -258,7 +259,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) real :: eis_mix2d_factor ! EIS modification factor for MIX2D [0-1] real :: eis_rmaxfrac_factor ! EIS modification factor for RMAXFRAC [1.0-1.1] - integer :: I, J, L + integer :: I, J, L, K integer :: IM,JM,LM call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS); VERIFY_(STATUS) @@ -351,8 +352,9 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_pybridge_gcrun_with_internal( "pyMoist.fortran.param_interfaces.convection.UW_interface", MAPL, IMPORT, EXPORT, INTERNAL ) call CNV_Tracers_To_AOS() else - ! Internals - call MAPL_GetPointer(INTERNAL, CUSH, 'CUSH' , RC=STATUS); VERIFY_(STATUS) + ! Internals + call MAPL_GetPointer(INTERNAL, CUSH, 'CUSH' , RC=STATUS); VERIFY_(STATUS) + endif ! USE_PYMOIST_UW ! Imports call MAPL_GetPointer(IMPORT, FRLAND ,'FRLAND' ,RC=STATUS); VERIFY_(STATUS) @@ -373,6 +375,9 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( PK (IM,JM,LM ) ) ALLOCATE ( DP (IM,JM,LM ) ) ALLOCATE ( MASS (IM,JM,LM ) ) + ! Temporary UW exports + ALLOCATE ( DQLDT_SC_(IM,JM,LM ) ) + ALLOCATE ( DQIDT_SC_(IM,JM,LM ) ) ! 2D Variables ALLOCATE ( RKFRE (IM,JM) ) ALLOCATE ( RKM2D (IM,JM) ) @@ -380,15 +385,48 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) ALLOCATE ( RMAXFRAC2D (IM,JM) ) ! Derived States - PKE = (PLE/MAPL_P00)**(MAPL_KAPPA) - PL = 0.5*(PLE(:,:,0:LM-1) + PLE(:,:,1:LM)) - PK = (PL/MAPL_P00)**(MAPL_KAPPA) - DO L=0,LM - ZLE0(:,:,L)= ZLE(:,:,L) - ZLE(:,:,LM) ! Edge Height (m) above the surface - END DO - ZL0 = 0.5*(ZLE0(:,:,0:LM-1) + ZLE0(:,:,1:LM) ) ! Layer Height (m) above the surface - DP = ( PLE(:,:,1:LM)-PLE(:,:,0:LM-1) ) - MASS = DP/MAPL_GRAV + !-------------------------------------------------------------- + + ! 1. Compute the top-of-atmosphere edge (k = 0) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, PKE, PLE, ZLE0, ZLE) & + !$OMP PRIVATE(i, j) + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + PKE(i,j,0) = (PLE(i,j,0) / MAPL_P00)**(MAPL_KAPPA) + ZLE0(i,j,0) = ZLE(i,j,0) - ZLE(i,j,LM) + end do + end do + !$OMP END PARALLEL DO + + ! 2. Compute the remaining edges and all layer variables (k = 1 to LM) + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, PKE, PLE, PL, PK, & + !$OMP ZLE0, ZLE, ZL0, DP, MASS) & + !$OMP PRIVATE(i, j, k) + do k = 1, LM + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + + ! Edge variables + PKE(i,j,k) = (PLE(i,j,k) / MAPL_P00)**(MAPL_KAPPA) + ZLE0(i,j,k) = ZLE(i,j,k) - ZLE(i,j,LM) + + ! Layer variables + PL(i,j,k) = 0.5 * (PLE(i,j,k-1) + PLE(i,j,k)) + PK(i,j,k) = (PL(i,j,k) / MAPL_P00)**(MAPL_KAPPA) + + ZL0(i,j,k) = 0.5 * (ZLE0(i,j,k-1) + ZLE0(i,j,k)) + + DP(i,j,k) = PLE(i,j,k) - PLE(i,j,k-1) + MASS(i,j,k) = DP(i,j,k) / MAPL_GRAV + + end do + end do + end do + !$OMP END PARALLEL DO call ESMF_ClockGetAlarm(clock, 'UW_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) @@ -425,57 +463,86 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) call MAPL_GetPointer(EXPORT, UFLX_SC, 'UFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, VFLX_SC, 'VFLX_SC' , ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (JASON_UW) then - RKFRE = SHLWPARAMS%RKFRE - RKM2D = SHLWPARAMS%RKM - MIX2D = SHLWPARAMS%MIXSCALE - RMAXFRAC2D = SHLWPARAMS%RMAXFRAC - else - ! resolution dependent throttle on UW via TKE and scaling of cloud-base mass flux - call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) - do J=1,JM - do I=1,IM - fac_eis = 0.0 - if (USE_EIS) fac_eis = get_fac_eis(EIS(i,j),srf_type(i,j)) ! Estimated inversion strength determine stable regime - SIG = SIGMA(SQRT(PTR2D(i,j))) ! Coarse -> Fine - - ! Base resolution-dependent parameters - ! Support for varying UW parameters by resolution ! Coarse*SIG -> Fine*(1.0-SIG) - rkfre_base = SHLWPARAMS%RKFRE *SIG + SHLWPARAMS%RKFRE_HR *(1.0-SIG) - rkm_base = SHLWPARAMS%RKM *SIG + SHLWPARAMS%RKM_HR *(1.0-SIG) - mix2d_base = SHLWPARAMS%MIXSCALE*SIG + SHLWPARAMS%MIXSCALE_HR*(1.0-SIG) - rmaxfrac_base = SHLWPARAMS%RMAXFRAC*SIG + SHLWPARAMS%RMAXFRAC_HR*(1.0-SIG) - - ! EIS-based regime modifications for marine stratocumulus enhancement - ! Reduce shallow convection activity in high EIS (stable inversion) regions - eis_rkfre_factor = 1.0 - 0.8*fac_eis ! Reduce RKFRE by up to 80% in stable regimes - eis_rkm_factor = 1.0 + 0.4*fac_eis ! Increase RKM by up to 40% in stable regimes - eis_mix2d_factor = 1.0 - 0.3*fac_eis ! Reduce mixing scale by up to 30% in stable regimes - eis_rmaxfrac_factor = 1.0 + 0.1*fac_eis ! INCREASE rmaxfrac in stable (high EIS) regimes - - ! Apply EIS modifications - RKFRE(i,j) = rkfre_base * eis_rkfre_factor - RKM2D(i,j) = rkm_base * eis_rkm_factor - MIX2D(i,j) = mix2d_base * eis_mix2d_factor - RMAXFRAC2D(i,j) = rmaxfrac_base * eis_rmaxfrac_factor - - ! Optional: Add minimum limits to prevent unrealistically low values - RKFRE(i,j) = max(RKFRE(i,j), 0.1) ! Minimum RKFRE threshold - RKM2D(i,j) = min(RKM2D(i,j), 14.0) ! Maximum RKM threshold - MIX2D(i,j) = max(MIX2D(i,j), 1500.0) ! Minimum mixing scale threshold - RMAXFRAC2D(i,j) = max(min(RMAXFRAC2D(i,j), 0.8), 0.05) ! Bounds: 5% to 80% - enddo - enddo - endif - - ! combine condensates for input (not updated within UW) + ! 1. Fetch all pointers first + !-------------------------------------------------------------- + call MAPL_GetPointer(IMPORT, PTR2D, 'AREA', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLTOT, 'QLTOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QITOT, 'QITOT', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLTOT = QLLS+QLCN - QITOT = QILS+QICN - DQLDT_SC = QLTOT - DQIDT_SC = QITOT - + + ! 2. 2D parameters for UW + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, JASON_UW, SHLWPARAMS, RKFRE, RKM2D, MIX2D, RMAXFRAC2D, & + !$OMP USE_EIS, EIS, srf_type, PTR2D, ZL0, KPBL_SC) & + !$OMP PRIVATE(i, j, fac_eis, DX, SIG, rkm_scale_fac, mix2d_phys, rkfre_base, rkm_base, & + !$OMP rmaxfrac_base, eis_rkfre_factor, eis_rkm_factor, eis_rmaxfrac_factor) + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + if (JASON_UW) then + RKFRE(i,j) = SHLWPARAMS%RKFRE + RKM2D(i,j) = SHLWPARAMS%RKM + MIX2D(i,j) = SHLWPARAMS%MIXSCALE + RMAXFRAC2D(i,j) = SHLWPARAMS%RMAXFRAC + else + fac_eis = 0.0 + if (USE_EIS) fac_eis = get_fac_eis(EIS(i,j), srf_type(i,j)) + DX = SQRT(PTR2D(i,j)) + SIG = SIGMA(DX) + + ! (If RKM=4.0, multiplier is 2.5. If RKM=8.0, multiplier is 5.0) + rkm_scale_fac = (SHLWPARAMS%RKM / 4.0) * 2.5 + + ! This ensures the dominant eddies scale with the PBL thickness and RKM + mix2d_phys = MAX(rkm_scale_fac * ZL0(i,j,KPBL_SC(i,j)), 1000.0 ) + + ! The subgrid mixing scale cannot exceed half the grid box + MIX2D(i,j) = MIN(0.5*DX, mix2d_phys, SHLWPARAMS%MIXSCALE) + + ! Base resolution-dependent parameters + rkfre_base = SHLWPARAMS%RKFRE * SIG + SHLWPARAMS%RKFRE_HR * (1.0 - SIG) + rkm_base = SHLWPARAMS%RKM * SIG + SHLWPARAMS%RKM_HR * (1.0 - SIG) + rmaxfrac_base = SHLWPARAMS%RMAXFRAC * SIG + SHLWPARAMS%RMAXFRAC_HR * (1.0 - SIG) + + ! EIS-based regime modifications + eis_rkfre_factor = 1.0 - 0.8 * fac_eis + eis_rkm_factor = 1.0 + 0.4 * fac_eis + eis_rmaxfrac_factor = 1.0 + 0.1 * fac_eis + + ! Apply EIS modifications + RKFRE(i,j) = rkfre_base * eis_rkfre_factor + RKM2D(i,j) = rkm_base * eis_rkm_factor + RMAXFRAC2D(i,j) = rmaxfrac_base * eis_rmaxfrac_factor + + ! Optional: Add minimum limits + RKFRE(i,j) = max(RKFRE(i,j), 0.1) + RKM2D(i,j) = min(RKM2D(i,j), 14.0) + RMAXFRAC2D(i,j) = max(min(RMAXFRAC2D(i,j), 0.8), 0.05) + end if + end do + end do + !$OMP END PARALLEL DO + + ! 3. Combine condensates for input (not updated within UW) + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, QLTOT, DQLDT_SC, QLLS, QLCN, & + !$OMP QITOT, DQIDT_SC, QILS, QICN) & + !$OMP PRIVATE(i, j, k) + do k = 1, LM + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + QLTOT(i,j,k) = QLLS(i,j,k) + QLCN(i,j,k) + QITOT(i,j,k) = QILS(i,j,k) + QICN(i,j,k) + ! Initialize tendencies + DQLDT_SC(i,j,k) = QLTOT(i,j,k) + DQIDT_SC(i,j,k) = QITOT(i,j,k) + end do + end do + end do + !$OMP END PARALLEL DO + ! Call UW shallow convection !---------------------------------------------------------------- call compute_uwshcu_inv(IM*JM, LM, UW_DT, & ! IN @@ -483,7 +550,7 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) U, V, Q, QLTOT, QITOT, T, TKE, RKFRE, KPBL_SC,& SH, EVAP, CNPCPRATE, FRLAND, RKM2D, MIX2D, RMAXFRAC2D, & CUSH, & ! INOUT - UMF_SC, DCM_SC, DQVDT_SC, & ! OUT + UMF_SC, DCM_SC, DQVDT_SC, DQLDT_SC_, DQIDT_SC_, & ! OUT DTDT_SC, DUDT_SC, DVDT_SC, DQRDT_SC, & DQSDT_SC, CUFRC_SC, ENTR_SC, DETR_SC, & QLDET_SC, QIDET_SC, QLSUB_SC, QISUB_SC, & @@ -501,98 +568,150 @@ subroutine UW_Run (GC, IMPORT, EXPORT, CLOCK, RC) #endif USE_TRACER_TRANSP_UW) - ! Calculate detrained mass flux + ! 1. Fetch ALL pointers at the top !-------------------------------------------------------------- - if (JASON_MFD_SC) then - where (DETR_SC.ne.MAPL_UNDEF) - MFD_SC = 0.5*(UMF_SC(:,:,1:LM)+UMF_SC(:,:,0:LM-1))*DETR_SC*DP - elsewhere - MFD_SC = 0.0 - end where - else - MFD_SC = DCM_SC - endif - DQADT_SC= MFD_SC*SCLM_SHALLOW/MASS - ! Convert detrained water units before passing to cloud - !--------------------------------------------------------------- - call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT, QIENT_SC, 'QIENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLENT_SC = 0. - QIENT_SC = 0. - WHERE (QLDET_SC.lt.0.) - QLENT_SC = QLDET_SC - QLDET_SC = 0. - END WHERE - WHERE (QIDET_SC.lt.0.) - QIENT_SC = QIDET_SC - QIDET_SC = 0. - END WHERE - ! scale the detrained fluxes before exporting - QLDET_SC = QLDET_SC*MASS - QIDET_SC = QIDET_SC*MASS - ! Precipitation + call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, QIENT_SC, 'QIENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SC_QT, 'SC_QT', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, SC_MSE, 'SC_MSE', RC=STATUS); VERIFY_(STATUS) + + ! 2. Fused 3D Loop for Detrainment and Conversions !-------------------------------------------------------------- - call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = DQRDT_SC ! [kg/kg/s] - call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - if (associated(PTR3D)) PTR3D = DQSDT_SC ! [kg/kg/s] - - ! Additional exports - call MAPL_GetPointer(EXPORT, PTR2D, 'SC_QT', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - ! column integral of UW total water tendency, for checking conservation - PTR2D = 0. - DO L = 1,LM - PTR2D = PTR2D + ( DQSDT_SC(:,:,L)+DQRDT_SC(:,:,L)+DQVDT_SC(:,:,L) & - + QLENT_SC(:,:,L)+QLSUB_SC(:,:,L)+QIENT_SC(:,:,L) & - + QISUB_SC(:,:,L) )*MASS(:,:,L) & - + QLDET_SC(:,:,L)+QIDET_SC(:,:,L) - END DO - end if - - call MAPL_GetPointer(EXPORT, PTR2D, 'SC_MSE', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) then - ! column integral of UW moist static energy tendency - PTR2D = 0. - DO L = 1,LM - PTR2D = PTR2D + (MAPL_CP * DTDT_SC(:,:,L) & - + MAPL_ALHL*DQVDT_SC(:,:,L) & - - MAPL_ALHF*DQIDT_SC(:,:,L))*MASS(:,:,L) - END DO - end if - - call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) - if (associated(PTR2D)) PTR2D = CUSH - - endif ! USE_PYMOIST_UW + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, JASON_MFD_SC, DETR_SC, UMF_SC, DP, MFD_SC, & + !$OMP DCM_SC, DQADT_SC, SCLM_SHALLOW, MASS, QLENT_SC, QLDET_SC, QIENT_SC, QIDET_SC) & + !$OMP PRIVATE(i, j, k) + do k = 1, LM + do j = 1, JM + !DIR$ IVDEP + do i = 1, IM + ! Calculate detrained mass flux + if (JASON_MFD_SC) then + if (DETR_SC(i,j,k) /= MAPL_UNDEF) then + MFD_SC(i,j,k) = 0.5 * (UMF_SC(i,j,k) + UMF_SC(i,j,k-1)) * DETR_SC(i,j,k) * DP(i,j,k) + else + MFD_SC(i,j,k) = 0.0 + end if + else + MFD_SC(i,j,k) = DCM_SC(i,j,k) + end if + + DQADT_SC(i,j,k) = MFD_SC(i,j,k) * SCLM_SHALLOW / MASS(i,j,k) + + ! Convert detrained water units before passing to cloud + QLENT_SC(i,j,k) = 0.0 + QIENT_SC(i,j,k) = 0.0 + + if (QLDET_SC(i,j,k) < 0.0) then + QLENT_SC(i,j,k) = QLDET_SC(i,j,k) + QLDET_SC(i,j,k) = 0.0 + end if + + if (QIDET_SC(i,j,k) < 0.0) then + QIENT_SC(i,j,k) = QIDET_SC(i,j,k) + QIDET_SC(i,j,k) = 0.0 + end if + + ! Scale the detrained fluxes before exporting + QLDET_SC(i,j,k) = QLDET_SC(i,j,k) * MASS(i,j,k) + QIDET_SC(i,j,k) = QIDET_SC(i,j,k) * MASS(i,j,k) + end do + end do + end do + !$OMP END PARALLEL DO + + ! 3. Whole-array copies for direct 3D variables + !-------------------------------------------------------------- + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_PRC3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = DQRDT_SC ! [kg/kg/s] + call MAPL_GetPointer(EXPORT, PTR3D, 'SHLW_SNO3', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) + if (associated(PTR3D)) PTR3D = DQSDT_SC ! [kg/kg/s] + call MAPL_GetPointer(EXPORT, PTR2D, 'CUSH_SC', RC=STATUS); VERIFY_(STATUS) + if (associated(PTR2D)) PTR2D = CUSH + + ! 4. Fused 2D Loop for Column Integrals + !-------------------------------------------------------------- + ! We parallelize over j,i and accumulate over k internally + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, SC_QT, SC_MSE, DQSDT_SC, DQRDT_SC, DQVDT_SC, & + !$OMP QLENT_SC, QLSUB_SC, QIENT_SC, QISUB_SC, MASS, QLDET_SC, QIDET_SC, & + !$OMP DTDT_SC, DQIDT_SC) & + !$OMP PRIVATE(i, j, k) + do j = 1, JM + do i = 1, IM + if (associated(SC_QT)) SC_QT(i,j) = 0.0 + if (associated(SC_MSE)) SC_MSE(i,j) = 0.0 + + do k = 1, LM + if (associated(SC_QT)) then + SC_QT(i,j) = SC_QT(i,j) + & + ( DQSDT_SC(i,j,k) + DQRDT_SC(i,j,k) + DQVDT_SC(i,j,k) + & + QLENT_SC(i,j,k) + QLSUB_SC(i,j,k) + QIENT_SC(i,j,k) + & + QISUB_SC(i,j,k) ) * MASS(i,j,k) + & + QLDET_SC(i,j,k) + QIDET_SC(i,j,k) + end if + + if (associated(SC_MSE)) then + SC_MSE(i,j) = SC_MSE(i,j) + & + ( MAPL_CP * DTDT_SC(i,j,k) + & + MAPL_ALHL * DQVDT_SC(i,j,k) - & + MAPL_ALHF * DQIDT_SC(i,j,k) ) * MASS(i,j,k) + end if + end do + end do + end do + !$OMP END PARALLEL DO endif - ! Apply tendencies + + ! 1. Fetch all pointers FIRST before doing any math !-------------------------------------------------------------- - Q = Q + DQVDT_SC * MOIST_DT - T = T + DTDT_SC * MOIST_DT - U = U + DUDT_SC * MOIST_DT - V = V + DVDT_SC * MOIST_DT - ! Tiedtke-style cloud fraction !! - CLCN = MAX(0.0, MIN(CLCN + DQADT_SC*MOIST_DT, 1.0)) - ! add detrained shallow convective ice/liquid source call MAPL_GetPointer(EXPORT, QLDET_SC, 'QLDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLCN = MAX(0.0, QLCN + QLDET_SC*MOIST_DT/MASS) call MAPL_GetPointer(EXPORT, QIDET_SC, 'QIDET_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QICN = MAX(0.0, QICN + QIDET_SC*MOIST_DT/MASS) - ! Apply condensate tendency from subsidence, and sink from - ! condensate entrained into shallow updraft. call MAPL_GetPointer(EXPORT, QLSUB_SC, 'QLSUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QLENT_SC, 'QLENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QLLS = MAX(0.0, QLLS + (QLSUB_SC+QLENT_SC)*MOIST_DT) call MAPL_GetPointer(EXPORT, QISUB_SC, 'QISUB_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT, QIENT_SC, 'QIENT_SC', ALLOC=.TRUE., RC=STATUS); VERIFY_(STATUS) - QILS = MAX(0.0, QILS + (QISUB_SC+QIENT_SC)*MOIST_DT) - DQLDT_SC = (QLLS + QLCN - DQLDT_SC) / MOIST_DT - DQIDT_SC = (QILS + QICN - DQIDT_SC) / MOIST_DT - + ! 2. Apply tendencies in a single fused loop with OpenMP + !-------------------------------------------------------------- + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(IM, JM, LM, Q, DQVDT_SC, MOIST_DT, T, DTDT_SC, U, DUDT_SC, V, DVDT_SC, & + !$OMP CLCN, DQADT_SC, QLCN, QLDET_SC, DQLDT_SC, MASS, QICN, QIDET_SC, DQIDT_SC, & + !$OMP QLLS, QLSUB_SC, QLENT_SC, QILS, QISUB_SC, QIENT_SC) & + !$OMP PRIVATE(i, j, k) + do k = 1, LM + do j = 1, JM + !DIR$ IVDEP + !DIR$ VECTOR ALWAYS + do i = 1, IM + ! Apply tendencies + Q(i,j,k) = Q(i,j,k) + DQVDT_SC(i,j,k) * MOIST_DT + T(i,j,k) = T(i,j,k) + DTDT_SC(i,j,k) * MOIST_DT + U(i,j,k) = U(i,j,k) + DUDT_SC(i,j,k) * MOIST_DT + V(i,j,k) = V(i,j,k) + DVDT_SC(i,j,k) * MOIST_DT + + ! Tiedtke-style cloud fraction + CLCN(i,j,k) = MAX(0.0, MIN(CLCN(i,j,k) + DQADT_SC(i,j,k)*MOIST_DT, 1.0)) + + ! Add detrained shallow convective ice/liquid source + QLCN(i,j,k) = MAX(0.0, QLCN(i,j,k) + QLDET_SC(i,j,k)*MOIST_DT/MASS(i,j,k)) + QICN(i,j,k) = MAX(0.0, QICN(i,j,k) + QIDET_SC(i,j,k)*MOIST_DT/MASS(i,j,k)) + + ! Apply condensate tendency from subsidence, and sink from + ! condensate entrained into shallow updraft. + QLLS(i,j,k) = MAX(0.0, QLLS(i,j,k) + (QLSUB_SC(i,j,k)+QLENT_SC(i,j,k))*MOIST_DT) + QILS(i,j,k) = MAX(0.0, QILS(i,j,k) + (QISUB_SC(i,j,k)+QIENT_SC(i,j,k))*MOIST_DT) + + ! Get export QL/QI tendencies + DQLDT_SC(i,j,k) = (QLLS(i,j,k) + QLCN(i,j,k) - DQLDT_SC(i,j,k)) / MOIST_DT + DQIDT_SC(i,j,k) = (QILS(i,j,k) + QICN(i,j,k) - DQIDT_SC(i,j,k)) / MOIST_DT + end do + end do + end do + !$OMP END PARALLEL DO + ! Cleanup negative water species ! ------------------------------ call MAPL_GetPointer(EXPORT, DQVDT_FILL, 'DQVDT_FILL_SC', RC=STATUS); VERIFY_(STATUS) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 index bf4bc89d78..41740f52e3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/Process_Library.F90 @@ -10,10 +10,8 @@ module GEOSmoist_Process_Library use ESMF use MAPL use GEOS_UtilsMod - !use Aer_Actv_Single_Moment - !use aer_cloud - USE module_mp_radar - + use GEOS_RadarMod + use module_mp_radar implicit none private @@ -37,38 +35,90 @@ module GEOSmoist_Process_Library end interface ICE_FRACTION ! SRF_TYPE constants - integer, parameter :: SRF_TYPE_LAND = 1 - integer, parameter :: SRF_TYPE_SNOW = 2 - integer, parameter :: SRF_TYPE_ICE = 3 - integer, parameter :: SRF_TYPE_OCEAN = 0 + integer, parameter :: SRF_TYPE_OCEAN = 0 + integer, parameter :: SRF_TYPE_LAND = 1 + integer, parameter :: SRF_TYPE_SNOW = 2 + integer, parameter :: SRF_TYPE_ICE = 3 + integer, parameter :: SRF_TYPE_LANDICE = 4 + + integer, parameter :: RAW_MODIS_POLYNOMIAL = 1 + integer, parameter :: JASON_ICE_POLYNOMIAL = 2 + integer, parameter :: V12_ICE_POLYNOMIAL = 3 + integer :: ICE_FRACTION_POLYNOMIAL = 3 ! ICE_FRACTION constants - logical :: constrain_modis_ice = .FALSE. - ! In anvil/convective clouds - real, parameter :: aT_ICE_ALL = 252.16 - real, parameter :: aT_ICE_MAX = 268.16 - real, parameter :: aICEFRPWR = 2.0 - ! Over snow SRF_TYPE = 2 and over ice SRF_TYPE = 3 - real, parameter :: iT_ICE_ALL = 236.16 - real, parameter :: iT_ICE_MAX = 261.16 - real, parameter :: iICEFRPWR = 5.0 - ! Over Land SRF_TYPE = 1 - real, parameter :: lT_ICE_ALL = 239.16 - real, parameter :: lT_ICE_MAX = 261.16 - real, parameter :: lICEFRPWR = 2.0 - ! Over Oceans SRF_TYPE = 0 - real, parameter :: oT_ICE_ALL = 238.16 - real, parameter :: oT_ICE_MAX = 263.16 - real, parameter :: oICEFRPWR = 4.0 - ! Jason + ! ========================================================================= + ! FINAL REVISED SURFACE-DEPENDENT CLOUD PHASE CONSTANTS (Bias-Corrected) + ! ========================================================================= + ! 1. Anvil / Convective Clouds (Deep updrafts, clean high-altitude cores) + ! Observations: High updraft velocity dynamically preserves liquid down to deep + ! temperatures. Freezing drops off exponentially close to homogeneous limit. + real, parameter :: aT_ICE_ALL = 233.16 ! Strict homogeneous limit (-40C) + real, parameter :: aT_ICE_MAX = 268.16 ! Latent heat maintains liquid until -5C + real, parameter :: aT_ICE_PWR = 4.5 ! Asymmetric S-curve to shield liquid peak + ! 2. Land Ice (Antarctica / Greenland) + ! Bias Fix: Widens mixed-phase window and raises PWR to fix the severe polar + ! downward LW deficit (-25 W/m²) and clear lower troposphere cold pools. + real, parameter :: liT_ICE_ALL = 234.16 ! Deep absolute freeze floor lowered to -39C + real, parameter :: liT_ICE_MAX = 268.15 ! Delays plateau glaciation onset to -5C + real, parameter :: liT_ICE_PWR = 4.2 ! Highly emissive summer liquid water shield + ! 3. Sea Ice (Arctic / Southern Ocean Pack Ice) + ! Bias Fix: Expands liquid window to restore thin supercooled liquid cloud tops. + ! Eliminates the MAM positive SW surface heating and matches vertical ERA5 QL mass. + real, parameter :: iT_ICE_ALL = 235.16 ! Lowers homogeneous floor to -38C + real, parameter :: iT_ICE_MAX = 271.15 ! Maintains warm liquid threshold near -2C + real, parameter :: iT_ICE_PWR = 4.5 ! High exponent shifts excess QI mass back to QL + ! 4. Snow Surface (High-latitude winter land) + ! Bias Fix: Shuts down spring continental shortwave overestimation and boundary + ! layer cold biases across snow-covered Siberia and northern boreal zones. + real, parameter :: sT_ICE_ALL = 236.16 ! Total freeze-out pushed down to -37C + real, parameter :: sT_ICE_MAX = 268.15 ! Delays land ice crystal production to -5C + real, parameter :: sT_ICE_PWR = 4.0 ! Stronger power curve guards spring liquid path + ! 5. Land (Ice-free, ice-nucleating aerosol rich) + ! Observations: Mineral and biological dust act as potent heterogeneous INPs. + ! Mixed-phase clouds glaciate rapidly and uniformly throughout the -10C to -25C zone. + real, parameter :: lT_ICE_ALL = 241.16 ! Dust forces total glaciation early at -32C + real, parameter :: lT_ICE_MAX = 266.16 ! Active INPs seed ice starting at -7C + real, parameter :: lT_ICE_PWR = 1.5 ! Near-linear transition curve clears liquid pooling + ! 6. Oceans (Open water, mid-to-high latitude marine boundary layers) + ! Bias Fix: Synchronized with Sea Ice limits to maintain high open-water marine + ! cloud optical depths, mitigating mid-latitude high-altitude liquid biases. + real, parameter :: oT_ICE_ALL = 235.16 ! Drops to 100% ice near -38C + real, parameter :: oT_ICE_MAX = 271.15 ! Highly liquid-dominated near 0C to -2C + real, parameter :: oT_ICE_PWR = 4.5 ! High power protects high marine LWP peak + + ! Jason constants ! In anvil/convective clouds real, parameter :: JaT_ICE_ALL = 245.16 real, parameter :: JaT_ICE_MAX = 261.16 - real, parameter :: JaICEFRPWR = 2.0 - ! Over snow/ice - real, parameter :: JiT_ICE_ALL = MAPL_TICE-40.0 - real, parameter :: JiT_ICE_MAX = MAPL_TICE - real, parameter :: JiICEFRPWR = 4.0 + real, parameter :: JaT_ICE_PWR = 2.0 + ! Over Land Ice SRF_TYPE == 4 + real, parameter :: JliT_ICE_ALL = 236.16 + real, parameter :: JliT_ICE_MAX = 261.16 + real, parameter :: JliT_ICE_PWR = 5.0 + ! Over Ice SRF_TYPE == 3 + real, parameter :: JiT_ICE_ALL = 236.16 + real, parameter :: JiT_ICE_MAX = 261.16 + real, parameter :: JiT_ICE_PWR = 5.0 + ! Over Snow SRF_TYPE = 2 + real, parameter :: JsT_ICE_ALL = 236.16 + real, parameter :: JsT_ICE_MAX = 261.16 + real, parameter :: JsT_ICE_PWR = 5.0 + ! Over Land SRF_TYPE = 1 + real, parameter :: JlT_ICE_ALL = 239.16 + real, parameter :: JlT_ICE_MAX = 261.16 + real, parameter :: JlT_ICE_PWR = 2.0 + ! Over Oceans SRF_TYPE = 0 + real, parameter :: JoT_ICE_ALL = 238.16 + real, parameter :: JoT_ICE_MAX = 263.16 + real, parameter :: JoT_ICE_PWR = 4.0 + + logical :: USE_BERGERON = .FALSE. + logical :: USE_AEROSOL_NN = .TRUE. + logical :: USE_NCLOUD_CLIM = .FALSE. + + integer :: WSUB_OPTION = -1 + integer :: PDFSHAPE = 1 ! parameters real, parameter :: EPSILON = MAPL_H2OMW/MAPL_AIRMW @@ -113,11 +163,16 @@ module GEOSmoist_Process_Library ! control for order of plumes logical :: SH_MD_DP = .FALSE. - ! Radar parameter + ! Radar parameters integer :: DBZ_VAR_INTERCP=2 ! use variable intercept parameters: 1 - on, 2 - snow boost, 3 - hail instead of graupel integer :: DBZ_LIQUID_SKIN=1 ! use liquid skin on snow(1) and graupel/hail(2) in warm environments - LOGICAL :: refl10cm_allow_wet_graupel = .false. - LOGICAL :: refl10cm_allow_wet_snow = .true. + logical :: refl10cm_allow_wet_graupel = .false. + logical :: refl10cm_allow_wet_snow = .true. + logical :: LIQUID_SKIN_SNOW = .false. + logical :: LIQUID_SKIN_GRAUPEL = .false. + logical :: LIQUID_SKIN_HAIL = .true. + real, PARAMETER :: W_START = 6.0 + real, PARAMETER :: W_FULL = 12.0 ! Thompson radar constants LOGICAL, PARAMETER:: iiwarm = .false. @@ -216,17 +271,12 @@ module GEOSmoist_Process_Library ! option for cloud liq/ice radii integer :: LIQ_RADII_PARAM = 1 integer :: ICE_RADII_PARAM = 1 - integer, parameter :: nsmx_par = 15 ! defined to determine CNV_FRACTION real :: CNV_FRACTION_MIN = 500.0 real :: CNV_FRACTION_MAX = 1500.0 real :: CNV_FRACTION_EXP = 1.0 - ! Storage of aerosol properties for activation - !type(AerPropsNew) :: AeroPropsNew(nsmx_par) - !type(AerProps), allocatable, dimension (:,:,:) :: AeroProps - ! Tracer Bundle things for convection type CNV_Tracer_Type real, pointer :: Q(:,:,:) => null() @@ -249,31 +299,12 @@ module GEOSmoist_Process_Library public :: DEBUG_TQ_ERRORS - type :: AerPropsNew - integer :: nmods ! total number of modes (nmods JaT_ICE_ALL) .AND. (TEMP <= JaT_ICE_MAX) ) then - ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JaT_ICE_ALL ) / ( JaT_ICE_MAX - JaT_ICE_ALL ) ) ) - end if - else - ICEFRCT_C = 0.00 - if ( TEMP <= aT_ICE_ALL ) then - ICEFRCT_C = 1.000 - else if ( (TEMP > aT_ICE_ALL) .AND. (TEMP <= aT_ICE_MAX) ) then - ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - aT_ICE_ALL ) / ( aT_ICE_MAX - aT_ICE_ALL ) ) ) - end if - end if - ICEFRCT_C = MIN(ICEFRCT_C,1.00) - ICEFRCT_C = MAX(ICEFRCT_C,0.00) - ICEFRCT_C = ICEFRCT_C**aICEFRPWR - ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 - select case (nint(SRF_TYPE)) - case (SRF_TYPE_SNOW, SRF_TYPE_ICE) - ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE == 3.0) - ICEFRCT_M = 0.00 - if ( TEMP <= iT_ICE_ALL ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > iT_ICE_ALL) .AND. (TEMP <= iT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - iT_ICE_ALL ) / ( iT_ICE_MAX - iT_ICE_ALL ) ) ) - end if - ICEFRCT_M = MIN(ICEFRCT_M,1.00) - ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**iICEFRPWR - case (SRF_TYPE_LAND) - ! Over Land (SRF_TYPE == 1) - ICEFRCT_M = 0.00 - if ( TEMP <= lT_ICE_ALL ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > lT_ICE_ALL) .AND. (TEMP <= lT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - lT_ICE_ALL ) / ( lT_ICE_MAX - lT_ICE_ALL ) ) ) - end if - ICEFRCT_M = MIN(ICEFRCT_M,1.00) - ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**lICEFRPWR - case (SRF_TYPE_OCEAN) - ! Over Oceans (SRF_TYPE == 0) - ICEFRCT_M = 0.00 - if ( TEMP <= oT_ICE_ALL ) then - ICEFRCT_M = 1.000 - else if ( (TEMP > oT_ICE_ALL) .AND. (TEMP <= oT_ICE_MAX) ) then - ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - oT_ICE_ALL ) / ( oT_ICE_MAX - oT_ICE_ALL ) ) ) - end if - ICEFRCT_M = MIN(ICEFRCT_M,1.00) - ICEFRCT_M = MAX(ICEFRCT_M,0.00) - ICEFRCT_M = ICEFRCT_M**oICEFRPWR - case default - ! You should not be here - print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE - error stop - end select - ! Combine the Convective and MODIS functions - ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) -#endif + select case (ICE_FRACTION_POLYNOMIAL) + case (RAW_MODIS_POLYNOMIAL) - if (constrain_modis_ice) then + ! Use MODIS polynomial from Hu et al, DOI: (10.1029/2009JD012384) + tc = MAX(-46.0,MIN(TEMP-MAPL_TICE,46.0)) ! convert to celcius and limit range from -46:46 C + ptc = 7.6725 + 1.0118*tc + 0.1422*tc**2 + 0.0106*tc**3 + 0.000339*tc**4 + 0.00000395*tc**5 + ICEFRCT = 1.0 - (1.0/(1.0 + exp(-1*ptc))) - ! ===================================================================== - ! NEW: Apply thermodynamic constraints - ! Ensures ice fraction doesn't violate physical laws while respecting - ! MODIS observations where physically reasonable - ! ===================================================================== - - ! Compute physics-based minimum ice fraction - ICEFRCT_PHYS = 0.0 + case (JASON_ICE_POLYNOMIAL) - if (TEMP < 235.0) then - ! Below -38°C: Homogeneous nucleation temperature - ! All supercooled liquid droplets freeze spontaneously - ! This is a thermodynamic law, not negotiable - ICEFRCT_PHYS = 1.0 - - elseif (TEMP < 238.0) then - ! -38°C to -35°C: Transition to 100% ice - ! Very rapid heterogeneous nucleation, essentially all ice - ICEFRCT_PHYS = 0.975 + 0.025 * (238.0 - TEMP) / 3.0 - - elseif (TEMP < 243.0) then - ! -35°C to -30°C: Should be 90-97.5% ice - ! Laboratory and aircraft observations show predominantly ice - ICEFRCT_PHYS = 0.90 + 0.075 * (243.0 - TEMP) / 5.0 - - elseif (TEMP < 248.0) then - ! -30°C to -25°C: Should be 80-90% ice - ! Mixed phase possible but ice dominant - ICEFRCT_PHYS = 0.80 + 0.10 * (248.0 - TEMP) / 5.0 - - elseif (TEMP < 253.0) then - ! -25°C to -20°C: Should be 65-80% ice - ! Active heterogeneous nucleation, ice favored - ICEFRCT_PHYS = 0.65 + 0.15 * (253.0 - TEMP) / 5.0 - - elseif (TEMP < 258.0) then - ! -20°C to -15°C: Should be 45-65% ice - ! True mixed phase regime - ICEFRCT_PHYS = 0.45 + 0.20 * (258.0 - TEMP) / 5.0 - - elseif (TEMP < 263.0) then - ! -15°C to -10°C: Should be 25-45% ice - ! Mixed phase, liquid becomes more common - ICEFRCT_PHYS = 0.25 + 0.20 * (263.0 - TEMP) / 5.0 - - elseif (TEMP < 268.0) then - ! -10°C to -5°C: Mixed phase, 10-25% ice - ! Supercooled liquid droplets stable - ICEFRCT_PHYS = 0.10 + 0.15 * (268.0 - TEMP) / 5.0 - - else - ! Above -5°C: MODIS parameterization is fine - ICEFRCT_PHYS = 0.0 - endif - - ! Take maximum of MODIS-based and physics-based ice fraction - ! This preserves MODIS accuracy where valid, applies constraints where needed - ICEFRCT = MAX(ICEFRCT, ICEFRCT_PHYS) - - endif + ! ------------------------------------------------------------------ + ! 1. Convective / Anvil Cloud Ice Fraction (ICEFRCT_C) + ! ------------------------------------------------------------------ + ICEFRCT_C = 0.00 + if ( TEMP <= JaT_ICE_ALL ) then + ICEFRCT_C = 1.000 + else if ( (TEMP > JaT_ICE_ALL) .AND. (TEMP <= JaT_ICE_MAX) ) then + ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JaT_ICE_ALL ) / ( JaT_ICE_MAX - JaT_ICE_ALL ) ) ) + end if + ICEFRCT_C = MIN(ICEFRCT_C,1.00) + ICEFRCT_C = MAX(ICEFRCT_C,0.00) + ICEFRCT_C = ICEFRCT_C**JaT_ICE_PWR + + ! ------------------------------------------------------------------ + ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) + ! ------------------------------------------------------------------ + ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 + select case (NINT(SRF_TYPE)) + case (SRF_TYPE_SNOW, SRF_TYPE_ICE, SRF_TYPE_LANDICE) + ! Over snow (SRF_TYPE == 2.0) and ice (SRF_TYPE >= 3.0) + ICEFRCT_M = 0.00 + if ( TEMP <= JiT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > JiT_ICE_ALL) .AND. (TEMP <= JiT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JiT_ICE_ALL ) / ( JiT_ICE_MAX - JiT_ICE_ALL ) ) ) + end if + ICEFRCT_M = MIN(ICEFRCT_M,1.00) + ICEFRCT_M = MAX(ICEFRCT_M,0.00) + ICEFRCT_M = ICEFRCT_M**JiT_ICE_PWR + case (SRF_TYPE_LAND) + ! Over Land (SRF_TYPE == 1) + ICEFRCT_M = 0.00 + if ( TEMP <= JlT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > JlT_ICE_ALL) .AND. (TEMP <= JlT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JlT_ICE_ALL ) / ( JlT_ICE_MAX - JlT_ICE_ALL ) ) ) + end if + ICEFRCT_M = MIN(ICEFRCT_M,1.00) + ICEFRCT_M = MAX(ICEFRCT_M,0.00) + ICEFRCT_M = ICEFRCT_M**JlT_ICE_PWR + case (SRF_TYPE_OCEAN) + ! Over Oceans (SRF_TYPE == 0) + ICEFRCT_M = 0.00 + if ( TEMP <= JoT_ICE_ALL ) then + ICEFRCT_M = 1.000 + else if ( (TEMP > JoT_ICE_ALL) .AND. (TEMP <= JoT_ICE_MAX) ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - JoT_ICE_ALL ) / ( JoT_ICE_MAX - JoT_ICE_ALL ) ) ) + end if + ICEFRCT_M = MIN(ICEFRCT_M,1.00) + ICEFRCT_M = MAX(ICEFRCT_M,0.00) + ICEFRCT_M = ICEFRCT_M**JoT_ICE_PWR + case default + ! You should not be here + print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE + error stop + end select + + ! Combine the Convective and Mesh functions + ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) + + case (V12_ICE_POLYNOMIAL) - ! Final bounds check - ICEFRCT = MIN(1.0, MAX(0.0, ICEFRCT)) + ! ------------------------------------------------------------------ + ! 1. Convective / Anvil Cloud Ice Fraction (ICEFRCT_C) + ! ------------------------------------------------------------------ + ICEFRCT_C = 0.00 + if ( TEMP <= aT_ICE_ALL ) then + ICEFRCT_C = 1.000 + else if ( TEMP <= aT_ICE_MAX ) then + ICEFRCT_C = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - aT_ICE_ALL ) / ( aT_ICE_MAX - aT_ICE_ALL ) ) ) + end if + ICEFRCT_C = MAX(0.00, MIN(1.00, ICEFRCT_C)) ** aT_ICE_PWR + + ! ------------------------------------------------------------------ + ! 2. Grid-Scale / Mesh Cloud Ice Fraction (ICEFRCT_M) + ! ------------------------------------------------------------------ + ! Select the correct constants based on surface type + select case (NINT(SRF_TYPE)) + case (SRF_TYPE_LANDICE) + t_all_loc = liT_ICE_ALL + t_max_loc = liT_ICE_MAX + pwr_loc = liT_ICE_PWR + case (SRF_TYPE_ICE) + t_all_loc = iT_ICE_ALL + t_max_loc = iT_ICE_MAX + pwr_loc = iT_ICE_PWR + case (SRF_TYPE_SNOW) + t_all_loc = sT_ICE_ALL + t_max_loc = sT_ICE_MAX + pwr_loc = sT_ICE_PWR + case (SRF_TYPE_LAND) + t_all_loc = lT_ICE_ALL + t_max_loc = lT_ICE_MAX + pwr_loc = lT_ICE_PWR + case (SRF_TYPE_OCEAN) + t_all_loc = oT_ICE_ALL + t_max_loc = oT_ICE_MAX + pwr_loc = oT_ICE_PWR + case default + ! You should not be here + print *, 'ICE_FRACTION_SC: Unknown SRF_TYPE = ',SRF_TYPE + error stop + end select + + ! Calculate ICEFRCT_M + ! Sigmoidal functions like figure 6b/6c of Hu et al 2010, doi:10.1029/2009JD012384 + ICEFRCT_M = 0.00 + if ( TEMP <= t_all_loc ) then + ICEFRCT_M = 1.000 + else if ( TEMP <= t_max_loc ) then + ICEFRCT_M = SIN( 0.5*MAPL_PI*( 1.00 - ( TEMP - t_all_loc ) / ( t_max_loc - t_all_loc ) ) ) + end if + ICEFRCT_M = MAX(0.00, MIN(1.00, ICEFRCT_M)) ** pwr_loc + + ! Combine the Convective and Mesh functions + ICEFRCT = ICEFRCT_M*(1.0-CNV_FRACTION) + ICEFRCT_C*(CNV_FRACTION) + + case default + ! You should not be here + print *, 'ICE_FRACTION_SC: Unknown ICE_FRACTION_POLYNOMIAL = ',ICE_FRACTION_POLYNOMIAL + error stop + end select + + ! Final bounds check + ICEFRCT = MIN(1.0, MAX(0.0, ICEFRCT)) end function ICE_FRACTION_SC @@ -2833,6 +2834,8 @@ subroutine hystpdf( & ! ======================================================================= ! PHASE 4: Finalization & Mapping back to Absolute Grid Box + ! Scale the environmental values back down to grid-box absolutes, + ! partition into ice/liquid, and update prognostic variables. ! ======================================================================= CLLS = cf_env * (1.0 - CLCN) @@ -3021,15 +3024,6 @@ subroutine Bergeron_Partition ( & if (q_tot_mass > 0.0) f_mass_ice = q_tot_ice / q_tot_mass n_ice_active = (1.0 - f_mass_ice) * n_ice - ! Handle completely glaciated or completely liquid regimes immediately - if (t_env >= iT_ICE_MAX) then ! Pure liquid cloud - f_ice = 0.0 - return - elseif (t_env <= iT_ICE_ALL) then ! Pure ice cloud - f_ice = 1.0 - return - end if - ! ======================================================================= ! PHASE 2: Mixed-Phase Regime & Deposition Physics ! Calculate how fast water vapor deposits onto existing ice crystals. @@ -3151,24 +3145,53 @@ end subroutine MELTFRZ_1D subroutine MELTFRZ_SC( DT, CNVFRC, SRFTYPE, TE, QL, QI ) real, intent(in ) :: DT, CNVFRC, SRFTYPE - real, intent(inout) :: TE,QL,QI - real :: fQi,dQil - integer :: K + real, intent(inout) :: TE, QL, QI + + real :: fQi, dQil, target_ice, target_melt, max_phase_change + real :: L_f + + ! Latent heat of fusion + L_f = MAPL_ALHS - MAPL_ALHL + if ( TE <= MAPL_TICE ) then - ! freeze liquid - fQi = ice_fraction( TE, CNVFRC, SRFTYPE ) - dQil = Ql *(1.0 - EXP( -DT * fQi / max(DT,taufrz) ) ) - dQil = max( 0., dQil ) - Qi = Qi + dQil - Ql = Ql - dQil - TE = TE + (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP + ! ------------------------------------------------------------- + ! FREEZING REGIME (TE <= TICE) + ! ------------------------------------------------------------- + + ! 1. Target ice deficit (new_ice_condensate) + fQi = ice_fraction( TE, CNVFRC, SRFTYPE ) + target_ice = min( max(0.0, fQi*(QL + QI) - QI), QL ) + + ! 2. Thermodynamic limit (prevent latent heating above freezing point) + max_phase_change = max( 0.0, (MAPL_TICE - TE) * MAPL_CP / L_f ) + + ! 3. Apply relaxation timescale (fQi is no longer in the exponent) + dQil = ( 1.0 - EXP( -DT / max(DT,taufrz) ) ) * min( target_ice, max_phase_change ) + + ! 4. Update states (liquid -> ice, temp warms) + Qi = Qi + dQil + Ql = Ql - dQil + TE = TE + (L_f * dQil) / MAPL_CP + else - ! melt ice above 0^C - dQil = -Qi *(1.0 - EXP( -DT / max(DT,taumlt) ) ) - dQil = min( 0., dQil ) - Qi = Qi + dQil - Ql = Ql - dQil - TE = TE + (MAPL_ALHS-MAPL_ALHL)*dQil/MAPL_CP + ! ------------------------------------------------------------- + ! MELTING REGIME (TE > TICE) + ! ------------------------------------------------------------- + + ! 1. Target melt (assuming 0% ice fraction above freezing) + target_melt = QI + + ! 2. Thermodynamic limit (prevent latent cooling below freezing point) + max_phase_change = max( 0.0, (TE - MAPL_TICE) * MAPL_CP / L_f ) + + ! 3. Apply relaxation timescale + dQil = ( 1.0 - EXP( -DT / max(DT,taumlt) ) ) * min( target_melt, max_phase_change ) + + ! 4. Update states (ice -> liquid, temp cools) + Qi = Qi - dQil + Ql = Ql + dQil + TE = TE - (L_f * dQil) / MAPL_CP + end if end subroutine MELTFRZ_SC @@ -3672,7 +3695,7 @@ function FIND_KLCL( T, Q, PL, IM, JM, LM ) result( KLCL ) end function FIND_KLCL function GET_LCL_AGL( T, Q, PL, Z, IM, JM, LM ) result( LCL_AGL ) - ! !DESCRIPTION: + ! !DESCRIPTION: ! Calculates the precise height of the Lifting Condensation Level (LCL) ! in meters Above Ground Level (AGL). @@ -4315,40 +4338,85 @@ subroutine FIX_NEGATIVE_PRECIP(QRAIN, QSNOW, QGRAUPEL) end subroutine FIX_NEGATIVE_PRECIP subroutine REDISTRIBUTE_CLOUDS_SCALAR(CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, QV, TE) - ! Note: Changed from dimension(:,:,:) to scalar inputs real, intent(inout) :: CF, QL, QI, CLCN, CLLS, QLCN, QLLS, QICN, QILS, QV, TE - - ! Liquid - QLLS = QLLS + (QL - (QLCN+QLLS)) - if (QLLS < 0.0) then - QLCN = max(0.0, QLCN + QLLS) - QLLS = 0.0 + + real :: QL_old, QI_old, CF_old + real :: f_cn + real, parameter :: epsilon = 1.0e-15 + + ! --------------------------------------------------------- + ! 1. Liquid Growth vs. Decay Redistribution + ! --------------------------------------------------------- + QL_old = QLCN + QLLS + if (QL < QL_old) then + ! DECAY: Microphysics consumed liquid. Reduce proportionally. + if (QL_old > epsilon) then + f_cn = QLCN / QL_old + QLCN = QL * f_cn + QLLS = QL * (1.0 - f_cn) + else + QLCN = 0.0 + QLLS = 0.0 + endif + else + ! GROWTH: Microphysics created new liquid. All new mass is Large-Scale. + ! QLCN remains unchanged + QLLS = QL - QLCN endif - ! Ice - QILS = QILS + (QI - (QICN+QILS)) - if (QILS < 0.0) then - QICN = max(0.0, QICN + QILS) - QILS = 0.0 + ! --------------------------------------------------------- + ! 2. Ice Growth vs. Decay Redistribution + ! --------------------------------------------------------- + QI_old = QICN + QILS + if (QI < QI_old) then + ! DECAY: Reduce proportionally + if (QI_old > epsilon) then + f_cn = QICN / QI_old + QICN = QI * f_cn + QILS = QI * (1.0 - f_cn) + else + QICN = 0.0 + QILS = 0.0 + endif + else + ! GROWTH: All new ice is Large-Scale + ! QICN remains unchanged + QILS = QI - QICN endif - ! Cloud - CLLS = min(1.0, CLLS + (CF - (CLCN+CLLS))) - if (CLLS < 0.0) then - CLCN = max(0.0, min(1.0, CLCN + CLLS)) - CLLS = 0.0 + ! --------------------------------------------------------- + ! 3. Cloud Fraction Growth vs. Decay Redistribution + ! --------------------------------------------------------- + CF_old = CLCN + CLLS + if (CF < CF_old) then + ! DECAY: Cloud fraction shrank. Reduce proportionally. + if (CF_old > epsilon) then + f_cn = CLCN / CF_old + CLCN = min(1.0, CF * f_cn) + CLLS = min(1.0, CF * (1.0 - f_cn)) + else + CLCN = 0.0 + CLLS = 0.0 + endif + else + ! GROWTH: Cloud expanded. Convective core stays its original size. + ! CLCN remains unchanged (bounded to CF just in case) + CLCN = min(CLCN, CF) + CLLS = min(1.0, CF - CLCN) endif - ! Evaporate/Sublimate liquid/ice where clouds are gone - if ( (CLLS == 0.0) .and. (QLLS+QILS > 0.0) ) then + ! --------------------------------------------------------- + ! 4. Clean up: Evaporate/Sublimate if clouds are completely gone + ! --------------------------------------------------------- + if ( (CLLS <= 0.0) .and. (QLLS+QILS > 0.0) ) then QV = QV + QLLS + QILS TE = TE - (alhlbcp)*QLLS - (alhsbcp)*QILS CLLS = 0.0 QLLS = 0.0 QILS = 0.0 endif - - if ( (CLCN == 0.0) .and. (QLCN+QICN > 0.0) ) then + + if ( (CLCN <= 0.0) .and. (QLCN+QICN > 0.0) ) then QV = QV + QLCN + QICN TE = TE - (alhlbcp)*QLCN - (alhsbcp)*QICN CLCN = 0.0 @@ -5362,4 +5430,184 @@ subroutine compute_sgs_vvel(IM,JM,LM,ZLE0,W,BYNCY, & end subroutine compute_sgs_vvel + subroutine compute_radar_diagnostics(EXPORT, clock, IM, JM, LM, & + Q, QRAIN, QSNOW, QGRAUPEL, T, PLmb, W, ZLE0, & + RC) + + implicit none + + ! --- Arguments --- + type(ESMF_State), intent(inout) :: EXPORT + type(ESMF_Clock), intent(in) :: clock + integer, intent(in) :: IM, JM, LM + real, intent(in) :: Q(IM,JM,LM), QRAIN(IM,JM,LM), QSNOW(IM,JM,LM) + real, intent(in) :: QGRAUPEL(IM,JM,LM), T(IM,JM,LM), PLmb(IM,JM,LM) + real, intent(in) :: W(IM,JM,LM), ZLE0(IM,JM,LM) + integer, intent(out) :: RC + + ! --- Local Variables --- + integer :: I, J, L, STATUS + type(ESMF_Alarm) :: alarm + logical :: alarm_is_ringing + real :: rand1, fraction_hail + + ! MAPL Export Pointers + real, pointer :: NACTR(:,:,:) + real, pointer :: PTR2D(:,:) + real, pointer :: DBZ(:,:,:) + real, pointer :: DBZ_MAX(:,:) + real, pointer :: DBZ_1KM(:,:) + real, pointer :: DBZ_TOP(:,:) + real, pointer :: DBZ_M10C(:,:) + + ! Temporary arrays + real, allocatable :: TMP3D(:,:,:) + real, allocatable :: TMP_NACTR(:,:,:) + real, allocatable :: DBZ3D(:,:,:) + + ! Automatic arrays for 1D columns (Thread-safe for OpenMP) + real :: qg_col(LM), qh_col(LM), prs_col(LM), dbz_col(LM) + + RC = ESMF_SUCCESS + STATUS = ESMF_SUCCESS + + ! Compute DBZ radar reflectivity + call ESMF_ClockGetAlarm(clock, 'DBZ_RunAlarm', alarm, RC=STATUS); VERIFY_(STATUS) + alarm_is_ringing = ESMF_AlarmIsRinging(alarm, RC=STATUS); VERIFY_(STATUS) + + call MAPL_GetPointer(EXPORT, NACTR, 'NACTR', RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, PTR2D, 'REFL10CM_MAX', RC=STATUS); VERIFY_(STATUS) + + ! 1. If the user explicitly requested NACTR export, fill it every time (or whenever needed) + if (associated(NACTR)) then + NACTR = 1.e8 * QRAIN**0.8 + endif + + ! 2. Handle the reflectivity alarm + if (alarm_is_ringing) then + call ESMF_AlarmRingerOff(alarm, RC=STATUS); VERIFY_(STATUS) + + ! Only compute if the user actually requested the reflectivity output + if (associated(PTR2D)) then + rand1 = 0.0 + + ALLOCATE(TMP3D(IM,JM,LM)) + TMP3D = 0.0 + + if (.not. associated(NACTR)) then + ALLOCATE ( TMP_NACTR(IM,JM,LM) ) + TMP_NACTR = 1.e8 * QRAIN**0.8 + endif + + DO J=1,JM ; DO I=1,IM + if (associated(NACTR)) then + call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + else + call calc_refl10cm(Q(I,J,:), QRAIN(I,J,:), TMP_NACTR(I,J,:), QSNOW(I,J,:), QGRAUPEL(I,J,:), & + T(I,J,:), 100*PLmb(I,J,:), TMP3D(I,J,:), rand1, 1, LM, I, J) + endif + END DO ; END DO + + if (.not. associated(NACTR)) DEALLOCATE ( TMP_NACTR ) + + PTR2D = -9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + PTR2D(I,J) = MAX(PTR2D(I,J),TMP3D(I,J,L)) + END DO ; END DO ; END DO + + DEALLOCATE(TMP3D) + endif + endif + + call MAPL_GetPointer(EXPORT, DBZ , 'DBZ' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_MAX , 'DBZ_MAX' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_1KM , 'DBZ_1KM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_TOP , 'DBZ_TOP' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT, DBZ_M10C, 'DBZ_M10C', RC=STATUS); VERIFY_(STATUS) + + if ( (associated(DBZ) .OR. & + associated(DBZ_MAX) .OR. associated(DBZ_1KM) .OR. associated(DBZ_TOP) .OR. associated(DBZ_M10C)) ) then + + ALLOCATE(DBZ3D(IM,JM,LM)) + + !$OMP parallel do default(none) & + !$OMP shared(IM, JM, LM, W, QGRAUPEL, PLmb, T, Q, QRAIN, QSNOW, DBZ3D, & + !$OMP DBZ_VAR_INTERCP, LIQUID_SKIN_SNOW, LIQUID_SKIN_GRAUPEL, LIQUID_SKIN_HAIL) & + !$OMP private(I, J, L, fraction_hail, qg_col, qh_col, prs_col, dbz_col) + DO J = 1, JM + DO I = 1, IM + ! 1. Prepare the 1D column data for this specific (I,J) location + DO L = 1, LM + fraction_hail = MAX(0.0, MIN(1.0, (W(I,J,L) - W_START) / (W_FULL - W_START))) + qh_col(L) = QGRAUPEL(I,J,L) * fraction_hail + qg_col(L) = QGRAUPEL(I,J,L) * (1.0 - fraction_hail) + prs_col(L) = 100.0 * PLmb(I,J,L) + END DO + + ! 2. Call the newly refactored 1D column function + dbz_col = compute_radar_reflectivity( & + PRS = prs_col, & + TMK = T(I,J,:), & + QVP = Q(I,J,:), & + QRAIN = QRAIN(I,J,:), & + QSNOW = QSNOW(I,J,:), & + QGRAUPEL = qg_col, & + QHAIL = qh_col, & + disable_variable_intercept_params = (DBZ_VAR_INTERCP == 0), & + liqskin_snow = LIQUID_SKIN_SNOW, & + liqskin_graupel = LIQUID_SKIN_GRAUPEL, & + liqskin_hail = LIQUID_SKIN_HAIL) + + ! 3. Store the returned column back into the 3D state + DO L = 1, LM + DBZ3D(I,J,L) = dbz_col(L) + END DO + END DO + END DO + + if (associated(DBZ)) DBZ(:,:,:) = DBZ3D(:,:,:) + + if (associated(DBZ_MAX)) then + DBZ_MAX=-9999.0 + DO L=1,LM ; DO J=1,JM ; DO I=1,IM + DBZ_MAX(I,J) = MAX(DBZ_MAX(I,J),DBZ3D(I,J,L)) + END DO ; END DO ; END DO + endif + + if (associated(DBZ_1KM)) then + call cs_interpolator(1, IM, 1, JM, LM, DBZ3D, 1000., ZLE0, DBZ_1KM, -20.) + endif + + if (associated(DBZ_TOP)) then + DBZ_TOP=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (DBZ3D(i,j,l) >= 18.5 ) then + DBZ_TOP(I,J) = ZLE0(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + if (associated(DBZ_M10C)) then + DBZ_M10C=MAPL_UNDEF + DO J=1,JM ; DO I=1,IM + DO L=LM,1,-1 + if (ZLE0(i,j,l) >= 25000.) continue + if (T(i,j,l) <= MAPL_TICE-10.0) then + DBZ_M10C(I,J) = DBZ3D(I,J,L) + exit + endif + END DO + END DO ; END DO + endif + + DEALLOCATE(DBZ3D) + end if + + end subroutine compute_radar_diagnostics + end module GEOSmoist_Process_Library diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 index 0dbad61a11..1eda4a339a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_actv_single_moment.F90 @@ -4,16 +4,17 @@ MODULE Aer_Actv_Single_Moment USE ESMF USE MAPL - USE GEOSmoist_Process_Library, only: AerPropsNew, AeroPropsNew + USE aer_cloud, only: AeroPropsNew !------------------------------------------------------------------------------------------------------------------------- IMPLICIT NONE - PUBLIC :: Aer_Activation, USE_BERGERON, USE_AEROSOL_NN, R_AIR + PUBLIC :: Aer_Activation + PUBLIC :: NN_MIN_LIQ, NN_MAX_LIQ + PUBLIC :: NN_MIN_ICE, NN_MAX_ICE PRIVATE ! Real kind for activation. - integer,public,parameter :: AER_PR = MAPL_R4 + integer, parameter :: AER_PR = MAPL_R4 - real , parameter :: R_AIR = 3.47e-3 !m3 Pa kg-1K-1 real(AER_PR), parameter :: ai = 0.0000594 real(AER_PR), parameter :: bi = 3.33 real(AER_PR), parameter :: ci = 0.0264 @@ -24,23 +25,23 @@ MODULE Aer_Actv_Single_Moment real(AER_PR), parameter :: deltai = 2.809e+3 real(AER_PR), parameter :: densic = 917.0 !Ice crystal density in kgm-3 - real, parameter :: NN_MIN = 100.0e6 - real, parameter :: NN_MAX = 500.0e6 + real :: NN_MIN_LIQ = 100.0e6 + real :: NN_MAX_LIQ = 500.0e6 + + real :: NN_MIN_ICE = 10.0e6 + real :: NN_MAX_ICE = 50.0e6 - LOGICAL :: USE_BERGERON = .FALSE. - LOGICAL :: USE_AEROSOL_NN = .TRUE. CONTAINS !>---------------------------------------------------------------------------------------------------------------------- !>---------------------------------------------------------------------------------------------------------------------- SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & - AeroPropsNew, aero_aci, NACTL, NACTI, NWFA, & + aero_aci, NACTL, NACTI, NWFA, & NN_LAND, NN_OCEAN, need_extra_fields, rc) IMPLICIT NONE type (MAPL_MetaComp), pointer :: MAPL integer, intent(in)::IM,JM,LM - TYPE(AerPropsNew), dimension (:), intent(inout) :: AeroPropsNew type(ESMF_State) ,intent(inout) :: aero_aci real, dimension (IM,JM,LM) ,intent(in ) :: plo ! Pa real, dimension (IM,JM,0:LM),intent(in ) :: ple ! Pa @@ -72,16 +73,6 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & NWFA = 0.0 - if (.not. USE_AEROSOL_NN) then - - do k = 1, LM - NACTL(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - NACTI(:,:,k) = NN_LAND*FRLAND + NN_OCEAN*(1.0-FRLAND) - end do - - RETURN_(ESMF_SUCCESS) - end if - call ESMF_AttributeGet(aero_aci, name='number_of_aerosol_modes', value=n_modes, __RC__) if (n_modes == 0) then @@ -161,9 +152,19 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & AeroPropsNew(n)%nmods = n_modes - where (AeroPropsNew(n)%kap > 0.4) - NWFA = NWFA + AeroPropsNew(n)%num - end where + ! Replace the slow 'where' construct with a threaded explicit loop + !$OMP parallel do default(none) & + !$OMP shared(IM, JM, LM, AeroPropsNew, n, NWFA) & + !$OMP private(i, j, k) + do k = 1, LM + do j = 1, JM + do i = 1, IM + if (AeroPropsNew(n)%kap(i,j,k) > 0.4) then + NWFA(i,j,k) = NWFA(i,j,k) + AeroPropsNew(n)%num(i,j,k) + endif + enddo + enddo + enddo end do ACTIVATION_PROPERTIES @@ -180,9 +181,11 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & allocate(bibar(IM,JM,n_modes), source=0.0, __STAT__) allocate( nact(IM,JM,n_modes), source=0.0, __STAT__) - !$OMP parallel do default(none) shared(IM,JM,LM,n_modes,T,plo,vvel,tke,MAPL_RGAS, & - !$OMP AeroPropsNew,NACTL,NACTI,NN_MIN,NN_MAX,ai,bi,ci,di) & - !$OMP private(k,n,tk,press,air_den,wupdraft,ni,rg,bibar,sig0,nact) + !$OMP parallel do default(none) & + !$OMP shared(IM, JM, LM, n_modes, T, plo, vvel, tke, AeroPropsNew, & + !$OMP NACTL, NACTI, NN_MIN_LIQ, NN_MAX_LIQ, NN_MIN_ICE, NN_MAX_ICE) & + !$OMP private(k, n, i, j, tk, press, air_den, wupdraft, ni, rg, bibar, & + !$OMP sig0, nact, numbinit) DO k=1,LM tk = T(:,:,k) ! K @@ -197,6 +200,8 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & bibar(:,:,n) = AeroPropsNew(n)%kap(:,:,k) sig0 (:,:,n) = AeroPropsNew(n)%sig(:,:,k) ENDDO + + ! Passed nact to ensure the private copy is populated call GetActFrac(IM*JM, n_modes & , ni(1,1,1) & , rg(1,1,1) & @@ -207,6 +212,7 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & ,wupdraft(1,1) & , nact(1,1,1) & ) + numbinit(:,:) = 0. NACTL(:,:,k) = 0. DO n=1,n_modes @@ -219,12 +225,14 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & ENDDO ENDDO ENDDO - numbinit = numbinit * air_den ! #/m3 + + ! Fused array multiplication into the existing loop for better cache performance DO j = 1, JM DO i = 1, IM + numbinit(i,j) = numbinit(i,j) * air_den(i,j) numbinit(i,j) = max(numbinit(i,j),0.0) NACTL(i,j,k) = MIN(NACTL(i,j,k),0.99*numbinit(i,j)) - NACTL(i,j,k) = MAX(MIN(NACTL(i,j,k),NN_MAX),NN_MIN) + NACTL(i,j,k) = MAX(MIN(NACTL(i,j,k),NN_MAX_LIQ),NN_MIN_LIQ) ENDDO ENDDO @@ -240,13 +248,22 @@ SUBROUTINE Aer_Activation(MAPL, IM,JM,LM, q, t, plo, ple, tke, vvel, FRLAND, & ENDDO ENDDO ENDDO - numbinit = numbinit * air_den ! #/m3 + + ! Optimized conditional calculation DO j = 1, JM DO i = 1, IM + numbinit(i,j) = numbinit(i,j) * air_den(i,j) numbinit(i,j) = max(numbinit(i,j),0.0) - ! Number of activated IN following deMott (2010) [#/m3] - NACTI(i,j,k) = (ai*(max(0.0,(MAPL_TICE-tk(i,j)))**bi)) * (numbinit(i,j)**(ci*max((MAPL_TICE-tk(i,j)),0.0)+di)) !#/m3 - NACTI(i,j,k) = MAX(MIN(NACTI(i,j,k),NN_MAX),NN_MIN) + + ! Only compute expensive exponents if cold enough AND aerosols exist + if (tk(i,j) < MAPL_TICE .and. numbinit(i,j) > 0.0) then + ! Number of activated IN following deMott (2010) [#/m3] + NACTI(i,j,k) = (ai*(max(0.0,(MAPL_TICE-tk(i,j)))**bi)) * (numbinit(i,j)**(ci*max((MAPL_TICE-tk(i,j)),0.0)+di)) + else + NACTI(i,j,k) = 0.0 + endif + + NACTI(i,j,k) = MAX(MIN(NACTI(i,j,k),NN_MAX_ICE),NN_MIN_ICE) ENDDO ENDDO diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 index 7a0d6dbffa..25a8222a62 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/aer_cloud.F90 @@ -13,7 +13,25 @@ MODULE aer_cloud implicit none private - + + integer, parameter :: nsmx_par = 20 !maximum number of modes allowed + integer, parameter :: npgauss = 10 + + ! Storage of aerosol properties for activation + type :: AerPropsNew + integer :: nmods ! total number of modes (nmods reduced to 0.5 * cpaut0 + ! Low inversion (fac_eis=0.0) -> stays at 1.0 * cpaut0 + cpaut = cpaut0 * (0.5 * fac_eis + 1.0 * (1.0 - fac_eis)) + ! 2. Threshold scaling based on Deep Instability (CAPE / cnv_fraction) + ! convective (cnv_fraction=1) -> rthreshu + ! stratiform (cnv_fraction=0) -> rthreshs + ! NOTE: Consider raising rthreshu from 7.0e-6 to 8.0e-6 or 8.5e-6 to help suppress ITCZ over-precipitation + fac_rc = rc * (rthreshu * cnv_fraction + rthreshs * (1.0 - cnv_fraction)) ** 3 ! ----------------------------------------------------------------------- ! conversion of temperature @@ -2593,24 +2598,44 @@ subroutine term_ice (ks, ke, tz, q, den, v_fac, v_min, v_max, const_v, vt) ! ----------------------------------------------------------- ! 1. Calculate Base Fall Speeds based on chosen formulation ! ----------------------------------------------------------- - if (ifflag .eq. 1) then - qden = q (k) * den (k) * 1.e3 - viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) - viCNV = 10.0**(log10(qden) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) - vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) - endif - - if (ifflag .eq. 2) then - qden = q (k) * den (k) - vt (k) = 3.29 * exp (0.16 * log (qden)) - endif - - if (ifflag .eq. 3) then - qden = q (k) * den (k) * 1.e3 - viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) - viCNV = MAX(10.0,(1.119*tc (k) + 14.21*log10(qden*1.e3) + 68.85)) - vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) - endif + select case (ifflag) + + case (1) + ! Pure Deng and Mace (2008) + qden = q (k) * den (k) * 1.e3 + viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + viCNV = 10.0**(log10(qden) * (tc (k) * (aaC * tc (k) + bbC) + ccC) + ddC * tc (k) + eeC) + vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) + + case (2) + ! Pure Heymsfield and Donner (1990) + qden = q (k) * den (k) + vt (k) = 3.29 * exp (0.16 * log (qden)) + + case (3) + ! Pure Mishra et al (2014, JGR) + qden = q (k) * den (k) * 1.e3 + ! Synoptic Vm: a=1.411, b=11.71, c=82.35 + viLSC = MAX(10.0, (1.411*tc (k) + 11.71*log10(qden*1.e3) + 82.35)) + ! Anvil Vm: a=1.119, b=14.21, c=68.85 + viCNV = MAX(10.0, (1.119*tc (k) + 14.21*log10(qden*1.e3) + 68.85)) + vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) + + case (4) + ! Combination: Deng & Mace (2008) LSC + Mishra et al (2014) Anvil CNV + qden = q (k) * den (k) * 1.e3 + viLSC = 10.0**(log10(qden) * (tc (k) * (aaL * tc (k) + bbL) + ccL) + ddL * tc (k) + eeL) + ! Anvil Vm: a=1.119, b=14.21, c=68.85 + viCNV = MAX(10.0, (1.119*tc (k) + 14.21*log10(qden*1.e3) + 68.85)) + vt (k) = 0.01 * (viLSC*(1.0-cnv_fraction) + viCNV*(cnv_fraction)) + + case default + ! Fail execution if an invalid flag is provided + print *, "ERROR: Invalid ifflag (", ifflag, ") provided for ice fall scheme." + print *, "Valid options are 1, 2, 3, or 4." + stop "Execution halted in ice settling code due to invalid ifflag." + + end select ! ----------------------------------------------------------- ! 2. Apply Universal Pressure Scaling (Accelerates high-alt ice) @@ -4224,8 +4249,16 @@ subroutine psacr_pgfr (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8 acc (3), acc (4), den (k)) endif - pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & - exp ((6 + mur) / (mur + 3) * log (6 * qr (k) * den (k))) + ! Homogeneous freezing threshold (e.g., -40 C) + if (tc .lt. -40.0) then + ! Colder than -40C: ALL liquid rain freezes instantaneously. + ! We set pgfr to consume all available qr. + pgfr = qr(k) + else + ! Warmer than -40C: Calculate probabilistic freezing normally. + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp ((6 + mur) / (mur + 3) * log (6 * qr (k) * den (k))) + endif ! --- Apply Mass and Thermal Limits --- sink = psacr + pgfr @@ -4893,6 +4926,7 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, real :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf + real :: snow_boost_mult real :: tau_wbf_eff real, parameter :: wbf_coarse_mult = 10.0 ! How much slower WBF is at 50km vs 2km @@ -4900,8 +4934,8 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, ! ------------------------------------------------------------------- ! Scale tau_wbf: - ! If onemsig = 1.0 (2km), tau_wbf_eff = tau_wbf * 1.0 - ! If onemsig = 0.0 (50km), tau_wbf_eff = tau_wbf * 10.0 + ! If onemsig = 1.0 (2km), tau_wbf_eff = tau_wbf + ! If onemsig = 0.0 (50km), tau_wbf_eff = tau_wbf * wbf_coarse_mult ! ------------------------------------------------------------------- tau_wbf_eff = tau_wbf * (wbf_coarse_mult * (1.0 - onemsig) + onemsig) @@ -4916,12 +4950,32 @@ subroutine pwbf (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den, qsw = wqs (tin, den (k), dqdt) qsi = iqs (tin, den (k), dqdt) - if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. qi (k) .gt. qcmin .and. & - qv (k) .gt. qsi .and. qv (k) .lt. qsw) then + ! heterogeneity and allow WBF to operate in large-scale updrafts + ! when the environment is supersaturated with respect to ice (qv > qsi) + ! and there is both liquid and ice present + ! Bypassed qi > qcmin constraint for colder temperatures to ensure initiation + if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. & + (qi (k) .gt. qcmin .or. tc .gt. 15.0) .and. & + qv (k) .gt. qsi) then + + ! 1. Homogeneous Freezing Limit (-40 C) + if (tc .ge. 40.0) then + sink = ql(k) + tmp = 0.0 ! All frozen liquid instantly becomes snow + else + ! Normal WBF probabilistic freezing + sink = min (fac_wbf * ql (k), tc / icpk (k)) + + ! 2. Temperature-Dependent Snow Boost + ! Scales from 1.0 (at 0 C) down to 0.0 (at -40 C) + ! As tc gets larger (colder), the multiplier shrinks, + ! reducing qim and forcing more mass to spill over into qs. + snow_boost_mult = max(0.0, 1.0 - (tc / 40.0)) + + qim = (pwbf_qi_crt * snow_boost_mult) / den (k) + tmp = min (sink, dim (qim, qi (k))) + endif - sink = min (fac_wbf * ql (k), tc / icpk (k)) - qim = pwbf_qi_crt / den (k) - tmp = min (sink, dim (qim, qi (k))) mppfw = mppfw + sink * dp (k) * convt call update_qt (qa (k), qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & @@ -4984,7 +5038,15 @@ subroutine pbigg (ks, ke, dts, qa, qv, ql, qr, qi, qs, qg, dp, tz, cvm, te8, den ccn (k) = ccn (k) / den (k) endif - sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 + ! Homogeneous freezing limit applied here + if (tc .ge. 40.0) then + ! Colder than -40C: ALL cloud liquid freezes instantaneously. + sink = ql(k) + else + ! Warmer than -40C: Calculate probabilistic Bigg freezing normally + sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 + endif + sink = min (ql (k), sink, tc / icpk (k)) mppfw = mppfw + sink * dp (k) * convt diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 index 412400954b..ca611b60c5 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSmoist_GridComp/uwshcu.F90 @@ -28,11 +28,10 @@ module uwshcu real :: rpen ! Penentrative entrainment factor real :: rle real :: rkfre ! fraction_of_tke_associated_with_vertical_velocity - real :: rkm ! Factor controlling lateral mixing rate - real :: mixscale ! Controls vertical structure of mixing real :: rkfre_hr ! fraction_of_tke_associated_with_vertical_velocity High Resolution + real :: rkm ! Factor controlling lateral mixing rate real :: rkm_hr ! Factor controlling lateral mixing rate High Resolution - real :: mixscale_hr ! Controls vertical structure of mixing High Resolution + real :: mixscale ! Controls vertical structure of mixing real :: detrhgt ! Mixing rate increases above this height real :: rmaxfrac ! Maximum core updraft fraction real :: rmaxfrac_hr ! Maximum core updraft fraction High Resolution @@ -86,7 +85,7 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT dp0_inv, u0_inv, v0_inv, qv0_inv, ql0_inv, qi0_inv, & t0_inv, tke_inv, rkfre, kpbl_inv, shfx,evap, cnvtr, frland, rkm2d, mix2d, rmaxfrac, & cush, & ! INOUT - umf_inv, dcm_inv, qvten_inv, tten_inv, & ! OUTPUT + umf_inv, dcm_inv, qvten_inv, qlten_inv, qiten_inv, tten_inv, & ! OUTPUT uten_inv, vten_inv, qrten_inv, qsten_inv, cufrc_inv, & fer_inv, fdr_inv, qldet_inv, qidet_inv, qlsub_inv, & qisub_inv, ndrop_inv, nice_inv, tpert_out, qpert_out, & @@ -136,10 +135,11 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT real, intent(out) :: umf_inv(idim,k0+1) ! Updraft mass flux at interfaces [kg/m2/s] real, intent(out) :: dcm_inv(idim,k0) ! Detrained cloudy air mass real, intent(out) :: qvten_inv(idim,k0) ! Tendency of water vapor specific humidity [ kg/kg/s ] + real, intent(out) :: qlten_inv(idim,k0) ! Tendency of liquid water specific humidity [ kg/kg/s ] + real, intent(out) :: qiten_inv(idim,k0) ! Tendency of ice specific humidity [ kg/kg/s ] real, intent(out) :: tten_inv(idim,k0) ! Tendency of temperature [ K/s ] real, intent(out) :: uten_inv(idim,k0) ! Tendency of zonal wind [ m/s2 ] real, intent(out) :: vten_inv(idim,k0) ! Tendency of meridional wind [ m/s2 ] -! real, intent(out) :: trten_inv(idim,k0,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ] real, intent(out) :: qrten_inv(idim,k0) ! Tendency of rain water specific humidity [ kg/kg/s ] real, intent(out) :: qsten_inv(idim,k0) ! Tendency of snow specific humidity [ kg/kg/s ] real, intent(out) :: cufrc_inv(idim,k0) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ] @@ -190,8 +190,6 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT #endif !----- Local variables ----- - real :: qlten_inv(idim,k0) ! Tendency of liquid water specific humidity [ kg/kg/s ] - real :: qiten_inv(idim,k0) ! Tendency of ice specific humidity [ kg/kg/s ] real :: pifc0(idim,0:k0) ! Environmental pressure at the interfaces [ Pa ] real :: zifc0(idim,0:k0) ! Environmental height at the interfaces [ m ] real :: exnifc0(idim,0:k0) ! Exner function on interfaces @@ -206,7 +204,7 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT real :: qi0(idim,k0) ! Environmental ice specific humidity [ kg/kg ] real :: th0(idim,k0) ! Environmental temperature [ K ] real :: tke(idim,0:k0) ! Turbulent kinetic energy [ m2 s-2 ] - real, allocatable :: tr0(:,:,:) ! Environmental tracers [ #, kg/kg ] + real, allocatable :: w_tr0(:,:) ! Environmental tracers [ #, kg/kg ] real :: umf(idim,0:k0) ! Updraft mass flux at the interfaces [ kg/m2/s ] real :: dcm(idim,k0) ! Detrained cloudy air mass real :: qvten(idim,k0) ! Tendency of water vapor specific humidity [ kg/kg/s ] @@ -235,30 +233,43 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT !--------- Local, Diagnostic only --------- #ifdef UWDIAG -! real :: trten(idim,k0,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ] - real :: qcu(idim,k0) ! Condensate water specific humidity within cumulus updraft + real :: w_qcu(idim,k0) ! Condensate water specific humidity within cumulus updraft ! at the layer mid-point [ kg/kg ] - real :: qlu(idim,k0) ! Liquid water specific humidity within cumulus updraft + real :: w_qlu(idim,k0) ! Liquid water specific humidity within cumulus updraft ! at the layer mid-point [ kg/kg ] - real :: qiu(idim,k0) ! Ice specific humidity within cumulus updraft + real :: w_qiu(idim,k0) ! Ice specific humidity within cumulus updraft ! at the layer mid-point [ kg/kg ] - real :: qc(idim,k0) ! Tendency of cumulus condensate detrained into the environment [ kg/kg/s ] - real :: cnt(idim) ! Cumulus top interface index, cnt = kpen [ no ] - real :: cnb(idim) ! Cumulus base interface index, cnb = krel - 1 [ no ] - real :: wu(idim,0:k0) - real :: qtu(idim,0:k0) - real :: thlu(idim,0:k0) - real :: thvu(idim,0:k0) - real :: uu(idim,0:k0) - real :: vu(idim,0:k0) - real :: xc(idim,k0) -! real :: trten_inv(idim,k0,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ] + real :: w_qc(idim,k0) ! Tendency of cumulus condensate detrained into the environment [ kg/kg/s ] + real :: w_cnt(idim) ! Cumulus top interface index, cnt = kpen [ no ] + real :: w_cnb(idim) ! Cumulus base interface index, cnb = krel - 1 [ no ] + real :: w_wu(idim,0:k0) + real :: w_qtu(idim,0:k0) + real :: w_thlu(idim,0:k0) + real :: w_thvu(idim,0:k0) + real :: w_uu(idim,0:k0) + real :: w_vu(idim,0:k0) + real :: w_xc(idim,k0) #endif - + ! Thread-private 1D workspaces + real :: w_pifc0(0:k0), w_zifc0(0:k0), w_exnifc0(0:k0), w_tke(0:k0) + real :: w_pmid0(1:k0), w_zmid0(1:k0), w_exnmid0(1:k0), w_dp0(1:k0) + real :: w_u0(1:k0), w_v0(1:k0), w_qv0(1:k0), w_ql0(1:k0), w_qi0(1:k0), w_th0(1:k0) + + real :: w_umf(0:k0), w_dcm(1:k0), w_qvten(1:k0), w_qlten(1:k0), w_qiten(1:k0) + real :: w_sten(1:k0), w_uten(1:k0), w_vten(1:k0), w_qrten(1:k0), w_qsten(1:k0) + real :: w_cufrc(1:k0), w_fer(1:k0), w_fdr(1:k0), w_qldet(1:k0), w_qidet(1:k0) + real :: w_qlsub(1:k0), w_qisub(1:k0), w_ndrop(1:k0), w_nice(1:k0) + real :: w_qtflx(0:k0), w_slflx(0:k0), w_uflx(0:k0), w_vflx(0:k0) + + ! Scalar workspaces + integer :: w_kpbl + real :: w_frland, w_rkfre, w_rkm2d, w_mix2d, w_rmaxfrac + real :: w_cush, w_shfx, w_evap, w_cnvtrmax, w_tpert, w_qpert + real :: w_cbmf, w_plcl, w_plfc, w_pinv, w_prel, w_pbup, w_cldtop !---------- Indices ----------- - integer :: i ! Horizontal index for local fields [ no ] + integer :: i, ii, jj ! Horizontal index for local fields [ no ] integer :: k ! Vertical index for local fields [ no ] integer :: k_inv ! Vertical index for incoming fields [ no ] integer :: m ! Tracer index [ no ] @@ -268,150 +279,226 @@ subroutine compute_uwshcu_inv(idim, k0, dt,pmid0_inv, & ! INPUT ncnst = size(CNV_Tracers) IM = size(CNV_Tracers(1)%Q,1) JM = size(CNV_Tracers(1)%Q,2) - allocate(tr0(idim,k0,ncnst)) - - ! flip mid-level variables - do k = 1, k0 - k_inv = k0 + 1 - k - pmid0(:idim,k) = pmid0_inv(:idim,k_inv) - u0(:idim,k) = u0_inv(:idim,k_inv) - v0(:idim,k) = v0_inv(:idim,k_inv) - zmid0(:idim,k) = zmid0_inv(:idim,k_inv) - exnmid0(:idim,k) = exnmid0_inv(:idim,k_inv) - dp0(:idim,k) = dp0_inv(:idim,k_inv) - qv0(:idim,k) = qv0_inv(:idim,k_inv) - ql0(:idim,k) = ql0_inv(:idim,k_inv) - qi0(:idim,k) = qi0_inv(:idim,k_inv) - th0(:idim,k) = t0_inv(:idim,k_inv)/exnmid0_inv(:idim,k_inv) - do m = 1, ncnst - tr0(:idim,k,m) = reshape(CNV_Tracers(m)%Q(:,:,k_inv), (/idim/)) - enddo - enddo - - ! flip interface variables - tke(:,:) = 0. - pifc0(:,:) = 0. - zifc0(:,:) = 0. - exnifc0(:,:) = 0. - do k = 0, k0 - k_inv = k0 - k + 1 - tke(:idim,k) = tke_inv(:idim,k_inv) - pifc0(:idim,k) = pifc0_inv(:idim,k_inv) - zifc0(:idim,k) = zifc0_inv(:idim,k_inv) - exnifc0(:idim,k) = exnifc0_inv(:idim,k_inv) - end do - - kpbl = int(kpbl_inv) - - do i = 1,idim -! cnvtrmax(i) = min(300.,max(0.,maxval(cnvtr(i,:)))) - cnvtrmax(i) = min(1e-5,max(0.,cnvtr(i))) - if (frland(i)>0.5) cnvtrmax(i) = 0. - if (isnan(cnvtrmax(i))) cnvtrmax(i) = 0. - end do - - call compute_uwshcu( idim,k0, dt, ncnst,pifc0, zifc0, & - exnifc0, pmid0, zmid0, exnmid0, dp0, u0, v0, & - qv0, ql0, qi0, th0, tr0, kpbl, frland, tke, rkfre, rkm2d, mix2d, rmaxfrac, & - cush, umf, & - dcm, qvten, qlten, qiten, sten, uten, vten, & - qrten, qsten, cufrc, fer, fdr, qldet, qidet, & - qlsub, qisub, ndrop, nice, & - shfx, evap, cnvtrmax, tpert_out, qpert_out, & - qtflx, slflx, uflx, vflx, & - cbmf, plcl, plfc, pinv, prel, pbup, cldtop, & ! Diagnostic only + allocate(w_tr0(k0, ncnst)) + + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(idim, k0, dt, ncnst, IM, JM, dotransport, & + !$OMP pifc0_inv, zifc0_inv, exnifc0_inv, pmid0_inv, zmid0_inv, & + !$OMP exnmid0_inv, dp0_inv, u0_inv, v0_inv, qv0_inv, ql0_inv, & + !$OMP qi0_inv, t0_inv, tke_inv, rkfre, kpbl_inv, shfx, evap, & + !$OMP cnvtr, frland, rkm2d, mix2d, rmaxfrac, cush, umf_inv, & + !$OMP dcm_inv, qvten_inv, qlten_inv, qiten_inv, tten_inv, & + !$OMP uten_inv, vten_inv, qrten_inv, qsten_inv, cufrc_inv, & + !$OMP fer_inv, fdr_inv, qldet_inv, qidet_inv, qlsub_inv, & + !$OMP qisub_inv, ndrop_inv, nice_inv, tpert_out, qpert_out, & + !$OMP qtflx_inv, slflx_inv, uflx_inv, vflx_inv, cbmf, plcl, & + !$OMP plfc, pinv, prel, pbup, cldtop, CNV_Tracers & #ifdef UWDIAG - qcu, qlu, qiu, qc, cnt, cnb, cin, wlcl, qtsrc, & - thlsrc, thvlsrc, tkeavg, wu, qtu, & - thlu, thvu, uu, vu, xc, & ! trten, & + !$OMP , qcu_inv, qlu_inv, qiu_inv, qc_inv, cnt_inv, cnb_inv, & + !$OMP cin, wlcl, qtsrc, thlsrc, thvlsrc, tkeavg, wu_inv, & + !$OMP qtu_inv, thlu_inv, thvu_inv, uu_inv, vu_inv, xc_inv & #endif - dotransport ) - - ! Reverse again - + !$OMP ) & + !$OMP PRIVATE(i, ii, jj, k, k_inv, m, w_kpbl, w_frland, w_rkfre, w_rkm2d, & + !$OMP w_mix2d, w_rmaxfrac, w_cush, w_shfx, w_evap, w_cnvtrmax, w_tpert, & + !$OMP w_qpert, w_pifc0, w_zifc0, w_exnifc0, w_pmid0, w_zmid0, w_exnmid0, & + !$OMP w_dp0, w_u0, w_v0, w_qv0, w_ql0, w_qi0, w_th0, w_tke, w_tr0, w_umf, & + !$OMP w_dcm, w_qvten, w_qlten, w_qiten, w_sten, w_uten, w_vten, w_qrten, & + !$OMP w_qsten, w_cufrc, w_fer, w_fdr, w_qldet, w_qidet, w_qlsub, w_qisub, & + !$OMP w_ndrop, w_nice, w_qtflx, w_slflx, w_uflx, w_vflx, w_cbmf, w_plcl, & + !$OMP w_plfc, w_pinv, w_prel, w_pbup, w_cldtop & #ifdef UWDIAG - cnt_inv(:idim) = k0 + 1 - cnt(:idim) - cnb_inv(:idim) = k0 + 1 - cnb(:idim) + !$OMP , w_qcu, w_qlu, w_qiu, w_qc, w_cnt, w_cnb, w_cin, w_wlcl, & + !$OMP w_qtsrc, w_thlsrc, w_thvlsrc, w_tkeavg, w_wu, w_qtu, & + !$OMP w_thlu, w_thvu, w_uu, w_vu, w_xc & #endif + !$OMP ) + do i = 1, idim + + ! Calculate 2D grid coordinates from 1D flat index + ii = mod(i - 1, IM) + 1 + jj = (i - 1) / IM + 1 + + ! 1. Setup 1D Scalars for this column + w_cnvtrmax = min(1e-5, max(0.0, cnvtr(i))) + if (frland(i) > 0.5) w_cnvtrmax = 0.0 + if (isnan(w_cnvtrmax)) w_cnvtrmax = 0.0 + + w_kpbl = int(kpbl_inv(i)) + w_frland = frland(i) + w_rkfre = rkfre(i) + w_rkm2d = rkm2d(i) + w_mix2d = mix2d(i) + w_rmaxfrac = rmaxfrac(i) + w_cush = cush(i) + w_shfx = shfx(i) + w_evap = evap(i) + + ! 2. Load and flip the column into cache + do k = 1, k0 + k_inv = k0 + 1 - k + w_pmid0(k) = pmid0_inv(i,k_inv) + w_zmid0(k) = zmid0_inv(i,k_inv) + w_exnmid0(k) = exnmid0_inv(i,k_inv) + w_dp0(k) = dp0_inv(i,k_inv) + w_u0(k) = u0_inv(i,k_inv) + w_v0(k) = v0_inv(i,k_inv) + w_qv0(k) = qv0_inv(i,k_inv) + w_ql0(k) = ql0_inv(i,k_inv) + w_qi0(k) = qi0_inv(i,k_inv) + w_th0(k) = t0_inv(i,k_inv) / exnmid0_inv(i,k_inv) + ! Load Tracers directly without RESHAPE! + do m = 1, ncnst + w_tr0(k,m) = CNV_Tracers(m)%Q(ii,jj,k_inv) + end do + end do + + do k = 0, k0 + k_inv = k0 - k + 1 + w_tke(k) = tke_inv(i,k_inv) + w_pifc0(k) = pifc0_inv(i,k_inv) + w_zifc0(k) = zifc0_inv(i,k_inv) + w_exnifc0(k) = exnifc0_inv(i,k_inv) + end do - do k = 0, k0 - k_inv = k0 + 1 - k - umf_inv(:idim,k_inv) = umf(:idim,k) - qtflx_inv(:idim,k_inv) = qtflx(:idim,k) - slflx_inv(:idim,k_inv) = slflx(:idim,k) - uflx_inv(:idim,k_inv) = uflx(:idim,k) - vflx_inv(:idim,k_inv) = vflx(:idim,k) - + ! 3. Call physics WITHOUT the 'idim' argument + call compute_uwshcu( k0, dt, ncnst, w_pifc0, w_zifc0, & + w_exnifc0, w_pmid0, w_zmid0, w_exnmid0, w_dp0, w_u0, w_v0, & + w_qv0, w_ql0, w_qi0, w_th0, w_tr0, w_kpbl, w_frland, w_tke, & + w_rkfre, w_rkm2d, w_mix2d, w_rmaxfrac, w_cush, w_umf, & + w_dcm, w_qvten, w_qlten, w_qiten, w_sten, w_uten, w_vten, & + w_qrten, w_qsten, w_cufrc, w_fer, w_fdr, w_qldet, w_qidet, & + w_qlsub, w_qisub, w_ndrop, w_nice, w_shfx, w_evap, w_cnvtrmax, & + w_tpert, w_qpert, w_qtflx, w_slflx, w_uflx, w_vflx, & + w_cbmf, w_plcl, w_plfc, w_pinv, w_prel, w_pbup, w_cldtop, & #ifdef UWDIAG - wu_inv(:idim,k_inv) = wu(:idim,k) ! Diagnostic only - qtu_inv(:idim,k_inv) = qtu(:idim,k) - thlu_inv(:idim,k_inv) = thlu(:idim,k) - thvu_inv(:idim,k_inv) = thvu(:idim,k) - uu_inv(:idim,k_inv) = uu(:idim,k) - vu_inv(:idim,k_inv) = vu(:idim,k) + w_qcu, w_qlu, w_qiu, w_qc, w_cnt, w_cnb, w_cin, w_wlcl, w_qtsrc, & + w_thlsrc, w_thvlsrc, w_tkeavg, w_wu, w_qtu, & + w_thlu, w_thvu, w_uu, w_vu, w_xc, & #endif - end do + dotransport ) + + ! 4. Unflip and store results back to _inv arrays + cush(i) = w_cush + tpert_out(i) = w_tpert + qpert_out(i) = w_qpert + + ! Add diagnostic scalars here + cbmf(i) = w_cbmf + plcl(i) = w_plcl + plfc(i) = w_plfc + pinv(i) = w_pinv + prel(i) = w_prel + pbup(i) = w_pbup + cldtop(i) = w_cldtop + + do k = 1, k0 + k_inv = k0 + 1 - k + dcm_inv(i,k_inv) = w_dcm(k) + qvten_inv(i,k_inv) = w_qvten(k) + qlten_inv(i,k_inv) = w_qlten(k) + qiten_inv(i,k_inv) = w_qiten(k) + tten_inv(i,k_inv) = w_sten(k) / cp + uten_inv(i,k_inv) = w_uten(k) + vten_inv(i,k_inv) = w_vten(k) + qrten_inv(i,k_inv) = w_qrten(k) + qsten_inv(i,k_inv) = w_qsten(k) + cufrc_inv(i,k_inv) = w_cufrc(k) + fer_inv(i,k_inv) = w_fer(k) + fdr_inv(i,k_inv) = w_fdr(k) + qldet_inv(i,k_inv) = w_qldet(k) + qidet_inv(i,k_inv) = w_qidet(k) + qlsub_inv(i,k_inv) = w_qlsub(k) + qisub_inv(i,k_inv) = w_qisub(k) + ndrop_inv(i,k_inv) = w_ndrop(k) + nice_inv(i,k_inv) = w_nice(k) + + ! Store Tracers directly without RESHAPE! + if (dotransport == 1) then + do m = 1, ncnst + w_tr0(k,m) = MAX(mintracer, w_tr0(k,m)) + CNV_Tracers(m)%Q(ii,jj,k_inv) = w_tr0(k,m) + end do + end if + end do + + do k = 0, k0 + k_inv = k0 + 1 - k + umf_inv(i,k_inv) = w_umf(k) + qtflx_inv(i,k_inv) = w_qtflx(k) + slflx_inv(i,k_inv) = w_slflx(k) + uflx_inv(i,k_inv) = w_uflx(k) + vflx_inv(i,k_inv) = w_vflx(k) + end do + + dcm_inv(i,k0) = 0.0 - do k = 1, k0 - k_inv = k0 + 1 - k - dcm_inv(:idim,k_inv) = dcm(:idim,k) - qvten_inv(:idim,k_inv) = qvten(:idim,k) - qlten_inv(:idim,k_inv) = qlten(:idim,k) - qiten_inv(:idim,k_inv) = qiten(:idim,k) - tten_inv(:idim,k_inv) = sten(:idim,k) / cp - uten_inv(:idim,k_inv) = uten(:idim,k) - vten_inv(:idim,k_inv) = vten(:idim,k) - qrten_inv(:idim,k_inv) = qrten(:idim,k) - qsten_inv(:idim,k_inv) = qsten(:idim,k) - cufrc_inv(:idim,k_inv) = cufrc(:idim,k) - fer_inv(:idim,k_inv) = fer(:idim,k) - fdr_inv(:idim,k_inv) = fdr(:idim,k) - qldet_inv(:idim,k_inv) = qldet(:idim,k) - qidet_inv(:idim,k_inv) = qidet(:idim,k) - qlsub_inv(:idim,k_inv) = qlsub(:idim,k) - qisub_inv(:idim,k_inv) = qisub(:idim,k) - ndrop_inv(:idim,k_inv) = ndrop(:idim,k) - nice_inv(:idim,k_inv) = nice(:idim,k) -#ifdef UWDIAG - qcu_inv(:idim,k_inv) = qcu(:idim,k) ! Diagnostic only - qlu_inv(:idim,k_inv) = qlu(:idim,k) - qiu_inv(:idim,k_inv) = qiu(:idim,k) - qc_inv(:idim,k_inv) = qc(:idim,k) - xc_inv(:idim,k_inv) = xc(:idim,k) -#endif - if (dotransport.eq.1) then - do m = 1, ncnst - do i=1,idim - tr0(i,k,m) = MAX(mintracer,tr0(i,k,m)) - enddo - CNV_Tracers(m)%Q(:,:,k_inv) = reshape(tr0(:,k,m), (/IM,JM/)) #ifdef UWDIAG -! trten_inv(:idim,k_inv,m) = trten(:idim,k,m) + cnt_inv(i) = k0 + 1 - w_cnt(i) + cnb_inv(i) = k0 + 1 - w_cnb(i) + + cin(i) = w_cin + wlcl(i) = w_wlcl + qtsrc(i) = w_qtsrc + thlsrc(i) = w_thlsrc + thvlsrc(i) = w_thvlsrc + tkeavg(i) = w_tkeavg + + do k = 0, k0 + k_inv = k0 + 1 - k + wu_inv(i,k_inv) = w_wu(k) + qtu_inv(i,k_inv) = w_qtu(k) + thlu_inv(i,k_inv) = w_thlu(k) + thvu_inv(i,k_inv) = w_thvu(k) + uu_inv(i,k_inv) = w_uu(k) + vu_inv(i,k_inv) = w_vu(k) + end do + + do k = 1, k0 + k_inv = k0 + 1 - k + qcu_inv(i,k_inv) = w_qcu(k) ! Diagnostic only + qlu_inv(i,k_inv) = w_qlu(k) + qiu_inv(i,k_inv) = w_qiu(k) + qc_inv(i,k_inv) = w_qc(k) + xc_inv(i,k_inv) = w_xc(k) + end do #endif - enddo - endif + end do - dcm_inv(:idim,k0) = 0. + !$OMP END PARALLEL DO + ! Re-scale liquid/ice water sub-tendencies to enforce conservation - where(ABS(qldet_inv+qlsub_inv).gt.1e-12) - tmp2d = qlten_inv / (qldet_inv+qlsub_inv) - qldet_inv = tmp2d*qldet_inv - qlsub_inv = tmp2d*qlsub_inv - end where - where(ABS(qidet_inv+qisub_inv).gt.1e-12) - tmp2d = qiten_inv / (qidet_inv+qisub_inv) - qidet_inv = tmp2d*qidet_inv - qisub_inv = tmp2d*qisub_inv - end where + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP SHARED(k0, idim, qldet_inv, qlsub_inv, qlten_inv, qidet_inv, & + !$OMP qisub_inv, qiten_inv, tmp2d) & + !$OMP PRIVATE(i, k) + do k = 1, k0 + !DIR$ IVDEP + do i = 1, idim + ! Liquid + if (abs(qldet_inv(i,k) + qlsub_inv(i,k)) > 1e-12) then + tmp2d(i,k) = qlten_inv(i,k) / (qldet_inv(i,k) + qlsub_inv(i,k)) + qldet_inv(i,k) = tmp2d(i,k) * qldet_inv(i,k) + qlsub_inv(i,k) = tmp2d(i,k) * qlsub_inv(i,k) + end if + ! Ice + if (abs(qidet_inv(i,k) + qisub_inv(i,k)) > 1e-12) then + tmp2d(i,k) = qiten_inv(i,k) / (qidet_inv(i,k) + qisub_inv(i,k)) + qidet_inv(i,k) = tmp2d(i,k) * qidet_inv(i,k) + qisub_inv(i,k) = tmp2d(i,k) * qisub_inv(i,k) + end if + end do + end do + !$OMP END PARALLEL DO end subroutine compute_uwshcu_inv - subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN - exnifc0_in, pmid0_in, zmid0_in, exnmid0_in, dp0_in, & - u0_in, v0_in, qv0_in, ql0_in, qi0_in, th0_in, & - tr0_inout, kpbl_in, frland_in, tke_in, rkfre, rkm2d, mix2d, rmaxfrac, & - cush_inout, & ! OUT + subroutine compute_uwshcu(k0, dt,ncnst, pifc0,zifc0,& ! IN + exnifc0, pmid0, zmid0, exnmid0, dp0, & + u0, v0, qv0, ql0, qi0, th0, & + tr0, kpbl, frland, tke, rkfre, rkm2d, mix2d, rmaxfrac, & + cush_inout, & ! INOUT umf_out, dcm_out, qvten_out, qlten_out, qiten_out, & sten_out, uten_out, vten_out, qrten_out, & qsten_out, cufrc_out, fer_out, fdr_out, qldet_out, & @@ -451,122 +538,97 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ! ! ------------------------------------------------------------ ! - integer, intent(in) :: idim ! Number of columns integer, intent(in) :: k0 ! Number of vertical levels integer, intent(in) :: ncnst ! Number of tracers integer, intent(in) :: dotransport ! Transport tracers [1 true] real, intent(in) :: dt ! Timestep [s] - real, intent(in) :: pifc0_in( idim,0:k0 ) ! Environmental pressure at interfaces [Pa] - real, intent(in) :: zifc0_in( idim,0:k0 ) ! Environmental height at interfaces [m] - real, intent(in) :: exnifc0_in( idim,0:k0 ) ! Exner function at interfaces - real, intent(in) :: pmid0_in( idim,k0 ) ! Environmental pressure at midpoints [Pa] - real, intent(in) :: zmid0_in( idim,k0 ) ! Environmental height at midpoints [m] - real, intent(in) :: exnmid0_in( idim,k0 ) ! Exner function at midpoints - real, intent(in) :: dp0_in( idim,k0 ) ! Environmental layer pressure thickness - real, intent(in) :: u0_in ( idim,k0 ) ! Environmental zonal wind [m/s] - real, intent(in) :: v0_in ( idim,k0 ) ! Environmental meridional wind [m/s] - real, intent(in) :: qv0_in( idim,k0 ) ! Environmental specific humidity - real, intent(in) :: ql0_in( idim,k0 ) ! Environmental liquid water specific humidity - real, intent(in) :: qi0_in( idim,k0 ) ! Environmental ice specific humidity - real, intent(in) :: th0_in( idim,k0 ) ! Environmental potential temperature [K] - real, intent(in) :: tke_in( idim,0:k0 ) ! Turbulent kinetic energy at interfaces - real, intent(in) :: rkfre(idim) ! Resolution dependent Vertical velocity variance as fraction of tke. - real, intent(in) :: rkm2d(idim) ! Resolution dependent lateral mixing parameter - real, intent(in) :: mix2d(idim) ! Resolution dependent lateral mixing depth - real, intent(in) :: rmaxfrac(idim) ! Resolution dependent Maximum core updraft fraction - real, intent(in) :: shfx(idim) ! Surface sensible heat - real, intent(in) :: evap(idim) ! Surface evaporation - real, intent(in) :: cnvtr(idim) ! Convective tracer - real, intent(out) :: tpert_out(idim) ! Temperature perturbation - real, intent(out) :: qpert_out(idim) ! Humidity perturbation - real, intent(out) :: qtflx_out(idim, 0:k0 ) - real, intent(out) :: slflx_out(idim, 0:k0 ) - real, intent(out) :: uflx_out(idim, 0:k0 ) - real, intent(out) :: vflx_out(idim, 0:k0 ) - integer, intent(in) :: kpbl_in( idim ) ! Boundary layer top layer index - real, intent(in) :: frland_in( idim ) ! fraction of and in grid cell - - real, intent(inout) :: cush_inout( idim ) ! Convective scale height [m] - real, intent(inout) :: tr0_inout(idim,k0,ncnst) ! Environmental tracers [ #, kg/kg ] - - real, intent(out) :: umf_out(idim,0:k0) ! Updraft mass flux at the interfaces [ kg/m2/s ] - real, intent(out) :: dcm_out(idim,k0) ! Detrained cloudy air mass - real, intent(out) :: qvten_out(idim,k0) ! Tendency of water vapor specific humidity [ kg/kg/s ] - real, intent(out) :: qlten_out(idim,k0) ! Tendency of liquid water specific humidity [ kg/kg/s ] - real, intent(out) :: qiten_out(idim,k0) ! Tendency of ice specific humidity [ kg/kg/s ] - real, intent(out) :: sten_out(idim,k0) ! Tendency of dry static energy [ J/kg/s ] - real, intent(out) :: uten_out(idim,k0) ! Tendency of zonal wind [ m/s2 ] - real, intent(out) :: vten_out(idim,k0) ! Tendency of meridional wind [ m/s2 ] - real, intent(out) :: qrten_out(idim,k0) ! Tendency of rain water specific humidity [ kg/kg/s ] - real, intent(out) :: qsten_out(idim,k0) ! Tendency of snow specific humidity [ kg/kg/s ] - real, intent(out) :: cufrc_out(idim,k0) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ] - real, intent(out) :: fer_out(idim,k0) ! Fractional lateral entrainment rate [ 1/Pa ] - real, intent(out) :: fdr_out(idim,k0) ! Fractional lateral detrainment rate [ 1/Pa ] - - real, intent(out) :: qldet_out(idim,k0) - real, intent(out) :: qidet_out(idim,k0) - real, intent(out) :: qlsub_out(idim,k0) - real, intent(out) :: qisub_out(idim,k0) - real, intent(out) :: ndrop_out(idim,k0) - real, intent(out) :: nice_out(idim,k0) + real, intent(in) :: pifc0( 0:k0 ) ! Environmental pressure at interfaces [Pa] + real, intent(in) :: zifc0( 0:k0 ) ! Environmental height at interfaces [m] + real, intent(in) :: exnifc0( 0:k0 ) ! Exner function at interfaces + real, intent(in) :: pmid0( k0 ) ! Environmental pressure at midpoints [Pa] + real, intent(in) :: zmid0( k0 ) ! Environmental height at midpoints [m] + real, intent(in) :: exnmid0( k0 ) ! Exner function at midpoints + real, intent(in) :: dp0( k0 ) ! Environmental layer pressure thickness + real, intent(inout) :: u0( k0 ) ! Environmental zonal wind [m/s] + real, intent(inout) :: v0( k0 ) ! Environmental meridional wind [m/s] + real, intent(inout) :: qv0( k0 ) ! Environmental specific humidity + real, intent(inout) :: ql0( k0 ) ! Environmental liquid water specific humidity + real, intent(inout) :: qi0( k0 ) ! Environmental ice specific humidity + real, intent(in) :: th0( k0 ) ! Environmental potential temperature [K] + real, intent(in) :: tke( 0:k0 ) ! Turbulent kinetic energy at interfaces + real, intent(in) :: rkfre ! Resolution dependent Vertical velocity variance as fraction of tke. + real, intent(in) :: rkm2d ! Resolution dependent lateral mixing parameter + real, intent(in) :: mix2d ! Resolution dependent lateral mixing depth + real, intent(in) :: rmaxfrac ! Resolution dependent Maximum core updraft fraction + real, intent(in) :: shfx ! Surface sensible heat + real, intent(in) :: evap ! Surface evaporation + real, intent(in) :: cnvtr ! Convective tracer + real, intent(out) :: tpert_out ! Temperature perturbation + real, intent(out) :: qpert_out ! Humidity perturbation + real, intent(out) :: qtflx_out( 0:k0 ) + real, intent(out) :: slflx_out( 0:k0 ) + real, intent(out) :: uflx_out( 0:k0 ) + real, intent(out) :: vflx_out( 0:k0 ) + integer, intent(in) :: kpbl ! Boundary layer top layer index + real, intent(in) :: frland ! fraction of and in grid cell + + real, intent(inout) :: cush_inout ! Convective scale height [m] + real, intent(inout) :: tr0(k0,ncnst) ! Environmental tracers [ #, kg/kg ] + + real, intent(out) :: umf_out(0:k0) ! Updraft mass flux at the interfaces [ kg/m2/s ] + real, intent(out) :: dcm_out(k0) ! Detrained cloudy air mass + real, intent(out) :: qvten_out(k0) ! Tendency of water vapor specific humidity [ kg/kg/s ] + real, intent(out) :: qlten_out(k0) ! Tendency of liquid water specific humidity [ kg/kg/s ] + real, intent(out) :: qiten_out(k0) ! Tendency of ice specific humidity [ kg/kg/s ] + real, intent(out) :: sten_out(k0) ! Tendency of dry static energy [ J/kg/s ] + real, intent(out) :: uten_out(k0) ! Tendency of zonal wind [ m/s2 ] + real, intent(out) :: vten_out(k0) ! Tendency of meridional wind [ m/s2 ] + real, intent(out) :: qrten_out(k0) ! Tendency of rain water specific humidity [ kg/kg/s ] + real, intent(out) :: qsten_out(k0) ! Tendency of snow specific humidity [ kg/kg/s ] + real, intent(out) :: cufrc_out(k0) ! Shallow cumulus cloud fraction at the layer mid-point [ fraction ] + real, intent(out) :: fer_out(k0) ! Fractional lateral entrainment rate [ 1/Pa ] + real, intent(out) :: fdr_out(k0) ! Fractional lateral detrainment rate [ 1/Pa ] + + real, intent(out) :: qldet_out(k0) + real, intent(out) :: qidet_out(k0) + real, intent(out) :: qlsub_out(k0) + real, intent(out) :: qisub_out(k0) + real, intent(out) :: ndrop_out(k0) + real, intent(out) :: nice_out(k0) !--------- Diagnostic only ------------ - real, intent(out) :: cbmf_out(idim) ! Cloud base mass flux [kg/m2/s] - real, intent(out) :: pinv_out(idim) ! PBL top pressure [ Pa ] - real, intent(out) :: plfc_out(idim) ! LFC of source air [ Pa ] - real, intent(out) :: plcl_out(idim) ! LCL of source air [ Pa ] - real, intent(out) :: prel_out(idim) - real, intent(out) :: pbup_out(idim) - real, intent(out) :: cldhgt_out(idim) + real, intent(out) :: cbmf_out ! Cloud base mass flux [kg/m2/s] + real, intent(out) :: pinv_out ! PBL top pressure [ Pa ] + real, intent(out) :: plfc_out ! LFC of source air [ Pa ] + real, intent(out) :: plcl_out ! LCL of source air [ Pa ] + real, intent(out) :: prel_out + real, intent(out) :: pbup_out + real, intent(out) :: cldhgt_out #ifdef UWDIAG -! real, intent(out) :: trten_out(idim,k0,ncnst) ! Tendency of tracers [ #/s, kg/kg/s ] - real, intent(out) :: wu_out(idim,0:k0) ! Updraft vertical velocity - real, intent(out) :: qtu_out(idim,0:k0) ! Updraft qt [ kg/kg ] - real, intent(out) :: thlu_out(idim,0:k0) ! Updraft thl [ K ] - real, intent(out) :: thvu_out(idim,0:k0) ! Updraft thv [ K ] - real, intent(out) :: uu_out(idim,0:k0) ! Updraft zonal wind [ m/s ] - real, intent(out) :: vu_out(idim,0:k0) ! Updraft meridional wind [ m/s ] - real, intent(out) :: qcu_out(idim,k0) ! Condensate water specific humidity within cumulus updraft [ kg/kg ] - real, intent(out) :: qlu_out(idim,k0) ! Liquid water specific humidity within cumulus updraft [ kg/kg ] - real, intent(out) :: qiu_out(idim,k0) ! Ice specific humidity within cumulus updraft [ kg/kg ] - real, intent(out) :: qc_out(idim,k0) ! Tendency of detrained cumulus condensate - real, intent(out) :: cnt_out(idim) ! Cumulus top interface index - real, intent(out) :: cnb_out(idim) ! Cumulus base interface index - real, intent(out) :: cinh_out(idim) - real, intent(out) :: tkeavg_out(idim) ! Average tke over the PBL [ m2/s2 ] - real, intent(out) :: xc_out(idim,k0) + real, intent(out) :: wu_out(0:k0) ! Updraft vertical velocity + real, intent(out) :: qtu_out(0:k0) ! Updraft qt [ kg/kg ] + real, intent(out) :: thlu_out(0:k0) ! Updraft thl [ K ] + real, intent(out) :: thvu_out(0:k0) ! Updraft thv [ K ] + real, intent(out) :: uu_out(0:k0) ! Updraft zonal wind [ m/s ] + real, intent(out) :: vu_out(0:k0) ! Updraft meridional wind [ m/s ] + real, intent(out) :: qcu_out(k0) ! Condensate water specific humidity within cumulus updraft [ kg/kg ] + real, intent(out) :: qlu_out(k0) ! Liquid water specific humidity within cumulus updraft [ kg/kg ] + real, intent(out) :: qiu_out(k0) ! Ice specific humidity within cumulus updraft [ kg/kg ] + real, intent(out) :: qc_out(k0) ! Tendency of detrained cumulus condensate + real, intent(out) :: cnt_out ! Cumulus top interface index + real, intent(out) :: cnb_out ! Cumulus base interface index + real, intent(out) :: cinh_out + real, intent(out) :: tkeavg_out ! Average tke over the PBL [ m2/s2 ] + real, intent(out) :: xc_out(k0) #endif - ! - ! Internal Output Variables - ! -! real qtten_out(idim,k0) ! Tendency of qt [ kg/kg/s ] -! real slten_out(idim,k0) ! Tendency of sl [ J/kg/s ] -! real ufrc_out(idim,0:k0) ! Updraft fractional area at the interfaces [ fraction ] - - - !----------------------------------------------- ! One-dimensional variables at each grid point !----------------------------------------------- - ! Input variables - - real :: pifc0(0:k0) - real :: zifc0(0:k0) - real :: pmid0(k0) - real :: zmid0(k0) - real :: dp0(k0) - real :: u0(k0) - real :: v0(k0) - real :: tke(1:k0) - real :: qv0(k0) - real :: ql0(k0) - real :: qi0(k0) real :: cush - real :: tr0(k0,ncnst) ! Environmental variables derived from input variables @@ -583,8 +645,6 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real :: thv0top(k0) real :: thvl0bot(k0) real :: thvl0top(k0) - real :: exnmid0(k0) - real :: exnifc0(0:k0) real :: sstr0(k0,ncnst) ! 2-1. For preventing negative condensate at the provisional time step @@ -706,7 +766,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Other internal variables - integer kk, k, i, kp1, km1, mm, m + integer kk, k, kp1, km1, mm, m integer iter_scaleh, iter_xc integer id_check, status @@ -751,36 +811,36 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN !----- Some diagnostic internal output variables #ifdef UWDIAG - real trflx_out(idim,0:k0,ncnst) ! Updraft/pen.entrainment tracer flux [ #/m2/s, kg/kg/m2/s ] - real ufrcinvbase_out(idim) ! Cumulus updraft fraction at the PBL top [ fraction ] - real ufrclcl_out(idim) ! Cumulus updraft fraction at the LCL + real trflx_out(0:k0,ncnst) ! Updraft/pen.entrainment tracer flux [ #/m2/s, kg/kg/m2/s ] + real ufrcinvbase_out ! Cumulus updraft fraction at the PBL top [ fraction ] + real ufrclcl_out ! Cumulus updraft fraction at the LCL ! ( or PBL top when LCL is below PBL top ) [ fraction ] - real winvbase_out(idim) ! Cumulus updraft velocity at the PBL top [ m/s ] - real wlcl_out(idim) ! Cumulus updraft velocity at the LCL + real winvbase_out ! Cumulus updraft velocity at the PBL top [ m/s ] + real wlcl_out ! Cumulus updraft velocity at the LCL ! ( or PBL top when LCL is below PBL top ) [ m/s ] -! real pbup_out(idim) ! Highest interface level of positive buoyancy [ Pa ] - real ppen_out(idim) ! Highest interface evel where Cu w = 0 [ Pa ] - real qtsrc_out(idim) ! Source air qt [ kg/kg ] - real thlsrc_out(idim) ! Source air thl [ K ] - real thvlsrc_out(idim) ! Source air thvl [ K ] - real emfkbup_out(idim) ! Penetrative downward mass flux at 'kbup' interface [ kg/m2/s ] - real cinlclh_out(idim) ! Convective INhibition upto LCL (CIN) [ J/kg = m2/s2 ] - real cbmflimit_out(idim) ! Cloud base mass flux limiter [ kg/m2/s ] - real zinv_out(idim) ! PBL top height [ m ] - real rcwp_out(idim) ! Layer mean Cumulus LWP+IWP [ kg/m2 ] - real rlwp_out(idim) ! Layer mean Cumulus LWP [ kg/m2 ] - real riwp_out(idim) ! Layer mean Cumulus IWP [ kg/m2 ] - - real qtu_emf_out(idim,0:k0) ! Penetratively entrained qt [ kg/kg ] - real thlu_emf_out(idim,0:k0) ! Penetratively entrained thl [ K ] - real uu_emf_out(idim,0:k0) ! Penetratively entrained u [ m/s ] - real vu_emf_out(idim,0:k0) ! Penetratively entrained v [ m/s ] - real uemf_out(idim,0:k0) ! Net upward mass flux +! real pbup_out ! Highest interface level of positive buoyancy [ Pa ] + real ppen_out ! Highest interface evel where Cu w = 0 [ Pa ] + real qtsrc_out ! Source air qt [ kg/kg ] + real thlsrc_out ! Source air thl [ K ] + real thvlsrc_out ! Source air thvl [ K ] + real emfkbup_out ! Penetrative downward mass flux at 'kbup' interface [ kg/m2/s ] + real cinlclh_out ! Convective INhibition upto LCL (CIN) [ J/kg = m2/s2 ] + real cbmflimit_out ! Cloud base mass flux limiter [ kg/m2/s ] + real zinv_out ! PBL top height [ m ] + real rcwp_out ! Layer mean Cumulus LWP+IWP [ kg/m2 ] + real rlwp_out ! Layer mean Cumulus LWP [ kg/m2 ] + real riwp_out ! Layer mean Cumulus IWP [ kg/m2 ] + + real qtu_emf_out(0:k0) ! Penetratively entrained qt [ kg/kg ] + real thlu_emf_out(0:k0) ! Penetratively entrained thl [ K ] + real uu_emf_out(0:k0) ! Penetratively entrained u [ m/s ] + real vu_emf_out(0:k0) ! Penetratively entrained v [ m/s ] + real uemf_out(0:k0) ! Net upward mass flux ! including penetrative entrainment (umf+emf) [ kg/m2/s ] - real dwten_out(idim,k0) - real diten_out(idim,k0) - real tru_out(idim,0:k0,ncnst) ! Updraft tracers [ #, kg/kg ] - real tru_emf_out(idim,0:k0,ncnst) ! Penetratively entrained tracers [ #, kg/kg ] + real dwten_out(k0) + real diten_out(k0) + real tru_out(0:k0,ncnst) ! Updraft tracers [ #, kg/kg ] + real tru_emf_out(0:k0,ncnst) ! Penetratively entrained tracers [ #, kg/kg ] real wu_s(0:k0) ! Same as above but for implicit CIN real qtu_s(0:k0) real thlu_s(0:k0) @@ -798,54 +858,54 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN real dwten_s(k0) real diten_s(k0) - real excessu_arr_out(idim,k0) + real excessu_arr_out(k0) real excessu_arr(k0) real excessu_arr_s(k0) - real excess0_arr_out(idim,k0) + real excess0_arr_out(k0) real excess0_arr(k0) real excess0_arr_s(k0) - real xc_arr_out(idim,k0) + real xc_arr_out(k0) real xc_arr(k0) real xc_arr_s(k0) - real aquad_arr_out(idim,k0) + real aquad_arr_out(k0) real aquad_arr(k0) real aquad_arr_s(k0) - real bquad_arr_out(idim,k0) + real bquad_arr_out(k0) real bquad_arr(k0) real bquad_arr_s(k0) - real cquad_arr_out(idim,k0) + real cquad_arr_out(k0) real cquad_arr(k0) real cquad_arr_s(k0) - real bogbot_arr_out(idim,k0) + real bogbot_arr_out(k0) real bogbot_arr(k0) real bogbot_arr_s(k0) - real bogtop_arr_out(idim,k0) + real bogtop_arr_out(k0) real bogtop_arr(k0) real bogtop_arr_s(k0) #endif - real exit_ufrc(idim) - real exit_wtw(idim) - real exit_drycore(idim) - real exit_wu(idim) - real exit_cufilter(idim) - real exit_rei(idim) - real exit_kinv1(idim) - real exit_klfck0(idim) - real exit_klclk0(idim) - real exit_uwcu(idim) - real exit_conden(idim) - - real limit_cinlcl(idim) - real limit_cin(idim) - real ind_delcin(idim) - real limit_rei(idim) - real limit_shcu(idim) - real limit_negcon(idim) - real limit_ufrc(idim) - real limit_ppen(idim) - real limit_emf(idim) - real limit_cbmf(idim) + real exit_ufrc + real exit_wtw + real exit_drycore + real exit_wu + real exit_cufilter + real exit_rei + real exit_kinv1 + real exit_klfck0 + real exit_klclk0 + real exit_uwcu + real exit_conden + + real limit_cinlcl + real limit_cin + real ind_delcin + real limit_rei + real limit_shcu + real limit_negcon + real limit_ufrc + real limit_ppen + real limit_emf + real limit_cbmf real :: ufrcinvbase_s, ufrclcl_s, winvbase_s, wlcl_s, plcl_s, pinv_s, prel_s, plfc_s, & qtsrc_s, thlsrc_s, thvlsrc_s, emfkbup_s, cinlcl_s, pbup_s, ppen_s, cbmflimit_s, & @@ -1043,144 +1103,124 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Initialize output variables defined for all grid points ! ! ------------------------------------------------------- ! - umf_out(:idim,0:k0) = 0.0 - dcm_out(:idim,:k0) = 0.0 - cufrc_out(:idim,:k0) = 0.0 - fer_out(:idim,:k0) = MAPL_UNDEF - fdr_out(:idim,:k0) = MAPL_UNDEF - qldet_out(:idim,:k0) = 0.0 - qidet_out(:idim,:k0) = 0.0 - qlsub_out(:idim,:k0) = 0.0 - qisub_out(:idim,:k0) = 0.0 - ndrop_out(:idim,:k0) = 0.0 - nice_out(:idim,:k0) = 0.0 - qtflx_out(:idim,0:k0) = 0.0 - slflx_out(:idim,0:k0) = 0.0 - uflx_out(:idim,0:k0) = 0.0 - vflx_out(:idim,0:k0) = 0.0 - tpert_out(:idim) = 0.0 - qpert_out(:idim) = 0.0 - - cbmf_out(:idim) = 0.0 - plcl_out(:idim) = MAPL_UNDEF - pinv_out(:idim) = MAPL_UNDEF - plfc_out(:idim) = MAPL_UNDEF - prel_out(:idim) = MAPL_UNDEF - pbup_out(:idim) = MAPL_UNDEF - cldhgt_out(:idim) = MAPL_UNDEF + umf_out(0:k0) = 0.0 + dcm_out(:k0) = 0.0 + cufrc_out(:k0) = 0.0 + fer_out(:k0) = MAPL_UNDEF + fdr_out(:k0) = MAPL_UNDEF + qldet_out(:k0) = 0.0 + qidet_out(:k0) = 0.0 + qlsub_out(:k0) = 0.0 + qisub_out(:k0) = 0.0 + ndrop_out(:k0) = 0.0 + nice_out(:k0) = 0.0 + qtflx_out(0:k0) = 0.0 + slflx_out(0:k0) = 0.0 + uflx_out(0:k0) = 0.0 + vflx_out(0:k0) = 0.0 + tpert_out = 0.0 + qpert_out = 0.0 + + cbmf_out = 0.0 + plcl_out = MAPL_UNDEF + pinv_out = MAPL_UNDEF + plfc_out = MAPL_UNDEF + prel_out = MAPL_UNDEF + pbup_out = MAPL_UNDEF + cldhgt_out = MAPL_UNDEF #ifdef UWDIAG - cinh_out(:idim) = MAPL_UNDEF - cinlclh_out(:idim) = MAPL_UNDEF - qcu_out(:idim,:k0) = 0.0 - qlu_out(:idim,:k0) = 0.0 - qiu_out(:idim,:k0) = 0.0 - qc_out(:idim,:k0) = 0.0 - cnt_out(:idim) = real(k0) - cnb_out(:idim) = 0.0 - xc_out(:idim,:k0) = 0.0 -! ufrc_out(:idim,0:k0) = 0.0 -! uflx_out(:idim,0:k0) = 0.0 -! vflx_out(:idim,0:k0) = 0.0 - ppen_out(:idim) = 0.0 - ufrcinvbase_out(:idim) = 0.0 - ufrclcl_out(:idim) = 0.0 - winvbase_out(:idim) = 0.0 - wlcl_out(:idim) = 0.0 - qtsrc_out(:idim) = 0.0 - thlsrc_out(:idim) = 0.0 - thvlsrc_out(:idim) = 0.0 - emfkbup_out(:idim) = 0.0 - cbmflimit_out(:idim) = 0.0 - tkeavg_out(:idim) = 0.0 - zinv_out(:idim) = 0.0 - rcwp_out(:idim) = 0.0 - rlwp_out(:idim) = 0.0 - riwp_out(:idim) = 0.0 + cinh_out = MAPL_UNDEF + cinlclh_out = MAPL_UNDEF + qcu_out(:k0) = 0.0 + qlu_out(:k0) = 0.0 + qiu_out(:k0) = 0.0 + qc_out(:k0) = 0.0 + cnt_out = real(k0) + cnb_out = 0.0 + xc_out(:k0) = 0.0 +! ufrc_out(0:k0) = 0.0 +! uflx_out(0:k0) = 0.0 +! vflx_out(0:k0) = 0.0 + ppen_out = 0.0 + ufrcinvbase_out = 0.0 + ufrclcl_out = 0.0 + winvbase_out = 0.0 + wlcl_out = 0.0 + qtsrc_out = 0.0 + thlsrc_out = 0.0 + thvlsrc_out = 0.0 + emfkbup_out = 0.0 + cbmflimit_out = 0.0 + tkeavg_out = 0.0 + zinv_out = 0.0 + rcwp_out = 0.0 + rlwp_out = 0.0 + riwp_out = 0.0 - wu_out(:idim,0:k0) = MAPL_UNDEF - qtu_out(:idim,0:k0) = MAPL_UNDEF - thlu_out(:idim,0:k0) = MAPL_UNDEF - thvu_out(:idim,0:k0) = MAPL_UNDEF - uu_out(:idim,0:k0) = MAPL_UNDEF - vu_out(:idim,0:k0) = MAPL_UNDEF - qtu_emf_out(:idim,0:k0) = 0.0 - thlu_emf_out(:idim,0:k0) = 0.0 - uu_emf_out(:idim,0:k0) = 0.0 - vu_emf_out(:idim,0:k0) = 0.0 - uemf_out(:idim,0:k0) = 0.0 - - dwten_out(:idim,:k0) = 0.0 - diten_out(:idim,:k0) = 0.0 - -! trten_out(:idim,:k0,:ncnst) = 0.0 - trflx_out(:idim,0:k0,:ncnst) = 0.0 - tru_out(:idim,0:k0,:ncnst) = 0.0 - tru_emf_out(:idim,0:k0,:ncnst) = 0.0 - - excessu_arr_out(:idim,:k0) = 0.0 - excess0_arr_out(:idim,:k0) = 0.0 - xc_arr_out(:idim,:k0) = 0.0 - aquad_arr_out(:idim,:k0) = 0.0 - bquad_arr_out(:idim,:k0) = 0.0 - cquad_arr_out(:idim,:k0) = 0.0 - bogbot_arr_out(:idim,:k0) = 0.0 - bogtop_arr_out(:idim,:k0) = 0.0 + wu_out(0:k0) = MAPL_UNDEF + qtu_out(0:k0) = MAPL_UNDEF + thlu_out(0:k0) = MAPL_UNDEF + thvu_out(0:k0) = MAPL_UNDEF + uu_out(0:k0) = MAPL_UNDEF + vu_out(0:k0) = MAPL_UNDEF + qtu_emf_out(0:k0) = 0.0 + thlu_emf_out(0:k0) = 0.0 + uu_emf_out(0:k0) = 0.0 + vu_emf_out(0:k0) = 0.0 + uemf_out(0:k0) = 0.0 + + dwten_out(:k0) = 0.0 + diten_out(:k0) = 0.0 + +! trten_out(:k0,:ncnst) = 0.0 + trflx_out(0:k0,:ncnst) = 0.0 + tru_out(0:k0,:ncnst) = 0.0 + tru_emf_out(0:k0,:ncnst) = 0.0 + + excessu_arr_out(:k0) = 0.0 + excess0_arr_out(:k0) = 0.0 + xc_arr_out(:k0) = 0.0 + aquad_arr_out(:k0) = 0.0 + bquad_arr_out(:k0) = 0.0 + cquad_arr_out(:k0) = 0.0 + bogbot_arr_out(:k0) = 0.0 + bogtop_arr_out(:k0) = 0.0 #endif - exit_UWCu(:idim) = 0.0 - exit_conden(:idim) = 0.0 - exit_klclk0(:idim) = 0.0 - exit_klfck0(:idim) = 0.0 - exit_ufrc(:idim) = 0.0 - exit_wtw(:idim) = 0.0 - exit_drycore(:idim) = 0.0 - exit_wu(:idim) = 0.0 - exit_cufilter(:idim) = 0.0 - exit_kinv1(:idim) = 0.0 - exit_rei(:idim) = 0.0 - - limit_shcu(:idim) = 0.0 - limit_negcon(:idim) = 0.0 - limit_ufrc(:idim) = 0.0 - limit_ppen(:idim) = 0.0 - limit_emf(:idim) = 0.0 - limit_cinlcl(:idim) = 0.0 - limit_cin(:idim) = 0.0 - limit_cbmf(:idim) = 0.0 - limit_rei(:idim) = 0.0 - - ind_delcin(:idim) = 0.0 + exit_UWCu = 0.0 + exit_conden = 0.0 + exit_klclk0 = 0.0 + exit_klfck0 = 0.0 + exit_ufrc = 0.0 + exit_wtw = 0.0 + exit_drycore = 0.0 + exit_wu = 0.0 + exit_cufilter = 0.0 + exit_kinv1 = 0.0 + exit_rei = 0.0 + + limit_shcu = 0.0 + limit_negcon = 0.0 + limit_ufrc = 0.0 + limit_ppen = 0.0 + limit_emf = 0.0 + limit_cinlcl = 0.0 + limit_cin = 0.0 + limit_cbmf = 0.0 + limit_rei = 0.0 + + ind_delcin = 0.0 !======================== - ! Start column loop + ! column work !======================== - do i = 1, idim - id_exit = .false. frc_rasn = shlwparams%frc_rasn - pifc0(0:k0) = pifc0_in(i,0:k0) - zifc0(0:k0) = zifc0_in(i,0:k0) - pmid0(:k0) = pmid0_in(i,:k0) - zmid0(:k0) = zmid0_in(i,:k0) - dp0(:k0) = dp0_in(i,:k0) - u0(:k0) = u0_in(i,:k0) - v0(:k0) = v0_in(i,:k0) - qv0(:k0) = qv0_in(i,:k0) - ql0(:k0) = ql0_in(i,:k0) - qi0(:k0) = qi0_in(i,:k0) - tke(1:k0) = tke_in(i,1:k0) -! pblh = pblh_in(i) - cush = cush_inout(i) - - if (dotransport.eq.1) then - do m = 1,ncnst ! loop over tracers - tr0(:k0,m) = tr0_inout(i,:k0,m) - end do - endif + cush = cush_inout !------------------------------------------------------! ! Compute basic thermodynamic variables directly from ! @@ -1189,15 +1229,12 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Compute internal environmental variables - exnmid0(:k0) = exnmid0_in(i,:k0) - exnifc0(:k0) = exnifc0_in(i,:k0) - t0(:k0) = th0_in(i,:k0) * exnmid0(:k0) + t0(:k0) = th0(:k0) * exnmid0(:k0) s0(:k0) = g*zmid0(:k0) + cp*t0(:k0) qt0(:k0) = qv0(:k0) + ql0(:k0) + qi0(:k0) thl0(:k0) = ( t0(:k0) - xlv*ql0(:k0)/cp - xls*qi0(:k0)/cp ) / exnmid0(:k0) thvl0(:k0) = ( 1. + zvir*qt0(:k0) )*thl0(:k0) - ! Compute slopes of environmental variables in each layer ssthl0 = slope( k0, thl0, pmid0 ) @@ -1218,7 +1255,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qt0bot = qt0(k) + ssqt0(k)*(pifc0(k-1) - pmid0(k)) call conden( pifc0(k-1),thl0bot,qt0bot,thj,qvj,qlj,qij,qse,id_check ) if ( id_check .eq. 1 ) then - exit_conden(i) = 1.0 + exit_conden = 1.0 id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: Exit, conden') @@ -1233,7 +1270,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (k.lt.k0) then call conden( pifc0(k),thl0top,qt0top,thj,qvj,qlj,qij,qse,id_check ) if ( id_check .eq. 1 ) then - exit_conden(i) = 1.0 + exit_conden = 1.0 id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: Exit, conden') @@ -1392,7 +1429,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! of the iterative cin loop. ! ! ---------------------------------------------------------------------- ! - tscaleh = cush + tscaleh = cush cush = -1. tkeavg = 0. qtavg = 0. @@ -1421,8 +1458,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ----------------------------------------------------------------------- ! ! invert kpbl index - if (kpbl_in(i).gt.k0/2) then - kinv = k0 - kpbl_in(i) + 1 + if (kpbl.gt.k0/2) then + kinv = k0 - kpbl + 1 else kinv = 5 end if @@ -1430,7 +1467,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN 15 continue if( kinv .le. 1 ) then - exit_kinv1(i) = 1. + exit_kinv1 = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: Exit, kinv<=1') @@ -1482,16 +1519,6 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN thvlavg = thvlavg/dpsum qtavg = qtavg/dpsum -! ! weighted average over lowest 20mb -! dpsum = 0. -! qtavg = 0. -! do k = 1,kinv -! dpi = max(0.,(2e3+pmid0(k)-pifc0(0))/2e3) -! qtavg = qtavg + dpi*qt0(k) -! dpsum = dpsum + dpi -! end do -! qtavg = qtavg/dpsum - ! Interpolate qt to specified height or the PBL edge height if (qtsrchgt > 1.0) then k = 1 @@ -1516,23 +1543,23 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (windsrcavg) then zrho = pifc0(0)/(287.04*(t0(1)*(1.+0.608*qv0(1)))) - buoyflx = (-shfx(i)/cp-0.608*t0(1)*evap(i))/zrho ! K m s-1 -! delzg = (zifc0(1)-zifc0(0))*g - delzg = (50.0)*g ! assume 50m surface scale + buoyflx = (-shfx/cp-0.608*t0(1)*evap)/zrho ! K m s-1 + ! Use actual PBL depth for convective velocity scale + delzg = (zifc0(kinv-1) - zifc0(0)) * g + ! Put a 50m safety minimum just in case the PBL is extremely shallow + delzg = max(delzg, 50.0*g) wstar = max(0.,0.001-0.41*buoyflx*delzg/t0(1)) ! m3 s-3 - qpert_out(i) = 0.0 - tpert_out(i) = 0.0 + qpert_out = 0.0 + tpert_out = 0.0 if (wstar > 0.001) then wstar = 1.0*wstar**.3333 - tpert_out(i) = thlsrc_fac*shfx(i)/(zrho*wstar*cp) ! K - qpert_out(i) = qtsrc_fac*evap(i)/(zrho*wstar) ! kg kg-1 + tpert_out = thlsrc_fac*shfx/(zrho*wstar*cp) ! K + qpert_out = qtsrc_fac*evap/(zrho*wstar) ! kg kg-1 end if - qpert_out(i) = max(min(qpert_out(i),0.02*qt0(1)),0.) ! limit to 1% of QT - tpert_out(i) = 0.1+max(min(tpert_out(i),1.0),0.) ! limit to 1K - qtsrc = qtavg + qpert_out(i) -! qtsrc = qt0(1) + qpert_out(i) -! thvlsrc = thvlavg + tpert_out(i)*(1.0+zvir*qtsrc) !/exnmid0(1) - thvlsrc = thvlmin + tpert_out(i)*(1.0+zvir*qtsrc) !/exnmid0(1) + qpert_out = max(min(qpert_out,0.01*qt0(1)),0.) ! limit to 1% of QT + tpert_out = max(min(tpert_out,1.0),0.) + 0.1 ! limit to 1K and give a 0.1K bouyancy kick + qtsrc = qtavg + qpert_out + thvlsrc = thvlmin + tpert_out*(1.0+zvir*qtsrc) thlsrc = thvlsrc / ( 1. + zvir * qtsrc ) usrc = uavg vsrc = vavg @@ -1596,7 +1623,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN klcl = max(1,klcl) if( plcl .lt. 60000. ) then - exit_klclk0(i) = 1. + exit_klclk0 = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, plcl<600mb') @@ -1616,7 +1643,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qt0lcl = qt0(klcl) + ssqt0(klcl) * ( plcl - pmid0(klcl) ) call conden(plcl,thl0lcl,qt0lcl,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if @@ -1682,14 +1709,14 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN thvubot = thvlsrc thvutop = thvlsrc cin = cin + single_cin(pifc0(k-1),thv0bot(k),plcl,thv0lcl,thvubot,thvutop) - if( cin .lt. 0. ) limit_cinlcl(i) = 1. + if( cin .lt. 0. ) limit_cinlcl = 1. cinlcl = max(cin,0.) cin = cinlcl !----- LCL to Top thvubot = thvlsrc call conden(pifc0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if @@ -1703,7 +1730,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN thvubot = thvutop call conden(pifc0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if @@ -1725,14 +1752,14 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN do k = kinv, k0 - 1 call conden(pifc0(k-1),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if thvubot = thj * ( 1. + zvir*qvj - qlj - qij ) call conden(pifc0(k),thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. go to 333 end if @@ -1746,7 +1773,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN endif ! End of CIN case selection 35 continue - if( cin .lt. 0. ) limit_cin(i) = 1. + if( cin .lt. 0. ) limit_cin = 1. cin = max(0.,cin) ! cin = max(cin,0.04*(lts-18.)) ! kludge to reduce UW in StCu regions @@ -1756,7 +1783,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (scverbose) then call write_parallel('------ UWShCu: klfc >= k0') end if - exit_klfck0(i) = 1. + exit_klfck0 = 1. id_exit = .true. go to 333 endif @@ -1984,7 +2011,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Identifier showing whether explicit or implicit CIN is used ! ! ----------------------------------------------------------- ! - ind_delcin(i) = 1. + ind_delcin = 1. if (scverbose) then call write_parallel('------ UWShCu: del_CIN<0') end if @@ -1993,41 +2020,41 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Restore original output values of "iter_cin = 1" and exit ! ! --------------------------------------------------------- ! - umf_out(i,0:k0) = umf_s(0:k0) - umf_out(i,0:kinv-1) = umf_s(kinv-1)*zifc0(0:kinv-1)/zifc0(kinv-1) - - dcm_out(i,:k0) = dcm_s(:k0) - qvten_out(i,:k0) = qvten_s(:k0) - qlten_out(i,:k0) = qlten_s(:k0) - qiten_out(i,:k0) = qiten_s(:k0) - sten_out(i,:k0) = sten_s(:k0) - uten_out(i,:k0) = uten_s(:k0) - vten_out(i,:k0) = vten_s(:k0) - qrten_out(i,:k0) = qrten_s(:k0) - qsten_out(i,:k0) = qsten_s(:k0) - qldet_out(i,:k0) = qldet_s(:k0) - qidet_out(i,:k0) = qidet_s(:k0) - qlsub_out(i,:k0) = qlsub_s(:k0) - qisub_out(i,:k0) = qisub_s(:k0) - cush_inout(i) = cush_s - cufrc_out(i,:k0) = cufrc_s(:k0) - qtflx_out(i,0:k0) = qtflx_s(0:k0) - slflx_out(i,0:k0) = slflx_s(0:k0) - uflx_out(i,0:k0) = uflx_s(0:k0) - vflx_out(i,0:k0) = vflx_s(0:k0) - - cbmf_out(i) = cbmf_s + umf_out(0:k0) = umf_s(0:k0) + umf_out(0:kinv-1) = umf_s(kinv-1)*zifc0(0:kinv-1)/zifc0(kinv-1) + + dcm_out(:k0) = dcm_s(:k0) + qvten_out(:k0) = qvten_s(:k0) + qlten_out(:k0) = qlten_s(:k0) + qiten_out(:k0) = qiten_s(:k0) + sten_out(:k0) = sten_s(:k0) + uten_out(:k0) = uten_s(:k0) + vten_out(:k0) = vten_s(:k0) + qrten_out(:k0) = qrten_s(:k0) + qsten_out(:k0) = qsten_s(:k0) + qldet_out(:k0) = qldet_s(:k0) + qidet_out(:k0) = qidet_s(:k0) + qlsub_out(:k0) = qlsub_s(:k0) + qisub_out(:k0) = qisub_s(:k0) + cush_inout = cush_s + cufrc_out(:k0) = cufrc_s(:k0) + qtflx_out(0:k0) = qtflx_s(0:k0) + slflx_out(0:k0) = slflx_s(0:k0) + uflx_out(0:k0) = uflx_s(0:k0) + vflx_out(0:k0) = vflx_s(0:k0) + + cbmf_out = cbmf_s #ifdef UWDIAG - qcu_out(i,:k0) = qcu_s(:k0) - qlu_out(i,:k0) = qlu_s(:k0) - qiu_out(i,:k0) = qiu_s(:k0) - qc_out(i,:k0) = qc_s(:k0) - cnt_out(i) = cnt_s - cnb_out(i) = cnb_s + qcu_out(:k0) = qcu_s(:k0) + qlu_out(:k0) = qlu_s(:k0) + qiu_out(:k0) = qiu_s(:k0) + qc_out(:k0) = qc_s(:k0) + cnt_out = cnt_s + cnb_out = cnb_s ! if (dotransport.eq.1) then ! do m = 1, ncnst -! trten_out(i,:k0,m) = trten_s(:k0,m) +! trten_out(:k0,m) = trten_s(:k0,m) ! enddo ! end if #endif @@ -2037,61 +2064,61 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! The order of vertical index is reversed for this internal diagnostic output. ! ! ------------------------------------------------------------------------------ ! - fer_out(i,1:k0) = fer_s(:k0) - fdr_out(i,1:k0) = fdr_s(:k0) - plcl_out(i) = plcl_s - pinv_out(i) = pinv_s - prel_out(i) = prel_s - plfc_out(i) = plfc_s - pbup_out(i) = pbup_s + fer_out(1:k0) = fer_s(:k0) + fdr_out(1:k0) = fdr_s(:k0) + plcl_out = plcl_s + pinv_out = pinv_s + prel_out = prel_s + plfc_out = plfc_s + pbup_out = pbup_s #ifdef UWDIAG - ufrcinvbase_out(i) = ufrcinvbase_s - ufrclcl_out(i) = ufrclcl_s - winvbase_out(i) = winvbase_s - wlcl_out(i) = wlcl_s - ppen_out(i) = ppen_s - qtsrc_out(i) = qtsrc_s - thlsrc_out(i) = thlsrc_s - thvlsrc_out(i) = thvlsrc_s - emfkbup_out(i) = emfkbup_s - cbmflimit_out(i) = cbmflimit_s - tkeavg_out(i) = tkeavg_s - zinv_out(i) = zinv_s - rcwp_out(i) = rcwp_s - rlwp_out(i) = rlwp_s - riwp_out(i) = riwp_s - - xc_out(i,1:k0) = xc_s(:k0) - cinh_out(i) = cin_s - cinlclh_out(i) = cinlcl_s - - wu_out(i,k0:0:-1) = wu_s(0:k0) - qtu_out(i,k0:0:-1) = qtu_s(0:k0) - thlu_out(i,k0:0:-1) = thlu_s(0:k0) - thvu_out(i,k0:0:-1) = thvu_s(0:k0) - uu_out(i,k0:0:-1) = uu_s(0:k0) - vu_out(i,k0:0:-1) = vu_s(0:k0) - qtu_emf_out(i,k0:0:-1) = qtu_emf_s(0:k0) - thlu_emf_out(i,k0:0:-1) = thlu_emf_s(0:k0) - uu_emf_out(i,k0:0:-1) = uu_emf_s(0:k0) - vu_emf_out(i,k0:0:-1) = vu_emf_s(0:k0) - uemf_out(i,k0:0:-1) = uemf_s(0:k0) - - excessu_arr_out(i,k0:1:-1) = excessu_arr_s(:k0) - excess0_arr_out(i,k0:1:-1) = excess0_arr_s(:k0) - xc_arr_out(i,k0:1:-1) = xc_arr_s(:k0) - aquad_arr_out(i,k0:1:-1) = aquad_arr_s(:k0) - bquad_arr_out(i,k0:1:-1) = bquad_arr_s(:k0) - cquad_arr_out(i,k0:1:-1) = cquad_arr_s(:k0) - bogbot_arr_out(i,k0:1:-1) = bogbot_arr_s(:k0) - bogtop_arr_out(i,k0:1:-1) = bogtop_arr_s(:k0) + ufrcinvbase_out = ufrcinvbase_s + ufrclcl_out = ufrclcl_s + winvbase_out = winvbase_s + wlcl_out = wlcl_s + ppen_out = ppen_s + qtsrc_out = qtsrc_s + thlsrc_out = thlsrc_s + thvlsrc_out = thvlsrc_s + emfkbup_out = emfkbup_s + cbmflimit_out = cbmflimit_s + tkeavg_out = tkeavg_s + zinv_out = zinv_s + rcwp_out = rcwp_s + rlwp_out = rlwp_s + riwp_out = riwp_s + + xc_out(1:k0) = xc_s(:k0) + cinh_out = cin_s + cinlclh_out = cinlcl_s + + wu_out(k0:0:-1) = wu_s(0:k0) + qtu_out(k0:0:-1) = qtu_s(0:k0) + thlu_out(k0:0:-1) = thlu_s(0:k0) + thvu_out(k0:0:-1) = thvu_s(0:k0) + uu_out(k0:0:-1) = uu_s(0:k0) + vu_out(k0:0:-1) = vu_s(0:k0) + qtu_emf_out(k0:0:-1) = qtu_emf_s(0:k0) + thlu_emf_out(k0:0:-1) = thlu_emf_s(0:k0) + uu_emf_out(k0:0:-1) = uu_emf_s(0:k0) + vu_emf_out(k0:0:-1) = vu_emf_s(0:k0) + uemf_out(k0:0:-1) = uemf_s(0:k0) + + excessu_arr_out(k0:1:-1) = excessu_arr_s(:k0) + excess0_arr_out(k0:1:-1) = excess0_arr_s(:k0) + xc_arr_out(k0:1:-1) = xc_arr_s(:k0) + aquad_arr_out(k0:1:-1) = aquad_arr_s(:k0) + bquad_arr_out(k0:1:-1) = bquad_arr_s(:k0) + cquad_arr_out(k0:1:-1) = cquad_arr_s(:k0) + bogbot_arr_out(k0:1:-1) = bogbot_arr_s(:k0) + bogtop_arr_out(k0:1:-1) = bogtop_arr_s(:k0) if (dotransport.eq.1) then do m = 1, ncnst - trflx_out(i,k0:0:-1,m) = trflx_s(0:k0,m) - tru_out(i,k0:0:-1,m) = tru_s(0:k0,m) - tru_emf_out(i,k0:0:-1,m) = tru_emf_s(0:k0,m) + trflx_out(k0:0:-1,m) = trflx_s(0:k0,m) + tru_out(k0:0:-1,m) = tru_s(0:k0,m) + tru_emf_out(k0:0:-1,m) = tru_emf_s(0:k0,m) enddo endif #endif @@ -2210,13 +2237,13 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! 1. 'cbmf' constraint if (cbmf > 1.0e-12) then ! limit and normalize by raw cbmf [0.1 : 1.0] - rkfre_eff = min(rkfre(i), min(1.0,max(0.1,(0.9*dp0(kinv-1)/g/dt)/cbmf))) + rkfre_eff = min(rkfre, min(1.0,max(0.1,(0.9*dp0(kinv-1)/g/dt)/cbmf))) else ! When no cloud base mass flux, limit to rkfre only - rkfre_eff = min(rkfre(i), 1.0) + rkfre_eff = min(rkfre, 1.0) endif cbmf = rkfre_eff*cbmf - if( rkfre_eff .lt. 1.0 ) limit_cbmf(i) = 1. + if( rkfre_eff .lt. 1.0 ) limit_cbmf = 1. ! 2. limited sigmaw (solving for sigmaw using limited cbmf) sigmaw = 2.5066 * cbmf * exp(mu**2) / rho0inv ! 3. 'ufrcinv' constraint @@ -2224,17 +2251,17 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN mu = max(max(mu,mumin0),mumin1) ! 4. 'ufrclcl' constraint mulcl = sqrt(max(0.0,2.*cinlcl*rbuoy))/1.4142/sigmaw - mulclstar = sqrt(max(0.,2.*(exp(-mu**2)/2.5066)**2*(1./erfc(mu)**2-0.25/rmaxfrac(i)**2))) + mulclstar = sqrt(max(0.,2.*(exp(-mu**2)/2.5066)**2*(1./erfc(mu)**2-0.25/rmaxfrac**2))) if( mulcl .gt. 1.e-8 .and. mulcl .gt. mulclstar ) then - mumin2 = compute_mumin2(mulcl,rmaxfrac(i),mu) + mumin2 = compute_mumin2(mulcl,rmaxfrac,mu) if( mu .gt. mumin2 ) then call write_parallel('Critical error in mu calculation in UW_ShCu') ! call endrun endif mu = max(mu,mumin2) - if( mu .eq. mumin2 ) limit_ufrc(i) = 1. + if( mu .eq. mumin2 ) limit_ufrc = 1. endif - if( mu .eq. mumin1 ) limit_ufrc(i) = 1. + if( mu .eq. mumin1 ) limit_ufrc = 1. ! ------------------------------------------------------------------- ! ! Calculate final ['cbmf','ufrcinv','winv'] at the PBL top interface. ! @@ -2262,7 +2289,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (scverbose) then call write_parallel('wlcl < 0 at the LCL') end if - exit_wtw(i) = 1. + exit_wtw = 1. id_exit = .true. go to 333 endif @@ -2273,7 +2300,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (scverbose) then call write_parallel( 'ufrclcl <= 0.0001' ) end if - exit_ufrc(i) = 1. + exit_ufrc = 1. id_exit = .true. go to 333 endif @@ -2314,7 +2341,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qtu(krel-1) = qtsrc call conden(prel,thlsrc,qtsrc,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2537,7 +2564,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pe,thle,qte,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2552,7 +2579,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pe,thlue,qtue,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2576,7 +2603,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN endif call conden(pe,thlue,qtue,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2642,7 +2669,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qtxsat = qtue + xsat * ( qte - qtue ); call conden(pe,thlxsat,qtxsat,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2703,12 +2730,12 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ------------------------------------------------------------------------ ! ee2 = xc**2 ud2 = 1. - 2.*xc + xc**2 ! (1-xc)**2 - if (min(scaleh,mix2d(i)) .gt. tiny) then - rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mix2d(i)) / g / rhomid0j ) ! alternative + if (min(scaleh,mix2d) .gt. tiny) then + rei(k) = ( (rkm2d+max(0.,(zmid0(k)-detrhgt)/200.) ) / min(scaleh,mix2d) / g / rhomid0j ) ! alternative ! regression bug due to cnvtr -! WMP rei(k) = ( (rkm2d(i)+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr(i))/2.5e-6))) / min(scaleh,mix2d(i)) / g / rhomid0j ) ! alternative +! WMP rei(k) = ( (rkm2d+max(0.,(zmid0(k)-detrhgt)/200.)-max(0.,min(2.,(cnvtr)/2.5e-6))) / min(scaleh,mix2d) / g / rhomid0j ) ! alternative else - rei(k) = ( 0.5 * rkm2d(i) / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version + rei(k) = ( 0.5 * rkm2d / zmid0(k) / g /rhomid0j ) ! Jason-2_0 version end if ! overflow if( xc .gt. 0.5 ) rei(k) = min(rei(k),0.9*log(max(tiny,dp0(k)/g/dt/umf(km1) + 1.))/dpe/(2.*xc-1.)) @@ -2820,7 +2847,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2860,7 +2887,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! ----------------------------------------------------------------- ! call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -2978,7 +3005,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN wu(k) = sqrt(wtw) ! Protected from NaN above if( wu(k) .gt. 100. ) then - exit_wu(i) = 1. + exit_wu = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exited, wu>100') @@ -3008,10 +3035,10 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN rhoifc0j = pifc0(k) / ( r * 0.5 * ( thv0bot(k+1) + thv0top(k) )*exnifc0(k) ) ufrc(k) = umf(k) / ( rhoifc0j * wu(k) ) - if( ufrc(k) .gt. rmaxfrac(i) ) then - limit_ufrc(i) = 1. - ufrc(k) = rmaxfrac(i) - umf(k) = rmaxfrac(i) * rhoifc0j * wu(k) + if( ufrc(k) .gt. rmaxfrac ) then + limit_ufrc = 1. + ufrc(k) = rmaxfrac + umf(k) = rmaxfrac * rhoifc0j * wu(k) fdr(k) = fer(k) - log(max(tiny, umf(k) / umf(km1)) ) / dpe if (fdr(k).gt.fer_fdr_limit) then print *,"fdr(k) [updated] > ",fer_fdr_limit," ! fdr=",fdr(k)," dpe=",dpe/100.0 @@ -3109,7 +3136,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN else ppen = compute_ppen(wtwb,drage,bogbot,bogtop,rhomid0j,dp0(kpen)) endif - if( ppen .eq. -dp0(kpen) .or. ppen .eq. 0. ) limit_ppen(i) = 1. + if( ppen .eq. -dp0(kpen) .or. ppen .eq. 0. ) limit_ppen = 1. ! -------------------------------------------------------------------- ! ! Re-calculate the amount of expelled condensate from cloud updraft ! @@ -3133,7 +3160,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pifc0(kpen-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -3173,10 +3200,10 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if( kbup .eq. krel ) then forcedCu = .true. - limit_shcu(i) = 1. + limit_shcu = 1. else forcedCu = .false. - limit_shcu(i) = 0. + limit_shcu = 0. endif ! ------------------------------------------------------------------ ! @@ -3198,7 +3225,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if (scverbose) then call write_parallel( 'forcedCu - did not overcome initial buoyancy barrier') end if - exit_cufilter(i) = 1. + exit_cufilter = 1. id_exit = .true. go to 333 end if @@ -3309,8 +3336,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! penetratively entraining interface. ! ! -------------------------------------------------------------------- ! - if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf(i) = 1. - if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.9*dp0(kpen)/g/dt ) limit_emf(i) = 1. + if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf = 1. + if( ( umf(k)*ppen*rei(kpen)*rpen ) .lt. -0.9*dp0(kpen)/g/dt ) limit_emf = 1. emf(k) = max( max( umf(k)*ppen*rei(kpen)*rpen, -0.1*rhoifc0j), -0.9*dp0(kpen)/g/dt) thlu_emf(k) = thl0(kpen) + ssthl0(kpen) * ( pifc0(k) - pmid0(kpen) ) @@ -3334,8 +3361,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN if( use_cumpenent ) then ! Original Cumulative Penetrative Entrainment - if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf(i) = 1 - if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9*dp0(k+1)/g/dt ) limit_emf(i) = 1 + if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf = 1 + if( ( emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9*dp0(k+1)/g/dt ) limit_emf = 1 emf(k) = max(max(emf(k+1)-umf(k)*dp0(k+1)*rei(k+1)*rpen, -0.1*rhoifc0j), -0.9*dp0(k+1)/g/dt ) if( abs(emf(k)) .gt. abs(emf(k+1)) ) then thlu_emf(k) = ( thlu_emf(k+1) * emf(k+1) + thl0(k+1) * ( emf(k) - emf(k+1) ) ) / emf(k) @@ -3361,8 +3388,8 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN else ! Alternative Non-Cumulative Penetrative Entrainment - if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf(i) = 1 - if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9*dp0(k+1)/g/dt ) limit_emf(i) = 1 + if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.1*rhoifc0j ) limit_emf = 1 + if( ( -umf(k)*dp0(k+1)*rei(k+1)*rpen ) .lt. -0.9*dp0(k+1)/g/dt ) limit_emf = 1 emf(k) = max(max(-umf(k)*dp0(k+1)*rei(k+1)*rpen, -0.1*rhoifc0j), -0.9*dp0(k+1)/g/dt ) thlu_emf(k) = thl0(k+1) qtu_emf(k) = qt0(k+1) @@ -3850,7 +3877,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN elseif( k .eq. krel ) then call conden(prel,thlu(krel-1),qtu(krel-1),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -3861,7 +3888,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qiubelow = qij call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -3873,7 +3900,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN elseif( k .eq. kpen ) then call conden(pifc0(k-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -3887,7 +3914,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN else call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4032,7 +4059,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! if( ( qv0(k) + qvten(k)*dt ) .lt. 0.0 .or. & ! ( ql0(k) + qlten(k)*dt ) .lt. 0.0 .or. & ! ( qi0(k) + qiten(k)*dt ) .lt. 0.0 ) then -! limit_negcon(i) = 1. +! limit_negcon = 1. ! end if slten(k) = sten(k) - xlv*qlten(k) - xls*qiten(k) slten(k) = slten(k) + xlv * qrten(k) + xls * qsten(k) @@ -4149,7 +4176,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(prel,thlu(krel-1),qtu(krel-1),thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4179,7 +4206,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN call conden(pifc0(k),thlu(k),qtu(k),thj,qvj,qlj,qij,qse,id_check) endif if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4380,7 +4407,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qt0bot = qt0(k) + ssqt0(k) * ( pifc0(k-1) - pmid0(k) ) call conden(pifc0(k-1),thl0bot,qt0bot,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4394,7 +4421,7 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN qt0top = qt0(k) + ssqt0(k) * ( pifc0(k) - pmid0(k) ) call conden(pifc0(k),thl0top,qt0top,thj,qvj,qlj,qij,qse,id_check) if( id_check .eq. 1 ) then - exit_conden(i) = 1. + exit_conden = 1. id_exit = .true. if (scverbose) then call write_parallel('------- UW ShCu: exit, conden') @@ -4416,36 +4443,36 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Update Output Variables ! ! ----------------------- ! - umf_out(i,0:k0) = umf(0:k0) - umf_out(i,0:kinv-1) = umf(kinv-1)*zifc0(0:kinv-1)/zifc0(kinv-1) -! umf_out(i,0:kinv-2) = uemf(0:kinv-2) - dcm_out(i,:k0) = dcm(:k0) + umf_out(0:k0) = umf(0:k0) + umf_out(0:kinv-1) = umf(kinv-1)*zifc0(0:kinv-1)/zifc0(kinv-1) +! umf_out(0:kinv-2) = uemf(0:kinv-2) + dcm_out(:k0) = dcm(:k0) !the indices are not reversed, these variables go into compute_mcshallow_inv - qvten_out(i,:k0) = qvten(:k0) - qlten_out(i,:k0) = qlten(:k0) - qiten_out(i,:k0) = qiten(:k0) - sten_out(i,:k0) = sten(:k0) - uten_out(i,:k0) = uten(:k0) - vten_out(i,:k0) = vten(:k0) - qrten_out(i,:k0) = qrten(:k0) - qsten_out(i,:k0) = qsten(:k0) - cufrc_out(i,:k0) = cufrc(:k0) - cush_inout(i) = cush - qldet_out(i,:k0) = qlten_det(:k0) - qidet_out(i,:k0) = qiten_det(:k0) - qlsub_out(i,:k0) = qlten_sink(:k0) - qisub_out(i,:k0) = qiten_sink(:k0) - ndrop_out(i,:k0) = qlten_det(:k0)/(4188.787*rdrop**3) -! ndrop_out(i,:k0) = qlten_det(:k0)/(4.19e-12) !(1.15e-11) ! /drop mass - nice_out(i,:k0) = qiten_det(:k0)/(3.0e-10) ! /crystal mass - qtflx_out(i,0:k0) = qtflx(0:k0) - slflx_out(i,0:k0) = slflx(0:k0) - uflx_out(i,0:k0) = uflx(0:k0) - vflx_out(i,0:k0) = vflx(0:k0) + qvten_out(:k0) = qvten(:k0) + qlten_out(:k0) = qlten(:k0) + qiten_out(:k0) = qiten(:k0) + sten_out(:k0) = sten(:k0) + uten_out(:k0) = uten(:k0) + vten_out(:k0) = vten(:k0) + qrten_out(:k0) = qrten(:k0) + qsten_out(:k0) = qsten(:k0) + cufrc_out(:k0) = cufrc(:k0) + cush_inout = cush + qldet_out(:k0) = qlten_det(:k0) + qidet_out(:k0) = qiten_det(:k0) + qlsub_out(:k0) = qlten_sink(:k0) + qisub_out(:k0) = qiten_sink(:k0) + ndrop_out(:k0) = qlten_det(:k0)/(4188.787*rdrop**3) +! ndrop_out(:k0) = qlten_det(:k0)/(4.19e-12) !(1.15e-11) ! /drop mass + nice_out(:k0) = qiten_det(:k0)/(3.0e-10) ! /crystal mass + qtflx_out(0:k0) = qtflx(0:k0) + slflx_out(0:k0) = slflx(0:k0) + uflx_out(0:k0) = uflx(0:k0) + vflx_out(0:k0) = vflx(0:k0) if (dotransport.eq.1) then do m = 1, ncnst - tr0_inout(i,:k0,m) = tr0_inout(i,:k0,m) + trten(:k0,m) * dt + tr0(:k0,m) = tr0(:k0,m) + trten(:k0,m) * dt enddo endif @@ -4454,86 +4481,86 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! analysis of cumulus scheme ! ! ------------------------------------------------- ! - fer_out(i,1:kpen) = fer(:kpen) - fdr_out(i,1:kpen) = fdr(:kpen) + fer_out(1:kpen) = fer(:kpen) + fdr_out(1:kpen) = fdr(:kpen) - cldhgt_out(i) = cldhgt - cbmf_out(i) = cbmf - plcl_out(i) = plcl - pinv_out(i) = pifc0(kinv-1) - plfc_out(i) = plfc - prel_out(i) = prel - pbup_out(i) = pifc0(kbup) + cldhgt_out = cldhgt + cbmf_out = cbmf + plcl_out = plcl + pinv_out = pifc0(kinv-1) + plfc_out = plfc + prel_out = prel + pbup_out = pifc0(kbup) #ifdef UWDIAG - cnt_out(i) = cnt - cnb_out(i) = cnb - qcu_out(i,:k0) = qcu(:k0) - qlu_out(i,:k0) = qlu(:k0) - qiu_out(i,:k0) = qiu(:k0) - qc_out(i,:k0) = qc(:k0) - xc_out(i,1:k0) = xco(:k0) - cinh_out(i) = cin - cinlclh_out(i) = cinlcl -! qtten_out(i,1:k0) = qtten(:k0) -! slten_out(i,1:k0) = slten(:k0) -! ufrc_out(i,0:k0) = ufrc(0:k0) -! uflx_out(i,0:k0) = uflx(0:k0) -! vflx_out(i,0:k0) = vflx(0:k0) + cnt_out = cnt + cnb_out = cnb + qcu_out(:k0) = qcu(:k0) + qlu_out(:k0) = qlu(:k0) + qiu_out(:k0) = qiu(:k0) + qc_out(:k0) = qc(:k0) + xc_out(1:k0) = xco(:k0) + cinh_out = cin + cinlclh_out = cinlcl +! qtten_out(1:k0) = qtten(:k0) +! slten_out(1:k0) = slten(:k0) +! ufrc_out(0:k0) = ufrc(0:k0) +! uflx_out(0:k0) = uflx(0:k0) +! vflx_out(0:k0) = vflx(0:k0) - ufrcinvbase_out(i) = ufrcinvbase - ufrclcl_out(i) = ufrclcl - winvbase_out(i) = winvbase - wlcl_out(i) = wlcl - ppen_out(i) = pifc0(kpen-1) + ppen - qtsrc_out(i) = qtsrc - thlsrc_out(i) = thlsrc - thvlsrc_out(i) = thvlsrc - emfkbup_out(i) = emf(kbup) - cbmflimit_out(i) = cbmflimit - tkeavg_out(i) = tkeavg - zinv_out(i) = zifc0(kinv-1) - rcwp_out(i) = rcwp - rlwp_out(i) = rlwp - riwp_out(i) = riwp - - wu_out(i,0:k0) = wu(0:k0) - qtu_out(i,0:k0) = qtu(0:k0) - thlu_out(i,0:k0) = thlu(0:k0) - thvu_out(i,0:k0) = thvu(0:k0) - uu_out(i,0:k0) = uu(0:k0) - vu_out(i,0:k0) = vu(0:k0) - qtu_emf_out(i,0:k0) = qtu_emf(0:k0) - thlu_emf_out(i,0:k0) = thlu_emf(0:k0) - uu_emf_out(i,0:k0) = uu_emf(0:k0) - vu_emf_out(i,0:k0) = vu_emf(0:k0) - uemf_out(i,0:k0) = uemf(0:k0) - - dwten_out(i,1:k0) = dwten(:k0) - diten_out(i,1:k0) = diten(:k0) - - excessu_arr_out(i,1:k0) = excessu_arr(:k0) - excess0_arr_out(i,1:k0) = excess0_arr(:k0) - xc_arr_out(i,1:k0) = xc_arr(:k0) - aquad_arr_out(i,1:k0) = aquad_arr(:k0) - bquad_arr_out(i,1:k0) = bquad_arr(:k0) - cquad_arr_out(i,1:k0) = cquad_arr(:k0) - bogbot_arr_out(i,1:k0) = bogbot_arr(:k0) - bogtop_arr_out(i,1:k0) = bogtop_arr(:k0) + ufrcinvbase_out = ufrcinvbase + ufrclcl_out = ufrclcl + winvbase_out = winvbase + wlcl_out = wlcl + ppen_out = pifc0(kpen-1) + ppen + qtsrc_out = qtsrc + thlsrc_out = thlsrc + thvlsrc_out = thvlsrc + emfkbup_out = emf(kbup) + cbmflimit_out = cbmflimit + tkeavg_out = tkeavg + zinv_out = zifc0(kinv-1) + rcwp_out = rcwp + rlwp_out = rlwp + riwp_out = riwp + + wu_out(0:k0) = wu(0:k0) + qtu_out(0:k0) = qtu(0:k0) + thlu_out(0:k0) = thlu(0:k0) + thvu_out(0:k0) = thvu(0:k0) + uu_out(0:k0) = uu(0:k0) + vu_out(0:k0) = vu(0:k0) + qtu_emf_out(0:k0) = qtu_emf(0:k0) + thlu_emf_out(0:k0) = thlu_emf(0:k0) + uu_emf_out(0:k0) = uu_emf(0:k0) + vu_emf_out(0:k0) = vu_emf(0:k0) + uemf_out(0:k0) = uemf(0:k0) + + dwten_out(1:k0) = dwten(:k0) + diten_out(1:k0) = diten(:k0) + + excessu_arr_out(1:k0) = excessu_arr(:k0) + excess0_arr_out(1:k0) = excess0_arr(:k0) + xc_arr_out(1:k0) = xc_arr(:k0) + aquad_arr_out(1:k0) = aquad_arr(:k0) + bquad_arr_out(1:k0) = bquad_arr(:k0) + cquad_arr_out(1:k0) = cquad_arr(:k0) + bogbot_arr_out(1:k0) = bogbot_arr(:k0) + bogtop_arr_out(1:k0) = bogtop_arr(:k0) ! if (dotransport.eq.1) then ! do m = 1, ncnst -! trten_out(i,:k0,m) = trten(:k0,m) -! trflx_out(i,0:k0,m) = trflx(0:k0,m) -! tru_out(i,0:k0,m) = tru(0:k0,m) -! tru_emf_out(i,0:k0,m) = tru_emf(0:k0,m) +! trten_out(:k0,m) = trten(:k0,m) +! trflx_out(0:k0,m) = trflx(0:k0,m) +! tru_out(0:k0,m) = tru(0:k0,m) +! tru_emf_out(0:k0,m) = tru_emf(0:k0,m) ! enddo ! endif #endif 333 if (id_exit) then - exit_uwcu(i) = 1. + exit_uwcu = 1. if (scverbose) then call write_parallel('------- UW ShCu: Exited!') end if @@ -4542,106 +4569,104 @@ subroutine compute_uwshcu(idim, k0, dt,ncnst, pifc0_in,zifc0_in,& ! IN ! Initialize output variables when cumulus convection was not performed.! ! --------------------------------------------------------------------- ! - umf_out(i,0:k0) = 0. - dcm_out(i,:k0) = 0. - qvten_out(i,:k0) = 0. - qlten_out(i,:k0) = 0. - qiten_out(i,:k0) = 0. - sten_out(i,:k0) = 0. - uten_out(i,:k0) = 0. - vten_out(i,:k0) = 0. - qrten_out(i,:k0) = 0. - qsten_out(i,:k0) = 0. - cufrc_out(i,:k0) = 0. - cush_inout(i) = -1. - qldet_out(i,:k0) = 0. - qidet_out(i,:k0) = 0. - qtflx_out(i,0:k0) = 0. - slflx_out(i,0:k0) = 0. - uflx_out(i,0:k0) = 0. - vflx_out(i,0:k0) = 0. - - fer_out(i,1:k0) = MAPL_UNDEF - fdr_out(i,1:k0) = MAPL_UNDEF - - cbmf_out(i) = 0. - plcl_out(i) = MAPL_UNDEF - pinv_out(i) = MAPL_UNDEF - prel_out(i) = MAPL_UNDEF - plfc_out(i) = MAPL_UNDEF - pbup_out(i) = MAPL_UNDEF - cldhgt_out(i) = MAPL_UNDEF + umf_out(0:k0) = 0. + dcm_out(:k0) = 0. + qvten_out(:k0) = 0. + qlten_out(:k0) = 0. + qiten_out(:k0) = 0. + sten_out(:k0) = 0. + uten_out(:k0) = 0. + vten_out(:k0) = 0. + qrten_out(:k0) = 0. + qsten_out(:k0) = 0. + cufrc_out(:k0) = 0. + cush_inout = -1. + qldet_out(:k0) = 0. + qidet_out(:k0) = 0. + qtflx_out(0:k0) = 0. + slflx_out(0:k0) = 0. + uflx_out(0:k0) = 0. + vflx_out(0:k0) = 0. + + fer_out(1:k0) = MAPL_UNDEF + fdr_out(1:k0) = MAPL_UNDEF + + cbmf_out = 0. + plcl_out = MAPL_UNDEF + pinv_out = MAPL_UNDEF + prel_out = MAPL_UNDEF + plfc_out = MAPL_UNDEF + pbup_out = MAPL_UNDEF + cldhgt_out = MAPL_UNDEF #ifdef UWDIAG - cnt_out(i) = 1. - cnb_out(i) = real(k0) - qcu_out(i,:k0) = 0. - qlu_out(i,:k0) = 0. - qiu_out(i,:k0) = 0. - qc_out(i,:k0) = 0. - xc_out(i,1:k0) = MAPL_UNDEF - cinh_out(i) = cin - cinlclh_out(i) = cinlcl -! qtten_out(i,k0:1:-1) = 0. -! slten_out(i,k0:1:-1) = 0. -! ufrc_out(i,k0:0:-1) = 0. -! uflx_out(i,k0:0:-1) = 0. -! vflx_out(i,k0:0:-1) = 0. - - ufrcinvbase_out(i) = 0. - ufrclcl_out(i) = 0. - winvbase_out(i) = 0. - wlcl_out(i) = MAPL_UNDEF - ppen_out(i) = MAPL_UNDEF - qtsrc_out(i) = MAPL_UNDEF - thlsrc_out(i) = MAPL_UNDEF - thvlsrc_out(i) = MAPL_UNDEF - emfkbup_out(i) = 0. - cbmflimit_out(i) = 0. - tkeavg_out(i) = tkeavg - zinv_out(i) = 0. - rcwp_out(i) = 0. - rlwp_out(i) = 0. - riwp_out(i) = 0. - - wu_out(i,k0:0:-1) = MAPL_UNDEF - qtu_out(i,k0:0:-1) = MAPL_UNDEF - thlu_out(i,k0:0:-1) = MAPL_UNDEF - thvu_out(i,k0:0:-1) = MAPL_UNDEF - uu_out(i,k0:0:-1) = MAPL_UNDEF - vu_out(i,k0:0:-1) = MAPL_UNDEF - qtu_emf_out(i,k0:0:-1) = MAPL_UNDEF - thlu_emf_out(i,k0:0:-1) = MAPL_UNDEF - uu_emf_out(i,k0:0:-1) = MAPL_UNDEF - vu_emf_out(i,k0:0:-1) = MAPL_UNDEF - uemf_out(i,k0:0:-1) = MAPL_UNDEF + cnt_out = 1. + cnb_out = real(k0) + qcu_out(:k0) = 0. + qlu_out(:k0) = 0. + qiu_out(:k0) = 0. + qc_out(:k0) = 0. + xc_out(1:k0) = MAPL_UNDEF + cinh_out = cin + cinlclh_out = cinlcl +! qtten_out(k0:1:-1) = 0. +! slten_out(k0:1:-1) = 0. +! ufrc_out(k0:0:-1) = 0. +! uflx_out(k0:0:-1) = 0. +! vflx_out(k0:0:-1) = 0. + + ufrcinvbase_out = 0. + ufrclcl_out = 0. + winvbase_out = 0. + wlcl_out = MAPL_UNDEF + ppen_out = MAPL_UNDEF + qtsrc_out = MAPL_UNDEF + thlsrc_out = MAPL_UNDEF + thvlsrc_out = MAPL_UNDEF + emfkbup_out = 0. + cbmflimit_out = 0. + tkeavg_out = tkeavg + zinv_out = 0. + rcwp_out = 0. + rlwp_out = 0. + riwp_out = 0. + + wu_out(k0:0:-1) = MAPL_UNDEF + qtu_out(k0:0:-1) = MAPL_UNDEF + thlu_out(k0:0:-1) = MAPL_UNDEF + thvu_out(k0:0:-1) = MAPL_UNDEF + uu_out(k0:0:-1) = MAPL_UNDEF + vu_out(k0:0:-1) = MAPL_UNDEF + qtu_emf_out(k0:0:-1) = MAPL_UNDEF + thlu_emf_out(k0:0:-1) = MAPL_UNDEF + uu_emf_out(k0:0:-1) = MAPL_UNDEF + vu_emf_out(k0:0:-1) = MAPL_UNDEF + uemf_out(k0:0:-1) = MAPL_UNDEF - dwten_out(i,k0:1:-1) = 0. - diten_out(i,k0:1:-1) = 0. - - excessu_arr_out(i,k0:1:-1) = 0. - excess0_arr_out(i,k0:1:-1) = 0. - xc_arr_out(i,k0:1:-1) = 0. - aquad_arr_out(i,k0:1:-1) = 0. - bquad_arr_out(i,k0:1:-1) = 0. - cquad_arr_out(i,k0:1:-1) = 0. - bogbot_arr_out(i,k0:1:-1) = 0. - bogtop_arr_out(i,k0:1:-1) = 0. + dwten_out(k0:1:-1) = 0. + diten_out(k0:1:-1) = 0. + + excessu_arr_out(k0:1:-1) = 0. + excess0_arr_out(k0:1:-1) = 0. + xc_arr_out(k0:1:-1) = 0. + aquad_arr_out(k0:1:-1) = 0. + bquad_arr_out(k0:1:-1) = 0. + cquad_arr_out(k0:1:-1) = 0. + bogbot_arr_out(k0:1:-1) = 0. + bogtop_arr_out(k0:1:-1) = 0. ! if (dotransport.eq.1) then ! do m = 1, ncnst -! trten_out(i,:k0,m) = 0. -! trflx_out(i,k0:0:-1,m) = 0. -! tru_out(i,k0:0:-1,m) = 0. -! tru_emf_out(i,k0:0:-1,m) = 0. +! trten_out(:k0,m) = 0. +! trflx_out(k0:0:-1,m) = 0. +! tru_out(k0:0:-1,m) = 0. +! tru_emf_out(k0:0:-1,m) = 0. ! enddo ! endif #endif end if - end do ! column i loop - return end subroutine compute_uwshcu diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 index 5ba1873b4b..ebcd67a43a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatch_GridComp/GEOS_CatchGridComp.F90 @@ -3620,7 +3620,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) ENDIF D0T = D0_BY_ZVEG*ZVG - DZE = max(DZ - D0T, 10.) + DZE = max(DZ - D0T, min(0.5*DZ,10.0)) ! was previously capped at 10m [problematic for L137/L181 with thinner surface layers] if(associated(Z0 )) Z0 = Z0T(:,N) if(associated(D0 )) D0 = D0T diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt index 09ff7482ea..21f6c7f389 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/CMakeLists.txt @@ -1,6 +1,40 @@ esma_set_this () +# First set alldirs to empty +set(alldirs) +# ... and srcs to the LandIceGridComp +set (srcs GEOS_LandIceGridComp.F90) + +# Then try to find ISSM +find_package (ISSM QUIET COMPONENTS Core) + +if(ISSM_FOUND) + # If ISSM is found, append the directory to alldirs + message(STATUS "ISSM found, building gridded component") + list (APPEND alldirs GEOSissm_GridComp) +else() + # If ISSM is not found, append the stub component to srcs + message(STATUS "ISSM not found, using stub component") + # For esma_create_stub_component, we need the name of the *module* + # that the landice gc is expecting, minus the mod. Also we + # have to use the variable srcs but not the ${srcs} because + # esma_create_stub_component is expecting the list itself, not the + # contents of the list. + esma_create_stub_component(srcs GEOS_IssmGridComp) +endif() + +# We have to do the above way because what esma_create_stub_component +# does is to append the stub component it creates in the build tree to a +# list of sources srcs. So if ISSM is found, we go into the subdir and +# build the real component, and if ISSM is not found, we create the stub +# component and append it to srcs. + esma_add_library (${this} - SRCS GEOS_LandIceGridComp.F90 - DEPENDENCIES MAPL GEOS_Shared GEOS_SurfaceShared ESMF::ESMF NetCDF::NetCDF_Fortran - ) + SRCS ${srcs} + SUBCOMPONENTS ${alldirs} + DEPENDENCIES MAPL GEOS_Shared GEOS_SurfaceShared ESMF::ESMF NetCDF::NetCDF_Fortran) + +if(ISSM_FOUND) + # If ISSM is found, add this definition + target_compile_definitions(${this} PRIVATE HAVE_ISSM) +endif() diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 index c22870a006..1abc31d675 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOS_LandIceGridComp.F90 @@ -10,11 +10,11 @@ module GEOS_LandiceGridCompMod ! !MODULE: GEOS_LandiceGridCompMod -- Implements slab landice tiles. ! !========================================================================== -! An improved version over the slab landice +! An improved version over the slab landice ! TODO : -! - Add multiple elevation classes support to account for ice sheet topo changes +! - Add multiple elevation classes support to account for ice sheet topo changes ! - Add more layers for a more realistic treatment of ice energy budget @@ -30,7 +30,7 @@ module GEOS_LandiceGridCompMod use StieglitzSnow, only: & snowrt => StieglitzSnow_snowrt, & SNOW_ALBEDO => StieglitzSnow_snow_albedo, & - TRID => StieglitzSnow_trid, & + TRID => StieglitzSnow_trid, & MINSWE => StieglitzSnow_MINSWE, & cpw => StieglitzSnow_CPW, & N_CONSTIT, & @@ -43,7 +43,13 @@ module GEOS_LandiceGridCompMod use MAPL use GEOS_UtilsMod use DragCoefficientsMod - + +#ifdef HAVE_ISSM + use GEOS_IssmGridCompMod, only : IssmSetServices => SetServices + use GEOS_IssmGridCompMod, only : T_ISSM_TILE_STATE + use GEOS_IssmGridCompMod, only : T_ISSM_TILE_WRAP +#endif + implicit none private @@ -55,11 +61,11 @@ module GEOS_LandiceGridCompMod integer, parameter :: NUM_SNOICE_LAYERS = NUM_SNOW_LAYERS+NUM_ICE_LAYERS real, parameter :: rad_to_deg = 180.0 / 3.1415926 - + ! snowrt related constants - ! will move these to a global module later + ! will move these to a global module later real, parameter :: ALHE = MAPL_ALHL ! J/kg @15C - real, parameter :: ALHM = MAPL_ALHF ! J/kg + real, parameter :: ALHM = MAPL_ALHF ! J/kg real, parameter :: TF = MAPL_TICE ! K real, parameter :: RHOW = MAPL_RHOWTR ! kg/m^3 @@ -67,11 +73,11 @@ module GEOS_LandiceGridCompMod real, parameter :: RHOICE = 917. ! kg/m^3 pure ice density real, parameter :: MAXSNDZ = 15.0 ! m real, parameter :: BIG = 1.e10 - real, parameter :: condice = 2.25 ! @ 0 C [W/m/K] + real, parameter :: condice = 2.25 ! @ 0 C [W/m/K] real, parameter :: MINFRACSNO = 1.e-20 ! mininum sno/ice fraction for ! heat diffusion of ice layers to take effect real, parameter :: LWCTOP = 1. ! top thickness to compute LWC. 1m taken from - ! Fettweis et al 2011 + ! Fettweis et al 2011 real, parameter :: VISMAX = 0.96 ! parameter for snow_albedo real, parameter :: NIRMAX = 0.68 ! parameter for snow_albedo real, parameter :: SLOPE = 1.0 ! parameter for snow_albedo @@ -81,15 +87,15 @@ module GEOS_LandiceGridCompMod AWTVDR = 0.00318, &! visible, direct ! for history and AWTIDR = 0.00182, &! near IR, direct ! diagnostics AWTVDF = 0.63282, &! visible, diffuse - AWTIDF = 0.36218 ! near IR, diffuse + AWTIDF = 0.36218 ! near IR, diffuse !real, dimension(NUM_SNOW_LAYERS), parameter :: DZMAX = (/0.08, 0.12, big/) real, dimension(NUM_SNOW_LAYERS), parameter :: DZMAX = (/0.08, 0.08, 0.08 & - , 0.15, 0.25, big, big, big, big, big, big, big, big, big, big/) + , 0.15, 0.25, big, big, big, big, big, big, big, big, big, big/) real, dimension(NUM_ICE_LAYERS), parameter :: DZMAXI = (/0.08, 0.08, 0.08 & - , 0.15, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.5, 3.0, 4.0/) - + , 0.15, 0.25, 0.5, 0.75, 1.0, 1.25, 1.5, 1.75, 2.0, 2.5, 3.0, 4.0/) + integer, parameter :: TAR_PE = 43 @@ -100,8 +106,10 @@ module GEOS_LandiceGridCompMod public SetServices + integer :: ISSM + ! !DESCRIPTION: -! +! ! {\tt GEOS\_Landice} is a light-weight gridded component that updates ! the landice tiles ! @@ -122,10 +130,10 @@ subroutine SetServices ( GC, RC ) type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component integer, optional :: RC ! return code -! !DESCRIPTION: +! !DESCRIPTION: ! This version uses the MAPL\_GenericSetServices, which sets ! the Initialize and Finalize services, as well as allocating -! our instance of a generic state and putting it in the +! our instance of a generic state and putting it in the ! gridded component (GC). Here we only need to set the run method and ! add the state variable specifications (also generic) to our instance ! of the generic state. This is the way our true state variables get into @@ -143,12 +151,13 @@ subroutine SetServices ( GC, RC ) integer :: STATUS character(len=ESMF_MAXSTR) :: COMP_NAME character(len=ESMF_MAXSTR) :: SURFRC - type(ESMF_Config) :: SCF + type(ESMF_Config) :: SCF !============================================================================= type(MAPL_MetaComp), pointer :: MAPL + integer :: DO_ISSM ! ISSM flag ! Begin... @@ -159,20 +168,32 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) Iam = trim(COMP_NAME) // 'SetServices' + ! Get my internal MAPL_Generic state +!----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + ! Set the Run entry point ! ----------------------- + !add initialize method for child (ISSM) + call MAPL_GetResource (MAPL, DO_ISSM, label='DO_ISSM:', DEFAULT=0, __RC__ ) - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run1, RC=STATUS ) - VERIFY_(STATUS) - call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) - VERIFY_(STATUS) +#ifndef HAVE_ISSM + DO_ISSM=0 +#endif -! Get my internal MAPL_Generic state -!----------------------------------- + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, RC=STATUS ) + VERIFY_(STATUS) - call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) - VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run1, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run2, RC=STATUS ) + VERIFY_(STATUS) + + ! Get resource parameters + ! ----------------------- call MAPL_GetResource (MAPL, SURFRC, label = 'SURFRC:', default = 'GEOS_SurfaceGridComp.rc', RC=STATUS) ; VERIFY_(STATUS) SCF = ESMF_ConfigCreate(rc=status) ; VERIFY_(STATUS) call ESMF_ConfigLoadFile(SCF,SURFRC,rc=status) ; VERIFY_(STATUS) @@ -188,6 +209,46 @@ subroutine SetServices ( GC, RC ) ! !Export state: + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICESMB', & + LONG_NAME = 'ice_surface_mass_balance', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICESURF', & + LONG_NAME = 'ice_surface_elevation', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICEVEL', & + LONG_NAME = 'ice_flow_speed', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICETHICK', & + LONG_NAME = 'ice_thickness', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RC=STATUS ) + VERIFY_(STATUS) + end if +#endif + call MAPL_AddExportSpec(GC, & SHORT_NAME = 'EMIS', & LONG_NAME = 'surface_emissivity', & @@ -356,7 +417,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'EVPICE_GL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -365,7 +426,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SUBLIM' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -374,7 +435,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SNOMAS_GL' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) @@ -384,7 +445,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SNOWMASS' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -583,7 +644,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SMELT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -592,7 +653,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'IMELT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -601,7 +662,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SNOWALB' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -610,7 +671,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SNICEALB' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -619,7 +680,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'MELTWTR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -628,7 +689,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'MELTWTRCONT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -637,7 +698,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'LWC' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -646,7 +707,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'RUNOFF' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -673,7 +734,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'Z0' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -682,7 +743,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'Z0H' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -781,7 +842,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'EVAPOUT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -790,7 +851,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SHOUT' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -799,7 +860,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'HLWUP' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& @@ -808,7 +869,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'LWNDSRF' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& @@ -817,7 +878,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'SWNDSRF' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -826,7 +887,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'HLATN' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -835,7 +896,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DNICFLX' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -844,7 +905,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'GHSNOW' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC, & @@ -853,7 +914,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'GHTSKIN' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& @@ -862,7 +923,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'ITY' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddExportSpec(GC ,& @@ -871,82 +932,95 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'RMELTDU001' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_2',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTDU002' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_3',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTDU003' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_4',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTDU004' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_dust_mass_flux_from_the_bottom_layer_bin_5',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTDU005' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_black_carbon_mass_flux_from_the_bottom_layer_bin_1',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTBC001' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_black_carbon_mass_flux_from_the_bottom_layer_bin_2',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTBC002' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_organic_carbon_mass_flux_from_the_bottom_layer_bin_1',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTOC001' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddExportSpec(GC ,& LONG_NAME = 'flushed_out_organic_carbon_mass_flux_from_the_bottom_layer_bin_2',& UNITS = 'kg m-2 s-1' ,& SHORT_NAME = 'RMELTOC002' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) ! !Internal state: +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICESMB_ISSM', & + LONG_NAME = 'issm_surface_mass_balance', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + DEFAULT = 0.0 , & + RC=STATUS ) + end if +#endif call MAPL_AddInternalSpec(GC, & SHORT_NAME = 'TS', & @@ -1065,7 +1139,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1077,7 +1151,7 @@ subroutine SetServices ( GC, RC ) RESTART = MAPL_RestartOptional, & VLOCATION = MAPL_VLocationNone, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1089,7 +1163,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1101,7 +1175,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1113,7 +1187,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1125,7 +1199,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1137,7 +1211,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1149,7 +1223,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddInternalSpec(GC, & @@ -1161,7 +1235,7 @@ subroutine SetServices ( GC, RC ) VLOCATION = MAPL_VLocationNone, & RESTART = MAPL_RestartOptional, & FRIENDLYTO = trim(COMP_NAME), & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) end if @@ -1194,7 +1268,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DRPAR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1203,7 +1277,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DFPAR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1212,7 +1286,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DRNIR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1221,7 +1295,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DFNIR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1230,7 +1304,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DRUVR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC ,& @@ -1239,7 +1313,7 @@ subroutine SetServices ( GC, RC ) SHORT_NAME = 'DFUVR' ,& DIMS = MAPL_DimsTileOnly ,& VLOCATION = MAPL_VLocationNone ,& - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) call MAPL_AddImportSpec(GC, & @@ -1424,9 +1498,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_DUDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'dust_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1434,9 +1508,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_DUSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'dust_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1444,9 +1518,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_DUWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'dust_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1454,9 +1528,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_DUSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'black_carbon_dry_depos_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1464,9 +1538,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_BCDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'black_carbon_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1474,9 +1548,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_BCSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'black_carbon_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1484,9 +1558,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_BCWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'black_carbon_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1494,9 +1568,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_BCSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'organic_carbon_dry_depos_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1504,9 +1578,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_OCDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'organic_carbon_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1514,9 +1588,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_OCSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'organic_carbon_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1524,9 +1598,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_OCWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'organic_carbon_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1534,9 +1608,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_OCSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sulfate_dry_depos_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1544,9 +1618,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SUDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sulfate_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1554,9 +1628,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SUSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sulfate_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1564,9 +1638,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SUWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sulfate_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1574,9 +1648,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SUSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sea_salt_dry_depos_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1584,9 +1658,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SSDP/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sea_salt_wet_depos_conv_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1594,9 +1668,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SSSV/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sea_salt_wet_depos_ls_scav_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1604,9 +1678,9 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SSWT/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) - + call MAPL_AddImportSpec(GC, & LONG_NAME = 'sea_salt_gravity_sett_all_bins', & UNITS = 'kg m-2 s-1', & @@ -1614,10 +1688,20 @@ subroutine SetServices ( GC, RC ) DIMS = MAPL_DimsTileOnly, & UNGRIDDED_DIMS = (/NUM_SSSD/), & VLOCATION = MAPL_VLocationNone, & - RC=STATUS ) + RC=STATUS ) VERIFY_(STATUS) !EOS +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + ! Add ISSM child gridcomp + ISSM = MAPL_AddChild(GC, NAME='ISSM', SS=IssmSetServices, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TerminateImport(GC, CHILD = ISSM, RC=STATUS) + VERIFY_(STATUS) + end if +#endif ! Set the Profiling timers ! ------------------------ @@ -1626,7 +1710,7 @@ subroutine SetServices ( GC, RC ) VERIFY_(STATUS) call MAPL_TimerAdd(GC, name="RUN2" ,RC=STATUS) VERIFY_(STATUS) - + ! Set generic init and final methods ! ---------------------------------- @@ -1635,12 +1719,143 @@ subroutine SetServices ( GC, RC ) RETURN_(ESMF_SUCCESS) - + end subroutine SetServices !BOP + + subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) + ! this is for ISSM to have access to to the tile locstream + + ! !ARGUMENTS: + + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code + + ! !DESCRIPTION: The Initialize method of the Landice Gridded Component. + + !EOP + + ! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + ! Local derived type aliases + + type (MAPL_MetaComp ), pointer :: MAPL + type (MAPL_MetaComp ), pointer :: CHILD_MAPL + type (MAPL_LocStream ) :: LOCSTREAM + type (ESMF_Config ) :: CF + type (ESMF_GridComp ), pointer :: GCS(:) + character(len=ESMF_MAXSTR), pointer :: gcnames(:) + + integer :: I +#ifdef HAVE_ISSM + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap + real, pointer, dimension(:) :: ICESURF + real, pointer, dimension(:) :: ICETHICK + real, pointer, dimension(:) :: ICEVEL +#endif + integer :: nt_local + integer :: DO_ISSM + real :: LANDICE_DT + + !============================================================================= + + ! Begin... + + ! Get the target components name and set-up traceback handle. + ! ----------------------------------------------------------- + + call ESMF_GridCompGet ( GC, name=COMP_NAME, RC=STATUS ) + VERIFY_(STATUS) + Iam = trim(COMP_NAME) // "Initialize" + + ! Get my internal MAPL_Generic state + !----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) + VERIFY_(STATUS) + + call MAPL_TimerOn(MAPL,"INITIALIZE", RC=STATUS ); VERIFY_(STATUS) + call MAPL_TimerOn(MAPL,"TOTAL", RC=STATUS ); VERIFY_(STATUS) + + ! Get the landice tilegrid and the child components + !----------------------------------------------- + + call MAPL_Get (MAPL, LOCSTREAM=LOCSTREAM, GCS=GCS, GCNAMES=gcnames, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_LocStreamGet(locstream, NT_LOCAL=nt_local, rc=STATUS) + VERIFY_(STATUS) + ! Place the land tilegrid in the generic state of each child component + !--------------------------------------------------------------------- + + ! get model timestep, overwrite with component-specific timestep if found + call MAPL_GetResource (MAPL, LANDICE_DT, label='RUN_DT:',_RC) + call MAPL_GetResource (MAPL, LANDICE_DT, label='DT:',default=LANDICE_DT,_RC) + + ! get ISSM flag + call MAPL_GetResource (MAPL, DO_ISSM, label='DO_ISSM:', DEFAULT=0, __RC__ ) + +#ifndef HAVE_ISSM + DO_ISSM=0 +#endif + +#ifdef HAVE_ISSM + ! Get Landice timestep to send to ISSM + do I = 1, SIZE(GCS) + call MAPL_GetObjectFromGC( GCS(I), CHILD_MAPL, RC=STATUS ) + VERIFY_(STATUS) + call MAPL_Set(CHILD_MAPL, LOCSTREAM=LOCSTREAM, RC=STATUS ) + VERIFY_(STATUS) + if (index(gcnames(I), 'ISSM') /=0 ) then + ! allocate landice tilespace variables for ISSM + allocate(issm_tile_state) + allocate(issm_tile_state%ICESURF_TILE(nt_local)) + allocate(issm_tile_state%ICETHICK_TILE(nt_local)) + allocate(issm_tile_state%ICEVEL_TILE(nt_local)) + allocate(issm_tile_state%ICESMB_ISSM(nt_local)) + issm_tile_state%LANDICE_DT = LANDICE_DT + issm_tile_wrap%ptr => issm_tile_state + call ESMF_UserCompSetInternalState(GCS(I), 'ISSM_TILES', issm_tile_wrap, status) + VERIFY_(STATUS) + endif + end do +#endif + call MAPL_TimerOff(MAPL,"TOTAL", RC=STATUS ); VERIFY_(STATUS) + + ! Call Initialize for every Child + !-------------------------------- + call MAPL_GenericInitialize ( GC, IMPORT, EXPORT, CLOCK, RC=STATUS) + VERIFY_(STATUS) + +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + ! initialize exports to restart values set by ISSM GridComp's Initialize, + ! because ISSM typically has a multi-day timestep and exports will remain empty otherwise + call MAPL_GetPointer(EXPORT,ICESURF , 'ICESURF',alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ICETHICK ,'ICETHICK',alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ICEVEL ,'ICEVEL',alloc=.true., RC=STATUS); VERIFY_(STATUS) + + if(associated(ICESURF)) ICESURF = issm_tile_state%ICESURF_TILE + if(associated(ICETHICK)) ICETHICK = issm_tile_state%ICETHICK_TILE + if(associated(ICEVEL)) ICEVEL = issm_tile_state%ICEVEL_TILE + end if +#endif + call MAPL_TimerOff(MAPL,"INITIALIZE", RC=STATUS ); VERIFY_(STATUS) + + RETURN_(ESMF_SUCCESS) + end subroutine Initialize + + ! !IROUTINE: RUN1 -- First Run stage for the LandIce component !INTERFACE: @@ -1649,7 +1864,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock @@ -1715,9 +1930,9 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:) :: UU real, pointer, dimension(:) :: UWINDLMTILE real, pointer, dimension(:) :: VWINDLMTILE - real, pointer, dimension(:) :: DZ + real, pointer, dimension(:) :: DZ real, pointer, dimension(:) :: TA - real, pointer, dimension(:) :: QA + real, pointer, dimension(:) :: QA real, pointer, dimension(:) :: PS integer :: N @@ -1768,7 +1983,7 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) integer :: CHOOSEZ0 !============================================================================= -! Begin... +! Begin... ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- @@ -2018,10 +2233,10 @@ subroutine RUN1 ( GC, IMPORT, EXPORT, CLOCK, RC ) CM(:,N) = VKM CH(:,N) = VKH CQ(:,N) = VKH - + CN = (MAPL_KARMAN/ALOG(DZ/Z0(:,N) + 1.0)) * (MAPL_KARMAN/ALOG(DZ/Z0(:,N) + 1.0)) ZT = Z0(:,N) - ZQ = Z0(:,N) + ZQ = Z0(:,N) RE = 0. UUU = UU UCN = 0. @@ -2124,17 +2339,20 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) !ARGUMENTS: - type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component type(ESMF_State), intent(inout) :: IMPORT ! Import state type(ESMF_State), intent(inout) :: EXPORT ! Export state type(ESMF_Clock), intent(inout) :: CLOCK ! The clock integer, optional, intent( out) :: RC ! Error code: - !DESCRIPTION: + !DESCRIPTION: ! Periodically refreshes the ozone mixing ratios. !EOP + type(MAPL_MetaComp), pointer :: CHILD_MAPL ! MAPL state for ISSM + type(ESMF_Alarm) :: ISSM_ALARM ! run alarm for ISSM component + ! ErrLog Variables @@ -2144,7 +2362,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Locals - type (MAPL_MetaComp), pointer :: MAPL + type (MAPL_MetaComp), pointer :: MAPL type (ESMF_State ) :: INTERNAL type (ESMF_Alarm ) :: ALARM type (ESMF_Config ) :: CF @@ -2155,9 +2373,17 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) type(MAPL_SunOrbit) :: ORBIT integer :: LANDICE_OFFLINE + integer :: DO_ISSM ! ISSM run flag + + type (ESMF_GridComp ), pointer :: GCS(:) + character(len=ESMF_MAXSTR), pointer :: gcnames(:) +#ifdef HAVE_ISSM + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap +#endif !============================================================================= -! Begin... +! Begin... ! Get the target components name and set-up traceback handle. ! ----------------------------------------------------------- @@ -2172,6 +2398,12 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_GetObjectFromGC ( GC, MAPL, RC=STATUS) VERIFY_(STATUS) + call MAPL_GetResource (MAPL, DO_ISSM, label='DO_ISSM:', DEFAULT=0, __RC__ ) + +#ifndef HAVE_ISSM + DO_ISSM=0 +#endif + ! Start Total timer !------------------ @@ -2187,7 +2419,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) ORBIT = ORBIT, & TILELATS = LATS, & TILELONS = LONS, & - !TILETYPES = TILETYPES, & + !TILETYPES = TILETYPES, & RUNALARM = ALARM, & RC=STATUS ) VERIFY_(STATUS) @@ -2212,7 +2444,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) call MAPL_TimerOff(MAPL,"RUN2") call MAPL_TimerOff(MAPL,"TOTAL") - + RETURN_(ESMF_SUCCESS) contains @@ -2221,19 +2453,28 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) subroutine LANDICECORE(RC) integer, optional, intent(OUT) :: RC - + ! Locals character(len=ESMF_MAXSTR) :: IAm integer :: STATUS -! pointers to export +! pointer to ISSM import via private internal state +! accumulate over time steps for averaging + real, pointer, dimension(:), save :: ICESMB_ISSM=>null() + integer, save :: ISSM_NSTEPS = 0 ! time steps since last ISSM run + +! pointers to export + real, pointer, dimension(: ) :: ICESMB + real, pointer, dimension(: ) :: ICESURF + real, pointer, dimension(: ) :: ICETHICK + real, pointer, dimension(: ) :: ICEVEL real, pointer, dimension(: ) :: EMISS - real, pointer, dimension(: ) :: ALBVF - real, pointer, dimension(: ) :: ALBVR - real, pointer, dimension(: ) :: ALBNF - real, pointer, dimension(: ) :: ALBNR + real, pointer, dimension(: ) :: ALBVF + real, pointer, dimension(: ) :: ALBVR + real, pointer, dimension(: ) :: ALBNF + real, pointer, dimension(: ) :: ALBNR real, pointer, dimension(: ) :: DELTS real, pointer, dimension(: ) :: DELQS real, pointer, dimension(: ) :: TST @@ -2262,11 +2503,11 @@ subroutine LANDICECORE(RC) real, pointer, dimension(:,:) :: DRHOS0 real, pointer, dimension(:,:) :: WESNEX real, pointer, dimension(: ) :: WESNEXT - real, pointer, dimension(: ) :: WESC - real, pointer, dimension(: ) :: SDSC - real, pointer, dimension(: ) :: WEPRE + real, pointer, dimension(: ) :: WESC + real, pointer, dimension(: ) :: SDSC + real, pointer, dimension(: ) :: WEPRE real, pointer, dimension(: ) :: SDPRE - real, pointer, dimension(: ) :: SD1PC + real, pointer, dimension(: ) :: SD1PC real, pointer, dimension(:,:) :: WEPERC real, pointer, dimension(:,:) :: WEREP real, pointer, dimension(: ) :: WEBOT @@ -2291,7 +2532,7 @@ subroutine LANDICECORE(RC) real, pointer, dimension(:) :: RMELTOC002 ! pointers to internal - + real, pointer, dimension(:) :: ICESMB_IN real, pointer, dimension(:,:) :: TS real, pointer, dimension(:,:) :: QS real, pointer, dimension(:,:) :: FR @@ -2412,8 +2653,8 @@ subroutine LANDICECORE(RC) real, allocatable :: LAI (:) real, allocatable :: GRN (:) real, allocatable :: MODISFAC(:) - real, allocatable :: SNOVR(:), SNONR(:), SNOVF(:), SNONF(:) - real, allocatable :: LNDVR(:), LNDNR(:), LNDVF(:), LNDNF(:) + real, allocatable :: SNOVR(:), SNONR(:), SNOVF(:), SNONF(:) + real, allocatable :: LNDVR(:), LNDNR(:), LNDVF(:), LNDNF(:) real, allocatable :: VSUVR (:) real, allocatable :: VSUVF (:) real, allocatable :: SWNETSNOW(:) @@ -2421,9 +2662,9 @@ subroutine LANDICECORE(RC) real, allocatable :: FHGND (:) real, allocatable :: DRHO0 (:,:) real, allocatable :: EXCS (:,:) - real, allocatable :: WESNSC(:), SNDZSC(:), WESNPREC(:), & - SNDZPREC(:), SNDZ1PERC(:) - real, allocatable :: WESNPERC(:,:), WESNDENS(:,:), WESNREPAR(:,:) + real, allocatable :: WESNSC(:), SNDZSC(:), WESNPREC(:), & + SNDZPREC(:), SNDZ1PERC(:) + real, allocatable :: WESNPERC(:,:), WESNDENS(:,:), WESNREPAR(:,:) real, allocatable :: WESNBOT(:) real, allocatable :: LANDICELT(:) real, allocatable :: RCONSTIT(:,:,:) @@ -2516,7 +2757,11 @@ subroutine LANDICECORE(RC) ! Pointers to internals !---------------------- - +#ifdef HAVE_ISSM +if (DO_ISSM==1) then + call MAPL_GetPointer(INTERNAL,ICESMB_IN , 'ICESMB_ISSM',alloc=.true., RC=STATUS); VERIFY_(STATUS) +end if +#endif call MAPL_GetPointer(INTERNAL,TS , 'TS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,QS , 'QS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(INTERNAL,FR , 'FR' , RC=STATUS); VERIFY_(STATUS) @@ -2542,7 +2787,15 @@ subroutine LANDICECORE(RC) ! Pointers to outputs !-------------------- +#ifdef HAVE_ISSM +if (DO_ISSM==1) then + call MAPL_GetPointer(EXPORT,ICESURF , 'ICESURF',alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ICETHICK ,'ICETHICK',alloc=.true., RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ICEVEL ,'ICEVEL',alloc=.true., RC=STATUS); VERIFY_(STATUS) +end if +#endif + call MAPL_GetPointer(EXPORT,ICESMB , 'ICESMB',alloc=.true., RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,EMISS , 'EMIS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,ALBVF , 'ALBVF' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,ALBVR , 'ALBVR' , RC=STATUS); VERIFY_(STATUS) @@ -2552,7 +2805,7 @@ subroutine LANDICECORE(RC) call MAPL_GetPointer(EXPORT,DELQS , 'DELQS' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,EVPICE , 'EVPICE_GL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SUBLIM , 'SUBLIM' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,ACCUM , 'ACCUM' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,ACCUM , 'ACCUM' , alloc=.true. , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SMELT , 'SMELT' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,IMELT , 'IMELT' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,RAINRFZ, 'RAINRFZ', RC=STATUS); VERIFY_(STATUS) @@ -2561,7 +2814,7 @@ subroutine LANDICECORE(RC) call MAPL_GetPointer(EXPORT,MELTWTR, 'MELTWTR', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,MELTWTRCONT, 'MELTWTRCONT', RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,LWC , 'LWC' , RC=STATUS); VERIFY_(STATUS) - call MAPL_GetPointer(EXPORT,RUNOFF , 'RUNOFF' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(EXPORT,RUNOFF , 'RUNOFF' , alloc=.true. ,RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SNOMAS , 'SNOMAS_GL' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SNOWMASS,'SNOWMASS',RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(EXPORT,SNOWDP , 'SNOWDP_GL' , RC=STATUS); VERIFY_(STATUS) @@ -2630,28 +2883,57 @@ subroutine LANDICECORE(RC) NT = size(ALW) + ! initialize running mean ICESMB and number of steps since last ISSM solve +#ifdef HAVE_ISSM + if(DO_ISSM==1) then + if (.not. associated(ICESMB_ISSM)) then + allocate(ICESMB_ISSM(NT),STAT=STATUS) + VERIFY_(STATUS) + + ! initialize from restart: + if (associated(ICESMB_IN)) then + ICESMB_ISSM(:) = ICESMB_IN(:) + else + ICESMB_ISSM(:) = 0 + end if + end if + + ! get number of timesteps from issm tile internal state + call MAPL_Get (MAPL, GCS=GCS, GCNAMES=GCNAMES, RC=STATUS ) + VERIFY_(STATUS) + do N=1, size(GCS) + if (index(GCNAMES(N), 'ISSM') /=0 ) then + call ESMF_UserCompGetInternalState(GCS(N), 'ISSM_TILES', issm_tile_wrap, status) + VERIFY_(STATUS) + issm_tile_state =>issm_tile_wrap%ptr + ISSM_NSTEPS = issm_tile_state%ISSM_NSTEPS + end if + end do + end if +#endif + allocate(MLT (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DTS (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DQS (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SHF (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LHF (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SHD (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LHD (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(CFT (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(CFQ (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SWN (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DIF (NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(ULW (NT), STAT=STATUS) VERIFY_(STATUS) @@ -2680,70 +2962,70 @@ subroutine LANDICECORE(RC) allocate(HLWO(NT) , STAT=STATUS) VERIFY_(STATUS) allocate(EVAPO(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LHFO(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SHFO(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(ZTH(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SLR(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(EVAPI(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DEVAPDT(NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(ITYPE(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LAI(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(GRN(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(MODISFAC(NT), STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SNOVR(NT), SNONR(NT), SNOVF(NT), SNONF(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(LNDVR(NT), LNDNR(NT), LNDVF(NT), LNDNF(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(VSUVR(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(VSUVF(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SWNETSNOW(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(RADDN(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(FHGND(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(DRHO0(NT,NUM_SNOW_LAYERS) , STAT=STATUS) VERIFY_(STATUS) allocate(EXCS(NT,NUM_SNOW_LAYERS) , STAT=STATUS) VERIFY_(STATUS) - allocate(WESNSC(NT), SNDZSC(NT), WESNPREC(NT), & - SNDZPREC(NT), SNDZ1PERC(NT), & + allocate(WESNSC(NT), SNDZSC(NT), WESNPREC(NT), & + SNDZPREC(NT), SNDZ1PERC(NT), & WESNBOT(NT), & - STAT=STATUS) + STAT=STATUS) VERIFY_(STATUS) allocate(WESNPERC(NT,NUM_SNOW_LAYERS), & WESNDENS(NT,NUM_SNOW_LAYERS), & WESNREPAR(NT,NUM_SNOW_LAYERS), & - STAT=STATUS) + STAT=STATUS) VERIFY_(STATUS) allocate(LANDICELT(NT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(WESNN (NUM_SNOW_LAYERS,NT)) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(HTSNN (NUM_SNOW_LAYERS,NT)) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(SNDZN (NUM_SNOW_LAYERS,NT)) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(RCONSTIT(NT, NUM_SNOW_LAYERS, N_CONSTIT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(TOTDEPOS(NT, N_CONSTIT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) allocate(RMELT(NT, N_CONSTIT) , STAT=STATUS) - VERIFY_(STATUS) + VERIFY_(STATUS) call ESMF_VMGetCurrent(VM, RC=STATUS) VERIFY_(STATUS) @@ -2752,23 +3034,23 @@ subroutine LANDICECORE(RC) call ESMF_VMGet(VM, localPet=mype, rc=status) VERIFY_(STATUS) - if(associated(EVAPOUT )) EVAPOUT = 0.0 + if(associated(EVAPOUT )) EVAPOUT = 0.0 if(associated(SUBLIM )) SUBLIM = 0.0 - if(associated(SHOUT )) SHOUT = 0.0 - if(associated(HLATN )) HLATN = 0.0 - if(associated(DELTS )) DELTS = 0.0 - if(associated(DELQS )) DELQS = 0.0 + if(associated(SHOUT )) SHOUT = 0.0 + if(associated(HLATN )) HLATN = 0.0 + if(associated(DELTS )) DELTS = 0.0 + if(associated(DELQS )) DELQS = 0.0 if(associated(SWNDSRF )) SWNDSRF = 0.0 if(associated(LWNDSRF )) LWNDSRF = 0.0 - if(associated(DNICFLX )) DNICFLX = 0.0 - if(associated(GHSNOW )) GHSNOW = 0.0 - if(associated(GHTSKIN )) GHTSKIN = 0.0 - if(associated(IMELT )) IMELT = 0.0 - if(associated(RUNOFF )) RUNOFF = 0.0 - if(associated(EVPICE )) EVPICE = 0.0 + if(associated(DNICFLX )) DNICFLX = 0.0 + if(associated(GHSNOW )) GHSNOW = 0.0 + if(associated(GHTSKIN )) GHTSKIN = 0.0 + if(associated(IMELT )) IMELT = 0.0 + if(associated(RUNOFF )) RUNOFF = 0.0 + if(associated(EVPICE )) EVPICE = 0.0 if(associated(HLWUP )) HLWUP = 0.0 if(associated(TICE0 )) TICE0 = 0.0 - if(associated(ACCUM )) ACCUM = 0.0 + if(associated(ACCUM )) ACCUM = 0.0 if(associated(MELTWTR )) MELTWTR = 0.0 if (N_constit>0) then @@ -2778,7 +3060,7 @@ subroutine LANDICECORE(RC) end if ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: - + select case (AEROSOL_DEPOSITION) case (0) DUDP(:,:)=0. @@ -2793,30 +3075,30 @@ subroutine LANDICECORE(RC) OCSV(:,:)=0. OCWT(:,:)=0. OCSD(:,:)=0. - + case (2) DUDP(:,:)=0. DUSV(:,:)=0. DUWT(:,:)=0. DUSD(:,:)=0. - + case (3) BCDP(:,:)=0. BCSV(:,:)=0. BCWT(:,:)=0. BCSD(:,:)=0. - + case (4) OCDP(:,:)=0. OCSV(:,:)=0. OCWT(:,:)=0. OCSD(:,:)=0. - + end select if (N_CONST_LANDICE4SNWALB /=0) then - + ! Convert the dimentions for LAAs from GEOS_SurfGridComp.F90 to GEOS_LandIceGridComp.F90 ! Note: Explanations of each variable ! TOTDEPOS(:,1): Combined dust deposition from size bin 1 (dry, conv-scav, ls-scav, sed) @@ -2894,17 +3176,17 @@ subroutine LANDICECORE(RC) ! RCONSTIT(:,:,15) = IRSS005(:,:) end if - LANDICELT = 0.0 - ZONEAREA = 1.0 + LANDICELT = 0.0 + ZONEAREA = 1.0 ! zc1 is not the actual thickness, but the vertical coordinate which is +ve upward ZC1 = -DZMAXI(1) * 0.5 TKGND = condice ! use value for ice at 0 degC PRECIP = PCU + PLS + SNO - RAIN = PCU + PLS + RAIN = PCU + PLS PERC = 0.0 MELTI = 0.0 FROZFRAC = 0.0 - TPSN = 0.0 + TPSN = 0.0 AREASC = 0.0 HCORR = 0.0 ghflxsno = 0.0 @@ -2922,13 +3204,13 @@ subroutine LANDICECORE(RC) WESNSC = 0.0 SNDZSC = 0.0 WESNPREC = 0.0 - SNDZPREC = 0.0 - SNDZ1PERC = 0.0 - WESNPERC = 0.0 - WESNDENS = 0.0 - WESNREPAR = 0.0 - RAINRF = 0.0 - MLT = 0.0 + SNDZPREC = 0.0 + SNDZ1PERC = 0.0 + WESNPERC = 0.0 + WESNDENS = 0.0 + WESNREPAR = 0.0 + RAINRF = 0.0 + MLT = 0.0 LNDVR = 0.0 LNDNR = 0.0 LNDVF = 0.0 @@ -2937,7 +3219,7 @@ subroutine LANDICECORE(RC) debugzth = .false. ! -------------------------------------------------------------------------- - ! Get the current time. + ! Get the current time. ! -------------------------------------------------------------------------- call ESMF_ClockGet( CLOCK, currTime=CURRENT_TIME, startTime=MODELSTART, TIMESTEP=DELT, RC=STATUS ) @@ -3001,8 +3283,8 @@ subroutine LANDICECORE(RC) VERIFY_(STATUS) ZTH = max(0.0,ZTH) - - do N=1,NUM_SUBTILES + + do N=1,NUM_SUBTILES if (LANDICE_OFFLINE == 0 ) then CFT = (CH(:,N)/CTATM) CFQ = (CQ(:,N)/CQATM) @@ -3021,7 +3303,7 @@ subroutine LANDICECORE(RC) LHD = CQ(:,N)*MAPL_ALHS*GEOS_DQSAT(TS(:,N), PS, PASCALS=.TRUE., RAMP=0.0) BLWN = LANDICEEMISS*MAPL_STFBOL*TS(:,N)*TS(:,N)*TS(:,N) ALWN = -3.0*BLWN*TS(:,N) - BLWN = 4.0*BLWN + BLWN = 4.0*BLWN endif SWN = ((DRUVR+DRPAR+DRNIR) + (DFUVR+DFPAR+DFNIR))*(1.0-LANDICEALB) @@ -3030,19 +3312,19 @@ subroutine LANDICECORE(RC) LANDICECAP= (MAPL_RHOWTR*MAPL_CAPICE*LANDICEDEPTH) - EVAPI = LHF / MAPL_ALHS + EVAPI = LHF / MAPL_ALHS DEVAPDT = LHD / MAPL_ALHS - RADDN = LWDNSRF + SWN + RADDN = LWDNSRF + SWN - PERC = 0.0 - MELTI = 0.0 + PERC = 0.0 + MELTI = 0.0 if(N==SNOW) then ITYPE = 9 LAI = 0.0 - GRN = 0.0 + GRN = 0.0 MODISFAC = 1.0 !*** have to do a transpose of these internals since their dimensions in SNOW_ALBEDO @@ -3050,9 +3332,9 @@ subroutine LANDICECORE(RC) WESNN = transpose(WESN) HTSNN = transpose(HTSN) SNDZN = transpose(SNDZ) - !*** call new/shared routine to compute albedo + !*** call new/shared routine to compute albedo - call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & + call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & RHOFRESH, VISMAX, NIRMAX, SLOPE, & !0.96, 0.68, 1.0, & ! WESNN, HTSNN, SNDZN, & ! snow stuff LNDVR, LNDNR, LNDVF, LNDNF, & ! instantaneous snow-free albedos on tiles @@ -3063,7 +3345,7 @@ subroutine LANDICECORE(RC) VSUVR = DRPAR + DRUVR VSUVF = DFPAR + DFUVR SWNETSNOW = (1.-SNOVR)*VSUVR + (1.-SNOVF)*VSUVF + (1.-SNONR)*DRNIR + (1.-SNONF)*DFNIR - RADDN = LWDNSRF + SWNETSNOW + RADDN = LWDNSRF + SWNETSNOW SWN = SWNETSNOW if(associated(SNOWALB)) then where(FR(:,N) > 0.0) @@ -3079,26 +3361,26 @@ subroutine LANDICECORE(RC) if(N==ICE) then do k=1,NT - if(FR(k,N) > MINFRACSNO) then + if(FR(k,N) > MINFRACSNO) then call SOLVEICELAYER(NUM_ICE_LAYERS, DT, TICE(k,N,:), DZMAXI, 0, & MELTI(k), DTSS=DTS(k), RUNOFF=PERC(k), & lhturb=LHF(k),hlwtc=ULW(k),hsturb=SHF(k),raddn=RADDN(k), & dlhdtc=LHD(k),dhsdtc=SHD(k),dhlwtc=BLWN(k),rain=RAIN(k), & - rainrf=RAINRF(k), & + rainrf=RAINRF(k), & lhflux=LHFO(k),shflux=SHFO(k),hlwout=HLWO(k),evapout=EVAPO(k), & ghflxice=ghflxice(k)) else TICE(k,N,:) = TICE(k,SNOW,:) endif - enddo + enddo TS(:,N) = TICE(:,N,1) if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC endif - if(N==SNOW) then + if(N==SNOW) then LANDICELT = TICE(:,N,1) - MAPL_TICE do k=1,NT -#if 0 +#if 0 LATSD=LATS(K)*rad_to_deg LONSD=LONS(K)*rad_to_deg !if(abs(LATSD-0.700003698112E+02) < 1.e-3 .and. & @@ -3107,46 +3389,46 @@ subroutine LANDICECORE(RC) ! abs(LONSD-(-0.433431029954E+02)) < 1.e-3 ) then if(abs(LATSD-0.807870232172E+02) < 1.e-3 .and. & abs(LONSD-(-0.154247429558E+02)) < 1.e-3 ) then - print*, 'PE = ', mype, ' tile = ',k - endif + print*, 'PE = ', mype, ' tile = ',k + endif #endif - TKSNO = condice + TKSNO = condice call SNOWRT( LONS(k), LATS(k), & ! in [radians] !!! - 1,NUM_SNOW_LAYERS,MAPL_LANDICE, & ! in - MAXSNDZ, RHOFRESH, DZMAX, & ! in - LANDICELT(k),ZONEAREA,TKGND,PRECIP(k),SNO(k),TA(k),DT, & ! in - EVAPI(k),DEVAPDT(k),SHF(k),SHD(k),ULW(k),BLWN(k), & ! in - RADDN(k),ZC1,TOTDEPOS(k,:), & ! in - WESN(k,:),HTSN(k,:),SNDZ(k,:), RCONSTIT(k,:,:), & ! inout - HLWO(k), FROZFRAC(k,:),TPSN(k,:), RMELT(k,:), & ! out - AREASC(k),FR(K,N),PERC(k),FHGND(k), & ! out - EVAPO(k),SHFO(k),LHFO(k),HCORR(k),ghflxsno(k), & ! out - SNDZSC(k), WESNPREC(k), SNDZPREC(k),SNDZ1PERC(k), & ! out - WESNPERC(k,:), WESNDENS(k,:), WESNREPAR(k,:), MLT(k), & ! out - EXCS(k,:), DRHO0(k,:), WESNBOT(k), TKSNO, DTS(k) ) ! out + 1,NUM_SNOW_LAYERS,MAPL_LANDICE, & ! in + MAXSNDZ, RHOFRESH, DZMAX, & ! in + LANDICELT(k),ZONEAREA,TKGND,PRECIP(k),SNO(k),TA(k),DT, & ! in + EVAPI(k),DEVAPDT(k),SHF(k),SHD(k),ULW(k),BLWN(k), & ! in + RADDN(k),ZC1,TOTDEPOS(k,:), & ! in + WESN(k,:),HTSN(k,:),SNDZ(k,:), RCONSTIT(k,:,:), & ! inout + HLWO(k), FROZFRAC(k,:),TPSN(k,:), RMELT(k,:), & ! out + AREASC(k),FR(K,N),PERC(k),FHGND(k), & ! out + EVAPO(k),SHFO(k),LHFO(k),HCORR(k),ghflxsno(k), & ! out + SNDZSC(k), WESNPREC(k), SNDZPREC(k),SNDZ1PERC(k), & ! out + WESNPERC(k,:), WESNDENS(k,:), WESNREPAR(k,:), MLT(k), & ! out + EXCS(k,:), DRHO0(k,:), WESNBOT(k), TKSNO, DTS(k) ) ! out ! Snow impurities update if (N_CONST_LANDICE4SNWALB /= 0) then - if(associated(IRDU001)) IRDU001(k,:) = RCONSTIT(k,:,1) - if(associated(IRDU002)) IRDU002(k,:) = RCONSTIT(k,:,2) - if(associated(IRDU003)) IRDU003(k,:) = RCONSTIT(k,:,3) - if(associated(IRDU004)) IRDU004(k,:) = RCONSTIT(k,:,4) - if(associated(IRDU005)) IRDU005(k,:) = RCONSTIT(k,:,5) - if(associated(IRBC001)) IRBC001(k,:) = RCONSTIT(k,:,6) - if(associated(IRBC002)) IRBC002(k,:) = RCONSTIT(k,:,7) - if(associated(IROC001)) IROC001(k,:) = RCONSTIT(k,:,8) - if(associated(IROC002)) IROC002(k,:) = RCONSTIT(k,:,9) + if(associated(IRDU001)) IRDU001(k,:) = RCONSTIT(k,:,1) + if(associated(IRDU002)) IRDU002(k,:) = RCONSTIT(k,:,2) + if(associated(IRDU003)) IRDU003(k,:) = RCONSTIT(k,:,3) + if(associated(IRDU004)) IRDU004(k,:) = RCONSTIT(k,:,4) + if(associated(IRDU005)) IRDU005(k,:) = RCONSTIT(k,:,5) + if(associated(IRBC001)) IRBC001(k,:) = RCONSTIT(k,:,6) + if(associated(IRBC002)) IRBC002(k,:) = RCONSTIT(k,:,7) + if(associated(IROC001)) IROC001(k,:) = RCONSTIT(k,:,8) + if(associated(IROC002)) IROC002(k,:) = RCONSTIT(k,:,9) end if if (N_constit>0) then - if(associated(RMELTDU001)) RMELTDU001(k) = RMELT(k,1) - if(associated(RMELTDU002)) RMELTDU002(k) = RMELT(k,2) - if(associated(RMELTDU003)) RMELTDU003(k) = RMELT(k,3) - if(associated(RMELTDU004)) RMELTDU004(k) = RMELT(k,4) - if(associated(RMELTDU005)) RMELTDU005(k) = RMELT(k,5) - if(associated(RMELTBC001)) RMELTBC001(k) = RMELT(k,6) - if(associated(RMELTBC002)) RMELTBC002(k) = RMELT(k,7) - if(associated(RMELTOC001)) RMELTOC001(k) = RMELT(k,8) + if(associated(RMELTDU001)) RMELTDU001(k) = RMELT(k,1) + if(associated(RMELTDU002)) RMELTDU002(k) = RMELT(k,2) + if(associated(RMELTDU003)) RMELTDU003(k) = RMELT(k,3) + if(associated(RMELTDU004)) RMELTDU004(k) = RMELT(k,4) + if(associated(RMELTDU005)) RMELTDU005(k) = RMELT(k,5) + if(associated(RMELTBC001)) RMELTBC001(k) = RMELT(k,6) + if(associated(RMELTBC002)) RMELTBC002(k) = RMELT(k,7) + if(associated(RMELTOC001)) RMELTOC001(k) = RMELT(k,8) if(associated(RMELTOC002)) RMELTOC002(k) = RMELT(k,9) end if @@ -3157,36 +3439,36 @@ subroutine LANDICECORE(RC) LWC(k) = sum(WESN(k,:)*(1.-FROZFRAC(k,:)))/sum(WESN(k,:)) else KL = 0 - ZKL = 0.0 + ZKL = 0.0 do l=1,NUM_SNOW_LAYERS - ZKL = ZKL + SNDZ(k,l) + ZKL = ZKL + SNDZ(k,l) if(ZKL > LWCTOP) then KL = l exit endif - enddo + enddo ALPHA = 1.0 - (ZKL-LWCTOP)/SNDZ(k,KL) LWC(k) = (sum(WESN(k,1:KL-1)*(1.-FROZFRAC(k,1:KL-1)))+ & ALPHA*WESN(k,KL)*(1.-FROZFRAC(k,KL))) / & - (sum(WESN(k,1:KL-1))+ALPHA*WESN(k,KL)) + (sum(WESN(k,1:KL-1))+ALPHA*WESN(k,KL)) endif else LWC(k) = 0.0 - endif + endif endif if(FR(K,N) < MINFRACSNO) then TICE(k,N,:) = TICE(k,ICE,:) else call SOLVEICELAYER(NUM_ICE_LAYERS, DT, TICE(k,N,:), DZMAXI, 1, & MELTI(k), & - condsno=TKSNO(NUM_SNOW_LAYERS), & - !tsn=TPSN(k,NUM_SNOW_LAYERS), & - fhgnd=FHGND(k), & + condsno=TKSNO(NUM_SNOW_LAYERS), & + !tsn=TPSN(k,NUM_SNOW_LAYERS), & + fhgnd=FHGND(k), & sndz=SNDZ(k,NUM_SNOW_LAYERS) & ) if(associated(RUNOFF)) RUNOFF(K) = RUNOFF(K) + FR(K,N) * MELTI(K) - endif - enddo + endif + enddo WESNSC = EVAPO !PERC = PERC + MELTI if(associated(RUNOFF)) RUNOFF = RUNOFF + PERC @@ -3195,11 +3477,11 @@ subroutine LANDICECORE(RC) endif DQS = GEOS_QSAT(TS(:,N), PS, PASCALS=.TRUE.,RAMP=0.0) - QS(:,N) - QS(:,N) = QS(:,N) + DQS + QS(:,N) = QS(:,N) + DQS LHF = LHFO SHF = SHFO - ULW = HLWO + ULW = HLWO if(associated(EVAPOUT)) EVAPOUT = EVAPOUT + FR(:,N)*EVAPO if(associated(SUBLIM )) SUBLIM = SUBLIM + FR(:,N)*EVAPO @@ -3218,21 +3500,21 @@ subroutine LANDICECORE(RC) if(associated(HLWUP )) HLWUP = HLWUP + ULW * FR(:,N) if(associated(DNICFLX )) DNICFLX = DNICFLX + DIF * FR(:,N) if(associated(GHSNOW )) GHSNOW = ghflxsno - if(associated(ACCUM )) ACCUM = ACCUM - FR(:,N) * EVAPO - if(associated(MELTWTR )) MELTWTR = MELTWTR + FR(:,N) * MELTI + if(associated(ACCUM )) ACCUM = ACCUM - FR(:,N) * EVAPO + if(associated(MELTWTR )) MELTWTR = MELTWTR + FR(:,N) * MELTI if(associated(TICE0 )) then do k=1,NT TICE0(k,:) = TICE0(k,:) + TICE(k,N,:) * FR(k,N) enddo - endif + endif - enddo ! NUM_SUBTILES + enddo ! NUM_SUBTILES FR(:,ICE) = max(1.0-FR(:,SNOW), 0.0) if(associated(GHTSKIN )) GHTSKIN = ghflxsno*FR(:,SNOW) + ghflxice*FR(:,ICE) - if(associated(ACCUM )) ACCUM = ACCUM + PRECIP + if(associated(ACCUM )) ACCUM = ACCUM + PRECIP if(associated(EMISS )) EMISS = LANDICEEMISS if(associated(SNOWMASS)) SNOWMASS = sum(WESN,dim=2) @@ -3241,8 +3523,21 @@ subroutine LANDICECORE(RC) if(associated(ASNOW)) ASNOW = FR(:,SNOW) if(associated(SMELT )) SMELT = PERC if(associated(RAINRFZ )) RAINRFZ = FR(:,ICE) * RAINRF - if(associated(MELTWTR )) MELTWTR = MELTWTR + MLT + if(associated(MELTWTR )) MELTWTR = MELTWTR + MLT + + + ! Calculate surface mass balance (SMB) for ISSM + if(associated(ICESMB)) ICESMB = ACCUM - RUNOFF + + ! average ICESMB over time steps between ISSM runs + if(DO_ISSM==1) then + if(associated(ICESMB_ISSM)) ICESMB_ISSM = ICESMB_ISSM + (ICESMB-ICESMB_ISSM)/(ISSM_NSTEPS+1) + ISSM_NSTEPS = ISSM_NSTEPS + 1 ! accumulated timesteps since last ISSM run + + ! update internal state + ICESMB_IN(:) = ICESMB_ISSM(:) + end if ! Update snow and landice albedos to anticipate ! next radiation calculation !----------------------------------------------- @@ -3257,7 +3552,7 @@ subroutine LANDICECORE(RC) ITYPE = 9 - call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & + call SNOW_ALBEDO(NT, NUM_SNOW_LAYERS, N_CONST_LANDICE4SNWALB, ITYPE, LAI, ZTH, & RHOFRESH, VISMAX, NIRMAX, SLOPE, & ! 0.96, 0.68, 1.0, & ! WESNN, HTSNN, SNDZN, & ! snow stuff LNDVR, LNDNR, LNDVF, LNDNF, & ! instantaneous snow-free albedos on tiles @@ -3272,7 +3567,7 @@ subroutine LANDICECORE(RC) if(associated(SNICEALB )) then - SNICEALB = FR(:,ICE)*LANDICEALB + & + SNICEALB = FR(:,ICE)*LANDICEALB + & FR(:,SNOW)*(SNOVR*AWTVDR + SNOVF*AWTVDF & + SNONR*AWTIDR + SNONF*AWTIDF) where(ZTH < 1.e-6) @@ -3299,23 +3594,23 @@ subroutine LANDICECORE(RC) if(associated(RHOSNOW )) then RHOSNOW = 0.0 - do N=1,NUM_SNOW_LAYERS + do N=1,NUM_SNOW_LAYERS !where(FR(:,SNOW) > 0.0 .and. SNDZ(:,N) > 0.0) where(sum(WESN,dim=2) > MINSWE) RHOSNOW(:,N) = WESN(:,N) / FR(:,SNOW) / SNDZ(:,N) elsewhere - RHOSNOW(:,N) = MAPL_UNDEF + RHOSNOW(:,N) = MAPL_UNDEF endwhere enddo end if if(associated(TSNOW )) then TSNOW = 0.0 - do N=1,NUM_SNOW_LAYERS + do N=1,NUM_SNOW_LAYERS where(FR(:,SNOW) > 0.0 .and. SNDZ(:,N) > 0.0) TSNOW(:,N) = TPSN(:,N) elsewhere - TSNOW(:,N) = MAPL_UNDEF + TSNOW(:,N) = MAPL_UNDEF endwhere enddo end if @@ -3341,7 +3636,7 @@ subroutine LANDICECORE(RC) end if if(associated(WESC )) then - WESC = WESNSC + WESC = WESNSC end if if(associated(SDSC )) then @@ -3376,23 +3671,63 @@ subroutine LANDICECORE(RC) WEBOT = WESNBOT / DT end if - if(allocated (MLT)) deallocate(MLT , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DTS)) deallocate(DTS , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DQS)) deallocate(DQS , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SHF)) deallocate(SHF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LHF)) deallocate(LHF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SHD)) deallocate(SHD , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LHD)) deallocate(LHD , STAT=STATUS); VERIFY_(STATUS) - if(allocated (CFT)) deallocate(CFT , STAT=STATUS); VERIFY_(STATUS) - if(allocated (CFQ)) deallocate(CFQ , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SWN)) deallocate(SWN , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DIF)) deallocate(DIF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (ULW)) deallocate(ULW , STAT=STATUS); VERIFY_(STATUS) - if(allocated (PRECIP )) deallocate(PRECIP , STAT=STATUS); VERIFY_(STATUS) - if(allocated (RAIN )) deallocate(RAIN , STAT=STATUS); VERIFY_(STATUS) - if(allocated (RAINRF )) deallocate(RAINRF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (PERC )) deallocate(PERC , STAT=STATUS); VERIFY_(STATUS) - if(allocated (MELTI )) deallocate(MELTI , STAT=STATUS); VERIFY_(STATUS) +! Run ISSM +#ifdef HAVE_ISSM + if (DO_ISSM==1) then + call MAPL_Get (MAPL, GCS=GCS, GCNAMES=GCNAMES, RC=STATUS ) + do N=1, size(GCS) + if (index(GCNAMES(N), 'ISSM') /=0 ) then + call MAPL_GetObjectFromGC(GCS(N), CHILD_MAPL, RC=STATUS); VERIFY_(STATUS) + call MAPL_Get(CHILD_MAPL, RUNALARM = ISSM_ALARM, RC=STATUS); VERIFY_(STATUS) + + issm_tile_state%ICESMB_ISSM = ICESMB_ISSM + issm_tile_state%ISSM_NSTEPS = ISSM_NSTEPS + + ! call ISSM run method every time landice runs so that restarts will persist + ! ISSM Run method only calls the ISSM C++ solvers at ISSM_DT intervals + call MAPL_GenericRunChildren(GC, IMPORT, EXPORT, CLOCK, RC=STATUS) + VERIFY_(STATUS) + + if (ESMF_AlarmIsRinging (ISSM_ALARM, RC=STATUS)) then + ! if ISSM solvers were called, get exports on tile space + if(associated(ICESURF)) ICESURF = issm_tile_state%ICESURF_TILE + if(associated(ICETHICK)) ICETHICK = issm_tile_state%ICETHICK_TILE + if(associated(ICEVEL)) ICEVEL = issm_tile_state%ICEVEL_TILE + + ! refresh ICESMB accumulator + ISSM_NSTEPS = 0 ! set ISSM time step accumulation back to zero + ICESMB_ISSM(:) = 0 ! zero out ICESMB running average + + ! update private internal state + issm_tile_state%ICESMB_ISSM = ICESMB_ISSM + issm_tile_state%ISSM_NSTEPS = ISSM_NSTEPS + + ! update internal state for running-mean ICESMB + ICESMB_IN(:) = ICESMB_ISSM(:) + + end if + end if + end do + end if +#endif + + if(allocated (MLT)) deallocate(MLT , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DTS)) deallocate(DTS , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DQS)) deallocate(DQS , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SHF)) deallocate(SHF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LHF)) deallocate(LHF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SHD)) deallocate(SHD , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LHD)) deallocate(LHD , STAT=STATUS); VERIFY_(STATUS) + if(allocated (CFT)) deallocate(CFT , STAT=STATUS); VERIFY_(STATUS) + if(allocated (CFQ)) deallocate(CFQ , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SWN)) deallocate(SWN , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DIF)) deallocate(DIF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (ULW)) deallocate(ULW , STAT=STATUS); VERIFY_(STATUS) + if(allocated (PRECIP )) deallocate(PRECIP , STAT=STATUS); VERIFY_(STATUS) + if(allocated (RAIN )) deallocate(RAIN , STAT=STATUS); VERIFY_(STATUS) + if(allocated (RAINRF )) deallocate(RAINRF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (PERC )) deallocate(PERC , STAT=STATUS); VERIFY_(STATUS) + if(allocated (MELTI )) deallocate(MELTI , STAT=STATUS); VERIFY_(STATUS) if(allocated (FROZFRAC)) deallocate(FROZFRAC, STAT=STATUS); VERIFY_(STATUS) if(allocated (TPSN )) deallocate(TPSN , STAT=STATUS); VERIFY_(STATUS) if(allocated (AREASC )) deallocate(AREASC , STAT=STATUS); VERIFY_(STATUS) @@ -3400,32 +3735,32 @@ subroutine LANDICECORE(RC) if(allocated (ghflxsno)) deallocate(ghflxsno, STAT=STATUS); VERIFY_(STATUS) if(allocated (ghflxice)) deallocate(ghflxice, STAT=STATUS); VERIFY_(STATUS) if(allocated (HLWO )) deallocate(HLWO , STAT=STATUS); VERIFY_(STATUS) - if(allocated (EVAPO )) deallocate(EVAPO , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LHFO )) deallocate(LHFO , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SHFO )) deallocate(SHFO , STAT=STATUS); VERIFY_(STATUS) - if(allocated (ZTH )) deallocate(ZTH , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SLR )) deallocate(SLR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (EVAPI )) deallocate(EVAPI , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DEVAPDT )) deallocate(DEVAPDT , STAT=STATUS); VERIFY_(STATUS) - if(allocated (ITYPE )) deallocate(ITYPE , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LAI )) deallocate(LAI , STAT=STATUS); VERIFY_(STATUS) - if(allocated (GRN )) deallocate(GRN , STAT=STATUS); VERIFY_(STATUS) - if(allocated (MODISFAC)) deallocate(MODISFAC, STAT=STATUS); VERIFY_(STATUS) - if(allocated (SNOVR )) deallocate(SNOVR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SNONR )) deallocate(SNONR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SNOVF )) deallocate(SNOVF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SNONF )) deallocate(SNONF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LNDVR )) deallocate(LNDVR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LNDNR )) deallocate(LNDNR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LNDVF )) deallocate(LNDVF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (LNDNF )) deallocate(LNDNF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (VSUVR )) deallocate(VSUVR , STAT=STATUS); VERIFY_(STATUS) - if(allocated (VSUVF )) deallocate(VSUVF , STAT=STATUS); VERIFY_(STATUS) - if(allocated (SWNETSNOW)) deallocate(SWNETSNOW, STAT=STATUS); VERIFY_(STATUS) - if(allocated (RADDN )) deallocate(RADDN , STAT=STATUS); VERIFY_(STATUS) - if(allocated (FHGND )) deallocate(FHGND , STAT=STATUS); VERIFY_(STATUS) - if(allocated (DRHO0 )) deallocate(DRHO0 , STAT=STATUS); VERIFY_(STATUS) - if(allocated (EXCS )) deallocate(EXCS , STAT=STATUS); VERIFY_(STATUS) + if(allocated (EVAPO )) deallocate(EVAPO , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LHFO )) deallocate(LHFO , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SHFO )) deallocate(SHFO , STAT=STATUS); VERIFY_(STATUS) + if(allocated (ZTH )) deallocate(ZTH , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SLR )) deallocate(SLR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (EVAPI )) deallocate(EVAPI , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DEVAPDT )) deallocate(DEVAPDT , STAT=STATUS); VERIFY_(STATUS) + if(allocated (ITYPE )) deallocate(ITYPE , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LAI )) deallocate(LAI , STAT=STATUS); VERIFY_(STATUS) + if(allocated (GRN )) deallocate(GRN , STAT=STATUS); VERIFY_(STATUS) + if(allocated (MODISFAC)) deallocate(MODISFAC, STAT=STATUS); VERIFY_(STATUS) + if(allocated (SNOVR )) deallocate(SNOVR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SNONR )) deallocate(SNONR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SNOVF )) deallocate(SNOVF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SNONF )) deallocate(SNONF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LNDVR )) deallocate(LNDVR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LNDNR )) deallocate(LNDNR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LNDVF )) deallocate(LNDVF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (LNDNF )) deallocate(LNDNF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (VSUVR )) deallocate(VSUVR , STAT=STATUS); VERIFY_(STATUS) + if(allocated (VSUVF )) deallocate(VSUVF , STAT=STATUS); VERIFY_(STATUS) + if(allocated (SWNETSNOW)) deallocate(SWNETSNOW, STAT=STATUS); VERIFY_(STATUS) + if(allocated (RADDN )) deallocate(RADDN , STAT=STATUS); VERIFY_(STATUS) + if(allocated (FHGND )) deallocate(FHGND , STAT=STATUS); VERIFY_(STATUS) + if(allocated (DRHO0 )) deallocate(DRHO0 , STAT=STATUS); VERIFY_(STATUS) + if(allocated (EXCS )) deallocate(EXCS , STAT=STATUS); VERIFY_(STATUS) if(allocated (WESNSC )) deallocate(WESNSC , STAT=STATUS); VERIFY_(STATUS) if(allocated (SNDZSC )) deallocate(SNDZSC , STAT=STATUS); VERIFY_(STATUS) if(allocated (WESNPREC )) deallocate(WESNPREC , STAT=STATUS); VERIFY_(STATUS) @@ -3440,10 +3775,10 @@ subroutine LANDICECORE(RC) if(allocated (HTSNN )) deallocate(HTSNN , STAT=STATUS); VERIFY_(STATUS) if(allocated (SNDZN )) deallocate(SNDZN , STAT=STATUS); VERIFY_(STATUS) -! All done -!----------- +! All done +!----------- - RETURN_(ESMF_SUCCESS) + RETURN_(ESMF_SUCCESS) end subroutine LANDICECORE @@ -3459,7 +3794,7 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & lhflux,shflux,hlwout,evapout, & condsno, fhgnd, sndz, ghflxice ) - implicit none + implicit none integer, intent(in) :: NICE real, intent(in ) :: DTS @@ -3475,28 +3810,28 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & real, optional, intent(in ) :: dlhdtc,dhsdtc,dhlwtc real, optional, intent(in ) :: rain real, optional, intent(out) :: rainrf - real, optional, intent(out) :: lhflux,shflux,hlwout,evapout + real, optional, intent(out) :: lhflux,shflux,hlwout,evapout real, optional, intent(out) :: ghflxice ! UPPER_BND == 1 - real, optional, intent(in ) :: condsno, fhgnd, sndz + real, optional, intent(in ) :: condsno, fhgnd, sndz ! Locals real :: melti,frrain,dtr,tsx,mass,snowd,rainf,denom,alhv,hcorr, & - enew,eold,tdum,fnew,tnew,icedens,densfac,hnew - integer :: i + enew,eold,tdum,fnew,tnew,icedens,densfac,hnew + integer :: i real, dimension(size(TICE) ) :: tpsn real, dimension(size(TICE) ) :: dtc,q,cl,cd,cr real, dimension(size(TICE)+1) :: fhsn,df - + df = 0. dtc = 0. fhsn = 0. MELT = 0. - + if(UPPER_BND == 0) then rainrf = 0.0 RUNOFF = 0.0 @@ -3506,8 +3841,8 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & alhv = alhe + alhm !randy - fhsn(NICE+1) = 0.0 - df(NICE+1) = 0.0 + fhsn(NICE+1) = 0.0 + df(NICE+1) = 0.0 !**** Calculate heat fluxes between snow layers. @@ -3526,9 +3861,9 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & else df(1) = -sqrt(condice*condsno)/((ICEDZ(1)+sndz)*0.5) - !fhsn(1) = df(1)*(TSN - tpsn(1)) + !fhsn(1) = df(1)*(TSN - tpsn(1)) fhsn(1) = fhgnd - endif + endif !**** Prepare array elements for solution & coefficient matrices. !**** Terms are as follows: left (cl), central (cd) & right (cr) @@ -3556,42 +3891,42 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & do i=1,NICE if(tpsn(i)+dtc(i) > 0.) then - melti = (tpsn(i)+dtc(i))*cpw*MAPL_RHOWTR*ICEDZ(i)/MAPL_ALHF - MELT = MELT + melti + melti = (tpsn(i)+dtc(i))*cpw*MAPL_RHOWTR*ICEDZ(i)/MAPL_ALHF + MELT = MELT + melti if(UPPER_BND == 0) then - RUNOFF = RUNOFF + melti + RUNOFF = RUNOFF + melti endif dtc(i) = -tpsn(i) tpsn(i) = tpsn(i) + dtc(i) - if(i == 1) then + if(i == 1) then if(UPPER_BND == 0) then RUNOFF = RUNOFF + rain * dts endif endif elseif(tpsn(i)+dtc(i) == 0.0) then tpsn(i) = tpsn(i) + dtc(i) - if(i == 1) then + if(i == 1) then if(UPPER_BND == 0) then RUNOFF = RUNOFF + rain * dts endif endif else ! temp < 0, refreeze rain if any tpsn(i) = tpsn(i) + dtc(i) - if(i == 1) then + if(i == 1) then if(UPPER_BND == 0) then - !*** only latent heat of rain is used to raise ice temp. + !*** only latent heat of rain is used to raise ice temp. !*** since AGCM assumes rain has 0 heat content - dtr = rain*dts*alhm/(RHOICE*cpw*ICEDZ(i)) + dtr = rain*dts*alhm/(RHOICE*cpw*ICEDZ(i)) if(tpsn(i)+dtr > 0.0) then frrain = max(dtr-(-tpsn(i))/dtr, 1.) dtr = -tpsn(i) - else + else frrain = 0.0 - endif + endif tpsn(i) = tpsn(i) + dtr dtc(i) = dtc(i) + dtr RUNOFF = RUNOFF + frrain * rain * dts - rainrf = rainrf + (1.-frrain) * rain * dts + rainrf = rainrf + (1.-frrain) * rain * dts endif endif endif @@ -3604,17 +3939,17 @@ subroutine SOLVEICELAYER(NICE, dts, TICE, ICEDZ, UPPER_BND, & endif endif enddo - - MELT = MELT / dts - if(present(RUNOFF)) RUNOFF = RUNOFF / dts - if(present(rainrf)) rainrf = rainrf / dts + MELT = MELT / dts + + if(present(RUNOFF)) RUNOFF = RUNOFF / dts + if(present(rainrf)) rainrf = rainrf / dts - if(present(dtss)) dtss = dtc(1) + if(present(dtss)) dtss = dtc(1) TICE = tpsn + tf - end subroutine SOLVEICELAYER + end subroutine SOLVEICELAYER end subroutine RUN2 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/CMakeLists.txt new file mode 100644 index 0000000000..b240dacfa3 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/CMakeLists.txt @@ -0,0 +1,9 @@ +find_package (ISSM REQUIRED COMPONENTS Core) + +esma_set_this () + +esma_add_library (${this} + SRCS GEOS_ISSMGridComp.F90 + DEPENDENCIES MAPL GEOS_Shared GEOS_SurfaceShared ESMF::ESMF NetCDF::NetCDF_Fortran ISSM::Core + ) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 new file mode 100644 index 0000000000..0bd5940be6 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSlandice_GridComp/GEOSissm_GridComp/GEOS_ISSMGridComp.F90 @@ -0,0 +1,1448 @@ +! $Id$ + +#include "MAPL_Generic.h" + +module GEOS_IssmGridCompMod + +!BOP +! !MODULE: GEOS_ISSM --- Runs ISSM (Ice-sheet and Sea-level System Model) +! +! +! !DESCRIPTION: +! +! {\tt GEOS\_ISSM} runs ISSM (Ice-sheet and Sea-level System Model) +! Imports: ICESMB (defined on landice tiles) [via private internal state] +! Exports: ICESURF, ICETHICK, ICESMB_ISSM, ICEVX, ICEVY (defined on mesh) [true export state] +! Exports: ICESURF, ICETHICK, ICEVEL (defined on landice tiles) [via private internal state] +! Internals: ICESURF, ICETHICK, IMLS, OMLS, ISSM_NSTEPS (defined on mesh) [true internal state] +! *** NOTES: +! (*) currently we run over all input files (*.bin) that are found in ISSM_EXPDIR (scratch directory) +! (e.g., Greenland + Antarctica + any other glaciers that have been configured) +! (*) ISSM meshes are internal to ISSM (C++ source)--we create an ESMF_MESH version for regridding +! imports/exports that is the global combination of all ISSM meshes +! (*) we transform imports from landice tiles to attached grid, then regrid to the mesh +! (*) ISSM outputs are saved with HISTORY via a 'mesh tile space' developed by Weiyuan Jiang (GMAO SI Team) +! (*) ISSM time step is generally larger than LANDICE timestep, or even a job duration. We persist ISSM +! variables across job segments through internal state checkpoints (restarts). We make sure that INTERNAL +! and EXPORT variables are 'filled in' by Initialize so that LANDICE and HISTORY have access to ISSM +! variables before it runs. +! (*) Related, we use a custom ISSM run alarm that is keyed to the last time ISSM ran, not the simulation +! start time. The number of LANDICE time steps since ISSM last ran is tracked via the internal state. + +! !USES: +use iso_fortran_env, only: dp=>real64, sp=>real32 +use iso_c_binding, only: c_ptr, c_double, c_f_pointer, c_null_char, c_char, c_loc, c_int +use ESMF +use MAPL +use GEOS_UtilsMod + +implicit none + +! declare interface to the ISSM C++ library (arguments described in Initialize & Run below) +interface +subroutine InitializeISSM(expdir, num_elements, num_nodes, comm) bind(c, name="InitializeISSM") + import :: c_char, c_int + character(c_char), dimension(*) :: expdir + integer(c_int) :: num_elements + integer(c_int) :: num_nodes + integer(c_int) :: comm +end subroutine InitializeISSM + +subroutine RunISSM(ISSM_DT, gcm_forcings, issm_outputs) bind(C,NAME="RunISSM") + import :: c_ptr, c_double + real(c_double), value :: ISSM_DT + type(c_ptr), value :: gcm_forcings + type(c_ptr), value :: issm_outputs +end subroutine RunISSM + +subroutine InputFromRestarts(gcm_restarts) bind(C,NAME="InputFromRestarts") + import :: c_ptr + type(c_ptr), value :: gcm_restarts +end subroutine InputFromRestarts + +subroutine GetNodesISSM(nodeIds, nodeCoords) bind(C,NAME="GetNodesISSM") + import :: c_ptr + type(c_ptr), value :: nodeIds + type(c_ptr), value :: nodeCoords +end subroutine GetNodesISSM + +subroutine GetElementsISSM(elementIds, elementConn, elementCoords, glacIds) bind(C,NAME="GetElementsISSM") + import :: c_ptr + type(c_ptr), value :: elementIds + type(c_ptr), value :: elementConn + type(c_ptr), value :: elementCoords + type(c_ptr), value :: glacIds +end subroutine GetElementsISSM + +subroutine FinalizeISSM() bind(C,NAME="FinalizeISSM") +end subroutine FinalizeISSM + +end interface + +private + +public SetServices + +! some shared derived types and parameters below: + +public :: T_ISSM_TILE_STATE +public :: T_ISSM_TILE_WRAP +! define ISSM export as internal variables, will be used by the landice gridcomp + +type T_ISSM_TILE_STATE + real, pointer :: ICESURF_TILE(:) + real, pointer :: ICETHICK_TILE(:) + real, pointer :: ICEVEL_TILE(:) + real, pointer :: ICESMB_ISSM(:) + integer :: ISSM_NSTEPS + real :: LANDICE_DT +end type T_ISSM_TILE_STATE + +type T_ISSM_TILE_WRAP + type(T_ISSM_TILE_STATE), pointer :: ptr=>null() +end type T_ISSM_TILE_WRAP + +! private internal state for regridding +type T_ISSM_STATE + private + type(ESMF_RouteHandle) :: routehandle_m2g ! routehandle for regridding mesh to grid + type(ESMF_RouteHandle) :: routehandle_g2m ! routehandle for regridding grid to mesh + type(ESMF_RouteHandle) :: halohandle ! routehandle for field halos + integer, pointer,dimension(:) :: halo_idx ! indices of halo nodes in arrays + integer, pointer,dimension(:) :: owned_idx ! indices of owned nodes in arrays + integer, pointer,dimension(:) :: halolist ! list of halo nodeIds + type(ESMF_DistGrid) :: nodalDistgrid ! distgrid (owned nodes) + type(ESMF_GRID) :: grid ! original grid (atmosphere) + type(ESMF_MESH) :: mesh ! ISSM mesh + type(MAPL_LocStream) :: locstream ! original locstream (landice tiles) +end type T_ISSM_STATE + +! Wrapper for extracting internal state +! ------------------------------------- +type ISSM_WRAP + type (T_ISSM_STATE), pointer :: ptr +end type ISSM_WRAP + +integer :: num_outputs = 6 ! number of output fields that ISSM sends to GEOS +logical :: ISSM_RST_FOUND = .false. ! restart found flag +type(T_ISSM_STATE), pointer :: internal_state=>null() ! internal state for regridding and halo operations + +contains + + +!BOP + +! !IROUTINE: SetServices -- Sets ESMF services for this component + +! !INTERFACE: + +subroutine SetServices ( GC, RC ) + + ! !ARGUMENTS: + + type(ESMF_GridComp), intent(INOUT) :: GC ! gridded component + integer, optional :: RC ! return code + + ! !DESCRIPTION: +! This version uses the MAPL\_GenericSetServices Here we set the initialize method, +! run method, and finalize method because we are interfacing with the external ISSM +! library IRF methods. + +!EOP + +!============================================================================= + +! ErrLog Variables + + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + +!============================================================================= + + type(MAPL_MetaComp), pointer :: MAPL + + ! Get my internal MAPL_Generic state + + ! Begin... + +! Get my name and set-up traceback handle +! --------------------------------------- + + call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) + Iam = trim(COMP_NAME) // 'SetServices' + +! Set the Initialize, Run, and Finalize entry points +!----------------------------------- + + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_INITIALIZE, Initialize, _RC) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_RUN, Run, _RC) + call MAPL_GridCompSetEntryPoint ( GC, ESMF_METHOD_FINALIZE, Finalize, _RC) + +!----------------------------------- + + call MAPL_GetObjectFromGC (GC, MAPL, _RC) + +! Set the state variable specs. +!----------------------------------- + +! Import states: ICESMB is imported via the ISSM_TILE private internal state + +! Export states: + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICESURF', & + LONG_NAME = 'ice_sheet_elevation', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICEVX', & + LONG_NAME = 'ice_velocity_x_direction', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICEVY', & + LONG_NAME = 'ice_velocity_y_direction', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICETHICK', & + LONG_NAME = 'ice_thickness', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME = 'ICESMB_ISSM', & + LONG_NAME = 'issm_surface_mass_balance', & + UNITS = 'kg m-2 s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + _RC ) + + ! Internal states: + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICESURF', & + LONG_NAME = 'ice_sheet_elevation', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICETHICK', & + LONG_NAME = 'ice_sheet_thickness', & + UNITS = 'm', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'IMLS', & + LONG_NAME = 'ice_mask_levelset', & + UNITS = 'none', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'OMLS', & + LONG_NAME = 'ocean_mask_levelset', & + UNITS = 'none', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICEVX', & + LONG_NAME = 'ice_velocity_x_direction', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ICEVY', & + LONG_NAME = 'ice_velocity_y_direction', & + UNITS = 'm s-1', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'ISSM_NSTEPS', & + LONG_NAME = 'steps_since_last_issm', & + UNITS = 'none', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + call MAPL_AddInternalSpec(GC, & + SHORT_NAME = 'RS_NODEIDS', & + LONG_NAME = 'restart_node_ids', & + UNITS = 'none', & + DIMS = MAPL_DimsTileOnly, & + VLOCATION = MAPL_VLocationNone, & + RESTART = MAPL_RestartOptional, & + _RC ) + + +! Set the Profiling timers +! ------------------------ + + call MAPL_TimerAdd(GC, name="RUN" ,_RC) + call MAPL_TimerAdd(GC, name="ISSMCore" ,_RC) + + +! ---------------------------------- + call MAPL_GenericSetServices ( GC, _RC) + + _RETURN(_SUCCESS) + + end subroutine SetServices + + ! ! INITIALIZE: + + subroutine Initialize ( GC, IMPORT, EXPORT, CLOCK, RC ) + type(ESMF_GridComp), intent(INOUT) :: GC ! Gridded component + type(ESMF_State), intent(INOUT) :: IMPORT ! Import state + type(ESMF_State), intent(INOUT) :: EXPORT ! Export state + type(ESMF_Clock), intent(INOUT) :: CLOCK ! The clock + integer, optional, intent(OUT) :: RC ! Error code + + type(MAPL_MetaComp), pointer :: MAPL + type(ESMF_State) :: INTERNAL ! internal state + + ! ISSM alarm variables + type(ESMF_Alarm) :: ISSM_ALARM ! custom ISSM RUNALARM + integer :: sec_to_ring ! seconds remaining until first ISSM run + type(ESMF_Time) :: startTime ! initial time + type(ESMF_TimeInterval) :: startInterval ! time interval to first ring + type(ESMF_Time) :: ringTime ! time of first ring + type(ESMF_TimeInterval) :: ringInterval ! ring time interval (ISSM_DT) + real :: ISSM_DT ! ISSM time step [s] (ISSM_DT set in AGCM.rc) + real :: LANDICE_DT ! landice time step [s] + integer :: NSTEPS_INIT ! landice timesteps since last ISSM run + integer :: NSTEPS_RING ! total landice timesteps between ISSM runs + real, pointer, dimension(:) :: ISSM_NSTEPS => null() ! steps since last ISSM run (from internal state) + + ! ErrLog Variables + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + ! virtual machine / mpi comm + type(ESMF_VM) :: vm + integer(c_int) :: comm ! mpi comm to pass to ISSM + integer :: localPET ! ~mpi rank + + ! mesh information + type(ESMF_Mesh) :: mesh ! ESMF_Mesh representation of ISSM mesh + integer, pointer, dimension(:) :: elementTypes => null() ! element geometry type (triangles) + integer(c_int) :: num_elements ! number of elements on PET + integer(c_int) :: num_nodes ! number of nodes on PET + integer(c_int) :: num_owned_nodes ! number of nodes owned by this PET (<=num_nodes) + integer, pointer, dimension(:) :: elementIds => null() ! list of elements local to PET + integer, pointer, dimension(:) :: elementConn => null() ! element connectivity (nodes indices) + real(dp),pointer, dimension(:) :: elementCoords => null() ! element centroids + real(dp),pointer,dimension(:) :: nodeCoords => null() ! node coordinates (longitude,latitude) + integer, pointer, dimension(:) :: nodeIds => null() ! Global IDs of nodes local to PET + integer, pointer, dimension(:) :: nodeOwners => null() ! Specify which PET owns each node + integer, pointer, dimension(:) :: glacIds => null() ! glacier ID for each element + + ! regridding varibales + type(ESMF_Grid) :: grid ! atmospheric grid + type(ESMF_RouteHandle) :: routehandle_m2g ! routehandle for regridding mesh to grid + type(ESMF_RouteHandle) :: routehandle_g2m ! routehandle for regridding grid to mesh + type(ESMF_Field) :: meshField ! field on mesh + type(ESMF_Field) :: gridField ! field on grid + type(ISSM_WRAP) :: wrap ! wrapper for internal state + + ! tile information + integer :: NT ! local number of landice tiles + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap + + ! field halo variables + integer :: num_halo_nodes ! num_nodes minus num_owned_nodes + type(ESMF_RouteHandle) :: halohandle ! routehandle for field halos + integer, pointer, dimension(:) :: halolist => null() ! list of halo nodeIds + integer, pointer, dimension(:) :: ownedNodeIds => null() ! nodeIds excluding halolist + type(ESMF_DistGrid) :: nodalDistgrid ! distgrid (owned nodes) + type(ESMF_Array) :: meshArray ! array for creating mesh fields + integer, pointer,dimension(:) :: halo_idx => null() ! indices of halo nodes in arrays + integer, pointer,dimension(:) :: owned_idx => null() ! indices of owned nodes in arrays + + ! owned node coordinates (longitude,latitude) + real(dp),pointer,dimension(:) :: ownedNodeCoords => null() + real, allocatable, dimension(:) :: ownedNodeLons, ownedNodeLats + + ! command-line arguments to initialize ISSM + integer :: i,j,k ! loop indices + character(len=ESMF_MAXSTR) :: ISSM_EXPDIR ! directory containing ISSM input files + character(len=ESMF_MAXSTR) :: EXPDIR ! C++ compatible ISSM_EXPDIR string + + ! variables for creating mesh tile space + type(ESMF_Grid) :: mesh_grid + type(MAPL_LocStream) :: mesh_locstream + + ! variables for masking the mesh seam (triangles that cross +/-180 longitude) + ! (needed for elements, this is not currently needed for regridding fields defined on nodes) + real(dp) :: dlon,lon1,lon2,lon3 + integer, pointer, dimension(:) :: elementMask => null() + integer :: n1,n2,n3 + + ! pointers to internal state for restarts + real, pointer, dimension(:) :: ICESURF_IN => null() ! ice surface elevation restart + real, pointer, dimension(:) :: ICETHICK_IN => null() ! ice thickness restart + real, pointer, dimension(:) :: ICEVX_IN => null() ! ice velocity (x direction) restart + real, pointer, dimension(:) :: ICEVY_IN => null() ! ice velocity (y direction) restart + real, pointer, dimension(:) :: IMLS_IN => null() ! ice-mask levelset restart + real, pointer, dimension(:) :: OMLS_IN => null() ! ocean-mask levelset restart + + ! restarts with halo points (interleaved), to send to ISSM + real(dp), pointer, dimension(:) :: ICESURF_HALO => null() + real(dp), pointer, dimension(:) :: ICETHICK_HALO => null() + real(dp), pointer, dimension(:) :: IMLS_HALO => null() + real(dp), pointer, dimension(:) :: OMLS_HALO => null() + real(dp), pointer, dimension(:) :: ICEVX_HALO => null() + real(dp), pointer, dimension(:) :: ICEVY_HALO => null() + real(dp), pointer, dimension(:) :: ICEVEL_HALO => null() + + real(dp), pointer, dimension(:) :: GEOS_RESTARTS => null() ! concatenate restart fields + real(dp), pointer, dimension(:) :: ZEROS => null() ! zero input for bootstrapping + + ! export variables on landice tile space + real, pointer, dimension(:) :: ICESURF_TILE => null() ! ice surface elevation on landice tiles + real, pointer, dimension(:) :: ICETHICK_TILE => null() ! ice thickness on landice tiles + real, pointer, dimension(:) :: ICEVEL_TILE => null() ! ice flow speed on landice tiles + + ! export variables on mesh tile space + real, pointer, dimension(:) :: ICESURF_EX => null() ! ice surface elevation on mesh tiles + real, pointer, dimension(:) :: ICETHICK_EX => null() ! ice thickness on mesh tiles + real, pointer, dimension(:) :: ICEVX_EX => null() ! ice velocity (x direction) on mesh tiles + real, pointer, dimension(:) :: ICEVY_EX => null() ! ice velocity (y direction) on mesh tiles + + ! restart redistribution + real, pointer, dimension(:) :: restartNodeIds=> null() ! nodeIds for restart ordering + type(ESMF_DistGrid) :: restartDistgrid ! distgrid from reading restarts + logical :: distgrid_match ! check if distgrid from restarts matches nodal disgrid (locally) + logical :: needRedist ! global check for consistent distgrid across all processes + integer,allocatable,dimension(:) :: localFlag, globalFlag ! arrays for vm operations + type(ESMF_Array) :: restartArray ! array corresponding to restartDistgrid + type(ESMF_Array) :: nodalArray ! array corresponding to nodalDistgrid + type(ESMF_RouteHandle) :: redisthandle ! routehandle for redistribution + + + ! Get the target components name and set-up traceback handle. + ! ----------------------------------------------------------- + + Iam = "Initialize" + call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) + + Iam = trim(COMP_NAME) // trim(Iam) + + ! Get my internal MAPL_Generic state + !----------------------------------- + + call MAPL_GetObjectFromGC ( GC, MAPL, _RC) + + call ESMF_VMGetCurrent(vm, _RC) + + call ESMF_VMGet(vm,mpiCommunicator=comm,localPet=localPET,_RC) + + ! **************************************************** + ! call ISSM initialize C++ code so we can set up mesh + + ! get directory with ISSM binary input files (can modify if needed) + call GET_ENVIRONMENT_VARIABLE("SCRDIR",ISSM_EXPDIR,STATUS=STATUS); _VERIFY(STATUS) + + EXPDIR = trim(ISSM_EXPDIR)//"/"//c_null_char ! create string for C++ + + ! Call the C++ function for initializing ISSM + ! gets the number of elements and nodes of the mesh + call InitializeISSM(EXPDIR, num_elements, num_nodes, comm) + + !allocate mesh-related pointers + allocate(nodeCoords(2*num_nodes)) + allocate(nodeIds(num_nodes)) + allocate(elementTypes(num_elements)) + allocate(elementIds(num_elements)) + allocate(glacIds(num_elements)) + allocate(elementConn(3*num_elements)) + allocate(elementCoords(2*num_elements)) + allocate(elementMask(num_elements)) + allocate(nodeOwners(num_nodes)) + + ! get information about nodes and elements + ! node coords and element coords (centroids) are in (lon,lat) + call GetNodesISSM(c_loc(nodeIds), c_loc(nodeCoords)) + call GetElementsISSM(c_loc(elementIds), c_loc(elementConn), c_loc(elementCoords),c_loc(glacIds)) + + elementTypes(:) = ESMF_MESHELEMTYPE_TRI ! triangular elements + + ! mask for triangles that cross the seam (longitude +/- 180) + ! (you don't have to 'activate' this mask, it can just be 'associated' with the mesh) + ! + ! NOTE: This is only relevant in regridding when fields are defined + ! on ESMF_MESHLOC_ELEMENT (rather than ESMF_MESHLOC_NODE) + ! so is NOT CURRENTLY USED, but retained for possible future developments + elementMask(:) = 0 + do j=1,num_elements + n1 = elementConn(3*(j-1)+1) + n2 = elementConn(3*(j-1)+2) + n3 = elementConn(3*(j-1)+3) + lon1 = nodeCoords(2*n1-1) + lon2 = nodeCoords(2*n2-1) + lon3 = nodeCoords(2*n3-1) + dlon = maxval((/lon1,lon2,lon3/)) - minval((/lon1,lon2,lon3/)) + if ( dlon>180.0 ) then + elementMask(j) = 1 + end if + end do + + ! create the ESMF mesh from ISSM mesh properties + mesh = ESMF_MeshCreate(parametricDim=2, spatialDim=2, nodeIds=nodeIds, nodeCoords=nodeCoords, & + elementIds=elementIds, elementTypes=elementTypes, elementConn=elementConn,elementMask=elementMask,& + elementCoords=elementCoords,coordSys=ESMF_COORDSYS_SPH_DEG, _RC) + + ! associate ESMF_Mesh representation of ISSM mesh with GC for regridding imports/exports in Run method + call ESMF_GridCompSet(GC,mesh=mesh,_RC) + + ! set up field halos + !----------------------------------- + call ESMF_MeshGet(mesh=mesh,nodeOwners=nodeOwners,numOwnedNodes=num_owned_nodes,nodalDistgrid=nodalDistgrid) + + num_halo_nodes = num_nodes - num_owned_nodes + allocate(halolist(num_halo_nodes)) + allocate(ownedNodeCoords(2*num_owned_nodes)) + allocate(ownedNodeIds(num_owned_nodes)) + allocate(halo_idx(num_halo_nodes)) + allocate(owned_idx(num_owned_nodes)) + + call ESMF_MeshGet(mesh=mesh,ownedNodeCoords=ownedNodeCoords) + + ! get list of (global) nodeIds that are halos on this PET + ! and create a mask to remove these values from arrays + i=1; k=1 + do j=1,num_nodes + if (nodeOwners(j)/= localPET) then + halolist(i) = nodeIds(j) + halo_idx(i) = j + i = i+1 + else + ownedNodeIds(k) = nodeIds(j) + owned_idx(k) = j + k = k+1 + end if + end do + + ! create array with halo information + meshArray=ESMF_ArrayCreate(nodalDistgrid,typekind=ESMF_TYPEKIND_R8,haloSeqIndexList=halolist,_RC) + + ! create field on ISSM mesh + meshField=ESMF_FieldCreate(mesh, array=meshArray, meshLoc=ESMF_MESHLOC_NODE, _RC) + + ! store the halo operation in a routehandle + call ESMF_FieldHaloStore(meshField, routehandle=halohandle, _RC) + + ! Set up regridding next + !----------------------------------- + ! get atmospheric (attached) grid + call ESMF_GridCompGet( GC, GRID=grid, _RC ) + + ! create field on atmospheric grid + gridField = ESMF_FieldCreate(grid=grid,typekind=ESMF_TYPEKIND_R4,_RC) + + ! create routehandle for mesh-to-grid regridding (set srcMaskValues to 1 if needed... ) + call ESMF_FieldRegridStore(srcField=meshField, dstField=gridField,routehandle=routehandle_m2g,& + unmappedaction=ESMF_UNMAPPEDACTION_IGNORE,extrapmethod=ESMF_EXTRAPMETHOD_CREEP,& + extrapNumLevels=1,_RC) + + ! create routehandle for grid-to-mesh regridding (set dstMaskValues to 1 if needed... ) + call ESMF_FieldRegridStore(srcField=gridField, dstField=meshField,routehandle=routehandle_g2m,& + unmappedaction=ESMF_UNMAPPEDACTION_IGNORE,extrapmethod=ESMF_EXTRAPMETHOD_NEAREST_D,_RC) + + ! create component's private internal state + ! stores everything needed for regrid and halo operations during run method + allocate(internal_state, stat=STATUS); _VERIFY(STATUS) + + allocate(internal_state%halo_idx(num_halo_nodes)) + allocate(internal_state%owned_idx(num_owned_nodes)) + allocate(internal_state%halolist(num_halo_nodes)) + internal_state%routehandle_m2g = routehandle_m2g + internal_state%routehandle_g2m = routehandle_g2m + internal_state%halohandle = halohandle + internal_state%halo_idx = halo_idx + internal_state%owned_idx = owned_idx + internal_state%grid = grid + internal_state%mesh = mesh + internal_state%halolist = halolist + internal_state%nodalDistgrid = nodalDistgrid + call MAPL_Get(MAPL, LocStream = internal_state%locstream, _RC) + + ! wrap the private internal state + wrap%ptr => internal_state + call ESMF_UserCompSetInternalState ( GC, 'ISSM_WRAP', wrap, STATUS ); _VERIFY(STATUS) + + ! Create losctream that match mesh element id, then set it to this GC and MAPL + ! note: original attached/atmospheric grid and landice tile locstream have + ! been stored in the internal state + allocate(ownedNodeLons(num_owned_nodes)) + allocate(ownedNodeLats(num_owned_nodes)) + ownedNodeLons = ownedNodeCoords(1::2)*MAPL_DEGREES_TO_RADIANS + ownedNodeLats = ownedNodeCoords(2::2)*MAPL_DEGREES_TO_RADIANS + + mesh_grid = create_mesh_grid(_RC) + call MAPL_LocstreamCreate(mesh_locstream, mesh_grid, local_id=ownedNodeIds, & + tilelons=ownedNodeLons, tilelats=ownedNodeLats, _RC) + call MAPL%grid%set(mesh_grid, _RC) + call ESMF_GridCompSet(gc, grid=mesh_grid, _RC) + call MAPL_Set(MAPL, locstream = mesh_locstream, _RC) + + ! Generic initialize + !----------------------------------- + + call MAPL_GenericInitialize( GC, IMPORT, EXPORT, CLOCK, _RC ) + + ! Get private internal state for sending information to/from LANDICE + !----------------------------------- + + call ESMF_UserCompGetInternalState(GC, 'ISSM_TILES', issm_tile_wrap, status); _VERIFY(STATUS) + issm_tile_state => issm_tile_wrap%ptr + + ! Create Custom ISSM Run Alarm + !----------------------------------- + + ! get internal state + call MAPL_Get(MAPL,INTERNAL_ESMF_STATE = INTERNAL,_RC) + + ! get number of time steps since last ISSM run + call MAPL_GetPointer(INTERNAL, ISSM_NSTEPS, 'ISSM_NSTEPS',_RC) + NSTEPS_INIT = nint(maxval(ISSM_NSTEPS)) + + ! get timestep for landice + LANDICE_DT = issm_tile_state%LANDICE_DT + + ! get timestep for ISSM + call MAPL_GetResource(MAPL, ISSM_DT, Label=trim(COMP_NAME)//"_DT:",DEFAULT=302400.0, _RC) + + ! total landice time steps between ISSM runs + NSTEPS_RING = nint(ISSM_DT/LANDICE_DT) + + ! calculate initial ring time from initial time and remaining timesteps + call ESMF_ClockGet(CLOCK,currTime=startTime) + sec_to_ring = (NSTEPS_RING-NSTEPS_INIT-1)*nint(LANDICE_DT) + call ESMF_TimeIntervalSet(startInterval,s = sec_to_ring ) + ringTime = startTime + startInterval + + ! set ring interval to ISSM time step + call ESMF_TimeIntervalSet(ringInterval,s=nint(ISSM_DT),_RC) + + ! create new ISSM_ALARM + ISSM_ALARM = ESMF_AlarmCreate(CLOCK,ringTime=ringTime,ringInterval=ringInterval,sticky=.false.,_RC) + + ! set run alarm + call MAPL_Set(MAPL, RUNALARM = ISSM_ALARM, _RC) + + ! Next, send GEOS restarts to ISSM + !----------------------------------- + ! array holding all restarts to send to/from ISSM + allocate(GEOS_RESTARTS(num_outputs*num_nodes)) + allocate(ICESURF_HALO(num_nodes)) + allocate(ICETHICK_HALO(num_nodes)) + allocate(ICEVX_HALO(num_nodes)) + allocate(ICEVY_HALO(num_nodes)) + allocate(ICEVEL_HALO(num_nodes)) + allocate(IMLS_HALO(num_nodes)) + allocate(OMLS_HALO(num_nodes)) + allocate(ZEROS(num_nodes)) + + ! get pointers to restarts + call MAPL_GetPointer(INTERNAL, ICESURF_IN, 'ICESURF', _RC) + call MAPL_GetPointer(INTERNAL, ICETHICK_IN, 'ICETHICK',_RC) + call MAPL_GetPointer(INTERNAL, ICEVX_IN, 'ICEVX',_RC) + call MAPL_GetPointer(INTERNAL, ICEVY_IN, 'ICEVY',_RC) + call MAPL_GetPointer(INTERNAL, IMLS_IN, 'IMLS', _RC) + call MAPL_GetPointer(INTERNAL, OMLS_IN, 'OMLS',_RC) + call MAPL_GetPointer(INTERNAL, restartNodeIds, 'RS_NODEIDS',_RC) + + ! if restart has been read, apply halo operation and send pointers to ISSM + ! else, ISSM will just use default initial values in ISSM*.bin input files + if (associated(ICETHICK_IN)) then + ! simple check for positive ice thickness (initialized to zero if restart not found) + ! ISSM throws error for zero ice thickness + ISSM_RST_FOUND = minval(ICETHICK_IN) > epsilon(ICETHICK_IN) + end if + + if (ISSM_RST_FOUND) then + ! check if the nodal distgrid created above matches the distgrid read from the restart + ! it will only be different if running over a different number of processes than when + ! the restart was written. if it is, we redistribute the restart arrays correctly + allocate(localFlag(1)) + allocate(globalFlag(1)) + distgrid_match = all(ownedNodeIds==nint(restartNodeIds)) + localFlag(1) = 0 + if (distgrid_match) localFlag(1) = 1 + call ESMF_VMAllReduce(vm, sendData=localFlag, recvData=globalFlag, count=1, reduceflag=ESMF_REDUCE_MIN, _RC) + needRedist = (globalFlag(1) == 0) + + if (needRedist) then + ! create routehandle for redistribution, and redistribute all restarts from the + ! restart distgrid to the current distgrid (nodalDistgrid) + restartDistgrid = ESMF_DistGridCreate(arbSeqIndexList=nint(restartNodeIds), _RC) + restartArray=ESMF_ArrayCreate(distgrid=restartDistgrid,typekind=ESMF_TYPEKIND_R4,_RC) + nodalArray=ESMF_ArrayCreate(distgrid=nodalDistgrid,typekind=ESMF_TYPEKIND_R4,_RC) + call ESMF_ArrayRedistStore(srcArray=restartArray, dstArray=nodalArray, routehandle=redisthandle,_RC) + + call apply_redist(ICESURF_IN,_RC) + call apply_redist(ICETHICK_IN,_RC) + call apply_redist(ICEVX_IN,_RC) + call apply_redist(ICEVY_IN,_RC) + call apply_redist(IMLS_IN,_RC) + call apply_redist(OMLS_IN,_RC) + + call ESMF_VMBarrier(vm, _RC) + + call ESMF_ArrayDestroy(restartArray, _RC) + call ESMF_ArrayDestroy(nodalArray, _RC) + + end if + + ! apply halo operation to all restart variables + call apply_halo(ICESURF_IN,ICESURF_HALO,_RC) + call apply_halo(ICETHICK_IN,ICETHICK_HALO,_RC) + call apply_halo(ICEVX_IN,ICEVX_HALO,_RC) + call apply_halo(ICEVY_IN,ICEVY_HALO,_RC) + call apply_halo(IMLS_IN,IMLS_HALO,_RC) + call apply_halo(OMLS_IN,OMLS_HALO,_RC) + + ! package restarts into one pointer + GEOS_RESTARTS(:) = 0.0_dp + GEOS_RESTARTS(1:num_nodes) = ICESURF_HALO(:) + GEOS_RESTARTS(num_nodes+1:2*num_nodes) = ICETHICK_HALO(:) + GEOS_RESTARTS(2*num_nodes+1:3*num_nodes) = ICEVX_HALO(:) + GEOS_RESTARTS(3*num_nodes+1:4*num_nodes) = ICEVY_HALO(:) + GEOS_RESTARTS(4*num_nodes+1:5*num_nodes) = OMLS_HALO(:) + GEOS_RESTARTS(5*num_nodes+1:6*num_nodes) = IMLS_HALO(:) + + ! set restarts on the ISSM side + call ESMF_VMBarrier(vm, _RC) + call InputFromRestarts(c_loc(GEOS_RESTARTS)) + call ESMF_VMBarrier(vm, _RC) + + else + ! bootstrap restart values from ISSM input files (ISSM*.bin) + ! by running with 'fake' time step with zero forcing + + call ESMF_VMBarrier(vm, _RC) + call RunISSM(real(ISSM_DT,kind=dp), c_loc(ZEROS), c_loc(GEOS_RESTARTS)) + call ESMF_VMBarrier(vm, _RC) + + ! Unpack restart array + ICESURF_HALO(:) = GEOS_RESTARTS(1:num_nodes) + ICETHICK_HALO(:) = GEOS_RESTARTS(num_nodes+1:2*num_nodes) + ICEVX_HALO(:) = GEOS_RESTARTS(2*num_nodes+1:3*num_nodes) + ICEVY_HALO(:) = GEOS_RESTARTS(3*num_nodes+1:4*num_nodes) + OMLS_HALO(:) = GEOS_RESTARTS(4*num_nodes+1:5*num_nodes) + IMLS_HALO(:) = GEOS_RESTARTS(5*num_nodes+1:6*num_nodes) + + ! filter out halo points (keep the owned indices) for restarts + if(associated(ICESURF_IN)) ICESURF_IN = ICESURF_HALO(owned_idx) + if(associated(ICETHICK_IN)) ICETHICK_IN = ICETHICK_HALO(owned_idx) + if(associated(ICEVX_IN)) ICEVX_IN = ICEVX_HALO(owned_idx) + if(associated(ICEVY_IN)) ICEVY_IN = ICEVY_HALO(owned_idx) + if(associated(OMLS_IN)) OMLS_IN = OMLS_HALO(owned_idx) + if(associated(IMLS_IN)) IMLS_IN = IMLS_HALO(owned_idx) + + end if + + ! Initialize Export pointers on mesh tile space so history has something to write + !----------------------------------- + + call MAPL_GetPointer(EXPORT, ICESURF_EX, 'ICESURF',alloc=.true., _RC) + if(associated(ICESURF_EX)) ICESURF_EX = ICESURF_HALO(owned_idx) + + call MAPL_GetPointer(EXPORT, ICETHICK_EX, 'ICETHICK',alloc=.true., _RC) + if(associated(ICETHICK_EX)) ICETHICK_EX = ICETHICK_HALO(owned_idx) + + call MAPL_GetPointer(EXPORT, ICEVX_EX, 'ICEVX',alloc=.true.,_RC) + if(associated(ICEVX_EX)) ICEVX_EX = ICEVX_HALO(owned_idx) + + call MAPL_GetPointer(EXPORT, ICEVY_EX, 'ICEVY',alloc=.true.,_RC) + if(associated(ICEVY_EX)) ICEVY_EX = ICEVY_HALO(owned_idx) + + ! Finally, set the tile export state so landice can access values before ISSM runs + !----------------------------------- + + ! Regrid from mesh to tile + call MAPL_LocStreamGet(internal_state%locstream, NT_LOCAL=NT, _RC) + + ! allocate variables on landice tile space + allocate(ICESURF_TILE(NT)) + allocate(ICETHICK_TILE(NT)) + allocate(ICEVEL_TILE(NT)) + + ! calculate ice flow speed + ICEVEL_HALO = sqrt(ICEVX_HALO**2 + ICEVY_HALO**2) + + call mesh_to_tile(ICESURF_HALO,ICESURF_TILE,_RC) + issm_tile_state%ICESURF_TILE = ICESURF_TILE + + call mesh_to_tile(ICETHICK_HALO,ICETHICK_TILE,_RC) + issm_tile_state%ICETHICK_TILE = ICETHICK_TILE + + call mesh_to_tile(ICEVEL_HALO,ICEVEL_TILE,_RC) + issm_tile_state%ICEVEL_TILE = ICEVEL_TILE + + issm_tile_state%ISSM_NSTEPS = NSTEPS_INIT + + + ! set nodeIds internal associated with restart + if(associated(restartNodeIds)) restartNodeIds(:) = ownedNodeIds(:) + + call ESMF_VMBarrier(vm, _RC) + + ! deallocate pointers + if(associated(nodeCoords)) deallocate(nodeCoords) + if(associated(nodeIds)) deallocate(nodeIds) + if(associated(elementTypes)) deallocate(elementTypes) + if(associated(elementIds)) deallocate(elementIds) + if(associated(elementConn)) deallocate(elementConn) + if(associated(elementCoords)) deallocate(elementCoords) + if(associated(glacIds)) deallocate(glacIds) + if(associated(elementMask)) deallocate(elementMask) + if(associated(halo_idx)) deallocate(halo_idx) + if(associated(owned_idx)) deallocate(owned_idx) + if(associated(halolist)) deallocate(halolist) + if(associated(ownedNodeCoords)) deallocate(ownedNodeCoords) + if(associated(ownedNodeIds)) deallocate(ownedNodeIds) + if(associated(nodeOwners)) deallocate(nodeOwners) + if(associated(ICESURF_HALO)) deallocate(ICESURF_HALO) + if(associated(ICETHICK_HALO)) deallocate(ICETHICK_HALO) + if(associated(IMLS_HALO)) deallocate(IMLS_HALO) + if(associated(OMLS_HALO)) deallocate(OMLS_HALO) + if(associated(ICEVX_HALO)) deallocate(ICEVX_HALO) + if(associated(ICEVY_HALO)) deallocate(ICEVY_HALO) + if(associated(GEOS_RESTARTS)) deallocate(GEOS_RESTARTS) + if(associated(ZEROS)) deallocate(ZEROS) + if(associated(ICESURF_TILE)) deallocate(ICESURF_TILE) + if(associated(ICETHICK_TILE)) deallocate(ICETHICK_TILE) + if(associated(ICEVEL_TILE)) deallocate(ICEVEL_TILE) + + ! destroy fields and arrays + call ESMF_FieldDestroy(gridField, _RC) + call ESMF_FieldDestroy(meshField, _RC) + call ESMF_ArrayDestroy(meshArray, _RC) + + _RETURN(_SUCCESS) + + contains + subroutine apply_halo(VAR_IN,VAR_HALO,RC) + ! apply halo operation to a restart variable + ! arguments: + real, pointer, dimension(:), intent(inout) :: VAR_IN ! var on owned_nodes + real(dp), pointer, dimension(:), intent(inout) :: VAR_HALO ! var on all nodes + integer, optional, intent(out) :: RC + + ! local variables: + real(dp), pointer, dimension(:) :: VAR_DP ! double version of VAR_IN + real(dp), pointer, dimension(:) :: MESH_PTR ! pointer for ESMF_FieldGet + real(dp), pointer, dimension(:) :: ARRAY_PTR ! pointer for ESMF_ArrayGet + type(ESMF_Array) :: meshArray ! array for creating mesh fields + type(ESMF_Field) :: meshField ! field associated with meshArray + + allocate(VAR_DP(num_nodes)) + VAR_DP(:) = 0.0_dp + VAR_DP(1:num_owned_nodes) = REAL(VAR_IN,kind=dp) + + ! create array with halo information + meshArray=ESMF_ArrayCreate(nodalDistgrid,typekind=ESMF_TYPEKIND_R8,haloSeqIndexList=halolist,_RC) + + call ESMF_ArrayGet(array=meshArray,farrayPtr=ARRAY_PTR) + ARRAY_PTR(:) = VAR_DP(:) + + ! create field on ISSM mesh + meshField=ESMF_FieldCreate(mesh, array=meshArray, meshLoc=ESMF_MESHLOC_NODE, _RC) + + ! append halo values to end of "owned" array + call ESMF_FieldHalo(meshField, routehandle=halohandle, _RC) + + ! get pointer to field on mesh + call ESMF_FieldGet(meshField,farrayPtr=MESH_PTR,_RC) + + ! copy values into VAR_HALO, interleave according to owned and halo indices + VAR_HALO(owned_idx) = MESH_PTR(1:num_owned_nodes) ! owned nodes + VAR_HALO(halo_idx) = MESH_PTR(num_owned_nodes+1:num_nodes) ! halo nodes + + ! destroy field and array, deallocate pointer + call ESMF_FieldDestroy(meshField,_RC) + call ESMF_ArrayDestroy(meshArray,_RC) + deallocate(VAR_DP) + + _RETURN(_SUCCESS) + end subroutine apply_halo + + subroutine apply_redist(VAR_RS,RC) + ! arguments: + real, pointer, dimension(:), intent(inout) :: VAR_RS ! var from restsart + integer, optional, intent(out) :: RC + + type(ESMF_Array) :: restartArray ! restart array + type(ESMF_Array) :: redistArray ! redistributed array + real, pointer, dimension(:) :: redistPtr + + restartArray=ESMF_ArrayCreate(distgrid=restartDistgrid,farrayPtr=VAR_RS,_RC) + redistArray=ESMF_ArrayCreate(distgrid=nodalDistgrid,typekind=ESMF_TYPEKIND_R4,_RC) + + ! redistribute the data + call ESMF_ArrayRedist(srcArray=restartArray, dstArray=redistArray, routehandle=redisthandle,_RC) + + ! get the pointer to the data + call ESMF_ArrayGet(redistArray,farrayPtr=redistPtr) + + ! make sure all processes have finished redistribution + call ESMF_VMBarrier(vm, _RC) + + ! copy values into output + VAR_RS(:) = redistPtr(:) + + call ESMF_VMBarrier(vm, _RC) + call ESMF_ArrayDestroy(restartArray,_RC) + call ESMF_ArrayDestroy(redistArray,_RC) + + _RETURN(_SUCCESS) + end subroutine apply_redist + + function create_mesh_grid(rc) result(mesh_grid) + type (ESMF_Grid) :: mesh_grid + integer, optional, intent(out) :: RC + integer :: status, nDEs, num(1) + real(kind=8), pointer :: centers_lon(:,:) + real(kind=8), pointer :: centers_lat(:,:) + integer, allocatable :: IMs(:) + + !comm, VM, num_owned_nodes are from containing subroutine + call ESMF_VMGet(vm, petcount=nDEs, _RC) + allocate(IMS(nDEs)) + num(1) = num_owned_nodes + call MAPL_CommsAllGather(vm, num, 1, IMs, 1, _RC) + + ! create a mesh-grid in 1D + mesh_grid = ESMF_GridCreate( & + name='MESH_GRID', & + countsPerDEDim1=IMs, & + countsPerDEDim2=[1], & + indexFlag=ESMF_INDEX_DELOCAL, & + coordDep1 = (/1,2/), & + coordDep2 = (/1,2/), & + gridEdgeLWidth = (/0,0/), & + gridEdgeUWidth = (/0,0/), & + _RC) + ! coord and centers are required for a valid grid, + ! even if their values don't make sense; + ! later on, the coord will be set to element's lat lon. + call ESMF_GridAddCoord(mesh_grid, _RC) + _VERIFY(STATUS) + + call ESMF_GridGetCoord(mesh_grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=centers_lon, _RC) + centers_lon(:,1) = ownedNodeLons + call ESMF_GridGetCoord(mesh_grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, & + farrayPtr=centers_lat, _RC) + centers_lat(:,1) = ownedNodeLats + + _RETURN(_SUCCESS) + end function create_mesh_grid + + end subroutine Initialize + + !BOP + + + subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) + ! ! ****** Run ISSM ice-sheet model ****** + ! ! the core C++ solvers and associated pre/post-processing of imports/exports + ! ! are only performed at ISSM_DT intervals. However, the Run method is engaged + ! ! at every landice timestep to ensure that ISSM restarts persist + ! !ARGUMENTS: + type(ESMF_GridComp), intent(inout) :: GC ! Gridded component + type(ESMF_State), intent(inout) :: IMPORT ! Import state + type(ESMF_State), intent(inout) :: EXPORT ! Export state + type(ESMF_Clock), intent(inout) :: CLOCK ! The clock + integer, optional, intent( out) :: RC ! Error code + type(ESMF_Alarm) :: ALARM ! run alarm for ISSM component + + ! ErrLog Variables + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + type(MAPL_MetaComp), pointer :: MAPL + type(ESMF_State) :: INTERNAL + type(ESMF_VM) :: vm + + ! internal state for regridding and halo operations + type(ESMF_Mesh) :: mesh ! ESMF version of ISSM mesh + integer :: num_nodes ! number of nodes on PET + + ! tile information + integer :: NT ! number of landice tiles + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap + + ! surface mass balance on mesh and landice tiles + ! note: SMB has been time-averaged between ISSM runs + real(dp), pointer, dimension(:) :: ICESMB_MESH => null() ! surface mass balce on mesh elements + real, pointer, dimension(:) :: ICESMB_TILE => null() ! surface mass balance on landice tiles + real, pointer, dimension(:) :: ICESMB_EX => null() ! pointer to export state (mesh tiles) + + ! ISSM Outputs + real(dp), pointer, dimension(:) :: ISSM_OUTPUTS => null() ! pointer containing all outputs + + ! ice-surface elevation on mesh and landice tiles + real(dp), pointer, dimension(:) :: ICESURF_MESH => null() ! ice elevation on mesh + real, pointer, dimension(:) :: ICESURF_TILE => null() ! ice elevation on landice tiles + real, pointer, dimension(:) :: ICESURF_EX => null() ! pointer to export state (mesh tiles) + real, pointer, dimension(:) :: ICESURF_IN => null() ! pointer to internal state (mesh tiles) + + ! ice thickness on mesh and landice tiles + real(dp), pointer, dimension(:) :: ICETHICK_MESH => null() ! ice thickness on mesh + real, pointer, dimension(:) :: ICETHICK_TILE => null() ! ice thickness on landice tiles + real, pointer, dimension(:) :: ICETHICK_EX => null() ! pointer to ice thickness export state (mesh tiles) + real, pointer, dimension(:) :: ICETHICK_IN => null() ! pointer to ice thicknesss internal state (mesh tiles) + + ! ice-flow velocity in x direction (in projection coordinates) + real(dp), pointer, dimension(:) :: ICEVX_MESH => null() ! ice x-velocity on mesh + real, pointer, dimension(:) :: ICEVX_EX => null() ! pointer to export state (mesh tiles) + real, pointer, dimension(:) :: ICEVX_IN => null() ! pointer to internal state (mesh tiles) + + ! ice-flow velocity in y direction (in projection coordinates) + real(dp), pointer, dimension(:) :: ICEVY_MESH => null() ! ice y-velocity on mesh + real, pointer, dimension(:) :: ICEVY_EX => null() ! pointer to export state (mesh tiles) + real, pointer, dimension(:) :: ICEVY_IN => null() ! pointer to export state (mesh tiles) + + ! ice mask level set (tracks glacier terminus) + real(dp), pointer, dimension(:) :: IMLS_MESH => null() ! ice mask level set + real, pointer, dimension(:) :: IMLS_IN => null() ! pointer to internal state (mesh tiles) + + ! ocean mask level set (tracks grounding line) + real(dp), pointer, dimension(:) :: OMLS_MESH => null() ! ocean mask level set + real, pointer, dimension(:) :: OMLS_IN => null() ! pointer to internal state (mesh tiles) + + ! ice-flow speed on mesh and landice tiles + real(dp), pointer, dimension(:) :: ICEVEL_MESH => null() ! ice flow speed on mesh tiles + real, pointer, dimension(:) :: ICEVEL_TILE => null() ! ice flow speed on landice tiles + + ! physical parameters + real(dp), parameter :: rho_ice = 917.0 ! pure ice density [kg m-3] + real(dp) :: ISSM_DT ! time step [s] (ISSM_DT set in AGCM.rc) + + ! Get the target components name, mesh and vm + ! ----------------------------------------------------------- + Iam = "Run" + call ESMF_GridCompGet(GC,name=COMP_NAME,mesh=mesh,vm=vm,_RC) + + Iam = trim(COMP_NAME) // Iam + + ! Get my internal MAPL_Generic state + !---------------------------------- + call MAPL_GetObjectFromGC(GC, MAPL, STATUS) + _VERIFY(STATUS) + + call MAPL_Get(MAPL,INTERNAL_ESMF_STATE = INTERNAL,_RC ) + + + ! Start Total timer + !------------------ + call MAPL_TimerOn(MAPL,"TOTAL") + call MAPL_TimerOn(MAPL,"RUN" ) + + call MAPL_Get(MAPL, RUNALARM = ALARM, _RC ) + + + ! run ISSM at specified time steps, + ! if bootstrapping restart and issm has run not by final time step, run anyways + ! with timestep of zero, which just gets restart values + if (ESMF_AlarmIsRinging (ALARM, RC=STATUS)) then + + ! *************************************************************************** ! + ! BASIC SETUP + ! *************************************************************************** ! + + ! get timestep for ISSM + call MAPL_GetResource(MAPL, ISSM_DT, Label=trim(COMP_NAME)//"_DT:",DEFAULT=302400.0, _RC) + + ! get number of mesh elements + call ESMF_MeshGet(mesh,nodeCount=num_nodes) + + ! allocate ice-elevation output (export from ISSM) + allocate(ISSM_OUTPUTS(num_outputs*num_nodes)) + + ! allocate output arrays defined on mesh nodes + allocate(ICESURF_MESH(num_nodes)) + allocate(ICETHICK_MESH(num_nodes)) + allocate(ICEVX_MESH(num_nodes)) + allocate(ICEVY_MESH(num_nodes)) + allocate(ICEVEL_MESH(num_nodes)) + allocate(IMLS_MESH(num_nodes)) + allocate(OMLS_MESH(num_nodes)) + + ! allocate input arrays defined on mesh nodes + allocate(ICESMB_MESH(num_nodes)) + + ! initialize ISSM outputs to zero + ICESURF_MESH(:) = 0.0_dp + ICETHICK_MESH(:) = 0.0_dp + ICEVX_MESH(:) = 0.0_dp + ICEVY_MESH(:) = 0.0_dp + ICEVEL_MESH(:) = 0.0_dp + IMLS_MESH(:) = 0.0_dp + OMLS_MESH(:) = 0.0_dp + ISSM_OUTPUTS(:) = 0.0_dp + + ! get landice tile dimensions + call MAPL_LocStreamGet(internal_state%locstream, NT_LOCAL=NT, _RC) + + call ESMF_UserCompGetInternalState(GC, 'ISSM_TILES', issm_tile_wrap, status); _VERIFY(STATUS) + issm_tile_state => issm_tile_wrap%ptr + + ! *************************************************************************** ! + ! GET ICESMB IMPORT (surface mass balance) + ! *************************************************************************** ! + ! NOTE: ICESMB (from landice) has been time-averaged between ISSM runs + ! hence the name ICESMB_ISSM + + ! allocate tiles for ICESMB + if(.not.associated(ICESMB_TILE)) then + allocate(ICESMB_TILE(NT), STAT=STATUS) + _VERIFY(STATUS) + ICESMB_TILE = MAPL_Undef + end if + + ! copy import values into tile array + ICESMB_TILE = issm_tile_state%ICESMB_ISSM + + ! transform ICESMB from landice tiles to mesh + call tile_to_mesh(ICESMB_TILE,ICESMB_MESH,_RC) + + ! save ICESMB on mesh elements + call MAPL_GetPointer(EXPORT , ICESMB_EX , 'ICESMB_ISSM' , _RC) + + if(associated(ICESMB_EX)) ICESMB_EX = ICESMB_MESH(internal_state%owned_idx) + + ! *************************************************************************** ! + ! RUN ISSM WITH SMB INPUT AND ICE-ELEVATION OUTPUT + ! *************************************************************************** ! + ! convert SMB to units of [m/s] (ice-equivalent) before passing to ISSM + ICESMB_MESH = ICESMB_MESH/rho_ice + + call ESMF_VMBarrier(vm, _RC) + call MAPL_TimerOn(MAPL,"ISSMCore" ) + + ! call run method from ISSM library + call RunISSM(ISSM_DT, c_loc(ICESMB_MESH), c_loc(ISSM_OUTPUTS)) + + call ESMF_VMBarrier(vm, _RC) + call MAPL_TimerOff(MAPL,"ISSMCore" ) + + ! *************************************************************************** ! + ! UNPACK AND EXPORT ISSM OUTPUTS ON MESH TILES + ! *************************************************************************** ! + ! unpack ISSM output pointer + ICESURF_MESH(:) = ISSM_OUTPUTS(1:num_nodes) + ICETHICK_MESH(:) = ISSM_OUTPUTS(num_nodes+1:2*num_nodes) + ICEVX_MESH(:) = ISSM_OUTPUTS(2*num_nodes+1:3*num_nodes) + ICEVY_MESH(:) = ISSM_OUTPUTS(3*num_nodes+1:4*num_nodes) + OMLS_MESH(:) = ISSM_OUTPUTS(4*num_nodes+1:5*num_nodes) + IMLS_MESH(:) = ISSM_OUTPUTS(5*num_nodes+1:6*num_nodes) + + ! calculate ice flow speed + ICEVEL_MESH = sqrt(ICEVX_MESH**2 + ICEVY_MESH**2) + + ! set pointers to tile-mesh exports + call MAPL_GetPointer(EXPORT, ICESURF_EX, 'ICESURF', _RC) + if(associated(ICESURF_EX)) ICESURF_EX = ICESURF_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(EXPORT, ICEVX_EX, 'ICEVX', _RC) + if(associated(ICEVX_EX)) ICEVX_EX = ICEVX_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(EXPORT, ICEVY_EX, 'ICEVY', _RC) + if(associated(ICEVY_EX)) ICEVY_EX = ICEVY_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(EXPORT, ICETHICK_EX, 'ICETHICK', _RC) + if(associated(ICETHICK_EX)) ICETHICK_EX = ICETHICK_MESH(internal_state%owned_idx) + + ! set pointers to tile-mesh internals + call MAPL_GetPointer(INTERNAL, ICESURF_IN, 'ICESURF', _RC) + if(associated(ICESURF_IN)) ICESURF_IN = ICESURF_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, ICETHICK_IN, 'ICETHICK', _RC) + if(associated(ICETHICK_IN)) ICETHICK_IN = ICETHICK_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, ICEVX_IN, 'ICEVX', _RC) + if(associated(ICEVX_IN)) ICEVX_IN = ICEVX_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, ICEVY_IN, 'ICEVY', _RC) + if(associated(ICEVY_IN)) ICEVY_IN = ICEVY_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, OMLS_IN, 'OMLS', _RC) + if(associated(OMLS_IN)) OMLS_IN = OMLS_MESH(internal_state%owned_idx) + + call MAPL_GetPointer(INTERNAL, IMLS_IN, 'IMLS', _RC) + if(associated(IMLS_IN)) IMLS_IN = IMLS_MESH(internal_state%owned_idx) + + ! *************************************************************************** ! + ! REGRID MESH FIELDS ONTO LANDICE TILES AND EXPORT VIA PRIVATE INTERNAL STATE + ! *************************************************************************** ! + ! transform from mesh to tiles + call mesh_to_tile(ICESURF_MESH,ICESURF_TILE,_RC) + issm_tile_state%ICESURF_TILE = ICESURF_TILE + + call mesh_to_tile(ICETHICK_MESH,ICETHICK_TILE,_RC) + issm_tile_state%ICETHICK_TILE = ICETHICK_TILE + + call mesh_to_tile(ICEVEL_MESH,ICEVEL_TILE,_RC) + issm_tile_state%ICEVEL_TILE = ICEVEL_TILE + + ! *************************************************************************** ! + ! Round ISSM output to single precision and reset on the C++ side + ! This ensures the same result as reading in (single-precision) restarts + ! *************************************************************************** ! + ISSM_OUTPUTS = real(ISSM_OUTPUTS, kind=sp) + call ESMF_VMBarrier(vm, _RC) + call InputFromRestarts(c_loc(ISSM_OUTPUTS)) + call ESMF_VMBarrier(vm, _RC) + + end if + + ! barrier to ensure regridding completes before any deallocates + call ESMF_VMBarrier(vm,_RC) + + ! deallocates + if(associated(ICESURF_MESH)) deallocate(ICESURF_MESH) + if(associated(ICETHICK_MESH)) deallocate(ICETHICK_MESH) + if(associated(ICEVEL_MESH)) deallocate(ICEVEL_MESH) + if(associated(ICEVX_MESH)) deallocate(ICEVX_MESH) + if(associated(ICEVY_MESH)) deallocate(ICEVY_MESH) + if(associated(IMLS_MESH)) deallocate(IMLS_MESH) + if(associated(OMLS_MESH)) deallocate(OMLS_MESH) + if(associated(ICESMB_MESH)) deallocate(ICESMB_MESH) + if(associated(ISSM_OUTPUTS)) deallocate(ISSM_OUTPUTS) + if(associated(ICESMB_TILE)) deallocate(ICESMB_TILE) + if(associated(ICESURF_TILE)) deallocate(ICESURF_TILE) + if(associated(ICETHICK_TILE)) deallocate(ICETHICK_TILE) + if(associated(ICEVEL_TILE)) deallocate(ICEVEL_TILE) + + call MAPL_TimerOff(MAPL,"RUN" ) + call MAPL_TimerOff(MAPL,"TOTAL") + + _RETURN(_SUCCESS) + + end subroutine RUN + + + !BOP + +!IROUTINE: Finalize -- Finalize method for ISSM + +!INTERFACE: + + subroutine Finalize ( GC, IMPORT, EXPORT, CLOCK, RC ) + + !ARGUMENTS: + type(ESMF_GridComp), intent(INOUT) :: GC ! Gridded component + type(ESMF_State), intent(INOUT) :: IMPORT ! Import state + type(ESMF_State), intent(INOUT) :: EXPORT ! Export state + type(ESMF_Clock), intent(INOUT) :: CLOCK ! The supervisor clock + integer, optional, intent( OUT) :: RC ! Error code: + + !EOP + type(MAPL_MetaComp), pointer :: MAPL + + type(ESMF_State) :: INTERNAL + + ! ErrLog Variables + character(len=ESMF_MAXSTR) :: IAm + integer :: STATUS + character(len=ESMF_MAXSTR) :: COMP_NAME + + + type(T_ISSM_TILE_STATE), pointer :: issm_tile_state + type(T_ISSM_TILE_WRAP) :: issm_tile_wrap + real, pointer, dimension(:) :: ISSM_NSTEPS + + ! Get the target components name and set-up traceback handle. + ! ----------------------------------------------------------- + Iam = "Finalize" + call ESMF_GridCompGet( GC, NAME=COMP_NAME, _RC ) + + Iam = trim(comp_name) // Iam + + call MAPL_GetObjectFromGC(GC, MAPL, STATUS) + _VERIFY(STATUS) + + ! save number of steps since last ISSM run via internal state checkpoints (restarts) + call ESMF_UserCompGetInternalState(GC, 'ISSM_TILES', issm_tile_wrap, STATUS); _VERIFY(STATUS) + issm_tile_state => issm_tile_wrap%ptr + + ! get internal state + call MAPL_Get(MAPL,INTERNAL_ESMF_STATE = INTERNAL,_RC) + + ! get number of time steps since last ISSM run + call MAPL_GetPointer(INTERNAL, ISSM_NSTEPS, 'ISSM_NSTEPS',_RC) + ISSM_NSTEPS(:) = real(issm_tile_state%ISSM_NSTEPS) + + ! call ISSM's finalize method + call FinalizeISSM() + + ! Generic Finalize + ! ------------------ + call MAPL_GenericFinalize( GC, IMPORT, EXPORT, CLOCK, _RC ) + + ! All Done + ! ------------------ + + _RETURN(_SUCCESS) + end subroutine Finalize + + + subroutine mesh_to_tile(VAR_MESH,VAR_TILE,RC) + ! regrid from mesh to grid, then transform from grid to landice tiles + ! arguments: + real(dp), pointer, dimension(:), intent(inout) :: VAR_MESH ! var on mesh nodes + real, pointer, dimension(:), intent(inout) :: VAR_TILE ! var on landice tiles + integer, optional, intent(OUT) :: RC ! Error code + + ! local variables: + real, pointer, dimension(:,:) :: VAR_GRID => null() ! var on attached grid + real(dp), pointer, dimension(:) :: VAR_MESH_OWN ! var on owned mesh nodes + type(ESMF_Field) :: srcField + type(ESMF_Field) :: dstField + integer :: num_owned_nodes + integer :: NT + integer :: STATUS + + num_owned_nodes = size(internal_state%owned_idx) + + call MAPL_LocStreamGet(internal_state%locstream, NT_LOCAL=NT, _RC) + + allocate(VAR_MESH_OWN(num_owned_nodes)) + + VAR_MESH_OWN = VAR_MESH(internal_state%owned_idx) + + ! allocate tiles + if (.not.associated(VAR_TILE)) then + allocate(VAR_TILE(NT)) + VAR_TILE = MAPL_Undef + end if + + ! create source field: field on mesh nodes + srcField = ESMF_FieldCreate(mesh=internal_state%mesh,farrayPtr=VAR_MESH_OWN,meshloc=ESMF_MESHLOC_NODE, & + datacopyflag=ESMF_DATACOPY_VALUE,_RC) + + ! create destination field: field on grid + dstField = ESMF_FieldCreate(grid=internal_state%grid,typekind=ESMF_TYPEKIND_R4,_RC) + + ! regrid field from mesh to grid + call ESMF_FieldRegrid(srcField, dstField, internal_state%routehandle_m2g, _RC) + + ! get pointer to field on grid + call ESMF_FieldGet(dstField,farrayPtr=VAR_GRID,_RC) + + ! transform from grid to tiles + call MAPL_LocStreamTransform(internal_state%locstream,VAR_TILE,VAR_GRID, _RC) + + ! destroy regridding fields so they can be reused + call ESMF_FieldDestroy(srcField,_RC) + call ESMF_FieldDestroy(dstField,_RC) + + _RETURN(_SUCCESS) + + end subroutine mesh_to_tile + + subroutine tile_to_mesh(VAR_TILE,VAR_MESH,RC) + ! transform from landice tile to grid, then regrid onto mesh + ! arguments: + real, pointer, dimension(:), intent(inout) :: VAR_TILE ! var on landice tiles + real(dp), pointer, dimension(:), intent(inout) :: VAR_MESH ! var on mesh elements + integer, optional, intent(OUT) :: RC ! Error code + + ! local variables: + real, pointer, dimension(:,:) :: VAR_GRID => null() ! var on attached grid + real(dp), pointer, dimension(:) :: MESH_PTR ! pointer for ESMF_FieldGet + type(ESMF_Field) :: srcField + type(ESMF_Field) :: dstField + type(ESMF_Array) :: meshArray + integer :: num_owned_nodes + integer :: num_nodes + integer :: IM, JM, local_dims(3) + integer :: STATUS + + ! get number of nodes + call ESMF_MeshGet(internal_state%mesh,nodeCount=num_nodes,numOwnedNodes=num_owned_nodes,_RC) + + ! get grid dimensions + call MAPL_GridGet(internal_state%grid, localCellCountPerDim=local_dims, _RC) + IM = local_dims(1) + JM = local_dims(2) + + ! allocate pointer on grid for regridding + allocate(VAR_GRID(IM,JM)) + + ! transform from tile to grid + ! NOTE: we use the "transpose" option with MAPL_LocStreamTransformG2T + ! (rather than MAPL_LocStreamTransformT2G) because the "default" value is zero + ! (rather than MAPL_UNDEF, which leads to errors when regridding onto mesh) + call MAPL_LocStreamTransform(internal_state%locstream, VAR_TILE, VAR_GRID, TRANSPOSE=.true., _RC) + + ! create source field on grid + srcField = ESMF_FieldCreate(grid=internal_state%grid,farrayPtr=VAR_GRID, datacopyflag=ESMF_DATACOPY_VALUE,_RC) + + ! create destination field on mesh elements + meshArray=ESMF_ArrayCreate(internal_state%nodalDistgrid,typekind=ESMF_TYPEKIND_R8,haloSeqIndexList=internal_state%halolist,_RC) + + ! create field on ISSM mesh + dstField=ESMF_FieldCreate(internal_state%mesh, array=meshArray, meshLoc=ESMF_MESHLOC_NODE, _RC) + + ! regrid from grid to mesh + call ESMF_FieldRegrid(srcField, dstField, internal_state%routehandle_g2m, _RC) + + ! append halo values to end of "owned" array + call ESMF_FieldHalo(dstField, routehandle=internal_state%halohandle, _RC) + + ! get pointer to field on mesh + call ESMF_FieldGet(dstField,farrayPtr=MESH_PTR,_RC) + + ! copy values into VAR_MESH + VAR_MESH(internal_state%owned_idx) = MESH_PTR(1:num_owned_nodes) ! owned nodes + VAR_MESH(internal_state%halo_idx) = MESH_PTR(num_owned_nodes+1:num_nodes) ! halo nodes + + ! destroy fields and arrays so they can be reused + deallocate(VAR_GRID) + call ESMF_FieldDestroy(srcField,_RC) + call ESMF_FieldDestroy(dstField,_RC) + call ESMF_ArrayDestroy(meshArray,_RC) + + _RETURN(_SUCCESS) + + end subroutine tile_to_mesh + +end module GEOS_IssmGridCompMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 index c964e4d535..a06b3471fc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSroute_GridComp/GEOS_RouteGridComp.F90 @@ -14,7 +14,7 @@ module GEOS_RouteGridCompMod ! IMPORTS : RUNOFF \\ ! !USES: - + use, intrinsic :: iso_fortran_env, only: REAL64 use ESMF use MAPL_Mod use MAPL_ConstantsMod @@ -549,7 +549,7 @@ function create_pfaf_grid(rc) result(pfaf_grid) type (ESMF_Grid) :: pfaf_grid integer, optional, intent(out) :: rc integer :: status - real(kind=8), pointer :: centers(:,:) + real(kind=REAL64), pointer :: centers(:,:) ! create catchment grid and it is tile space pfaf_Grid = ESMF_GridCreate( & name='CATCHMENT_GRID', & @@ -608,10 +608,10 @@ subroutine create_mapping_handler(tilegrid, pfaf_tilegrid, rc) character(len=MAPL_TileNameLength), pointer :: GNAMES(:) ! create source for orignal tile space - route%field_src = ESMF_FieldCreate(grid=tilegrid, typekind=ESMF_TYPEKIND_R4, _RC) + route%field_src = ESMF_FieldCreate(grid=tilegrid, typekind=ESMF_TYPEKIND_R8, _RC) ! create destination for pfaf tile space - route%field = ESMF_FieldCreate(grid=pfaf_tilegrid, typekind=ESMF_TYPEKIND_R4, _RC) + route%field = ESMF_FieldCreate(grid=pfaf_tilegrid, typekind=ESMF_TYPEKIND_R8, _RC) call MAPL_LocstreamGet(LOCSTREAM, GRIDNAMES=GNAMES, pfaf_index=pfaf_index, tilearea=tilearea, local_id=local_id, local_i=local_i, local_j=local_j, _RC) ! ESMF use global indices increasing with mpi_rank, no mask here for tile grid @@ -947,7 +947,7 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) integer :: nt_global, nt_local - real, pointer :: arrayPtr(:) + real(kind=REAL64), pointer :: arrayPtr8(:) type (RES_STATE), pointer :: res !real, allocatable :: WTOT_BEFORE(:) @@ -1028,21 +1028,36 @@ subroutine RUN (GC,IMPORT, EXPORT, CLOCK, RC ) if (ESMF_AlarmIsRinging(CollectWaterAlarm)) then ! finalize runoff accumulation over ROUTE_DT - route%runoff_acc = (route%runoff_acc + RUNOFF_SRC0)/real(ROUTE_DT/HEARTBEAT) ! time-avg runoff over ROUTE_DT in land[ice] tile space [kg/m2/s] + route%runoff_acc = (route%runoff_acc + RUNOFF_SRC0)/real(ROUTE_DT/HEARTBEAT) ! time-avg runoff over ROUTE_DT in land[ice] tile space [kg/m2/s] - ! redistribute runoff from tile space of GEOS_LandGridComp to Pfafstetter catchment space of GEOS_RouteGridComp - call ESMF_FieldGet(route%field_src, farrayPtr=arrayPtr, rc=status) + ! Redistribute time-averaged runoff from GEOS_LandGridComp tile space + ! to GEOS_RouteGridComp Pfafstetter catchment space. + ! Use R8 remap fields to avoid small run-to-run roundoff differences in + ! the EASE/Pfaf sparse remap before casting back to the route runoff array. + + ! Clear destination route/Pfaf field before remapping. + call ESMF_FieldGet(route%field, farrayPtr=arrayPtr8, rc=status) VERIFY_(STATUS) - ArrayPtr = route%runoff_acc(:) - call ESMF_FieldSMM(srcField=route%field_src, dstField=route%Field, & - routeHandle=route%routeHandle, rc=rc) - call ESMF_FieldGet(route%field, farrayPtr=arrayPtr, rc=status) + arrayPtr8 = 0.0_REAL64 + + ! Fill source field from accumulated runoff in original land tile space. + call ESMF_FieldGet(route%field_src, farrayPtr=arrayPtr8, rc=status) VERIFY_(STATUS) - ! convert units [kg/m2/s] --> [m3/s] - QRUNOFF = arrayPtr*route%areacat/1000. ! time-avg runoff over ROUTE_DT in Pfaf catch space [m3/s] - !WTOT_BEFORE = WSTREAM + WRIVER + WRES - - + arrayPtr8 = real(route%runoff_acc(:), kind=REAL64) + + ! Map accumulated runoff from land tile space to route/Pfaf space. + call ESMF_FieldSMM(srcField=route%field_src, dstField=route%field, & + routeHandle=route%routeHandle, rc=status) + VERIFY_(STATUS) + + ! Get mapped route/Pfaf runoff field. + call ESMF_FieldGet(route%field, farrayPtr=arrayPtr8, rc=status) + VERIFY_(STATUS) + + ! Convert units [kg m-2 s-1] --> [m3 s-1]. + QRUNOFF = real(arrayPtr8 * real(route%areacat, kind=REAL64) / 1000.0_REAL64, & + kind=kind(QRUNOFF(1))) + ! Compute outflow from main river and (optionally) reservoirs ! ! Call river_routing_model (get outflows from main river and local streams, also updates storage of main river and local streams) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 index 0f4ba9e7d8..6e6df781f3 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_OpenWaterGridComp.F90 @@ -1298,7 +1298,7 @@ subroutine SetServices ( GC, RC ) UNITS = 'PSU', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - DEFAULT = 30.0, & + DEFAULT = 33.3333, & !SK - Match the SS_FOUND in OpenWater and SeaiceInterface _RC) call MAPL_AddImportSpec(GC, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 index e3897efc1b..d573698cf4 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSsaltwater_GridComp/GEOS_SimpleSeaiceGridComp.F90 @@ -1071,7 +1071,7 @@ subroutine SetServices ( GC, RC ) UNITS = 'psu', & DIMS = MAPL_DimsTileOnly, & VLOCATION = MAPL_VLocationNone, & - DEFAULT = 30.0, & + DEFAULT = 33.3333, & !SK - Match the SS_FOUND inSimpleSeaice with that from OpenWater and SeaiceInterface _RC ) call MAPL_AddImportSpec(GC, & diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc index 6985db47e0..16ebfc0d2a 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc @@ -257,3 +257,15 @@ # =============== EOF ===================================================================================== +#--------------------------------------------------------# +# Ice-Sheet and Sea-Level System Model (ISSM) # +# # +# * DO_ISSM is the run flag, turned off (0) by default # +# set DO_ISSM: 1 to run ISSM # +# * ISSM_DT is ISSM's time step, semiweekly by default # +#--------------------------------------------------------# +# GEOSagcm=>DO_ISSM: 0 +# GEOSagcm=>ISSM_DT: 302400 +# +# GEOSldas=>DO_ISSM: 0 +# GEOSldas=>ISSM_DT: 302400 \ No newline at end of file diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt index 3fb24cb508..a6b165cd17 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CMakeLists.txt @@ -11,18 +11,10 @@ zip.c util.c ) -if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) - list(APPEND srcs findloc.F90) -endif () - set_source_files_properties(mkMITAquaRaster.F90 PROPERTIES COMPILE_FLAGS "${BYTERECLEN}") esma_add_library(${this} SRCS ${srcs} DEPENDENCIES MAPL GEOS_SurfaceShared GEOS_LandShared ESMF::ESMF NetCDF::NetCDF_Fortran OpenMP::OpenMP_Fortran) -if(NOT FORTRAN_COMPILER_SUPPORTS_FINDLOC) - target_compile_definitions(${this} PRIVATE USE_EXTERNAL_FINDLOC) -endif () - # MAT NOTE This should use find_package(ZLIB) but Baselibs currently # confuses find_package(). This is a hack until Baselibs is # reorganized. @@ -51,7 +43,7 @@ ecbuild_add_executable (TARGET mk_runofftbl.x SOURCES mk_runofftbl.F90 LIBS MAPL ecbuild_add_executable (TARGET mkEASETilesParam.x SOURCES mkEASETilesParam.F90 LIBS MAPL ${this}) ecbuild_add_executable (TARGET TileFile_ASCII_to_nc4.x SOURCES TileFile_ASCII_to_nc4.F90 LIBS MAPL ${this}) -install(PROGRAMS clsm_plots.pro create_README.csh DESTINATION bin) +install(PROGRAMS clsm_plots.py create_README.csh DESTINATION bin) file(GLOB MAKE_BCS_PYTHON CONFIGURE_DEPENDS "./make_bcs*.py") list(FILTER MAKE_BCS_PYTHON EXCLUDE REGEX "make_bcs_shared.py") install(PROGRAMS ${MAKE_BCS_PYTHON} DESTINATION bin) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.pro deleted file mode 100755 index d5584b3dde..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.pro +++ /dev/null @@ -1,3738 +0,0 @@ -;_____________________________________________________________________ - -FUNCTION NCDF_ISNCDF, FILENAME - -;- Set return values - -false = 0B -true = 1B - -;- Establish error handler - -catch, error_status -if error_status ne 0 then begin - catch, /cancel - return, false -endif - -;- Try opening the file - -cdfid = ncdf_open( filename ) - -;- If we get this far, open must have worked - -ncdf_close, cdfid -catch, /cancel -return, true - -END - -; ---------------- - -function nint, x, LONG = long ;Nearest Integer Function -;+ -; NAME: -; NINT -; PURPOSE: -; Nearest integer function. -; EXPLANATION: -; NINT() is similar to the intrinsic ROUND function, with the following -; two differences: -; (1) if no absolute value exceeds 32767, then the array is returned as -; as a type INTEGER instead of LONG -; (2) NINT will work on strings, e.g. print,nint(['3.4','-0.9']) will -; give [3,-1], whereas ROUND() gives an error message -; -; CALLING SEQUENCE: -; result = nint( x, [ /LONG] ) -; -; INPUT: -; X - An IDL variable, scalar or vector, usually floating or double -; Unless the LONG keyword is set, X must be between -32767.5 and -; 32767.5 to avoid integer overflow -; -; OUTPUT -; RESULT - Nearest integer to X -; -; OPTIONAL KEYWORD INPUT: -; LONG - If this keyword is set and non-zero, then the result of NINT -; is of type LONG. Otherwise, the result is of type LONG if -; any absolute values exceed 32767, and type INTEGER if all -; all absolute values are less than 32767. -; EXAMPLE: -; If X = [-0.9,-0.1,0.1,0.9] then NINT(X) = [-1,0,0,1] -; -; PROCEDURE CALL: -; None: -; REVISION HISTORY: -; Written W. Landsman January 1989 -; Added LONG keyword November 1991 -; Use ROUND if since V3.1.0 June 1993 -; Always start with ROUND function April 1995 -; Return LONG values, if some input value exceed 32767 -; and accept string values February 1998 -; Use size(/TNAME) instead of DATATYPE() October 2001 -;- -xmax = max(x,min=xmin) - xmax = abs(xmax) > abs(xmin) - if (xmax gt 32767) or keyword_set(long) then begin - if size(x,/TNAME) eq 'STRING' then b = round(float(x)) else b = round(x) - end else begin - if size(x,/TNAME) eq 'STRING' then b = fix(round(float(x))) else $ - b = fix(round(x)) - endelse - - return, b - end - -; ------------------------------------------------------------------------------------------- - -FUNCTION IS_IN_DOMAIN, xylim, x,y - -if (((x ge xylim(1)) and (x le xylim(3))) and $ - ((y ge xylim(0)) and (y le xylim(2)))) then begin - - return_value = boolean(1) - -endif else begin - - return_value = boolean(0) - -endelse - -return,return_value - -END - -; ####################################################### - -FUNCTION Z0_VALUE, Z2CH, lai, SCALE4Z0 - -MIN_VEG_HEIGHT = 0.01 -Z0_BY_ZVEG = 0.13 - -if (SCALE4Z0 eq 2.) then begin - return_value = SCALE4Z0 * Z0_BY_ZVEG * (Z2CH - (Z2CH - MIN_VEG_HEIGHT) * exp(-1.*LAI)) -endif else begin - return_value = Z0_BY_ZVEG * (Z2CH - SCALE4Z0 * (Z2CH - MIN_VEG_HEIGHT) * exp(-1.*LAI)) -endelse - -return,return_value - -END - -;=========================================================== -;+ -; NAME: -; SHUFFLE -; -; PURPOSE: -; This function returns the uniformly-shuffled elements of an array. -; -; CATEGORY: -; Math. -; -; CALLING SEQUENCE: -; -; Result = SHUFFLE( A [, Num]) -; -; INPUTS: -; A: Array containing the elements to shuffle (e.g. INDGEN(100)) -; -; OPTIONAL INPUTS: -; Num: Number of shuffled elements to return. Must be < N_ELEMENTS(A)+1 -; -; OPTIONAL INPUT KEYWORD PARAMETERS: -; SEED: Number used to seed the random number generator, RANDOMU. -; -; OUTPUTS: -; Returns the Num shuffled elements of the A array. -; -; OPTIONAL OUTPUT KEYWORD PARAMETERS: -; -; INDICES: Array of indices pointing to the shuffled elements of A. -; -; EXAMPLE: -; Pick 10 unique random integers between the numbers 1..100: -; -; i = INDGEN(100) -; j = SHUFFLE(i,10) -; -; MODIFICATION HISTORY: -; Written by: Han Wen, January 1997. -;- -function SHUFFLE, A, Num, INDICES=Indices, SEED=Seed - - NP = N_PARAMS() - N = N_ELEMENTS(A) - if (N eq 0) then message, $ - 'Must be called with 1-2 parameters: A [,Num]' - if (NP eq 1) then Num = N - - r = RANDOMU(Seed, N) - Indices = SORT(r) - return, A(Indices(0:Num-1)) -end - -; ######################################################### - -PRO clsm_plots - -; ########################################################## -; Calling Sequence: -; (1) get environment variables -; (2) reading catchment.def and setting map limits -; (3) generating NC_plot x NR_plot mask for plotting maps -; (4) plotting catchment-tiles in the Eastern United States -; (5) processing JPL Height -; (6) plotting CTI statistics -; (7) plotting vegetation types -; (8) plotting soil hydraulic properties -; (9) plotting elevation -; (10)plot LAI monthly climatology -; (11)generating NC_plot x NR_plot mask for plotting maps -; (12)making movies of Seasonal data -; -; Miscellaneous Routines -; (a1) check_satparam - Check ars and arw parameters -; (a2) create_vec_file - For LIS/GSWP-2 type applications -; ########################################################## - -; (1) Reading in Enviornment variables -; -------------------------------- - -gfile=GETENV('gfile') -path =GETENV('workdir') -NC =1l*GETENV('NC') -NR =1l*GETENV('NR') - - -; (2) Reading number of catchments -;--------------------------------- - -openr,1,'../catchment.def' -ncat = 0l -readf,1,ncat - -if((stregex (gfile,'Pfafstetter') ge 0) or (stregex (gfile,'SMAP') ge 0)) then begin -; global plots -endif else begin - -min_lon = 180. -max_lon = -180. -min_lat = 90. -max_lat = -90. -a1 = 0. -a2 = 0. -a3 = 0. -a4 = 0. -k = 0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,a1, a2, a3, a4 - if (a1 lt min_lon) then min_lon = a1 - if (a2 gt max_lon) then max_lon = a2 - if (a3 lt min_lat) then min_lat = a3 - if (a4 gt max_lat) then max_lat = a4 -endfor - -limits = [floor(min_lat), floor(min_lon),ceil(max_lat),ceil(max_lon)] -if((ceil(max_lon) - floor(min_lon)) lt 180.) then save,limits,file ='limits.idl' - -endelse - -close,1 - -; (3) generating NC_plot x NR_plot mask for plotting maps -;-------------------------------------------------------- - -NC_plot = 4320 -NR_plot = 2160 - -tile_id = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -rst_file=path + '/rst/' + gfile+'*.rst' -openr,1,rst_file,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le ncat) then begin - min1 = min(subset) - subset(where (subset gt ncat)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tile_id[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 - - -; (4) plotting catchment-tiles in the Eastern United States -;---------------------------------------------------------- - -plot_tiles,nc,nr,ncat,gfile,path - -; plot countr_codes -country_codes, tile_id - -; (5) Plot canopy height -; ---------------------- - -;canop_Height, nc,nr, tile_id, gfile, path - -; (6) plotting CTI statistics -;---------------------------- - -filename = '../cti_stats.dat' -cti_mean = fltarr (ncat) -cti_std = fltarr (ncat) -cti_skew = fltarr (ncat) - -a1 = 0. -a2 = 0. -a3 = 0. -a4 = 0. -a5 = 0. -k = 0 -openr,1,filename - -readf,1,k - -for i = 0l,ncat -1l do begin - readf,1,k,k,a1, a2, a3, a4, a5 - cti_mean (i) = a1 - cti_std (i) = a2 - cti_skew (i) = a5 -endfor - -close,1 -clm_file = '../CLM_veg_typs_fracs' -if (file_test (clm_file)) then begin -endif else begin -cti_mean = 0.961*cti_mean - 1.957 -endelse - - -;plot_vars2, ncat, tile_id, cti_mean, 'cti_mean' -;plot_vars2, ncat, tile_id, cti_std , 'cti_std' -;plot_vars2, ncat, tile_id, cti_skew, 'cti_skew' - -plot_three_vars1, ncat, tile_id, cti_mean, cti_std, cti_skew - -cti_mean = 0. -cti_std = 0. -cti_skew = 0. - -; (7) plotting vegetation types -;------------------------------ - -plot_mosaic, ncat, tile_id -clm_file = '../CLM_veg_typs_fracs' - -if (file_test (clm_file)) then begin - - plot_clm , ncat, tile_id - plot_carbon, ncat, tile_id - -; Now plot Ndep, T2m and SoilAlb -; ------------------------------ - - filename = '../CLM_NDep_SoilAlb_T2m' - ndep = fltarr (ncat) - visdr = fltarr (ncat) - visdf = fltarr (ncat) - nirdr = fltarr (ncat) - nirdf = fltarr (ncat) - t2mm = fltarr (ncat) - t2mp = fltarr (ncat) - - a1 = 0. - a2 = 0. - a3 = 0. - a4 = 0. - a5 = 0. - a6 = 0. - a7 = 0. - - openr,1,filename - - for i = 0l,ncat -1l do begin - readf,1,a1, a2, a3, a4, a5, a6, a7 - ndep (i) = a1 - visdr(i) = a2 - visdf(i) = a3 - nirdr(i) = a4 - nirdf(i) = a5 - t2mm (i) = a6 - t2mp (i) = a7 - - endfor - - close,1 - plot_three_vars2, ncat, tile_id, ndep, t2mm, t2mp - plot_soilalb, ncat, tile_id,VISDR, VISDF, NIRDR, NIRDF - - ndep = 0. - visdr = 0. - visdf = 0. - nirdr = 0. - nirdf = 0. - t2mm = 0. - t2mp = 0. - -endif - -; (8) plotting soil hydraulic properties -;--------------------------------------- - -filename = '../soil_param.dat' -bee = fltarr (ncat) -psis = fltarr (ncat) -poro = fltarr (ncat) -cond = fltarr (ncat) -wwet = fltarr (ncat) -sdep = fltarr (ncat) -a1 = 0. -a2 = 0. -a3 = 0. -a4 = 0. -a5 = 0. -a6 = 0. -k = 0 - -openr,1,filename - -for i = 0l,ncat -1l do begin - readf,1,k,k,k,k,a1, a2, a3, a4, a5, a6 - bee (i) = a1 - psis (i) = a2 - poro (i) = a3 - cond (i) = a4 - wwet (i) = a5 - sdep (i) = a6 -endfor - -close,1 - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,800], Z_Buffer=0 -load_colors -Erase,255 - -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 3, 0, 0] - -plot_vars, ncat, tile_id, bee, [1. ,8.], 'BEE' -plot_vars, ncat, tile_id, psis,[-1.85,-0.1],'PSIS',advance =1 -plot_vars, ncat, tile_id, poro,[0.37,0.8],'POROS',advance =1 -plot_vars, ncat, tile_id, cond,[2.37e-6,2.845e-4],'COND',advance =1 -plot_vars, ncat, tile_id, wwet,[0.01,0.45],'WPWET',advance =1 -plot_vars, ncat, tile_id, sdep,[1334.,5000.],'SOILDEPTH',advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 800) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'soil_param.jpg', image24, True=1, Quality=100 - -;plot_vars2, ncat, tile_id, bee, 'BEE' -;plot_vars2, ncat, tile_id, psis,'PSIS' -;plot_vars2, ncat, tile_id, poro,'POROS' -;plot_vars2, ncat, tile_id, cond,'COND' -;plot_vars2, ncat, tile_id, wwet,'WPWET' -;plot_vars2, ncat, tile_id, sdep,'SOILDEPTH' - -bee = 0. -psis = 0. -poro = 0. -cond = 0. -wwet = 0. -sdep = 0. - -; (9) plotting elevation -;----------------------- - -filename = '../catchment.def' -elevation = fltarr (ncat) - -a1 = 0. -a2 = 0. -k = 0 - -openr,1,filename - -readf,1,k - -for i = 0l,ncat -1l do begin - readf,1,k,k,a1, a1, a1, a1, a2 - elevation (i) = a2 -endfor - -close,1 - -plot_vars2, ncat, tile_id, elevation, 'ELEVATION' - -elevation = 0. - -; (10) plot LAI monthly climatology -; -------------------------------- - -plot_lai, ncat, tile_id - -; (11) vegetation height and roughness length -filename = '../vegdyn.data' -ncdf_file = boolean (ncdf_isncdf(filename)) - -if (ncdf_file) then begin - - ncid = NCDF_OPEN(filename,/NOWRITE) - NCDF_VARGET, ncid,'ITY', ITYP - NCDF_VARGET, ncid,'Z2CH', Z2 - NCDF_VARGET, ncid,'ASCATZ0', ASZ0 - NCDF_CLOSE, ncid - -endif else begin - - openr,1,filename,/F77_UNFORMATTED - ityp = fltarr (ncat) - z2 = fltarr (ncat) - asz0 = fltarr (ncat) - - readu,1,ITYP - readu,1,Z2 - readu,1,ASZ0 - close,1 - -endelse - -ASZ0 = ASZ0 * 1000. - - -plot_canoph, z2, tile_id - -if (file_test ( '../CLM_veg_typs_fracs')) then begin -SCALE4Z0 = 0.5 -endif else begin -SCALE4Z0 = 2. -endelse - -compute_zo,'ascat' , SCALE4Z0, ASZ0, Z2, tile_id -compute_zo,'icarus', SCALE4Z0, ASZ0, Z2, tile_id -compute_zo,'merged', SCALE4Z0, ASZ0, Z2, tile_id - -; plotting irrigation parameters -; ------------------------------ - -;plot_crop_times, ncat, tile_id -;irrig_method, ncat, tile_id -;plot_lai_minmax, ncat, tile_id -;irrig_fractions, ncat, tile_id - - -; (12) generating NC_plot x NR_plot mask for plotting maps -;-------------------------------------------------------- - -NC_movie = 720 -NR_movie = 360 -Ntiles_per_cell = 30 -if(NC gt 8640) then Ntiles_per_cell = 800 - -vec_map = {NT:0, TID: lonarr (Ntiles_per_cell), TFrac : fltarr (Ntiles_per_cell)} -vec2grid = REPLICATE (vec_map,NC_movie,NR_movie) - -dx = NC/NC_movie -dy = NR/NR_movie -cat = lonarr(nc,dy) -catrow = lonarr(nc) - -rst_file=path + '/rst/' + gfile+'*.rst' -openr,1,rst_file,/F77_UNFORMATTED - -for j = 0l, NR_movie -1 do begin - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_movie -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - cat_unq = Subset[uniq(Subset,sort(Subset))] - k_land = where ((cat_unq ge 1l) and (cat_unq le ncat)) - if (max(k_land) ne -1) then begin - hh = intarr(n_elements (cat_unq)) - for k = 0,n_elements (cat_unq) -1 do hh[k] = $ - n_elements(where (Subset eq cat_unq[k])) - NCOUNT = 0 - - for k = 0, n_elements (hh) -1 do begin - if((cat_unq (k) ge 1) and (cat_unq (k) le ncat)) then begin - if (NCOUNT eq Ntiles_per_cell) then begin - print, 'Increase Ntiles_per_cell' - stop - endif - vec2grid[i,j].NT = vec2grid[i,j].NT + 1 - vec2grid[i,j].TID (NCOUNT) = cat_unq (k) - vec2grid[i,j].TFrac(NCOUNT) = 1.*hh(k)/total(hh) - NCOUNT = NCOUNT + 1 - endif - endfor - endif - endfor -endfor - -close,1 - -; (12) Making movies of Seasonal data -;------------------------------------ - -make_movies, ncat, vec2grid, 'LAI' -make_movies, ncat, vec2grid, 'GREEN' -make_movies, ncat, vec2grid, 'VISDF' -make_movies, ncat, vec2grid, 'NIRDF' - -END - -; ============================================================================== -; Catchment-CN classes -; ============================================================================== - -PRO plot_carbon,ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_type = intarr (ncat,4) -clm_grid = intarr (im,jm,4) - -filename = '../CLM_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -fr= 0. -v1= 0 -v2= 0 -v3= 0 -v4 =0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,v1,v2,v3,v4,fr,fr,fr,fr,v,v - clm_type(i,0) = v1 - clm_type(i,1) = v2 - clm_type(i,2) = v3 - clm_type(i,3) = v4 -endfor - -close,1 - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - clm_grid(i,j,2) = clm_type(tile_id[i,j] -1,2) - clm_grid(i,j,3) = clm_type(tile_id[i,j] -1,3) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 -;types= [ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,11a, 12, 13, 14,14a, 15,15a, 16,16a, 17] -r_in = [106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_in = [ 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_in = [154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(19) -clm_name( 0) = 'NLEt' ; 1 needleleaf evergreen temperate tree -clm_name( 1) = 'NLEB' ; 2 needleleaf evergreen boreal tree -clm_name( 2) = 'NLDB' ; 3 needleleaf deciduous boreal tree -clm_name( 3) = 'BLET' ; 4 broadleaf evergreen tropical tree -clm_name( 4) = 'BLEt' ; 5 broadleaf evergreen temperate tree -clm_name( 5) = 'BLDT' ; 6 broadleaf deciduous tropical tree -clm_name( 6) = 'BLDt' ; 7 broadleaf deciduous temperate tree -clm_name( 7) = 'BLDB' ; 8 broadleaf deciduous boreal tree -clm_name( 8) = 'BLEtS' ; 9 broadleaf evergreen temperate shrub -clm_name( 9) = 'BLDtS' ; 10 broadleaf deciduous temperate shrub [moisture + deciduous] -clm_name(10) = 'BLDtSm'; 11 broadleaf deciduous temperate shrub [moisture stress only] -clm_name(11) = 'BLDBS' ; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass [moisture + deciduous] -clm_name(14) = 'CC3Gm' ; 15 cool c3 grass [moisture stress only] -clm_name(15) = 'WC4G' ; 16 warm c4 grass [moisture + deciduous] -clm_name(16) = 'WC4Gm' ; 17 warm c4 grass [moisture stress only] -clm_name(17) = 'CROP' ; 18 crop [moisture + deciduous] -clm_name(18) = 'CROPm' ; 19 crop [moisture stress only] - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CatchmentCN_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,2],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,3],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CatchmentCN_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END - -; ============================================================================== -; CLM classes -; ============================================================================== - -PRO plot_clm,ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_type = intarr (ncat,2) -clm_grid = intarr (im,jm,2) - -filename = '../CLM_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -fr= 0. -v1= 0 -v2= 0 - -for i = 0l,ncat -1l do begin - readf,1,k,k,v,v,v,v,fr,fr,fr,fr,v1,v2 - clm_type(i,0) = v1 - clm_type(i,1) = v2 -endfor - -close,1 - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [255,106,202,251, 0, 29, 77,109,142,233,255,255,127,164,217,204, 0] -g_in = [245, 91,178,154, 85,115,145,165,185, 23,131,191, 39, 53, 72,204, 70] -b_in = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0, 0, 4, 3, 1,204,200] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(16) -clm_name( 0) = 'BARE' ; 1 bare -clm_name( 1) = 'NLEt' ; 2 needleleaf evergreen temperate tree -clm_name( 2) = 'NLEB' ; 3 needleleaf evergreen boreal tree -clm_name( 3) = 'NLDB' ; 4 needleleaf deciduous boreal tree -clm_name( 4) = 'BLET' ; 5 broadleaf evergreen tropical tree -clm_name( 5) = 'BLEt' ; 6 broadleaf evergreen temperate tree -clm_name( 6) = 'BLDT' ; 7 broadleaf deciduous tropical tree -clm_name( 7) = 'BLDt' ; 8 broadleaf deciduous temperate tree -clm_name( 8) = 'BLDB' ; 9 broadleaf deciduous boreal tree -clm_name( 9) = 'BLEtS'; 10 broadleaf evergreen temperate shrub -clm_name(10) = 'BLDtS'; 11 broadleaf deciduous temperate shrub -clm_name(11) = 'BLDBS'; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass -clm_name(14) = 'WC4G' ; 15 warm c4 grass -clm_name(15) = 'CROP' ; 16 crop - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(clm_name) -1 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END - -; ============================================================================== -; Make movies -; ============================================================================== - -PRO make_movies, ncat, vec2grid, vname - -upval = 1. -lwval = 0. - -if (vname eq 'LAI') then upval = 6. - -if (vname eq 'LAI') then filename = '../lai.dat' -if (vname eq 'GREEN') then filename = '../green.dat' -if (vname eq 'VISDF') then filename = '../AlbMap.WS.8-day.tile.0.3_0.7.dat' -if (vname eq 'NIRDF') then filename = '../AlbMap.WS.8-day.tile.0.7_5.0.dat' - -im = n_elements(vec2grid[*,0].NT) -jm = n_elements(vec2grid[0,*].NT) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -DEVICE, DECOMPOSED = 0 - -r_in = [253,224,255,238,205,193,152, 0,124, 0, 0, 0, 0, 0, 0, 48,110, 85] -g_in = [253,238,255,238,205,255,251,255,252,255,238,205,139,128,100,128,139,107] -b_in = [253,224, 0, 0, 0,193,152,127, 0, 0, 0, 0, 0, 0, 0, 20, 61, 47] - -n_levels = n_elements (r_in) - -if (vname eq 'LAI') then begin - levels=[0.,0.25,0.5,0.75,1.,1.25,1.5,10. * indgen(11)*0.05+2.] -endif else begin - levels=[0.,0.025,0.05,0.075,0.1,0.125,0.15,0.2,0.3,0.35,0.4,0.45,0.5,0.6,0.7,0.8,0.9,1.0] -endelse - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, N_levels -1 do begin - red (k+1) = r_in (k) - green(k+1) = g_in (k) - blue (k+1) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = indgen (N_levels) + 1 - -compile_opt idl2 - -openr,1,filename,/F77_UNFORMATTED - -yr=0. -mn =0. -dy =0. -dum =0. -yr1 =0. -mn1 =0. -dy1 =0. -yrg=0. -mng =0. -lai = fltarr (im,jm) -lai1 = fltarr (im,jm) -lai2 = fltarr (im,jm) -lai_vec = fltarr (ncat) -lai1 [*,*] = !VALUES.F_NAN -lai2 [*,*] = !VALUES.F_NAN - -alpha = fltarr(n_levels,2) -alpha [*,0] = levels -alpha [*,1] = levels -h = [0,1] -m_days = [31,28,31,30,31,30,31,31,30,31,30,31] - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -readu,1,lai_vec - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(vec2grid[i,j].NT gt 0) then begin - for k = 0, vec2grid[i,j].NT -1 do begin - if (k eq 0) then lai1[i,j] = 0. - lai1[i,j] = lai1[i,j] + lai_vec[vec2grid[i,j].TID[k] -1]*vec2grid[i,j].TFrac[k] - endfor - endif - endfor -endfor - -dofyr_b4 = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,1,lai_vec - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(vec2grid[i,j].NT gt 0) then begin - for k = 0, vec2grid[i,j].NT -1 do begin - if (k eq 0) then lai2[i,j] = 0. - lai2[i,j] = lai2[i,j] + lai_vec[vec2grid[i,j].TID[k] -1]*vec2grid[i,j].TFrac[k] - endfor - endif - endfor -endfor - -compile_opt idl2 - -video_file = vname+'.mp4' -video = idlffvideowrite(video_file) -framerate = 10 -framedims = [750,512] -stream = video.addvideostream(framedims[0], framedims[1], framerate) -set_plot, 'z', /copy -device, set_resolution=framedims, set_pixel_depth=24, decomposed=0 - -for month = 1,12 do begin - for day =1,m_days[month -1] do begin - !P.position=0 - dofyr_now = float(julday(month,day,2001+yr)-julday(12,31,2000)) - fac1 = (dofyr_now - dofyr_b4 )/(dofyr_nxt - dofyr_b4) - fac2 = (dofyr_nxt - dofyr_now)/(dofyr_nxt - dofyr_b4) - lai = fac1*lai2 + fac2*lai1 - - dstamp =string(2001+fix(yr),'(i4.4)')+string(fix(month),'(i2.2)')+string(fix(day),'(i2.2)') - Erase, Color= 255 - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,title=vname + ':' + dstamp - contour, lai,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - !P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=255,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=levels - if (vname eq 'LAI') then begin - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format='(f4.2)') ,orientation=90,color=0,charsize =0.8 - endif else begin - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format='(f5.3)') ,orientation=90,color=0,charsize =0.8 - endelse - - timestamp = video.put(stream, tvrd(true=1)) - - if(dofyr_now + 0.5 ge dofyr_nxt) then begin - lai1 = lai2 - dofyr_b4 = dofyr_nxt - readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - - dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - if((month eq 12) and (yr eq 2)) then yr = yr -1 - readu,1,lai_vec - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(vec2grid[i,j].NT gt 0) then begin - for k = 0, vec2grid[i,j].NT -1 do begin - if (k eq 0) then lai2[i,j] = 0. - lai2[i,j] = lai2[i,j] + lai_vec[vec2grid[i,j].TID[k] -1]*vec2grid[i,j].TFrac[k] - endfor - endif - endfor - endfor - endif - endfor - endfor - -close,1 - -device, /close -set_plot, strlowcase(!version.os_family) eq 'windows' ? 'win' : 'x' -video.cleanup - -END - -; ============================================================================== -; Mosaic classes -; ============================================================================== - -PRO plot_mosaic, ncat, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -mos_type = intarr (ncat) -mos_grid = intarr (im,jm) - -filename = '../mosaic_veg_typs_fracs' -openr,1,filename -k = 0 -v = 0 -for i = 0l,ncat -1l do begin - readf,1,k,k,v - mos_type(i) = v -endfor - -close,1 - -mos_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then mos_grid(i,j) = mos_type(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [233,255,255,255,210, 0, 0, 0,204,170,255,220,205, 0, 0,170, 0, 40,120,140,190,150,255,255, 0, 0, 0,195,255, 0,255, 0] -g_in = [ 23,131,191,255,255,255,155, 0,204,240,255,240,205,100,160,200, 60,100,130,160,150,100,180,235,120,150,220, 20,245, 70,255, 0] -b_in = [ 0, 0, 0,178,255,255,255,200,204,240,100,100,102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50,175, 90,120,130, 0,215,200,255, 0] -vtypes =[ 1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 14, 20, 30, 40, 50, 60, 70, 90,100,110,120,130,140,150,160,170,180,190,200,210,220,230] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, mos_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -mos_name = strarr(6) -mos_name( 0) = 'BL Evergreen' -mos_name( 1) = 'BL Deciduous' -mos_name( 2) = 'Needleleaf' -mos_name( 3) = 'Grassland' -mos_name( 4) = 'BL Shrubs' -mos_name( 5) = 'Dwarf' - -n_levels = 6;n_elements(vtypes) -alpha=fltarr(n_levels+1,2) -alpha[*,0]=levels [0:n_levels] -alpha[*,1]=levels [0:n_levels] -h=[0,1] -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels[0:6],h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[1,7], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels[0:6],h,levels=levels,color=0,/overplot,c_label=clev -for k = 0,5 do xyouts,levels[k]+0.5,1.2,mos_name[k] ,orientation=90,color=0 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'mosaic_prim.jpg', image24, True=1, Quality=100 - - -END - -; ============================================================================== -; Catchment-tiles in the Eastern United States -; ============================================================================== - -PRO plot_tiles,nc,nr,ncat,gfile,path - -dx=360./nc -dy=180./nr - -glon = fltarr (nc) -glat = fltarr (nr) - -for i = 0l,nc -1l do glon(i) = -180. + dx/2. + i*dx -for i = 0l,nr -1l do glat(i) = -90. + dy/2. + i*dy - -xylim = [35.,-82.,42.,-73] - -if file_test ('limits.idl') then begin - restore,'limits.idl' - xylim = limits -endif - -i1 = where((glon ge xylim(1)) and (glon lt xylim(1) + dx)) -i2 = where((glon ge xylim(3)) and (glon lt xylim(3) + dx)) -j1 = where((glat ge xylim(0)) and (glat lt xylim(0) + dy)) -j2 = where((glat ge xylim(2)) and (glat lt xylim(2) + dy)) - -xlen=xylim(3)-xylim(1) -ylen=xylim(2)-xylim(0) -init=replicate(0.,xlen,ylen) -x = indgen(xlen)+xylim(1) -y = indgen(ylen)+xylim(0) - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 -n_levels = 30 -colors = indgen(30) + 90 -load_colors -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -contour,init,x,y,title=tit,xrange=[x(0),x(xlen-1)+1.],yrange=[y(0),y(ylen-1)+1.],xstyle=1,ystyle=1,color =0 - -pfc =0l -pfc1=0l -pfcl=0l -pfcr=0l - -cat =lonarr(nc) -catp=lonarr(nc) -rst_file=path + '/rst/' + gfile+'*.rst' -idum=0l -openr,1,rst_file,/F77_UNFORMATTED - -for j= 0l,j2(0) do begin - - readu,1,cat - if(j ge j1) then begin - yu = -90. + j*dy + dy - yl = -90. + j*dy - for i = i1(0),i2(0) do begin - pfc =cat(i) - pfc1=cat(i) - if((pfc ge 1) and (pfc le ncat)) then begin - if(i ne 0) then pfcl = cat(i-1) - if(i ne nc-1) then pfcr = cat(i+1) - if(j eq 0)then catp(i)=pfc - xl= -180. + i*dx - xr= -180. + i*dx +dx - xx=fltarr(5) - yy=fltarr(5) - xx=[xl,xl,xr,xr,xl] - yy=[yu,yl,yl,yu,yu] - n = pfc mod n_levels - polyfill,xx,yy,color=colors(n) - if(pfc ne catp(i)) then oplot,[xl,xr],[yl,yl],color =0 - if(pfc ne pfcl) then oplot,[xl,xl],[yl,yu],color =0 - if(pfc ne pfcr) then oplot,[xr,xr],[yl,yu],color =0 - endif - catp(i)=pfc - endfor - endif -endfor -close,1 -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'US-east.jpg', image24, True=1, Quality=100 - -END - -;======================================================================== -; Global maps -;======================================================================== - -PRO plot_vars, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) -if (vname eq 'SOILDEPTH') then upval = 5000. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if(vname eq 'POROS') then $ -levels = [lwval,lwval+(0.57-lwval)/(n_levels -2) +indgen(n_levels -2)*(0.57-lwval)/(n_levels -2),upval] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -levels_x = levels - -if(vname eq 'POROS') then begin -dxp = (0.8-0.37)/16. -levels_x = indgen(17)*dxp+ 0.37 -endif - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f4.2)' -if(vname eq 'COND') then fmt_string = '(e8.2)' -if(vname eq 'SOILDEPTH') then fmt_string = '(i4)' -if(vname eq 'PSIS') then fmt_string = '(f5.2)' - -if(vname eq 'BEE') then !P.position=[0.064, 0.675, 0.41, 0.69] -if(vname eq 'PSIS') then !P.position=[0.58, 0.675, 0.92, 0.69] -if(vname eq 'POROS') then !P.position=[0.064, 0.345, 0.41, 0.36] -if(vname eq 'COND') then !P.position=[0.58, 0.345, 0.92, 0.36] -if(vname eq 'WPWET') then !P.position=[0.064, 0.015, 0.41, 0.03] -if(vname eq 'SOILDEPTH') then !P.position=[0.58, 0.015, 0.92, 0.03] - -;!P.position=[0.064, 0.675, 0.41, 0.69] -;!P.position=[0.58, 0.0+0.005, 0.92, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -;for l = 0,n_levels -2 do begin -; k = l -; xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] -; ybox = [-65., -55.,-55.,-65.,-65.] -; polyfill, xbox,ybox,color=colors [k] -; -; xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -; k = k + 1 -;endfor -; -;l = n_levels -1 -;xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -!P.position=0 - -END - -;________________________________________________________ -;________________________________________________________ -;________________________________________________________ - - -PRO plot_vars2, ncat, tile_id, data, vname - -lwval = min(data) -upval = max(data) -if (vname eq 'SOILDEPTH') then upval = 5000. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -load_colors -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,title = vname -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] -!P.position=[0.15, 0.0+0.005, 0.85, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev -if(vname eq 'COND') then begin - for k = 0,n_elements(levels) -1 do xyouts,levels[k],1.1, string(levels[k],'(e10.3)'),orientation=90,color=0 -endif else begin - if ((vname eq 'SOILDEPTH') or (vname eq 'ELEVATION')) then begin - for k = 0,n_elements(levels) -1 do xyouts,levels[k],1.1, string(levels[k],'(f5.0)'),orientation=90,color=0 - endif else begin - for k = 0,n_elements(levels) -1 do xyouts,levels[k],1.1, string(levels[k],'(f5.2)'),orientation=90,color=0 - endelse -endelse - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, vname + '.jpg', image24, True=1, Quality=100 - -END - -;======================================================================== -; Check ars and arw parameters -;======================================================================== - -PRO check_satparam - -arw1=0. -arw2=0. -arw3=0. -arw4=0. -ars1=0. -ars2=0. -ars3=0. -cti_mean=0. -cti_std =0. -cti_min =0. -cti_max =0. -cti_skew=0. -BEE =0. -PSIS =0. -POROS=0. -COND =0. -WPWET=0. -soildepth=0. -nbdep=0 -nbdepl=0 -wmin0=0. -cdcr1=0. -cdcr2=0. - -file3='file.0000001' -openr,12,file3 -readf,12,cti_mean, cti_std,cti_min, cti_max, cti_skew -readf,12,BEE, PSIS,POROS,COND,WPWET,soildepth -readf,12,nbdep,nbdepl,wmin0,cdcr1,cdcr2 - -catdef = fltarr(nbdep) -ar1 = fltarr(nbdep) -wmin = fltarr(nbdep) - -readf,12,catdef -readf,12,ar1 -readf,12,wmin -readf,12,ars1,ars2,ars3 -readf,12,arw1,arw2,arw3,arw4 -close,12 - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -load_colors -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] - -ntot=nbdep -x=indgen(ntot) -y = fltarr(ntot) - -plot,x,y,xrange=[0.,max(catdef)],yrange=[0.,1.],linestyle=0,title='WMIN and AR1', color =0 -oplot,catdef,wmin,color = 30 -oplot,[cdcr1,cdcr1],[0.,1], color = 100 -oplot,[cdcr2,cdcr2],[0.,1], color = 100 - -;ntot=fix(catdef(nbdep-1))+ 1. -ntot =fix(cdcr1)+ 1. -ntot2=fix(cdcr2)+ 1. - -x=indgen(ntot2) -y=fltarr(ntot) -y2=fltarr(ntot2) -for n =0,ntot2-1 do begin - - if (n lt ntot) then y(n) = arw4 + (1.- arw4)*(1.+ arw1*x(n))/(1.+ arw2*x(n)+ arw3*x(n)*x(n)) - y2(n) = (1.+ ars1*x(n))/(1.+ ars2*x(n)+ ars3*x(n)*x(n)) -endfor - -oplot,x(0:ntot-1),y,color = 0, linestyle = 1 -oplot,catdef,ar1,color = 220 -oplot,x,y2,color = 0, linestyle = 1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG,'img.0000001.jpg', image24, True=1, Quality=100 - -end - -;======================================================================== -; Process JPL Canopy Height -;======================================================================== - -PRO canop_Height, nc, nr, tileid_plot, gfile, path - -CanopH=read_tiff('/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.tif') -im=n_elements(CanopH(*,0)) -jm=n_elements(CanopH(0,*)) -CanopH = reverse(CanopH,2,/overwrite) - -yh= dblarr(jm) -for i = 0l,jm -1l do yh(i) = i*1./120 -90. + 1./240. -xh = dblarr(im) -for i = 0l,im -1l do xh(i) = i*1./120 -180. + 1./240. - -N_tiles = 0l - -openr,1,'../catchment.def' -readf,1,N_tiles -close,1 - -canop_tiles = fltarr (N_tiles) -count_pix = fltarr (N_tiles) - -canop_tiles (*) = 0.01 -count_pix (*) = 0. - -dx = IM/NC -dy = JM/NR - -catrow = lonarr (nc) -tile_id = lonarr (NC, nr) -rst_file= path + '/rst/' + gfile+'*.rst' - -openr,1,rst_file,/F77_UNFORMATTED - -for j = 0l, NR -1l do begin - readu,1,catrow - tile_id(*,j) = catrow(*) - for i=0l, nc-1l do begin - subset = CanopH (i*dx: (i+1)*dx -1,j*dy: (j+1)*dy -1) - if ((catrow(i) ge 1) and (catrow(i) le N_tiles)) then begin - canop_tiles (catrow(i) -1) = canop_tiles (catrow(i) -1) + mean (subset) - count_pix (catrow(i) -1) = count_pix (catrow(i) -1) + 1. - endif - endfor -endfor - -close,1 - -canop_tiles (where (count_pix gt 0.)) = canop_tiles/count_pix -canop_tiles (where (canop_tiles lt 0.01)) = 0.01 - -openw,1,'Simard_Pinto_3DGlobalVeg_JGR.dat' - -for k = 0l,n_tiles -1l do begin - printf,1,format='(f7.3)',canop_tiles(k) -endfor - -close,1 - -;openw,1,'../Simard_Pinto_3DGlobalVeg_JGR.bin',/F77_UNFORMATTED -;writeu,1,canop_tiles -;close,1 - -lwval = min(0.) - -ip = n_elements(tileid_plot[*,0]) -jp = n_elements(tileid_plot[0,*]) - -dx = 360. / ip -dy = 180. / jp - -x = indgen(ip)*dx -180. + dx/2. -y = indgen(jp)*dy -90. + dy/2. - -data_grid = fltarr (ip,jp) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jp -1l do begin - for i = 0l, ip -1 do begin - if((tileid_plot[i,j] gt 0) and (tileid_plot[i,j] le N_tiles)) then data_grid(i,j) = canop_tiles(tileid_plot[i,j] -1) - endfor -endfor - -upval = max(canop_tiles) - -limits = [-60,-180,90,180] - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -colors = reverse (colors) -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[800,400], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 0] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER -contour, data_grid, x, y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - - endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 800,400) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'Canopy_Height_onTiles.jpg', image24, True=1, Quality=100 - -spawn, "paste ../mosaic_veg_typs_fracs Simard_Pinto_3DGlobalVeg_JGR.dat > new_mos" -spawn, "/bin/mv new_mos ../mosaic_veg_typs_fracs" -spawn, "/bin/rm Simard_Pinto_3DGlobalVeg_JGR.dat" - -tmp_data = read_ascii ("../mosaic_veg_typs_fracs") -openw,1,'../vegdyn.data',/F77_UNFORMATTED -writeu,1,tmp_data.field1(2,*) -writeu,1,tmp_data.field1(6,*) -close,1 - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_three_vars2, ncat, tile_id, data1, data2, data3 - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. -;stop -data_grid1 = fltarr (im,jm) -data_grid1 (*,*) = !VALUES.F_NAN -data_grid2 = fltarr (im,jm) -data_grid2 (*,*) = !VALUES.F_NAN -data_grid3 = fltarr (im,jm) -data_grid3 (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid1(i,j) = data1(tile_id[i,j] -1) - if(tile_id[i,j] gt 0) then data_grid2(i,j) = data2(tile_id[i,j] -1) - if(tile_id[i,j] gt 0) then data_grid3(i,j) = data3(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,900], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 3, 0, 1] - -for n = 0,2 do begin - -if (n eq 0) then begin - upval = 350. - lwval = 0. - data = data_grid1 -endif - -if (n eq 1) then begin - upval = 300. - lwval = 250. - data = data_grid2 -endif - -if (n eq 2) then begin - upval = 300. - lwval = 250. - data = data_grid3 -endif - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] -if(n eq 0) then levels = [indgen(15)*4.,65.,350.] -if(n eq 0) then MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/NOBORDER -if(n gt 0) then MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/NOBORDER -contour, data,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.1)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.1)'),color =0, orientation =90,charsize =0.8 - endfor - -endfor - -;stop -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 900) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'CLM_Ndep_T2m.jpg', image24, True=1, Quality=100 - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_soilalb, ncat, tile_id,VISDR, VISDF, NIRDR, NIRDF - - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = 0. -upval = 0.65 - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'VISDR' - if (map eq 2) then ctitle = 'VISDF' - if (map eq 3) then ctitle = 'NIRDR' - if (map eq 4) then ctitle = 'NIRDF' - - if (map ge 3) then upval = 1. - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - if((map eq 1) or (map eq 3)) then begin - if(map eq 1) then !P.position=[0.25, 0.55, 0.75, 0.575] - if(map eq 3) then !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f4.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'SoilAlb.jpg', image24, True=1, Quality=100 - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro create_vec_file - -dx = 1.d0/12. -dy = 1.d0/12. -DATELINE = 1 -global_bcs = 0 -WORKDIR = '' - -nc = long(360./dx) -nr = long(180./dy) - -openw,1,workdir + 'clsm/NLDAS-5arcmin_vec.data' - -if(NOT (boolean (global_bcs))) then begin - xylim = [35., -180., 80., -55.] - x = indgen (nc)*dx -180. + dx/2. - y = indgen (nr)*dy -90. + dy/2. - i1 = value_locate (x, xylim(1)) + 1 - i2 = value_locate (x, xylim(3)) - j1 = value_locate (y, xylim(0)) + 1 - j2 = value_locate (y, xylim(2)) - i_offset = i1 - j_offset = j1 - nc_domain = i2 - i1 + 1 - nr_domain = j2 - j1 + 1 - printf,1,format ='(2f8.4, i3, 4i5)', dx,dy, dateline, nc_domain,nr_domain,i_offset,j_offset -endif else begin - printf,1,dx,dy, dateline -endelse - -SRTM_maxcat = 291284 - -nc_esa = 129600l -nr_esa = 64800l - -nx = nc_esa/nc -ny = nr_esa/nr - -ncid = NCDF_OPEN('/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/shared/mask/GEOS5_10arcsec_mask.nc') -;NCDF_VARGET, ncid,0, y -;NCDF_VARGET, ncid,1, x - -n = 1l - -subset = lonarr (nc_esa,ny) -for j = 0l,nr -1l do begin - NCDF_VARGET, ncid,'CatchIndex', offset = [0,j*ny], count = [nc_esa,ny], SubSet - for i = 0l,nc -1l do begin -; NCDF_VARGET, ncid,'CatchIndex', offset = [i*nx,j*ny], count = [nx,ny], CatchIndex - CatchIndex = SubSet(i*nx:(i+1)*nx -1,*) - if(max(CatchIndex) gt SRTM_maxcat) then CatchIndex (where (CatchIndex gt SRTM_maxcat)) = 0 - if (max (CatchIndex) ge 1) then begin - if(boolean (global_bcs)) then begin - printf,1,format ='(i7,2(1x,f10.5),2(1x,I5))',n,j*dy -90. + dy/2.,i*dx -180. + dx/2.,I+1,J+1 - n = n + 1 - endif else begin - if(IS_IN_DOMAIN(xylim, i*dx -180. + dx/2.,j*dy -90. + dy/2.)) then begin - printf,1,format ='(i7,2(1x,f10.5),2(1x,I5))',n,j*dy -90. + dy/2.,i*dx -180. + dx/2.,I+1 - i_offset,J+1 - j_offset - n = n + 1 - endif - endelse - endif - endfor -endfor -close,1 -ncdf_close,ncid - - -end -;_________________________________________________________________ -;_________________________________________________________________ - - -PRO plot_three_vars1, ncat, tile_id, data1, data2, data3 - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. -;stop -data_grid1 = fltarr (im,jm) -data_grid1 (*,*) = !VALUES.F_NAN -data_grid2 = fltarr (im,jm) -data_grid2 (*,*) = !VALUES.F_NAN -data_grid3 = fltarr (im,jm) -data_grid3 (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid1(i,j) = data1(tile_id[i,j] -1) - if(tile_id[i,j] gt 0) then data_grid2(i,j) = data2(tile_id[i,j] -1) - if(tile_id[i,j] gt 0) then data_grid3(i,j) = data3(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,900], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 3, 0, 1] - -for n = 0,2 do begin - -if (n eq 0) then begin - upval = 14. - lwval = 6. - data = data_grid1 -endif - -if (n eq 1) then begin - upval = 4. - lwval = 0. - data = data_grid2 -endif - -if (n eq 2) then begin - upval = 2.5 - lwval = -2.5 - data = data_grid3 -endif - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] -if(n eq 0) then MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/NOBORDER -if(n gt 0) then MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/NOBORDER -contour, data,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - if (n eq 0) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - if (n eq 1) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - if (n eq 2) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f6.2)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - if (n eq 0) then xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - if (n eq 1) then xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - if (n eq 2) then xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f6.2)'),color =0, orientation =90,charsize =0.8 - endfor - -endfor - -;stop -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 900) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'cti.jpg', image24, True=1, Quality=100 - -END -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_lai, ncat, tile_id - -lwval = 0. -upval = 7. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -r_in = [253,224,255,238,205,193,152, 0,124, 0, 0, 0, 0, 0, 0, 48,110, 85] -g_in = [253,238,255,238,205,255,251,255,252,255,238,205,139,128,100,128,139,107] -b_in = [253,224, 0, 0, 0,193,152,127, 0, 0, 0, 0, 0, 0, 0, 20, 61, 47] - -n_levels = n_elements (r_in) -levels=[0.,0.25,0.5,0.75,1.,1.25,1.5,10. * indgen(11)*0.05+2.] -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, N_levels -1 do begin - red (k+1) = r_in (k) - green(k+1) = g_in (k) - blue (k+1) = b_in (k) -endfor - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[1080,600], Z_Buffer=0 - -TVLCT,red,green,blue - -colors = indgen (N_levels) + 1 - - -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 3, 4, 0, 0] - -file = '../lai.dat' - -yr = 0. -mn = 0. -dy = 0. -dum = 0. -yr1 = 0. -mn1 = 0. -dy1 = 0. -yrg = 0. -mng = 0. -lai = fltarr (ncat) -lai1 = fltarr (ncat) -lai2 = fltarr (ncat) -mdays = [31,28,31,30,31,30,31,31,30,31,30,31] -mname = ['JAN','FEB','MAR','APR','MAY','JUN','JUL','AUG','SEP','OCT','NOV','DEC'] - -openr,1,file,/F77_UNFORMATTED -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - -readu,1,lai1 -dofyr_b4 = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - -dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) -readu,1,lai2 - -for month = 1,12 do begin - lai_month = fltarr (ncat) - for day =1,mdays[month -1] do begin - dofyr_now = float(julday(month,day,2001+yr)-julday(12,31,2000)) - fac1 = (dofyr_now - dofyr_b4 )/(dofyr_nxt - dofyr_b4) - fac2 = (dofyr_nxt - dofyr_now)/(dofyr_nxt - dofyr_b4) - - lai = fac1*lai2 + fac2*lai1 - lai_month(*) = lai_month(*) + lai (*)/mdays[month -1] - - if(dofyr_now + 0.5 ge dofyr_nxt) then begin - lai1 = lai2 - dofyr_b4 = dofyr_nxt - readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - - dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - if((month eq 12) and (yr eq 2)) then yr = yr -1 - readu,1,lai2 - endif - endfor - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = lai_month(tile_id[i,j] -1) - endfor - endfor - if(month gt 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/NOBORDER,title=mname(month-1) - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/NOBORDER,title=mname(month-1) - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 -endfor - -close,1 - -!P.position=[0.15, 0.005, 0.85, 0.025] - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format='(f4.2)') ,orientation=90,color=0,charsize =0.8 -!P.position=0 -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 1080, 600) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'lai.jpg', image24, True=1, Quality=100 - -!P.Multi = 0 -!P.position=0 - -end - -;_____________________________________________________________________ - -pro load_random_colors - -R = shuffle(indgen(256)) -G = shuffle(indgen(256)) -B = shuffle(indgen(256)) - -R (255) = 255 -G (255) = 255 -B (255) = 255 -R (0) = 0 -G (0) = 0 -B (0) = 0 - -TVLCT,R ,G ,B - -end - - - -;_____________________________________________________________________ - -pro load_colors - -R = intarr (256) -G = intarr (256) -B = intarr (256) - -R (*) = 255 -G (*) = 255 -B (*) = 255 - -r_drought = [0, 0, 0, 0, 47, 200, 255, 255, 255, 255, 249, 197] -g_drought = [0, 115, 159, 210, 255, 255, 255, 255, 219, 157, 0, 0] -b_drought = [0, 0, 0, 0, 67, 130, 255, 0, 0, 0, 0, 0] - -colors = indgen (11) + 1 -R (0:11) = r_drought -G (0:11) = g_drought -B (0:11) = b_drought - -r_green = [200, 150, 47, 60, 0, 0, 0, 0] -g_green = [255, 255, 255, 230, 219, 187, 159, 131] -b_green = [200, 150, 67, 15, 0, 0, 0, 0] - -r_blue = [ 55, 0, 0, 0, 0, 0, 0, 0, 0, 0] -g_blue = [255, 255, 227, 195, 167, 115, 83, 0, 0, 0] -b_blue = [199, 255, 255, 255, 255, 255, 255, 255, 200, 130] - -r_red = [255, 240, 255, 255, 255, 255, 255, 233, 197] -g_red = [255, 255, 219, 187, 159, 131, 51, 23, 0] -b_red = [153, 15, 0, 0, 0, 0, 0, 0, 0] - -r_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -g_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -b_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] - -r_type = [255,106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_type = [245, 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_type = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] - -r_lct2 = [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 55, 120, 190, 240, 255, 255, 255, 255, 255, 233, 197, 158] -g_lct2 = [ 0, 0, 0, 83, 115, 167, 195, 227, 255, 255, 255, 255, 255, 219, 187, 159, 131, 51, 23, 0, 0] -b_lct2 = [130, 200, 255, 255, 255, 255, 255, 255, 255, 199, 135, 67, 15, 0, 0, 0, 0 , 0, 0, 0, 0] - -r_veg = [233,255,255,255,210, 0, 0, 0,204,170,255,220,205, 0, 0,170, 0, 40,120,140,190,150,255,255, 0, 0, 0,195,255, 0] -g_veg = [ 23,131,191,255,255,255,155, 0,204,240,255,240,205,100,160,200, 60,100,130,160,150,100,180,235,120,150,220, 20,245, 70] -b_veg = [ 0, 0, 0,178,255,255,255,200,204,240,100,100,102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50,175, 90,120,130, 0,215,200] - -r_grads_rb = [160, 110, 30, 0, 0, 0, 0, 160, 230, 230, 240, 250, 240] -g_grads_rb = [ 0, 0, 60, 150, 200, 210, 220, 230, 220, 175, 130, 60, 0] -b_grads_rb = [200, 220, 255, 255, 200, 140, 0, 50, 50, 45, 40, 60, 130] - -R (20:27) = r_green -G (20:27) = g_green -B (20:27) = b_green - -R (30:39) = r_blue -G (30:39) = g_blue -B (30:39) = b_blue - -R (40:48) = r_red -G (40:48) = g_red -B (40:48) = b_red - -R (50:58) = r_grey -G (50:58) = g_grey -B (50:58) = b_grey - -R (60:80) = r_type -G (60:80) = g_type -B (60:80) = b_type - -R (90:119) = r_veg -G (90:119) = g_veg -B (90:119) = b_veg - -R (120:132) = r_grads_rb -G (120:132) = g_grads_rb -B (120:132) = b_grads_rb - -R (140:160) = r_lct2 -G (140:160) = g_lct2 -B (140:160) = b_lct2 -TVLCT,R ,G ,B - -end - -; ----------------------------------------------------------------------- - -pro jpl_tif2nc4 - -CanopH=read_tiff('/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.tif') -im=n_elements(CanopH(*,0)) -jm=n_elements(CanopH(0,*)) -CanopH = reverse(CanopH,2,/overwrite) - -yh= dblarr(jm) -for i = 0l,jm -1l do yh(i) = i*1./120 -90. + 1./240. -xh = dblarr(im) -for i = 0l,im -1l do xh(i) = i*1./120 -180. + 1./240. - -id = NCDF_CREATE('/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4', /clobber, /NETCDF4_FORMAT) -xid = NCDF_DIMDEF(id, 'N_lon' , im) ;Define x-dimension -yid = NCDF_DIMDEF(id, 'N_lat' , jm) ;Define y-dimension -NCDF_ATTPUT,id, 'CreatedBy', 'NASA GSFC GMAO Land Group',/global -NCDF_ATTPUT,id, 'Contact', 'NASA GSFC GMAO Land Group',/global - -str_date=systime() -NCDF_ATTPUT,id, 'Date', str_date,/global -vid = NCDF_VARDEF(id,'longitude' , [xid], /DOUBLE) -vid = NCDF_VARDEF(id,'latitude' , [yid], /DOUBLE) -vid = NCDF_VARDEF(id,'CanopyHeight',[xid,yid], /SHORT) - -NCDF_CONTROL, id, /ENDEF - -NCDF_VARPUT, id,'longitude',xh -NCDF_VARPUT, id,'latitude', yh - -for j = 0, jm -1 do begin - NCDF_VARPUT, id,'CanopyHeight',offset=[0,j],count=[im,1],CanopH(*,j) -endfor - -NCDF_CLOSE, id - -end - -; ----------------------------------------------------------------------- - -pro plot_canoph, z2, tileid_plot -N_tiles = 0l - -openr,1,'../catchment.def' -readf,1,N_tiles -close,1 -ip = n_elements(tileid_plot[*,0]) -jp = n_elements(tileid_plot[0,*]) - -dx = 360. / ip -dy = 180. / jp - -x = indgen(ip)*dx -180. + dx/2. -y = indgen(jp)*dy -90. + dy/2. - -data_grid = fltarr (ip,jp) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jp -1l do begin - for i = 0l, ip -1 do begin - if((tileid_plot[i,j] gt 0) and (tileid_plot[i,j] le N_tiles)) then data_grid(i,j) = z2(tileid_plot[i,j] -1) - endfor -endfor - -upval = max(z2) -lwval = min(z2) - -limits = [-60,-180,90,180] - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -colors = reverse (colors) -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[800,400], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 0] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER -contour, data_grid, x, y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(f5.2)'),color =0, orientation =90,charsize =0.8 - - endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 800,400) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'Canopy_Height_onTiles.jpg', image24, True=1, Quality=100 - -end - -; ==================================================================================== -pro country_codes, tile_id - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. -cnt_grid = intarr (im,jm) -cnt_grid (*,*) = !VALUES.F_NAN - -N_tiles = 0l -openr,1,'../catchment.def' -readf,1,N_tiles -close,1 -cnt_code = intarr (N_tiles) -st_code = intarr (N_tiles) - -openr,1,"../country_and_state_code.data" -k = 0l -i1 = 0 -i2 = 0 - -for n = 0l, N_Tiles -1l do begin -readf,1,k,i1,i2 -cnt_code (n) = i1 -st_code (n) = i2 -endfor -close,1 -us_ind = where (cnt_code eq 243) -cnt_code (us_ind) = st_code (us_ind) -cnt_code (where (cnt_code eq 257)) = !VALUES.F_NAN -tmp_data = 0 - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - cnt_grid(i,j) = cnt_code(tile_id[i,j] -1) + 1 - endif - endfor -endfor - -colors = indgen(256) -levels = colors -limits = [-60,-180,90,180] -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[800,400], Z_Buffer=0 -load_random_colors -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 0] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if((cnt_grid[i,j] gt 0) and (cnt_grid[i,j] le 255)) then begin - yu = -90. + j*dy + dy - yl = -90. + j*dy - xl= -180. + i*dx - xr= -180. + i*dx +dx - xx=fltarr(5) - yy=fltarr(5) - xx=[xl,xl,xr,xr,xl] - yy=[yu,yl,yl,yu,yu] - oplot,[xl,xr],[yl,yl],color =cnt_grid[i,j] - endif - endfor -endfor - -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 800,400) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'Country_codes.jpg', image24, True=1, Quality=100 -end -; ==================================================================================== - -pro compute_zo, pname, SCALE4Z0, ASZ0, Z2CH, tile_id - -ncat = n_elements (Z2CH) - -; Reading LAI and computing Z0 -; ---------------------------- - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -mdays = [31,28,31,30,31,30,31,31,30,31,30,31] - -zo_vec = fltarr (ncat, 4) -ndvi_vec = fltarr (ncat, 4) -ZOT = fltarr (NCAT) - -if (pname eq 'ascat') then goto, skip_lai - -lai_file = '../lai.dat' -ndvi_file = '../ndvi.dat' - -yr = 0. -mn = 0. -dy = 0. -dum = 0. -yr1 = 0. -mn1 = 0. -dy1 = 0. -yrg = 0. -mng = 0. -lai = fltarr (ncat) -lai1 = fltarr (ncat) -lai2 = fltarr (ncat) -ndvi = fltarr (ncat) -ndvi1 = fltarr (ncat) -ndvi2 = fltarr (ncat) - -openr,1,lai_file,/F77_UNFORMATTED -openr,2,ndvi_file,/F77_UNFORMATTED - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -readu,1,lai1 -dofyr_b4 = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) -readu,1,lai2 - -readu,2,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -readu,2,ndvi1 -ndvi_b4 = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - -readu,2,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -ndvi_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) -readu,2,ndvi2 - - -for month = 1,12 do begin - lai_month = fltarr (ncat) - for day =1,mdays[month -1] do begin - dofyr_now = float(julday(month,day,2001+yr)-julday(12,31,2000)) - fac1 = (dofyr_now - dofyr_b4 )/(dofyr_nxt - dofyr_b4) - fac2 = (dofyr_nxt - dofyr_now)/(dofyr_nxt - dofyr_b4) - lai = fac1*lai2 + fac2*lai1 - - fac1 = (dofyr_now - ndvi_b4 )/(ndvi_nxt - ndvi_b4) - fac2 = (ndvi_nxt - dofyr_now)/(ndvi_nxt - ndvi_b4) - ndvi = fac1*ndvi2 + fac2*ndvi1 - -; ========================================================================================== -; Here is the roughness length parameterization -; ========================================================================================== - - for n = 0l,ncat -1l do ZOT(n) = Z0_VALUE(Z2CH(n), lai(n), SCALE4Z0) - - if((month eq 1) or (month eq 2) or (month eq 12)) then zo_vec (*,0) = zo_vec (*,0) + zot (*)/total (mdays ([11, 0, 1])) - if((month eq 3) or (month eq 4) or (month eq 5)) then zo_vec (*,1) = zo_vec (*,1) + zot (*)/total (mdays ([ 2, 3, 4])) - if((month eq 6) or (month eq 7) or (month eq 8)) then zo_vec (*,2) = zo_vec (*,2) + zot (*)/total (mdays ([ 5, 6, 7])) - if((month eq 9) or (month eq 10) or (month eq 11)) then zo_vec (*,3) = zo_vec (*,3) + zot (*)/total (mdays ([ 8, 9,10])) - - if((month eq 1) or (month eq 2) or (month eq 12)) then ndvi_vec (*,0) = ndvi_vec (*,0) + ndvi (*)/total (mdays ([11, 0, 1])) - if((month eq 3) or (month eq 4) or (month eq 5)) then ndvi_vec (*,1) = ndvi_vec (*,1) + ndvi (*)/total (mdays ([ 2, 3, 4])) - if((month eq 6) or (month eq 7) or (month eq 8)) then ndvi_vec (*,2) = ndvi_vec (*,2) + ndvi (*)/total (mdays ([ 5, 6, 7])) - if((month eq 9) or (month eq 10) or (month eq 11)) then ndvi_vec (*,3) = ndvi_vec (*,3) + ndvi (*)/total (mdays ([ 8, 9,10])) - - if(dofyr_now + 0.5 ge dofyr_nxt) then begin - lai1 = lai2 - dofyr_b4 = dofyr_nxt - readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - dofyr_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - if((month eq 12) and (yr eq 2)) then yr = yr -1 - readu,1,lai2 - endif - - if(dofyr_now + 0.5 ge ndvi_nxt) then begin - ndvi1 = ndvi2 - ndvi_b4 = ndvi_nxt - readu,2,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - ndvi_nxt = ((float(julday(mn1,dy1,2001+yr1)-julday(12,31,2000))) - (float(julday(mn,dy,2001+yr)-julday(12,31,2000))))/2 + $ - float(julday(mn,dy,2001+yr)-julday(12,31,2000)) - if((month eq 12) and (yr eq 2)) then yr = yr -1 - readu,2,ndvi2 - endif - - endfor -endfor - -close,1 -close,2 - -skip_lai: - -; now plotting -;------------- - -sea_label = ['DJF','MAM','JJA','SON'] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,600], Z_Buffer=0 -;Device, Set_Resolution=[720,500], Z_Buffer=0 -load_colors -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 2, 0, 0] -;!P.Multi = [0, 1, 1, 0, 0] -;!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -colors = [74,77,35,34,33,32,25,24,23,22,21,20,41,42,43,44,45,46,47,48] -levels = [0.02,0.05,0.07,0.1,0.3,0.5,1,2,4,6,8,10,50,100,500,1000,2000,3000,4000,5000] -n_levels = n_elements (levels) - -for season = 0,3,2 do begin - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - if (pname eq 'ascat') then data_grid(i,j) = asz0(tile_id[i,j] -1) - if (pname eq 'icarus') then data_grid(i,j) = 1000.*zo_vec(tile_id[i,j] -1, season) - if (pname eq 'merged') then begin - data_grid(i,j) = 1000.*zo_vec(tile_id[i,j] -1, season) - if(ndvi_vec(tile_id[i,j]-1, season) le 0.2) then data_grid(i,j) = asz0(tile_id[i,j] -1) - endif - endif - endfor - endfor - - if(season ge 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/NOBORDER,title=pname +' : '+ sea_label (season) - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/NOBORDER,title=pname +' : '+ sea_label (season) - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - dx = (240.)/(n_levels-1) - - clev = levels - clev (*) = 1 - - k = 0 - for l = 0,n_levels -2 do begin - k = l - xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] - ybox = [-65., -55.,-55.,-65.,-65.] - polyfill, xbox,ybox,color=colors [k] - if (l le 5) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(f4.2)'),color =0, orientation =90,charsize =0.8 - if (l gt 5) then xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format='(i4)'),color =0, orientation =90,charsize =0.8 - k = k + 1 - endfor - - for l = n_levels -1,n_levels -1 do begin - xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format='(i4)'),color =0, orientation =90,charsize =0.8 - endfor - -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 600) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, pname + '_Z0.jpg', image24, True=1, Quality=100 - -end - -; ------------------------------------ - -;; This program is being deprecated, we don't have IDATA valid path -;pro proc_glass -; -; -;;IDATA = '/gpfsm/dnb43/projects/p03/RS_DATA/GLASS/LAI/AVHRR/V4/HDF/' -;;ODATA = '/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/lai_grn/v4/GLASS-LAI/AVHRR.v4/' -;;LABEL = 'GLASS01B02.V04.A' -;;yearb = 1981 -;;YEARe = 2017 -; -;IDATA = '/gpfsm/dnb43/projects/p03/RS_DATA/GLASS/LAI/MODIS/V4/HDF/' -;ODATA = '/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/lai_grn/v4/GLASS-LAI/MODIS.v4/' -;LABEL = 'GLASS01B01.V04.A' -;yearb = 2000 -;YEARe = 2017 -; -;nc = 7200 -;nr = 3600 -;nyrs = YEARe - yearb + 1 -; -;lwval = 0. -;upval = 7. -; -;im = nc -;jm = nr -; -;dx = 360. / im -;dy = 180. / jm -; -;x = indgen(im)*dx -180. + dx/2. -;y = indgen(jm)*dy -90. + dy/2. -;r_in = [253,224,255,238,205,193,152, 0,124, 0, 0, 0, 0, 0, 0, 48,110, 85] -;g_in = [253,238,255,238,205,255,251,255,252,255,238,205,139,128,100,128,139,107] -;b_in = [253,224, 0, 0, 0,193,152,127, 0, 0, 0, 0, 0, 0, 0, 20, 61, 47] -; -;n_levels = n_elements (r_in) -;levels=[0.,0.25,0.5,0.75,1.,1.25,1.5,10. * indgen(11)*0.05+2.] -;red = intarr (256) -;green= intarr (256) -;blue = intarr (256) -; -;red (255) = 255 -;green(255) = 255 -;blue (255) = 255 -; -;for k = 0, N_levels -1 do begin -; red (k+1) = r_in (k) -; green(k+1) = g_in (k) -; blue (k+1) = b_in (k) -;endfor -;thisDevice = !D.Name -;set_plot,'Z' -;Device, Set_Resolution=[800,500], Z_Buffer=0 -;TVLCT,red,green,blue -;colors = indgen (N_levels) + 1 -; -;limits = [-60,-180,90,180] -; -;Erase,255 -;!p.background = 255 -; -;;file1 = '/gpfsm/dnb43/projects/p03/RS_DATA/GLASS/LAI/MODIS/V4/HDF/2008/GLASS01B01.V04.A2008185.hdf' -;file1 = '/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/lai_grn/v4/GLASS-LAI/MODIS.v4/GLASS01B01.V04.AYYYY105.nc4' -;ncid = ncdf_open (file1) -;NCDF_VARGET, ncid,'LAI', adum -;ncdf_close,ncid -; -;;FileID=HDF_SD_Start(file1, /read) -;;sds_id = hdf_sd_select(FileID, 0) -;;hdf_sd_getdata, sds_id,adum -;;HDF_SD_END, FileID -;adum (where (adum eq 2550)) = !VALUES.F_NAN -;adum = adum /100. -; -; -;MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -;MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2,/USA -;;contour, adum,x,y,levels = levels,c_colors=colors,/cell_fill -; -;snapshot = TVRD() -;TVLCT, r, g, b, /Get -;Device, Z_Buffer=1 -;Set_Plot, thisDevice -;image24 = BytArr(3, 800, 500) -;image24[0,*,*] = r[snapshot] -;image24[1,*,*] = g[snapshot] -;image24[2,*,*] = b[snapshot] -;Write_JPEG, 'global_map.jpg', image24, True=1, Quality=100 -;stop -; -;for DOY = 1,361,8 do begin -; LAI = intarr (nc,nr,nyrs) -; LAI (*,*,*) = 2550 -; DDD = string (DOY,'(i3.3)') -; for year = yearB, yearE do begin -; YYYY = string (year, '(i4.4)') -; filename = IDATA + YYYY + '/' + LABEL + yyyy + DDD + '.hdf' -; FileID=HDF_SD_Start(filename, /read) -; sds_id = hdf_sd_select(FileID, 0) -; hdf_sd_getdata, sds_id,adum -; adum = adum *10 -; HDF_SD_END, FileID -; print, year,min(adum), max(adum) -; LAI (*,*,year - yearB) = adum -; -; endfor -; -;indata = intarr (nc,nr) -;indata (*,*) = 2550 -; -;for j = 0, nr -1 do begin -; for i = 0, nc -1 do begin -; if(min (LAI (i,j,*)) lt 2550) then begin -; syears = where (LAI (i,j,*) lt 2550) -; indata (i,j) = mean (LAI (i,j,syears)) -; ; if(mean (LAI (i,j,syears)) gt 500.) then stop -; ; print, n_elements (syears), mean (LAI (i,j,syears)) -; endif -; endfor -;endfor -; -;print, min (indata), max(indata) -; -;ofile = ODATA + LABEL + 'YYYY' + DDD + '.nc4' -;write_glass_output, indata, ofile -; -;endfor -; -;end -; -;; ---------------------------------------------------------------- -; -; -;; This program is being deprecated, since it needs "pro proc_glass" - -;pro write_glass_output,indata,ofile -; -;nc = 7200 -;nr = 3600 -; -;id = NCDF_CREATE(ofile, /clobber) ;Create netCDF output file -;xid = NCDF_DIMDEF(id, 'N_lon', nc) ;Define x-dimension -;yid = NCDF_DIMDEF(id, 'N_lat', nr) ;Define y-dimension -;NCDF_ATTPUT,id, 'CellSize_arcmin' , 3,/global -;NCDF_ATTPUT,id, 'CreatedBy', 'Sarith Mahanama GSFC/NASA',/global -;NCDF_ATTPUT,id, 'Contact', 'Anyone from GMAO Land Group',/global -;str_date=systime() -;NCDF_ATTPUT,id, 'Date', str_date,/global -;vid = NCDF_VARDEF(id, 'lat', yid, /DOUBLE) ;Define latitude variable -;vid = NCDF_VARDEF(id, 'lon', xid, /DOUBLE) ;Define longitude variable -;vid = NCDF_VARDEF(id, 'LAI', [xid, yid], /SHORT) -;NCDF_ATTPUT, id, vid, 'LongName','Leaf Area Index 8-Day 0.05-degrees GEO Grid climatology' -;NCDF_ATTPUT, id, vid, 'units', 'm^2/m^2' -;NCDF_ATTPUT, id, vid, 'scale_factor',0.01 -;NCDF_ATTPUT, id, vid, 'valid_range','0 1000' -;NCDF_ATTPUT, id, vid, '_FillValue', 2550 -; -;NCDF_CONTROL, id, /ENDEF -; -;dxy = 360.d/7200.d -; -;x = indgen (nc)*dxy -180. + dxy/2.d -;y = indgen (nr)*dxy -90. + dxy/2.d -; -;NCDF_VARPUT, id,'lat', y -;NCDF_VARPUT, id,'lon', x -;for j =0, nr -1 do begin -;NCDF_VARPUT, id, 'LAI',offset=[0,nr-1 -j],count=[nc,1] , nint(indata [*,j]) -;endfor -;NCDF_CLOSE, id -; -;end - -; ------------------------------------------------------------------- - pro irrig_method, ncat, tile_id - -; Rerad 0.25-degree GRIPC and MIRCA data - -filename = '../irrig.dat' -limits = [-60.,-180.,90.,-180.] -if file_test ('limits.idl') then restore,'limits.idl' - -id = NCDF_OPEN (filename, /NOWRITE) - -NCDF_VARGET, id,'SPRINKLERFR',SPRINKLERV -NCDF_VARGET, id,'DRIPFR',DRIPV -NCDF_VARGET, id,'FLOODFR',FLOODV - -NCDF_CLOSE, id - -SPRINKLERV(where (SPRINKLERV gt 1.)) = !VALUES.F_NAN -DRIPV (where (DRIPV gt 1.)) = !VALUES.F_NAN -FLOODV (where (FLOODV gt 1.)) = !VALUES.F_NAN - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -SPRINKLER = REPLICATE (!VALUES.F_NAN,IM, JM) -DRIP = REPLICATE (!VALUES.F_NAN,IM, JM) -FLOOD = REPLICATE (!VALUES.F_NAN,IM, JM) - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - SPRINKLER(i,j) = SPRINKLERV (tile_id[i,j] -1) - DRIP (i,j) = DRIPV (tile_id[i,j] -1) - FLOOD (i,j) = FLOODV (tile_id[i,j] -1) - endif - endfor -endfor - -SPRINKLER(where (SPRINKLER eq 0.)) = !VALUES.F_NAN -DRIP (where (DRIP eq 0.)) = !VALUES.F_NAN -FLOOD (where (FLOOD eq 0.)) = !VALUES.F_NAN - -colors = indgen (21) + 140 -levels = indgen (21)*0.1/2. - -position_row1 = [0.02, 0.70, 0.98, 0.95] -position_row2 = [0.02, 0.40, 0.98, 0.65] -position_row3 = [0.02, 0.10, 0.98, 0.35] - -position_col = [0.20, 0.02, 0.80, 0.05] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT -load_colors -;set_plot,'PS' -!P.font=0 -;Device, FILENAME= plotdir + 'IrrigMethod.ps',/color,/PORTRAIT,xsi=0.9*8.2, ysi=0.9*11.7, xoff=.7, yoff=.5, _extra=_extra,/INCHES -Erase,255 -!p.background = 255 -!P.position=0 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = .9, title = 'SPRINKLER FRACTION', /noborder,/isotropic, position = position_row1 -contour,sprinkler,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = .9, title = 'DRIP FRACTION', /noborder,/isotropic, position = position_row2 -contour,drip,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = .9, title = 'FLOOD FRACTION', /noborder,/isotropic, position = position_row3 -contour,flood,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -colorbar,n_levels = 21, levels = levels, colors = colors, labels = levels, position = position_col -;DEVICE, /CLOSE -;Set_Plot, thisDevice -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 850, 1100) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_PNG, 'IrrigMethod.png' , image24 - -end -; --------------------------------------------------------------------------------------------- - - pro plot_lai_minmax, ncat, tile_id - -; Rerad 0.25-degree GRIPC and MIRCA data - -filename = '../irrig.dat' -limits = [-60.,-180.,90.,-180.] -if file_test ('limits.idl') then restore,'limits.idl' - -id = NCDF_OPEN (filename, /NOWRITE) - -NCDF_VARGET, id,'LAIMIN',LAI_MNV -NCDF_VARGET, id,'LAIMAX',LAI_MXV - -NCDF_CLOSE, id - -LAI_MNV (where (LAI_MNV gt 100.)) = !VALUES.F_NAN -LAI_MXV (where (LAI_MXV gt 100.)) = !VALUES.F_NAN - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -LAI_MN = REPLICATE (!VALUES.F_NAN,IM, JM) -LAI_MX = REPLICATE (!VALUES.F_NAN,IM, JM) -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - LAI_MN(i,j) = LAI_MNV (tile_id[i,j] -1) - LAI_MX(i,j) = LAI_MXV (tile_id[i,j] -1) - endif - endfor -endfor -LAI_MN (where (LAI_MN eq 0.)) = !VALUES.F_NAN -LAI_MX (where (LAI_MX eq 0.)) = !VALUES.F_NAN - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT - -load_colors -r_in = [253,224,255,238,205,193,152, 0,124, 0, 0, 0, 0, 0, 0, 48,110, 85] -g_in = [253,238,255,238,205,255,251,255,252,255,238,205,139,128,100,128,139,107] -b_in = [253,224, 0, 0, 0,193,152,127, 0, 0, 0, 0, 0, 0, 0, 20, 61, 47] - -n_levels = n_elements (r_in) -levels=[0.,0.25,0.5,0.75,1.,1.25,1.5,10. * indgen(11)*0.05+2.] -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, N_levels -1 do begin - red (k+1) = r_in (k) - green(k+1) = g_in (k) - blue (k+1) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = indgen (N_levels) + 1 - -position_row1 = [0.02, 0.50, 0.98, 0.95] -position_row2 = [0.02, 0.10, 0.98, 0.45] - -position_col = [0.20, 0.02, 0.80, 0.05] - - -Erase,255 -!p.background = 255 -!P.position=0 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'LAI Minimum', /noborder,/isotropic, position = position_row1 -contour,LAI_MN,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'LAI Maximum', /noborder,/isotropic, position = position_row2 -contour,LAI_MX,x,y,levels = levels, c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 -!P.position= position_col -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format='(f4.2)') ,orientation=90,color=0,charsize =0.8 - - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 850, 1100) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_PNG, 'LAI_minmax.png' , image24 - -end -; --------------------------------------------------------------------------------------------- - - pro irrig_fractions, ncat, tile_id - -; Rerad 0.25-degree GRIPC and MIRCA data -filename = '../irrig.dat' -limits = [-60.,-180.,90.,-180.] -if file_test ('limits.idl') then restore,'limits.idl' - -id = NCDF_OPEN (filename, /NOWRITE) - -NCDF_VARGET, id,'IRRIGFRAC',IRRIGFRACV -NCDF_VARGET, id,'PADDYFRAC',PADDYFRACV -NCDF_VARGET, id,'RAINFEDFRAC',RAINFEDFRACV - -NCDF_CLOSE, id - -IRRIGFRACV (where (IRRIGFRACV gt 1.)) = !VALUES.F_NAN -PADDYFRACV (where (PADDYFRACV gt 1.)) = !VALUES.F_NAN -RAINFEDFRACV(where (RAINFEDFRACV gt 1.)) = !VALUES.F_NAN - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -IRRIGFRAC = REPLICATE (!VALUES.F_NAN,IM, JM) -PADDYFRAC = REPLICATE (!VALUES.F_NAN,IM, JM) -RAINFEDFRAC = REPLICATE (!VALUES.F_NAN,IM, JM) - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - IRRIGFRAC (i,j) = IRRIGFRACV (tile_id[i,j] -1) - PADDYFRAC (i,j) = PADDYFRACV (tile_id[i,j] -1) - RAINFEDFRAC(i,j) = RAINFEDFRACV (tile_id[i,j] -1) - endif - endfor -endfor - -IRRIGFRAC (where (IRRIGFRAC eq 0.)) = !VALUES.F_NAN -PADDYFRAC (where (PADDYFRAC eq 0.)) = !VALUES.F_NAN -RAINFEDFRAC(where (RAINFEDFRAC eq 0.)) = !VALUES.F_NAN - -colors = indgen (21) + 140 -levels = indgen (21)*0.05/2. - -position_row1 = [0.02, 0.70, 0.98, 0.95] -position_row2 = [0.02, 0.40, 0.98, 0.65] -position_row3 = [0.02, 0.10, 0.98, 0.35] - -position_col = [0.20, 0.02, 0.80, 0.05] - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT -Erase,255 -!p.background = 255 -!P.position=0 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'IRRIGATED CROP FRACTION', /noborder,/isotropic, position = position_row1 -contour,irrigfrac,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'PADDY FRACTION', /noborder,/isotropic, position = position_row2 -contour,paddyfrac,x,y,levels = levels, c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 1.5, title = 'RAINFED FRACTION', /noborder,/isotropic, position = position_row3 -contour,rainfedfrac,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot -MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - -colorbar,n_levels = 21, levels = levels, colors = colors, labels = levels, position = position_col - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 850, 1100) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_PNG, 'GIA-Hybrid_IrrigFracs.png' , image24 - -end - -; ------------------------------------------------------------------------------------------- - -pro plot_crop_times, ncat, tile_id - - -filename = '../irrig.dat' -limits = [-60.,-180.,90.,-180.] -if file_test ('limits.idl') then restore,'limits.idl' - -id = NCDF_OPEN (filename, /NOWRITE) - -NCDF_VARGET, id,'IRRIGPLANT',plantv -NCDF_VARGET, id,'IRRIGHARVEST',harvestv -NCDF_VARGET, id,'CROPIRRIGFRAC',Fracv -NCDF_VARGET, id,'IRRIGTYPE',irrigtypev -NCDF_VARGET, id,'CROPCLASSNAME',cropname -NCDF_CLOSE, id - -cropname = string (cropname) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -xx = indgen(im)*dx -180. + dx/2. -yy = indgen(jm)*dy -90. + dy/2. -x = fltarr (IM,JM) -y = fltarr (IM,JM) -PLANT = REPLICATE (!VALUES.F_NAN,IM, JM, 2, 26) -HARVEST = REPLICATE (!VALUES.F_NAN,IM, JM, 2, 26) -FRAC = REPLICATE (!VALUES.F_NAN,IM, JM, 26) -IRRIGTYPE = REPLICATE (!VALUES.F_NAN,IM, JM, 26) - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - x (i,j) = xx(i) - y (i,j) = yy(j) - if(tile_id[i,j] gt 0) then begin - PLANT (i,j,*,*) = PLANTV (tile_id[i,j] -1,*,*) - HARVEST (i,j,*,*) = HARVESTV (tile_id[i,j] -1,*,*) - FRAC (i,j,*) = FRACV (tile_id[i,j] -1,*) - IRRIGTYPE(i,j,*) = IRRIGTYPEV (tile_id[i,j] -1,*) - endif - endfor -endfor -;for n = 0, 25 do begin -; data1 = frac (*,*,n) -; data2 = plant (*,*,0,n) -; data3 = harvest (*,*,0,n) -; for j = 0, nr - 1 do begin -; for i = 0, nc -1 do begin -; if (mask (i,j) gt 0.5) then begin -; -; if((Plant (I,J,0,n) gt 400) and (frac (i,j,n) gt 0.)) then begin -; print , i,j, n,Plant (I,J,0,0:3), frac (i,j,0:3) -; if((data2 (I,J) gt 400) and (data1 (i,j) gt 0.)) then begin -; print , i,j, n,data2 (I,J), data1 (i,j) -; -; endif -; endif -; endfor -; endfor -;endfor - -;fmask = where (frac gt 0.) -;frac (where (frac eq 0.)) = !VALUES.F_NAN -;plant (where (plant gt 400)) = !VALUES.F_NAN -;harvest (where (harvest gt 400)) = !VALUES.F_NAN -;stop - -colors = indgen (21) + 140 -levels = indgen (21)*0.05/2. -DOY = [ 1, 32, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366, 370] -DOYM = [15, 46, 74, 105, 135, 166, 196, 227, 258, 288, 319, 349, 366, 370] -DOYL = [15, 46, 74, 105, 135, 166, 196, 227, 258, 288, 319, 349, 366, 370] -ITYP = [1,2,3,4] -colors2= [69, 145, 64, 66, 70, 71,73,75,76, 78, 80, 113, 114, 116, 117] -colors3 = [69, 64,80] -row_dims1 = [0.10, 0.32, 0.54, 0.76] -row_dims2 = [0.27, 0.49, 0.71, 0.96] -;col_dmis1 = [0.02, 0.34, 0.66] -;col_dmis2 = [0.34, 0.66, 0.98] -col_dmis1 = [0.02, 0.25, 0.50, 0.75] -col_dmis2 = [0.25, 0.50, 0.75, 0.98] - -;position_col1 = [0.04, 0.02, 0.32, 0.05] -;position_col2 = [0.38, 0.02, 0.92, 0.05] -position_col1 = [0.04, 0.02, 0.32, 0.05] -position_col2 = [0.38, 0.02, 0.68, 0.05] -position_col3 = [0.70, 0.02, 0.92, 0.05] - -page = 1 -Row = 1 -A=findgen(16)*(!PI*2/16.) -usersym,0.1*cos(a),0.1*sin(a),/fill -thisDevice = !D.Name - -set_plot,'Z' -Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT -load_colors -;set_plot,'PS' -;!P.font=0 -;Device, FILENAME= plotdir + 'gia_irrig_params.ps',/color,/PORTRAIT,xsi=0.9*8.2, ysi=0.9*11.7, xoff=.7, yoff=.5, _extra=_extra,/INCHES -Erase,255 -!p.background = 255 -!P.position=0 - -for n = 0, 25 do begin - - if (row eq 1) then begin - thisDevice = !D.Name - set_plot,'Z' - Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT - Erase,255 - !p.background = 255 - !P.position=0 - endif - - data1 = frac (*,*,n) - fmask = where (data1 gt 0.) - this = plant (*,*,0,n) - data2 = this (fmask) - this = harvest (*,*,0,n) - data3 = this (fmask) - this = irrigtype (*,*,n) - data4 = this (fmask) - lons = x (fmask) - lats = y (fmask) - - data1 (where (data1 le 0)) = !VALUES.F_NAN - - for col = 0,3 do begin - print, col - if (col eq 0) then begin - ptitle = ' : frac' - data_grid = data1 - endif - - if (col eq 1) then begin - ptitle = ' : DOY plant' - data_grid = data2 - endif - - if (col eq 2) then begin - ptitle = ' : DOY harvest' - data_grid = data3 - endif - - if (col eq 3) then begin - ptitle = ' : IRRIGTYPE' - data_grid = data4 - endif - - plot_position = [col_dmis1(col),row_dims1(row-1), col_dmis2(col),row_dims2(row-1)] - print, col, row, plot_position - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 0.8, title = cropname(n) + ptitle, /noborder, position = plot_position - - if(col eq 0) then begin - contour,data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - endif else if (col eq 3) then begin - for i = 0l, n_elements (data_grid) -1l do begin - if(data_grid(i) gt 0.) then oplot,[lons(i), lons(i)], [lats(i), lats(i)],psym=8,color= colors3(value_locate (ITYP,data_grid(i))) - endfor - endif else begin - for i = 0l, n_elements (data_grid) -1l do begin - if((data_grid(i) gt 0.) and (data_grid(i) le 366.)) then oplot,[lons(i), lons(i)], [lats(i), lats(i)],psym=8,color= colors2(value_locate (doy,data_grid(i))) - endfor - - endelse - - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - endfor - - row = row + 1 - - if (row eq 5) then begin - - colorbar,n_levels = 21, levels = levels, colors = colors, labels = levels, position = position_col1 - colorbar,n_levels = n_elements (DOY), levels = DOY, colors = colors2, labels = DOY, position = position_col2 - colorbar,n_levels = 4, levels = [1,2,3,4], colors = colors3, labels = ['Sprinkler', 'Drip', 'Flood',''], position = position_col3 -; ERASE - snapshot = TVRD() - TVLCT, r, g, b, /Get - Device, Z_Buffer=1 - Set_Plot, thisDevice - image24 = BytArr(3, 850, 1100) - image24[0,*,*] = r[snapshot] - image24[1,*,*] = g[snapshot] - image24[2,*,*] = b[snapshot] - Write_PNG, 'gia_irrig_params_' + string (page, '(i2.2)') + '.png' , image24 - - row = 1 - page = page + 1 - - endif - - this = plant (*,*,1,n) - data2 = this (fmask) - - if(max (data2) gt 0) then begin - if (row eq 1) then begin - thisDevice = !D.Name - set_plot,'Z' - Device, Set_Resolution=[850,1100], Z_Buffer=0,SET_FONT='Helvetica Bold', /TT_FONT - Erase,255 - !p.background = 255 - !P.position=0 - endif - - this = plant (*,*,1,n) - data2 = this (fmask) - this = harvest (*,*,1,n) - data3 = this (fmask) - - for col = 0,2 do begin - if (col eq 0) then begin - ptitle = ' : frac' - data_grid = data1 - endif - - if (col eq 1) then begin - ptitle = ' : DOY plant' - data_grid = data2 - endif - - if (col eq 2) then begin - ptitle = ' : DOY harvest' - data_grid = data3 - endif - - plot_position = [col_dmis1(col),row_dims1(row-1), col_dmis2(col),row_dims2(row-1)] - print, col, row, plot_position - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits , charsize = 0.8, title = cropname(n) + ptitle, /noborder, position = plot_position - if(col eq 0) then begin - contour,data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - endif else if (col eq 3) then begin - for i = 0l, n_elements (data_grid) -1l do begin - if(data_grid(i) gt 0.) then oplot,[lons(i), lons(i)], [lats(i), lats(i)],psym=8,color= colors3(value_locate (ITYP,data_grid(i))) - endfor - endif else begin - for i = 0l, n_elements (data_grid) -1l do begin - if((data_grid(i) gt 0.) and (data_grid(i) le 366.)) then oplot,[lons(i), lons(i)], [lats(i), lats(i)],psym=8,color= colors2(value_locate (doy,data_grid(i))) - endfor - endelse - - MAP_CONTINENTS,/COASTS,color=0,MLINETHICK=2 - - endfor - row = row + 1 - - if (row eq 5) then begin - - colorbar,n_levels = 21, levels = levels, colors = colors, labels = levels, position = position_col1 - colorbar,n_levels = n_elements (DOY), levels = DOY, colors = colors2, labels = DOY, position = position_col2 - colorbar,n_levels = 4, levels = [1,2,3,4], colors = colors3, labels = ['Sprinkler', 'Drip', 'Flood',''], position = position_col3 -; ERASE - snapshot = TVRD() - TVLCT, r, g, b, /Get - Device, Z_Buffer=1 - Set_Plot, thisDevice - image24 = BytArr(3, 850, 1100) - image24[0,*,*] = r[snapshot] - image24[1,*,*] = g[snapshot] - image24[2,*,*] = b[snapshot] - Write_PNG, 'gia_irrig_params_' + string (page, '(i2.2)') + '.png' , image24 - - row = 1 - page = page + 1 - - endif - endif -endfor - -;DEVICE, /CLOSE -;Set_Plot, thisDevice -end -; ========================================================================= - -pro colorbar,n_levels = n_levels, levels = levels, colors = colors, labels = labels,$ - position = position, vertical= vertical, horizontal = horizontal - - IF KEYWORD_SET(vertical) THEN BEGIN - - !P.position=[position(2) + 0.02, position(1) ,position(2) + 0.05, position(3)] - - alpha=fltarr(2,n_levels) - alpha(0,*)=levels - alpha(1,*)=levels - h=[-1,1] - clev = levels - clev (*) = 1 - k = 0 - - levelsx = indgen (N_levels) - - contour,alpha,h,levelsx,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,xticks=1, xtickname=[' ',' '] ,yrange=[min(levelsx),max(levelsx)], $ - ytitle=' ', color=0, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)",ytickformat = "(A1)" - contour,alpha,h,levelsx,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(levels) -1 do xyouts,1.1, levelsx[k],labels(k) ,color=0,charsize =1.2 - - endif else begin - -; !P.position=[position(0) +0.1, position(1)-0.06 ,position(2) - 0.1, position(1)-0.04] - !P.position=[0.15, 0.01, 0.85, 0.04] - IF KEYWORD_SET(position) then !P.position=position ; - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - k = 0 - - levelsx = indgen (N_levels) - - contour,alpha,levelsx,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1, ytickname=[' ',' '] ,xrange=[min(levelsx),max(levelsx)], $ - xtitle=' ', color=0, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)",ytickformat = "(A1)" - contour,alpha,levelsx,h,levels=levels,color=0,/overplot,c_label=clev - - if(n_levels eq 4) then begin - - for k = 0,n_elements(levels) -1 do xyouts, levelsx[k],1.1, strtrim(labels(k)), color=0,charsize =0.8,orientation=90 - endif else begin - if(max (labels) le 1.) then begin - for k = 0,n_elements(levels) -1 do xyouts, levelsx[k],1.1,string(labels(k),'(f5.2)') ,color=0,charsize =0.8,orientation=90 - - endif else begin - for k = 0,n_elements(levels) -1 do xyouts, levelsx[k],1.1,string(labels(k),'(i3.3)') ,color=0,charsize =0.8,orientation=90 - endelse - endelse - endelse - - !P.position=0 - -end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py new file mode 100755 index 0000000000..427d11970f --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/clsm_plots.py @@ -0,0 +1,3066 @@ +#!/usr/bin/env python3 +""" +Python replacement/extension for GEOS makebcs clsm_plots.pro + +This script is intended to be run from the same place the IDL driver was run +(usually clsm/plots). With no arguments it reads $gfile, $workdir, $NC, and +$NR and writes the standard plot products into the current directory. + +Typical first run from clsm/plots: + + python clsm_plots.py \ + --gfile "$gfile" --workdir "$workdir" --nc "$NC" --nr "$NR" \ + --plots default --outdir . + +Notes: + * F77 unformatted files are read as sequential records with 4-byte record + markers by default. Use --endian/--record-marker if your files differ. + * Cartopy is optional. If available, this script can draw coastlines with + --coastlines. Otherwise plots are still generated with lon/lat axes. + * Movie generation is optional and potentially slow. Use --plots movies + for movies only, or --plots legacy for fixed JPGs plus movies. +""" +from __future__ import annotations + +import argparse +import dataclasses +import datetime as _dt +import glob +import math +import os +import sys +import re +import shutil +import subprocess +from pathlib import Path +from typing import List, Optional, Sequence, Tuple + +import numpy as np + +import matplotlib +matplotlib.use("Agg") +import matplotlib.pyplot as plt +from matplotlib.colors import BoundaryNorm, ListedColormap +from matplotlib.cm import ScalarMappable +from matplotlib.collections import LineCollection +from matplotlib.ticker import FixedLocator, FixedFormatter + +try: + from scipy import sparse as sp_sparse # type: ignore +except Exception: # pragma: no cover - optional on Discover modules + sp_sparse = None + +try: + from scipy.stats import mode as scipy_mode # type: ignore +except Exception: # pragma: no cover + scipy_mode = None + +class FFMpegPipeWriter: + """Small MP4 writer that pipes RGB frames to the system ffmpeg executable. + + Discover's GEOSpyD imageio package may not include the imageio-ffmpeg plugin, + even when the shell ffmpeg module is available. Calling ffmpeg through + subprocess avoids that Python plugin dependency. Load the module with + + module load ffmpeg/5.0 + + or set CLSM_FFMPEG=/path/to/ffmpeg before running. + """ + + def __init__(self, outpath: Path, fps: int = 10): + self.outpath = Path(outpath) + self.fps = int(fps) + self.proc: Optional[subprocess.Popen] = None + self.width: Optional[int] = None + self.height: Optional[int] = None + + def __enter__(self): + self.outpath.parent.mkdir(parents=True, exist_ok=True) + return self + + def __exit__(self, exc_type, exc, tb): + if exc_type is not None: + if self.proc is not None and self.proc.poll() is None: + try: + self.proc.kill() + except Exception: + pass + return False + self.close() + return False + + @staticmethod + def _ffmpeg_exe() -> str: + explicit = os.environ.get("CLSM_FFMPEG") + if explicit: + p = Path(explicit).expanduser() + if p.exists(): + return str(p) + exe = shutil.which("ffmpeg") + if exe: + return exe + # Useful Discover fallback if the module path is present but PATH was not + # updated for some reason. The preferred route is still module load. + fallback = Path("/usr/local/other/ffmpeg/5.0/bin/ffmpeg") + if fallback.exists(): + return str(fallback) + raise ClsmPlotError( + "ffmpeg executable not found. Load it with `module load ffmpeg/5.0` " + "or set CLSM_FFMPEG=/path/to/ffmpeg before requesting movies." + ) + + @staticmethod + def _as_rgb_uint8(frame: np.ndarray) -> np.ndarray: + arr = np.asarray(frame) + if arr.ndim == 2: + arr = np.repeat(arr[:, :, None], 3, axis=2) + if arr.ndim != 3 or arr.shape[2] not in (3, 4): + raise ClsmPlotError(f"Movie frame must be HxWx3 or HxWx4, got shape {arr.shape}") + arr = arr[:, :, :3] + if arr.dtype != np.uint8: + arr = arr.astype(np.float32, copy=False) + if np.nanmax(arr) <= 1.0: + arr = arr * 255.0 + arr = np.nan_to_num(arr, nan=255.0, posinf=255.0, neginf=0.0) + arr = np.clip(arr, 0.0, 255.0).astype(np.uint8) + + # H.264 with yuv420p requires even frame dimensions. Adding the movie + # colorbar changed the canvas to 780x585 on Discover, which made + # ffmpeg reject the stream ("height not divisible by 2"). Pad, rather + # than crop, so no tick labels/colorbar pixels are lost. Use white + # padding to match the figure background. + h, w = arr.shape[:2] + new_h = h + (h % 2) + new_w = w + (w % 2) + if new_h != h or new_w != w: + padded = np.full((new_h, new_w, 3), 255, dtype=np.uint8) + padded[:h, :w, :] = arr + arr = padded + return np.ascontiguousarray(arr) + + def _start(self, frame: np.ndarray) -> None: + h, w = frame.shape[:2] + self.height, self.width = int(h), int(w) + ffmpeg = self._ffmpeg_exe() + cmd = [ + ffmpeg, + "-y", + "-loglevel", "error", + "-f", "rawvideo", + "-vcodec", "rawvideo", + "-pix_fmt", "rgb24", + "-s", f"{self.width}x{self.height}", + "-r", str(self.fps), + "-i", "-", + "-an", + "-vcodec", "libx264", + "-preset", "medium", + "-crf", "18", + "-pix_fmt", "yuv420p", + str(self.outpath), + ] + self.proc = subprocess.Popen( + cmd, + stdin=subprocess.PIPE, + stdout=subprocess.DEVNULL, + stderr=subprocess.PIPE, + ) + + def append_data(self, frame: np.ndarray) -> None: + rgb = self._as_rgb_uint8(frame) + if self.proc is None: + self._start(rgb) + if rgb.shape[0] != self.height or rgb.shape[1] != self.width: + raise ClsmPlotError( + f"Movie frame size changed from {self.width}x{self.height} " + f"to {rgb.shape[1]}x{rgb.shape[0]}" + ) + assert self.proc is not None and self.proc.stdin is not None + try: + self.proc.stdin.write(rgb.tobytes()) + except BrokenPipeError as exc: + err = b"" + if self.proc.stderr is not None: + err = self.proc.stderr.read() + raise ClsmPlotError(f"ffmpeg pipe closed while writing {self.outpath}: {err.decode(errors='replace')}") from exc + + def close(self) -> None: + if self.proc is None: + return + assert self.proc.stdin is not None + self.proc.stdin.close() + ret = self.proc.wait() + err = b"" + if self.proc.stderr is not None: + err = self.proc.stderr.read() + if ret != 0: + raise ClsmPlotError( + f"ffmpeg failed while writing {self.outpath} with exit code {ret}: " + f"{err.decode(errors='replace')}" + ) + + +def open_mp4_writer(outpath: Path, fps: int = 10): + """Open an MP4 writer. Uses system ffmpeg, not imageio-ffmpeg.""" + return FFMpegPipeWriter(Path(outpath), fps=fps) + +try: + import xarray as xr # type: ignore +except Exception: # pragma: no cover + xr = None + +try: + import cartopy.crs as ccrs # type: ignore + import cartopy.feature as cfeature # type: ignore + from cartopy.mpl.ticker import LongitudeFormatter, LatitudeFormatter # type: ignore +except Exception: # pragma: no cover + ccrs = None + cfeature = None + LongitudeFormatter = None + LatitudeFormatter = None + + +# ----------------------------------------------------------------------------- +# IDL-compatible color tables +# ----------------------------------------------------------------------------- + + +def _as_rgb(rows: Sequence[Sequence[int]]) -> np.ndarray: + return np.asarray(rows, dtype=np.float32) / 255.0 + + +def idl_palette() -> np.ndarray: + """Return a 256 x 3 RGB palette approximating load_colors.pro.""" + rgb = np.ones((256, 3), dtype=np.float32) + + def put(start: int, r: Sequence[int], g: Sequence[int], b: Sequence[int]) -> None: + n = len(r) + rgb[start:start + n, 0] = np.asarray(r) / 255.0 + rgb[start:start + n, 1] = np.asarray(g) / 255.0 + rgb[start:start + n, 2] = np.asarray(b) / 255.0 + + r_drought = [0, 0, 0, 0, 47, 200, 255, 255, 255, 255, 249, 197] + g_drought = [0, 115, 159, 210, 255, 255, 255, 255, 219, 157, 0, 0] + b_drought = [0, 0, 0, 0, 67, 130, 255, 0, 0, 0, 0, 0] + put(0, r_drought, g_drought, b_drought) + + r_green = [200, 150, 47, 60, 0, 0, 0, 0] + g_green = [255, 255, 255, 230, 219, 187, 159, 131] + b_green = [200, 150, 67, 15, 0, 0, 0, 0] + put(20, r_green, g_green, b_green) + + r_blue = [55, 0, 0, 0, 0, 0, 0, 0, 0, 0] + g_blue = [255, 255, 227, 195, 167, 115, 83, 0, 0, 0] + b_blue = [199, 255, 255, 255, 255, 255, 255, 255, 200, 130] + put(30, r_blue, g_blue, b_blue) + + r_red = [255, 240, 255, 255, 255, 255, 255, 233, 197] + g_red = [255, 255, 219, 187, 159, 131, 51, 23, 0] + b_red = [153, 15, 0, 0, 0, 0, 0, 0, 0] + put(40, r_red, g_red, b_red) + + r_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] + g_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] + b_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] + put(50, r_grey, g_grey, b_grey) + + r_type = [255, 106, 202, 251, 0, 29, 77, 109, 142, 233, 255, 255, 255, 127, 164, 164, 217, 217, 204, 104, 0] + g_type = [245, 91, 178, 154, 85, 115, 145, 165, 185, 23, 131, 131, 191, 39, 53, 53, 72, 72, 204, 104, 70] + b_type = [215, 154, 214, 153, 0, 0, 0, 0, 13, 0, 0, 200, 0, 4, 3, 200, 1, 200, 204, 200, 200] + put(60, r_type, g_type, b_type) + + r_lct2 = [0, 0, 0, 0, 0, 0, 0, 0, 0, 55, 120, 190, 240, 255, 255, 255, 255, 255, 233, 197, 158] + g_lct2 = [0, 0, 0, 83, 115, 167, 195, 227, 255, 255, 255, 255, 255, 219, 187, 159, 131, 51, 23, 0, 0] + b_lct2 = [130, 200, 255, 255, 255, 255, 255, 255, 255, 199, 135, 67, 15, 0, 0, 0, 0, 0, 0, 0, 0] + put(140, r_lct2, g_lct2, b_lct2) + + r_veg = [233, 255, 255, 255, 210, 0, 0, 0, 204, 170, 255, 220, 205, 0, 0, 170, 0, 40, 120, 140, 190, 150, 255, 255, 0, 0, 0, 195, 255, 0] + g_veg = [23, 131, 191, 255, 255, 255, 155, 0, 204, 240, 255, 240, 205, 100, 160, 200, 60, 100, 130, 160, 150, 100, 180, 235, 120, 150, 220, 20, 245, 70] + b_veg = [0, 0, 0, 178, 255, 255, 255, 200, 204, 240, 100, 100, 102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50, 175, 90, 120, 130, 0, 215, 200] + put(90, r_veg, g_veg, b_veg) + + r_grads_rb = [160, 110, 30, 0, 0, 0, 0, 160, 230, 230, 240, 250, 240] + g_grads_rb = [0, 0, 60, 150, 200, 210, 220, 230, 220, 175, 130, 60, 0] + b_grads_rb = [200, 220, 255, 255, 200, 140, 0, 50, 50, 45, 40, 60, 130] + put(120, r_grads_rb, g_grads_rb, b_grads_rb) + + rgb[255] = (1.0, 1.0, 1.0) + return rgb + + +PALETTE = idl_palette() +CONTINUOUS_COLOR_IDS = [27, 26, 25, 24, 23, 22, 21, 20, 40, 41, 42, 43, 44, 45, 46, 47, 48] +LAI_RGB = _as_rgb([ + [253, 253, 253], [224, 238, 224], [255, 255, 0], [238, 238, 0], + [205, 205, 0], [193, 255, 193], [152, 251, 152], [0, 255, 127], + [124, 252, 0], [0, 255, 0], [0, 238, 0], [0, 205, 0], + [0, 139, 0], [0, 128, 0], [0, 100, 0], [48, 128, 20], + [110, 139, 61], [85, 107, 47], +]) +# White is reserved for missing / invalid / no-data only. +# It is not used as a valid data color in LAI, GREEN, NDVI, VISDF, or NIRDF. +NO_DATA_COLOR = (1.0, 1.0, 1.0) + +# LAI is plotted from 0.0 to 7.5 using 0.5 increments. +# There are 16 boundaries and therefore 15 valid color intervals. +# Drop the first nearly-white color from LAI_RGB so the first valid data +# interval, 0.0-0.5, is light gray instead of white. +LAI_LEVELS = np.asarray([ + 0.0, 0.5, 1.0, 1.5, 2.0, 2.5, + 3.0, 3.5, 4.0, 4.5, 5.0, 5.5, + 6.0, 6.5, 7.0, 7.5, +], dtype=np.float32) + +LAI_PLOT_RGB = LAI_RGB[1:len(LAI_LEVELS)].copy() + +LAI_TICKS = LAI_LEVELS.astype(float) + +LAI_TICK_LABELS = [ + "0", "0.5", "1", "1.5", "2", "2.5", + "3", "3.5", "4", "4.5", "5", "5.5", + "6", "6.5", "7", "7.5", +] + +# Fraction fields use FRACTION_LEVELS as true 0..1 bin boundaries. +# FRACTION_LEVELS has 18 boundaries, so it needs 17 colors. +# White is reserved for missing/no-data; valid zero values use light blue. +FRACTION_LEVELS = np.asarray([ + 0.00, 0.025, 0.050, 0.075, 0.10, + 0.15, 0.20, 0.25, 0.30, 0.35, + 0.40, 0.45, 0.50, + 0.60, 0.70, 0.80, 0.90, 1.00, +], dtype=np.float32) + +FRACTION_RGB = LAI_RGB[1:len(FRACTION_LEVELS)].copy() + +FRACTION_TICKS = FRACTION_LEVELS.astype(float) + +FRACTION_TICK_LABELS = [ + "0", "0.025", "0.05", "0.075", "0.1", + "0.15", "0.2", "0.25", "0.3", "0.35", + "0.4", "0.45", "0.5", + "0.6", "0.7", "0.8", "0.9", "1", +] + +FRACTION_RGB = LAI_RGB[1:].copy() +FRACTION_RGB[0] = _as_rgb([[210, 230, 255]])[0] + +# IDL Z0 levels used by compute_zo for ascat/icarus/merged. Keep +# labels as strings so matplotlib cannot round the sub-1 bins to repeated +# ``0`` labels on the horizontal colorbar. +Z0_LEVELS = np.asarray([ + 0.02, 0.05, 0.07, 0.10, 0.30, 0.50, + 1.0, 2.0, 4.0, 6.0, 8.0, 10.0, + 50.0, 100.0, 500.0, 1000.0, 2000.0, 3000.0, 4000.0, 5000.0, +], dtype=np.float32) +Z0_TICK_LABELS = [ + "≤0.02", "0.05", "0.07", "0.10", "0.30", "0.50", + "1", "2", "4", "6", "8", "10", + "50", "100", "500", "1000", "2000", "3000", "4000", "5000", +] +Z0_COLOR_IDS = [74, 77, 35, 34, 33, 32, 25, 24, 23, 22, 21, 20, 41, 42, 43, 44, 45, 46, 47, 48] + +# User-tunable output quality for static JPG products. These are set from +# --dpi and --jpeg-quality in main(). +PLOT_DPI = int(os.environ.get("CLSM_PLOT_DPI", "180")) +JPEG_QUALITY = int(os.environ.get("CLSM_JPEG_QUALITY", "95")) + + +# ----------------------------------------------------------------------------- +# File readers +# ----------------------------------------------------------------------------- + + +class ClsmPlotError(RuntimeError): + pass + + +@dataclasses.dataclass(frozen=True) +class F77Layout: + endian: str = "<" + marker_bytes: int = 4 + + @property + def marker_dtype(self) -> np.dtype: + if self.marker_bytes == 4: + return np.dtype(self.endian + "i4") + if self.marker_bytes == 8: + return np.dtype(self.endian + "i8") + raise ValueError("record markers must be 4 or 8 bytes") + + + + +@dataclasses.dataclass(frozen=True) +class TimeSeriesLayout: + """Layout for LAI/GREEN/NDVI/AlbMap-style seasonal time-series files. + + Most make_bcs files are F77 sequential records with a header record + containing at least the 9 IDL date fields, followed by an ncat-value data + record. Finished BCS trees may expose renamed/symlinked files with extended + headers or double-precision header fields. A few test copies may be raw + header+data streams without F77 record markers. + """ + mode: str = "f77" + endian: str = "<" + marker_bytes: int = 4 + header_dtype: str = "f4" + value_dtype: str = "f4" + + @property + def f77_layout(self) -> F77Layout: + return F77Layout(self.endian, self.marker_bytes) + + +class TimeSeriesReader: + def __init__(self, path: Path, layout: TimeSeriesLayout, ncat: int): + self.path = Path(path) + self.layout = layout + self.ncat = int(ncat) + self.rdr = None + self.fh = None + + def __enter__(self) -> "TimeSeriesReader": + if self.layout.mode == "f77": + self.rdr = FortranSequentialReader(self.path, self.layout.f77_layout) + else: + self.fh = self.path.open("rb") + return self + + def __exit__(self, exc_type, exc, tb) -> None: # type: ignore[override] + if self.rdr is not None: + self.rdr.close() + if self.fh is not None: + self.fh.close() + + def _dt(self, kind: str) -> np.dtype: + return np.dtype(self.layout.endian + kind) + + def read_record(self) -> Tuple[np.ndarray, np.ndarray]: + hdt = self._dt(self.layout.header_dtype) + vdt = self._dt(self.layout.value_dtype) + if self.layout.mode == "f77": + if self.rdr is None: + raise ClsmPlotError("TimeSeriesReader not opened") + hpayload = self.rdr.read_record_bytes() + header = np.frombuffer(hpayload, dtype=hdt) + if header.size < 9: + raise ClsmPlotError(f"header record in {self.path} has {header.size} values, expected at least 9") + vpayload = self.rdr.read_record_bytes() + values = np.frombuffer(vpayload, dtype=vdt) + if values.size != self.ncat: + raise ClsmPlotError(f"data record in {self.path} has {values.size} values, expected {self.ncat}") + # IDL only reads the first 9 values from the header record. Extra + # fields may be present in finalized lai_clim/green/ndvi files. + return header[:9].astype(np.float64).copy(), values.astype(np.float32).copy() + if self.fh is None: + raise ClsmPlotError("TimeSeriesReader not opened") + hbytes = self.fh.read(9 * hdt.itemsize) + if not hbytes: + raise EOFError(f"end of file in {self.path}") + if len(hbytes) != 9 * hdt.itemsize: + raise ClsmPlotError(f"short raw header in {self.path}") + vbytes = self.fh.read(self.ncat * vdt.itemsize) + if len(vbytes) != self.ncat * vdt.itemsize: + raise ClsmPlotError(f"short raw data record in {self.path}") + return np.frombuffer(hbytes, dtype=hdt).astype(np.float64).copy(), np.frombuffer(vbytes, dtype=vdt).astype(np.float32).copy() + + +def detect_timeseries_layout(path: Path, ncat: int) -> TimeSeriesLayout: + path = Path(path) + head = path.read_bytes()[:128] + # F77 sequential: IDL reads the first 9 floats from each header record: + # readu,1,yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + # In finished BCS trees the header record can contain more than those 9 + # values. For example lai_clim_* often starts with a 56-byte record, i.e. + # 14 float32 values: the first 9 are the dates and the remaining values are + # metadata. Therefore accept any float32/float64 header record with at least + # 9 values, then verify that the following data record has ncat values. + for marker_bytes in (4, 8): + for endian in ("<", ">"): + if len(head) < marker_bytes: + continue + mdtype = np.dtype(endian + ("i4" if marker_bytes == 4 else "i8")) + nhead = int(np.frombuffer(head[:marker_bytes], dtype=mdtype)[0]) + if nhead <= 0: + continue + for hkind, hsize in (("f4", 4), ("f8", 8)): + if nhead % hsize != 0 or nhead < 9 * hsize: + continue + try: + with FortranSequentialReader(path, F77Layout(endian, marker_bytes)) as rdr: + hpayload = rdr.read_record_bytes() + header = np.frombuffer(hpayload, dtype=np.dtype(endian + hkind)) + if header.size < 9: + continue + # Simple sanity check for the date fields read by IDL. + # year offsets are usually 0/1/2, months 1..12, days 1..31. + if not (0 <= float(header[1]) <= 12 and 0 <= float(header[7]) <= 12): + continue + vpayload = rdr.read_record_bytes() + if len(vpayload) == int(ncat) * 4: + print(f"Detected time-series layout for {path.name}: mode=f77 endian={endian} marker={marker_bytes} header_values={header.size} header_dtype={hkind} value_dtype=f4") + return TimeSeriesLayout("f77", endian, marker_bytes, hkind, "f4") + if len(vpayload) == int(ncat) * 8: + print(f"Detected time-series layout for {path.name}: mode=f77 endian={endian} marker={marker_bytes} header_values={header.size} header_dtype={hkind} value_dtype=f8") + return TimeSeriesLayout("f77", endian, marker_bytes, hkind, "f8") + except Exception: + pass + # Raw fallback: header/data/header/data with no F77 markers. Accept both + # the exact IDL 9-value header and the 14-value extended header. + size = path.stat().st_size + for nheader in (9, 14): + rec4 = (nheader + int(ncat)) * 4 + rec8 = (nheader + int(ncat)) * 8 + if rec4 > 0 and size % rec4 == 0: + print(f"Detected time-series layout for {path.name}: mode=raw header_values={nheader} dtype=f4") + return TimeSeriesLayout("raw", "<", 0, "f4", "f4") + if rec8 > 0 and size % rec8 == 0: + print(f"Detected time-series layout for {path.name}: mode=raw header_values={nheader} dtype=f8") + return TimeSeriesLayout("raw", "<", 0, "f8", "f8") + raise ClsmPlotError( + f"Could not detect LAI/GREEN/NDVI time-series layout for {path}. " + "Expected an F77 header record with at least 9 float values followed by an ncat-value record, " + "or a raw stream of header+ncat float values." + ) + + +def choose_timeseries_layout(path: Path, ncat: int, endian: str = "auto", marker_bytes: int = 0) -> TimeSeriesLayout: + # Auto is safest because finished-layout symlinks can expose f4 or f8 headers. + if endian == "auto" or marker_bytes == 0: + return detect_timeseries_layout(path, ncat) + endian_char = "<" if endian in ("little", "<") else ">" + # When endian and record-marker are explicitly specified, assume a + # single-precision F77 layout. Use auto detection for files that may + # have extended or double-precision headers. + return TimeSeriesLayout("f77", endian_char, marker_bytes, "f4", "f4") + +class FortranSequentialReader: + """Read F77 sequential unformatted records.""" + + def __init__(self, path: Path, layout: F77Layout): + self.path = Path(path) + self.layout = layout + self.fh = self.path.open("rb") + + def close(self) -> None: + self.fh.close() + + def __enter__(self) -> "FortranSequentialReader": + return self + + def __exit__(self, exc_type, exc, tb) -> None: # type: ignore[override] + self.close() + + def read_record_bytes(self) -> bytes: + m = self.layout.marker_bytes + start = self.fh.read(m) + if not start: + raise EOFError(f"end of file in {self.path}") + if len(start) != m: + raise ClsmPlotError(f"short F77 record marker in {self.path}") + nbytes = int(np.frombuffer(start, dtype=self.layout.marker_dtype)[0]) + if nbytes < 0: + raise ClsmPlotError(f"negative F77 record length {nbytes} in {self.path}") + payload = self.fh.read(nbytes) + if len(payload) != nbytes: + raise ClsmPlotError(f"short F77 record payload in {self.path}: wanted {nbytes}, got {len(payload)}") + end = self.fh.read(m) + if len(end) != m: + raise ClsmPlotError(f"short trailing F77 record marker in {self.path}") + end_nbytes = int(np.frombuffer(end, dtype=self.layout.marker_dtype)[0]) + if end_nbytes != nbytes: + raise ClsmPlotError( + f"F77 marker mismatch in {self.path}: leading={nbytes}, trailing={end_nbytes}" + ) + return payload + + def read_array(self, dtype: np.dtype | str, count: Optional[int] = None) -> np.ndarray: + payload = self.read_record_bytes() + dt = np.dtype(dtype).newbyteorder(self.layout.endian) + arr = np.frombuffer(payload, dtype=dt) + if count is not None and arr.size != count: + raise ClsmPlotError( + f"record in {self.path} has {arr.size} values of {dt}, expected {count}" + ) + return arr.copy() + + +def detect_f77_layout(path: Path, expected_payload_bytes: int) -> F77Layout: + head = Path(path).read_bytes()[:32] + for marker_bytes in (4, 8): + for endian in ("<", ">"): + if len(head) < marker_bytes: + continue + dtype = np.dtype(endian + ("i4" if marker_bytes == 4 else "i8")) + n = int(np.frombuffer(head[:marker_bytes], dtype=dtype)[0]) + if n == expected_payload_bytes: + return F77Layout(endian=endian, marker_bytes=marker_bytes) + raise ClsmPlotError( + f"Could not detect F77 layout for {path}. Expected first record payload " + f"{expected_payload_bytes} bytes. Try --endian little|big and/or --record-marker." + ) + + +def choose_layout(path: Path, expected_payload_bytes: int, endian: str, marker_bytes: int) -> F77Layout: + if endian == "auto" or marker_bytes == 0: + return detect_f77_layout(path, expected_payload_bytes) + endian_char = "<" if endian in ("little", "<") else ">" + return F77Layout(endian=endian_char, marker_bytes=marker_bytes) + + +def is_netcdf(path: Path) -> bool: + try: + magic = Path(path).read_bytes()[:8] + except FileNotFoundError: + return False + return magic.startswith(b"CDF") or magic.startswith(b"\x89HDF\r\n\x1a\n") + + +def load_ascii_table(path: Path, skiprows: int = 0, min_cols: Optional[int] = None) -> np.ndarray: + if not path.exists(): + raise ClsmPlotError(f"Missing required file: {path}") + arr = np.loadtxt(path, comments="#", skiprows=skiprows) + if arr.ndim == 1: + arr = arr.reshape(1, -1) + if min_cols is not None and arr.shape[1] < min_cols: + raise ClsmPlotError(f"{path} has {arr.shape[1]} columns; expected at least {min_cols}") + return arr + + +def read_ncat(base_dir: Path) -> int: + path = base_dir / "catchment.def" + if not path.exists(): + raise ClsmPlotError(f"Missing catchment definition: {path}") + with path.open("r") as fh: + first = fh.readline().split() + if not first: + raise ClsmPlotError(f"Empty catchment definition: {path}") + return int(float(first[0])) + + +def read_limits(base_dir: Path, gfile: str) -> Tuple[float, float, float, float]: + """Return IDL-style default map limits as (min_lat, min_lon, max_lat, max_lon).""" + default = (-60.0, -180.0, 90.0, 180.0) + if "Pfafstetter" in gfile or "SMAP" in gfile: + return default + path = base_dir / "catchment.def" + try: + rows = load_ascii_table(path, skiprows=1, min_cols=6) + except Exception: + return default + min_lon = np.nanmin(rows[:, 2]) + max_lon = np.nanmax(rows[:, 3]) + min_lat = np.nanmin(rows[:, 4]) + max_lat = np.nanmax(rows[:, 5]) + if math.ceil(max_lon) - math.floor(min_lon) < 180: + return (math.floor(min_lat), math.floor(min_lon), math.ceil(max_lat), math.ceil(max_lon)) + return default + + + +def list_rst_files(workdir: Path, gfile: str, explicit_rst_file: Optional[str] = None) -> List[Path]: + """Return candidate rst files. + + IDL used a wildcard, ``/rst/*.rst``. For EASE grids this + can include several companion rasters, for example the pure EASE raster and + the EASE/Pfafstetter combined raster. The combined raster is often the one + that maps pixels to the CLSM/catchment tile IDs used by ``catchment.def``. + + Therefore do *not* discard filenames containing ``Pfafstetter`` here. Keep + every ``*.rst`` candidate and let ``select_rst_file`` score which one + actually behaves like a geographic CLSM tile-id raster. The user can still + force any file with ``--rst-file``. + """ + if explicit_rst_file: + p = Path(explicit_rst_file).expanduser() + if not p.is_absolute(): + p = Path.cwd() / p + if not p.exists(): + raise ClsmPlotError(f"Explicit --rst-file does not exist: {p}") + return [p.resolve()] + + rst_dir = workdir / "rst" + pattern = str(rst_dir / f"{gfile}*.rst") + matches = [Path(m).resolve() for m in sorted(glob.glob(pattern))] + if not matches: + raise ClsmPlotError(f"No restart/raster file matched {pattern}") + + # Stable unique order. + seen = set() + out: List[Path] = [] + for m in matches: + if m not in seen: + seen.add(m) + out.append(m) + return out + + +@dataclasses.dataclass(frozen=True) +class RstCandidateScore: + path: Path + layout: F77Layout + valid_fraction: float + valid_count: int + sample_count: int + min_value: int + max_value: int + first_valid_row: int + last_valid_row: int + valid_row_count: int + sampled_row_count: int + + @property + def row_span_fraction(self) -> float: + if self.first_valid_row < 0 or self.last_valid_row < 0 or self.sampled_row_count <= 1: + return 0.0 + return float(self.last_valid_row - self.first_valid_row) / float(max(1, self.sampled_row_count - 1)) + + +def sample_rst_candidate( + path: Path, + nc: int, + nr: int, + ncat: int, + endian: str, + marker_bytes: int, + sample_rows: int = 144, +) -> RstCandidateScore: + """Sample an rst candidate and summarize whether it looks like CLSM tile IDs. + + A misleading raster can contain many values in 1..ncat but only over a narrow + projected band when interpreted as lon/lat. The original IDL maps are + geographic/global, so for global grids the correct raster should have valid + land rows spread across much of the sampled row range. We therefore record + both the number of valid tile IDs and the sampled row span. + """ + layout = choose_layout(path, nc * 4, endian, marker_bytes) + record_bytes = layout.marker_bytes + nc * 4 + layout.marker_bytes + row_ids = np.unique(np.linspace(0, nr - 1, min(sample_rows, nr), dtype=np.int64)) + valid_count = 0 + sample_count = 0 + min_val: Optional[int] = None + max_val: Optional[int] = None + first_valid_idx = -1 + last_valid_idx = -1 + valid_row_count = 0 + marker_dtype = layout.marker_dtype + data_dtype = np.dtype(layout.endian + "i4") + + with path.open("rb") as fh: + for sample_idx, row in enumerate(row_ids): + fh.seek(int(row) * record_bytes) + marker = fh.read(layout.marker_bytes) + if len(marker) != layout.marker_bytes: + raise ClsmPlotError(f"short marker while sampling {path} row {row}") + nbytes = int(np.frombuffer(marker, dtype=marker_dtype)[0]) + if nbytes != nc * 4: + raise ClsmPlotError( + f"record length mismatch while sampling {path} row {row}: " + f"got {nbytes}, expected {nc * 4}" + ) + payload = fh.read(nc * 4) + if len(payload) != nc * 4: + raise ClsmPlotError(f"short payload while sampling {path} row {row}") + arr = np.frombuffer(payload, dtype=data_dtype) + sample_count += int(arr.size) + valid = (arr >= 1) & (arr <= ncat) + row_valid = int(np.count_nonzero(valid)) + valid_count += row_valid + if row_valid > 0: + if first_valid_idx < 0: + first_valid_idx = sample_idx + last_valid_idx = sample_idx + valid_row_count += 1 + row_min = int(arr.min()) + row_max = int(arr.max()) + min_val = row_min if min_val is None else min(min_val, row_min) + max_val = row_max if max_val is None else max(max_val, row_max) + + frac = float(valid_count) / float(sample_count) if sample_count else 0.0 + return RstCandidateScore( + path=path, + layout=layout, + valid_fraction=frac, + valid_count=valid_count, + sample_count=sample_count, + min_value=int(min_val or 0), + max_value=int(max_val or 0), + first_valid_row=first_valid_idx, + last_valid_row=last_valid_idx, + valid_row_count=valid_row_count, + sampled_row_count=int(len(row_ids)), + ) + + +def select_rst_file( + workdir: Path, + gfile: str, + ncat: int, + nc: int, + nr: int, + endian: str, + marker_bytes: int, + explicit_rst_file: Optional[str] = None, +) -> Tuple[Path, F77Layout]: + """Choose the raster that actually looks like the CLSM tile-id raster.""" + candidates = list_rst_files(workdir, gfile, explicit_rst_file) + if len(candidates) > 1: + print("RST candidates after filtering:") + scored: List[Tuple[float, float, float, int, RstCandidateScore]] = [] + errors: List[str] = [] + for idx, path in enumerate(candidates): + try: + score = sample_rst_candidate(path, nc, nr, ncat, endian, marker_bytes) + # Primary: row span. Secondary: number/fraction of valid tile IDs. + # Keep original order as the final tie breaker. + scored.append((score.row_span_fraction, score.valid_fraction, float(score.valid_count), -idx, score)) + if len(candidates) > 1 or explicit_rst_file: + print( + f" {path.name}: valid_sample={score.valid_count}/{score.sample_count} " + f"({score.valid_fraction:.6f}), valid_rows={score.valid_row_count}/{score.sampled_row_count}, " + f"row_span={score.row_span_fraction:.3f}, min={score.min_value}, max={score.max_value}, " + f"endian={score.layout.endian}, marker={score.layout.marker_bytes}" + ) + except Exception as exc: + errors.append(f"{path.name}: {exc}") + if len(candidates) > 1 or explicit_rst_file: + print(f" {path.name}: skipped ({exc})") + + if not scored: + detail = "\n".join(errors) + raise ClsmPlotError(f"No usable rst files found under {workdir / 'rst'}.\n{detail}") + + # Prefer candidates with the broadest sampled latitude/row coverage. This + # avoids selecting projection/Pfafstetter companion rasters that have valid + # numeric ranges but do not make global geographic plots. + scored.sort(key=lambda item: (-item[0], -item[1], -item[2], -item[3])) + best = scored[0][4] + if best.valid_count == 0: + raise ClsmPlotError( + f"Selected rst candidate has zero values in 1..ncat: {best.path}. " + "Check --gfile/--workdir/--nc/--nr or pass --rst-file explicitly." + ) + if len(candidates) > 1: + print( + f"Selected raster: {best.path} " + f"(row_span={best.row_span_fraction:.3f}, valid_sample_fraction={best.valid_fraction:.6f})" + ) + elif explicit_rst_file: + print( + f"Using explicit raster: {best.path} " + f"(row_span={best.row_span_fraction:.3f}, valid_sample_fraction={best.valid_fraction:.6f})" + ) + else: + print(f"Using raster file: {best.path}") + return best.path, best.layout + +def read_nc_var(path: Path, varname: str) -> np.ndarray: + if xr is None: + raise ClsmPlotError("xarray/netCDF support is not available in this Python environment") + if not path.exists(): + raise ClsmPlotError(f"Missing NetCDF file: {path}") + with xr.open_dataset(path, decode_times=False) as ds: + if varname not in ds: + raise ClsmPlotError(f"Variable {varname!r} not found in {path}. Available: {list(ds.data_vars)}") + return np.asarray(ds[varname].values) + + +# ----------------------------------------------------------------------------- +# Grid and tile tools +# ----------------------------------------------------------------------------- + + +def lon_lat_centers(nc: int, nr: int) -> Tuple[np.ndarray, np.ndarray]: + lon = np.arange(nc, dtype=np.float64) * (360.0 / nc) - 180.0 + 0.5 * (360.0 / nc) + lat = np.arange(nr, dtype=np.float64) * (180.0 / nr) - 90.0 + 0.5 * (180.0 / nr) + return lon, lat + + +def mode_rows_int(blocks: np.ndarray) -> np.ndarray: + """Return the row-wise mode for integer blocks.""" + if blocks.ndim != 2: + raise ValueError("blocks must be 2D") + if blocks.shape[1] == 1: + return blocks[:, 0].astype(np.int32, copy=False) + if scipy_mode is not None: + result = scipy_mode(blocks, axis=1, keepdims=False) + return np.asarray(result.mode, dtype=np.int32) + out = np.empty(blocks.shape[0], dtype=np.int32) + for i, row in enumerate(blocks): + vals, counts = np.unique(row, return_counts=True) + out[i] = vals[np.argmax(counts)] + return out + + +def dominant_land_tile(blocks: np.ndarray, ncat: int) -> np.ndarray: + """IDL-compatible dominant tile selection for a downsampled raster block. + + The IDL code ignores ocean/invalid values when a plotting cell contains at + least one land tile. A naive mode over values with invalid pixels replaced + by zero would let ocean dominate coastal cells, so we first compute a fast + mode and then repair only cells where zero won but valid land is present. + """ + valid = (blocks >= 1) & (blocks <= ncat) + masked = np.where(valid, blocks, 0).astype(np.int32, copy=False) + out = mode_rows_int(masked) + + repair = (out == 0) & valid.any(axis=1) + if np.any(repair): + repair_idx = np.flatnonzero(repair) + for i in repair_idx: + vals, counts = np.unique(blocks[i, valid[i]], return_counts=True) + out[i] = vals[np.argmax(counts)] + return out + + +def build_tile_id_from_rst( + rst_file: Path, + nc: int, + nr: int, + ncat: int, + nc_plot: int, + nr_plot: int, + layout: F77Layout, + cache: Optional[Path] = None, +) -> np.ndarray: + """Build the dominant catchment tile map. Returns array shape (nr_plot, nc_plot).""" + if cache and cache.exists(): + data = np.load(cache, allow_pickle=True) + meta = dict(data["meta"].item()) if "meta" in data else {} + rst_stat = rst_file.stat() + cache_ok = ( + meta.get("nc") == nc + and meta.get("nr") == nr + and meta.get("ncat") == ncat + and meta.get("nc_plot") == nc_plot + and meta.get("nr_plot") == nr_plot + and meta.get("rst_file") == str(rst_file.resolve()) + and meta.get("rst_size") == int(rst_stat.st_size) + ) + if cache_ok: + print(f"Reading cached tile map: {cache}") + return np.asarray(data["tile_id"], dtype=np.int32) + print(f"Ignoring stale cache: {cache}") + + if nc % nc_plot != 0 or nr % nr_plot != 0: + raise ClsmPlotError( + f"NC/NR must be integer multiples of plot grid. Got NC={nc}, NR={nr}, " + f"plot={nc_plot}x{nr_plot}. Try --plot-nc/--plot-nr." + ) + dx = nc // nc_plot + dy = nr // nr_plot + print(f"Building tile map from {rst_file}: source {nc}x{nr}, plot {nc_plot}x{nr_plot}, block {dx}x{dy}") + tile_id = np.zeros((nr_plot, nc_plot), dtype=np.int32) + + with FortranSequentialReader(rst_file, layout) as rdr: + for j in range(nr_plot): + rows = np.empty((dy, nc), dtype=np.int32) + for jj in range(dy): + rows[jj, :] = rdr.read_array(np.int32, nc) + if dx == 1 and dy == 1: + vals = rows[0].copy() + vals[(vals < 1) | (vals > ncat)] = 0 + tile_id[j, :] = vals + else: + block = rows.reshape(dy, nc_plot, dx).transpose(1, 0, 2).reshape(nc_plot, dx * dy) + tile_id[j, :] = dominant_land_tile(block, ncat) + if (j + 1) % max(1, nr_plot // 20) == 0 or j == nr_plot - 1: + print(f" tile map rows {j + 1}/{nr_plot}") + + if cache: + cache.parent.mkdir(parents=True, exist_ok=True) + np.savez_compressed( + cache, + tile_id=tile_id, + meta={ + "nc": nc, + "nr": nr, + "ncat": ncat, + "nc_plot": nc_plot, + "nr_plot": nr_plot, + "rst_file": str(rst_file.resolve()), + "rst_size": int(rst_file.stat().st_size), + }, + ) + print(f"Wrote tile-map cache: {cache}") + return tile_id + + +def vector_to_grid(tile_id: np.ndarray, vec: np.ndarray, fill_zero: bool = False) -> np.ndarray: + vals = np.asarray(vec) + out = np.full(tile_id.shape, np.nan, dtype=np.float32) + mask = (tile_id >= 1) & (tile_id <= vals.shape[0]) + out[mask] = vals[tile_id[mask] - 1].astype(np.float32) + if fill_zero: + out[~mask] = 0.0 + return out + +def build_tile_id_from_catchment_def( + base_dir: Path, + ncat: int, + nc_plot: int, + nr_plot: int, + cache: Optional[Path] = None, +) -> np.ndarray: + """Build a plotting tile map directly from catchment.def lon/lat boxes. + + This is a fallback for grids such as EASE where ``*.rst`` + companion rasters can contain projection-cell or Pfafstetter IDs rather + than the CLSM tile IDs that index the tile-parameter files. IDL primarily + used the rst map, but all of the global fixed-parameter maps ultimately + need only a lon/lat plotting grid whose values are row numbers in + ``catchment.def``/``cti_stats.dat``/``soil_param.dat``. The catchment + bounds in columns 3:6 of ``catchment.def`` provide that mapping. + """ + cdef = base_dir / "catchment.def" + if cache and cache.exists(): + data = np.load(cache, allow_pickle=True) + meta = dict(data["meta"].item()) if "meta" in data else {} + st = cdef.stat() + if ( + meta.get("source") == "catchment.def" + and meta.get("ncat") == ncat + and meta.get("nc_plot") == nc_plot + and meta.get("nr_plot") == nr_plot + and meta.get("catchment_def") == str(cdef.resolve()) + and meta.get("catchment_size") == int(st.st_size) + ): + print(f"Reading cached catchment.def tile map: {cache}") + return np.asarray(data["tile_id"], dtype=np.int32) + print(f"Ignoring stale catchment.def cache: {cache}") + + rows = load_ascii_table(cdef, skiprows=1, min_cols=6) + if rows.shape[0] < ncat: + raise ClsmPlotError(f"{cdef} has {rows.shape[0]} rows but ncat={ncat}") + rows = rows[:ncat] + minlon = rows[:, 2].astype(float) + maxlon = rows[:, 3].astype(float) + minlat = rows[:, 4].astype(float) + maxlat = rows[:, 5].astype(float) + + dx = 360.0 / float(nc_plot) + dy = 180.0 / float(nr_plot) + tile_id = np.zeros((nr_plot, nc_plot), dtype=np.int32) + + def lat_slice(lo: float, hi: float) -> Optional[slice]: + if not np.isfinite(lo) or not np.isfinite(hi): + return None + lo = max(-90.0, min(90.0, lo)) + hi = max(-90.0, min(90.0, hi)) + if hi < lo: + lo, hi = hi, lo + # Fill cells whose area intersects the catchment box. This guarantees + # very small boxes still get at least one plot pixel. + j0 = int(math.floor((lo + 90.0) / dy)) + j1 = int(math.ceil((hi + 90.0) / dy)) - 1 + j0 = max(0, min(nr_plot - 1, j0)) + j1 = max(0, min(nr_plot - 1, j1)) + if j1 < j0: + j = max(0, min(nr_plot - 1, int(round(((lo + hi) * 0.5 + 90.0) / dy - 0.5)))) + j0 = j1 = j + return slice(j0, j1 + 1) + + def lon_slices(lo: float, hi: float) -> List[slice]: + if not np.isfinite(lo) or not np.isfinite(hi): + return [] + # Normalize to [-180, 180). If the original box spans the dateline, + # split into two slices. + lo0, hi0 = lo, hi + lo = ((lo + 180.0) % 360.0) - 180.0 + hi = ((hi + 180.0) % 360.0) - 180.0 + wraps = (lo0 > hi0) or (lo > hi and abs(lo - hi) < 359.999) + + def one_slice(a: float, b: float) -> Optional[slice]: + a = max(-180.0, min(180.0, a)) + b = max(-180.0, min(180.0, b)) + i0 = int(math.floor((a + 180.0) / dx)) + i1 = int(math.ceil((b + 180.0) / dx)) - 1 + i0 = max(0, min(nc_plot - 1, i0)) + i1 = max(0, min(nc_plot - 1, i1)) + if i1 < i0: + i = max(0, min(nc_plot - 1, int(round(((a + b) * 0.5 + 180.0) / dx - 0.5)))) + i0 = i1 = i + return slice(i0, i1 + 1) + + if not wraps: + sl = one_slice(lo, hi) + return [sl] if sl is not None else [] + out: List[slice] = [] + sl1 = one_slice(lo, 180.0) + sl2 = one_slice(-180.0, hi) + if sl1 is not None: + out.append(sl1) + if sl2 is not None: + out.append(sl2) + return out + + print(f"Building tile map from catchment.def boxes: plot {nc_plot}x{nr_plot}") + for k in range(ncat): + js = lat_slice(float(minlat[k]), float(maxlat[k])) + if js is None: + continue + for is_ in lon_slices(float(minlon[k]), float(maxlon[k])): + tile_id[js, is_] = k + 1 + if (k + 1) % max(1, ncat // 10) == 0 or k == ncat - 1: + print(f" catchment boxes {k + 1}/{ncat}") + + if cache: + cache.parent.mkdir(parents=True, exist_ok=True) + np.savez_compressed( + cache, + tile_id=tile_id, + meta={ + "source": "catchment.def", + "ncat": ncat, + "nc_plot": nc_plot, + "nr_plot": nr_plot, + "catchment_def": str(cdef.resolve()), + "catchment_size": int(cdef.stat().st_size), + }, + ) + print(f"Wrote catchment.def tile-map cache: {cache}") + return tile_id + + +def catchment_spatial_match_fraction(tile_id: np.ndarray, base_dir: Path, lon: np.ndarray, lat: np.ndarray, ncat: int, max_samples: int = 200000) -> float: + """Return fraction of sampled tile_id cells whose lon/lat falls in its catchment.def box.""" + valid = (tile_id >= 1) & (tile_id <= ncat) + rows, cols = np.where(valid) + if rows.size == 0: + return 0.0 + if rows.size > max_samples: + step = int(math.ceil(rows.size / float(max_samples))) + rows = rows[::step] + cols = cols[::step] + ids = tile_id[rows, cols].astype(np.int64) - 1 + cdef = load_ascii_table(base_dir / "catchment.def", skiprows=1, min_cols=6)[:ncat] + minlon = cdef[:, 2].astype(float) + maxlon = cdef[:, 3].astype(float) + minlat = cdef[:, 4].astype(float) + maxlat = cdef[:, 5].astype(float) + x = lon[cols] + y = lat[rows] + tol_lon = 360.0 / float(lon.size) + 1e-6 + tol_lat = 180.0 / float(lat.size) + 1e-6 + inlat = (y >= minlat[ids] - tol_lat) & (y <= maxlat[ids] + tol_lat) + normal = minlon[ids] <= maxlon[ids] + inlon_normal = (x >= minlon[ids] - tol_lon) & (x <= maxlon[ids] + tol_lon) + inlon_wrap = (x >= minlon[ids] - tol_lon) | (x <= maxlon[ids] + tol_lon) + inlon = np.where(normal, inlon_normal, inlon_wrap) + return float(np.count_nonzero(inlat & inlon)) / float(rows.size) + + +def build_fractional_sparse_from_rst( + rst_file: Path, + nc: int, + nr: int, + ncat: int, + nc_out: int, + nr_out: int, + layout: F77Layout, + cache: Optional[Path] = None, +): + if sp_sparse is None: + raise ClsmPlotError("scipy.sparse is required for fractional movie aggregation") + if cache and cache.exists(): + print(f"Reading cached fractional mapping: {cache}") + return sp_sparse.load_npz(cache) + if nc % nc_out != 0 or nr % nr_out != 0: + raise ClsmPlotError( + f"NC/NR must be integer multiples of movie grid. Got NC={nc}, NR={nr}, movie={nc_out}x{nr_out}." + ) + dx = nc // nc_out + dy = nr // nr_out + row_idx: List[int] = [] + col_idx: List[int] = [] + weight: List[float] = [] + print(f"Building fractional mapping from {rst_file}: movie {nc_out}x{nr_out}, block {dx}x{dy}") + with FortranSequentialReader(rst_file, layout) as rdr: + for j in range(nr_out): + rows = np.empty((dy, nc), dtype=np.int32) + for jj in range(dy): + rows[jj, :] = rdr.read_array(np.int32, nc) + for i in range(nc_out): + subset = rows[:, i * dx:(i + 1) * dx].ravel() + valid = subset[(subset >= 1) & (subset <= ncat)] + if valid.size == 0: + continue + ids, counts = np.unique(valid, return_counts=True) + cell = j * nc_out + i + row_idx.extend([cell] * len(ids)) + col_idx.extend((ids - 1).astype(int).tolist()) + # IDL divides by the full block count, not only land count. + weight.extend((counts / float(subset.size)).astype(float).tolist()) + if (j + 1) % max(1, nr_out // 20) == 0 or j == nr_out - 1: + print(f" fractional rows {j + 1}/{nr_out}") + mat = sp_sparse.csr_matrix((weight, (row_idx, col_idx)), shape=(nc_out * nr_out, ncat), dtype=np.float32) + if cache: + cache.parent.mkdir(parents=True, exist_ok=True) + sp_sparse.save_npz(cache, mat) + print(f"Wrote fractional mapping cache: {cache}") + return mat + + +# ----------------------------------------------------------------------------- +# Plot helpers +# ----------------------------------------------------------------------------- + + +def _limits_to_extent(limits: Tuple[float, float, float, float]) -> Tuple[float, float, float, float]: + min_lat, min_lon, max_lat, max_lon = limits + return (min_lon, max_lon, min_lat, max_lat) + + +def crop_to_limits(grid: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits: Tuple[float, float, float, float]): + min_lat, min_lon, max_lat, max_lon = limits + lon_mask = (lon >= min_lon) & (lon <= max_lon) + lat_mask = (lat >= min_lat) & (lat <= max_lat) + if not lon_mask.any() or not lat_mask.any(): + return grid, lon, lat, _limits_to_extent(limits) + sub = grid[np.ix_(lat_mask, lon_mask)] + lon_sub = lon[lon_mask] + lat_sub = lat[lat_mask] + dx = 360.0 / lon.size + dy = 180.0 / lat.size + extent = (lon_sub[0] - dx / 2, lon_sub[-1] + dx / 2, lat_sub[0] - dy / 2, lat_sub[-1] + dy / 2) + return sub, lon_sub, lat_sub, extent + + +def centers_to_edges(a: np.ndarray) -> np.ndarray: + """Convert a 1-D regular center-coordinate array to edges.""" + a = np.asarray(a, dtype=float) + if a.size == 0: + return a + if a.size == 1: + # Fall back to a one-degree cell for pathological one-cell debug plots. + return np.asarray([a[0] - 0.5, a[0] + 0.5], dtype=float) + d = float(np.median(np.diff(a))) + return np.r_[a[0] - 0.5 * d, a + 0.5 * d] + + +def add_land_outline(ax, sub: np.ndarray, lon_sub: np.ndarray, lat_sub: np.ndarray, coastlines: bool, linewidth: float = 0.75) -> None: + """Draw a no-dependency land/ocean outline from the valid-data mask. + + IDL drew MAP_CONTINENTS on every panel. When Cartopy is unavailable or + --no-coastlines is used, the plots otherwise lose all continent outlines. + This mask-derived outline is not a political boundary dataset, but it gives + the same visual coast/land edge cue and works on Discover without extra + data downloads. + """ + if coastlines and ccrs is not None: + return + try: + good = np.isfinite(sub).astype(float) + if good.shape[0] < 2 or good.shape[1] < 2 or np.nanmax(good) <= 0: + return + ax.contour(lon_sub, lat_sub, good, levels=[0.5], colors="black", linewidths=linewidth) + except Exception: + pass + + +def add_horizontal_category_key( + fig: plt.Figure, + colors: np.ndarray, + labels: Sequence[str], + *, + x0: float = 0.16, + y0: float = 0.035, + width: float = 0.68, + height: float = 0.035, + label_size: float = 7.0, + title: str = "", + tick_rotation: float = 45.0, +) -> None: + """Add an IDL-style horizontal categorical color strip.""" + n = len(labels) + if n == 0: + return + key_ax = fig.add_axes([x0, y0, width, height]) + cmap = ListedColormap(np.asarray(colors[:n], dtype=np.float32)) + key_ax.imshow(np.arange(n, dtype=float)[None, :], cmap=cmap, aspect="auto", extent=[0, n, 0, 1], interpolation="nearest") + key_ax.set_yticks([]) + key_ax.set_xticks(np.arange(n) + 0.5) + key_ax.set_xticklabels(labels, rotation=tick_rotation, fontsize=label_size, ha="right", va="top") + key_ax.tick_params(axis="x", length=0, pad=3) + for spine in key_ax.spines.values(): + spine.set_linewidth(0.8) + if title: + key_ax.set_xlabel(title, fontsize=8, labelpad=4) + + +def read_rst_subset( + rst_file: Path, + nc: int, + nr: int, + layout: F77Layout, + limits: Tuple[float, float, float, float], +) -> Tuple[np.ndarray, np.ndarray, np.ndarray]: + """Read a lon/lat subset from a fixed-record F77 int32 raster. + + This is used for US-east.jpg. The IDL code reads the full-resolution rst + raster directly for that regional plot; using the globally downsampled map + creates blocky catchments and apparent leakage. + """ + min_lat, min_lon, max_lat, max_lon = limits + dx = 360.0 / float(nc) + dy = 180.0 / float(nr) + i1 = max(0, int(math.floor((min_lon + 180.0) / dx))) + i2 = min(nc - 1, int(math.ceil((max_lon + 180.0) / dx)) - 1) + j1 = max(0, int(math.floor((min_lat + 90.0) / dy))) + j2 = min(nr - 1, int(math.ceil((max_lat + 90.0) / dy)) - 1) + if i2 < i1 or j2 < j1: + raise ClsmPlotError(f"Invalid rst subset for limits={limits}") + width = i2 - i1 + 1 + height = j2 - j1 + 1 + dtype = np.dtype(layout.endian + "i4") + rec_bytes = layout.marker_bytes + nc * 4 + layout.marker_bytes + out = np.empty((height, width), dtype=np.int32) + with Path(rst_file).open("rb") as fh: + for jj, j in enumerate(range(j1, j2 + 1)): + fh.seek(j * rec_bytes + layout.marker_bytes + i1 * 4) + row = np.fromfile(fh, dtype=dtype, count=width) + if row.size != width: + raise ClsmPlotError(f"Short read from {rst_file} row {j}: got {row.size}, wanted {width}") + out[jj, :] = row.astype(np.int32, copy=False) + lon_sub = -180.0 + (np.arange(i1, i2 + 1) + 0.5) * dx + lat_sub = -90.0 + (np.arange(j1, j2 + 1) + 0.5) * dy + return out, lon_sub, lat_sub + + +def build_boundary_segments_from_tile_ids( + tile_ids: np.ndarray, + lon_sub: np.ndarray, + lat_sub: np.ndarray, + ncat: int, +) -> Tuple[List[Tuple[Tuple[float, float], Tuple[float, float]]], List[Tuple[Tuple[float, float], Tuple[float, float]]]]: + """Return vertical and horizontal catchment/coast boundary line segments. + + IDL's plot_tiles draws an oplot line at every pixel edge where the raster + category changes, including category-to-ocean edges. Baking one-pixel black + edges into a full-resolution image can vanish when the figure is resampled, + so draw true matplotlib line segments in lon/lat coordinates instead. + """ + valid = (tile_ids >= 1) & (tile_ids <= int(ncat)) + if tile_ids.size == 0: + return [], [] + lon_edges = centers_to_edges(lon_sub) + lat_edges = centers_to_edges(lat_sub) + v_segments: List[Tuple[Tuple[float, float], Tuple[float, float]]] = [] + h_segments: List[Tuple[Tuple[float, float], Tuple[float, float]]] = [] + # Vertical boundaries between neighboring columns. + diff_v = tile_ids[:, 1:] != tile_ids[:, :-1] + draw_v = diff_v & (valid[:, 1:] | valid[:, :-1]) + rows, cols = np.where(draw_v) + for r, c in zip(rows.tolist(), cols.tolist()): + x = float(lon_edges[c + 1]) + v_segments.append(((x, float(lat_edges[r])), (x, float(lat_edges[r + 1])))) + # Left/right outside edges where a valid cell borders the regional/ocean edge. + for r in range(tile_ids.shape[0]): + if valid[r, 0]: + x = float(lon_edges[0]) + v_segments.append(((x, float(lat_edges[r])), (x, float(lat_edges[r + 1])))) + if valid[r, -1]: + x = float(lon_edges[-1]) + v_segments.append(((x, float(lat_edges[r])), (x, float(lat_edges[r + 1])))) + # Horizontal boundaries between neighboring rows. + diff_h = tile_ids[1:, :] != tile_ids[:-1, :] + draw_h = diff_h & (valid[1:, :] | valid[:-1, :]) + rows, cols = np.where(draw_h) + for r, c in zip(rows.tolist(), cols.tolist()): + y = float(lat_edges[r + 1]) + h_segments.append(((float(lon_edges[c]), y), (float(lon_edges[c + 1]), y))) + # Bottom/top outside edges. + for c in range(tile_ids.shape[1]): + if valid[0, c]: + y = float(lat_edges[0]) + h_segments.append(((float(lon_edges[c]), y), (float(lon_edges[c + 1]), y))) + if valid[-1, c]: + y = float(lat_edges[-1]) + h_segments.append(((float(lon_edges[c]), y), (float(lon_edges[c + 1]), y))) + return v_segments, h_segments + + +def add_tile_boundary_lines(ax, tile_ids: np.ndarray, lon_sub: np.ndarray, lat_sub: np.ndarray, ncat: int, linewidth: float = 0.23) -> None: + v_segments, h_segments = build_boundary_segments_from_tile_ids(tile_ids, lon_sub, lat_sub, ncat) + if v_segments: + ax.add_collection(LineCollection(v_segments, colors="black", linewidths=linewidth, antialiaseds=False, zorder=5)) + if h_segments: + ax.add_collection(LineCollection(h_segments, colors="black", linewidths=linewidth, antialiaseds=False, zorder=5)) + + +def make_axes(fig: plt.Figure, nrows: int, ncols: int, idx: int, coastlines: bool): + if coastlines and ccrs is not None: + ax = fig.add_subplot(nrows, ncols, idx, projection=ccrs.PlateCarree()) + else: + ax = fig.add_subplot(nrows, ncols, idx) + return ax + + +def _nice_geo_ticks(lo: float, hi: float, is_lon: bool) -> np.ndarray: + """Return readable lon/lat tick locations for IDL-like map axes.""" + span = float(hi) - float(lo) + if span >= 300.0: + step = 60.0 + elif span >= 150.0: + step = 30.0 + elif span >= 70.0: + step = 15.0 + elif span >= 25.0: + step = 5.0 + elif span >= 10.0: + step = 2.0 + else: + step = 1.0 + start = math.ceil(float(lo) / step) * step + stop = math.floor(float(hi) / step) * step + ticks = np.arange(start, stop + 0.5 * step, step, dtype=float) + if ticks.size == 0: + ticks = np.asarray([lo, hi], dtype=float) + # Keep the full-domain endpoints when they are part of the requested map. + if is_lon: + if lo <= -179.999 and not np.isclose(ticks[0], -180.0): + ticks = np.r_[-180.0, ticks] + if hi >= 179.999 and not np.isclose(ticks[-1], 180.0): + ticks = np.r_[ticks, 180.0] + else: + if lo <= -89.999 and not np.isclose(ticks[0], -90.0): + ticks = np.r_[-90.0, ticks] + if hi >= 89.999 and not np.isclose(ticks[-1], 90.0): + ticks = np.r_[ticks, 90.0] + # Avoid too many labels in narrow panels. + if ticks.size > 9: + ticks = ticks[:: int(math.ceil(ticks.size / 9.0))] + return ticks + + +def _plain_lon_label(x: float) -> str: + x = float(x) + if abs(x) < 1e-9: + return "0°" + hemi = "E" if x > 0 else "W" + return f"{abs(x):g}°{hemi}" + + +def _plain_lat_label(y: float) -> str: + y = float(y) + if abs(y) < 1e-9: + return "0°" + hemi = "N" if y > 0 else "S" + return f"{abs(y):g}°{hemi}" + + +def decorate_geo( + ax, + limits: Tuple[float, float, float, float], + coastlines: bool, + show_xlabel: bool = True, + show_ylabel: bool = True, +) -> None: + min_lat, min_lon, max_lat, max_lon = limits + if coastlines and ccrs is not None and hasattr(ax, "set_extent"): + ax.set_extent([min_lon, max_lon, min_lat, max_lat], crs=ccrs.PlateCarree()) + ax.coastlines(linewidth=0.5) + try: + ax.add_feature(cfeature.BORDERS, linewidth=0.3) + except Exception: + pass + + # Cartopy axes do not show normal Matplotlib lon/lat ticks unless we + # explicitly set them. Without this, movie frames with --coastlines + # have coastlines but lose the longitude/latitude labels. + try: + xticks = _nice_geo_ticks(min_lon, max_lon, is_lon=True) + yticks = _nice_geo_ticks(min_lat, max_lat, is_lon=False) + ax.set_xticks(xticks, crs=ccrs.PlateCarree()) + ax.set_yticks(yticks, crs=ccrs.PlateCarree()) + if LongitudeFormatter is not None: + ax.xaxis.set_major_formatter(LongitudeFormatter(zero_direction_label=False)) + else: + ax.set_xticklabels([_plain_lon_label(x) for x in xticks]) + if LatitudeFormatter is not None: + ax.yaxis.set_major_formatter(LatitudeFormatter()) + else: + ax.set_yticklabels([_plain_lat_label(y) for y in yticks]) + ax.tick_params( + labelsize=7, + bottom=show_xlabel, labelbottom=show_xlabel, + left=show_ylabel, labelleft=show_ylabel, + top=False, right=False, + pad=2, + ) + ax.set_xlabel("Longitude" if show_xlabel else "", fontsize=8, labelpad=6) + ax.set_ylabel("Latitude" if show_ylabel else "", fontsize=8, labelpad=6) + try: + ax.gridlines( + xlocs=xticks, ylocs=yticks, draw_labels=False, + linewidth=0.25, color="0.35", alpha=0.35, linestyle="-", + ) + except Exception: + pass + except Exception: + # Coastlines are more important than labels; avoid failing plots if a + # particular Cartopy build cannot format projected tick labels. + pass + else: + ax.set_xlim(min_lon, max_lon) + ax.set_ylim(min_lat, max_lat) + ax.set_xlabel("Longitude" if show_xlabel else "", labelpad=6) + ax.set_ylabel("Latitude" if show_ylabel else "", labelpad=6) + ax.grid(True, linewidth=0.2, alpha=0.4) + try: + ax.set_aspect("equal", adjustable="box") + except Exception: + pass + +def plot_continuous_on_ax( + ax, + grid: np.ndarray, + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + title: str, + levels: Sequence[float], + color_ids: Optional[Sequence[int]] = None, + rgb: Optional[np.ndarray] = None, + coastlines: bool = False, + show_xlabel: bool = True, + show_ylabel: bool = True, + bad_color = "white", +): + sub, lon_sub, lat_sub, extent = crop_to_limits(grid, lon, lat, limits) + finite = np.isfinite(sub) + if finite.any(): + print(f" plot {title}: finite={int(finite.sum())}/{sub.size}, min={float(np.nanmin(sub)):.6g}, max={float(np.nanmax(sub)):.6g}") + else: + print(f" plot {title}: finite=0/{sub.size} -- output will be blank") + if rgb is not None: + cmap = ListedColormap(rgb) + else: + cmap = ListedColormap(PALETTE[np.asarray(color_ids or CONTINUOUS_COLOR_IDS)]) + levels_arr = np.asarray(levels, dtype=float) + # BoundaryNorm expects one more boundary than colors. IDL uses each listed + # level as a filled-contour break; extend one upper boundary if needed. + if len(levels_arr) == cmap.N: + step = levels_arr[-1] - levels_arr[-2] if len(levels_arr) > 1 else 1.0 + boundaries = np.r_[levels_arr, levels_arr[-1] + step] + else: + boundaries = levels_arr + norm = BoundaryNorm(boundaries, cmap.N, clip=True) + # Convert data to an explicit RGBA image before putting it + # on the axes. On Discover some Agg/pcolormesh combinations were producing + # blank-looking panels even though the arrays contained valid data. This + # follows the successful direct-image debug path. + cmap.set_bad(bad_color) + rgba = cmap(norm(np.ma.masked_invalid(sub))) + imshow_kwargs = dict( + origin="lower", + extent=extent, + interpolation="nearest", + aspect="equal", + ) + if coastlines and ccrs is not None: + imshow_kwargs["transform"] = ccrs.PlateCarree() + ax.imshow(rgba, **imshow_kwargs) + add_land_outline(ax, sub, lon_sub, lat_sub, coastlines) + try: + ax.set_aspect("equal", adjustable="box") + except Exception: + pass + ax.set_title(title, fontsize=10, pad=10) + decorate_geo(ax, limits, coastlines, show_xlabel=show_xlabel, show_ylabel=show_ylabel) + sm = ScalarMappable(norm=norm, cmap=cmap) + sm.set_array([]) + return sm + + +def plot_indexed_on_ax( + ax, + grid: np.ndarray, + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + title: str, + classes: Sequence[int], + colors: Sequence[Sequence[float]] | np.ndarray, + labels: Optional[Sequence[str]] = None, + coastlines: bool = False, + show_xlabel: bool = True, + show_ylabel: bool = True, +): + sub, lon_sub, lat_sub, extent = crop_to_limits(grid, lon, lat, limits) + finite = np.isfinite(sub) + if finite.any(): + vals = np.unique(sub[finite]) + print(f" plot {title}: finite={int(finite.sum())}/{sub.size}, unique={vals.size}, first={vals[:8]}") + else: + print(f" plot {title}: finite=0/{sub.size} -- output will be blank") + cls = np.asarray(classes) + idx_grid = np.full(sub.shape, np.nan, dtype=np.float32) + for k, value in enumerate(cls): + idx_grid[sub == value] = k + cmap = ListedColormap(np.asarray(colors, dtype=np.float32)) + norm = BoundaryNorm(np.arange(-0.5, len(cls) + 0.5, 1.0), cmap.N) + cmap.set_bad("white") + rgba = cmap(norm(np.ma.masked_invalid(idx_grid))) + imshow_kwargs = dict( + origin="lower", + extent=extent, + interpolation="nearest", + aspect="equal", + ) + if coastlines and ccrs is not None: + imshow_kwargs["transform"] = ccrs.PlateCarree() + ax.imshow(rgba, **imshow_kwargs) + add_land_outline(ax, sub, lon_sub, lat_sub, coastlines) + try: + ax.set_aspect("equal", adjustable="box") + except Exception: + pass + ax.set_title(title, fontsize=10, pad=10) + decorate_geo(ax, limits, coastlines, show_xlabel=show_xlabel, show_ylabel=show_ylabel) + sm = ScalarMappable(norm=norm, cmap=cmap) + sm.set_array([]) + if labels: + cbar = plt.colorbar(sm, ax=ax, shrink=0.75, pad=0.02, ticks=np.arange(len(cls))) + cbar.ax.set_yticklabels(labels) + return sm + + +def save_fig(fig: plt.Figure, outpath: Path, dpi: Optional[int] = None) -> None: + """Save a static plot with package-wide DPI/JPEG quality settings.""" + outpath.parent.mkdir(parents=True, exist_ok=True) + use_dpi = int(PLOT_DPI if dpi is None else dpi) + kwargs = dict(dpi=use_dpi, bbox_inches="tight", facecolor="white") + if outpath.suffix.lower() in (".jpg", ".jpeg"): + kwargs["pil_kwargs"] = {"quality": int(JPEG_QUALITY), "optimize": True} + try: + fig.savefig(outpath, **kwargs) + except TypeError: + # Older Matplotlib builds may not support pil_kwargs. + kwargs.pop("pil_kwargs", None) + fig.savefig(outpath, **kwargs) + plt.close(fig) + print(f"Wrote {outpath}") + + +def panel_continuous( + grids: Sequence[np.ndarray], + titles: Sequence[str], + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + outpath: Path, + ncols: int, + levels_list: Sequence[Sequence[float]], + color_ids_list: Optional[Sequence[Sequence[int]]] = None, + rgb_list: Optional[Sequence[np.ndarray]] = None, + figsize: Tuple[float, float] = (10, 8), + coastlines: bool = False, + bad_color = "white", +) -> None: + n = len(grids) + nrows = int(math.ceil(n / ncols)) + # Multi-panel products need more vertical real estate than the default + # Matplotlib layout, especially once each panel has its own colorbar. + # Make this global rather than only fixing cti.jpg. This prevents titles + # such as POROS/COND/T2m from colliding with the axis labels of the panel + # above. + compact_two_column = (ncols == 2 and n in (4, 6)) + if compact_two_column: + # 4-panel (SoilAlb) and 6-panel (soil_param) global maps were + # visually too tall because Cartopy/geographic aspect makes each map + # panel wide and shallow. Use explicit compact figure heights for + # these layouts instead of the generic multi-panel height rule. + if n == 4: + figsize = (max(figsize[0], 12.0), 5.6) + else: # n == 6 + figsize = (max(figsize[0], 12.2), 7.35) + elif nrows > 1: + # Keep enough room for titles/colorbars, but avoid very large gaps. + min_h_per_row = 3.35 if ncols <= 2 else 2.85 + figsize = (max(figsize[0], 9.5 if ncols == 1 else figsize[0]), max(figsize[1], min_h_per_row * nrows)) + fig = plt.figure(figsize=figsize) + if compact_two_column: + fig.subplots_adjust(hspace=0.12, wspace=0.18, top=0.955, bottom=0.105, left=0.070, right=0.985) + elif nrows > 1: + hspace = 0.46 if ncols <= 2 else 0.34 + wspace = 0.20 if ncols > 1 else 0.14 + fig.subplots_adjust(hspace=hspace, wspace=wspace, top=0.965, bottom=0.085, left=0.075, right=0.975) + last_im = None + for k, grid in enumerate(grids): + ax = make_axes(fig, nrows, ncols, k + 1, coastlines) + row = k // ncols + col = k % ncols + show_xlabel = row == (nrows - 1) + show_ylabel = col == 0 + last_im = plot_continuous_on_ax( + ax, + grid, + lon, + lat, + limits, + titles[k], + levels=levels_list[k], + color_ids=(color_ids_list[k] if color_ids_list is not None else None), + rgb=(rgb_list[k] if rgb_list is not None else None), + coastlines=coastlines, + show_xlabel=show_xlabel, + show_ylabel=show_ylabel, + bad_color=bad_color, + ) + cbar = fig.colorbar(last_im, ax=ax, shrink=0.65, pad=0.02) + cbar.ax.tick_params(labelsize=7) + save_fig(fig, outpath) + + +# ----------------------------------------------------------------------------- +# Plot products translated from clsm_plots.pro +# ----------------------------------------------------------------------------- + +def plot_tiles( + tile_id: np.ndarray, + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + outdir: Path, + coastlines: bool, + rst_file: Optional[Path] = None, + nc_full: Optional[int] = None, + nr_full: Optional[int] = None, + ncat: Optional[int] = None, + layout: Optional[F77Layout] = None, + gfile: str = "", +) -> None: + n_levels = 30 + colors = PALETTE[np.arange(90, 90 + n_levels)] + + if nc_full is not None and nr_full is not None: + raster_res = max(int(nc_full), int(nr_full)) + else: + raster_res = 0 + + rst_name = str(rst_file).upper() if rst_file is not None else "" + grid_name = f"{gfile} {rst_name}".upper() + + is_ease = "EASE" in grid_name + is_ease_m01 = is_ease and "M01" in grid_name + is_ease_m03 = is_ease and "M03" in grid_name + + # Cubed-sphere logical resolution. + # Examples: + # CF0180x6C_DE1440xPE0720 + # CF2880x6C_CF2880x6C + # CF2160x6C-SG001_CF2160x6C + m_cf = re.search(r"CF0*([0-9]+)X6C", grid_name) + cf_res = int(m_cf.group(1)) if m_cf else 0 + + # Lat-lon / data-ocean style names. + # Examples: + # DC0288xPC0181_DE0360xPE0180 + # DE1440xPE0720 + is_latlon = bool( + re.search(r"(?:DC|DE)0*[0-9]+X(?:PC|PE)0*[0-9]+", grid_name) + ) + + if is_ease_m01: + # EASE 1-km: tight zoom. + us_east_limits = (38.35, -76.45, 38.75, -75.95) + + elif is_ease_m03: + # EASE 3-km: moderate zoom. + us_east_limits = (38.0, -77.2, 39.2, -75.4) + + elif is_ease: + # EASE M09/M25/M36 and any other EASE not explicitly zoomed. + us_east_limits = (35.0, -82.0, 42.0, -73.0) + + elif cf_res > 0 and cf_res <= 720: + # C12 through C720: broad region, like original IDL. + us_east_limits = (35.0, -82.0, 42.0, -73.0) + + elif cf_res >= 5760: + # C5760: tight Chesapeake zoom. + us_east_limits = (38.35, -76.45, 38.75, -75.95) + + elif cf_res >= 2160: + # C2160/C2880/C3072 and fine stretched. + us_east_limits = (38.0, -76.8, 39.0, -75.6) + + elif cf_res >= 768: + # C768/C1000/C1080/C1120/C1152/C1440/C1536. + us_east_limits = (37.6, -77.2, 39.2, -75.4) + + elif is_latlon: + # Lat-lon b/c/d/e grids: broad region. + us_east_limits = (35.0, -82.0, 42.0, -73.0) + + else: + # Preserve IDL-like behavior for unrecognized grids/res. + # Do NOT fall back to raster_res-based zoom here. + us_east_limits = (35.0, -82.0, 42.0, -73.0) + + print( + f" plot US-east catchment tile zoom: " + f"gfile={gfile}, cf_res={cf_res}, is_latlon={is_latlon}, " + f"raster_res={raster_res}, limits={us_east_limits}" + ) + if rst_file is not None and nc_full is not None and nr_full is not None and ncat is not None and layout is not None: + sub_id, lon_sub, lat_sub = read_rst_subset(Path(rst_file), int(nc_full), int(nr_full), layout, us_east_limits) + valid = (sub_id >= 1) & (sub_id <= int(ncat)) + idx = np.full(sub_id.shape, np.nan, dtype=np.float32) + idx[valid] = (sub_id[valid] % n_levels).astype(np.float32) + cmap = ListedColormap(colors) + cmap.set_bad("white") + rgba = cmap(np.ma.masked_invalid(idx.astype(float) / max(1, n_levels - 1))) + dx = 360.0 / float(nc_full) + dy = 180.0 / float(nr_full) + extent = (lon_sub[0] - dx / 2, lon_sub[-1] + dx / 2, lat_sub[0] - dy / 2, lat_sub[-1] + dy / 2) + fig = plt.figure(figsize=(7.0, 5.0)) + ax = make_axes(fig, 1, 1, 1, coastlines) + imshow_kwargs = dict(origin="lower", extent=extent, interpolation="nearest", aspect="equal", zorder=1) + if coastlines and ccrs is not None: + imshow_kwargs["transform"] = ccrs.PlateCarree() + ax.imshow(rgba, **imshow_kwargs) + + # Boundary linewidth is grid/resolution dependent. + # Coarse grids need visible borders so same-color neighboring tiles + # are still separable. Fine zooms need thinner borders. + if is_ease_m01: + tile_boundary_linewidth = 0.10 + elif is_ease_m03: + tile_boundary_linewidth = 0.16 + elif is_ease: + tile_boundary_linewidth = 0.23 + + elif cf_res > 0 and cf_res <= 720: + tile_boundary_linewidth = 0.23 + elif cf_res >= 5760: + tile_boundary_linewidth = 0.08 + elif cf_res >= 2160: + tile_boundary_linewidth = 0.12 + elif cf_res >= 768: + tile_boundary_linewidth = 0.16 + + elif is_latlon: + tile_boundary_linewidth = 0.23 + + else: + tile_boundary_linewidth = 0.23 + + if tile_boundary_linewidth > 0.0: + add_tile_boundary_lines( + ax, sub_id, lon_sub, lat_sub, int(ncat), + linewidth=tile_boundary_linewidth + ) + + decorate_geo(ax, us_east_limits, coastlines) + ax.grid(False) + ax.set_title("Catchment tiles", fontsize=10, pad=8) + save_fig(fig, outdir / "US-east.jpg") + return + + # Fallback for unusual runs where the rst file is unavailable. + grid = np.full(tile_id.shape, np.nan, dtype=np.float32) + mask = tile_id > 0 + grid[mask] = tile_id[mask] % n_levels + fig = plt.figure(figsize=(7.0, 5.0)) + ax = make_axes(fig, 1, 1, 1, coastlines) + plot_indexed_on_ax(ax, grid, lon, lat, us_east_limits, "Catchment tiles", np.arange(n_levels), colors, coastlines=coastlines) + save_fig(fig, outdir / "US-east.jpg") + +def plot_country_codes(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "country_and_state_code.data" + if not path.exists(): + print(f"Skipping country codes; missing {path}") + return + # File has numeric columns followed by text labels such as UNK; read only + # the first three numeric columns instead of np.loadtxt-ing the whole row. + rows = np.genfromtxt(path, comments="#", usecols=(0, 1, 2), dtype=np.float64, invalid_raise=False) + if rows.ndim == 1: + rows = rows.reshape(1, -1) + if rows.shape[1] < 3: + raise ClsmPlotError(f"{path} has fewer than three numeric columns") + ncat = int(np.nanmax(tile_id)) + if rows.shape[0] < ncat: + print(f"WARNING: {path} has {rows.shape[0]} rows but tile map references {ncat} tiles") + cnt = rows[:ncat, 1].astype(np.float32) + st = rows[:ncat, 2].astype(np.float32) + us = cnt == 243 + cnt[us] = st[us] + cnt[cnt == 257] = np.nan + grid = vector_to_grid(tile_id, cnt + 1) + # Use a reproducible random-looking palette for up to 256 codes. + rng = np.random.default_rng(12345) + colors = rng.random((256, 3)) + colors[0] = 0 + colors[-1] = 1 + fig = plt.figure(figsize=(10, 5)) + ax = make_axes(fig, 1, 1, 1, coastlines) + sub, lon_sub, lat_sub, extent = crop_to_limits(grid, lon, lat, limits) + finite = np.isfinite(sub) + if finite.any(): + vals = np.unique(sub[finite]) + print(f" plot Country / state codes: finite={int(finite.sum())}/{sub.size}, unique={vals.size}, first={vals[:8]}") + else: + print(f" plot Country / state codes: finite=0/{sub.size} -- output will be blank") + cmap = ListedColormap(colors) + cmap.set_bad("white") + # Wrap arbitrary numeric country/state codes into the available palette for + # a stable categorical image. The exact colors do not need to encode the + # numeric magnitude. + idx = np.full(sub.shape, np.nan, dtype=np.float32) + good = np.isfinite(sub) + idx[good] = (sub[good].astype(np.int64) % colors.shape[0]).astype(np.float32) + norm = BoundaryNorm(np.arange(-0.5, colors.shape[0] + 0.5, 1.0), cmap.N) + rgba = cmap(norm(np.ma.masked_invalid(idx))) + ax.imshow(rgba, origin="lower", extent=extent, interpolation="nearest", aspect="equal") + try: + ax.set_aspect("equal", adjustable="box") + except Exception: + pass + ax.set_title("Country / state codes") + decorate_geo(ax, limits, coastlines) + save_fig(fig, outdir / "Country_codes.jpg") + + +def plot_cti(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "cti_stats.dat" + rows = load_ascii_table(path, skiprows=1, min_cols=7) + cti_mean = rows[:, 2].astype(np.float32) + cti_std = rows[:, 3].astype(np.float32) + cti_skew = rows[:, 6].astype(np.float32) + if not (base_dir / "CLM_veg_typs_fracs").exists(): + cti_mean = 0.961 * cti_mean - 1.957 + grids = [vector_to_grid(tile_id, v) for v in (cti_mean, cti_std, cti_skew)] + levels = [np.linspace(6.0, 14.0, 17), np.linspace(0.0, 4.0, 17), np.linspace(-2.5, 2.5, 17)] + panel_continuous( + grids, ["CTI mean", "CTI std", "CTI skew"], lon, lat, limits, outdir / "cti.jpg", + ncols=1, levels_list=levels, figsize=(10.4, 10.1), coastlines=coastlines, + ) + + +def plot_mosaic(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "mosaic_veg_typs_fracs" + rows = load_ascii_table(path, min_cols=3) + mos_type = rows[:, 2].astype(int) + grid = vector_to_grid(tile_id, mos_type) + vtypes = [1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 14, 20, 30, 40, 50, 60, 70, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 210, 220, 230] + r = [233, 255, 255, 255, 210, 0, 0, 0, 204, 170, 255, 220, 205, 0, 0, 170, 0, 40, 120, 140, 190, 150, 255, 255, 0, 0, 0, 195, 255, 0, 255, 0] + g = [23, 131, 191, 255, 255, 255, 155, 0, 204, 240, 255, 240, 205, 100, 160, 200, 60, 100, 130, 160, 150, 100, 180, 235, 120, 150, 220, 20, 245, 70, 255, 0] + b = [0, 0, 0, 178, 255, 255, 255, 200, 204, 240, 100, 100, 102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50, 175, 90, 120, 130, 0, 215, 200, 255, 0] + colors = _as_rgb(list(zip(r, g, b))) + fig = plt.figure(figsize=(10.8, 5.4)) + fig.subplots_adjust(bottom=0.20, top=0.93) + ax = make_axes(fig, 1, 1, 1, coastlines) + plot_indexed_on_ax(ax, grid, lon, lat, limits, "Mosaic primary vegetation type", vtypes, colors, labels=None, coastlines=coastlines) + # The IDL map uses the full vtypes color table, but the legend intentionally + # labels only the six broad mosaic classes. + mos_labels = ["BL Evergreen", "BL Deciduous", "Needleleaf", "Grassland", "BL Shrubs", "Dwarf"] + add_horizontal_category_key(fig, colors[:6], mos_labels, x0=0.33, y0=0.050, width=0.36, height=0.026, label_size=7, tick_rotation=45.0) + save_fig(fig, outdir / "mosaic_prim.jpg") + +def _read_clm_rows(base_dir: Path) -> Optional[np.ndarray]: + path = base_dir / "CLM_veg_typs_fracs" + if not path.exists(): + print(f"Skipping CLM/Catchment-CN vegetation plots; missing {path}") + return None + return load_ascii_table(path, min_cols=12) + + +def plot_clm(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + rows = _read_clm_rows(base_dir) + if rows is None: + return + clm = rows[:, [10, 11]].astype(int) + colors = _as_rgb(list(zip( + [255,106,202,251,0,29,77,109,142,233,255,255,127,164,217,204,0], + [245,91,178,154,85,115,145,165,185,23,131,191,39,53,72,204,70], + [215,154,214,153,0,0,0,0,13,0,0,0,4,3,1,204,200], + ))) + classes = list(range(1, 18)) + labels = ["BARE", "NLEt", "NLEB", "NLDB", "BLET", "BLEt", "BLDT", "BLDt", "BLDB", "BLEtS", "BLDtS", "BLDBS", "AC3G", "CC3G", "WC4G", "CROP"] + for idx, name in enumerate(["PRIM", "SEC"]): + grid = vector_to_grid(tile_id, clm[:, idx]) + fig = plt.figure(figsize=(10, 6)) + ax = make_axes(fig, 1, 1, 1, coastlines) + fig.subplots_adjust(bottom=0.18, top=0.92) + plot_indexed_on_ax(ax, grid, lon, lat, limits, f"CLM {name} vegetation type", classes, colors, labels=None, coastlines=coastlines) + add_horizontal_category_key(fig, colors[:len(labels)], labels, x0=0.16, y0=0.045, width=0.68, height=0.026, label_size=7, tick_rotation=45.0) + save_fig(fig, outdir / f"CLM_{name}_veg_typs.jpg") + + +def plot_carbon(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + rows = _read_clm_rows(base_dir) + if rows is None: + return + cn = rows[:, [2, 3, 4, 5]].astype(int) + colors = _as_rgb(list(zip( + [106,202,251,0,29,77,109,142,233,255,255,255,127,164,164,217,217,204,104,0], + [91,178,154,85,115,145,165,185,23,131,131,191,39,53,53,72,72,204,104,70], + [154,214,153,0,0,0,0,13,0,0,200,0,4,3,200,1,200,204,200,200], + ))) + classes = list(range(1, 21)) + labels = ["NLEt", "NLEB", "NLDB", "BLET", "BLEt", "BLDT", "BLDt", "BLDB", "BLEtS", "BLDtS", "BLDtSm", "BLDBS", "AC3G", "CC3G", "CC3Gm", "WC4G", "WC4Gm", "CROP", "CROPm"] + for label, cols in [("PRIM", [0, 1]), ("SEC", [2, 3])]: + fig = plt.figure(figsize=(12.0, 8.6)) + fig.subplots_adjust(hspace=0.16, bottom=0.17, top=0.955, left=0.06, right=0.98) + for k, c in enumerate(cols): + ax = make_axes(fig, 2, 1, k + 1, coastlines) + grid = vector_to_grid(tile_id, cn[:, c]) + plot_indexed_on_ax(ax, grid, lon, lat, limits, f"Catchment-CN {label} vegetation {k + 1}", classes, colors, labels=None, coastlines=coastlines, show_xlabel=(k == 1)) + add_horizontal_category_key(fig, colors[:len(labels)], labels, x0=0.16, y0=0.055, width=0.68, height=0.026, label_size=7, tick_rotation=45.0) + save_fig(fig, outdir / f"CatchmentCN_{label}_veg_typs.jpg") + + +def plot_ndep_t2m_soilalb(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "CLM_NDep_SoilAlb_T2m" + if not path.exists(): + print(f"Skipping NDep/T2m/SoilAlb; missing {path}") + return + rows = load_ascii_table(path, min_cols=7) + ndep, visdr, visdf, nirdr, nirdf, t2mm, t2mp = [rows[:, i].astype(np.float32) for i in range(7)] + grids = [vector_to_grid(tile_id, v) for v in (ndep, t2mm, t2mp)] + levels = [np.asarray(list(np.arange(15) * 4.0) + [65.0, 350.0]), np.linspace(250.0, 300.0, 17), np.linspace(250.0, 300.0, 17)] + panel_continuous(grids, ["NDep", "T2m mean", "T2m plus"], lon, lat, limits, outdir / "CLM_Ndep_T2m.jpg", ncols=1, levels_list=levels, figsize=(10.4, 9.8), coastlines=coastlines) + soilalb_grids = [vector_to_grid(tile_id, v) for v in (visdr, visdf, nirdr, nirdf)] + levels_alb = [np.linspace(0.0, 0.65, 17), np.linspace(0.0, 0.65, 17), np.linspace(0.0, 1.0, 17), np.linspace(0.0, 1.0, 17)] + panel_continuous(soilalb_grids, ["VISDR", "VISDF", "NIRDR", "NIRDF"], lon, lat, limits, outdir / "SoilAlb.jpg", ncols=2, levels_list=levels_alb, figsize=(10, 7), coastlines=coastlines) + + +def plot_soil(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "soil_param.dat" + rows = load_ascii_table(path, min_cols=10) + vals = { + "BEE": rows[:, 4].astype(np.float32), + "PSIS": rows[:, 5].astype(np.float32), + "POROS": rows[:, 6].astype(np.float32), + "COND": rows[:, 7].astype(np.float32), + "WPWET": rows[:, 8].astype(np.float32), + "SOILDEPTH": rows[:, 9].astype(np.float32), + } + vlims = { + "BEE": (1.0, 8.0), + "PSIS": (-1.85, -0.1), + "POROS": (0.37, 0.8), + "COND": (2.37e-6, 2.845e-4), + "WPWET": (0.01, 0.45), + "SOILDEPTH": (1334.0, 5000.0), + } + grids, titles, levs = [], [], [] + for name in vals: + lo, hi = vlims[name] + if name == "POROS": + levels = np.r_[lo, lo + np.arange(15) * ((0.57 - lo) / 15.0), hi] + else: + levels = np.linspace(lo, hi, 17) + grids.append(vector_to_grid(tile_id, vals[name])) + titles.append(name) + levs.append(levels) + panel_continuous(grids, titles, lon, lat, limits, outdir / "soil_param.jpg", ncols=2, levels_list=levs, figsize=(11, 9), coastlines=coastlines) + + +def plot_elevation(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, coastlines: bool) -> None: + rows = load_ascii_table(base_dir / "catchment.def", skiprows=1, min_cols=7) + elevation = rows[:, 6].astype(np.float32) + grid = vector_to_grid(tile_id, elevation) + lo = float(np.nanmin(elevation)) + hi = float(np.nanmax(elevation)) + panel_continuous([grid], ["ELEVATION"], lon, lat, limits, outdir / "ELEVATION.jpg", ncols=1, levels_list=[np.linspace(lo, hi, 17)], figsize=(11.2, 5.6), coastlines=coastlines) + + +# ----------------------------------------------------------------------------- +# Time series LAI/GREEN/albedo readers and Z0 +# ----------------------------------------------------------------------------- + + +def read_timeseries_record(rdr, ncat: int) -> Tuple[np.ndarray, np.ndarray]: + if isinstance(rdr, TimeSeriesReader): + return rdr.read_record() + header = rdr.read_array(np.float32, 9) + values = rdr.read_array(np.float32, ncat) + return header, values + + +def _doy_from_header_part(yroff: float, month: float, day: float) -> float: + y = 2001 + int(round(float(yroff))) + m = max(1, min(12, int(round(float(month))))) + d = max(1, min(31, int(round(float(day))))) + dt = _dt.date(y, m, d) + return float((dt - _dt.date(2000, 12, 31)).days) + + +def midpoint_doy(header: np.ndarray) -> float: + start = _doy_from_header_part(header[0], header[1], header[2]) + end = _doy_from_header_part(header[6], header[7], header[8]) + return (end - start) / 2.0 + start + + +def _sanitize_lai(values: np.ndarray, *, max_lai: float = 12.0) -> np.ndarray: + """Return LAI with impossible/fill values masked as NaN. + + LAI in these climatology files should be non-negative and normally below + about 8. Use 12 as a conservative upper bound so real dense-canopy values + are retained while bad extrapolated/fill values do not contaminate Z0. + """ + out = np.asarray(values, dtype=np.float32).copy() + bad = (~np.isfinite(out)) | (out < 0.0) | (out > max_lai) | (np.abs(out) > 1.0e10) + out[bad] = np.nan + return out + + +def _sanitize_ndvi(values: np.ndarray) -> np.ndarray: + """Return NDVI with impossible/fill values masked as NaN.""" + out = np.asarray(values, dtype=np.float32).copy() + bad = (~np.isfinite(out)) | (out < -0.1) | (out > 1.1) | (np.abs(out) > 1.0e10) + out[bad] = np.nan + # Keep a very small tolerance for files with roundoff; clip to physical range. + out = np.where(np.isfinite(out), np.clip(out, 0.0, 1.0), np.nan).astype(np.float32) + return out + + +def _sanitize_fraction(values: np.ndarray) -> np.ndarray: + """Return generic fractional fields (GREEN/albedo) in 0..1 with fill values masked.""" + out = np.asarray(values, dtype=np.float32).copy() + bad = (~np.isfinite(out)) | (out < -0.01) | (out > 1.01) | (np.abs(out) > 1.0e10) + out[bad] = np.nan + out = np.where(np.isfinite(out), np.clip(out, 0.0, 1.0), np.nan).astype(np.float32) + return out + + +def _sanitize_z0_mm(values: np.ndarray, *, max_mm: float = 10000.0) -> np.ndarray: + """Mask impossible roughness length values in millimeters.""" + out = np.asarray(values, dtype=np.float32).copy() + bad = (~np.isfinite(out)) | (out < 0.0) | (out > max_mm) | (np.abs(out) > 1.0e20) + out[bad] = np.nan + return out + + +def _initial_loop_year_offset(h1: np.ndarray, h2: np.ndarray) -> int: + """Mimic the IDL loop's active year variable after the second header read. + + In clsm_plots.pro, the variable ``yr`` is overwritten by the *second* header + before the month/day loop starts. For files whose first interval is late + Dec -> Jan, using the first header's year makes January a full year too + early and causes large negative extrapolated LAI. Use h2[0] here to match + IDL's state at loop entry. + """ + return int(round(float(h2[0]))) + + +def _advance_loop_year_offset(header: np.ndarray, month: int) -> int: + yoff = int(round(float(header[0]))) + # IDL has: if((month eq 12) and (yr eq 2)) then yr = yr -1 + if month == 12 and yoff == 2: + yoff -= 1 + return yoff + + +def _valid_weighted_monthly_add(total: np.ndarray, count: np.ndarray, month_index: int, vals: np.ndarray) -> None: + good = np.isfinite(vals) + if np.any(good): + total[month_index, good] += vals[good].astype(np.float64) + count[month_index, good] += 1.0 + + +def monthly_means_from_interpolated(path: Path, ncat: int, layout: TimeSeriesLayout, kind: str = "raw") -> np.ndarray: + mdays = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] + total = np.zeros((12, ncat), dtype=np.float64) + count = np.zeros((12, ncat), dtype=np.float64) + if not path.exists(): + raise ClsmPlotError(f"Missing time series file: {path}") + with TimeSeriesReader(path, layout, ncat) as rdr: + h1, v1 = read_timeseries_record(rdr, ncat) + h2, v2 = read_timeseries_record(rdr, ncat) + b4 = midpoint_doy(h1) + nxt = midpoint_doy(h2) + current_year_offset = _initial_loop_year_offset(h1, h2) + for month in range(1, 13): + for day in range(1, mdays[month - 1] + 1): + now = float((_dt.date(2001 + current_year_offset, month, day) - _dt.date(2000, 12, 31)).days) + denom = (nxt - b4) if abs(nxt - b4) > 1e-6 else 1.0 + fac1 = (now - b4) / denom + fac2 = (nxt - now) / denom + vals = (fac1 * v2 + fac2 * v1).astype(np.float32) + if kind.lower() == "lai": + vals = _sanitize_lai(vals) + elif kind.lower() == "ndvi": + vals = _sanitize_ndvi(vals) + elif kind.lower() in ("fraction", "green", "albedo"): + vals = _sanitize_fraction(vals) + else: + vals = np.where(np.isfinite(vals), vals, np.nan).astype(np.float32) + _valid_weighted_monthly_add(total, count, month - 1, vals) + if now + 0.5 >= nxt: + v1 = v2 + b4 = nxt + try: + h2, v2 = read_timeseries_record(rdr, ncat) + nxt = midpoint_doy(h2) + current_year_offset = _advance_loop_year_offset(h2, month) + except EOFError: + nxt = now + 9999.0 + monthly = np.full((12, ncat), np.nan, dtype=np.float32) + good = count > 0.0 + monthly[good] = (total[good] / count[good]).astype(np.float32) + return monthly + + +def panel_continuous_shared_colorbar( + grids: Sequence[np.ndarray], + titles: Sequence[str], + lon: np.ndarray, + lat: np.ndarray, + limits: Tuple[float, float, float, float], + outpath: Path, + ncols: int, + levels: Sequence[float], + color_ids: Optional[Sequence[int]] = None, + rgb: Optional[np.ndarray] = None, + figsize: Tuple[float, float] = (13, 9), + coastlines: bool = False, + cbar_label: str = "", + cbar_ticks: Optional[Sequence[float]] = None, + cbar_ticklabels: Optional[Sequence[str]] = None, + cbar_tick_rotation: float = 90.0, + bad_color = "white", +) -> None: + """Multi-panel plot with one shared colorbar. + + This is better for LAI and Z0 where all panels use identical bins. + It avoids shrinking every map panel to make room for separate colorbars. + """ + n = len(grids) + nrows = int(math.ceil(n / ncols)) + fig = plt.figure(figsize=figsize) + fig.subplots_adjust(left=0.065, right=0.985, top=0.955, bottom=0.145, hspace=0.30, wspace=0.14) + last_im = None + for k, grid in enumerate(grids): + ax = make_axes(fig, nrows, ncols, k + 1, coastlines) + row = k // ncols + col = k % ncols + last_im = plot_continuous_on_ax( + ax, + grid, + lon, + lat, + limits, + titles[k], + levels=levels, + color_ids=color_ids, + rgb=rgb, + coastlines=coastlines, + show_xlabel=(row == nrows - 1), + show_ylabel=(col == 0), + bad_color=bad_color, + ) + if last_im is not None: + cax = fig.add_axes([0.14, 0.060, 0.72, 0.024]) + if cbar_ticks is not None: + tick_values = np.asarray(cbar_ticks, dtype=float) + cbar = fig.colorbar( + last_im, + cax=cax, + orientation="horizontal", + ticks=tick_values, + spacing="uniform", + ) + cbar.ax.xaxis.set_major_locator(FixedLocator(tick_values)) + if cbar_ticklabels is not None: + if len(cbar_ticklabels) != len(tick_values): + raise ClsmPlotError( + f"Colorbar label count {len(cbar_ticklabels)} does not match " + f"tick count {len(tick_values)} for {outpath}" + ) + cbar.ax.xaxis.set_major_formatter(FixedFormatter(list(cbar_ticklabels))) + else: + cbar = fig.colorbar(last_im, cax=cax, orientation="horizontal") + cbar.ax.tick_params(labelsize=7, rotation=cbar_tick_rotation, pad=4) + for label in cbar.ax.get_xticklabels(): + label.set_horizontalalignment("right" if abs(cbar_tick_rotation) > 1.0 else "center") + label.set_verticalalignment("top") + if cbar_label: + cbar.set_label(cbar_label, fontsize=8, labelpad=7) + save_fig(fig, outpath) + + +def plot_monthly_timeseries( + base_dir: Path, + tile_id: np.ndarray, + lon: np.ndarray, + lat: np.ndarray, + limits, + outdir: Path, + ncat: int, + filename: str, + outname: str, + product_label: str, + layout: Optional[TimeSeriesLayout], + coastlines: bool, + bad_color = NO_DATA_COLOR, + *, + kind: str = "raw", + levels: Sequence[float] = FRACTION_LEVELS, + rgb: np.ndarray = FRACTION_RGB, + cbar_label: str = "", + cbar_ticks: Optional[Sequence[float]] = None, + cbar_ticklabels: Optional[Sequence[str]] = None, +) -> None: + """Plot a 12-panel monthly climatology from a tile time-series file. + + This is the same machinery used by LAI. GREEN and NDVI are easy package + additions because they share the same F77 time-series layout already used + for GREEN.mp4 and merged_Z0 diagnostics. + """ + path = base_dir / filename + if not path.exists(): + print(f"Skipping {outname}; missing {path}") + return + if layout is None: + print(f"Skipping {outname}; could not determine time-series layout for {path}") + return + monthly = monthly_means_from_interpolated(path, ncat, layout, kind=kind) + names = ["JAN", "FEB", "MAR", "APR", "MAY", "JUN", "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"] + titles = [f"{mon}" for mon in names] + grids = [vector_to_grid(tile_id, monthly[m, :]) for m in range(12)] + panel_continuous_shared_colorbar( + grids, + titles, + lon, + lat, + limits, + outdir / outname, + ncols=3, + levels=levels, + rgb=rgb, + figsize=(13.5, 9.2), + coastlines=coastlines, + cbar_label=(cbar_label or product_label), + cbar_ticks=cbar_ticks, + cbar_ticklabels=cbar_ticklabels, + cbar_tick_rotation=0.0 if cbar_ticks is not None else 90.0, + bad_color=bad_color, + ) + + +def plot_lai(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, ncat: int, layout: Optional[TimeSeriesLayout], coastlines: bool) -> None: + plot_monthly_timeseries( + base_dir, tile_id, lon, lat, limits, outdir, ncat, + "lai.dat", "lai.jpg", "LAI", layout, coastlines, + kind="lai", levels=LAI_LEVELS, rgb=LAI_PLOT_RGB, cbar_label="LAI", + cbar_ticks=LAI_TICKS, + cbar_ticklabels=LAI_TICK_LABELS, + ) + + +def plot_green(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, ncat: int, layout: Optional[TimeSeriesLayout], coastlines: bool) -> None: + plot_monthly_timeseries( + base_dir, tile_id, lon, lat, limits, outdir, ncat, + "green.dat", "green.jpg", "GREEN", layout, coastlines, + kind="fraction", levels=FRACTION_LEVELS, rgb=FRACTION_RGB, + cbar_label="Green vegetation fraction", + cbar_ticks=FRACTION_TICKS, + cbar_ticklabels=FRACTION_TICK_LABELS, + ) + + +def plot_ndvi(base_dir: Path, tile_id: np.ndarray, lon: np.ndarray, lat: np.ndarray, limits, outdir: Path, ncat: int, layout: Optional[TimeSeriesLayout], coastlines: bool) -> None: + plot_monthly_timeseries( + base_dir, tile_id, lon, lat, limits, outdir, ncat, + "ndvi.dat", "ndvi.jpg", "NDVI", layout, coastlines, + kind="ndvi", levels=FRACTION_LEVELS, rgb=FRACTION_RGB, + cbar_label="NDVI", + cbar_ticks=FRACTION_TICKS, + cbar_ticklabels=FRACTION_TICK_LABELS, + ) + +def z0_value(z2ch: np.ndarray, lai: np.ndarray, scale4z0: float) -> np.ndarray: + min_veg_height = 0.01 + z0_by_zveg = 0.13 + if scale4z0 == 2.0: + return scale4z0 * z0_by_zveg * (z2ch - (z2ch - min_veg_height) * np.exp(-lai)) + return z0_by_zveg * (z2ch - scale4z0 * (z2ch - min_veg_height) * np.exp(-lai)) + + +def read_vegdyn(base_dir: Path, ncat: int, layout: F77Layout) -> Tuple[np.ndarray, np.ndarray, np.ndarray]: + path = base_dir / "vegdyn.data" + if not path.exists(): + raise ClsmPlotError(f"Missing vegdyn data: {path}") + if is_netcdf(path): + ity = read_nc_var(path, "ITY").reshape(-1).astype(np.float32) + z2 = read_nc_var(path, "Z2CH").reshape(-1).astype(np.float32) + asz0 = read_nc_var(path, "ASCATZ0").reshape(-1).astype(np.float32) + return ity[:ncat], z2[:ncat], asz0[:ncat] + with FortranSequentialReader(path, layout) as rdr: + ity = rdr.read_array(np.float32, ncat) + z2 = rdr.read_array(np.float32, ncat) + asz0 = rdr.read_array(np.float32, ncat) + return ity, z2, asz0 + + +def plot_canoph_from_vegdyn(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, ncat: int, layout: F77Layout, coastlines: bool) -> Tuple[np.ndarray, np.ndarray]: + _, z2, asz0 = read_vegdyn(base_dir, ncat, layout) + grid = vector_to_grid(tile_id, z2) + levels = np.linspace(float(np.nanmin(z2)), float(np.nanmax(z2)), 17) + panel_continuous([grid], ["Canopy height Z2CH"], lon, lat, limits, outdir / "Canopy_Height_onTiles.jpg", ncols=1, levels_list=[levels], color_ids_list=[list(reversed(CONTINUOUS_COLOR_IDS))], figsize=(11.2, 5.6), coastlines=coastlines) + return z2, asz0 * 1000.0 + + +def seasonal_z0_and_ndvi(base_dir: Path, ncat: int, z2ch: np.ndarray, scale4z0: float, lai_layout: TimeSeriesLayout, ndvi_layout: Optional[TimeSeriesLayout] = None) -> Tuple[np.ndarray, np.ndarray]: + lai_path = base_dir / "lai.dat" + ndvi_path = base_dir / "ndvi.dat" + if not lai_path.exists() or not ndvi_path.exists(): + raise ClsmPlotError(f"Missing {lai_path} or {ndvi_path}; required for icarus/merged Z0") + mdays = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] + # Accumulate valid daily means only. Invalid LAI/NDVI should not become + # zero roughness; otherwise it appears as artificial brown/underflow bins. + zo_sum = np.zeros((ncat, 4), dtype=np.float64) + zo_count = np.zeros((ncat, 4), dtype=np.float64) + ndvi_sum = np.zeros((ncat, 4), dtype=np.float64) + ndvi_count = np.zeros((ncat, 4), dtype=np.float64) + + if ndvi_layout is None: + ndvi_layout = lai_layout + with TimeSeriesReader(lai_path, lai_layout, ncat) as lai_rdr, TimeSeriesReader(ndvi_path, ndvi_layout, ncat) as ndvi_rdr: + lh1, lv1 = read_timeseries_record(lai_rdr, ncat) + lh2, lv2 = read_timeseries_record(lai_rdr, ncat) + nh1, nv1 = read_timeseries_record(ndvi_rdr, ncat) + nh2, nv2 = read_timeseries_record(ndvi_rdr, ncat) + lb4, lnxt = midpoint_doy(lh1), midpoint_doy(lh2) + nb4, nnxt = midpoint_doy(nh1), midpoint_doy(nh2) + current_year_offset = _initial_loop_year_offset(lh1, lh2) + for month in range(1, 13): + season = 0 if month in (12, 1, 2) else 1 if month in (3, 4, 5) else 2 if month in (6, 7, 8) else 3 + for day in range(1, mdays[month - 1] + 1): + now = float((_dt.date(2001 + current_year_offset, month, day) - _dt.date(2000, 12, 31)).days) + lden = (lnxt - lb4) if abs(lnxt - lb4) > 1e-6 else 1.0 + nden = (nnxt - nb4) if abs(nnxt - nb4) > 1e-6 else 1.0 + lai = ((now - lb4) / lden) * lv2 + ((lnxt - now) / lden) * lv1 + ndvi = ((now - nb4) / nden) * nv2 + ((nnxt - now) / nden) * nv1 + lai = _sanitize_lai(lai) + ndvi = _sanitize_ndvi(ndvi) + zot_m = 1000.0 * z0_value(z2ch, lai, scale4z0) + zot_m = _sanitize_z0_mm(zot_m) + + good_z = np.isfinite(zot_m) + if np.any(good_z): + zo_sum[good_z, season] += zot_m[good_z] + zo_count[good_z, season] += 1.0 + good_n = np.isfinite(ndvi) + if np.any(good_n): + ndvi_sum[good_n, season] += ndvi[good_n] + ndvi_count[good_n, season] += 1.0 + + if now + 0.5 >= lnxt: + lv1 = lv2 + lb4 = lnxt + try: + lh2, lv2 = read_timeseries_record(lai_rdr, ncat) + lnxt = midpoint_doy(lh2) + current_year_offset = _advance_loop_year_offset(lh2, month) + except EOFError: + lnxt = now + 9999.0 + if now + 0.5 >= nnxt: + nv1 = nv2 + nb4 = nnxt + try: + nh2, nv2 = read_timeseries_record(ndvi_rdr, ncat) + nnxt = midpoint_doy(nh2) + except EOFError: + nnxt = now + 9999.0 + zo_vec_mm = np.full((ncat, 4), np.nan, dtype=np.float32) + ndvi_vec = np.full((ncat, 4), np.nan, dtype=np.float32) + goodz = zo_count > 0.0 + goodn = ndvi_count > 0.0 + zo_vec_mm[goodz] = (zo_sum[goodz] / zo_count[goodz]).astype(np.float32) + ndvi_vec[goodn] = (ndvi_sum[goodn] / ndvi_count[goodn]).astype(np.float32) + return zo_vec_mm, ndvi_vec + + +def plot_z0(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, ncat: int, z2: np.ndarray, asz0_mm: np.ndarray, layout: Optional[TimeSeriesLayout], coastlines: bool, products: Sequence[str], ndvi_layout: Optional[TimeSeriesLayout] = None) -> None: + scale4z0 = 0.5 if (base_dir / "CLM_veg_typs_fracs").exists() else 2.0 + need_lai = any(p in ("icarus", "merged") for p in products) + zo_vec_mm = ndvi_vec = None + if need_lai: + if layout is None: + print("Skipping icarus/merged Z0: could not determine LAI/NDVI time-series layout") + else: + try: + zo_vec_mm, ndvi_vec = seasonal_z0_and_ndvi(base_dir, ncat, z2, scale4z0, layout, ndvi_layout) + except Exception as exc: + print(f"Skipping icarus/merged Z0: {exc}") + colors = Z0_COLOR_IDS + levels = Z0_LEVELS + sea_label = ["DJF", "MAM", "JJA", "SON"] + seasons_to_plot = [0, 2] + asz0_mm = _sanitize_z0_mm(asz0_mm) + for pname in products: + grids: List[np.ndarray] = [] + titles: List[str] = [] + for season in seasons_to_plot: + if pname == "ascat": + data = asz0_mm.copy() + elif pname == "icarus" and zo_vec_mm is not None: + data = _sanitize_z0_mm(zo_vec_mm[:, season]) + elif pname == "merged" and zo_vec_mm is not None and ndvi_vec is not None: + icarus = _sanitize_z0_mm(zo_vec_mm[:, season]) + ndvi = _sanitize_ndvi(ndvi_vec[:, season]) + data = icarus.copy() + # IDL uses ASZ0 where seasonal NDVI <= 0.2. Also use ASZ0 + # when NDVI or icarus is invalid so bad seasonal values do not + # appear as artificial lowest-bin/brown areas. + use_ascat = (~np.isfinite(data)) | (~np.isfinite(ndvi)) | (ndvi <= 0.2) + data[use_ascat] = asz0_mm[use_ascat] + data = _sanitize_z0_mm(data) + else: + continue + grids.append(vector_to_grid(tile_id, data)) + titles.append(f"{pname}: {sea_label[season]}") + if grids: + panel_continuous_shared_colorbar( + grids, + titles, + lon, + lat, + limits, + outdir / f"{pname}_Z0.jpg", + ncols=1, + levels=levels, + color_ids=colors, + figsize=(11.0, 8.0), + coastlines=coastlines, + cbar_label="Z0 (mm)", + cbar_ticks=Z0_LEVELS, + cbar_ticklabels=Z0_TICK_LABELS, + cbar_tick_rotation=45.0, + ) + + + +# ----------------------------------------------------------------------------- +# Irrigation products - NOT TESTED IN Python Package due to file unavailability. +# ----------------------------------------------------------------------------- + + +def plot_irrig_method(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "irrig.dat" + if not path.exists(): + print(f"Skipping irrigation method; missing {path}") + return + names = ["SPRINKLERFR", "DRIPFR", "FLOODFR"] + titles = ["SPRINKLER FRACTION", "DRIP FRACTION", "FLOOD FRACTION"] + grids = [] + for name in names: + vec = read_nc_var(path, name).reshape(-1).astype(np.float32) + vec[vec > 1.0] = np.nan + g = vector_to_grid(tile_id, vec) + g[g == 0.0] = np.nan + grids.append(g) + levels = [np.arange(21) * 0.05] * 3 + panel_continuous(grids, titles, lon, lat, limits, outdir / "IrrigMethod.png", ncols=1, levels_list=levels, color_ids_list=[list(range(140, 161))] * 3, figsize=(9, 11), coastlines=coastlines) + + +def plot_lai_minmax(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "irrig.dat" + if not path.exists(): + print(f"Skipping LAI min/max; missing {path}") + return + grids = [] + for name in ["LAIMIN", "LAIMAX"]: + vec = read_nc_var(path, name).reshape(-1).astype(np.float32) + vec[vec > 100.0] = np.nan + g = vector_to_grid(tile_id, vec) + g[g == 0.0] = np.nan + grids.append(g) + panel_continuous(grids, ["LAI Minimum", "LAI Maximum"], lon, lat, limits, outdir / "LAI_minmax.png", ncols=1, levels_list=[LAI_LEVELS, LAI_LEVELS], rgb_list=[LAI_PLOT_RGB, LAI_PLOT_RGB], figsize=(9, 11), coastlines=coastlines) + + +def plot_irrig_fractions(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, coastlines: bool) -> None: + path = base_dir / "irrig.dat" + if not path.exists(): + print(f"Skipping irrigation fractions; missing {path}") + return + names = ["IRRIGFRAC", "PADDYFRAC", "RAINFEDFRAC"] + titles = ["IRRIGATED CROP FRACTION", "PADDY FRACTION", "RAINFED FRACTION"] + grids = [] + for name in names: + vec = read_nc_var(path, name).reshape(-1).astype(np.float32) + vec[vec > 1.0] = np.nan + g = vector_to_grid(tile_id, vec) + g[g == 0.0] = np.nan + grids.append(g) + levels = [np.arange(21) * 0.025] * 3 + panel_continuous(grids, titles, lon, lat, limits, outdir / "GIA-Hybrid_IrrigFracs.png", ncols=1, levels_list=levels, color_ids_list=[list(range(140, 161))] * 3, figsize=(9, 11), coastlines=coastlines) + + +def _decode_crop_names(arr: np.ndarray) -> List[str]: + if arr.dtype.kind in {"S", "U"}: + return [str(x).strip(" b'\x00") for x in arr.reshape(-1)] + # xarray sometimes returns char arrays. Try joining along the last dimension. + if arr.ndim >= 2 and arr.dtype.kind in {"S", "U"}: + return ["".join(map(str, row)).strip() for row in arr.reshape(arr.shape[0], -1)] + return [f"crop_{i + 1:02d}" for i in range(26)] + + +def plot_crop_times(base_dir: Path, tile_id: np.ndarray, lon, lat, limits, outdir: Path, coastlines: bool) -> None: + """A compact Python version of plot_crop_times. + + The IDL routine creates multiple 4-row pages with crop fraction, planting + day, harvest day, and irrigation type for up to 26 crops. This version keeps + that structure but uses raster panels for fraction and scatter panels for DOY + and irrigation type. + """ + path = base_dir / "irrig.dat" + if not path.exists(): + print(f"Skipping crop times; missing {path}") + return + if xr is None: + print("Skipping crop times; xarray is unavailable") + return + with xr.open_dataset(path, decode_times=False) as ds: + required = ["IRRIGPLANT", "IRRIGHARVEST", "CROPIRRIGFRAC", "IRRIGTYPE"] + missing = [v for v in required if v not in ds] + if missing: + print(f"Skipping crop times; missing variables in {path}: {missing}") + return + plantv = np.asarray(ds["IRRIGPLANT"].values) + harvestv = np.asarray(ds["IRRIGHARVEST"].values) + fracv = np.asarray(ds["CROPIRRIGFRAC"].values) + irrigtypev = np.asarray(ds["IRRIGTYPE"].values) + crop_names = _decode_crop_names(np.asarray(ds["CROPCLASSNAME"].values)) if "CROPCLASSNAME" in ds else [f"crop_{i + 1:02d}" for i in range(26)] + + ncat = int(np.nanmax(tile_id)) + # Normalize expected dimensions so tile is first, crop is last where possible. + plantv = np.asarray(plantv) + harvestv = np.asarray(harvestv) + fracv = np.asarray(fracv) + irrigtypev = np.asarray(irrigtypev) + # Best effort: assume first dimension is tile. If not, try moving the ncat dimension first. + def move_tile_first(a: np.ndarray) -> np.ndarray: + for ax, size in enumerate(a.shape): + if size >= ncat: + return np.moveaxis(a, ax, 0) + return a + plantv = move_tile_first(plantv) + harvestv = move_tile_first(harvestv) + fracv = move_tile_first(fracv) + irrigtypev = move_tile_first(irrigtypev) + ncrops = min(26, fracv.shape[-1]) + levels_frac = np.arange(21) * 0.025 + doy_levels = np.array([1, 32, 60, 91, 121, 152, 182, 213, 244, 274, 305, 335, 366, 370]) + page = 1 + row_in_page = 0 + fig = None + + def new_page(): + return plt.figure(figsize=(13, 11)) + + for crop in range(ncrops): + # Extract tile vectors. Common shapes are (tile, season, crop) for plant/harvest and (tile, crop) for frac/type. + frac = fracv[:ncat, crop].astype(np.float32) if fracv.ndim == 2 else fracv[:ncat, ..., crop].reshape(ncat, -1)[:, 0].astype(np.float32) + ityp = irrigtypev[:ncat, crop].astype(np.float32) if irrigtypev.ndim == 2 else irrigtypev[:ncat, ..., crop].reshape(ncat, -1)[:, 0].astype(np.float32) + plant = plantv[:ncat, 0, crop].astype(np.float32) if plantv.ndim >= 3 else plantv[:ncat, crop].astype(np.float32) + harvest = harvestv[:ncat, 0, crop].astype(np.float32) if harvestv.ndim >= 3 else harvestv[:ncat, crop].astype(np.float32) + if not np.isfinite(frac).any() or np.nanmax(frac) <= 0: + continue + if fig is None: + fig = new_page() + panels = [vector_to_grid(tile_id, frac), vector_to_grid(tile_id, plant), vector_to_grid(tile_id, harvest), vector_to_grid(tile_id, ityp)] + titles = ["frac", "DOY plant", "DOY harvest", "IRRIGTYPE"] + levels = [levels_frac, doy_levels, doy_levels, [1, 2, 3, 4]] + color_ids = [list(range(140, 161)), [69, 145, 64, 66, 70, 71, 73, 75, 76, 78, 80, 113, 114, 116, 117], [69, 145, 64, 66, 70, 71, 73, 75, 76, 78, 80, 113, 114, 116, 117], [69, 64, 80, 255]] + for col in range(4): + ax = make_axes(fig, 4, 4, row_in_page * 4 + col + 1, coastlines) + plot_continuous_on_ax(ax, panels[col], lon, lat, limits, f"{crop_names[crop] if crop < len(crop_names) else crop}: {titles[col]}", levels[col], color_ids[col], coastlines=coastlines) + row_in_page += 1 + if row_in_page == 4: + save_fig(fig, outdir / f"gia_irrig_params_{page:02d}.png") + fig = None + row_in_page = 0 + page += 1 + if fig is not None: + save_fig(fig, outdir / f"gia_irrig_params_{page:02d}.png") + + +# ----------------------------------------------------------------------------- +# Movies +# ----------------------------------------------------------------------------- + + +def _format_movie_tick_label(x: float) -> str: + """Compact numeric labels for per-frame movie colorbars.""" + x = float(x) + if abs(x) < 1.0e-10: + return "0" + if abs(x - round(x)) < 1.0e-10: + return str(int(round(x))) + if abs(x) < 0.1: + return f"{x:.3f}".rstrip("0").rstrip(".") + if abs(x) < 1.0: + return f"{x:.2f}".rstrip("0").rstrip(".") + return f"{x:g}" + + +def movie_colorbar_ticks(vname: str) -> Tuple[np.ndarray, List[str], str]: + """Return movie colorbar ticks consistent with static plots.""" + label_map = { + "GREEN": "Green vegetation fraction", + "VISDF": "VIS diffuse albedo", + "NIRDF": "NIR diffuse albedo", + "NDVI": "NDVI", + } + + if vname == "LAI": + return LAI_TICKS, list(LAI_TICK_LABELS), "LAI" + + return FRACTION_TICKS, list(FRACTION_TICK_LABELS), label_map.get(vname, vname) + +def add_movie_colorbar(fig: plt.Figure, ax, sm: ScalarMappable, vname: str, levels: Sequence[float]) -> None: + """Add one horizontal colorbar to every movie frame. + + The movie frame is captured from the raw canvas, so the colorbar must be + drawn into the figure before ``buffer_rgba`` is read. Use fixed ticks so + every frame has a stable scale and readable labels. + """ + ticks, labels, label = movie_colorbar_ticks(vname) + cax = fig.add_axes([0.08, 0.075, 0.84, 0.030]) + cbar = fig.colorbar(sm, cax=cax, orientation="horizontal", ticks=ticks, spacing="uniform") + cbar.ax.xaxis.set_major_locator(FixedLocator(ticks)) + cbar.ax.xaxis.set_major_formatter(FixedFormatter(labels)) + cbar.ax.tick_params(labelsize=5, rotation=0, pad=2) + cbar.set_label(label, fontsize=8, labelpad=3) + +def make_movie( + base_dir: Path, + rst_file: Path, + nc: int, + nr: int, + ncat: int, + layout: Optional[TimeSeriesLayout], + rst_layout: F77Layout, + outdir: Path, + gfile: str, + vname: str, + nc_movie: int, + nr_movie: int, + limits: Tuple[float, float, float, float], + cache_dir: Path, + coastlines: bool, +) -> None: + if layout is None: + print(f"Skipping {vname} movie; could not determine time-series layout") + return + mapping_cache = cache_dir / f"fractional_{gfile}_{nc_movie}x{nr_movie}.npz" + # The movie aggregation map is built from the integer raster (.rst), so it + # must use the raster F77 layout. The seasonal LAI/GREEN/AlbMap layout is + # a different object and does not have marker_dtype. Passing it here caused + # movie-only runs to fail with: 'TimeSeriesLayout' object has no attribute + # 'marker_dtype'. + mat = build_fractional_sparse_from_rst(rst_file, nc, nr, ncat, nc_movie, nr_movie, rst_layout, mapping_cache) + # Rows with no contributing land/catchment tiles are ocean/no-data. + # Sparse matrix multiplication returns 0.0 for empty rows, which would + # otherwise be plotted as a valid zero/low-value color in movies. Static + # climatology plots get NaN from vector_to_grid() for invalid cells; do + # the equivalent here so cmap.set_bad(NO_DATA_COLOR) is used consistently. + movie_cell_has_data = np.asarray(mat.getnnz(axis=1)).ravel() > 0 + filename_map = { + "LAI": "lai.dat", + "GREEN": "green.dat", + "VISDF": "AlbMap.WS.8-day.tile.0.3_0.7.dat", + "NIRDF": "AlbMap.WS.8-day.tile.0.7_5.0.dat", + "NDVI": "ndvi.dat", + } + path = base_dir / filename_map[vname] + if not path.exists(): + print(f"Skipping {vname} movie; missing {path}") + return + levels = LAI_LEVELS if vname == "LAI" else FRACTION_LEVELS + rgb = LAI_PLOT_RGB if vname == "LAI" else FRACTION_RGB + bad_color = NO_DATA_COLOR + lon, lat = lon_lat_centers(nc_movie, nr_movie) + mdays = [31,28,31,30,31,30,31,31,30,31,30,31] + outpath = outdir / f"{vname}.mp4" + print(f"Writing movie {outpath}") + with TimeSeriesReader(path, layout, ncat) as rdr: + h1, v1 = read_timeseries_record(rdr, ncat) + h2, v2 = read_timeseries_record(rdr, ncat) + b4 = midpoint_doy(h1) + nxt = midpoint_doy(h2) + # Use the same year-offset logic and sanitation as the LAI/Z0 static plots. + # Using h1[0] here can extrapolate January from the wrong year for Dec->Jan + # climatology records, producing negative LAI in the movie even when lai.jpg is OK. + current_year_offset = _initial_loop_year_offset(h1, h2) + with open_mp4_writer(outpath, fps=10) as writer: + for month in range(1, 13): + for day in range(1, mdays[month - 1] + 1): + now = float((_dt.date(2001 + current_year_offset, month, day) - _dt.date(2000, 12, 31)).days) + denom = (nxt - b4) if abs(nxt - b4) > 1e-6 else 1.0 + vec = ((now - b4) / denom) * v2 + ((nxt - now) / denom) * v1 + if vname == "LAI": + vec = _sanitize_lai(vec) + elif vname == "NDVI": + vec = _sanitize_ndvi(vec) + else: + # GREEN, VISDF, and NIRDF are fractional fields. Keep real + # values in [0,1] and mask impossible/fill values. + vec = np.asarray(vec, dtype=np.float32) + bad = (~np.isfinite(vec)) | (vec < 0.0) | (vec > 1.0) | (np.abs(vec) > 1.0e10) + vec = vec.copy() + vec[bad] = np.nan + flat = np.asarray(mat @ vec.astype(np.float32), dtype=np.float32).ravel() + flat[~movie_cell_has_data] = np.nan + grid = flat.reshape(nr_movie, nc_movie) + fig = plt.figure(figsize=(7.8, 5.85), dpi=100) + # Leave room for lon/lat tick labels and a fixed colorbar. + # Movie frames are captured from the raw canvas, not through + # savefig(..., bbox_inches="tight"), so margins must be explicit. + fig.subplots_adjust(left=0.085, right=0.985, bottom=0.205, top=0.90) + ax = make_axes(fig, 1, 1, 1, coastlines) + date_stamp = f"{2001 + current_year_offset:04d}{month:02d}{day:02d}" + sm = plot_continuous_on_ax(ax, grid, lon, lat, limits, f"{vname}: {date_stamp}", levels, rgb=rgb, coastlines=coastlines, bad_color=bad_color) + add_movie_colorbar(fig, ax, sm, vname, levels) + fig.canvas.draw() + frame = np.asarray(fig.canvas.buffer_rgba())[:, :, :3] + writer.append_data(frame) + plt.close(fig) + if now + 0.5 >= nxt: + v1 = v2 + b4 = nxt + try: + h2, v2 = read_timeseries_record(rdr, ncat) + nxt = midpoint_doy(h2) + current_year_offset = _advance_loop_year_offset(h2, month) + except EOFError: + nxt = now + 9999.0 + print(f"Wrote {outpath}") + + +# ----------------------------------------------------------------------------- +# Main driver +# ----------------------------------------------------------------------------- + + +DEFAULT_PLOTS = [ + "tiles", "country", "cti", "mosaic", "clm", "carbon", "ndep", "soil", + "elevation", "lai", "green", "ndvi", "canopy", "z0" +] +MOVIE_PLOTS = ["movies"] +LEGACY_PLOTS = DEFAULT_PLOTS + MOVIE_PLOTS +# Irrigation products - NOT TESTED IN Python Package due to file unavailability. +# These routines exist as legacy/experimental helpers, but the active legacy IDL +# driver does not call them by default. Keep them explicitly requestable without +# making --plots all unexpectedly produce unvalidated products. +EXPERIMENTAL_PLOTS = ["irrig_method", "lai_minmax", "irrig_fractions", "crop_times"] +VALID_PLOTS = LEGACY_PLOTS + EXPERIMENTAL_PLOTS +# User-facing "all" is intentionally current legacy parity, not experimental extras. +ALL_PLOTS = LEGACY_PLOTS + + +def parse_plot_list(text: str) -> List[str]: + text = text.strip().lower() + if text in ("default", "main", "fixed", "images"): + return DEFAULT_PLOTS.copy() + if text in ("legacy", "legacy_idl", "legacy-idl", "idl", "idl_default", "idl-default"): + return LEGACY_PLOTS.copy() + if text in ("all", "everything"): + return ALL_PLOTS.copy() + if text in ("quick", "smoke"): + return ["tiles", "cti", "elevation"] + if text in ("experimental", "extras"): + return EXPERIMENTAL_PLOTS.copy() + plots = [] + aliases = { + "veg": "mosaic", + "ndep_t2m": "ndep", + "soilalb": "ndep", + "irrig": "irrig_fractions", + "irrigation": "irrig_fractions", + } + for item in text.split(","): + item = item.strip().lower().replace("-", "_") + if not item: + continue + plots.append(aliases.get(item, item)) + unknown = [p for p in plots if p not in VALID_PLOTS] + if unknown: + raise ClsmPlotError( + f"Unknown plot option(s): {unknown}. " + f"Valid modes: quick, default, movies, legacy, all, experimental. " + f"Valid explicit items: {VALID_PLOTS}" + ) + return plots + + +def build_arg_parser() -> argparse.ArgumentParser: + p = argparse.ArgumentParser(description="Drop-in Python replacement for IDL clsm_plots.pro") + p.add_argument("--gfile", default=os.environ.get("gfile"), help="Grid/file stem used to find workdir/rst/*.rst. Defaults to $gfile.") + p.add_argument("--workdir", default=os.environ.get("workdir"), help="BCS work directory containing rst/. Defaults to $workdir.") + p.add_argument("--nc", type=int, default=int(os.environ["NC"]) if os.environ.get("NC") else None, help="Full raster NC. Defaults to $NC.") + p.add_argument("--nr", type=int, default=int(os.environ["NR"]) if os.environ.get("NR") else None, help="Full raster NR. Defaults to $NR.") + p.add_argument("--base-dir", default="..", help="Directory containing catchment.def, cti_stats.dat, soil_param.dat, etc. Default: ..") + p.add_argument("--outdir", default=".", help="Directory for plot outputs. Default: current directory.") + p.add_argument("--plots", default=os.environ.get("CLSM_PLOTS", "legacy"), help=f"Comma list, or quick/default/movies/legacy/all/experimental. No-argument default is legacy (current legacy IDL-equivalent outputs: fixed JPGs + movies); override with $CLSM_PLOTS. Valid explicit items: {','.join(VALID_PLOTS)}") + p.add_argument("--plot-nc", type=int, default=4320, help="Output longitude cells for the main tile map. IDL default: 4320") + p.add_argument("--plot-nr", type=int, default=2160, help="Output latitude cells for the main tile map. IDL default: 2160") + p.add_argument("--movie-nc", type=int, default=720, help="Movie longitude cells. IDL default: 720") + p.add_argument("--movie-nr", type=int, default=360, help="Movie latitude cells. IDL default: 360") + p.add_argument("--dpi", type=int, default=int(os.environ.get("CLSM_PLOT_DPI", "180")), help="DPI for static JPG plots. Default: 180; may also be set with $CLSM_PLOT_DPI.") + p.add_argument("--jpeg-quality", type=int, default=int(os.environ.get("CLSM_JPEG_QUALITY", "95")), help="JPEG quality for static JPG plots. Default: 95; may also be set with $CLSM_JPEG_QUALITY.") + p.add_argument("--endian", choices=["auto", "little", "big", "<", ">"], default="auto", help="Endian for F77 binary files. Default: auto") + p.add_argument("--record-marker", type=int, choices=[0, 4, 8], default=0, help="F77 record marker bytes. 0 means auto; otherwise 4 or 8.") + p.add_argument("--cache-dir", default=None, help="Directory for tile/mapping caches. Default: /.clsm_plot_cache, so cache is not moved into final clsm/plots.") + p.add_argument("--rst-file", default=None, help="Explicit raster file to use instead of auto-selecting workdir/rst/*.rst. Useful when both .rst and -Pfafstetter.rst are present.") + p.add_argument("--tile-source", choices=["auto", "rst", "catchment"], default=os.environ.get("CLSM_TILE_SOURCE", "auto"), help="How to build the plotting tile map. rst reproduces the IDL raster path; catchment builds lon/lat boxes directly from catchment.def; auto uses rst unless its IDs fail a catchment.def spatial-consistency check. Default: auto; may also be set with $CLSM_TILE_SOURCE") + p.add_argument("--no-cache", action="store_true", help="Do not read/write tile-map cache") + p.add_argument("--coastlines", dest="coastlines", action="store_true", default=(ccrs is not None), help="Draw coastlines if Cartopy is installed. Default: on when Cartopy is available.") + p.add_argument("--no-coastlines", dest="coastlines", action="store_false", help="Disable Cartopy coastlines even if Cartopy is installed.") + p.add_argument("--z0-products", default="ascat,icarus,merged", help="Comma list of Z0 products: ascat,icarus,merged") + return p + + +def main(argv: Optional[Sequence[str]] = None) -> int: + args = build_arg_parser().parse_args(argv) + global PLOT_DPI, JPEG_QUALITY + PLOT_DPI = int(args.dpi) + JPEG_QUALITY = int(args.jpeg_quality) + missing = [name for name in ("gfile", "workdir", "nc", "nr") if getattr(args, name) in (None, "")] + if missing: + raise ClsmPlotError(f"Missing required settings: {missing}. Provide args or set gfile/workdir/NC/NR environment variables.") + + gfile = str(args.gfile) + workdir = Path(str(args.workdir)).expanduser().resolve() + base_dir = Path(args.base_dir).expanduser().resolve() + outdir = Path(args.outdir).expanduser().resolve() + outdir.mkdir(parents=True, exist_ok=True) + cache_dir = Path(args.cache_dir).expanduser().resolve() if args.cache_dir else workdir / ".clsm_plot_cache" + plots = parse_plot_list(args.plots) + + ncat = read_ncat(base_dir) + limits = read_limits(base_dir, gfile) + rst_file, layout = select_rst_file( + workdir, gfile, ncat, int(args.nc), int(args.nr), args.endian, args.record_marker, args.rst_file + ) + print(f"ncat={ncat}; limits={limits}; F77 layout=endian {layout.endian}, marker {layout.marker_bytes} bytes") + + lon, lat = lon_lat_centers(args.plot_nc, args.plot_nr) + tile_cache = None if args.no_cache else cache_dir / f"tile_id_{gfile}_{args.plot_nc}x{args.plot_nr}.npz" + catch_cache = None if args.no_cache else cache_dir / f"tile_id_from_catchment_def_{gfile}_{args.plot_nc}x{args.plot_nr}.npz" + + if args.tile_source == "catchment": + tile_id = build_tile_id_from_catchment_def(base_dir, ncat, args.plot_nc, args.plot_nr, catch_cache) + else: + tile_id = build_tile_id_from_rst(rst_file, int(args.nc), int(args.nr), ncat, args.plot_nc, args.plot_nr, layout, tile_cache) + match = catchment_spatial_match_fraction(tile_id, base_dir, lon, lat, ncat) + print(f"RST/catchment.def spatial match fraction: {match:.6f}") + if args.tile_source == "auto" and match < 0.05: + print( + "RST tile IDs do not spatially match catchment.def boxes well; " + "falling back to catchment.def-derived plotting tile map. " + "Use --tile-source rst to force IDL-style rst mapping." + ) + tile_id = build_tile_id_from_catchment_def(base_dir, ncat, args.plot_nc, args.plot_nr, catch_cache) + + valid_tile_cells = int(np.count_nonzero((tile_id >= 1) & (tile_id <= ncat))) + total_tile_cells = int(tile_id.size) + print(f"Valid plotting cells: {valid_tile_cells}/{total_tile_cells}") + if valid_tile_cells == 0: + raise ClsmPlotError( + "Tile map has zero valid CLSM tile ids. This usually means the wrong rst file was used " + "or catchment.def boxes could not be mapped to the plotting grid. Delete the cache, " + "rerun with --no-cache, or try --tile-source catchment / --rst-file ." + ) + + if "tiles" in plots: + plot_tiles( + tile_id, lon, lat, limits, outdir, args.coastlines, + rst_file, int(args.nc), int(args.nr), ncat, layout, + gfile=gfile, + ) + if "country" in plots: + plot_country_codes(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "cti" in plots: + plot_cti(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "mosaic" in plots: + plot_mosaic(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "clm" in plots: + plot_clm(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "carbon" in plots: + plot_carbon(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "ndep" in plots: + plot_ndep_t2m_soilalb(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "soil" in plots: + plot_soil(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "elevation" in plots: + plot_elevation(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "lai" in plots: + try: + ts_layout = choose_timeseries_layout(base_dir / "lai.dat", ncat, args.endian, args.record_marker) if (base_dir / "lai.dat").exists() else None + plot_lai(base_dir, tile_id, lon, lat, limits, outdir, ncat, ts_layout, args.coastlines) + except Exception as exc: + print(f"Skipping lai.jpg after error: {exc}") + if "green" in plots: + try: + green_layout = choose_timeseries_layout(base_dir / "green.dat", ncat, args.endian, args.record_marker) if (base_dir / "green.dat").exists() else None + plot_green(base_dir, tile_id, lon, lat, limits, outdir, ncat, green_layout, args.coastlines) + except Exception as exc: + print(f"Skipping green.jpg after error: {exc}") + if "ndvi" in plots: + try: + ndvi_layout_static = choose_timeseries_layout(base_dir / "ndvi.dat", ncat, args.endian, args.record_marker) if (base_dir / "ndvi.dat").exists() else None + plot_ndvi(base_dir, tile_id, lon, lat, limits, outdir, ncat, ndvi_layout_static, args.coastlines) + except Exception as exc: + print(f"Skipping ndvi.jpg after error: {exc}") + + z2 = asz0_mm = None + if "canopy" in plots or "z0" in plots: + try: + z2, asz0_mm = plot_canoph_from_vegdyn(base_dir, tile_id, lon, lat, limits, outdir, ncat, layout, args.coastlines) + except Exception as exc: + print(f"Skipping Canopy_Height_onTiles.jpg / ASZ0 inputs after error: {exc}") + if "z0" in plots and z2 is not None and asz0_mm is not None: + z0_products = [x.strip().lower() for x in args.z0_products.split(",") if x.strip()] + ts_layout = None + ndvi_layout = None + if (base_dir / "lai.dat").exists(): + try: + ts_layout = choose_timeseries_layout(base_dir / "lai.dat", ncat, args.endian, args.record_marker) + except Exception as exc: + print(f"Could not determine LAI layout for icarus/merged Z0: {exc}") + if (base_dir / "ndvi.dat").exists(): + try: + ndvi_layout = choose_timeseries_layout(base_dir / "ndvi.dat", ncat, args.endian, args.record_marker) + except Exception as exc: + print(f"Could not determine NDVI layout for icarus/merged Z0: {exc}") + try: + plot_z0(base_dir, tile_id, lon, lat, limits, outdir, ncat, z2, asz0_mm, ts_layout, args.coastlines, z0_products, ndvi_layout=ndvi_layout) + except Exception as exc: + print(f"Skipping Z0 plots after error: {exc}") + + if "irrig_method" in plots: + plot_irrig_method(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "lai_minmax" in plots: + plot_lai_minmax(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "irrig_fractions" in plots: + plot_irrig_fractions(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + if "crop_times" in plots: + plot_crop_times(base_dir, tile_id, lon, lat, limits, outdir, args.coastlines) + + if "movies" in plots: + for vname in ["LAI", "GREEN", "VISDF", "NIRDF", "NDVI"]: + try: + movie_layout = choose_timeseries_layout(base_dir / {"LAI":"lai.dat", "GREEN":"green.dat", "VISDF":"AlbMap.WS.8-day.tile.0.3_0.7.dat", "NIRDF":"AlbMap.WS.8-day.tile.0.7_5.0.dat", "NDVI":"ndvi.dat"}[vname], ncat, args.endian, args.record_marker) if (base_dir / {"LAI":"lai.dat", "GREEN":"green.dat", "VISDF":"AlbMap.WS.8-day.tile.0.3_0.7.dat", "NIRDF":"AlbMap.WS.8-day.tile.0.7_5.0.dat", "NDVI":"ndvi.dat"}[vname]).exists() else None + make_movie(base_dir, rst_file, int(args.nc), int(args.nr), ncat, movie_layout, layout, outdir, gfile, vname, args.movie_nc, args.movie_nr, limits, cache_dir, args.coastlines) + except Exception as exc: + print(f"Skipping {vname}.mp4 after error: {exc}") + + print("Done.") + return 0 + + +if __name__ == "__main__": + try: + raise SystemExit(main()) + except ClsmPlotError as exc: + print(f"ERROR: {exc}", file=sys.stderr) + raise SystemExit(2) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/create_README.csh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/create_README.csh index 4998f77ada..8cc811d351 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/create_README.csh +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/create_README.csh @@ -1616,28 +1616,36 @@ cat clsm/intro clsm/soil clsm/veg1 clsm/veg2 clsm/README1 clsm/README2 clsm/READ ################################################################################# mkdir -p clsm/plots -/bin/cp bin/clsm_plots.pro clsm/plots/. +/bin/cp -p bin/clsm_plots.py clsm/plots/. cd clsm/plots/ module purge -module use -a /discover/swdev/gmao_SIteam/modulefiles-SLES12 +module use -a /discover/swdev/gmao_SIteam/modulefiles-SLES15 source ../../bin/g5_modules -module load idl/8.5 +module load python/GEOSpyD/26.3.2-0/3.14 +module load ffmpeg/5.0 # we need this for movies mp4 -idl < 1 else 24000 +h_min = sys.argv[2] if len(sys.argv) > 2 else 2000 +h_max = float(h_max) +h_min = float(h_min) + +print(f'h_max: {h_max}') +print(f'h_min: {h_min}') + +if not os.path.exists('./netcdfs'): + os.mkdir('./netcdfs') + +# Step 1: Mesh generation +# Generate initial uniform mesh (resolution = 60000 m) +# project mesh onto new coordinate system +md = triangle(model(), '/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/AIS/AntarcticaOutline.exp', 60000) + +print(' Loading velocities data from NetCDF') +nsidc_vel = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/AIS/Antarctica_ice_velocity.nc') +xmin = nsidc_vel.xmin +xmin = float(xmin.lstrip()[0:10]) +ymax = nsidc_vel.ymax +ymax = float(ymax.lstrip()[0:10]) +spacing = nsidc_vel.spacing +spacing = float((spacing.lstrip())[0:4]) +nx = nsidc_vel.nx +ny = nsidc_vel.ny +vx = nsidc_vel['vx'][:].data +vy = nsidc_vel['vy'][:].data +# Build coordinates +x2 = xmin + np.arange(nx + 1) * spacing +y2 = (ymax - ny * spacing) + np.arange(ny + 1) * spacing + +vx_ = InterpFromGridToMesh(x2, y2, np.flipud(vx), md.mesh.x, md.mesh.y, 0) +vy_ = InterpFromGridToMesh(x2, y2, np.flipud(vy), md.mesh.x, md.mesh.y, 0) +speed = np.sqrt(vx_**2 + vy_**2) +del vx, vy, vx_, vy_ + +md = bamg(md, 'hmax', h_max, 'hmin', h_min, 'gradation', 1.4, 'field', speed, 'err', 8) + +# export mesh +export_discover(md, './netcdfs/AIS_mesh.nc') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_parameterize.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_parameterize.py new file mode 100755 index 0000000000..a8fbbcf973 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/AIS/AIS_parameterize.py @@ -0,0 +1,143 @@ +import numpy as np +from paterson import paterson +from netCDF4 import Dataset +from xy2ll import xy2ll +from InterpFromGridToMesh import InterpFromGridToMesh +from SetMarineIceSheetBC import SetMarineIceSheetBC +from m1qn3inversion import m1qn3inversion +from setflowequation import setflowequation +from pathlib import Path + +#Name and Coordinate system +md.miscellaneous.name="AIS" +md.mesh.epsg=3031 + +nsidc_vel = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/AIS/Antarctica_ice_velocity.nc') +xmin = nsidc_vel.xmin +xmin = float(xmin.lstrip()[0:10]) +ymax = nsidc_vel.ymax +ymax = float(ymax.lstrip()[0:10]) +spacing = nsidc_vel.spacing +spacing = float((spacing.lstrip())[0:4]) +nx = nsidc_vel.nx +ny = nsidc_vel.ny +velx = nsidc_vel['vx'][:].data +vely = nsidc_vel['vy'][:].data +# Build coordinates +x2 = xmin + np.arange(nx + 1) * spacing +y2 = (ymax - ny * spacing) + np.arange(ny + 1) * spacing + +# print(' Set observed velocities') +md.initialization.vx = InterpFromGridToMesh(x2, y2, np.flipud(velx), md.mesh.x, md.mesh.y, 0) +md.initialization.vy = InterpFromGridToMesh(x2, y2, np.flipud(vely), md.mesh.x, md.mesh.y, 0) +md.initialization.vz = np.zeros(md.mesh.numberofvertices) +md.initialization.vel = np.sqrt(md.initialization.vx**2 + md.initialization.vy**2) +del velx, vely + +# Parameters to change/Try +friction_coefficient = 10 # default [10] +Temp_change = 0 # default [0 K] + +# NetCDF Loading +print(' Loading SeaRISE data from NetCDF') +ncdata = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/AIS/Antarctica_5km_withshelves_v0.75.nc') +x1 = ncdata['x1'][:].data +y1 = ncdata['y1'][:].data +usrf = ncdata['usrf'][:].data[0] +topg = ncdata['topg'][:].data[0] +temp = ncdata['presartm'][:].data[0] +smb = ncdata['presprcp'][:].data[0] +gflux = ncdata['bheatflx_fox'][:].data[0] + +# Geometry +print(' Interpolating surface and ice base') +md.geometry.base = InterpFromGridToMesh(x1, y1, topg, md.mesh.x, md.mesh.y, 0) +md.geometry.surface = InterpFromGridToMesh(x1, y1, usrf, md.mesh.x, md.mesh.y, 0) +del usrf, topg + +thkmask=ncdata['thkmask'][:].data[0] + +##interpolate onto our mesh vertices +groundedice= InterpFromGridToMesh(x1,y1,thkmask,md.mesh.x,md.mesh.y,0) +groundedice[groundedice<=0]=-1 +del thkmask + +#fill in the md.mask structure +md.mask.ocean_levelset = groundedice #ice is grounded for mask equal one +md.mask.ice_levelset = -1*np.ones(np.shape(md.mesh.x)) #ice is present when negatvie + +print(' Constructing thickness') +md.geometry.thickness = md.geometry.surface - md.geometry.base + +# Ensure hydrostatic equilibrium on ice shelf +di = md.materials.rho_ice / md.materials.rho_water + +# Get the node numbers of floating nodes +pos = np.where(md.mask.ocean_levelset < 0) + +# Apply flotation criterion +md.geometry.thickness[pos] = 1 / (1 - di) * md.geometry.surface[pos] +md.geometry.base[pos] = md.geometry.surface[pos] - md.geometry.thickness[pos] +md.geometry.hydrostatic_ratio = np.ones(md.mesh.numberofvertices) + +# Set min thickness to 1 meter +pos0 = np.where(md.geometry.thickness <= 1) +md.geometry.thickness[pos0] = 1 +md.geometry.surface = md.geometry.thickness + md.geometry.base +md.geometry.bed = md.geometry.base.copy() +md.geometry.bed[pos] = md.geometry.base[pos] - 1000 + + +# Initialization parameters +print(' Interpolating temperatures') +md.initialization.temperature = InterpFromGridToMesh( + x1, y1, temp, md.mesh.x, md.mesh.y, 0 +) + 273.15 + Temp_change + +[md.mesh.lat, md.mesh.long] = xy2ll(md.mesh.x, md.mesh.y, -1) + + +print(' Set Pressure') +md.initialization.pressure = md.materials.rho_ice * md.constants.g * md.geometry.thickness + +print(' Construct ice rheological properties') +md.materials.rheology_n = 3 * np.ones(md.mesh.numberofelements) +md.materials.rheology_B = paterson(md.initialization.temperature) + +# Forcings +print(' Interpolating surface mass balance') +mass_balance = InterpFromGridToMesh(x1, y1, smb, md.mesh.x, md.mesh.y, 0) +md.smb.mass_balance = mass_balance * md.materials.rho_water / md.materials.rho_ice + +print(' Set geothermal heat flux') +md.basalforcings.geothermalflux = InterpFromGridToMesh(x1, y1, gflux, md.mesh.x, md.mesh.y, 0) + +# Friction and inversion set up +print(' Construct basal friction parameters') +md.friction.coefficient = friction_coefficient * np.ones(md.mesh.numberofvertices) +md.friction.p = np.ones(md.mesh.numberofelements) +md.friction.q = np.ones(md.mesh.numberofelements) + +# No friction applied on floating ice +pos = np.where(md.mask.ocean_levelset < 0)[0] +md.friction.coefficient[pos] = 0 +md.groundingline.migration = 'SubelementMigration' + +md.inversion = m1qn3inversion() +md.inversion.vx_obs = md.initialization.vx +md.inversion.vy_obs = md.initialization.vy +md.inversion.vel_obs = md.initialization.vel + +print(' Set flow equations') +md = setflowequation(md,'SSA','all') + +print(' Set boundary conditions') +md = SetMarineIceSheetBC(md) +md.basalforcings.floatingice_melting_rate = np.zeros(md.mesh.numberofvertices) +md.basalforcings.groundedice_melting_rate = np.zeros(md.mesh.numberofvertices) +md.thermal.spctemperature = md.initialization.temperature +md.masstransport.spcthickness = np.full(md.mesh.numberofvertices, np.nan) + + + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_control.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_control.py new file mode 100755 index 0000000000..1646342d38 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_control.py @@ -0,0 +1,68 @@ +import devpath +import os +ISSM_DIR = os.getenv('ISSM_DIR') # for binaries + +import numpy as np +from model import * +from loadmodel import loadmodel +from setmask import setmask +from parameterize import parameterize +from setflowequation import setflowequation +from clusters.discover_geos import export_discover +from marshall import marshall +from m1qn3inversion import m1qn3inversion + +# Step 2: parameterize model +md = loadmodel('./netcdfs/GRIS_mesh.nc') +md = setmask(md, '', '') +md = parameterize(md, './GRIS_parameterize.py') +md = setflowequation(md, 'SSA', 'all') + +# export parameterization +export_discover(md, "./netcdfs/GRIS_parameterization.nc",delete_rundir=True) + +# Control general +md.inversion = m1qn3inversion() +md.inversion.vx_obs = md.initialization.vx +md.inversion.vy_obs = md.initialization.vy +md.inversion.vel_obs = md.initialization.vel + +md.inversion.nsteps = 100 +md.inversion.iscontrol=1 +md.inversion.maxsteps=100 +md.inversion.maxiter=100 +md.inversion.dxmin=0.01 +md.inversion.gttol=1.0e-8 + +md.inversion.step_threshold = 0.99 * np.ones((md.inversion.nsteps)) +md.inversion.maxiter_per_step = 40 * np.ones((md.inversion.nsteps)) + +md.inversion.gradient_scaling = 50 * np.ones((md.inversion.nsteps, 1)) +md.inversion.min_parameters = 1 * np.ones((md.mesh.numberofvertices, 1)) +md.inversion.max_parameters = 200 * np.ones((md.mesh.numberofvertices, 1)) + +#Cost functions +md.inversion.cost_functions = [101, 103, 501] +md.inversion.cost_functions_coefficients = np.ones((md.mesh.numberofvertices, 3)) +md.inversion.cost_functions_coefficients[:, 0] = 1 +md.inversion.cost_functions_coefficients[:, 1] = 1 +md.inversion.cost_functions_coefficients[:, 2] = 2e-10 + +# Controls +md.inversion.control_parameters = ['FrictionCoefficient'] +md.inversion.min_parameters=1*np.ones(np.shape(md.mesh.x)) +md.inversion.max_parameters=200*np.ones(np.shape(md.mesh.x)) + +# Additional parameters +md.stressbalance.restol=1.0e-12 +md.stressbalance.reltol=1.0e-12 +md.stressbalance.abstol=np.nan + +# Solve +md.private.solution = 'Stressbalance' +md.settings.waitonlock = 0 +md.toolkits.ToolkitsFile('ISSM_'+md.miscellaneous.name + '.toolkits') +marshall(md,'ISSM_'+md.miscellaneous.name+'.bin') + +# export configuration for loading solution in next step +export_discover(md,'./netcdfs/GRIS_inversion.nc',delete_rundir=True) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_finalize.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_finalize.py new file mode 100755 index 0000000000..37d1c12caa --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_finalize.py @@ -0,0 +1,31 @@ +import devpath +import os +ISSM_DIR = os.getenv('ISSM_DIR') # for binaries + +from model import * +from loadmodel import loadmodel +from clusters.discover_geos import export_discover +from loadresultsfromdisk import loadresultsfromdisk +from marshall import marshall +from verbose import verbose + +md = loadmodel('./netcdfs/GRIS_inversion.nc') +md = loadresultsfromdisk(md,'ISSM_GRIS.outbin') +md.friction.coefficient = md.results.StressbalanceSolution.FrictionCoefficient + + +# Write the binary input file +# Additional options +md.inversion.iscontrol = 0 +md.stressbalance.restol=1.0e-12 +md.stressbalance.reltol=1.0e-12 +md.transient.requested_outputs = ['default'] +md.transient.isthermal=0 +md.settings.waitonlock = 0 +md.private.solution = 'Transient' +md.verbose = verbose('000000000') +md.toolkits = toolkits() +marshall(md,'ISSM_'+md.miscellaneous.name+'.bin') # create .bin file +md.toolkits.ToolkitsFile('ISSM_'+md.miscellaneous.name + '.toolkits') +export_discover(md,'./netcdfs/GRIS_initialization.nc',delete_rundir=True) + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_meshgen.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_meshgen.py new file mode 100644 index 0000000000..4898354df9 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_meshgen.py @@ -0,0 +1,55 @@ +import devpath +import sys,os +import numpy as np +from triangle import triangle +from model import * +from netCDF4 import Dataset +from InterpFromGridToMesh import InterpFromGridToMesh +from bamg import bamg +from xy2ll import xy2ll +from ll2xy import ll2xy +from clusters.discover_geos import export_discover + +if not os.path.exists('./netcdfs'): + os.mkdir('./netcdfs') + +h_max = sys.argv[1] if len(sys.argv) > 1 else 24000 +h_min = sys.argv[2] if len(sys.argv) > 2 else 2000 +h_max = float(h_max) +h_min = float(h_min) + +print(f'h_max: {h_max}') +print(f'h_min: {h_min}') + +# Step 1: Mesh generation +#Generate initial uniform mesh (resolution = 20000 m) +# project mesh onto new coordinate system +md = triangle(model(), '/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/GreenlandOutline.exp', 20000) +[md.mesh.lat, md.mesh.long] = xy2ll(md.mesh.x, md.mesh.y, + 1, 39, 71) +[xi, yi] = ll2xy(md.mesh.lat, md.mesh.long, + 1, 45, 70) +md.mesh.x = xi +md.mesh.y = yi + +ncdata_vx = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/greenland_vel_mosaic200_2017_2018_vx_v02.1.nc', mode='r') +ncdata_vy = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/greenland_vel_mosaic200_2017_2018_vy_v02.1.nc', mode='r') + +# Get velocities (Note: You can use ncprint('file') to see an ncdump) +x1 = np.squeeze(ncdata_vx.variables['x'][:].data) +y1 = np.squeeze(ncdata_vx.variables['y'][:].data) +velx = np.squeeze(ncdata_vx.variables['Band1'][:].data) +vely = np.squeeze(ncdata_vy.variables['Band1'][:].data) +ncdata_vx.close() +ncdata_vy.close() + +velx[np.abs(velx)>1e9] = 0 +vely[np.abs(vely)>1e9] = 0 + +vx = InterpFromGridToMesh(x1, y1, velx, md.mesh.x, md.mesh.y, 0) +vy = InterpFromGridToMesh(x1, y1, vely, md.mesh.x, md.mesh.y, 0) +speed = np.sqrt(vx**2 + vy**2) + +# Mesh Greenland (refine according to flow speed) +md = bamg(md, 'hmax', h_max, 'hmin', h_min, 'gradation', 1.4, 'field', speed, 'err', 8) + +# export mesh +export_discover(md, './netcdfs/GRIS_mesh.nc') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_parameterize.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_parameterize.py new file mode 100755 index 0000000000..292984656b --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/GRIS/GRIS_parameterize.py @@ -0,0 +1,126 @@ +import numpy as np +from paterson import paterson +from netCDF4 import Dataset +from ll2xy import ll2xy +from xy2ll import xy2ll +from InterpFromGridToMesh import InterpFromGridToMesh +from SetIceSheetBC import SetIceSheetBC +from pathlib import Path + +#Name and Coordinate system +md.miscellaneous.name = "GRIS" +md.mesh.epsg = 3413 + +# interpolate velocities +ncdata_x = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/greenland_vel_mosaic200_2017_2018_vx_v02.1.nc', mode='r') +ncdata_y = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/greenland_vel_mosaic200_2017_2018_vy_v02.1.nc', mode='r') + +x1 = np.squeeze(ncdata_x.variables['x'][:].data) +y1 = np.squeeze(ncdata_x.variables['y'][:].data) +velx = np.squeeze(ncdata_x.variables['Band1'][:].data) +vely = np.squeeze(ncdata_y.variables['Band1'][:].data) +ncdata_x.close() +ncdata_y.close() + +# set missing data points to zero??? +velx[np.abs(velx)>1e9] = 0 +vely[np.abs(vely)>1e9] = 0 + +vx = InterpFromGridToMesh(x1, y1, velx, md.mesh.x, md.mesh.y, 0) +vy = InterpFromGridToMesh(x1, y1, vely, md.mesh.x, md.mesh.y, 0) +speed = np.sqrt(vx**2 + vy**2) + +md.initialization.vx = vx +md.initialization.vy = vy +md.initialization.vz = np.zeros((md.mesh.numberofvertices)) +md.initialization.vel = speed + +md.inversion.vx_obs = vx +md.inversion.vy_obs = vy +md.inversion.vel_obs = speed + +# initialize ice thickness +ncdata_H = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/BedMachineGreenland-v5.nc', mode='r') +H = np.flipud(ncdata_H['thickness'][:].data.astype(np.float64)) +surf = np.flipud(ncdata_H['surface'][:].data.astype(np.float64)) +bed = np.flipud(ncdata_H['bed'][:].data.astype(np.float64)) +x1 = ncdata_H['x'][:].data.astype(np.float64) +y1 = np.flipud(ncdata_H['y'][:].data.astype(np.float64)) +ncdata_H.close() + +md.geometry.base = InterpFromGridToMesh(x1, y1, bed, md.mesh.x, md.mesh.y, 0) +md.geometry.surface = InterpFromGridToMesh(x1, y1, surf, md.mesh.x, md.mesh.y, 0) + +md.geometry.thickness = md.geometry.surface - md.geometry.base + +#Set min thickness to 1 meter +pos0 = np.nonzero(md.geometry.thickness <= 0) +md.geometry.thickness[pos0] = 1 +md.geometry.surface = md.geometry.thickness + md.geometry.base + + #-------------------------------------------------- + ## EDITS +## Project mesh onto old coordinate system temporarily +[md.mesh.lat, md.mesh.long] = xy2ll(md.mesh.x, md.mesh.y, + 1, 45, 70) +[xi, yi] = ll2xy(md.mesh.lat, md.mesh.long, + 1, 39, 71) +md.mesh.x = xi +md.mesh.y = yi + +ncdata = Dataset('/discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/GRIS/Greenland_5km_dev1.2.nc', mode='r') +x1 = np.squeeze(ncdata.variables['x1'][:].data) +y1 = np.squeeze(ncdata.variables['y1'][:].data) +usrf = np.squeeze(ncdata.variables['usrf'][:].data) +topg = np.squeeze(ncdata.variables['topg'][:].data) +velx = np.squeeze(ncdata.variables['surfvelx'][:].data) +vely = np.squeeze(ncdata.variables['surfvely'][:].data) +temp = np.squeeze(ncdata.variables['airtemp2m'][:].data) +smb = np.squeeze(ncdata.variables['smb'][:].data) +gflux = np.squeeze(ncdata.variables['bheatflx'][:].data) +ncdata.close() + +# initialize temperature +md.initialization.temperature = InterpFromGridToMesh(x1, y1, temp, md.mesh.x, md.mesh.y, 0) + 273.15 + +# impose observed temperature on surface +md.thermal.spctemperature = md.initialization.temperature +md.masstransport.spcthickness = np.nan * np.ones((md.mesh.numberofvertices)) + +# initialize surface mass balance (zero smb example) +md.smb.mass_balance = InterpFromGridToMesh(x1, y1, smb, md.mesh.x, md.mesh.y, 0) +md.smb.mass_balance = md.smb.mass_balance * md.materials.rho_water / md.materials.rho_ice + +# initialize basal friction +md.friction.coefficient = 30 * np.ones((md.mesh.numberofvertices)) +pos = np.nonzero(md.mask.ocean_levelset < 0) +md.friction.coefficient[pos] = 0 #no friction applied on floating ice +md.friction.p = np.ones((md.mesh.numberofelements)) +md.friction.q = np.ones((md.mesh.numberofelements)) + +# initialize ice rheology +md.materials.rheology_n = 3 * np.ones((md.mesh.numberofelements)) +md.materials.rheology_B = paterson(md.initialization.temperature) + +# set geothermal heat flux +md.basalforcings.geothermalflux = InterpFromGridToMesh(x1, y1, gflux, md.mesh.x, md.mesh.y, 0) + +# set other boundary conditions +md.mask.ice_levelset[np.nonzero(md.mesh.vertexonboundary == 1)] = 0 +md.basalforcings.floatingice_melting_rate = np.zeros((md.mesh.numberofvertices)) +md.basalforcings.groundedice_melting_rate = np.zeros((md.mesh.numberofvertices)) + +# initialize pressure +md.initialization.pressure = md.materials.rho_ice * md.constants.g * md.geometry.thickness + +# initialize single point constraints +md.stressbalance.referential = np.nan * np.ones((md.mesh.numberofvertices, 6)) +md.stressbalance.spcvx = np.nan * np.ones((md.mesh.numberofvertices)) +md.stressbalance.spcvy = np.nan * np.ones((md.mesh.numberofvertices)) +md.stressbalance.spcvz = np.nan * np.ones((md.mesh.numberofvertices)) + +## Re-project mesh onto coordinate system +[md.mesh.lat, md.mesh.long] = xy2ll(md.mesh.x, md.mesh.y, + 1, 39, 71) +[xi, yi] = ll2xy(md.mesh.lat, md.mesh.long, + 1, 45, 70) +md.mesh.x = xi +md.mesh.y = yi + +md = SetIceSheetBC(md) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/README.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/README.txt new file mode 100644 index 0000000000..c2ec8e5f6c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/README.txt @@ -0,0 +1,59 @@ +generate_issm_bcs.sh creates ISSM input files (ISSM*.bin and ISSM*.toolkits) to be used in GEOS. +The "ISSM" prefix is used to make sure ISSM doesn't inadvertently try to read other binary files. +Run via: sbatch generate_issm_bcs.sh h_max h_min +where the (optional) arguments h_min and h_max are (approximately) the maxium and minumum element +edge length in meters, respectively. The default arguments are h_max=24000 and h_min=2000. + +Default example is produced with: + +sbatch generate_issm_bcs.sh + +Data is read from: /discover/nobackup/projects/gmao/bcs_shared/preprocessing_bcs_inputs/landice/issm/v1/ +That directory is organized into AIS (Antarctica) and GRIS (Greenland) subdirectories. + +Output is currently archived here: +/discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/landice/issm/v1/ + +There is only one resolution for v1 ISSM BCs, ISSM_ME23083_N34534_AIS_GRIS. +The domain naming convention (ISSM_ME*_N*...) is described below. + +The script finds all subdirectories containing files of the form: +glaciername/glaciername_meshgen.py +glaciername/glaciername_parameterize.py +glaciername/glaciername_control.py +glaciername/glaciername_finalize.py + +where "glaciername" (e.g., AIS, GRIS, etc...) is the name of the subdirectory. + +The subdirectories can be nested or organized in any way (i.e., directories without the required +python files are passed over), so future development could add a structure like: + +iceland/vatnajokull/vatnajokull*.py +iceland/snaefellsjokull/snaefellsjokull*.py +... + +Upon running the required python files, two files will be produced for each glacier found: +ISSM_glaciername.bin and ISSM_glaciername.toolkits + +The bin file contains the mesh, boundary conditions, physical parameters, etc., while the toolkits +file contains configuration options for external packages (usually just PETSc solver options). + +The script then calls utils_issm/domain_name.py, which calculates the mean length of every triangle +edge across all glaciers (i.e. mean node spacing) and calculates the total number of nodes. + +A domain name is then prescribed as: + +ISSM_ME{ mean edge length }_N{ total nodes }_{ top-level glacier names separated by _ } + +*The mean edge length (in meters) is rounded to the nearest meter. + +*Top-level glacier names are those that exist at the issm directory level. In the iceland example + above, iceland would appear in domain_name while vatnajokull and snaefellsjokull would not. + +Currently, the generated domain name is: ISSM_ME23083_N34534_AIS_GRIS + +Finally, the script creates a directory with this domain name and copies all ISSM*.bin and +ISSM*toolkits files there. + + + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/generate_issm_bcs.sh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/generate_issm_bcs.sh new file mode 100755 index 0000000000..f65800da62 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/generate_issm_bcs.sh @@ -0,0 +1,65 @@ +#!/bin/bash +#SBATCH --job-name=preproc_issm +#SBATCH --time=1:00:00 +#SBATCH --ntasks=126 +#SBATCH --qos=debug +#SBATCH --constraint=mil + +h_max=${1:-24000} +h_min=${2:-2000} + +find . -mindepth 1 -type d ! -name utils_issm -exec bash -c ' +h_max="$1" +h_min="$2" +shift 2 + +for dir do +( + hdir=$(pwd) + cd "$dir" || exit + name=$(basename "$dir") + + for f in "${name}_meshgen.py" "${name}_parameterize.py" "${name}_control.py" "${name}_finalize.py"; do + [[ -f "$f" ]] || exit + done + + source "$hdir/issm_env" + rm -f ISSM_${name}.bin ISSM_${name}.outbin ISSM_${name}.errlog + rm -rf netcdfs + (export LD_LIBRARY_PATH=$PYTHON_LIB:$LD_LIBRARY_PATH; python ${name}_meshgen.py "$h_max" "$h_min") + (export LD_LIBRARY_PATH=$PYTHON_LIB:$LD_LIBRARY_PATH; python ${name}_control.py) + + if [ -n "$SLURM_JOB_ID" ]; then + mpirun -np $SLURM_NTASKS ${ISSM_DIR}/bin/issm.exe StressbalanceSolution $(pwd) ISSM_${name} 2>> ISSM_${name}.errlog + else + ${ISSM_DIR}/bin/issm.exe StressbalanceSolution $(pwd) ISSM_${name} 2>> ISSM_${name}.errlog + fi + + (export LD_LIBRARY_PATH=$PYTHON_LIB:$LD_LIBRARY_PATH; python ${name}_finalize.py) +) +done +' bash "$h_max" "$h_min" {} + + +source issm_env +domain_name=$( + LD_LIBRARY_PATH="$PYTHON_LIB:$LD_LIBRARY_PATH" \ + python ./utils_issm/domain_name.py +) + +rm -rf "$domain_name" && mkdir "$domain_name" + +find . -type f -name "ISSM*.bin" -not -path "./ISSM_ME*/*" -exec cp -t "$domain_name" {} + +find . -type f -name "ISSM*.toolkits" -not -path "./ISSM_ME*/*" -exec cp -t "$domain_name" {} + + +cp ISSM_MESH.nc "$domain_name" + +echo "" +echo "================================================================================================================" +echo "Created ISSM BCs!" +echo "" +echo "Domain name: $domain_name" +echo "(ME=mean edge length [meters], N = total nodes)" +echo "" +echo "ISSM BCs copied to $(pwd)/$domain_name" +echo "================================================================================================================" +echo "" diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/issm_env b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/issm_env new file mode 100755 index 0000000000..3b24aabde8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/issm_env @@ -0,0 +1,11 @@ +#ISSM +module purge +source /discover/nobackup/mathomp4/SystemTests/builds/AGCM/CURRENT/GEOSgcm/@env/g5_modules.sh +export ISSM_ARCH="linux-gnu-amd64" +export ISSM_DIR=$ISSM_ROOT_DIR +export PATH="$PATH:$ISSM_DIR/scripts:/usr/include:/usr/lib64:/usr/lib" +export PYTHONPATH="$PYTHONPATH:$ISSM_DIR/src/m/dev" +export PYTHON_LIB="$(python -c "import sys; print(sys.prefix)")/lib/" +export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:$ISSM_DIR/lib +source $ISSM_DIR/etc/environment.sh + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/domain_name.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/domain_name.py new file mode 100644 index 0000000000..8e1d2802f8 --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/domain_name.py @@ -0,0 +1,135 @@ +import devpath +import numpy as np +import os,sys +from pathlib import Path +from contextlib import redirect_stdout +from netCDF4 import Dataset +ISSM_DIR = os.getenv('ISSM_DIR') # for binaries + +from model import * +from loadmodel import loadmodel + +num_nodes = np.array([ ]) +num_edges = np.array([ ]) +mean_edges = np.array([ ]) + +# node coordinates +nodeCoords_lon = np.array([]) +nodeCoords_lat = np.array([]) + +# element connectivity +elementConn_n1 = np.array([]) +elementConn_n2 = np.array([]) +elementConn_n3 = np.array([]) + + +# find all subdirectories with python code +ROOT = Path(".").resolve() +EXCLUDE = (ROOT / "utils_issm").resolve() + +models = sorted({ + str(p.parent) + for p in ROOT.rglob("*.py") + if EXCLUDE not in p.resolve().parents + and p.parent != ROOT + and not any(part.startswith(".") for part in p.relative_to(ROOT).parts) +}) + +# top-level glacier names +model_names = sorted({Path(p).relative_to(ROOT).parts[0] for p in models}) + +i=0 +for model in models: + with open(os.devnull, "w") as f: + with redirect_stdout(f): + md = loadmodel(f'{model}/netcdfs/{model_names[i]}_initialization.nc') + + v1_idx = md.mesh.edges[:,0]-1 + v2_idx = md.mesh.edges[:,1]-1 + + v1_x = md.mesh.x[v1_idx] + v1_y = md.mesh.y[v1_idx] + + v2_x = md.mesh.x[v2_idx] + v2_y = md.mesh.y[v2_idx] + + edge_lengths = np.sqrt((v1_x-v2_x)**2 + (v1_y-v2_y)**2) + mean_edge_length = np.mean(edge_lengths) + # print(f'mean edge length: {int(np.ceil(mean_edge_length))} m') + # print(f'number of edges: {v1_x.size}') + # print(f'number of nodes: {md.mesh.x.size}') + # print('\n') + + nodeCoords_lon = np.append(nodeCoords_lon,md.mesh.long) + nodeCoords_lat = np.append(nodeCoords_lat,md.mesh.lat) + + # shift nodeIds by total number of nodes from previous models + elementConn_n1 = np.append(elementConn_n1,md.mesh.elements[:,0] - 1 + np.sum(num_nodes) ) + elementConn_n2 = np.append(elementConn_n2,md.mesh.elements[:,1] - 1 + np.sum(num_nodes) ) + elementConn_n3 = np.append(elementConn_n3,md.mesh.elements[:,2] - 1 + np.sum(num_nodes) ) + + num_edges = np.append(num_edges,[v1_x.size]) + num_nodes = np.append(num_nodes,[md.mesh.x.size]) + mean_edges = np.append(mean_edges,[mean_edge_length]) + i += 1 + +nodeCoords = np.column_stack((nodeCoords_lon, nodeCoords_lat)) +elementConn = np.column_stack((elementConn_n1, elementConn_n2,elementConn_n3)) + +#print(nodeCoords.shape) + +global_mean = 0 +total_nodes = int(np.sum(num_nodes)) +total_edges = int(np.sum(num_edges)) +# print(f'total nodes: {total_nodes}') +for j in range(np.size(num_nodes)): + global_mean += num_edges[j]*mean_edges[j]/total_edges + +global_mean = int(np.round(global_mean,0)) + +#print(f'mean edge length method: {global_mean} m') + +#print('\n') +#print('============================================================') +#print(f'Domain name:) +print(f'ISSM_ME{global_mean}_N{total_nodes}_{"_".join(model_names)}') +#print('============================================================') + + +N = nodeCoords.shape[0] +M = elementConn.shape[0] + +with Dataset("ISSM_MESH.nc", "w", format="NETCDF4") as nc: + + # --- Dimensions --- + nc.createDimension("nNodes", N) + nc.createDimension("nElements", M) + nc.createDimension("nVertices", 3) # triangles + + # --- Mesh topology variable (UGRID convention) --- + mesh = nc.createVariable("mesh", "i4") + mesh.cf_role = "mesh_topology" + mesh.topology_dimension = 2 + mesh.node_coordinates = "node_lon node_lat" + mesh.face_node_connectivity = "element_conn" + + # --- Node coordinates --- + node_lon = nc.createVariable("node_lon", "f8", ("nNodes",)) + node_lon.standard_name = "longitude" + node_lon.units = "degrees_east" + node_lon[:] = nodeCoords[:, 0] + + node_lat = nc.createVariable("node_lat", "f8", ("nNodes",)) + node_lat.standard_name = "latitude" + node_lat.units = "degrees_north" + node_lat[:] = nodeCoords[:, 1] + + # --- Element connectivity --- + conn = nc.createVariable("element_conn", "i4", ("nElements", "nVertices")) + conn.cf_role = "face_node_connectivity" + conn.start_index = 0 # 0-based indexing + conn[:] = elementConn + + # --- Global attributes --- + nc.Conventions = "UGRID-1.0" + diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/meshgenie.sh b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/meshgenie.sh new file mode 100755 index 0000000000..d81f16d93c --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/issm/utils_issm/meshgenie.sh @@ -0,0 +1,53 @@ +#!/bin/bash +# +# simple script for generating issm meshes at different resolutions +# + +SCRIPT_DIR=$( cd -- "$( dirname -- "${BASH_SOURCE[0]}" )" &> /dev/null && pwd ) +cd $SCRIPT_DIR +cd ../ + +h_max=$1 +h_min=$2 + + +find . -mindepth 1 -type d ! -name utils_issm -exec bash -c ' +h_max="$1" +h_min="$2" +shift 2 + +for dir do +( + hdir=$(pwd) + cd "$dir" || exit + name=$(basename "$dir") + + for f in "${name}_meshgen.py" "${name}_parameterize.py" "${name}_control.py" "${name}_finalize.py"; do + [[ -f "$f" ]] || exit + done + + source "$hdir/issm_env" + rm -f ISSM_${name}.bin ISSM_${name}.outbin ISSM_${name}.errlog + rm -rf netcdfs + + (export LD_LIBRARY_PATH=$PYTHON_LIB:$LD_LIBRARY_PATH; python ${name}_meshgen.py "$h_max" "$h_min") +) +done +' bash "$h_max" "$h_min" {} + + +source issm_env +domain_name=$( + LD_LIBRARY_PATH="$PYTHON_LIB:$LD_LIBRARY_PATH" \ + python ./utils_issm/domain_name.py +) + + +echo "" +echo "================================================================================================================" +echo "Candidate ISSM mesh:" +echo "" +echo "Domain name: $domain_name" +echo "(ME=mean edge length [meters], N = total nodes)" +echo "" +echo "================================================================================================================" +echo "" diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 index b4db17591b..3292704109 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/preproc/topography/utils_topo/generate_scrip_cube.F90 @@ -147,6 +147,7 @@ program ESMF_GenerateCSGridDescription real(ESMF_KIND_R8) :: epsilon integer :: l real(ESMF_KIND_R8) :: global_max_area, global_min_area,ratio + real(ESMF_KIND_R8) :: area_sum_local, area_sum_global, area_err real(ESMF_KIND_R8), allocatable :: my_corner_lat(:,:), my_corner_lon(:,:) real(ESMF_KIND_R8), allocatable :: A_uniform(:) real(ESMF_KIND_R8) :: max_rrfac_allowed @@ -582,12 +583,12 @@ program ESMF_GenerateCSGridDescription p3(1) = modulo(p3(1), 2.0d0*pi) p4(1) = modulo(p4(1), 2.0d0*pi) - ! compute area - area_signed = get_signed_area_spherical_polygon(p1,p2,p3,p4) - if (area_signed <= 0.d0 .or. abs(area_signed) < 1.0d-12) then - area_signed = 1.0d-12 - end if - SCRIP_Area(n) = abs(area_signed) + ! compute positive spherical area using the same method used by the regular-grid path + SCRIP_Area(n) = get_area_spherical_polygon(p1,p2,p3,p4) + + if (SCRIP_Area(n) /= SCRIP_Area(n) .or. SCRIP_Area(n) <= 0.0d0) then + SCRIP_Area(n) = 1.0d-12 + end if ! write fallback into SCRIP arrays SCRIP_CornerLon(:,n) = modulo([p1(1),p2(1),p3(1),p4(1)]*(180._8/pi),360.0_8) @@ -662,32 +663,46 @@ program ESMF_GenerateCSGridDescription ! 4) Reorder hull consistently -> p1,p2,p3,p4 call safe_reorder_hull(node_xy_tmp, hull, p1, p2, p3, p4, n, i, j) - area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) - + ! Use signed-area routine only as an orientation test. + ! Do NOT use it as the final cell area for stretched grids. + area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) + SCRIP_Area(n) = get_area_spherical_polygon(p1, p2, p3, p4) + ! If NaN/inf/tiny/huge area, rebuild a tiny CCW square and recompute - if (area_signed /= area_signed .or. abs(area_signed) < 1.0d-12 .or. abs(area_signed) > 1.0d10) then + if (area_signed /= area_signed .or. & + SCRIP_Area(n) /= SCRIP_Area(n) .or. & + SCRIP_Area(n) < 1.0d-12 .or. SCRIP_Area(n) > 1.0d10) then + clon = tmp_center_lons(i,j) clat = tmp_center_lats(i,j) tiny_dlon = 1.0d-4 * pi/180._8 tiny_dlat = 1.0d-4 * pi/180._8 + p1 = [modulo(clon-tiny_dlon,2*pi), clat-tiny_dlat] p2 = [modulo(clon+tiny_dlon,2*pi), clat-tiny_dlat] p3 = [modulo(clon+tiny_dlon,2*pi), clat+tiny_dlat] p4 = [modulo(clon-tiny_dlon,2*pi), clat+tiny_dlat] - area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) + + area_signed = get_signed_area_spherical_polygon(p1, p2, p3, p4) + SCRIP_Area(n) = get_area_spherical_polygon(p1, p2, p3, p4) fallback_mask(n) = .true. end if - - ! Enforce CCW orientation for SCRIP (positive signed area) + + ! Enforce CCW orientation for SCRIP, preserving current stretched-grid convention. if (area_signed < 0.0d0) then swap_p = p2; p2 = p4; p4 = swap_p - area_signed = -area_signed endif - - ! Write CCW corners and POSITIVE area + + !Write CCW corners and POSITIVE area SCRIP_CornerLon(:,n) = modulo([p1(1),p2(1),p3(1),p4(1)]*(180._8/pi), 360.0_8) SCRIP_CornerLat(:,n) = [p1(2),p2(2),p3(2),p4(2)]*(180._8/pi) - SCRIP_Area(n) = area_signed + + SCRIP_Area(n) = get_area_spherical_polygon(p1, p2, p3, p4) + + if (SCRIP_Area(n) /= SCRIP_Area(n) .or. SCRIP_Area(n) <= 0.0d0) then + SCRIP_Area(n) = 1.0d-12 + fallback_mask(n) = .true. + endif else ! ----- Regular grid path: enforce CLOCKWISE corners ----- @@ -772,6 +787,25 @@ program ESMF_GenerateCSGridDescription write(*,*) 'Finished per-cell geometry/length pass' call MPI_Barrier(mpiC, mpi_err) + !---------------- Global SCRIP area closure check ---------------- + area_sum_local = sum(SCRIP_Area(n_start:n_end)) + + call MPI_Allreduce(area_sum_local, area_sum_global, 1, MPI_DOUBLE_PRECISION, MPI_SUM, mpiC, mpi_err) + _VERIFY(mpi_err) + + area_err = abs(area_sum_global - 4.0d0*pi) + + if (localPet == 0) then + write(*,*) "SCRIP grid_area global sum:", area_sum_global + write(*,*) "Expected 4*pi:", 4.0d0*pi + write(*,*) "Absolute area error:", area_err + endif + + if (area_err > 1.0d-6) then + if (localPet == 0) write(*,*) "ERROR: SCRIP grid_area does not close to 4*pi" + call MPI_Abort(mpiC, 1, mpi_err) + endif + !---------------- Global min/max of per-cell length ---------------- local_max_length = maxval(local_max_length_all) local_min_length = minval(local_min_length_all) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt index ca7f56ea72..1a9989e3e0 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/CMakeLists.txt @@ -7,16 +7,11 @@ set(srcs ) set (exe_srcs - Scale_Catch.F90 - Scale_CatchCN.F90 cv_SaltRestart.F90 SaltIntSplitter.F90 SaltImpConverter.F90 mk_CICERestart.F90 - mk_CatchCNRestarts.F90 - mk_CatchRestarts.F90 mk_LakeLandiceSaltRestarts.F90 - mk_GEOSldasRestarts.F90 mk_catchANDcnRestarts.F90 ) @@ -32,7 +27,6 @@ foreach (src ${exe_srcs}) LIBS MAPL GFTL_SHARED::gftl-shared GEOS_SurfaceShared GEOSroute_GridComp GEOS_LandShared GEOS_CatchCNShared ${this}) endforeach () -install(PROGRAMS mk_Restarts DESTINATION bin) foreach (src ${exe_srcs}) string (REGEX REPLACE ".F90" ".x" exe ${src}) string (REGEX REPLACE ".F90" "" lname ${src}) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 deleted file mode 100644 index f792250313..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_Catch.F90 +++ /dev/null @@ -1,728 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program Scale_Catch - - use MAPL - - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD - - implicit none - - character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ - integer :: ftell - external :: ftell -#endif - integer :: bpos, epos, ntiles, n, nargs - integer :: old, new, sca - integer :: iargc - real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params - ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params - real :: WEMIN_IN, WEMIN_OUT - character*256 :: arg(6) - - type catch_rst - real, pointer :: bf1(:) - real, pointer :: bf2(:) - real, pointer :: bf3(:) - real, pointer :: vgwmax(:) - real, pointer :: cdcr1(:) - real, pointer :: cdcr2(:) - real, pointer :: psis(:) - real, pointer :: bee(:) - real, pointer :: poros(:) - real, pointer :: wpwet(:) - real, pointer :: cond(:) - real, pointer :: gnu(:) - real, pointer :: ars1(:) - real, pointer :: ars2(:) - real, pointer :: ars3(:) - real, pointer :: ara1(:) - real, pointer :: ara2(:) - real, pointer :: ara3(:) - real, pointer :: ara4(:) - real, pointer :: arw1(:) - real, pointer :: arw2(:) - real, pointer :: arw3(:) - real, pointer :: arw4(:) - real, pointer :: tsa1(:) - real, pointer :: tsa2(:) - real, pointer :: tsb1(:) - real, pointer :: tsb2(:) - real, pointer :: atau(:) - real, pointer :: btau(:) - real, pointer :: ity(:) - real, pointer :: tc(:,:) - real, pointer :: qc(:,:) - real, pointer :: capac(:) - real, pointer :: catdef(:) - real, pointer :: rzexc(:) - real, pointer :: srfexc(:) - real, pointer :: ghtcnt1(:) - real, pointer :: ghtcnt2(:) - real, pointer :: ghtcnt3(:) - real, pointer :: ghtcnt4(:) - real, pointer :: ghtcnt5(:) - real, pointer :: ghtcnt6(:) - real, pointer :: tsurf(:) - real, pointer :: wesnn1(:) - real, pointer :: wesnn2(:) - real, pointer :: wesnn3(:) - real, pointer :: htsnnn1(:) - real, pointer :: htsnnn2(:) - real, pointer :: htsnnn3(:) - real, pointer :: sndzn1(:) - real, pointer :: sndzn2(:) - real, pointer :: sndzn3(:) - real, pointer :: ch(:,:) - real, pointer :: cm(:,:) - real, pointer :: cq(:,:) - real, pointer :: fr(:,:) - real, pointer :: ww(:,:) - endtype catch_rst - - type(catch_rst) catch(3) - - real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 - real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT - real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out - - type(Netcdf4_fileformatter) :: formatter(3) - type(Filemetadata) :: cfg(3) - integer :: i, rc, filetype - integer :: status - character(256) :: Iam = "Scale_Catch" - -! Usage -! ----- - if (iargc() /= 6) then - write(*,*) "Usage: Scale_Catch " - call exit(2) - end if - - do n=1,6 - call getarg(n,arg(n)) - enddo - -! Open INPUT and Regridded Catch Files -! ------------------------------------ - read(arg(1),'(a)') fname1 - - read(arg(2),'(a)') fname2 - -! Open OUTPUT (Scaled) Catch File -! ------------------------------- - read(arg(3),'(a)') fname3 - - call MAPL_NCIOGetFileType(fname1, filetype, __RC__) - - if (filetype == 0) then - call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) - call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) - cfg(2)=formatter(2)%read(__RC__) - else - open(unit=10, file=trim(fname1), form='unformatted') - open(unit=20, file=trim(fname2), form='unformatted') - open(unit=30, file=trim(fname3), form='unformatted') - end if - -! Get SURFLAY Value -! ----------------- - read(arg(4),*) SURFLAY - read(arg(5),*) WEMIN_IN - read(arg(6),*) WEMIN_OUT - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - print *, 'SURFLAY: ',SURFLAY - - if (filetype ==0) then - - ntiles = cfg(1)%get_dimension('tile', __RC__) - - else - -! Determine NTILES -! ---------------- - bpos=0 - read(10) - epos = ftell(10) ! ending position of file pointer - ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind 10 - - end if - - write(6,100) ntiles - -! Allocate Catches -! ---------------- - do n=1,3 - call allocatch ( ntiles,catch(n) ) - enddo - -! Read INPUT Catches -! ------------------ - old = 1 - new = 2 - - if (filetype ==0) then - call readcatch_nc4 ( catch(old), formatter(old), __RC__ ) - call readcatch_nc4 ( catch(new), formatter(new), __RC__ ) - else - call readcatch ( 10,catch(old) ) - call readcatch ( 20,catch(new) ) - end if - -! Create Scaled Catch -! ------------------- - sca = 3 - - catch(sca) = catch(new) - -! 1) soil moisture prognostics -! ---------------------------- -! n = count( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! write(6,200) n,100*n/ntiles -! -! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & -! catch(old)%vgwmax ) -! -! catch(sca)%catdef = catch(new)%cdcr1 + & -! ( catch(old)%catdef-catch(old)%cdcr1 ) / & -! ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & -! ( catch(new)%cdcr2 -catch(new)%cdcr1 ) -! end where - - n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - - write(6,200) n,100*n/ntiles - -! Scale rxexc regardless of CDCR1, CDCR2 differences -! -------------------------------------------------- - catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & - catch(old)%vgwmax ) - -! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation -! ---------------------------------------------------------------------------------- - where (catch(old)%catdef .gt. catch(old)%cdcr1) - - catch(sca)%catdef = catch(new)%cdcr1 + & - ( catch(old)%catdef-catch(old)%cdcr1 ) / & - ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & - ( catch(new)%cdcr2 -catch(new)%cdcr1 ) - end where - -! Scale catdef also for the case where catdef le cdcr1. -! ----------------------------------------------------- - where( (catch(old)%catdef .le. catch(old)%cdcr1)) - catch(sca)%catdef = catch(old)%catdef * (catch(new)%cdcr1 / catch(old)%cdcr1) - end where - -! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) -! ------------ - print *, 'Performing Sanity Check ...' - allocate ( dzsf(ntiles) ) - allocate ( ar1( ntiles) ) - allocate ( ar2( ntiles) ) - allocate ( ar4( ntiles) ) - - dzsf = SURFLAY - - call catch_calc_soil_moist( ntiles, dzsf, & - catch(sca)%vgwmax, catch(sca)%cdcr1, catch(sca)%cdcr2, & - catch(sca)%psis, catch(sca)%bee, catch(sca)%poros, catch(sca)%wpwet, & - catch(sca)%ars1, catch(sca)%ars2, catch(sca)%ars3, & - catch(sca)%ara1, catch(sca)%ara2, catch(sca)%ara3, catch(sca)%ara4, & - catch(sca)%arw1, catch(sca)%arw2, catch(sca)%arw3, catch(sca)%arw4, & - catch(sca)%bf1, catch(sca)%bf2, & - catch(sca)%srfexc, catch(sca)%rzexc, catch(sca)%catdef, & - ar1, ar2, ar4 ) - - n = count( catch(sca)%catdef .ne. catch(new)%catdef ) - write(6,300) n,100*n/ntiles - n = count( catch(sca)%srfexc .ne. catch(new)%srfexc ) - write(6,400) n,100*n/ntiles - n = count( catch(sca)%rzexc .ne. catch(new)%rzexc ) - write(6,400) n,100*n/ntiles - -! (2) Ground heat -! --------------- - - allocate (TP_IN (N_GT, Ntiles)) - allocate (GHT_IN (N_GT, Ntiles)) - allocate (GHT_OUT(N_GT, Ntiles)) - allocate (FICE (N_GT, NTILES)) - allocate (TP_OUT (N_GT, Ntiles)) - - GHT_IN (1,:) = catch(old)%ghtcnt1 - GHT_IN (2,:) = catch(old)%ghtcnt2 - GHT_IN (3,:) = catch(old)%ghtcnt3 - GHT_IN (4,:) = catch(old)%ghtcnt4 - GHT_IN (5,:) = catch(old)%ghtcnt5 - GHT_IN (6,:) = catch(old)%ghtcnt6 - - call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) - GHT_OUT = GHT_IN - -! open (99,file='ght.diff', form = 'formatted') - - do n = 1, ntiles - do i = 1, N_GT - call catch_calc_ght(dzgt(i), catch(new)%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) -! if (i == N_GT) then -! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,catch(old)%poros(n),catch(new)%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) -! endif - end do - end do - - catch(sca)%ghtcnt1 = GHT_IN (1,:) - catch(sca)%ghtcnt2 = GHT_IN (2,:) - catch(sca)%ghtcnt3 = GHT_IN (3,:) - catch(sca)%ghtcnt4 = GHT_IN (4,:) - catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) - -! Deep soil temp sanity check -! --------------------------- - - call catch_calc_tp ( NTILES, catch(new)%poros, GHT_IN, tp_out, FICE) - - print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) - - -! SNOW scaling -! ------------ - - if(wemin_out /= wemin_in) then - - allocate (swe_in (Ntiles)) - allocate (depth_in (Ntiles)) - allocate (depth_out (Ntiles)) - allocate (areasc_in (Ntiles)) - allocate (areasc_out (Ntiles)) - - swe_in = catch(new)%wesnn1 + catch(new)%wesnn2 + catch(new)%wesnn3 - depth_in = catch(new)%sndzn1 + catch(new)%sndzn2 + catch(new)%sndzn3 - areasc_in = min(swe_in/wemin_in, 1.) - areasc_out= min(swe_in/wemin_out,1.) - - ! catch(sca)%sndzn1=catch(old)%sndzn1 - ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 - ! do i = 1, ntiles - ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then - ! print *, i, areasc_in(i), depth_in(i) - ! density_in(i)= swe_in(i)/(areasc_in(i) * depth_in(i)) - ! depth_out(i) = swe_in(i)/(areasc_out(i)*density_in(i)) - ! depth_out(i) = areasc_in(i) * depth_in(i)/(areasc_out(i) + 1.e-20) - ! print *, catch(sca)%sndzn1(i), catch(old)%sndzn1(i),wemin_out/wemin_in - ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif - ! end do - - where (swe_in .gt. 0.) - where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) - ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) - ! depth_out = swe_in/(areasc_out*density_in) - depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) - catch(sca)%sndzn1 = depth_out/3. - catch(sca)%sndzn2 = depth_out/3. - catch(sca)%sndzn3 = depth_out/3. - endwhere - endwhere - - print *, 'Snow scaling summary' - print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - - endif - - ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat - ! ------------------------------------------------------------------------------- - - where ( (catch(old)%poros < PEATCLSM_POROS_THRESHOLD) .and. (catch(sca)%poros >= PEATCLSM_POROS_THRESHOLD) ) - catch(sca)%catdef = 25. - catch(sca)%rzexc = 0. - catch(sca)%srfexc = 0. - end where - -! Write Scaled Catch -! ------------------ - if (filetype ==0) then - cfg(3)=cfg(2) - call formatter(3)%create(fname3, __RC__) - call formatter(3)%write(cfg(3), __RC__) - call writecatch_nc4 ( catch(sca), formatter(3) ) - else - call writecatch ( 30,catch(sca) ) - end if - -100 format(1x,'Total Tiles: ',i10) -200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') -300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') -400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') -500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') - - stop - - contains - - subroutine allocatch (ntiles,catch) - - integer ntiles - - type(catch_rst) catch - - allocate( catch% bf1(ntiles) ) - allocate( catch% bf2(ntiles) ) - allocate( catch% bf3(ntiles) ) - allocate( catch% vgwmax(ntiles) ) - allocate( catch% cdcr1(ntiles) ) - allocate( catch% cdcr2(ntiles) ) - allocate( catch% psis(ntiles) ) - allocate( catch% bee(ntiles) ) - allocate( catch% poros(ntiles) ) - allocate( catch% wpwet(ntiles) ) - allocate( catch% cond(ntiles) ) - allocate( catch% gnu(ntiles) ) - allocate( catch% ars1(ntiles) ) - allocate( catch% ars2(ntiles) ) - allocate( catch% ars3(ntiles) ) - allocate( catch% ara1(ntiles) ) - allocate( catch% ara2(ntiles) ) - allocate( catch% ara3(ntiles) ) - allocate( catch% ara4(ntiles) ) - allocate( catch% arw1(ntiles) ) - allocate( catch% arw2(ntiles) ) - allocate( catch% arw3(ntiles) ) - allocate( catch% arw4(ntiles) ) - allocate( catch% tsa1(ntiles) ) - allocate( catch% tsa2(ntiles) ) - allocate( catch% tsb1(ntiles) ) - allocate( catch% tsb2(ntiles) ) - allocate( catch% atau(ntiles) ) - allocate( catch% btau(ntiles) ) - allocate( catch% ity(ntiles) ) - allocate( catch% tc(ntiles,4) ) - allocate( catch% qc(ntiles,4) ) - allocate( catch% capac(ntiles) ) - allocate( catch% catdef(ntiles) ) - allocate( catch% rzexc(ntiles) ) - allocate( catch% srfexc(ntiles) ) - allocate( catch% ghtcnt1(ntiles) ) - allocate( catch% ghtcnt2(ntiles) ) - allocate( catch% ghtcnt3(ntiles) ) - allocate( catch% ghtcnt4(ntiles) ) - allocate( catch% ghtcnt5(ntiles) ) - allocate( catch% ghtcnt6(ntiles) ) - allocate( catch% tsurf(ntiles) ) - allocate( catch% wesnn1(ntiles) ) - allocate( catch% wesnn2(ntiles) ) - allocate( catch% wesnn3(ntiles) ) - allocate( catch% htsnnn1(ntiles) ) - allocate( catch% htsnnn2(ntiles) ) - allocate( catch% htsnnn3(ntiles) ) - allocate( catch% sndzn1(ntiles) ) - allocate( catch% sndzn2(ntiles) ) - allocate( catch% sndzn3(ntiles) ) - allocate( catch% ch(ntiles,4) ) - allocate( catch% cm(ntiles,4) ) - allocate( catch% cq(ntiles,4) ) - allocate( catch% fr(ntiles,4) ) - allocate( catch% ww(ntiles,4) ) - - return - end subroutine allocatch - - subroutine readcatch_nc4 (catch,formatter, rc) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - integer, optional, intent(out) :: rc - integer :: status - character(256) :: Iam = "readcatch_nc4" - - call MAPL_VarRead(formatter,"BF1",catch%bf1, __RC__) - call MAPL_VarRead(formatter,"BF2",catch%bf2, __RC__) - call MAPL_VarRead(formatter,"BF3",catch%bf3, __RC__) - call MAPL_VarRead(formatter,"VGWMAX",catch%vgwmax, __RC__) - call MAPL_VarRead(formatter,"CDCR1",catch%cdcr1, __RC__) - call MAPL_VarRead(formatter,"CDCR2",catch%cdcr2, __RC__) - call MAPL_VarRead(formatter,"PSIS",catch%psis, __RC__) - call MAPL_VarRead(formatter,"BEE",catch%bee, __RC__) - call MAPL_VarRead(formatter,"POROS",catch%poros, __RC__) - call MAPL_VarRead(formatter,"WPWET",catch%wpwet, __RC__) - call MAPL_VarRead(formatter,"COND",catch%cond, __RC__) - call MAPL_VarRead(formatter,"GNU",catch%gnu, __RC__) - call MAPL_VarRead(formatter,"ARS1",catch%ars1, __RC__) - call MAPL_VarRead(formatter,"ARS2",catch%ars2, __RC__) - call MAPL_VarRead(formatter,"ARS3",catch%ars3, __RC__) - call MAPL_VarRead(formatter,"ARA1",catch%ara1, __RC__) - call MAPL_VarRead(formatter,"ARA2",catch%ara2, __RC__) - call MAPL_VarRead(formatter,"ARA3",catch%ara3, __RC__) - call MAPL_VarRead(formatter,"ARA4",catch%ara4, __RC__) - call MAPL_VarRead(formatter,"ARW1",catch%arw1, __RC__) - call MAPL_VarRead(formatter,"ARW2",catch%arw2, __RC__) - call MAPL_VarRead(formatter,"ARW3",catch%arw3, __RC__) - call MAPL_VarRead(formatter,"ARW4",catch%arw4, __RC__) - call MAPL_VarRead(formatter,"TSA1",catch%tsa1, __RC__) - call MAPL_VarRead(formatter,"TSA2",catch%tsa2, __RC__) - call MAPL_VarRead(formatter,"TSB1",catch%tsb1, __RC__) - call MAPL_VarRead(formatter,"TSB2",catch%tsb2, __RC__) - call MAPL_VarRead(formatter,"ATAU",catch%atau, __RC__) - call MAPL_VarRead(formatter,"BTAU",catch%btau, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) - call MAPL_VarRead(formatter,"TC",catch%tc, __RC__) - call MAPL_VarRead(formatter,"QC",catch%qc, __RC__) - call MAPL_VarRead(formatter,"OLD_ITY",catch%ity, __RC__) - call MAPL_VarRead(formatter,"CAPAC",catch%capac, __RC__) - call MAPL_VarRead(formatter,"CATDEF",catch%catdef, __RC__) - call MAPL_VarRead(formatter,"RZEXC",catch%rzexc, __RC__) - call MAPL_VarRead(formatter,"SRFEXC",catch%srfexc, __RC__) - call MAPL_VarRead(formatter,"GHTCNT1",catch%ghtcnt1, __RC__) - call MAPL_VarRead(formatter,"GHTCNT2",catch%ghtcnt2, __RC__) - call MAPL_VarRead(formatter,"GHTCNT3",catch%ghtcnt3, __RC__) - call MAPL_VarRead(formatter,"GHTCNT4",catch%ghtcnt4, __RC__) - call MAPL_VarRead(formatter,"GHTCNT5",catch%ghtcnt5, __RC__) - call MAPL_VarRead(formatter,"GHTCNT6",catch%ghtcnt6, __RC__) - call MAPL_VarRead(formatter,"TSURF",catch%tsurf, __RC__) - call MAPL_VarRead(formatter,"WESNN1",catch%wesnn1, __RC__) - call MAPL_VarRead(formatter,"WESNN2",catch%wesnn2, __RC__) - call MAPL_VarRead(formatter,"WESNN3",catch%wesnn3, __RC__) - call MAPL_VarRead(formatter,"HTSNNN1",catch%htsnnn1, __RC__) - call MAPL_VarRead(formatter,"HTSNNN2",catch%htsnnn2, __RC__) - call MAPL_VarRead(formatter,"HTSNNN3",catch%htsnnn3, __RC__) - call MAPL_VarRead(formatter,"SNDZN1",catch%sndzn1, __RC__) - call MAPL_VarRead(formatter,"SNDZN2",catch%sndzn2, __RC__) - call MAPL_VarRead(formatter,"SNDZN3",catch%sndzn3, __RC__) - call MAPL_VarRead(formatter,"CH",catch%ch, __RC__) - call MAPL_VarRead(formatter,"CM",catch%cm, __RC__) - call MAPL_VarRead(formatter,"CQ",catch%cq, __RC__) - call MAPL_VarRead(formatter,"FR",catch%fr, __RC__) - call MAPL_VarRead(formatter,"WW",catch%ww, __RC__) - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - end subroutine readcatch_nc4 - - subroutine readcatch (unit,catch) - integer unit - type(catch_rst) catch - - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww - - return - end subroutine readcatch - - subroutine writecatch_nc4 (catch,formatter) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - - call MAPL_VarWrite(formatter,"BF1",catch%bf1) - call MAPL_VarWrite(formatter,"BF2",catch%bf2) - call MAPL_VarWrite(formatter,"BF3",catch%bf3) - call MAPL_VarWrite(formatter,"VGWMAX",catch%vgwmax) - call MAPL_VarWrite(formatter,"CDCR1",catch%cdcr1) - call MAPL_VarWrite(formatter,"CDCR2",catch%cdcr2) - call MAPL_VarWrite(formatter,"PSIS",catch%psis) - call MAPL_VarWrite(formatter,"BEE",catch%bee) - call MAPL_VarWrite(formatter,"POROS",catch%poros) - call MAPL_VarWrite(formatter,"WPWET",catch%wpwet) - call MAPL_VarWrite(formatter,"COND",catch%cond) - call MAPL_VarWrite(formatter,"GNU",catch%gnu) - call MAPL_VarWrite(formatter,"ARS1",catch%ars1) - call MAPL_VarWrite(formatter,"ARS2",catch%ars2) - call MAPL_VarWrite(formatter,"ARS3",catch%ars3) - call MAPL_VarWrite(formatter,"ARA1",catch%ara1) - call MAPL_VarWrite(formatter,"ARA2",catch%ara2) - call MAPL_VarWrite(formatter,"ARA3",catch%ara3) - call MAPL_VarWrite(formatter,"ARA4",catch%ara4) - call MAPL_VarWrite(formatter,"ARW1",catch%arw1) - call MAPL_VarWrite(formatter,"ARW2",catch%arw2) - call MAPL_VarWrite(formatter,"ARW3",catch%arw3) - call MAPL_VarWrite(formatter,"ARW4",catch%arw4) - call MAPL_VarWrite(formatter,"TSA1",catch%tsa1) - call MAPL_VarWrite(formatter,"TSA2",catch%tsa2) - call MAPL_VarWrite(formatter,"TSB1",catch%tsb1) - call MAPL_VarWrite(formatter,"TSB2",catch%tsb2) - call MAPL_VarWrite(formatter,"ATAU",catch%atau) - call MAPL_VarWrite(formatter,"BTAU",catch%btau) - call MAPL_VarWrite(formatter,"OLD_ITY",catch%ity) - call MAPL_VarWrite(formatter,"TC",catch%tc) - call MAPL_VarWrite(formatter,"QC",catch%qc) - call MAPL_VarWrite(formatter,"OLD_ITY",catch%ity) - call MAPL_VarWrite(formatter,"CAPAC",catch%capac) - call MAPL_VarWrite(formatter,"CATDEF",catch%catdef) - call MAPL_VarWrite(formatter,"RZEXC",catch%rzexc) - call MAPL_VarWrite(formatter,"SRFEXC",catch%srfexc) - call MAPL_VarWrite(formatter,"GHTCNT1",catch%ghtcnt1) - call MAPL_VarWrite(formatter,"GHTCNT2",catch%ghtcnt2) - call MAPL_VarWrite(formatter,"GHTCNT3",catch%ghtcnt3) - call MAPL_VarWrite(formatter,"GHTCNT4",catch%ghtcnt4) - call MAPL_VarWrite(formatter,"GHTCNT5",catch%ghtcnt5) - call MAPL_VarWrite(formatter,"GHTCNT6",catch%ghtcnt6) - call MAPL_VarWrite(formatter,"TSURF",catch%tsurf) - call MAPL_VarWrite(formatter,"WESNN1",catch%wesnn1) - call MAPL_VarWrite(formatter,"WESNN2",catch%wesnn2) - call MAPL_VarWrite(formatter,"WESNN3",catch%wesnn3) - call MAPL_VarWrite(formatter,"HTSNNN1",catch%htsnnn1) - call MAPL_VarWrite(formatter,"HTSNNN2",catch%htsnnn2) - call MAPL_VarWrite(formatter,"HTSNNN3",catch%htsnnn3) - call MAPL_VarWrite(formatter,"SNDZN1",catch%sndzn1) - call MAPL_VarWrite(formatter,"SNDZN2",catch%sndzn2) - call MAPL_VarWrite(formatter,"SNDZN3",catch%sndzn3) - call MAPL_VarWrite(formatter,"CH",catch%ch) - call MAPL_VarWrite(formatter,"CM",catch%cm) - call MAPL_VarWrite(formatter,"CQ",catch%cq) - call MAPL_VarWrite(formatter,"FR",catch%fr) - call MAPL_VarWrite(formatter,"WW",catch%ww) - - return - end subroutine writecatch_nc4 - - subroutine writecatch (unit,catch) - integer unit - type(catch_rst) catch - - write(unit) catch% bf1 - write(unit) catch% bf2 - write(unit) catch% bf3 - write(unit) catch% vgwmax - write(unit) catch% cdcr1 - write(unit) catch% cdcr2 - write(unit) catch% psis - write(unit) catch% bee - write(unit) catch% poros - write(unit) catch% wpwet - write(unit) catch% cond - write(unit) catch% gnu - write(unit) catch% ars1 - write(unit) catch% ars2 - write(unit) catch% ars3 - write(unit) catch% ara1 - write(unit) catch% ara2 - write(unit) catch% ara3 - write(unit) catch% ara4 - write(unit) catch% arw1 - write(unit) catch% arw2 - write(unit) catch% arw3 - write(unit) catch% arw4 - write(unit) catch% tsa1 - write(unit) catch% tsa2 - write(unit) catch% tsb1 - write(unit) catch% tsb2 - write(unit) catch% atau - write(unit) catch% btau - write(unit) catch% ity - write(unit) catch% tc - write(unit) catch% qc - write(unit) catch% capac - write(unit) catch% catdef - write(unit) catch% rzexc - write(unit) catch% srfexc - write(unit) catch% ghtcnt1 - write(unit) catch% ghtcnt2 - write(unit) catch% ghtcnt3 - write(unit) catch% ghtcnt4 - write(unit) catch% ghtcnt5 - write(unit) catch% ghtcnt6 - write(unit) catch% tsurf - write(unit) catch% wesnn1 - write(unit) catch% wesnn2 - write(unit) catch% wesnn3 - write(unit) catch% htsnnn1 - write(unit) catch% htsnnn2 - write(unit) catch% htsnnn3 - write(unit) catch% sndzn1 - write(unit) catch% sndzn2 - write(unit) catch% sndzn3 - write(unit) catch% ch - write(unit) catch% cm - write(unit) catch% cq - write(unit) catch% fr - write(unit) catch% ww - - return - end subroutine writecatch - - end program diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 deleted file mode 100755 index cd2bce354d..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/Scale_CatchCN.F90 +++ /dev/null @@ -1,962 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program Scale_CatchCN - - use MAPL - - use LSM_ROUTINES, ONLY: & - catch_calc_soil_moist, & - catch_calc_tp, & - catch_calc_ght - - USE CATCH_CONSTANTS, ONLY: & - N_GT => CATCH_N_GT, & - DZGT => CATCH_DZGT, & - PEATCLSM_POROS_THRESHOLD - - implicit none - - character(256) :: fname1, fname2, fname3 -#ifndef __GFORTRAN__ - integer :: ftell - external :: ftell -#endif - integer :: bpos, epos, ntiles, n, nargs - integer :: old, new, sca - integer :: iargc - real :: SURFLAY ! (Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params - ! (Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params - real :: WEMIN_IN, WEMIN_OUT - character*256 :: arg(6) - - integer, parameter :: nveg = 4 - integer, parameter :: nzone = 3 - integer :: VAR_COL, VAR_PFT - integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 - integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - - logical :: clm45 = .false. - integer :: un_dim3 - - type catch_rst - real, pointer :: bf1(:) - real, pointer :: bf2(:) - real, pointer :: bf3(:) - real, pointer :: vgwmax(:) - real, pointer :: cdcr1(:) - real, pointer :: cdcr2(:) - real, pointer :: psis(:) - real, pointer :: bee(:) - real, pointer :: poros(:) - real, pointer :: wpwet(:) - real, pointer :: cond(:) - real, pointer :: gnu(:) - real, pointer :: ars1(:) - real, pointer :: ars2(:) - real, pointer :: ars3(:) - real, pointer :: ara1(:) - real, pointer :: ara2(:) - real, pointer :: ara3(:) - real, pointer :: ara4(:) - real, pointer :: arw1(:) - real, pointer :: arw2(:) - real, pointer :: arw3(:) - real, pointer :: arw4(:) - real, pointer :: tsa1(:) - real, pointer :: tsa2(:) - real, pointer :: tsb1(:) - real, pointer :: tsb2(:) - real, pointer :: atau(:) - real, pointer :: btau(:) - real, pointer :: ity(:,:) - real, pointer :: fvg(:,:) - real, pointer :: tc(:,:) - real, pointer :: qc(:,:) - real, pointer :: tg(:,:) - real, pointer :: capac(:) - real, pointer :: catdef(:) - real, pointer :: rzexc(:) - real, pointer :: srfexc(:) - real, pointer :: ghtcnt1(:) - real, pointer :: ghtcnt2(:) - real, pointer :: ghtcnt3(:) - real, pointer :: ghtcnt4(:) - real, pointer :: ghtcnt5(:) - real, pointer :: ghtcnt6(:) - real, pointer :: tsurf(:) - real, pointer :: wesnn1(:) - real, pointer :: wesnn2(:) - real, pointer :: wesnn3(:) - real, pointer :: htsnnn1(:) - real, pointer :: htsnnn2(:) - real, pointer :: htsnnn3(:) - real, pointer :: sndzn1(:) - real, pointer :: sndzn2(:) - real, pointer :: sndzn3(:) - real, pointer :: ch(:,:) - real, pointer :: cm(:,:) - real, pointer :: cq(:,:) - real, pointer :: fr(:,:) - real, pointer :: ww(:,:) - real, pointer :: TILE_ID(:) - real, pointer :: ndep(:) - real, pointer :: t2(:) - real, pointer :: BGALBVR(:) - real, pointer :: BGALBVF(:) - real, pointer :: BGALBNR(:) - real, pointer :: BGALBNF(:) - real, pointer :: CNCOL(:,:) - real, pointer :: CNPFT(:,:) - real, pointer :: ABM (:) - real, pointer :: FIELDCAP(:) - real, pointer :: HDM (:) - real, pointer :: GDP (:) - real, pointer :: PEATF (:) - endtype catch_rst - - type(catch_rst) catch(3) - - real, allocatable, dimension(:) :: dzsf, ar1, ar2, ar4 - real, allocatable, dimension(:,:) :: TP_IN, GHT_IN, FICE, GHT_OUT, TP_OUT - real, allocatable, dimension(:) :: swe_in, depth_in, areasc_in, areasc_out, depth_out - - type(Netcdf4_fileformatter) :: formatter(3) - type(Filemetadata) :: cfg(3) - integer :: i, rc, filetype - integer :: status - character(256) :: Iam = "Scale_CatchCN" - -! Usage -! ----- - if (iargc() /= 6) then - write(*,*) "Usage: Scale_CatchCN " - call exit(2) - end if - - do n=1,6 - call getarg(n,arg(n)) - enddo - -! Open INPUT and Regridded Catch Files -! ------------------------------------ - read(arg(1),'(a)') fname1 - - read(arg(2),'(a)') fname2 - -! Open OUTPUT (Scaled) Catch File -! ------------------------------- - read(arg(3),'(a)') fname3 - - call MAPL_NCIOGetFileType(fname1, filetype, __RC__) - - if (filetype == 0) then - call formatter(1)%open(trim(fname1),pFIO_READ, __RC__) - call formatter(2)%open(trim(fname2),pFIO_READ, __RC__) - cfg(1)=formatter(1)%read(__RC__) - cfg(2)=formatter(2)%read(__RC__) - ! else - ! open(unit=10, file=trim(fname1), form='unformatted') - ! open(unit=20, file=trim(fname2), form='unformatted') - ! open(unit=30, file=trim(fname3), form='unformatted') - end if - -! Get SURFLAY Value -! ----------------- - read(arg(4),*) SURFLAY - read(arg(5),*) WEMIN_IN - read(arg(6),*) WEMIN_OUT - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - print *, 'SURFLAY: ',SURFLAY - - VAR_COL = VAR_COL_CLM40 - VAR_PFT = VAR_PFT_CLM40 - - if (filetype ==0) then - - ntiles = cfg(1)%get_dimension('tile', __RC__) - un_dim3 = cfg(1)%get_dimension('unknown_dim3', __RC__) - if(un_dim3 == 105) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif -! else -! -!! Determine NTILES -!! ---------------- -! bpos=0 -! read(10) -! epos = ftell(10) ! ending position of file pointer -! ntiles = (epos-bpos)/4-2 ! record size (in 4 byte words; -! rewind 10 - - end if - - write(6,100) ntiles - -! Allocate Catches -! ---------------- - do n=1,3 - call allocatch ( ntiles,catch(n) ) - enddo - -! Read INPUT Catches -! ------------------ - old = 1 - new = 2 - - if (filetype ==0) then - call readcatchcn_nc4 ( catch(old), formatter(old), cfg(old), __RC__ ) - call readcatchcn_nc4 ( catch(new), formatter(new), cfg(new), __RC__ ) -! else -! call readcatchcn ( 10,catch(old) ) -! call readcatchcn ( 20,catch(new) ) - end if - -! Create Scaled Catch -! ------------------- - sca = 3 - - catch(sca) = catch(new) - -! 1) soil moisture prognostics -! ---------------------------- -! n = count( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! write(6,200) n,100*n/ntiles -! -! where( (catch(old)%catdef .gt. catch(old)%cdcr1) .and. & -! (catch(new)%cdcr2 .gt. catch(old)%cdcr2) ) -! -! catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & -! catch(old)%vgwmax ) -! -! catch(sca)%catdef = catch(new)%cdcr1 + & -! ( catch(old)%catdef-catch(old)%cdcr1 ) / & -! ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & -! ( catch(new)%cdcr2 -catch(new)%cdcr1 ) -! end where - - n =count((catch(old)%catdef .gt. catch(old)%cdcr1)) - - write(6,200) n,100*n/ntiles - -! Scale rxexc regardless of CDCR1, CDCR2 differences -! -------------------------------------------------- - catch(sca)%rzexc = catch(old)%rzexc * ( catch(new)%vgwmax / & - catch(old)%vgwmax ) - -! Scale catdef regardless of whether CDCR2 is larger or smaller in the new situation -! ---------------------------------------------------------------------------------- - where (catch(old)%catdef .gt. catch(old)%cdcr1) - - catch(sca)%catdef = catch(new)%cdcr1 + & - ( catch(old)%catdef-catch(old)%cdcr1 ) / & - ( catch(old)%cdcr2 -catch(old)%cdcr1 ) * & - ( catch(new)%cdcr2 -catch(new)%cdcr1 ) - end where - -! Scale catdef also for the case where catdef le cdcr1. -! ----------------------------------------------------- - where( (catch(old)%catdef .le. catch(old)%cdcr1)) - catch(sca)%catdef = catch(old)%catdef * (catch(new)%cdcr1 / catch(old)%cdcr1) - end where - -! Sanity Check (catch_calc_soil_moist() forces consistency betw. srfexc, rzexc, catdef) -! ------------ - print *, 'Performing Sanity Check ...' - allocate ( dzsf(ntiles) ) - allocate ( ar1( ntiles) ) - allocate ( ar2( ntiles) ) - allocate ( ar4( ntiles) ) - - dzsf = SURFLAY - - call catch_calc_soil_moist( ntiles, dzsf, & - catch(sca)%vgwmax, catch(sca)%cdcr1, catch(sca)%cdcr2, & - catch(sca)%psis, catch(sca)%bee, catch(sca)%poros, catch(sca)%wpwet, & - catch(sca)%ars1, catch(sca)%ars2, catch(sca)%ars3, & - catch(sca)%ara1, catch(sca)%ara2, catch(sca)%ara3, catch(sca)%ara4, & - catch(sca)%arw1, catch(sca)%arw2, catch(sca)%arw3, catch(sca)%arw4, & - catch(sca)%bf1, catch(sca)%bf2, & - catch(sca)%srfexc, catch(sca)%rzexc, catch(sca)%catdef, & - ar1, ar2, ar4 ) - - n = count( catch(sca)%catdef .ne. catch(new)%catdef ) - write(6,300) n,100*n/ntiles - n = count( catch(sca)%srfexc .ne. catch(new)%srfexc ) - write(6,400) n,100*n/ntiles - n = count( catch(sca)%rzexc .ne. catch(new)%rzexc ) - write(6,400) n,100*n/ntiles - -! (2) Ground heat -! --------------- - - allocate (TP_IN (N_GT, Ntiles)) - allocate (GHT_IN (N_GT, Ntiles)) - allocate (GHT_OUT(N_GT, Ntiles)) - allocate (FICE (N_GT, NTILES)) - allocate (TP_OUT (N_GT, Ntiles)) - - GHT_IN (1,:) = catch(old)%ghtcnt1 - GHT_IN (2,:) = catch(old)%ghtcnt2 - GHT_IN (3,:) = catch(old)%ghtcnt3 - GHT_IN (4,:) = catch(old)%ghtcnt4 - GHT_IN (5,:) = catch(old)%ghtcnt5 - GHT_IN (6,:) = catch(old)%ghtcnt6 - - call catch_calc_tp ( NTILES, catch(old)%poros, GHT_IN, tp_in, FICE) - GHT_OUT = GHT_IN - -! open (99,file='ght.diff', form = 'formatted') - - do n = 1, ntiles - do i = 1, N_GT - call catch_calc_ght(dzgt(i), catch(new)%poros(n), tp_in(i,n), fice(i,n), GHT_IN(i,n)) -! if (i == N_GT) then -! if (GHT_IN(i,n) /= GHT_OUT(i,n)) write (99,*)n,catch(old)%poros(n),catch(new)%poros(n),ABS(GHT_IN(i,n)-GHT_OUT(i,n)) -! endif - end do - end do - - catch(sca)%ghtcnt1 = GHT_IN (1,:) - catch(sca)%ghtcnt2 = GHT_IN (2,:) - catch(sca)%ghtcnt3 = GHT_IN (3,:) - catch(sca)%ghtcnt4 = GHT_IN (4,:) - catch(sca)%ghtcnt5 = GHT_IN (5,:) - catch(sca)%ghtcnt6 = GHT_IN (6,:) - -! Deep soil temp sanity check -! --------------------------- - - call catch_calc_tp ( NTILES, catch(new)%poros, GHT_IN, tp_out, FICE) - - print *, 'Percent tiles TP Layer 1 differ : ', 100.* count(ABS(tp_out(1,:) - tp_in(1,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 2 differ : ', 100.* count(ABS(tp_out(2,:) - tp_in(2,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 3 differ : ', 100.* count(ABS(tp_out(3,:) - tp_in(3,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 4 differ : ', 100.* count(ABS(tp_out(4,:) - tp_in(4,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 5 differ : ', 100.* count(ABS(tp_out(5,:) - tp_in(5,:)) > 1.e-5) /float (Ntiles) - print *, 'Percent tiles TP Layer 6 differ : ', 100.* count(ABS(tp_out(6,:) - tp_in(6,:)) > 1.e-5) /float (Ntiles) - - -! SNOW scaling -! ------------ - - if(wemin_out /= wemin_in) then - - allocate (swe_in (Ntiles)) - allocate (depth_in (Ntiles)) - allocate (depth_out (Ntiles)) - allocate (areasc_in (Ntiles)) - allocate (areasc_out (Ntiles)) - - swe_in = catch(new)%wesnn1 + catch(new)%wesnn2 + catch(new)%wesnn3 - depth_in = catch(new)%sndzn1 + catch(new)%sndzn2 + catch(new)%sndzn3 - areasc_in = min(swe_in/wemin_in, 1.) - areasc_out= min(swe_in/wemin_out,1.) - - ! catch(sca)%sndzn1=catch(old)%sndzn1 - ! catch(sca)%sndzn2=catch(old)%sndzn2 - ! catch(sca)%sndzn3=catch(old)%sndzn3 - ! do i = 1, ntiles - ! if((swe_in(i) > 0.).and. ((areasc_in(i) < 1.).OR.(areasc_out(i) < 1.))) then - ! print *, i, areasc_in(i), depth_in(i) - ! density_in(i)= swe_in(i)/(areasc_in(i) * depth_in(i)) - ! depth_out(i) = swe_in(i)/(areasc_out(i)*density_in(i)) - ! depth_out(i) = areasc_in(i) * depth_in(i)/(areasc_out(i) + 1.e-20) - ! print *, catch(sca)%sndzn1(i), catch(old)%sndzn1(i),wemin_out/wemin_in - ! catch(sca)%sndzn1(i) = catch(new)%sndzn1(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn2(i) = catch(new)%sndzn2(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! catch(sca)%sndzn3(i) = catch(new)%sndzn3(i)*wemin_out/wemin_in ! depth_out(i)/3. - ! endif - ! end do - - where (swe_in .gt. 0.) - where (areasc_in .lt. 1. .or. areasc_out .lt. 1.) - ! density_in= swe_in/(areasc_in * depth_in + 1.e-20) - ! depth_out = swe_in/(areasc_out*density_in) - depth_out = areasc_in * depth_in/(areasc_out + 1.e-20) - catch(sca)%sndzn1 = depth_out/3. - catch(sca)%sndzn2 = depth_out/3. - catch(sca)%sndzn3 = depth_out/3. - endwhere - endwhere - - print *, 'Snow scaling summary' - print *, '....................' - print *, 'Percent tiles SNDZ scaled : ', 100.* count (catch(sca)%sndzn3 .ne. catch(old)%sndzn3) /float (count (catch(sca)%sndzn3 > 0.)) - - endif - - ! PEATCLSM - ensure low CATDEF on peat tiles where "old" restart is not also peat - ! ------------------------------------------------------------------------------- - - where ( (catch(old)%poros < PEATCLSM_POROS_THRESHOLD) .and. (catch(sca)%poros >= PEATCLSM_POROS_THRESHOLD) ) - catch(sca)%catdef = 25. - catch(sca)%rzexc = 0. - catch(sca)%srfexc = 0. - end where - -! Write Scaled Catch -! ------------------ - if (filetype ==0) then - cfg(3)=cfg(2) - call formatter(3)%create(fname3, __RC__) - call formatter(3)%write(cfg(3), __RC__) - call writecatchcn_nc4 ( catch(sca), formatter(3) ,cfg(3) ) -! else -! call writecatchcn ( 30,catch(sca) ) - end if - -100 format(1x,'Total Tiles: ',i10) -200 format(1x,'Scaled Tiles: ',i10,2x,'(',i2.2,'%)') -300 format(1x,'CatDef Tiles: ',i10,2x,'(',i2.2,'%)') -400 format(1x,'SrfExc Tiles: ',i10,2x,'(',i2.2,'%)') -500 format(1x,' Rzexc Tiles: ',i10,2x,'(',i2.2,'%)') - - stop - - contains - - subroutine allocatch (ntiles,catch) - - integer ntiles - - type(catch_rst) catch - - allocate( catch% bf1(ntiles) ) - allocate( catch% bf2(ntiles) ) - allocate( catch% bf3(ntiles) ) - allocate( catch% vgwmax(ntiles) ) - allocate( catch% cdcr1(ntiles) ) - allocate( catch% cdcr2(ntiles) ) - allocate( catch% psis(ntiles) ) - allocate( catch% bee(ntiles) ) - allocate( catch% poros(ntiles) ) - allocate( catch% wpwet(ntiles) ) - allocate( catch% cond(ntiles) ) - allocate( catch% gnu(ntiles) ) - allocate( catch% ars1(ntiles) ) - allocate( catch% ars2(ntiles) ) - allocate( catch% ars3(ntiles) ) - allocate( catch% ara1(ntiles) ) - allocate( catch% ara2(ntiles) ) - allocate( catch% ara3(ntiles) ) - allocate( catch% ara4(ntiles) ) - allocate( catch% arw1(ntiles) ) - allocate( catch% arw2(ntiles) ) - allocate( catch% arw3(ntiles) ) - allocate( catch% arw4(ntiles) ) - allocate( catch% tsa1(ntiles) ) - allocate( catch% tsa2(ntiles) ) - allocate( catch% tsb1(ntiles) ) - allocate( catch% tsb2(ntiles) ) - allocate( catch% atau(ntiles) ) - allocate( catch% btau(ntiles) ) - allocate( catch% ity(ntiles,4) ) - allocate( catch% fvg(ntiles,4) ) - allocate( catch% tc(ntiles,4) ) - allocate( catch% qc(ntiles,4) ) - allocate( catch% tg(ntiles,4) ) - allocate( catch% capac(ntiles) ) - allocate( catch% catdef(ntiles) ) - allocate( catch% rzexc(ntiles) ) - allocate( catch% srfexc(ntiles) ) - allocate( catch% ghtcnt1(ntiles) ) - allocate( catch% ghtcnt2(ntiles) ) - allocate( catch% ghtcnt3(ntiles) ) - allocate( catch% ghtcnt4(ntiles) ) - allocate( catch% ghtcnt5(ntiles) ) - allocate( catch% ghtcnt6(ntiles) ) - allocate( catch% tsurf(ntiles) ) - allocate( catch% wesnn1(ntiles) ) - allocate( catch% wesnn2(ntiles) ) - allocate( catch% wesnn3(ntiles) ) - allocate( catch% htsnnn1(ntiles) ) - allocate( catch% htsnnn2(ntiles) ) - allocate( catch% htsnnn3(ntiles) ) - allocate( catch% sndzn1(ntiles) ) - allocate( catch% sndzn2(ntiles) ) - allocate( catch% sndzn3(ntiles) ) - allocate( catch% ch(ntiles,4) ) - allocate( catch% cm(ntiles,4) ) - allocate( catch% cq(ntiles,4) ) - allocate( catch% fr(ntiles,4) ) - allocate( catch% ww(ntiles,4) ) - allocate( catch% TILE_ID(ntiles) ) - allocate( catch% ndep(ntiles) ) - allocate( catch% t2(ntiles) ) - allocate( catch% BGALBVR(ntiles) ) - allocate( catch% BGALBVF(ntiles) ) - allocate( catch% BGALBNR(ntiles) ) - allocate( catch% BGALBNF(ntiles) ) - allocate( catch% CNCOL(ntiles,nzone*VAR_COL)) - allocate( catch% CNPFT(ntiles,nzone*nveg*VAR_PFT)) - allocate( catch% ABM(ntiles) ) - allocate( catch% FIELDCAP(ntiles) ) - allocate( catch% HDM(ntiles) ) - allocate( catch% GDP(ntiles) ) - allocate( catch% PEATF(ntiles) ) - - return - end subroutine allocatch - - subroutine readcatchcn_nc4 (catch,formatter,cfg, rc) - type(catch_rst) catch - type(Filemetadata) :: cfg - type(Netcdf4_fileformatter) :: formatter - integer, optional, intent(out) :: rc - integer :: j, dim1,dim2 - type(Variable), pointer :: myVariable - character(len=:), pointer :: dname - integer :: status - character(256) :: Iam = "readcatchcn_nc4" - - call MAPL_VarRead(formatter,"BF1",catch%bf1, __RC__) - call MAPL_VarRead(formatter,"BF2",catch%bf2, __RC__) - call MAPL_VarRead(formatter,"BF3",catch%bf3, __RC__) - call MAPL_VarRead(formatter,"VGWMAX",catch%vgwmax, __RC__) - call MAPL_VarRead(formatter,"CDCR1",catch%cdcr1, __RC__) - call MAPL_VarRead(formatter,"CDCR2",catch%cdcr2, __RC__) - call MAPL_VarRead(formatter,"PSIS",catch%psis, __RC__) - call MAPL_VarRead(formatter,"BEE",catch%bee, __RC__) - call MAPL_VarRead(formatter,"POROS",catch%poros, __RC__) - call MAPL_VarRead(formatter,"WPWET",catch%wpwet, __RC__) - call MAPL_VarRead(formatter,"COND",catch%cond, __RC__) - call MAPL_VarRead(formatter,"GNU",catch%gnu, __RC__) - call MAPL_VarRead(formatter,"ARS1",catch%ars1, __RC__) - call MAPL_VarRead(formatter,"ARS2",catch%ars2, __RC__) - call MAPL_VarRead(formatter,"ARS3",catch%ars3, __RC__) - call MAPL_VarRead(formatter,"ARA1",catch%ara1, __RC__) - call MAPL_VarRead(formatter,"ARA2",catch%ara2, __RC__) - call MAPL_VarRead(formatter,"ARA3",catch%ara3, __RC__) - call MAPL_VarRead(formatter,"ARA4",catch%ara4, __RC__) - call MAPL_VarRead(formatter,"ARW1",catch%arw1, __RC__) - call MAPL_VarRead(formatter,"ARW2",catch%arw2, __RC__) - call MAPL_VarRead(formatter,"ARW3",catch%arw3, __RC__) - call MAPL_VarRead(formatter,"ARW4",catch%arw4, __RC__) - call MAPL_VarRead(formatter,"TSA1",catch%tsa1, __RC__) - call MAPL_VarRead(formatter,"TSA2",catch%tsa2, __RC__) - call MAPL_VarRead(formatter,"TSB1",catch%tsb1, __RC__) - call MAPL_VarRead(formatter,"TSB2",catch%tsb2, __RC__) - call MAPL_VarRead(formatter,"ATAU",catch%atau, __RC__) - call MAPL_VarRead(formatter,"BTAU",catch%btau, __RC__) - - myVariable => cfg%get_variable("ITY") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"ITY",catch%ity(:,j),offset1=j, __RC__) - call MAPL_VarRead(formatter,"FVG",catch%fvg(:,j),offset1=j, __RC__) - enddo - - call MAPL_VarRead(formatter,"TC",catch%tc, __RC__) - call MAPL_VarRead(formatter,"QC",catch%qc, __RC__) - call MAPL_VarRead(formatter,"TG",catch%tg, __RC__) - call MAPL_VarRead(formatter,"CAPAC",catch%capac, __RC__) - call MAPL_VarRead(formatter,"CATDEF",catch%catdef, __RC__) - call MAPL_VarRead(formatter,"RZEXC",catch%rzexc, __RC__) - call MAPL_VarRead(formatter,"SRFEXC",catch%srfexc, __RC__) - call MAPL_VarRead(formatter,"GHTCNT1",catch%ghtcnt1, __RC__) - call MAPL_VarRead(formatter,"GHTCNT2",catch%ghtcnt2, __RC__) - call MAPL_VarRead(formatter,"GHTCNT3",catch%ghtcnt3, __RC__) - call MAPL_VarRead(formatter,"GHTCNT4",catch%ghtcnt4, __RC__) - call MAPL_VarRead(formatter,"GHTCNT5",catch%ghtcnt5, __RC__) - call MAPL_VarRead(formatter,"GHTCNT6",catch%ghtcnt6, __RC__) - call MAPL_VarRead(formatter,"TSURF",catch%tsurf, __RC__) - call MAPL_VarRead(formatter,"WESNN1",catch%wesnn1, __RC__) - call MAPL_VarRead(formatter,"WESNN2",catch%wesnn2, __RC__) - call MAPL_VarRead(formatter,"WESNN3",catch%wesnn3, __RC__) - call MAPL_VarRead(formatter,"HTSNNN1",catch%htsnnn1, __RC__) - call MAPL_VarRead(formatter,"HTSNNN2",catch%htsnnn2, __RC__) - call MAPL_VarRead(formatter,"HTSNNN3",catch%htsnnn3, __RC__) - call MAPL_VarRead(formatter,"SNDZN1",catch%sndzn1, __RC__) - call MAPL_VarRead(formatter,"SNDZN2",catch%sndzn2, __RC__) - call MAPL_VarRead(formatter,"SNDZN3",catch%sndzn3, __RC__) - call MAPL_VarRead(formatter,"CH",catch%ch, __RC__) - call MAPL_VarRead(formatter,"CM",catch%cm, __RC__) - call MAPL_VarRead(formatter,"CQ",catch%cq, __RC__) - call MAPL_VarRead(formatter,"FR",catch%fr, __RC__) - call MAPL_VarRead(formatter,"WW",catch%ww, __RC__) - call MAPL_VarRead(formatter,"TILE_ID",catch%TILE_ID, __RC__) - call MAPL_VarRead(formatter,"NDEP",catch%ndep, __RC__) - call MAPL_VarRead(formatter,"CLI_T2M",catch%t2, __RC__) - call MAPL_VarRead(formatter,"BGALBVR",catch%BGALBVR, __RC__) - call MAPL_VarRead(formatter,"BGALBVF",catch%BGALBVF, __RC__) - call MAPL_VarRead(formatter,"BGALBNR",catch%BGALBNR, __RC__) - call MAPL_VarRead(formatter,"BGALBNF",catch%BGALBNF, __RC__) - myVariable => cfg%get_variable("CNCOL") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - if(clm45) then - call MAPL_VarRead(formatter,"ABM", catch%ABM, __RC__) - call MAPL_VarRead(formatter,"FIELDCAP",catch%FIELDCAP, __RC__) - call MAPL_VarRead(formatter,"HDM", catch%HDM , __RC__) - call MAPL_VarRead(formatter,"GDP", catch%GDP , __RC__) - call MAPL_VarRead(formatter,"PEATF", catch%PEATF , __RC__) - endif - do j=1,dim1 - call MAPL_VarRead(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j, __RC__) - enddo - ! The following three lines were added as a bug fix by smahanam on 5 Oct 2020 - ! (to be merged into the "develop" branch in late 2020): - ! The length of the 2nd dim of CNPFT differs from that of CNCOL. Prior to this fix, - ! CNPFT was not read in its entirety and some elements remained uninitialized (or zero), - ! resulting in bad values in the "regridded" (re-tiled) restart file. - ! This impacted re-tiled restarts for both CNCLM40 and CLCLM45. - ! - reichle, 23 Nov 2020 - myVariable => cfg%get_variable("CNPFT") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j, __RC__) - enddo - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - end subroutine readcatchcn_nc4 - - subroutine readcatchcn (unit,catch) - integer unit, i,j,n - type(catch_rst) catch - - read(unit) catch% bf1 - read(unit) catch% bf2 - read(unit) catch% bf3 - read(unit) catch% vgwmax - read(unit) catch% cdcr1 - read(unit) catch% cdcr2 - read(unit) catch% psis - read(unit) catch% bee - read(unit) catch% poros - read(unit) catch% wpwet - read(unit) catch% cond - read(unit) catch% gnu - read(unit) catch% ars1 - read(unit) catch% ars2 - read(unit) catch% ars3 - read(unit) catch% ara1 - read(unit) catch% ara2 - read(unit) catch% ara3 - read(unit) catch% ara4 - read(unit) catch% arw1 - read(unit) catch% arw2 - read(unit) catch% arw3 - read(unit) catch% arw4 - read(unit) catch% tsa1 - read(unit) catch% tsa2 - read(unit) catch% tsb1 - read(unit) catch% tsb2 - read(unit) catch% atau - read(unit) catch% btau - read(unit) catch% ity(:,1) - read(unit) catch% ity(:,2) - read(unit) catch% ity(:,3) - read(unit) catch% ity(:,4) - read(unit) catch% fvg(:,1) - read(unit) catch% fvg(:,2) - read(unit) catch% fvg(:,3) - read(unit) catch% fvg(:,4) - read(unit) catch% tc - read(unit) catch% qc - read(unit) catch% tg - read(unit) catch% capac - read(unit) catch% catdef - read(unit) catch% rzexc - read(unit) catch% srfexc - read(unit) catch% ghtcnt1 - read(unit) catch% ghtcnt2 - read(unit) catch% ghtcnt3 - read(unit) catch% ghtcnt4 - read(unit) catch% ghtcnt5 - read(unit) catch% ghtcnt6 - read(unit) catch% tsurf - read(unit) catch% wesnn1 - read(unit) catch% wesnn2 - read(unit) catch% wesnn3 - read(unit) catch% htsnnn1 - read(unit) catch% htsnnn2 - read(unit) catch% htsnnn3 - read(unit) catch% sndzn1 - read(unit) catch% sndzn2 - read(unit) catch% sndzn3 - read(unit) catch% ch - read(unit) catch% cm - read(unit) catch% cq - read(unit) catch% fr - read(unit) catch% ww - read(unit) catch% TILE_ID - read(unit) catch% ndep - read(unit) catch% t2 - read(unit) catch% BGALBVR - read(unit) catch% BGALBVF - read(unit) catch% BGALBNR - read(unit) catch% BGALBNF - - do j = 1,nzone * VAR_COL - read(unit) catch% CNCOL (:,j) - end do - - do i = 1,nzone * nveg * VAR_PFT - read(unit) catch% CNPFT (:,i) - end do - return - end subroutine readcatchcn - - subroutine writecatchcn_nc4 (catch,formatter,cfg) - type(catch_rst) catch - type(Netcdf4_fileformatter) :: formatter - type(filemetadata) :: cfg - integer :: i,j, dim1,dim2 - real, dimension (:), allocatable :: var - type(Variable), pointer :: myVariable - character(len=:), pointer :: dname - - call MAPL_VarWrite(formatter,"BF1",catch%bf1) - call MAPL_VarWrite(formatter,"BF2",catch%bf2) - call MAPL_VarWrite(formatter,"BF3",catch%bf3) - call MAPL_VarWrite(formatter,"VGWMAX",catch%vgwmax) - call MAPL_VarWrite(formatter,"CDCR1",catch%cdcr1) - call MAPL_VarWrite(formatter,"CDCR2",catch%cdcr2) - call MAPL_VarWrite(formatter,"PSIS",catch%psis) - call MAPL_VarWrite(formatter,"BEE",catch%bee) - call MAPL_VarWrite(formatter,"POROS",catch%poros) - call MAPL_VarWrite(formatter,"WPWET",catch%wpwet) - call MAPL_VarWrite(formatter,"COND",catch%cond) - call MAPL_VarWrite(formatter,"GNU",catch%gnu) - call MAPL_VarWrite(formatter,"ARS1",catch%ars1) - call MAPL_VarWrite(formatter,"ARS2",catch%ars2) - call MAPL_VarWrite(formatter,"ARS3",catch%ars3) - call MAPL_VarWrite(formatter,"ARA1",catch%ara1) - call MAPL_VarWrite(formatter,"ARA2",catch%ara2) - call MAPL_VarWrite(formatter,"ARA3",catch%ara3) - call MAPL_VarWrite(formatter,"ARA4",catch%ara4) - call MAPL_VarWrite(formatter,"ARW1",catch%arw1) - call MAPL_VarWrite(formatter,"ARW2",catch%arw2) - call MAPL_VarWrite(formatter,"ARW3",catch%arw3) - call MAPL_VarWrite(formatter,"ARW4",catch%arw4) - call MAPL_VarWrite(formatter,"TSA1",catch%tsa1) - call MAPL_VarWrite(formatter,"TSA2",catch%tsa2) - call MAPL_VarWrite(formatter,"TSB1",catch%tsb1) - call MAPL_VarWrite(formatter,"TSB2",catch%tsb2) - call MAPL_VarWrite(formatter,"ATAU",catch%atau) - call MAPL_VarWrite(formatter,"BTAU",catch%btau) - - myVariable => cfg%get_variable("ITY") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"ITY",catch%ity(:,j),offset1=j) - call MAPL_VarWrite(formatter,"FVG",catch%fvg(:,j),offset1=j) - enddo - - call MAPL_VarWrite(formatter,"TC",catch%tc) - call MAPL_VarWrite(formatter,"QC",catch%qc) - call MAPL_VarWrite(formatter,"TG",catch%TG) - call MAPL_VarWrite(formatter,"CAPAC",catch%capac) - call MAPL_VarWrite(formatter,"CATDEF",catch%catdef) - call MAPL_VarWrite(formatter,"RZEXC",catch%rzexc) - call MAPL_VarWrite(formatter,"SRFEXC",catch%srfexc) - call MAPL_VarWrite(formatter,"GHTCNT1",catch%ghtcnt1) - call MAPL_VarWrite(formatter,"GHTCNT2",catch%ghtcnt2) - call MAPL_VarWrite(formatter,"GHTCNT3",catch%ghtcnt3) - call MAPL_VarWrite(formatter,"GHTCNT4",catch%ghtcnt4) - call MAPL_VarWrite(formatter,"GHTCNT5",catch%ghtcnt5) - call MAPL_VarWrite(formatter,"GHTCNT6",catch%ghtcnt6) - call MAPL_VarWrite(formatter,"TSURF",catch%tsurf) - call MAPL_VarWrite(formatter,"WESNN1",catch%wesnn1) - call MAPL_VarWrite(formatter,"WESNN2",catch%wesnn2) - call MAPL_VarWrite(formatter,"WESNN3",catch%wesnn3) - call MAPL_VarWrite(formatter,"HTSNNN1",catch%htsnnn1) - call MAPL_VarWrite(formatter,"HTSNNN2",catch%htsnnn2) - call MAPL_VarWrite(formatter,"HTSNNN3",catch%htsnnn3) - call MAPL_VarWrite(formatter,"SNDZN1",catch%sndzn1) - call MAPL_VarWrite(formatter,"SNDZN2",catch%sndzn2) - call MAPL_VarWrite(formatter,"SNDZN3",catch%sndzn3) - call MAPL_VarWrite(formatter,"CH",catch%ch) - call MAPL_VarWrite(formatter,"CM",catch%cm) - call MAPL_VarWrite(formatter,"CQ",catch%cq) - call MAPL_VarWrite(formatter,"FR",catch%fr) - call MAPL_VarWrite(formatter,"WW",catch%ww) - call MAPL_VarWrite(formatter,"TILE_ID",catch%TILE_ID) - call MAPL_VarWrite(formatter,"NDEP",catch%NDEP) - call MAPL_VarWrite(formatter,"CLI_T2M",catch%t2) - call MAPL_VarWrite(formatter,"BGALBVR",catch%BGALBVR) - call MAPL_VarWrite(formatter,"BGALBVF",catch%BGALBVF) - call MAPL_VarWrite(formatter,"BGALBNR",catch%BGALBNR) - call MAPL_VarWrite(formatter,"BGALBNF",catch%BGALBNF) - myVariable => cfg%get_variable("CNCOL") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - - do j=1,dim1 - call MAPL_VarWrite(formatter,"CNCOL",catch%CNCOL(:,j),offset1=j) - enddo - myVariable => cfg%get_variable("CNPFT") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"CNPFT",catch%CNPFT(:,j),offset1=j) - enddo - - dim1 = cfg%get_dimension('tile') - allocate (var (dim1)) - var = 0. - - call MAPL_VarWrite(formatter,"BFLOWM", var) - call MAPL_VarWrite(formatter,"TOTWATM",var) - call MAPL_VarWrite(formatter,"TAIRM", var) - call MAPL_VarWrite(formatter,"TPM", var) - call MAPL_VarWrite(formatter,"CNSUM", var) - call MAPL_VarWrite(formatter,"SNDZM", var) - call MAPL_VarWrite(formatter,"ASNOWM", var) - - myVariable => cfg%get_variable("TGWM") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarWrite(formatter,"TGWM",var,offset1=j) - call MAPL_VarWrite(formatter,"RZMM",var,offset1=j) - end do - - if (clm45) then - do j=1,dim1 - call MAPL_VarWrite(formatter,"SFMM", var,offset1=j) - enddo - - call MAPL_VarWrite(formatter,"ABM", catch%ABM, rc =rc ) - call MAPL_VarWrite(formatter,"FIELDCAP",catch%FIELDCAP) - call MAPL_VarWrite(formatter,"HDM", catch%HDM ) - call MAPL_VarWrite(formatter,"GDP", catch%GDP ) - call MAPL_VarWrite(formatter,"PEATF", catch%PEATF ) - call MAPL_VarWrite(formatter,"RHM", var) - call MAPL_VarWrite(formatter,"WINDM", var) - call MAPL_VarWrite(formatter,"RAINFM", var) - call MAPL_VarWrite(formatter,"SNOWFM", var) - call MAPL_VarWrite(formatter,"RUNSRFM", var) - call MAPL_VarWrite(formatter,"AR1M", var) - call MAPL_VarWrite(formatter,"T2M10D", var) - call MAPL_VarWrite(formatter,"TPREC10D",var) - call MAPL_VarWrite(formatter,"TPREC60D",var) - else - call MAPL_VarWrite(formatter,"SFMCM", var) - endif - - myVariable => cfg%get_variable("PSNSUNM") - dname => myVariable%get_ith_dimension(2) - dim1 = cfg%get_dimension(dname) - dname => myVariable%get_ith_dimension(3) - dim2 = cfg%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarWrite(formatter,"PSNSUNM",var,offset1=j,offset2=i) - call MAPL_VarWrite(formatter,"PSNSHAM",var,offset1=j,offset2=i) - end do - end do - call formatter%close() - return - end subroutine writecatchcn_nc4 - - subroutine writecatchcn (unit,catch) - integer unit, i,j,n - type(catch_rst) catch - - write(unit) catch% bf1 - write(unit) catch% bf2 - write(unit) catch% bf3 - write(unit) catch% vgwmax - write(unit) catch% cdcr1 - write(unit) catch% cdcr2 - write(unit) catch% psis - write(unit) catch% bee - write(unit) catch% poros - write(unit) catch% wpwet - write(unit) catch% cond - write(unit) catch% gnu - write(unit) catch% ars1 - write(unit) catch% ars2 - write(unit) catch% ars3 - write(unit) catch% ara1 - write(unit) catch% ara2 - write(unit) catch% ara3 - write(unit) catch% ara4 - write(unit) catch% arw1 - write(unit) catch% arw2 - write(unit) catch% arw3 - write(unit) catch% arw4 - write(unit) catch% tsa1 - write(unit) catch% tsa2 - write(unit) catch% tsb1 - write(unit) catch% tsb2 - write(unit) catch% atau - write(unit) catch% btau - write(unit) catch% ity(:,1) - write(unit) catch% ity(:,2) - write(unit) catch% ity(:,3) - write(unit) catch% ity(:,4) - write(unit) catch% fvg(:,1) - write(unit) catch% fvg(:,2) - write(unit) catch% fvg(:,3) - write(unit) catch% fvg(:,4) - write(unit) catch% tc - write(unit) catch% qc - write(unit) catch% tg - write(unit) catch% capac - write(unit) catch% catdef - write(unit) catch% rzexc - write(unit) catch% srfexc - write(unit) catch% ghtcnt1 - write(unit) catch% ghtcnt2 - write(unit) catch% ghtcnt3 - write(unit) catch% ghtcnt4 - write(unit) catch% ghtcnt5 - write(unit) catch% ghtcnt6 - write(unit) catch% tsurf - write(unit) catch% wesnn1 - write(unit) catch% wesnn2 - write(unit) catch% wesnn3 - write(unit) catch% htsnnn1 - write(unit) catch% htsnnn2 - write(unit) catch% htsnnn3 - write(unit) catch% sndzn1 - write(unit) catch% sndzn2 - write(unit) catch% sndzn3 - write(unit) catch% ch - write(unit) catch% cm - write(unit) catch% cq - write(unit) catch% fr - write(unit) catch% ww - write(unit) catch% TILE_ID - write(unit) catch% ndep - write(unit) catch% t2 - write(unit) catch% BGALBVR - write(unit) catch% BGALBVF - write(unit) catch% BGALBNR - write(unit) catch% BGALBNF - - do j = 1,nzone * VAR_COL - write(unit) catch% CNCOL (:,j) - end do - - do i = 1,nzone * nveg * VAR_PFT - write(unit) catch% CNPFT (:,i) - end do - - return - end subroutine writecatchcn - - end program - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 deleted file mode 100755 index e4ab880c8a..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchCNRestarts.F90 +++ /dev/null @@ -1,2453 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -program mk_CatchCNRestarts - -! Usage : mk_CatchCNRestarts OutTileFile InTileFile InRestart SURFLAY RestartTime -! Version 1 : Sarith Mahanama -! sarith.p.mahanama@nasa.gov (Feb 19, 2016) -! The program follows the same nearest neighbor based procedure, as in mk_CatchRestarts.F90, -! to regrid hydrological variables and BCs-based parameters. The algorithm developed -! by Greg Walker (~gkwalker/geos5/convert_offline_cn_restart.f90) to regrid carbon -! variables that looks for a neighbor with a similar vegetation type was modified -! to improve efficiency (in subroutine regrid_carbon_vars). The two main -! modifications in this implementation include: (1) instead looping over the globe, -! it starts from a 10 x 10 window and zoom out until a similar type appears, -! (2) uses MPI enabling parrellel computation. -! Version 2 : Sarith Mahanama (Oct 12, 2016) -! (1) updated to read both carbon and hydrological variables more recent SMAP M09 simulation from Fanwei. -! (2) added subroutine reorder_LDASsa_rst -! The program produces catchcn_internal_rst in nc4 format for any user specified AGCM grid resolution. - -! regrid.pl visits this program twice during the regridding process. During the first visit, the program does not use BCs data. -! It just regrids hydrological variables and BCs-based land parameters in InRestart from InTile space to OutTile -! space (InRestart could be either a catchcn_internal_rst or a catch_internal_rst). If InRestart is a -! catchcn_internal_rst, carbon variables will be regridded using the same simple nearest neighbor algorithm (getids.H) that -! was employed for regridding all other variables. If InRestart is a catch_internal_rst, carbon variables will be -! filled with zeros. - -! During the second visit, the program uses the catchcn_internal_rst produced from the first visit as InRestart (herein -! referred to as InRestart2 which is in OutTile space already). The program reads BCs data from BCSDIR, carbon variables -! from an offline simulation on the SMAP_EASEv2_M09 grid which has been initialized by another 3000-year offline simulation, and -! hydrological from -! InRestart2 in Version 1, -! the same offline simulation on the SMAP_EASEv2_M09 in Version 2. -! Then, they will be regridded to OutTile space. The regridding carbon variables utilizes a more complicated algorithm which looks -! for a M09 grid cell in the neighborhood with a similar vegetation type seperately for each fractional vegetation type within the -! catchment-tile. Note, the model can have upto 4 different types per catchment-tile: primary and secondary types -! and 2 split types for each primary and secondary type. - -! regrid.pl will then execute Scale_CatchCN.F90 which reads catchcn_internal_rst files created in the above 2 steps, -! and scale soil moisture variables to be consistent with the new BCs-based land parameters to produce the final -! catchcn_internal_rst file. - -! Output file format: Output catchcn_internal_rst is always a nc4 file. - -! Here are available options: -! (1) OPT1 (for above first step) -! Input : (1) catchcn_internal_rst from an existing AGCM run (will always be nc4) -! (2) InTile and OutTile are DIFFERENT -! (3) NO land BCs -! OutPut: Every variable (BCs-based land parameters, hydrological variables, and carbon parameters) will be regridded -! from InTile to OutTile space using the simple nearest neighbor algorithm (getids.H) - -! (2) OPT2 (for above first step) -! Input : (1) catch_internal_rst from an existing AGCM run (either nc4 or binary) -! (2) InTile and OutTile are DIFFERENT -! (3) NO land BCs -! OutPut: BCs-based land parameters, and hydrological variables will regridded from InTile to OutTile space -! using the simple nearest neighbor algorithm (getids.H). All carbon variables are filled with zeros. - -! (3) OPT3 (above second step) : -! Input : (1) catchcn_internal_rst (file format is always nc4) -! (2) InTile and OutTile are the same user defined OutTile -! (3) land BCs, -! Output: BCs-based land parameters will be replaced and carbon variables will be filled with regridded (from the -! nearest offline cell with the same vegetation type) data to produce catchcn_internal_rst - -! ---------------------------------------------------------------------------------------------------------------------------------------------- - - ! ====================== ! - ! Process ! - ! ====================== ! - -! HAVEDATA -! | -! _______________________________________________________________________ -! | | -! -! NO (OPT1/OPT2) YES (OPT3) -! -------------- ---------- -!OutTile : /= InTile == InTile -!regridding: ID (InTile to OutTile using getids.H) ID (one-to-one i.e. 1:NTILES, no regridding) -! | | -! clsmcn_file | -! _____________________________________ | -! | | | -! YES (OPT1) NO (OPT2) | -!InRestart : catchcn_internal_rst catch_internal_rst catchcn_internal_rst -! | | | -! | filetype | -! | | | -! | _________________________________ | -! | | | | -! V 0 /= 0 V -!call : read_catchcn_nc4 read_catch_nc4 read_catch_bin read_bcs_data -! | | -! ----------------------------------- -! | -! V -!1) reads InRestart nVars records (1) reads InCNRestart/regrids/writes (1:65) (1) reads BCs -!2) regrids (takes hydrological initial conditions (2) writes 1:37; 66:72 -!3) writes from offline SMAP M09) (3) reads InRestart2/writes 38, 39,40=38,41:65 -!4) close files (2) close files (4) call regrid_carbon_vars (from offline SMAP M09) -! (a) reads from InCNRestart -! (b) regrids each veg type from the nearest InRestart cell -! (c) writes (73-192,193-1080) -! (d) close files -! -! -! -! OUTPUT catchcn_internal_rst will always be nc4 -! ---------------------------------------------------------------------------------------------------------------------------------------------- - - -! The order of the INTERNAL STATE variables in GEOS_CatchCNGridComp -! ----------------------------------------------------------------- -! 1: BF1 -! 2: BF2 -! 3: BF3 -! 4: VGWMAX -! 5: CDCR1 -! 6: CDCR2 -! 7: PSIS -! 8: BEE -! 9: POROS -! 10: WPWET -! 11: COND -! 12: GNU -! 13: ARS1 -! 14: ARS2 -! 15: ARS3 -! 16: ARA1 -! 17: ARA2 -! 18: ARA3 -! 19: ARA4 -! 20: ARW1 -! 21: ARW2 -! 22: ARW3 -! 23: ARW4 -! 24: TSA1 -! 25: TSA2 -! 26: TSB1 -! 27: TSB2 -! 28: ATAU -! 29: BTAU -! 30-33: ITY * NUM_VEG -! 34-37: FVEG * NUM_VEG -! 38: ((TC (n,i),n=1,n_catd),i=1,4) -! 39: ((QC (n,i),n=1,n_catd),i=1,4) -! 40: ((TG (n,i),n=1,n_catd),i=1,4) -! 41: CAPAC -! 42: CATDEF -! 43: RZEXC -! 44: SRFEXC -! 45: GHTCNT1 -! 46: GHTCNT2 -! 47: GHTCNT3 -! 48: GHTCNT4 -! 49: GHTCNT5 -! 50: GHTCNT6 -! 51: TSURF -! 52: WESNN1 -! 53: WESNN2 -! 54: WESNN3 -! 55: HTSNNN1 -! 56: HTSNNN2 -! 57: HTSNNN3 -! 58: SNDZN1 -! 59: SNDZN2 -! 60: SNDZN3 -! 61: ((CH (n,i),n=1,n_catd),i=1,4) -! 62: ((CM (n,i),n=1,n_catd),i=1,4) -! 63: ((CQ (n,i),n=1,n_catd),i=1,4) -! 64: ((FR (n,i),n=1,n_catd),i=1,4) -! 65: ((WW (n,i),n=1,n_catd),i=1,4) -! 66: cat_id -! 67: ndep -! 68: cli_t2m -! 69: BGALBVR -! 70: BGALBVF -! 71: BGALBNR -! 72: BGALBNF -! 73-192: CNCOL (n,nz*VAR_COL) -! 193-1080: CNPFT (n,nz*nv*VAR_PFT) -! 1081-1083: TGWM (n,nz) -! 1084: SFMCM -! 1085: BFLOWM -! 1086: TOTWATM -! 1087: TAIRM -! 1088: TPM -! 1089: CNSUM -! 1090: SNDZM -! 1091: ASNOWM -! 1092-1103: PSNSUNM (n,nz*nv) -! 1104-1115: PSNSHAM (n,nz*nv) - - use MAPL - use ESMF - use gFTL_StringVector - use ieee_arithmetic, only: isnan => ieee_is_nan - use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use clm_varpar_shared , only : nzone => NUM_ZON_CN, nveg => NUM_VEG_CN, & - VAR_COL => VAR_COL_40, VAR_PFT => VAR_PFT_40, & - npft => numpft_CN - - implicit none - include 'mpif.h' - INCLUDE 'netcdf.inc' - - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) - logical :: root_proc=.true. - - real, parameter :: nan = O'17760000000' - real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer, parameter :: OutUnit = 40, InUnit = 50 - - ! =============================================================================================== - ! Below hard-wired ldas restart file is from a global offline simulation on the SMAP M09 grid - ! after 1000s of years of simulations - - integer, parameter :: ntiles_cn = 1684725 - character(len=300), parameter :: & - InCNRestart = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Icarus-NLv3/Icarus-NLv3_EASE/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' - - character(len=256), parameter :: CatNames (57) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU ','OLD_ITY', & - 'TC ','QC ','CAPAC ','CATDEF ','RZEXC ', & - 'SRFEXC ','GHTCNT1','GHTCNT2','GHTCNT3','GHTCNT4', & - 'GHTCNT5','GHTCNT6','TSURF ','WESNN1 ','WESNN2 ', & - 'WESNN3 ','HTSNNN1','HTSNNN2','HTSNNN3','SNDZN1 ', & - 'SNDZN2 ','SNDZN3 ','CH ','CM ','CQ ', & - 'FR ','WW '/) - - character(len=256), parameter :: CarbNames (68) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX ','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU ','ITY ', & - 'FVG ','TC ','QC ','TG ','CAPAC ', & - 'CATDEF ','RZEXC ','SRFEXC ','GHTCNT1','GHTCNT2', & - 'GHTCNT3','GHTCNT4','GHTCNT5','GHTCNT6','TSURF ', & - 'WESNN1 ','WESNN2 ','WESNN3 ','HTSNNN1','HTSNNN2', & - 'HTSNNN3','SNDZN1 ','SNDZN2 ','SNDZN3 ','CH ', & - 'CM ','CQ ','FR ','WW ','TILE_ID', & - 'NDEP ','CLI_T2M','BGALBVR','BGALBVF','BGALBNR', & - 'BGALBNF','CNCOL ','CNPFT ' /) - - integer :: AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR - - character*256 :: DataDir="OutData/clsm/" - character*256 :: Usage="mk_CatchCNRestarts OutTileFile InTileFile InRestart SURFLAY RestartTime" - character*256 :: OutTileFile, InTileFile, InRestart, arg(6), OutFileName - character*10 :: RestartTime - - logical :: clsmcn_file = .true., RegridSMAP = .false. - logical :: havedata - integer :: i, i1, iargc, n, k, ncatch,ntiles,ntiles_in, filetype, rc, nVars, req, infos, STATUS - integer, pointer :: Id(:), id_loc(:), tid_in(:) - real, pointer :: loni(:),lono(:), lati(:), lato(:) , lonn(:), latt(:) - real :: SURFLAY - type(Netcdf4_Fileformatter) :: InFmt,OutFmt - type(FileMetadata) :: InCfg,OutCfg - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - character(256) :: Iam = "mk_CatchCNRestarts" - - call init_MPI() - call MPI_Info_create(infos, STATUS) ; VERIFY_(STATUS) - call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) ; VERIFY_(STATUS) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - !----------------------------------------------------- - ! Read command-line arguments, file names (inRestart, - ! inTile, outTile), determine file format, and BCs - ! availability. - !----------------------------------------------------- - - call ESMF_Initialize(LogKindFlag=ESMF_LOGKIND_NONE) - - I = iargc() - - if( I /=5 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - stop - end if - - do n=1,I - call getarg(n,arg(n)) - enddo - - read(arg(1),'(a)') OutTileFile - read(arg(2),'(a)') InTileFile - read(arg(3),'(a)') InRestart - read(arg(4),*) SURFLAY - read(arg(5),'(a)') RestartTime - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - - ! Are BCs data available? - ! ----------------------- - - inquire(file=trim(DataDir)//"CLM_veg_typs_fracs",exist=havedata) - - ! Reading restart time stamp and constructing daylength array - ! ----------------------------------------------------------- - read (RestartTime (1: 4), '(i4)', IOSTAT = K) AGCM_YY ; VERIFY_(K) - read (RestartTime (5: 6), '(i2)', IOSTAT = K) AGCM_MM ; VERIFY_(K) - read (RestartTime (7: 8), '(i2)', IOSTAT = K) AGCM_DD ; VERIFY_(K) - read (RestartTime (9:10), '(i2)', IOSTAT = K) AGCM_HR ; VERIFY_(K) - - MPI_PROC0 : if (root_proc) then - - ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,xlon=loni, xlat=lati) - allocate(Id (ntiles)) - - ! ------------------------------------------------ - ! create output catchcn_internal_rst in nc4 format - ! ------------------------------------------------ - - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy',pFIO_READ, __RC__) - InCfg=InFmt%read( __RC__) - call MAPL_IOCountNonDimVars(InCfg,nvars, __RC__) - call MAPL_IOChangeRes(InCfg,OutCfg,(/'tile'/),(/ntiles/),__RC__) - i = index(InRestart,'/',back=.true.) - OutFileName = "OutData/"//trim(InRestart(i+1:)) - call OutFmt%create(OutFileName, __RC__) - call OutFmt%write(OutCfg, __RC__) - i1= index(InRestart,'/',back=.true.) - i = index(InRestart,'catchcn',back=.true.) - - endif MPI_PROC0 - - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) - call MPI_BCAST(NTILES_IN, 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) ; VERIFY_(mpierr) - - HAVE_DATA :if(havedata) then - - ! OPT3 - ! ---- - ! Get number of catchments - ! ------------------------ - - open(unit=22, & - file=trim(DataDir)//"catchment.def",status='old',form='formatted') - - read(22,*) ncatch - - close(22) - - if(ncatch /= ntiles) then - print *, "Number of tiles in BCs data, ",Ncatch," does not match number in OutTile file ", NTILES - print *, trim(OutTileFile) - stop - endif - - if(ntiles_in /= ntiles) then - print *, "HAVEDATA : Number of tiles in InTileFile, ",NTILES_IN," does not match number in OutTileFile ", NTILES - print *, trim ( InTileFile) - print *, trim (OutTileFile) - stop - endif - - allocate (Id(ntiles)) - - do i = 1,ntiles - id (i) = i ! Just one-to-one mapping - end do - RegridSMAP = .true. - - !OPT3 (Reading/writing BCs/hydrological variables) - - if (root_proc) call read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, __RC__) - - else - - ! What is the format of the InRestart file? - ! ----------------------------------------- - - call MAPL_NCIOGetFileType(InRestart, filetype, __RC__) - - if (filetype /= 0) then - - ! OPT2 (filetype =/ 0: a binary file must be a catch_internal_rst) - ! ---- - clsmcn_file = .false. - - open(unit=InUnit,FILE=InRestart,form='unformatted', & - status='old',convert='little_endian') - - else - - ! filetype = 0 : nc4, could be catch_internal_rst or catchcn_internal_rst - ! check nVars: if nVars > 57 OPT1 (catchcn_internal_rst) ; else OPT2 (catch_internal_rst) - ! --------------------------------------------------------------------------------------- - - call InFmt%open(InRestart,pFIO_READ, __RC__) - InCfg = InFmt%read(__RC__) - call InFmt%close() - - call MAPL_IOCountNonDimVars(InCfg,nvars) - - if(nVars == 57) clsmcn_file = .false. - - endif - - CATCHCN: if (clsmcn_file) then - - ! OPT1 - ! ---- - - ! ---------------------------------------------------- - ! INPUT/OUTPUT Mapping since InTileFile =/ OutTileFile - ! ---------------------------------------------------- - - if(myid > 0) allocate (loni (1:ntiles_in)) - if(myid > 0) allocate (lati (1:ntiles_in)) - - allocate (tid_in (1:ntiles_in)) - do n = 1, NTILES_IN - tid_in (n) = n - end do - - call MPI_BCAST(loni,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(lati,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - ! Now mapping (Id) - ! ---------------- - - allocate (Id(ntiles)) ! Id contains corresponding InTileID after mapping InTiles on to OutTile - ! call GetIds(loni,lati,lono,lato,zoom,Id) - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - ! Get out tile lat/lots from root - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = lono(low_ind(i) : upp_ind(i)) - latt(:) = lato(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - - call MPI_ISend(lono(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(lato(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - call GetIds(loni,lati,lonn,latt,id_loc, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (lono, lato,lonn,latt, tid_in) - - deallocate (loni,lati) - - - if (root_proc) call read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, ID, InRestart, __RC__) - - else - - call regrid_hyd_vars (NTILES, OutFmt) - - ! OPT2 - ! ---- - ! NC4ORBIN: if(filetype ==0) then - ! - ! call read_catch_nc4 (NTILES_IN, NTILES, OutFmt, ID, InRestart) - ! - ! else - ! - ! call read_catch_bin (NTILES_IN, NTILES, OutFmt, ID) - ! - ! endif NC4ORBIN - - endif CATCHCN - - endif HAVE_DATA - - if (root_proc) then - - ! ----------------- - ! BEGIN THE PROCESS - ! ----------------- - - print *, " " - print *, "**********************************************************************" - print *, " " - print *, "mk_CatchCNRestarts Configuration" - print *, "--------------------------------" - print *, " " - print '(A22, i4.4,i2.2,i2.2,i2.2)', " Restart Time :",AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - print *, 'SURFLAY : ',SURFLAY - print *, 'Have BCs data : ',havedata - print *, "# of tiles in InTile : ",ntiles_in - print *, "# of tiles in OutTile: ",ntiles - - if(clsmcn_file) then - print *,"InRestart is from : Catchment-carbon AGCM simulation" - else - InRestart = trim(InCNRestart) - print *,"InRestart is from : offline SMAP_EASEv2_M09" - endif - - print *, "InRestart filename : ",trim(InRestart) - print *, "OutRestart filename : ",trim(OutFileName) - print *, "OutRestart file fmt : nc4" - print *, " " - print *, "**********************************************************************" - print *, " " - - endif - - call MPI_BCAST(OutFileName , 256, MPI_CHARACTER, 0,MPI_COMM_WORLD,mpierr) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - if (RegridSMAP) then - ntiles_in = ntiles_cn - !OPT3 (carbon variables from offline SMAP M09) - call regrid_carbon_vars (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - ! call regrid_carbon_vars_omp (NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - - endif -call MPI_BARRIER( MPI_COMM_WORLD, mpierr) -call ESMF_Finalize(endflag=ESMF_END_KEEPMPI) -call MPI_FINALIZE(mpierr) - -contains - - ! ***************************************************************************** - - SUBROUTINE read_bcs_data (ntiles, SURFLAY, OutFmt, InRestart, rc) - - ! This subroutine : - ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. - ! InRestart is a catchcn_internal_rst nc4 file. - ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). - ! output catchcn_internal_rst is nc4. - - implicit none - real, intent (in) :: SURFLAY - integer, intent (in) :: ntiles - character (*), intent (in) :: InRestart - type(Netcdf4_Fileformatter), intent (inout) :: OutFmt - integer, optional, intent(out) :: rc - - real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:), CanopH(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), var1(:) - integer, allocatable :: ity(:) - character*256 :: vname - character*256 :: DataDir="OutData/clsm/" - integer :: idum, i,j,n, ib, nv - real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) - logical :: file_exists - type(Netcdf4_Fileformatter) :: InFmt,CatchCNFmt, CatchFmt - integer :: status - - allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) - allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) - allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) - allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) - allocate ( ARA4(ntiles), ARW1(ntiles), ARW2(ntiles) ) - allocate ( ARW3(ntiles), ARW4(ntiles), TSA1(ntiles) ) - allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) - allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) - allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) - allocate ( ity(ntiles), rity(ntiles), CanopH(ntiles)) - allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) - allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - - inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) - - if(file_exists) then - - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%open(trim(DataDir)//'/catch_params.nc4',pFIO_READ, __RC__) - call CatchCNFmt%open(trim(DataDir)//'/catchcn_params.nc4',pFIO_READ, __RC__) - call MAPL_VarRead ( CatchFmt ,'OLD_ITY', rity, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( CatchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( CatchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( CatchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( CatchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( CatchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( CatchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( CatchFmt ,'POROS', POROS, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 - call CatchFmt%close() - call CatchCNFmt%close() - - else - - open(unit=22, & - file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - - do N=1,ntiles - read(22,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - enddo - - rity(:) = float(ity) - - close(22) - - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - - do n=1,ntiles - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - - read (27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & - CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - - read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - - end do - - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') - - endif - - do n=1,ntiles - - BVISDR(n) = amax1(1.e-6, BVISDR(n)) - BVISDF(n) = amax1(1.e-6, BVISDF(n)) - BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) - BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - - ! convert % to fractions - - CLMC_pf1(n) = CLMC_pf1(n) / 100. - CLMC_pf2(n) = CLMC_pf2(n) / 100. - CLMC_sf1(n) = CLMC_sf1(n) / 100. - CLMC_sf2(n) = CLMC_sf2(n) / 100. - - fvg(1) = CLMC_pf1(n) - fvg(2) = CLMC_pf2(n) - fvg(3) = CLMC_sf1(n) - fvg(4) = CLMC_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC_pf1(n) = fvg(1) - CLMC_pf2(n) = fvg(2) - CLMC_sf1(n) = fvg(3) - CLMC_sf2(n) = fvg(4) - - enddo - - NDEP = NDEP * 1.e-9 - -! prevent trivial fractions -! ------------------------- - do n = 1,ntiles - if(CLMC_pf1(n) <= 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) - CLMC_pf1(n) = 0. - endif - - if(CLMC_pf2(n) <= 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) - CLMC_pf2(n) = 0. - endif - - if(CLMC_sf1(n) <= 1.e-4) then - if(CLMC_sf2(n) > 1.e-4) then - CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf1(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf1(n) - else - stop 'fveg3' - endif - CLMC_sf1(n) = 0. - endif - - if(CLMC_sf2(n) <= 1.e-4) then - if(CLMC_sf1(n) > 1.e-4) then - CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf2(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf2(n) - else - stop 'fveg4' - endif - CLMC_sf2(n) = 0. - endif - end do - - - - ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 - ! ----------------------------------------------------------------------- - - call InFmt%open(InRestart,pFIO_READ, __RC__) - - call MAPL_VarWrite(OutFmt,trim(CarbNames(1)),BF1) ! 1 - call MAPL_VarWrite(OutFmt,trim(CarbNames(2)),BF2) ! 2 - call MAPL_VarWrite(OutFmt,trim(CarbNames(3)),BF3) ! 3 - call MAPL_VarWrite(OutFmt,trim(CarbNames(4)),VGWMAX) ! 4 - call MAPL_VarWrite(OutFmt,trim(CarbNames(5)),CDCR1) ! 5 - call MAPL_VarWrite(OutFmt,trim(CarbNames(6)),CDCR2) ! 6 - call MAPL_VarWrite(OutFmt,trim(CarbNames(7)),PSIS) ! 7 - call MAPL_VarWrite(OutFmt,trim(CarbNames(8)),BEE) ! 8 - call MAPL_VarWrite(OutFmt,trim(CarbNames(9)),POROS) ! 9 - call MAPL_VarWrite(OutFmt,trim(CarbNames(10)),WPWET) ! 10 - call MAPL_VarWrite(OutFmt,trim(CarbNames(11)),COND) ! 11 - call MAPL_VarWrite(OutFmt,trim(CarbNames(12)),GNU) ! 12 - call MAPL_VarWrite(OutFmt,trim(CarbNames(13)),ARS1) ! 13 - call MAPL_VarWrite(OutFmt,trim(CarbNames(14)),ARS2) ! 14 - call MAPL_VarWrite(OutFmt,trim(CarbNames(15)),ARS3) ! 15 - call MAPL_VarWrite(OutFmt,trim(CarbNames(16)),ARA1) ! 16 - call MAPL_VarWrite(OutFmt,trim(CarbNames(17)),ARA2) ! 17 - call MAPL_VarWrite(OutFmt,trim(CarbNames(18)),ARA3) ! 18 - call MAPL_VarWrite(OutFmt,trim(CarbNames(19)),ARA4) ! 19 - call MAPL_VarWrite(OutFmt,trim(CarbNames(20)),ARW1) ! 20 - call MAPL_VarWrite(OutFmt,trim(CarbNames(21)),ARW2) ! 21 - call MAPL_VarWrite(OutFmt,trim(CarbNames(22)),ARW3) ! 22 - call MAPL_VarWrite(OutFmt,trim(CarbNames(23)),ARW4) ! 23 - call MAPL_VarWrite(OutFmt,trim(CarbNames(24)),TSA1) ! 24 - call MAPL_VarWrite(OutFmt,trim(CarbNames(25)),TSA2) ! 25 - call MAPL_VarWrite(OutFmt,trim(CarbNames(26)),TSB1) ! 26 - call MAPL_VarWrite(OutFmt,trim(CarbNames(27)),TSB2) ! 27 - call MAPL_VarWrite(OutFmt,trim(CarbNames(28)),ATAU2) ! 28 - call MAPL_VarWrite(OutFmt,trim(CarbNames(29)),BTAU2) ! 29 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_pt1,offset1=1) ! 30 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_pt2,offset1=2) ! 31 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_st1,offset1=3) ! 32 - call MAPL_VarWrite(OutFmt,'ITY',CLMC_st2,offset1=4) ! 33 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_pf1,offset1=1) ! 34 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_pf2,offset1=2) ! 35 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf1,offset1=3) ! 36 - call MAPL_VarWrite(OutFmt,'FVG',CLMC_sf2,offset1=4) ! 37 - - allocate(var1(ntiles)) - - ! TC QC TG - - do n = 38,40 - if(n == 38) vname = 'TC' - if(n == 39) vname = 'QC' - if(n == 40) vname = 'TG' - do j = 1,4 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,vname,var1 ,offset1=j) ! 38-40 - end do - end do - - ! CAPAC CATDEF RZEXC SRFEXC ... SNDZN3 - - do n=41,60 - call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1, __RC__) - call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1) ! 41-60 - enddo - - ! CH CM CQ FR WW - var1 = 0. - - do n=61,65 - if((n >= 61).AND.(n <= 63)) var1 = 1.e-3 - if(n == 64) var1 = 0.25 - if(n == 65) var1 = 0.1 - do j = 1,4 - - call MAPL_VarRead ( InFmt,trim(CarbNames(n-6)),var1 ,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,trim(CarbNames(n-6)),var1 ,offset1=j) ! 61-65 - end do - end do - - do i=1,ntiles - var1(i) = real(i) - end do - - call MAPL_VarWrite(OutFmt,'TILE_ID',var1 ) ! 66 : cat_id - call MAPL_VarWrite(OutFmt,'NDEP' ,NDEP ) ! 67 : ndep - call MAPL_VarWrite(OutFmt,'CLI_T2M',T2 ) ! 68 : cli_t2m - call MAPL_VarWrite(OutFmt,'BGALBVR',BVISDR) ! 69 : BGALBVR - call MAPL_VarWrite(OutFmt,'BGALBVF',BVISDF) ! 70 : BGALBVF - call MAPL_VarWrite(OutFmt,'BGALBNR',BNIRDR) ! 71 : BGALBNR - call MAPL_VarWrite(OutFmt,'BGALBNF',BNIRDF) ! 72 : BGALBNF - - deallocate (var1) - call InFmt%close() - call OutFmt%close() - -! Vegdyn Boundary Condition -! ------------------------- -! -! open(20,file=trim("OutData/vegdyn_internal_rst"), & -! status="unknown", & -! form="unformatted",convert="little_endian") -! write(20) rity -! write(20) CanopH -! close(20) -! print *, "Wrote vegdyn_internal_restart" - - deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) - deallocate ( WPWET, COND, GNU ) - deallocate ( ARS1, ARS2, ARS3 ) - deallocate ( ARA1, ARA2, ARA3 ) - deallocate ( ARA4, ARW1, ARW2 ) - deallocate ( ARW3, ARW4, TSA1 ) - deallocate ( TSA2, TSB1, TSB2 ) - deallocate ( ATAU2, BTAU2, DP2BR ) - deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) - deallocate ( ity, rity, CanopH) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) - deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) - deallocate (CLMC_st1,CLMC_st2) - if (present(rc)) rc = 0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_bcs_data - - ! ***************************************************************************** - - SUBROUTINE read_catchcn_nc4 (NTILES_IN, NTILES, OutFmt, IDX, InRestart, rc) - - implicit none - - ! Reads catchcn_internal_rst nc4 file, regrids every single variable and writes - ! out catchcn_internal_rst in nc4 format. - ! This subroutine is called when BCs data are not available. - - integer, intent (in) :: NTILES_IN, NTILES - character(*), intent (in) :: InRestart - type(Netcdf4_Fileformatter), intent (inout) :: OutFmt - integer, dimension (NTILES), intent (in) :: IDX - integer, optional, intent(out) :: rc - type(Netcdf4_Fileformatter) :: InFmt - type(FileMetadata) :: InCfg - integer :: n,i,j, ndims, nVars,dim1,dim2 - character(len=:), pointer :: vname - real, allocatable :: var1 (:), var2 (:) - integer, allocatable :: TILE_ID (:) - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: var - type(StringVariableMapIterator) :: var_iter - type(StringVector), pointer :: var_dimensions - character(len=:), pointer :: dname - integer :: status - - call InFmt%open(InRestart,pFIO_READ, __RC__) - InCfg = InFmt%read(__RC__) - - allocate (var1 (1:NTILES_IN)) - allocate (var2 (1:NTILES_IN)) - allocate (TILE_ID (1:NTILES_IN)) - - call MAPL_VarRead ( InFmt,'TILE_ID',var1, __RC__) - do n = 1, NTILES_IN - tile_id (NINT (var1(n))) = n - end do - - variables => InCfg%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - - vname => var_iter%key() - var => var_iter%value() - var_dimensions => var%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead ( InFmt,vname,var1, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx)) - - else if (ndims == 2) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j) - enddo - - else if (ndims == 3) then - - dname => var%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - dname => var%get_ith_dimension(3) - dim2=InCfg%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j,offset2=i, __RC__) - var2 = var1 (tile_id) - call MAPL_VarWrite(OutFmt,vname,var2(idx),offset1=j,offset2=i) - enddo - enddo - - end if - - call var_iter%next() - enddo - - deallocate (var1, var2, tile_id) - call InFmt%close() - call OutFmt%close() - if (present(rc)) rc = 0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_catchcn_nc4 - - ! ***************************************************************************** - - SUBROUTINE regrid_carbon_vars ( & - NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR, OutFileName, OutTileFile) - - implicit none - character (*), intent (in) :: OutTileFile, OutFileName - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 - - ! =============================================================================================== - - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) - integer, allocatable, dimension(:,:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: tid_offl, id_vec - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl - real :: fveg_new, sub_dist - integer :: n,i,j, k, nv, nx, nz, iv, offl_cell, ityp_new, STATUS,NCFID, req - integer :: outid, local_id - integer, allocatable, dimension (:) :: sub_tid, sub_ityp1, sub_ityp2,icl_ityp1 - real , pointer, dimension (:) :: sub_lon, sub_lat, rev_dist, sub_fevg1, sub_fevg2,& - lonc, latc, LATT, LONN, DAYX, long, latg, var_dum, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - integer :: AGCM_YYY, AGCM_MMM, AGCM_DDD, AGCM_HRR, AGCM_MI, AGCM_S, dofyr - type(MAPL_SunOrbit) :: ORBIT - type(ESMF_Time) :: CURRENT_TIME - type(ESMF_TimeInterval) :: timeStep - type(ESMF_Clock) :: CLOCK - type(ESMF_Config) :: CF - - - allocate (tid_offl (ntiles_cn)) - allocate (ityp_offl (ntiles_cn,nveg)) - allocate (fveg_offl (ntiles_cn,nveg)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1),4)) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - ! -------------------------------------------- - ! Read exact lonn, latt from output .til file - ! -------------------------------------------- - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (DAYX (NTILES)) - - call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg) - - !----------------------- - ! COMPUTE DAYX - !----------------------- - - AGCM_YYY = AGCM_YY - AGCM_MMM = AGCM_MM - AGCM_DDD = AGCM_DD - AGCM_HRR = AGCM_HR - AGCM_MI = 0 - AGCM_S = 0 - - - call ESMF_CalendarSetDefault ( ESMF_CALKIND_GREGORIAN, rc=status ) - - ! get current date & time - ! ----------------------- - call ESMF_TimeSet ( CURRENT_TIME, YY = AGCM_YYY, & - MM = AGCM_MMM, & - DD = AGCM_DDD, & - H = AGCM_HRR, & - M = AGCM_MI, & - S = AGCM_S , & - rc=status ) - VERIFY_(STATUS) - - call ESMF_TimeIntervalSet(TimeStep, S=450, RC=status) - clock = ESMF_ClockCreate(TimeStep, startTime = CURRENT_TIME, RC=status) - VERIFY_(STATUS) - call ESMF_ClockSet ( clock, CurrTime=CURRENT_TIME, rc=status ) - - CF = ESMF_ConfigCreate(RC=STATUS) - VERIFY_(status) - - ORBIT = MAPL_SunOrbitCreateFromConfig(CF, CLOCK, .false., RC=status) - VERIFY_(status) - - ! compute current daylight duration - !---------------------------------- - call MAPL_SunGetDaylightDuration(ORBIT,latg,dayx,currTime=CURRENT_TIME,RC=STATUS) - VERIFY_(STATUS) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(InCNTilFile,i,xlon=lonc,xlat=latc) - - endif - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst - ! ---------------------------------------------------------------------------- - ! call MPI_Info_create(info, STATUS) - ! call MPI_Info_set(info, "romio_cb_read", "automatic", STATUS) - ! STATUS = NF_OPEN_PAR (trim(InCNRestart),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, info,NCFID) - ! STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, info,OUTID) - - STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_NOWRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) - ! if(root_proc) then - ! STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) - ! - ! else - ! STATUS = NF_OPEN (trim(OutFileName),NF_NOWRITE,OUTID) - ! endif - ! - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OFFLINE RESTART FAILED') - allocate (TILE_ID (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_cn/),TILE_ID) - - do n = 1,ntiles_cn - - K = NINT (TILE_ID (n)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(k,:)) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(k,:)) - - tid_offl (n) = n - - do nv = 1,nveg - if(ityp_offl(k,nv)<0 .or. ityp_offl(k,nv)>npft) stop 'ityp' - if(fveg_offl(k,nv)<0..or. fveg_offl(k,nv)>1.00001) stop 'fveg' - end do - - if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) == 0)) then - if(ityp_offl(k,1) /= 0) then - ityp_offl(k,3) = ityp_offl(k,1) - else - ityp_offl(k,3) = ityp_offl(k,2) - endif - endif - - if((ityp_offl(k,1) == 0).and.(ityp_offl(k,2) /= 0)) ityp_offl(k,1) = ityp_offl(k,2) - if((ityp_offl(k,2) == 0).and.(ityp_offl(k,1) /= 0)) ityp_offl(k,2) = ityp_offl(k,1) - if((ityp_offl(k,3) == 0).and.(ityp_offl(k,4) /= 0)) ityp_offl(k,3) = ityp_offl(k,4) - if((ityp_offl(k,4) == 0).and.(ityp_offl(k,3) /= 0)) ityp_offl(k,4) = ityp_offl(k,3) - - end do - - endif - - call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2,lonc,latc,lonn,latt) - - ! update id_glb in root - - if(root_proc) then - allocate (id_glb (ntiles,4)) - allocate (id_vec (ntiles)) - endif - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc (:,nv), nt_local(myid+1) , MPI_real, & -! id_vec, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_vec(low_ind(i) : upp_ind(i)) = Id_loc(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb (:,nv) = id_vec - - end do - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - STATUS = NF_CLOSE (OutID) -! write out regridded carbon variables - - if(root_proc) then - - STATUS = NF_OPEN (trim(OutFileName),NF_WRITE,OUTID) ; VERIFY_(STATUS) - allocate (CLMC_pf1(NTILES)) - allocate (CLMC_pf2(NTILES)) - allocate (CLMC_sf1(NTILES)) - allocate (CLMC_sf2(NTILES)) - allocate (CLMC_pt1(NTILES)) - allocate (CLMC_pt2(NTILES)) - allocate (CLMC_st1(NTILES)) - allocate (CLMC_st2(NTILES)) - allocate (VAR_DUM (NTILES)) - allocate (var_dum2 (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) - - allocate (var_off_col (1: NTILES_CN, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_CN, 1 : nzone,1 : nveg, 1 : var_pft)) - - allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - end do - - var_col_out = 0. - var_pft_out = NaN - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - - OUT_TILE : DO N = 1, NTILES - - !if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - - NVLOOP2 : do nv = 1, nveg - - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary - nx = nv + 2 - else - nx = nv - 2 - endif - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if (fveg_new > fmin) then - - offl_cell = Id_glb(n,nv) - - if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) - else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! primary, other type (same class) - else if(fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! secondary, other type (same class) - endif - - ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst - ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) - var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - - ! Check whether var_pft_out is realistic - do nz = 1, nzone - do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new - !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 - end do - end do - endif - - end do NVLOOP2 - - ! reset carbon if negative < 10g - ! ------------------------ - - NZLOOP : do nz = 1, nzone - - if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - - NVLOOP3 : do nv = 1,nveg - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - - if(ityp_new <= 12) then ! tree or shrub deadstemc - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) - endif - - var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) - var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) - var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) - var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) - var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) - var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) - var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - - if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) - else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous - endif - - var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) - var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) - var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) - var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) - var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) - var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) - var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) - var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) - var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) - var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) - var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) - var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) - var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) - var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) - var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) - var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) - var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) - var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) - var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) - var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) - var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) - var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) - var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) - var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) - var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) - var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) - var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) - endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check - end do NZLOOP ! end zone loop - - ! Update dayx variable var_pft_out (:,:,28) - - do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) - do nv = 1,nveg - do nz = 1,nzone - var_pft_out (n, nz,nv,j) = dayx(n) - end do - end do - end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - - ! column vars - ! ----------- - ! 1 clm3%g%l%c%ccs%col_ctrunc - ! 2 clm3%g%l%c%ccs%cwdc - ! 3 clm3%g%l%c%ccs%litr1c - ! 4 clm3%g%l%c%ccs%litr2c - ! 5 clm3%g%l%c%ccs%litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc - ! 7 clm3%g%l%c%ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c - ! 11 clm3%g%l%c%ccs%soil2c - ! 12 clm3%g%l%c%ccs%soil3c - ! 13 clm3%g%l%c%ccs%soil4c - ! 14 clm3%g%l%c%ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc - ! 17 clm3%g%l%c%cns%cwdn - ! 18 clm3%g%l%c%cns%litr1n - ! 19 clm3%g%l%c%cns%litr2n - ! 20 clm3%g%l%c%cns%litr3n - ! 21 clm3%g%l%c%cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n - ! 23 clm3%g%l%c%cns%seedn - ! 24 clm3%g%l%c%cns%sminn - ! 25 clm3%g%l%c%cns%soil1n - ! 26 clm3%g%l%c%cns%soil2n - ! 27 clm3%g%l%c%cns%soil3n - ! 28 clm3%g%l%c%cns%soil4n - ! 29 clm3%g%l%c%cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned - ! 31 clm3%g%l%c%cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob - ! 36 clm3%g%l%c%cps%fireseasonl - ! 37 clm3%g%l%c%cps%fpg - ! 38 clm3%g%l%c%cps%fpi - ! 39 clm3%g%l%c%cps%me - ! 40 clm3%g%l%c%cps%mean_fire_prob - - ! PFT vars - ! -------- - ! 1 clm3%g%l%c%p%pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn - ! 69 clm3%g%l%c%p%pps%elai - ! 70 clm3%g%l%c%p%pps%esai - ! 71 clm3%g%l%c%p%pps%hbot - ! 72 clm3%g%l%c%p%pps%htop - ! 73 clm3%g%l%c%p%pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai - - end do OUT_TILE - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) - i = i + 1 - end do - end do - end do - - VAR_DUM = 0. - - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TGWM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) - end do - - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'BFLOWM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM'), (/1/), (/NTILES/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM'), (/1/), (/NTILES/),VAR_DUM(:)) - - do nv = 1,nzone - do nz = 1,nveg - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) - end do - end do - - STATUS = NF_CLOSE (NCFID) - STATUS = NF_CLOSE (OutID) - - deallocate (var_off_col,var_off_pft,var_col_out,var_pft_out) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - - END SUBROUTINE regrid_carbon_vars - - ! ***************************************************************************** - - SUBROUTINE NCDF_reshape_getOput (NCFID,CID,col,pft, get_var) - - implicit none - - integer, intent (in) :: NCFID,CID - logical, intent (in) :: get_var - real, intent (inout) :: col (nzone * VAR_COL) - real, intent (inout) :: pft (nzone * nveg * var_PFT) - integer :: STATUS - - if (get_var) then - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/CID,1/), (/1,nzone * VAR_COL /),col) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/CID,1/), (/1,nzone * nveg * var_PFT/),pft) - else - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/CID,1/), (/1,nzone * VAR_COL /),col) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/CID,1/), (/1,nzone * nveg * var_PFT/),pft) - endif - - IF ((STATUS .NE. NF_NOERR).and.(get_var)) then - print *,CID - CALL HANDLE_ERR(STATUS, 'Out : NCDF_reshape_getOput') - ENDIF - - IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) then - print *,CID - CALL HANDLE_ERR(STATUS, 'In : NCDF_reshape_getOput') - ENDIF - END SUBROUTINE NCDF_reshape_getOput - - ! ***************************************************************************** - - SUBROUTINE NCDF_whole_getOput (NCFID,NTILES,col,pft, get_var) - - implicit none - - integer, intent (in) :: NCFID,NTILES - logical, intent (in) :: get_var - real, intent (inout) :: col (NTILES, nzone * VAR_COL) - real, intent (inout) :: pft (NTILES, nzone * nveg * var_PFT) - integer :: STATUS, J - - if (get_var) then - DO J = 1,nzone * VAR_COL - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,J/), (/NTILES,1 /),col(:,j)) - END DO - DO J = 1, nzone * nveg * var_PFT - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,J/), (/NTILES,1/),pft(:,J)) - END DO - else - DO J = 1,nzone * VAR_COL - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,J/), (/NTILES,1 /),col(:,J)) - END DO - DO J = 1, nzone * nveg * var_PFT - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,J/), (/NTILES,1/) ,pft(:,J)) - END DO - endif - - IF ((STATUS .NE. NF_NOERR).and.(get_var)) CALL HANDLE_ERR(STATUS, 'Out : NCDF_whole_getOput') - IF ((STATUS .NE. NF_NOERR).and.(.not.get_var)) CALL HANDLE_ERR(STATUS, 'In : NCDF_whole_getOput') - - END SUBROUTINE NCDF_whole_getOput - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID - - ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, OutFMT) - - implicit none - integer, intent (in) :: NTILES - - ! =============================================================================================== - - integer, allocatable, dimension(:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: ld_reorder, tid_offl - real , allocatable, dimension(:) :: tmp_var - integer :: n,i,j, nv, nx, offl_cell, STATUS,NCFID, req - integer :: outid, local_id - real , pointer, dimension (:) :: lonc, latc, LATT, LONN, long, latg - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - type(Netcdf4_Fileformatter) :: InFmt, OutFmt - - allocate (tid_offl (ntiles_cn)) - allocate (tmp_var (ntiles_cn)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_cn)) - - call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(trim(InCNTilFile), i,xlon=lonc,xlat=latc) - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),tmp_var) - STATUS = NF_CLOSE (NCFID) - - do n = 1, ntiles_cn - ld_reorder ( NINT(tmp_var(n))) = n - tid_offl(n) = n - end do - - deallocate (tmp_var) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. - - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - if (root_proc) call put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_hyd_vars - - ! ***************************************************************************** - SUBROUTINE put_land_vars (NTILES, id_glb, ld_reorder, OutFmt) - - implicit none - - integer, intent (in) :: NTILES - integer, intent (in) :: id_glb(NTILES), ld_reorder (NTILES_CN) - integer :: i,k,n - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_Fileformatter) :: OutFmt - integer :: nVars, STATUS, NCFID - - allocate (var_get (NTILES_CN)) - allocate (var_put (NTILES)) - - ! Read catparam - ! ------------- - - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'POROS' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'COND' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'PSIS' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BEE' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=4) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=4) - - ! read restart and regrid - ! ----------------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=1) ! if you see offset1=1 it is a 2-D var - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,3/), (/NTILES_CN,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CAPAC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_CN/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - STATUS = NF_CLOSE ( NCFID) - - deallocate (var_get, var_put) - - END SUBROUTINE put_land_vars - - ! ***************************************************************************** - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" -! write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - - ! ***************************************************************************** - -end program mk_CatchCNRestarts - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 deleted file mode 100644 index 26884ad035..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_CatchRestarts.F90 +++ /dev/null @@ -1,778 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" -program mk_CatchRestarts - -! $Id: - - use MAPL - use mk_restarts_getidsMod, only: GetIDs,ReadTileFile_RealLatLon - use gFTL_StringVector - - implicit none - include 'mpif.h' - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr, mpistatus(MPI_STATUS_SIZE) - logical :: root_proc=.true. - - character*256 :: Usage="mk_CatchRestarts OutTileFile InTileFile InRestart SURFLAY " - character*256 :: OutTileFile - character*256 :: InTileFile - character*256 :: InRestart - character*256 :: OutType - character*256 :: arg(6) - - integer :: i, k, iargc, n, ntiles,ntiles_in, nplus, req - integer, pointer :: Id(:), tid_in (:) - real, pointer :: loni(:),lono(:), lati(:), lato(:) - real :: SURFLAY - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:), Id_loc (:) - real , pointer, dimension (:) :: LATT, LONN - logical :: OutIsOld, havedata - character*256, parameter :: DataDir="OutData/clsm/" - real :: min_lon, max_lon, min_lat, max_lat - logical, allocatable, dimension(:) :: mask - integer, allocatable, dimension (:) :: sub_tid - real , allocatable, dimension (:) :: sub_lon, sub_lat - integer :: status - - call init_MPI() - -!--------------------------------------------------------------------------- - - I = iargc() - - if( I<4 .or. I>5 ) then - print *, "Wrong Number of arguments: ", i - print *, trim(Usage) - call exit(1) - end if - - do n=1,I - call getarg(n,arg(n)) - enddo - read(arg(1),'(a)') OutTileFile - read(arg(2),'(a)') InTileFile - read(arg(3),'(a)') InRestart - read(arg(4),*) SURFLAY - - if(I==5) then - call getarg(6,OutType) - OutIsOld = trim(OutType)=="OutIsOld" - else - OutIsOld = .false. - endif - - if (SURFLAY.ne.20 .and. SURFLAY.ne.50) then - print *, "You must supply a valid SURFLAY value:" - print *, "(Ganymed-3 and earlier) SURFLAY=20.0 for Old Soil Params" - print *, "(Ganymed-4 and later ) SURFLAY=50.0 for New Soil Params" - call exit(2) - end if - - inquire(file=trim(DataDir)//"mosaic_veg_typs_fracs",exist=havedata) - - if (root_proc) then - - ! Read Output/Input .til files - call ReadTileFile_RealLatLon(OutTileFile, ntiles, xlon=lono, xlat=lato) - call ReadTileFile_RealLatLon(InTileFile,ntiles_in,xlon=loni, xlat=lati) - allocate(Id (ntiles)) - ! allocate(mask (ntiles_in)) - ! allocate(tid_in (ntiles_in)) - ! do n = 1, NTILES_IN - ! tid_in (n) = n - ! end do - - endif - - if (havedata) then - if (root_proc) call read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES, __RC__) - else - - call MPI_BCAST (ntiles , 1, MPI_INTEGER, 0,MPI_COMM_WORLD, mpierr) - call MPI_BCAST (ntiles_in, 1, MPI_INTEGER, 0,MPI_COMM_WORLD, mpierr) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - ! Get intile lat/lon - -! do i = 2, numprocs -! if (i -1 == myid) then -! ! receive ntiles_in in the block -! call MPI_RECV(ntiles_in, 1, MPI_INTEGER,0,999,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! ! ALLOCATE -! allocate (loni (1:NTILES_IN)) -! allocate (lati (1:NTILES_IN)) -! allocate (tid_in (1:NTILES_IN)) -! -! ! RECEIVE LAT/LON IN -! call MPI_RECV(tid_in, ntiles_in, MPI_INTEGER,0,998,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! call MPI_RECV(loni , ntiles_in, MPI_REAL ,0,997,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! call MPI_RECV(lati , ntiles_in, MPI_REAL ,0,996,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) -! -! else if (myid == 0) then -! -! ! Send local ntiles_in -! -! min_lon = MAX(MINVAL(lono (low_ind(i) : upp_ind(i))) - 5, -180.) -! max_lon = MIN(MAXVAL(lono (low_ind(i) : upp_ind(i))) + 5, 180.) -! min_lat = MAX(MINVAL(lato (low_ind(i) : upp_ind(i))) - 5, -90.) -! max_lat = MIN(MAXVAL(lato (low_ind(i) : upp_ind(i))) + 5, 90.) -! mask = .false. -! mask = ((lati >= min_lat .and. lati <= max_lat).and.(loni >= min_lon .and. loni <= max_lon)) -! nplus = count(mask = mask) -! -! call MPI_ISend(NPLUS ,1,MPI_INTEGER,i-1,999,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! -! -! ! SEND LAT/LON IN -! allocate (sub_tid (1:nplus)) -! allocate (sub_lon (1:nplus)) -! allocate (sub_lat (1:nplus)) -! -! sub_tid = PACK (tid_in , mask= mask) -! sub_lon = PACK (loni , mask= mask) -! sub_lat = PACK (lati , mask= mask) -! -! call MPI_ISend(sub_tid, nplus,MPI_INTEGER,i-1,998,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! call MPI_ISend(sub_lon, nplus,MPI_REAL ,i-1,997,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! call MPI_ISend(sub_lat, nplus,MPI_REAL ,i-1,996,MPI_COMM_WORLD,req,mpierr) -! call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) -! deallocate (sub_tid,sub_lon,sub_lat) -! endif -! end do - - ! Get out tile lat/lots from root - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = lono(low_ind(i) : upp_ind(i)) - latt(:) = lato(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(lono(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(lato(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! lono,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! lato,nt_local,low_ind-1,MPI_real, & -! latt,size(latt),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(myid > 0) allocate (loni (1:NTILES_IN)) - if(myid > 0) allocate (lati (1:NTILES_IN)) - - call MPI_BCAST(loni,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(lati,ntiles_in,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - allocate(tid_in (ntiles_in)) - do n = 1, NTILES_IN - tid_in (n) = n - end do - - call GetIds(loni,lati,lonn,latt,Id_loc, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) -! call MPI_GATHERV( & -! id_loc (:), nt_local(myid+1), MPI_real, & -! id, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - deallocate (loni,lati,lonn,latt, tid_in) - call MPI_Barrier(MPI_COMM_WORLD, mpierr) - - if (root_proc) call read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES_IN, id, __RC__) - - endif - - call MPI_BARRIER( MPI_COMM_WORLD, mpierr) - call MPI_FINALIZE(mpierr) - -contains - - SUBROUTINE read_and_write_rst (NTILES, SURFLAY, OutIsOld, NTILES_IN, idi, rc) - - implicit none - real, intent (in) :: SURFLAY - logical, intent (in) :: OutIsOld - integer, intent (in) :: NTILES, NTILES_IN - integer, pointer, dimension(:), optional, intent (in) :: idi - integer, optional, intent(out) :: rc - logical :: havedata, NewLand - character(len=256), parameter :: Names(29) = & - (/'BF1 ','BF2 ','BF3 ','VGWMAX','CDCR1 ', & - 'CDCR2 ','PSIS ','BEE ','POROS ','WPWET ', & - 'COND ','GNU ','ARS1 ','ARS2 ','ARS3 ', & - 'ARA1 ','ARA2 ','ARA3 ','ARA4 ','ARW1 ', & - 'ARW2 ','ARW3 ','ARW4 ','TSA1 ','TSA2 ', & - 'TSB1 ','TSB2 ','ATAU ','BTAU '/) - - integer, pointer :: ity(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), rity(:) - - real :: zdep1, zdep2, zdep3, zmet, term1, term2, rdum - real, allocatable :: var1(:),var2(:,:) - character*256 :: vname - character*256 :: OutFileName - integer :: i, n, j,k,ncatch,idum - logical,allocatable :: written(:) - integer :: ndims,filetype - integer :: dimSizes(3),nVars - logical :: file_exists - integer, pointer :: Ido(:), idx(:), id(:) - logical :: InIsOld - type(NetCDF4_Fileformatter) :: InFmt,OutFmt,CatchFmt - type(FileMetadata) :: InCfg,OutCfg - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: myVariable - type(StringVariableMapIterator) :: var_iter - character(len=:), pointer :: var_name,dname - type(StringVector), pointer :: var_dimensions - integer :: dim1, dim2 - character(256) :: Iam = "read_and_write_rst" - integer :: status - - print *, 'SURFLAY: ',SURFLAY - - inquire(file=trim(DataDir)//"mosaic_veg_typs_fracs",exist=havedata) - inquire(file=trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) - - print *, 'havedata = ',havedata - - call MAPL_NCIOGetFileType(InRestart, filetype,__RC__) - - if (filetype == 0) then - - call InFmt%open(InRestart,pFIO_READ,__RC__) - InCfg=InFmt%read(__RC__) - call MAPL_IOChangeRes(InCfg,OutCfg,(/'tile'/),(/ntiles/),__RC__) - i = index(InRestart,'/',back=.true.) - OutFileName = "OutData/"//trim(InRestart(i+1:)) - call OutFmt%create(OutFileName,__RC__) - call OutFmt%write(OutCfg,__RC__) - call MAPL_IOCountNonDimVars(OutCfg,nvars,__RC__) - - allocate(written(nvars)) - written=.false. - - else - - open(unit=50,FILE=InRestart,form='unformatted',& - status='old',convert='little_endian') - - do i=1,58 - read(50,end=2001) - end do -2001 continue - InIsOld = I==59 - - rewind(50) - - i = index(InRestart,'/',back=.true.) - - open(unit=40,FILE="OutData/"//trim(InRestart(i+1:)),form='unformatted',& - status='unknown',convert='little_endian') - - end if - - HAVE: if(havedata) then - - print *,'Working from Sariths data pretiled for this resolution' - - ! Get number of catchments - - open(unit=22, & - file=trim(DataDir)//"catchment.def",status='old',form='formatted') - - read (22, *) ncatch - - close(22) - - if(ncatch==ntiles) then - print *, "Read ",Ncatch," land tiles." - allocate (ido (ntiles)) - do i=1,ncatch - ido(i) = i - enddo - else - print *, "Number of tiles in data, ",Ncatch," does not match number in til file ", size(Ido) - call exit(1) - endif - - allocate(ity(ncatch),rity(ncatch)) - allocate ( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) - allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) - allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) - allocate ( WPWET(ncatch), COND(ncatch), GNU(ncatch) ) - allocate ( ARS1(ncatch), ARS2(ncatch), ARS3(ncatch) ) - allocate ( ARA1(ncatch), ARA2(ncatch), ARA3(ncatch) ) - allocate ( ARA4(ncatch), ARW1(ncatch), ARW2(ncatch) ) - allocate ( ARW3(ncatch), ARW4(ncatch), TSA1(ncatch) ) - allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) - allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) - - inquire(file = trim(DataDir)//'/catch_params.nc4', exist=file_exists) - - if(file_exists) then - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%open(trim(DataDir)//'/catch_params.nc4',pFIO_Read, __RC__) - call MAPL_VarRead ( catchFmt ,'OLD_ITY', rity, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( catchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( catchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( catchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( catchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( catchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( catchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( catchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( catchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( catchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( catchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( catchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( catchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( catchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( catchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( catchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( catchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( catchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( catchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( catchFmt ,'POROS', POROS, __RC__) - call catchFmt%close(__RC__) - - else - open(unit=21, file=trim(DataDir)//"mosaic_veg_typs_fracs",status='old',form='formatted') - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - - do n=1,ncatch - read (21,*) I, j, ITY(N) - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - end do - - rity = float(ity) - CLOSE (21, STATUS = 'KEEP') - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - - endif - - do n=1,ncatch - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 > 0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - enddo - - - if (filetype /=0) then - do i=1,30 - read(50) - enddo - end if - - idx => ido - - else - - print *,'Working from restarts alone' - - ncatch = NTILES_IN - - allocate ( rity(ncatch)) - allocate ( BF1(ncatch), BF2 (ncatch), BF3(ncatch) ) - allocate (VGWMAX(ncatch), CDCR1(ncatch), CDCR2(ncatch) ) - allocate ( PSIS(ncatch), BEE(ncatch), POROS(ncatch) ) - allocate ( WPWET(ncatch), COND(ncatch), GNU(ncatch) ) - allocate ( ARS1(ncatch), ARS2(ncatch), ARS3(ncatch) ) - allocate ( ARA1(ncatch), ARA2(ncatch), ARA3(ncatch) ) - allocate ( ARA4(ncatch), ARW1(ncatch), ARW2(ncatch) ) - allocate ( ARW3(ncatch), ARW4(ncatch), TSA1(ncatch) ) - allocate ( TSA2(ncatch), TSB1(ncatch), TSB2(ncatch) ) - allocate ( ATAU2(ncatch), BTAU2(ncatch), DP2BR(ncatch) ) - - if (filetype == 0) then - - call MAPL_VarRead(InFmt,names(1),BF1, __RC__) - call MAPL_VarRead(InFmt,names(2),BF2, __RC__) - call MAPL_VarRead(InFmt,names(3),BF3, __RC__) - call MAPL_VarRead(InFmt,names(4),VGWMAX, __RC__) - call MAPL_VarRead(InFmt,names(5),CDCR1, __RC__) - call MAPL_VarRead(InFmt,names(6),CDCR2, __RC__) - call MAPL_VarRead(InFmt,names(7),PSIS, __RC__) - call MAPL_VarRead(InFmt,names(8),BEE, __RC__) - call MAPL_VarRead(InFmt,names(9),POROS, __RC__) - call MAPL_VarRead(InFmt,names(10),WPWET, __RC__) - - call MAPL_VarRead(InFmt,names(11),COND, __RC__) - call MAPL_VarRead(InFmt,names(12),GNU, __RC__) - call MAPL_VarRead(InFmt,names(13),ARS1, __RC__) - call MAPL_VarRead(InFmt,names(14),ARS2, __RC__) - call MAPL_VarRead(InFmt,names(15),ARS3, __RC__) - call MAPL_VarRead(InFmt,names(16),ARA1, __RC__) - call MAPL_VarRead(InFmt,names(17),ARA2, __RC__) - call MAPL_VarRead(InFmt,names(18),ARA3, __RC__) - call MAPL_VarRead(InFmt,names(19),ARA4, __RC__) - call MAPL_VarRead(InFmt,names(20),ARW1, __RC__) - - call MAPL_VarRead(InFmt,names(21),ARW2, __RC__) - call MAPL_VarRead(InFmt,names(22),ARW3, __RC__) - call MAPL_VarRead(InFmt,names(23),ARW4, __RC__) - call MAPL_VarRead(InFmt,names(24),TSA1, __RC__) - call MAPL_VarRead(InFmt,names(25),TSA2, __RC__) - call MAPL_VarRead(InFmt,names(26),TSB1, __RC__) - call MAPL_VarRead(InFmt,names(27),TSB2, __RC__) - call MAPL_VarRead(InFmt,names(28),ATAU2, __RC__) - call MAPL_VarRead(InFmt,names(29),BTAU2, __RC__) - call MAPL_VarRead(InFmt,'OLD_ITY',rITY, __RC__) - - else - - read(50) BF1 - read(50) BF2 - read(50) BF3 - read(50) VGWMAX - read(50) CDCR1 - read(50) CDCR2 - read(50) PSIS - read(50) BEE - read(50) POROS - read(50) WPWET - - read(50) COND - read(50) GNU - read(50) ARS1 - read(50) ARS2 - read(50) ARS3 - read(50) ARA1 - read(50) ARA2 - read(50) ARA3 - read(50) ARA4 - read(50) ARW1 - - read(50) ARW2 - read(50) ARW3 - read(50) ARW4 - read(50) TSA1 - read(50) TSA2 - read(50) TSB1 - read(50) TSB2 - read(50) ATAU2 - read(50) BTAU2 - read(50) rITY - - end if - - idx => idi - - endif HAVE - - if (filetype == 0) then - call MAPL_VarWrite(OutFmt,names(1),BF1(Idx)) - call MAPL_VarWrite(OutFmt,names(2),BF2(Idx)) - call MAPL_VarWrite(OutFmt,names(3),BF3(Idx)) - call MAPL_VarWrite(OutFmt,names(4),VGWMAX(Idx)) - call MAPL_VarWrite(OutFmt,names(5),CDCR1(Idx)) - call MAPL_VarWrite(OutFmt,names(6),CDCR2(Idx)) - call MAPL_VarWrite(OutFmt,names(7),PSIS(Idx)) - call MAPL_VarWrite(OutFmt,names(8),BEE(Idx)) - call MAPL_VarWrite(OutFmt,names(9),POROS(Idx)) - call MAPL_VarWrite(OutFmt,names(10),WPWET(Idx)) - call MAPL_VarWrite(OutFmt,names(11),COND(Idx)) - call MAPL_VarWrite(OutFmt,names(12),GNU(Idx)) - call MAPL_VarWrite(OutFmt,names(13),ARS1(Idx)) - call MAPL_VarWrite(OutFmt,names(14),ARS2(Idx)) - call MAPL_VarWrite(OutFmt,names(15),ARS3(Idx)) - call MAPL_VarWrite(OutFmt,names(16),ARA1(Idx)) - call MAPL_VarWrite(OutFmt,names(17),ARA2(Idx)) - call MAPL_VarWrite(OutFmt,names(18),ARA3(Idx)) - call MAPL_VarWrite(OutFmt,names(19),ARA4(Idx)) - call MAPL_VarWrite(OutFmt,names(20),ARW1(Idx)) - call MAPL_VarWrite(OutFmt,names(21),ARW2(Idx)) - call MAPL_VarWrite(OutFmt,names(22),ARW3(Idx)) - call MAPL_VarWrite(OutFmt,names(23),ARW4(Idx)) - call MAPL_VarWrite(OutFmt,names(24),TSA1(Idx)) - call MAPL_VarWrite(OutFmt,names(25),TSA2(Idx)) - call MAPL_VarWrite(OutFmt,names(26),TSB1(Idx)) - call MAPL_VarWrite(OutFmt,names(27),TSB2(Idx)) - call MAPL_VarWrite(OutFmt,names(28),ATAU2(Idx)) - call MAPL_VarWrite(OutFmt,names(29),BTAU2(Idx)) - call MAPL_VarWrite(OutFmt,'OLD_ITY',rity(Idx)) - - - call MAPL_IOCountNonDimVars(InCfg,nvars) - - variables => InCfg%get_variables() - var_iter = variables%begin() - i = 0 - do while (var_iter /= variables%end()) - - var_name => var_iter%key() - i=i+1 - do j=1,29 - if ( trim(var_name) == trim(names(j)) ) written(i) = .true. - enddo - if (trim(var_name) == "OLD_ITY" ) written(i) = .true. - - call var_iter%next() - - enddo - - variables => InCfg%get_variables() - var_iter = variables%begin() - n=0 - allocate(var1(NTILES_IN)) - do while (var_iter /= variables%end()) - - var_name => var_iter%key() - myVariable => var_iter%value() - - if (.not.InCfg%is_coordinate_variable(var_name)) then - - n=n+1 - if (.not.written(n) ) then - - var_dimensions => myVariable%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead(InFmt,var_name,var1, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx)) - else if (ndims == 2) then - - dname => myVariable%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead(InFmt,var_name,var1,offset1=j, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx),offset1=j) - enddo - else if (ndims == 3) then - - dname => myVariable%get_ith_dimension(2) - dim1=InCfg%get_dimension(dname) - dname => myVariable%get_ith_dimension(3) - dim2=InCfg%get_dimension(dname) - do k=1,dim2 - do j=1,dim1 - call MAPL_VarRead(InFmt,var_name,var1,offset1=j,offset2=k, __RC__) - call MAPL_VarWrite(OutFmt,var_name,var1(idx),offset1=j,offset2=k) - enddo - enddo - - end if - - end if - end if - call var_iter%next() - - enddo - - else - - write(40) BF1(Idx) - write(40) BF2(Idx) - write(40) BF3(Idx) - write(40) VGWMAX(Idx) - write(40) CDCR1(Idx) - write(40) CDCR2(Idx) - write(40) PSIS(Idx) - write(40) BEE(Idx) - write(40) POROS (Idx) - write(40) WPWET(Idx) - write(40) COND(Idx) - write(40) GNU(Idx) - write(40) ARS1(Idx) - write(40) ARS2(Idx) - write(40) ARS3(Idx) - write(40) ARA1(Idx) - write(40) ARA2(Idx) - write(40) ARA3(Idx) - write(40) ARA4(Idx) - write(40) ARW1(Idx) - write(40) ARW2(Idx) - write(40) ARW3(Idx) - write(40) ARW4(Idx) - write(40) TSA1(Idx) - write(40) TSA2(Idx) - write(40) TSB1(Idx) - write(40) TSB2(Idx) - write(40) ATAU2(Idx) - write(40) BTAU2(Idx) - write(40) rITY(Idx) - - - allocate(var1(NTILES_IN)) - allocate(var2(NTILES_IN,4)) - - ! TC QC - - do n=1,2 - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end do - - !CAPAC CATDEF RZEXC SRFEXC ... SNDZN3 - - do n=1,20 - read (50) var1 - write(40) var1(Idx) - enddo - - ! CH CM CQ FR - - do n=1,4 - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end do - - ! These are the 2 prev/next pairs that dont are not - ! in the internal in fortuna-2_0 and later. Earlier the - ! record are there, but their values are not needed, since - ! they are initialized on start-up. - - if(InIsOld) then - do n=1,4 - read (50) - enddo - endif - - if(OutIsOld) then - var1 = 0.0 - do n=1,4 - write(40) (var1(idx(i)),i = 1, ntiles) - end do - endif - - ! WW - - read (50) var2 - write(40) ((var2(idx(i),j),i=1,ntiles),j=1,4) - end if - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_and_write_rst - - ! ***************************************************************************** - - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" -! write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - -end program mk_CatchRestarts - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 deleted file mode 100644 index 5e3da8d3ad..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_GEOSldasRestarts.F90 +++ /dev/null @@ -1,3917 +0,0 @@ -#define I_AM_MAIN -#include "MAPL_Generic.h" - -PROGRAM mk_GEOSldasRestarts - -! USAGE/HELP (NOTICE mpirun -np 1) -! mpirun -np 1 bin/mk_GEOSldasRestarts.x -h -! -! (1) to create an initial catch(cn)_internal_rst file ready for an offline experiment : -! -------------------------------------------------------------------------------------- -! (1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50) -t TILFILE -! where MODEL : catch or catchcn -! (1.2) sbatch mkLDAS.j -! -! (2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment : -! -------------------------------------------------------------------------------------------- -! mpirun -np 1 bin/mk_GEOSldasRestarts.x -b BCSDIR -d YYYYMMDD -e EXPNAME -l EXPDIR -m MODEL -s SURFLAY(20/50) -r Y -t TILFILE -p PARAMFILE - use netcdf - use MAPL - use mk_restarts_getidsMod, only: GetIDs, ReadTileFile_RealLatLon - use gFTL_StringVector - use ieee_arithmetic, only: isnan => ieee_is_nan - USE STIEGLITZSNOW, ONLY : & - StieglitzSnow_calc_tpsnow - implicit none - include 'mpif.h' - INCLUDE 'netcdf.inc' - - ! initialize to non-MPI values - - integer :: myid=0, numprocs=1, mpierr - logical :: root_proc=.true. - - ! Carbon model specifics - ! ---------------------- - - character*256 :: Usage="mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -d YYYYMMDDHH -e EXPNAME -j JOBFILE -k ENS -l EXPDIR -m MODEL -r REORDER -s SURFLAY -t TILFILE -p PARAMFILE -f RSTFILE" - character*256 :: BCSDIR, SPONSORCODE, EXPNAME, EXPDIR, TILFILE, SFL, PFILE - character*400 :: CMD - character*10 :: YYYYMMDDHH - character(len=:), allocatable :: model, catch_scaler, rstfile - - real, parameter :: ECCENTRICITY = 0.0167 - real, parameter :: PERIHELION = 102.0 - real, parameter :: OBLIQUITY = 23.45 - integer, parameter :: EQUINOX = 80 - - integer, parameter :: nveg = 4 - integer, parameter :: nzone = 3 - integer, parameter :: VAR_COL_CLM40 = 40 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM40 = 74 ! number of CN PFT variables per column - integer, parameter :: npft = 19 - integer, parameter :: npft_clm45 = 19 - integer, parameter :: VAR_COL_CLM45 = 35 ! number of CN column restart variables - integer, parameter :: VAR_PFT_CLM45 = 75 ! number of CN PFT variables per column - - real, parameter :: nan = O'17760000000' - real, parameter :: fmin= 1.e-4 ! ignore vegetation fractions at or below this value - integer, parameter :: OutUnit = 40, InUnit = 50 - character*256 :: arg, tmpstring, ESMADIR - character*1 :: opt, REORDER='N', JOBFILE ='N' - character*4 :: ENS='0000' - integer :: ntiles, rc, nxt - character(len=300) :: OutFileName - integer :: VAR_COL, VAR_PFT - integer :: iclass(npft) = (/1,1,2,3,3,4,5,5,6,7,8,9,10,11,12,11,12,11,12/) - - ! =============================================================================================== - ! Below hard-wired ldas restart file is from a global offline simulation on the SMAP M09 grid - ! after 1000s of years of simulations - - integer, parameter :: ntiles_cn = 1684725, ntiles_cat = 1653157 - character(len=300), parameter :: & - InCNRestart = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/catchcn_internal_rst', & - InCNTilFile = '/discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Heracles-NL/SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & - InCatRestart= '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & - InCatTilFile= '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til', & - InCatRest45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/M09/20170101/catch_internal_rst', & - InCatTil45 = '/discover/nobackup/projects/gmao/ssd/land/l_data/geos5/bcs/CLSM_params/mkCatchParam_SMAP_L4SM_v002/' & - //'SMAP_EASEv2_M09/SMAP_EASEv2_M09_3856x1624.til' - REAL :: SURFLAY = 50. - integer :: STATUS - - character(len=256), parameter :: CatNames (57) = & - (/'BF1 ', 'BF2 ', 'BF3 ', 'VGWMAX ', 'CDCR1 ', & - 'CDCR2 ', 'PSIS ', 'BEE ', 'POROS ', 'WPWET ', & - 'COND ', 'GNU ', 'ARS1 ', 'ARS2 ', 'ARS3 ', & - 'ARA1 ', 'ARA2 ', 'ARA3 ', 'ARA4 ', 'ARW1 ', & - 'ARW2 ', 'ARW3 ', 'ARW4 ', 'TSA1 ', 'TSA2 ', & - 'TSB1 ', 'TSB2 ', 'ATAU ', 'BTAU ', 'OLD_ITY', & - 'TC ', 'QC ', 'CAPAC ', 'CATDEF ', 'RZEXC ', & - 'SRFEXC ', 'GHTCNT1', 'GHTCNT2', 'GHTCNT3', 'GHTCNT4', & - 'GHTCNT5', 'GHTCNT6', 'TSURF ', 'WESNN1 ', 'WESNN2 ', & - 'WESNN3 ', 'HTSNNN1', 'HTSNNN2', 'HTSNNN3', 'SNDZN1 ', & - 'SNDZN2 ', 'SNDZN3 ', 'CH ', 'CM ', 'CQ ', & - 'FR ', 'WW '/) - - character(len=256), parameter :: CarbNames (68) = & - (/'BF1 ', 'BF2 ', 'BF3 ', 'VGWMAX ', 'CDCR1 ', & - 'CDCR2 ', 'PSIS ', 'BEE ', 'POROS ', 'WPWET ', & - 'COND ', 'GNU ', 'ARS1 ', 'ARS2 ', 'ARS3 ', & - 'ARA1 ', 'ARA2 ', 'ARA3 ', 'ARA4 ', 'ARW1 ', & - 'ARW2 ', 'ARW3 ', 'ARW4 ', 'TSA1 ', 'TSA2 ', & - 'TSB1 ', 'TSB2 ', 'ATAU ', 'BTAU ', 'ITY ', & - 'FVG ', 'TC ', 'QC ', 'TG ', 'CAPAC ', & - 'CATDEF ', 'RZEXC ', 'SRFEXC ', 'GHTCNT1', 'GHTCNT2', & - 'GHTCNT3', 'GHTCNT4', 'GHTCNT5', 'GHTCNT6', 'TSURF ', & - 'WESNN1 ', 'WESNN2 ', 'WESNN3 ', 'HTSNNN1', 'HTSNNN2', & - 'HTSNNN3', 'SNDZN1 ', 'SNDZN2 ', 'SNDZN3 ', 'CH ', & - 'CM ', 'CQ ', 'FR ', 'WW ', 'TILE_ID', & - 'NDEP ', 'CLI_T2M', 'BGALBVR', 'BGALBVF', 'BGALBNR', & - 'BGALBNF', 'CNCOL ', 'CNPFT ' /) - - CHARACTER( * ), PARAMETER :: LOWER_CASE = 'abcdefghijklmnopqrstuvwxyz' - CHARACTER( * ), PARAMETER :: UPPER_CASE = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - logical :: clm45 = .false. - logical :: second_visit - integer :: zoom, k, n, infos - character*100 :: InRestart - character(100) :: Iam = "mk_GEOSldasRestarts" - - VAR_COL = VAR_COL_CLM40 - VAR_PFT = VAR_PFT_CLM40 - - call init_MPI() - call MPI_Info_create(infos, STATUS) ; VERIFY_(STATUS) - call MPI_Info_set(infos, "romio_cb_read", "automatic", STATUS) ; VERIFY_(STATUS) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! process commands - ! ---------------- - - CALL get_command (cmd) - call getenv ("ESMADIR" ,ESMADIR ) - nxt = 1 - - call getarg(nxt,arg) - rstfile = 'NONE' - do while(arg(1:1)=='-') - - opt=arg(2:2) - if(len(trim(arg))==2) then - nxt = nxt + 1 - call getarg(nxt,arg) - else - arg = arg(3:) - end if - - select case (opt) - case ('a') - SPONSORCODE = trim(arg) - case ('b') - BCSDIR = trim(arg) - case ('d') - YYYYMMDDHH = trim(arg) - case ('e') - EXPNAME = trim(arg) - case ('h') - print *,' ' - print *,'(1) to create an initial catch(cn)_internal_rst file ready for an offline experiment :' - print *,'--------------------------------------------------------------------------------------' - print *,'(1.1) mpirun -np 1 bin/mk_GEOSldasRestarts.x -a SPONSORCODE -b BCSDIR -m MODEL -s SURFLAY(20/50)' - print *,'where MODEL : catch, catchcnclm40, catchcnclm45' - print *,'(1.2) sbatch mkLDAS.j' - print *,' ' - print *,'(2) to reorder an LDASsa restart file to the order of the BCs for use in an GCM experiment :' - print *,'--------------------------------------------------------------------------------------------' - print *,'mpirun -np 1 bin/mk_GEOSldasRestarts.x -b BCSDIR -d YYYYMMDDHH -e EXPNAME -l EXPDIR -m MODEL -s SURFLAY(20/50) -r Y -t TILFILE -p PARAMFILE' - stop - case ('j') - JOBFILE = trim(arg) - case ('k') - ENS = trim(arg) - case ('l') - EXPDIR = trim(arg) - case ('m') - MODEL = StrLowCase(trim(arg)) - case ('r') - REORDER = trim(arg) - case ('s') - SFL = trim(arg) - read(arg,*) SURFLAY - case ('t') - TILFILE = trim(arg) - case ('p') - PFILE = trim(arg) - case ('f') - RSTFILE = trim(arg) - case default - print *, trim(Usage) - call exit(1) - end select - nxt = nxt + 1 - call getarg(nxt,arg) - end do - - if (index(model, 'catchcn') /=0 ) then - if((INDEX(BCSDIR, 'NL') == 0).AND.(INDEX(BCSDIR, 'OutData') == 0)) then - print *,'Land BCs in : ',trim(BCSDIR) - print *,'do not support ',trim (model) - stop - endif - - if (index(model,'45') /=0) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - endif - catch_scaler = 'Scale_CatchCN' - else - catch_scaler = 'Scale_Catch' - endif - - - if(trim(REORDER) == 'Y') then - - ! This call is to reorder a LDASsa restart file (RESTART: 1) - - call reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile, __RC__) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - call MPI_FINALIZE(mpierr) - call exit(0) - - elseif (trim(REORDER) == 'R') then - - ! This call is to regrid LDASsa/GEOSldas restarts from a different grid (RESTART: 2) - - call regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - call MPI_FINALIZE(mpierr) - call exit(0) - - else - - ! The user does not have restarts, thus cold start (RESTART: 0) - - if(JOBFILE == 'N') then - - call system('mkdir -p InData/ OutData/') - tmpstring = 'cp '//trim(BCSDIR)//'/'//trim(TILFILE)//' InData/OutTileFile' - call system(tmpstring) - tmpstring = 'cp '//trim(BCSDIR)//'/'//trim(TILFILE)//' OutData/OutTileFile' - call system(tmpstring) - tmpstring = 'ln -s '//trim(BCSDIR)//'/clsm OutData/clsm' - call system(tmpstring) - - open (10, file ='mkLDASsa.j', form = 'formatted', status ='unknown', action = 'write') - write(10,'(a)')'#!/bin/csh -fx' - write(10,'(a)')' ' - write(10,'(a)')'#SBATCH --account='//trim(SPONSORCODE) - write(10,'(a)')'#SBATCH --time=1:00:00' - write(10,'(a)')'#SBATCH --ntasks=56' - write(10,'(a)')'#SBATCH --job-name=mkLDAS' - write(10,'(a)')'###SBATCH --constraint=hasw' - write(10,'(a)')'#SBATCH --output=mkLDAS.o' - write(10,'(a)')'#SBATCH --error=mkLDAS.e' - write(10,'(a)')' ' - write(10,'(a)')'limit stacksize unlimited' - write(10,'(a)')'source bin/g5_modules' - !tmpstring = "set BINDIR=`ls -l bin | cut -d'>' -f2`" - !write(10,'(a)')trim(tmpstring) - !tmpstring = "setenv ESMADIR `echo $BINDIR | sed 's/Linux\/bin//g'`" - write(10,'(a)')'setenv ESMADIR '//trim(ESMADIR) - write(10,'(a)')'setenv MKL_CBWR SSE4_2 # ensure zero-diff across archs' - write(10,'(a)')'setenv MV2_ON_DEMAND_THRESHOLD 8192 # MVAPICH2' - write(10,'(a)')' ' - write(10,'(a)')'mpirun -np 56 '//trim(cmd)//' -j Y' - - write(10,'(a)')'bin/'//trim(catch_scaler)//' InData/'//model//'_internal_rst OutData/'//model//'_internal_rst '//model//'_internal_rst '//trim(SFL) - - close (10, status ='keep') - call system('chmod 755 mkLDASsa.j') - stop - endif - endif - - if (root_proc) then - - ! read in ntiles - ! ---------------------------- - - open (10,file = trim(BCSDIR)//'/clsm/catchment.def', form = 'formatted', status ='old', action = 'read') - read (10,*) ntiles - close (10, status ='keep') - - endif - - call MPI_BCAST(NTILES , 1, MPI_INTEGER , 0,MPI_COMM_WORLD,mpierr) - - ! Regridding - inquire(file='InData/'//trim(MODEL)//'_internal_rst',exist=second_visit ) - - if(.not. second_visit) then - call regrid_hyd_vars (NTILES, trim(MODEL)) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - stop - endif - if (root_proc) then - call read_bcs_data (NTILES, SURFLAY, trim(MODEL),'OutData/clsm/','OutData/'//trim(MODEL)//'_internal_rst', __RC__) - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - if(index(MODEL,'catchcn') /=0) then - - call regrid_carbon_vars (NTILES, model) - - endif - - call MPI_FINALIZE(mpierr) - -contains - - ! ***************************************************************************** - - SUBROUTINE regrid_from_xgrid (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile) - - implicit none - - real, intent (in) :: SURFLAY - character(*), intent (in) :: BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, PFILE, rstfile - character(256) :: tile_coord, vname - character(300) :: rst_file - integer :: NTILES, nv, iv, i,j,k,n, nx, nz, ndims,dimSizes(3), NTILES_RST,nplus, STATUS,NCFID, req, filetype, OUTID - integer, allocatable :: LDAS2BCS (:), tile_id(:) - real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:), lon_rst(:), lat_rst(:) - logical :: fexist, bin_out = .false., lendian = .true. - real , allocatable, dimension (:) :: LATT, LONN, DAYX - real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable, dimension (:) :: low_ind, upp_ind, nt_local - integer, allocatable, dimension (:) :: Id_glb, id_loc - integer, allocatable, dimension (:,:) :: Id_glb_cn, id_loc_cn - integer, allocatable, dimension (:) :: ld_reorder, tid_offl - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum2 - integer :: AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR=0,AGCM_DATE - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl, fveg_tmp, ityp_tmp - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - type(Netcdf4_FileFormatter) :: ldFmt - type(FileMetadata) :: meta_data - character(256) :: Iam = "regrid_from_xgrid" - ! read NTILES from output BCs and tile_coord from GEOSldas/LDASsa input restarts - - open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') - read (10,*) ntiles - close (10, status = 'keep') - - ! Determine whether LDASsa or GEOSldas - if (trim(rstfile) == "NONE") then - if (trim(MODEL) == 'catch') then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.catch_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' - inquire(file = trim(rst_file), exist=fexist) - if (.not.fexist) then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/' & - //trim(ExpName)//'.ens'//ENS//'.catch_ldas_rst.'// & - YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z.bin' - lendian = .false. - endif - else !catchcn - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.'//trim(MODEL)//'_internal_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00' - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.ens'//ENS//'.'//trim(MODEL)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z' - lendian = .false. - endif - endif ! catch - else ! rstfile is provided - rst_file = rstfile - if (index(rst_file, "_ldas_rst") /=0) lendian = .false. - endif - - if (index(MODEL, 'catchcn') /=0) then - call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) - meta_data = ldFmt%read(__RC__) - call ldFmt%close(__RC__) - if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then - clm45 = .true. - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif - endif - - ! Open input tile_coord - tile_coord = trim(EXPDIR)//'rc_out/'//trim(expname)//'.ldas_tilecoord.bin' - inquire(file = trim(tile_coord), exist=fexist) - if ( .not. fexist ) then - print*, tile_coord // " file not exists" - stop " no tile_coord file" - endif - - if(lendian) then - open (10,file =trim(tile_coord),status='old',form='unformatted', action = 'read') - else - open (10,file =trim(tile_coord),status='old',form='unformatted', action = 'read', convert ='big_endian') - endif - - read (10) NTILES_RST - - if(root_proc) then - print *,'NTILES in BCs : ',NTILES - print *,'NTILES in restarts : ',NTILES_RST - endif - - ! Domain decomposition - ! -------------------- - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_rst)) - allocate (latc (1:ntiles_rst)) - allocate (tid_offl (ntiles_rst)) - - if (root_proc) then - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_rst)) - allocate (tile_id (1:ntiles_rst)) - allocate (LDAS2BCS (1:ntiles_rst)) - allocate (lon_rst (1:ntiles_rst)) - allocate (lat_rst (1:ntiles_rst)) - - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, xlon=long, xlat=latg); VERIFY_(i-ntiles) - - read (10) LDAS2BCS - read (10) tile_id - read (10) tile_id - read (10) lon_rst - read (10) lat_rst - - tile_id = LDAS2BCS - - do n = 1, NTILES_RST - ld_reorder (tile_id(n)) = n - tid_offl(n) = n - end do - do n = 1, NTILES_RST - lonc(n) = lon_rst(ld_reorder(n)) - latc(n) = lat_rst(ld_reorder(n)) - END DO - deallocate (lon_rst, lat_rst) - endif - - close (10, status = 'keep') - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) deallocate (long) - - call MPI_BCAST(lonc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_rst,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - ! id_glb for hydrologic variable - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - deallocate (id_loc) - - if(root_proc) then - - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - print*, "WARNING!!" - print*, trim(rst_file) // " does not exist .. !" - stop - endif - - ! =========================================================== - ! Map restart nearest restart to output grid (hydrologic var) - ! =========================================================== - - filetype = 0 - call MAPL_NCIOGetFileType(rst_file, filetype,__RC__) - if(filetype == 0) then - ! GEOSldas CATCH/CATCHCN or CATCHCN LDASsa - call put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_file) - else - call read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) - endif - - ! ==================== - ! READ AND PUT OUT BCS - ! ==================== - - do i = 1,10000 - ! just delaying few seconds to allow the system to copy the file - end do - - call read_bcs_data (NTILES, SURFLAY, trim(MODEL),'OutData/clsm/','OutData/'//trim(model)//'_internal_rst', __RC__) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - ! ============= - ! REGRID Carbon - ! ============= - - if (index(MODEL, 'catchcn') /=0) then - - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (ityp_offl (ntiles_rst,nveg)) - allocate (fveg_offl (ntiles_rst,nveg)) - allocate (id_loc_cn (nt_local (myid + 1),nveg)) - -! STATUS = NF90_OPEN ('OutData/catchcn_internal_rst',NF_WRITE,OUTID) ; VERIFY_(STATUS) - STATUS = NF_OPEN_PAR ('OutData/'//trim(model)//'_internal_rst',IOR(NF_WRITE,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - - allocate (ityp_tmp (ntiles_rst,nveg)) - allocate (fveg_tmp (ntiles_rst,nveg)) - allocate (DAYX (NTILES)) - - READ(YYYYMMDDHH(1:8),'(I8)') AGCM_DATE - AGCM_YY = AGCM_DATE / 10000 - AGCM_MM = (AGCM_DATE - AGCM_YY*10000) / 100 - AGCM_DD = (AGCM_DATE - AGCM_YY*10000 - AGCM_MM*100) - - call compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) - - STATUS = NF_OPEN (trim(rst_file),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,1/), (/ntiles_rst,4/),ityp_tmp) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/ntiles_rst,4/),fveg_tmp) - - do n = 1, NTILES_RST - ityp_offl (n,:) = ityp_tmp (ld_reorder(n),:) - fveg_offl (n,:) = fveg_tmp (ld_reorder(n),:) - - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) == 0)) then - if(ityp_offl(N,1) /= 0) then - ityp_offl(N,3) = ityp_offl(N,1) - else - ityp_offl(N,3) = ityp_offl(N,2) - endif - endif - - if((ityp_offl(N,1) == 0).and.(ityp_offl(N,2) /= 0)) ityp_offl(N,1) = ityp_offl(N,2) - if((ityp_offl(N,2) == 0).and.(ityp_offl(N,1) /= 0)) ityp_offl(N,2) = ityp_offl(N,1) - if((ityp_offl(N,3) == 0).and.(ityp_offl(N,4) /= 0)) ityp_offl(N,3) = ityp_offl(N,4) - if((ityp_offl(N,4) == 0).and.(ityp_offl(N,3) /= 0)) ityp_offl(N,4) = ityp_offl(N,3) - end do - deallocate (ityp_tmp, fveg_tmp) - endif - - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - call GetIds(lonc,latc,lonn,latt,id_loc_cn, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - - if(root_proc) allocate (id_glb_cn (ntiles,nveg)) - - allocate (id_loc (ntiles)) - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! call MPI_GATHERV( & - ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & - ! id_vec, nt_local,low_ind-1, MPI_real, & - ! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_loc(low_ind(i) : upp_ind(i)) = Id_loc_cn(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc_cn(:,nv),nt_local(i),MPI_INTEGER,0,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_loc(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb_cn (:,nv) = id_loc - - end do - - if(root_proc) then - - allocate (var_off_col (1: NTILES_RST, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_RST, 1 : nzone,1 : nveg, 1 : var_pft)) - allocate (var_dum2 (1:ntiles_rst)) - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_RST,1 /),VAR_DUM2) - do k = 1, NTILES_RST - var_off_col(k, nz,nv) = VAR_DUM2(ld_reorder(k)) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_RST,1 /),VAR_DUM2) - do k = 1, NTILES_RST - var_off_pft(K, nz,nv,iv) = VAR_DUM2(ld_reorder(k)) - end do - i = i + 1 - end do - end do - end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - print *, 'Writing regridded carbn' - call write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb_cn, & - DAYX, var_off_col,var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) - endif - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - STATUS = NF_CLOSE (OutID) - endif - - END SUBROUTINE regrid_from_xgrid - - ! ***************************************************************************** - - SUBROUTINE reorder_LDASsa_restarts (SURFLAY, BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile, rc) - - implicit none - - real, intent (in) :: SURFLAY - character(*), intent (in) :: BCSDIR, YYYYMMDDHH, EXPNAME, EXPDIR, MODEL, ENS, rstfile - integer, optional, intent(out) :: rc - character(256) :: tile_coord - character(300) :: rst_file, out_rst_file - type(Netcdf4_FileFormatter) :: InFmt,OutFmt, ldFmt - type(FileMetadata) :: meta_data - integer :: NTILES, i,j,k,n, ndims,dimSizes(3) - integer, allocatable :: LDAS2BCS (:), g2d(:), tile_id(:) - real, allocatable :: var1(:), var2(:),wesn1(:), htsn1(:) - integer :: dim1,dim2 - type(StringVariableMap), pointer :: variables - type(Variable), pointer :: var - type(StringVariableMapIterator) :: var_iter - type(StringVector), pointer :: var_dimensions - character(len=:), pointer :: vname,dname - logical :: fexist, bin_out = .false. - character(len=:), allocatable :: ftype - character*256 :: Iam = "reorder_LDASsa_restarts" - integer :: status - - if (trim(rstfile) == "NONE") then - ftype = '' - if(trim(MODEL) == 'catch') ftype='.bin' - rst_file = trim(EXPDIR)//'rs/ens'//ENS//'/Y'//YYYYMMDDHH(1:4)//'/M'//YYYYMMDDHH(5:6)//'/'//trim(ExpName)//& - '.ens'//ENS//'.'//trim(model)//'_ldas_rst.'//YYYYMMDDHH(1:8)//'_'//YYYYMMDDHH(9:10)//'00z'//trim(ftype) - else - rst_file = rstfile - endif - - inquire(file = trim(rst_file), exist=fexist) - if (.not. fexist) then - print*, "WARNING!!" - print*, rst_file // "does not exsit" - print*, "MAY USE ENS0000 only!!" - return - endif - - out_rst_file = trim(model)//ENS//'_internal_rst.'//YYYYMMDDHH(1:8) - - if (index(model,'catchcn') /=0) then - call ldFmt%open(trim(rst_file) , pFIO_READ,__RC__) - meta_data = ldFmt%read(__RC__) - call ldFmt%close(__RC__) - if(meta_data%get_dimension('unknown_dim3',rc=status) == 105) then - VAR_COL = VAR_COL_CLM45 - VAR_PFT = VAR_PFT_CLM45 - if ( .not. clm45) stop ' ERROR: Given clm45 restart, but the model is not clm45' - if (root_proc) print *, 'Processing CLM45 restarts : ', VAR_COL, VAR_PFT, clm45 - else - if (root_proc) print *, 'Processing CLM40 restarts : ', VAR_COL, VAR_PFT, clm45 - endif - endif - - open (10,file =trim(BCSDIR)//"clsm/catchment.def",status='old',form='formatted') - read (10,*) ntiles - close (10, status = 'keep') - - ! read NTILES from BCs and tile_coord from LDASsa experiment - - tile_coord = trim(EXPDIR)//'rc_out/'//trim(expname)//'.ldas_tilecoord.bin' - inquire(file = tile_coord, exist=fexist) - if (.not. fexist) then - print*, trim(tile_coord) // " file should be provided" - stop "no tile_coord file" - endif - - open (10,file =trim(tile_coord),status='old',form='unformatted',convert='big_endian') - read (10) i - if (i /= ntiles) then - print *,'NTILES BCs/LDASsa mismatch:', i,ntiles - stop - endif - - if(trim(MODEL) == 'catch') then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/Catch/catch_internal_rst' , pFIO_READ,__RC__) - end if - if(index(MODEL, 'catchcn') /=0) then - if (clm45) then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_clm45',PFIO_READ, __RC__) - else - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_dummy' , pFIO_READ, __RC__) - endif - end if - meta_data = InFmt%read(__RC__) - call inFmt%close(__RC__) - - call meta_data%modify_dimension('tile',ntiles,__RC__) - - call OutFmt%create(trim(out_rst_file),__RC__) - call OutFmt%write(meta_data, __RC__) - - - allocate (tile_id (1:ntiles)) - allocate (LDAS2BCS (1:ntiles)) - allocate (g2d (1:ntiles)) - - read (10) LDAS2BCS - close (10, status = 'keep') - - ! ========================== - ! READ/WRITE LDASsa RESTARTS - ! ========================== - - allocate(var1(ntiles)) - allocate(var2(ntiles)) - allocate(wesn1 (ntiles)) - allocate(htsn1 (ntiles)) - ! CH CM CQ FR WW - ! WW - var1 = 0.1 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'WW',var1 ,offset1=j) - end do - ! FR - var1 = 0.25 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'FR',var1 ,offset1=j) - end do - ! CH CM CQ - var1 = 0.001 - do j = 1,4 - call MAPL_VarWrite(OutFmt,'CH',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CM',var1 ,offset1=j) - call MAPL_VarWrite(OutFmt,'CQ',var1 ,offset1=j) - end do - - tile_id = LDAS2BCS - do n = 1, NTILES - G2D(tile_id(n)) = n - end do - - if(trim(MODEL) == 'catch') then - - open(10, file=trim(rst_file), form='unformatted', status='old', & - convert='big_endian', action='read') - - var1 = real(tile_id) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TILE_ID' ,var2) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=1) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=3) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=1) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=3) - call MAPL_VarWrite(OutFmt,'QC' ,var2, offset1=4) - - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'CAPAC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'CATDEF' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'RZEXC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6' ,var2) - read(10) var1 - var2 = var1 (tile_id) - - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - wesn1 = var2 - call MAPL_VarWrite(OutFmt,'WESNN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'WESNN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'WESNN3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - htsn1 = var2 - call MAPL_VarWrite(OutFmt,'HTSNNN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2' ,var2) - read(10) var1 - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3' ,var2) - call STIEGLITZSNOW_CALC_TPSNOW(NTILES, HTSN1(:), WESN1(:), var2, var1) - var2 = var2 + 273.16 - call MAPL_VarWrite(OutFmt,'TC' ,var2, offset1=4) - deallocate (var1, var2) - call OutFmt%close() - close(10) - - else ! CATCHCN - - call InFmt%open(trim(rst_file),pFIO_READ,__RC__) - meta_data = InFmt%read(__RC__) - - call MAPL_VarRead ( InFmt,'TILE_ID',var1, __RC__) - if(sum (nint(var1) - LDAS2BCS) /= 0) then - print *, 'Tile order mismatch ', sum(var1)/ntiles, sum(LDAS2BCS)/ntiles - stop - endif - - variables => meta_data%get_variables() - var_iter = variables%begin() - do while (var_iter /= variables%end()) - - vname => var_iter%key() - var => var_iter%value() - var_dimensions => var%get_dimensions() - - ndims = var_dimensions%size() - - if (ndims == 1) then - call MAPL_VarRead ( InFmt,vname,var1, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'SFMCM' ) var2 = 0. - if(trim(vname) == 'BFLOWM' ) var2 = 0. - if(trim(vname) == 'TOTWATM') var2 = 0. - if(trim(vname) == 'TAIRM' ) var2 = 0. - if(trim(vname) == 'TPM' ) var2 = 0. - if(trim(vname) == 'CNSUM' ) var2 = 0. - if(trim(vname) == 'SNDZM' ) var2 = 0. - if(trim(vname) == 'ASNOWM' ) var2 = 0. - if(trim(vname) == 'TSURF' ) var2 = 0. - - call MAPL_VarWrite(OutFmt,vname,var2) - - else if (ndims == 2) then - - dname => var%get_ith_dimension(2) - dim1=meta_data%get_dimension(dname) - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'TGWM' ) var2 = 0. - if(trim(vname) == 'RZMM' ) var2 = 0. - if(trim(vname) == 'WW' ) var2 = 0.1 - if(trim(vname) == 'FR' ) var2 = 0.25 - if(trim(vname) == 'CQ' ) var2 = 0.001 - if(trim(vname) == 'CN' ) var2 = 0.001 - if(trim(vname) == 'CM' ) var2 = 0.001 - if(trim(vname) == 'CH' ) var2 = 0.001 - call MAPL_VarWrite(OutFmt,vname,var2 ,offset1=j) - enddo - - else if (ndims == 3) then - - dname => var%get_ith_dimension(2) - dim1=meta_data%get_dimension(dname) - dname => var%get_ith_dimension(3) - dim2=meta_data%get_dimension(dname) - do i=1,dim2 - do j=1,dim1 - call MAPL_VarRead ( InFmt,vname,var1 ,offset1=j,offset2=i, __RC__) - var2 = var1 (tile_id) - do n = 1, NTILES - var2(n) = var1(g2d(n)) - end do - if(trim(vname) == 'PSNSUNM' ) var2 = 0. - if(trim(vname) == 'PSNSHAM' ) var2 = 0. - call MAPL_VarWrite(OutFmt,vname,var2 ,offset1=j,offset2=i) - enddo - enddo - - end if - call var_iter%next() - enddo - - call InFmt%close() - call OutFmt%close() - deallocate (var1, var2, tile_id) - endif - - call read_bcs_data (ntiles, SURFLAY, trim(MODEL), trim(BCSDIR)//'/clsm/',trim(out_rst_file), __RC__) - - if(bin_out) then - call InFmt%open(trim(out_rst_file),pFIO_READ,__RC__) - open(unit=30, file=trim(out_rst_file)//'.bin', form='unformatted') - call write_bin (30, InFmt, NTILES) - close(30) - call InFmt%close() - endif - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - - END SUBROUTINE reorder_LDASsa_restarts - - ! ***************************************************************************** - - SUBROUTINE regrid_hyd_vars (NTILES, model) - - implicit none - integer, intent (in) :: NTILES - character(*), intent (in) :: model - - ! =============================================================================================== - - integer, allocatable, dimension(:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: ld_reorder, tid_offl - real , allocatable, dimension(:) :: tmp_var - integer :: n,i,nplus, STATUS,NCFID, req - integer :: local_id, ntiles_smap - real , allocatable, dimension (:) :: LATT, LONN - real , pointer , dimension (:) :: long, latg, lonc, latc - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - - logical :: all_found - character(256) :: Iam="regrid_hyd_vars" - - if(index(MODEL, 'catchcn') /=0) ntiles_smap = ntiles_cn - if(trim(MODEL) == 'catch' ) ntiles_smap = ntiles_cat - - allocate (tid_offl (ntiles_smap)) - allocate (tmp_var (ntiles_smap)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1))) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (lonc (1:ntiles_smap)) - allocate (latc (1:ntiles_smap)) - - if (root_proc) then - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (ld_reorder(ntiles_smap)) - - call ReadTileFile_RealLatLon ('InData/OutTileFile', i, xlon=long, xlat=latg); VERIFY_(i-ntiles) - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - if(index(MODEL,'catchcn') /=0) then - call ReadTileFile_RealLatLon(trim(InCNTilFile ),i,xlon=lonc,xlat=latc) - VERIFY_(i-ntiles_smap) - endif - if(trim(MODEL) == 'catch' ) then - call ReadTileFile_RealLatLon(trim(InCatTilFile),i,xlon=lonc,xlat=latc) - VERIFY_(i-ntiles_smap) - endif - if(index(MODEL,'catchcn') /=0) then - STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - if(trim(MODEL) == 'catch' ) then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_SMAP/),tmp_var) - STATUS = NF_CLOSE (NCFID) - - do n = 1, ntiles_smap - ld_reorder ( NINT(tmp_var(n))) = n - tid_offl(n) = n - end do - - deallocate (tmp_var) - - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) -! -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_smap,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(tid_offl,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl) - - ! Loop through NTILES (# of tiles in output array) find the nearest neighbor from Qing. - - if(root_proc) allocate (id_glb (ntiles)) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) -! call MPI_GATHERV( & -! id_loc, nt_local(myid+1) , MPI_real, & -! id_glb, nt_local,low_ind-1, MPI_real, & -! 0, MPI_COMM_WORLD, mpierr ) - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_glb(low_ind(i) : upp_ind(i)) = Id_loc(:) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc,nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_glb(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if (root_proc) call put_land_vars (NTILES, ntiles_smap, id_glb, ld_reorder, model) - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_hyd_vars - - - ! ***************************************************************************** - - SUBROUTINE read_bcs_data (ntiles, SURFLAY,MODEL, DataDir, InRestart, rc) - - ! This subroutine : - ! 1) reads BCs from BCSDIR and hydrological varables from InRestart. - ! InRestart is a catchcn_internal_rst nc4 file. - ! - ! 2) writes out BCs and hydrological variables in catchcn_internal_rst (1:72). - ! output catchcn_internal_rst is nc4. - - implicit none - real, intent (in) :: SURFLAY - integer, intent (in) :: ntiles - character(*), intent (in) :: MODEL, DataDir, InRestart - integer, optional, intent(out) :: rc - real, allocatable :: CLMC_pf1(:), CLMC_pf2(:), CLMC_sf1(:), CLMC_sf2(:) - real, allocatable :: CLMC_pt1(:), CLMC_pt2(:), CLMC_st1(:), CLMC_st2(:) - real, allocatable :: CLMC45_pf1(:), CLMC45_pf2(:), CLMC45_sf1(:), CLMC45_sf2(:) - real, allocatable :: CLMC45_pt1(:), CLMC45_pt2(:), CLMC45_st1(:), CLMC45_st2(:) - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), DP2BR(:), CanopH(:) - real, allocatable :: NDEP(:), BVISDR(:), BVISDF(:), BNIRDR(:), BNIRDF(:) - real, allocatable :: T2(:), var1(:), hdm(:), fc(:), gdp(:), peatf(:), RITY(:) - integer, allocatable :: ity(:), abm (:) - integer :: NCFID, STATUS - integer :: idum, i,j,n, ib, nv - real :: rdum, zdep1, zdep2, zdep3, zmet, term1, term2, bare,fvg(4) - logical :: NEWLAND, isCatchCN - logical :: file_exists - type(NetCDF4_Fileformatter) :: CatchFmt,CatchCNFmt - character*256 :: Iam = "read_bcs_data" - - allocate ( BF1(ntiles), BF2 (ntiles), BF3(ntiles) ) - allocate (VGWMAX(ntiles), CDCR1(ntiles), CDCR2(ntiles) ) - allocate ( PSIS(ntiles), BEE(ntiles), POROS(ntiles) ) - allocate ( WPWET(ntiles), COND(ntiles), GNU(ntiles) ) - allocate ( ARS1(ntiles), ARS2(ntiles), ARS3(ntiles) ) - allocate ( ARA1(ntiles), ARA2(ntiles), ARA3(ntiles) ) - allocate ( ARA4(ntiles), ARW1(ntiles), ARW2(ntiles) ) - allocate ( ARW3(ntiles), ARW4(ntiles), TSA1(ntiles) ) - allocate ( TSA2(ntiles), TSB1(ntiles), TSB2(ntiles) ) - allocate ( ATAU2(ntiles), BTAU2(ntiles), DP2BR(ntiles) ) - allocate (BVISDR(ntiles), BVISDF(ntiles), BNIRDR(ntiles) ) - allocate (BNIRDF(ntiles), T2(ntiles), NDEP(ntiles) ) - allocate ( ity(ntiles), CanopH(ntiles) ) - allocate (CLMC_pf1(ntiles), CLMC_pf2(ntiles), CLMC_sf1(ntiles)) - allocate (CLMC_sf2(ntiles), CLMC_pt1(ntiles), CLMC_pt2(ntiles)) - allocate (CLMC45_pf1(ntiles), CLMC45_pf2(ntiles), CLMC45_sf1(ntiles)) - allocate (CLMC45_sf2(ntiles), CLMC45_pt1(ntiles), CLMC45_pt2(ntiles)) - allocate (CLMC_st1(ntiles), CLMC_st2(ntiles)) - allocate (CLMC45_st1(ntiles), CLMC45_st2(ntiles)) - allocate (hdm(ntiles), fc(ntiles), gdp(ntiles)) - allocate (peatf(ntiles), abm(ntiles), var1(ntiles), RITY(ntiles)) - - inquire(file = trim(DataDir)//'/catchcn_params.nc4', exist=file_exists) - inquire(file = trim(DataDir)//"CLM_veg_typs_fracs" ,exist=NewLand ) - - isCatchCN = (index(model,'catchcn') /=0) - - if(file_exists) then - - print *,'FILE FORMAT FOR LAND BCS IS NC4' - call CatchFmt%Open(trim(DataDir)//'/catch_params.nc4', pFIO_READ, __RC__) - call MAPL_VarRead ( CatchFmt ,'OLD_ITY', RITY, __RC__) - ITY = NINT (RITY) - call MAPL_VarRead ( CatchFmt ,'ARA1', ARA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA2', ARA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA3', ARA3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARA4', ARA4, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS1', ARS1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS2', ARS2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARS3', ARS3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW1', ARW1, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW2', ARW2, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW3', ARW3, __RC__) - call MAPL_VarRead ( CatchFmt ,'ARW4', ARW4, __RC__) - - if( SURFLAY.eq.20.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU2', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU2', BTAU2, __RC__) - endif - - if( SURFLAY.eq.50.0 ) then - call MAPL_VarRead ( CatchFmt ,'ATAU5', ATAU2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BTAU5', BTAU2, __RC__) - endif - - call MAPL_VarRead ( CatchFmt ,'PSIS', PSIS, __RC__) - call MAPL_VarRead ( CatchFmt ,'BEE', BEE, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF1', BF1, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF2', BF2, __RC__) - call MAPL_VarRead ( CatchFmt ,'BF3', BF3, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA1', TSA1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSA2', TSA2, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB1', TSB1, __RC__) - call MAPL_VarRead ( CatchFmt ,'TSB2', TSB2, __RC__) - call MAPL_VarRead ( CatchFmt ,'COND', COND, __RC__) - call MAPL_VarRead ( CatchFmt ,'GNU', GNU, __RC__) - call MAPL_VarRead ( CatchFmt ,'WPWET', WPWET, __RC__) - call MAPL_VarRead ( CatchFmt ,'DP2BR', DP2BR, __RC__) - call MAPL_VarRead ( CatchFmt ,'POROS', POROS, __RC__) - call CatchFmt%close() - if(isCatchCN) then - call CatchCNFmt%Open(trim(DataDir)//'/catchcn_params.nc4', pFIO_READ, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNF', BNIRDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBNR', BNIRDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVF', BVISDF, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'BGALBVR', BVISDR, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'NDEP', NDEP, __RC__) - call MAPL_VarRead ( CatchCNFmt ,'T2_M', T2, __RC__) - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt1,offset1=1, __RC__) ! 30 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_pt2,offset1=2, __RC__) ! 31 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st1,offset1=3, __RC__) ! 32 - call MAPL_VarRead(CatchCNFmt,'ITY',CLMC_st2,offset1=4, __RC__) ! 33 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf1,offset1=1, __RC__) ! 34 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_pf2,offset1=2, __RC__) ! 35 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf1,offset1=3, __RC__) ! 36 - call MAPL_VarRead(CatchCNFmt,'FVG',CLMC_sf2,offset1=4, __RC__) ! 37 - call CatchCNFmt%close() - if(clm45) then - open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') - do n=1,ntiles - read (30, *) i, j, abm(n), peatf(n), & - gdp(n), hdm(n), fc(n) - end do - CLOSE (30, STATUS = 'KEEP') - endif - endif - - - else - open(unit=21, file=trim(DataDir)//'mosaic_veg_typs_fracs',form='formatted') - open(unit=22, file=trim(DataDir)//'bf.dat' ,form='formatted') - open(unit=23, file=trim(DataDir)//'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(DataDir)//'ar.new' ,form='formatted') - open(unit=25, file=trim(DataDir)//'ts.dat' ,form='formatted') - open(unit=26, file=trim(DataDir)//'tau_param.dat' ,form='formatted') - - if(NewLand .and. isCatchCN) then - open(unit=27, file=trim(DataDir)//'CLM_veg_typs_fracs' ,form='formatted') - open(unit=28, file=trim(DataDir)//'CLM_NDep_SoilAlb_T2m' ,form='formatted') - if(clm45) then - open(unit=29, file=trim(DataDir)//'CLM4.5_veg_typs_fracs',form='formatted') - open(unit=30, file=trim(DataDir)//'CLM4.5_abm_peatf_gdp_hdm_fc' ,form='formatted') - endif - endif - - do n=1,ntiles - var1 (n) = real (n) - ! W.J notes: CanopH is not used. If CLM_veg_typs_fracs exists, the read some dummy ???? Ask Sarith - if (NewLand) then - read(21,*) I, j, ITY(N),idum, rdum, rdum, CanopH(N) - else - read(21,*) I, j, ITY(N),idum, rdum, rdum - endif - - read (22, *) i,j, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) i,j, idum, idum, BEE(n), PSIS(n),& - POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) i,j, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) i,j, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - if( SURFLAY.eq.20.0 ) read (26, *) i,j, ATAU2(n), BTAU2(n), rdum, rdum ! for old soil params - if( SURFLAY.eq.50.0 ) read (26, *) i,j, rdum , rdum, ATAU2(n), BTAU2(n) ! for new soil params - - if (NewLand .and. isCatchCN) then - read (27, *) i,j, CLMC_pt1(n), CLMC_pt2(n), CLMC_st1(n), CLMC_st2(n), & - CLMC_pf1(n), CLMC_pf2(n), CLMC_sf1(n), CLMC_sf2(n) - - read (28, *) NDEP(n), BVISDR(n), BVISDF(n), BNIRDR(n), BNIRDF(n), T2(n) ! MERRA-2 Annual Mean Temp is default. - if(clm45) then - read (29, *) i,j, CLMC45_pt1(n), CLMC45_pt2(n), CLMC45_st1(n), CLMC45_st2(n), & - CLMC45_pf1(n), CLMC45_pf2(n), CLMC45_sf1(n), CLMC45_sf2(n) - - read (30, *) i, j, abm(n), peatf(n), & - gdp(n), hdm(n), fc(n) - endif - endif - end do - - CLOSE (21, STATUS = 'KEEP') - CLOSE (22, STATUS = 'KEEP') - CLOSE (23, STATUS = 'KEEP') - CLOSE (24, STATUS = 'KEEP') - CLOSE (25, STATUS = 'KEEP') - CLOSE (26, STATUS = 'KEEP') - - if(NewLand .and. isCatchCN) then - CLOSE (27, STATUS = 'KEEP') - CLOSE (28, STATUS = 'KEEP') - if(clm45) then - CLOSE (29, STATUS = 'KEEP') - CLOSE (30, STATUS = 'KEEP') - endif - endif - endif - - - do n=1,ntiles - var1 (n) = real (n) - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - - if( isCatchCN) then - - BVISDR(n) = amax1(1.e-6, BVISDR(n)) - BVISDF(n) = amax1(1.e-6, BVISDF(n)) - BNIRDR(n) = amax1(1.e-6, BNIRDR(n)) - BNIRDF(n) = amax1(1.e-6, BNIRDF(n)) - - ! convert % to fractions - - CLMC_pf1(n) = CLMC_pf1(n) / 100. - CLMC_pf2(n) = CLMC_pf2(n) / 100. - CLMC_sf1(n) = CLMC_sf1(n) / 100. - CLMC_sf2(n) = CLMC_sf2(n) / 100. - - fvg(1) = CLMC_pf1(n) - fvg(2) = CLMC_pf2(n) - fvg(3) = CLMC_sf1(n) - fvg(4) = CLMC_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC_pf1(n) = fvg(1) - CLMC_pf2(n) = fvg(2) - CLMC_sf1(n) = fvg(3) - CLMC_sf2(n) = fvg(4) - - if(CLM45) then - ! CLM 45 - - CLMC45_pf1(n) = CLMC45_pf1(n) / 100. - CLMC45_pf2(n) = CLMC45_pf2(n) / 100. - CLMC45_sf1(n) = CLMC45_sf1(n) / 100. - CLMC45_sf2(n) = CLMC45_sf2(n) / 100. - - fvg(1) = CLMC45_pf1(n) - fvg(2) = CLMC45_pf2(n) - fvg(3) = CLMC45_sf1(n) - fvg(4) = CLMC45_sf2(n) - - BARE = 1. - - DO NV = 1, NVEG - BARE = BARE - FVG(NV)! subtract vegetated fractions - END DO - - if (BARE /= 0.) THEN - IB = MAXLOC(FVG(:),1) - FVG (IB) = FVG(IB) + BARE ! This also corrects all cases sum ne 0. - ENDIF - - CLMC45_pf1(n) = fvg(1) - CLMC45_pf2(n) = fvg(2) - CLMC45_sf1(n) = fvg(3) - CLMC45_sf2(n) = fvg(4) - endif - endif - enddo - - if( isCatchCN) then - - NDEP = NDEP * 1.e-9 - - ! prevent trivial fractions - ! ------------------------- - do n = 1,ntiles - if(CLMC_pf1(n) <= 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_pf1(n) - CLMC_pf1(n) = 0. - endif - - if(CLMC_pf2(n) <= 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_pf2(n) - CLMC_pf2(n) = 0. - endif - - if(CLMC_sf1(n) <= 1.e-4) then - if(CLMC_sf2(n) > 1.e-4) then - CLMC_sf2(n) = CLMC_sf2(n) + CLMC_sf1(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf1(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf1(n) - else - stop 'fveg3' - endif - CLMC_sf1(n) = 0. - endif - - if(CLMC_sf2(n) <= 1.e-4) then - if(CLMC_sf1(n) > 1.e-4) then - CLMC_sf1(n) = CLMC_sf1(n) + CLMC_sf2(n) - else if(CLMC_pf2(n) > 1.e-4) then - CLMC_pf2(n) = CLMC_pf2(n) + CLMC_sf2(n) - else if(CLMC_pf1(n) > 1.e-4) then - CLMC_pf1(n) = CLMC_pf1(n) + CLMC_sf2(n) - else - stop 'fveg4' - endif - CLMC_sf2(n) = 0. - endif - - if (clm45) then - ! CLM45 - if(CLMC45_pf1(n) <= 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_pf1(n) - CLMC45_pf1(n) = 0. - endif - - if(CLMC45_pf2(n) <= 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_pf2(n) - CLMC45_pf2(n) = 0. - endif - - if(CLMC45_sf1(n) <= 1.e-4) then - if(CLMC45_sf2(n) > 1.e-4) then - CLMC45_sf2(n) = CLMC45_sf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf1(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf1(n) - else - stop 'fveg3' - endif - CLMC45_sf1(n) = 0. - endif - - if(CLMC45_sf2(n) <= 1.e-4) then - if(CLMC45_sf1(n) > 1.e-4) then - CLMC45_sf1(n) = CLMC45_sf1(n) + CLMC45_sf2(n) - else if(CLMC45_pf2(n) > 1.e-4) then - CLMC45_pf2(n) = CLMC45_pf2(n) + CLMC45_sf2(n) - else if(CLMC45_pf1(n) > 1.e-4) then - CLMC45_pf1(n) = CLMC45_pf1(n) + CLMC45_sf2(n) - else - stop 'fveg4' - endif - CLMC45_sf2(n) = 0. - endif - endif - end do - endif - - - ! Vegdyn Boundary Condition - ! ------------------------- - - ! open(20,file=trim("vegdyn_internal_rst"), & - ! status="unknown", & - ! form="unformatted",convert="little_endian") - ! write(20) real(ity) - ! if(NewLand) write(20) CanopH - ! close(20) - ! print *, "Wrote vegdyn_internal_restart" - - ! Now writing BCs (from BCSDIR) and regridded hydrological variables 1-72 - ! ----------------------------------------------------------------------- - - STATUS = NF_OPEN (trim(InRestart),NF_WRITE,NCFID) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF1'), (/1/), (/NTILES/),BF1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF2'), (/1/), (/NTILES/),BF2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BF3'), (/1/), (/NTILES/),BF3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX'), (/1/), (/NTILES/),VGWMAX) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CDCR1'), (/1/), (/NTILES/),CDCR1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CDCR2'), (/1/), (/NTILES/),CDCR2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PSIS'), (/1/), (/NTILES/),PSIS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BEE'), (/1/), (/NTILES/),BEE) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'POROS'), (/1/), (/NTILES/),POROS) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'WPWET'), (/1/), (/NTILES/),WPWET) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'COND'), (/1/), (/NTILES/),COND) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GNU'), (/1/), (/NTILES/),GNU) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS1'), (/1/), (/NTILES/),ARS1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS2'), (/1/), (/NTILES/),ARS2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARS3'), (/1/), (/NTILES/),ARS3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA1'), (/1/), (/NTILES/),ARA1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA2'), (/1/), (/NTILES/),ARA2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA3'), (/1/), (/NTILES/),ARA3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARA4'), (/1/), (/NTILES/),ARA4) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW1'), (/1/), (/NTILES/),ARW1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW2'), (/1/), (/NTILES/),ARW2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW3'), (/1/), (/NTILES/),ARW3) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ARW4'), (/1/), (/NTILES/),ARW4) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSA1'), (/1/), (/NTILES/),TSA1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSA2'), (/1/), (/NTILES/),TSA2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSB1'), (/1/), (/NTILES/),TSB1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TSB2'), (/1/), (/NTILES/),TSB2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ATAU'), (/1/), (/NTILES/),ATAU2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BTAU'), (/1/), (/NTILES/),BTAU2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID'), (/1/), (/NTILES/),VAR1) - - if( isCatchCN ) then - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) - - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'NDEP' ), (/1/), (/NTILES/),NDEP) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'CLI_T2M'), (/1/), (/NTILES/),T2) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBVR'), (/1/), (/NTILES/),BVISDR) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBVF'), (/1/), (/NTILES/),BVISDF) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNR'), (/1/), (/NTILES/),BNIRDR) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'BGALBNF'), (/1/), (/NTILES/),BNIRDF) - - if(CLM45) then - - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'ABM' ), (/1/), (/NTILES/),real(ABM)) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'FIELDCAP'), (/1/), (/NTILES/),FC) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'HDM' ), (/1/), (/NTILES/),HDM) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'GDP' ), (/1/), (/NTILES/),GDP) - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'PEATF' ), (/1/), (/NTILES/),PEATF) - endif - - else - STATUS = NF_PUT_VARA_REAL(NCFID,VarID(NCFID,'OLD_ITY'), (/1/), (/NTILES/),real(ITY)) - endif - - STATUS = NF_CLOSE ( NCFID) - - deallocate ( BF1, BF2, BF3 ) - deallocate (VGWMAX, CDCR1, CDCR2 ) - deallocate ( PSIS, BEE, POROS ) - deallocate ( WPWET, COND, GNU ) - deallocate ( ARS1, ARS2, ARS3 ) - deallocate ( ARA1, ARA2, ARA3 ) - deallocate ( ARA4, ARW1, ARW2 ) - deallocate ( ARW3, ARW4, TSA1 ) - deallocate ( TSA2, TSB1, TSB2 ) - deallocate ( ATAU2, BTAU2, DP2BR ) - deallocate (BVISDR, BVISDF, BNIRDR ) - deallocate (BNIRDF, T2, NDEP ) - deallocate ( ity, CanopH) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1) - deallocate (CLMC_sf2, CLMC_pt1, CLMC_pt2) - deallocate (CLMC_st1,CLMC_st2) - if (present(rc)) rc =0 - !_RETURN(_SUCCESS) - END SUBROUTINE read_bcs_data - - ! ***************************************************************************** - - SUBROUTINE regrid_carbon_vars (NTILES, model) - - implicit none - - integer, intent (in) :: NTILES - character(*), intent (in) :: model - character*300 :: OutTileFile = 'InData/OutTileFile' - character*300 :: OutFileName - integer :: AGCM_YY=2015,AGCM_MM=1,AGCM_DD=1,AGCM_HR=0 - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2 - - ! =============================================================================================== - - integer, allocatable, dimension(:,:) :: Id_glb, Id_loc - integer, allocatable, dimension(:) :: tid_offl, id_vec - real, allocatable, dimension(:,:) :: fveg_offl, ityp_offl - integer :: n,i,j, k, offl_cell, STATUS,NCFID, req - integer :: outid, local_id, nv, nz, iv - real , allocatable, dimension (:) :: LATT, LONN, DAYX, TILE_ID, var_dum2 - real, allocatable :: var_off_col (:,:,:), var_off_pft (:,:,:,:) - integer, allocatable :: low_ind(:), upp_ind(:), nt_local (:) - real , pointer , dimension (:) :: long, latg, lonc, latc - character*256 :: Iam = "regrid_carbon_vars" - - OutFileName='OutData/'//trim(model)//'_internal_rst' - - allocate (tid_offl (ntiles_cn)) - allocate (ityp_offl (ntiles_cn,nveg)) - allocate (fveg_offl (ntiles_cn,nveg)) - - allocate(low_ind ( numprocs)) - allocate(upp_ind ( numprocs)) - allocate(nt_local( numprocs)) - - low_ind (:) = 1 - upp_ind (:) = NTILES - nt_local(:) = NTILES - - ! Domain decomposition - ! -------------------- - - if (numprocs > 1) then - do i = 1, numprocs - 1 - upp_ind(i) = low_ind(i) + (ntiles/numprocs) - 1 - low_ind(i+1) = upp_ind(i) + 1 - nt_local(i) = upp_ind(i) - low_ind(i) + 1 - end do - nt_local(numprocs) = upp_ind(numprocs) - low_ind(numprocs) + 1 - endif - - allocate (id_loc (nt_local (myid + 1),4)) - allocate (lonn (nt_local (myid + 1))) - allocate (latt (nt_local (myid + 1))) - allocate (CLMC_pf1(nt_local (myid + 1))) - allocate (CLMC_pf2(nt_local (myid + 1))) - allocate (CLMC_sf1(nt_local (myid + 1))) - allocate (CLMC_sf2(nt_local (myid + 1))) - allocate (CLMC_pt1(nt_local (myid + 1))) - allocate (CLMC_pt2(nt_local (myid + 1))) - allocate (CLMC_st1(nt_local (myid + 1))) - allocate (CLMC_st2(nt_local (myid + 1))) - allocate (lonc (1:ntiles_cn)) - allocate (latc (1:ntiles_cn)) - - if (root_proc) then - - ! -------------------------------------------- - ! Read exact lonn, latt from output .til file - ! -------------------------------------------- - - allocate (long (ntiles)) - allocate (latg (ntiles)) - allocate (DAYX (NTILES)) - - call ReadTileFile_RealLatLon (OutTileFile, i, xlon=long, xlat=latg); VERIFY_(i-ntiles) - - ! Compute DAYX - ! ------------ - - call compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATG, DAYX) - - ! --------------------------------------------- - ! Read exact lonc, latc from offline .til File - ! --------------------------------------------- - - call ReadTileFile_RealLatLon(trim(InCNTilFile),i,xlon=lonc,xlat=latc); VERIFY_(i-ntiles_cn) - - endif - -! call MPI_SCATTERV ( & -! long,nt_local,low_ind-1,MPI_real, & -! lonn,size(lonn),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - -! call MPI_SCATTERV ( & -! latg,nt_local,low_ind-1,MPI_real, & -! latt,nt_local(myid+1),MPI_real , & -! 0,MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - lonn(:) = long(low_ind(i) : upp_ind(i)) - latt(:) = latg(low_ind(i) : upp_ind(i)) - else if (I > 1) then - if(I-1 == myid) then - ! receiving from root - call MPI_RECV(lonn,nt_local(i) , MPI_REAL, 0,995,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - call MPI_RECV(latt,nt_local(i) , MPI_REAL, 0,994,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root sends - call MPI_ISend(long(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,995,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - call MPI_ISend(latg(low_ind(i) : upp_ind(i)),nt_local(i),MPI_REAL,i-1,994,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - - if(root_proc) deallocate (long, latg) - - call MPI_BCAST(lonc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(latc,ntiles_cn,MPI_REAL,0,MPI_COMM_WORLD,mpierr) - - ! Open GKW/Fzeng SMAP M09 catchcn_internal_rst and output catchcn_internal_rst - ! ---------------------------------------------------------------------------- - - STATUS = NF_OPEN_PAR (trim(OutFileName),IOR(NF_WRITE ,NF_MPIIO),MPI_COMM_WORLD, infos,OUTID) - IF (STATUS .NE. NF_NOERR) CALL HANDLE_ERR(STATUS, 'OUTPUT RESTART FAILED') - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pt1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pt2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_st1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_st2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),1/), (/nt_local(myid+1),1/),CLMC_pf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),2/), (/nt_local(myid+1),1/),CLMC_pf2) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),3/), (/nt_local(myid+1),1/),CLMC_sf1) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/low_ind(myid+1),4/), (/nt_local(myid+1),1/),CLMC_sf2) - - if (root_proc) then - STATUS = NF_OPEN (trim(InCNRestart),NF_NOWRITE,NCFID) - allocate (TILE_ID (1:ntiles_cn)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TILE_ID' ), (/1/), (/NTILES_CN/),TILE_ID) - - do n = 1,ntiles_cn - - K = NINT (TILE_ID (n)) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY'), (/n,1/), (/1,4/),ityp_offl(K,:)) - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG'), (/n,1/), (/1,4/),fveg_offl(K,:)) - - tid_offl (n) = n - - do nv = 1,nveg - if(ityp_offl(K,nv)<0 .or. ityp_offl(K,nv)>npft) stop 'ityp' - if(fveg_offl(K,nv)<0..or. fveg_offl(K,nv)>1.00001) stop 'fveg' - end do - - if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) == 0)) then - if(ityp_offl(K,1) /= 0) then - ityp_offl(K,3) = ityp_offl(K,1) - else - ityp_offl(K,3) = ityp_offl(K,2) - endif - endif - - if((ityp_offl(K,1) == 0).and.(ityp_offl(K,2) /= 0)) ityp_offl(K,1) = ityp_offl(K,2) - if((ityp_offl(K,2) == 0).and.(ityp_offl(K,1) /= 0)) ityp_offl(K,2) = ityp_offl(K,1) - if((ityp_offl(K,3) == 0).and.(ityp_offl(K,4) /= 0)) ityp_offl(K,3) = ityp_offl(K,4) - if((ityp_offl(K,4) == 0).and.(ityp_offl(K,3) /= 0)) ityp_offl(K,4) = ityp_offl(K,3) - - end do - - endif - - call MPI_BCAST(tid_offl ,size(tid_offl ),MPI_INTEGER,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(ityp_offl,size(ityp_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - call MPI_BCAST(fveg_offl,size(fveg_offl),MPI_REAL ,0,MPI_COMM_WORLD,mpierr) - - ! -------------------------------------------------------------------------------- - ! Here we create transfer index array to map offline restarts to output tile space - ! -------------------------------------------------------------------------------- - - call GetIds(lonc,latc,lonn,latt,id_loc, tid_offl, & - CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, & - fveg_offl, ityp_offl) - - ! update id_glb in root - - if(root_proc) then - allocate (id_glb (ntiles, nveg)) - allocate (id_vec (ntiles)) - endif - - do nv = 1, nveg - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - ! call MPI_GATHERV( & - ! id_loc (:,nv), nt_local(myid+1) , MPI_real, & - ! id_vec, nt_local,low_ind-1, MPI_real, & - ! 0, MPI_COMM_WORLD, mpierr ) - - do i = 1, numprocs - if((I == 1).and.(myid == 0)) then - id_vec(low_ind(i) : upp_ind(i)) = Id_loc(:,nv) - else if (I > 1) then - if(I-1 == myid) then - ! send to root - call MPI_ISend(id_loc(:,nv),nt_local(i),MPI_INTEGER,0,993,MPI_COMM_WORLD,req,mpierr) - call MPI_WAIT (req,MPI_STATUS_IGNORE,mpierr) - else if (myid == 0) then - ! root receives - call MPI_RECV(id_vec(low_ind(i) : upp_ind(i)),nt_local(i) , MPI_INTEGER, i-1,993,MPI_COMM_WORLD,MPI_STATUS_IGNORE,mpierr) - endif - endif - end do - - if(root_proc) id_glb (:,nv) = id_vec - - end do - - if(root_proc) then - - allocate (var_off_col (1: NTILES_CN, 1 : nzone,1 : var_col)) - allocate (var_off_pft (1: NTILES_CN, 1 : nzone,1 : nveg, 1 : var_pft)) - allocate (var_dum2 (1:ntiles_cn)) - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNCOL'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_col(TILE_ID(K), nz,nv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - - i = 1 - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CNPFT'), (/1,i/), (/NTILES_CN,1 /),VAR_DUM2) - do k = 1, NTILES_CN - var_off_pft(TILE_ID(K), nz,nv,iv) = VAR_DUM2(K) - end do - i = i + 1 - end do - end do - end do - - where(isnan(var_off_pft)) var_off_pft = 0. - where(var_off_pft /= var_off_pft) var_off_pft = 0. - - call write_regridded_carbon (NTILES, ntiles_cn, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) - deallocate (var_off_col,var_off_pft) - endif - - call MPI_Barrier(MPI_COMM_WORLD, STATUS) - - END SUBROUTINE regrid_carbon_vars - -! --------------------------------------------------------------------------------------------------------- - - SUBROUTINE write_regridded_carbon (NTILES, ntiles_rst, NCFID, OUTID, id_glb, & - DAYX, var_off_col, var_off_pft, ityp_offl, fveg_offl) - - ! write out regridded carbon variables - implicit none - integer, intent (in) :: NTILES, ntiles_rst,NCFID, OUTID, id_glb (ntiles,nveg) - real, intent (in) :: DAYX (NTILES), var_off_col(NTILES_RST,NZONE,var_col), var_off_pft(NTILES_RST,NZONE, NVEG, var_pft) - real, intent (in), dimension(ntiles_rst,nveg) :: fveg_offl, ityp_offl - real, allocatable, dimension (:) :: CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2, & - CLMC_pt1, CLMC_pt2,CLMC_st1,CLMC_st2, var_dum - real, allocatable :: var_col_out (:,:,:), var_pft_out (:,:,:,:) - integer :: N, STATUS, nv, nx, offl_cell, ityp_new, i, j, nz, iv - real :: fveg_new - character(256) :: Iam = "write_regridded_carbon" - - - allocate (CLMC_pf1(NTILES)) - allocate (CLMC_pf2(NTILES)) - allocate (CLMC_sf1(NTILES)) - allocate (CLMC_sf2(NTILES)) - allocate (CLMC_pt1(NTILES)) - allocate (CLMC_pt2(NTILES)) - allocate (CLMC_st1(NTILES)) - allocate (CLMC_st2(NTILES)) - allocate (VAR_DUM (NTILES)) - - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,1/), (/NTILES,1/),CLMC_pt1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,2/), (/NTILES,1/),CLMC_pt2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,3/), (/NTILES,1/),CLMC_st1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'ITY'), (/1,4/), (/NTILES,1/),CLMC_st2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,1/), (/NTILES,1/),CLMC_pf1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,2/), (/NTILES,1/),CLMC_pf2) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,3/), (/NTILES,1/),CLMC_sf1) ; VERIFY_(STATUS) - STATUS = NF_GET_VARA_REAL(OUTID,VarID(OUTID,'FVG'), (/1,4/), (/NTILES,1/),CLMC_sf2) ; VERIFY_(STATUS) - - allocate (var_col_out (1: NTILES, 1 : nzone,1 : var_col)) - allocate (var_pft_out (1: NTILES, 1 : nzone,1 : nveg, 1 : var_pft)) - - var_col_out = 0. - var_pft_out = NaN - - OUT_TILE : DO N = 1, NTILES - - ! if(mod (n,1000) == 0) print *, myid +1, n, Id_glb(n,:) - - NVLOOP2 : do nv = 1, nveg - - if(nv <= 2) then ! index for secondary PFT index if primary or primary if secondary - nx = nv + 2 - else - nx = nv - 2 - endif - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if (fveg_new > fmin) then - - offl_cell = Id_glb(n,nv) - - if(ityp_new == ityp_offl (offl_cell,nv) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! same type fraction (primary of secondary) - else if(ityp_new == ityp_offl (offl_cell,nx) .and. fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! not same fraction - else if(iclass(ityp_new)==iclass(ityp_offl(offl_cell,nv)) .and. fveg_offl (offl_cell,nv)> fmin) then - iv = nv ! primary, other type (same class) - else if(fveg_offl (offl_cell,nx)> fmin) then - iv = nx ! secondary, other type (same class) - endif - - ! Get col and pft variables for the Id_glb(nv) grid cell from offline catchcn_internal_rst - ! ---------------------------------------------------------------------------------------- - - ! call NCDF_reshape_getOput (NCFID,Id_glb(n,nv),var_off_col,var_off_pft,.true.) - - var_pft_out (n,:,nv,:) = var_off_pft(Id_glb(n,nv), :,iv,:) - var_col_out (n,:,:) = var_col_out(n,:,:) + fveg_new * var_off_col(Id_glb(n,nv), :,:) ! gkw: column state simple weighted mean; ! could use "woody" fraction? - - ! Check whether var_pft_out is realistic - do nz = 1, nzone - do j = 1, VAR_PFT - if (isnan(var_pft_out (n, nz,nv,j))) print *,j,nv,nz,n,var_pft_out (n, nz,nv,j),fveg_new - !if(isnan(var_pft_out (n, nz,nv,69))) var_pft_out (n, nz,nv,69) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,70))) var_pft_out (n, nz,nv,70) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,73))) var_pft_out (n, nz,nv,73) = 1.e-6 - !if(isnan(var_pft_out (n, nz,nv,74))) var_pft_out (n, nz,nv,74) = 1.e-6 - end do - end do - endif - - end do NVLOOP2 - - ! reset carbon if negative < 10g - ! ------------------------ - - NZLOOP : do nz = 1, nzone - - if(var_col_out (n, nz,14) < 10.) then - - var_col_out(n, nz, 1) = max(var_col_out(n, nz, 1), 0.) - var_col_out(n, nz, 2) = max(var_col_out(n, nz, 2), 0.) - var_col_out(n, nz, 3) = max(var_col_out(n, nz, 3), 0.) - var_col_out(n, nz, 4) = max(var_col_out(n, nz, 4), 0.) - var_col_out(n, nz, 5) = max(var_col_out(n, nz, 5), 0.) - var_col_out(n, nz,10) = max(var_col_out(n, nz,10), 0.) - var_col_out(n, nz,11) = max(var_col_out(n, nz,11), 0.) - var_col_out(n, nz,12) = max(var_col_out(n, nz,12), 0.) - var_col_out(n, nz,13) = max(var_col_out(n, nz,13),10.) ! soil4c - var_col_out(n, nz,14) = max(var_col_out(n, nz,14), 0.) - var_col_out(n, nz,15) = max(var_col_out(n, nz,15), 0.) - var_col_out(n, nz,16) = max(var_col_out(n, nz,16), 0.) - var_col_out(n, nz,17) = max(var_col_out(n, nz,17), 0.) - var_col_out(n, nz,18) = max(var_col_out(n, nz,18), 0.) - var_col_out(n, nz,19) = max(var_col_out(n, nz,19), 0.) - var_col_out(n, nz,20) = max(var_col_out(n, nz,20), 0.) - var_col_out(n, nz,24) = max(var_col_out(n, nz,24), 0.) - var_col_out(n, nz,25) = max(var_col_out(n, nz,25), 0.) - var_col_out(n, nz,26) = max(var_col_out(n, nz,26), 0.) - var_col_out(n, nz,27) = max(var_col_out(n, nz,27), 0.) - var_col_out(n, nz,28) = max(var_col_out(n, nz,28), 1.) - var_col_out(n, nz,29) = max(var_col_out(n, nz,29), 0.) - - NVLOOP3 : do nv = 1,nveg - - if (nv == 1) ityp_new = CLMC_pt1(n) - if (nv == 1) fveg_new = CLMC_pf1(n) - if (nv == 2) ityp_new = CLMC_pt2(n) - if (nv == 2) fveg_new = CLMC_pf2(n) - if (nv == 3) ityp_new = CLMC_st1(n) - if (nv == 3) fveg_new = CLMC_sf1(n) - if (nv == 4) ityp_new = CLMC_st2(n) - if (nv == 4) fveg_new = CLMC_sf2(n) - - if(fveg_new > fmin) then - var_pft_out(n, nz,nv, 1) = max(var_pft_out(n, nz,nv, 1),0.) - var_pft_out(n, nz,nv, 2) = max(var_pft_out(n, nz,nv, 2),0.) - var_pft_out(n, nz,nv, 3) = max(var_pft_out(n, nz,nv, 3),0.) - var_pft_out(n, nz,nv, 4) = max(var_pft_out(n, nz,nv, 4),0.) - - if(ityp_new <= 12) then ! tree or shrub deadstemc - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.1) - else - var_pft_out(n, nz,nv, 5) = max(var_pft_out(n, nz,nv, 5),0.0) - endif - - var_pft_out(n, nz,nv, 6) = max(var_pft_out(n, nz,nv, 6),0.) - var_pft_out(n, nz,nv, 7) = max(var_pft_out(n, nz,nv, 7),0.) - var_pft_out(n, nz,nv, 8) = max(var_pft_out(n, nz,nv, 8),0.) - var_pft_out(n, nz,nv, 9) = max(var_pft_out(n, nz,nv, 9),0.) - var_pft_out(n, nz,nv,10) = max(var_pft_out(n, nz,nv,10),0.) - var_pft_out(n, nz,nv,11) = max(var_pft_out(n, nz,nv,11),0.) - var_pft_out(n, nz,nv,12) = max(var_pft_out(n, nz,nv,12),0.) - - if(ityp_new <=2 .or. ityp_new ==4 .or. ityp_new ==5 .or. ityp_new == 9) then - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),1.) ! leaf carbon display for evergreen - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),0.) - else - var_pft_out(n, nz,nv,13) = max(var_pft_out(n, nz,nv,13),0.) - var_pft_out(n, nz,nv,14) = max(var_pft_out(n, nz,nv,14),1.) ! leaf carbon storage for deciduous - endif - - var_pft_out(n, nz,nv,15) = max(var_pft_out(n, nz,nv,15),0.) - var_pft_out(n, nz,nv,16) = max(var_pft_out(n, nz,nv,16),0.) - var_pft_out(n, nz,nv,17) = max(var_pft_out(n, nz,nv,17),0.) - var_pft_out(n, nz,nv,18) = max(var_pft_out(n, nz,nv,18),0.) - var_pft_out(n, nz,nv,19) = max(var_pft_out(n, nz,nv,19),0.) - var_pft_out(n, nz,nv,20) = max(var_pft_out(n, nz,nv,20),0.) - var_pft_out(n, nz,nv,21) = max(var_pft_out(n, nz,nv,21),0.) - var_pft_out(n, nz,nv,22) = max(var_pft_out(n, nz,nv,22),0.) - var_pft_out(n, nz,nv,23) = max(var_pft_out(n, nz,nv,23),0.) - var_pft_out(n, nz,nv,25) = max(var_pft_out(n, nz,nv,25),0.) - var_pft_out(n, nz,nv,26) = max(var_pft_out(n, nz,nv,26),0.) - var_pft_out(n, nz,nv,27) = max(var_pft_out(n, nz,nv,27),0.) - var_pft_out(n, nz,nv,41) = max(var_pft_out(n, nz,nv,41),0.) - var_pft_out(n, nz,nv,42) = max(var_pft_out(n, nz,nv,42),0.) - var_pft_out(n, nz,nv,44) = max(var_pft_out(n, nz,nv,44),0.) - var_pft_out(n, nz,nv,45) = max(var_pft_out(n, nz,nv,45),0.) - var_pft_out(n, nz,nv,46) = max(var_pft_out(n, nz,nv,46),0.) - var_pft_out(n, nz,nv,47) = max(var_pft_out(n, nz,nv,47),0.) - var_pft_out(n, nz,nv,48) = max(var_pft_out(n, nz,nv,48),0.) - var_pft_out(n, nz,nv,49) = max(var_pft_out(n, nz,nv,49),0.) - var_pft_out(n, nz,nv,50) = max(var_pft_out(n, nz,nv,50),0.) - var_pft_out(n, nz,nv,51) = max(var_pft_out(n, nz,nv, 5)/500.,0.) - var_pft_out(n, nz,nv,52) = max(var_pft_out(n, nz,nv,52),0.) - var_pft_out(n, nz,nv,53) = max(var_pft_out(n, nz,nv,53),0.) - var_pft_out(n, nz,nv,54) = max(var_pft_out(n, nz,nv,54),0.) - var_pft_out(n, nz,nv,55) = max(var_pft_out(n, nz,nv,55),0.) - var_pft_out(n, nz,nv,56) = max(var_pft_out(n, nz,nv,56),0.) - var_pft_out(n, nz,nv,57) = max(var_pft_out(n, nz,nv,13)/25.,0.) - var_pft_out(n, nz,nv,58) = max(var_pft_out(n, nz,nv,14)/25.,0.) - var_pft_out(n, nz,nv,59) = max(var_pft_out(n, nz,nv,59),0.) - var_pft_out(n, nz,nv,60) = max(var_pft_out(n, nz,nv,60),0.) - var_pft_out(n, nz,nv,61) = max(var_pft_out(n, nz,nv,61),0.) - var_pft_out(n, nz,nv,62) = max(var_pft_out(n, nz,nv,62),0.) - var_pft_out(n, nz,nv,63) = max(var_pft_out(n, nz,nv,63),0.) - var_pft_out(n, nz,nv,64) = max(var_pft_out(n, nz,nv,64),0.) - var_pft_out(n, nz,nv,65) = max(var_pft_out(n, nz,nv,65),0.) - var_pft_out(n, nz,nv,66) = max(var_pft_out(n, nz,nv,66),0.) - var_pft_out(n, nz,nv,67) = max(var_pft_out(n, nz,nv,67),0.) - var_pft_out(n, nz,nv,68) = max(var_pft_out(n, nz,nv,68),0.) - var_pft_out(n, nz,nv,69) = max(var_pft_out(n, nz,nv,69),0.) - var_pft_out(n, nz,nv,70) = max(var_pft_out(n, nz,nv,70),0.) - var_pft_out(n, nz,nv,73) = max(var_pft_out(n, nz,nv,73),0.) - var_pft_out(n, nz,nv,74) = max(var_pft_out(n, nz,nv,74),0.) - if(clm45) var_pft_out(n, nz,nv,75) = max(var_pft_out(n, nz,nv,75),0.) - endif - end do NVLOOP3 ! end veg loop - endif ! end carbon check - end do NZLOOP ! end zone loop - - ! Update dayx variable var_pft_out (:,:,28) - - do j = 28, 28 ! 1,VAR_PFT var_pft_out (:,:,:,28) - do nv = 1,nveg - do nz = 1,nzone - var_pft_out (n, nz,nv,j) = dayx(n) - end do - end do - end do - - ! call NCDF_reshape_getOput (OutID,N,var_col_out,var_pft_out,.false.) - - ! column vars clm40 clm45 - ! ----------------- --------------------- - ! 1 clm3%g%l%c%ccs%col_ctrunc ! 1 ccs%col_ctrunc_vr (:,1) - ! 2 clm3%g%l%c%ccs%cwdc ! 2 ccs%decomp_cpools_vr(:,1,4) ! cwdc - ! 3 clm3%g%l%c%ccs%litr1c ! 3 ccs%decomp_cpools_vr(:,1,1) ! litr1c - ! 4 clm3%g%l%c%ccs%litr2c ! 4 ccs%decomp_cpools_vr(:,1,2) ! litr2c - ! 5 clm3%g%l%c%ccs%litr3c ! 5 ccs%decomp_cpools_vr(:,1,3) ! litr3c - ! 6 clm3%g%l%c%ccs%pcs_a%totvegc ! 6 ccs%totvegc_col - ! 7 clm3%g%l%c%ccs%prod100c ! 7 ccs%prod100c - ! 8 clm3%g%l%c%ccs%prod10c ! 8 ccs%prod10c - ! 9 clm3%g%l%c%ccs%seedc ! 9 ccs%seedc - ! 10 clm3%g%l%c%ccs%soil1c ! 10 ccs%decomp_cpools_vr(:,1,5) ! soil1c - ! 11 clm3%g%l%c%ccs%soil2c ! 11 ccs%decomp_cpools_vr(:,1,6) ! soil2c - ! 12 clm3%g%l%c%ccs%soil3c ! 12 ccs%decomp_cpools_vr(:,1,7) ! soil3c - ! 13 clm3%g%l%c%ccs%soil4c ! 13 ccs%decomp_cpools_vr(:,1,8) ! soil4c - ! 14 clm3%g%l%c%ccs%totcolc ! 14 ccs%totcolc - ! 15 clm3%g%l%c%ccs%totlitc ! 15 ccs%totlitc - ! 16 clm3%g%l%c%cns%col_ntrunc ! 16 cns%col_ntrunc_vr (:,1) - ! 17 clm3%g%l%c%cns%cwdn ! 17 cns%decomp_npools_vr(:,1,4) ! cwdn - ! 18 clm3%g%l%c%cns%litr1n ! 18 cns%decomp_npools_vr(:,1,1) ! litr1n - ! 19 clm3%g%l%c%cns%litr2n ! 19 cns%decomp_npools_vr(:,1,2) ! litr2n - ! 20 clm3%g%l%c%cns%litr3n ! 20 cns%decomp_npools_vr(:,1,3) ! litr3n - ! 21 clm3%g%l%c%cns%prod100n ! 21 cns%prod100n - ! 22 clm3%g%l%c%cns%prod10n ! 22 cns%prod10n - ! 23 clm3%g%l%c%cns%seedn ! 23 cns%seedn - ! 24 clm3%g%l%c%cns%sminn ! 24 cns%sminn_vr (:,1) - ! 25 clm3%g%l%c%cns%soil1n ! 25 cns%decomp_npools_vr(:,1,5) ! soil1n - ! 26 clm3%g%l%c%cns%soil2n ! 26 cns%decomp_npools_vr(:,1,6) ! soil2n - ! 27 clm3%g%l%c%cns%soil3n ! 27 cns%decomp_npools_vr(:,1,7) ! soil3n - ! 28 clm3%g%l%c%cns%soil4n ! 28 cns%decomp_npools_vr(:,1,8) ! soil4n - ! 29 clm3%g%l%c%cns%totcoln ! 29 cns%totcoln - ! 30 clm3%g%l%c%cps%ann_farea_burned ! 30 cps%fpg - ! 31 clm3%g%l%c%cps%annsum_counter ! 31 cps%annsum_counter - ! 32 clm3%g%l%c%cps%cannavg_t2m ! 32 cps%cannavg_t2m - ! 33 clm3%g%l%c%cps%cannsum_npp ! 33 cps%cannsum_npp - ! 34 clm3%g%l%c%cps%farea_burned ! 34 cps%farea_burned - ! 35 clm3%g%l%c%cps%fire_prob ! 35 cps%fpi_vr (:,1) - ! 36 clm3%g%l%c%cps%fireseasonl ! OLD ! 30 cps%altmax - ! 37 clm3%g%l%c%cps%fpg ! OLD ! 31 cps%annsum_counter - ! 38 clm3%g%l%c%cps%fpi ! OLD ! 32 cps%cannavg_t2m - ! 39 clm3%g%l%c%cps%me ! OLD ! 33 cps%cannsum_npp - ! 40 clm3%g%l%c%cps%mean_fire_prob ! OLD ! 34 cps%farea_burned - ! OLD ! 35 cps%altmax_lastyear - ! OLD ! 36 cps%altmax_indx - ! OLD ! 37 cps%fpg - ! OLD ! 38 cps%fpi_vr (:,1) - ! OLD ! 39 cps%altmax_lastyear_indx - - ! PFT vars CLM40 CLM45 - ! -------------- ----- - ! 1 clm3%g%l%c%p%pcs%cpool ! 1 pcs%cpool - ! 2 clm3%g%l%c%p%pcs%deadcrootc ! 2 pcs%deadcrootc - ! 3 clm3%g%l%c%p%pcs%deadcrootc_storage ! 3 pcs%deadcrootc_storage - ! 4 clm3%g%l%c%p%pcs%deadcrootc_xfer ! 4 pcs%deadcrootc_xfer - ! 5 clm3%g%l%c%p%pcs%deadstemc ! 5 pcs%deadstemc - ! 6 clm3%g%l%c%p%pcs%deadstemc_storage ! 6 pcs%deadstemc_storage - ! 7 clm3%g%l%c%p%pcs%deadstemc_xfer ! 7 pcs%deadstemc_xfer - ! 8 clm3%g%l%c%p%pcs%frootc ! 8 pcs%frootc - ! 9 clm3%g%l%c%p%pcs%frootc_storage ! 9 pcs%frootc_storage - ! 10 clm3%g%l%c%p%pcs%frootc_xfer ! 10 pcs%frootc_xfer - ! 11 clm3%g%l%c%p%pcs%gresp_storage ! 11 pcs%gresp_storage - ! 12 clm3%g%l%c%p%pcs%gresp_xfer ! 12 pcs%gresp_xfer - ! 13 clm3%g%l%c%p%pcs%leafc ! 13 pcs%leafc - ! 14 clm3%g%l%c%p%pcs%leafc_storage ! 14 pcs%leafc_storage - ! 15 clm3%g%l%c%p%pcs%leafc_xfer ! 15 pcs%leafc_xfer - ! 16 clm3%g%l%c%p%pcs%livecrootc ! 16 pcs%livecrootc - ! 17 clm3%g%l%c%p%pcs%livecrootc_storage ! 17 pcs%livecrootc_storage - ! 18 clm3%g%l%c%p%pcs%livecrootc_xfer ! 18 pcs%livecrootc_xfer - ! 19 clm3%g%l%c%p%pcs%livestemc ! 19 pcs%livestemc - ! 20 clm3%g%l%c%p%pcs%livestemc_storage ! 20 pcs%livestemc_storage - ! 21 clm3%g%l%c%p%pcs%livestemc_xfer ! 21 pcs%livestemc_xfer - ! 22 clm3%g%l%c%p%pcs%pft_ctrunc ! 22 pcs%pft_ctrunc - ! 23 clm3%g%l%c%p%pcs%xsmrpool ! 23 pcs%xsmrpool - ! 24 clm3%g%l%c%p%pepv%annavg_t2m ! 24 pepv%annavg_t2m - ! 25 clm3%g%l%c%p%pepv%annmax_retransn ! 25 pepv%annmax_retransn - ! 26 clm3%g%l%c%p%pepv%annsum_npp ! 26 pepv%annsum_npp - ! 27 clm3%g%l%c%p%pepv%annsum_potential_gpp ! 27 pepv%annsum_potential_gpp - ! 28 clm3%g%l%c%p%pepv%dayl ! 28 pepv%dayl - ! 29 clm3%g%l%c%p%pepv%days_active ! 29 pepv%days_active - ! 30 clm3%g%l%c%p%pepv%dormant_flag ! 30 pepv%dormant_flag - ! 31 clm3%g%l%c%p%pepv%offset_counter ! 31 pepv%offset_counter - ! 32 clm3%g%l%c%p%pepv%offset_fdd ! 32 pepv%offset_fdd - ! 33 clm3%g%l%c%p%pepv%offset_flag ! 33 pepv%offset_flag - ! 34 clm3%g%l%c%p%pepv%offset_swi ! 34 pepv%offset_swi - ! 35 clm3%g%l%c%p%pepv%onset_counter ! 35 pepv%onset_counter - ! 36 clm3%g%l%c%p%pepv%onset_fdd ! 36 pepv%onset_fdd - ! 37 clm3%g%l%c%p%pepv%onset_flag ! 37 pepv%onset_flag - ! 38 clm3%g%l%c%p%pepv%onset_gdd ! 38 pepv%onset_gdd - ! 39 clm3%g%l%c%p%pepv%onset_gddflag ! 39 pepv%onset_gddflag - ! 40 clm3%g%l%c%p%pepv%onset_swi ! 40 pepv%onset_swi - ! 41 clm3%g%l%c%p%pepv%prev_frootc_to_litter ! 41 pepv%prev_frootc_to_litter - ! 42 clm3%g%l%c%p%pepv%prev_leafc_to_litter ! 42 pepv%prev_leafc_to_litter - ! 43 clm3%g%l%c%p%pepv%tempavg_t2m ! 43 pepv%tempavg_t2m - ! 44 clm3%g%l%c%p%pepv%tempmax_retransn ! 44 pepv%tempmax_retransn - ! 45 clm3%g%l%c%p%pepv%tempsum_npp ! 45 pepv%tempsum_npp - ! 46 clm3%g%l%c%p%pepv%tempsum_potential_gpp ! 46 pepv%tempsum_potential_gpp - ! 47 clm3%g%l%c%p%pepv%xsmrpool_recover ! 47 pepv%xsmrpool_recover - ! 48 clm3%g%l%c%p%pns%deadcrootn ! 48 pns%deadcrootn - ! 49 clm3%g%l%c%p%pns%deadcrootn_storage ! 49 pns%deadcrootn_storage - ! 50 clm3%g%l%c%p%pns%deadcrootn_xfer ! 50 pns%deadcrootn_xfer - ! 51 clm3%g%l%c%p%pns%deadstemn ! 51 pns%deadstemn - ! 52 clm3%g%l%c%p%pns%deadstemn_storage ! 52 pns%deadstemn_storage - ! 53 clm3%g%l%c%p%pns%deadstemn_xfer ! 53 pns%deadstemn_xfer - ! 54 clm3%g%l%c%p%pns%frootn ! 54 pns%frootn - ! 55 clm3%g%l%c%p%pns%frootn_storage ! 55 pns%frootn_storage - ! 56 clm3%g%l%c%p%pns%frootn_xfer ! 56 pns%frootn_xfer - ! 57 clm3%g%l%c%p%pns%leafn ! 57 pns%leafn - ! 58 clm3%g%l%c%p%pns%leafn_storage ! 58 pns%leafn_storage - ! 59 clm3%g%l%c%p%pns%leafn_xfer ! 59 pns%leafn_xfer - ! 60 clm3%g%l%c%p%pns%livecrootn ! 60 pns%livecrootn - ! 61 clm3%g%l%c%p%pns%livecrootn_storage ! 61 pns%livecrootn_storage - ! 62 clm3%g%l%c%p%pns%livecrootn_xfer ! 62 pns%livecrootn_xfer - ! 63 clm3%g%l%c%p%pns%livestemn ! 63 pns%livestemn - ! 64 clm3%g%l%c%p%pns%livestemn_storage ! 64 pns%livestemn_storage - ! 65 clm3%g%l%c%p%pns%livestemn_xfer ! 65 pns%livestemn_xfer - ! 66 clm3%g%l%c%p%pns%npool ! 66 pns%npool - ! 67 clm3%g%l%c%p%pns%pft_ntrunc ! 67 pns%pft_ntrunc - ! 68 clm3%g%l%c%p%pns%retransn ! 68 pns%retransn - ! 69 clm3%g%l%c%p%pps%elai ! 69 pps%elai - ! 70 clm3%g%l%c%p%pps%esai ! 70 pps%esai - ! 71 clm3%g%l%c%p%pps%hbot ! 71 pps%hbot - ! 72 clm3%g%l%c%p%pps%htop ! 72 pps%htop - ! 73 clm3%g%l%c%p%pps%tlai ! 73 pps%tlai - ! 74 clm3%g%l%c%p%pps%tsai ! 74 pps%tsai - ! 75 pepv%plant_ndemand - ! OLD ! 75 pps%gddplant - ! OLD ! 76 pps%gddtsoi - ! OLD ! 77 pps%peaklai - ! OLD ! 78 pps%idop - ! OLD ! 79 pps%aleaf - ! OLD ! 80 pps%aleafi - ! OLD ! 81 pps%astem - ! OLD ! 82 pps%astemi - ! OLD ! 83 pps%htmx - ! OLD ! 84 pps%hdidx - ! OLD ! 85 pps%vf - ! OLD ! 86 pps%cumvd - ! OLD ! 87 pps%croplive - ! OLD ! 88 pps%cropplant - ! OLD ! 89 pps%harvdate - ! OLD ! 90 pps%gdd1020 - ! OLD ! 91 pps%gdd820 - ! OLD ! 92 pps%gdd020 - ! OLD ! 93 pps%gddmaturity - ! OLD ! 94 pps%huileaf - ! OLD ! 95 pps%huigrain - ! OLD ! 96 pcs%grainc - ! OLD ! 97 pcs%grainc_storage - ! OLD ! 98 pcs%grainc_xfer - ! OLD ! 99 pns%grainn - ! OLD !100 pns%grainn_storage - ! OLD !101 pns%grainn_xfer - ! OLD !102 pepv%fert_counter - ! OLD !103 pnf%fert - ! OLD !104 pepv%grain_flag - - end do OUT_TILE - - i = 1 - do nv = 1,VAR_COL - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNCOL'), (/1,i/), (/NTILES,1 /),var_col_out(:, nz,nv)) ; VERIFY_(STATUS) - i = i + 1 - end do - end do - - i = 1 - if(clm45) then - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - if(iv <= 74) then - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) - else - if((iv == 78) .OR. (iv == 89)) then ! idop and harvdate - var_dum = 999 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - else - var_dum = 0. - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_dum) ; VERIFY_(STATUS) - endif - endif - i = i + 1 - end do - end do - end do - else - do iv = 1,VAR_PFT - do nv = 1,nveg - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OutID,'CNPFT'), (/1,i/), (/NTILES,1 /),var_pft_out(:, nz,nv,iv)) ; VERIFY_(STATUS) - i = i + 1 - end do - end do - end do - endif - - VAR_DUM = 0. - - do nz = 1,nzone - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TGWM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RZMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - if(clm45) STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMM'), (/1,nz/), (/NTILES,1 /),VAR_DUM(:)) ; VERIFY_(STATUS) - end do - - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'BFLOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TOTWATM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TAIRM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CNSUM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNDZM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'ASNOWM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - - if(clm45) then - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'AR1M' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RAINFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RHM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'RUNSRFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SNOWFM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WINDM' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC10D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'TPREC60D'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'T2M10D' ), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - else - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'SFMCM'), (/1/), (/NTILES/),VAR_DUM(:)) ; VERIFY_(STATUS) - endif - - do nv = 1,nzone - do nz = 1,nveg - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSUNM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) ; VERIFY_(STATUS) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'PSNSHAM'), (/1,nz,nv/), (/NTILES,1,1/),VAR_DUM(:)) ; VERIFY_(STATUS) - end do - end do - - VAR_DUM = 0.1 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'WW'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - VAR_DUM = 0.25 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'FR'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - VAR_DUM = 0.001 - do i = 1,4 - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CH'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CM'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - STATUS = NF_PUT_VARA_REAL(OutID,VarID(OUTID,'CQ'), (/1,i/), (/NTILES,1 /),VAR_DUM(:)) - end do - - STATUS = NF_CLOSE (NCFID) - - deallocate (var_col_out,var_pft_out) - deallocate (CLMC_pf1, CLMC_pf2, CLMC_sf1, CLMC_sf2) - deallocate (CLMC_pt1, CLMC_pt2, CLMC_st1, CLMC_st2) - - END SUBROUTINE write_regridded_carbon - - ! ***************************************************************************** - - SUBROUTINE put_land_vars (NTILES, ntiles_rst, id_glb, ld_reorder, model, rst_file) - - implicit none - character(*), intent (in) :: model - integer, intent (in) :: NTILES, ntiles_rst - integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) - integer :: k, rc - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_FileFormatter):: OutFmt, InFmt - type(FileMetadata) :: meta_data - integer :: STATUS, NCFID, OUTID - character(*), intent (in), optional :: rst_file - character(256) :: Iam = "put_land_vars" - - allocate (var_get (NTILES_RST)) - allocate (var_put (NTILES)) - - ! create output catchcn_internal_rst - if(index(model,'catchcn') /=0) then - if (clm45) then - call InFmt%open('/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/catchcn_internal_clm45',PFIO_READ, __RC__) - else - call InFmt%open(trim(InCNRestart ), pFIO_READ, __RC__) - endif - endif - if(trim(model) == 'catch' ) then - call InFmt%open(trim(InCatRestart), pFIO_READ, __RC__) - endif - meta_data = InFmt%read(__RC__) - call InFmt%close(__RC__) - - call meta_data%modify_dimension('tile', ntiles, __RC__) - - OutFileName = "InData/"//trim(model)//"_internal_rst" - - call OutFmt%create(trim(OutFileName),__RC__) - call OutFmt%write(meta_data,__RC__) - - if (present(rst_file)) then - STATUS = NF_OPEN (trim(rst_file ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - else - if(index(model, 'catchcn') /=0 ) then - STATUS = NF_OPEN (trim(InCNRestart ),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - if(trim(model) == 'catch') then - STATUS = NF_OPEN (trim(InCatRestart),NF_NOWRITE,NCFID) ; VERIFY_(STATUS) - endif - endif - - ! Read catparam - ! ------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'POROS' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'COND' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'PSIS' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BEE' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WPWET' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GNU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'VGWMAX' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BF3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CDCR2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARS3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARA4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ARW4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSA2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TSB2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ATAU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'BTAU' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - if(index(model,'catchcn') /=0) then - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'ITY' ), (/1,4/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ITY',var_put, offset1=4) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'FVG' ), (/1,4/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'FVG',var_put, offset1=4) - - ! read restart and regrid - ! ----------------------- - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=1) ! if you see offset1=1 it is a 2-D var - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TG' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TG',var_put, offset1=3) - - endif - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'TC' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,1/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,2/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'QC' ), (/1,3/), (/NTILES_RST,1/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CAPAC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'CATDEF' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'RZEXC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SRFEXC' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT4' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT5' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'GHTCNT6' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'WESNN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'HTSNNN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN1' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN2' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - - STATUS = NF_GET_VARA_REAL(NCFID,VarID(NCFID,'SNDZN3' ), (/1/), (/NTILES_RST/),var_get) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - ! CH CM CQ FR WW - ! WW - VAR_PUT = 0.1 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'WW',VAR_PUT ,offset1=k) - end do - ! FR - VAR_PUT = 0.25 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'FR',VAR_PUT ,offset1=k) - end do - ! CH CM CQ - VAR_PUT = 0.001 - do k = 1,4 - call MAPL_VarWrite(OutFmt,'CH',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CM',VAR_PUT ,offset1=k) - call MAPL_VarWrite(OutFmt,'CQ',VAR_PUT ,offset1=k) - end do - - call OutFmt%close(__RC__) - STATUS = NF_CLOSE ( NCFID) - - deallocate (var_get, var_put) - CALL EXECUTE_COMMAND_LINE('/bin/cp InData/'//trim(model)//'_internal_rst OutData/'//trim(model)//'_internal_rst', .TRUE.) - - END SUBROUTINE put_land_vars - - ! ***************************************************************************** - - subroutine init_MPI() - - ! initialize MPI - - call MPI_INIT(mpierr) - - call MPI_COMM_RANK( MPI_COMM_WORLD, myid, mpierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, mpierr ) - - if (myid .ne. 0) root_proc = .false. - -! call init_MPI_types() - - write (*,*) "MPI process ", myid, " of ", numprocs, " is alive" - write (*,*) "MPI process ", myid, ": root_proc=", root_proc - - end subroutine init_MPI - - ! ----------------------------------------------------------------------- - - SUBROUTINE HANDLE_ERR(STATUS, Line) - - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line - - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF - - END SUBROUTINE HANDLE_ERR - - ! ***************************************************************************** - - subroutine compute_dayx ( & - NTILES, AGCM_YY, AGCM_MM, AGCM_DD, AGCM_HR, & - LATT, DAYX) - - implicit none - - integer, intent (in) :: NTILES,AGCM_YY,AGCM_MM,AGCM_DD,AGCM_HR - real, dimension (NTILES), intent (in) :: LATT - real, dimension (NTILES), intent (out) :: DAYX - integer, parameter :: DT = 900 - integer, parameter :: ncycle = 1461 ! number of days in a 4-year leap cycle (365*4 + 1) - real, dimension(ncycle) :: zc, zs - integer :: dofyr, sec,YEARS_PER_CYCLE, DAYS_PER_CYCLE, year, iday, idayp1, nn, n - real :: fac, YEARLEN, zsin, zcos, declin - - dofyr = AGCM_DD - if(AGCM_MM > 1) dofyr = dofyr + 31 - if(AGCM_MM > 2) then - dofyr = dofyr + 28 - if(mod(AGCM_YY,4) == 0) dofyr = dofyr + 1 - endif - if(AGCM_MM > 3) dofyr = dofyr + 31 - if(AGCM_MM > 4) dofyr = dofyr + 30 - if(AGCM_MM > 5) dofyr = dofyr + 31 - if(AGCM_MM > 6) dofyr = dofyr + 30 - if(AGCM_MM > 7) dofyr = dofyr + 31 - if(AGCM_MM > 8) dofyr = dofyr + 31 - if(AGCM_MM > 9) dofyr = dofyr + 30 - if(AGCM_MM > 10) dofyr = dofyr + 31 - if(AGCM_MM > 11) dofyr = dofyr + 30 - - sec = AGCM_HR * 3600 - DT ! subtract DT to get time of previous physics step - fac = real(sec) / 86400. - - call orbit_create(zs,zc,ncycle) ! GEOS5 leap cycle routine - - YEARLEN = 365.25 - - ! Compute length of leap cycle - !------------------------------ - - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif - - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - - ! declination & daylength - ! ----------------------- - - YEAR = mod(AGCM_YY-1,YEARS_PER_CYCLE) - - IDAY = YEAR*int(YEARLEN)+dofyr - IDAYP1 = mod(IDAY,DAYS_PER_CYCLE) + 1 - - ZSin = ZS(IDAYP1)*FAC + ZS(IDAY)*(1.-FAC) ! sine of solar declination - ZCos = ZC(IDAYP1)*FAC + ZC(IDAY)*(1.-FAC) ! cosine of solar declination - - nn = 0 - do n = 1,days_per_cycle - nn = nn + 1 - if(nn > 365) nn = nn - 365 - ! print *, 'cycle:',n,nn,asin(ZS(n)) - end do - - declin = asin(ZSin) - - ! compute daylength on input tile space (accounts for any change in physics time step) - ! do n = 1,ntiles_cn - ! fac = -(sin((latc(n)/zoom)*(MAPL_PI/180.))*zsin)/(cos((latc(n)/zoom)*(MAPL_PI/180.))*zcos) - ! fac = min(1.,max(-1.,fac)) - ! dayl(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - ! end do - - ! compute daylength on output tile space (accounts for lat shift due to split & change in time step) - - do n = 1,ntiles - fac = -(sin(latt(n)*(MAPL_PI/180.))*zsin)/(cos(latt(n)*(MAPL_PI/180.))*zcos) - fac = min(1.,max(-1.,fac)) - dayx(n) = (86400./MAPL_PI) * acos(fac) ! daylength (seconds) - end do - - ! print *,'DAYX : ', minval(dayx),maxval(dayx), minval(latt), maxval(latt), zsin, zcos, dofyr, iday, idayp1, declin - - end subroutine compute_dayx - - ! ***************************************************************************** - - subroutine orbit_create(zs,zc,ncycle) - - implicit none - - integer, intent(in) :: ncycle - real, intent(out), dimension(ncycle) :: zs, zc - - integer :: YEARS_PER_CYCLE, DAYS_PER_CYCLE - integer :: K, KP !, KM - real*8 :: T1, T2, T3, T4, FUN, Y, SOB, OMG, PRH, TT - real*8 :: YEARLEN - - ! STATEMENT FUNCTION - - FUN(Y) = OMG*(1.0-ECCENTRICITY*cos(Y-PRH))**2 - - YEARLEN = 365.25 - - ! Factors involving the orbital parameters - !------------------------------------------ - - OMG = (2.0*MAPL_PI/YEARLEN) / (sqrt(1.-ECCENTRICITY**2)**3) - PRH = PERIHELION*(MAPL_PI/180.) - SOB = sin(OBLIQUITY*(MAPL_PI/180.)) - - ! Compute length of leap cycle - !------------------------------ - - if(YEARLEN-int(YEARLEN) > 0.) then - YEARS_PER_CYCLE = nint(1./(YEARLEN-int(YEARLEN))) - else - YEARS_PER_CYCLE = 1 - endif - - DAYS_PER_CYCLE=nint(YEARLEN*YEARS_PER_CYCLE) - - if(days_per_cycle /= ncycle) stop 'bad cycle' - - ! ZS: Sine of declination - ! ZC: Cosine of declination - - ! Begin integration at vernal equinox - - KP = EQUINOX - TT = 0.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) - - ! Integrate orbit for entire leap cycle using Runge-Kutta - - do K=2,DAYS_PER_CYCLE - T1 = FUN(TT ) - T2 = FUN(TT+T1*0.5) - T3 = FUN(TT+T2*0.5) - T4 = FUN(TT+T3 ) - KP = mod(KP,DAYS_PER_CYCLE) + 1 - TT = TT + (T1 + 2.0*(T2 + T3) + T4) / 6.0 - ZS(KP) = sin(TT)*SOB - ZC(KP) = sqrt(1.0-ZS(KP)**2) - end do - - end subroutine orbit_create - -! ***************************************************************************** - -! function to_radian(degree) result(rad) -! -! ! degrees to radians -! real,intent(in) :: degree -! real :: rad -! -! rad = degree*MAPL_PI/180. -! -! end function to_radian -! -! ! ***************************************************************************** -! -! real function haversine(deglat1,deglon1,deglat2,deglon2) -! ! great circle distance -- adapted from Matlab -! real,intent(in) :: deglat1,deglon1,deglat2,deglon2 -! real :: a,c, dlat,dlon,lat1,lat2 -! real,parameter :: radius = MAPL_radius -! -!! dlat = to_radian(deglat2-deglat1) -!! dlon = to_radian(deglon2-deglon1) -! ! lat1 = to_radian(deglat1) -!! lat2 = to_radian(deglat2) -! dlat = deglat2-deglat1 -! dlon = deglon2-deglon1 -! lat1 = deglat1 -! lat2 = deglat2 -! a = (sin(dlat/2))**2 + cos(lat1)*cos(lat2)*(sin(dlon/2))**2 -! if(a>=0. .and. a<=1.) then -! c = 2*atan2(sqrt(a),sqrt(1-a)) -! haversine = radius*c / 1000. -! else -! haversine = 1.e20 -! endif -! end function -! -! ! ---------------------------------------------------------------------- - - integer function VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status - - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function VarID -! ! ----------------------------------------------------------------------------- -! - - FUNCTION StrUpCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in lower case constant string - n = INDEX( LOWER_CASE, Output_String( i:i ) ) - ! -- If current substring is a lower case letter, make it upper case - IF ( n /= 0 ) Output_String( i:i ) = UPPER_CASE( n:n ) - END DO - END FUNCTION StrUpCase - - ! ----------------------------------------------------------------------------- - - FUNCTION StrLowCase ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n - - ! -- Copy input string - Output_String = Input_String - ! -- Loop over string elements - DO i = 1, LEN( Output_String ) - ! -- Find location of letter in upper case constant string - n = INDEX( UPPER_CASE, Output_String( i:i ) ) - ! -- If current substring is an upper case letter, make it lower case - IF ( n /= 0 ) Output_String( i:i ) = LOWER_CASE( n:n ) - END DO - END FUNCTION StrLowCase - - ! ----------------------------------------------------------------------------- - - FUNCTION StrExtName ( Input_String ) RESULT ( Output_String ) - ! -- Argument and result - CHARACTER( * ), INTENT( IN ) :: Input_String - CHARACTER( LEN( Input_String ) ) :: Output_String - ! -- Local variables - INTEGER :: i, n1, n2, n3, n4, n5, n, k - - ! -- Copy input string - ! Output_String = Input_String - ! -- Loop over string elements - - k = 1 - - DO i = 1, LEN( Input_String ) - - ! -- Find location of letter in upper case constant string - n1 = INDEX( UPPER_CASE, Input_String( i:i ) ) - n2 = INDEX( LOWER_CASE, Input_String( i:i ) ) - n3 = INDEX( '.', Input_String( i:i ) ) - n4 = INDEX( '-', Input_String( i:i ) ) - n5 = INDEX( '_', Input_String( i:i ) ) - - n = 0 - Output_String(i:i) = '' - - if (n1 /= 0) n = n1 - if (n2 /= 0) n = n2 - if (n3 /= 0) n = n3 - if (n4 /= 0) n = n4 - if (n5 /= 0) n = n5 - - ! -- If current substring is acceptable - IF ( n /= 0 ) then - Output_String( k:k ) = Input_String( i:i ) - k = k + 1 - endif - - END DO - - END FUNCTION StrExtName - - ! ---------------------------------------------------------------------------- - - SUBROUTINE write_bin (unit, InFmt, NTILES) - - implicit none - integer :: ntiles - integer :: unit - type(Netcdf4_FileFormatter) :: InFmt - - - real :: bf1(ntiles) - real :: bf2(ntiles) - real :: bf3(ntiles) - real :: vgwmax(ntiles) - real :: cdcr1(ntiles) - real :: cdcr2(ntiles) - real :: psis(ntiles) - real :: bee(ntiles) - real :: poros(ntiles) - real :: wpwet(ntiles) - real :: cond(ntiles) - real :: gnu(ntiles) - real :: ars1(ntiles) - real :: ars2(ntiles) - real :: ars3(ntiles) - real :: ara1(ntiles) - real :: ara2(ntiles) - real :: ara3(ntiles) - real :: ara4(ntiles) - real :: arw1(ntiles) - real :: arw2(ntiles) - real :: arw3(ntiles) - real :: arw4(ntiles) - real :: tsa1(ntiles) - real :: tsa2(ntiles) - real :: tsb1(ntiles) - real :: tsb2(ntiles) - real :: atau(ntiles) - real :: btau(ntiles) - real :: ity(ntiles) - real :: tc(ntiles,4) - real :: qc(ntiles,4) - real :: capac(ntiles) - real :: catdef(ntiles) - real :: rzexc(ntiles) - real :: srfexc(ntiles) - real :: ghtcnt1(ntiles) - real :: ghtcnt2(ntiles) - real :: ghtcnt3(ntiles) - real :: ghtcnt4(ntiles) - real :: ghtcnt5(ntiles) - real :: ghtcnt6(ntiles) - real :: tsurf(ntiles) - real :: wesnn1(ntiles) - real :: wesnn2(ntiles) - real :: wesnn3(ntiles) - real :: htsnnn1(ntiles) - real :: htsnnn2(ntiles) - real :: htsnnn3(ntiles) - real :: sndzn1(ntiles) - real :: sndzn2(ntiles) - real :: sndzn3(ntiles) - real :: ch(ntiles,4) - real :: cm(ntiles,4) - real :: cq(ntiles,4) - real :: fr(ntiles,4) - real :: ww(ntiles,4) - character*256 :: Iam = "Write bin" - integer :: status - - call MAPL_VarRead(InFmt,"BF1",bf1, __RC__) - call MAPL_VarRead(InFmt,"BF2",bf2, __RC__) - call MAPL_VarRead(InFmt,"BF3",bf3, __RC__) - call MAPL_VarRead(InFmt,"VGWMAX",vgwmax, __RC__) - call MAPL_VarRead(InFmt,"CDCR1",cdcr1, __RC__) - call MAPL_VarRead(InFmt,"CDCR2",cdcr2, __RC__) - call MAPL_VarRead(InFmt,"PSIS",psis, __RC__) - call MAPL_VarRead(InFmt,"BEE",bee, __RC__) - call MAPL_VarRead(InFmt,"POROS",poros, __RC__) - call MAPL_VarRead(InFmt,"WPWET",wpwet, __RC__) - call MAPL_VarRead(InFmt,"COND",cond, __RC__) - call MAPL_VarRead(InFmt,"GNU",gnu, __RC__) - call MAPL_VarRead(InFmt,"ARS1",ars1, __RC__) - call MAPL_VarRead(InFmt,"ARS2",ars2, __RC__) - call MAPL_VarRead(InFmt,"ARS3",ars3, __RC__) - call MAPL_VarRead(InFmt,"ARA1",ara1, __RC__) - call MAPL_VarRead(InFmt,"ARA2",ara2, __RC__) - call MAPL_VarRead(InFmt,"ARA3",ara3, __RC__) - call MAPL_VarRead(InFmt,"ARA4",ara4, __RC__) - call MAPL_VarRead(InFmt,"ARW1",arw1, __RC__) - call MAPL_VarRead(InFmt,"ARW2",arw2, __RC__) - call MAPL_VarRead(InFmt,"ARW3",arw3, __RC__) - call MAPL_VarRead(InFmt,"ARW4",arw4, __RC__) - call MAPL_VarRead(InFmt,"TSA1",tsa1, __RC__) - call MAPL_VarRead(InFmt,"TSA2",tsa2, __RC__) - call MAPL_VarRead(InFmt,"TSB1",tsb1, __RC__) - call MAPL_VarRead(InFmt,"TSB2",tsb2, __RC__) - call MAPL_VarRead(InFmt,"ATAU",atau, __RC__) - call MAPL_VarRead(InFmt,"BTAU",btau, __RC__) - call MAPL_VarRead(InFmt,"OLD_ITY",ity, __RC__) - call MAPL_VarRead(InFmt,"TC",tc, __RC__) - call MAPL_VarRead(InFmt,"QC",qc, __RC__) - call MAPL_VarRead(InFmt,"OLD_ITY",ity, __RC__) - call MAPL_VarRead(InFmt,"CAPAC",capac, __RC__) - call MAPL_VarRead(InFmt,"CATDEF",catdef, __RC__) - call MAPL_VarRead(InFmt,"RZEXC",rzexc, __RC__) - call MAPL_VarRead(InFmt,"SRFEXC",srfexc, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT1",ghtcnt1, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT2",ghtcnt2, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT3",ghtcnt3, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT4",ghtcnt4, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT5",ghtcnt5, __RC__) - call MAPL_VarRead(InFmt,"GHTCNT6",ghtcnt6, __RC__) - call MAPL_VarRead(InFmt,"TSURF",tsurf, __RC__) - call MAPL_VarRead(InFmt,"WESNN1",wesnn1, __RC__) - call MAPL_VarRead(InFmt,"WESNN2",wesnn2, __RC__) - call MAPL_VarRead(InFmt,"WESNN3",wesnn3, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN1",htsnnn1, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN2",htsnnn2, __RC__) - call MAPL_VarRead(InFmt,"HTSNNN3",htsnnn3, __RC__) - call MAPL_VarRead(InFmt,"SNDZN1",sndzn1, __RC__) - call MAPL_VarRead(InFmt,"SNDZN2",sndzn2, __RC__) - call MAPL_VarRead(InFmt,"SNDZN3",sndzn3, __RC__) - call MAPL_VarRead(InFmt,"CH",ch, __RC__) - call MAPL_VarRead(InFmt,"CM",cm, __RC__) - call MAPL_VarRead(InFmt,"CQ",cq, __RC__) - call MAPL_VarRead(InFmt,"FR",fr, __RC__) - call MAPL_VarRead(InFmt,"WW",ww, __RC__) - - write(unit) bf1 - write(unit) bf2 - write(unit) bf3 - write(unit) vgwmax - write(unit) cdcr1 - write(unit) cdcr2 - write(unit) psis - write(unit) bee - write(unit) poros - write(unit) wpwet - write(unit) cond - write(unit) gnu - write(unit) ars1 - write(unit) ars2 - write(unit) ars3 - write(unit) ara1 - write(unit) ara2 - write(unit) ara3 - write(unit) ara4 - write(unit) arw1 - write(unit) arw2 - write(unit) arw3 - write(unit) arw4 - write(unit) tsa1 - write(unit) tsa2 - write(unit) tsb1 - write(unit) tsb2 - write(unit) atau - write(unit) btau - write(unit) ity - write(unit) tc - write(unit) qc - write(unit) capac - write(unit) catdef - write(unit) rzexc - write(unit) srfexc - write(unit) ghtcnt1 - write(unit) ghtcnt2 - write(unit) ghtcnt3 - write(unit) ghtcnt4 - write(unit) ghtcnt5 - write(unit) ghtcnt6 - write(unit) tsurf - write(unit) wesnn1 - write(unit) wesnn2 - write(unit) wesnn3 - write(unit) htsnnn1 - write(unit) htsnnn2 - write(unit) htsnnn3 - write(unit) sndzn1 - write(unit) sndzn2 - write(unit) sndzn3 - write(unit) ch - write(unit) cm - write(unit) cq - write(unit) fr - write(unit) ww - - END SUBROUTINE write_bin - - ! ---------------------------------------------------------------------------- - - SUBROUTINE read_ldas_restarts (NTILES, ntiles_rst, id_glb, ld_reorder, rst_file, pfile) - - implicit none - integer, intent (in) :: NTILES, ntiles_rst - integer, intent (in) :: id_glb(NTILES), ld_reorder (ntiles_rst) - integer :: k - character(*), intent (in) :: rst_file, pfile - real , dimension (:), allocatable :: var_get, var_put - type(Netcdf4_FileFormatter) :: OutFmt, InFmt - type(FileMetadata) :: meta_data - - allocate (var_get (NTILES_RST)) - allocate (var_put (NTILES)) - - call InFmt%Open(trim(InCatRestart), pFIO_READ, __RC__) - meta_data = InFmt%read(__RC__) - call InFmt%close() - call meta_data%modify_dimension('tile', ntiles, __RC__) - - OutFileName = "InData/catch_internal_rst" - call OutFmt%create(OutFileName, __RC__) - call OutFmt%write(meta_data, __RC__) - - open(10, file=trim(rst_file), form='unformatted', status='old', & - convert='big_endian', action='read') - - read (10) var_get ! (cat_progn(n)%tc1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=1) - - read (10) var_get ! (cat_progn(n)%tc2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=2) - - read (10) var_get ! (cat_progn(n)%tc4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TC',var_put, offset1=3) - - read (10) var_get ! (cat_progn(n)%qa1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=1) - - read (10) var_get ! (cat_progn(n)%qa2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=2) - - read (10) var_get ! (cat_progn(n)%qa4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=3) - call MAPL_VarWrite(OutFmt,'QC',var_put, offset1=4) - - read (10) var_get ! (cat_progn(n)%capac, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CAPAC',var_put) - - read (10) var_get ! (cat_progn(n)%catdef, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CATDEF',var_put) - - read (10) var_get ! (cat_progn(n)%rzexc, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'RZEXC',var_put) - - read (10) var_get ! (cat_progn(n)%srfexc, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SRFEXC',var_put) - - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT1',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT2',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT3',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT4',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT5',var_put) - read (10) var_get ! (cat_progn(n)%ght(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GHTCNT6',var_put) - - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN1',var_put) - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN2',var_put) - read (10) var_get !(cat_progn(n)%wesn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WESNN3',var_put) - - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN1',var_put) - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN2',var_put) - read (10) var_get !(cat_progn(n)%htsn(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'HTSNNN3',var_put) - - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN1',var_put) - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN2',var_put) - read (10) var_get !(cat_progn(n)%sndz(k), n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'SNDZN3',var_put) - - close (10) - -! PARAM - - open(10, file=trim(pfile), form='unformatted', status='old', & - convert='big_endian', action='read') - - - read (10) var_get !(cat_param(n)%dpth, n=1,N_catd) - - read (10) var_get !(cat_param(n)%dzsf, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzrz, n=1,N_catd) - read (10) var_get !(cat_param(n)%dzpr, n=1,N_catd) - - do k=1,6 - read (10) var_get !(cat_param(n)%dzgt(k), n=1,N_catd) - end do - do k = 1, NTILES - VAR_PUT(k) = id_glb(k) - end do - call MAPL_VarWrite(OutFmt,'TILE_ID',var_put) - - read (10) var_get !(cat_param(n)%poros, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'POROS',var_put) - - read (10) var_get !(cat_param(n)%cond, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'COND',var_put) - - read (10) var_get !(cat_param(n)%psis, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'PSIS',var_put) - - read (10) var_get !(cat_param(n)%bee, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BEE',var_put) - - read (10) var_get !(cat_param(n)%wpwet, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'WPWET',var_put) - - read (10) var_get !(cat_param(n)%gnu, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'GNU',var_put) - - read (10) var_get !(cat_param(n)%vgwmax, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'VGWMAX',var_put) - - read (10) var_get !(cat_param(n)%vegcls, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'OLD_ITY',var_put) - - read (10) var_get !(cat_param(n)%soilcls30, n=1,N_catd) - read (10) var_get !(cat_param(n)%soilcls100, n=1,N_catd) - - read (10) var_get !(cat_param(n)%bf1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF1',var_put) - - read (10) var_get !(cat_param(n)%bf2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF2',var_put) - - read (10) var_get !(cat_param(n)%bf3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BF3',var_put) - - read (10) var_get !(cat_param(n)%cdcr1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR1',var_put) - - read (10) var_get !(cat_param(n)%cdcr2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'CDCR2',var_put) - - read (10) var_get !(cat_param(n)%ars1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS1',var_put) - - read (10) var_get !(cat_param(n)%ars2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS2',var_put) - - read (10) var_get !(cat_param(n)%ars3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARS3',var_put) - - read (10) var_get !(cat_param(n)%ara1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA1',var_put) - - read (10) var_get !(cat_param(n)%ara2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA2',var_put) - - read (10) var_get !(cat_param(n)%ara3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA3',var_put) - - read (10) var_get !(cat_param(n)%ara4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARA4',var_put) - - read (10) var_get !(cat_param(n)%arw1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW1',var_put) - - read (10) var_get !(cat_param(n)%arw2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW2',var_put) - - read (10) var_get !(cat_param(n)%arw3, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW3',var_put) - - read (10) var_get !(cat_param(n)%arw4, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ARW4',var_put) - - read (10) var_get !(cat_param(n)%tsa1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA1',var_put) - - read (10) var_get !(cat_param(n)%tsa2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSA2',var_put) - - read (10) var_get !(cat_param(n)%tsb1, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB1',var_put) - - read (10) var_get !(cat_param(n)%tsb2, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'TSB2',var_put) - - read (10) var_get !(cat_param(n)%atau, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'ATAU',var_put) - - read (10) var_get !(cat_param(n)%btau, n=1,N_catd) - do k = 1, NTILES - VAR_PUT(k) = var_get(ld_reorder(id_glb(k))) - end do - call MAPL_VarWrite(OutFmt,'BTAU',var_put) - - read (10) var_get !(cat_param(n)%gravel30, n=1,N_catd) - read (10) var_get !(cat_param(n)%orgC30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%orgC , n=1,N_catd) - read (10) var_get !(cat_param(n)%sand30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%clay30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%sand , n=1,N_catd) - read (10) var_get !(cat_param(n)%clay , n=1,N_catd) - read (10) var_get !(cat_param(n)%wpwet30 , n=1,N_catd) - read (10) var_get !(cat_param(n)%poros30 , n=1,N_catd) - - close (10, status = 'keep') - deallocate (var_get, var_put) - - call OutFmt%close() - - call system('/bin/cp InData/catch_internal_rst OutData/catch_internal_rst') - - END SUBROUTINE read_ldas_restarts - - END PROGRAM mk_GEOSldasRestarts diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts deleted file mode 100755 index 7040cf2a65..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/mk_Restarts +++ /dev/null @@ -1,404 +0,0 @@ -#!/usr/bin/env perl -#======================================================================= -# name - mk_Restarts -# purpose - wrapper script to run programs which regrid surface restarts -#======================================================================= -use strict; -use warnings; -use FindBin qw($Bin); -use lib ("$Bin"); -use Cwd qw(getcwd); - -# global variables -#----------------- -my ($saltwater, $openwater, $seaice, $lake, $landice, $route); -my ($catchFLG, $catchcn, $catchcnFLG, @cnlist, @cnlen); -my ($surflay, $rsttime, $grpID, $numtasks, $walltime, $rescale, $qos, $partition, $constraint, $yyyymm); -my ($mk_catch_j, $mk_catch_log, $weminIN, $weminOUT, $weminDFLT); -my ($zoom); - -# mk_catch job and log file names (also applies to catchcn) -#---------------------------------------------------------- -$mk_catch_j = "mk_catch.j"; -$mk_catch_log = "mk_catch.log"; - -# main program -#------------- -{ - my ($cmd, $line, $pid); - - init(); - - #--------------------------- - # catch and catchcn restarts - #--------------------------- - if ($catchFLG or $catchcnFLG) { - write_mk_catch_j() unless -e $mk_catch_j; - - # run interactively if already on interactive job nodes - #------------------------------------------------------ - if (-x $mk_catch_j) { - $cmd = "./$mk_catch_j"; - system_($cmd); - } - else { - $cmd = "sbatch -W $mk_catch_j"; - print "$cmd\n"; - chomp($line = `$cmd`); - $pid = (split /\s+/, $line)[-1]; - } - } - - #------------------ - # saltwater restart - #------------------ - if ($saltwater) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*saltwater_internal_rst\* 0 $zoom"; - system_($cmd); - } - - if ($openwater) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*openwater_internal_rst\* 0 $zoom"; - system_($cmd); - } - - if ($seaice) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*seaicethermo_internal_rst\* 0 $zoom"; - system_($cmd); - } - - #------------- - # lake restart - #------------- - if ($lake) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*lake_internal_rst\* 19 $zoom"; - system_($cmd); - } - - #---------------- - # landice restart - #---------------- - if ($landice) { - $cmd = "$Bin/mk_LakeLandiceSaltRestarts " - . "OutData/\*.til " - . "InData/\*.til " - . "InData/\*landice_internal_rst\* 20 $zoom"; - system_($cmd); - } - - #-------------- - # route restart - #-------------- - if ($route) { - $cmd = "$Bin/mk_RouteRestarts OutData/\*.til $yyyymm"; - system_($cmd); - } - wait_for_pid($pid) if $pid; -} - -#======================================================================= -# name - init -# purpose - get runtime flags to determine which restarts to regrid -#======================================================================= -sub init { - use Getopt::Long; - my $help; - $| = 1; # flush buffer after each output operation - - GetOptions( "saltwater" => \$saltwater, - "openwater" => \$openwater, - "seaice" => \$seaice, - "lake" => \$lake, - "landice" => \$landice, - "catch" => \$catchFLG, - "catchcn=s" => \$catchcn, - "wemin=i" => \$weminIN, - "wemout=i" => \$weminOUT, - "route" => \$route, - - "surflay=i" => \$surflay, - "rsttime=i" => \$rsttime, - "grpID=s" => \$grpID, - - "constraint=s" => \$constraint, - - "ntasks=i" => \$numtasks, - "walltime=s"=> \$walltime, - "rescale" => \$rescale, - "qos=s" => \$qos, - "partition=s" => \$partition, - "zoom=i" => \$zoom, - "h|help" => \$help ); - # defaults - #--------- - $rsttime = 0 unless $rsttime; - $catchcnFLG = 0 unless $catchcn; - $rescale = 0 unless $rescale; - $weminDFLT = 26; - $weminIN = $weminDFLT unless defined($weminIN); - $weminOUT = $weminDFLT unless defined($weminOUT); - $zoom = 8 unless $zoom; - - usage() if $help; - - # unpack catchcn values - #---------------------- - if ($catchcn) { - $catchcnFLG = 1; - @cnlist = split(/,/, $catchcn); - @cnlen = scalar(@cnlist); - } - - # error if no restart specified - #------------------------------ - die "Error. No restart specified;" - unless $saltwater or $lake or $landice or $catchFLG or $catchcnFLG; - - # rsttime and grpID values are needed for catchcn - #---------------------------------------------- - if ($catchcnFLG) { - die "Error. Must specify rsttime for catchcn;" unless $rsttime; - die "Error. rsttime not in yyyymmddhh format: $rsttime;" - unless $rsttime =~ m/^\d{10}$/; - } - if ($catchFLG or $catchcnFLG) { - unless ($grpID) { - $grpID = `$Bin/getsponsor.pl -d`; - print "Using default grpID = $grpID\n"; - } - unless ($walltime) { $walltime = "1:00:00" } - unless ($numtasks) { $numtasks = 84 } - $qos = "" unless $qos; - $partition = "" unless $partition; - $constraint = "" unless $constraint; - } - - # rsttime value is needed for route - #---------------------------------- - if ($route) { - die "Error. Must specify rsttime for route;" unless $rsttime; - die "Error. Cannot extract yyyymm from rsttime: $rsttime" - unless $rsttime =~ m/^\d{6,}$/; - $yyyymm = $1 if $rsttime =~ /^(\d{6})/; - } -} - -#======================================================================= -# name - write_mk_catch_j -# purpose - write job file to make catch and/or catchcn restart -#======================================================================= -sub write_mk_catch_j { - my ($grouplist, $cwd, $QOSline, $PARTline, $CONSline, $FH); - - $grouplist = ""; - $grouplist = "SBATCH --account=$grpID" if $grpID; - - $cwd = getcwd; - - $QOSline = ""; - if ($qos) { - $QOSline = "SBATCH --qos=$qos"; - if ($qos eq "debug") { - $QOSline = "" unless $numtasks <= 532 and $walltime le "1:00:00"; - } - } - $PARTline = ""; - if ($partition) { - $PARTline = "SBATCH --partition=$partition"; - } - $CONSline = ""; - if ($constraint) { - $CONSline = "SBATCH --constraint=$constraint"; - } - print("\nWriting jobscript: $mk_catch_j\n"); - open CNj, ">> $mk_catch_j" or die "Error opening $mk_catch_j: $!"; - - $FH = select; - select CNj; - - print <<"EOF"; -#!/bin/csh -f -#$grouplist -#SBATCH --ntasks=$numtasks -#SBATCH --time=$walltime -#SBATCH --job-name=catchcnj -#SBATCH --output=$cwd/$mk_catch_log -#$QOSline -#$PARTline -#$CONSline - -source $Bin/g5_modules -set echo - -#limit stacksize unlimited -unlimit - -set catchFLG = $catchFLG -set catchcnFLG = $catchcnFLG -set weminIN = $weminIN -set weminOUT = $weminOUT -set rescaleFLG = $rescale - -set numtasks = $numtasks -set rsttime = $rsttime -set surflay = $surflay -set zoom = $zoom - -set esma_mpirun_X = ( $Bin/esma_mpirun -np \$numtasks ) -set mk_CatchRestarts_X = ( \$esma_mpirun_X $Bin/mk_CatchRestarts ) -set mk_CatchCNRestarts_X = ( \$esma_mpirun_X $Bin/mk_CatchCNRestarts ) -set mk_GEOSldasRestarts_X = ( \$esma_mpirun_X $Bin/mk_GEOSldasRestarts ) -set Scale_Catch_X = $Bin/Scale_Catch -set Scale_CatchCN_X = $Bin/Scale_CatchCN - -set OUT_til = OutData/\*.til -set IN_til = InData/\*.til - -if (\$catchFLG) then - set catchIN = InData/\*catch_internal_rst\* - set params = ( \$OUT_til \$IN_til \$catchIN \$surflay ) - \$mk_CatchRestarts_X \$params - - if (\$rescaleFLG) then - set catch_regrid = OutData/\$catchIN:t - set catch_scaled = \${catch_regrid}.scaled - set params = ( \$catchIN \$catch_regrid \$catch_scaled \$surflay ) - set params = ( \$params \$weminIN \$weminOUT ) - \$Scale_Catch_X \$params - - mv \$catch_regrid \${catch_regrid}.1 - mv \$catch_scaled \$catch_regrid - endif -endif - -if (\$catchcnFLG) then - if ($cnlen[0] == 1) then - set catchcnIN = InData/\*catchcn_internal_rst\* - set params = ( \$OUT_til \$IN_til \$catchcnIN \$surflay \$rsttime ) - \$mk_CatchCNRestarts_X \$params - endif - if ($cnlen[0] == 4) then - set OUT_til = `ls OutData/\*.til | cut -d '/' -f2` - /bin/cp OutData/\*.til OutData/OutTileFile - /bin/cp OutData/\*.til InData/OutTileFile - set CN_VERSION = $cnlist[0] - set RESTART_ID = $cnlist[1] - set RESTART_PATH = $cnlist[2] - set RESTART_DOMAIN = $cnlist[3] - set RESTART_short = \${RESTART_PATH}/\${RESTART_ID}/output/\${RESTART_DOMAIN}/ - set YYYY = `echo \${rsttime} | cut -c1-4` - set MM = `echo \${rsttime} | cut -c5-6` - set PARAM_FILE = `ls \$RESTART_short/rc_out/Y\${YYYY}/M\${MM}/*ldas_catparam* | head -1` - set params = ( -b OutData/ -d \$rsttime -e \$RESTART_ID -m catchcn\$CN_VERSION -s \$surflay -j Y -r R -p \$PARAM_FILE -l \$RESTART_short) - \$mk_GEOSldasRestarts_X \$params - endif - if (\$rescaleFLG) then - set catchcnIN = InData/catchcn\${CN_VERSION}_internal_rst\* - set catchcn_regrid = OutData/\$catchcnIN:t - set catchcn_scaled = \${catchcn_regrid}.scaled - set params = ( \$catchcnIN \$catchcn_regrid \$catchcn_scaled \$surflay ) - set params = ( \$params \$weminIN \$weminOUT ) - \$Scale_CatchCN_X \$params - - mv \$catchcn_regrid \${catchcn_regrid}.1 - mv \$catchcn_scaled \$catchcn_regrid - endif -endif -exit -EOF -; - close CNj; - select $FH; - chmod 0755, $mk_catch_j if $ENV{"SLURM_JOBID"}; -} - -#======================================================================= -# name - system_ -# purpose - wrapper for perl system command -#======================================================================= -sub system_ { - my $cmd = shift @_; - print "\n$cmd\n"; - die "Error: $!;" if system($cmd); -} - -#======================================================================= -# name - wait_for_pid -# purpose - wait for batch job to finish -# -# input parameter -# => $pid: process ID of batch job to wait for -#======================================================================= -sub wait_for_pid { - my ($pid, $first, %found, $line, $id); - $pid = shift @_; - return unless $pid; - - $first = 1; - while (1) { - %found = (); - #--foreach $line (`qstat | grep $ENV{"USER"}`) { - foreach $line (`squeue | grep $ENV{"USER"}`) { - $line =~ s/^\s+//; - $id = (split /\s+/, $line)[0]; - $found{$id} = 1; - } - last unless $found{$pid}; - print "\nWaiting for job $pid to finish\n" if $first; - $first = 0; - sleep 10; - } - print "Job $pid is DONE\n\n" unless $first; -} - -#======================================================================= -# name - usage -# purpose - print usage information -#======================================================================= -sub usage { - use File::Basename ("basename"); - my $name = basename $0; - print <<"EOF"; - -usage $name [-saltwater] [-lake] [-landice] [-catch] [-h] - -option flags - -saltwater regrid saltwater internal restart - -lake regrid lake internal restart - -landice regrid landice internal restart - -catch regrid catchment internal restart - -catchcn regrid catchment CN internal restart - -wemin weminIN minimum snow water equivalent threshold for input catch/cn [$weminDFLT] - -wemout weminOUT minimum snow water equivalent threshold for output catch/cn [$weminDFLT] - -route create the route internal restart - -surflay n thickness [mm] of surface soil moisture layer (catch & catchcn) - Ganymed-3 and earlier: SURFLAY=20 - Ganymed-4 and later : SURFLAY=50 - -rsttime n10 restart time in format, yyyymmddhh (catchcn) or yyyymm (route) - -grpID grpID group ID for batch submittal (catchcn) - -ntasks nt number of tasks to assign to catchcn batch job [112] - -walltime wt walltime in format \"hh:mm:ss\" for catchcn batch job [1:00:00] - -rescale - -qos val use \"SBATCH --qos=val directive\" for batch jobs; - \"-qos debug\" will not work unless these conditions are met - -> numtasks <= 532 - -> walltime le \"1:00:00\" - -partition val use \"SBATCH --partition=val directive\" for batch jobs - -zoom n zoom value to send to land regridding codes [8] - -h print usage information - -EOF -exit; -} diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt deleted file mode 100755 index dd2d3fc402..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/catchplt +++ /dev/null @@ -1,25 +0,0 @@ -n = 1 -while ( n < 64 ) - -m = n -if( m < 10 ) ; m = 0n ; endif - -'set dfile 1' -'setx' -'set y 1' -'set z 1' -'set cmark 0' -'d var'm'.1' - -'set dfile 2' -'setx' -'set y 1' -'set z 1' -'set cmark 0' -'d var'm'.2' - -'draw title Var: 'm -pull flag -'c' -n = n + 1 -endwhile diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro deleted file mode 100755 index 54afd3705d..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/check_land_restarts.pro +++ /dev/null @@ -1,1167 +0,0 @@ -; ========================================================================= -; USAGE : -; Edit lines to 44-47 specify paths to BCs dir and yjecatch{cn}_internal_rst file -; ========================================================================= -;_____________________________________________________________________ -;_____________________________________________________________________ - -FUNCTION NCDF_ISNCDF, FILENAME - -;- Set return values - -false = 0B -true = 1B - -;- Establish error handler - -catch, error_status -if error_status ne 0 then begin - catch, /cancel - return, false -endif - -;- Try opening the file - -cdfid = ncdf_open( filename ) - -;- If we get this far, open must have worked - -ncdf_close, cdfid -catch, /cancel -return, true - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_rst - -; ********************************************************************************************************** -; STEP (1) Specify below: -; ----------------------- - -BCSDIR = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0180x6C_DE1440xPE0720/' -GFILE = 'CF0180x6C_DE1440xPE0720-Pfafstetter' -OutDir = 'OutData2/' -int_rst = 'catchcn_internal_rst' - -; STEP (2) save : -; --------------- -; On dali : (a) module load tool/idl-8.5, (b) idl (c) .compile chk_restarts -; and (d) plot_rst - -; ********************************************************************************************************** - -; Setting up and select variables for plotting -; -------------------------------------------- - -TILFILE = BCSDIR + 'til/' + GFILE + '.til' -RSTFILE = BCSDIR + 'rst/' + GFILE + '.rst' - -NTILES = 0l -NG = 0l -NC = 0l -NR = 0l - -openr,1,BCSDIR + 'clsm/catchment.def' -readf,1,NTILES -close,1 - -openr,1,TILFILE -readf,1,NG,NC,NR -close,1 - -Var_Names = [ $ - 'CDCR2' , $ ; 0 - 'BEE' , $ ; 1 - 'POROS' , $ ; 2 - 'ITY1' , $ ; 3 - 'ITY2' , $ ; 4 - 'ITY3' , $ ; 5 - 'ITY4' , $ ; 6 - 'TC1' , $ ; 7 - 'TC2' , $ ; 8 - 'TC3' , $ ; 9 - 'TC4' , $ ;10 - 'CATDEF' , $ ;11 - 'RZEXC' , $ ;12 - 'SFEXC' ] - -N_VARS = N_ELEMENTS (Var_Names) -PLOT_VARS = fltarr (NTILES,N_VARS) -TMP_VAR1 = fltarr (NTILES) -TMP_VAR2 = fltarr (NTILES,4) - - -; Get file information : (1) model, (2) file format -; ------------------------------------------------- - -catch_model = boolean (strcmp(int_rst,'catchcn',7,/fold_case) eq 0) -ncdf_file = boolean (ncdf_isncdf(OutDir + int_rst)) - -; Set up vector to grid for plotting -; ---------------------------------- - -NC_plot = 4320 -NR_plot = 2160 - -tileid_plot = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -openr,1,RSTFILE,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le NTILES) then begin - min1 = min(subset) - subset(where (subset gt NTILES)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tileid_plot[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 - -; Reading catch*_internal_rst -; --------------------------- - -if (ncdf_file) then begin - - ncid = NCDF_OPEN(OutDir + int_rst,/NOWRITE) - result = ncdf_inquire( ncid) - if(result.nvars gt 60) then catch_model = boolean (result.nvars lt 60) - NCDF_VARGET, ncid,'CDCR2' ,TMP_VAR1 - PLOT_VARS (*,0) = TMP_VAR1 - NCDF_VARGET, ncid,'BEE' ,TMP_VAR1 - PLOT_VARS (*,1) = TMP_VAR1 - NCDF_VARGET, ncid,'POROS' ,TMP_VAR1 - PLOT_VARS (*,2) = TMP_VAR1 - NCDF_VARGET, ncid,'TC' ,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - NCDF_VARGET, ncid,'CATDEF' ,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - NCDF_VARGET, ncid,'RZEXC' ,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - NCDF_VARGET, ncid,'SRFEXC' ,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - if(catch_model) then begin - - NCDF_VARGET, ncid,'OLD_ITY' ,TMP_VAR1 - PLOT_VARS (*,3) = TMP_VAR1 - - endif else begin - - NCDF_VARGET, ncid,'ITY' ,TMP_VAR2 - PLOT_VARS (*,3) = TMP_VAR2(*,0) - PLOT_VARS (*,4) = TMP_VAR2(*,1) - PLOT_VARS (*,5) = TMP_VAR2(*,2) - PLOT_VARS (*,6) = TMP_VAR2(*,3) - - endelse - - NCDF_CLOSE, ncid - -endif else begin - - openr,1,OutDir + int_rst, /F77_UNFORMATTED - - if(catch_model) then begin - - for i = 1,30 do begin - readu,1,TMP_VAR1 - if (i eq 6) then PLOT_VARS (*,0) = TMP_VAR1 - if (i eq 8) then PLOT_VARS (*,1) = TMP_VAR1 - if (i eq 9) then PLOT_VARS (*,2) = TMP_VAR1 - if (i eq 30) then PLOT_VARS (*,3) = TMP_VAR1 - endfor - - readu,1,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - - readu,1,TMP_VAR2 - readu,1,TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - endif else begin - - for i = 1,37 do begin - readu,1,TMP_VAR1 - if (i eq 6) then PLOT_VARS (*,0) = TMP_VAR1 - if (i eq 8) then PLOT_VARS (*,1) = TMP_VAR1 - if (i eq 9) then PLOT_VARS (*,2) = TMP_VAR1 - if (i eq 30) then PLOT_VARS (*,3) = TMP_VAR1 - if (i eq 31) then PLOT_VARS (*,4) = TMP_VAR1 - if (i eq 32) then PLOT_VARS (*,5) = TMP_VAR1 - if (i eq 33) then PLOT_VARS (*,6) = TMP_VAR1 - endfor - readu,1,TMP_VAR2 - PLOT_VARS (*,7) = TMP_VAR2(*,0) - PLOT_VARS (*,8) = TMP_VAR2(*,1) - PLOT_VARS (*,9) = TMP_VAR2(*,2) - PLOT_VARS (*,10)= TMP_VAR2(*,3) - - readu,1,TMP_VAR2 - readu,1,TMP_VAR2 - readu,1,TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,11) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,12) = TMP_VAR1 - readu,1,TMP_VAR1 - PLOT_VARS (*,13) = TMP_VAR1 - - endelse - - close,1 - -endelse - -; Plotting -; -------- - -spawn, 'mkdir -p ' + OutDir + 'plots' -load_colors - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,800], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 3, 0, 0] - -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,0), [min(PLOT_VARS(*,0)), max(PLOT_VARS(*,0))] , Var_Names (0) -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,1), [min(PLOT_VARS(*,1)), max(PLOT_VARS(*,1))] , Var_Names (1),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,2), [0.37,0.8] , Var_Names (2),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,11),[min(PLOT_VARS(*,11)), max(PLOT_VARS(*,11))], Var_Names (11),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,12),[min(PLOT_VARS(*,12)), max(PLOT_VARS(*,12))], Var_Names (12),advance =1 -plot_6maps, ntiles, tileid_plot, PLOT_VARS(*,13),[min(PLOT_VARS(*,13)), max(PLOT_VARS(*,13))], Var_Names (13),advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 800) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + 'plots/soil_var.jpg', image24, True=1, Quality=100 - -plot_tc, NTILES, tileid_plot,OutDir + 'plots/', plot_vars (*,7), plot_vars (*,8), plot_vars (*,9), plot_vars (*,10) - -if(catch_model) then begin - plot_mosaic, ntiles, OutDir + 'plots/', tileid_plot, fix(plot_vars (*,3)) -endif else begin - plot_carbon, ntiles, OutDir + 'plots/', tileid_plot, fix(plot_vars (*,3:6)) -endelse - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro check_regrid_carbon - -; ********************************************************************************************************** -; STEP (1) Specify below: -; ----------------------- - -BCSDIR1 = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/SMAP_EASEv2_M09/' -GFILE1 = 'SMAP_EASEv2_M09_3856x1624' -OutDir1 = '/discover/nobackup/projects/gmao/ssd/land/l_data/LandRestarts_for_Regridding/CatchCN/M09/20151231/' -int_rst1 = 'catchcn_internal_rst' - -BCSDIR2 = '/discover/nobackup/smahanam/bcs/Heracles-4_3/Heracles-4_3_MERRA-3/CF0180x6C_DE1440xPE0720/' -GFILE2 = 'CF0180x6C_DE1440xPE0720-Pfafstetter' -OutDir2 = '' -int_rst2 = 'catchcn_internal_rst' - -; STEP (2) save : -; --------------- -; On dali : (a) module load tool/idl-8.5, (b) idl (c) .compile chk_restarts -; and (d) plot_rst - -; ********************************************************************************************************** - -; Setting up and select variables for plotting -; -------------------------------------------- -Var_Names = [ $ - 'CDCR2' , $ ; 0 - 'BEE' , $ ; 1 - 'POROS' , $ ; 2 - 'ITY1' , $ ; 3 - 'ITY2' , $ ; 4 - 'ITY3' , $ ; 5 - 'ITY4' , $ ; 6 - 'TC1' , $ ; 7 - 'TC2' , $ ; 8 - 'TC3' , $ ; 9 - 'TC4' , $ ;10 - 'CATDEF' , $ ;11 - 'RZEXC' , $ ;12 - 'SFEXC' ] -NC_plot = 4320 -NR_plot = 2160 - -;goto, jump - -for resol = 1,2 do begin - -if(resol eq 1) then begin - BCSDIR = BCSDIR1 - TILFILE = BCSDIR1 + 'til/' + GFILE1 + '.til' - RSTFILE = BCSDIR1 + 'rst/' + GFILE1 + '.rst' -endif else begin - BCSDIR = BCSDIR2 - TILFILE = BCSDIR2 + 'til/' + GFILE2 + '.til' - RSTFILE = BCSDIR2 + 'rst/' + GFILE2 + '.rst' -endelse - - -NTILES = 0l -NG = 0l -NC = 0l -NR = 0l - -openr,1,BCSDIR + 'clsm/catchment.def' -readf,1,NTILES -close,1 - -openr,1,TILFILE -readf,1,NG,NC,NR -close,1 -; Set up vector to grid for plotting -; ---------------------------------- - - - -tileid_plot = lonarr (NC_plot,NR_plot) - -dx = NC/NC_plot -dy = NR/NR_plot - -catrow = lonarr(nc) -cat = lonarr(nc,dy) - -openr,1,RSTFILE,/F77_UNFORMATTED - -for j = 0l, NR_plot -1 do begin - - for i=0,dy -1 do begin - readu,1,catrow - cat (*,i) = catrow - endfor - - for i = 0, NC_plot -1 do begin - subset = cat (i*dx: (i+1)*dx -1,*) - if (min (subset) le NTILES) then begin - min1 = min(subset) - subset(where (subset gt NTILES)) = 0 - hh = histogram(subset,bin=1,min = min1, locations=loc_val) - dom_tile = max(hh,loc) - tileid_plot[i,j] = loc_val(loc) - endif - endfor - -endfor - -close,1 -if (resol eq 1) then begin - tileid_plot1 = tileid_plot - NTILES1 = NTILES -endif else begin - tileid_plot2 = tileid_plot - NTILES2 = NTILES -endelse -endfor - -cnpft1 = fltarr (ntiles1, 888) -cnpft2 = fltarr (ntiles2, 888) -fvg1 = fltarr (ntiles1, 4) -fvg2 = fltarr (ntiles2, 4) -ncid = NCDF_OPEN(OutDir1 + int_rst1,/NOWRITE) -NCDF_VARGET, ncid,'TILE_ID' ,TILE_ID -NCDF_VARGET, ncid,'CNPFT' ,CNPFT1 -NCDF_VARGET, ncid,'FVG' ,fvg1 -TILE_ID = long (TILE_ID) - 1l - -CNPFT=CNPFT1 -FVG =FVG1 - -for k =0l,n_elements (CNPFT1(*,0)) -1l do CNPFT1(TILE_ID(k),*) = CNPFT(k,*) -for k =0l,n_elements (FVG1 (*,0)) -1l do FVG1 (TILE_ID(k),*) = FVG (k,*) - -CNPFT=0. -FVG =0. -NCDF_CLOSE, ncid - -ncid = NCDF_OPEN(OutDir2 + int_rst2,/NOWRITE) -NCDF_VARGET, ncid,'CNPFT' ,CNPFT2 -NCDF_VARGET, ncid,'FVG' ,fvg2 -NCDF_CLOSE, ncid -save,NTILES1,NTILES2,tileid_plot1,tileid_plot2,CNPFT1,CNPFT2, fvg1, fvg2,file = 'temp_file.idl' -;stop - -jump: - -restore,'temp_file.idl' - -; Plotting -; -------- - -spawn, 'mkdir -p plots' -load_colors -limits = [-60,-180,90,180] - -plot_varid = 14 -cnpft1 = reform ( cnpft1,[ntiles1,3,4,74],/overwrite) -cnpft2 = reform ( cnpft2,[ntiles2,3,4,74],/overwrite) - -for iv = 1,4 do begin - -plot_vars1 = cnpft1(*,0,iv - 1,plot_varid-1) -plot_vars2 = cnpft2(*,0,iv - 1,plot_varid-1) - - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,1000], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -plot_2maps, ntiles1, tileid_plot1, plot_vars1(*), [min([PLOT_VARS1,plot_vars2],/nan),max([PLOT_VARS1,plot_vars2],/nan)], string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)') -plot_2maps, ntiles2, tileid_plot2, plot_vars2(*), [min([PLOT_VARS1,plot_vars2],/nan),max([PLOT_VARS1,plot_vars2],/nan)], string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)'),advance =1 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, 'plots/pft_'+ string(plot_varid,'(i2.2)')+'_v' + string(iv,'(i1.1)') +'.jpg', image24, True=1, Quality=100 -endfor -fvg1(where (fvg1 le 1.e-4)) = !VALUES.F_NAN -fvg2(where (fvg2 le 1.e-4)) = !VALUES.F_NAN - -plot_fr, NTILES1, tileid_plot1,'plots/offl_', fvg1 (*,0), fvg1 (*,1), fvg1 (*,2), fvg1 (*,3) - -plot_fr, NTILES2, tileid_plot2,'plots/agcm_', fvg2 (*,0), fvg2 (*,1), fvg2 (*,2), fvg2 (*,3) - -end -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_2maps, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title =vname -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title =vname -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -levels_x = levels - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f7.2)' -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -!P.position=0 - -END - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_fr, ncat, tile_id,out_path, VISDR, VISDF, NIRDR, NIRDF - -load_colors -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = 0. -upval = 1. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'PF1' - if (map eq 2) then ctitle = 'PF2' - if (map eq 3) then ctitle = 'SF1' - if (map eq 4) then ctitle = 'SF2' - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - if(map eq 3) then begin - !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f6.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, out_path +'FR.jpg', image24, True=1, Quality=100 - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro load_colors - -R = intarr (256) -G = intarr (256) -B = intarr (256) - -R (*) = 255 -G (*) = 255 -B (*) = 255 - -r_drought = [0, 0, 0, 0, 47, 200, 255, 255, 255, 255, 249, 197] -g_drought = [0, 115, 159, 210, 255, 255, 255, 255, 219, 157, 0, 0] -b_drought = [0, 0, 0, 0, 67, 130, 255, 0, 0, 0, 0, 0] - -colors = indgen (11) + 1 -R (0:11) = r_drought -G (0:11) = g_drought -B (0:11) = b_drought - -r_green = [200, 150, 47, 60, 0, 0, 0, 0] -g_green = [255, 255, 255, 230, 219, 187, 159, 131] -b_green = [200, 150, 67, 15, 0, 0, 0, 0] - -r_blue = [ 55, 0, 0, 0, 0, 0, 0, 0, 0, 0] -g_blue = [255, 255, 227, 195, 167, 115, 83, 0, 0, 0] -b_blue = [199, 255, 255, 255, 255, 255, 255, 255, 200, 130] - -r_red = [255, 240, 255, 255, 255, 255, 255, 233, 197] -g_red = [255, 255, 219, 187, 159, 131, 51, 23, 0] -b_red = [153, 15, 0, 0, 0, 0, 0, 0, 0] - -r_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -g_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] -b_grey = [245, 225, 205, 185, 165, 145, 125, 105, 85] - -r_type = [255,106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_type = [245, 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_type = [215,154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] - -R (20:27) = r_green -G (20:27) = g_green -B (20:27) = b_green - -R (30:39) = r_blue -G (30:39) = g_blue -B (30:39) = b_blue - -R (40:48) = r_red -G (40:48) = g_red -B (40:48) = b_red - -R (50:58) = r_grey -G (50:58) = g_grey -B (50:58) = b_grey - -R (60:80) = r_type -G (60:80) = g_type -B (60:80) = b_type - -TVLCT,R ,G ,B - -end - -;_____________________________________________________________________ -;_____________________________________________________________________ - -PRO plot_6maps, ncat, tile_id, data, vlim, vname,advance = advance - -lwval = vlim(0) -upval = vlim(1) -if (vname eq 'SOILDEPTH') then upval = 5000. - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -data_grid = fltarr (im,jm) -data_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - -if(vname eq 'POROS') then $ -levels = [lwval,lwval+(0.57-lwval)/(n_levels -2) +indgen(n_levels -2)*(0.57-lwval)/(n_levels -2),upval] - -if keyword_set (advance) then begin - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title =vname -endif else begin -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title =vname -endelse - -contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -levels_x = levels - -if(vname eq 'POROS') then begin -dxp = (0.8-0.37)/16. -levels_x = indgen(17)*dxp+ 0.37 -endif - -alpha=fltarr(n_levels,2) -alpha(*,0)=levels -alpha(*,1)=levels -h=[0,1] - -dx = (240.)/(n_levels-1) - -clev = levels -clev (*) = 1 -n=0 -k = 0 -fmt_string = '(f7.2)' - -if(vname eq 'CDCR2' ) then !P.position=[0.064, 0.675, 0.41, 0.69] -if(vname eq 'BEE' ) then !P.position=[0.58, 0.675, 0.92, 0.69] -if(vname eq 'POROS' ) then !P.position=[0.064, 0.345, 0.41, 0.36] -if(vname eq 'CATDEF') then !P.position=[0.58, 0.345, 0.92, 0.36] -if(vname eq 'RZEXC' ) then !P.position=[0.064, 0.015, 0.41, 0.03] -if(vname eq 'SFEXC' ) then !P.position=[0.58, 0.015, 0.92, 0.03] - -;!P.position=[0.064, 0.675, 0.41, 0.69] -;!P.position=[0.58, 0.0+0.005, 0.92, 0.015+0.005] - -contour,alpha,levels_x,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels_x,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels_x[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - -;for l = 0,n_levels -2 do begin -; k = l -; xbox = [-120. + k*dx,-120. + k*dx, -120. + (k+1)*dx, -120. + (k+1)*dx,-120. + k*dx] -; ybox = [-65., -55.,-55.,-65.,-65.] -; polyfill, xbox,ybox,color=colors [k] -; -; xyouts,xbox[1],ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -; k = k + 1 -;endfor -; -;l = n_levels -1 -;xyouts,-120. + l*dx,ybox[2]+0.05,string(levels[l],format=fmt_string),color =0, orientation =90,charsize =0.8 -!P.position=0 - -END -;_____________________________________________________________________ -;_____________________________________________________________________ - -pro plot_tc, ncat, tile_id,out_path, VISDR, VISDF, NIRDR, NIRDF - -load_colors -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[720,500], Z_Buffer=0 -Erase,255 -!p.background = 255 - -!P.position=0 -!P.Multi = [0, 2, 2, 0, 0] -limits = [-60,-180,90,180] - -lwval = min ([min(VISDR), min(VISDF), min(NIRDR), min(NIRDF)]) -upval = max ([max(VISDR), max(VISDF), max(NIRDR), max(NIRDF)]) - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -colors = [27,26,25,24,23,22,21,20,40,41,42,43,44,45,46,47,48] -n_levels = n_elements (colors) - -for map = 1,4 do begin - - if (map eq 1) then data = VISDR - if (map eq 2) then data = VISDF - if (map eq 3) then data = NIRDR - if (map eq 4) then data = NIRDF - - if (map eq 1) then ctitle = 'TC1' - if (map eq 2) then ctitle = 'TC2' - if (map eq 3) then ctitle = 'TC3' - if (map eq 4) then ctitle = 'TC4' - - levels = [lwval,lwval+(upval-lwval)/(n_levels -1) +indgen(n_levels -1)*(upval-lwval)/(n_levels -1)] - - data_grid = fltarr (im,jm) - data_grid (*,*) = !VALUES.F_NAN - - for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then data_grid(i,j) = data(tile_id[i,j] -1) - endfor - endfor - - if(map eq 1) then begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ISOTROPIC,/NOBORDER, title = ctitle - endif else begin - MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/ADVANCE,/ISOTROPIC,/NOBORDER, title = ctitle - endelse - - contour, data_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - if(map eq 3) then begin - !P.position=[0.25, 0.05, 0.75, 0.075] - - alpha=fltarr(n_levels,2) - alpha(*,0)=levels - alpha(*,1)=levels - h=[0,1] - clev = levels - clev (*) = 1 - n=0 - k = 0 - fmt_string = '(f6.2)' - contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" - contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(colors) -1 do xyouts,levels[k],1.1,string(levels[k],format=fmt_string) ,orientation=90,color=0,charsize =0.8 - !P.position=0 - endif -endfor - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 720, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, out_path +'TC.jpg', image24, True=1, Quality=100 - -end -; ============================================================================== -; Mosaic classes -; ============================================================================== - -PRO plot_mosaic, ncat, outdir, tile_id, mos_type - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -mos_grid = intarr (im,jm) -mos_grid (*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then mos_grid(i,j) = mos_type(tile_id[i,j] -1) - endfor -endfor - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,500], Z_Buffer=0 - -r_in = [233,255,255,255,210, 0, 0, 0,204,170,255,220,205, 0, 0,170, 0, 40,120,140,190,150,255,255, 0, 0, 0,195,255, 0,255, 0] -g_in = [ 23,131,191,255,255,255,155, 0,204,240,255,240,205,100,160,200, 60,100,130,160,150,100,180,235,120,150,220, 20,245, 70,255, 0] -b_in = [ 0, 0, 0,178,255,255,255,200,204,240,100,100,102, 0, 0, 0, 0, 0, 0, 0, 0, 0, 50,175, 90,120,130, 0,215,200,255, 0] -vtypes =[ 1, 2, 3, 4, 5, 6, 7, 8, 10, 11, 14, 20, 30, 40, 50, 60, 70, 90,100,110,120,130,140,150,160,170,180,190,200,210,220,230] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 1, 0, 1] -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, mos_grid,x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -mos_name = strarr(6) -mos_name( 0) = 'BL Evergreen' -mos_name( 1) = 'BL Deciduous' -mos_name( 2) = 'Needleleaf' -mos_name( 3) = 'Grassland' -mos_name( 4) = 'BL Shrubs' -mos_name( 5) = 'Dwarf' - -n_levels = 6;n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels [0:n_levels-1] -alpha(*,1)=levels [0:n_levels-1] -h=[0,1] -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels[0:5],h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[1,7], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels[0:5],h,levels=levels,color=0,/overplot,c_label=clev -for k = 0,5 do xyouts,levels[k]+0.5,1.2,mos_name[k] ,orientation=90,color=0 - -snapshot = TVRD() -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 500) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, outdir + '/mosaic_prim.jpg', image24, True=1, Quality=100 - - -END -; ============================================================================== -; CLM-Carbon classes -; ============================================================================== - -PRO plot_carbon,ncat, OutDir, tile_id, clm_type - -im = n_elements(tile_id[*,0]) -jm = n_elements(tile_id[0,*]) - -dx = 360. / im -dy = 180. / jm - -x = indgen(im)*dx -180. + dx/2. -y = indgen(jm)*dy -90. + dy/2. - -clm_grid = intarr (im,jm,4) - -clm_grid (*,*,*) = !VALUES.F_NAN - -for j = 0l, jm -1l do begin - for i = 0l, im -1 do begin - if(tile_id[i,j] gt 0) then begin - clm_grid(i,j,0) = clm_type(tile_id[i,j] -1,0) - clm_grid(i,j,1) = clm_type(tile_id[i,j] -1,1) - clm_grid(i,j,2) = clm_type(tile_id[i,j] -1,2) - clm_grid(i,j,3) = clm_type(tile_id[i,j] -1,3) - endif - endfor -endfor - -clm_type = 0 - -limits = [-60,-180,90,180] -if file_test ('limits.idl') then restore,'limits.idl' - -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 -;types= [ 2, 3, 4, 5, 6, 7, 8, 9, 10, 11,11a, 12, 13, 14,14a, 15,15a, 16,16a, 17] -r_in = [106,202,251, 0, 29, 77,109,142,233,255,255,255,127,164,164,217,217,204,104, 0] -g_in = [ 91,178,154, 85,115,145,165,185, 23,131,131,191, 39, 53, 53, 72, 72,204,104, 70] -b_in = [154,214,153, 0, 0, 0, 0, 13, 0, 0,200, 0, 4, 3,200, 1,200,204,200,200] -vtypes= [ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20] - -red = intarr (256) -green= intarr (256) -blue = intarr (256) - -red (255) = 255 -green(255) = 255 -blue (255) = 255 - -for k = 0, n_elements(vtypes) -1 do begin - red (vtypes(k)) = r_in (k) - green(vtypes(k)) = g_in (k) - blue (vtypes(k)) = b_in (k) -endfor - -TVLCT,red,green,blue - -colors = vtypes -levels = vtypes - -clm_name = strarr(19) -clm_name( 0) = 'NLEt' ; 1 needleleaf evergreen temperate tree -clm_name( 1) = 'NLEB' ; 2 needleleaf evergreen boreal tree -clm_name( 2) = 'NLDB' ; 3 needleleaf deciduous boreal tree -clm_name( 3) = 'BLET' ; 4 broadleaf evergreen tropical tree -clm_name( 4) = 'BLEt' ; 5 broadleaf evergreen temperate tree -clm_name( 5) = 'BLDT' ; 6 broadleaf deciduous tropical tree -clm_name( 6) = 'BLDt' ; 7 broadleaf deciduous temperate tree -clm_name( 7) = 'BLDB' ; 8 broadleaf deciduous boreal tree -clm_name( 8) = 'BLEtS' ; 9 broadleaf evergreen temperate shrub -clm_name( 9) = 'BLDtS' ; 10 broadleaf deciduous temperate shrub [moisture + deciduous] -clm_name(10) = 'BLDtSm'; 11 broadleaf deciduous temperate shrub [moisture stress only] -clm_name(11) = 'BLDBS' ; 12 broadleaf deciduous boreal shrub -clm_name(12) = 'AC3G' ; 13 arctic c3 grass -clm_name(13) = 'CC3G' ; 14 cool c3 grass [moisture + deciduous] -clm_name(14) = 'CC3Gm' ; 15 cool c3 grass [moisture stress only] -clm_name(15) = 'WC4G' ; 16 warm c4 grass [moisture + deciduous] -clm_name(16) = 'WC4Gm' ; 17 warm c4 grass [moisture stress only] -clm_name(17) = 'CROP' ; 18 crop [moisture + deciduous] -clm_name(18) = 'CROPm' ; 19 crop [moisture stress only] - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,0],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,1],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(vtypes) -2 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + '/CLM-Carbon_PRIM_veg_typs.jpg', image24, True=1, Quality=100 - -; now plotting secondary -thisDevice = !D.Name -set_plot,'Z' -Device, Set_Resolution=[700,1000], Z_Buffer=0 - -Erase,255 -!p.background = 255 -!P.position=0 -!P.Multi = [0, 1, 2, 0, 1] - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits -contour, clm_grid[*,*,2],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -MAP_SET,/CYLINDRICAL,/hires,color= 0,/NoErase,limit=limits,/advance -contour, clm_grid[*,*,3],x,y,levels = levels,c_colors=colors,/cell_fill,/overplot - -n_levels = n_elements(vtypes) -alpha=fltarr(n_levels,2) -alpha(*,0)=levels (0:n_levels-1) -alpha(*,1)=levels (0:n_levels-1) -h=[0,1] - -!P.position=[0.30, 0.0+0.005, 0.70, 0.015+0.005] -clev = levels -clev (*) = 1 -contour,alpha,levels,h,levels=levels,c_colors=colors,/fill,/xstyle,/ystyle, $ - /noerase,yticks=1,ytickname=[' ',' '] ,xrange=[min(levels),max(levels)], $ - xtitle=' ', color=0,xtickv=levels, $ - C_charsize=1.0, charsize=0.5 ,xtickformat = "(A1)" -contour,alpha,levels,h,levels=levels,color=0,/overplot,c_label=clev - for k = 0,n_elements(vtypes) -2 do xyouts,levels[k]+0.5,1.1,clm_name(k) ,orientation=90,color=0 -snapshot = TVRD() - -TVLCT, r, g, b, /Get -Device, Z_Buffer=1 -Set_Plot, thisDevice -image24 = BytArr(3, 700, 1000) -image24[0,*,*] = r[snapshot] -image24[1,*,*] = g[snapshot] -image24[2,*,*] = b[snapshot] -Write_JPEG, OutDir + '/CLM-Carbon_SEC_veg_typs.jpg', image24, True=1, Quality=100 - -END diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart deleted file mode 100755 index 0aa20db94a..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/csh - -setenv ARCH `uname` -setenv LANDIR /land/l_data/geos5/bcs/SiB2_V2 -setenv HOMDIR /home1/ltakacs/catchment/ -setenv WRKDIR $HOMDIR/wrk -cd $WRKDIR -/bin/rm mk_catch_restart.x - - -setenv old_rslv 540x361 -setenv old_dateline DC -setenv old_tilefile FV_540x361_DC_360x180_DE.til -setenv old_restart d500_eros_01.catch_internal_rst.20060529_21z.bin - -setenv new_rslv 1080x721 -setenv new_tilefile FV_1080x721_DC_360x180_DE.til -setenv new_dateline DC - - -if( $ARCH == 'IRIX64' ) then - f90 -o mk_catch_restart.x -g $HOMDIR/mk_catch_restart.F90 -endif - -if( $ARCH == 'OSF1' ) then - f90 -o mk_catch_restart.x -g -convert big_endian -assume byterecl $HOMDIR/mk_catch_restart.F90 -endif - -./mk_catch_restart.x diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 deleted file mode 100755 index 4b54e203af..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_catch_restart.F90 +++ /dev/null @@ -1,859 +0,0 @@ -PROGRAM mk_catch_internal -implicit none - -integer :: im_gcm_old, jm_gcm_old -integer :: im_ocn_old, jm_ocn_old -integer :: im_gcm_new, jm_gcm_new -integer :: im_ocn_new, jm_ocn_new -integer :: ntiles_old, ntiles_new -integer :: nland_old, nland_new - -integer qtile -parameter ( qtile = 45848 ) - -real, allocatable :: lats_old(:), lats_new(:), lats_tmp(:) -real, allocatable :: lons_old(:), lons_new(:), lons_tmp(:) -integer, allocatable :: ii_old(:), ii_new(:), ii_tmp(:) -integer, allocatable :: jj_old(:), jj_new(:), jj_tmp(:) -real, allocatable :: fr_old(:), fr_new(:), fr_tmp(:) -integer, allocatable :: typ_tmp(:) - -character*20 :: version1, version2 -character*400 :: landir,wrkdir, old_tilefile, new_tilefile, arch, flag -character*400 :: old_rslv, old_dateline, oldtilnam -character*400 :: new_rslv, new_dateline, newtildir, newtilnam -character*400 :: old_restart, new_restart, sarithpath, home -character*400 :: maxtilnam, maxtildir, logfile -character*400 :: old_diag_grids, new_diag_grids - -logical :: maxoldtoggle, twotiles -integer :: ierr, indr1, indr2, indr3, ig, jg, indx_dum, ip1, ip2 -real :: fr_ocn, rdum -integer :: dum,n,nn,nta,v,loc,idum -character*4 :: bak=char(8)//char(8)//char(8)//char(8) -real, allocatable :: oldprogvars(:,:), oldparmvars(:,:), oldallvars(:,:) -real, allocatable :: newallvars(:,:) -real, allocatable :: oldvargrids(:,:,:) -real, allocatable :: newvargrids(:,:,:), dumtile(:,:), dumgrid(:,:) -real, allocatable :: tiletilevar(:,:), tilevar(:) -integer :: numrecs, allrecs, numparmrecs, numsubtiles -logical, allocatable :: ttlookup(:) -integer, allocatable :: corners_lookup(:,:) -real, allocatable :: weights_lookup(:,:) -real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) -real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) -real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) -real, allocatable :: ARS1(:), ARS2(:), ARS3(:) -real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) -real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) -real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) -real, allocatable :: ATAU2(:), BTAU2(:), ITY0(:) -integer, allocatable :: ity_int(:) -integer :: ity2, nmin -real :: frc1, frc2, dmin, dist -real, allocatable :: DP2BR(:), tmp_wgt(:,:), tmp_sum(:,:) -real :: zdep1, zdep2, zdep3, zmet, term1, term2 -integer :: catindex21, catindex22, catindex23 -integer :: catindex24, catindex25, catindex26 -integer :: catid, checksum -integer :: ii0, jj0, i,j -real :: fr0, val0, ESMF_MISSING -real :: lata, latb,lona, lonb, vaa, vbb, vab, vba -real :: lat00_old, lon00_old, dx_old, dy_old -real :: lonIM_old, lon0, lat0, d1,d2,d3,d4 -integer :: ia, ib, ja, jb -real :: waa, wab, wba, wbb, wsum, tol, tempval -!real :: mindist, olddist, thislat, thislon - -! ------------------------------------------------------------------------------- -! Strategy: -! 1. Read in the "old" .til definition file -! 2. Read in the "new" .til definition file -! 3. Read in the "old" restart from a previous run -! 4. Read in Sarith's tilespace catchment parameters -! 5. Convert the prognostic variables from the old restart -! to the new catchment definitions -! a. Create aggregate imxjm grid of progs from old restart -! b. Create reasonable interolated values based on centroids -! in the new .til definitions file. -! 6. Write the restart using stored values -! ------------------------------------------------------------------------------- - -! user parameters -! --------------- - - call getenv ('ARCH' ,arch ) - call getenv ('LANDIR' ,landir ) - call getenv ('WRKDIR' ,wrkdir ) - - call getenv ('old_rslv' ,old_rslv ) - call getenv ('old_dateline',old_dateline) - call getenv ('old_tilefile',old_tilefile) - call getenv ('old_restart' ,old_restart ) - - call getenv ('new_rslv' ,new_rslv ) - call getenv ('new_dateline',new_dateline) - call getenv ('new_tilefile',new_tilefile) - - if( ARCH == 'OSF1' ) flag = 'no' - if( ARCH == 'IRIX64' ) flag = 'yes' - -old_restart = trim(wrkdir) // '/' // trim(old_restart) -new_restart = trim(old_restart) // '.' // trim(new_rslv) // '_' // trim(new_dateline) - sarithpath = trim(landir) // '/' - -numsubtiles = 4 -numrecs = 61 ! number of records in the restart (includes tiletile vars) -numparmrecs = 30 ! number of parameters at the beginning of restart - -allrecs = numrecs + 7*3 ! all records, with tile-tile prognostic variables expanded - -allocate(ttlookup(numrecs)) -ttlookup(:) = .false. ! ttlookup specifies which records in restart are tile-tile -ttlookup(31:32) = .true. ! or tileonly (.false.=tileonly) -ttlookup(53:56) = .true. -ttlookup(61) = .true. - -twotiles=.false. ! set this to true to force a two tile test -ESMF_MISSING=-999.0 ! missing value in old restart prognostic variables -tol=1.0E-6 -logfile='mk_catch_restart.log' - -old_diag_grids = 'old_grids.dat' -new_diag_grids = 'new_grids.dat' - -! ------------------------------------------------------------------------------- -! 1. Read in the old .til file and store the I, J, FR's -! ------------------------------------------------------------------------------- - -newtildir = trim(sarithpath) // trim(new_dateline) // '/FV_' // trim(new_rslv) - -oldtilnam = trim(wrkdir) // '/' // trim(old_tilefile) -newtilnam = trim(wrkdir) // '/' // trim(new_tilefile) -print *, 'newtilenam1 = ',newtilnam -!newtilnam = trim(newtildir) // '/FV_' // trim(new_rslv) //'_'//trim(new_dateline)//'_360x180_DE_NO_TINY.til' -!newtilnam = trim(newtildir) // '/FV_' // trim(new_rslv) //'_'//trim(new_dateline)//'_576x540_DE_NO_TINY.til' -print *, 'newtilenam2 = ',newtilnam - -open(9, file=trim(logfile),action='write',form='formatted') - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading source (old) tile definitions from:' -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading source (old) tile definitions from:' -write (9,*) trim(oldtilnam) -write (*,*) trim(oldtilnam) - -open (10,file=trim(oldtilnam),status='old', action='read',form='formatted') -read (10,*) ntiles_old -read (10,*) dum -read (10,'(a)')version1 -read (10,*)im_gcm_old -read (10,*)jm_gcm_old -read (10,'(a)')version2 -read (10,*) im_ocn_old -read (10,*) jm_ocn_old -write(9,*) 'Header: ', ntiles_old, dum, trim(version1), im_gcm_old, jm_gcm_old, & - trim(version2), im_ocn_old, jm_ocn_old - -allocate(lats_tmp(ntiles_old)) -allocate(lons_tmp(ntiles_old)) -allocate( fr_tmp(ntiles_old)) -allocate( ii_tmp(ntiles_old)) -allocate( jj_tmp(ntiles_old)) -allocate( typ_tmp(ntiles_old)) - -write(*, 40, advance=trim(flag)) -nland_old=0 -do n = 1,ntiles_old - read(10,'(i10,i9,2f10.4,2i5,f10.6,3i8,f10.6,i8)',IOSTAT=ierr)typ_tmp(n),& - indr1,lons_tmp(n),lats_tmp(n),ii_tmp(n),jj_tmp(n),fr_tmp(n),indx_dum,indr2,dum,fr_ocn,indr3 - if (typ_tmp(n) == 100) then - ip2=n - nland_old=nland_old+1 - endif - if (typ_tmp(n) == 0) then - ip1=n - endif - if(ierr /= 0) write (*,*) 'Problem reading' - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(ntiles_old)*100) -end do -close (10,status='keep') - -write(9,*) 'Last ocean index:', ip1 -write(9,*) 'Last land index:', ip2 -write(9,*) 'NTILES LAND:', nland_old -write(*,*) - -!write(*,*) 'Packing land coordinate arrays...' - -allocate ( lats_old(nland_old) ) -allocate ( lons_old(nland_old) ) -allocate ( fr_old(nland_old) ) -allocate ( ii_old(nland_old) ) -allocate ( jj_old(nland_old) ) - -lats_old = pack(lats_tmp, mask=typ_tmp .eq. 100) -lons_old = pack(lons_tmp, mask=typ_tmp .eq. 100) - fr_old = pack( fr_tmp, mask=typ_tmp .eq. 100) - ii_old = pack( ii_tmp, mask=typ_tmp .eq. 100) - jj_old = pack( jj_tmp, mask=typ_tmp .eq. 100) - -write(9,*) 'lats', size(lats_old), minval(lats_old), maxval(lats_old) -write(9,*) 'lons', size(lons_old), minval(lons_old), maxval(lons_old) -write(9,*) 'fr ', size (fr_old), minval (fr_old), maxval (fr_old) -write(9,*) 'ii ', size (ii_old), minval (ii_old), maxval (ii_old) -write(9,*) 'jj ', size (jj_old), minval (jj_old), maxval (jj_old) - -deallocate(lats_tmp) -deallocate(lons_tmp) -deallocate( fr_tmp) -deallocate( ii_tmp) -deallocate( jj_tmp) -deallocate( typ_tmp) - -! ------------------------------------------------------------------------------- -! 2. Read in the new .til file and store the I, J, FR's -! ------------------------------------------------------------------------------- - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading source (new) tile definitions from:' -write (*,*) trim(newtilnam) -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading source (new) tile definitions from:' -write (9,*) trim(newtilnam) - -open (10,file=trim(newtilnam),status='old',action='read',form='formatted') -read (10,*) ntiles_new -read (10,*) dum -read (10,'(a)')version1 -read (10,*)im_gcm_new -read (10,*)jm_gcm_new -read (10,'(a)')version2 -read (10,*) im_ocn_new -read (10,*) jm_ocn_new -write(9,*) 'Header: ', ntiles_new, dum, trim(version1), im_gcm_new, jm_gcm_new, & - trim(version2), im_ocn_new, jm_ocn_new - -allocate ( lats_tmp(ntiles_new) ) -allocate ( lons_tmp(ntiles_new) ) -allocate ( fr_tmp(ntiles_new) ) -allocate ( ii_tmp(ntiles_new) ) -allocate ( jj_tmp(ntiles_new) ) -allocate ( typ_tmp(ntiles_new) ) - - write(*, 40, advance=trim(flag)) -nland_new=0 -do n = 1,ntiles_new - read(10,'(i10,i9,2f10.4,2i5,f10.6,3i8,f10.6,i8)',IOSTAT=ierr)typ_tmp(n),& - indr1,lons_tmp(n),lats_tmp(n),ii_tmp(n),jj_tmp(n),fr_tmp(n),indx_dum,indr2,dum,fr_ocn,indr3 - if (typ_tmp(n) == 100) then - ip2=n - nland_new=nland_new+1 - endif - if (typ_tmp(n) == 0) then - ip1=n - endif - if(ierr /= 0) write (*,*) 'Problem reading' - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(ntiles_new)*100) -end do -close (10,status='keep') - -write(9,*) 'Last ocean index:', ip1 -write(9,*) 'Last land index:', ip2 -write(9,*) 'NTILES LAND:', nland_new -write(*,*) - -allocate ( lats_new(nland_new) ) -allocate ( lons_new(nland_new) ) -allocate ( fr_new(nland_new) ) -allocate ( ii_new(nland_new) ) -allocate ( jj_new(nland_new) ) - -lats_new = pack(lats_tmp, mask=typ_tmp .eq. 100) -lons_new = pack(lons_tmp, mask=typ_tmp .eq. 100) - fr_new = pack( fr_tmp, mask=typ_tmp .eq. 100) - ii_new = pack( ii_tmp, mask=typ_tmp .eq. 100) - jj_new = pack( jj_tmp, mask=typ_tmp .eq. 100) - -write(9,*) 'lats', size(lats_new), minval(lats_new), maxval(lats_new) -write(9,*) 'lons', size(lons_new), minval(lons_new), maxval(lons_new) -write(9,*) 'fr ', size(fr_new), minval(fr_new), maxval(fr_new) -write(9,*) 'ii ', size(ii_new), minval(ii_new), maxval(ii_new) -write(9,*) 'jj ', size(jj_new), minval(jj_new), maxval(jj_new) - -deallocate(lats_tmp) -deallocate(lons_tmp) -deallocate( fr_tmp) -deallocate( ii_tmp) -deallocate( jj_tmp) -deallocate( typ_tmp) - -! ------------------------------------------------------------------------------- -! 3. Read in the old restart from a previous run -! Here, I separate the parameters and prognostic variables. Some of the -! prognostic variables are printed out by catch-finalize as var(ntiles, 4) -! This routine takes that into account, and I put the parameters and -! prognostics in separate arrays. Then, the parameters will be replaced by -! something Sarith makes, while the prognostics will be regridded. If you -! wish, you can also retain the soil parameters in the trivial case (eg. -! you want to keep same land specification but just adjust the initialization -! to a different date) -! ------------------------------------------------------------------------------- - -allocate(oldparmvars(nland_old, numparmrecs)) -allocate(oldprogvars(nland_old,allrecs-numparmrecs)) - -allocate( oldallvars(nland_old,allrecs)) -allocate(tiletilevar(nland_old, numsubtiles)) -allocate( tilevar(nland_old)) - -open(unit=30, file=trim(old_restart),form='unformatted') - -write (*,*) -write (*,*) '---------------------------------------------------------------------' -write (*,*) 'Reading old restart from:' -write (*,*) trim(old_restart) - -write (9,*) -write (9,*) '---------------------------------------------------------------------' -write (9,*) 'Reading '//trim(old_restart) -write (9,*) 'Sizes', size(tiletilevar), size(tilevar) - - write(*, 70, advance=trim(flag)) -open(unit=65, file='old_catch.dat' ,form='unformatted') - -nta=1 -do n=1, numrecs - if (ttlookup(n)) then - read(30) tiletilevar - do nn=1, numsubtiles - oldallvars(:,nta)=tiletilevar(:,nn) - write (65) tiletilevar(:,nn) ! Write Grads-Formatted Catchment File - nta=nta+1 - enddo - else - read(30) tilevar - oldallvars(:,nta)=tilevar(:) - write (65) tilevar(:) ! Write Grads-Formatted Catchment File - nta=nta+1 - endif - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(numrecs)*100) -enddo - -close(30) -deallocate(tiletilevar) -deallocate(tilevar) - -write(*,*) 'Separating parameter and prognostic variables' -write(9,*) 'Separating parameter and prognostic variables' - -do n=1, numparmrecs - oldparmvars(:,n)=oldallvars(:,n) -enddo -do n=1, allrecs-numparmrecs - oldprogvars(:,n)=oldallvars(:,n+numparmrecs) -end do - -loc = 0 -do n=1,numrecs - nta = 1 - if( ttlookup(n) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - if( loc.le.numparmrecs ) then - write(9,*) ' Transferred old parameter (',n,',',nn,') ', & - minval(oldallvars(:,loc)), maxval(oldallvars(:,loc)) - else - write(9,*) ' Transferred old prognostic (',n,',',nn,') ', & - minval(oldallvars(:,loc)), maxval(oldallvars(:,loc)) - endif - enddo -enddo - - -! ------------------------------------------------------------------------------- -! 4. Read in the soil parameter variables (there are 29 of them) from Sarith -! vegetation type is also read in here, from an old Aries format (this needs -! to be changed, so vegtype is in .til file!) -! ------------------------------------------------------------------------------- - -allocate ( BF1(nland_new), BF2 (nland_new), BF3(nland_new) ) -allocate (VGWMAX(nland_new), CDCR1(nland_new), CDCR2(nland_new) ) -allocate ( PSIS(nland_new), BEE(nland_new), POROS(nland_new) ) -allocate ( WPWET(nland_new), COND(nland_new), GNU(nland_new) ) -allocate ( ARS1(nland_new), ARS2(nland_new), ARS3(nland_new) ) -allocate ( ARA1(nland_new), ARA2(nland_new), ARA3(nland_new) ) -allocate ( ARA4(nland_new), ARW1(nland_new), ARW2(nland_new) ) -allocate ( ARW3(nland_new), ARW4(nland_new), TSA1(nland_new) ) -allocate ( TSA2(nland_new), TSB1(nland_new), TSB2(nland_new) ) -allocate ( ATAU2(nland_new), BTAU2(nland_new), DP2BR(nland_new) ) -allocate ( ITY0(nland_new), ity_int(nland_new)) - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Reading Sarith parameters from:' -write(9,*) trim(newtildir) -write(9,*) 'Sample output ... ' -write(*,*) 'Reading Sarith parameters from:' -write(*,*) trim(newtildir) -write(*,*) 'Sample output ... ' - -open(unit=21, file=trim(newtildir) // '/' //'mosaic_veg_typs_fracs',form='formatted') -open(unit=22, file=trim(newtildir) // '/' //'bf.dat' ,form='formatted') -open(unit=23, file=trim(newtildir) // '/' //'soil_param.dat' ,form='formatted') -open(unit=24, file=trim(newtildir) // '/' //'ar.new' ,form='formatted') -open(unit=25, file=trim(newtildir) // '/' //'ts.dat' ,form='formatted') -open(unit=26, file=trim(newtildir) // '/' //'tau_param.dat' ,form='formatted') - - write(*, 80, advance=trim(flag)) - -do n=1,nland_new -! read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2, rdum - read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2 ! version 2 doesnt have rdum variable - ITY0(n)=1.0*ity_int(n) - read (22, *) catindex22, catid, GNU(n), BF1(n), BF2(n), BF3(n) - read (23, *) catindex23, catid, idum, idum, BEE(n), PSIS(n), POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) catindex24, catid, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) catindex25, catid, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - read (26, *) catindex26, catid, ATAU2(n), BTAU2(n), rdum, rdum - - checksum=catindex21+catindex22+catindex23+catindex24+catindex25+catindex26-6*(n+ip1) - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - zdep1=20. - zmet=zdep3/1000. - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - VGWMAX(n)=POROS(n)*zdep2 - CDCR1(n)=1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n)=(1.-WPWET(n))*POROS(n)*zdep3 - if (checksum .ne. 0) then - write(9,*) 'Catchment id mismatch with following id list at n=', n - write(9,*) catindex22, catindex23, catindex24, catindex25, catindex26, ip1+n - write(*,*) 'Halted on catchment mismatch' - STOP - else - if (modulo(n, 1000).eq.1 .or. n.eq.qtile ) then - write(9,*) - write(9,*) n, 'mosaic_vegtype: ', ity_int(n) - write(9,*) n, 'bf.dat: ', catindex22, catid, GNU(n), BF1(n), BF2(n) - write(9,*) n, 'bf.dat: ', BF3(n) - write(9,*) n, 'soil_param.dat: ', catindex23, catid, rdum, BEE(n), PSIS(n) - write(9,*) n, 'soil_param.dat: ', POROS(n), COND(n), WPWET(n), DP2BR(n) - write(9,*) n, 'ar.dat: ', catindex24, catid, rdum, ARS1(n), ARS2(n) - write(9,*) n, 'ar.dat: ', ARS3(n), ARA1(n), ARA2(n), ARA3(n), ARA4(n) - write(9,*) n, 'ar.dat: ', ARW1(n), ARW2(n), ARW3(n), ARW4(n) - write(9,*) n, 'ts.dat: ', catindex25, catid, rdum, TSA1(n), TSA2(n) - write(9,*) n, 'ts.dat: ', TSB1(n), TSB2(n) - write(9,*) n, 'tau_param.dat: ', catindex26, catid, ATAU2(n), BTAU2(n) - write(9,*) n, 'Computed: ', VGWMAX(n), CDCR1(n), CDCR2(n) - end if - endif - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(nland_new)*100) -end do - -close (21) -close (22) -close (23) -close (24) -close (25) -close (26) - -! ------------------------------------------------------------------------------- -! 5. Regrid all variables to im_gcm_oldXjm_gcm_old grid -! Then, find interpolated values based upon the centroids of tiles in -! new .til definitions. Missing values: if a single tile is missing, -! it's influence on the gridded value is ignored, except if there are no -! non-missing values in an i,j cell, then the new tile is defined as missing -! -! Alternatives for future development: -! -! a. Nearest neighbor -! b. Nearest neighbor of same/similar vegetation type, latitude, etc. -! c. Gridding, ungridding (this is done currently) -! d. Krieging of some kind, pick a radius of influence and weigh by inverse -! square of distance, or limit to veg type, or whatever. -! -! ------------------------------------------------------------------------------- - -open(unit=8, file=trim(old_diag_grids),form='unformatted') - -allocate( tmp_sum(im_gcm_old,jm_gcm_old)) -allocate( tmp_wgt(im_gcm_old,jm_gcm_old)) -allocate(oldvargrids(im_gcm_old,jm_gcm_old,allrecs)) -allocate( dumgrid(im_gcm_old,jm_gcm_old)) - -loc = 0 -do v=1, numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - tmp_sum(:,:)=0.0 - tmp_wgt(:,:)=0.0 - do n=1, nland_old - val0=oldallvars(n,loc) - ii0=ii_old(n) - jj0=jj_old(n) - fr0=fr_old(n) - if (abs(val0-ESMF_MISSING) .gt. tol) then - tmp_sum(ii0,jj0) = tmp_sum(ii0,jj0) + fr0*val0 - tmp_wgt(ii0,jj0) = tmp_wgt(ii0,jj0) + fr0 - else - print *, 'Old_Catch_Val = ',val0,' n = ',n,' loc = ',loc - endif - enddo - do j=1,jm_gcm_old - do i=1,im_gcm_old - if (tmp_wgt(i,j) .gt. tol) then - oldvargrids(i,j,loc)=tmp_sum(i,j)/tmp_wgt(i,j) - else - oldvargrids(i,j,loc)=ESMF_MISSING - endif - dumgrid(i,j) =oldvargrids(i,j,loc) - enddo - enddo - write (8) dumgrid - enddo -enddo - -deallocate(dumgrid) -deallocate(tmp_sum) -deallocate(tmp_wgt) -close(8) - -allocate( corners_lookup(nland_new, 4) ) -allocate( weights_lookup(nland_new, 4) ) - -lat00_old = -90 - dx_old = (360.0)/ im_gcm_old - dy_old = (180.0)/(jm_gcm_old-1) - -if (old_dateline .eq. 'DC') then - lon00_old = -180 - lonIM_old = 180-dx_old -else - lon00_old = -180+0.5*dx_old - lonIM_old = 180-0.5*dx_old -end if - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Computing interpolation lookup table for new tiles' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Computing interpolation lookup table for new tiles' - write(*, 90, advance=trim(flag)) - -do n=1,nland_new - lat0=lats_new(n) ! latitude of tile centroid to find - lon0=lons_new(n) ! longitude of tile centroid - if ((lon0 .gt. lonIM_old) .or. (lon0 .lt. lon00_old)) then - ia=im_gcm_old - ib=1 - lona=lonIM_old - lonb=lon00_old - else - ia=floor((lon0-lon00_old)/dx_old)+1 - ib=ia+1 - lona=(ia-1)*dx_old+lon00_old - lonb=lona+dx_old - end if - ja=floor((lat0-lat00_old)/dy_old)+1 ! left bottom corner y coordinate - jb=ja+1 ! right top corner y coordinate - lata=(ja-1)*dy_old+lat00_old ! latitude of left bottom corner - latb=lata+dy_old - - if( ia.lt.1 .or. ia.gt.im_gcm_old .or. & - ib.lt.1 .or. ib.gt.im_gcm_old .or. & - ja.lt.1 .or. ja.gt.jm_gcm_old .or. & - jb.lt.1 .or. jb.gt.jm_gcm_old ) then - print *, 'Warning, bad indicies!' - print *, 'New Land variable: ',n,ia,ib,ja,jb - stop - endif - - if (modulo(n, 1000).eq.1 .or. n.eq.qtile) then - write (9,*) - write (9,*) n, lona, lon0, lonb, ia, ib - write (9,*) n, lata, lat0, latb, ja, jb - end if - corners_lookup(n,1)=ia - corners_lookup(n,2)=ib - corners_lookup(n,3)=ja - corners_lookup(n,4)=jb - waa=sqrt((lat0-lata)**2+(lon0-lona)**2) - wab=sqrt((lat0-lata)**2+(lon0-lonb)**2) - wba=sqrt((lat0-latb)**2+(lon0-lona)**2) - wbb=sqrt((lat0-latb)**2+(lon0-lonb)**2) - wsum=waa+wab+wba+wbb - weights_lookup(n,1)=waa - weights_lookup(n,2)=wab - weights_lookup(n,3)=wba - weights_lookup(n,4)=wbb - write(*, 50, advance=trim(flag)) bak, floor(float(n)/float(nland_new)*100) -end do - -allocate(newallvars(nland_new, allrecs)) -! new allvars allocated by number of new land tiles X number of total restart records -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Interpolating prognostic records to new tile definitions' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Interpolating prognostic records to new tile definitions' - write(*, 90, advance=trim(flag)) - write(*, 50, advance=trim(flag)) bak, 0 - -do v=31, allrecs - do n=1, nland_new - ia=corners_lookup(n,1) - ib=corners_lookup(n,2) - ja=corners_lookup(n,3) - jb=corners_lookup(n,4) - waa=weights_lookup(n,1) - wbb=weights_lookup(n,4) - wab=weights_lookup(n,2) - wba=weights_lookup(n,3) - wsum=0 - tempval=0 - vaa=oldvargrids(ia,ja, v) - vbb=oldvargrids(ib,jb, v) - vab=oldvargrids(ia,jb, v) - vba=oldvargrids(ib,ja, v) - if (abs(vaa-ESMF_MISSING) .gt. tol) then - tempval=tempval+vaa*waa - wsum=waa+wsum - end if - if (abs(vab-ESMF_MISSING) .gt. tol) then - tempval=tempval+vab*wab - wsum=wab+wsum - end if - if (abs(vba-ESMF_MISSING) .gt. tol) then - tempval=tempval+vba*wba - wsum=wsum+wba - end if - if (abs(vbb-ESMF_MISSING) .gt. tol) then - tempval=tempval+vbb*wbb - wsum=wsum+wbb - end if - if (abs(wsum) .lt. tol) then - dmin = 1e15 - nmin = 0 - do nn = 1,nland_old - dist = sqrt( (lats_old(nn)-lats_new(n))**2 & - + (lons_old(nn)-lons_new(n))**2 ) - if( dist.lt.dmin ) then - nmin = nn - dmin = dist - endif - enddo - tempval=oldallvars(nmin,v) ! Find nearest old tile to new tile - print *, 'NewVal = ',tempval,' nmin = ',nmin,' loc = ',v - print *, 'newlat = ',lats_new(n),' oldlat = ',lats_old(nmin) - print *, 'newlon = ',lons_new(n),' oldlon = ',lons_old(nmin) - print * - else - tempval=tempval/(1.0*wsum) - end if - newallvars(n, v)=tempval - if (modulo(n, 1000) .eq. 1) then - write(9,*) - write(9,*) n, 'Interpolation summary' - write(9,*) n, 'Weights:', waa, wab, wba, wbb - write(9,*) n, 'Values:', vaa, vab, vba, vbb - write(9,*) n, 'Results:', tempval, wsum - end if - end do - - write(*,*) v - write(*, 50, advance=trim(flag)) bak, floor((float(v-31)/float(allrecs-31)*100)) -end do - -! I am now finished with the old tiles, get rid of them -deallocate(oldprogvars, oldparmvars, oldallvars) -deallocate(corners_lookup, weights_lookup) - -! ------------------------------------------------------------------------------- -! 6. Create the restart from stored values -! a. 29 Sarith tilespace records from his parameter files -! b. The vegetation type from Sarith's mosaic_veg_typ_file -! (I have used the PRIMARY veg type for this work, as opposed -! to the second one that also has a fraction. I am assuming that -! the catchment fraction is totally composed of the PRIMARY veg type) -! c. The modified/regridded prognostic variables that have been regridded -! At this point, the variable newallvars contains ALL records for the -! restart, including estimates of Sarith's parameters based upon -! the old values interpolated from the old restart. These are skipped, but -! might be useful for comparison in a debugging situation -! ------------------------------------------------------------------------------- - -open(unit=41, file=trim(new_restart),form='unformatted') -open(unit=66, file='new_catch.dat' ,form='unformatted') - -! replace the old interpolated parameters in newallvars with the new Sarith ones - - write(9,*) ' Min/Max for ARS1: ', minval(ARS1), maxval(ARS1) - write(9,*) ' Min/Max for ARS2: ', minval(ARS2), maxval(ARS2) - write(9,*) ' Min/Max for ARS3: ', minval(ARS3), maxval(ARS3) - -newallvars(:,1)=BF1 -newallvars(:,2)=BF2 -newallvars(:,3)=BF3 -newallvars(:,4)=VGWMAX -newallvars(:,5)=CDCR1 -newallvars(:,6)=CDCR2 -newallvars(:,7)=PSIS -newallvars(:,8)=BEE -newallvars(:,9)=POROS -newallvars(:,10)=WPWET -newallvars(:,11)=COND -newallvars(:,12)=GNU -newallvars(:,13)=ARS1 -newallvars(:,14)=ARS2 -newallvars(:,15)=ARS3 -newallvars(:,16)=ARA1 -newallvars(:,17)=ARA2 -newallvars(:,18)=ARA3 -newallvars(:,19)=ARA4 -newallvars(:,20)=ARW1 -newallvars(:,21)=ARW2 -newallvars(:,22)=ARW3 -newallvars(:,23)=ARW4 -newallvars(:,24)=TSA1 -newallvars(:,25)=TSA2 -newallvars(:,26)=TSB1 -newallvars(:,27)=TSB2 -newallvars(:,28)=ATAU2 -newallvars(:,29)=BTAU2 -newallvars(:,30)=ITY0 - -write(*,*) -write(*,*) '---------------------------------------------------------------------' -write(*,*) 'Writing new restart' -write(9,*) -write(9,*) '---------------------------------------------------------------------' -write(9,*) 'Writing new restart' - -loc = 0 -do v=1,numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - allocate( dumtile(nland_new,nta) ) - do nn = 1,nta - loc = loc+1 - dumtile(:,nn) = newallvars(:,loc) - write (66) dumtile(:,nn) ! Write Grads-Formatted Catchment File - enddo - write (41) dumtile - write(9,*) 'NEW RESTART RECORD #', v , ' Size = ',size(dumtile) - deallocate ( dumtile ) -enddo -close(41) - -loc = 0 -do n=1,numrecs - nta = 1 - if( ttlookup(n) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - if( loc.le.numparmrecs ) then - write(9,*) ' Transferred new parameter (',n,',',nn,') ', & - minval(newallvars(:,loc)), maxval(newallvars(:,loc)) - else - write(9,*) ' Transferred new prognostic (',n,',',nn,') ', & - minval(newallvars(:,loc)), maxval(newallvars(:,loc)) - endif - enddo -enddo - - -! ------------------------------------------------------------------------------- -! 7. Save a gridded copy of the new restart on rectangular grid found in the -! new .til file definitions. This can be used to check the results. -! ------------------------------------------------------------------------------- - -open(unit=42, file=trim(new_diag_grids),form='unformatted') - -allocate( tmp_sum(im_gcm_new, jm_gcm_new)) -allocate( tmp_wgt(im_gcm_new, jm_gcm_new)) -allocate( dumgrid(im_gcm_new, jm_gcm_new)) - -loc = 0 -do v=1, numrecs - nta = 1 - if( ttlookup(v) ) nta = numsubtiles - do nn = 1,nta - loc = loc+1 - tmp_sum(:,:)=0.0 - tmp_wgt(:,:)=0.0 - do n=1, nland_new - val0=newallvars(n,loc) - ii0=ii_new(n) - jj0=jj_new(n) - fr0=fr_new(n) - if (abs(val0-ESMF_MISSING) .gt. tol) then - tmp_sum(ii0,jj0)=tmp_sum(ii0,jj0)+fr0*val0 - tmp_wgt(ii0,jj0)=tmp_wgt(ii0,jj0)+fr0 - endif - enddo - do i=1,im_gcm_new - do j=1,jm_gcm_new - if (tmp_wgt(i,j) .gt. tol) then - dumgrid(i,j)=tmp_sum(i,j)/tmp_wgt(i,j) - else - dumgrid(i,j)=ESMF_MISSING - endif - enddo - enddo - write (42) dumgrid - enddo -enddo -close(42) - -deallocate(tmp_sum) -deallocate(tmp_wgt) -deallocate( dumgrid ) - -deallocate(BF1, BF2, BF3, VGWMAX) -deallocate(CDCR1, CDCR2, PSIS, BEE) -deallocate(POROS, WPWET, COND, GNU) -deallocate(ARS1, ARS2, ARS3) -deallocate(ARA1, ARA2, ARA3) -deallocate(ARA4, ARW1, ARW2, ARW3, ARW4) -deallocate(TSA1, TSA2, TSB1, TSB2) -deallocate(DP2BR, ATAU2, BTAU2) -deallocate(ITY0, ity_int) - -deallocate(lats_old) -deallocate(lons_old) -deallocate(fr_old) -deallocate(ii_old) -deallocate(jj_old) -deallocate(lats_new) -deallocate(lons_new) -deallocate(fr_new) -deallocate(ii_new) -deallocate(jj_new) -deallocate(ttlookup) - -40 FORMAT(' Percent tile definitions read: ') -50 FORMAT(A4, I3.3, '%') -60 FORMAT(' Percent MODIS data read: ') -70 FORMAT(' Percent restart read: ') -80 FORMAT(' Percent Sarith catchment parameters read: ') -90 FORMAT(' Percent completed: ') -END diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart deleted file mode 100755 index 86e90e73ae..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart +++ /dev/null @@ -1,23 +0,0 @@ -#!/bin/csh - -setenv ARCH `uname` -setenv LANDIR /land/l_data/geos5/bcs/SiB2_V2 -setenv HOMDIR /home1/ltakacs/catchment -setenv WRKDIR $HOMDIR/wrk -cd $WRKDIR - -setenv rslv 1080x721 -setenv dateline DC -setenv nland 374925 # Note, check mk_catch LOG file for number of land tiles - - -if( $ARCH == 'IRIX64' ) then - f90 -o mk_vegdyn_restart.x $HOMDIR/mk_vegdyn_restart.F90 -endif - -if( $ARCH == 'OSF1' ) then - f90 -o mk_vegdyn_restart.x -convert big_endian -assume byterecl $HOMDIR/mk_vegdyn_restart.F90 -endif - -mk_vegdyn_restart.x - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 deleted file mode 100755 index 849e9f8e45..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/mk_vegdyn_restart.F90 +++ /dev/null @@ -1,54 +0,0 @@ -PROGRAM mk_vegdyn_internal -implicit none -real, allocatable :: dummy(:),ity0(:) -integer,allocatable :: ity0_int(:) -real :: filler, dum0 -integer :: vvv -integer :: bi,li -integer :: nland, nt, index, id, dum -character*256 outpath, sarithdir, dateline, restag, vegname, numland -character*256 landir - -!--------------------------------------------------------------------------- - call GETENV ( 'LANDIR' , landir ) - call GETENV ( 'rslv' , restag ) - call GETENV ( 'dateline', dateline ) - call GETENV ( 'nland' , numland ) - read(numland,*)nland - -outpath = 'vegdyn_internal_restart.' // trim(restag) // '_' // trim(dateline) -!--------------------------------------------------------------------------- - -allocate(dummy (nland)) -allocate(ity0 (nland)) -allocate(ity0_int(nland)) - -dummy(:)=-999.0 -sarithdir = trim(landir) // '/' // trim(dateline) // '/FV_' // trim(restag) // '/' -vegname = trim(sarithdir)//'mosaic_veg_typs_fracs' -write (*,*) 'Reading '//vegname - -open(unit=21, file=trim(vegname),form='formatted') -DO nt=1,nland -! read (21, *) index, id, ity0_int(nt), dum, dum0, dum0, dum0 - read (21, *) index, id, ity0_int(nt), dum, dum0, dum0 ! version 2 doesn't have frc3 - print *, ity0_int(nt) -ENDDO -ity0=ity0_int*1.0 -close(21) - - -open(unit=30, file=trim(outpath),form='unformatted') -! write out dummy lai_prev, lai_next, grn_prev, grn_next -print *, ' VEGTYPES', minval(ity0), maxval(ity0) -write (30) dummy -write (30) dummy -write (30) dummy -write (30) dummy -write (30) ity0 -close (30) -deallocate(ity0) -deallocate(ity0_int) -deallocate(dummy) -END - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl deleted file mode 100755 index b48983d75b..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/new_catch.ctl +++ /dev/null @@ -1,73 +0,0 @@ -dset wrk/new_catch.dat -options sequential template big_endian -undef -9999.0 -xdef 45147 linear 1 1 -ydef 1 linear 1 1 -zdef 4 linear 1 1 -tdef 1 linear jan1900 1mo -* -VARS 63 -var01 0 99 topo_baseflow_param_1 -var02 0 99 topo_baseflow_param_2 -var03 0 99 topo_baseflow_param_3 -var04 0 99 max_rootzone_water_content -var05 0 99 moisture_threshold -var06 0 99 max_water_content_unsat_zone -var07 0 99 saturated_matrix_potential -var08 0 99 clapp_hornberger_b -var09 0 99 soil_porosity -var10 0 99 wetness_at_wilting_point -var11 0 99 sfc_sat_hydraulic_conduct -var12 0 99 vertical_transmissivity -var13 0 99 wetness_param_1 -var14 0 99 wetness_param_2 -var15 0 99 wetness_param_3 -var16 0 99 shape_param_1 -var17 0 99 shape_param_2 -var18 0 99 shape_param_3 -var19 0 99 shape_param_4 -var20 0 99 min_theta_1 -var21 0 99 min_theta_2 -var22 0 99 min_theta_3 -var23 0 99 min_theta_4 -var24 0 99 water_transfer_1 -var25 0 99 water_transfer_2 -var26 0 99 water_transfer_3 -var27 0 99 water_transfer_4 -var28 0 99 soil_param_1 -var29 0 99 soil_param_2 -var30 0 99 vegetation_type -var31 4 99 canopy_temperature_1,2,3,4 -var32 4 99 canopy_specific_humidity_1,2,3,4 -var33 0 99 interception_reservoir_capac -var34 0 99 catchment_deficit -var35 0 99 root_zone_excess -var36 0 99 surface_excess -var37 0 99 soil_heat_content_layer1 -var38 0 99 soil_heat_content_layer2 -var39 0 99 soil_heat_content_layer3 -var40 0 99 soil_heat_content_layer4 -var41 0 99 soil_heat_content_layer5 -var42 0 99 soil_heat_content_layer6 -var43 0 99 mean_catchment_temp_incl_snow -var44 0 99 water_eq_snow_layer1 -var45 0 99 water_eq_snow_layer2 -var46 0 99 water_eq_snow_layer3 -var47 0 99 heat_content_snow_layer1 -var48 0 99 heat_content_snow_layer2 -var49 0 99 heat_content_snow_layer3 -var50 0 99 snow_depth_layer1 -var51 0 99 snow_depth_layer2 -var52 0 99 snow_depth_layer3 -var53 4 99 surface_heat_exchange_coefficient_1,2,3,4 -var54 4 99 surface_momentum_exchange_coefficient_1,2,3,4 -var55 4 99 surface_moisture_exchange_coefficient_1,2,3,4 -var56 4 99 subtile_fractions_1,2,3,4 -var57 0 99 observed_albedo_minimum_previous -var58 0 99 observed_albedo_minimum_next -var59 0 99 observed_albedo_mean_previous -var60 0 99 observed_albedo_mean_next -var61 0 99 observed_albedo_maxmindif_previous -var62 0 99 observed_albedo_maxmindir_next -var63 4 99 vertical_velocity_scale_squared_1,2,3,4 -ENDVARS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 deleted file mode 100644 index 0ad4f26e33..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newcatch.F90 +++ /dev/null @@ -1,91 +0,0 @@ -#define VERIFY_(A) if(A /=0)then;print *,'ERROR code',A,'at',__LINE__;call exit(3);endif - -program newcatch - implicit none - -#ifndef __GFORTRAN__ - integer*4 :: iargc - external :: iargc - integer*8 :: ftell - external :: ftell -#endif - character(256) :: str, f_in, f_out - - integer :: m - integer :: status - integer*8 :: bpos, epos, rsize - real, allocatable :: a(:) - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," " - call exit(2) - end if - - call getarg(1,f_in) - - open(unit=10, file=trim(f_in), form='unformatted') - -! Count the records in the files -! ------------------------------ -! Valid numbers are: -! 61 - old catch_internal_restart -! 57 - old catch_internal_restart - m=0 - do while(.true.) - read(10, end=50, err=200) ! skip to next record - m = m+1 - end do -50 continue - rewind(10) - - if (m == 57) then - print *,'WARNING: this file contains ', m, ' records and appears to have been already convered' - print *,'Refuse to convert!' - print *,'Exiting ...' - call exit(1) - else if (m /= 61) then - print *,'ERROR: this file contains ',m, & - ' records and does not appear to be a valid catchment internal restart' - print *,'Exiting ...' - call exit(2) - end if - -! Open the output file -! -------------------- - call getarg(2,f_out) - open(unit=20, file=trim(f_out), form='unformatted') - - m=0 - bpos=0 - do while(.true.) - m = m+1 - read(10, end=100, err=200) ! skip to next record - epos = ftell(10) ! ending position of file pointer - backspace(10) - - rsize = (epos-bpos)/4-2 ! record size (in 4 byte words; - bpos = epos - allocate(a(rsize), stat=status) - VERIFY_(status) - read (10) a - if (m < 57 .or. m > 60) then - print *,'Writing record ',m - write(20) a - else - print *,'Skipping record ',m - end if - deallocate(a) - end do -100 continue - close(10) - close(20) - stop - -! If we are here something must have gone wrong -200 VERIFY_(200) - -end program newcatch - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 deleted file mode 100644 index beafa84247..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/newvegdyn.f90 +++ /dev/null @@ -1,57 +0,0 @@ -program newvegdyn - implicit none - - real, pointer :: var(:) - - integer :: i, bpos, epos, status - integer :: rsize - character(256) :: str, f_in, f_out - integer*4 :: ftell - external :: ftell - - integer*4 :: iargc - external :: iargc - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," " - call exit(2) - end if - - call getarg(1,f_in) - call getarg(2,f_out) - - open(unit=10, file=trim(f_in), form='unformatted') - open(unit=20, file=trim(f_out), form='unformatted') - - print *,'New Restart Format for File: ',trim(f_in) - - bpos=0 - read(10, err=200) ! skip to next record - epos = ftell(10) ! ending position of file pointer - - rsize = (epos-bpos)/4-2 ! record size (in 4 byte words; - ! 2 is the number of fortran control words) - allocate(var(rsize), stat=status) - if (status /= 0) then - print *, 'Error: allocation ', rsize, ' failed!' - call exit(11) - end if - - read(10, err=200) ! skip to next record - read(10, err=200) ! skip to next record - read(10, err=200) ! skip to next record -! alltogather we skip 4 record - read (10) var - write(20) var - deallocate(var) - close(10) - close(20) - stop - -200 print *,'Error reading file ',trim(f_in) - call exit(11) - -end diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl deleted file mode 100755 index b98d321634..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/old_catch.ctl +++ /dev/null @@ -1,73 +0,0 @@ -dset wrk/old_catch.dat -options sequential template big_endian -undef -9999.0 -xdef 76847 linear 1 1 -ydef 1 linear 1 1 -zdef 4 linear 1 1 -tdef 1 linear jan1900 1mo -* -VARS 63 -var01 0 99 topo_baseflow_param_1 -var02 0 99 topo_baseflow_param_2 -var03 0 99 topo_baseflow_param_3 -var04 0 99 max_rootzone_water_content -var05 0 99 moisture_threshold -var06 0 99 max_water_content_unsat_zone -var07 0 99 saturated_matrix_potential -var08 0 99 clapp_hornberger_b -var09 0 99 soil_porosity -var10 0 99 wetness_at_wilting_point -var11 0 99 sfc_sat_hydraulic_conduct -var12 0 99 vertical_transmissivity -var13 0 99 wetness_param_1 -var14 0 99 wetness_param_2 -var15 0 99 wetness_param_3 -var16 0 99 shape_param_1 -var17 0 99 shape_param_2 -var18 0 99 shape_param_3 -var19 0 99 shape_param_4 -var20 0 99 min_theta_1 -var21 0 99 min_theta_2 -var22 0 99 min_theta_3 -var23 0 99 min_theta_4 -var24 0 99 water_transfer_1 -var25 0 99 water_transfer_2 -var26 0 99 water_transfer_3 -var27 0 99 water_transfer_4 -var28 0 99 soil_param_1 -var29 0 99 soil_param_2 -var30 0 99 vegetation_type -var31 4 99 canopy_temperature_1,2,3,4 -var32 4 99 canopy_specific_humidity_1,2,3,4 -var33 0 99 interception_reservoir_capac -var34 0 99 catchment_deficit -var35 0 99 root_zone_excess -var36 0 99 surface_excess -var37 0 99 soil_heat_content_layer1 -var38 0 99 soil_heat_content_layer2 -var39 0 99 soil_heat_content_layer3 -var40 0 99 soil_heat_content_layer4 -var41 0 99 soil_heat_content_layer5 -var42 0 99 soil_heat_content_layer6 -var43 0 99 mean_catchment_temp_incl_snow -var44 0 99 water_eq_snow_layer1 -var45 0 99 water_eq_snow_layer2 -var46 0 99 water_eq_snow_layer3 -var47 0 99 heat_content_snow_layer1 -var48 0 99 heat_content_snow_layer2 -var49 0 99 heat_content_snow_layer3 -var50 0 99 snow_depth_layer1 -var51 0 99 snow_depth_layer2 -var52 0 99 snow_depth_layer3 -var53 4 99 surface_heat_exchange_coefficient_1,2,3,4 -var54 4 99 surface_momentum_exchange_coefficient_1,2,3,4 -var55 4 99 surface_moisture_exchange_coefficient_1,2,3,4 -var56 4 99 subtile_fractions_1,2,3,4 -var57 0 99 observed_albedo_minimum_previous -var58 0 99 observed_albedo_minimum_next -var59 0 99 observed_albedo_mean_previous -var60 0 99 observed_albedo_mean_next -var61 0 99 observed_albedo_maxmindif_previous -var62 0 99 observed_albedo_maxmindir_next -var63 4 99 vertical_velocity_scale_squared_1,2,3,4 -ENDVARS diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 deleted file mode 100644 index 09fa5c26b8..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/replace_params.F90 +++ /dev/null @@ -1,296 +0,0 @@ -PROGRAM replace_params - implicit none - - integer :: nland_old, nland_new - character*400 :: tilefile - character*400 :: old_restart, new_restart, sarithpath - - real, allocatable :: var1(:),var2(:,:) - integer :: numrecs, allrecs, numparmrecs - - real, allocatable :: BF1(:), BF2(:), BF3(:), VGWMAX(:) - real, allocatable :: CDCR1(:), CDCR2(:), PSIS(:), BEE(:) - real, allocatable :: POROS(:), WPWET(:), COND(:), GNU(:) - real, allocatable :: ARS1(:), ARS2(:), ARS3(:) - real, allocatable :: ARA1(:), ARA2(:), ARA3(:), ARA4(:) - real, allocatable :: ARW1(:), ARW2(:), ARW3(:), ARW4(:) - real, allocatable :: TSA1(:), TSA2(:), TSB1(:), TSB2(:) - real, allocatable :: ATAU2(:), BTAU2(:), ITY0(:) - integer, allocatable :: ity_int(:) - integer :: ity2, nmin, type - real, allocatable :: DP2BR(:), tmp_wgt(:,:), tmp_sum(:,:) - real :: zdep1, zdep2, zdep3, zmet, term1, term2 - integer :: catindex21, catindex22, catindex23 - integer :: catindex24, catindex25, catindex26 - real :: frc1, frc2, rdum - integer :: catid, checksum, ntilesold - integer :: ii0, jj0, i,j,n, idum,II - integer :: IARGC - - - II = iargc() - - if(II /= 4) then - print *, "Wrong Number of arguments: ", ii - call exit(66) - end if - - call getarg(1,old_restart) - call getarg(2,new_restart) - call getarg(3,tilefile) - call getarg(4,sarithpath) - - sarithpath = "/land/l_data/geos5/bcs/SiB2_V2/DC/"//trim(sarithpath) - - numrecs = 61 - numparmrecs = 30 - - ! read .til file - - open (10,file=trim(tilefile),status='old',form='formatted') - read (10,*) ntilesold - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - read (10,*) - nland_old=0 - do n = 1,ntilesold - read(10,*) type - if (type == 100) then - nland_old=nland_old+1 - endif - end do - close (10,status='keep') - - print *, ' Number of land tiles = ', nland_old - - nland_new = nland_old - - allocate ( BF1(nland_new), BF2 (nland_new), BF3(nland_new) ) - allocate (VGWMAX(nland_new), CDCR1(nland_new), CDCR2(nland_new) ) - allocate ( PSIS(nland_new), BEE(nland_new), POROS(nland_new) ) - allocate ( WPWET(nland_new), COND(nland_new), GNU(nland_new) ) - allocate ( ARS1(nland_new), ARS2(nland_new), ARS3(nland_new) ) - allocate ( ARA1(nland_new), ARA2(nland_new), ARA3(nland_new) ) - allocate ( ARA4(nland_new), ARW1(nland_new), ARW2(nland_new) ) - allocate ( ARW3(nland_new), ARW4(nland_new), TSA1(nland_new) ) - allocate ( TSA2(nland_new), TSB1(nland_new), TSB2(nland_new) ) - allocate ( ATAU2(nland_new), BTAU2(nland_new), DP2BR(nland_new) ) - allocate ( ITY0(nland_new), ity_int(nland_new)) - - - - open(unit=21, file=trim(sarithpath) // '/' //'mosaic_veg_typs_fracs',form='formatted') - open(unit=22, file=trim(sarithpath) // '/' //'bf.dat' ,form='formatted') - open(unit=23, file=trim(sarithpath) // '/' //'soil_param.dat' ,form='formatted') - open(unit=24, file=trim(sarithpath) // '/' //'ar.new' ,form='formatted') - open(unit=25, file=trim(sarithpath) // '/' //'ts.dat' ,form='formatted') - open(unit=26, file=trim(sarithpath) // '/' //'tau_param.dat' ,form='formatted') - - - print *, 'opened units' - - do n=1,nland_new - read (21, *) catindex21, catid, ity_int(n), ity2, frc1, frc2 - ITY0(n)=1.0*ity_int(n) - - read (22, *) catindex22, catid, GNU(n), BF1(n), BF2(n), BF3(n) - - read (23, *) catindex23, catid, idum, idum, BEE(n), PSIS(n), POROS(n), COND(n), WPWET(n), DP2BR(n) - - read (24, *) catindex24, catid, rdum, ARS1(n), ARS2(n), ARS3(n), & - ARA1(n), ARA2(n), ARA3(n), ARA4(n), & - ARW1(n), ARW2(n), ARW3(n), ARW4(n) - - read (25, *) catindex25, catid, rdum, TSA1(n), TSA2(n), TSB1(n), TSB2(n) - - read (26, *) catindex26, catid, ATAU2(n), BTAU2(n), rdum, rdum - - zdep2=1000. - zdep3=amax1(1000.,DP2BR(n)) - if (zdep2 .gt.0.75*zdep3) then - zdep2 = 0.75*zdep3 - end if - zdep1=20. - zmet=zdep3/1000. - - term1=-1.+((PSIS(n)-zmet)/PSIS(n))**((BEE(n)-1.)/BEE(n)) - term2=PSIS(n)*BEE(n)/(BEE(n)-1) - - VGWMAX(n) = POROS(n)*zdep2 - CDCR1(n) = 1000.*POROS(n)*(zmet-(-term2*term1)) - CDCR2(n) = (1.-WPWET(n))*POROS(n)*zdep3 - enddo - - close (21) - close (22) - close (23) - close (24) - close (25) - close (26) - - - print *, ' Doing restarts' - - open(unit=30, file=trim(old_restart),form='unformatted',status='old',convert='little_endian') - open(unit=40, file=trim(new_restart),form='unformatted',status='unknown',convert='little_endian') - - allocate(var1(nland_old)) - allocate(var2(nland_old,4)) - - print *, 'Opened restart files' - print *, 30, trim(old_restart) - print *, 40, trim(new_restart) - - - - write(40) BF1 - read(30) var1 - print *, "BF1",maxval(BF1), maxval(var1), minval(BF1),minval(var1) - - write(40) BF2 - read(30) var1 - print *, "BF2",maxval(BF2), maxval(var1), minval(BF2),minval(var1) - - write(40) BF3 - read(30) var1 - print *, "BF3",maxval(BF3), maxval(var1), minval(BF3),minval(var1) - - write(40) VGWMAX - read(30) var1 - print *, "VGWMAX",maxval(VGWMAX), maxval(var1), minval(VGWMAX),minval(var1) - - write(40) CDCR1 - read(30) var1 - print *, "CDCR1",maxval(CDCR1), maxval(var1), minval(CDCR1),minval(var1) - - write(40) CDCR2 - read(30) var1 - print *, "CDCR2",maxval(CDCR2), maxval(var1), minval(CDCR2),minval(var1) - - write(40) PSIS - read(30) var1 - print *, "PSIS",maxval(PSIS), maxval(var1), minval(PSIS),minval(var1) - - write(40) BEE - read(30) var1 - print *, "BEE",maxval(BEE), maxval(var1), minval(BEE),minval(var1) - - write(40) POROS - read(30) var1 - print *, "POROS ",maxval(POROS ), maxval(var1), minval(POROS ),minval(var1) - - write(40) WPWET - read(30) var1 - print *, "WPWET",maxval(WPWET), maxval(var1), minval(WPWET),minval(var1) - - write(40) COND - read(30) var1 - print *, "COND",maxval(COND), maxval(var1), minval(COND),minval(var1) - - write(40) GNU - read(30) var1 - print *, "GNU",maxval(GNU), maxval(var1), minval(GNU),minval(var1) - - write(40) ARS1 - read(30) var1 - print *, "ARS1",maxval(ARS1), maxval(var1), minval(ARS1),minval(var1) - - write(40) ARS2 - read(30) var1 - print *, "ARS2",maxval(ARS2), maxval(var1), minval(ARS2),minval(var1) - - write(40) ARS3 - read(30) var1 - print *, "ARS3",maxval(ARS3), maxval(var1), minval(ARS3),minval(var1) - - write(40) ARA1 - read(30) var1 - print *, "ARA1",maxval(ARA1), maxval(var1), minval(ARA1),minval(var1) - - write(40) ARA2 - read(30) var1 - print *, "ARA2",maxval(ARA2), maxval(var1), minval(ARA2),minval(var1) - - write(40) ARA3 - read(30) var1 - print *, "ARA3",maxval(ARA3), maxval(var1), minval(ARA3),minval(var1) - - write(40) ARA4 - read(30) var1 - print *, "ARA4",maxval(ARA4), maxval(var1), minval(ARA4),minval(var1) - - write(40) ARW1 - read(30) var1 - print *, "ARW1",maxval(ARW1), maxval(var1), minval(ARW1),minval(var1) - - write(40) ARW2 - read(30) var1 - print *, "ARW2",maxval(ARW2), maxval(var1), minval(ARW2),minval(var1) - - write(40) ARW3 - read(30) var1 - print *, "ARW3",maxval(ARW3), maxval(var1), minval(ARW3),minval(var1) - - write(40) ARW4 - read(30) var1 - print *, "ARW4",maxval(ARW4), maxval(var1), minval(ARW4),minval(var1) - - write(40) TSA1 - read(30) var1 - print *, "TSA1",maxval(TSA1), maxval(var1), minval(TSA1),minval(var1) - - write(40) TSA2 - read(30) var1 - print *, "TSA2",maxval(TSA2), maxval(var1), minval(TSA2),minval(var1) - - write(40) TSB1 - read(30) var1 - print *, "TSB1",maxval(TSB1), maxval(var1), minval(TSB1),minval(var1) - - write(40) TSB2 - read(30) var1 - print *, "TSB2",maxval(TSB2), maxval(var1), minval(TSB2),minval(var1) - - write(40) ATAU2 - read(30) var1 - print *, "ATAU2",maxval(ATAU2), maxval(var1), minval(ATAU2),minval(var1) - - write(40) BTAU2 - read(30) var1 - print *, "BTAU2",maxval(BTAU2), maxval(var1), minval(BTAU2),minval(var1) - - write(40) ITY0 - read(30) var1 - print *, "ITY0",maxval(ITY0), maxval(var1), minval(ITY0),minval(var1) - - - print *, 'Wrote parameters' - - do n=1,2 - read (30) var2 - write(40) var2 - end do - - do n=1,20 - read (30) var1 - write(40) var1 - enddo - - do n=1,4 - read (30) var2 - write(40) var2 - end do - - do n=1,4 - read (30) var1 - write(40) var1 - enddo - - read (30) var2 - write(40) var2 - -END PROGRAM replace_params diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 deleted file mode 100644 index 2fd95d2b8e..0000000000 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/mk_restarts/obsolete/strip_vegdyn.F90 +++ /dev/null @@ -1,78 +0,0 @@ -#define VERIFY_(A) if(A /=0)then;print *,'ERROR code',A,'at',__LINE__;call exit(3);endif - -program checkVegDyn - implicit none - -#ifndef __GFORTRAN__ - integer*4 :: iargc - external :: iargc - integer :: ftell - external :: ftell -#endif - character(256) :: str, f_in, f_out - - integer :: m, n - integer :: status - integer :: bpos, epos, nt - integer, parameter :: unit=10 - real, allocatable :: a(:) - integer, allocatable :: veg(:) - integer :: minVegType - integer :: maxVegType - -! Begin - - if (iargc() /= 2) then - call getarg(0,str) - write(*,*) "Usage:",trim(str)," "," " - call exit(2) - end if - - call getarg(1,f_in) - call getarg(2,f_out) - - open(unit=unit, file=trim(f_in), form='unformatted') - -! count the records - m=0 - do while(.true.) - read(unit, end=50, err=200) ! skip to next record - m = m+1 - end do -50 continue - if (m == 1) then - print *, 'File ', trim(f_in), 'contains only only record. Exiting ...' - goto 100 - end if - - rewind(unit) - - open(unit=20, file=trim(f_out), form='unformatted') - -! determine number of tiles by the size of the first record - - bpos=0 - read(unit, err=200) ! skip to next record - epos = ftell(unit) ! ending position of file pointer - nt = (epos-bpos)/4-2 ! record size (in 4 byte words; - rewind(unit) - - allocate(a(nt), stat=status) - VERIFY_(status) - -! Read and copy first record - read (unit) a - write(20) a - - close(20) - -! clean up -100 continue - close(unit) - stop - -! If we are here, something must have gone wrong -200 VERIFY_(200) - -end program checkVegDyn - diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 index f5e7ff31df..9bd39023ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/GEOS_TurbulenceGridComp.F90 @@ -3217,17 +3217,17 @@ subroutine REFRESH(IM,JM,LM,RC) call MAPL_GetResource (MAPL, USE_EIS, trim(COMP_NAME)//"_USE_EIS:", default=.false.,RC=STATUS); VERIFY_(STATUS) else call MAPL_GetResource (MAPL, LAMBDADISS, trim(COMP_NAME)//"_LAMBDADISS:", default=15., RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=1.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, KHRADFAC, trim(COMP_NAME)//"_KHRADFAC:", default=0.8, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_LND, trim(COMP_NAME)//"_KHSFCFAC_LND:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, KHSFCFAC_OCN, trim(COMP_NAME)//"_KHSFCFAC_OCN:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLSFC, trim(COMP_NAME)//"_PRANDTLSFC:", default=1.0, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, PRANDTLRAD, trim(COMP_NAME)//"_PRANDTLRAD:", default=0.75, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.30, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.15, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_RAD, trim(COMP_NAME)//"_BETA_RAD:", default=0.15, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, BETA_SURF, trim(COMP_NAME)//"_BETA_SURF:", default=0.10, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, ENTRATE_SURF, trim(COMP_NAME)//"_ENTRATE_SURF:", default=1.5e-3, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_MIN, trim(COMP_NAME)//"_TPFAC_MIN:", default=0.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, TPFAC_MAX, trim(COMP_NAME)//"_TPFAC_MAX:", default=0.0, RC=STATUS); VERIFY_(STATUS) - call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_MIN, trim(COMP_NAME)//"_TPFAC_MIN:", default=10.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, TPFAC_MAX, trim(COMP_NAME)//"_TPFAC_MAX:", default=20.0, RC=STATUS); VERIFY_(STATUS) + call MAPL_GetResource (MAPL, PCEFF_SURF, trim(COMP_NAME)//"_PCEFF_SURF:", default=0.375, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, LOCK_ON, trim(COMP_NAME)//"_LOCK_ON:", default=1, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, VSCALE_SURF, trim(COMP_NAME)//"_VSCALE_SURF:", default=2.5e-3, RC=STATUS); VERIFY_(STATUS) call MAPL_GetResource (MAPL, USE_EIS, trim(COMP_NAME)//"_USE_EIS:", default=.false.,RC=STATUS); VERIFY_(STATUS) @@ -4826,29 +4826,47 @@ subroutine REFRESH(IM,JM,LM,RC) else temparray(1:LM+1) = KH(I,J,0:LM) endif - maxkh = maxval(temparray) - - if (USE_EIS) then - if (EIS(I,J) >= 12.0) then - eis_stable = 1.0 - elseif (EIS(I,J) <= 0.0) then - eis_stable = 0.0 - else - eis_stable = (EIS(I,J) / 12.0)**1.5 - endif - ! Adaptive threshold: 10-30% based on EIS - kh_thresh = 0.10 + eis_stable * 0.20 + if ( (LM .eq. 72) .OR. (JASON_TRB) ) then + maxkh = maxval(temparray) + kh_thresh = 0.1 + do L=LM-1,2,-1 + if ( (temparray(L) < kh_thresh*maxkh) .and. (temparray(L+1) >= kh_thresh*maxkh) & + .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then + KPBL_SC(I,J) = float(L) + end if + end do else - kh_thresh = 0.1 + ! ----------------------------------------------------------------- + ! Find max turbulence, but ignore the lowest 50 meters + ! to safely bypass grid-dependent numerical surface spikes + ! ----------------------------------------------------------------- + maxkh = 0.0 + do L = 1, LM + ! Assuming Z(I,J,L) is height. + ! (If Z is altitude MSL, use: Z(I,J,L) - Z(I,J,LM) > 50.0) + if ( Z(I,J,L) > 50.0 ) then + if (temparray(L) > maxkh) then + maxkh = temparray(L) + endif + endif + end do + ! Safety fallback: If maxkh is still 0.0 (e.g., highly stable arctic night), + ! just grab the absolute maximum of the whole column. + if (maxkh == 0.0) then + maxkh = maxval(temparray) + endif + ! ----------------------------------------------------------------- + kh_thresh = 0.1*maxkh + ! Search TOP-DOWN to find the true PBL top + do L = 2, LM-1 + if ( (temparray(L) >= kh_thresh) .and. & + (KPBL_SC(I,J) == MAPL_UNDEF ) ) then + KPBL_SC(I,J) = float(L) + exit ! Break the loop once we hit the top of the turbulence + end if + end do endif - - do L=LM-1,2,-1 - if ( (temparray(L) < kh_thresh*maxkh) .and. (temparray(L+1) >= kh_thresh*maxkh) & - .and. (KPBL_SC(I,J) == MAPL_UNDEF ) ) then - KPBL_SC(I,J) = float(L) - end if - end do - if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then + if ( KPBL_SC(I,J) .eq. MAPL_UNDEF .or. (maxkh.lt.1.)) then KPBL_SC(I,J) = float(LM) endif end do diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 index 9664332c05..71546f6c3d 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSturbulence_GridComp/LockEntrain.F90 @@ -810,8 +810,7 @@ subroutine entrain( & ! 3. Apply combined factor ! Ensure the floor isn't too low for marine clouds - ! (0.5 is a safer floor for marine Sc than 0.4) - eis_floor = 0.5 - (0.1 * frland(i,j)) + eis_floor = 0.2 - (0.1 * frland(i,j)) wentr_tmp = wentr_tmp * depth_factor * max(eis_floor, eis_factor) else ! Original depth-only scaling @@ -840,8 +839,11 @@ subroutine entrain( & if (ipbl .lt. ibot) then if (use_eis) then - khsfcfac = khsfcfac_lnd*( eis_stability) + & - khsfcfac_ocn*(1.0-eis_stability) + ! Calculate the base geographic factor first + khsfcfac = khsfcfac_lnd*frland(i,j) + khsfcfac_ocn*(1.0-frland(i,j)) + ! Then modulate it based on stability (e.g., reduce it under high stability) + ! (Adjust the 0.5 factor to whatever tuning you prefer) + khsfcfac = khsfcfac * (1.0 - 0.5 * eis_stability) else khsfcfac = khsfcfac_lnd*frland(i,j) + khsfcfac_ocn*(1.0-frland(i,j)) endif @@ -1100,7 +1102,7 @@ subroutine entrain( & wentr_rad = wentr_rad * max(0.0,(zradtop-500.)/300.) endif wentr_rad = wentr_rad * min(3.0,(zradtop/800.)) - endif + endif !----------------------------------------- k_entr_tmp = min ( akmax, wentr_rad*(zfull(i,j,kcldtop-1)-zfull(i,j,kcldtop)) ) @@ -1353,7 +1355,14 @@ subroutine mpbl_depth(i,j,icol,jcol,nlev, tpfac_min, tpfac_max, entrate, pceff, pp = p(i,j,k) du = sqrt ( ( u2 - u1 )**2 + ( v2 - v1 )**2 ) / (z2-z1) - du = min(du,1.0e-8) + if (tpfac_max /= tpfac_min) then + ! Prevent negative/zero shear, but allow real shear (e.g., 0.01 to 0.1 s-1) + du = max(du, 1.0e-8) + ! Optional: If we need to cap extreme shear + du = min(du, 0.1) + else + du = min(du, 1.0e-8) ! This is likely a bug + endif if (use_eis) then entrate_x = (entrate - 0.6e-3*LTS_FAC) * & ! adjust entrate based on LTS_FAC diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 index 9d10e6eafc..a70b3fa4b0 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOS_SuperdynGridComp.F90 @@ -361,6 +361,12 @@ subroutine SetServices ( GC, RC ) RC=STATUS ) VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC , & + SHORT_NAME = 'WSPD_STABLE300M', & + CHILD_ID = DYN, & + RC=STATUS ) + VERIFY_(STATUS) + call MAPL_AddExportSpec ( GC , & SHORT_NAME = 'TROPP_BLENDED', & CHILD_ID = DYN, & diff --git a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 index 0c71b5e69e..061f87ab6d 100644 --- a/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 +++ b/GEOSagcm_GridComp/GEOSsuperdyn_GridComp/GEOSdatmodyn_GridComp/GEOS_DatmoDynGridComp.F90 @@ -541,7 +541,15 @@ subroutine SetServices ( GC, RC ) UNITS ='m s-1', & DIMS = MAPL_DimsHorzOnly, & VLOCATION = MAPL_VLocationNone, & - __RC__ ) + __RC__ ) + + call MAPL_AddExportSpec(GC, & + SHORT_NAME='WSPD_STABLE300M', & + LONG_NAME ='max_wind_speed_in_stable_cold_surface_layer', & + UNITS ='m s-1', & + DIMS = MAPL_DimsHorzOnly, & + VLOCATION = MAPL_VLocationNone, & + __RC__ ) call MAPL_AddExportSpec(GC, & @@ -1185,6 +1193,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! else: use interactive winds integer :: IM,JM,LM,L,K,NQ,ii,NOT1,COLDSTART,Ktrc,iip1,itr,ntracs + logical :: is_stable real, pointer, dimension(:,:,:) :: PLE,PLEOUT real, pointer, dimension(:,:,:) :: ZLE @@ -1212,6 +1221,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) real, pointer, dimension(:,:) :: DZ real, pointer, dimension(:,:) :: TA real, pointer, dimension(:,:) :: SPEED + real, pointer, dimension(:,:) :: WSPD_STABLE300M real, pointer, dimension(:,:) :: QA real, pointer, dimension(:,:) :: US real, pointer, dimension(:,:) :: VS @@ -2030,7 +2040,7 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) ! Forcing based on Phase 2 of CGILS intercomparison. See Blossey et al. (2016) if ( CFMIP3 ) then - ZLO = 0.5*(ZLE(:,:,0:LM-1)+ZLE(:,:,1:LM)) + ZLO = 0.5*(ZLE(:,:,0:LM-1)+ZLE(:,:,1:LM)) if (CFCSE .eq. 12) then zrel=1200. @@ -2124,10 +2134,44 @@ subroutine RUN ( GC, IMPORT, EXPORT, CLOCK, RC ) if (associated(DQVDTDYN)) DQVDTDYN = DQVDTDYN - CFMIPRLX * ( Q - QOBS ) end if - call MAPL_GetPointer(EXPORT, PREF, 'PREF' , & + call MAPL_GetPointer(EXPORT, WSPD_STABLE300M, 'WSPD_STABLE300M', & ALLOC=.true., __RC__) + if (associated(WSPD_STABLE300M)) then + WSPD_STABLE300M = 0.0 + do J = 1, JM + do I = 1, IM + ! 1. Check if surface air is freezing (T at lowest model level) + if (T(I,J,LM) <= MAPL_TICE) then + ! Assume no inversion until proven otherwise + is_stable = .false. + ! Start max wind tracking with the lowest model level + WSPD_STABLE300M(I,J) = SQRT(U(I,J,LM)**2 + V(I,J,LM)**2) + ! 2. Scan the lowest 300m AGL (ZLE(I,J,LM) is the surface height) + do K = LM-1, 1, -1 + ! Height AGL at mid-level using ZLO (0.5*(ZLE(K-1)+ZLE(K))) + if ( (ZLO(I,J,K) - ZLE(I,J,LM)) <= 300.0 ) then + ! Track maximum wind speed + WSPD_STABLE300M(I,J) = MAX(WSPD_STABLE300M(I,J), & + SQRT(U(I,J,K)**2 + V(I,J,K)**2)) + ! 3. Check for temperature inversion anywhere in the 300m layer + if (T(I,J,K) > T(I,J,LM)) then + is_stable = .true. + endif + else + exit ! Reached top of 300m layer + endif + end do + ! 4. If no inversion found, not a katabatic zone; zero out wind speed + if (.not. is_stable) then + WSPD_STABLE300M(I,J) = 0.0 + endif + endif + end do + end do + end if - + call MAPL_GetPointer(EXPORT, PREF, 'PREF' , & + ALLOC=.true., __RC__) PREF = PREF_IN VARFLT = 0.