diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 index e0f91528e..8ffa7a183 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM40_GridComp/GEOS_CatchCNCLM40GridComp.F90 @@ -5912,11 +5912,13 @@ subroutine Driver ( RC ) !--------------- GOSWIM IMPORTS FROM GOCART --------------- ! Initialization - RCONSTIT(:,:,:) = 0.0 - TOTDEPOS(:,:) = 0.0 - RMELT(:,:) = 0.0 + if (N_constit>0) then + RCONSTIT(:,:,:) = 0.0 + TOTDEPOS(:,:) = 0.0 + RMELT(:,:) = 0.0 + end if !------------------------------------------------------------------ - + ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: select case (catchcn_internal%AEROSOL_DEPOSITION) @@ -5953,6 +5955,8 @@ subroutine Driver ( RC ) OCSD(:,:)=0. end select + + if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then ! Convert the dimentions for LAAs from GEOS_SurfGridComp.F90 to GEOS_LandIceGridComp.F90 ! Note: Explanations of each variable @@ -5992,8 +5996,6 @@ subroutine Driver ( RC ) ! --------------- GOSWIM PROGRNOSTICS --------------------------- - if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then - ! Conversion of the masses of the snow impurities ! Note: Explanations of each variable ! Number of snow layer is 15: N = 1-15 @@ -7452,15 +7454,18 @@ subroutine Driver ( RC ) if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) - if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) - if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) - if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) - if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) - if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) - if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) - if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) - if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) - if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + if (N_constit>0) then + if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) + if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) + if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) + if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) + if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) + if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) + if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) + if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) + if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + end if + if(associated(PEATCLSM_FSWCHANGE)) then where (POROS >= PEATCLSM_POROS_THRESHOLD) PEATCLSM_FSWCHANGE = FSW_CHANGE diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 index 9289b2e09..15b2daf2e 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/GEOSland_GridComp/GEOScatchCN_GridComp/GEOScatchCNCLM45_GridComp/GEOS_CatchCNCLM45GridComp.F90 @@ -5943,9 +5943,11 @@ subroutine Driver ( RC ) !--------------- GOSWIM IMPORTS FROM GOCART --------------- ! Initialization - RCONSTIT(:,:,:) = 0.0 - TOTDEPOS(:,:) = 0.0 - RMELT(:,:) = 0.0 + if (N_constit>0) then + RCONSTIT(:,:,:) = 0.0 + TOTDEPOS(:,:) = 0.0 + RMELT(:,:) = 0.0 + end if !------------------------------------------------------------------ ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: @@ -5985,6 +5987,8 @@ subroutine Driver ( RC ) end select + if (catchcn_internal%N_CONST_LAND4SNWALB /= 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) @@ -6023,8 +6027,6 @@ subroutine Driver ( RC ) ! --------------- GOSWIM PROGRNOSTICS --------------------------- - if (catchcn_internal%N_CONST_LAND4SNWALB /= 0) then - ! Conversion of the masses of the snow impurities ! Note: Explanations of each variable ! Number of snow layer is 15: N = 1-15 @@ -7733,15 +7735,18 @@ subroutine Driver ( RC ) if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) - if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) - if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) - if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) - if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) - if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) - if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) - if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) - if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) - if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + if (N_constit>0) then + if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) + if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) + if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) + if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) + if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) + if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) + if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) + if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) + if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + end if + if(associated(PEATCLSM_FSWCHANGE )) then where (POROS >= PEATCLSM_POROS_THRESHOLD) PEATCLSM_FSWCHANGE = FSW_CHANGE 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 788745c46..33c30e413 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 @@ -4965,9 +4965,11 @@ subroutine Driver ( RC ) !--------------- GOSWIM IMPORTS FROM GOCART --------------- ! Initialization - RCONSTIT(:,:,:) = 0.0 - TOTDEPOS(:,:) = 0.0 - RMELT(:,:) = 0.0 + if (N_constit>0) then + RCONSTIT(:,:,:) = 0.0 + TOTDEPOS(:,:) = 0.0 + RMELT(:,:) = 0.0 + end if !------------------------------------------------------------------ ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: @@ -5007,6 +5009,8 @@ subroutine Driver ( RC ) end select + if (CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB /= 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) @@ -5066,7 +5070,6 @@ subroutine Driver ( RC ) ! RCONSTIT(NTILES,N,14): Sea salt mass from size bin 4 in layer N ! RCONSTIT(NTILES,N,15): Sea salt mass from size bin 5 in layer N - if (CATCH_INTERNAL_STATE%N_CONST_LAND4SNWALB /= 0) then RCONSTIT(:,:,1) = RDU001(:,:) RCONSTIT(:,:,2) = RDU002(:,:) RCONSTIT(:,:,3) = RDU003(:,:) @@ -6032,15 +6035,18 @@ subroutine Driver ( RC ) if(associated(FICE2 )) FICE2 = max( min( FICESOUT(2,:),1.0 ), 0.0 ) if(associated(FICE3 )) FICE3 = max( min( FICESOUT(3,:),1.0 ), 0.0 ) - if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) - if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) - if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) - if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) - if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) - if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) - if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) - if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) - if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + + if (N_constit>0) then + if(associated(RMELTDU001)) RMELTDU001 = RMELT(:,1) + if(associated(RMELTDU002)) RMELTDU002 = RMELT(:,2) + if(associated(RMELTDU003)) RMELTDU003 = RMELT(:,3) + if(associated(RMELTDU004)) RMELTDU004 = RMELT(:,4) + if(associated(RMELTDU005)) RMELTDU005 = RMELT(:,5) + if(associated(RMELTBC001)) RMELTBC001 = RMELT(:,6) + if(associated(RMELTBC002)) RMELTBC002 = RMELT(:,7) + if(associated(RMELTOC001)) RMELTOC001 = RMELT(:,8) + if(associated(RMELTOC002)) RMELTOC002 = RMELT(:,9) + end if if(associated(DZGT1 )) DZGT1 = DZGT(1) ! [m] if(associated(DZGT2 )) DZGT2 = DZGT(2) ! [m] 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 a7725436a..c22870a00 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 @@ -2154,6 +2154,7 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) !integer, pointer :: TILETYPES(:) type(MAPL_SunOrbit) :: ORBIT + integer :: LANDICE_OFFLINE !============================================================================= ! Begin... @@ -2198,6 +2199,9 @@ subroutine RUN2 ( GC, IMPORT, EXPORT, CLOCK, RC ) VERIFY_(STATUS) call ESMF_AlarmRingerOff(ALARM, RC=STATUS) VERIFY_(STATUS) + ! borrow CATCHMENT_OFFLINE + call MAPL_GetResource ( MAPL, LANDICE_OFFLINE, Label="CATCHMENT_OFFLINE:", DEFAULT=0, RC=STATUS) + VERIFY_(STATUS) call LANDICECORE(RC=STATUS ) VERIFY_(STATUS) end if @@ -2333,6 +2337,7 @@ subroutine LANDICECORE(RC) real, pointer, dimension(:) :: DRUVR real, pointer, dimension(:) :: DFUVR real, pointer, dimension(:) :: TA + real, pointer, dimension(:) :: QA real, pointer, dimension(:) :: UU real, pointer, dimension(:,:) :: DUDP real, pointer, dimension(:,:) :: DUSV @@ -2367,6 +2372,8 @@ subroutine LANDICECORE(RC) real, allocatable :: SWN(:) real, allocatable :: DIF(:) real, allocatable :: ULW(:) + real, allocatable :: ALWN(:) + real, allocatable :: BLWN(:) real :: DT real :: LANDICECAP @@ -2484,6 +2491,7 @@ subroutine LANDICECORE(RC) call MAPL_GetPointer(IMPORT,DRUVR , 'DRUVR' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,DFUVR , 'DFUVR' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,TA , 'TA' , RC=STATUS); VERIFY_(STATUS) + call MAPL_GetPointer(IMPORT,QA , 'QA' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,UU , 'UU' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,DUDP , 'DUDP' , RC=STATUS); VERIFY_(STATUS) call MAPL_GetPointer(IMPORT,DUSV , 'DUSV' , RC=STATUS); VERIFY_(STATUS) @@ -2762,10 +2770,12 @@ subroutine LANDICECORE(RC) if(associated(TICE0 )) TICE0 = 0.0 if(associated(ACCUM )) ACCUM = 0.0 if(associated(MELTWTR )) MELTWTR = 0.0 - - TOTDEPOS = 0.0 - RCONSTIT = 0.0 - RMELT = 0.0 + + if (N_constit>0) then + TOTDEPOS = 0.0 + RCONSTIT = 0.0 + RMELT = 0.0 + end if ! Zero the light-absorbing aerosol (LAA) deposition rates from GOCART: @@ -2804,6 +2814,9 @@ subroutine LANDICECORE(RC) 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) @@ -2862,7 +2875,6 @@ subroutine LANDICECORE(RC) ! RCONSTIT(NT,N,14): Sea salt mass from size bin 4 in layer N ! RCONSTIT(NT,N,15): Sea salt mass from size bin 5 in layer N - if (N_CONST_LANDICE4SNWALB /=0) then RCONSTIT(:,:,1) = IRDU001(:,:) RCONSTIT(:,:,2) = IRDU002(:,:) RCONSTIT(:,:,3) = IRDU003(:,:) @@ -2942,155 +2954,169 @@ subroutine LANDICECORE(RC) !! The next sequence is to make sure that the albedo here and in solar are in sync !! ! Need to know when Solar was called last, so first get the solar alarm - call ESMF_ClockGetAlarm ( CLOCK, alarmname="SOLAR_Alarm", ALARM=SOLALARM, RC=STATUS ) - VERIFY_(STATUS) + call ESMF_ClockGetAlarm ( CLOCK, alarmname="SOLAR_Alarm", ALARM=SOLALARM, RC=STATUS ) + VERIFY_(STATUS) ! Get the interval of the solar alarm - first get it in seconds - call ESMF_ConfigGetAttribute ( CF, DT_SOLAR, Label="SOLAR_DT:", DEFAULT=DT, RC=STATUS ) - VERIFY_(STATUS) + call ESMF_ConfigGetAttribute ( CF, DT_SOLAR, Label="SOLAR_DT:", DEFAULT=DT, RC=STATUS ) + VERIFY_(STATUS) ! Now make an ESMF interval from the increment in seconds - CALL ESMF_TimeIntervalSet ( TINT, S=NINT(DT_SOLAR), RC=STATUS ) - VERIFY_(STATUS) + CALL ESMF_TimeIntervalSet ( TINT, S=NINT(DT_SOLAR), RC=STATUS ) + VERIFY_(STATUS) ! Now print out the solar alarm interval - if (MAPL_AM_I_Root(VM).and.debugzth) CALL ESMF_TimeIntervalPrint ( TINT, OPTIONS="string", RC=STATUS ) + if (MAPL_AM_I_Root(VM).and.debugzth) CALL ESMF_TimeIntervalPrint ( TINT, OPTIONS="string", RC=STATUS ) ! Now find out if it is ringing now: if so, set "BEFORE" to last time it rang before now - solalarmison = ESMF_AlarmIsRinging(SOLALARM,RC=STATUS) - VERIFY_(STATUS) - if (MAPL_AM_I_Root(VM).and.debugzth)print *,' logical for solar alarm ',solalarmison + solalarmison = ESMF_AlarmIsRinging(SOLALARM,RC=STATUS) + VERIFY_(STATUS) + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' logical for solar alarm ',solalarmison ! if so, set "BEFORE" to last time it rang before now - if(solalarmison) then - if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is ringing ' - NOW = CURRENT_TIME - BEFORE = NOW - TINT + if(solalarmison) then + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is ringing ' + NOW = CURRENT_TIME + BEFORE = NOW - TINT ! Now print out the last time solar alarm rang - if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) + if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) ! If alarm is not ringing now, find out when it rang last - else - if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is not ringing ' - call ESMF_AlarmGet ( SOLALARM, prevRingTime=BEFORE, RC=STATUS ) - VERIFY_(STATUS) + else + if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm is not ringing ' + call ESMF_AlarmGet ( SOLALARM, prevRingTime=BEFORE, RC=STATUS ) + VERIFY_(STATUS) ! PrevRingTime can lie: if alarm never went off yet it gives next alarm time, not prev. - if(BEFORE > CURRENT_TIME) then + if(BEFORE > CURRENT_TIME) then BEFORE = BEFORE-TINT if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm not ringing, prev time lied ' if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) - else + else if (MAPL_AM_I_Root(VM).and.debugzth)print *,' In catch, solar alarm not ringing, prev time okay ' if (MAPL_AM_I_Root(VM).and.debugzth)CALL ESMF_TimePrint ( BEFORE, OPTIONS="string", RC=STATUS ) - endif + endif ! Now print out the last time solar alarm rang - endif + endif ! Get the zenith angle at the center of the time between the last solar call and the next one - call MAPL_SunGetInsolation(LONS, LATS, & + call MAPL_SunGetInsolation(LONS, LATS, & ORBIT, ZTH, SLR, & INTV = TINT, & currTime=BEFORE+DELT, & RC=STATUS ) - VERIFY_(STATUS) - - ZTH = max(0.0,ZTH) + VERIFY_(STATUS) + ZTH = max(0.0,ZTH) + do N=1,NUM_SUBTILES - - CFT = (CH(:,N)/CTATM) - CFQ = (CQ(:,N)/CQATM) - SHF = CFT*(SH + DSH*(TS(:,N)-THATM)) - LHF = CFQ*(EVAP + DEV*(QS(:,N)-QHATM))*MAPL_ALHS - SHD = CFT*DSH - LHD = CFQ*DEV*MAPL_ALHS*GEOS_DQSAT(TS(:,N), PS, PASCALS=.TRUE., RAMP=0.0) - SWN = ((DRUVR+DRPAR+DRNIR) + (DFUVR+DFPAR+DFNIR))*(1.0-LANDICEALB) - DIF = 0.0 - ULW = ALW + BLW*TS(:,N) - - LANDICECAP= (MAPL_RHOWTR*MAPL_CAPICE*LANDICEDEPTH) - - EVAPI = LHF / MAPL_ALHS - DEVAPDT = LHD / MAPL_ALHS - RADDN = LWDNSRF + SWN - - PERC = 0.0 - MELTI = 0.0 - - - if(N==SNOW) then - - ITYPE = 9 - LAI = 0.0 - GRN = 0.0 - MODISFAC = 1.0 - - !*** have to do a transpose of these internals since their dimensions in SNOW_ALBEDO - !*** are reversed - WESNN = transpose(WESN) - HTSNN = transpose(HTSN) - SNDZN = transpose(SNDZ) - !*** call new/shared routine to compute albedo - - 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 - SNOVR, SNONR, SNOVF, SNONF, & ! instantaneous snow albedos on tiles - RCONSTIT, UU, TS(:,SNOW), DRPAR, DFPAR & ! When only N_constit > 0 (oprional) - ) - - VSUVR = DRPAR + DRUVR - VSUVF = DFPAR + DFUVR - SWNETSNOW = (1.-SNOVR)*VSUVR + (1.-SNOVF)*VSUVF + (1.-SNONR)*DRNIR + (1.-SNONF)*DFNIR - RADDN = LWDNSRF + SWNETSNOW - SWN = SWNETSNOW - if(associated(SNOWALB)) then - where(FR(:,N) > 0.0) - SNOWALB = SNOVR*AWTVDR + SNOVF*AWTVDF + SNONR*AWTIDR + SNONF*AWTIDF - elsewhere - SNOWALB = MAPL_UNDEF - endwhere - where(ZTH < 1.e-6) - SNOWALB = MAPL_UNDEF - endwhere + if (LANDICE_OFFLINE == 0 ) then + CFT = (CH(:,N)/CTATM) + CFQ = (CQ(:,N)/CQATM) + SHF = CFT*(SH + DSH*(TS(:,N)-THATM)) + LHF = CFQ*(EVAP + DEV*(QS(:,N)-QHATM))*MAPL_ALHS + SHD = CFT*DSH + LHD = CFQ*DEV*MAPL_ALHS*GEOS_DQSAT(TS(:,N), PS, PASCALS=.TRUE., RAMP=0.0) + ALWN = ALW + BLWN = BLW + else + CFT = 1.0 + CFQ = 1.0 + SHF = MAPL_CP*CH(:,N)*(TS(:,N)-TA) + LHF = CQ(:,N)*(QS(:,N)-QA) * MAPL_ALHS + SHD = MAPL_CP*CH(:,N) + 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 endif - endif - if(N==ICE) then - do k=1,NT - 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=BLW(k),rain=RAIN(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,:) + SWN = ((DRUVR+DRPAR+DRNIR) + (DFUVR+DFPAR+DFNIR))*(1.0-LANDICEALB) + DIF = 0.0 + ULW = ALWN + BLWN*TS(:,N) + + LANDICECAP= (MAPL_RHOWTR*MAPL_CAPICE*LANDICEDEPTH) + + EVAPI = LHF / MAPL_ALHS + DEVAPDT = LHD / MAPL_ALHS + RADDN = LWDNSRF + SWN + + PERC = 0.0 + MELTI = 0.0 + + + if(N==SNOW) then + + ITYPE = 9 + LAI = 0.0 + GRN = 0.0 + MODISFAC = 1.0 + + !*** have to do a transpose of these internals since their dimensions in SNOW_ALBEDO + !*** are reversed + WESNN = transpose(WESN) + HTSNN = transpose(HTSN) + SNDZN = transpose(SNDZ) + !*** call new/shared routine to compute albedo + + 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 + SNOVR, SNONR, SNOVF, SNONF, & ! instantaneous snow albedos on tiles + RCONSTIT, UU, TS(:,SNOW), DRPAR, DFPAR & ! When only N_constit > 0 (oprional) + ) + + VSUVR = DRPAR + DRUVR + VSUVF = DFPAR + DFUVR + SWNETSNOW = (1.-SNOVR)*VSUVR + (1.-SNOVF)*VSUVF + (1.-SNONR)*DRNIR + (1.-SNONF)*DFNIR + RADDN = LWDNSRF + SWNETSNOW + SWN = SWNETSNOW + if(associated(SNOWALB)) then + where(FR(:,N) > 0.0) + SNOWALB = SNOVR*AWTVDR + SNOVF*AWTVDF + SNONR*AWTIDR + SNONF*AWTIDF + elsewhere + SNOWALB = MAPL_UNDEF + endwhere + where(ZTH < 1.e-6) + SNOWALB = MAPL_UNDEF + endwhere endif - enddo - TS(:,N) = TICE(:,N,1) - if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC - endif + endif - if(N==SNOW) then - LANDICELT = TICE(:,N,1) - MAPL_TICE - do k=1,NT + if(N==ICE) then + do k=1,NT + 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), & + lhflux=LHFO(k),shflux=SHFO(k),hlwout=HLWO(k),evapout=EVAPO(k), & + ghflxice=ghflxice(k)) + else + TICE(k,N,:) = TICE(k,SNOW,:) + endif + enddo + TS(:,N) = TICE(:,N,1) + if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC + endif + + if(N==SNOW) then + LANDICELT = TICE(:,N,1) - MAPL_TICE + do k=1,NT #if 0 - LATSD=LATS(K)*rad_to_deg - LONSD=LONS(K)*rad_to_deg - !if(abs(LATSD-0.700003698112E+02) < 1.e-3 .and. & - ! abs(LONSD-(-0.539905136947E+02)) < 1.e-3 ) then - !if(abs(LATSD-0.605467530483E+02) < 1.e-3 .and. & - ! 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 + LATSD=LATS(K)*rad_to_deg + LONSD=LONS(K)*rad_to_deg + !if(abs(LATSD-0.700003698112E+02) < 1.e-3 .and. & + ! abs(LONSD-(-0.539905136947E+02)) < 1.e-3 ) then + !if(abs(LATSD-0.605467530483E+02) < 1.e-3 .and. & + ! 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 #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),BLW(k), & ! 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 @@ -3099,108 +3125,109 @@ subroutine LANDICECORE(RC) 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) + + ! 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) + 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(RMELTOC002)) RMELTOC002(k) = RMELT(k,9) end if - 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) - - if(associated(LWC ))then - ZDEP = sum(SNDZ(k,:)) - if(sum(WESN(k,:)) > MINSWE) then - if(ZDEP <= LWCTOP) then - LWC(k) = sum(WESN(k,:)*(1.-FROZFRAC(k,:)))/sum(WESN(k,:)) - else - KL = 0 - ZKL = 0.0 - do l=1,NUM_SNOW_LAYERS - ZKL = ZKL + SNDZ(k,l) - if(ZKL > LWCTOP) then - KL = l - exit - endif - 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)) - endif - else - LWC(k) = 0.0 - 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), & - sndz=SNDZ(k,NUM_SNOW_LAYERS) & - ) - if(associated(RUNOFF)) RUNOFF(K) = RUNOFF(K) + FR(K,N) * MELTI(K) - endif - enddo - WESNSC = EVAPO - !PERC = PERC + MELTI - if(associated(RUNOFF)) RUNOFF = RUNOFF + PERC - TS(:,N) = TPSN(:,1)+MAPL_TICE - if(associated(MELTWTRCONT )) MELTWTRCONT = sum(WESN*(1.-FROZFRAC),dim=2) - endif - DQS = GEOS_QSAT(TS(:,N), PS, PASCALS=.TRUE.,RAMP=0.0) - QS(:,N) - QS(:,N) = QS(:,N) + DQS + if(associated(LWC ))then + ZDEP = sum(SNDZ(k,:)) + if(sum(WESN(k,:)) > MINSWE) then + if(ZDEP <= LWCTOP) then + LWC(k) = sum(WESN(k,:)*(1.-FROZFRAC(k,:)))/sum(WESN(k,:)) + else + KL = 0 + ZKL = 0.0 + do l=1,NUM_SNOW_LAYERS + ZKL = ZKL + SNDZ(k,l) + if(ZKL > LWCTOP) then + KL = l + exit + endif + 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)) + endif + else + LWC(k) = 0.0 + 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), & + sndz=SNDZ(k,NUM_SNOW_LAYERS) & + ) + if(associated(RUNOFF)) RUNOFF(K) = RUNOFF(K) + FR(K,N) * MELTI(K) + endif + enddo + WESNSC = EVAPO + !PERC = PERC + MELTI + if(associated(RUNOFF)) RUNOFF = RUNOFF + PERC + TS(:,N) = TPSN(:,1)+MAPL_TICE + if(associated(MELTWTRCONT )) MELTWTRCONT = sum(WESN*(1.-FROZFRAC),dim=2) + endif + + DQS = GEOS_QSAT(TS(:,N), PS, PASCALS=.TRUE.,RAMP=0.0) - QS(:,N) + QS(:,N) = QS(:,N) + DQS - LHF = LHFO - SHF = SHFO - ULW = HLWO + LHF = LHFO + SHF = SHFO + ULW = HLWO - if(associated(EVAPOUT)) EVAPOUT = EVAPOUT + FR(:,N)*EVAPO - if(associated(SUBLIM )) SUBLIM = SUBLIM + FR(:,N)*EVAPO - if(associated(SHOUT )) SHOUT = SHOUT + FR(:,N)*SHF - if(associated(HLATN )) HLATN = HLATN + FR(:,N)*LHF + if(associated(EVAPOUT)) EVAPOUT = EVAPOUT + FR(:,N)*EVAPO + if(associated(SUBLIM )) SUBLIM = SUBLIM + FR(:,N)*EVAPO + if(associated(SHOUT )) SHOUT = SHOUT + FR(:,N)*SHF + if(associated(HLATN )) HLATN = HLATN + FR(:,N)*LHF - if(associated(DELTS )) DELTS = DELTS + DTS*CFT*FR(:,N) - if(associated(DELQS )) DELQS = DELQS + DQS*CFQ*FR(:,N) - if(associated(EVPICE)) EVPICE = EVPICE + FR(:,N)*LHF + if(associated(DELTS )) DELTS = DELTS + DTS*CFT*FR(:,N) + if(associated(DELQS )) DELQS = DELQS + DQS*CFQ*FR(:,N) + if(associated(EVPICE)) EVPICE = EVPICE + FR(:,N)*LHF - !if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC - if(associated(IMELT )) IMELT = IMELT + FR(:,N) * MELTI + !if(associated(RUNOFF)) RUNOFF = RUNOFF + FR(:,N) * PERC + if(associated(IMELT )) IMELT = IMELT + FR(:,N) * MELTI - if(associated(SWNDSRF )) SWNDSRF = SWNDSRF + SWN * FR(:,N) - if(associated(LWNDSRF )) LWNDSRF = LWNDSRF + (LWDNSRF - ULW) * FR(:,N) - 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(SWNDSRF )) SWNDSRF = SWNDSRF + SWN * FR(:,N) + if(associated(LWNDSRF )) LWNDSRF = LWNDSRF + (LWDNSRF - ULW) * FR(:,N) + 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(TICE0 )) then - do k=1,NT - TICE0(k,:) = TICE0(k,:) + TICE(k,N,:) * FR(k,N) - enddo - endif + if(associated(TICE0 )) then + do k=1,NT + TICE0(k,:) = TICE0(k,:) + TICE(k,N,:) * FR(k,N) + enddo + endif - enddo + enddo ! NUM_SUBTILES FR(:,ICE) = max(1.0-FR(:,SNOW), 0.0) 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 5469b0cce..02ec74f9f 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/GEOS_SurfaceGridComp.rc @@ -120,7 +120,7 @@ # - backfilled with global land average snow albedo where unavailable # - must use compatible bcs version that includes MODIS-based snow albedo (e.g., v06, v08, v09, ...) # - NOTE: bcs v06, v08, and v09 used approximate averaging of MODIS-based snow albedo to tile space; -# bcs v11 and v12 employ more accurate, raster-based averaging. +# bcs v11, v12 and v13 employ more accurate, raster-based averaging. # # GEOSagcm=>SNOW_ALBEDO_INFO: 0 # GEOSldas=>SNOW_ALBEDO_INFO: 0 @@ -129,13 +129,15 @@ # GOSWIM aerosol deposition on surface snow # #--------------------------------------------------------# +# *** NOTE: GOSWIM is DISABLED via hardcoded N_constit=0 in StieglitzSnow.F90 *** + # ---- Aerosol deposition on snow (available only with MERRA-2 forcings) # # 0 : GOCART aerosol are NOT used (default) -# 1 : Use all GOCART aerosol data -# 2 : Use GOCART aerosols *except* dust -# 3 : Use GOCART aerosols *except* black carbon -# 4 : Use GOCART aerosols *except* organic carbon +# DISABLED: 1 : Use all GOCART aerosol data +# DISABLED: 2 : Use GOCART aerosols *except* dust +# DISABLED: 3 : Use GOCART aerosols *except* black carbon +# DISABLED: 4 : Use GOCART aerosols *except* organic carbon # # GEOSagcm=>AEROSOL_DEPOSITION: 0 # GEOSldas=>AEROSOL_DEPOSITION: 0 @@ -145,7 +147,7 @@ # NOTE: There are separate parameters for LAND and LANDICE # # 0 : Default, GOSWIM snow albedo scheme is turned OFF for land/landice -# 9 : GOSWIM snow albedo scheme is turned ON for land/landice +# DISABLED: 9 : GOSWIM snow albedo scheme is turned ON for land/landice # # GEOSagcm=>N_CONST_LAND4SNWALB: 0 # GEOSldas=>N_CONST_LAND4SNWALB: 0 diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 index cca760400..c0aa05caf 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Shared/StieglitzSnow.F90 @@ -95,7 +95,24 @@ module StieglitzSnow integer, parameter, public :: NUM_SUDP = 1, NUM_SUSV = 1, NUM_SUWT = 1, NUM_SUSD = 1 integer, parameter, public :: NUM_SSDP = 5, NUM_SSSV = 5, NUM_SSWT = 5, NUM_SSSD = 5 - integer, public, parameter :: N_constit = 9 ! Number of constituents in snow + ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! Turn off GOSWIM by setting N_constit=0 + ! + integer, parameter, public :: N_constit = 0 ! number of constituents *used* below + integer, parameter, private :: N_constit_GOSWIM = 9 ! number of constituents in GOSWIM + ! + ! Previously, N_constit=9 was hardwired even though GOSWIM was never used. + ! The GCM's rc parameter AEROSOL_DEPOSITION was set to 0, which forced + ! the constituent mass and the deposition rates to remain zero, but the many + ! do loops through the 9 constituents were still executed, thus multiplying and adding lots + ! zeros many times. + ! + ! If needed, recover original behavior by setting N_constit=N_constit_GOSWIM=9 + ! + ! - reichle, 31 Jan 2025 + ! + ! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ ! (for riv, rin,aicev, aicen, and denice, instead use Teppei-defined ! values below) @@ -128,7 +145,7 @@ module StieglitzSnow ! constants for snow constituents (dust, carbon, etc.) ! MAC, visible (VIS) - real, private, parameter, dimension(N_constit) :: ABVIS = (/ & + real, private, parameter, dimension(N_constit_GOSWIM) :: ABVIS = (/ & 0.148, & ! Dust1 0.106, & ! Dust2 0.076, & ! Dust3 @@ -140,7 +157,7 @@ module StieglitzSnow 0.114 /) ! Organic carbon hydrophic ! MAC, near-infrared (NIR) - real, private, parameter, dimension(N_constit) :: ABNIR = (/ & + real, private, parameter, dimension(N_constit_GOSWIM) :: ABNIR = (/ & 0.095, & ! Dust1 0.080, & ! Dust2 0.062, & ! Dust3 @@ -158,7 +175,7 @@ module StieglitzSnow ! Tuning parameters so as to satisfy NCAR/CLM based scavenging efficiencies; ! See more in Yasunari et al. (SOLA, 2014) - real, private, parameter, dimension(N_constit) :: SCAV = (/ & + real, private, parameter, dimension(N_constit_GOSWIM) :: SCAV = (/ & 0.065442, & ! Dust 1 0.077829, & ! Dust 2 0.306841, & ! Dust 3 @@ -172,7 +189,7 @@ module StieglitzSnow ! Representative particle size in diameter ! based on effective radius GOCART/GEOS-5 (dust 1-5 bins, BC, and OC) [um] - real, private, parameter, dimension(N_constit) :: PSIZE = (/ & + real, private, parameter, dimension(N_constit_GOSWIM) :: PSIZE = (/ & 1.272, & ! Dust 1 2.649, & ! Dust 2 4.602, & ! Dust 3 @@ -240,7 +257,7 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & ! wesn : Layer water contents per unit area of catchment [kg/m^2] ! htsnn : Layer heat contents relative to liquid water at 0 C [J/m^2] ! sndz : Layer depths [m] - ! rconstit : Mass of constituents in snow layer [kg] (i.e., [kg m-2]) + ! rconstit : Mass of constituents in snow layer [kg] (i.e., [kg m-2]) ! rmelt : Flushed mass amount of constituents from the bottom snow layer [kg m-2 s-1 (kg/m^2/s)] !********* ! OUTPUTS: @@ -403,7 +420,8 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & dtss = 0. excswe = 0. - rmelt = 0.0 + if (N_constit>0) rmelt = 0.0 + mltwtr = 0.0 drho0 = 0.0 tksno = 0.0 @@ -424,7 +442,7 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & do k=1,N_constit rmelt(k)=sum(rconstit(:,k))/dts enddo - rconstit(:,:) = 0. + if (N_constit>0) rconstit(:,:) = 0. if(snowf > 0.) then ! only initialize with non-liquid part of precip ! liquid precip (rainf) is part of outflow from snow base (see "pre" above) @@ -742,9 +760,9 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & !**** Updated by Koster, August 27, 2002. pre = 0. - rmelt(:) = 0. + if (N_constit>0) rmelt(:) = 0. flow = 0. - flow_r(:) = 0. + if (N_constit>0) flow_r(:) = 0. wesnperc = wesn @@ -762,8 +780,11 @@ subroutine StieglitzSnow_snowrt(tile_lon, tile_lat, & pre = max((1.-fices(i))*wesn(i), 0.) flow = 0. - flow_r(:) = 0. - rconc(:) = 0. + + if (N_constit>0) then + flow_r(:) = 0. + rconc(:) = 0. + end if if(snowd > wemin) then 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 706d3cf82..d713fe3c6 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 @@ -49,11 +49,13 @@ ecbuild_add_executable (TARGET mkMOMAquaRaster.x SOURCES mkMOMAquaRaster.F90 LIB ecbuild_add_executable (TARGET FillMomGrid.x SOURCES FillMomGrid.F90 LIBS MAPL ${this}) ecbuild_add_executable (TARGET mk_runofftbl.x SOURCES mk_runofftbl.F90 LIBS MAPL ${this}) 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) 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) +install(PROGRAMS ${MAKE_BCS_PYTHON} DESTINATION bin) +install(PROGRAMS TileFile_ASCII_to_nc4.py DESTINATION bin) set(file ./make_bcs_shared.py) configure_file(${file} ${file} @ONLY) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 index b81da0868..001bce06c 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CombineRasters.F90 @@ -3,7 +3,7 @@ program mkOverlaySimple - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: WriteRaster, WriteTiling, SortTiling use MAPL_SortMod use MAPL_HashMod use MAPL_ExceptionHandling @@ -28,7 +28,7 @@ program mkOverlaySimple integer, parameter :: TILUNIT1 = 22 integer, parameter :: TILUNIT2 = 23 - real(kind=8), parameter :: PI = MAPL_PI_R8 + real(REAL64), parameter :: PI = MAPL_PI_R8 integer :: command_argument_count integer :: nxt, argl, fill @@ -43,12 +43,12 @@ program mkOverlaySimple integer, allocatable :: RST2(: ) integer, allocatable :: iTable(:,:) - real(kind=8) , allocatable :: Table1(:,:) - real(kind=8) , allocatable :: Table2(:,:) - real(kind=8) , allocatable :: rTable(:,:) - real(kind=8) , allocatable :: cc(:), ss(:) - real(kind=8) :: dx, dy, area, xc, yc, d2r, vv(4) - real(kind=8) :: lats, lons, da + real(REAL64) , allocatable :: Table1(:,:) + real(REAL64) , allocatable :: Table2(:,:) + real(REAL64) , allocatable :: rTable(:,:) + real(REAL64) , allocatable :: cc(:), ss(:) + real(REAL64) :: dx, dy, area, xc, yc, d2r, vv(4) + real(REAL64) :: lats, lons, da logical :: DoZip logical :: Verb diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 index d3331da0e..642ad4770 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/CubedSphere_GridMod.F90 @@ -2,7 +2,7 @@ module CubedSphere_GridMod use MAPL_ConstantsMod -#define r8 kind=8 +#define r8 REAL64 implicit none diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 index 36dbc1921..3f282fdbd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/FillMomGrid.F90 @@ -4,10 +4,11 @@ program FillMomGrid - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: WriteRaster, WriteTiling use MAPL_SortMod use MAPL_HashMod use MAPL_ConstantsMod + use, intrinsic :: iso_fortran_env, only: REAL64 ! Modifies Pfafstetter.rst such that for every pixel within a MOM ocean diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/TileFile_ASCII_to_nc4.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/TileFile_ASCII_to_nc4.F90 new file mode 100644 index 000000000..a88c2a7ff --- /dev/null +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/TileFile_ASCII_to_nc4.F90 @@ -0,0 +1,305 @@ +! +! Utility program that converts ASCII-formatted *.til file and catchment.def file into a single nc4 file +! +! Usage TileFile_ASCII-to-nc4.x tile_file catchmentdef_file +! +! wjiang, rreichle, 29 Nov 2024 + +program TileFile_ASCII_to_nc4 + use, intrinsic :: iso_fortran_env, only: REAL64 + use MAPL + use LogRectRasterizeMod, only: WriteTilingNC4, MAPL_UNDEF_R8 + use EASE_conv, only: ease_extent + + implicit none + + character(512) :: arg + integer :: i, unit, unit2 + + character(:), allocatable :: tile_file + character(:), allocatable :: catchmentdef_file + real(REAL64), allocatable :: rTable(:,:) + integer, allocatable :: iTable(:,:) + character(128) :: gName1, gName2 + character(len=512) :: tmpline + + character(:), allocatable :: array(:) + character(len=:), allocatable :: filenameNC4 + + real :: cell_area + + integer :: n_tile, n_grid, n_lon1, n_lat1, n_cat, tmp_in1, tmp_in2 + integer :: n_lon2, n_lat2, nx, ny, num, ll, maxcat + logical :: file_exists + + ! ---------------------------------------------------------------------- + ! + ! process command-line arguments + + CALL get_command_argument(1, arg) + tile_file = trim(arg) + CALL get_command_argument(2, arg) + catchmentdef_file = trim(arg) + + ! ---------------------------------------------------------------------- + ! + ! open and read *.til ASCII file + + open (newunit=unit, file=trim(tile_file), form='formatted', action='read') + + read (unit,*) tmpline ! header line 1: N_tile [maxcat] nx ny (see below) + read (unit,*) N_grid ! header line 2: N_grid [=1 for EASE, =2 otherwise] + read (unit,*) gName1 ! header line 3: name of atm grid + read (unit,*) n_lon1 ! header line 4: N_lon of atm grid + read (unit,*) n_lat1 ! header line 5: N_lat of atm grid + + ! special treatment needed for header line 1 because maxcat is not included in legacy bcs + + call split(tmpline, array, " ") + read(array(1), *) n_tile + num = size(array) + ll = 0 + if (num == 4) then + ll = 1 + read(array(2), *) maxcat ! number of Pfafstetter catchments + else + maxcat = -1 ! maxcat not available in legacy bcs + endif + + read(array(2+ll), *) nx ! N_lon of raster grid + read(array(3+ll), *) ny ! N_lat of raster grid + + if (N_grid == 1) then + + ! EASE grid tile space + + ! in some legacy bcs, dummy ocean grid info is included in header (despite N_grid=1); + ! read next line and decide if it is dummy header or info for first tile + + read (unit,*) tmpline + if (index(tmpline,'OCEAN')/=0) then + read (unit,*) + read (unit,*) + read (unit,*) tmpline + endif + + else + + ! lat/lon or cube-sphere tile space + + read (unit,*) gName2 + read (unit,*) n_lon2 + read (unit,*) n_lat2 + read (unit,*) tmpline ! read info for first tile (to accommodate legacy EASE grid issues above) + + endif + + allocate(iTable(N_tile,0:7)) + allocate(rTable(N_tile,10)) + + rTable = MAPL_UNDEF_r8 + + ! read ASCII tile file (NOTE: Info for first tile is already in tmpline!) + + if ( index(gName1, 'EASE') /=0 ) then ! EASE grid tile space + + read (tmpline,*) iTable(1,0), iTable(1,4), rTable(1,1), rTable(1,2), & + iTable(1,2), iTable(1,3), rTable(1,4) + + do i = 2, N_tile + read (unit,*) iTable(i,0), iTable(i,4), rTable(i,1), rTable(i,2), & + iTable(i,2), iTable(i,3), rTable(i,4) + enddo + + ! rTable(:,4) is tile area fraction within grid cell (fr), convert to area; + ! get fr back in WriteTilingNC4 + + call ease_extent(gName1, tmp_in1, tmp_in2, cell_area=cell_area) ! get EASE grid cell area + + rTable(:,3) = rTable(:,4)*cell_area + rTable(:,4) = cell_area + + else ! lat/lon or cube-sphere tile space + + read (tmpline,*) iTable(1,0), rTable(1,3), rTable(1,1), rTable(1,2), & + iTable(1,2), iTable(1,3), rTable(1,4), iTable(1,6), & + iTable(1,4), iTable(1,5), rTable(1,5), iTable(1,7) + + do i = 2, N_tile + read (unit,*) iTable(i,0), rTable(i,3), rTable(i,1), rTable(i,2), & + iTable(i,2), iTable(i,3), rTable(i,4), iTable(i,6), & + iTable(i,4), iTable(i,5), rTable(i,5), iTable(i,7) + enddo + + ! re-define rTable(:,4) and rTable(:,5). + ! fr will be re-created in WriteTilingNC4 + + where (rTable(:,4) /=0.0) + rTable(:,4) = rTable(:,3)/rTable(:,4) + endwhere + + where (rTable(:,5) /=0.0) + rTable(:,5) = rTable(:,3)/rTable(:,5) + endwhere + + endif + + close(unit) + + ! ---------------------------------------------------------------------- + ! + ! open and read catchment.def ASCII file + + inquire( file= trim(catchmentdef_file), exist=file_exists) + + if (file_exists) then + + open (newunit=unit, file=trim(catchmentdef_file), form='formatted', action='read') + + read(unit, *) n_cat ! number of *land* tiles + + do i = 1, n_cat + read(unit, *) & + tmp_in1, & + tmp_in2, & + rTable(i, 6), & + rTable(i, 7), & + rTable(i, 8), & + rTable(i, 9), & + rTable(i,10) + enddo + + close(unit) + + endif + + ! assemble name of nc4 file + + ll = index(tile_file, '.til') + filenameNC4 = tile_file(1:ll)//'nc4' + + ! write nc4 file + + if (N_grid == 1) then + call WriteTilingNC4(filenameNc4, [gName1 ], [n_lon1 ], [n_lat1 ], nx, ny, iTable, rTable, N_PfafCat=maxcat) + else + call WriteTilingNC4(filenameNc4, [gName1, gName2], [n_lon1, n_lon2], [n_lat1, n_lat2], nx, ny, iTable, rTable, N_PfafCat=maxcat) + endif + +contains + + subroutine split(input_line,array,delimiters,order,nulls) + + character(len=*),intent(in) :: input_line + character(len=*),optional,intent(in) :: delimiters + character(len=*),optional,intent(in) :: order + character(len=*),optional,intent(in) :: nulls + character(len=:),allocatable,intent(out) :: array(:) + + integer :: n + integer,allocatable :: ibegin(:) + integer,allocatable :: iterm(:) + character(len=:),allocatable :: dlim + character(len=:),allocatable :: ordr + character(len=:),allocatable :: nlls + integer :: ii,iiii + integer :: icount + integer :: ilen + integer :: i10,i20,i30 + integer :: icol + integer :: idlim + integer :: ifound + integer :: inotnull + integer :: ireturn + integer :: imax + + ! decide on value for optional DELIMITERS parameter + if (present(delimiters)) then ! optional delimiter list was present + if(delimiters/='')then ! if DELIMITERS was specified and not null use it + dlim=delimiters + else ! DELIMITERS was specified on call as empty string + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified + endif + else ! no delimiter value was specified + dlim=' '//char(9)//char(10)//char(11)//char(12)//char(13)//char(0) ! use default delimiter when not specified + endif + idlim=len(dlim) ! dlim a lot of blanks on some machines if dlim is a big string + + if(present(order))then; ordr=adjustl(order); else; ordr='sequential'; endif ! decide on value for optional ORDER parameter + + if(present(nulls))then; nlls=adjustl(nulls); else; nlls='ignore' ; endif ! optional parameter + + n=len(input_line)+1 ! max number of strings INPUT_LINE could split into if all delimiter + allocate(ibegin(n)) ! allocate enough space to hold starting location of tokens if string all tokens + allocate(iterm(n)) ! allocate enough space to hold ending location of tokens if string all tokens + ibegin(:)=1 + iterm(:)=1 + + ilen=len(input_line) ! ILEN is the column position of the last non-blank character + icount=0 ! how many tokens found + inotnull=0 ! how many tokens found not composed of delimiters + imax=0 ! length of longest token found + + select case (ilen) + + case (0) ! command was totally blank + + case default ! there is at least one non-delimiter in INPUT_LINE if get here + icol=1 ! initialize pointer into input line + INFINITE: do i30=1,ilen,1 ! store into each array element + ibegin(i30)=icol ! assume start new token on the character + if(index(dlim(1:idlim),input_line(icol:icol))==0)then ! if current character is not a delimiter + iterm(i30)=ilen ! initially assume no more tokens + do i10=1,idlim ! search for next delimiter + ifound=index(input_line(ibegin(i30):ilen),dlim(i10:i10)) + IF(ifound>0)then + iterm(i30)=min(iterm(i30),ifound+ibegin(i30)-2) + endif + enddo + icol=iterm(i30)+2 ! next place to look as found end of this token + inotnull=inotnull+1 ! increment count of number of tokens not composed of delimiters + else ! character is a delimiter for a null string + iterm(i30)=icol-1 ! record assumed end of string. Will be less than beginning + icol=icol+1 ! advance pointer into input string + endif + imax=max(imax,iterm(i30)-ibegin(i30)+1) + icount=i30 ! increment count of number of tokens found + if(icol>ilen)then ! no text left + exit INFINITE + endif + enddo INFINITE + + end select + + select case (trim(adjustl(nlls))) + case ('ignore','','ignoreend') + ireturn=inotnull + case default + ireturn=icount + end select + allocate(character(len=imax) :: array(ireturn)) ! allocate the array to return + !allocate(array(ireturn)) ! allocate the array to turn + + select case (trim(adjustl(ordr))) ! decide which order to store tokens + case ('reverse','right') ; ii=ireturn ; iiii=-1 ! last to first + case default ; ii=1 ; iiii=1 ! first to last + end select + + do i20=1,icount ! fill the array with the tokens that were found + if(iterm(i20) clsm/soil read ([UNIT],'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tile_index, pfaf_code, soil_class_top, soil_class_com, BEE, & + tile_index, pfaf_index, soil_class_top, soil_class_com, BEE, & PSIS, POROS, COND, WPWET, DP2BR, gravel, OrgCarbon_top, & OrgCarbon_rz, sand_top, clay_top, sand_rz, clay_rz, WPWET_top, POROS_top, PMAP end do where for each tile: (1) tile_index [-] number - (2) pfaf_code [-] ${pfaf_des} + (2) pfaf_index [-] ${pfaf_des} (3) soil_class_top [-] soil class for the surface layer (0-30cm) (4) soil_class_com [-] soil class for the root-zone (0-100cm) (5) BEE [-] b-parameter of the tension curve @@ -946,14 +953,14 @@ _EOS1_ else cat << _EOS2_ > clsm/soil read ([UNIT],'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') & - tile_index, pfaf_code, soil_class_top, & + tile_index, pfaf_index, soil_class_top, & soil_class_com,BEE, PSIS, POROS, COND, & WPWET, soildepth end do where for each tile: (1) tile_index [-] number - (2) pfaf_code [-] ${pfaf_des} + (2) pfaf_index [-] ${pfaf_des} (3) soil_class_top [-] soil class for the surface layer (0-30cm) (4) soil_class_com [-] soil class for the root-zone (0-100cm) (5) BEE [-] b-parameter of the tension curve @@ -1016,14 +1023,14 @@ cat << _EOV1_ > clsm/veg1 3.2.1 Mosaic vegetation types and fractions file name: mosaic_veg_typs_fracs do n = 1, ${NTILES} - read ([UNIT],(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)) tile_index, pfaf_code, & + read ([UNIT],(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)) tile_index, pfaf_index, & primary_veg_type, secondary_veg_type, primary_veg_frac, & secondary_veg_frac, canopy_height, ASCATZ0 end do where for each tile: (1) tile_index [-] number - (2) pfaf_code [-] ${pfaf_des} + (2) pfaf_index [-] ${pfaf_des} (3) primary_veg_type [-] primary vegetation type [Figure 5 : "plots/mosaic_prim.jpg"] (4) secondary_veg_type [-] secondary vegetation type @@ -1052,7 +1059,7 @@ cat << _EOV2_ > clsm/veg2 file names: CLM_veg_typs_fracs do n = 1, ${NTILES} read ([UNIT],'(2I10,4I3,4f7.2,2I3,2f7.2)') & - tile_index, pfaf_code, & + tile_index, pfaf_index, & CLM-C_pt1, CLM-C_pt2, CLM-C_st1, CLM-C_st2, & CLM-C_pf1, CLM-C_pf2, CLM-C_sf1, CLM-C_sf2, & CLM_pt, CLM_st, CLM_pf, CLM_sf @@ -1060,7 +1067,7 @@ cat << _EOV2_ > clsm/veg2 where for each tile: (1) tile_index [-] number - (2) pfaf_code [-] ${pfaf_des} + (2) pfaf_index [-] ${pfaf_des} (3) CLM-C_pt1 [-] Catchment-CN primary type 1 [Figure 7a : top panel of "plots/CLM-Carbon_PRIM_veg_typs.jpg"] (4) CLM-C_pt2 [-] Catchment-CN primary type 2 (moisture stressed only) @@ -1362,7 +1369,7 @@ cat << _EOF0_ > clsm/README1 file name : tau_param.dat do n = 1, ${NTILES} read ([UNIT],'(i10,i8,4f10.7)') & - tile_index, pfaf_code, atau2, btau2, atau5, btau5 + tile_index, pfaf_index, atau2, btau2, atau5, btau5 end do where: (1) atau2 atau2: Equation (17) for a 2cm surface layer [-] @@ -1374,7 +1381,7 @@ cat << _EOF0_ > clsm/README1 root zone and water table file name : ts.dat do n = 1, ${NTILES} - read ([UNIT],'(i10,i8,f5.2,4(2x,e13.7))') tile_index, pfaf_code,gnu, & + read ([UNIT],'(i10,i8,f5.2,4(2x,e13.7))') tile_index, pfaf_index, gnu, & tsa1, tsa2, tsb1, tsb2 end do @@ -1387,7 +1394,7 @@ cat << _EOF0_ > clsm/README1 6.2.3 Baseflow parameters file name : bf.dat do n = 1, ${NTILES} - read ([UNIT],'(i10,i8,f5.2,3(2x,e13.7))') tile_index, pfaf_code, gnu, bf1, bf2, bf3 + read ([UNIT],'(i10,i8,f5.2,3(2x,e13.7))') tile_index, pfaf_index, gnu, bf1, bf2, bf3 end do where: @@ -1399,7 +1406,7 @@ cat << _EOF0_ > clsm/README1 6.2.4 Area fractioning parameters file name : ar.new do n = 1, ${NTILES} - read ([UNIT],'(i10,i8,f5.2,11(2x,e14.7))') tile_index, pfaf_code, gnu, & + read ([UNIT],'(i10,i8,f5.2,11(2x,e14.7))') tile_index, pfaf_index, gnu, & ars1, ars2, ars3, ara1, ara2, ara3, ara4, arw1, arw2, arw3, arw4 end do @@ -1492,7 +1499,7 @@ cat << _EOF1_ > clsm/README2 water pixel is assumed to be the location of the downstream confluence. 7.2 Data files - 7.2.1 Pafafstetter catchment connectivity, channel information + 7.2.1 Pfafstetter catchment connectivity, channel information file path : /discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/ [NCCS/Discover] file name : land/topo/v1/SRTM-TopoData/Pfafcatch-routing.dat read ([UNIT],*) NPfafs @@ -1503,8 +1510,8 @@ cat << _EOF1_ > clsm/README2 UP_lon, UP_lat, mouth_lon, mouth_lat end do - pfaf_index [-] catchment index (1-$NPfafs) after sorting Pfafstetter codes in ascending order - pfaf_code [-] Pfafstetter code of the hydrologic catchment + pfaf_index [-] Pfafstetter (hydrological) catchment index (1-$NPfafs) after sorting Pfafstetter codes in ascending order + pfaf_code [-] Pfafstetter (routing) code of the hydrologic catchment min_lon [degree] Western edge of the catchment max_lon [degree] Eastern edge of the catchment min_lat [degree] Southern edge of the catchment diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_cube.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_cube.py index 50287a2a3..0311e9bb7 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_cube.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_cube.py @@ -8,81 +8,57 @@ cube_template = """ -if ( {STEP1} == True ) then - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/360x200 data/MOM5/360x200 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/720x410 data/MOM5/720x410 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/1440x1080 data/MOM5/1440x1080 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/72x36 data/MOM6/72x36 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/540x458 data/MOM6/540x458 - ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/1440x1080 data/MOM6/1440x1080 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/360x200 data/MOM5/360x200 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/720x410 data/MOM5/720x410 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM5/1440x1080 data/MOM5/1440x1080 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/72x36 data/MOM6/72x36 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/540x458 data/MOM6/540x458 +ln -s {MAKE_BCS_INPUT_DIR}/ocean/MOM6/1440x1080 data/MOM6/1440x1080 - if( -e CF{NC}x6C{SGNAME}_{DATENAME}{IMO}x{POLENAME}{JMO}.stdout ) /bin/rm -f CF{NC}x6C{SGNAME}_{DATENAME}{IMO}x{POLENAME}{JMO}.stdout +if( -e CF{NC}x6C{SGNAME}_{DATENAME}{IMO}x{POLENAME}{JMO}.stdout ) /bin/rm -f CF{NC}x6C{SGNAME}_{DATENAME}{IMO}x{POLENAME}{JMO}.stdout -endif - -if ( {STEP1} == True ) then - bin/mkCubeFVRaster.x -x {NX} -y {NY} {SGPARAM} {STRETCH} {NC} >/dev/null - bin/mkLandRaster.x -x {NX} -y {NY} -v -t {NT} -endif +bin/mkCubeFVRaster.x -x {NX} -y {NY} {SGPARAM} {STRETCH} {NC} >/dev/null +bin/mkLandRaster.x -x {NX} -y {NY} -v -t {NT} if( {LATLON_OCEAN} == True ) then - - if ( {STEP1} == True ) then - bin/mkLatLonRaster.x -x {NX} -y {NY} -b DE -p PE -t 0 {IMO} {JMO} >/dev/null - bin/CombineRasters.x -f 0 -t {NT} DE{IMO}xPE{JMO} Pfafstetter >/dev/null - bin/CombineRasters.x -t {NT} CF{NC}x6C{SGNAME} DE{IMO}xPE{JMO}-Pfafstetter - setenv OMP_NUM_THREADS 1 - if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} - endif - - if ( {STEP2} == True ) then - setenv OMP_NUM_THREADS {NCPUS} - if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} - chmod 755 bin/create_README.csh - bin/create_README.csh - endif + bin/mkLatLonRaster.x -x {NX} -y {NY} -b DE -p PE -t 0 {IMO} {JMO} >/dev/null + bin/CombineRasters.x -f 0 -t {NT} DE{IMO}xPE{JMO} Pfafstetter >/dev/null + bin/CombineRasters.x -t {NT} CF{NC}x6C{SGNAME} DE{IMO}xPE{JMO}-Pfafstetter + setenv OMP_NUM_THREADS {NCPUS} + if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} + setenv OMP_NUM_THREADS 1 + chmod 755 bin/create_README.csh + bin/create_README.csh endif if( {TRIPOL_OCEAN} == True ) then - if ( {STEP1} == True ) then - bin/mkMOMAquaRaster.x -x {NX} -y {NY} -w {OCEAN_VERSION} data/{MOM_VERSION}/{imo}x{jmo}/MAPL_Tripolar.nc > /dev/null - /bin/cp til/Pfafstetter.til til/Pfafstetter-ORIG.til - /bin/cp rst/Pfafstetter.rst rst/Pfafstetter-ORIG.rst - bin/FillMomGrid.x -f 0 -g Pfafstetter-M {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter data/{MOM_VERSION}/{imo}x{jmo}/MAPL_Tripolar.nc - /bin/mv til/Pfafstetter-M.til til/Pfafstetter.til - /bin/mv rst/Pfafstetter-M.rst rst/Pfafstetter.rst - bin/CombineRasters.x -f 0 -t {NT} {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter >/dev/null - bin/CombineRasters.x -t {NT} CF{NC}x6C{SGNAME} {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter - bin/mk_runofftbl.x -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} - setenv OMP_NUM_THREADS 1 - if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} - endif - - if ( {STEP2} == True ) then - setenv OMP_NUM_THREADS {NCPUS} - if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} - chmod 755 bin/create_README.csh - bin/create_README.csh - endif + bin/mkMOMAquaRaster.x -x {NX} -y {NY} -w {OCEAN_VERSION} data/{MOM_VERSION}/{imo}x{jmo}/MAPL_Tripolar.nc > /dev/null + /bin/cp til/Pfafstetter.til til/Pfafstetter-ORIG.til + /bin/cp rst/Pfafstetter.rst rst/Pfafstetter-ORIG.rst + bin/FillMomGrid.x -f 0 -g Pfafstetter-M {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter data/{MOM_VERSION}/{imo}x{jmo}/MAPL_Tripolar.nc + /bin/mv til/Pfafstetter-M.til til/Pfafstetter.til + /bin/mv rst/Pfafstetter-M.rst rst/Pfafstetter.rst + bin/CombineRasters.x -f 0 -t {NT} {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter >/dev/null + bin/CombineRasters.x -t {NT} CF{NC}x6C{SGNAME} {OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter + bin/mk_runofftbl.x -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} + setenv OMP_NUM_THREADS {NCPUS} + if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} + setenv OMP_NUM_THREADS 1 + chmod 755 bin/create_README.csh + bin/create_README.csh endif if( {CUBED_SPHERE_OCEAN} == True ) then - if ( {STEP1} == True ) then - if ( {IS_STRETCHED} == True ) then - bin/mkCubeFVRaster.x -x {NX} -y {NY} {STRETCH} {NC} >/dev/null - endif - bin/CombineRasters.x -f 0 -t {NT} CF{NC}x6C Pfafstetter >/dev/null - bin/CombineRasters.x -t {NT} {SGPARAM} CF{NC}x6C CF{NC}x6C-Pfafstetter - setenv OMP_NUM_THREADS 1 - if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_CF{NC}x6C-Pfafstetter -v {lbcsv} - endif - - if ( {STEP2} == True ) then - setenv OMP_NUM_THREADS {NCPUS} - if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_CF{NC}x6C-Pfafstetter -v {lbcsv} - chmod 755 bin/create_README.csh - bin/create_README.csh - endif + if ( {IS_STRETCHED} == True ) then + bin/mkCubeFVRaster.x -x {NX} -y {NY} {STRETCH} {NC} >/dev/null + endif + bin/CombineRasters.x -f 0 -t {NT} CF{NC}x6C Pfafstetter >/dev/null + bin/CombineRasters.x -t {NT} {SGPARAM} CF{NC}x6C CF{NC}x6C-Pfafstetter + setenv OMP_NUM_THREADS {NCPUS} + if ({SKIPLAND} != True) bin/mkCatchParam.x -x {NX} -y {NY} -g CF{NC}x6C{SGNAME}_CF{NC}x6C-Pfafstetter -v {lbcsv} + setenv OMP_NUM_THREADS 1 + chmod 755 bin/create_README.csh + bin/create_README.csh endif """ @@ -158,23 +134,13 @@ def make_bcs_cube(config): if not os.path.exists(log_dir): os.makedirs(log_dir) - STEP1 = True - STEP2 = True - GRIDNAME2 = GRIDNAME script_template = get_script_head() + cube_template + get_script_mv(config['grid_type']) - if resolution in ['c1080' ,'c1536', 'c2160', 'c2880', 'c3072','c5760'] : - STEP1 = True - STEP2 = False - script_template = get_script_head() + cube_template script_string = script_template.format(\ account = account, \ EXPDIR = config['expdir'], \ TMP_DIR = tmp_dir, \ GRIDNAME = GRIDNAME, \ - GRIDNAME2 = GRIDNAME2, \ - STEP1 = STEP1, \ - STEP2 = STEP2, \ SCRATCH_DIR = scratch_dir, \ bin_dir = bin_dir, \ MAKE_BCS_INPUT_DIR = config['inputdir'], \ @@ -212,56 +178,6 @@ def make_bcs_cube(config): cube_job.write(script_string) cube_job.close() - if resolution in ['c1080' ,'c1536', 'c2160', 'c2880', 'c3072','c5760'] : - STEP1 = False - STEP2 = True - GRIDNAME2 = GRIDNAME+'-2' - script_template = get_script_head() + cube_template + get_script_mv(config['grid_type']) - script_string = script_template.format(\ - account = account, \ - EXPDIR = config['expdir'], \ - TMP_DIR = tmp_dir, \ - GRIDNAME = GRIDNAME, \ - GRIDNAME2 = GRIDNAME2, \ - STEP1 = STEP1, \ - STEP2 = STEP2, \ - SCRATCH_DIR = scratch_dir, \ - bin_dir = bin_dir, \ - MAKE_BCS_INPUT_DIR = config['inputdir'], \ - DATENAME = DATENAME, \ - POLENAME = POLENAME, \ - OCEAN_VERSION = OCEAN_VERSION, \ - SKIPLAND = SKIPLAND, \ - MOM_VERSION = config['MOM_VERSION'], \ - LATLON_OCEAN= config['LATLON_OCEAN'], \ - TRIPOL_OCEAN= config['TRIPOL_OCEAN'], \ - CUBED_SPHERE_OCEAN = config['CUBED_SPHERE_OCEAN'], \ - nc = nc, \ - nc6 = nc6, \ - imo = config['imo'], \ - jmo = config['jmo'], \ - IRRIGTHRES = 2, \ - IMO = IMO, \ - JMO = JMO, \ - NC = NC, \ - MASKFILE = config['MASKFILE'], \ - lbcsv = config['lbcsv'], \ - NX = config['NX'], \ - NY = config['NY'], \ - NT = config['NT'], \ - RC = RC,\ - SG = SG,\ - STRETCH = STRETCH, \ - SGNAME = SGNAME, \ - SGPARAM = SGPARAM, \ - IS_STRETCHED = IS_STRETCHED, \ - RS = '-Pfafstetter',\ - NCPUS = config['NCPUS']) - - cube_job = open(bcjob+'-2','wt') - cube_job.write(script_string) - cube_job.close() - interactive = os.getenv('SLURM_JOB_ID', default = None) if ( interactive ) : if resolution in ['c1080' ,'c1536', 'c2160', 'c2880', 'c3072','c5760'] : @@ -280,10 +196,6 @@ def make_bcs_cube(config): out = subprocess.check_output(['sbatch', bcjob]) jobid = str(int(out.split()[3])) print( "Submitted batch job " + jobid) - if resolution in ['c1080' ,'c1536', 'c2160', 'c2880', 'c3072','c5760'] : - print("sbatch " + bcjob+'-2' + " depending on " + bcjob + "\n") - subprocess.call(['sbatch', '--dependency=afterok:'+jobid, bcjob+'-2']) - print() print( "cd " + bin_dir) os.chdir(bin_dir) diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_ease.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_ease.py index 2f164e5f6..590b65b8b 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_ease.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_ease.py @@ -8,12 +8,10 @@ ease_template = """ -setenv OMP_NUM_THREADS 1 bin/mkEASETilesParam.x -ease_label {GRIDNAME} -setenv OMP_NUM_THREADS 1 -bin/mkCatchParam.x -g {GRIDNAME} -v {lbcsv} -x {NX} -y {NY} setenv OMP_NUM_THREADS {NCPUS} bin/mkCatchParam.x -g {GRIDNAME} -v {lbcsv} -x {NX} -y {NY} +setenv OMP_NUM_THREADS 1 chmod 755 bin/create_README.csh bin/create_README.csh diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_latlon.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_latlon.py index d552f7ae4..7050a1f9f 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_latlon.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_latlon.py @@ -42,10 +42,9 @@ bin/CombineRasters.x -f 0 -t {NT} {DATENAME}{IMO}x{POLENAME}{JMO} Pfafstetter >/dev/null bin/CombineRasters.x -t {NT} DC{IM}xPC{JM} {DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter bin/mk_runofftbl.x -g DC{IM}xPC{JM}_{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter -v {lbcsv} - setenv OMP_NUM_THREADS 1 - if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g DE{IMO}xPE{JMO}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} setenv OMP_NUM_THREADS {NCPUS} if ( {SKIPLAND} != True ) bin/mkCatchParam.x -x {NX} -y {NY} -g DE{IMO}xPE{JMO}_DE{IMO}xPE{JMO}-Pfafstetter -v {lbcsv} + setenv OMP_NUM_THREADS 1 chmod 755 bin/create_README.csh bin/create_README.csh endif diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_questionary.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_questionary.py index a47b7a535..cb9fcd30a 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_questionary.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_questionary.py @@ -148,7 +148,7 @@ def get_configs_from_answers(answers): config ['expdir'] = expdir config ['outdir'] = outdir config ['inputdir'] = make_bcs_input_dir - config ['NCPUS'] = 20 + config ['NCPUS'] = 16 for x in answers.get('Stretched_CS',[]): config ['SG'] = answers['SG'] @@ -195,8 +195,8 @@ def ask_questions(default_grid="Cubed-Sphere"): "v10 : NL3 + PEATMAP + MODIS snow alb v2", \ "v11 : NL3 + JPL veg height + PEATMAP + MODIS snow alb v2", \ "v12 : NL3 + JPL veg height + PEATMAP + MODIS snow alb v2 + Argentina peatland fix", \ - "v13 : NL3 + JPL veg height + PEATMAP + MODIS snow alb v2 + Argentina peatland fix + Irrigation", \ - + "v13 : NL3 + JPL veg height + PEATMAP + MODIS snow alb v2 + Argentina peatland fix + mean land elevation fix", \ + "v14 : v13 + Irrigation", \ "ICA : Icarus (archived*: /discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Icarus/)", \ "GM4 : Ganymed-4_0 (archived*: /discover/nobackup/projects/gmao/bcs_shared/legacy_bcs/Ganymed-4_0/)", \ "F25 : Fortuna-2_5 (archived*: n/a)"], diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py index 95c047446..317c6985d 100755 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/make_bcs_shared.py @@ -10,16 +10,16 @@ def get_script_head() : head = """#!/bin/csh -x -#SBATCH --output={EXPDIR}/{TMP_DIR}/logs/{GRIDNAME}/{GRIDNAME2}.log -#SBATCH --error={EXPDIR}/{TMP_DIR}/logs/{GRIDNAME}/{GRIDNAME2}.err +#SBATCH --output={EXPDIR}/{TMP_DIR}/logs/{GRIDNAME}/{GRIDNAME}.log +#SBATCH --error={EXPDIR}/{TMP_DIR}/logs/{GRIDNAME}/{GRIDNAME}.err #SBATCH --account={account} #SBATCH --time=12:00:00 #SBATCH --nodes=1 -#SBATCH --job-name={GRIDNAME2}.j +#SBATCH --job-name={GRIDNAME}.j """ - constraint = "#SBATCH --constraint=sky|cas" - if BUILT_ON_SLES15 : - constraint = "#SBATCH --constraint=mil" + constraint = '#SBATCH --constraint="[mil|cas]"' + #if 'TRUE' not in BUILT_ON_SLES15: + # constraint = "#SBATCH --constraint=sky" head = head + constraint + """ echo "-----------------------------" @@ -34,6 +34,7 @@ def get_script_head() : endif source bin/g5_modules +module load nco setenv MASKFILE {MASKFILE} setenv MAKE_BCS_INPUT_DIR {MAKE_BCS_INPUT_DIR} limit stacksize unlimited @@ -52,33 +53,23 @@ def get_change_til_file(grid_type): script = """ cd geometry/{GRIDNAME}/ -/bin/rm -f sedfile if( {TRIPOL_OCEAN} == True ) then -cat > sedfile << EOF -s/CF{NC}x6C/PE{nc}x{nc6}-CF/g -s/{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{OCEAN_VERSION}/g -EOF -sed -f sedfile {GRIDNAME}{RS}.til > tile.file -/bin/mv -f tile.file {GRIDNAME}{RS}.til -/bin/rm -f sedfile + sed -i 's/{OCEAN_VERSION}{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{OCEAN_VERSION}/g' {GRIDNAME}{RS}.til + sed -i 's/CF{NC}x6C/PE{nc}x{nc6}-CF/g' {GRIDNAME}{RS}.til + ncatted -a Grid_Name,global,o,c,'PE{nc}x{nc6}-CF' {GRIDNAME}{RS}.nc4 + ncatted -a Grid_ocn_Name,global,o,c,'PE{imo}x{jmo}-{OCEAN_VERSION}' {GRIDNAME}{RS}.nc4 endif if( {CUBED_SPHERE_OCEAN} == True ) then -cat > sedfile << EOF -s/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/OC{nc}x{nc6}-CF/g -s/CF{NC}x6C{SGNAME}/PE{nc}x{nc6}-CF/g -EOF -sed -f sedfile {GRIDNAME}{RS}.til > tile.file -/bin/mv -f tile.file {GRIDNAME}{RS}.til -/bin/rm -f sedfile + sed -i 's/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/OC{nc}x{nc6}-CF/g' {GRIDNAME}{RS}.til + sed -i 's/CF{NC}x6C{SGNAME}/PE{nc}x{nc6}-CF/g' {GRIDNAME}{RS}.til + ncatted -a Grid_Name,global,o,c,'PE{nc}x{nc6}-CF' {GRIDNAME}{RS}.nc4 + ncatted -a Grid_ocn_Name,global,o,c,'OC{nc}x{nc6}-CF' {GRIDNAME}{RS}.nc4 endif if( {LATLON_OCEAN} == True ) then -cat > sedfile << EOF -s/CF{NC}x6C{SGNAME}/PE{nc}x{nc6}-CF/g -s/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{DATENAME}/g -EOF -sed -f sedfile {GRIDNAME}{RS}.til > tile.file -/bin/mv -f tile.file {GRIDNAME}{RS}.til -/bin/rm -f sedfile + sed -i 's/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{DATENAME}/g' {GRIDNAME}{RS}.til + sed -i 's/CF{NC}x6C{SGNAME}/PE{nc}x{nc6}-CF/g' {GRIDNAME}{RS}.til + ncatted -a Grid_Name,global,o,c,'PE{nc}x{nc6}-CF' {GRIDNAME}{RS}.nc4 + ncatted -a Grid_ocn_Name,global,o,c,'PE{imo}x{jmo}-{DATENAME}' {GRIDNAME}{RS}.nc4 endif cd ../../ @@ -87,14 +78,10 @@ def get_change_til_file(grid_type): script = """ cd geometry/{GRIDNAME}/ -/bin/rm -f sedfile -cat > sedfile << EOF -s/DC{IM}xPC{JM}/PC{im}x{jm}-DC/g -s/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{DATENAME}/g -EOF -sed -f sedfile {GRIDNAME}{RS}.til > tile.file -/bin/mv -f tile.file {GRIDNAME}{RS}.til -/bin/rm -f sedfile +sed -i 's/{DATENAME}{IMO}x{POLENAME}{JMO}-Pfafstetter/PE{imo}x{jmo}-{DATENAME}/g' {GRIDNAME}{RS}.til +sed -i 's/DC{IM}xPC{JM}/PC{im}x{jm}-DC/g' {GRIDNAME}{RS}.til +ncatted -a Grid_Name,global,o,c,'PC{im}x{jm}-DC' {GRIDNAME}{RS}.nc4 +ncatted -a Grid_ocn_Name,global,o,c,'PE{imo}x{jmo}-{DATENAME}' {GRIDNAME}{RS}.nc4 cd ../../ """ @@ -107,6 +94,7 @@ def get_script_mv(grid_type): mkdir -p geometry/{GRIDNAME} /bin/mv {GRIDNAME}.j geometry/{GRIDNAME}/. /bin/cp til/{GRIDNAME}{RS}.til geometry/{GRIDNAME}/. +/bin/cp til/{GRIDNAME}{RS}.nc4 geometry/{GRIDNAME}/. if( {TRIPOL_OCEAN} == True ) /bin/cp til/{GRIDNAME}{RS}.TRN geometry/{GRIDNAME}/. /bin/mv rst til geometry/{GRIDNAME}/. diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 index d6e821b7f..68b2b3649 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCatchParam.F90 @@ -19,6 +19,7 @@ PROGRAM mkCatchParam ! Sarith Mahanama - March 23, 2012 ! Email: sarith.p.mahanama@nasa.gov use EASE_conv + use LogRectRasterizeMod, ONLY: ReadTilingNC4 use rmTinyCatchParaMod use process_hres_data use module_irrig_params, ONLY : create_irrig_params @@ -58,10 +59,16 @@ PROGRAM mkCatchParam type (regrid_map) :: maparc30, mapgeoland2,maparc60 character*200 :: tmpstring, tmpstring1, tmpstring2 character*200 :: fname_tmp, fname_tmp2, fname_tmp3, fname_tmp4 - integer :: N_tile + integer :: n_land logical :: process_snow_albedo = .false. character(len=10) :: nc_string, nr_string - integer :: nc_ease, nr_ease + integer :: nc_ease, nr_ease, unit, clock_rate, clock1, clock2 + real :: seconds + integer, allocatable :: iTable(:,:), tile_pfs(:), tile_j_dum(:) + integer, pointer :: tile_id(:,:) + real, allocatable :: tile_lat(:), tile_lon(:), min_lon(:), max_lon(:), min_lat(:), max_lat(:) + real :: minlon, minlat, maxlon, maxlat, elev + integer :: tindex1, pfaf1, n, status ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ ! @@ -112,6 +119,7 @@ PROGRAM mkCatchParam ! Process Arguments !------------------ + CALL system_clock(count_rate=clock_rate) CALL get_command (cmd) inquire(file='clsm/mkCatchParam.log', exist=file_exists) if(file_exists) then @@ -197,7 +205,7 @@ PROGRAM mkCatchParam if (trim(SNOWALB)=='MODC061' .or. trim(SNOWALB) =='MODC061v2') process_snow_albedo=.true. - if(n_threads == 1) then +! if(n_threads == 1) then write (log_file,'(a)')trim(LAIBCS) write (log_file,'(a)')trim(MODALB) @@ -230,33 +238,77 @@ PROGRAM mkCatchParam ! ! ****************************************************************************** + allocate(tile_id(nc, nr)) + fname_tmp = trim(fnameRst)//'.rst' + open (newunit=unit,file=fname_tmp,status='old',action='read',form='unformatted',convert='little_endian', IOSTAT=status) + if (status /=0) then + write (log_file,'(a)')' '//trim(fname_tmp) // 'cannot be opened, exit ' + call exit(1) + endif + do j = 1, nr + read(unit)tile_id(:,j) + end do + close(unit) ! Creating catchment.def ! ---------------------- - tmpstring = 'Step 01: Supplemental catchment definitions' + tmpstring = 'Step 01: Supplemental tile attributes and nc4-formatted tile file' fname_tmp = 'clsm/catchment.def' write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' if(.not.ease_grid) then inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' - call catchment_def (nc,nr,regrid,dl,fnameTil,fnameRst) - write (log_file,'(a)')' Done.' + write (log_file,'(a)')' Creating catchment def and nc4 tile file...' + call system_clock(clock1) + call supplemental_tile_attributes(nc,nr,regrid,dl,fnameTil, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif else write (log_file,'(a)')'Skipping step for EASE grid. ' + write (log_file,'(a)')'catchment.def file and tile file should already be created by mkEASETilesParam.x ' endif write (log_file,'(a)')' ' - open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - read (10, *) N_tile - close (10, status = 'keep') + call ReadTilingNC4( trim(fnameTil)//".nc4", iTable = iTable) + N_land = count(iTable(:,0) == 100) ! n_land = number of land tiles + allocate(tile_j_dum, source = iTable(1:n_land,7)) ! possible used in cti_stats.dat + deallocate (iTable) + + ! reading from catchment to preserve zero-diff + open (newunit=unit,file='clsm/catchment.def',status='old',action='read',form='formatted', IOSTAT=status) + if (status /=0) then + write (log_file,'(a)')' clsm/cathment.def cannot be opened, exit ' + call exit(1) + endif + read(unit,*) N + if (n /= n_land) then + write (log_file,'(a)')'n_land not consistent between tile file and catchment.def file, exit ' + write (log_file,*) n_land, n + call exit(1) + endif + + allocate(min_lon(n_land), max_lon(n_land), min_lat(n_land), max_lat(n_land)) + allocate(tile_lat(n_land), tile_lon(n_land)) + allocate(tile_pfs(n_land)) + + do n = 1, N_land + read (unit,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat, elev + min_lon(n) = minlon + max_lon(n) = maxlon + min_lat(n) = minlat + max_lat(n) = maxlat + tile_lon(n)= (minlon + maxlon)/2.0 + tile_lat(n)= (minlat + maxlat)/2.0 + tile_pfs(n)= pfaf1 + end do + close (unit,status='keep') inquire(file='clsm/catch_params.nc4', exist=file_exists) - if (.not.file_exists) CALL open_landparam_nc4_files(N_tile,process_snow_albedo) + if (.not.file_exists) CALL open_landparam_nc4_files(N_land,process_snow_albedo) ! Creating cti_stats.dat ! ---------------------- @@ -266,9 +318,12 @@ PROGRAM mkCatchParam write (log_file,'(a,a,a,a)') trim(tmpstring), ' (', trim(fname_tmp), ')' inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then - write (log_file,'(a)')' Creating file...' - call cti_stat_file (ease_grid,fnameTil, MaskFile) - write (log_file,'(a)')' Done.' + write (log_file,'(a)')' Creating file...' + call system_clock(clock1) + call cti_stat_file (MaskFile, n_land, tile_pfs, tile_j_dum) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -285,8 +340,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call ESA2MOSAIC (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call ESA2MOSAIC (nc,nr, n_land, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -298,8 +356,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call ESA2CLM (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call ESA2CLM (nc,nr, n_land, tile_lat, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -313,8 +374,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call compute_mosaic_veg_types (nc,nr,ease_grid,regrid,fnameTil,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call compute_mosaic_veg_types (nc, nr, regrid, n_land, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -354,13 +418,23 @@ PROGRAM mkCatchParam if (.not.file_exists) then write (log_file,'(a)')' Creating file...' !allocate (mapgeoland2 (1:40320,1:20160)) - call create_mapping (nc,nr,40320,20160,mapgeoland2, fnameRst) - lai_name = 'GEOLAND2_10-DayClim/geoland2_' + call system_clock(clock1) + call create_mapping (nc,nr,40320,20160,mapgeoland2, n_land, tile_id ) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done create mapping mapgeoland2. Spent ', seconds, " seconds" + lai_name = 'GEOLAND2_10-DayClim/geoland2_' + + write (log_file,'(a)')' Creating '//lai_name + call system_clock(clock1) if(trim(LAIBCS) == 'GEOLAND2') then - call hres_lai_no_gswp (40320,20160,mapgeoland2, lai_name) + call hres_lai_no_gswp (40320,20160,mapgeoland2, lai_name, n_land, tile_lon, tile_lat) else - call hres_lai_no_gswp (40320,20160,mapgeoland2, lai_name, merge=1) + call hres_lai_no_gswp (40320,20160,mapgeoland2, lai_name, n_land, tile_lon, tile_lat, merge=1) endif + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" ! if(allocated(mapgeoland2)) deallocate (mapgeoland2) deallocate (mapgeoland2%map) deallocate (mapgeoland2%ij_index) @@ -372,7 +446,11 @@ PROGRAM mkCatchParam if ((LAIBCS == 'MODGEO').or.(LAIBCS == 'MODIS').or.(MODALB == 'MODIS2')) then ! allocate (maparc30 (1:43200,1:21600)) - call create_mapping (nc,nr,43200,21600,maparc30, fnameRst) + call system_clock(clock1) + call create_mapping (nc,nr,43200,21600,maparc30, n_land, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done create mapping maparc30. Spent ', seconds, " seconds" endif fname_tmp = 'clsm/green.dat' @@ -380,16 +458,20 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' + + call system_clock(clock1) if (trim(LAIBCS) == 'GSWP2') then - call process_gswp2_veg (nc,nr,regrid,'grnFrac',fnameRst) + call process_gswp2_veg (nc,nr,regrid,'grnFrac',n_land, tile_id) else if (size(maparc30%ij_index,1) /= 43200) then ! allocate (maparc30 (1:43200,1:21600)) - call create_mapping (nc,nr,43200,21600,maparc30, fnameRst) + call create_mapping (nc,nr,43200,21600,maparc30, n_land, tile_id) endif - call hres_gswp2 (43200,21600, maparc30, 'green') + call hres_gswp2 (43200,21600, maparc30, 'green', n_land, tile_lon, tile_lat) endif - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -401,44 +483,46 @@ PROGRAM mkCatchParam write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' redo_modis = .true. - if (trim(LAIBCS) == 'GSWP2') call process_gswp2_veg (nc,nr,regrid,'LAI',fnameRst) + call system_clock(clock1) + if (trim(LAIBCS) == 'GSWP2') call process_gswp2_veg (nc,nr,regrid,'LAI', n_land, tile_id) if (trim(LAIBCS) == 'GSWPH') then if (size(maparc30%ij_index,1) /= 43200) then ! allocate (maparc30 (1:43200,1:21600)) - call create_mapping (nc,nr,43200,21600,maparc30, fnameRst) + call create_mapping (nc,nr,43200,21600,maparc30, n_land, tile_id) endif inquire(file='clsm/lai.MODIS_8-DayClim', exist=file_exists) - if (.not.file_exists) call hres_gswp2 (43200,21600, maparc30, 'lai') + if (.not.file_exists) call hres_gswp2 (43200,21600, maparc30, 'lai', n_land, tile_lon, tile_lat) endif if (trim(LAIBCS) == 'MODIS') then lai_name = 'MODIS_8-DayClim/MODIS_' - call hres_lai_no_gswp (43200,21600,maparc30,lai_name) + call hres_lai_no_gswp (43200,21600,maparc30,lai_name, n_land, tile_lon, tile_lon) endif if (trim(LAIBCS) == 'MODGEO') then lai_name = 'MODIS_8-DayClim/MODIS_' inquire(file='clsm/lai.MODIS_8-DayClim', exist=file_exists) - if (.not.file_exists)call hres_lai_no_gswp (43200,21600,maparc30,lai_name, merge=1) - call merge_lai_data (MaskFile) + if (.not.file_exists)call hres_lai_no_gswp (43200,21600,maparc30,lai_name, n_land, tile_lon, tile_lat, merge=1) + call merge_lai_data (MaskFile, n_land, tile_pfs) endif if (trim(LAIBCS) == 'MODISV6') then lai_name = 'MCD15A2H.006/MODIS_' - call grid2tile_modis6 (86400,43200,nc,nr,fnameRst,lai_name) + call grid2tile_modis6 (86400,43200,nc,nr,n_land, tile_lon, tile_lat, tile_id, lai_name) endif if (trim(LAIBCS) == 'GLASSA') then lai_name = 'GLASS-LAI/AVHRR.v4/GLASS01B02.V04.AYYYY' - call grid2tile_glass (nc,nr,fnameRst,lai_name) + call grid2tile_glass (nc,nr, tile_id,lai_name, n_land, tile_lon, tile_lat) endif if (trim(LAIBCS) == 'GLASSM') then lai_name = 'GLASS-LAI/MODIS.v4/GLASS01B01.V04.AYYYY' - call grid2tile_glass (nc,nr,fnameRst,lai_name) + call grid2tile_glass (nc,nr,tile_id,lai_name, n_land, tile_lon, tile_lat) endif - - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -448,8 +532,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' - call gimms_clim_ndvi (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call gimms_clim_ndvi (nc,nr, n_land, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -474,16 +561,19 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' + call system_clock(clock1) if(F25Tag) then - call create_mapping (nc,nr,21600,10800,maparc60, fnameRst) - call modis_alb_on_tiles_high (21600,10800,maparc60,MODALB) + call create_mapping (nc,nr,21600,10800,maparc60, n_land, tile_id) + call modis_alb_on_tiles_high (21600,10800,maparc60,MODALB, n_land) deallocate (maparc60%map) deallocate (maparc60%ij_index) else ! This option is for legacy sets like Fortuna 2.1 - call modis_alb_on_tiles (nc,nr,ease_grid,regrid,fnameTil,fnameRst) + call modis_alb_on_tiles (nc,nr,regrid, n_land, tile_id) endif - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -496,9 +586,12 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp ), exist=file_exists ) inquire(file=trim(fname_tmp2), exist=file_exists2) if ((.not.file_exists).or.(.not.file_exists2)) then + call system_clock(clock1) write (log_file,'(a)')' Creating files...' - call modis_alb_on_tiles_high (43200,21600,maparc30,MODALB) - write (log_file,'(a)')' Done.' + call modis_alb_on_tiles_high (43200,21600,maparc30,MODALB, n_land) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -521,7 +614,8 @@ PROGRAM mkCatchParam if ((redo_modis).or.(.not.file_exists).or.(.not.file_exists2)) then ! if(.not.F25Tag) then write (log_file,'(a)')' Creating files... (resolution will be added to file name later)' - call modis_scale_para_high (ease_grid,MODALB,fnameTil) + call system_clock(clock1) + call modis_scale_para_high (MODALB, n_land) ! else ! This option is for legacy sets like Fortuna 2.1 ! inquire(file='clsm/modis_scale_factor.albvf.clim', exist=file_exists) @@ -530,7 +624,9 @@ PROGRAM mkCatchParam ! call REFORMAT_VEGFILES ! endif ! endif - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing files.' endif @@ -540,15 +636,18 @@ PROGRAM mkCatchParam ! write(tmpstring2,'(2(a2,x,i5,x))')'-x',nc,'-y',nr ! tmpstring = 'bin/mkCatchParam_openmp '//trim(tmpstring2)//' '//trim(tmpstring1) - else +! else ! this block is for n_threads>1 !============================== if(trim(SOILBCS)=='NGDC') then write (log_file,'(a)')'Creating (intermediate) NGDC soil types file...' - call create_soil_types_files (nc,nr,ease_grid,fnameTil,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call create_soil_types_files (nc,nr, n_land, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" write (log_file,'(a)')' ' endif @@ -562,12 +661,15 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' + call system_clock(clock1) if(trim(SOILBCS)=='NGDC') then - if( F25Tag) call soil_para_high (nc,nr,regrid,fnameRst,F25Tag=F25Tag) - if(.not.F25Tag) call soil_para_high (nc,nr,regrid,fnameRst) + if( F25Tag) call soil_para_high (nc,nr,regrid, n_land, tile_id,F25Tag=F25Tag) + if(.not.F25Tag) call soil_para_high (nc,nr,regrid, n_land, tile_id) endif - if(SOILBCS(1:4)=='HWSD') call soil_para_hwsd (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + if(SOILBCS(1:4)=='HWSD') call soil_para_hwsd (nc,nr, n_land, tile_pfs, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a,a)')' Using existing file.' endif @@ -586,9 +688,12 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp4), exist=file_exists4) if ((.not.file_exists).or.(.not.file_exists2).or.(.not.file_exists3).or.(.not.file_exists4)) then write (log_file,'(a)')' Creating files...' - if(trim(SOILBCS)=='NGDC') call create_model_para( MaskFile) - if(SOILBCS(1:4) =='HWSD') call create_model_para_woesten(MaskFile) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + if(trim(SOILBCS)=='NGDC') call create_model_para( MaskFile, n_land, tile_lon, tile_lat, tile_pfs) + if(SOILBCS(1:4) =='HWSD') call create_model_para_woesten(MaskFile, n_land, tile_lon, tile_lat, tile_pfs) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) ' Done. Spent ', seconds, " seconds" else write (log_file,'(a,a)')' Using existing files.' endif @@ -609,8 +714,11 @@ PROGRAM mkCatchParam inquire(file='clsm/CLM_veg_typs_fracs', exist=file_exists) if (file_exists) then write (log_file,'(a)')' Creating file...' - call grid2tile_ndep_t2m_alb (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call grid2tile_ndep_t2m_alb (nc,nr, n_land,tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" else write (log_file,'(a)')'Skipping step for lack of matching veg types file.' endif @@ -622,8 +730,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call CLM45_fixed_parameters (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call CLM45_fixed_parameters (nc,nr, n_land, tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -635,8 +746,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file... (resolution will be added to file name later)' - call CLM45_clim_parameters (nc,nr,fnameRst) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call CLM45_clim_parameters (nc,nr,n_land,tile_id) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -648,8 +762,11 @@ PROGRAM mkCatchParam inquire(file=trim(fname_tmp), exist=file_exists) if (.not.file_exists) then write (log_file,'(a)')' Creating file...' - call map_country_codes (nc,nr) - write (log_file,'(a)')' Done.' + call system_clock(clock1) + call map_country_codes (nc,nr,n_land, tile_lon, tile_lat) + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" else write (log_file,'(a)')' Using existing file.' endif @@ -659,18 +776,21 @@ PROGRAM mkCatchParam tmpstring = 'Step 14: Static snow albedo from MODIS' write (log_file,'(a)') trim(tmpstring) write (log_file,'(a)')' Creating file...' + call system_clock(clock1) if (trim(SNOWALB)=='MODC061') then - call MODIS_snow_alb ( ) + call MODIS_snow_alb (n_land, min_lon, max_lon, min_lat, max_lat) elseif (trim(SNOWALB)=='MODC061v2') then if (size(maparc30%ij_index,1) /= 43200) then - call create_mapping (nc,nr,43200,21600,maparc30,fnameRst) + call create_mapping (nc,nr,43200,21600,maparc30, n_land, tile_id) end if - call MODIS_snow_alb_v2(43200,21600,maparc30) + call MODIS_snow_alb_v2(43200,21600,maparc30, n_land) else write (log_file,'(a)')'Unknown SNOWALB... stopping!' stop endif - write (log_file,'(a)')' Done.' + call system_clock(clock2) + seconds = (clock2-clock1)/real(clock_rate) + write (log_file, *) 'Done. Spent ', seconds, " seconds" write (log_file,'(a)')' ' endif @@ -692,7 +812,7 @@ PROGRAM mkCatchParam write (log_file,'(a)')' ' ! call execute_command_line ('chmod 755 bin/create_README.csh ; bin/create_README.csh') - endif +! endif close (log_file,status='keep') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 index 5b1c4d12a..ad6f663dc 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkCubeFVRaster.F90 @@ -16,7 +16,7 @@ program mkCubeFVRaster ! !USES: ! use CubedSphere_GridMod - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling !EOP diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 index d64bf0967..867b47165 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkEASETilesParam.F90 @@ -30,20 +30,23 @@ PROGRAM mkEASETilesParam ! - added comments ! - white-space changes for improved readability - use EASE_conv, only : EASE_extent, EASE_convert, EASE_inverse - use rmTinyCatchParaMod, only : i_raster, j_raster, SRTM_maxcat - use rmTinyCatchParaMod, only : RegridRasterReal - use process_hres_data, only : histogram + use EASE_conv, only : EASE_extent, EASE_convert, EASE_inverse + use rmTinyCatchParaMod, only : i_raster, j_raster + use rmTinyCatchParaMod, only : RegridRasterReal + use rmTinyCatchParaMod, only : Target_mean_land_elev + use process_hres_data, only : histogram + use LogRectRasterizeMod, only : WriteTilingNC4, SRTM_maxcat, MAPL_UNDEF_R8 ! rasterize.F90 use MAPL_SortMod use MAPL_ConstantsMod use MAPL_ExceptionHandling + use MAPL use netcdf implicit none - integer, parameter :: nc_esa = 129600 ! number of cols in 10-arcsec ESA mask file - integer, parameter :: nr_esa = 64800 ! number of rows in 10-arcsec ESA mask file - + integer, parameter :: nc_esa = 129600 ! number of cols in 10-arcsec ESA mask file + integer, parameter :: nr_esa = 64800 ! number of rows in 10-arcsec ESA mask file + ! define tile types used for processing here (values may be from ESA mask?) integer, parameter :: OceanType = 0 @@ -51,8 +54,6 @@ PROGRAM mkEASETilesParam integer, parameter :: LakeType = 10 ! lake type used for processing here; in GEOS, lake tiles are type= 19 integer, parameter :: IceType = 11 ! landice type used for processing here; in GEOS, landice tiles are type= 20 - real*8, parameter :: Target_mean_land_elev = 614.649D0 - ! ------------------------------------------------------------ integer :: i, j, ig, jg, nn, kkE, kkR, mm @@ -70,7 +71,7 @@ PROGRAM mkEASETilesParam integer :: dx_esa, dy_esa, NBINS, NPLUS integer*8, allocatable, dimension(:) :: SRTM_catid - real(kind=8),allocatable, dimension(:) :: SRTM_catid_r8 + real(REAL64),allocatable, dimension(:) :: SRTM_catid_r8 integer, allocatable, dimension(:,:), target :: tileid_index, catid_index @@ -82,7 +83,9 @@ PROGRAM mkEASETilesParam integer*1, allocatable, dimension(:,:) :: veg real*4, allocatable, dimension(:,:) :: q0, raster REAL, allocatable, dimension(:) :: tile_elev - + integer, allocatable, dimension(:,:) :: iTable + real(REAL64),allocatable, dimension(:,:) :: rTable + !INTEGER*8 :: PFAF_CODE integer :: l, l_index, i_index, w_index, typ, pfaf_index @@ -612,7 +615,7 @@ PROGRAM mkEASETilesParam allocate(my_land (1:n_landlakelandice)) allocate(all_id (1:n_landlakelandice)) - allocate(tile_elev (1:n_land)) + allocate(tile_elev (1:n_landlakelandice)) ! =========================================================================== ! @@ -708,13 +711,6 @@ PROGRAM mkEASETilesParam tileid_index(i,j) = land_id(kkE) - ! sum up area and (area-weighted) elevation (only over raster grid cells of type land!) - - tile_elev( tileid_index(i,j)) = tile_elev( tileid_index(i,j)) + q0(i,j) * pix_area ! q0 = elevation - - ! tile_area_land should be obsolete because identical to tile_area(1:n_land) - !tile_area_land(tileid_index(i,j)) = tile_area_land(tileid_index(i,j)) + pix_area - case default print *,'ERROR: unknown tile type value in veg(i,j): ', veg(i,j), ' STOPPING.' @@ -726,6 +722,12 @@ PROGRAM mkEASETilesParam tile_area(tileid_index(i,j)) = tile_area(tileid_index(i,j)) + pix_area + ! sum up (area-weighted) elevation + + tile_elev(tileid_index(i,j)) = tile_elev(tileid_index(i,j)) + q0(i,j) * pix_area ! q0 = elevation on 30-arcsec raster + + ! record 1-dim indices w.r.t. EASE grid cell and raster grid cell + my_land(tileid_index(i,j)) = kkE ! for this tile, store 1-dim index for EASE grid cells all_id( tileid_index(i,j)) = kkR ! for this tile, store 1-dim index for raster grid cells - last in prevails! @@ -770,7 +772,7 @@ PROGRAM mkEASETilesParam deallocate(water_id) deallocate(ice_id ) - tile_elev = tile_elev/tile_area(1:n_land) ! finalize tile elevation + tile_elev = tile_elev/tile_area(1:n_landlakelandice) ! finalize tile elevation ! --------------------------------------------------------------------------------- @@ -793,7 +795,7 @@ PROGRAM mkEASETilesParam print *, 'Global mean land elevation before adjustment [m]: ', mean_land_elev - tile_elev = tile_elev*(Target_mean_land_elev/mean_land_elev) + tile_elev(1:n_land) = tile_elev(1:n_land)*(Target_mean_land_elev/mean_land_elev) ! print adjusted elevation to log file mean_land_elev=0. @@ -845,6 +847,9 @@ PROGRAM mkEASETilesParam ! write (10,*) -9999 dx_ease = 180./real(nc_ease) + + allocate(iTable(n_landlakelandice,0:4)) ! 0-based index inherited from elsewhere in make_bcs + allocate(rTable(n_landlakelandice,10), source = MAPL_UNDEF_R8) do nn=1,n_landlakelandice @@ -875,6 +880,26 @@ PROGRAM mkEASETilesParam i = kkR - nc*(j-1) ! (1-based) pfaf_index = catid_index(i,j) + + ! get min/max lat/lon of EASE grid cell + ! BUG: This is *not* the desired min/max lat/lon of the land tile!!! + + call EASE_inverse( EASELabel, real(ig-1), real(jg-1), clat, clon ) + + mnx = clon - dx_ease + mxx = clon + dx_ease + + jgv = real(jg-1) + 0.5 + + call EASE_inverse( EASELabel, real(ig-1), jgv, clat, clon ) + + mny = clat + + jgv = real(jg-1) - 0.5 + + call EASE_inverse( EASELabel, real(ig-1), jgv, clat, clon ) + + mxy = clat if ((nn>n_land) .and. (nn<=n_landlake)) typ = 19 ! Lake tile @@ -884,30 +909,10 @@ PROGRAM mkEASETilesParam typ = 100 ! Land tile - ! get min/max lat/lon of EASE grid cell - ! BUG: This is *not* the desired min/max lat/lon of the land tile!!! - - call EASE_inverse( EASELabel, real(ig-1), real(jg-1), clat, clon ) - - mnx = clon - dx_ease - mxx = clon + dx_ease - - jgv = real(jg-1) + 0.5 - - call EASE_inverse( EASELabel, real(ig-1), jgv, clat, clon ) - - mny = clat - - jgv = real(jg-1) - 0.5 - - call EASE_inverse( EASELabel, real(ig-1), jgv, clat, clon ) - - mxy = clat - - ! write tile properties into catchment.def file + ! write tile properties into (ASCII-formatted) catchment.def file write (11,'(i10,i8,5(2x,f9.4), i4)') nn, pfaf_index, mnx, mxx, mny, mxy, tile_elev(nn) - + endif ! get area fraction of tile within EASE grid cell @@ -920,7 +925,25 @@ PROGRAM mkEASETilesParam fr_gcm = tile_area(nn) / ease_grid_area((jg-1)*nc_ease+ig) - ! write tile properties into *.til file + ! add info into array used for writing nc4-formatted tile file + + rTable(nn, 1) = clon + rTable(nn, 2) = clat + rTable(nn, 3) = tile_area(nn) + rTable(nn, 4) = ease_grid_area((jg-1)*nc_ease+ig) + rTable(nn, 5) = SRTM_catid_r8(pfaf_index) + rTable(nn, 6) = mnx + rTable(nn, 7) = mxx + rTable(nn, 8) = mny + rTable(nn, 9) = mxy + rTable(nn,10) = tile_elev(nn) + + iTable(nn, 0) = typ ! 0-based index inherited from elsewhere in make_bcs + iTable(nn, 2) = ig -1 + iTable(nn, 3) = jg -1 + iTable(nn, 4) = pfaf_index + + ! write tile properties into ASCII-formatted tile file (*.til) if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then @@ -942,28 +965,33 @@ PROGRAM mkEASETilesParam stop ! ! write(10,'(i10,i9,2f10.4,2i5,f19.12,i10,e13.4,i8)') & -! typ,pfaf,clon,clat,ig-1,jg-1,fr_gcm ,cindex + ! typ,pfaf,clon,clat,ig-1,jg-1,fr_gcm ,cindex endif end do close(10,status='keep') - close(11,status='keep') + close(11,status='keep') + + ! write nc4-formatted tile file (including supplemental tile attributes ["catchment.def"]) + + call WriteTilingNC4('til/'//trim(gfile)//'.nc4', [EASELabel],[nc_ease],[nr_ease], & + nc, nr, iTable, rTable) deallocate( tileid_index, catid_index,veg ) deallocate( tile_area, ease_grid_area, tile_elev, my_land, all_id ) ! Commented out "empty" if-block. -rreichle, 15 Jun 2023 -! -! if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then -! -! print *,'Creating SMAP-Catch_TransferData.nc files.' -! -! !--------------------------------------------------- -! -! deallocate (SRTM_CatchArea, SRTM_catid, SRTM_catid_r8) -! -! endif + ! + ! if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + ! + ! print *,'Creating SMAP-Catch_TransferData.nc files.' + ! + ! !--------------------------------------------------- + ! + ! deallocate (SRTM_CatchArea, SRTM_catid, SRTM_catid_r8) + ! + ! endif ! create Grid2Catch transfer file ! ------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 index 1ecb9a0c3..6f0bb09ee 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLandRaster.F90 @@ -4,12 +4,13 @@ Program MakeLandRaster use MAPL_ExceptionHandling - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: WriteRaster, WriteTiling, SortTiling, SRTM_maxcat use MAPL_HashMod use process_hres_data use MAPL_SortMod - use rmTinyCatchParaMod, ONLY: SRTM_maxcat, RegridRaster - use MAPL_Constants, only: PI=>MAPL_PI_R8 + use rmTinyCatchParaMod, ONLY: RegridRaster + use MAPL_Constants, ONLY: PI=>MAPL_PI_R8 + use, intrinsic :: iso_fortran_env, only: REAL64 ! Program to create a surface raster file that has ! the ocean divided with a regular lat-lon DE grid. Its inputs @@ -52,12 +53,12 @@ Program MakeLandRaster integer :: type, maxtiles, nx, ny integer :: count0,count1,count_rate - real(kind=8) :: dx, dy, d2r ! Grid spacing of raster grid - real(kind=8) :: xmin, ymin, xmax, ymax, xs, ys, da + real(REAL64) :: dx, dy, d2r ! Grid spacing of raster grid + real(REAL64) :: xmin, ymin, xmax, ymax, xs, ys, da - real(kind=8), allocatable :: cc(:), ss(:) + real(REAL64), allocatable :: cc(:), ss(:) - real(kind=8) , allocatable :: rTable( :,:) + real(REAL64) , allocatable :: rTable( :,:) integer, pointer :: Raster( :,:) integer, allocatable, target :: Raster0(:,:) @@ -70,7 +71,7 @@ Program MakeLandRaster logical :: Verb logical :: regrid=.false., reynolds_sst=.false. - real(kind=8) :: VV(4) + real(REAL64) :: VV(4) ! ESA/SRTM ocean/land/ice/lake mask parameters ! -------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 index 05c220ebd..2dbc78a52 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkLatLonRaster.F90 @@ -44,7 +44,7 @@ program mkLatLonRaster ! The rasterization fails if there are not an integer number of pixels ! in each box. - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling implicit none diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 index 6fc5ffdfd..7edff67ed 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMITAquaRaster.F90 @@ -3,21 +3,20 @@ program MAIN - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling - + use, intrinsic :: iso_fortran_env, only: REAL64 implicit none integer, parameter :: IUNIT = 11, OUNIT = 12 integer :: iargc - integer, parameter :: RKIND = 8 INTEGER :: NC INTEGER :: NX, NY integer :: STATARRAY(12) - integer(kind=8) :: filesize - integer(kind=8) :: Length + integer(REAL64) :: filesize + integer(REAL64) :: Length integer :: K integer :: i, j integer :: KF, L, NF @@ -27,9 +26,9 @@ program MAIN integer :: J1,JN integer :: N integer :: nxt - REAL(kind=RKIND), POINTER :: XG(:,:), YG(:,:) - real(kind=RKIND), pointer :: XT(:,: ), YT(:,: ) - real(kind=RKIND), allocatable :: XV(:,:,:), YV(:,:,:) + REAL(kind=REAL64), POINTER :: XG(:,:), YG(:,:) + real(kind=REAL64), pointer :: XT(:,: ), YT(:,: ) + real(kind=REAL64), allocatable :: XV(:,:,:), YV(:,:,:) character(len=128) :: GridDir character(len=128) :: & @@ -52,7 +51,7 @@ program MAIN integer :: Ncol = 8640, NRow = 4320 type Ptr2 - real(kind=RKIND), pointer :: V(:,:) + real(kind=REAL64), pointer :: V(:,:) end type Ptr2 type(Ptr2) :: X(4), Y(4) @@ -99,7 +98,7 @@ program MAIN integer :: BLNKSZ integer, dimension(MAXBLNKSZ) :: blankList - real(kind=RKIND) :: areamin, xc, yc + real(kind=REAL64) :: areamin, xc, yc character(len=128) :: Iam = "mkMITAquaRaster" NAMELIST /W2_EXCH2_PARM01/ sNx, SNy, blankList @@ -162,7 +161,7 @@ program MAIN if (filesize <= 0) filesize = 2389893248 ! print *,'file size=',filesize - LENGTH = filesize/rkind + LENGTH = filesize/REAL64 do k=16,20 if(mod(length,k)==0) exit @@ -173,13 +172,13 @@ program MAIN call exit(1) end if - nc = nint(sqrt(length/real(k,kind=rkind))) + nc = nint(sqrt(length/real(k,kind=REAL64))) ! nc = 4321 nx = nc-1 ny = nc-1 - LENGTH = nx*ny*rkind + LENGTH = nx*ny*REAL64 ! Open Facet 1 to check sizes CS or LLC) open (IUNIT,file=trim(GridDir)//'/tile001.mitgrid', status='old') @@ -192,7 +191,7 @@ program MAIN if (filesize <= 0) filesize = 7168573568 ! print *,'file size=',filesize - LENGTH = filesize/(rkind * k) + LENGTH = filesize/(REAL64 * k) if (LENGTH == NC*NC) then ! cubed-sphere isLLC = .false. @@ -295,8 +294,8 @@ program MAIN xg=0.0 yg=0.0 - LENGTH = size(XG)*rkind -! print *,'DEBUG:length=',length, rkind + LENGTH = size(XG)*REAL64 +! print *,'DEBUG:length=',length, REAL64 ! Read vertcies for each face !---------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 index c22ddc57e..f347221ea 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mkMOMAquaRaster.F90 @@ -2,8 +2,9 @@ #include "MAPL_ErrLog.h" program MOMraster - use LogRectRasterizeMod + use LogRectRasterizeMod, ONLY: LRRasterize use MAPL_ExceptionHandling + use, intrinsic :: iso_fortran_env, only: REAL64 implicit none ! this program builds a rasterized grid whose cells are 2.5 by 2.5 minutes @@ -13,9 +14,9 @@ program MOMraster ! via namelist hence can be changed at runtime integer :: im, jm ! dimensions of MOM grid - real(kind=8), pointer :: xvert(:,:,:) ! Lons of MOM's vertices - real(kind=8), pointer :: yvert(:,:,:) ! Lats of MOM's vertices - real(kind=8) :: xmin, xmax + real(REAL64), pointer :: xvert(:,:,:) ! Lons of MOM's vertices + real(REAL64), pointer :: yvert(:,:,:) ! Lats of MOM's vertices + real(REAL64) :: xmin, xmax integer :: i, j, nxt,k integer :: status, command_argument_count character*(128) :: GridFile @@ -35,7 +36,7 @@ program MOMraster integer :: Nc = 8640 integer :: NR = 4320 - real(kind=8) :: tol + real(REAL64) :: tol INCLUDE "netcdf.inc" ! Process Arguments @@ -147,13 +148,13 @@ end subroutine FieldSize subroutine ReadGridFile(FILE,XVERT,YVERT) character*(*), intent(IN ) :: FILE - real(kind=8), pointer :: XVERT(:,:,:) - real(kind=8), pointer :: YVERT(:,:,:) + real(REAL64), pointer :: XVERT(:,:,:) + real(REAL64), pointer :: YVERT(:,:,:) integer :: STATUS, NCID, VARID integer :: SIZ_XVERT_X, SIZ_XVERT_Y integer :: SIZ_YVERT_X, SIZ_YVERT_Y - real(kind=8), pointer :: VERTX(:,:),VERTY(:,:) + real(REAL64), pointer :: VERTX(:,:),VERTY(:,:) Status=NF_OPEN(FILE,NF_NOWRITE,NCID) _ASSERT(STATUS==NF_NOERR,'needs informative message') diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 index 88ed9210c..b07c9fb4b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mk_runofftbl.F90 @@ -29,6 +29,7 @@ program mk_runofftbl use mapl_sortmod use rmTinyCatchParaMod, only : init_bcs_config, OUTLETV use netcdf + use, intrinsic :: iso_fortran_env, only: REAL64 implicit none include 'netcdf.inc' @@ -168,8 +169,8 @@ program mk_runofftbl if(lnd<0) in(l) = 1. end do - print *, "area of sphere = ", sum(real(area,kind=8)) - print *, "area of land = ", sum(real(area*in,kind=8)) + print *, "area of sphere = ", sum(real(area,REAL64)) + print *, "area of land = ", sum(real(area*in,REAL64)) close(10) @@ -330,7 +331,7 @@ program mk_runofftbl do j=1,NumTrans Out(DstTile(j)) = Out(DstTile(j)) + In(SrcTile(J))*SrcFraction(J) enddo - print *, "area of land = ", sum(real(area*out,kind=8)) + print *, "area of land = ", sum(real(area*out,REAL64)) print *, "Completed successfully" diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 index 5d0ebce60..6300fdebd 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/mod_process_hres_data.F90 @@ -20,15 +20,16 @@ MODULE process_hres_data - + use MAPL_SortMod use MAPL_ConstantsMod use MAPL_Base, ONLY: MAPL_UNDEF use LDAS_DateTimeMod - + use rmTinyCatchParaMod use lsm_routines, ONLY: sibalb + use LogRectRasterizeMod, ONLY: SRTM_maxcat #if defined USE_EXTERNAL_FINDLOC use findloc_mod, only: findloc @@ -36,17 +37,17 @@ MODULE process_hres_data implicit none - include 'netcdf.inc' - + include 'netcdf.inc' + private - - public :: soil_para_hwsd,hres_lai,hres_gswp2, merge_lai_data, grid2tile_modis6 + + public :: soil_para_hwsd,hres_gswp2, merge_lai_data, grid2tile_modis6 public :: MODIS_snow_alb, MODIS_snow_alb_v2 public :: modis_alb_on_tiles_high,modis_scale_para_high,hres_lai_no_gswp public :: histogram, create_mapping, esa2mosaic , esa2clm public :: grid2tile_ndep_t2m_alb, map_country_codes, get_country_codes public :: CLM45_fixed_parameters, CLM45_clim_parameters, gimms_clim_ndvi, grid2tile_glass, open_landparam_nc4_files - + integer, parameter :: nc_esa = 129600 ! # columns in 10-arcsec GEOS5_10arcsec_mask* file integer, parameter :: nr_esa = 64800 ! # rows in 10-arcsec GEOS5_10arcsec_mask* file @@ -55,47 +56,49 @@ MODULE process_hres_data integer, parameter :: N_GADM = 256 + 1 integer, parameter :: N_STATES = 50 - + real, parameter :: SOILDEPTH_MIN_HWSD = 1334. ! minimum soil depth for HWSD soil parameters - + character*512 :: MAKE_BCS_INPUT_DIR ! structure for remapping high-resolution data to tile space integer, parameter :: N_tiles_per_cell = 9 - + type :: do_regrid integer :: NT ! number of tiles or raster grid cells [??] integer, dimension(N_tiles_per_cell) :: TID ! tile ID [??] integer, dimension(N_tiles_per_cell) :: count ! [??] end type do_regrid - + type, public :: regrid_map integer :: nc_data = 1 integer :: nr_data = 1 integer, dimension(:,:), allocatable :: ij_index type(do_regrid), dimension(:), pointer :: map end type regrid_map - + contains - + ! --------------------------------------------------------------------- ! - - SUBROUTINE ESA2CLM (nc, nr, fnameRst) + + SUBROUTINE ESA2CLM (nc, nr, n_land, tile_lat, tile_pfs, Rst_id) implicit none - integer , intent (in) :: nc, nr - character (*) :: fnameRst - + integer, intent (in) :: nc, nr, n_land + real, intent (in) :: tile_lat(:) + integer, intent (in) :: tile_pfs(:) + integer, intent (in) :: Rst_id(:,:) + integer , parameter :: N_lon_clm = 1152, N_lat_clm = 768, lsmpft = 17 integer*2, allocatable, target, dimension (:,:) :: esa_veg integer*2, pointer , dimension (:,:) :: subset integer , allocatable, dimension (:) :: tile_id, i_esa2clm, j_esa2clm - integer :: i,j, k,n, status, ncid, varid, maxcat, dx,dy, esa_type, tid, cid, ii, jj + integer :: i,j, k,n, status, ncid, varid, dx,dy, esa_type, tid, cid, ii, jj real :: dx_clm, dy_clm, x_min_clm (N_lon_clm), y_min_clm (N_lat_clm), clm_fracs(lsmpft) - real :: minlon,maxlon,minlat,maxlat,tile_lat, scale, ftot + real :: scale, ftot integer :: cpt1, cpt2, cst1, cst2 ! CLM-carbon types real :: cpf1, cpf2, csf1, csf2 ! CLM-carbon fractions DOUBLE PRECISION, allocatable, dimension (:) :: lon_esa, lat_esa @@ -140,26 +143,26 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) ! CLM description (17) CatchmentCNCLM description (19) ! -------------------- ------------------------------ - ! 'BARE' 1 bare (does not have bare soil) - ! 'NLEt' 2 needleleaf evergreen temperate tree 1 - ! 'NLEB' 3 needleleaf evergreen boreal tree 2 - ! 'NLDB' 4 needleleaf deciduous boreal tree 3 - ! 'BLET' 5 broadleaf evergreen tropical tree 4 - ! 'BLEt' 6 broadleaf evergreen temperate tree 5 - ! 'BLDT' 7 broadleaf deciduous tropical tree 6 - ! 'BLDt' 8 broadleaf deciduous temperate tree 7 - ! 'BLDB' 9 broadleaf deciduous boreal tree 8 - ! 'BLEtS' 10 broadleaf evergreen temperate shrub 9 - ! 'BLDtS' 11 broadleaf deciduous temperate shrub 10 broadleaf deciduous temperate shrub [moisture + deciduous] - ! 'BLDtSm' broadleaf deciduous temperate shrub 11 broadleaf deciduous temperate shrub [moisture stress only] - ! 'BLDBS' 12 broadleaf deciduous boreal shrub 12 - ! 'AC3G' 13 arctic c3 grass 13 - ! 'CC3G' 14 cool c3 grass 14 cool c3 grass [moisture + deciduous] + ! 'BARE' 1 bare (does not have bare soil) + ! 'NLEt' 2 needleleaf evergreen temperate tree 1 + ! 'NLEB' 3 needleleaf evergreen boreal tree 2 + ! 'NLDB' 4 needleleaf deciduous boreal tree 3 + ! 'BLET' 5 broadleaf evergreen tropical tree 4 + ! 'BLEt' 6 broadleaf evergreen temperate tree 5 + ! 'BLDT' 7 broadleaf deciduous tropical tree 6 + ! 'BLDt' 8 broadleaf deciduous temperate tree 7 + ! 'BLDB' 9 broadleaf deciduous boreal tree 8 + ! 'BLEtS' 10 broadleaf evergreen temperate shrub 9 + ! 'BLDtS' 11 broadleaf deciduous temperate shrub 10 broadleaf deciduous temperate shrub [moisture + deciduous] + ! 'BLDtSm' broadleaf deciduous temperate shrub 11 broadleaf deciduous temperate shrub [moisture stress only] + ! 'BLDBS' 12 broadleaf deciduous boreal shrub 12 + ! 'AC3G' 13 arctic c3 grass 13 + ! 'CC3G' 14 cool c3 grass 14 cool c3 grass [moisture + deciduous] ! 'CC3Gm' cool c3 grass 15 cool c3 grass [moisture stress only] - ! 'WC4G' 15 warm c4 grass 16 - ! 'WC4Gm' warm c4 grass 17 - ! 'CROP' 16 crop 18 crop [moisture + deciduous] - ! 'CROPm' crop 19 crop [moisture stress only] + ! 'WC4G' 15 warm c4 grass 16 + ! 'WC4Gm' warm c4 grass 17 + ! 'CROP' 16 crop 18 crop [moisture + deciduous] + ! 'CROPm' crop 19 crop [moisture stress only] ! 17 water dx_clm = 360./N_lon_clm @@ -190,16 +193,16 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) ! if (maxval (clm_fracs) == 100.) then ! clm_veg(i,j,:) = maxloc (clm_fracs) ! else - ! clm_veg(i,j,0) = maxloc (clm_fracs) + ! clm_veg(i,j,0) = maxloc (clm_fracs) ! clm_fracs (clm_veg(i,j,0)) = 0. - ! clm_veg(i,j,1) = maxloc (clm_fracs) + ! clm_veg(i,j,1) = maxloc (clm_fracs) ! endif ! else ! clm_veg(i,j,:) = 17 ! endif ! end do ! end do - + ! Reading ESA vegetation types !----------------------------- @@ -215,8 +218,8 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) stop endif - status = NF_GET_VARA_DOUBLE (ncid,1,(/1/),(/nr_esa/),lat_esa) - status = NF_GET_VARA_DOUBLE (ncid,2,(/1/),(/nc_esa/),lon_esa) + status = NF_GET_VARA_DOUBLE (ncid,1,(/1/),(/nr_esa/),lat_esa) + status = NF_GET_VARA_DOUBLE (ncid,2,(/1/),(/nc_esa/),lon_esa) do j = 1,nr_esa status = NF_GET_VARA_INT2 (ncid,3,(/1,j/),(/nc_esa,1/),esa_veg(:,j)) @@ -244,44 +247,31 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) where ((real(lat_esa) >= y_min_clm(j)).and.(real(lat_esa) < (y_min_clm(j) + dy_clm))) j_esa2clm= j end do - ! - ! Reading number of tiles - ! ----------------------- - - open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (10, *) maxcat - close (10, status = 'keep') - ! ! Loop through tile_id raster ! ___________________________ allocate (tile_id (1:nc )) - allocate (clm_veg (1:maxcat,1:lsmpft)) + allocate (clm_veg (1:n_land,1:lsmpft)) clm_veg = 0. dx = nc_esa / nc dy = nr_esa / nr - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - do j=1,nr - + ! read a row - - read(10)tile_id(:) - + + tile_id(:) = Rst_id(:, j) + do i = 1,nc ii = i_esa2clm ((i-1)*dx + dx/2) jj = j_esa2clm ((j-1)*dy + dy/2) - if((tile_id (i) >= 1).and.(tile_id(i) <= maxcat)) then + if((tile_id (i) >= 1).and.(tile_id(i) <= n_land)) then if (associated (subset)) NULLIFY (subset) subset => esa_veg((i-1)*dx +1 :i*dx, (j-1)*dy +1:j*dy) @@ -297,31 +287,31 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) end do NBINS = count(unq_mask) - + allocate(loc_val (1:NBINS)) allocate(density (1:NBINS)) loc_val = 1.*pack(loc_int,mask =unq_mask) call histogram (size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset)) - + do k = 1, nbins - + if (density (k) > 0) then - + esa_type = int (loc_val(k)) - + ! if (esa_type == 10) clm_veg (tile_id(i), 17) = 1.* density(k) ! lakes inland water - + if (esa_type == 11) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 11: Post-flooding or irrigated croplands if (esa_type == 14) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 14: Rainfed croplands if (esa_type == 20) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 20: Mosaic Cropland (50-70%) / Vegetation (grassland, shrubland, forest) (20-50%) - if (esa_type == 190) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 190: Artificial surfaces and associated areas (urban areas >50%) - - ! if (esa_type == 200) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.* density(k) ! ESA type 200: Bare areas + if (esa_type == 190) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.* density(k) ! ESA type 190: Artificial surfaces and associated areas (urban areas >50%) + + ! if (esa_type == 200) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.* density(k) ! ESA type 200: Bare areas ! if (esa_type == 210) clm_veg (tile_id(i), 17) = clm_veg (tile_id(i), 17) + 1.* density(k) ! ocean ! if (esa_type == 220) clm_veg (tile_id(i), 17) = clm_veg (tile_id(i), 17) + 1.* density(k) ! ice ! gkw: bare soil excluded! only considering vegetated land ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 30) then ! ESA type 30: Mosaic Vegetation (grassland, shrubland, forest) (50-70%) / Cropland (20-50%) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 0.5* density(k) @@ -333,12 +323,12 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) clm_veg (tile_id(i), 16) = clm_veg (tile_id(i), 16) + 1.0* density(k) endif endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 40) then - ! ESA type 40: Closed to open (>15%) broadleaved evergreen and/or semi-deciduous forest (>5m) - + ! ESA type 40: Closed to open (>15%) broadleaved evergreen and/or semi-deciduous forest (>5m) + if(sum(PCTPFT(ii,jj,5:6)) > 0.) then do n = 5, 6 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,5:6)) @@ -351,13 +341,13 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) endif endif endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if ((esa_type == 50) .or. (esa_type == 60)) then - ! ESA type 50: Closed (>40%) broadleaved deciduous forest (>5m) - ! ESA type 60: Open (15-40%) broadleaved deciduous forest (>5m) - + ! ESA type 50: Closed (>40%) broadleaved deciduous forest (>5m) + ! ESA type 60: Open (15-40%) broadleaved deciduous forest (>5m) + if(sum(PCTPFT(ii,jj,7:9)) > 0.) then do n = 7, 9 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:9)) @@ -371,30 +361,30 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 70) then - ! ESA type 70: Closed (>40%) needleleaved evergreen forest (>5m) - + ! ESA type 70: Closed (>40%) needleleaved evergreen forest (>5m) + if(sum(PCTPFT(ii,jj,2:3)) > 0.) then do n = 2, 3 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:3)) + clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:3)) enddo else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 1.0* density(k) - else - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) + else + clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 90) then - !ESA type 90: Open (15-40%) needleleaved deciduous or evergreen forest (>5m) - + !ESA type 90: Open (15-40%) needleleaved deciduous or evergreen forest (>5m) + if(sum(PCTPFT(ii,jj,2:4)) > 0.) then do n = 2, 4 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,2:4)) @@ -402,40 +392,40 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 1.0* density(k) - else - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) + else + clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 1.0* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 100) then - ! ESA type 100: Closed to open (>15%) mixed broadleaved and needleleaved forest (>5m) - + ! ESA type 100: Closed to open (>15%) mixed broadleaved and needleleaved forest (>5m) + if((sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) > 0.) then do n = 2, 9 - if((n /= 5) .and. (n /= 6)) clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/(sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) + if((n /= 5) .and. (n /= 6)) clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + density(k)*(PCTPFT(ii,jj,n))/(sum(PCTPFT(ii,jj,2:4)) + sum(PCTPFT(ii,jj,7:9))) enddo else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.5* density(k) - clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) + clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) elseif (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.5* density(k) clm_veg (tile_id(i), 2) = clm_veg (tile_id(i), 2) + 0.5* density(k) else clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.5* density(k) - clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 0.5* density(k) + clm_veg (tile_id(i), 3) = clm_veg (tile_id(i), 3) + 0.5* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 110) then - ! ESA type 110: Mosaic Forest/Shrubland (50-70%) / Grassland (20-50%) - + ! ESA type 110: Mosaic Forest/Shrubland (50-70%) / Grassland (20-50%) + if(sum(PCTPFT(ii,jj,7:12)) > 0.) then do n = 7, 12 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.6*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:12)) @@ -443,16 +433,16 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.3* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) + clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.3* density(k) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.3* density(k) else clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.3* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.3* density(k) + clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.3* density(k) end if end if - + if(sum(PCTPFT(ii,jj,13:15)) > 0.) then do n =13, 15 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.4*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) @@ -467,12 +457,12 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- if (esa_type == 120) then - ! ESA type 120: Mosaic Grassland (50-70%) / Forest/Shrubland (20-50%) - + ! ESA type 120: Mosaic Grassland (50-70%) / Forest/Shrubland (20-50%) + if(sum(PCTPFT(ii,jj,7:12)) > 0.) then do n = 7, 12 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.4*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,7:12)) @@ -480,16 +470,16 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then clm_veg (tile_id(i), 7) = clm_veg (tile_id(i), 7) + 0.2* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) + clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 0.2* density(k) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.2* density(k) else clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 0.2* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.2* density(k) + clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.2* density(k) end if end if - + if(sum(PCTPFT(ii,jj,13:15)) > 0.) then do n =13, 15 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 0.6*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) @@ -504,12 +494,12 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 130) then - ! Closed to open (>15%) shrubland (<5m) - + ! Closed to open (>15%) shrubland (<5m) + if(sum(PCTPFT(ii,jj,10:12)) > 0.) then do n = 10,12 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:12)) @@ -517,17 +507,17 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 1.0* density(k) - else - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 1.0* density(k) + else + clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 1.0* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 140) then - ! ESA type 140: Closed to open (>15%) grassland - + ! ESA type 140: Closed to open (>15%) grassland + if(sum(PCTPFT(ii,jj,13:15)) > 0.) then do n = 13,15 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,13:15)) @@ -535,19 +525,19 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 1.0* density(k) - else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) + else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then + clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) + else + clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) end if end if end if - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 150) then - ! ESA type 150: Sparse (<15%) vegetation (woody vegetation, shrubs, grassland) - + ! ESA type 150: Sparse (<15%) vegetation (woody vegetation, shrubs, grassland) + if(sum(PCTPFT(ii,jj,10:15)) > 0.) then do n = 10, 15 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.0*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) @@ -555,22 +545,22 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.5* density(k) - clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) + clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 0.5* density(k) clm_veg (tile_id(i), 11) = clm_veg (tile_id(i), 11) + 0.5* density(k) else clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 0.5* density(k) - clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.5* density(k) + clm_veg (tile_id(i), 12) = clm_veg (tile_id(i), 12) + 0.5* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if((esa_type == 160) .or. (esa_type == 170)) then - ! ESA type 160: Closed (>40%) broadleaved forest regularly flooded - Fresh water ! ESA type 170: Closed (>40%) broadleaved semi-deciduous and/or evergreen forest regularly flooded - + ! ESA type 160: Closed (>40%) broadleaved forest regularly flooded - Fresh water ! ESA type 170: Closed (>40%) broadleaved semi-deciduous and/or evergreen forest regularly flooded + if(sum(PCTPFT(ii,jj,5:9)) > 0.) then do n = 5,9 clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,5:9)) @@ -579,29 +569,29 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) if(abs(y_min_clm(jj) + 0.5*dy_clm) < 23.5) then clm_veg (tile_id(i), 5) = clm_veg (tile_id(i), 5) + 1.0* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 60.) then - clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 1.0* density(k) - else - clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 1.0* density(k) + clm_veg (tile_id(i), 8) = clm_veg (tile_id(i), 8) + 1.0* density(k) + else + clm_veg (tile_id(i), 9) = clm_veg (tile_id(i), 9) + 1.0* density(k) end if end if endif - + ! ----------------------------------------------------------------------------------------------------------------------------------------- - + if (esa_type == 180) then - ! ESA type 180: Closed to open (>15%) vegetation (grassland, shrubland, woody vegetation) on regularly flooded or waterlogged soil - Fresh, brackish or saline water - + ! ESA type 180: Closed to open (>15%) vegetation (grassland, shrubland, woody vegetation) on regularly flooded or waterlogged soil - Fresh, brackish or saline water + if(sum(PCTPFT(ii,jj,10:15)) > 0.) then do n = 10,15 - clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) + clm_veg (tile_id(i), n) = clm_veg (tile_id(i), n) + 1.*density(k)*(PCTPFT(ii,jj,n))/sum(PCTPFT(ii,jj,10:15)) enddo else if(abs(y_min_clm(jj) + 0.5*dy_clm) < 30.) then clm_veg (tile_id(i), 15) = clm_veg (tile_id(i), 15) + 1.0* density(k) else if (abs(y_min_clm(jj) + 0.5*dy_clm) < 55.) then - clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) - else - clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) + clm_veg (tile_id(i), 14) = clm_veg (tile_id(i), 14) + 1.0* density(k) + else + clm_veg (tile_id(i), 13) = clm_veg (tile_id(i), 13) + 1.0* density(k) end if end if endif @@ -612,10 +602,9 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) end if enddo end do - - + + deallocate (tile_id, PCTPFT,esa_veg,lon_esa,lat_esa,i_esa2clm,j_esa2clm) - close (10,status='keep') ! ! Now create CLM-carbon_veg_fracs file @@ -623,30 +612,24 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) open (10,file='clsm/CLM_veg_typs_fracs', & form='formatted',status='unknown') - open (11, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (11, *) maxcat inquire(file='clsm/catchcn_params.nc4', exist=file_exists) if(file_exists) then status = NF_OPEN ('clsm/catchcn_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (NITYP (1:MAXCAT, 1:4)) - allocate (NFVEG (1:MAXCAT, 1:4)) + allocate (NITYP (1:n_land, 1:4)) + allocate (NFVEG (1:n_land, 1:4)) endif - do k = 1, maxcat + do k = 1, n_land - read (11,'(i10,i8,5(2x,f9.4))') tid,cid,minlon,maxlon,minlat,maxlat - tile_lat = (minlat + maxlat)/2. - scale = (ABS (tile_lat) - 32.)/10. + scale = (ABS (tile_lat(k)) - 32.)/10. scale = min (max(scale,0.),1.) esa_clm_veg = 0 esa_clm_frac= 0. clm_fracs = clm_veg (k,:) - + if (sum (clm_fracs) == 0.) then ! gkw: no vegetated land found; set to BLDtS esa_clm_veg (1) = 11 ! broadleaf deciduous shrub esa_clm_frac(1) = 100. @@ -667,12 +650,12 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) esa_clm_frac(2) = 100. - esa_clm_frac(1) end if -! Now splitting CLM types for CNCLM model -! -------------------------------------------- - -! CLM types 2- 10,12,13 are not being split. -! ............................................. - + ! Now splitting CLM types for CNCLM model + ! -------------------------------------------- + + ! CLM types 2- 10,12,13 are not being split. + ! ............................................. + if ((esa_clm_veg (1) >= 2).and.(esa_clm_veg (1) <= 10)) then CPT1 = esa_clm_veg (1) - 1 CPT2 = esa_clm_veg (1) - 1 @@ -687,7 +670,7 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF2 = 0. endif -! ............................................. + ! ............................................. if ((esa_clm_veg (1) >= 12).and.(esa_clm_veg (1) <= 13)) then CPT1 = esa_clm_veg (1) @@ -703,8 +686,8 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF2 = 0. endif -! Now splitting -! ............. + ! Now splitting + ! ............. if (esa_clm_veg (1) == 11) then CPT1 = 10 @@ -720,7 +703,7 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF2 = esa_clm_frac(2) * (1. - scale) endif -! ............. + ! ............. if (esa_clm_veg (1) == 14) then CPT1 = 14 @@ -736,7 +719,7 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF2 = esa_clm_frac(2) * (1. - scale) endif -! ............. + ! ............. if (esa_clm_veg (1) == 15) then CPT1 = 16 @@ -751,7 +734,7 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) CSF1 = esa_clm_frac(2) * scale CSF2 = esa_clm_frac(2) * (1. - scale) endif -! ............. + ! ............. if (esa_clm_veg (1) == 16) then CPT1 = 18 @@ -777,9 +760,9 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) csf1 = 100. * csf1 / ftot csf2 = 100. * csf2 / ftot endif - + write (10,'(2I10,4I3,4f7.2,2I3,2f7.2)') & - tid,cid,cpt1, cpt2, cst1, cst2, cpf1, cpf2, csf1, csf2, & + k, tile_pfs(k), cpt1, cpt2, cst1, cst2, cpf1, cpf2, csf1, csf2, & esa_clm_veg (1), esa_clm_veg (2), esa_clm_frac(1), esa_clm_frac(2) if (allocated (NITYP)) NITYP (k, :) = (/REAL(cpt1), REAL(cpt2), REAL(cst1), REAL(cst2)/) @@ -789,37 +772,37 @@ SUBROUTINE ESA2CLM (nc, nr, fnameRst) if(file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,1/),(/maxcat,1/), NITYP (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,2/),(/maxcat,1/), NITYP (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,3/),(/maxcat,1/), NITYP (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,4/),(/maxcat,1/), NITYP (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,1/),(/maxcat,1/), NFVEG (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,2/),(/maxcat,1/), NFVEG (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,3/),(/maxcat,1/), NFVEG (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,4/),(/maxcat,1/), NFVEG (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,1/),(/n_land,1/), NITYP (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,2/),(/n_land,1/), NITYP (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,3/),(/n_land,1/), NITYP (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1,4/),(/n_land,1/), NITYP (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,1/),(/n_land,1/), NFVEG (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,2/),(/n_land,1/), NFVEG (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,3/),(/n_land,1/), NFVEG (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'FVG' ) ,(/1,4/),(/n_land,1/), NFVEG (:, 4)) ; VERIFY_(STATUS) DEALLOCATE (NITYP, NFVEG) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - + endif - + close (10, status = 'keep') - close (11, status = 'keep') END SUBROUTINE ESA2CLM -! -! --------------------------------------------------------------------- -! - SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) - + ! + ! --------------------------------------------------------------------- + ! + SUBROUTINE ESA2MOSAIC (nc, nr, n_land, tile_pfs, rst_id) + implicit none - integer , intent (in) :: nc, nr - character (*) :: fnameRst + integer, intent(in) :: nc, nr, n_land + integer, intent(in) :: tile_pfs(:) + integer, intent(in) :: rst_id(:,:) !integer , parameter :: nc_esa = 129600, nr_esa = 64800 integer*2, allocatable, target, dimension (:,:) :: esa_veg integer*2, pointer , dimension (:,:) :: subset integer , allocatable, dimension (:) :: tile_id, ityp - integer :: i,j, k, status, ncid, maxcat, dx,dy, esa_type, tid, cid + integer :: i,j, k, status, ncid, dx,dy, esa_type integer :: mos1, mos2 real :: mfrac, sfrac, tfrac, tem (6) integer, allocatable, dimension (:) :: density, loc_int @@ -855,62 +838,48 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) end do status = NF_CLOSE(ncid) -! -! Reading number of tiles -! ----------------------- - - open (10, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (10, *) maxcat - - close (10, status = 'keep') - -! -! Loop through tile_id raster -! ___________________________ + ! + ! Loop through tile_id raster + ! ___________________________ allocate (tile_id (1:nc)) - allocate(veg(1:maxcat,1:6)) + allocate(veg(1:n_land,1:6)) veg = 0. dx = nc_esa / nc dy = nr_esa / nr - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - do j=1,nr ! read a row - read(10)tile_id(:) + tile_id(:) = rst_id(:,j) do i = 1,nc - if((tile_id (i) >= 1).and.(tile_id(i) <= maxcat)) then + if((tile_id (i) >= 1).and.(tile_id(i) <= n_land)) then if (associated (subset)) NULLIFY (subset) subset => esa_veg((i-1)*dx +1 :i*dx, (j-1)*dy +1:j*dy) - + NPLUS = count(subset >= 1 .and. subset <= 230) - + if(NPLUS > 0) then allocate (loc_int (1:NPLUS)) allocate (unq_mask(1:NPLUS)) loc_int = pack(subset,mask = (subset >= 1 .and. subset <= 230)) call MAPL_Sort (loc_int) unq_mask = .true. - + do k = 2,NPLUS unq_mask(k) = .not.(loc_int(k) == loc_int(k-1)) end do NBINS = count(unq_mask) - + allocate(loc_val (1:NBINS)) allocate(density (1:NBINS)) loc_val = 1.*pack(loc_int,mask =unq_mask) call histogram (size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset)) - + do k = 1, nbins if (density (k) > 0) then @@ -936,7 +905,7 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) if (esa_type == 120) veg (tile_id(i), 4) = veg (tile_id(i), 4) + 0.6* density (k) if (esa_type == 130) veg (tile_id(i), 5) = veg (tile_id(i), 5) + 1.* density (k) if (esa_type == 140) veg (tile_id(i), 4) = veg (tile_id(i), 4) + 1.* density (k) - + if((j > NINT(real(nr)*(40./180.))).and.(j < NINT(real(nr)*(140./180.)))) then if (esa_type == 150) veg (tile_id(i),5) = veg (tile_id(i),5) + 0.5* density (k) if (esa_type == 150) veg (tile_id(i),4) = veg (tile_id(i),4) + 0.5* density (k) @@ -944,13 +913,13 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) if (esa_type == 150) veg (tile_id(i),6) = veg (tile_id(i),6) + 0.5* density (k) if (esa_type == 150) veg (tile_id(i),4) = veg (tile_id(i),4) + 0.5* density (k) end if - + if((j > NINT(real(nr)*(70./180.))).and.(j < NINT(real(nr)*(110./180.)))) then if (esa_type == 160) veg (tile_id(i), 1) = veg (tile_id(i), 1) + 1.* density (k) else if (esa_type == 160) veg (tile_id(i), 2) = veg (tile_id(i), 2) + 1.* density (k) end if - + if (esa_type == 170) veg (tile_id(i), 1) = veg (tile_id(i), 1) + 1.* density (k) if (esa_type == 180) veg (tile_id(i), 4) = veg (tile_id(i), 4) + 1.* density (k) if (esa_type == 190) veg (tile_id(i), 4) = veg (tile_id(i), 4) + 1.* density (k) @@ -968,33 +937,26 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) end do deallocate (tile_id) - close (10,status='keep') -! Canopy height and ASCAT roughness length + ! Canopy height and ASCAT roughness length - call ascat_r0 (nc,nr,fnameRst, z0) + call ascat_r0 (nc,nr, n_land, Rst_id, z0) if(jpl_height) then - call jpl_canoph (nc,nr,fnameRst, z2) + call jpl_canoph (nc,nr, n_land, Rst_id, z2) else - allocate (z2(1:maxcat)) + allocate (z2(1:n_land)) endif -! -! Now create mosaic_veg_fracs file -! -------------------------------- + ! + ! Now create mosaic_veg_fracs file + ! -------------------------------- - allocate (ityp (1:maxcat)) + allocate (ityp (1:n_land)) open (10,file='clsm/mosaic_veg_typs_fracs', & form='formatted',status='unknown') - open (11, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (11, *) maxcat - - do k = 1, maxcat - - read (11,'(i10,i8,5(2x,f9.4))') tid,cid + + do k = 1, n_land tem = 0. tem(1:6)=veg (k,1:6) @@ -1016,7 +978,7 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) sfrac = tem(i) mos2 = i endif - endif + endif end do mfrac = max (mfrac,0.) @@ -1036,29 +998,28 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) if(.not.jpl_height) z2(k) = VGZ2(mos1) ityp (k) = mos1 write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & - tid,cid,mos1,mos2,100.*mfrac,100.*sfrac, z2(k), z0 (k) - + k, tile_pfs(k) ,mos1,mos2,100.*mfrac,100.*sfrac, z2(k), z0 (k) + endif end do close (10,status='keep') - close (11,status='keep') inquire(file='clsm/catch_params.nc4', exist=file_exists) if(file_exists) then status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'OLD_ITY' ) ,(/1/),(/maxcat/), real(ityp)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'OLD_ITY' ) ,(/1/),(/n_land/), real(ityp)) ; VERIFY_(STATUS) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) endif - + inquire(file='clsm/vegdyn.data', exist=file_exists) if(file_exists) then status = NF_OPEN ('clsm/vegdyn.data', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1/),(/maxcat/), real(ityp)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'Z2CH' ) ,(/1/),(/maxcat/), z2 ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ASCATZ0') ,(/1/),(/maxcat/), Z0 ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ) ,(/1/),(/n_land/), real(ityp)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'Z2CH' ) ,(/1/),(/n_land/), z2 ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ASCATZ0') ,(/1/),(/n_land/), Z0 ) ; VERIFY_(STATUS) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) else open (20,file='clsm/vegdyn.data',status='unknown',action='write',form='unformatted', & @@ -1067,19 +1028,19 @@ SUBROUTINE ESA2MOSAIC (nc, nr, fnameRst) write (20) z2 (:) write (20) z0 (:) close (20) - endif - - deallocate (veg, z0, z2, ityp) - + endif + + deallocate (veg, z0, z2, ityp) + END SUBROUTINE ESA2MOSAIC -! -!---------------------------------------------------------------------- -! + ! + !---------------------------------------------------------------------- + ! SUBROUTINE HISTOGRAM (NLENS, NBINS, density, loc_val, x, BIN) - + ! intent: in in out inout in in - + ! assemble histogram of x ! ! if optional input argument "bin" is not present, return only density @@ -1087,25 +1048,25 @@ SUBROUTINE HISTOGRAM (NLENS, NBINS, density, loc_val, x, BIN) ! NOTE: When the underlying data are integer (as, e.g., when histogram() is used ! in subroutine create_mapping()), the use of this subroutine and how it is ! implemented is highly questionable. - + implicit none - + integer, intent(in) :: NBINS ! # bins integer, intent(in) :: NLENS ! # data - + real, dimension(NLENS), intent(in) :: x ! data integer, dimension(NBINS), intent(out) :: density ! hist value real, dimension(NBINS), intent(inout) :: loc_val ! lower boundary of bin real, intent(in), optional :: bin ! bin size ("delta_x") - + ! -------------------------------------------------------------- - + real :: xdum(NLENS), xl, xu, min_value integer :: n - + if (present(bin)) min_value = real(floor(minval(x))) - + DO N=1,NBINS if(present(bin)) then xl = (N - 1)*BIN + min_value @@ -1119,303 +1080,287 @@ SUBROUTINE HISTOGRAM (NLENS, NBINS, density, loc_val, x, BIN) endif density(n) = int(sum(XDUM)) END DO - + END SUBROUTINE HISTOGRAM -! -!---------------------------------------------------------------------- -! + ! + !---------------------------------------------------------------------- + ! - SUBROUTINE create_mapping( nc, nr, nc_data, nr_data, rmap, fnameRst ) - - ! assemble "rmap" structure that can be used for remapping 2-dim gridded - ! science data (nc_data-by-nr_data) to *land* tiles, which are defined - ! on a 2-dim raster grid (nc-by-nr) - - implicit none - - integer, intent(in) :: nc, nr ! dims of raster array (with tile IDs) - integer, intent(in) :: nc_data, nr_data ! dims of science data array - type(regrid_map), intent(inout) :: rmap ! structure for remapping - character(*), intent(in) :: fnameRst ! name of raster (*.rst) file - - ! ----------------------- - - integer :: i, j, n, i1, i2, j1, j2, ncatch, nbins, status, NPLUS, pix_count - - REAL, allocatable, DIMENSION(:) :: loc_val - INTEGER, ALLOCATABLE, DIMENSION(:) :: density, loc_int - logical, allocatable, dimension(:) :: unq_mask - integer, allocatable, dimension(:,:), target :: tile_id - integer, dimension(:,:), pointer :: subset, iraster - - real :: dx_data, dy_data, dx_rst, dy_rst - - ! ------------------------------------------------------------------- - ! - ! Read raster (*.rst) file - - open( 10, file=trim(fnameRst)//'.rst', status='old', action='read', & - form='unformatted', convert='little_endian') - - allocate(tile_id(1:nc,1:nr)) - - do j=1,nr - read(10) tile_id(:,j) - end do - - close( 10,status='keep') - - ! Read number of land ("catchment") tiles (ncatch) - - open( 10, file='clsm/catchment.def', status='old', action='read', & - form='formatted') - read( 10, *) ncatch - close(10, status = 'keep') - - ! grid spacing - - dx_data = 360./real(nc_data) ! science data - dy_data = 180./real(nr_data) - - dx_rst = 360./real(nc) ! raster (*.rst) - dy_rst = 180./real(nr) - - if( (nc_data >= nc) .and. (nr_data >= nr) ) then - - ! science data to be remapped has resolution same as or finer than that of raster grid with tile_id - - ! Step 1: - ! Apply primitive regridding of tile_id(1:nc,1:nr) to iraster(1:nc_data,1:nr_data) - ! - ! NOTE: When the mask file is GEOS5_10arcsec_mask*.nc, then tile_id raster grid is nc=nx=43200 by nr=ny=21600. - ! In mkCatchParam.F90, nc_data=43200 and nr_data=21600 except for GEOLAND and old (16-day) MODIS1 data. - ! - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! [??] --> In most cases, RegridRaster should have no impact and could probably be skipped. - ! Edits in RegridRaster() will do just that but may not be 0-diff. - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! - allocate(iraster(nc_data,nr_data),stat=STATUS); VERIFY_(STATUS) - call RegridRaster(tile_id,iraster) - - ! now iraster contains tile_id on nc_data-by-nr_data science data grid - - ! [??] WHY REMAP RASTER TO DATA?? SHOULDN'T DATA BE REMAPPED TO RASTER?? - ! THEN WE WOULDN'T NEED A CUSTOM rmap STRUCTURE FOR EACH SCIENCE DATASET - - ! count number of science data grid cells that contribute to *land* tiles (excl. lake, landice, ocean) - - NPLUS = count(iraster>=1 .and. iraster<=ncatch) - - allocate( rmap%ij_index(1:nc_data, 1:nr_data), source = 0 ) ! allocate and initialize to 0 - allocate( rmap%map( 1:NPLUS )) - - rmap%map%NT = 1 ! science data & raster resolutions are such that there is at most 1 unique tile ID per science data grid cell - - pix_count = 0 ! 1-dim indexing of 1:NPLUS *science* *data* grid cells that contribute to land tiles - ! [??] WHY IS THIS CALLED pix_count?? - - do j=1,nr_data - do i=1,nc_data - - if( (iraster(i,j)>=1) .and. (iraster(i,j)<=ncatch) ) then - - ! science data grid cell (i,j) contributes to a land tile - - pix_count = pix_count + 1 - rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) - - rmap%map(pix_count)%TID (1) = iraster (i,j) ! 1-dim array with tile_id values - rmap%map(pix_count)%count(1) = 1 ! [??] MAYBE DO rmap%map%count=1 OUTSIDE OF THIS LOOP?? - - - endif - end do - end do - deallocate (iraster) ; VERIFY_(STATUS) - - ! verify final value of pix_count after i,j loop - if (pix_count/=NPLUS) then - print *, 'ERROR 1 in create_mapping(); stopping.' - stop - end if - - else - - ! science data to be remapped has coarser resolution than that of raster grid with tile_id - - ! count number of *original* raster grid cells that contribute to *land* tiles (excl. lake, landice, ocean) - - NPLUS = count(tile_id>=1 .and. tile_id<=ncatch) - - allocate (rmap%ij_index(1:nc_data, 1:nr_data), source = 0) - allocate (rmap%map( 1:NPLUS )) - - rmap%map%NT = 0 - - pix_count = 1 ! 1-dim indexing of 1:NPLUS *science* *data* grid cells that contribute to land tiles - ! [??] WHY IS THIS CALLED pix_count?? - - ! loop through *science* data grid - - do j=1,nr_data - - ! block (i1:i2,j1:j2) of orig raster grid falls within science data grid cell (i,j) - ! - ! NOTE: --> when ratio dy_data/dy_rst is not integer, all orig raster grid cells that - ! fall partly within science data grid cell are included - - j1 = floor ( ( -90. + (j-1)*dy_data +90. )/dy_rst ) + 1 ! WARNING: mixed mode arithmetic!!! [??] WHY NOT REPLACE dy_data/dy_rst WITH SOMETHING LIKE nr_data/nr[+1] ??? - j2 = ceiling( ( -90. + (j )*dy_data +90. )/dy_rst ) ! WARNING: mixed mode arithmetic!!! - - do i=1,nc_data - - i1 = floor ( ( -180. + (i-1)*dx_data +180.)/dx_rst) + 1 ! WARNING: mixed mode arithmetic!!! [??] WHY NOT REPLACE dx_data/dx_rst WITH SOMETHING LIKE nc_data/nc[+1] ??? - i2 = ceiling( ( -180. + (i )*dx_data +180.)/dx_rst) ! WARNING: mixed mode arithmetic!!! - - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! a more sensible order of operations might be as follows: - ! - ! ! check if there is *land* in this science data grid cell - ! - ! subset => tile_id(i1:i2,j1:j2) - ! - ! ! WITHIN SUBSET, count number of *original* raster grid cells that contribute - ! ! to *land* tiles (excl. lake, landice, ocean) - ! - ! NPLUS = count(subset>=1 .and. subset<=ncatch) ! [??] OVERWRITES NPLUS FROM ABOVE !?!?!?!?! - ! - ! if (NPLUS>0) then - ! - ! ! there is *land* in this science data grid cell - ! - ! rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) - ! pix_count = pix_count + 1 ! [??] SWITCH ORDER WITH PREVIOUS LINE AND INIT pix_count TO ZERO ABOVE - ! - ! if (j2>j1 .or. i2>i1) then - ! - ! etc... [MAKE SURE TO REMOVE rmap%ij_index(i,j)=.. AND pix_count+=1 FROM CODE BELOW] - ! - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - - if (j2>j1 .or. i2>i1) then - - subset => tile_id(i1:i2,j1:j2) - - ! WITHIN SUBSET, count number of *original* raster grid cells that contribute - ! to *land* tiles (excl. lake, landice, ocean) - - NPLUS = count(subset>=1 .and. subset<=ncatch) ! [??] OVERWRITES NPLUS FROM ABOVE !?!?!?!?! - - if (NPLUS>0) then - - ! determine unique *land* tile IDs within science data grid cell (i,j) - - ! Step (i): determine NBINS = unique *land* tile ID values within subset - - allocate(loc_int (1:NPLUS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? NPLUS<=ceiling(dx_data/dx_rst)*ceiling(dy_data/dy_rst) - allocate(unq_mask(1:NPLUS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? - - loc_int = pack(subset, mask=(subset>=1 .and. subset<=ncatch)) - call MAPL_Sort(loc_int) - unq_mask = .true. - do n=2,NPLUS - unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) - end do - NBINS = count(unq_mask) - - ! Step (ii): assemble histogram of unique *land* tile ID values - - allocate(loc_val(1:NBINS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? NBINS<=N_tile_per_gridcell - allocate(density(1:NBINS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? - - loc_val = 1.*pack(loc_int,mask=unq_mask) ! [??] WHY REAL WHEN HANDLING INTEGERS??? - - call histogram( size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset) ) - - ! now "density(n)" contains the number of orig raster grid cells within the science - ! data grid cell (i,j) that contribute to the tile with the tile ID in "loc_val(n)" - - DO N=1,NBINS - - if (density(n)>0) then - - ! build up NT = # unique tile IDs within science grid cell (i,j) [a.k.a. (pix_count)] - - rmap%map(pix_count)%NT = rmap%map(pix_count)%NT + 1 - - ! verify NT <= max allowed value (=N_tiles_per_cell) - - if(rmap%map(pix_count)%NT > N_tiles_per_cell) then ! [??] WHY NOT CHECK NBINS<=N_tiles_per_gridcell OUTSIDE OF THIS LOOP???? - print *, 'N_tiles_per_cell exceeded :', rmap%map(pix_count)%NT - print *, i, j, i1, i2, j1, j2 - print *, 'NT =', rmap%map(pix_count)%NT - print *, 'TID =', rmap%map(pix_count)%TID - print *, 'count=', rmap%map(pix_count)%count - stop - endif - - ! for NT-th unique tile ID within science data grid cell (i,j), record tile ID and count - - rmap%map(pix_count)%TID (rmap%map(pix_count)%NT) = NINT(loc_val(n)) ! convert tile ID back to int!?!?!? - rmap%map(pix_count)%count(rmap%map(pix_count)%NT) = density(n) - - endif ! if (density(n)>0) - - END DO ! N=1,NBINS - - rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) - pix_count = pix_count + 1 - - deallocate (loc_val, density) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? - deallocate (loc_int, unq_mask) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? - - endif ! if (NPLUS>0) - - NULLIFY (subset) - - else - - if ( (tile_id (i1,j1)>=1) .and. (tile_id(i1,j1)<=ncatch) ) then - - ! only one unique *land* tile ID in science data grid cell (i,j) - - rmap%map(pix_count)%NT = 1 - rmap%map(pix_count)%TID(1) = tile_id(i1,j1) - rmap%map(pix_count)%COUNT(1) = 1 - rmap%ij_index(i,j) = pix_count - pix_count = pix_count + 1 - - endif - - endif - - end do ! i=1,nc_data - end do ! j=1,nr_data - - end if ! relative resolution of (nc,nr) and (nc_data,nr_data) - - END SUBROUTINE create_mapping + SUBROUTINE create_mapping( nc, nr, nc_data, nr_data, rmap, n_land, tile_id ) + + ! assemble "rmap" structure that can be used for remapping 2-dim gridded + ! science data (nc_data-by-nr_data) to *land* tiles, which are defined + ! on a 2-dim raster grid (nc-by-nr) -! -!---------------------------------------------------------------------- -! - SUBROUTINE merge_lai_data (MaskFile) implicit none - type (date_time_type) :: bf_geol2_time,af_geol2_time,date_time_new,bf_lai_time, & - af_lai_time + + integer, intent(in) :: nc, nr ! dims of raster array (with tile IDs) + integer, intent(in) :: nc_data, nr_data ! dims of science data array + type(regrid_map), intent(inout) :: rmap ! structure for remapping + integer, intent(in) :: n_land ! number of land tiles + integer, target, intent(in) :: tile_id(:,:) + + ! ----------------------- + + integer :: i, j, n, i1, i2, j1, j2, nbins, status, NPLUS, pix_count + + REAL, allocatable, DIMENSION(:) :: loc_val + INTEGER, ALLOCATABLE, DIMENSION(:) :: density, loc_int + logical, allocatable, dimension(:) :: unq_mask + integer, dimension(:,:), pointer :: subset, iraster + + real :: dx_data, dy_data, dx_rst, dy_rst + + ! ------------------------------------------------------------------- + ! + + ! grid spacing + + dx_data = 360./real(nc_data) ! science data + dy_data = 180./real(nr_data) + + dx_rst = 360./real(nc) ! raster (*.rst) + dy_rst = 180./real(nr) + + if( (nc_data >= nc) .and. (nr_data >= nr) ) then + + ! science data to be remapped has resolution same as or finer than that of raster grid with tile_id + + ! Step 1: + ! Apply primitive regridding of tile_id(1:nc,1:nr) to iraster(1:nc_data,1:nr_data) + ! + ! NOTE: When the mask file is GEOS5_10arcsec_mask*.nc, then tile_id raster grid is nc=nx=43200 by nr=ny=21600. + ! In mkCatchParam.F90, nc_data=43200 and nr_data=21600 except for GEOLAND and old (16-day) MODIS1 data. + ! + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! [??] --> In most cases, RegridRaster should have no impact and could probably be skipped. + ! Edits in RegridRaster() will do just that but may not be 0-diff. + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! + allocate(iraster(nc_data,nr_data),stat=STATUS); VERIFY_(STATUS) + call RegridRaster(tile_id,iraster) + + ! now iraster contains tile_id on nc_data-by-nr_data science data grid + + ! [??] WHY REMAP RASTER TO DATA?? SHOULDN'T DATA BE REMAPPED TO RASTER?? + ! THEN WE WOULDN'T NEED A CUSTOM rmap STRUCTURE FOR EACH SCIENCE DATASET + + ! count number of science data grid cells that contribute to *land* tiles (excl. lake, landice, ocean) + + NPLUS = count(iraster>=1 .and. iraster<=n_land) + + allocate( rmap%ij_index(1:nc_data, 1:nr_data), source = 0 ) ! allocate and initialize to 0 + allocate( rmap%map( 1:NPLUS )) + + rmap%map%NT = 1 ! science data & raster resolutions are such that there is at most 1 unique tile ID per science data grid cell + + pix_count = 0 ! 1-dim indexing of 1:NPLUS *science* *data* grid cells that contribute to land tiles + ! [??] WHY IS THIS CALLED pix_count?? + + do j=1,nr_data + do i=1,nc_data + + if( (iraster(i,j)>=1) .and. (iraster(i,j)<=n_land) ) then + + ! science data grid cell (i,j) contributes to a land tile + + pix_count = pix_count + 1 + rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) + + rmap%map(pix_count)%TID (1) = iraster (i,j) ! 1-dim array with tile_id values + rmap%map(pix_count)%count(1) = 1 ! [??] MAYBE DO rmap%map%count=1 OUTSIDE OF THIS LOOP?? + + + endif + end do + end do + deallocate (iraster) ; VERIFY_(STATUS) + + ! verify final value of pix_count after i,j loop + if (pix_count/=NPLUS) then + print *, 'ERROR 1 in create_mapping(); stopping.' + stop + end if + + else + + ! science data to be remapped has coarser resolution than that of raster grid with tile_id + + ! count number of *original* raster grid cells that contribute to *land* tiles (excl. lake, landice, ocean) + + NPLUS = count(tile_id>=1 .and. tile_id<=n_land) + + allocate (rmap%ij_index(1:nc_data, 1:nr_data), source = 0) + allocate (rmap%map( 1:NPLUS )) + + rmap%map%NT = 0 + + pix_count = 1 ! 1-dim indexing of 1:NPLUS *science* *data* grid cells that contribute to land tiles + ! [??] WHY IS THIS CALLED pix_count?? + + ! loop through *science* data grid + + do j=1,nr_data + + ! block (i1:i2,j1:j2) of orig raster grid falls within science data grid cell (i,j) + ! + ! NOTE: --> when ratio dy_data/dy_rst is not integer, all orig raster grid cells that + ! fall partly within science data grid cell are included + + j1 = floor ( ( -90. + (j-1)*dy_data +90. )/dy_rst ) + 1 ! WARNING: mixed mode arithmetic!!! [??] WHY NOT REPLACE dy_data/dy_rst WITH SOMETHING LIKE nr_data/nr[+1] ??? + j2 = ceiling( ( -90. + (j )*dy_data +90. )/dy_rst ) ! WARNING: mixed mode arithmetic!!! + + do i=1,nc_data + + i1 = floor ( ( -180. + (i-1)*dx_data +180.)/dx_rst) + 1 ! WARNING: mixed mode arithmetic!!! [??] WHY NOT REPLACE dx_data/dx_rst WITH SOMETHING LIKE nc_data/nc[+1] ??? + i2 = ceiling( ( -180. + (i )*dx_data +180.)/dx_rst) ! WARNING: mixed mode arithmetic!!! + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! a more sensible order of operations might be as follows: + ! + ! ! check if there is *land* in this science data grid cell + ! + ! subset => tile_id(i1:i2,j1:j2) + ! + ! ! WITHIN SUBSET, count number of *original* raster grid cells that contribute + ! ! to *land* tiles (excl. lake, landice, ocean) + ! + ! NPLUS = count(subset>=1 .and. subset<=n_land) ! [??] OVERWRITES NPLUS FROM ABOVE !?!?!?!?! + ! + ! if (NPLUS>0) then + ! + ! ! there is *land* in this science data grid cell + ! + ! rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) + ! pix_count = pix_count + 1 ! [??] SWITCH ORDER WITH PREVIOUS LINE AND INIT pix_count TO ZERO ABOVE + ! + ! if (j2>j1 .or. i2>i1) then + ! + ! etc... [MAKE SURE TO REMOVE rmap%ij_index(i,j)=.. AND pix_count+=1 FROM CODE BELOW] + ! + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + + if (j2>j1 .or. i2>i1) then + + subset => tile_id(i1:i2,j1:j2) + + ! WITHIN SUBSET, count number of *original* raster grid cells that contribute + ! to *land* tiles (excl. lake, landice, ocean) + + NPLUS = count(subset>=1 .and. subset<=n_land) ! [??] OVERWRITES NPLUS FROM ABOVE !?!?!?!?! + + if (NPLUS>0) then + + ! determine unique *land* tile IDs within science data grid cell (i,j) + + ! Step (i): determine NBINS = unique *land* tile ID values within subset + + allocate(loc_int (1:NPLUS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? NPLUS<=ceiling(dx_data/dx_rst)*ceiling(dy_data/dy_rst) + allocate(unq_mask(1:NPLUS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? + + loc_int = pack(subset, mask=(subset>=1 .and. subset<=n_land)) + call MAPL_Sort(loc_int) + unq_mask = .true. + do n=2,NPLUS + unq_mask(n) = .not.(loc_int(n) == loc_int(n-1)) + end do + NBINS = count(unq_mask) + + ! Step (ii): assemble histogram of unique *land* tile ID values + + allocate(loc_val(1:NBINS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? NBINS<=N_tile_per_gridcell + allocate(density(1:NBINS)) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? + + loc_val = 1.*pack(loc_int,mask=unq_mask) ! [??] WHY REAL WHEN HANDLING INTEGERS??? + + call histogram( size(subset,1)*size(subset,2), NBINS, density, loc_val, real(subset) ) + + ! now "density(n)" contains the number of orig raster grid cells within the science + ! data grid cell (i,j) that contribute to the tile with the tile ID in "loc_val(n)" + + DO N=1,NBINS + + if (density(n)>0) then + + ! build up NT = # unique tile IDs within science grid cell (i,j) [a.k.a. (pix_count)] + + rmap%map(pix_count)%NT = rmap%map(pix_count)%NT + 1 + + ! verify NT <= max allowed value (=N_tiles_per_cell) + + if(rmap%map(pix_count)%NT > N_tiles_per_cell) then ! [??] WHY NOT CHECK NBINS<=N_tiles_per_gridcell OUTSIDE OF THIS LOOP???? + print *, 'N_tiles_per_cell exceeded :', rmap%map(pix_count)%NT + print *, i, j, i1, i2, j1, j2 + print *, 'NT =', rmap%map(pix_count)%NT + print *, 'TID =', rmap%map(pix_count)%TID + print *, 'count=', rmap%map(pix_count)%count + stop + endif + + ! for NT-th unique tile ID within science data grid cell (i,j), record tile ID and count + + rmap%map(pix_count)%TID (rmap%map(pix_count)%NT) = NINT(loc_val(n)) ! convert tile ID back to int!?!?!? + rmap%map(pix_count)%count(rmap%map(pix_count)%NT) = density(n) + + endif ! if (density(n)>0) + + END DO ! N=1,NBINS + + rmap%ij_index(i,j) = pix_count ! 1-dim index for [land subset of] 2-dim array (science data grid) + pix_count = pix_count + 1 + + deallocate (loc_val, density) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? + deallocate (loc_int, unq_mask) ! [??] WHY NOT ALLOCATE TO A MAX SIZE OUTSIDE OF THE LOOP?? + + endif ! if (NPLUS>0) + + NULLIFY (subset) + + else + + if ( (tile_id (i1,j1)>=1) .and. (tile_id(i1,j1)<=n_land) ) then + + ! only one unique *land* tile ID in science data grid cell (i,j) + + rmap%map(pix_count)%NT = 1 + rmap%map(pix_count)%TID(1) = tile_id(i1,j1) + rmap%map(pix_count)%COUNT(1) = 1 + rmap%ij_index(i,j) = pix_count + pix_count = pix_count + 1 + + endif + + endif + + end do ! i=1,nc_data + end do ! j=1,nr_data + + end if ! relative resolution of (nc,nr) and (nc_data,nr_data) + + END SUBROUTINE create_mapping + + ! + !---------------------------------------------------------------------- + ! + SUBROUTINE merge_lai_data (MaskFile, ntiles, pfaf) + implicit none character (*) :: MaskFile - integer :: n,k,ntiles,t,ierr - integer, allocatable, dimension (:) :: pfaf + integer, intent(in) :: ntiles + integer, intent(in) :: pfaf(:) + + type (date_time_type) :: bf_geol2_time,af_geol2_time,date_time_new,bf_lai_time, & + af_lai_time + integer :: n,k, t,ierr + ! South AMerica/ Africa/ Australia are from GEOLAND2 integer :: i1,i2,i3,i4,i5,i6 - integer, parameter :: i1_hydr = 1011000, i2_hydr = 1999900 ! South America - integer, parameter :: i3_hydr = 3021000, i4_hydr = 3990000 ! Africa - integer, parameter :: i5_hydr = 5000142, i6_hydr = 5999900 ! Australia - integer, parameter :: i1_srtm = 229075 , i2_srtm = 267083 ! South America - integer, parameter :: i3_srtm = 75369 , i4_srtm = 140751 ! Africa + integer, parameter :: i1_hydr = 1011000, i2_hydr = 1999900 ! South America + integer, parameter :: i3_hydr = 3021000, i4_hydr = 3990000 ! Africa + integer, parameter :: i5_hydr = 5000142, i6_hydr = 5999900 ! Australia + integer, parameter :: i1_srtm = 229075 , i2_srtm = 267083 ! South America + integer, parameter :: i3_srtm = 75369 , i4_srtm = 140751 ! Africa integer, parameter :: i5_srtm = 267084 , i6_srtm = SRTM_maxcat ! Australia REAL, ALLOCATABLE, dimension (:) :: geol2_lai_bf,geol2_lai_af,geol2_lai, lai @@ -1438,133 +1383,120 @@ SUBROUTINE merge_lai_data (MaskFile) i6 = i6_hydr endif - open (10, file ='clsm/catchment.def',form='formatted',status='old',action='read') - read (10,*) ntiles - - allocate (pfaf(1:ntiles)) allocate (geol2_lai_bf(1:ntiles)) allocate (geol2_lai_af(1:ntiles)) allocate (geol2_lai (1:ntiles)) allocate (lai (1:ntiles)) - - do n =1,ntiles - read (10,*) k,pfaf(n) - end do - close (10,status='keep') - -! - open (41,file='clsm/lai.GEOLAND2_10-DayClim', & + ! + open (41,file='clsm/lai.GEOLAND2_10-DayClim', & form='unformatted',status='old',convert='little_endian',action='read') - open (42,file='clsm/lai.MODIS_8-DayClim', & + open (42,file='clsm/lai.MODIS_8-DayClim', & form='unformatted',status='old',convert='little_endian',action='read') - open (43,file='clsm/lai.dat', & + open (43,file='clsm/lai.dat', & form='unformatted',status='unknown',convert='little_endian',action='write') - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) geol2_lai_bf - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) - - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) geol2_lai_af - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) - - do t = 1, 48 - - read(42) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read(42) lai - write(43) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(ntiles),1. - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,date_time_new) - -! date_time_new%year = nint(yr) + 2001 -! date_time_new%month = nint(mn) -! date_time_new%day = nint(dy) -! date_time_new%hour = 0 -! date_time_new%min = 0 -! date_time_new%sec = 0 -! call get_dofyr_pentad(date_time_new) - if (datetime_le_refdatetime(date_time_new,af_geol2_time)) then - + read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + read(41) geol2_lai_bf + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) + + read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + read(41) geol2_lai_af + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) + + do t = 1, 48 + + read(42) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read(42) lai + write(43) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(ntiles),1. + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,date_time_new) + + ! date_time_new%year = nint(yr) + 2001 + ! date_time_new%month = nint(mn) + ! date_time_new%day = nint(dy) + ! date_time_new%hour = 0 + ! date_time_new%min = 0 + ! date_time_new%sec = 0 + ! call get_dofyr_pentad(date_time_new) + if ( .not. datetime_le_refdatetime(date_time_new,af_geol2_time)) then + read(41,IOSTAT=ierr) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + if(ierr == 0) then + geol2_lai_bf = geol2_lai_af + read(41) geol2_lai_af + bf_geol2_time = af_geol2_time + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) else - read(41,IOSTAT=ierr) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - if(ierr == 0) then - geol2_lai_bf = geol2_lai_af - read(41) geol2_lai_af - bf_geol2_time = af_geol2_time - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) - else - print *,'END OF GEOL2 LAI FILE' - stop - endif - endif - - if(t==1) then - date_time_new%year = date_time_new%year + 1 - geol2_lai_af = geol2_lai_bf - af_geol2_time = bf_geol2_time - af_geol2_time%year = af_geol2_time%year + 1 - - do k = 1,34 - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) geol2_lai_bf - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) - end do + print *,'END OF GEOL2 LAI FILE' + stop endif + endif -! print *,t -! print *,'DATE_TIME_NEW :',date_time_new -! print *,'bf_geol2_time :',bf_geol2_time -! print *,'af_geol2_time :',af_geol2_time + if(t==1) then + date_time_new%year = date_time_new%year + 1 + geol2_lai_af = geol2_lai_bf + af_geol2_time = bf_geol2_time + af_geol2_time%year = af_geol2_time%year + 1 - call Time_Interp_Fac (date_time_new, bf_geol2_time, af_geol2_time, slice1, slice2) - geol2_lai = (slice1*geol2_lai_bf + slice2*geol2_lai_af) - - if(t == 1) then - rewind(41) + do k = 1,34 read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 read(41) geol2_lai_bf - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) - - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) geol2_lai_af - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) - endif + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) + end do + endif -! replace South America with GEOLAND2 + ! print *,t + ! print *,'DATE_TIME_NEW :',date_time_new + ! print *,'bf_geol2_time :',bf_geol2_time + ! print *,'af_geol2_time :',af_geol2_time - DO n =1,ntiles - if((pfaf(n) >= i1).and.(pfaf(n) <= i2)) lai(n) = geol2_lai(n) - if((pfaf(n) >= i3).and.(pfaf(n) <= i4)) lai(n) = geol2_lai(n) - if((pfaf(n) >= i5).and.(pfaf(n) <= i6)) lai(n) = geol2_lai(n) - end do - write (43) lai(:) + call Time_Interp_Fac (date_time_new, bf_geol2_time, af_geol2_time, slice1, slice2) + geol2_lai = (slice1*geol2_lai_bf + slice2*geol2_lai_af) + + if(t == 1) then + rewind(41) + read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + read(41) geol2_lai_bf + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_geol2_time) + + read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 + read(41) geol2_lai_af + call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_geol2_time) + endif + + ! replace South America with GEOLAND2 + + DO n =1,ntiles + if((pfaf(n) >= i1).and.(pfaf(n) <= i2)) lai(n) = geol2_lai(n) + if((pfaf(n) >= i3).and.(pfaf(n) <= i4)) lai(n) = geol2_lai(n) + if((pfaf(n) >= i5).and.(pfaf(n) <= i6)) lai(n) = geol2_lai(n) end do + write (43) lai(:) + end do - close (41,status = 'keep') - close (42,status = 'keep') - close (43,status = 'keep') + close (41,status = 'keep') + close (42,status = 'keep') + close (43,status = 'keep') - deallocate (pfaf,geol2_lai_bf, geol2_lai_af,geol2_lai,lai) + deallocate (geol2_lai_bf, geol2_lai_af,geol2_lai,lai) END SUBROUTINE merge_lai_data -! -!---------------------------------------------------------------------- -! - SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) - + ! + !---------------------------------------------------------------------- + ! + SUBROUTINE modis_scale_para_high (MA, n_land) implicit none + character(*), intent(in) :: MA + integer, intent(in) :: n_land + type (date_time_type) :: gf_green_time,af_green_time,end_time, & - bf_lai_time,af_lai_time,date_time_new,bf_modis_time, & - af_modis_time - logical :: ease_grid - character*6 :: MA + bf_lai_time,af_lai_time,date_time_new,bf_modis_time, & + af_modis_time CHARACTER*20 :: version,resoln,continent integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean REAL :: tsteps,zth, slr,tarea - INTEGER :: typ,j_dum,ierr,indr1,ip2 + INTEGER :: typ,j_dum,ierr,indr1 character*100 :: path,fname,fout,metpath - character (*) :: fnameTil - integer :: n,maxcat,ip + integer :: n,ip integer :: yy,j,month integer, allocatable, dimension (:) :: vegcls real, allocatable, dimension (:) :: & @@ -1579,60 +1511,32 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) real :: yr,mn,dy,yr1,mn1,dy1,dum, slice1,slice2 logical :: save_sib = .false. - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)maxcat - allocate (albvf (1:maxcat)) - allocate (albnf (1:maxcat)) - allocate (calbvf (1:maxcat)) - allocate (calbnf (1:maxcat)) - allocate (modisvf (1:maxcat)) - allocate (modisnf (1:maxcat)) - allocate (lai (1:maxcat)) - allocate (green (1:maxcat)) - allocate (lai_before (1:maxcat)) - allocate (grn_before (1:maxcat)) - allocate (lai_after (1:maxcat)) - allocate (grn_after (1:maxcat)) - allocate (vegcls (1:maxcat)) - allocate (zero_array (1:maxcat)) - allocate (one_array (1:maxcat)) - allocate (albvr (1:maxcat)) - allocate (albnr (1:maxcat)) - close (10,status='keep') - - fname=trim(fnameTil)//'.til' - open (10,file=fname,status='old',action='read',form='formatted') + allocate (albvf (1:n_land)) + allocate (albnf (1:n_land)) + allocate (calbvf (1:n_land)) + allocate (calbnf (1:n_land)) + allocate (modisvf (1:n_land)) + allocate (modisnf (1:n_land)) + allocate (lai (1:n_land)) + allocate (green (1:n_land)) + allocate (lai_before (1:n_land)) + allocate (grn_before (1:n_land)) + allocate (lai_after (1:n_land)) + allocate (grn_after (1:n_land)) + allocate (vegcls (1:n_land)) + allocate (zero_array (1:n_land)) + allocate (one_array (1:n_land)) + allocate (albvr (1:n_land)) + allocate (albnr (1:n_land)) + fname='clsm/mosaic_veg_typs_fracs' open (20,file=fname,status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum - - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - end do - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ !,pfs,lont,latt,ig,jg,fr_gcm - else - !read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - ! typ,tarea,lont,latt,ig,jg,fr_gcm,indx_dum,pfs,j_dum,fr_cat,j_dum - read(10,*,IOSTAT=ierr) typ - endif - if (typ == 100) then - ip2 = n - !read (20,'(i10,i8,2(2x,i3),2(2x,f6.4))') & - ! indr1,indr1,vegcls(ip2),indr1,fr_gcm,fr_gcm - read (20,*,IOSTAT=ierr) indr1,indr1,vegcls(ip2) - endif - if(ierr /= 0)write (*,*)'Problem reading', n, ease_grid + do n = 1, n_land + read (20,*,IOSTAT=ierr) indr1,indr1,vegcls(n) + if(ierr /= 0)write (*,*)'Problem reading', n end do - close (10,status='keep') close (20,status='keep') albvf =0. @@ -1646,7 +1550,7 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) albvr = 0. albnr = 0. -! MODIS Albedo files + ! MODIS Albedo files if(MA == 'MODIS1') then open (10,file='clsm/AlbMap.WS.16-day.tile.0.3_0.7.dat',& form='unformatted',convert='little_endian', & @@ -1670,23 +1574,23 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) read (10) modisvf (:) read (11) modisnf (:) -! SiB Albedo Parameterization files + ! SiB Albedo Parameterization files if (save_sib) then open (20,file='clsm/sib_visdf.dat',convert='little_endian', & - action='write',status='unknown',form='unformatted') + action='write',status='unknown',form='unformatted') open (21,file='clsm/sib_nirdf.dat',convert='little_endian', & - action='write',status='unknown',form='unformatted') - write(20) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - write(21) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. + action='write',status='unknown',form='unformatted') + write(20) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + write(21) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. endif -! MODIS scale parameter files + ! MODIS scale parameter files open (30,file='clsm/visdf.dat',convert='little_endian', & - action='write',status='unknown',form='unformatted') + action='write',status='unknown',form='unformatted') open (31,file='clsm/nirdf.dat',convert='little_endian', & - action='write',status='unknown',form='unformatted') - write(30) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - write(31) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. + action='write',status='unknown',form='unformatted') + write(30) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + write(31) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,date_time_new) bf_modis_time = date_time_new @@ -1712,19 +1616,19 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(40) lai_before call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,bf_lai_time) - + read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(40) lai_after call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - - if(date_time_new%dofyr < bf_lai_time%dofyr) then + + if(date_time_new%dofyr < bf_lai_time%dofyr) then do while ((date_time_new%dofyr > af_lai_time%dofyr)) lai_before = lai_after bf_lai_time = af_lai_time read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(40) lai_after call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - end do + end do endif fname='clsm/green.dat' @@ -1733,7 +1637,7 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(41) grn_before call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,gf_green_time) - + read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 read(41) grn_after call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) @@ -1745,187 +1649,179 @@ SUBROUTINE modis_scale_para_high (ease_grid,MA,fnameTil) tsteps =0. do while (datetime_le_refdatetime(date_time_new,end_time)) - -! write (*,'(a48,i4.4,i2.2,i2.2)') ' Computing MODIS scale parameters for month: ', & - - - if (datetime_le_refdatetime(date_time_new,af_lai_time)) then - else + ! write (*,'(a48,i4.4,i2.2,i2.2)') ' Computing MODIS scale parameters for month: ', & + - read(40,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - if(ierr == 0) then - lai_before = lai_after - read(40) lai_after - bf_lai_time = af_lai_time - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - else - rewind(40) - read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read(40) lai_before - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,bf_lai_time) - read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read(40) lai_after - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - - if(date_time_new%dofyr < bf_lai_time%dofyr) then - do while ((date_time_new%dofyr > af_lai_time%dofyr)) - lai_before = lai_after - bf_lai_time = af_lai_time - read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read(40) lai_after - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) - end do - endif - endif - endif - call Time_Interp_Fac (date_time_new, bf_lai_time, af_lai_time, slice1, slice2) - lai = (slice1*lai_before + slice2*lai_after) - - if (datetime_le_refdatetime(date_time_new,af_green_time)) then - - else - - read(41,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - if(ierr == 0) then - grn_before = grn_after - gf_green_time = af_green_time - read(41) grn_after - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) - endif - endif -! else -! rewind(41) -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_before -! gf_green_time%month = NINT(mn) -! gf_green_time%day = NINT(dy) -! call get_dofyr_pentad(gf_green_time) -! af_green_time%month = NINT(mn1) -! af_green_time%day = NINT(dy1) -! call get_dofyr_pentad(af_green_time) -! if(date_time_new%dofyr < gf_green_time%dofyr) then -! do while ((date_time_new%dofyr > af_green_time%dofyr)) -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_before -! gf_green_time%year = date_time_new%year -! gf_green_time%month = NINT(mn) -! gf_green_time%day = NINT(dy) -! call get_dofyr_pentad(gf_green_time) -! af_green_time%year = date_time_new%year -! if ((yr1-yr) == 1.)af_green_time%year = af_green_time%year+1 -! af_green_time%month = NINT(mn1) -! af_green_time%day = NINT(dy1) -! call get_dofyr_pentad(af_green_time) -! end do -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_after -! endif -! endif -! endif - - call Time_Interp_Fac (date_time_new, gf_green_time, af_green_time, slice1, slice2) - green = (slice1*grn_before + slice2*grn_after) - - call sibalb ( & - MAXCAT,vegcls,lai,green, zero_array, & - one_array,one_array,one_array,one_array, & - ALBVR, ALBNR, albvf, albnf) - - calbvf = calbvf + albvf - calbnf = calbnf + albnf - tsteps = tsteps + 1. - call augment_date_time( 86400, date_time_new ) - - if (datetime_le_refdatetime(date_time_new,af_modis_time)) then - + if ( .not. datetime_le_refdatetime(date_time_new,af_lai_time)) then + read(40,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + if(ierr == 0) then + lai_before = lai_after + read(40) lai_after + bf_lai_time = af_lai_time + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) else + rewind(40) + read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read(40) lai_before + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,bf_lai_time) + read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read(40) lai_after + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) + + if(date_time_new%dofyr < bf_lai_time%dofyr) then + do while ((date_time_new%dofyr > af_lai_time%dofyr)) + lai_before = lai_after + bf_lai_time = af_lai_time + read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read(40) lai_after + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) + end do + endif + endif + endif + call Time_Interp_Fac (date_time_new, bf_lai_time, af_lai_time, slice1, slice2) + lai = (slice1*lai_before + slice2*lai_after) + + if ( .not. datetime_le_refdatetime(date_time_new,af_green_time)) then + read(41,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + if(ierr == 0) then + grn_before = grn_after + gf_green_time = af_green_time + read(41) grn_after + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) + endif + endif + ! else + ! rewind(41) + ! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + ! read(41) grn_before + ! gf_green_time%month = NINT(mn) + ! gf_green_time%day = NINT(dy) + ! call get_dofyr_pentad(gf_green_time) + ! af_green_time%month = NINT(mn1) + ! af_green_time%day = NINT(dy1) + ! call get_dofyr_pentad(af_green_time) + ! if(date_time_new%dofyr < gf_green_time%dofyr) then + ! do while ((date_time_new%dofyr > af_green_time%dofyr)) + ! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + ! read(41) grn_before + ! gf_green_time%year = date_time_new%year + ! gf_green_time%month = NINT(mn) + ! gf_green_time%day = NINT(dy) + ! call get_dofyr_pentad(gf_green_time) + ! af_green_time%year = date_time_new%year + ! if ((yr1-yr) == 1.)af_green_time%year = af_green_time%year+1 + ! af_green_time%month = NINT(mn1) + ! af_green_time%day = NINT(dy1) + ! call get_dofyr_pentad(af_green_time) + ! end do + ! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + ! read(41) grn_after + ! endif + ! endif + ! endif + + call Time_Interp_Fac (date_time_new, gf_green_time, af_green_time, slice1, slice2) + green = (slice1*grn_before + slice2*grn_after) + + call sibalb ( & + n_land,vegcls,lai,green, zero_array, & + one_array,one_array,one_array,one_array, & + ALBVR, ALBNR, albvf, albnf) + + calbvf = calbvf + albvf + calbnf = calbnf + albnf + tsteps = tsteps + 1. + call augment_date_time( 86400, date_time_new ) + + if ( .not. datetime_le_refdatetime(date_time_new,af_modis_time)) then + bf_modis_time = af_modis_time + calbvf = calbvf/tsteps + calbnf = calbnf/tsteps + + modisvf = modisvf/(calbvf + 1.e-20) + modisnf = modisnf/(calbnf + 1.e-20) + + do n =1, n_land + ! if(modisvf(n).le.0)print *,'Negative MODISVF scale param at cell',n, modisvf(n) + ! if(modisnf(n).le.0)print *,'Negative MODISNF scale param at cell',n, modisnf(n) + ! if(modisvf(n).gt.100)print *,'Too large MODISVF scale param at cell',n, modisvf(n) + ! if(modisnf(n).gt.100)print *,'Too large MODISNF scale param at cell',n, modisnf(n) + if(modisvf(n).le.0.) modisvf(n) = 1. + if(modisnf(n).le.0.) modisnf(n) = 1. + if(modisvf(n).gt.100)modisvf(n)= 1. + if(modisnf(n).gt.100)modisnf(n)= 1. + enddo + + if (save_sib) then + write (20) calbvf (:) + write (21) calbnf (:) + endif + + write (30) modisvf (:) + write (31) modisnf (:) + + read(10,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + + if(ierr == 0) then + read(11) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 + read (10) modisvf (:) + read (11) modisnf (:) + write(30) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + write(31) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + + if (save_sib) then + write(20) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + write(21) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(n_land),1. + endif + bf_modis_time = af_modis_time - calbvf = calbvf/tsteps - calbnf = calbnf/tsteps - - modisvf = modisvf/(calbvf + 1.e-20) - modisnf = modisnf/(calbnf + 1.e-20) - - do n =1, maxcat -! if(modisvf(n).le.0)print *,'Negative MODISVF scale param at cell',n, modisvf(n) -! if(modisnf(n).le.0)print *,'Negative MODISNF scale param at cell',n, modisnf(n) -! if(modisvf(n).gt.100)print *,'Too large MODISVF scale param at cell',n, modisvf(n) -! if(modisnf(n).gt.100)print *,'Too large MODISNF scale param at cell',n, modisnf(n) - if(modisvf(n).le.0.) modisvf(n) = 1. - if(modisnf(n).le.0.) modisnf(n) = 1. - if(modisvf(n).gt.100)modisvf(n)= 1. - if(modisnf(n).gt.100)modisnf(n)= 1. - enddo - - if (save_sib) then - write (20) calbvf (:) - write (21) calbnf (:) - endif - - write (30) modisvf (:) - write (31) modisnf (:) - - read(10,IOSTAT=ierr) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - - if(ierr == 0) then - - read(11) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 - read (10) modisvf (:) - read (11) modisnf (:) - write(30) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - write(31) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - - if (save_sib) then - write(20) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - write(21) yr,mn,dy,0.,0.,0.,yr1,mn1,dy1,0.,0.,0.,float(maxcat),1. - endif - - bf_modis_time = af_modis_time - call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_modis_time) - calbvf =0. - calbnf =0. - albvf =0. - albnf =0. - tsteps =0. - endif - endif - end do - - deallocate (modisvf,modisnf,albvf,albnf) - deallocate (green,lai) - deallocate (vegcls) - deallocate (calbvf,calbnf) - deallocate (lai_before,grn_before, lai_after,grn_after) - deallocate (zero_array, one_array, albvr, albnr) - - close (10, status='keep') - close (11, status='keep') - close (30, status='keep') - close (31, status='keep') - if (save_sib) then - close (20, status='keep') - close (21, status='keep') - endif - -END SUBROUTINE modis_scale_para_high + call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_modis_time) + calbvf =0. + calbnf =0. + albvf =0. + albnf =0. + tsteps =0. + endif + endif + end do ! while (datetime_le_refdatetime(date_time_new,end_time)) + + deallocate (modisvf,modisnf,albvf,albnf) + deallocate (green,lai) + deallocate (vegcls) + deallocate (calbvf,calbnf) + deallocate (lai_before,grn_before, lai_after,grn_after) + deallocate (zero_array, one_array, albvr, albnr) + + close (10, status='keep') + close (11, status='keep') + close (30, status='keep') + close (31, status='keep') + if (save_sib) then + close (20, status='keep') + close (21, status='keep') + endif + + END SUBROUTINE modis_scale_para_high + + ! + ! --------------------------------------------------------------------------------------- + ! + SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA, n_tiles) -! -! --------------------------------------------------------------------------------------- -! - SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) - ! process high-res MODIS albedo and create 8-day or 16-day climatological data in tile space - + implicit none integer, intent(in) :: nc_data, nr_data ! expected dimensions of global science data array type (regrid_map), intent(in) :: rmap ! structure for mapping from science data grid to tile space character*6, intent(in) :: MA ! MODIS albedo version string - + integer, intent(in) :: n_tiles + ! ------------------------------------------ - integer :: kk, nn, ii, jj, ncid, i_highd, j_highd, pix_count, N_tiles + integer :: kk, nn, ii, jj, ncid, i_highd, j_highd, pix_count integer :: status, iLL, jLL, iG, jG, ix, jx, nc_10, nr_10, n_tslices, tt integer :: time_slice, time_slice_next, yr, mn, dd, yr1, mn1, dd1 character*512 :: fname @@ -1938,20 +1834,14 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) character(64) :: Iam = 'modis_alb_on_tiles_high' REAL :: sf - + ! ----------------------------------------------------------------------- ! - ! read number of catchment-tiles (N_tiles) from "catchment.def" file - - fname='clsm/catchment.def' - open( 10, file=fname, status='old', action='read', form='formatted') - read( 10, * ) N_tiles - close(10, status='keep') - + ! get some common dimensions and attributes from one of the 36-by-18 MODIS files - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - + if (MA=='MODIS1') then fname =trim(MAKE_BCS_INPUT_DIR)//'/land/albedo/snowfree/MODIS/v1/MODISalb.c004.v2.WS_H11V13.nc' elseif (MA=='MODIS2') then @@ -1962,88 +1852,88 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) end if status = NF_OPEN( trim(fname), NF_NOWRITE, ncid ); VERIFY_(STATUS) - + status = NF_GET_att_INT( ncid, NF_GLOBAL, 'N_lon_global', i_highd ); VERIFY_(STATUS) status = NF_GET_att_INT( ncid, NF_GLOBAL, 'N_lat_global', j_highd ); VERIFY_(STATUS) - + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) ! nc_10 = # grid cells in long dir status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) ! nr_10 = # grid cells in lat dir status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) ! # time slices - + allocate(MMDD (0:n_tslices+1)) allocate(MMDD_next(0:n_tslices+1)) - + ! read variable #3 = MMDD = start month/day of time-averaging interval per MAPL_ReadForcing() convention - + status = NF_GET_VARA_text( ncid, 3, (/1,1/), (/4,n_tslices/), MMDD(1:n_tslices) ); VERIFY_(STATUS) status = NF_CLOSE(ncid); VERIFY_(STATUS) - + ! verify input nc_data and nr_data against global dimensions in nc4 file - + if(nc_data/=i_highd .or. nr_data/=j_highd) then print *, 'ERROR ', trim(Iam), '(): Inconsistent mapping and dimensions; stopping' stop end if - + ! "wrap around" for mmdd - + mmdd(0) = mmdd(n_tslices) mmdd(n_tslices+1) = mmdd(1) - + ! assemble mmdd_next - + mmdd_next( 0:n_tslices-1) = mmdd(1:n_tslices) mmdd_next(n_tslices:n_tslices+1) = mmdd(1:2) - + ! allocate arrays for gridded albedo data from one of the 36-by-18 MODIS files - + allocate(net_data1(1:nc_10,1:nr_10)) allocate(net_data2(1:nc_10,1:nr_10)) - + ! open *output* files - + if(MA == 'MODIS1') then open(31,file='clsm/AlbMap.WS.16-day.tile.0.3_0.7.dat', & form='unformatted',status='unknown',convert='little_endian') open(32,file='clsm/AlbMap.WS.16-day.tile.0.7_5.0.dat', & form='unformatted',status='unknown',convert='little_endian') endif - + if(MA == 'MODIS2') then open(31,file='clsm/AlbMap.WS.8-day.tile.0.3_0.7.dat', & form='unformatted',status='unknown',convert='little_endian') open(32,file='clsm/AlbMap.WS.8-day.tile.0.7_5.0.dat', & form='unformatted',status='unknown',convert='little_endian') endif - + ! allocate data vectors in tile space - + allocate(vec_AlbVis( N_tiles)) allocate(count_AlbVis(N_tiles)) allocate(vec_AlbNir( N_tiles)) allocate(count_AlbNir(N_tiles)) - + do tt=0,n_tslices+1 ! get time stamp for MAPL_Readforcing convention - + ! yr, mn, dd = year/month/day at end of averaging interval in current time slice ! yr1, mn1, dd1 = year/month/day at start of averaging interval in current time slice - + ! initialize time_slice = tt yr = 1 yr1 = 1 - + ! deal with wrap-around for tt=0, tt=n_tslices, and tt=n_tslices+1 - + if (tt == 0) then time_slice = n_tslices yr = 0 endif - + if (tt >= n_tslices) then yr1 = 2 if (tt==n_tslices+1) then @@ -2051,26 +1941,26 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) yr = 2 endif endif - + ! convert mmdd string to integers for month (mn) and day (dd) - + read(mmdd( tt),'(i2.2,i2.2)') mn, dd read(mmdd_next(tt),'(i2.2,i2.2)') mn1, dd1 - + ! initialize data vectors in tile space - + vec_AlbVis = 0. count_AlbVis = 0. vec_AlbNir = 0. count_AlbNir = 0. - + ! loop through 36-by-18 MODIS files - - do jx = 1,18 + + do jx = 1,18 do ix = 1,36 ! open MODIS file (ix,jx) - + write (vv,'(i2.2)')jx write (hh,'(i2.2)')ix @@ -2080,39 +1970,39 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) if(status == 0) then - + ! read attributes (global i,j indices of first grid cell in chunk of data in this MODIS file) - + status = NF_GET_att_INT( ncid, NF_GLOBAL, 'i_ind_offset_LL', iLL ); VERIFY_(STATUS) status = NF_GET_att_INT( ncid, NF_GLOBAL, 'j_ind_offset_LL', jLL ); VERIFY_(STATUS) - + ! assume scale factor (sf) is same for Vis and NIR albedo - + status = NF_GET_att_REAL( ncid, 4, 'ScaleFactor', sf ); VERIFY_(STATUS) - + ! read chunk of MODIS data in file ! ! variable #4 = net_data1 = Alb_0.3_0.7 = visible (Vis) albedo ! variable #5 = net_data2 = Alb_0.7_5.0 = near-infrared (NIR) albedo - + status = NF_GET_VARA_INT( ncid, 4, (/1,1,time_slice/), (/nc_10,nr_10,1/), net_data1 ); VERIFY_(STATUS) status = NF_GET_VARA_INT( ncid, 5, (/1,1,time_slice/), (/nc_10,nr_10,1/), net_data2 ); VERIFY_(STATUS) - + ! loop through grid cells of this file's albedo science data and add into tile-space data vectors; ! keep count of how many (original) raster grid cells contribute (note that this integer count ! does not allow for fractional coverage of raster grid cells by the science data value and ! therefore is approximate) - + do jj=1,nr_10 do ii=1,nc_10 - + iG = ii+iLL-1 ! i-index relative to *global* 30-arcsec grid jG = jj+jLL-1 ! j-index relative to *global* 30-arcsec grid - + pix_count = rmap%ij_index(iG,jG) - + if (pix_count ==0) cycle - + if(net_data1(ii,jj) > 0) then if(rmap%map(pix_count)%nt > 0) then do kk = 1, rmap%map(pix_count)%nt @@ -2135,2542 +2025,2430 @@ SUBROUTINE modis_alb_on_tiles_high( nc_data, nr_data, rmap, MA ) endif enddo enddo - + status = NF_CLOSE(ncid) endif end do end do - + ! finalize remapping - + DO nn =1,N_tiles if(count_AlbVis(nn)/=0.) vec_AlbVis(nn)=vec_AlbVis(nn)/count_AlbVis(nn) if(count_AlbNir(nn)/=0.) vec_AlbNir(nn)=vec_AlbNir(nn)/count_AlbNir(nn) END DO - + ! write to file (MAPL_ReadForcing convention) - + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,N_tiles,1/)) write(31) vec_AlbVis(:) write(32) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,N_tiles,1/)) write(32) vec_AlbNir(:) - + end do ! do tt=0,n_tslices+1 - + close(31,status='keep') close(32,status='keep') - + deallocate( net_data1, net_data2 ) deallocate( count_AlbVis, count_AlbNir ) deallocate( vec_AlbVis, vec_AlbNir ) - + END SUBROUTINE modis_alb_on_tiles_high + + ! --------------------------------------------------------------------------------------- -! --------------------------------------------------------------------------------------- -! - SUBROUTINE hres_lai (nx,ny,fnameRst,lai_name,merge) +! SUBROUTINE hres_lai (nx,ny, maxcat,fnameRst,lai_name,merge) +! ! +! ! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data +! ! +! implicit none +! integer, intent (in) :: nx, ny, maxcat +! character(*) :: fnameRst,lai_name +! integer, intent(in), optional :: merge +! integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr +! integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & +! time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2 +! real :: dum, gyr,gmn,gdy,gyr1,gmn1,gdy1, slice1,slice2 +! character*100 :: fout +! character*200 :: fname +! character*10 :: string +! character*2 :: VV,HH +! integer, allocatable, dimension (:,:) :: & +! net_data1 +! integer (kind=2) , allocatable, target, dimension (:,:) :: LAI_HIGH +! integer (kind=2), pointer, dimension (:,:) :: Raster +! REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai +! REAL, ALLOCATABLE, dimension (:) :: gswp2_lai_bf,gswp2_lai_af,gswp2_lai +! integer, allocatable, target, dimension (:,:) :: tile_id +! integer, pointer :: iRaster(:,:) +! character(len=4), dimension (:), allocatable :: MMDD, MMDD_next +! logical :: regrid +! REAL :: sf +! logical :: first_entry = .true. +! type (date_time_type) :: bf_gswp2_time,af_gswp2_time,date_time_new,bf_lai_time, & +! af_lai_time +! ! +! if (first_entry) then +! nullify(iraster) ; first_entry = .false. +! end if ! -! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data +! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) +! fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H11V13.nc' +! status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) +! status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) +! status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) +! status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) +! status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) +! status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) +! status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) +! status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) +! allocate (MMDD (0: n_tslices + 1)) +! allocate (MMDD_next (0: n_tslices + 1)) ! - implicit none - integer, intent (in) :: nx, ny - character(*) :: fnameRst,lai_name - integer, intent(in), optional :: merge - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2 - real :: dum, gyr,gmn,gdy,gyr1,gmn1,gdy1, slice1,slice2 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, dimension (:,:) :: & - net_data1 - integer (kind=2) , allocatable, target, dimension (:,:) :: LAI_HIGH - integer (kind=2), pointer, dimension (:,:) :: Raster - REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai - REAL, ALLOCATABLE, dimension (:) :: gswp2_lai_bf,gswp2_lai_af,gswp2_lai - integer, allocatable, target, dimension (:,:) :: tile_id - integer, pointer :: iRaster(:,:) - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf - logical :: first_entry = .true. - type (date_time_type) :: bf_gswp2_time,af_gswp2_time,date_time_new,bf_lai_time, & - af_lai_time +! status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) +! status = NF_CLOSE(ncid); VERIFY_(STATUS) ! -! Reading number of cathment-tiles from catchment.def file -!--------------------------------------------------------- - if (first_entry) then - nullify(iraster) ; first_entry = .false. - end if - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - - allocate(tile_id(1:nx,1:ny)) - allocate(net_data1 (1:nc_10,1:nr_10)) - - fname=trim(fnameRst)//'.rst' - ! - ! Reading tile-id raster file - ! - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - ! - ! writing GEOLAND2 LAI data - ! - - if(present(merge)) then - open (31,file='clsm/lai.'//lai_name(1:index(lai_name,'/')-1), & - form='unformatted',status='unknown',convert='little_endian') - else - open (31,file='clsm/lai.dat', & - form='unformatted',status='unknown',convert='little_endian') - endif - - allocate(vec_lai(maxcat)) - allocate(lai_high(1:i_highd,1:j_highd)) - allocate(count_lai(1:maxcat)) - allocate(gswp2_lai_bf (1:maxcat)) - allocate(gswp2_lai_af (1:maxcat)) - allocate(gswp2_lai (1:maxcat)) - - ! - ! reading GSWP2 LAI data - ! - - open (41,file='clsm/lai.gswp2', & - form='unformatted',status='old',convert='little_endian',action='read') - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) gswp2_lai_bf - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_gswp2_time) - - read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - read(41) gswp2_lai_af - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_gswp2_time) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - lai_high = -9999 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) - - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & - lai_high(i,j) = net_data1(i-iLL +1 ,j - jLL +1) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do - - ! Regridding - - nx_adj = nx - ny_adj = ny - - regrid = nx/=i_highd .or. ny/=j_highd - - if(regrid) then - if(nx > i_highd) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(lai_high,raster) - iRaster => tile_id - if(ny < j_highd) then - print *,'nx > i_highd and ny < j_highd' - stop - endif - else - if(.not. associated(iraster)) then - allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) - endif - -! if( associated(iraster)) deallocate(iraster) -! allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) - call RegridRaster(tile_id,iraster) - raster => lai_high - nx_adj = i_highd - ny_adj = j_highd - - if(ny > j_highd) then - print *,'nx < i_highd and ny > j_highd' - stop - endif - endif - else - raster => lai_high - iRaster => tile_id - end if - - ! Interpolation or aggregation on to catchment-tiles - - vec_lai =0. - count_lai = 0. - - do j=1,ny_adj - do i=1,nx_adj - if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then - if ((raster(i,j).ge.0)) then - vec_lai(iRaster(i,j)) = & - vec_lai(iRaster(i,j)) + sf*raster(i,j) - count_lai(iRaster(i,j)) = & - count_lai(iRaster(i,j)) + 1. - endif - endif - end do - end do - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - call Get_MidTime(real(yr),real(mn),real(dd),real(yr1),real(mn1),real(dd1),date_time_new) -! date_time_new%year = yr + 2001 -! date_time_new%month = mn -! date_time_new%day = dd -! date_time_new%hour = 0 -! date_time_new%min = 0 -! date_time_new%sec = 0 -! call get_dofyr_pentad(date_time_new) - - if (datetime_le_refdatetime(date_time_new,af_gswp2_time)) then - - else - read(41,IOSTAT=ierr) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 - if(ierr == 0) then - gswp2_lai_bf = gswp2_lai_af - read(41) gswp2_lai_af - bf_gswp2_time = af_gswp2_time - call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_gswp2_time) - else - print *,'END OF GSWP2 LAI FILE' - stop - endif - endif - - call Time_Interp_Fac (date_time_new, bf_gswp2_time, af_gswp2_time, slice1, slice2) - gswp2_lai = (slice1*gswp2_lai_bf + slice2*gswp2_lai_af) - -! print *, 'Merging GEOLAND2-AVHRR' -! print *, bf_gswp2_time -! print *, date_time_new -! print *, af_gswp2_time -! print *, slice1, slice2 -! print *, maxval(gswp2_lai), minval(gswp2_lai) - - DO n =1,maxcat - if(count_lai(n)/=0.) vec_lai(n)= vec_lai(n)/count_lai(n) - if(vec_lai(n)==0.) vec_lai(n) = gswp2_lai(n) - END DO - - write(31) vec_lai(:) - end do - close(31,status='keep') - close(41,status='keep') - - deallocate (net_data1) - deallocate (LAI_HIGH) - deallocate (count_lai) - deallocate (vec_lai, iRaster) - deallocate (gswp2_lai_bf,gswp2_lai_af,gswp2_lai, tile_id) - - END SUBROUTINE hres_lai +! mmdd(0) = mmdd(n_tslices) +! mmdd(n_tslices + 1)= mmdd(1) ! -! --------------------------------------------------------------------------------------- -! - SUBROUTINE grid2tile_modis6 (nc_data,nr_data,ncol,nrow,fnameRst,lai_name) +! mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) +! mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) ! -! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data ! - implicit none - integer, intent (in) :: nc_data,nr_data, ncol,nrow - real, parameter :: dxy = 1. - integer :: QSize - character(*) :: fnameRst,lai_name - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, target, dimension (:,:) :: net_data1 - integer, pointer, dimension (:,:) :: QSub - real, pointer, dimension (:,:) :: subset - REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai,tile_lon, tile_lat & - , x, y !, distance - real, allocatable, target, dimension (:,:) :: lai_grid - INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon - logical :: first_entry = .true. - type (date_time_type) :: date_time_new,bf_lai_time, & - af_lai_time - integer, dimension (:,:), allocatable, target :: tile_id - integer :: tileid_tile - real :: dxm, dym -! Reading rst file -!----------------- - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - allocate (tile_id (1:ncol,1:nrow)) - - do j=1,nrow - read(10)tile_id(:,j) - end do - close (10,status='keep') - - dxm = real(nc_data) /real(ncol) - dym = real(nr_data) /real(nrow) - - if ((mod( nc_data, ncol) /= 0).OR. (mod( nc_data, ncol) /= 0)) then - print *, 'For now, 86400 should be evenly divisible by NC Talk to Sarith' - stop - endif +! allocate(tile_id(1:nx,1:ny)) +! allocate(net_data1 (1:nc_10,1:nr_10)) ! -! Reading number of cathment-tiles from catchment.def file -!_________________________________________________________ +! fname=trim(fnameRst)//'.rst' +! ! +! ! Reading tile-id raster file +! ! +! open (10,file=fname,status='old',action='read', & +! form='unformatted',convert='little_endian') ! - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - allocate (tile_lon(1:maxcat)) - allocate (tile_lat(1:maxcat)) - - do n = 1, maxcat - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - end do - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v3/'//trim(lai_name)//'lai_clim.H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - if(nc_data/=i_highd .or. nr_data/=j_highd) then - print *,'Inconsistent mapping and dimensions in hres_lai_no_gswp -so stopping ...' - stop - end if - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - - allocate(net_data1 (1:nc_10,1:nr_10)) - - ! writing MODIS6 - ! - open (31,file='clsm/lai.dat', & - form='unformatted',status='unknown',convert='little_endian') - - allocate (vec_lai (maxcat)) - allocate (count_lai (1:maxcat)) - -! allocate (vec_fill (maxcat)) -! allocate (distance (maxcat)) -! allocate (vec_lai_save(maxcat)) -! vec_fill = 0 - - nx = nint (360./dxy) - ny = nint (180./dxy) - allocate (x(1:nx)) - allocate (y(1:ny)) - - FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy - FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy - - allocate (lai_grid (1 : nx, 1 : ny)) - - QSize = nint(dxy*nc_data/360.) -! allocate (QSub (1:QSize,1:QSize)) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - ! Reading Interpolation or aggregation on to catchment-tiles - - vec_lai = -9999. - count_lai = 0. - lai_grid = -9999 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v3/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) - - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then - tileid_tile = tile_id (ceiling(i/dxm), ceiling (j/dym)) - if((tileid_tile >= 1).and.(tileid_tile <= maxcat)) then - if(vec_lai(tileid_tile) == -9999.) vec_lai(tileid_tile) = 0. - vec_lai(tileid_tile) = vec_lai(tileid_tile) + & - sf*net_data1(i-iLL +1 ,j - jLL +1) - count_lai(tileid_tile) = & - count_lai(tileid_tile) + 1. - endif - endif - enddo - enddo - -! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, -! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. -!--------------------------------------------------------------------------------------------------------------------------------------- - do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize - do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize - QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) - if(maxval (QSub) > 0) lai_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do - - NULLIFY (QSub) - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - - where (count_lai > 0.) vec_lai = vec_lai/count_lai - -! Filling gaps -!------------- - DO n =1,maxcat - if(count_lai(n)==0.) then - - DO i = 1,nx - 1 - if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i - end do - DO i = 1,ny -1 - if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i - end do - - l = 1 - do - imx=ix + l - imn=ix - l - jmn=jx - l - jmx=jx + l - imn=MAX(imn,1) - jmn=MAX(jmn,1) - imx=MIN(imx,nx) - jmx=MIN(jmx,ny) - d1=imx-imn+1 - d2=jmx-jmn+1 - subset => lai_grid(imn: imx,jmn:jmx) - - if(maxval(subset) > 0.) then - vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) - exit - endif - l = l + 1 - NULLIFY (subset) - end do - endif - END DO - write(31) vec_lai(:) - end do - close(31,status='keep') - - deallocate (net_data1, tile_id) - deallocate (count_lai) - deallocate (vec_lai) - deallocate (tile_lat,tile_lon) - - END SUBROUTINE grid2tile_modis6 - +! do j=1,ny +! read(10)tile_id(:,j) +! end do ! -! --------------------------------------------------------------------------------------- -! - SUBROUTINE hres_lai_no_gswp (nc_data,nr_data,rmap,lai_name, merge) +! close (10,status='keep') ! -! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data +! ! +! ! writing GEOLAND2 LAI data +! ! ! - implicit none - integer, intent (in) :: nc_data,nr_data - real, parameter :: dxy = 1. - integer :: QSize - type (regrid_map), intent (in) :: rmap - character(*) :: lai_name - integer, intent(in), optional :: merge - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, target, dimension (:,:) :: net_data1 - integer, pointer, dimension (:,:) :: QSub - real, pointer, dimension (:,:) :: subset - REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai,tile_lon, tile_lat & - , x, y !, distance - real, allocatable, target, dimension (:,:) :: lai_grid - INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l,pix_count - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon - logical :: first_entry = .true. - type (date_time_type) :: date_time_new,bf_lai_time, & - af_lai_time - -! Reading rst file -!----------------- -! open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & -! form='unformatted',convert='little_endian') -! allocate (tile_id (1:nx,1:ny)) -! -! do j=1,ny -! read(10)tile_id(:,j) -! end do -! close (10,status='keep') +! if(present(merge)) then +! open (31,file='clsm/lai.'//lai_name(1:index(lai_name,'/')-1), & +! form='unformatted',status='unknown',convert='little_endian') +! else +! open (31,file='clsm/lai.dat', & +! form='unformatted',status='unknown',convert='little_endian') +! endif ! +! allocate(vec_lai(maxcat)) +! allocate(lai_high(1:i_highd,1:j_highd)) +! allocate(count_lai(1:maxcat)) +! allocate(gswp2_lai_bf (1:maxcat)) +! allocate(gswp2_lai_af (1:maxcat)) +! allocate(gswp2_lai (1:maxcat)) ! -! Reading number of cathment-tiles from catchment.def file -!_________________________________________________________ +! ! +! ! reading GSWP2 LAI data +! ! ! - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - allocate (tile_lon(1:maxcat)) - allocate (tile_lat(1:maxcat)) - - do n = 1, maxcat - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - end do - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - if(nc_data/=i_highd .or. nr_data/=j_highd) then - print *,'Inconsistent mapping and dimensions in hres_lai_no_gswp -so stopping ...' - stop - end if - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - - allocate(net_data1 (1:nc_10,1:nr_10)) - - ! - ! writing MODIS/GEOLAND2 LAI data - ! - - if(present(merge)) then - open (31,file='clsm/lai.'//lai_name(1:index(lai_name,'/')-1), & - form='unformatted',status='unknown',convert='little_endian') - else - open (31,file='clsm/lai.dat', & - form='unformatted',status='unknown',convert='little_endian') - endif - - allocate (vec_lai (maxcat)) - allocate (count_lai (1:maxcat)) - -! allocate (vec_fill (maxcat)) -! allocate (distance (maxcat)) -! allocate (vec_lai_save(maxcat)) -! vec_fill = 0 - - nx = nint (360./dxy) - ny = nint (180./dxy) - allocate (x(1:nx)) - allocate (y(1:ny)) - - FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy - FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy - - allocate (lai_grid (1 : nx, 1 : ny)) - - QSize = nint(dxy*nc_data/360.) -! allocate (QSub (1:QSize,1:QSize)) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - ! Reading Interpolation or aggregation on to catchment-tiles - - vec_lai = -9999. - count_lai = 0. - lai_grid = -9999 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) - - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then - pix_count = rmap%ij_index(i,j) - if (pix_count ==0) cycle - if(rmap%map(pix_count)%nt > 0) then - do n = 1, rmap%map(pix_count)%nt - if(vec_lai(rmap%map(pix_count)%tid(n)) == -9999.) vec_lai(rmap%map(pix_count)%tid(n)) = 0. - vec_lai(rmap%map(pix_count)%tid(n)) = vec_lai(rmap%map(pix_count)%tid(n)) + & - sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap%map(pix_count)%count(n) - count_lai(rmap%map(pix_count)%tid(n)) = & - count_lai(rmap%map(pix_count)%tid(n)) + 1.*rmap%map(pix_count)%count(n) - end do - endif - endif - enddo - enddo - -! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, -! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. -!--------------------------------------------------------------------------------------------------------------------------------------- - do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize - do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize - QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) - if(maxval (QSub) > 0) lai_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do - - NULLIFY (QSub) - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - - where (count_lai > 0.) vec_lai = vec_lai/count_lai - -! Filling gaps -!------------- - DO n =1,maxcat - if(count_lai(n)==0.) then - - DO i = 1,nx - 1 - if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i - end do - DO i = 1,ny -1 - if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i - end do - - l = 1 - do - imx=ix + l - imn=ix - l - jmn=jx - l - jmx=jx + l - imn=MAX(imn,1) - jmn=MAX(jmn,1) - imx=MIN(imx,nx) - jmx=MIN(jmx,ny) - d1=imx-imn+1 - d2=jmx-jmn+1 - subset => lai_grid(imn: imx,jmn:jmx) - - if(maxval(subset) > 0.) then - vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) - exit - endif - l = l + 1 - NULLIFY (subset) - end do - -! Another Method in which search for a neighboring value while looping through nc_data*nr_data +! open (41,file='clsm/lai.gswp2', & +! form='unformatted',status='old',convert='little_endian',action='read') +! read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 +! read(41) gswp2_lai_bf +! call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,bf_gswp2_time) +! +! read(41) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 +! read(41) gswp2_lai_af +! call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_gswp2_time) +! +! do t=0,n_tslices+1 +! +! time_slice = t +! yr = 1 +! yr1= 1 +! if(t == 0) then +! time_slice = n_tslices +! yr = 1 - 1 +! endif +! +! if(t >= n_tslices) then +! yr1 = 1 + 1 +! if(t ==n_tslices + 1) then +! time_slice = 1 +! yr = 1 + 1 +! endif +! endif +! +! read(mmdd(t),'(i2.2,i2.2)') mn,dd +! read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 +! +! lai_high = -9999 +! +! do jx = 1,18 +! do ix = 1,36 +! write (vv,'(i2.2)')jx +! write (hh,'(i2.2)')ix +! fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' +! status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) +! if(status == 0) then +! status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) +! status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) +! status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) +! status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) +! status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) +! +! do j = jLL,jLL + nr_10 -1 +! do i = iLL, iLL + nc_10 -1 +! if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & +! lai_high(i,j) = net_data1(i-iLL +1 ,j - jLL +1) +! enddo +! enddo +! status = NF_CLOSE(ncid) +! endif +! end do +! end do ! -! -! DO i = 1,nc_data - 1 -! if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i -! end do -! DO i = 1,nr_data -1 -! if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i -! end do -! -! l = 1 -! do -! imx=ix + l -! imn=ix - l -! jmn=jx - l -! jmx=jx + l -! imn=MAX(imn,1) -! jmn=MAX(jmn,1) -! imx=MIN(imx,nc_data) -! jmx=MIN(jmx,nr_data) -! d1=imx-imn+1 -! d2=jmx-jmn+1 -! ALLOCATE(subset(1:d1,1:d2)) -! subset = -9999 -! -! do j = 1,d2 -! do i = 1,d1 -! if (rmap(imn + i -1,jmn + j -1)%nt > 0) subset(i,j)=rmap(imn + i -1,jmn + j -1)%tid(1) -! end do -! end do -! -! mval = maxval(subset) -! deallocate (subset) +! ! Regridding ! -! if((mval > 0).and.(vec_lai_save(mval) > 0.)) then -! vec_lai (n) = vec_lai_save (mval) -! print *, count_lai(n),mval, vec_lai_save (mval) -! exit -! endif -! l = l + 1 -! end do -! -! The OLDEST METHOD - in which process tile space -! if((vec_fill(n) > 0).and.(vec_lai_save(vec_fill(n)) > 0.)) then -! vec_lai (n) = vec_lai_save (vec_fill(n)) -! else +! nx_adj = nx +! ny_adj = ny ! -! distance = 1000000. -! where ((abs(tile_lat - tile_lat(n)) < 20.).and. & -! (abs(tile_lon - tile_lon(n)) < 10.)) & -! distance = & -! (tile_lon - tile_lon(n)) * (tile_lon - tile_lon(n)) + & -! (tile_lat - tile_lat(n)) * (tile_lat - tile_lat(n)) -! distance (n) = 1000000. -! k = minloc(distance,dim=1) +! regrid = nx/=i_highd .or. ny/=j_highd ! -!! do i = 1,maxcat -!! if((i /= n).and.(abs(tile_lat(i) - tile_lat(n)) < 20.).and. & -!! (abs(tile_lon(i) - tile_lon(n)) < 10.)) then -!! if(vec_lai_save(i).gt.0.) then -!! tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & -!! (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) -!! if(tile_distance < dist_save) then -!! k = i -!! dist_save = tile_distance -!! endif -!! endif -!! endif -!! enddo +! if(regrid) then +! if(nx > i_highd) then +! allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) +! call RegridRaster2(lai_high,raster) +! iRaster => tile_id +! if(ny < j_highd) then +! print *,'nx > i_highd and ny < j_highd' +! stop +! endif +! else +! if(.not. associated(iraster)) then +! allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) +! endif ! -! vec_lai (n) = vec_lai_save (k) -! vec_fill(n) = k +! ! if( associated(iraster)) deallocate(iraster) +! ! allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) +! call RegridRaster(tile_id,iraster) +! raster => lai_high +! nx_adj = i_highd +! ny_adj = j_highd +! +! if(ny > j_highd) then +! print *,'nx < i_highd and ny > j_highd' +! stop +! endif +! endif +! else +! raster => lai_high +! iRaster => tile_id +! end if +! +! ! Interpolation or aggregation on to catchment-tiles +! +! vec_lai =0. +! count_lai = 0. +! +! do j=1,ny_adj +! do i=1,nx_adj +! if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then +! if ((raster(i,j).ge.0)) then +! vec_lai(iRaster(i,j)) = & +! vec_lai(iRaster(i,j)) + sf*raster(i,j) +! count_lai(iRaster(i,j)) = & +! count_lai(iRaster(i,j)) + 1. ! endif - endif - END DO - write(31) vec_lai(:) - end do - close(31,status='keep') - - deallocate (net_data1) - deallocate (count_lai) - deallocate (vec_lai) - deallocate (tile_lat,tile_lon) - - END SUBROUTINE hres_lai_no_gswp +! endif +! end do +! end do ! -! --------------------------------------------------------------------------------------- -! - SUBROUTINE hres_gswp2 (nc_data,nr_data,rmap,lai_name,merge) +! write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) +! call Get_MidTime(real(yr),real(mn),real(dd),real(yr1),real(mn1),real(dd1),date_time_new) +! ! date_time_new%year = yr + 2001 +! ! date_time_new%month = mn +! ! date_time_new%day = dd +! ! date_time_new%hour = 0 +! ! date_time_new%min = 0 +! ! date_time_new%sec = 0 +! ! call get_dofyr_pentad(date_time_new) ! -! Processing GSWP2 30sec LAI and grnFrac climatological data +! if ( .not. datetime_le_refdatetime(date_time_new,af_gswp2_time)) then +! read(41,IOSTAT=ierr) gyr,gmn,gdy,dum,dum,dum,gyr1,gmn1,gdy1 +! if(ierr == 0) then +! gswp2_lai_bf = gswp2_lai_af +! read(41) gswp2_lai_af +! bf_gswp2_time = af_gswp2_time +! call Get_MidTime(gyr,gmn,gdy,gyr1,gmn1,gdy1,af_gswp2_time) +! else +! print *,'END OF GSWP2 LAI FILE' +! stop +! endif +! endif ! - implicit none - integer, intent (in) :: nc_data, nr_data - character(*) :: lai_name - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2 - type (regrid_map), intent (in) :: rmap - real :: dum, gyr,gmn,gdy,gyr1,gmn1,gdy1, slice1,slice2 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, target, dimension (:,:) :: & - net_data1 - REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf,minlat,maxlat,minlon,maxlon - logical :: first_entry = .true. - type (date_time_type) :: date_time_new,bf_lai_time, & - af_lai_time - integer, intent(in), optional :: merge - real, parameter :: dxy = 1. - integer :: nx, ny, QSize, pix_count - REAL, ALLOCATABLE, dimension (:) :: x,y,tile_lon, tile_lat - real, allocatable, target, dimension (:,:) :: data_grid - integer, pointer, dimension (:,:) :: QSub - INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l,tindex1,pfaf1 - real, pointer, dimension (:,:) :: subset - - if(trim(lai_name) == 'lai' ) vid = 4 - if(trim(lai_name) == 'green') vid = 5 - - - ! For Gap filling - ! --------------- - - nx = nint (360./dxy) - ny = nint (180./dxy) - allocate (x(1:nx)) - allocate (y(1:ny)) - - FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy - FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy - - allocate (data_grid (1 : nx, 1 : ny)) - - QSize = nint(dxy*nc_data/360.) - -! Reading number of cathment-tiles from catchment.def file -! -------------------------------------------------------- - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - allocate (tile_lon(1:maxcat)) - allocate (tile_lat(1:maxcat)) - - do n = 1, maxcat - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - end do - - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v1/GSWP2_VegParam_H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - allocate(net_data1 (1:nc_10,1:nr_10)) - - ! writing GSWP2 data - ! ------------------ - - if(present(merge)) then - open (31,file='clsm/lai.gswp2', & - form='unformatted',status='unknown',convert='little_endian') - else - open (31,file='clsm/'//trim(lai_name)//'.dat', & - form='unformatted',status='unknown',convert='little_endian') - endif - - allocate(vec_lai (1:maxcat)) - allocate(count_lai (1:maxcat)) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - vec_lai = -9999. - count_lai = 0. - data_grid = -9999 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v1/GSWP2_VegParam_H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,vid,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,vid,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, vid,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) - - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then - pix_count = rmap%ij_index(i,j) - if (pix_count == 0) cycle - if(rmap%map(pix_count)%nt > 0) then - do n = 1, rmap%map(pix_count)%nt - if(vec_lai(rmap%map(pix_count)%tid(n)) == -9999.) vec_lai(rmap%map(pix_count)%tid(n)) = 0. - vec_lai(rmap%map(pix_count)%tid(n)) = vec_lai(rmap%map(pix_count)%tid(n)) + & - sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap%map(pix_count)%count(n) - count_lai(rmap%map(pix_count)%tid(n)) = & - count_lai(rmap%map(pix_count)%tid(n)) + 1.*rmap%map(pix_count)%count(n) - end do - endif - endif - enddo - enddo - - ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, - ! creating a 1.-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. - !--------------------------------------------------------------------------------------------------------------------------------------- - - do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize - do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize - QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) - if(maxval (QSub) > 0) data_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) - enddo - enddo - - status = NF_CLOSE(ncid) - endif - end do - end do - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - where (count_lai > 0.) vec_lai = vec_lai/count_lai - - ! Filling gaps - !------------- - DO n =1,maxcat - if(count_lai(n)==0.) then - - DO i = 1,nx - 1 - if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i - end do - DO i = 1,ny -1 - if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i - end do - - l = 1 - do - imx=ix + l - imn=ix - l - jmn=jx - l - jmx=jx + l - imn=MAX(imn,1) - jmn=MAX(jmn,1) - imx=MIN(imx,nx) - jmx=MIN(jmx,ny) - d1=imx-imn+1 - d2=jmx-jmn+1 - subset => data_grid(imn: imx,jmn:jmx) - - if(maxval(subset) > 0.) then - vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) - exit - endif - l = l + 1 - NULLIFY (subset) - end do - endif - end do - write(31) vec_lai(:) - end do - - close(31,status='keep') - - deallocate (net_data1) - deallocate (count_lai) - deallocate (vec_lai) - - END SUBROUTINE hres_gswp2 - - !---------------------------------------------------------------------- - - SUBROUTINE MODIS_snow_alb_v2( nc_data, nr_data, rmap ) - - ! Map static, MODIS climatology-based snow albedo from preprocessed 30-arcsec grid - ! to *land* tiles and write into clsm/catch_params.nc4. +! call Time_Interp_Fac (date_time_new, bf_gswp2_time, af_gswp2_time, slice1, slice2) +! gswp2_lai = (slice1*gswp2_lai_bf + slice2*gswp2_lai_af) +! +! ! print *, 'Merging GEOLAND2-AVHRR' +! ! print *, bf_gswp2_time +! ! print *, date_time_new +! ! print *, af_gswp2_time +! ! print *, slice1, slice2 +! ! print *, maxval(gswp2_lai), minval(gswp2_lai) +! +! DO n =1,maxcat +! if(count_lai(n)/=0.) vec_lai(n)= vec_lai(n)/count_lai(n) +! if(vec_lai(n)==0.) vec_lai(n) = gswp2_lai(n) +! END DO +! +! write(31) vec_lai(:) +! +! end do ! t=0,n_tslices+1 +! +! close(31,status='keep') +! close(41,status='keep') +! +! deallocate (net_data1) +! deallocate (LAI_HIGH) +! deallocate (count_lai) +! deallocate (vec_lai, iRaster) +! deallocate (gswp2_lai_bf,gswp2_lai_af,gswp2_lai, tile_id) +! +! END SUBROUTINE hres_lai + ! + ! --------------------------------------------------------------------------------------- + ! + SUBROUTINE grid2tile_modis6 (nc_data,nr_data,ncol,nrow, n_land, tile_lon, tile_lat, tile_id,lai_name) ! - ! Assumes that input snow albedo is backfilled (i.e., does not contain no-data values). + ! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data ! - ! Snow albedo assigned to each tile is averaged over 30-arcsec MODIS grid cells associated - ! with the tile per the 30-arcsec raster file associated with the tile space. - ! Unlike in subroutine MODIS_snow_alb_v2, the tile-average snow albedo computed here - ! does not include snow albedo values from neighboring land tiles or water/landice tiles. + implicit none + integer, intent(in) :: nc_data,nr_data, ncol,nrow, n_land + real, intent(in) :: tile_lon(:), tile_lat(:) + integer, target, intent(in) :: tile_id(:,:) + character(*), intent(in) :: lai_name + + real, parameter :: dxy = 1. + integer :: QSize + integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & + time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH + integer, allocatable, target, dimension (:,:) :: net_data1 + integer, pointer, dimension (:,:) :: QSub + real, pointer, dimension (:,:) :: subset + REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai, x, y !, distance + real, allocatable, target, dimension (:,:) :: lai_grid + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l + character(len=4), dimension (:), allocatable :: MMDD, MMDD_next + logical :: regrid + REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon + logical :: first_entry = .true. + type (date_time_type) :: date_time_new,bf_lai_time, & + af_lai_time + integer :: tileid_tile + real :: dxm, dym + + dxm = real(nc_data) /real(ncol) + dym = real(nr_data) /real(nrow) + + if ((mod( nc_data, ncol) /= 0).OR. (mod( nc_data, ncol) /= 0)) then + print *, 'For now, 86400 should be evenly divisible by NC Talk to Sarith' + stop + endif ! - ! rmap is the precomputed mapping from a 30-arcsec raster file to the tile space. - ! The raster file used to compute rmap must be on the same 30-arcsec grid as the - ! MODIS input data. + !_________________________________________________________ ! - ! Biljana Orescanin June 2023, SSAI@NASA - - implicit none - - integer(kind=4), parameter :: nc_10=1200 ! # columns in 10deg-by-10deg MODIS input file - integer(kind=4), parameter :: nr_10=1200 ! # rows in 10deg-by-10deg MODIS input file - - type (regrid_map), intent (in) :: rmap - integer, intent (in) :: nc_data,nr_data - - integer :: nn, N_tile, ii, jj, ncid, iG, jG - integer :: status, iLL, jLL, ix, jx - integer :: pix_count - - character*200 :: fname - character*2 :: VV, HH - logical :: file_exists - - character*128 :: Iam = "MODIS_snow_alb_v2" - - real, allocatable, dimension (:) :: snw_alb, count_snow_alb - real, allocatable, target, dimension (:,:) :: stch_snw_alb - - ! ---------------------------------------------------------------------------- + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v3/'//trim(lai_name)//'lai_clim.H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + if(nc_data/=i_highd .or. nr_data/=j_highd) then + print *,'Inconsistent mapping and dimensions in hres_lai_no_gswp -so stopping ...' + stop + end if + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + + allocate(net_data1 (1:nc_10,1:nr_10)) + + ! writing MODIS6 + ! + open (31,file='clsm/lai.dat', & + form='unformatted',status='unknown',convert='little_endian') + + allocate (vec_lai (n_land)) + allocate (count_lai (1:n_land)) + + ! allocate (vec_fill (n_land)) + ! allocate (distance (n_land)) + ! allocate (vec_lai_save(n_land)) + ! vec_fill = 0 + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (lai_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*nc_data/360.) + ! allocate (QSub (1:QSize,1:QSize)) + + do t=0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + ! Reading Interpolation or aggregation on to catchment-tiles + + vec_lai = -9999. + count_lai = 0. + lai_grid = -9999 + + do jx = 1,18 + do ix = 1,36 + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v3/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) + + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then + tileid_tile = tile_id (ceiling(i/dxm), ceiling (j/dym)) + if((tileid_tile >= 1).and.(tileid_tile <= n_land)) then + if(vec_lai(tileid_tile) == -9999.) vec_lai(tileid_tile) = 0. + vec_lai(tileid_tile) = vec_lai(tileid_tile) + & + sf*net_data1(i-iLL +1 ,j - jLL +1) + count_lai(tileid_tile) = & + count_lai(tileid_tile) + 1. + endif + endif + enddo + enddo + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize + do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize + QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(maxval (QSub) > 0) lai_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) + enddo + enddo + status = NF_CLOSE(ncid) + endif + end do + end do + + NULLIFY (QSub) + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,n_land,1/)) + + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! Filling gaps + !------------- + DO n =1,n_land + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => lai_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + endif + END DO + write(31) vec_lai(:) + + end do ! t=0,n_tslices+1 + + close(31,status='keep') + + deallocate (net_data1) + deallocate (count_lai) + deallocate (vec_lai) + deallocate (lai_grid) + + END SUBROUTINE grid2tile_modis6 + + ! + ! --------------------------------------------------------------------------------------- + ! + SUBROUTINE hres_lai_no_gswp (nc_data,nr_data,rmap,lai_name, n_land, tile_lon, tile_lat, merge) + ! + ! Processing GEOLAND2/MODIS LAI and creating 10-day climatological data + ! + implicit none + integer, intent(in) :: nc_data,nr_data + type (regrid_map), intent(in) :: rmap + character(*), intent(in) :: lai_name + integer, intent(in) :: n_land + real, intent(in) :: tile_lon(:), tile_lat(:) + integer, intent(in), optional :: merge + + real, parameter :: dxy = 1. + integer :: QSize + integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & + time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH + integer, allocatable, target, dimension (:,:) :: net_data1 + integer, pointer, dimension (:,:) :: QSub + real, pointer, dimension (:,:) :: subset + REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai, x, y !, distance + real, allocatable, target, dimension (:,:) :: lai_grid + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l,pix_count + character(len=4), dimension (:), allocatable :: MMDD, MMDD_next + logical :: regrid + REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon + logical :: first_entry = .true. + type (date_time_type) :: date_time_new,bf_lai_time, & + af_lai_time + + !_________________________________________________________ + ! + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + if(nc_data/=i_highd .or. nr_data/=j_highd) then + print *,'Inconsistent mapping and dimensions in hres_lai_no_gswp -so stopping ...' + stop + end if + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + + allocate(net_data1 (1:nc_10,1:nr_10)) + + ! + ! writing MODIS/GEOLAND2 LAI data + ! + + if(present(merge)) then + open (31,file='clsm/lai.'//lai_name(1:index(lai_name,'/')-1), & + form='unformatted',status='unknown',convert='little_endian') + else + open (31,file='clsm/lai.dat', & + form='unformatted',status='unknown',convert='little_endian') + endif + + allocate (vec_lai (n_land)) + allocate (count_lai (1:n_land)) + + ! allocate (vec_fill (n_land)) + ! allocate (distance (n_land)) + ! allocate (vec_lai_save(n_land)) + ! vec_fill = 0 + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (lai_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*nc_data/360.) + ! allocate (QSub (1:QSize,1:QSize)) + + do t =0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + ! Reading Interpolation or aggregation on to catchment-tiles + + vec_lai = -9999. + count_lai = 0. + lai_grid = -9999 + + do jx = 1,18 + do ix = 1,36 + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/'//trim(lai_name)//'lai_clim.H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 4,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) + + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then + pix_count = rmap%ij_index(i,j) + if (pix_count ==0) cycle + if(rmap%map(pix_count)%nt > 0) then + do n = 1, rmap%map(pix_count)%nt + if(vec_lai(rmap%map(pix_count)%tid(n)) == -9999.) vec_lai(rmap%map(pix_count)%tid(n)) = 0. + vec_lai(rmap%map(pix_count)%tid(n)) = vec_lai(rmap%map(pix_count)%tid(n)) + & + sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap%map(pix_count)%count(n) + count_lai(rmap%map(pix_count)%tid(n)) = & + count_lai(rmap%map(pix_count)%tid(n)) + 1.*rmap%map(pix_count)%count(n) + end do + endif + endif + enddo + enddo + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize + do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize + QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(maxval (QSub) > 0) lai_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) + enddo + enddo + status = NF_CLOSE(ncid) + endif + end do + end do + + NULLIFY (QSub) + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,n_land,1/)) + + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! Filling gaps + !------------- + DO n =1,n_land + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => lai_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + + ! Another Method in which search for a neighboring value while looping through nc_data*nr_data + ! + ! + ! DO i = 1,nc_data - 1 + ! if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + ! end do + ! DO i = 1,nr_data -1 + ! if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + ! end do + ! + ! l = 1 + ! do + ! imx=ix + l + ! imn=ix - l + ! jmn=jx - l + ! jmx=jx + l + ! imn=MAX(imn,1) + ! jmn=MAX(jmn,1) + ! imx=MIN(imx,nc_data) + ! jmx=MIN(jmx,nr_data) + ! d1=imx-imn+1 + ! d2=jmx-jmn+1 + ! ALLOCATE(subset(1:d1,1:d2)) + ! subset = -9999 + ! + ! do j = 1,d2 + ! do i = 1,d1 + ! if (rmap(imn + i -1,jmn + j -1)%nt > 0) subset(i,j)=rmap(imn + i -1,jmn + j -1)%tid(1) + ! end do + ! end do + ! + ! mval = maxval(subset) + ! deallocate (subset) + ! + ! if((mval > 0).and.(vec_lai_save(mval) > 0.)) then + ! vec_lai (n) = vec_lai_save (mval) + ! print *, count_lai(n),mval, vec_lai_save (mval) + ! exit + ! endif + ! l = l + 1 + ! end do + ! + ! The OLDEST METHOD - in which process tile space + ! if((vec_fill(n) > 0).and.(vec_lai_save(vec_fill(n)) > 0.)) then + ! vec_lai (n) = vec_lai_save (vec_fill(n)) + ! else + ! + ! distance = 1000000. + ! where ((abs(tile_lat - tile_lat(n)) < 20.).and. & + ! (abs(tile_lon - tile_lon(n)) < 10.)) & + ! distance = & + ! (tile_lon - tile_lon(n)) * (tile_lon - tile_lon(n)) + & + ! (tile_lat - tile_lat(n)) * (tile_lat - tile_lat(n)) + ! distance (n) = 1000000. + ! k = minloc(distance,dim=1) + ! + !! do i = 1,n_land + !! if((i /= n).and.(abs(tile_lat(i) - tile_lat(n)) < 20.).and. & + !! (abs(tile_lon(i) - tile_lon(n)) < 10.)) then + !! if(vec_lai_save(i).gt.0.) then + !! tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & + !! (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) + !! if(tile_distance < dist_save) then + !! k = i + !! dist_save = tile_distance + !! endif + !! endif + !! endif + !! enddo + ! + ! vec_lai (n) = vec_lai_save (k) + ! vec_fill(n) = k + ! endif + endif + END DO + write(31) vec_lai(:) + end do + close(31,status='keep') + + deallocate (net_data1) + deallocate (count_lai) + deallocate (vec_lai) + deallocate (lai_grid) + + END SUBROUTINE hres_lai_no_gswp + ! + ! --------------------------------------------------------------------------------------- + ! + SUBROUTINE hres_gswp2 (nc_data,nr_data,rmap,lai_name, n_land, tile_lon, tile_lat, merge) + ! + ! Processing GSWP2 30sec LAI and grnFrac climatological data + ! + implicit none + integer, intent (in) :: nc_data, nr_data + type (regrid_map), intent (in) :: rmap + character(*), intent (in) :: lai_name + integer, intent (in) :: n_land + real, intent (in) :: tile_lon(:), tile_lat(:) + integer, optional, intent (in) :: merge + + integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & + time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2 + real :: dum, gyr,gmn,gdy,gyr1,gmn1,gdy1, slice1,slice2 + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH + integer, allocatable, target, dimension (:,:) :: & + net_data1 + REAL, ALLOCATABLE, dimension (:) :: vec_lai, count_lai + character(len=4), dimension (:), allocatable :: MMDD, MMDD_next + logical :: regrid + REAL :: sf,minlat,maxlat,minlon,maxlon + logical :: first_entry = .true. + type (date_time_type) :: date_time_new,bf_lai_time, & + af_lai_time + real, parameter :: dxy = 1. + integer :: nx, ny, QSize, pix_count + REAL, ALLOCATABLE, dimension (:) :: x,y + real, allocatable, target, dimension (:,:) :: data_grid + integer, pointer, dimension (:,:) :: QSub + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l,tindex1,pfaf1 + real, pointer, dimension (:,:) :: subset + + if(trim(lai_name) == 'lai' ) vid = 4 + if(trim(lai_name) == 'green') vid = 5 + + + ! For Gap filling + ! --------------- + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (data_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*nc_data/360.) + + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v1/GSWP2_VegParam_H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + allocate(net_data1 (1:nc_10,1:nr_10)) + + ! writing GSWP2 data + ! ------------------ + + if(present(merge)) then + open (31,file='clsm/lai.gswp2', & + form='unformatted',status='unknown',convert='little_endian') + else + open (31,file='clsm/'//trim(lai_name)//'.dat', & + form='unformatted',status='unknown',convert='little_endian') + endif + + allocate(vec_lai (1:n_land)) + allocate(count_lai (1:n_land)) + + do t =0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + vec_lai = -9999. + count_lai = 0. + data_grid = -9999 + + do jx = 1,18 + do ix = 1,36 + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v1/GSWP2_VegParam_H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,vid,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid,vid,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, vid,(/1,1,time_slice/),(/nc_10,nr_10,1/),net_data1); VERIFY_(STATUS) + + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) then + pix_count = rmap%ij_index(i,j) + if (pix_count == 0) cycle + if(rmap%map(pix_count)%nt > 0) then + do n = 1, rmap%map(pix_count)%nt + if(vec_lai(rmap%map(pix_count)%tid(n)) == -9999.) vec_lai(rmap%map(pix_count)%tid(n)) = 0. + vec_lai(rmap%map(pix_count)%tid(n)) = vec_lai(rmap%map(pix_count)%tid(n)) + & + sf*net_data1(i-iLL +1 ,j - jLL +1)*rmap%map(pix_count)%count(n) + count_lai(rmap%map(pix_count)%tid(n)) = & + count_lai(rmap%map(pix_count)%tid(n)) + 1.*rmap%map(pix_count)%count(n) + end do + endif + endif + enddo + enddo + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 1.-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + + do j = ceiling(1.*jLL/QSize),ceiling(1.*jLL/QSize) -1 + nr_10/QSize + do i = ceiling(1.*iLL/QSize),ceiling(1.*iLL/QSize) -1 + nc_10/QSize + QSub => net_data1((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(maxval (QSub) > 0) data_grid(i,j) = sf*sum(QSub, QSub>0)/(max(1,count(QSub>0))) + enddo + enddo + + status = NF_CLOSE(ncid) + endif + end do + end do + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,n_land,1/)) + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! Filling gaps + !------------- + DO n =1,n_land + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => data_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + endif + end do + write(31) vec_lai(:) + end do + + close(31,status='keep') + + deallocate (net_data1) + deallocate (count_lai) + deallocate (vec_lai) + deallocate (data_grid) + + END SUBROUTINE hres_gswp2 + + !---------------------------------------------------------------------- + + SUBROUTINE MODIS_snow_alb_v2( nc_data, nr_data, rmap, n_tile ) + + ! Map static, MODIS climatology-based snow albedo from preprocessed 30-arcsec grid + ! to *land* tiles and write into clsm/catch_params.nc4. + ! + ! Assumes that input snow albedo is backfilled (i.e., does not contain no-data values). + ! + ! Snow albedo assigned to each tile is averaged over 30-arcsec MODIS grid cells associated + ! with the tile per the 30-arcsec raster file associated with the tile space. + ! Unlike in subroutine MODIS_snow_alb_v2, the tile-average snow albedo computed here + ! does not include snow albedo values from neighboring land tiles or water/landice tiles. + ! + ! rmap is the precomputed mapping from a 30-arcsec raster file to the tile space. + ! The raster file used to compute rmap must be on the same 30-arcsec grid as the + ! MODIS input data. + ! + ! Biljana Orescanin June 2023, SSAI@NASA + + implicit none + + integer(kind=4), parameter :: nc_10=1200 ! # columns in 10deg-by-10deg MODIS input file + integer(kind=4), parameter :: nr_10=1200 ! # rows in 10deg-by-10deg MODIS input file + + integer, intent (in) :: nc_data,nr_data + type (regrid_map), intent (in) :: rmap + integer, intent (in) :: n_tile + + integer :: nn, ii, jj, ncid, iG, jG + integer :: status, iLL, jLL, ix, jx + integer :: pix_count + + character*200 :: fname + character*2 :: VV, HH + logical :: file_exists + + character*128 :: Iam = "MODIS_snow_alb_v2" + + real, allocatable, dimension (:) :: snw_alb, count_snow_alb + real, allocatable, target, dimension (:,:) :: stch_snw_alb + + ! ---------------------------------------------------------------------------- call get_environment_variable( "MAKE_BCS_INPUT_DIR", MAKE_BCS_INPUT_DIR ) - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - ! - ! TO DO + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! + ! TO DO + ! + ! ASSERT THAT rmap IS CONSISTENT WITH 30-arcsec GRID OF MODIS INPUTS + ! + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + allocate(stch_snw_alb (1:nc_10,1:nr_10)) ! 10deg-by-10deg snow albedo data + allocate(snw_alb (1:N_tile)) ! snow albedo in tile space + allocate(count_snow_alb (1:N_tile)) ! count of MODIS grid cells contributing to tile-average snow albedo + + snw_alb = -9999. ! set all to missing + count_snow_alb = 0. ! initialize counter (SHOULD THIS BE KIND REAL???) + + ! loop through the 36x18 10deg-by-10deg MODIS files + + do jx = 1,18 + do ix = 1,36 + + ! assemble file name and open file + + write (hh,'(i2.2)') ix + write (vv,'(i2.2)') jx + + fname = trim(MAKE_BCS_INPUT_DIR) // '/land/albedo/snow/MODIS/v2/snow_alb_FillVal_MOD10A1.061_30arcsec_H'//hh//'V'//vv//'.nc' + + status = NF_OPEN (trim(fname),NF_NOWRITE, ncid) ! open file to read + + if(status == 0) then ! if file exists, read snow albedo + + status = NF_GET_VARA_REAL( ncid, NC_VarID(NCID,'Snow_Albedo'), (/1,1/), (/nc_10,nr_10/), stch_snw_alb); VERIFY_(STATUS) + + ! verify that input snow albedo has been back-filled *everywhere*, incl. water and landice + ! (i.e., stch_snw_alb must not contain no-data or unphysical values) + + if ( any(stch_snw_alb<0.) .or. any(stch_snw_alb>1.) ) then + + print *, 'ERROR: subroutine ', trim(Iam), '() : detected no-data or unphysical values in MODIS file ', trim(fname) + print *, 'STOPPING.' + stop + + end if + + ! calculate Lower Left (LL) indices for the chunk of the global 30-arcsec grid that is stored in file (ix,jx) + ! + ! NOTE: In similar subroutines for processing other data, iLL and jLL are stored in the nc4 file. + + iLL=(ix-1)*nc_10+1 + jLL=(jx-1)*nr_10+1 + + ! loop through 30-arcsec grid cells in current 10deg-by-10deg chunk + + do jj=1,nr_10 + do ii=1,nc_10 + + iG = ii+iLL-1 ! i-index relative to *global* 30-arcsec grid + jG = jj+jLL-1 ! j-index relative to *global* 30-arcsec grid + + pix_count = rmap%ij_index(iG,jG) ! pix_count == ID/index of tile to which current 30-arcsec grid cell belongs [???] + + if (pix_count == 0) cycle ! if this MODIS grid cell has no corresponding remapped value, skip it + + if (rmap%map(pix_count)%nt > 0) then ! if the # of tiles corresponding to this gridbox is gt 0, proceed with calculations + + do nn = 1,rmap%map(pix_count)%nt ! loop through all corresponding tiles [???] + + ! if first pass, set albedo to zero + ! [????] CAN THIS BE SKIPPED IF snw_alb IS INITIALIZED TO ZERO ABOVE? + ! BECAUSE MODIS DATA ARE BACKFILLED, THERE SHOULD NOT BE NO-DATA-VALUES FOR ANY TILE + if (snw_alb(rmap%map(pix_count)%tid(nn)) == -9999.) snw_alb(rmap%map(pix_count)%tid(nn)) = 0. + + ! accumulate values and counts + snw_alb(rmap%map(pix_count)%tid(nn)) = & + snw_alb(rmap%map(pix_count)%tid(nn)) + stch_snw_alb(ii,jj)*rmap%map(pix_count)%count(nn) + + ! [???] rmap%map(pix_count)%count(nn) IS INTEGER; MAKE count_snow_alb INTEGER AFTER FIRST ASSERTING 0-DIFF FOR CURRENT CLEANUP + count_snow_alb(rmap%map(pix_count)%tid(nn)) = & + count_snow_alb(rmap%map(pix_count)%tid(nn)) + 1.*rmap%map(pix_count)%count(nn) + + end do + + endif ! if not missing + enddo ! ii-loop + enddo ! jj-loop + + ! Close the file, freeing all resources. + status=NF_CLOSE(ncid); VERIFY_(STATUS) + + endif + end do ! jx-loop through 10deg-by-10deg files + end do ! ix-loop through 10deg-by-10deg files + + ! finalize calculation of mean values + ! [???] NOTE: count_snw_alb SHOULD BE INTEGER --> CONVERT TO REAL + + ! because MODIS data are backfilled, should have count_snow_alb>0 + + if ( any(count_snow_alb<=0.) ) then + + print *, 'ERROR: subroutine ', trim(Iam), '() : something wrong with count_snow_alb(:)' + print *, 'STOPPING.' + stop + + end if + + snw_alb = snw_alb/count_snow_alb ! finalize calculation of tile-average snow albedo + + ! write snow albedo into clsm/catch_params.nc4 + + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'SNOWALB'),(/1/),(/N_tile/),real(snw_alb)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + endif + + deallocate(stch_snw_alb) + deallocate(count_snow_alb) + deallocate(snw_alb) + + END SUBROUTINE MODIS_snow_alb_v2 + + !---------------------------------------------------------------------- + + SUBROUTINE MODIS_snow_alb(n_tile, min_lon, max_lon, min_lat, max_lat) + + ! Map static, MODIS climatology-based snow albedo from preprocessed 30-arcsec grid + ! to land tiles and write into clsm/catch_params.nc4. + ! + ! Assumes that input snow albedo is backfilled (i.e., does not contain no-data values). + ! + ! Snow albedo assigned to each tile is average over 30-arcsec MODIS grid cells located + ! within the rectangle defined by the min/max lat/lon of tile; this can include MODIS grid + ! cells located in neighboring land tiles and/or water/landice tiles. + ! See subroutine MODIS_snow_alb_v2() for a refined algorithm. + ! + ! Biljana Orescanin July 2022, SSAI@NASA + + implicit none + integer, intent(in) :: n_tile + real, intent(in) :: min_lon(:),max_lon(:),min_lat(:),max_lat(:) + + real, allocatable :: snw_alb(:) + + character*200 :: fname + character*2 :: vv,hh + integer :: n,ncid,status + integer(kind=4),parameter :: xdim = 1200, ydim = 1200 + real,dimension(xdim,ydim) :: stch_snw_alb_tmp + real,dimension(36,18,xdim,ydim) :: stch_snw_alb + real :: sno_alb_cnt,sno_alb_sum + integer :: vvtil_min,hhtil_min,vvtil_max,hhtil_max,hhtil,vvtil + integer(kind=4) :: imin,imax,jmin,jmax,varid1 + logical :: file_exists + + ! the stitched MODIS albedo file + allocate (snw_alb(1:N_tile)) + + ! Start by setting all snow albedo values to missing + snw_alb(:)=MAPL_UNDEF + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + + ! ----------- Get the information on snow albedo ----- + ! ----------- The information on snow albedo is stored in 10x10deg 30-arcsec resolution files. + ! ----------- Read in this information, then loop over the tiles to find a corresponding snow albedo. + + ! Read in all 10x10deg snow albedo files into a single [36,18,1200,1200] array + do hhtil=1,36 ! loop over input files - horizontal direction + do vvtil=1,18 ! loop over input files - vertical direction + + write(vv,'(i2.2)') vvtil + write(hh,'(i2.2)') hhtil + + ! MODIS-based climatology albedo raster files, backfilled with global land + ! average snow albedo (=0.56; average excludes Antarctica and Greenland ice + ! sheets and is weighted by the grid-cell area). + + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/albedo/snow/MODIS/v2/snow_alb_FillVal_MOD10A1.061_30arcsec_H'//hh//'V'//vv//'.nc' + + ! Open the file. (NF90_NOWRITE ensures read-only access to the file) + status=NF_OPEN(trim(fname),NF_NOWRITE, ncid) ; VERIFY_(STATUS) + ! Based on vars name, get the varids. + status=NF_INQ_VARID(ncid,'Snow_Albedo',VarID1) ; VERIFY_(STATUS) + ! Read the data. + status=NF_GET_VARA_REAL(ncid,VarID1,(/1,1/),(/xdim,ydim/),stch_snw_alb_tmp) ; VERIFY_(STATUS) + ! Close the file, freeing all resources. + status=NF_CLOSE(ncid); VERIFY_(STATUS) + + ! Store snow albedo values into a single 4D aray + stch_snw_alb(hhtil,vvtil,:,:)=stch_snw_alb_tmp + + enddo + enddo + + if (minval(stch_snw_alb) .le. 0.0 .or. maxval(stch_snw_alb) .gt. 1.0) then + print*, 'There is a problem with snow albedo raster file. Non-physical values present. STOP!' + stop + endif + + ! loop over tiles + print*, 'Starting tile loop for snow albedo.' + + do n = 1, N_tile ! loop over tiles + + ! Set sums and counts to zero + sno_alb_sum=0. + sno_alb_cnt=0. + + ! Use tile's min/max lat/lon info to identify the 10x10deg input file(s) + ! indexes + vvtil_min=floor((min_lat(n)+ 90.0)/10.)+1 + hhtil_min=floor((min_lon(n)+180.0)/10.)+1 + + ! if tile crosses the edge of the snow albedo 10x10deg box, expand the + ! search area into the neighbouring 10x10deg box + hhtil_max=hhtil_min + vvtil_max=vvtil_min + if (floor(min_lon(n)/10) .ne. floor(max_lon(n)/10)) hhtil_max=hhtil_min+1 + if (floor(min_lat(n)/10) .ne. floor(max_lat(n)/10)) vvtil_max=vvtil_min+1 + + ! Safety check; keep within the range + vvtil_min=max(vvtil_min,1) + vvtil_max=min(vvtil_max,18) + hhtil_min=max(hhtil_min,1) + hhtil_max=min(hhtil_max,36) + + do hhtil=hhtil_min,hhtil_max ! loop through input files - horizontal direction + do vvtil=vvtil_min,vvtil_max ! loop through input files - vertical direction + + ! Find indices ranges corresponding to the current tile area. + imin=floor((min_lon(n)+180.0 - (hhtil-1)*10.0) * (xdim/10.0)) +1 + imax=floor((max_lon(n)+180.0 - (hhtil-1)*10.0) * (xdim/10.0)) +1 + jmin=floor((min_lat(n)+ 90.0 - (vvtil-1)*10.0) * (ydim/10.0)) +1 + jmax=floor((max_lat(n)+ 90.0 - (vvtil-1)*10.0) * (ydim/10.0)) +1 + + ! if no matching grids, go to the next vv/hh box + if (imin .gt. xdim .or. jmin .gt. ydim .or. imax .lt. 1 .or. jmax .lt. 1) cycle + + ! Keep within the range, to include only the portion of the tile within this vv/hh box + imin=max(imin,1) + imax=min(imax,xdim) + jmin=max(jmin,1) + jmax=min(jmax,ydim) + + ! Generate sums and counts using current tile corresponding indices + sno_alb_sum = sno_alb_sum + sum(stch_snw_alb(hhtil,vvtil,imin:imax,jmin:jmax)) + sno_alb_cnt = sno_alb_cnt + (imax-imin+1)*(jmax-jmin+1) + + end do ! vvtil + end do ! hhtil + + ! If matching grids found, calculate snow albedo for the current tile; + ! ensure that resulting value is within physical range [0,1]. + if (sno_alb_cnt .ne. 0) snw_alb(n)=min(1.0,max(0.0,sno_alb_sum/sno_alb_cnt)) + + end do ! n-loop over tiles + + ! write snow albedo into clsm/catch_params.nc4 + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'SNOWALB'),(/1/),(/N_tile/),real(snw_alb)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + endif + + print*, 'Ended tile loop for snow albedo. ' + + END SUBROUTINE MODIS_snow_alb + + !-------------------------------------------------------------------------------------- + + SUBROUTINE soil_para_hwsd (nx,ny, n_land, tile_pfs, tile_id) + + ! Processing NGDC-HWSD-STATSGO merged soil properties with Woesten Soil + ! Parameters and produces tau_param.dat and soil_param.dat files + + implicit none + integer, intent(in) :: nx, ny, n_land + integer, intent(in) :: tile_pfs(:) + integer, target, intent(in) :: tile_id(:,:) + + + real, dimension (:), allocatable :: & + a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & + a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & + atau_2cm,btau_2cm + integer, dimension (100,3) :: table_map + integer, dimension (3) :: nsoil_pcarbon + type (mineral_perc) :: min_percs + + integer :: n,i,j,k,ktop,ncid,i_highd,j_highd,nx_adj,ny_adj + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,d_undef, & + i1,i2,icount + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH, tmpversion + + logical, allocatable, dimension(:,:) :: land_pixels + integer, allocatable, dimension (:,:) :: & + net_data1,net_data2,net_data3,net_data4,net_data5,net_data6 ,net_data7 + integer (kind=2) , allocatable, target, dimension (:,:) :: SOIL_HIGH, & + sand_top,clay_top,oc_top,sand_sub,clay_sub,oc_sub, grav_grid + integer (kind=2), pointer, dimension (:,:) :: Raster, & + Raster1,Raster2,Raster3,Raster4,Raster5,Raster6 + integer (kind=4), allocatable, dimension (:) :: tileid_vec,arrayA,arrayB + integer (kind=2), allocatable, dimension (:) :: & + data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6 + REAL, ALLOCATABLE, dimension (:) :: soildepth, grav_vec,soc_vec,poc_vec + ! ncells_top,ncells_top_pro,ncells_sub_pro ! ncells_* not used + integer(kind=2) , allocatable, dimension (:) :: ss_clay, & + ss_sand,ss_clay_all,ss_sand_all,ss_oc_all + REAL, ALLOCATABLE :: count_soil(:) + integer, pointer :: iRaster(:,:) + integer :: tindex, pfafindex,fac,o_cl,o_clp,fac_surf !,vtype + real,dimension(4) :: cFamily + real ,dimension(5) :: cF_lim + logical :: first_entry = .true. + logical :: regrid,write_debug + INTEGER, allocatable, dimension (:) :: soil_class_top,soil_class_com + REAL :: sf,factor,wp_wetness,fac_count,this_cond + logical :: CatchParamsNC_file_exists + REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file + + ! PEATCLSM: + REAL, PARAMETER :: PEATMAP_THRESHOLD_1 = 0.5 ! for converting PEATMAP area fraction into peat/non-peat (on raster grid) + REAL, PARAMETER :: PEATMAP_THRESHOLD_2 = 0.5 ! for aggregation from raster grid cells to tiles + + REAL, DIMENSION (:), POINTER :: PMAP + REAL, ALLOCATABLE, DIMENSION (:,:) :: PMAPR + + + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ + ! + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1, li, ui, t_count + ! + integer, dimension(:), allocatable :: low_ind, upp_ind + ! + ! ------------------------------------------------------------------ + + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + + if (first_entry) then + nullify(iraster) ; first_entry = .false. + endif + + ! define orgC content thresholds for orgC classes 1-4 (low, medium, high, peat) + + cF_lim(1) = 0. + cF_lim(2) = 0.4 ! 0.365 ! 0.3 + cF_lim(3) = 0.64 ! 0.585 ! 4.0 + cF_lim(4) = 15./1.72 ! 15./1.72=8.72 ! 9.885 ! 8.5 + cF_lim(5) = 100.0 + + ! define number of mineral classes in each orgC class + + nsoil_pcarbon(1) = 84 ! 84 + nsoil_pcarbon(2) = nsoil_pcarbon(1) + 84 ! 84 + nsoil_pcarbon(3) = nsoil_pcarbon(2) + 84 ! 57 + + + ! read soil depth data from GSWP2_soildepth_H[xx]V[yy].nc + ! + ! get info common to all H[xx]V[yy] rectangles: + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v2/GSWP2_soildepth_H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + ! GSWP2_soildepth_H[xx]V[yy].nc as of 29 Apr 2022: + ! + ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): + ! + ! N_lon_global = i_highd = 43200 + ! N_lat_global = j_highd = 21600 + ! + ! i_ind_offset_LL = iLL = 42001 + ! j_ind_offset_LL = jLL = 19201 + ! + ! Each file contains data for one rectangle of size 1200-by-1200, which is + ! assumed to be the same for each H[xx]V[yy] rectangle + ! + ! N_lon = nc_10 = 1200 + ! N_lat = nr_10 = 1200 + + allocate(soil_high(1:i_highd,1:j_highd)) + allocate(net_data1 (1:nc_10,1:nr_10)) + + soil_high = -9999 + do jx = 1,18 + do ix = 1,36 + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v2/GSWP2_soildepth_H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) + + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & + soil_high(i,j) = net_data1(i-iLL +1 ,j - jLL +1) + enddo + enddo + status = NF_CLOSE(ncid) + endif + end do + end do + + deallocate (net_data1) + + ! Regridding + + ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, + ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine + ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* + ! grid tile space. + + nx_adj = nx + ny_adj = ny + + regrid = nx/=i_highd .or. ny/=j_highd + + if(regrid) then + if(nx > i_highd) then + allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(soil_high,raster) + iRaster => tile_id + if(ny < j_highd) then + print *,'nx > i_highd and ny < j_highd' + stop + endif + else + if( .not.associated(iraster) ) then + allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) + endif + call RegridRaster(tile_id,iraster) + raster => soil_high + nx_adj = i_highd + ny_adj = j_highd + + if(ny > j_highd) then + print *,'nx < i_highd and ny > j_highd' + stop + endif + endif + else + raster => soil_high + iRaster => tile_id + end if + + ! Interpolate/aggregate soil depth from raster grid to catchment-tiles + + allocate(soildepth(1:n_land)) + allocate(count_soil(1:n_land)) + + soildepth = 0. ! 1-d tile space + count_soil = 0. ! 1-d tile space + + do j=1,ny_adj + do i=1,nx_adj + if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.n_land)) then + if ((raster(i,j).gt.0)) then + soildepth(iRaster(i,j)) = & + soildepth(iRaster(i,j)) + sf*raster(i,j) ! integer "raster" --> real "soildepth" + count_soil(iRaster(i,j)) = & + count_soil(iRaster(i,j)) + 1. + endif + endif + end do + end do + + DO n =1,n_land + if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) + soildepth(n) = max(soildepth(n),SOILDEPTH_MIN_HWSD) + ! soildepth(n) = soildepth(n) + 2000. + ! soildepth(n) = min(soildepth(n),8000.) + END DO + + deallocate (SOIL_HIGH) + !deallocate (count_soil) ! do not deallocate, needed again shortly + NULLIFY(Raster) + + ! --------------------------------------------------------------------------------- ! - ! ASSERT THAT rmap IS CONSISTENT WITH 30-arcsec GRID OF MODIS INPUTS + ! Read NGDC-HWSD-STATSGO merged soil texture from SoilProperties_H[xx]V[yy].nc' ! - ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! get info common to all H[xx]V[yy] rectangles (could in theory differ from that + ! of soildepth data read above but is the same as of 29 Apr 2022). - ! Read number of catchment-tiles (N_tile) from catchment.def file + if (trim(SOILBCS)=='HWSD_b') then + tmpversion = 'v3' + else if (trim(SOILBCS)=='HWSD') then + tmpversion = 'v2' + else + print *, 'Unknown SOILBCS: ', SOILBCS + stop + end if - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*) N_tile ! # of tiles - close(10,status='keep') - - allocate(stch_snw_alb (1:nc_10,1:nr_10)) ! 10deg-by-10deg snow albedo data - allocate(snw_alb (1:N_tile)) ! snow albedo in tile space - allocate(count_snow_alb (1:N_tile)) ! count of MODIS grid cells contributing to tile-average snow albedo - - snw_alb = -9999. ! set all to missing - count_snow_alb = 0. ! initialize counter (SHOULD THIS BE KIND REAL???) - - ! loop through the 36x18 10deg-by-10deg MODIS files - - do jx = 1,18 + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/' // tmpversion // '/SoilProperties_H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here + !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) + status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) + status = NF_CLOSE(ncid) + + ! SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022: + ! + ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): + ! + ! N_lon_global = i_highd = 43200 + ! N_lat_global = j_highd = 21600 + ! + ! i_ind_offset_LL = iLL = 42001 + ! j_ind_offset_LL = jLL = 19201 + ! + ! Each file contains soil texture data for one rectangle of size 1200-by-1200, which is + ! assumed to be the same for each H[xx]V[yy] rectangle + ! + ! N_lon = nc_10 = 1200 + ! N_lat = nr_10 = 1200 + + !regrid = nx/=i_highd .or. ny/=j_highd ! not needed here, done below + + allocate(net_data1 (1:nc_10,1:nr_10)) + allocate(net_data2 (1:nc_10,1:nr_10)) + allocate(net_data3 (1:nc_10,1:nr_10)) + allocate(net_data4 (1:nc_10,1:nr_10)) + allocate(net_data5 (1:nc_10,1:nr_10)) + allocate(net_data6 (1:nc_10,1:nr_10)) + allocate(net_data7 (1:nc_10,1:nr_10)) + + allocate(sand_top (1:i_highd,1:j_highd)) + allocate(clay_top (1:i_highd,1:j_highd)) + allocate(oc_top (1:i_highd,1:j_highd)) + allocate(sand_sub (1:i_highd,1:j_highd)) + allocate(clay_sub (1:i_highd,1:j_highd)) + allocate(oc_sub (1:i_highd,1:j_highd)) + allocate(grav_grid(1:i_highd,1:j_highd)) + + sand_top = -9999 ! integer*2 + clay_top = -9999 ! integer*2 + oc_top = -9999 ! integer*2 + sand_sub = -9999 ! integer*2 + clay_sub = -9999 ! integer*2 + oc_sub = -9999 ! integer*2 + grav_grid= -9999 ! integer*2 + + do jx = 1,18 do ix = 1,36 - - ! assemble file name and open file - - write (hh,'(i2.2)') ix - write (vv,'(i2.2)') jx - - fname = trim(MAKE_BCS_INPUT_DIR) // '/land/albedo/snow/MODIS/v2/snow_alb_FillVal_MOD10A1.061_30arcsec_H'//hh//'V'//vv//'.nc' - - status = NF_OPEN (trim(fname),NF_NOWRITE, ncid) ! open file to read - - if(status == 0) then ! if file exists, read snow albedo - - status = NF_GET_VARA_REAL( ncid, NC_VarID(NCID,'Snow_Albedo'), (/1,1/), (/nc_10,nr_10/), stch_snw_alb); VERIFY_(STATUS) - - ! verify that input snow albedo has been back-filled *everywhere*, incl. water and landice - ! (i.e., stch_snw_alb must not contain no-data or unphysical values) - - if ( any(stch_snw_alb<0.) .or. any(stch_snw_alb>1.) ) then - - print *, 'ERROR: subroutine ', trim(Iam), '() : detected no-data or unphysical values in MODIS file ', trim(fname) - print *, 'STOPPING.' - stop - - end if - - ! calculate Lower Left (LL) indices for the chunk of the global 30-arcsec grid that is stored in file (ix,jx) - ! - ! NOTE: In similar subroutines for processing other data, iLL and jLL are stored in the nc4 file. - - iLL=(ix-1)*nc_10+1 - jLL=(jx-1)*nr_10+1 - - ! loop through 30-arcsec grid cells in current 10deg-by-10deg chunk - - do jj=1,nr_10 - do ii=1,nc_10 - - iG = ii+iLL-1 ! i-index relative to *global* 30-arcsec grid - jG = jj+jLL-1 ! j-index relative to *global* 30-arcsec grid - - pix_count = rmap%ij_index(iG,jG) ! pix_count == ID/index of tile to which current 30-arcsec grid cell belongs [???] - - if (pix_count == 0) cycle ! if this MODIS grid cell has no corresponding remapped value, skip it - - if (rmap%map(pix_count)%nt > 0) then ! if the # of tiles corresponding to this gridbox is gt 0, proceed with calculations - - do nn = 1,rmap%map(pix_count)%nt ! loop through all corresponding tiles [???] - - ! if first pass, set albedo to zero - ! [????] CAN THIS BE SKIPPED IF snw_alb IS INITIALIZED TO ZERO ABOVE? - ! BECAUSE MODIS DATA ARE BACKFILLED, THERE SHOULD NOT BE NO-DATA-VALUES FOR ANY TILE - if (snw_alb(rmap%map(pix_count)%tid(nn)) == -9999.) snw_alb(rmap%map(pix_count)%tid(nn)) = 0. - - ! accumulate values and counts - snw_alb(rmap%map(pix_count)%tid(nn)) = & - snw_alb(rmap%map(pix_count)%tid(nn)) + stch_snw_alb(ii,jj)*rmap%map(pix_count)%count(nn) - - ! [???] rmap%map(pix_count)%count(nn) IS INTEGER; MAKE count_snow_alb INTEGER AFTER FIRST ASSERTING 0-DIFF FOR CURRENT CLEANUP - count_snow_alb(rmap%map(pix_count)%tid(nn)) = & - count_snow_alb(rmap%map(pix_count)%tid(nn)) + 1.*rmap%map(pix_count)%count(nn) - - end do + write (vv,'(i2.2)')jx + write (hh,'(i2.2)')ix + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/' // tmpversion // '/SoilProperties_H'//hh//'V'//vv//'.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) + if(status == 0) then + status = NF_GET_att_INT (ncid, NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) + status = NF_GET_att_INT (ncid, NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) + ! assume UNDEF and ScaleFactor (sf) are the same for *all* variables read below + ! (ok for SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022). + status = NF_GET_att_INT (ncid, 4,'UNDEF',d_undef); VERIFY_(STATUS) + status = NF_GET_att_REAL (ncid, 4,'ScaleFactor',sf); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 5,(/1,1/),(/nc_10,nr_10/),net_data2); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 6,(/1,1/),(/nc_10,nr_10/),net_data3); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 7,(/1,1/),(/nc_10,nr_10/),net_data4); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 8,(/1,1/),(/nc_10,nr_10/),net_data5); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid, 9,(/1,1/),(/nc_10,nr_10/),net_data6); VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid,10,(/1,1/),(/nc_10,nr_10/),net_data7); VERIFY_(STATUS) + do j = jLL,jLL + nr_10 -1 + do i = iLL, iLL + nc_10 -1 + if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & + clay_top(i,j) = net_data1(i-iLL +1 ,j - jLL +1) + if(net_data2(i-iLL +1 ,j - jLL +1) /= d_undef) & + sand_top(i,j) = net_data2(i-iLL +1 ,j - jLL +1) + if(net_data3(i-iLL +1 ,j - jLL +1) /= d_undef) & + oc_top (i,j) = net_data3(i-iLL +1 ,j - jLL +1) + if(net_data4(i-iLL +1 ,j - jLL +1) /= d_undef) & + clay_sub(i,j) = net_data4(i-iLL +1 ,j - jLL +1) + if(net_data5(i-iLL +1 ,j - jLL +1) /= d_undef) & + sand_sub(i,j) = net_data5(i-iLL +1 ,j - jLL +1) + if(net_data6(i-iLL +1 ,j - jLL +1) /= d_undef) & + oc_sub (i,j) = net_data6(i-iLL +1 ,j - jLL +1) + if(net_data7(i-iLL +1 ,j - jLL +1) /= d_undef) & + grav_grid(i,j) = net_data7(i-iLL +1 ,j - jLL +1) + enddo + enddo + status = NF_CLOSE(ncid) + endif + end do + end do - endif ! if not missing - enddo ! ii-loop - enddo ! jj-loop - - ! Close the file, freeing all resources. - status=NF_CLOSE(ncid); VERIFY_(STATUS) - + deallocate (net_data1) + deallocate (net_data2) + deallocate (net_data3) + deallocate (net_data4) + deallocate (net_data5) + deallocate (net_data6) + deallocate (net_data7) + + ! ---------------------------------------------------------------------------- + + if(use_PEATMAP) then + print *, 'PEATMAP_THRESHOLD_1 : ', PEATMAP_THRESHOLD_1 + allocate(pmapr (1:i_highd,1:j_highd)) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/PEATMAP_mask.nc4', NF_NOWRITE, ncid) + status = NF_GET_VARA_REAL (ncid,NC_VarID(NCID,'PEATMAP'), (/1,1/),(/i_highd, j_highd/), pmapr) ; VERIFY_(STATUS) + + ! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat + + where (oc_sub*sf >= cF_lim(4)) + oc_sub = NINT(8./sf) + endwhere + + ! Hybridize: add OC 1km PEATMAP pixels to HWSD oc_top + + where (pmapr >= PEATMAP_THRESHOLD_1) + oc_top = NINT(33.0/sf) + endwhere + + deallocate (pmapr) + status = NF_CLOSE(ncid) + endif + + ! ---------------------------------------------------------------------------- + + ! Regridding + + ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, + ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine + ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* + ! grid tile space. + + nx_adj = nx + ny_adj = ny + + regrid = nx/=i_highd .or. ny/=j_highd + + if(regrid) then + if(nx > i_highd) then + allocate(raster1(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(clay_top,raster1) + + allocate(raster2(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(sand_top,raster2) + + allocate(raster3(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(oc_top, raster3) + + allocate(raster4(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(clay_sub,raster4) + + allocate(raster5(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(sand_sub,raster5) + + allocate(raster6(nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(oc_sub, raster6) + + allocate(raster (nx,ny),stat=STATUS); VERIFY_(STATUS) + call RegridRaster2(grav_grid,raster) + + iRaster => tile_id + + if(ny < j_highd) then + print *,'nx > i_highd and ny < j_highd' + stop endif - end do ! jx-loop through 10deg-by-10deg files - end do ! ix-loop through 10deg-by-10deg files - - ! finalize calculation of mean values - ! [???] NOTE: count_snw_alb SHOULD BE INTEGER --> CONVERT TO REAL - - ! because MODIS data are backfilled, should have count_snow_alb>0 - - if ( any(count_snow_alb<=0.) ) then - - print *, 'ERROR: subroutine ', trim(Iam), '() : something wrong with count_snow_alb(:)' - print *, 'STOPPING.' - stop - + else + nx_adj = i_highd + ny_adj = j_highd + if( .not.associated(iraster) ) then + allocate(iRaster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) + endif + call RegridRaster(tile_id,iRaster) + + raster1 => clay_top + raster2 => sand_top + raster3 => oc_top + raster4 => clay_sub + raster5 => sand_sub + raster6 => oc_sub + raster => grav_grid + + if(ny > j_highd) then + print *,'nx < i_highd and ny > j_highd' + stop + endif + endif + else + iRaster => tile_id + raster1 => clay_top + raster2 => sand_top + raster3 => oc_top + raster4 => clay_sub + raster5 => sand_sub + raster6 => oc_sub + raster => grav_grid end if - - snw_alb = snw_alb/count_snow_alb ! finalize calculation of tile-average snow albedo - - ! write snow albedo into clsm/catch_params.nc4 - inquire(file='clsm/catch_params.nc4', exist=file_exists) - - if(file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'SNOWALB'),(/1/),(/N_tile/),real(snw_alb)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + ! ---------------------------------------------------------------------------- + + ! compute peat fraction on tile for CLM45+ (for fires?) + + allocate(pmap (1:n_land)) + !allocate(count_soil(1:n_land)) ! already allocated above + + pmap = 0. ! 1-d tile space; peat fraction in tile based on oc_top + count_soil = 0. ! 1-d tile space + + do j=1,ny_adj + do i=1,nx_adj + if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.n_land)) then + count_soil(iRaster(i,j)) = count_soil(iRaster(i,j)) + 1. + if (raster3(i,j)*sf >= cF_lim(4)) then + pmap (iRaster(i,j)) = pmap(iRaster(i,j)) + 1 + endif + endif + end do + end do + + where (count_soil > 0) pmap = pmap /count_soil + + !deallocate (count_soil) ! do not deallocate, needed again shortly + + ! ---------------------------------------------------------------------------- + + ! get number of "land" pixels (i1) on raster grid + + allocate(land_pixels(1:size(iRaster,1),1:size(iRaster,2))) + land_pixels = (iRaster >=1).and.(iRaster<=n_land) + i1 = count(land_pixels) + deallocate (land_pixels) + + ! allocate 1-d arrays for all "land" pixels on raster grid + + allocate (tileid_vec(1:i1)) + allocate (data_vec1 (1:i1)) + allocate (data_vec2 (1:i1)) + allocate (data_vec3 (1:i1)) + allocate (data_vec4 (1:i1)) + allocate (data_vec5 (1:i1)) + allocate (data_vec6 (1:i1)) + + ! allocate 1-d arrays for all "land" tiles + + allocate (grav_vec (1:n_land)) + allocate (soc_vec (1:n_land)) + allocate (poc_vec (1:n_land)) + !allocate (ncells_top (1:n_land)) ! ncells_* not used + !allocate (ncells_top_pro (1:n_land)) ! ncells_* not used + !allocate (ncells_sub_pro (1:n_land)) ! ncells_* not used + !allocate(count_soil(1:n_land)) + + count_soil = 0. + grav_vec = 0. + soc_vec = 0. ! soil orgC (top layer 0-30) + poc_vec = 0. ! soil orgC (profile layer 0-100) + + !ncells_top = 0. ! ncells_* not used + !ncells_top_pro = 0. ! ncells_* not used + !ncells_sub_pro = 0. ! ncells_* not used + + n =1 + do j=1,ny_adj + do i=1,nx_adj + if((iRaster(i,j).ge.1).and.(iRaster(i,j).le.n_land)) then + + ! map from 2-d raster array to 1-d raster vec + + tileid_vec (n) = iRaster(i,j) ! iRaster => tile_id int*4 + data_vec1 (n) = Raster1(i,j) ! raster1 => clay_top int*2 + data_vec2 (n) = Raster2(i,j) ! raster2 => sand_top int*2 + data_vec3 (n) = Raster3(i,j) ! raster3 => oc_top int*2 + data_vec4 (n) = Raster4(i,j) ! raster4 => clay_sub int*2 + data_vec5 (n) = Raster5(i,j) ! raster5 => sand_sub int*2 + data_vec6 (n) = Raster6(i,j) ! raster6 => oc_sub int*2 + + ! BUG??? It is unclear why here grav_vec is filled in the order of "tile_id" + ! while data_vec[x] is filled in the order of the long/lat grid. + ! Not sure if grav_vec is processed correctly below! + ! -reichle, 29 Apr 2022 + + if ((raster(i,j).gt.0)) then + grav_vec(iRaster(i,j)) = & + grav_vec(iRaster(i,j)) + sf*raster(i,j) ! raster => grav_grid int*2 + count_soil(iRaster(i,j)) = & + count_soil(iRaster(i,j)) + 1. + endif + n = n + 1 + endif + end do + end do + + DO n =1,n_land + if(count_soil(n)/=0.) grav_vec(n)=grav_vec(n)/count_soil(n) + END DO + + deallocate (count_soil) + NULLIFY(Raster,Raster1,Raster2,Raster3,Raster4,Raster5,Raster6) + deallocate (clay_top,sand_top,oc_top,clay_sub,sand_sub,oc_sub,grav_grid) + + ! sort 1-d land pixels vectors according to tile_id + + allocate (arrayA (1:i1)) ! 1-d land pixels on raster grid + allocate (arrayB (1:i1)) ! 1-d land pixels on raster grid + + arrayA = tileid_vec + arrayB = data_vec1 + call MAPL_Sort (arrayA, arrayB) + data_vec1 = arrayB + + arrayA = tileid_vec + arrayB = data_vec2 + call MAPL_Sort (arrayA, arrayB) + data_vec2 = arrayB + + arrayA = tileid_vec + arrayB = data_vec3 + call MAPL_Sort (arrayA, arrayB) + data_vec3 = arrayB + + arrayA = tileid_vec + arrayB = data_vec4 + call MAPL_Sort (arrayA, arrayB) + data_vec4 = arrayB + + arrayA = tileid_vec + arrayB = data_vec5 + call MAPL_Sort (arrayA, arrayB) + data_vec5 = arrayB + + arrayA = tileid_vec + arrayB = data_vec6 + call MAPL_Sort (arrayA, arrayB) + data_vec6 = arrayB + + tileid_vec= arrayA + + deallocate (arrayA, arrayB) + + ! -------------------------------------------------------------------- + ! + ! Read Woesten soil parameters and CLSM tau parameters for soil classes (1:253) + + allocate(a_sand (1:n_SoilClasses)) + allocate(a_clay (1:n_SoilClasses)) + allocate(a_silt (1:n_SoilClasses)) + allocate(a_oc (1:n_SoilClasses)) + allocate(a_bee (1:n_SoilClasses)) + allocate(a_psis (1:n_SoilClasses)) + allocate(a_poros (1:n_SoilClasses)) + allocate(a_wp (1:n_SoilClasses)) + allocate(a_aksat (1:n_SoilClasses)) + allocate(atau (1:n_SoilClasses)) + allocate(btau (1:n_SoilClasses)) + allocate(atau_2cm(1:n_SoilClasses)) + allocate(btau_2cm(1:n_SoilClasses)) + allocate(a_wpsurf(1:n_SoilClasses)) + allocate(a_porosurf(1:n_SoilClasses)) + + ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ + ! only in the parameters for the peat class #253. The file *.peatmap contains + ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). + ! + ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND + ! + ! K_s COND [m/s] + ! NLv4 7.86e-7 5.81e-6 + ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 + + if(use_PEATMAP) then + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.peatmap' + else + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat' endif - - deallocate(stch_snw_alb) - deallocate(count_snow_alb) - deallocate(snw_alb) - - END SUBROUTINE MODIS_snow_alb_v2 - - !---------------------------------------------------------------------- - - SUBROUTINE MODIS_snow_alb( ) - ! Map static, MODIS climatology-based snow albedo from preprocessed 30-arcsec grid - ! to land tiles and write into clsm/catch_params.nc4. + table_map = 0 ! 100-by-3 look-up table + + open (11, file=trim(fname), form='formatted',status='old', & + action = 'read') + read (11,'(a)')fout ! read header line + + do n =1,n_SoilClasses + + read (11,'(4f7.3,4f8.4,e13.5,2f12.7,2f8.4,4f12.7)')a_sand(n),a_clay(n),a_silt(n),a_oc(n),a_bee(n),a_psis(n), & + a_poros(n),a_wp(n),a_aksat(n),atau(n),btau(n),a_wpsurf(n),a_porosurf(n),atau_2cm(n),btau_2cm(n) + + ! assemble scalar structure that holds mineral percentages of soil class n + + min_percs%clay_perc = a_clay(n) + min_percs%silt_perc = a_silt(n) + min_percs%sand_perc = a_sand(n) + + ! "soil_class" is an integer function (see rmTinyCatchParam.F90) that assigns + ! an integer (mineral) soil class [1-100] for a given mineral percentage triplet + + ! "table_map" is a 2-d array (100-by-3) that maps between overall soil class (1:252) and + ! (mineral_class 1:84, orgC_class). "table_map" has no entry for the peat class #253. + + if( n <= nsoil_pcarbon(1)) table_map(soil_class (min_percs),1) = n + if((n > nsoil_pcarbon(1)).and.(n <= nsoil_pcarbon(2))) table_map(soil_class (min_percs),2) = n + if((n > nsoil_pcarbon(2)).and.(n <= nsoil_pcarbon(3))) table_map(soil_class (min_percs),3) = n + + end do ! n=1,n_SoilClasses + + close (11,status='keep') + + ! ------------------------------------------------------------ ! - ! Assumes that input snow albedo is backfilled (i.e., does not contain no-data values). + ! When Woesten soil parameters are not available for a particular soil class, + ! as defined by "tiny" triangles in HWSD soil triangle, Woesten soil + ! parameters from the nearest available "tiny" triangle will be substituted. + ! For "tiny" triangles, see Fig 1b of De Lannoy et al. 2014 (doi:10.1002/2014MS000330). + + do n =1,10 + do k=1,n*2 -1 + + min_percs%clay_perc = 100. -((n-1)*10 + 5) + min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. + min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc + + i = soil_class (min_percs) + + if(table_map (i,1)== 0) then + j = center_pix (a_clay(1:nsoil_pcarbon(1)),a_sand(1:nsoil_pcarbon(1)), & + min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) + + min_percs%clay_perc = a_clay(j) + min_percs%silt_perc = a_silt(j) + min_percs%sand_perc = a_sand(j) + table_map (i,1)= table_map (soil_class (min_percs),1) + endif + + min_percs%clay_perc = 100. -((n-1)*10 + 5) + min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. + min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc + + if(table_map (i,2)== 0) then + j = center_pix(a_clay(nsoil_pcarbon(1)+1 : nsoil_pcarbon(2)), & + a_sand(nsoil_pcarbon(1)+1 : nsoil_pcarbon(2)), & + min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) + min_percs%clay_perc = a_clay(j + nsoil_pcarbon(1)) + min_percs%silt_perc = a_silt(j + nsoil_pcarbon(1)) + min_percs%sand_perc = a_sand(j + nsoil_pcarbon(1)) + table_map (i,2)= table_map (soil_class (min_percs),2) + endif + + min_percs%clay_perc = 100. -((n-1)*10 + 5) + min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. + min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc + + if(table_map (i,3)== 0) then + j = center_pix (a_clay(nsoil_pcarbon(2)+1 : nsoil_pcarbon(3)), & + a_sand(nsoil_pcarbon(2)+1 : nsoil_pcarbon(3)), & + min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) + min_percs%clay_perc = a_clay(j + nsoil_pcarbon(2)) + min_percs%silt_perc = a_silt(j + nsoil_pcarbon(2)) + min_percs%sand_perc = a_sand(j + nsoil_pcarbon(2)) + table_map (i,3)= table_map (soil_class (min_percs),3) + endif + end do + end do ! - ! Snow albedo assigned to each tile is average over 30-arcsec MODIS grid cells located - ! within the rectangle defined by the min/max lat/lon of tile; this can include MODIS grid - ! cells located in neighboring land tiles and/or water/landice tiles. - ! See subroutine MODIS_snow_alb_v2() for a refined algorithm. + ! Now deriving soil types based on NGDC-HWSD-STATSGO merged soil property maps ! - ! Biljana Orescanin July 2022, SSAI@NASA + allocate (soil_class_top (1:n_land)) + allocate (soil_class_com (1:n_land)) + soil_class_top =-9999 + soil_class_com =-9999 - implicit none + allocate(low_ind(n_threads)) + allocate(upp_ind(n_threads)) + low_ind(1) = 1 + upp_ind(n_threads) = n_land - character*200 :: fname - character*2 :: vv,hh - integer :: n,N_tile,ncid,status - real,allocatable,dimension(:) :: min_lon,max_lon,min_lat,max_lat,snw_alb - integer(kind=4),parameter :: xdim = 1200, ydim = 1200 - real,dimension(xdim,ydim) :: stch_snw_alb_tmp - real,dimension(36,18,xdim,ydim) :: stch_snw_alb - real :: minlon,maxlon,minlat,maxlat - real :: sno_alb_cnt,sno_alb_sum - integer :: vvtil_min,hhtil_min,vvtil_max,hhtil_max,hhtil,vvtil - integer :: tindex1,pfaf1 - integer(kind=4) :: imin,imax,jmin,jmax,varid1 - logical :: file_exists + if (running_omp) then + do i=1,n_threads-1 + upp_ind(i) = low_ind(i) + (n_land/n_threads) - 1 + low_ind(i+1) = upp_ind(i) + 1 + end do + end if + + !$OMP PARALLELDO DEFAULT(NONE) & + !$OMP SHARED( n_threads, low_ind, upp_ind, tileid_vec, & + !$OMP sf,data_vec1,data_vec2,data_vec3, & + !$OMP data_vec4,data_vec5,data_vec6,cF_lim, & + !$OMP table_map,soil_class_top,soil_class_com, & + !$OMP soc_vec,poc_vec,use_PEATMAP) & + !ncells_* not used !$OMP soc_vec,poc_vec,ncells_top,ncells_top_pro,& + !ncells_* not used !$OMP ncells_sub_pro,use_PEATMAP) & + !$OMP PRIVATE(n,i,j,k,icount,t_count,i1,i2,ss_clay, & + !$OMP ss_sand,ss_clay_all,ss_sand_all, & + !$OMP ss_oc_all,cFamily,factor,o_cl,o_clp,ktop, & + !$OMP min_percs, fac_count, write_debug) + + ! loop through tiles (split into two loops for OpenMP) + + DO t_count = 1,n_threads + DO n = low_ind(t_count),upp_ind(t_count) + + write_debug = .false. + + ! if (n==171010) write_debug = .true. + + ! initialize "icount" when starting loop through n at low_ind(t_count) + ! recall: tileid_vec is a 1-d vector that covers all land pixels on the raster grid that + ! contains the (sorted) tile IDs, with matching parameter vectors data_vec[x] + + if(n==low_ind(t_count)) then + icount = 1 + ! Not sure what the following loops do. Why not check backwards from low_ind(t_count)?? + do k=1,low_ind(t_count) - 1 + do while (tileid_vec(icount)== k) + icount = icount + 1 + end do + end do + endif - ! Read number of catchment-tiles (N_tile) from catchment.def file - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) N_tile + ! ------------------------------------------------------------------ + ! + ! determine the land raster grid cells i1:i2 that make up tile n - ! Read min/max lat/lons to use when locating snow albedo grids in - ! the stitched MODIS albedo file - allocate (min_lon(1:N_tile)) - allocate (min_lat(1:N_tile)) - allocate (max_lon(1:N_tile)) - allocate (max_lat(1:N_tile)) - allocate (snw_alb(1:N_tile)) + ! NOTE change in meaning of "i1": + ! + ! before: i1 = total no. of land pixels on the raster grid + ! now: i1 = starting index of land raster grid cells (within 1-d vector) that make up tile n (?) - ! Start by setting all snow albedo values to missing - snw_alb(:)=MAPL_UNDEF + i1 = icount - do n = 1, N_tile - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - min_lon(n) = minlon - max_lon(n) = maxlon - min_lat(n) = minlat - max_lat(n) = maxlat - end do + loop: do while (tileid_vec(icount)== n) + if(icount <= size(tileid_vec,1)) icount = icount + 1 + if(icount > size(tileid_vec,1)) exit loop + end do loop - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + i2 = icount -1 + i = i2 - i1 + 1 ! number of land raster grid cells that make up tile n (?) - ! ----------- Get the information on snow albedo ----- - ! ----------- The information on snow albedo is stored in 10x10deg 30-arcsec resolution files. - ! ----------- Read in this information, then loop over the tiles to find a corresponding snow albedo. - ! Read in all 10x10deg snow albedo files into a single [36,18,1200,1200] array - do hhtil=1,36 ! loop over input files - horizontal direction - do vvtil=1,18 ! loop over input files - vertical direction + ! ------------------------------------------------------------------- + ! + ! prep data - write(vv,'(i2.2)') vvtil - write(hh,'(i2.2)') hhtil + allocate(ss_clay (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? + allocate(ss_sand (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? - ! MODIS-based climatology albedo raster files, backfilled with global land - ! average snow albedo (=0.56; average excludes Antarctica and Greenland ice - ! sheets and is weighted by the grid-cell area). + allocate(ss_clay_all(1:2*i)) ! for top (0-30) and sub (30-100) layers + allocate(ss_sand_all(1:2*i)) ! for top (0-30) and sub (30-100) layers + allocate(ss_oc_all (1:2*i)) ! for top (0-30) and sub (30-100) layers - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/albedo/snow/MODIS/v2/snow_alb_FillVal_MOD10A1.061_30arcsec_H'//hh//'V'//vv//'.nc' + ss_clay = 0 ! int*2 -- why only clay and sand for top layer and not orgC ?? + ss_sand = 0 ! int*2 - ! Open the file. (NF90_NOWRITE ensures read-only access to the file) - status=NF_OPEN(trim(fname),NF_NOWRITE, ncid) ; VERIFY_(STATUS) - ! Based on vars name, get the varids. - status=NF_INQ_VARID(ncid,'Snow_Albedo',VarID1) ; VERIFY_(STATUS) - ! Read the data. - status=NF_GET_VARA_REAL(ncid,VarID1,(/1,1/),(/xdim,ydim/),stch_snw_alb_tmp) ; VERIFY_(STATUS) - ! Close the file, freeing all resources. - status=NF_CLOSE(ncid); VERIFY_(STATUS) + ss_clay_all= 0 ! int*2 + ss_sand_all= 0 ! int*2 + ss_oc_all = 0 ! int*2 - ! Store snow albedo values into a single 4D aray - stch_snw_alb(hhtil,vvtil,:,:)=stch_snw_alb_tmp + ss_clay_all (1:i) = data_vec1(i1:i2) ! put top layer info into first i elements (1:i) + ss_sand_all (1:i) = data_vec2(i1:i2) + ss_oc_all (1:i) = data_vec3(i1:i2) - enddo - enddo + ss_clay_all (1+i:2*i) = data_vec4(i1:i2) ! put sub layer info into next i elements (i+1:2*i) + ss_sand_all (1+i:2*i) = data_vec5(i1:i2) + ss_oc_all (1+i:2*i) = data_vec6(i1:i2) ! <-- oc_sub - if (minval(stch_snw_alb) .le. 0.0 .or. maxval(stch_snw_alb) .gt. 1.0) then - print*, 'There is a problem with snow albedo raster file. Non-physical values present. STOP!' - stop - endif - ! loop over tiles - print*, 'Starting tile loop for snow albedo.' + ! ----------------------------------------------------------------------- + ! + ! determine aggregate/dominant orgC *top* layer soil class ("o_cl") of tile n - do n = 1, N_tile ! loop over tiles + cFamily = 0. + !! factor = 1. - ! Set sums and counts to zero - sno_alb_sum=0. - sno_alb_cnt=0. - - ! Use tile's min/max lat/lon info to identify the 10x10deg input file(s) - ! indexes - vvtil_min=floor((min_lat(n)+ 90.0)/10.)+1 - hhtil_min=floor((min_lon(n)+180.0)/10.)+1 - - ! if tile crosses the edge of the snow albedo 10x10deg box, expand the - ! search area into the neighbouring 10x10deg box - hhtil_max=hhtil_min - vvtil_max=vvtil_min - if (floor(min_lon(n)/10) .ne. floor(max_lon(n)/10)) hhtil_max=hhtil_min+1 - if (floor(min_lat(n)/10) .ne. floor(max_lat(n)/10)) vvtil_max=vvtil_min+1 - - ! Safety check; keep within the range - vvtil_min=max(vvtil_min,1) - vvtil_max=min(vvtil_max,18) - hhtil_min=max(hhtil_min,1) - hhtil_max=min(hhtil_max,36) - - do hhtil=hhtil_min,hhtil_max ! loop through input files - horizontal direction - do vvtil=vvtil_min,vvtil_max ! loop through input files - vertical direction - - ! Find indices ranges corresponding to the current tile area. - imin=floor((min_lon(n)+180.0 - (hhtil-1)*10.0) * (xdim/10.0)) +1 - imax=floor((max_lon(n)+180.0 - (hhtil-1)*10.0) * (xdim/10.0)) +1 - jmin=floor((min_lat(n)+ 90.0 - (vvtil-1)*10.0) * (ydim/10.0)) +1 - jmax=floor((max_lat(n)+ 90.0 - (vvtil-1)*10.0) * (ydim/10.0)) +1 - - ! if no matching grids, go to the next vv/hh box - if (imin .gt. xdim .or. jmin .gt. ydim .or. imax .lt. 1 .or. jmax .lt. 1) cycle - - ! Keep within the range, to include only the portion of the tile within this vv/hh box - imin=max(imin,1) - imax=min(imax,xdim) - jmin=max(jmin,1) - jmax=min(jmax,ydim) - - ! Generate sums and counts using current tile corresponding indices - sno_alb_sum = sno_alb_sum + sum(stch_snw_alb(hhtil,vvtil,imin:imax,jmin:jmax)) - sno_alb_cnt = sno_alb_cnt + (imax-imin+1)*(jmax-jmin+1) - - end do ! vvtil - end do ! hhtil - - ! If matching grids found, calculate snow albedo for the current tile; - ! ensure that resulting value is within physical range [0,1]. - if (sno_alb_cnt .ne. 0) snw_alb(n)=min(1.0,max(0.0,sno_alb_sum/sno_alb_cnt)) + do j=1,i + if(j <= i) factor = 1. + if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor + if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor + if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor + if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor + end do - end do ! n-loop over tiles + if (sum(cFamily) == 0.) o_cl = 1 ! default is o_cl=1 (if somehow no grid cell has top-layer orgC >=0.) - ! write snow albedo into clsm/catch_params.nc4 - inquire(file='clsm/catch_params.nc4', exist=file_exists) + !! if (.not. use_PEATMAP) then - if(file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'SNOWALB'),(/1/),(/N_tile/),real(snw_alb)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - endif + ! assign dominant *top* layer org soil class (even if only a minority of the contributing + ! raster grid cells is peat) - print*, 'Ended tile loop for snow albedo. ' + if (sum(cFamily) > 0.) o_cl = maxloc(cFamily, dim = 1) - END SUBROUTINE MODIS_snow_alb + !! else - !-------------------------------------------------------------------------------------- + if (use_PEATMAP) then - SUBROUTINE soil_para_hwsd (nx,ny,fnameRst) - -! Processing NGDC-HWSD-STATSGO merged soil properties with Woesten Soil -! Parameters and produces tau_param.dat and soil_param.dat files - - implicit none - integer, intent (in) :: nx, ny - character(*) :: fnameRst - real, dimension (:), allocatable :: & - a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & - a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & - atau_2cm,btau_2cm - integer, dimension (100,3) :: table_map - integer, dimension (3) :: nsoil_pcarbon - type (mineral_perc) :: min_percs - - integer :: n,maxcat,i,j,k,ktop,ncid,i_highd,j_highd,nx_adj,ny_adj - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,d_undef, & - i1,i2,icount - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH, tmpversion - - logical, allocatable, dimension(:,:) :: land_pixels - integer, allocatable, dimension (:,:) :: & - net_data1,net_data2,net_data3,net_data4,net_data5,net_data6 ,net_data7 - integer (kind=2) , allocatable, target, dimension (:,:) :: SOIL_HIGH, & - sand_top,clay_top,oc_top,sand_sub,clay_sub,oc_sub, grav_grid - integer (kind=2), pointer, dimension (:,:) :: Raster, & - Raster1,Raster2,Raster3,Raster4,Raster5,Raster6 - integer (kind=4), allocatable, dimension (:) :: tileid_vec,arrayA,arrayB - integer (kind=2), allocatable, dimension (:) :: & - data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6 - REAL, ALLOCATABLE, dimension (:) :: soildepth, grav_vec,soc_vec,poc_vec -! ncells_top,ncells_top_pro,ncells_sub_pro ! ncells_* not used - integer(kind=2) , allocatable, dimension (:) :: ss_clay, & - ss_sand,ss_clay_all,ss_sand_all,ss_oc_all - REAL, ALLOCATABLE :: count_soil(:) - integer, allocatable, target, dimension (:,:) :: tile_id - integer, pointer :: iRaster(:,:) - integer :: tindex, pfafindex,fac,o_cl,o_clp,fac_surf !,vtype - real,dimension(4) :: cFamily - real ,dimension(5) :: cF_lim - logical :: first_entry = .true. - logical :: regrid,write_debug - INTEGER, allocatable, dimension (:) :: soil_class_top,soil_class_com - REAL :: sf,factor,wp_wetness,fac_count,this_cond - logical :: CatchParamsNC_file_exists - REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file - - ! PEATCLSM: - REAL, PARAMETER :: PEATMAP_THRESHOLD_1 = 0.5 ! for converting PEATMAP area fraction into peat/non-peat (on raster grid) - REAL, PARAMETER :: PEATMAP_THRESHOLD_2 = 0.5 ! for aggregation from raster grid cells to tiles - - REAL, DIMENSION (:), POINTER :: PMAP - REAL, ALLOCATABLE, DIMENSION (:,:) :: PMAPR - - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1, li, ui, t_count -! -integer, dimension(:), allocatable :: low_ind, upp_ind -! -! ------------------------------------------------------------------ - - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - ! - ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION - ! - !$ running_omp = .true. ! conditional compilation - ! - ! ECHO BASIC OMP VARIABLES - ! - !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) - ! - !$OMP SINGLE - ! - !$ n_threads = omp_get_num_threads() - ! - !$ write (*,*) 'running_omp = ', running_omp - !$ write (*,*) - !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' - !$ write (*,*) - !$OMP ENDSINGLE - ! - !$OMP CRITICAL - !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' - !$OMP ENDCRITICAL - ! - !$OMP BARRIER - ! - !$OMP ENDPARALLEL - - if (first_entry) then - nullify(iraster) ; first_entry = .false. - endif - - ! define orgC content thresholds for orgC classes 1-4 (low, medium, high, peat) - - cF_lim(1) = 0. - cF_lim(2) = 0.4 ! 0.365 ! 0.3 - cF_lim(3) = 0.64 ! 0.585 ! 4.0 - cF_lim(4) = 15./1.72 ! 15./1.72=8.72 ! 9.885 ! 8.5 - cF_lim(5) = 100.0 - - ! define number of mineral classes in each orgC class - - nsoil_pcarbon(1) = 84 ! 84 - nsoil_pcarbon(2) = nsoil_pcarbon(1) + 84 ! 84 - nsoil_pcarbon(3) = nsoil_pcarbon(2) + 84 ! 57 - - ! Read number of catchment-tiles (maxcat) from catchment.def file - - fname='clsm/catchment.def' - - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - - close (10,status='keep') - - ! Read tile-id raster file - - allocate(tile_id(1:nx,1:ny)) - - fname=trim(fnameRst)//'.rst' - - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - ! read soil depth data from GSWP2_soildepth_H[xx]V[yy].nc - ! - ! get info common to all H[xx]V[yy] rectangles: - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v2/GSWP2_soildepth_H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here - !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - ! GSWP2_soildepth_H[xx]V[yy].nc as of 29 Apr 2022: - ! - ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): - ! - ! N_lon_global = i_highd = 43200 - ! N_lat_global = j_highd = 21600 - ! - ! i_ind_offset_LL = iLL = 42001 - ! j_ind_offset_LL = jLL = 19201 - ! - ! Each file contains data for one rectangle of size 1200-by-1200, which is - ! assumed to be the same for each H[xx]V[yy] rectangle - ! - ! N_lon = nc_10 = 1200 - ! N_lat = nr_10 = 1200 - - allocate(soil_high(1:i_highd,1:j_highd)) - allocate(net_data1 (1:nc_10,1:nr_10)) - - soil_high = -9999 - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v2/GSWP2_soildepth_H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid,4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid,4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) + ! PEATMAP: tile has *top* layer peat class only if more than 50% of the contributing + ! raster grid cells are peat (may loose some peat tiles w.r.t. non-PEATMAP bcs version) - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & - soil_high(i,j) = net_data1(i-iLL +1 ,j - jLL +1) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do - - deallocate (net_data1) - - ! Regridding - - ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, - ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine - ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* - ! grid tile space. - - nx_adj = nx - ny_adj = ny - - regrid = nx/=i_highd .or. ny/=j_highd - - if(regrid) then - if(nx > i_highd) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(soil_high,raster) - iRaster => tile_id - if(ny < j_highd) then - print *,'nx > i_highd and ny < j_highd' - stop - endif - else - if( .not.associated(iraster) ) then - allocate(iraster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) - endif - call RegridRaster(tile_id,iraster) - raster => soil_high - nx_adj = i_highd - ny_adj = j_highd - - if(ny > j_highd) then - print *,'nx < i_highd and ny > j_highd' - stop - endif - endif - else - raster => soil_high - iRaster => tile_id - end if - - ! Interpolate/aggregate soil depth from raster grid to catchment-tiles - - allocate(soildepth(1:maxcat)) - allocate(count_soil(1:maxcat)) - - soildepth = 0. ! 1-d tile space - count_soil = 0. ! 1-d tile space - - do j=1,ny_adj - do i=1,nx_adj - if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then - if ((raster(i,j).gt.0)) then - soildepth(iRaster(i,j)) = & - soildepth(iRaster(i,j)) + sf*raster(i,j) ! integer "raster" --> real "soildepth" - count_soil(iRaster(i,j)) = & - count_soil(iRaster(i,j)) + 1. - endif - endif - end do - end do - - DO n =1,maxcat - if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) - soildepth(n) = max(soildepth(n),SOILDEPTH_MIN_HWSD) -! soildepth(n) = soildepth(n) + 2000. -! soildepth(n) = min(soildepth(n),8000.) - END DO + if (cFamily(4)/real(i) > PEATMAP_THRESHOLD_2) then + o_cl = 4 + else + if (sum(cFamily(1:3)) > 0.) o_cl = maxloc(cFamily(1:3), dim = 1) ! o_cl = 1, 2, or 3 + endif - deallocate (SOIL_HIGH) - !deallocate (count_soil) ! do not deallocate, needed again shortly - NULLIFY(Raster) - - ! --------------------------------------------------------------------------------- - ! - ! Read NGDC-HWSD-STATSGO merged soil texture from SoilProperties_H[xx]V[yy].nc' - ! - ! get info common to all H[xx]V[yy] rectangles (could in theory differ from that - ! of soildepth data read above but is the same as of 29 Apr 2022). - - if (trim(SOILBCS)=='HWSD_b') then - tmpversion = 'v3' - else if (trim(SOILBCS)=='HWSD') then - tmpversion = 'v2' - else - print *, 'Unknown SOILBCS: ', SOILBCS - stop - end if - - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/' // tmpversion // '/SoilProperties_H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - !status = NF_GET_att_INT(ncid,NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) ! cannot be needed here - !status = NF_GET_att_INT(ncid,NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) ! cannot be needed here - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lon_global',i_highd); VERIFY_(STATUS) - status = NF_GET_att_INT(ncid,NF_GLOBAL,'N_lat_global',j_highd); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,1,string, nc_10); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,2,string, nr_10); VERIFY_(STATUS) - status = NF_CLOSE(ncid) - - ! SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022: - ! - ! Associated 43200-by-21600 global grid (1/120=0.083333 deg lat/lon): - ! - ! N_lon_global = i_highd = 43200 - ! N_lat_global = j_highd = 21600 - ! - ! i_ind_offset_LL = iLL = 42001 - ! j_ind_offset_LL = jLL = 19201 - ! - ! Each file contains soil texture data for one rectangle of size 1200-by-1200, which is - ! assumed to be the same for each H[xx]V[yy] rectangle - ! - ! N_lon = nc_10 = 1200 - ! N_lat = nr_10 = 1200 - - !regrid = nx/=i_highd .or. ny/=j_highd ! not needed here, done below - - allocate(net_data1 (1:nc_10,1:nr_10)) - allocate(net_data2 (1:nc_10,1:nr_10)) - allocate(net_data3 (1:nc_10,1:nr_10)) - allocate(net_data4 (1:nc_10,1:nr_10)) - allocate(net_data5 (1:nc_10,1:nr_10)) - allocate(net_data6 (1:nc_10,1:nr_10)) - allocate(net_data7 (1:nc_10,1:nr_10)) - - allocate(sand_top (1:i_highd,1:j_highd)) - allocate(clay_top (1:i_highd,1:j_highd)) - allocate(oc_top (1:i_highd,1:j_highd)) - allocate(sand_sub (1:i_highd,1:j_highd)) - allocate(clay_sub (1:i_highd,1:j_highd)) - allocate(oc_sub (1:i_highd,1:j_highd)) - allocate(grav_grid(1:i_highd,1:j_highd)) - - sand_top = -9999 ! integer*2 - clay_top = -9999 ! integer*2 - oc_top = -9999 ! integer*2 - sand_sub = -9999 ! integer*2 - clay_sub = -9999 ! integer*2 - oc_sub = -9999 ! integer*2 - grav_grid= -9999 ! integer*2 - - do jx = 1,18 - do ix = 1,36 - write (vv,'(i2.2)')jx - write (hh,'(i2.2)')ix - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/' // tmpversion // '/SoilProperties_H'//hh//'V'//vv//'.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid) - if(status == 0) then - status = NF_GET_att_INT (ncid, NF_GLOBAL,'i_ind_offset_LL',iLL); VERIFY_(STATUS) - status = NF_GET_att_INT (ncid, NF_GLOBAL,'j_ind_offset_LL',jLL); VERIFY_(STATUS) - ! assume UNDEF and ScaleFactor (sf) are the same for *all* variables read below - ! (ok for SoilProperties_H[xx]V[yy].nc as of 29 Apr 2022). - status = NF_GET_att_INT (ncid, 4,'UNDEF',d_undef); VERIFY_(STATUS) - status = NF_GET_att_REAL (ncid, 4,'ScaleFactor',sf); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 4,(/1,1/),(/nc_10,nr_10/),net_data1); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 5,(/1,1/),(/nc_10,nr_10/),net_data2); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 6,(/1,1/),(/nc_10,nr_10/),net_data3); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 7,(/1,1/),(/nc_10,nr_10/),net_data4); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 8,(/1,1/),(/nc_10,nr_10/),net_data5); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid, 9,(/1,1/),(/nc_10,nr_10/),net_data6); VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid,10,(/1,1/),(/nc_10,nr_10/),net_data7); VERIFY_(STATUS) - do j = jLL,jLL + nr_10 -1 - do i = iLL, iLL + nc_10 -1 - if(net_data1(i-iLL +1 ,j - jLL +1) /= d_undef) & - clay_top(i,j) = net_data1(i-iLL +1 ,j - jLL +1) - if(net_data2(i-iLL +1 ,j - jLL +1) /= d_undef) & - sand_top(i,j) = net_data2(i-iLL +1 ,j - jLL +1) - if(net_data3(i-iLL +1 ,j - jLL +1) /= d_undef) & - oc_top (i,j) = net_data3(i-iLL +1 ,j - jLL +1) - if(net_data4(i-iLL +1 ,j - jLL +1) /= d_undef) & - clay_sub(i,j) = net_data4(i-iLL +1 ,j - jLL +1) - if(net_data5(i-iLL +1 ,j - jLL +1) /= d_undef) & - sand_sub(i,j) = net_data5(i-iLL +1 ,j - jLL +1) - if(net_data6(i-iLL +1 ,j - jLL +1) /= d_undef) & - oc_sub (i,j) = net_data6(i-iLL +1 ,j - jLL +1) - if(net_data7(i-iLL +1 ,j - jLL +1) /= d_undef) & - grav_grid(i,j) = net_data7(i-iLL +1 ,j - jLL +1) - enddo - enddo - status = NF_CLOSE(ncid) - endif - end do - end do + endif - deallocate (net_data1) - deallocate (net_data2) - deallocate (net_data3) - deallocate (net_data4) - deallocate (net_data5) - deallocate (net_data6) - deallocate (net_data7) - - ! ---------------------------------------------------------------------------- - if(use_PEATMAP) then - print *, 'PEATMAP_THRESHOLD_1 : ', PEATMAP_THRESHOLD_1 - allocate(pmapr (1:i_highd,1:j_highd)) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/PEATMAP_mask.nc4', NF_NOWRITE, ncid) - status = NF_GET_VARA_REAL (ncid,NC_VarID(NCID,'PEATMAP'), (/1,1/),(/i_highd, j_highd/), pmapr) ; VERIFY_(STATUS) + ! determine aggregate/dominant orgC *profile* (0-100) soil class ("o_clp") of tile n, + ! weight factor=1. for top (0-30) layer and weight factor=2.33 for sub (30-100) layer - ! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat + cFamily = 0. - where (oc_sub*sf >= cF_lim(4)) - oc_sub = NINT(8./sf) - endwhere + do j=1,2*i + if(j <= i) factor = 1. + if(j > i) factor = 2.33 + if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor + if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor + if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor + if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor + end do - ! Hybridize: add OC 1km PEATMAP pixels to HWSD oc_top + ! NOTE: For PEATMAP, oc_sub was cut back to 8./sf above: + ! "! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat" + ! "where (oc_sub*sf >= cF_lim(4)) " + ! " oc_sub = NINT(8./sf) " + ! "endwhere " + ! For PEATMAP, the sub-layer weight of 2.33 should only count towards cFamily(1:3), and in most cases the + ! maxloc statement below should therefore result in o_clp = 1, 2, or 3 only. However, if the top-layer orgC + ! is peat for most contributing raster grid cells and the sub-layer orgC values are relatively evenly spread + ! over orgC classes 1, 2, and 3, then maxloc(cFamily) can result in o_clp=4. + + if (sum(cFamily) == 0.) o_clp = 1 + if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) + + ! ---------------------------------------------------------------------------------------- + ! + ! Determine *top* layer mineral/organic soil class of tile n + + if(o_cl == 4) then + + ! Top-layer soil class of tile n is peat. + ! Compute average top-layer orgC (only across raster grid cells whose top layer is peat). + + soil_class_top(n) = n_SoilClasses + ktop = 0 + do j=1,i + ! avg only across contributing raster grid cells that are peat + if(ss_oc_all(j)*sf >= cF_lim(4)) then + soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf + ktop = ktop + 1 + endif + end do + if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop + !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used - where (pmapr >= PEATMAP_THRESHOLD_1) - oc_top = NINT(33.0/sf) - endwhere + else - deallocate (pmapr) - status = NF_CLOSE(ncid) - endif - - ! ---------------------------------------------------------------------------- - - ! Regridding - - ! *EASE* grid bcs use mask file GEOS5_10arcsec_mask.nc or GEOS5_10arcsec_mask_freshwater-lakes.nc, - ! and the make_bcs script assigns NX=43200, NY=21600, which are passed into the present subroutine - ! via command-line arguments of mkCatchParam.x. That is, should have regrid=.false. for *EASE* - ! grid tile space. - - nx_adj = nx - ny_adj = ny - - regrid = nx/=i_highd .or. ny/=j_highd - - if(regrid) then - if(nx > i_highd) then - allocate(raster1(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(clay_top,raster1) - - allocate(raster2(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(sand_top,raster2) - - allocate(raster3(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(oc_top, raster3) - - allocate(raster4(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(clay_sub,raster4) - - allocate(raster5(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(sand_sub,raster5) - - allocate(raster6(nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(oc_sub, raster6) - - allocate(raster (nx,ny),stat=STATUS); VERIFY_(STATUS) - call RegridRaster2(grav_grid,raster) - - iRaster => tile_id - - if(ny < j_highd) then - print *,'nx > i_highd and ny < j_highd' - stop - endif - else - nx_adj = i_highd - ny_adj = j_highd - if( .not.associated(iraster) ) then - allocate(iRaster(i_highd,j_highd),stat=STATUS); VERIFY_(STATUS) - endif - call RegridRaster(tile_id,iRaster) - - raster1 => clay_top - raster2 => sand_top - raster3 => oc_top - raster4 => clay_sub - raster5 => sand_sub - raster6 => oc_sub - raster => grav_grid - - if(ny > j_highd) then - print *,'nx < i_highd and ny > j_highd' - stop - endif - endif - else - iRaster => tile_id - raster1 => clay_top - raster2 => sand_top - raster3 => oc_top - raster4 => clay_sub - raster5 => sand_sub - raster6 => oc_sub - raster => grav_grid - end if - - ! ---------------------------------------------------------------------------- - - ! compute peat fraction on tile for CLM45+ (for fires?) - - allocate(pmap (1:maxcat)) - !allocate(count_soil(1:maxcat)) ! already allocated above - - pmap = 0. ! 1-d tile space; peat fraction in tile based on oc_top - count_soil = 0. ! 1-d tile space - - do j=1,ny_adj - do i=1,nx_adj - if((iRaster(i,j).gt.0).and.(iRaster(i,j).le.maxcat)) then - count_soil(iRaster(i,j)) = count_soil(iRaster(i,j)) + 1. - if (raster3(i,j)*sf >= cF_lim(4)) then - pmap (iRaster(i,j)) = pmap(iRaster(i,j)) + 1 - endif - endif - end do - end do - - where (count_soil > 0) pmap = pmap /count_soil - - !deallocate (count_soil) ! do not deallocate, needed again shortly - - ! ---------------------------------------------------------------------------- - - ! get number of "land" pixels (i1) on raster grid - - allocate(land_pixels(1:size(iRaster,1),1:size(iRaster,2))) - land_pixels = (iRaster >=1).and.(iRaster<=maxcat) - i1 = count(land_pixels) - deallocate (land_pixels) - - ! allocate 1-d arrays for all "land" pixels on raster grid - - allocate (tileid_vec(1:i1)) - allocate (data_vec1 (1:i1)) - allocate (data_vec2 (1:i1)) - allocate (data_vec3 (1:i1)) - allocate (data_vec4 (1:i1)) - allocate (data_vec5 (1:i1)) - allocate (data_vec6 (1:i1)) - - ! allocate 1-d arrays for all "land" tiles - - allocate (grav_vec (1:maxcat)) - allocate (soc_vec (1:maxcat)) - allocate (poc_vec (1:maxcat)) - !allocate (ncells_top (1:maxcat)) ! ncells_* not used - !allocate (ncells_top_pro (1:maxcat)) ! ncells_* not used - !allocate (ncells_sub_pro (1:maxcat)) ! ncells_* not used - !allocate(count_soil(1:maxcat)) - - count_soil = 0. - grav_vec = 0. - soc_vec = 0. ! soil orgC (top layer 0-30) - poc_vec = 0. ! soil orgC (profile layer 0-100) - - !ncells_top = 0. ! ncells_* not used - !ncells_top_pro = 0. ! ncells_* not used - !ncells_sub_pro = 0. ! ncells_* not used - - n =1 - do j=1,ny_adj - do i=1,nx_adj - if((iRaster(i,j).ge.1).and.(iRaster(i,j).le.maxcat)) then - - ! map from 2-d raster array to 1-d raster vec - - tileid_vec (n) = iRaster(i,j) ! iRaster => tile_id int*4 - data_vec1 (n) = Raster1(i,j) ! raster1 => clay_top int*2 - data_vec2 (n) = Raster2(i,j) ! raster2 => sand_top int*2 - data_vec3 (n) = Raster3(i,j) ! raster3 => oc_top int*2 - data_vec4 (n) = Raster4(i,j) ! raster4 => clay_sub int*2 - data_vec5 (n) = Raster5(i,j) ! raster5 => sand_sub int*2 - data_vec6 (n) = Raster6(i,j) ! raster6 => oc_sub int*2 - - ! BUG??? It is unclear why here grav_vec is filled in the order of "tile_id" - ! while data_vec[x] is filled in the order of the long/lat grid. - ! Not sure if grav_vec is processed correctly below! - ! -reichle, 29 Apr 2022 - - if ((raster(i,j).gt.0)) then - grav_vec(iRaster(i,j)) = & - grav_vec(iRaster(i,j)) + sf*raster(i,j) ! raster => grav_grid int*2 - count_soil(iRaster(i,j)) = & - count_soil(iRaster(i,j)) + 1. - endif - n = n + 1 - endif - end do - end do - - DO n =1,maxcat - if(count_soil(n)/=0.) grav_vec(n)=grav_vec(n)/count_soil(n) - END DO - - deallocate (count_soil) - NULLIFY(Raster,Raster1,Raster2,Raster3,Raster4,Raster5,Raster6) - deallocate (clay_top,sand_top,oc_top,clay_sub,sand_sub,oc_sub,grav_grid) - deallocate (tile_id) - - ! sort 1-d land pixels vectors according to tile_id - - allocate (arrayA (1:i1)) ! 1-d land pixels on raster grid - allocate (arrayB (1:i1)) ! 1-d land pixels on raster grid - - arrayA = tileid_vec - arrayB = data_vec1 - call MAPL_Sort (arrayA, arrayB) - data_vec1 = arrayB - - arrayA = tileid_vec - arrayB = data_vec2 - call MAPL_Sort (arrayA, arrayB) - data_vec2 = arrayB - - arrayA = tileid_vec - arrayB = data_vec3 - call MAPL_Sort (arrayA, arrayB) - data_vec3 = arrayB - - arrayA = tileid_vec - arrayB = data_vec4 - call MAPL_Sort (arrayA, arrayB) - data_vec4 = arrayB - - arrayA = tileid_vec - arrayB = data_vec5 - call MAPL_Sort (arrayA, arrayB) - data_vec5 = arrayB - - arrayA = tileid_vec - arrayB = data_vec6 - call MAPL_Sort (arrayA, arrayB) - data_vec6 = arrayB - - tileid_vec= arrayA - - deallocate (arrayA, arrayB) - - ! -------------------------------------------------------------------- - ! - ! Read Woesten soil parameters and CLSM tau parameters for soil classes (1:253) - - allocate(a_sand (1:n_SoilClasses)) - allocate(a_clay (1:n_SoilClasses)) - allocate(a_silt (1:n_SoilClasses)) - allocate(a_oc (1:n_SoilClasses)) - allocate(a_bee (1:n_SoilClasses)) - allocate(a_psis (1:n_SoilClasses)) - allocate(a_poros (1:n_SoilClasses)) - allocate(a_wp (1:n_SoilClasses)) - allocate(a_aksat (1:n_SoilClasses)) - allocate(atau (1:n_SoilClasses)) - allocate(btau (1:n_SoilClasses)) - allocate(atau_2cm(1:n_SoilClasses)) - allocate(btau_2cm(1:n_SoilClasses)) - allocate(a_wpsurf(1:n_SoilClasses)) - allocate(a_porosurf(1:n_SoilClasses)) - - ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ - ! only in the parameters for the peat class #253. The file *.peatmap contains - ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). - ! - ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND - ! - ! K_s COND [m/s] - ! NLv4 7.86e-7 5.81e-6 - ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 - - if(use_PEATMAP) then - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.peatmap' - else - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat' - endif + ! Top-layer soil class of tile n is mineral. + ! Compute average top-layer orgC (only across raster grid cells within same orgC class) + ! and collect all clay/sand pairs of raster grid cells within same orgC class. + + !k = 1 !cleanup k counter + !ktop = 1 !cleanup k counter + ktop = 0 !cleanup k counter - table_map = 0 ! 100-by-3 look-up table + do j=1,i ! loop only through top-layer elements of ss_*_all - open (11, file=trim(fname), form='formatted',status='old', & - action = 'read') - read (11,'(a)')fout ! read header line + ! avg only across contributing raster grid cells with orgC class as that assigned to tile n + if((ss_oc_all(j)*sf >= cF_lim(o_cl)).and.(ss_oc_all(j)*sf < cF_lim(o_cl + 1))) then + + if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values - do n =1,n_SoilClasses + ktop = ktop + 1 !cleanup k counter + ss_clay (ktop) = ss_clay_all(j) + ss_sand (ktop) = ss_sand_all(j) - read (11,'(4f7.3,4f8.4,e13.5,2f12.7,2f8.4,4f12.7)')a_sand(n),a_clay(n),a_silt(n),a_oc(n),a_bee(n),a_psis(n), & - a_poros(n),a_wp(n),a_aksat(n),atau(n),btau(n),a_wpsurf(n),a_porosurf(n),atau_2cm(n),btau_2cm(n) + ! adjust clay and sand content if outside joint physical bounds + if((ss_clay (ktop) + ss_sand (ktop)) > 9999) then ! note: 9999 = 99.99% (scale factor = 0.01) + if(ss_clay (ktop) >= ss_sand (ktop)) then + ss_sand (ktop) = 10000 - ss_clay (ktop) + else + ss_clay (ktop) = 10000 - ss_sand (ktop) + endif + endif + soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf ! sum up top-layer orgC + !k = k + 1 !cleanup k counter + !ktop = ktop + 1 !cleanup k counter + endif + endif + end do - ! assemble scalar structure that holds mineral percentages of soil class n + !k = k - 1 !cleanup k counter + !ktop = ktop -1 !cleanup k counter - min_percs%clay_perc = a_clay(n) - min_percs%silt_perc = a_silt(n) - min_percs%sand_perc = a_sand(n) - - ! "soil_class" is an integer function (see rmTinyCatchParam.F90) that assigns - ! an integer (mineral) soil class [1-100] for a given mineral percentage triplet - - ! "table_map" is a 2-d array (100-by-3) that maps between overall soil class (1:252) and - ! (mineral_class 1:84, orgC_class). "table_map" has no entry for the peat class #253. - - if( n <= nsoil_pcarbon(1)) table_map(soil_class (min_percs),1) = n - if((n > nsoil_pcarbon(1)).and.(n <= nsoil_pcarbon(2))) table_map(soil_class (min_percs),2) = n - if((n > nsoil_pcarbon(2)).and.(n <= nsoil_pcarbon(3))) table_map(soil_class (min_percs),3) = n - - end do ! n=1,n_SoilClasses - - close (11,status='keep') - - ! ------------------------------------------------------------ - ! - ! When Woesten soil parameters are not available for a particular soil class, - ! as defined by "tiny" triangles in HWSD soil triangle, Woesten soil - ! parameters from the nearest available "tiny" triangle will be substituted. - ! For "tiny" triangles, see Fig 1b of De Lannoy et al. 2014 (doi:10.1002/2014MS000330). - - do n =1,10 - do k=1,n*2 -1 - - min_percs%clay_perc = 100. -((n-1)*10 + 5) - min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - - i = soil_class (min_percs) - - if(table_map (i,1)== 0) then - j = center_pix (a_clay(1:nsoil_pcarbon(1)),a_sand(1:nsoil_pcarbon(1)), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - - min_percs%clay_perc = a_clay(j) - min_percs%silt_perc = a_silt(j) - min_percs%sand_perc = a_sand(j) - table_map (i,1)= table_map (soil_class (min_percs),1) - endif - - min_percs%clay_perc = 100. -((n-1)*10 + 5) - min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - - if(table_map (i,2)== 0) then - j = center_pix(a_clay(nsoil_pcarbon(1)+1 : nsoil_pcarbon(2)), & - a_sand(nsoil_pcarbon(1)+1 : nsoil_pcarbon(2)), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - min_percs%clay_perc = a_clay(j + nsoil_pcarbon(1)) - min_percs%silt_perc = a_silt(j + nsoil_pcarbon(1)) - min_percs%sand_perc = a_sand(j + nsoil_pcarbon(1)) - table_map (i,2)= table_map (soil_class (min_percs),2) - endif - - min_percs%clay_perc = 100. -((n-1)*10 + 5) - min_percs%sand_perc = 100. - min_percs%clay_perc -2.-(k-1)*5. - min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc - - if(table_map (i,3)== 0) then - j = center_pix (a_clay(nsoil_pcarbon(2)+1 : nsoil_pcarbon(3)), & - a_sand(nsoil_pcarbon(2)+1 : nsoil_pcarbon(3)), & - min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) - min_percs%clay_perc = a_clay(j + nsoil_pcarbon(2)) - min_percs%silt_perc = a_silt(j + nsoil_pcarbon(2)) - min_percs%sand_perc = a_sand(j + nsoil_pcarbon(2)) - table_map (i,3)= table_map (soil_class (min_percs),3) - endif - end do - end do -! -! Now deriving soil types based on NGDC-HWSD-STATSGO merged soil property maps -! - allocate (soil_class_top (1:maxcat)) - allocate (soil_class_com (1:maxcat)) - soil_class_top =-9999 - soil_class_com =-9999 - - allocate(low_ind(n_threads)) - allocate(upp_ind(n_threads)) - low_ind(1) = 1 - upp_ind(n_threads) = maxcat - - if (running_omp) then - do i=1,n_threads-1 - upp_ind(i) = low_ind(i) + (maxcat/n_threads) - 1 - low_ind(i+1) = upp_ind(i) + 1 - end do - end if - -!$OMP PARALLELDO DEFAULT(NONE) & -!$OMP SHARED( n_threads, low_ind, upp_ind, tileid_vec, & -!$OMP sf,data_vec1,data_vec2,data_vec3, & -!$OMP data_vec4,data_vec5,data_vec6,cF_lim, & -!$OMP table_map,soil_class_top,soil_class_com, & -!$OMP soc_vec,poc_vec,use_PEATMAP) & -!ncells_* not used !$OMP soc_vec,poc_vec,ncells_top,ncells_top_pro,& -!ncells_* not used !$OMP ncells_sub_pro,use_PEATMAP) & -!$OMP PRIVATE(n,i,j,k,icount,t_count,i1,i2,ss_clay, & -!$OMP ss_sand,ss_clay_all,ss_sand_all, & -!$OMP ss_oc_all,cFamily,factor,o_cl,o_clp,ktop, & -!$OMP min_percs, fac_count, write_debug) + if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop ! normalize top-layer orgC - ! loop through tiles (split into two loops for OpenMP) + !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used - DO t_count = 1,n_threads - DO n = low_ind(t_count),upp_ind(t_count) + ! debugging output + if (write_debug) write(80+n,*)ktop,o_cl + if(ktop > 0 .and. write_debug) then + write (80+n,*)ss_clay(1:ktop) + write (80+n,*)ss_sand(1:ktop) + endif - write_debug = .false. + ! Determine the raster grid cell j that has (top-layer) clay/sand content closest + ! to the average (top-layer) clay/sand across all raster grid cells within the + ! dominant orgC class. -! if (n==171010) write_debug = .true. + j = center_pix_int0(sf, ktop,ktop, ss_clay(1:ktop),ss_sand(1:ktop)) - ! initialize "icount" when starting loop through n at low_ind(t_count) - ! recall: tileid_vec is a 1-d vector that covers all land pixels on the raster grid that - ! contains the (sorted) tile IDs, with matching parameter vectors data_vec[x] + ! Assign soil class of raster grid cell j to tile n - if(n==low_ind(t_count)) then - icount = 1 - ! Not sure what the following loops do. Why not check backwards from low_ind(t_count)?? - do k=1,low_ind(t_count) - 1 - do while (tileid_vec(icount)== k) - icount = icount + 1 - end do - end do - endif - - ! ------------------------------------------------------------------ - ! - ! determine the land raster grid cells i1:i2 that make up tile n - - ! NOTE change in meaning of "i1": - ! - ! before: i1 = total no. of land pixels on the raster grid - ! now: i1 = starting index of land raster grid cells (within 1-d vector) that make up tile n (?) - - i1 = icount - - loop: do while (tileid_vec(icount)== n) - if(icount <= size(tileid_vec,1)) icount = icount + 1 - if(icount > size(tileid_vec,1)) exit loop - end do loop - - i2 = icount -1 - i = i2 - i1 + 1 ! number of land raster grid cells that make up tile n (?) - - - ! ------------------------------------------------------------------- - ! - ! prep data - - allocate(ss_clay (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? - allocate(ss_sand (1:2*i)) ! for top layer (0-30) -- why allocate 1:2*i and not 1:i?? - - allocate(ss_clay_all(1:2*i)) ! for top (0-30) and sub (30-100) layers - allocate(ss_sand_all(1:2*i)) ! for top (0-30) and sub (30-100) layers - allocate(ss_oc_all (1:2*i)) ! for top (0-30) and sub (30-100) layers - - ss_clay = 0 ! int*2 -- why only clay and sand for top layer and not orgC ?? - ss_sand = 0 ! int*2 - - ss_clay_all= 0 ! int*2 - ss_sand_all= 0 ! int*2 - ss_oc_all = 0 ! int*2 - - ss_clay_all (1:i) = data_vec1(i1:i2) ! put top layer info into first i elements (1:i) - ss_sand_all (1:i) = data_vec2(i1:i2) - ss_oc_all (1:i) = data_vec3(i1:i2) - - ss_clay_all (1+i:2*i) = data_vec4(i1:i2) ! put sub layer info into next i elements (i+1:2*i) - ss_sand_all (1+i:2*i) = data_vec5(i1:i2) - ss_oc_all (1+i:2*i) = data_vec6(i1:i2) ! <-- oc_sub - - - ! ----------------------------------------------------------------------- - ! - ! determine aggregate/dominant orgC *top* layer soil class ("o_cl") of tile n - - cFamily = 0. -!! factor = 1. - - do j=1,i - if(j <= i) factor = 1. - if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor - if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor - if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor - if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor - end do - - if (sum(cFamily) == 0.) o_cl = 1 ! default is o_cl=1 (if somehow no grid cell has top-layer orgC >=0.) - -!! if (.not. use_PEATMAP) then - - ! assign dominant *top* layer org soil class (even if only a minority of the contributing - ! raster grid cells is peat) - - if (sum(cFamily) > 0.) o_cl = maxloc(cFamily, dim = 1) - -!! else - - if (use_PEATMAP) then - - ! PEATMAP: tile has *top* layer peat class only if more than 50% of the contributing - ! raster grid cells are peat (may loose some peat tiles w.r.t. non-PEATMAP bcs version) - - if (cFamily(4)/real(i) > PEATMAP_THRESHOLD_2) then - o_cl = 4 - else - if (sum(cFamily(1:3)) > 0.) o_cl = maxloc(cFamily(1:3), dim = 1) ! o_cl = 1, 2, or 3 - endif - - endif - - - ! determine aggregate/dominant orgC *profile* (0-100) soil class ("o_clp") of tile n, - ! weight factor=1. for top (0-30) layer and weight factor=2.33 for sub (30-100) layer - - cFamily = 0. - - do j=1,2*i - if(j <= i) factor = 1. - if(j > i) factor = 2.33 - if((ss_oc_all(j)*sf >= cF_lim(1)).and. (ss_oc_all(j)*sf < cF_lim(2))) cFamily(1) = cFamily(1) + factor - if((ss_oc_all(j)*sf >= cF_lim(2)).and. (ss_oc_all(j)*sf < cF_lim(3))) cFamily(2) = cFamily(2) + factor - if((ss_oc_all(j)*sf >= cF_lim(3)).and. (ss_oc_all(j)*sf < cF_lim(4))) cFamily(3) = cFamily(3) + factor - if((ss_oc_all(j)*sf >= cF_lim(4) )) cFamily(4) = cFamily(4) + factor - end do - - ! NOTE: For PEATMAP, oc_sub was cut back to 8./sf above: - ! "! move HWSD sub-surface peat to peat-rich mineral Group 3 because merged surface peat defines sub-surface peat" - ! "where (oc_sub*sf >= cF_lim(4)) " - ! " oc_sub = NINT(8./sf) " - ! "endwhere " - ! For PEATMAP, the sub-layer weight of 2.33 should only count towards cFamily(1:3), and in most cases the - ! maxloc statement below should therefore result in o_clp = 1, 2, or 3 only. However, if the top-layer orgC - ! is peat for most contributing raster grid cells and the sub-layer orgC values are relatively evenly spread - ! over orgC classes 1, 2, and 3, then maxloc(cFamily) can result in o_clp=4. - - if (sum(cFamily) == 0.) o_clp = 1 - if (sum(cFamily) > 0.) o_clp = maxloc(cFamily, dim = 1) - - ! ---------------------------------------------------------------------------------------- - ! - ! Determine *top* layer mineral/organic soil class of tile n - - if(o_cl == 4) then - - ! Top-layer soil class of tile n is peat. - ! Compute average top-layer orgC (only across raster grid cells whose top layer is peat). - - soil_class_top(n) = n_SoilClasses - ktop = 0 - do j=1,i - ! avg only across contributing raster grid cells that are peat - if(ss_oc_all(j)*sf >= cF_lim(4)) then - soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf - ktop = ktop + 1 + if(j >=1) then + min_percs%clay_perc = ss_clay(j)*sf + min_percs%sand_perc = ss_sand(j)*sf + min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf + soil_class_top (n) = table_map(soil_class (min_percs),o_cl) endif - end do - if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop - !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used - else - - ! Top-layer soil class of tile n is mineral. - ! Compute average top-layer orgC (only across raster grid cells within same orgC class) - ! and collect all clay/sand pairs of raster grid cells within same orgC class. + ! debugging output + if (write_debug) write(80+n,*)j - !k = 1 !cleanup k counter - !ktop = 1 !cleanup k counter - ktop = 0 !cleanup k counter + endif ! o_cl==4 - do j=1,i ! loop only through top-layer elements of ss_*_all + ! debugging output + if (write_debug) write(80+n,*)soil_class_top (n) - ! avg only across contributing raster grid cells with orgC class as that assigned to tile n - if((ss_oc_all(j)*sf >= cF_lim(o_cl)).and.(ss_oc_all(j)*sf < cF_lim(o_cl + 1))) then + ! ------------------------------------------------------------------------------- + ! + ! determine aggregate sand/clay/orgC for *profile* layer of tile n - if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values + if(o_clp == 4) then - ktop = ktop + 1 !cleanup k counter - ss_clay (ktop) = ss_clay_all(j) - ss_sand (ktop) = ss_sand_all(j) - - ! adjust clay and sand content if outside joint physical bounds - if((ss_clay (ktop) + ss_sand (ktop)) > 9999) then ! note: 9999 = 99.99% (scale factor = 0.01) - if(ss_clay (ktop) >= ss_sand (ktop)) then - ss_sand (ktop) = 10000 - ss_clay (ktop) - else - ss_clay (ktop) = 10000 - ss_sand (ktop) - endif - endif - soc_vec (n) = soc_vec(n) + ss_oc_all(j)*sf ! sum up top-layer orgC - !k = k + 1 !cleanup k counter - !ktop = ktop + 1 !cleanup k counter - endif - endif - end do - - !k = k - 1 !cleanup k counter - !ktop = ktop -1 !cleanup k counter - - if(ktop.ne.0) soc_vec (n) = soc_vec(n)/ktop ! normalize top-layer orgC - - !ncells_top(n) = 100.*float(ktop)/float(i) ! ncells_* not used - - ! debugging output - if (write_debug) write(80+n,*)ktop,o_cl - if(ktop > 0) then - if (write_debug) write (80+n,*)ss_clay(1:ktop) - if (write_debug) write (80+n,*)ss_sand(1:ktop) - endif - - ! Determine the raster grid cell j that has (top-layer) clay/sand content closest - ! to the average (top-layer) clay/sand across all raster grid cells within the - ! dominant orgC class. - - j = center_pix_int0(sf, ktop,ktop, ss_clay(1:ktop),ss_sand(1:ktop)) - - ! Assign soil class of raster grid cell j to tile n - - if(j >=1) then - min_percs%clay_perc = ss_clay(j)*sf - min_percs%sand_perc = ss_sand(j)*sf - min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf - soil_class_top (n) = table_map(soil_class (min_percs),o_cl) - endif - - ! debugging output - if (write_debug) write(80+n,*)j - - endif - - ! debugging output - if (write_debug) write(80+n,*)soil_class_top (n) - - ! ------------------------------------------------------------------------------- - ! - ! determine aggregate sand/clay/orgC for *profile* layer of tile n - - if(o_clp == 4) then - - ! Profile-layer soil class of tile n is peat. - ! Compute average profile-layer orgC (only across raster grid cells and layers that are peat) - - soil_class_com(n) = n_SoilClasses - fac_count = 0. - k =0 - ktop =0 - do j=1,2*i - if(ss_oc_all(j)*sf >= cF_lim(4)) then - if(j <= i) factor = 1. ! top layer contribution 1 <= j <=i - if(j > i) factor = 2.33 ! sub layer contribution i+1 <= j <=2*i - if(j > i) k = k + 1 ! sub layer counter - if(j <= i) ktop = ktop + 1 ! top layer counter - poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC - fac_count = fac_count + factor ! sum of weights - endif - end do - if(fac_count.ne.0) poc_vec (n) = poc_vec (n)/fac_count ! normalize - !ncells_sub_pro(n) = 100.*float(k)/float(i) ! ncells_* not used - !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used - else - - ! Profile-layer soil class of tile n is mineral. - ! Compute average profile-layer orgC (only across raster grid cells within same orgC class) - ! and collect all clay/sand pairs of raster grid cells within same orgC class. - - !k = 1 !cleanup k counter - !ktop = 1 !cleanup k counter - k = 0 !cleanup k counter - ktop = 0 !cleanup k counter - - ss_clay=0 - ss_sand=0 - fac_count = 0. - - do j=1,2*i ! loop through both top (1<=j<=i) layer and sub (i+1<=j<=2*i) layer elements - + ! Profile-layer soil class of tile n is peat. + ! Compute average profile-layer orgC (only across raster grid cells and layers that are peat) + + soil_class_com(n) = n_SoilClasses + fac_count = 0. + k =0 + ktop =0 + do j=1,2*i + if(ss_oc_all(j)*sf >= cF_lim(4)) then + if(j <= i) factor = 1. ! top layer contribution 1 <= j <=i + if(j > i) factor = 2.33 ! sub layer contribution i+1 <= j <=2*i + if(j > i) k = k + 1 ! sub layer counter + if(j <= i) ktop = ktop + 1 ! top layer counter + poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC + fac_count = fac_count + factor ! sum of weights + endif + end do + if(fac_count.ne.0) poc_vec (n) = poc_vec (n)/fac_count ! normalize + !ncells_sub_pro(n) = 100.*float(k)/float(i) ! ncells_* not used + !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used + else + + ! Profile-layer soil class of tile n is mineral. + ! Compute average profile-layer orgC (only across raster grid cells within same orgC class) + ! and collect all clay/sand pairs of raster grid cells within same orgC class. + + !k = 1 !cleanup k counter + !ktop = 1 !cleanup k counter + k = 0 !cleanup k counter + ktop = 0 !cleanup k counter + + ss_clay=0 + ss_sand=0 + fac_count = 0. + + do j=1,2*i ! loop through both top (1<=j<=i) layer and sub (i+1<=j<=2*i) layer elements ! avg only across contributing raster grid cells and layers with orgC class as that assigned to tile n - if((ss_oc_all(j)*sf >= cF_lim(o_clp)).and.(ss_oc_all(j)*sf < cF_lim(o_clp + 1))) then + if((ss_oc_all(j)*sf >= cF_lim(o_clp)).and.(ss_oc_all(j)*sf < cF_lim(o_clp + 1))) then if((ss_clay_all(j)*sf >= 0.).and.(ss_sand_all(j)*sf >= 0.)) then ! avoiding no-data-values - if(j <= i) factor = 1. ! top layer contribution - if(j > i) factor = 2.33 ! sub layer contribution + if(j <= i) factor = 1. ! top layer contribution + if(j > i) factor = 2.33 ! sub layer contribution - poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC - fac_count = fac_count + factor + poc_vec (n) = poc_vec(n) + ss_oc_all(j)*sf*factor ! weighted sum of orgC + fac_count = fac_count + factor k = k + 1 ! counter for top and sub contributions !cleanup k counter - + if (j<=i) ktop = ktop + 1 ! counter for top contributions only !cleanup k counter -!obsolete20220502 The code within the if-then and if-else statements below was nearly identical, -!obsolete20220502 except for the omission of the ktop counter from the else block. -!obsolete20220502 -!obsolete20220502 if(j <= i) then + !obsolete20220502 The code within the if-then and if-else statements below was nearly identical, + !obsolete20220502 except for the omission of the ktop counter from the else block. + !obsolete20220502 + !obsolete20220502 if(j <= i) then ss_clay (k) = ss_clay_all(j) ss_sand (k) = ss_sand_all(j) @@ -4686,463 +4464,456 @@ SUBROUTINE soil_para_hwsd (nx,ny,fnameRst) !k = k + 1 !cleanup k counter !ktop = ktop + 1 !cleanup k counter -!obsolete20220502 else -!obsolete20220502 ss_clay (k) = ss_clay_all(j) -!obsolete20220502 ss_sand (k) = ss_sand_all(j) -!obsolete20220502 if((ss_clay (k) + ss_sand (k)) > 9999) then -!obsolete20220502 if(ss_clay (k) >= ss_sand (k)) then -!obsolete20220502 ss_sand (k) = 10000 - ss_clay (k) -!obsolete20220502 else -!obsolete20220502 ss_clay (k) = 10000 - ss_sand (k) -!obsolete20220502 endif -!obsolete20220502 endif -!obsolete20220502 !k = k + 1 !cleanup k counter -!obsolete20220502 endif + !obsolete20220502 else + !obsolete20220502 ss_clay (k) = ss_clay_all(j) + !obsolete20220502 ss_sand (k) = ss_sand_all(j) + !obsolete20220502 if((ss_clay (k) + ss_sand (k)) > 9999) then + !obsolete20220502 if(ss_clay (k) >= ss_sand (k)) then + !obsolete20220502 ss_sand (k) = 10000 - ss_clay (k) + !obsolete20220502 else + !obsolete20220502 ss_clay (k) = 10000 - ss_sand (k) + !obsolete20220502 endif + !obsolete20220502 endif + !obsolete20220502 !k = k + 1 !cleanup k counter + !obsolete20220502 endif endif - endif - end do - - !k = k - 1 !cleanup k counter - !ktop = ktop -1 !cleanup k counter - - if(fac_count.ne.0) poc_vec (n) = poc_vec(n)/fac_count ! normalize profile-layer orgC - - !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used - !ncells_sub_pro(n) = 100.*float(k-ktop)/float(i) ! ncells_* not used - - ! debugging output - if (write_debug) write (80+n,*)ktop,k,o_cl - if (write_debug) write (80+n,*)ss_clay(1:k) - if (write_debug) write (80+n,*)ss_sand(1:k) - - ! Determine the raster grid cell and layer j that has clay/sand content closest - ! to the average (profile) clay/sand across all raster grid cells within the - ! dominant orgC class. - - j = center_pix_int0 (sf, ktop,k, ss_clay(1:k),ss_sand(1:k)) - - ! Assign soil class of raster grid cell and layer j to tile n - - if(j >=1) then - min_percs%clay_perc = ss_clay(j)*sf - min_percs%sand_perc = ss_sand(j)*sf - min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf - soil_class_com (n) = table_map(soil_class (min_percs),o_clp) - endif - - ! debugging output - if (write_debug) write(80+n,*) j - if (write_debug) write(80+n,*) soil_class_com (n) - if (write_debug) close(80+n) - - endif - - deallocate (ss_clay,ss_sand,ss_clay_all,ss_sand_all,ss_oc_all) - - END DO - END DO ! loop through tiles -!$OMP ENDPARALLELDO - -! call process_peatmap (nx, ny, fnameRst, pmap) - - ! ----------------------------------------------------------------------------- - ! - ! apply final touches and write output files: - ! - soil_param.first - ! - tau_param.dat - ! - catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters ONLY; - ! parameters from ar.new, bf.dat, and ts.dat parameters will be - ! added to catch_params.nc4 by subroutine create_model_para_woesten()] - - inquire(file='clsm/catch_params.nc4', exist=CatchParamsNC_file_exists) - - if(CatchParamsNC_file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (parms4file (1:maxcat, 1:10)) - endif + endif + end do + + !k = k - 1 !cleanup k counter + !ktop = ktop -1 !cleanup k counter + + if(fac_count.ne.0) poc_vec (n) = poc_vec(n)/fac_count ! normalize profile-layer orgC + + !ncells_top_pro(n) = 100.*float(ktop)/float(i) ! ncells_* not used + !ncells_sub_pro(n) = 100.*float(k-ktop)/float(i) ! ncells_* not used + + ! debugging output + if (write_debug) write (80+n,*)ktop,k,o_cl + if (write_debug) write (80+n,*)ss_clay(1:k) + if (write_debug) write (80+n,*)ss_sand(1:k) + + ! Determine the raster grid cell and layer j that has clay/sand content closest + ! to the average (profile) clay/sand across all raster grid cells within the + ! dominant orgC class. + + j = center_pix_int0 (sf, ktop,k, ss_clay(1:k),ss_sand(1:k)) + + ! Assign soil class of raster grid cell and layer j to tile n + + if(j >=1) then + min_percs%clay_perc = ss_clay(j)*sf + min_percs%sand_perc = ss_sand(j)*sf + min_percs%silt_perc = 100. - ss_clay(j)*sf - ss_sand(j)*sf + soil_class_com (n) = table_map(soil_class (min_percs),o_clp) + endif + + ! debugging output + if (write_debug) write(80+n,*) j + if (write_debug) write(80+n,*) soil_class_com (n) + if (write_debug) close(80+n) + + endif ! o_clp==4 + + deallocate (ss_clay,ss_sand,ss_clay_all,ss_sand_all,ss_oc_all) + END DO + END DO ! loop through tiles + !$OMP ENDPARALLELDO + + ! call process_peatmap (nx, ny, fnameRst, pmap) + + ! ----------------------------------------------------------------------------- + ! + ! apply final touches and write output files: + ! - soil_param.first + ! - tau_param.dat + ! - catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters ONLY; + ! parameters from ar.new, bf.dat, and ts.dat parameters will be + ! added to catch_params.nc4 by subroutine create_model_para_woesten()] + + inquire(file='clsm/catch_params.nc4', exist=CatchParamsNC_file_exists) + + if(CatchParamsNC_file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:n_land, 1:10)) + endif + + fname ='clsm/soil_param.first' + open (11,file=trim(fname),form='formatted',status='unknown',action = 'write') + + fname ='clsm/tau_param.dat' + open (12,file=trim(fname),form='formatted',status='unknown',action = 'write') + + + !obsolete20220502 fname ='clsm/mosaic_veg_typs_fracs' + !obsolete20220502 open (13,file=trim(fname),form='formatted',status='old',action = 'read') + + do n = 1, n_land + + !obsolete20220502 read (13,*) tindex,pfafindex,vtype - fname ='clsm/soil_param.first' - open (11,file=trim(fname),form='formatted',status='unknown',action = 'write') + ! fill gaps from neighbor for rare missing values caused by inconsistent masks + + if ((soil_class_top (n) == -9999).or.(soil_class_com (n) == -9999)) then + + ! if com-layer has data, the issue is only with top-layer + + if(soil_class_com (n) >= 1) soil_class_top (n) = soil_class_com (n) + + ! if there is nothing, look for the neighbor + ! + ! ^ + ! | + ! | The comment above seems wrong; could have soil_class_top(n)>=1, unless + ! earlier soil_class_com was set equal to soil_class_top whenever + ! soil_class_top was available and soil_class_com was not. + + if (soil_class_com (n) == -9999) then + + ! Look for neighbor j (regardless of soil_class_top) and set both + ! soil_class_com(n) and soil_class_top(n) equal to the neighbor's + ! soil_class_com(j). + + do k = 1, n_land + j = 0 + i1 = n - k + i2 = n + k + if(i1 >= 1) then + if (soil_class_com (i1) >=1) j = i1 ! tentatively use "lower" neighbor unless out of range + endif + + if(1 <= i2 .and. i2 <=n_land) then + if (soil_class_com (i2) >=1) j = i2 ! "upper" neighbor prevails unless out of range + endif + + if (j > 0) then + soil_class_com (n) = soil_class_com (j) + !soil_class_top (n) = soil_class_com (n) + soil_class_top (n) = soil_class_com (j) ! should be faster/safer than usin gsoil_class_com(n) + grav_vec(n) = grav_vec(j) + soc_vec(n) = soc_vec (j) + poc_vec(n) = poc_vec (j) + endif + + if (soil_class_com (n) >=1) exit + end do + endif + + endif + + fac_surf = soil_class_top(n) + fac = soil_class_com(n) + + if(use_PEATMAP) then + ! the maximum peat soil depth is set to the value Michel used to derive parameters (5000.) + if (fac_surf == 253) soildepth(n) = 5000. ! max(soildepth(n),5000.) + ! reset subsurface to peat if surface soil type is peat + if (fac_surf == 253) fac = 253 + endif + + wp_wetness = a_wp(fac) /a_poros(fac) + + this_cond = a_aksat(fac)/exp(-1.0*zks*gnu) + + + tindex = n + pfafindex = tile_pfs(n) + + ! write soil_param.first + + write (11,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)')tindex,pfafindex, & + fac_surf, fac, a_bee(fac),a_psis(fac),a_poros(fac),& + this_cond,wp_wetness,soildepth(n), & + grav_vec(n),soc_vec(n),poc_vec(n), & + a_sand(fac_surf),a_clay(fac_surf),a_sand(fac),a_clay(fac), & + a_wpsurf(fac_surf)/a_porosurf(fac_surf),a_porosurf(fac_surf), pmap(n) + + ! write tau_param.dat + write (12,'(i10,i8,4f10.7)')tindex,pfafindex, & + atau_2cm(fac_surf),btau_2cm(fac_surf),atau(fac_surf),btau(fac_surf) + + ! write catch_params.nc [soil hydraulic and srfexc-rzexc time scale parameters] + + if (allocated (parms4file)) then + + parms4file (n, 1) = a_bee(fac) + parms4file (n, 2) = this_cond ! a_aksat(fac)/exp(-1.0*zks*gnu) + parms4file (n, 3) = a_poros(fac) + parms4file (n, 4) = a_psis(fac) + parms4file (n, 5) = wp_wetness + parms4file (n, 6) = soildepth(n) + parms4file (n, 7) = atau_2cm(fac_surf) + parms4file (n, 8) = btau_2cm(fac_surf) + parms4file (n, 9) = atau(fac_surf) + parms4file (n,10) = btau(fac_surf) + + endif + end do - fname ='clsm/tau_param.dat' - open (12,file=trim(fname),form='formatted',status='unknown',action = 'write') + ! add "header" line to the bottom of soil_param.first + + write (11,'(a)')' ' + write (11,'(a)')'FMT=i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4,f8.4' + write (11,'(a)')'TileIndex PfafID SoilClassTop SoilClassProfile BEE PSIS POROS Ks_at_SURF WPWET SoilDepth %Grav %OCTop %OCProf %Sand_top %Clay_top %Sand_prof %Clay_prof WPWET_SURF POROS_SURF PMAP' + + close (10, status = 'keep') + close (11, status = 'keep') + close (12, status = 'keep') + + !obsolete20220502 close (13, status = 'keep') + + deallocate (data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6) + deallocate (tileid_vec) + deallocate (a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & + a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & + atau_2cm,btau_2cm) + deallocate (soildepth, grav_vec,soc_vec,poc_vec,soil_class_top,soil_class_com) + !ncells_top,ncells_top_pro,ncells_sub_pro,soil_class_top,soil_class_com) ! ncells_* not used + + ! write catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters] + + if(CatchParamsNC_file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/n_land/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/n_land/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/n_land/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/n_land/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/n_land/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/n_land/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU2') ,(/1/),(/n_land/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU2') ,(/1/),(/n_land/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU5') ,(/1/),(/n_land/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU5') ,(/1/),(/n_land/), parms4file (:,10)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif - ! open catchment.def for reading tile index and Pfafstetter index - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat ! re-read header line - -!obsolete20220502 fname ='clsm/mosaic_veg_typs_fracs' -!obsolete20220502 open (13,file=trim(fname),form='formatted',status='old',action = 'read') - - do n = 1, maxcat - -!obsolete20220502 read (13,*) tindex,pfafindex,vtype - - ! fill gaps from neighbor for rare missing values caused by inconsistent masks - - if ((soil_class_top (n) == -9999).or.(soil_class_com (n) == -9999)) then - - ! if com-layer has data, the issue is only with top-layer - - if(soil_class_com (n) >= 1) soil_class_top (n) = soil_class_com (n) - - ! if there is nothing, look for the neighbor - ! - ! ^ - ! | - ! | The comment above seems wrong; could have soil_class_top(n)>=1, unless - ! earlier soil_class_com was set equal to soil_class_top whenever - ! soil_class_top was available and soil_class_com was not. - - if (soil_class_com (n) == -9999) then - - ! Look for neighbor j (regardless of soil_class_top) and set both - ! soil_class_com(n) and soil_class_top(n) equal to the neighbor's - ! soil_class_com(j). - - do k = 1, maxcat - j = 0 - i1 = n - k - i2 = n + k - if(i1 >= 1) then - if (soil_class_com (i1) >=1) j = i1 ! tentatively use "lower" neighbor unless out of range - endif - - if(1 <= i2 .and. i2 <=maxcat) then - if (soil_class_com (i2) >=1) j = i2 ! "upper" neighbor prevails unless out of range - endif - - if (j > 0) then - soil_class_com (n) = soil_class_com (j) - !soil_class_top (n) = soil_class_com (n) - soil_class_top (n) = soil_class_com (j) ! should be faster/safer than usin gsoil_class_com(n) - grav_vec(n) = grav_vec(j) - soc_vec(n) = soc_vec (j) - poc_vec(n) = poc_vec (j) - endif - - if (soil_class_com (n) >=1) exit - end do - endif - - endif - - fac_surf = soil_class_top(n) - fac = soil_class_com(n) - - if(use_PEATMAP) then - ! the maximum peat soil depth is set to the value Michel used to derive parameters (5000.) - if (fac_surf == 253) soildepth(n) = 5000. ! max(soildepth(n),5000.) - ! reset subsurface to peat if surface soil type is peat - if (fac_surf == 253) fac = 253 - endif - - wp_wetness = a_wp(fac) /a_poros(fac) - - this_cond = a_aksat(fac)/exp(-1.0*zks*gnu) - - ! read tile index and Pfafstetter index from catchment.def - - read (10,*) tindex,pfafindex - - ! write soil_param.first - - write (11,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)')tindex,pfafindex, & - fac_surf, fac, a_bee(fac),a_psis(fac),a_poros(fac),& - this_cond,wp_wetness,soildepth(n), & - grav_vec(n),soc_vec(n),poc_vec(n), & - a_sand(fac_surf),a_clay(fac_surf),a_sand(fac),a_clay(fac), & - a_wpsurf(fac_surf)/a_porosurf(fac_surf),a_porosurf(fac_surf), pmap(n) - - ! write tau_param.dat - - write (12,'(i10,i8,4f10.7)')tindex,pfafindex, & - atau_2cm(fac_surf),btau_2cm(fac_surf),atau(fac_surf),btau(fac_surf) - - ! write catch_params.nc [soil hydraulic and srfexc-rzexc time scale parameters] - - if (allocated (parms4file)) then - - parms4file (n, 1) = a_bee(fac) - parms4file (n, 2) = this_cond ! a_aksat(fac)/exp(-1.0*zks*gnu) - parms4file (n, 3) = a_poros(fac) - parms4file (n, 4) = a_psis(fac) - parms4file (n, 5) = wp_wetness - parms4file (n, 6) = soildepth(n) - parms4file (n, 7) = atau_2cm(fac_surf) - parms4file (n, 8) = btau_2cm(fac_surf) - parms4file (n, 9) = atau(fac_surf) - parms4file (n,10) = btau(fac_surf) + END SUBROUTINE soil_para_hwsd - endif - end do - - ! add "header" line to the bottom of soil_param.first - - write (11,'(a)')' ' - write (11,'(a)')'FMT=i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4,f8.4' - write (11,'(a)')'TileIndex PfafID SoilClassTop SoilClassProfile BEE PSIS POROS Ks_at_SURF WPWET SoilDepth %Grav %OCTop %OCProf %Sand_top %Clay_top %Sand_prof %Clay_prof WPWET_SURF POROS_SURF PMAP' - - close (10, status = 'keep') - close (11, status = 'keep') - close (12, status = 'keep') - -!obsolete20220502 close (13, status = 'keep') - - deallocate (data_vec1, data_vec2,data_vec3, data_vec4,data_vec5, data_vec6) - deallocate (tileid_vec) - deallocate (a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & - a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & - atau_2cm,btau_2cm) - deallocate (soildepth, grav_vec,soc_vec,poc_vec,soil_class_top,soil_class_com) - !ncells_top,ncells_top_pro,ncells_sub_pro,soil_class_top,soil_class_com) ! ncells_* not used - - ! write catch_params.nc4 [soil hydraulic and srfexc-rzexc time scale parameters] - - if(CatchParamsNC_file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/maxcat/), parms4file (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/maxcat/), parms4file (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/maxcat/), parms4file (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/maxcat/), parms4file (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/maxcat/), parms4file (:, 5)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/maxcat/), parms4file (:, 6)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU2') ,(/1/),(/maxcat/), parms4file (:, 7)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU2') ,(/1/),(/maxcat/), parms4file (:, 8)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU5') ,(/1/),(/maxcat/), parms4file (:, 9)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU5') ,(/1/),(/maxcat/), parms4file (:,10)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - DEALLOCATE (parms4file) - endif + ! -------------------------------------------------------------------------------------------------------- + + !obsolete20220502 INTEGER FUNCTION center_pix_int (sf,ktop, ktot, x,y,x0,y0,z0,ext_point) + !obsolete20220502 + !obsolete20220502 implicit none + !obsolete20220502 + !obsolete20220502 integer (kind =2), dimension (:), intent (in) :: x,y + !obsolete20220502 integer, intent (in) :: ktop,ktot + !obsolete20220502 real, intent (in) :: sf + !obsolete20220502 real :: xi,xj,yi,yj,xx0,yy0,zz0 + !obsolete20220502 real, allocatable, dimension (:,:) :: length_m + !obsolete20220502 real, allocatable, dimension (:) :: length + !obsolete20220502 real, intent (inout) :: x0,y0,z0 + !obsolete20220502 integer :: i,j,npix + !obsolete20220502 logical, intent(in) :: ext_point + !obsolete20220502 real :: zi, zj + !obsolete20220502 + !obsolete20220502 allocate (length_m (1:ktot,1:ktot)) + !obsolete20220502 allocate (length (1:ktot)) + !obsolete20220502 length_m =0. + !obsolete20220502 length =0. + !obsolete20220502 + !obsolete20220502 center_pix_int = -9999 + !obsolete20220502 if(ktot /= 0) then + !obsolete20220502 do i = 1,ktot + !obsolete20220502 xi = sf*x(i) + !obsolete20220502 yi = sf*y(i) + !obsolete20220502 zi = 100. - xi - yi + !obsolete20220502 if (.not. ext_point) then + !obsolete20220502 x0 = xi + !obsolete20220502 y0 = yi + !obsolete20220502 z0 = zi + !obsolete20220502 endif + !obsolete20220502 + !obsolete20220502 do j = 1,ktot + !obsolete20220502 xj = sf*x(j) + !obsolete20220502 yj = sf*y(j) + !obsolete20220502 zj = 100. - xj - yj + !obsolete20220502 xx0= xj - x0 + !obsolete20220502 yy0= yj - y0 + !obsolete20220502 zz0= zj - z0 + !obsolete20220502 + !obsolete20220502 if(ktot > ktop) then + !obsolete20220502 if(j <= ktop) then + !obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 + !obsolete20220502 else + !obsolete20220502 length_m (i,j) = 2.33*((xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5) + !obsolete20220502 endif + !obsolete20220502 else + !obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 + !obsolete20220502 endif + !obsolete20220502 end do + !obsolete20220502 length (i) = sum(length_m (i,:)) + !obsolete20220502 end do + !obsolete20220502 + !obsolete20220502 center_pix_int = minloc(length,dim=1) + !obsolete20220502 endif + !obsolete20220502 + !obsolete20220502 END FUNCTION center_pix_int + !obsolete20220502 + !obsolete20220502 ! + !obsolete20220502 + + ! ==================================================================== + ! + + INTEGER FUNCTION center_pix_int0 (sf,ktop, ktot, x,y) - END SUBROUTINE soil_para_hwsd - - ! -------------------------------------------------------------------------------------------------------- - -!obsolete20220502 INTEGER FUNCTION center_pix_int (sf,ktop, ktot, x,y,x0,y0,z0,ext_point) -!obsolete20220502 -!obsolete20220502 implicit none -!obsolete20220502 -!obsolete20220502 integer (kind =2), dimension (:), intent (in) :: x,y -!obsolete20220502 integer, intent (in) :: ktop,ktot -!obsolete20220502 real, intent (in) :: sf -!obsolete20220502 real :: xi,xj,yi,yj,xx0,yy0,zz0 -!obsolete20220502 real, allocatable, dimension (:,:) :: length_m -!obsolete20220502 real, allocatable, dimension (:) :: length -!obsolete20220502 real, intent (inout) :: x0,y0,z0 -!obsolete20220502 integer :: i,j,npix -!obsolete20220502 logical, intent(in) :: ext_point -!obsolete20220502 real :: zi, zj -!obsolete20220502 -!obsolete20220502 allocate (length_m (1:ktot,1:ktot)) -!obsolete20220502 allocate (length (1:ktot)) -!obsolete20220502 length_m =0. -!obsolete20220502 length =0. -!obsolete20220502 -!obsolete20220502 center_pix_int = -9999 -!obsolete20220502 if(ktot /= 0) then -!obsolete20220502 do i = 1,ktot -!obsolete20220502 xi = sf*x(i) -!obsolete20220502 yi = sf*y(i) -!obsolete20220502 zi = 100. - xi - yi -!obsolete20220502 if (.not. ext_point) then -!obsolete20220502 x0 = xi -!obsolete20220502 y0 = yi -!obsolete20220502 z0 = zi -!obsolete20220502 endif -!obsolete20220502 -!obsolete20220502 do j = 1,ktot -!obsolete20220502 xj = sf*x(j) -!obsolete20220502 yj = sf*y(j) -!obsolete20220502 zj = 100. - xj - yj -!obsolete20220502 xx0= xj - x0 -!obsolete20220502 yy0= yj - y0 -!obsolete20220502 zz0= zj - z0 -!obsolete20220502 -!obsolete20220502 if(ktot > ktop) then -!obsolete20220502 if(j <= ktop) then -!obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 -!obsolete20220502 else -!obsolete20220502 length_m (i,j) = 2.33*((xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5) -!obsolete20220502 endif -!obsolete20220502 else -!obsolete20220502 length_m (i,j) = (xx0*xx0 + yy0*yy0 + zz0*zz0)**0.5 -!obsolete20220502 endif -!obsolete20220502 end do -!obsolete20220502 length (i) = sum(length_m (i,:)) -!obsolete20220502 end do -!obsolete20220502 -!obsolete20220502 center_pix_int = minloc(length,dim=1) -!obsolete20220502 endif -!obsolete20220502 -!obsolete20220502 END FUNCTION center_pix_int -!obsolete20220502 -!obsolete20220502 ! -!obsolete20220502 - - ! ==================================================================== + implicit none + + ! In a nutshell, given a list of clay/sand pairs, this function determines + ! the element (pair) in this list that is closest to the average clay/sand + ! across all pairs. ! - - INTEGER FUNCTION center_pix_int0 (sf,ktop, ktot, x,y) - - implicit none + ! The input list of clay/sand can consist of only top (0-30) layer clay/sand + ! pairs, or of pairs of clay/sand pairs for the top (0-30) and sub (30-70) + ! layers. In the latter case, a weighted average is computed. + ! + ! This is to ensure that ultimately the clay/sand values assigned to a tile + ! represent an actual soil class. + ! + ! sf = 0.01 (integer to real scale factor) + ! ktop = # of pixels in top layer + ! ktot = total # of pixels, top + subsurface combined + ! x (clay), y (sand) + integer (kind =2), dimension (:), intent (in) :: x,y + integer, intent (in) :: ktop,ktot + real, intent (in) :: sf + + real :: xi,xj,yi,yj + real :: length + + integer :: i,j,npix + real :: zi, zj, mindist,xc,yc,zc + + length = 0. + + center_pix_int0 = -9999 + + ! compute average clay/sand + + if(ktot /= 0) then + ! There should be some data pixels + if(ktot > ktop) then + ! Have both layers + if(ktop > 0) then + ! There are data in top layer + xc = sf*0.3*sum(real(x(1:ktop)))/real(ktop) + sf*0.7*sum(real(x(ktop+1 : ktot)))/real(ktot - ktop) + yc = sf*0.3*sum(real(y(1:ktop)))/real(ktop) + sf*0.7*sum(real(y(ktop+1 : ktot)))/real(ktot - ktop) + else + ! There are no data in top layer + xc = sf*sum(real(x(1:ktot)))/real(ktot) + yc = sf*sum(real(y(1:ktot)))/real(ktot) + endif + else + ! working on Top layer alone + xc = sf*sum(real(x(1:ktot)))/real(ktot) + yc = sf*sum(real(y(1:ktot)))/real(ktot) + endif + zc = 100. - xc - yc ! silt [percent] + endif - ! In a nutshell, given a list of clay/sand pairs, this function determines - ! the element (pair) in this list that is closest to the average clay/sand - ! across all pairs. - ! - ! The input list of clay/sand can consist of only top (0-30) layer clay/sand - ! pairs, or of pairs of clay/sand pairs for the top (0-30) and sub (30-70) - ! layers. In the latter case, a weighted average is computed. - ! - ! This is to ensure that ultimately the clay/sand values assigned to a tile - ! represent an actual soil class. - ! - ! sf = 0.01 (integer to real scale factor) - ! ktop = # of pixels in top layer - ! ktot = total # of pixels, top + subsurface combined - ! x (clay), y (sand) - integer (kind =2), dimension (:), intent (in) :: x,y - integer, intent (in) :: ktop,ktot - real, intent (in) :: sf - - real :: xi,xj,yi,yj - real :: length - - integer :: i,j,npix - real :: zi, zj, mindist,xc,yc,zc - - length = 0. - - center_pix_int0 = -9999 - - ! compute average clay/sand - - if(ktot /= 0) then - ! There should be some data pixels - if(ktot > ktop) then - ! Have both layers - if(ktop > 0) then - ! There are data in top layer - xc = sf*0.3*sum(real(x(1:ktop)))/real(ktop) + sf*0.7*sum(real(x(ktop+1 : ktot)))/real(ktot - ktop) - yc = sf*0.3*sum(real(y(1:ktop)))/real(ktop) + sf*0.7*sum(real(y(ktop+1 : ktot)))/real(ktot - ktop) - else - ! There are no data in top layer - xc = sf*sum(real(x(1:ktot)))/real(ktot) - yc = sf*sum(real(y(1:ktot)))/real(ktot) - endif - else - ! working on Top layer alone - xc = sf*sum(real(x(1:ktot)))/real(ktot) - yc = sf*sum(real(y(1:ktot)))/real(ktot) - endif - zc = 100. - xc - yc ! silt [percent] - endif - - mindist=100000.*100000. - - do i = 1,ktot - xi = sf*x(i) - yi = sf*y(i) - zi = 100. - xi - yi - length = (xi-xc)**2+(yi-yc)**2+(zi-zc)**2 - if(mindist>length)then - mindist=length - center_pix_int0=i - end if - end do - !print *,ktop,ktot,center_pix_int0 - - END FUNCTION center_pix_int0 - - ! -------------------------------------------------------------------------------------- - -! this subroutine seems obsolete, commented out for now - reichle, 9 Feb 2022 - -! SUBROUTINE process_peatmap (nc, nr, fnameRst, pmap) -! -! implicit none -! integer , parameter :: N_lon_pm = 43200, N_lat_pm = 21600 -! integer, intent (in) :: nc, nr -! real, pointer, dimension (:), intent (inout) :: pmap -! character(*), intent (in) :: fnameRst -! integer :: i,j, status, varid, ncid -! integer :: NTILES -! REAL, ALLOCATABLE, dimension (:) :: count_pix -! REAL, ALLOCATABLE, dimension (:,:) :: data_grid, pm_grid -! INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id -! character*100 :: fout -! -! character*300 :: MAKE_BCS_INPUT_DIR -! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) -! -! ! Reading number of tiles -! ! ----------------------- -! -! open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') -! -! read (20, *) NTILES -! -! close (20, status = 'keep') -! -! ! READ PEATMAP source data files and regrid -! ! ----------------------------------------- -! -! status = NF_OPEN (''//trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/PEATMAP_mask.nc4', NF_NOWRITE, ncid) -! -! allocate (pm_grid (1 : NC , 1 : NR)) -! allocate (data_grid (1 : N_lon_pm, 1 : N_lat_pm)) -! -! status = NF_INQ_VARID (ncid,'PEATMAP',VarID) ; VERIFY_(STATUS) -! status = NF_GET_VARA_REAL (ncid,VarID, (/1,1/),(/N_lon_pm, N_lat_pm/), data_grid) ; VERIFY_(STATUS) -! -! call RegridRasterReal(data_grid, pm_grid) -! -! status = NF_CLOSE(ncid) -! -! ! Grid to tile -! ! ------------ -! -! ! Reading tile-id raster file -! -! allocate(tile_id(1:nc,1:nr)) -! -! open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & -! form='unformatted',convert='little_endian') -! -! do j=1,nr -! read(10)tile_id(:,j) -! end do -! -! close (10,status='keep') -! -! allocate (pmap (1:NTILES)) -! allocate (count_pix (1:NTILES)) -! -! pmap = 0. -! count_pix = 0. -! -! do j = 1,nr -! do i = 1, nc -! if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then -! if(pm_grid(i,j) > 0.) pmap (tile_id(i,j)) = pmap (tile_id(i,j)) + pm_grid(i,j) -! count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. -! endif -! end do -! end do -! -! where (count_pix > 0.) pmap = pmap/count_pix -! -! deallocate (count_pix) -! deallocate (pm_grid) -! deallocate (tile_id) -! -! END SUBROUTINE process_peatmap - -! ==================================================================== - - SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) + mindist=100000.*100000. + + do i = 1,ktot + xi = sf*x(i) + yi = sf*y(i) + zi = 100. - xi - yi + length = (xi-xc)**2+(yi-yc)**2+(zi-zc)**2 + if(mindist>length)then + mindist=length + center_pix_int0=i + end if + end do + !print *,ktop,ktot,center_pix_int0 + + END FUNCTION center_pix_int0 + + ! -------------------------------------------------------------------------------------- + + ! this subroutine seems obsolete, commented out for now - reichle, 9 Feb 2022 + + ! SUBROUTINE process_peatmap (nc, nr, fnameRst, pmap) + ! + ! implicit none + ! integer , parameter :: N_lon_pm = 43200, N_lat_pm = 21600 + ! integer, intent (in) :: nc, nr + ! real, pointer, dimension (:), intent (inout) :: pmap + ! character(*), intent (in) :: fnameRst + ! integer :: i,j, status, varid, ncid + ! integer :: NTILES + ! REAL, ALLOCATABLE, dimension (:) :: count_pix + ! REAL, ALLOCATABLE, dimension (:,:) :: data_grid, pm_grid + ! INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id + ! character*100 :: fout + ! + ! character*300 :: MAKE_BCS_INPUT_DIR + ! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + ! + ! ! Reading number of tiles + ! ! ----------------------- + ! + ! open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') + ! + ! read (20, *) NTILES + ! + ! close (20, status = 'keep') + ! + ! ! READ PEATMAP source data files and regrid + ! ! ----------------------------------------- + ! + ! status = NF_OPEN (''//trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/PEATMAP_mask.nc4', NF_NOWRITE, ncid) + ! + ! allocate (pm_grid (1 : NC , 1 : NR)) + ! allocate (data_grid (1 : N_lon_pm, 1 : N_lat_pm)) + ! + ! status = NF_INQ_VARID (ncid,'PEATMAP',VarID) ; VERIFY_(STATUS) + ! status = NF_GET_VARA_REAL (ncid,VarID, (/1,1/),(/N_lon_pm, N_lat_pm/), data_grid) ; VERIFY_(STATUS) + ! + ! call RegridRasterReal(data_grid, pm_grid) + ! + ! status = NF_CLOSE(ncid) + ! + ! ! Grid to tile + ! ! ------------ + ! + ! ! Reading tile-id raster file + ! + ! allocate(tile_id(1:nc,1:nr)) + ! + ! open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & + ! form='unformatted',convert='little_endian') + ! + ! do j=1,nr + ! read(10)tile_id(:,j) + ! end do + ! + ! close (10,status='keep') + ! + ! allocate (pmap (1:NTILES)) + ! allocate (count_pix (1:NTILES)) + ! + ! pmap = 0. + ! count_pix = 0. + ! + ! do j = 1,nr + ! do i = 1, nc + ! if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + ! if(pm_grid(i,j) > 0.) pmap (tile_id(i,j)) = pmap (tile_id(i,j)) + pm_grid(i,j) + ! count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + ! endif + ! end do + ! end do + ! + ! where (count_pix > 0.) pmap = pmap/count_pix + ! + ! deallocate (count_pix) + ! deallocate (pm_grid) + ! deallocate (tile_id) + ! + ! END SUBROUTINE process_peatmap + + ! ==================================================================== + + SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,nland, tile_id) implicit none @@ -5167,12 +4938,12 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) ! 18 crop [moisture + deciduous] ! 19 crop [moisture stress only] - integer ,intent (in) :: irst, jrst - character (*), intent (in) :: fnameRst + integer, intent(in) :: irst, jrst, nland + integer, intent(in) :: tile_id(:,:) ! tile raster file integer, parameter :: nveg = 4 ! number of veg types integer, parameter :: npft = 19 ! number of PFT - + integer, parameter :: iclm = 1152 ! lon dimension CLM NDEP data integer, parameter :: jclm = 768 ! lat dimension CLM NDEP data @@ -5185,12 +4956,11 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) integer, parameter :: ialb = 7200 ! lon dimension MODIS soil background albedo data integer, parameter :: jalb = 3600 ! lat dimension MODIS soil background albedo data -! integer, parameter :: irst = 43200 ! lon dimension of tile raster file -! integer, parameter :: jrst = 21600 ! lat dimension of tile raster file + ! integer, parameter :: irst = 43200 ! lon dimension of tile raster file + ! integer, parameter :: jrst = 21600 ! lat dimension of tile raster file logical, parameter :: dir_access_files = .false. - integer, dimension (:,:), allocatable :: tile_id ! tile raster file real, allocatable :: ndep_tile(:), t2mp_tile(:), t2mm_tile(:), alb_tile(:,:,:) real, allocatable :: data_grid (:,:), vector(:) @@ -5199,32 +4969,16 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) character :: ctype*1, cband*1 real :: rdum, ftot, xg, yg, fill, alonw, alats, alone, alatn, rlonw, rlats, rlone, rlatn, xx, yy - integer :: i, j, n, im, jm, lwi, idum, ntiles, nland, nv, ix, jx, itype, iband, isum, ntl, np, jalbx, ialbx, ncid, status + integer :: i, j, n, im, jm, lwi, idum, ntiles, nv, ix, jx, itype, iband, isum, ntl, np, jalbx, ialbx, ncid, status logical :: file_exists - ! read nland from catchment.def - ! ----------------------------- - - open (8, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (8,*) nland - - close(8, status = 'keep') - ! Read tile-id raster file; used for mapping gridded fields to tile space ! ----------------------------------------------------------------------- - allocate (tile_id(1:irst,1:jrst)) allocate(vector(nland)) allocate(icount(nland)) - - open(8,file=trim(fnameRst)//'.rst' ,status='old',action='read',form='unformatted') - do j=1,jrst - read(8) tile_id(:,j) - end do - close (8) + !===================================================================================================== ! The below correction was moved to esa2clm - SM @@ -5292,7 +5046,7 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) ! endif ! ! if(abs(sum(fveg(n,:))-1.) > 1.e-6) stop 'fracs/=1' - + ! if (dir_access_files) write(9,rec=n) ityp(n,:),fveg(n,:) ! !80 format('pft:',i8,2f10.4,4i3,4f7.4) @@ -5301,202 +5055,202 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) ! ! close(8) ! if (dir_access_files) close(9) - - !===================================================================================================== - - ! nitrogen deposition - ! ------------------- - - allocate(data_grid(iclm,jclm)) - allocate(ndep_tile(nland)) - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/nitrogen_deposition/v1/ndep_clm_simyr2000_0.23x0.31_c091106.gdat', & - form='unformatted',status='old') - read(8) data_grid - close(8) - - ! regridding to raster grid irst x jrst - ! ------------------------------------- - - xx = iclm/real(irst) - yy = (jclm-1)/real(jrst) ! gkw: subtract 1, since 1 & jclm are centered at pole (dlat=180/(jclm-1)) - - vector = 0. - icount = 0 - - do j = 1,jrst - jx = (j-1)*yy + 1 + 0.5 ! add half because CLM data is centered at south pole - if(jx<1 .or. jx>jclm) stop 'jclm' - do i = 1,irst - - if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then - ix = (i-1)*xx + 1 + 0.5 ! add half because CLM data is centered on dateline - ix = ix + iclm/2 - if(ix > iclm) ix = ix - iclm ! shift 180 degrees; data starts at 0 lon - if(ix<1 .or. ix>iclm) stop 'iclm' - - if(data_grid(ix,jx) >= 0.) then - - ! aggregation on to catchment-tiles - ! --------------------------------- - - vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) - icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 - - endif - endif - end do - end do - - where (icount > 0) ndep_tile = (vector/icount)* (1.e9 / (86400. * 365.)) ! g/m2/yr --> ng/m2/s (for offline; GEOS5 will use g/m2/s) - - if (dir_access_files) then - ! write tile-space data - ! --------------------- - open(9,file='clsm/ndep.dat',form='unformatted',convert='big_endian', & - status='unknown',access='direct',recl=1) - do n = 1,nland - write(9,rec=n) ndep_tile(n) - end do - close(9) - endif - deallocate(data_grid) - - !===================================================================================================== - - - ! annual mean 2m air temperature climatology: Sheffield Princeton 1948-2012 - ! ------------------------------------------------------------------------- - allocate(data_grid(iprn,jprn)) - allocate(t2mp_tile(nland)) - - open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/annual_mean_T2m/v1/princeton_annual_mean_T2m_1948-2012.gdat', & - form='unformatted',status='old') - read(8) data_grid - close(8) - - ! regridding to raster grid irst x jrst - ! ------------------------------------- - xx = iprn/real(irst) - yy = jprn/real(jrst) - - vector = 0. - icount = 0 - - do j = 1,jrst - jx = (j-1)*yy + 1 - if(jx<1 .or. jx>jprn) stop 'jprn' - do i = 1,irst - - if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then - ix = (i-1)*xx + 1 - ix = ix + iprn/2 ! shift 180 degrees; data starts at 0 lon - if(ix > iprn) ix = ix - iprn - if(ix<1 .or. ix>iprn) stop 'iprn' - if(data_grid(ix,jx) >= 0.) then - - ! aggregation on to catchment-tiles - ! --------------------------------- - - vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) - icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 - - endif - endif - end do - end do - - where (icount > 0) t2mp_tile = vector/icount - - if (dir_access_files) then - ! write tile-space data - ! --------------------- - open(9,file='clsm/cli_t2m_princeton.dat',form='unformatted',convert='big_endian', & - status='unknown',access='direct',recl=1) - do n = 1,nland - write(9,rec=n) t2mp_tile(n) - end do - close(9) - endif - - deallocate(data_grid) - - !===================================================================================================== - - - ! annual mean 2m air temperature climatology: MERRA-2 1980-2014 - ! ------------------------------------------------------------- - allocate(data_grid(imra,jmra)) - allocate(t2mm_tile(nland)) - - open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/annual_mean_T2m/v1/MERRA2_annual_mean_T2m_1980-2014.gdat', & - form='unformatted',status='old') - read(8) data_grid - close(8) - - ! regridding to raster grid irst x jrst - ! ------------------------------------- - xx = imra/real(irst) - yy = (jmra-1)/real(jrst) - - vector = 0. - icount = 0 - - do j = 1,jrst - jx = (j-1)*yy + 1 + 0.5 - if(jx<1 .or. jx>jmra) stop 'jmra' - do i = 1,irst - - if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then - ix = (i-1)*xx + 1 + 0.5 - if(ix > imra) ix = ix - imra - if(ix<1 .or. ix>imra) stop 'imra' - if(data_grid (ix,jx) >= 0.) then - - ! aggregation on to catchment-tiles - ! --------------------------------- - - vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) - icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 - - endif - endif - end do - end do - - where (icount > 0) t2mm_tile = vector/icount - - if (dir_access_files) then - ! write tile-space data - ! --------------------- - open(9,file='clsm/cli_t2m_merra2.dat',form='unformatted',convert='big_endian', & - status='unknown',access='direct',recl=1) - do n = 1,nland - write(9,rec=n) t2mm_tile(n) - end do - close(9) - endif - - deallocate(data_grid) - + + !===================================================================================================== + + ! nitrogen deposition + ! ------------------- + + allocate(data_grid(iclm,jclm)) + allocate(ndep_tile(nland)) + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/nitrogen_deposition/v1/ndep_clm_simyr2000_0.23x0.31_c091106.gdat', & + form='unformatted',status='old') + read(8) data_grid + close(8) + + ! regridding to raster grid irst x jrst + ! ------------------------------------- + + xx = iclm/real(irst) + yy = (jclm-1)/real(jrst) ! gkw: subtract 1, since 1 & jclm are centered at pole (dlat=180/(jclm-1)) + + vector = 0. + icount = 0 + + do j = 1,jrst + jx = (j-1)*yy + 1 + 0.5 ! add half because CLM data is centered at south pole + if(jx<1 .or. jx>jclm) stop 'jclm' + do i = 1,irst + + if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then + ix = (i-1)*xx + 1 + 0.5 ! add half because CLM data is centered on dateline + ix = ix + iclm/2 + if(ix > iclm) ix = ix - iclm ! shift 180 degrees; data starts at 0 lon + if(ix<1 .or. ix>iclm) stop 'iclm' + + if(data_grid(ix,jx) >= 0.) then + + ! aggregation on to catchment-tiles + ! --------------------------------- + + vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) + icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 + + endif + endif + end do + end do + + where (icount > 0) ndep_tile = (vector/icount)* (1.e9 / (86400. * 365.)) ! g/m2/yr --> ng/m2/s (for offline; GEOS5 will use g/m2/s) + + if (dir_access_files) then + ! write tile-space data + ! --------------------- + open(9,file='clsm/ndep.dat',form='unformatted',convert='big_endian', & + status='unknown',access='direct',recl=1) + do n = 1,nland + write(9,rec=n) ndep_tile(n) + end do + close(9) + endif + deallocate(data_grid) + + !===================================================================================================== + + + ! annual mean 2m air temperature climatology: Sheffield Princeton 1948-2012 + ! ------------------------------------------------------------------------- + allocate(data_grid(iprn,jprn)) + allocate(t2mp_tile(nland)) + + open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/annual_mean_T2m/v1/princeton_annual_mean_T2m_1948-2012.gdat', & + form='unformatted',status='old') + read(8) data_grid + close(8) + + ! regridding to raster grid irst x jrst + ! ------------------------------------- + xx = iprn/real(irst) + yy = jprn/real(jrst) + + vector = 0. + icount = 0 + + do j = 1,jrst + jx = (j-1)*yy + 1 + if(jx<1 .or. jx>jprn) stop 'jprn' + do i = 1,irst + + if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then + ix = (i-1)*xx + 1 + ix = ix + iprn/2 ! shift 180 degrees; data starts at 0 lon + if(ix > iprn) ix = ix - iprn + if(ix<1 .or. ix>iprn) stop 'iprn' + if(data_grid(ix,jx) >= 0.) then + + ! aggregation on to catchment-tiles + ! --------------------------------- + + vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) + icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 + + endif + endif + end do + end do + + where (icount > 0) t2mp_tile = vector/icount + + if (dir_access_files) then + ! write tile-space data + ! --------------------- + open(9,file='clsm/cli_t2m_princeton.dat',form='unformatted',convert='big_endian', & + status='unknown',access='direct',recl=1) + do n = 1,nland + write(9,rec=n) t2mp_tile(n) + end do + close(9) + endif + + deallocate(data_grid) + + !===================================================================================================== + + + ! annual mean 2m air temperature climatology: MERRA-2 1980-2014 + ! ------------------------------------------------------------- + allocate(data_grid(imra,jmra)) + allocate(t2mm_tile(nland)) + + open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/annual_mean_T2m/v1/MERRA2_annual_mean_T2m_1980-2014.gdat', & + form='unformatted',status='old') + read(8) data_grid + close(8) + + ! regridding to raster grid irst x jrst + ! ------------------------------------- + xx = imra/real(irst) + yy = (jmra-1)/real(jrst) + + vector = 0. + icount = 0 + + do j = 1,jrst + jx = (j-1)*yy + 1 + 0.5 + if(jx<1 .or. jx>jmra) stop 'jmra' + do i = 1,irst + + if(tile_id(i,j)>0 .and. tile_id(i,j)<=nland) then + ix = (i-1)*xx + 1 + 0.5 + if(ix > imra) ix = ix - imra + if(ix<1 .or. ix>imra) stop 'imra' + if(data_grid (ix,jx) >= 0.) then + + ! aggregation on to catchment-tiles + ! --------------------------------- + + vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) + icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 + + endif + endif + end do + end do + + where (icount > 0) t2mm_tile = vector/icount + + if (dir_access_files) then + ! write tile-space data + ! --------------------- + open(9,file='clsm/cli_t2m_merra2.dat',form='unformatted',convert='big_endian', & + status='unknown',access='direct',recl=1) + do n = 1,nland + write(9,rec=n) t2mm_tile(n) + end do + close(9) + endif + + deallocate(data_grid) + !===================================================================================================== - - + + ! read soil background albedo if tile falls in MODIS grid cell, use that value gkw: may want to interpolate or aggregate ! ---------------------------------------------------------------------------- allocate(data_grid(ialb,jalb)) allocate(alb_tile(nland,2,2)) - + do itype = 1,2 do iband = 1,2 - + if(itype == 1) then ctype = 'b' ! "b" (direct, black sky) else ctype = 'w' ! "w" (diffuse, white sky) endif - + if(iband == 1) then cband = '1' ! "1" (visible) fill = 0.10 ! fill value to use when albedo not defined over land @@ -5504,21 +5258,21 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) cband = '2' ! "2" (near IR) fill = 0.07 endif - + open(8,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_albedo/v1/modis_'//ctype//'sa_soil_bb'//cband//'_cmg', & form='unformatted',status='old',access='direct',recl=ialb*jalb) read(8,rec=1) (data_grid(:,j), j = jalb,1,-1) ! data is from north to south where(data_grid <= 0.) data_grid = fill close(8) - + ! regridding to raster grid irst x jrst ! ------------------------------------- xx = ialb/real(irst) yy = jalb/real(jrst) - + vector = 0. icount = 0 - + do j = 1,jrst jx = (j-1)*yy + 1 if(jx<1 .or. jx>jalb) stop 'jalb' @@ -5531,7 +5285,7 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) ! aggregation on to catchment-tiles ! --------------------------------- - + vector(tile_id(i,j)) = vector(tile_id(i,j)) + data_grid(ix,jx) icount(tile_id(i,j)) = icount(tile_id(i,j)) + 1 @@ -5539,10 +5293,10 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) endif end do end do - + where (icount > 0) vector = vector/icount alb_tile(:,itype,iband) = vector (:) - + if (dir_access_files) then ! write tile-space data ! --------------------- @@ -5560,7 +5314,7 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) open (10, file = 'clsm/CLM_NDep_SoilAlb_T2m', form = 'formatted', status ='unknown', & action = 'write') - + do n = 1,nland write (10, '(f10.4,4f7.4,2f8.3)') ndep_tile(n), & alb_tile(n,1,1),alb_tile(n,2,1), & @@ -5587,364 +5341,343 @@ SUBROUTINE grid2tile_ndep_t2m_alb (irst,jrst,fnameRst) end SUBROUTINE grid2tile_ndep_t2m_alb -! -! -------------------------------------------------------------------------------------- -! + ! + ! -------------------------------------------------------------------------------------- + ! + + ! SUBROUTINE CREATE_ROUT_PARA_FILE (NC, NR, fnameRst, MGRID, deltaXY) + ! + ! IMPLICIT NONE + ! + ! INTEGER, INTENT (IN) :: NC, NR + ! character*5, INTENT (IN), OPTIONAL :: MGRID + ! REAL, INTENT (IN), OPTIONAL :: deltaXY + ! character(*),INTENT (IN) :: fnameRst + ! real, allocatable, dimension (:) :: pfaf_area + ! integer,allocatable, dimension (:) :: pfaf_index + ! INTEGER :: NBINS, NPLUS, PFAF,N,L, I1,I2,J1,J2,I,J,K,IL1,IL2,JL1,JL2,NC_RAT + ! REAL :: mnx,mxx,mny,mxy, lats, dxy30 + ! INTEGER, PARAMETER :: NC_SRTM = 21600, NR_SRTM = 10800 + ! REAL :: dx =360._8/NC_ESA,dy = 180._8/NR_ESA, d2r = PI/180._8 + ! integer :: max_pfaf_smap = 40 + ! INTEGER, TARGET, ALLOCATABLE, DIMENSION (:,:) :: raster, tileid_index,& + ! SUBSET_MSK + ! INTEGER, POINTER, DIMENSION (:,:) :: SUBSET_RST + ! REAL, ALLOCATABLE, DIMENSION (:,:) :: SUBSET_AREA + ! REAL, ALLOCATABLE, DIMENSION (:) :: loc_val, loc_area + ! INTEGER, ALLOCATABLE, DIMENSION (:) :: density, loc_int + ! logical, ALLOCATABLE, DIMENSION (:) :: unq_mask + ! + ! INCLUDE 'netcdf.inc' + ! + ! INTEGER :: CellID, MaxID, d2(2), STATUS, VID, NCID, NCID_MSK, NCAT + ! integer, dimension(8) :: date_time_values + ! character (22) :: time_stamp + ! + ! + ! ! Reading raster file + ! + ! allocate(raster (1:nc,1:nr)) + ! + ! open (10, file ='rst/'//trim(fnameRst)//'.rst',form='unformatted',status='old', & + ! action='read') + ! + ! do j=1,nr + ! read(10)(raster (i,j),i=1,nc) + ! end do + ! + ! close (10,status='keep') + ! + ! ! Creating SMAP-Catch_TransferData.nc that contains SMAP cells to Pfafstetter transfer infor + ! + ! open (10,file='clsm/catchment.def',form='formatted',status='old', action = 'read') + ! + ! read (10,*) NCAT + ! + ! if (PRESENT (MGRID)) then + ! if (trim(MGRID) == 'M25') max_pfaf_smap = 30 + ! if (trim(MGRID) == 'M09') max_pfaf_smap = 12 + ! if (trim(MGRID) == 'M03') max_pfaf_smap = 5 + ! endif + ! + ! if (PRESENT (deltaXY)) then + ! if (deltaXY < 0.125) max_pfaf_smap = 15 + ! if (deltaXY >= 0.125) max_pfaf_smap = 15 + ! if (deltaXY >= 0.25 ) max_pfaf_smap = 40 + ! if (deltaXY >= 0.5 ) max_pfaf_smap = 100 + ! if (deltaXY >= 1.0 ) max_pfaf_smap = 250 + ! endif + ! + ! status = NF_CREATE ('clsm/Grid2Catch_TransferData.nc', NF_NETCDF4, NCID) + ! status = NF_DEF_DIM(NCID, 'N_GRID_CELLS' , ncat,CellID) + ! status = NF_DEF_DIM(NCID, 'MAX_CAT_PER_CELL', max_pfaf_smap ,MaxID ) + ! + ! d2(1) = MaxID + ! d2(2) = CellID + ! + ! status = NF_DEF_VAR(NCID, 'NCats_in_GRID', NF_INT , 1 ,CellID, vid) + ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name',& + ! LEN_TRIM('No. of watersheds contributed to the Grid cell'), & + ! trim('No. of watersheds contributed to the Grid cell')) + ! status = NF_DEF_VAR(NCID, 'Pfaf_Index' , NF_INT , 2 ,d2 , vid) + ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name',& + ! LEN_TRIM('Pfaf indices of those contributing watersheds'), & + ! trim('Pfaf indices of those contributing watersheds')) + ! status = NF_DEF_VAR(NCID, 'Pfaf_Area ' , NF_FLOAT, 2 ,d2 , vid) + ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name', & + ! LEN_TRIM('Area of watershed fraction'),& + ! trim('Area of watershed fraction')) + ! status = NF_PUT_ATT_TEXT(NCID, vid, 'units',& + ! LEN_TRIM('km2'), trim('km2')) + ! ! status = NF_DEF_VAR(NCID, 'Pfaf_Frac ' , NF_FLOAT, 2 ,d2 , vid) + ! ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name', & + ! ! LEN_TRIM('Fraction of Pfaf catchment contributed to the SMAP cell'),& + ! ! trim('Fraction of Pfaf catchment contributed to the SMAP cell')) + ! ! + ! ! Global attributes + ! ! + ! call date_and_time(VALUES=date_time_values) + ! + ! write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & + ! date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & + ! date_time_values(5),':',date_time_values(6),':',date_time_values(7) + ! + ! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'CreatedBy', LEN_TRIM('Sarith Mahanama @ GMAO/GSFC/NASA'), & + ! trim('Sarith Mahanama @ GMAO/GSFC/NASA')) + ! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'Contact', LEN_TRIM('sarith.p.mahanama@nasa.gov'), & + ! trim('sarith.p.mahanama@nasa.gov')) + ! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + ! status = NF_ENDDEF(NCID) + ! + ! ! Now computing SMAP-cells to Pfafcatchment fractional areas + ! + ! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + ! status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/shared/mask/GEOS5_10arcsec_mask.nc', NF_NOWRITE, ncid_msk) + ! nbins = 1 + ! + ! allocate (pfaf_area (1:max_pfaf_smap)) + ! allocate (pfaf_index(1:max_pfaf_smap)) + ! + ! dxy30 = 360._8/nc + ! NC_RAT = nc_esa/nc + ! + ! DO N = 1, NCAT + ! + ! pfaf_index = 0 + ! pfaf_area = 0. + ! + ! READ (10,'(i10,i8,5(2x,f9.4), i4)')l,pfaf,mnx,mxx,mny,mxy + ! + ! IL1 = FLOOR ((180. + mnx)/DXY30 + 1.) + ! IL2 = CEILING((180. + mxx)/DXY30 + 1.) + ! JL1 = FLOOR (( 90. + mny)/DXY30 + 1.) + ! JL2 = CEILING(( 90. + mxy)/DXY30 + 1.) + ! + ! IF(IL2 > NC) IL2 = NC + ! IF(JL2 > NR) JL2 = NR + ! + ! I1 = NC_RAT * IL1 - (NC_RAT -1) + ! I2 = NC_RAT * IL2 + ! J1 = NC_RAT * JL1 - (NC_RAT -1) + ! J2 = NC_RAT * JL2 + ! + ! ALLOCATE (SUBSET_MSK (1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) + ! ALLOCATE (SUBSET_AREA(1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) + ! ALLOCATE (TILEID_INDEX(1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) + ! + ! DO J = J1, J2 + ! lats = -90._8 + (j - 0.5_8)*dy + ! SUBSET_AREA(:,J-J1 + 1) = (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) + ! END DO + ! + ! status = NF_GET_VARA_INT (ncid_msk,4,(/I1,J1/),(/I2 - I1 +1,J2 - J1 + 1/),SUBSET_MSK) + ! + ! if (associated (subset_rst )) NULLIFY (subset_rst) + ! SUBSET_RST => RASTER (IL1 : IL2, JL1 : JL2) + ! + ! call RegridRaster(SUBSET_RST, tileid_index) + ! + ! NPLUS = count((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat)) + ! allocate (loc_int (1:NPLUS)) + ! allocate (loc_area(1:NPLUS)) + ! allocate (unq_mask(1:NPLUS)) + ! + ! loc_int = pack(SUBSET_MSK ,mask = ((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat))) + ! loc_area= pack(SUBSET_AREA ,mask = ((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat))) + ! + ! call MAPL_Sort (loc_int, loc_area) + ! + ! unq_mask = .true. + ! do K = 2,NPLUS + ! unq_mask(K) = .not.(loc_int(K) == loc_int(K-1)) ! count number of unique numbers in loc_int for binning + ! end do + ! NBINS = count(unq_mask) + ! + ! if (NBINS > max_pfaf_smap) then + ! print *, 'NBINS exceeded max_pfaf_smap', NBINS, max_pfaf_smap + ! STOP + ! endif + ! + ! if (NBINS > 1) then + ! L = 1 + ! pfaf_index(L) = loc_int (1) + ! pfaf_area (L) = loc_area(1) + ! DO K = 2,NPLUS + ! IF(.not.(loc_int(K) == loc_int(K-1))) L = L + 1 + ! pfaf_index(L) = loc_int (K) + ! pfaf_area (L) = pfaf_area (L) + loc_area(K) * MAPL_RADIUS * MAPL_RADIUS/1000./1000. + ! END DO + ! else + ! IF(NBINS == 1) THEN + ! pfaf_index(1) = loc_int (1) + ! pfaf_area (1) = sum (loc_area(1:NPLUS)) + ! pfaf_area (1) = pfaf_area(1) * MAPL_RADIUS * MAPL_RADIUS/1000./1000. + ! ELSE + ! PRINT *,'NO Catchments so skipping' + ! NBINS = 1 + ! pfaf_index(1) = -1 + ! pfaf_area (1)= -9999. + ! ENDIF + ! endif + ! + ! status = NF_PUT_VARA_INT (NCID, 1,(/N/),(/1/),nbins) + ! status = NF_PUT_VARA_INT (NCID, 2,(/1,N/),(/nbins,1/),pfaf_index(1:nbins)) + ! status = NF_PUT_VARA_REAL(NCID, 3,(/1,N/),(/nbins,1/),pfaf_area (1:nbins)) + ! + ! DEALLOCATE (SUBSET_MSK,SUBSET_AREA, loc_int,loc_area,unq_mask,tileid_index) + ! END DO + ! + ! DEALLOCATE (RASTER) + ! status = NF_CLOSE (ncid) + ! status = NF_CLOSE (ncid_msk) + ! close (10, status = 'keep') + ! + ! END SUBROUTINE CREATE_ROUT_PARA_FILE + + ! ------------------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE CLM45_fixed_parameters (nc,nr, ntiles, tile_id) -! SUBROUTINE CREATE_ROUT_PARA_FILE (NC, NR, fnameRst, MGRID, deltaXY) -! -! IMPLICIT NONE -! -! INTEGER, INTENT (IN) :: NC, NR -! character*5, INTENT (IN), OPTIONAL :: MGRID -! REAL, INTENT (IN), OPTIONAL :: deltaXY -! character(*),INTENT (IN) :: fnameRst -! real, allocatable, dimension (:) :: pfaf_area -! integer,allocatable, dimension (:) :: pfaf_index -! INTEGER :: NBINS, NPLUS, PFAF,N,L, I1,I2,J1,J2,I,J,K,IL1,IL2,JL1,JL2,NC_RAT -! REAL :: mnx,mxx,mny,mxy, lats, dxy30 -! INTEGER, PARAMETER :: NC_SRTM = 21600, NR_SRTM = 10800 -! REAL :: dx =360._8/NC_ESA,dy = 180._8/NR_ESA, d2r = PI/180._8 -! integer :: max_pfaf_smap = 40 -! INTEGER, TARGET, ALLOCATABLE, DIMENSION (:,:) :: raster, tileid_index,& -! SUBSET_MSK -! INTEGER, POINTER, DIMENSION (:,:) :: SUBSET_RST -! REAL, ALLOCATABLE, DIMENSION (:,:) :: SUBSET_AREA -! REAL, ALLOCATABLE, DIMENSION (:) :: loc_val, loc_area -! INTEGER, ALLOCATABLE, DIMENSION (:) :: density, loc_int -! logical, ALLOCATABLE, DIMENSION (:) :: unq_mask -! -! INCLUDE 'netcdf.inc' -! -! INTEGER :: CellID, MaxID, d2(2), STATUS, VID, NCID, NCID_MSK, NCAT -! integer, dimension(8) :: date_time_values -! character (22) :: time_stamp -! -! -! ! Reading raster file -! -! allocate(raster (1:nc,1:nr)) -! -! open (10, file ='rst/'//trim(fnameRst)//'.rst',form='unformatted',status='old', & -! action='read') -! -! do j=1,nr -! read(10)(raster (i,j),i=1,nc) -! end do -! -! close (10,status='keep') -! -! ! Creating SMAP-Catch_TransferData.nc that contains SMAP cells to Pfafstetter transfer infor -! -! open (10,file='clsm/catchment.def',form='formatted',status='old', action = 'read') -! -! read (10,*) NCAT -! -! if (PRESENT (MGRID)) then -! if (trim(MGRID) == 'M25') max_pfaf_smap = 30 -! if (trim(MGRID) == 'M09') max_pfaf_smap = 12 -! if (trim(MGRID) == 'M03') max_pfaf_smap = 5 -! endif -! -! if (PRESENT (deltaXY)) then -! if (deltaXY < 0.125) max_pfaf_smap = 15 -! if (deltaXY >= 0.125) max_pfaf_smap = 15 -! if (deltaXY >= 0.25 ) max_pfaf_smap = 40 -! if (deltaXY >= 0.5 ) max_pfaf_smap = 100 -! if (deltaXY >= 1.0 ) max_pfaf_smap = 250 -! endif -! -! status = NF_CREATE ('clsm/Grid2Catch_TransferData.nc', NF_NETCDF4, NCID) -! status = NF_DEF_DIM(NCID, 'N_GRID_CELLS' , ncat,CellID) -! status = NF_DEF_DIM(NCID, 'MAX_CAT_PER_CELL', max_pfaf_smap ,MaxID ) -! -! d2(1) = MaxID -! d2(2) = CellID -! -! status = NF_DEF_VAR(NCID, 'NCats_in_GRID', NF_INT , 1 ,CellID, vid) -! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name',& -! LEN_TRIM('No. of watersheds contributed to the Grid cell'), & -! trim('No. of watersheds contributed to the Grid cell')) -! status = NF_DEF_VAR(NCID, 'Pfaf_Index' , NF_INT , 2 ,d2 , vid) -! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name',& -! LEN_TRIM('Pfaf indices of those contributing watersheds'), & -! trim('Pfaf indices of those contributing watersheds')) -! status = NF_DEF_VAR(NCID, 'Pfaf_Area ' , NF_FLOAT, 2 ,d2 , vid) -! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name', & -! LEN_TRIM('Area of watershed fraction'),& -! trim('Area of watershed fraction')) -! status = NF_PUT_ATT_TEXT(NCID, vid, 'units',& -! LEN_TRIM('km2'), trim('km2')) -! ! status = NF_DEF_VAR(NCID, 'Pfaf_Frac ' , NF_FLOAT, 2 ,d2 , vid) -! ! status = NF_PUT_ATT_TEXT(NCID, vid, 'long_name', & -! ! LEN_TRIM('Fraction of Pfaf catchment contributed to the SMAP cell'),& -! ! trim('Fraction of Pfaf catchment contributed to the SMAP cell')) -! ! -! ! Global attributes -! ! -! call date_and_time(VALUES=date_time_values) -! -! write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & -! date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & -! date_time_values(5),':',date_time_values(6),':',date_time_values(7) -! -! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'CreatedBy', LEN_TRIM('Sarith Mahanama @ GMAO/GSFC/NASA'), & -! trim('Sarith Mahanama @ GMAO/GSFC/NASA')) -! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'Contact', LEN_TRIM('sarith.p.mahanama@nasa.gov'), & -! trim('sarith.p.mahanama@nasa.gov')) -! status = NF_PUT_ATT_TEXT(NCID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) -! status = NF_ENDDEF(NCID) -! -! ! Now computing SMAP-cells to Pfafcatchment fractional areas -! -! call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) -! status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/shared/mask/GEOS5_10arcsec_mask.nc', NF_NOWRITE, ncid_msk) -! nbins = 1 -! -! allocate (pfaf_area (1:max_pfaf_smap)) -! allocate (pfaf_index(1:max_pfaf_smap)) -! -! dxy30 = 360._8/nc -! NC_RAT = nc_esa/nc -! -! DO N = 1, NCAT -! -! pfaf_index = 0 -! pfaf_area = 0. -! -! READ (10,'(i10,i8,5(2x,f9.4), i4)')l,pfaf,mnx,mxx,mny,mxy -! -! IL1 = FLOOR ((180. + mnx)/DXY30 + 1.) -! IL2 = CEILING((180. + mxx)/DXY30 + 1.) -! JL1 = FLOOR (( 90. + mny)/DXY30 + 1.) -! JL2 = CEILING(( 90. + mxy)/DXY30 + 1.) -! -! IF(IL2 > NC) IL2 = NC -! IF(JL2 > NR) JL2 = NR -! -! I1 = NC_RAT * IL1 - (NC_RAT -1) -! I2 = NC_RAT * IL2 -! J1 = NC_RAT * JL1 - (NC_RAT -1) -! J2 = NC_RAT * JL2 -! -! ALLOCATE (SUBSET_MSK (1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) -! ALLOCATE (SUBSET_AREA(1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) -! ALLOCATE (TILEID_INDEX(1 : I2 - I1 +1 , 1 : J2 - J1 + 1)) -! -! DO J = J1, J2 -! lats = -90._8 + (j - 0.5_8)*dy -! SUBSET_AREA(:,J-J1 + 1) = (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) -! END DO -! -! status = NF_GET_VARA_INT (ncid_msk,4,(/I1,J1/),(/I2 - I1 +1,J2 - J1 + 1/),SUBSET_MSK) -! -! if (associated (subset_rst )) NULLIFY (subset_rst) -! SUBSET_RST => RASTER (IL1 : IL2, JL1 : JL2) -! -! call RegridRaster(SUBSET_RST, tileid_index) -! -! NPLUS = count((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat)) -! allocate (loc_int (1:NPLUS)) -! allocate (loc_area(1:NPLUS)) -! allocate (unq_mask(1:NPLUS)) -! -! loc_int = pack(SUBSET_MSK ,mask = ((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat))) -! loc_area= pack(SUBSET_AREA ,mask = ((tileid_index ==N).AND.(SUBSET_MSK >= 1 .and. subset_MSK <= SRTM_maxcat))) -! -! call MAPL_Sort (loc_int, loc_area) -! -! unq_mask = .true. -! do K = 2,NPLUS -! unq_mask(K) = .not.(loc_int(K) == loc_int(K-1)) ! count number of unique numbers in loc_int for binning -! end do -! NBINS = count(unq_mask) -! -! if (NBINS > max_pfaf_smap) then -! print *, 'NBINS exceeded max_pfaf_smap', NBINS, max_pfaf_smap -! STOP -! endif -! -! if (NBINS > 1) then -! L = 1 -! pfaf_index(L) = loc_int (1) -! pfaf_area (L) = loc_area(1) -! DO K = 2,NPLUS -! IF(.not.(loc_int(K) == loc_int(K-1))) L = L + 1 -! pfaf_index(L) = loc_int (K) -! pfaf_area (L) = pfaf_area (L) + loc_area(K) * MAPL_RADIUS * MAPL_RADIUS/1000./1000. -! END DO -! else -! IF(NBINS == 1) THEN -! pfaf_index(1) = loc_int (1) -! pfaf_area (1) = sum (loc_area(1:NPLUS)) -! pfaf_area (1) = pfaf_area(1) * MAPL_RADIUS * MAPL_RADIUS/1000./1000. -! ELSE -! PRINT *,'NO Catchments so skipping' -! NBINS = 1 -! pfaf_index(1) = -1 -! pfaf_area (1)= -9999. -! ENDIF -! endif -! -! status = NF_PUT_VARA_INT (NCID, 1,(/N/),(/1/),nbins) -! status = NF_PUT_VARA_INT (NCID, 2,(/1,N/),(/nbins,1/),pfaf_index(1:nbins)) -! status = NF_PUT_VARA_REAL(NCID, 3,(/1,N/),(/nbins,1/),pfaf_area (1:nbins)) -! -! DEALLOCATE (SUBSET_MSK,SUBSET_AREA, loc_int,loc_area,unq_mask,tileid_index) -! END DO -! -! DEALLOCATE (RASTER) -! status = NF_CLOSE (ncid) -! status = NF_CLOSE (ncid_msk) -! close (10, status = 'keep') -! -! END SUBROUTINE CREATE_ROUT_PARA_FILE - -! ------------------------------------------------------------------------------------------------------------------------------- - - SUBROUTINE CLM45_fixed_parameters (nc,nr,fnameRst) + implicit none + + ! producing CLM4.5 fixed parameters : + + + ! 1) Population density /discover/nobackup/fzeng/clm4-to-clm4.5/data/firedata4.5/clmforc.Li_2012_hdm_0.5x0.5_AVHRR_simyr1850-2010_c130401.nc + ! Use 2010 + ! 2) /gpfsm/dnb31/fzeng/clm4-to-clm4.5/data/rawdata4.5 + ! mksrf_abm_0.5x0.5_AVHRR_simyr2000.c130201.nc + ! mksrf_gdp_0.5x0.5_AVHRR_simyr2000.c130228.nc + ! mksrf_peatf_0.5x0.5_AVHRR_simyr2000.c130228.nc + ! one value per tile + ! 3) field capacity one value per tile + + integer, intent(in) :: nc, nr, ntiles + integer, intent(in) :: tile_id(:,:) + + integer , parameter :: N_lon_clm = 720, N_lat_clm = 360 + real, parameter :: dxy_clm = 0.5 + integer :: i,j, status, varid, ncid_hdm, ncid_abm, ncid_gdp, ncid_peatf + integer :: tid, cid, ABM_INT, sc_top, sc_com + REAL, ALLOCATABLE, dimension (:) :: hdm, abm, gdp, peatf + REAL, ALLOCATABLE, dimension (:,:) :: hdm_grid, gdp_grid, peatf_grid, data_grid, count_pix + INTEGER, ALLOCATABLE, dimension (:,:) :: abm_grid, int_grid + REAL :: hdm_r, gdp_r, peatf_r + character*100 :: fout + real :: & + a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & + a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & + atau_2cm,btau_2cm, field_cap (n_SoilClasses) + + + ! READ CLM4.5 source data files and regrid + ! ---------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/clmforc.Li_2012_hdm_0.5x0.5_AVHRR_simyr1850-2010_c130401.nc', NF_NOWRITE, ncid_hdm ) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_abm_0.5x0.5_AVHRR_simyr2000.c130201.nc' , NF_NOWRITE, ncid_abm ) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_gdp_0.5x0.5_AVHRR_simyr2000.c130228.nc' , NF_NOWRITE, ncid_gdp ) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_peatf_0.5x0.5_AVHRR_simyr2000.c130228.nc' , NF_NOWRITE, ncid_peatf) + + allocate (hdm_grid (1:NC,1:NR)) + allocate (abm_grid (1:NC,1:NR)) + allocate (gdp_grid (1:NC,1:NR)) + allocate (peatf_grid (1:NC,1:NR)) + allocate (data_grid (1 : N_lon_clm, 1 : N_lat_clm)) + allocate (int_grid (1 : N_lon_clm, 1 : N_lat_clm)) + + status = NF_INQ_VARID (ncid_hdm,'hdm',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL (ncid_hdm,VarID,(/1,1,161/),(/N_lon_clm, N_lat_clm, 1/),data_grid(:,:)) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, hdm_grid) + + status = NF_INQ_VARID (ncid_abm,'abm',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid_abm,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), int_grid) ; VERIFY_(STATUS) + call RegridRaster (int_grid, abm_grid) + + status = NF_INQ_VARID (ncid_gdp,'gdp',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL (ncid_gdp,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), data_grid) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, gdp_grid) + + status = NF_INQ_VARID (ncid_peatf,'peatf',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL (ncid_peatf,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), data_grid) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, peatf_grid) + + status = NF_CLOSE(ncid_hdm ) + status = NF_CLOSE(ncid_abm ) + status = NF_CLOSE(ncid_gdp ) + status = NF_CLOSE(ncid_peatf) + + ! Grid to tile + ! ------------ + + allocate (hdm (1:NTILES)) + allocate (abm (1:NTILES)) + allocate (gdp (1:NTILES)) + allocate (peatf (1:NTILES)) + allocate (count_pix (1:NTILES, 1:4)) + + hdm = 0. + abm = 0. + gdp = 0. + peatf = 0. + count_pix = 0. + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + + ! peatf 0. < 1. + if((peatf_grid(i,j) >= 0.).and.(peatf_grid(i,j) <= 1.)) then + peatf (tile_id(i,j)) = peatf (tile_id(i,j)) + peatf_grid(i,j) + count_pix (tile_id(i,j), 1) = count_pix (tile_id(i,j), 1) + 1. + endif + + ! gdp 0. < 300. + if((gdp_grid(i,j) >= 0.).and.(gdp_grid(i,j) <= 300.)) then + gdp (tile_id(i,j)) = gdp (tile_id(i,j)) + gdp_grid(i,j) + count_pix (tile_id(i,j), 2) = count_pix (tile_id(i,j), 2) + 1. + endif + + ! abm 1 < 12 + if((abm_grid(i,j) >= 1).and.(abm_grid(i,j) <= 12)) then + abm (tile_id(i,j)) = abm (tile_id(i,j)) + abm_grid(i,j) + count_pix (tile_id(i,j), 3) = count_pix (tile_id(i,j), 3) + 1. + endif + + ! hdm 0. < 20000. + if((hdm_grid(i,j) >= 0.).and.(hdm_grid(i,j) <= 20000.)) then + hdm (tile_id(i,j)) = hdm (tile_id(i,j)) + hdm_grid(i,j) + count_pix (tile_id(i,j), 4) = count_pix (tile_id(i,j), 4) + 1. + endif + endif + end do + end do - implicit none - - ! producing CLM4.5 fixed parameters : - - - ! 1) Population density /discover/nobackup/fzeng/clm4-to-clm4.5/data/firedata4.5/clmforc.Li_2012_hdm_0.5x0.5_AVHRR_simyr1850-2010_c130401.nc - ! Use 2010 - ! 2) /gpfsm/dnb31/fzeng/clm4-to-clm4.5/data/rawdata4.5 - ! mksrf_abm_0.5x0.5_AVHRR_simyr2000.c130201.nc - ! mksrf_gdp_0.5x0.5_AVHRR_simyr2000.c130228.nc - ! mksrf_peatf_0.5x0.5_AVHRR_simyr2000.c130228.nc - ! one value per tile - ! 3) field capacity one value per tile - - integer, intent (in) :: nc, nr - character(*), intent (in) :: fnameRst - integer , parameter :: N_lon_clm = 720, N_lat_clm = 360 - real, parameter :: dxy_clm = 0.5 - integer :: i,j, status, varid, ncid_hdm, ncid_abm, ncid_gdp, ncid_peatf - integer :: NTILES, tid, cid, ABM_INT, sc_top, sc_com - REAL, ALLOCATABLE, dimension (:) :: hdm, abm, gdp, peatf - REAL, ALLOCATABLE, dimension (:,:) :: hdm_grid, gdp_grid, peatf_grid, data_grid, count_pix - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id, abm_grid, int_grid - REAL :: hdm_r, gdp_r, peatf_r - character*100 :: fout - real :: & - a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & - a_poros,a_wp,a_aksat,atau,btau,a_wpsurf,a_porosurf, & - atau_2cm,btau_2cm, field_cap (n_SoilClasses) - - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') - - ! READ CLM4.5 source data files and regrid - ! ---------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/clmforc.Li_2012_hdm_0.5x0.5_AVHRR_simyr1850-2010_c130401.nc', NF_NOWRITE, ncid_hdm ) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_abm_0.5x0.5_AVHRR_simyr2000.c130201.nc' , NF_NOWRITE, ncid_abm ) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_gdp_0.5x0.5_AVHRR_simyr2000.c130228.nc' , NF_NOWRITE, ncid_gdp ) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/mksrf_peatf_0.5x0.5_AVHRR_simyr2000.c130228.nc' , NF_NOWRITE, ncid_peatf) - - allocate (hdm_grid (1:NC,1:NR)) - allocate (abm_grid (1:NC,1:NR)) - allocate (gdp_grid (1:NC,1:NR)) - allocate (peatf_grid (1:NC,1:NR)) - allocate (data_grid (1 : N_lon_clm, 1 : N_lat_clm)) - allocate (int_grid (1 : N_lon_clm, 1 : N_lat_clm)) - - status = NF_INQ_VARID (ncid_hdm,'hdm',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL (ncid_hdm,VarID,(/1,1,161/),(/N_lon_clm, N_lat_clm, 1/),data_grid(:,:)) ; VERIFY_(STATUS) - call RegridRasterReal(data_grid, hdm_grid) - - status = NF_INQ_VARID (ncid_abm,'abm',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid_abm,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), int_grid) ; VERIFY_(STATUS) - call RegridRaster (int_grid, abm_grid) - - status = NF_INQ_VARID (ncid_gdp,'gdp',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL (ncid_gdp,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), data_grid) ; VERIFY_(STATUS) - call RegridRasterReal(data_grid, gdp_grid) - - status = NF_INQ_VARID (ncid_peatf,'peatf',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL (ncid_peatf,VarID, (/1,1/),(/N_lon_clm, N_lat_clm/), data_grid) ; VERIFY_(STATUS) - call RegridRasterReal(data_grid, peatf_grid) - - status = NF_CLOSE(ncid_hdm ) - status = NF_CLOSE(ncid_abm ) - status = NF_CLOSE(ncid_gdp ) - status = NF_CLOSE(ncid_peatf) - - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file - - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - allocate (hdm (1:NTILES)) - allocate (abm (1:NTILES)) - allocate (gdp (1:NTILES)) - allocate (peatf (1:NTILES)) - allocate (count_pix (1:NTILES, 1:4)) - - hdm = 0. - abm = 0. - gdp = 0. - peatf = 0. - count_pix = 0. - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - - ! peatf 0. < 1. - if((peatf_grid(i,j) >= 0.).and.(peatf_grid(i,j) <= 1.)) then - peatf (tile_id(i,j)) = peatf (tile_id(i,j)) + peatf_grid(i,j) - count_pix (tile_id(i,j), 1) = count_pix (tile_id(i,j), 1) + 1. - endif - - ! gdp 0. < 300. - if((gdp_grid(i,j) >= 0.).and.(gdp_grid(i,j) <= 300.)) then - gdp (tile_id(i,j)) = gdp (tile_id(i,j)) + gdp_grid(i,j) - count_pix (tile_id(i,j), 2) = count_pix (tile_id(i,j), 2) + 1. - endif - - ! abm 1 < 12 - if((abm_grid(i,j) >= 1).and.(abm_grid(i,j) <= 12)) then - abm (tile_id(i,j)) = abm (tile_id(i,j)) + abm_grid(i,j) - count_pix (tile_id(i,j), 3) = count_pix (tile_id(i,j), 3) + 1. - endif - - ! hdm 0. < 20000. - if((hdm_grid(i,j) >= 0.).and.(hdm_grid(i,j) <= 20000.)) then - hdm (tile_id(i,j)) = hdm (tile_id(i,j)) + hdm_grid(i,j) - count_pix (tile_id(i,j), 4) = count_pix (tile_id(i,j), 4) + 1. - endif - endif - end do - end do - ! Field Capacity ! -------------- open (11, file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat', form='formatted',status='old', & - action = 'read') + action = 'read') read (11,'(a)')fout do i =1,n_SoilClasses read (11,'(4f7.3,4f8.4,e13.5,2f12.7,2f8.4,4f12.7)')a_sand,a_clay,a_silt,a_oc,a_bee,a_psis, & @@ -5970,1312 +5703,1234 @@ SUBROUTINE CLM45_fixed_parameters (nc,nr,fnameRst) if(count_pix(i,2) > 0.) gdp_r = gdp (i) / count_pix(i,2) if(count_pix(i,3) > 0.) abm_int = NINT(abm (i) / count_pix(i,3)) if(count_pix(i,4) > 0.) hdm_r = hdm (i) / count_pix(i,4) - + write (10,'(2I10, i3, f8.4, f8.2, f10.2, f8.4)' ) tid, cid, abm_int, peatf_r, gdp_r, hdm_r, field_cap(sc_com) end do deallocate (hdm, abm, gdp, peatf) deallocate (hdm_grid, gdp_grid, peatf_grid, data_grid, count_pix) - deallocate (tile_id, abm_grid) + deallocate (abm_grid) close (10, status = 'keep') close (20, status = 'keep') END SUBROUTINE CLM45_fixed_parameters - ! ---------------------------------------------------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------------------------------------------------- - SUBROUTINE CLM45_clim_parameters (nc,nr,fnameRst) + SUBROUTINE CLM45_clim_parameters (nc,nr, ntiles, tile_id) - implicit none - ! Producing : lightening frequency HRMC_COM_FR /gpfsm/dnb31/fzeng/clm4-to-clm4.5/data/firedata4.5/LISOTD_HRMC_V2.3.2014.hdf - ! 12 values per tile - integer, intent (in) :: nc, nr - character(*), intent (in) :: fnameRst - integer , parameter :: N_lon_clm = 720, N_lat_clm = 360 - integer :: NTILES, status, varid, ncid - real, dimension (:,:), allocatable :: hrmc_grid, data_grid - REAL, ALLOCATABLE, dimension (:) :: hrmc, count_pix - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id - integer :: yr,mn,yr1,mn1, k,t,i,j - - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') - - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file - - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - ! READ CLM4.5 source data files and regrid - ! ---------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/LISOTD_HRMC_V2.3.2014.nc4', NF_NOWRITE, ncid) - status = NF_INQ_VARID (ncid,'HRMC_COM_FR',VarID) ; VERIFY_(STATUS) - - allocate (hrmc_grid (1:NC,1:NR)) - allocate (data_grid (1 : N_lon_clm, 1 : N_lat_clm)) - allocate (hrmc (1:NTILES)) - allocate (count_pix (1:NTILES)) - - ! writing tile-spaced output - ! -------------------------- - - open (31,file='clsm/lnfm.dat',status='unknown',action='write',form='unformatted', & - convert='little_endian') - - do K=0,13 - yr = (k+11)/12 - mn = mod(k+11,12)+1 - yr1= (k+12)/12 - mn1= mod(k+12,12)+1 - write(31) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) - hrmc = 0. - count_pix = 0. - t = k - if (t == 0 ) t = 12 - if (t == 13) t = 1 - status = NF_GET_VARA_REAL (ncid,VarID, (/1,1,t/),(/N_lon_clm, N_lat_clm,1/), data_grid) ; VERIFY_(STATUS) - call RegridRasterReal(data_grid, hrmc_grid) - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - if((hrmc_grid(i,j) >= 0.).and.(hrmc_grid(i,j) <= 1.)) then - hrmc (tile_id(i,j)) = hrmc (tile_id(i,j)) + hrmc_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - endif - end do - end do - - where (count_pix > 0.) hrmc = hrmc /count_pix - write(31) hrmc - end do - - close(31,status='keep') - - END SUBROUTINE CLM45_clim_parameters - -! ---------------------------------------------------------------------------------------------------------------------------- - - SUBROUTINE grid2tile_glass (ncol,nrow,fnameRst,lai_name) -! -! Processing GLASS LAI (AVHRR or MODIS) and creating 8-day climatological data -! - implicit none - integer , parameter :: N_lon_glass = 7200, N_lat_glass = 3600 - integer, intent (in) :: ncol, nrow - real, parameter :: dxy = 1. - integer :: QSize - character(*) :: fnameRst,lai_name - integer :: n,maxcat,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny - integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & - time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 - character*100 :: fout - character*200 :: fname - character*10 :: string - character*2 :: VV,HH - integer, allocatable, target, dimension (:,:) :: net_data1 - real, pointer, dimension (:,:) :: QSub - real, pointer, dimension (:,:) :: subset - REAL, ALLOCATABLE, dimension (:):: vec_lai, count_lai,tile_lon, tile_lat & - , x, y !, distance - real, allocatable, target, dimension (:,:) :: lai_grid, data_grid, data_grid2 - INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l, VarID - character(len=4), dimension (:), allocatable :: MMDD, MMDD_next - logical :: regrid - REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon - logical :: first_entry = .true. - type (date_time_type) :: date_time_new,bf_lai_time, & - af_lai_time, date_time_this - integer, dimension (:,:), allocatable, target :: tile_id - integer :: tileid_tile - character*3 :: ddd - -! Reading rst file -!----------------- - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - allocate (tile_id (1:ncol,1:nrow)) - - do j=1,nrow - read(10)tile_id(:,j) - end do - close (10,status='keep') + implicit none + ! Producing : lightening frequency HRMC_COM_FR /gpfsm/dnb31/fzeng/clm4-to-clm4.5/data/firedata4.5/LISOTD_HRMC_V2.3.2014.hdf + ! 12 values per tile + integer, intent (in) :: nc, nr, ntiles + INTEGER, intent (in) :: tile_id(:,:) -! -! Reading number of cathment-tiles from catchment.def file -!_________________________________________________________ -! - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - allocate (tile_lon(1:maxcat)) - allocate (tile_lat(1:maxcat)) - - do n = 1, maxcat - read (10,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - end do - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/MODIS_8-DayClim/MODIS_lai_clim.H11V13.nc' - status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) - status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) - allocate (MMDD (0: n_tslices + 1)) - allocate (MMDD_next (0: n_tslices + 1)) - - status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) - status = NF_CLOSE(ncid); VERIFY_(STATUS) - - mmdd(0) = mmdd(n_tslices) - mmdd(n_tslices + 1)= mmdd(1) - - mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) - mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) - - ! writing GLASS LAI - ! - open (31,file='clsm/lai.dat', & - form='unformatted',status='unknown',convert='little_endian') - - allocate (vec_lai (maxcat)) - allocate (count_lai (1:maxcat)) - - nx = nint (360./dxy) - ny = nint (180./dxy) - allocate (x(1:nx)) - allocate (y(1:ny)) - - FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy - FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy - - allocate (lai_grid (1 : nx, 1 : ny)) - - QSize = nint(dxy*N_lon_glass/360.) - allocate (QSub (1:QSize,1:QSize)) - allocate (net_data1 (1 : N_lon_glass, 1 : N_lat_glass)) - allocate (data_grid (1:NCOL,1:NROW)) - allocate (data_grid2 (1 : N_lon_glass, 1 : N_lat_glass)) - - do t =0,n_tslices+1 - - time_slice = t - yr = 1 - yr1= 1 - if(t == 0) then - time_slice = n_tslices - yr = 1 - 1 - endif - - if(t >= n_tslices) then - yr1 = 1 + 1 - if(t ==n_tslices + 1) then - time_slice = 1 - yr = 1 + 1 - endif - endif - - read(mmdd(t),'(i2.2,i2.2)') mn,dd - read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 - - date_time_this%year = 2001 - date_time_this%month = mn - date_time_this%day = dd - date_time_this%hour = 0 - date_time_this%min = 0 - date_time_this%sec = 0 - call get_dofyr_pentad(date_time_this) - - write (ddd,'(i3.3)') date_time_this%dofyr - - ! Reading Interpolation or aggregation on to catchment-tiles - - vec_lai = -9999. - count_lai = 0. - lai_grid = -9999 - - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v4/'//trim(lai_name)//ddd//'.nc4', NF_NOWRITE, ncid) ; VERIFY_(STATUS) - status = NF_INQ_VARID (ncid,'LAI',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT(ncid,VarID, (/1,1/),(/N_lon_glass, N_lat_glass/), net_data1) ; VERIFY_(STATUS) - - call RegridRasterReal(0.01*real(net_data1), data_grid) - data_grid2 = 0.01*real(net_data1) - - status = NF_CLOSE(ncid) - - do j = 1,nrow - do i = 1, ncol - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.MAXCAT)) then - if((data_grid(i,j) >= 0.).and.(data_grid(i,j) <= 10.)) then - if(vec_lai(tile_id(i,j)) == -9999.) vec_lai(tile_id(i,j)) = 0. - vec_lai (tile_id(i,j)) = vec_lai (tile_id(i,j)) + data_grid(i,j) - count_lai (tile_id(i,j)) = count_lai (tile_id(i,j)) + 1. - endif - endif - end do - end do - - write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,maxcat,1/)) - - where (count_lai > 0.) vec_lai = vec_lai/count_lai - - ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, - ! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. - !--------------------------------------------------------------------------------------------------------------------------------------- - - iLL = 1 - jLL = 1 - do j = 1, N_lat_glass/QSize - do i = 1, N_lon_glass/QSize - QSub => data_grid2((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) - if(minval (QSub) <= 10.) lai_grid(i,j) = sum(QSub, QSub<=10.)/(max(1,count(QSub<=10.))) - enddo - enddo - - NULLIFY (QSub) - -! Filling gaps -!------------- - DO n =1,maxcat - if(count_lai(n)==0.) then - - DO i = 1,nx - 1 - if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i - end do - DO i = 1,ny -1 - if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i - end do - - l = 1 - do - imx=ix + l - imn=ix - l - jmn=jx - l - jmx=jx + l - imn=MAX(imn,1) - jmn=MAX(jmn,1) - imx=MIN(imx,nx) - jmx=MIN(jmx,ny) - d1=imx-imn+1 - d2=jmx-jmn+1 - subset => lai_grid(imn: imx,jmn:jmx) - - if(maxval(subset) > 0.) then - vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) - exit - endif - l = l + 1 - NULLIFY (subset) - end do + integer , parameter :: N_lon_clm = 720, N_lat_clm = 360 + integer :: status, varid, ncid + real, dimension (:,:), allocatable :: hrmc_grid, data_grid + REAL, ALLOCATABLE, dimension (:) :: hrmc, count_pix + integer :: yr,mn,yr1,mn1, k,t,i,j + + + ! Grid to tile + ! ------------ + + + ! READ CLM4.5 source data files and regrid + ! ---------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/misc/CLM45/LISOTD_HRMC_V2.3.2014.nc4', NF_NOWRITE, ncid) + status = NF_INQ_VARID (ncid,'HRMC_COM_FR',VarID) ; VERIFY_(STATUS) + + allocate (hrmc_grid (1:NC,1:NR)) + allocate (data_grid (1 : N_lon_clm, 1 : N_lat_clm)) + allocate (hrmc (1:NTILES)) + allocate (count_pix (1:NTILES)) + + ! writing tile-spaced output + ! -------------------------- + + open (31,file='clsm/lnfm.dat',status='unknown',action='write',form='unformatted', & + convert='little_endian') + + do K=0,13 + yr = (k+11)/12 + mn = mod(k+11,12)+1 + yr1= (k+12)/12 + mn1= mod(k+12,12)+1 + write(31) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) + hrmc = 0. + count_pix = 0. + t = k + if (t == 0 ) t = 12 + if (t == 13) t = 1 + status = NF_GET_VARA_REAL (ncid,VarID, (/1,1,t/),(/N_lon_clm, N_lat_clm,1/), data_grid) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, hrmc_grid) + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((hrmc_grid(i,j) >= 0.).and.(hrmc_grid(i,j) <= 1.)) then + hrmc (tile_id(i,j)) = hrmc (tile_id(i,j)) + hrmc_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif endif - END DO - write(31) vec_lai(:) + end do end do - close(31,status='keep') - - deallocate (net_data1, tile_id) - deallocate (count_lai) - deallocate (vec_lai) - deallocate (tile_lat,tile_lon) - END SUBROUTINE grid2tile_glass + where (count_pix > 0.) hrmc = hrmc /count_pix + write(31) hrmc + end do - ! ---------------------------------------------------------------------------------------------------------------------------- + close(31,status='keep') - SUBROUTINE gimms_clim_ndvi (nc,nr,fnameRst) - - implicit none - ! Producing : GIMMS NDVI 15-day climatology from 5 arcmin data - ! 24 values per tile - integer, intent (in) :: nc, nr - character(*), intent (in) :: fnameRst - integer , parameter :: N_lon_gimms = 4320, N_lat_gimms = 2160 - integer :: NTILES, status, varid, ncid1, ncid2,ncid - real, dimension (:,:), allocatable :: ndvi_grid, data_grid - integer, dimension (:,:), allocatable ::data_grid2 - REAL, ALLOCATABLE, dimension (:) :: ndvi, count_pix - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id - integer :: yr,mn,yr1,mn1, k,t,i,j,l - integer, parameter :: scale_fac = 10000 - real, parameter :: val_min = -0.3, val_max = 1. - - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') - - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file - - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - ! READ GIMMS NDVI source data files and regrid - ! ---------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/ndvi/v1/ndvi3g_geo_v1_YYYY_0106.nc4', NF_NOWRITE, ncid1) ; VERIFY_(STATUS) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/ndvi/v1/ndvi3g_geo_v1_YYYY_0712.nc4', NF_NOWRITE, ncid2) ; VERIFY_(STATUS) - status = NF_INQ_VARID (ncid2,'ndvi',VarID) ; VERIFY_(STATUS) - - allocate (ndvi_grid (1:NC,1:NR)) - allocate (data_grid (1 : N_lon_gimms, 1 : N_lat_gimms)) - allocate (data_grid2(1 : N_lon_gimms, 1 : N_lat_gimms)) - allocate (ndvi (1:NTILES)) - allocate (count_pix (1:NTILES)) - - ! writing tile-spaced output - ! -------------------------- - - open (31,file='clsm/ndvi.dat',status='unknown',action='write',form='unformatted', & - convert='little_endian') - - do K=0,13 - yr = (k+11)/12 - mn = mod(k+11,12)+1 - yr1= (k+12)/12 - mn1= mod(k+12,12)+1 - - ndvi = 0. - count_pix = 0. - t = k - if (k == 0 ) then - t = 12 - ncid = ncid2 - write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) - - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) - - do j = 1, N_lat_gimms - data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) - end do - - call RegridRasterReal(data_grid, ndvi_grid) - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then - ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - endif - end do - end do - - where (count_pix > 0.) ndvi = ndvi /count_pix - write(31) ndvi - - elseif (k == 13) then - - t = 1 - ncid = ncid1 - write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) - - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) - - do j = 1, N_lat_gimms - data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) - end do - - call RegridRasterReal(data_grid, ndvi_grid) - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then - ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - endif - end do - end do - - where (count_pix > 0.) ndvi = ndvi /count_pix - write(31) ndvi - - else - - do l = 1, 0 , -1 - t = k*2 - l - if (k <= 6) ncid = ncid1 - if (k >= 7) ncid = ncid2 - if (k >= 7) t = t - 12 - if(l == 1) write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) - if(l == 0) write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) - - ndvi = 0. - count_pix = 0. - - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) - - do j = 1, N_lat_gimms - data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) - end do - - call RegridRasterReal(data_grid, ndvi_grid) - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then - ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - endif - end do - end do - - where (count_pix > 0.) ndvi = ndvi /count_pix - write(31) ndvi - - end do - endif - end do - - close(31,status='keep') - - END SUBROUTINE gimms_clim_ndvi - - ! -------------------------------------------------------------------------- - - SUBROUTINE open_landparam_nc4_files(N_tile,process_snow_albedo) + END SUBROUTINE CLM45_clim_parameters - implicit none - integer :: NCCatOUTID, NCCatCNOUTID, NCVegOUTID - integer :: STATUS, CellID1, CellID2, CellID3, SubID - integer, intent (in) :: N_tile - logical, intent (in) :: process_snow_albedo - integer, dimension(8) :: date_time_values - character (22) :: time_stamp - character (100) :: MYNAME - - status = NF_CREATE ('clsm/catch_params.nc4' , NF_NETCDF4, NCCatOUTID ) ; VERIFY_(STATUS) - status = NF_CREATE ('clsm/catchcn_params.nc4', NF_NETCDF4, NCCatCNOUTID) ; VERIFY_(STATUS) - status = NF_CREATE ('clsm/vegdyn.data' , NF_NETCDF4, NCVegOUTID ) ; VERIFY_(STATUS) - - status = NF_DEF_DIM(NCCatOUTID , 'tile' , N_tile, CellID1) - status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , N_tile, CellID2) - status = NF_DEF_DIM(NCVegOUTID , 'tile' , N_tile, CellID3) - status = NF_DEF_DIM(NCCatCNOUTID, 'unknown_dim2' , 4, SubID) - - call DEF_VAR ( NCCatOUTID, CellID1,'OLD_ITY' ,'vegetation_type.' , '1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARA1' ,'shape_param_1' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARA2' ,'shape_param_2' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARA3' ,'shape_param_3' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARA4' ,'shape_param_4' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARS1' ,'wetness_param_1' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARS2' ,'wetness_param_2' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARS3' ,'wetness_param_3' ,'m+4 kg-2' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARW1' ,'min_theta_param_1' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARW2' ,'min_theta_param_2' ,'m+2 kg-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARW3' ,'min_theta_param_3' ,'m+4 kg-2' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ARW4' ,'min_theta_param_4' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ATAU2' ,'2cm_water_transfer_param_5' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'ATAU5' ,'5cm_water_transfer_param_5' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BEE' ,'clapp_hornberger_b' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BF1' ,'topo_baseflow_param_1' ,'kg m-4' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BF2' ,'topo_baseflow_param_2' ,'m' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BF3' ,'topo_baseflow_param_3' ,'log(m)' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BTAU2' ,'2cm_water_transfer_param_6' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'BTAU5' ,'5cm_water_transfer_param_6' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'COND' ,'sfc_sat_hydraulic_conduct' ,'m s-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'GNU' ,'vertical_transmissivity' ,'m-1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'POROS' ,'soil_porosity' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'PSIS' ,'saturated_matric_potential' ,'m' ) - call DEF_VAR ( NCCatOUTID, CellID1,'TSA1' ,'water_transfer_param_1' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'TSA2' ,'water_transfer_param_2' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'TSB1' ,'water_transfer_param_3' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'TSB2' ,'water_transfer_param_4' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'WPWET' ,'wetness_at_wilting_point' ,'1' ) - call DEF_VAR ( NCCatOUTID, CellID1,'DP2BR' ,'depth_to_bedrock' ,'mm' ) - if (process_snow_albedo) & - call DEF_VAR ( NCCatOUTID, CellID1,'SNOWALB' ,'snow_albedo' ,'1' ) - - call DEF_VAR ( NCVegOUTID, CellID3,'ITY' ,'vegetation_type' ,'1' ) - call DEF_VAR ( NCVegOUTID, CellID3,'Z2CH' ,'vegetation_height' ,'m' ) - call DEF_VAR ( NCVegOUTID, CellID3,'ASCATZ0' ,'ASCAT_roughness_length' ,'m' ) - - call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNF' ,'MODIS soil albedo nir dif' ,'1' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNR' ,'MODIS soil albedo nir dir' ,'1' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVF' ,'MODIS soil albedo vis dif' ,'1' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVR' ,'MODIS soil albedo vis dir' ,'1' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_M' ,'Clim 2m temperature (MERRA2)' ,'K' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_S' ,'Clim 2m temperature (Sheffield)' ,'K' ) - call DEF_VAR ( NCCatCNOUTID, CellID2,'NDEP' ,'CLM_nitrogen_deposition' ,'g m-2 s-1') - call DEF_VAR ( NCCatCNOUTID, CellID2,'FVG' ,'vegetation_fraction' ,'1' ,SubID = SubID) - call DEF_VAR ( NCCatCNOUTID, CellID2,'ITY' ,'vegetation_type' ,'1' ,SubID = SubID) - - call date_and_time(VALUES=date_time_values) - - write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & - date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & - date_time_values(5),':',date_time_values(6),':',date_time_values(7) -! call execute_command_line('setenv MYNAME `finger $USER | cut -d: -f3 | head -1`') -! call sleep (5) - call get_environment_variable ("USER" ,MYNAME ) - status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) - status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) - status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) - status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) - - status = NF_ENDDEF(NCCatOUTID ) - status = NF_ENDDEF(NCVegOUTID ) - status = NF_ENDDEF(NCCatCNOUTID) - - status = NF_CLOSE (NCCatOUTID ) - status = NF_CLOSE (NCVegOUTID ) - status = NF_CLOSE (NCCatCNOUTID) - - contains + ! ---------------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE grid2tile_glass (ncol,nrow, tile_id,lai_name, n_land, tile_lon, tile_lat) + ! + ! Processing GLASS LAI (AVHRR or MODIS) and creating 8-day climatological data + ! + implicit none + integer, intent(in) :: ncol, nrow + integer, target, intent(in) :: tile_id(:,:) + character(*), intent(in) :: lai_name + integer, intent(in) :: n_land + real, intent(in) :: tile_lon(:), tile_lat(:) + + integer , parameter :: N_lon_glass = 7200, N_lat_glass = 3600 + real, parameter :: dxy = 1. + integer :: QSize + integer :: n,i,j,k,ncid,i_highd,j_highd,nx_adj,ny_adj,ierr,nx,ny + integer :: status,iLL,jLL,ix,jx,vid,nc_10,nr_10,n_tslices,d_undef,t, & + time_slice,time_slice_next,yr,mn,dd,yr1,mn1,dd1,i1,i2,tindex1,pfaf1 + character*100 :: fout + character*200 :: fname + character*10 :: string + character*2 :: VV,HH + integer, allocatable, target, dimension (:,:) :: net_data1 + real, pointer, dimension (:,:) :: QSub + real, pointer, dimension (:,:) :: subset + REAL, ALLOCATABLE, dimension (:):: vec_lai, count_lai, x, y !, distance + real, allocatable, target, dimension (:,:) :: lai_grid, data_grid, data_grid2 + INTEGER ::imn,imx,jmn,jmx,mval,d1,d2,l, VarID + character(len=4), dimension (:), allocatable :: MMDD, MMDD_next + logical :: regrid + REAL :: sf, dum,dist_save,tile_distance,minlat,maxlat,minlon,maxlon + logical :: first_entry = .true. + type (date_time_type) :: date_time_new,bf_lai_time, & + af_lai_time, date_time_this + integer :: tileid_tile + character*3 :: ddd + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + fname =trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v2/MODIS_8-DayClim/MODIS_lai_clim.H11V13.nc' + status = NF_OPEN(trim(fname),NF_NOWRITE, ncid); VERIFY_(STATUS) + status = NF_INQ_DIM (ncid,3,string, n_tslices); VERIFY_(STATUS) + allocate (MMDD (0: n_tslices + 1)) + allocate (MMDD_next (0: n_tslices + 1)) + + status = NF_GET_VARA_text(ncid, 3,(/1,1/),(/4,n_tslices/),MMDD(1:n_tslices)); VERIFY_(STATUS) + status = NF_CLOSE(ncid); VERIFY_(STATUS) + + mmdd(0) = mmdd(n_tslices) + mmdd(n_tslices + 1)= mmdd(1) + + mmdd_next(0:n_tslices - 1) = mmdd(1:n_tslices) + mmdd_next(n_tslices: n_tslices + 1) = mmdd (1:2) + + ! writing GLASS LAI + ! + open (31,file='clsm/lai.dat', & + form='unformatted',status='unknown',convert='little_endian') + + allocate (vec_lai (n_land)) + allocate (count_lai (1:n_land)) + + nx = nint (360./dxy) + ny = nint (180./dxy) + allocate (x(1:nx)) + allocate (y(1:ny)) + + FORALL (i = 1:nx) x(i) = -180. + dxy/2. + (i-1)*dxy + FORALL (i = 1:ny) y(i) = -90. + dxy/2. + (i-1)*dxy + + allocate (lai_grid (1 : nx, 1 : ny)) + + QSize = nint(dxy*N_lon_glass/360.) + allocate (QSub (1:QSize,1:QSize)) + allocate (net_data1 (1 : N_lon_glass, 1 : N_lat_glass)) + allocate (data_grid (1:NCOL,1:NROW)) + allocate (data_grid2 (1 : N_lon_glass, 1 : N_lat_glass)) + + do t =0,n_tslices+1 + + time_slice = t + yr = 1 + yr1= 1 + if(t == 0) then + time_slice = n_tslices + yr = 1 - 1 + endif + + if(t >= n_tslices) then + yr1 = 1 + 1 + if(t ==n_tslices + 1) then + time_slice = 1 + yr = 1 + 1 + endif + endif + + read(mmdd(t),'(i2.2,i2.2)') mn,dd + read(mmdd_next(t),'(i2.2,i2.2)') mn1,dd1 + + date_time_this%year = 2001 + date_time_this%month = mn + date_time_this%day = dd + date_time_this%hour = 0 + date_time_this%min = 0 + date_time_this%sec = 0 + call get_dofyr_pentad(date_time_this) + + write (ddd,'(i3.3)') date_time_this%dofyr + + ! Reading Interpolation or aggregation on to catchment-tiles + + vec_lai = -9999. + count_lai = 0. + lai_grid = -9999 + + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/v4/'//trim(lai_name)//ddd//'.nc4', NF_NOWRITE, ncid) ; VERIFY_(STATUS) + status = NF_INQ_VARID (ncid,'LAI',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT(ncid,VarID, (/1,1/),(/N_lon_glass, N_lat_glass/), net_data1) ; VERIFY_(STATUS) + + call RegridRasterReal(0.01*real(net_data1), data_grid) + data_grid2 = 0.01*real(net_data1) + + status = NF_CLOSE(ncid) + + do j = 1,nrow + do i = 1, ncol + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.n_land)) then + if((data_grid(i,j) >= 0.).and.(data_grid(i,j) <= 10.)) then + if(vec_lai(tile_id(i,j)) == -9999.) vec_lai(tile_id(i,j)) = 0. + vec_lai (tile_id(i,j)) = vec_lai (tile_id(i,j)) + data_grid(i,j) + count_lai (tile_id(i,j)) = count_lai (tile_id(i,j)) + 1. + endif + endif + end do + end do + + write(31) float((/yr,mn,dd,0,0,0,yr1,mn1,dd1,0,0,0,n_land,1/)) + + where (count_lai > 0.) vec_lai = vec_lai/count_lai + + ! After experimenting with few finer methods, in order to reduce the time taken by the gap filling procedure, + ! creating a 0.25-degree gridded data set from finer LAI data and use it for filling the gaps seems the most practical/manageble method. + !--------------------------------------------------------------------------------------------------------------------------------------- + + iLL = 1 + jLL = 1 + do j = 1, N_lat_glass/QSize + do i = 1, N_lon_glass/QSize + QSub => data_grid2((i-1)*QSize+2-iLL :i*QSize-iLL+1, (j-1)*QSize+2-jLL :j*QSize-jLL+1) + if(minval (QSub) <= 10.) lai_grid(i,j) = sum(QSub, QSub<=10.)/(max(1,count(QSub<=10.))) + enddo + enddo + + NULLIFY (QSub) + + ! Filling gaps + !------------- + DO n =1,n_land + if(count_lai(n)==0.) then + + DO i = 1,nx - 1 + if ((tile_lon(n) >= x(i)).and.(tile_lon(n) < x(i+1))) ix = i + end do + DO i = 1,ny -1 + if ((tile_lat(n) >= y(i)).and.(tile_lat(n) < y(i+1))) jx = i + end do + + l = 1 + do + imx=ix + l + imn=ix - l + jmn=jx - l + jmx=jx + l + imn=MAX(imn,1) + jmn=MAX(jmn,1) + imx=MIN(imx,nx) + jmx=MIN(jmx,ny) + d1=imx-imn+1 + d2=jmx-jmn+1 + subset => lai_grid(imn: imx,jmn:jmx) + + if(maxval(subset) > 0.) then + vec_lai (n) = sum(subset, subset>0.)/(max(1,count(subset>0.))) + exit + endif + l = l + 1 + NULLIFY (subset) + end do + endif + END DO + write(31) vec_lai(:) + end do + close(31,status='keep') + + deallocate (net_data1) + deallocate (count_lai) + deallocate (vec_lai) + deallocate (data_grid) + deallocate (data_grid2) + + END SUBROUTINE grid2tile_glass + + ! ---------------------------------------------------------------------------------------------------------------------------- - SUBROUTINE DEF_VAR (NCFID, CellID, VarName, long_name, units, SubID) - - implicit none - integer, intent (in) :: NCFID, CellID - character (*), intent (in) :: VarName, long_name, units - integer, intent (in), optional :: SubID - integer :: STATUS, VID + SUBROUTINE gimms_clim_ndvi (nc,nr, ntiles, tile_id) + + implicit none + ! Producing : GIMMS NDVI 15-day climatology from 5 arcmin data + ! 24 values per tile + integer, intent (in) :: nc, nr, ntiles + INTEGER, intent(in) :: tile_id(:,:) + + integer , parameter :: N_lon_gimms = 4320, N_lat_gimms = 2160 + integer :: status, varid, ncid1, ncid2,ncid + real, dimension (:,:), allocatable :: ndvi_grid, data_grid + integer, dimension (:,:), allocatable ::data_grid2 + REAL, ALLOCATABLE, dimension (:) :: ndvi, count_pix + integer :: yr,mn,yr1,mn1, k,t,i,j,l + integer, parameter :: scale_fac = 10000 + real, parameter :: val_min = -0.3, val_max = 1. + + + ! Grid to tile + ! ------------ + + ! READ GIMMS NDVI source data files and regrid + ! ---------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/ndvi/v1/ndvi3g_geo_v1_YYYY_0106.nc4', NF_NOWRITE, ncid1) ; VERIFY_(STATUS) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/ndvi/v1/ndvi3g_geo_v1_YYYY_0712.nc4', NF_NOWRITE, ncid2) ; VERIFY_(STATUS) + status = NF_INQ_VARID (ncid2,'ndvi',VarID) ; VERIFY_(STATUS) + + allocate (ndvi_grid (1:NC,1:NR)) + allocate (data_grid (1 : N_lon_gimms, 1 : N_lat_gimms)) + allocate (data_grid2(1 : N_lon_gimms, 1 : N_lat_gimms)) + allocate (ndvi (1:NTILES)) + allocate (count_pix (1:NTILES)) + + ! writing tile-spaced output + ! -------------------------- + + open (31,file='clsm/ndvi.dat',status='unknown',action='write',form='unformatted', & + convert='little_endian') + + do K=0,13 + yr = (k+11)/12 + mn = mod(k+11,12)+1 + yr1= (k+12)/12 + mn1= mod(k+12,12)+1 + + ndvi = 0. + count_pix = 0. + t = k + if (k == 0 ) then + t = 12 + ncid = ncid2 + write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) + + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) + + do j = 1, N_lat_gimms + data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) + end do + + call RegridRasterReal(data_grid, ndvi_grid) + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then + ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + endif + end do + end do + + where (count_pix > 0.) ndvi = ndvi /count_pix + write(31) ndvi + + elseif (k == 13) then + + t = 1 + ncid = ncid1 + write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) + + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) + + do j = 1, N_lat_gimms + data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) + end do + + call RegridRasterReal(data_grid, ndvi_grid) - if(present (SubID)) then - status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 2 ,(/CellID, SubID/), vid) ; VERIFY_(STATUS) - else - status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 1 ,(/CellID/), vid) ; VERIFY_(STATUS) - endif + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then + ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + endif + end do + end do + + where (count_pix > 0.) ndvi = ndvi /count_pix + write(31) ndvi + + else + + do l = 1, 0 , -1 + t = k*2 - l + if (k <= 6) ncid = ncid1 + if (k >= 7) ncid = ncid2 + if (k >= 7) t = t - 12 + if(l == 1) write(31) float((/yr,mn,1,0,0,0,yr,mn,16,0,0,0,NTILES,1/)) + if(l == 0) write(31) float((/yr,mn,16,0,0,0,yr1,mn1,1,0,0,0,NTILES,1/)) + + ndvi = 0. + count_pix = 0. + + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,t/),(/N_lon_gimms, N_lat_gimms,1/), data_grid2) ; VERIFY_(STATUS) + + do j = 1, N_lat_gimms + data_grid (:,j) = data_grid2 (:,N_lat_gimms - (j-1)) / real(scale_fac) + end do + + call RegridRasterReal(data_grid, ndvi_grid) + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + if((ndvi_grid(i,j) >= val_min).and.(ndvi_grid(i,j) <= val_max)) then + ndvi (tile_id(i,j)) = ndvi (tile_id(i,j)) + ndvi_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + endif + end do + end do - status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', LEN_TRIM(long_name), trim(long_name)) ; VERIFY_(STATUS) - status = NF_PUT_ATT_TEXT(NCFID, vid, 'units' , LEN_TRIM(units) , trim(units)) ; VERIFY_(STATUS) + where (count_pix > 0.) ndvi = ndvi /count_pix + write(31) ndvi + end do + endif + end do - END SUBROUTINE DEF_VAR + close(31,status='keep') - END SUBROUTINE open_landparam_nc4_files + END SUBROUTINE gimms_clim_ndvi - ! ---------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------- + SUBROUTINE open_landparam_nc4_files(N_tile,process_snow_albedo) - SUBROUTINE map_country_codes (NC, NR) + implicit none + integer :: NCCatOUTID, NCCatCNOUTID, NCVegOUTID + integer :: STATUS, CellID1, CellID2, CellID3, SubID + integer, intent (in) :: N_tile + logical, intent (in) :: process_snow_albedo + integer, dimension(8) :: date_time_values + character (22) :: time_stamp + character (100) :: MYNAME + + status = NF_CREATE ('clsm/catch_params.nc4' , NF_NETCDF4, NCCatOUTID ) ; VERIFY_(STATUS) + status = NF_CREATE ('clsm/catchcn_params.nc4', NF_NETCDF4, NCCatCNOUTID) ; VERIFY_(STATUS) + status = NF_CREATE ('clsm/vegdyn.data' , NF_NETCDF4, NCVegOUTID ) ; VERIFY_(STATUS) + + status = NF_DEF_DIM(NCCatOUTID , 'tile' , N_tile, CellID1) + status = NF_DEF_DIM(NCCatCNOUTID, 'tile' , N_tile, CellID2) + status = NF_DEF_DIM(NCVegOUTID , 'tile' , N_tile, CellID3) + status = NF_DEF_DIM(NCCatCNOUTID, 'unknown_dim2' , 4, SubID) + + call DEF_VAR ( NCCatOUTID, CellID1,'OLD_ITY' ,'vegetation_type.' , '1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA1' ,'shape_param_1' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA2' ,'shape_param_2' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA3' ,'shape_param_3' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARA4' ,'shape_param_4' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARS1' ,'wetness_param_1' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARS2' ,'wetness_param_2' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARS3' ,'wetness_param_3' ,'m+4 kg-2' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW1' ,'min_theta_param_1' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW2' ,'min_theta_param_2' ,'m+2 kg-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW3' ,'min_theta_param_3' ,'m+4 kg-2' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ARW4' ,'min_theta_param_4' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ATAU2' ,'2cm_water_transfer_param_5' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'ATAU5' ,'5cm_water_transfer_param_5' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BEE' ,'clapp_hornberger_b' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BF1' ,'topo_baseflow_param_1' ,'kg m-4' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BF2' ,'topo_baseflow_param_2' ,'m' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BF3' ,'topo_baseflow_param_3' ,'log(m)' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BTAU2' ,'2cm_water_transfer_param_6' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'BTAU5' ,'5cm_water_transfer_param_6' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'COND' ,'sfc_sat_hydraulic_conduct' ,'m s-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'GNU' ,'vertical_transmissivity' ,'m-1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'POROS' ,'soil_porosity' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'PSIS' ,'saturated_matric_potential' ,'m' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSA1' ,'water_transfer_param_1' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSA2' ,'water_transfer_param_2' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSB1' ,'water_transfer_param_3' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'TSB2' ,'water_transfer_param_4' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'WPWET' ,'wetness_at_wilting_point' ,'1' ) + call DEF_VAR ( NCCatOUTID, CellID1,'DP2BR' ,'depth_to_bedrock' ,'mm' ) + if (process_snow_albedo) & + call DEF_VAR ( NCCatOUTID, CellID1,'SNOWALB' ,'snow_albedo' ,'1' ) + + call DEF_VAR ( NCVegOUTID, CellID3,'ITY' ,'vegetation_type' ,'1' ) + call DEF_VAR ( NCVegOUTID, CellID3,'Z2CH' ,'vegetation_height' ,'m' ) + call DEF_VAR ( NCVegOUTID, CellID3,'ASCATZ0' ,'ASCAT_roughness_length' ,'m' ) + + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNF' ,'MODIS soil albedo nir dif' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBNR' ,'MODIS soil albedo nir dir' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVF' ,'MODIS soil albedo vis dif' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'BGALBVR' ,'MODIS soil albedo vis dir' ,'1' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_M' ,'Clim 2m temperature (MERRA2)' ,'K' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'T2_S' ,'Clim 2m temperature (Sheffield)' ,'K' ) + call DEF_VAR ( NCCatCNOUTID, CellID2,'NDEP' ,'CLM_nitrogen_deposition' ,'g m-2 s-1') + call DEF_VAR ( NCCatCNOUTID, CellID2,'FVG' ,'vegetation_fraction' ,'1' ,SubID = SubID) + call DEF_VAR ( NCCatCNOUTID, CellID2,'ITY' ,'vegetation_type' ,'1' ,SubID = SubID) + + call date_and_time(VALUES=date_time_values) + + write (time_stamp,'(i4.4,a1,i2.2,a1,i2.2,1x,a2,1x,i2.2,a1,i2.2,a1,i2.2)') & + date_time_values(1),'-',date_time_values(2),'-',date_time_values(3),'at', & + date_time_values(5),':',date_time_values(6),':',date_time_values(7) + ! call execute_command_line('setenv MYNAME `finger $USER | cut -d: -f3 | head -1`') + ! call sleep (5) + call get_environment_variable ("USER" ,MYNAME ) + status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) + status = NF_PUT_ATT_TEXT(NCCatOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) + status = NF_PUT_ATT_TEXT(NCVegOUTID , NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'CreatedBy', LEN_TRIM(MYNAME), trim(MYNAME) ) + status = NF_PUT_ATT_TEXT(NCCatCNOUTID, NF_GLOBAL, 'Date' , LEN_TRIM(time_stamp),trim(time_stamp)) + + status = NF_ENDDEF(NCCatOUTID ) + status = NF_ENDDEF(NCVegOUTID ) + status = NF_ENDDEF(NCCatCNOUTID) + + status = NF_CLOSE (NCCatOUTID ) + status = NF_CLOSE (NCVegOUTID ) + status = NF_CLOSE (NCCatCNOUTID) + + contains + + SUBROUTINE DEF_VAR (NCFID, CellID, VarName, long_name, units, SubID) implicit none - integer , intent (in) :: nc, nr - - integer, parameter :: GC = 43200 - integer, parameter :: GR = 21600 - INTEGER, dimension (:), pointer :: index_RANGE - character*20, dimension (:), pointer :: ST_NAME - character*48, dimension (:), pointer :: CNT_NAME - - integer :: CNT_CODE, ST_CODE - integer :: i(GC),j(GR), k,n, status, ncid, varid, maxcat, I0(1), j0(1) - INTEGER, TARGET, ALLOCATABLE, dimension (:,:):: ST_grid, cnt_grid - real :: lat_mn, lat_mx, lon_mn, lon_mx - real (kind =8) :: XG(GC),YG(GR), y0, x0, dxy - - call get_country_codes (index_RANGE = index_RANGE, ST_NAME = ST_NAME, & - CNT_NAME = CNT_NAME) - - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', & - action = 'read') - - read (20, *) maxcat - - - ! READ country code source data files and regrid - ! ----------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/misc/country_codes/v1/GADM_Country_and_USStates_codes_1km.nc4', NF_NOWRITE, ncid) - - allocate (cnt_grid (1 : GC, 1 : GR)) - allocate (st_grid (1 : GC, 1 : GR)) - - status = NF_INQ_VARID (ncid,'UNIT_CODE',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,1/),(/GC, GR,1/), cnt_grid) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid,VarID, (/1,1,2/),(/GC, GR,1/), st_grid) ; VERIFY_(STATUS) - where (st_grid == 0) st_grid = 999 - status = NF_CLOSE(ncid) - - open (10,file='clsm/country_and_state_code.data', & + integer, intent (in) :: NCFID, CellID + character (*), intent (in) :: VarName, long_name, units + integer, intent (in), optional :: SubID + integer :: STATUS, VID + + if(present (SubID)) then + status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 2 ,(/CellID, SubID/), vid) ; VERIFY_(STATUS) + else + status = NF_DEF_VAR(NCFID, trim(VarName) , NF_FLOAT, 1 ,(/CellID/), vid) ; VERIFY_(STATUS) + endif + + status = NF_PUT_ATT_TEXT(NCFID, vid, 'long_name', LEN_TRIM(long_name), trim(long_name)) ; VERIFY_(STATUS) + status = NF_PUT_ATT_TEXT(NCFID, vid, 'units' , LEN_TRIM(units) , trim(units)) ; VERIFY_(STATUS) + + + END SUBROUTINE DEF_VAR + + END SUBROUTINE open_landparam_nc4_files + + ! ---------------------------------------------------------------------------------------------- + + + SUBROUTINE map_country_codes (NC, NR, n_land, tile_lon, tile_lat) + + implicit none + integer , intent(in) :: nc, nr, n_land + real, intent(in) :: tile_lon(:), tile_lat(:) + + integer, parameter :: GC = 43200 + integer, parameter :: GR = 21600 + INTEGER, dimension (:), pointer :: index_RANGE + character*20, dimension (:), pointer :: ST_NAME + character*48, dimension (:), pointer :: CNT_NAME + + integer :: CNT_CODE, ST_CODE + integer :: i(GC),j(GR), k,n, status, ncid, varid, I0(1), j0(1) + INTEGER, TARGET, ALLOCATABLE, dimension (:,:):: ST_grid, cnt_grid + real :: lat_mn, lat_mx, lon_mn, lon_mx + real (REAL64) :: XG(GC),YG(GR), y0, x0, dxy + + call get_country_codes (index_RANGE = index_RANGE, ST_NAME = ST_NAME, & + CNT_NAME = CNT_NAME) + + + + ! READ country code source data files and regrid + ! ----------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/misc/country_codes/v1/GADM_Country_and_USStates_codes_1km.nc4', NF_NOWRITE, ncid) + + allocate (cnt_grid (1 : GC, 1 : GR)) + allocate (st_grid (1 : GC, 1 : GR)) + + status = NF_INQ_VARID (ncid,'UNIT_CODE',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,1/),(/GC, GR,1/), cnt_grid) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid,VarID, (/1,1,2/),(/GC, GR,1/), st_grid) ; VERIFY_(STATUS) + where (st_grid == 0) st_grid = 999 + status = NF_CLOSE(ncid) + + open (10,file='clsm/country_and_state_code.data', & form='formatted',status='unknown') - dxy = 360./GC - do k = 1, GC - xg(k) = (k-1)*dxy -180. + dxy/2. - end do - do k = 1, GR - yg(k) = (k-1)*dxy -90. + dxy/2. - end do - - DO n = 1, MAXCAT - read (20,*) i0,j0, lon_mn, lon_mx, lat_mn, lat_mx - x0 = (lon_mn + lon_mx)/2. - y0 = (lat_mn + lat_mx)/2. - I = 0 - J = 0 - WHERE ((xg >= x0).and.(xg < x0 + dxy)) I = 1 - WHERE ((yg >= y0).and.(yg < y0 + dxy)) J = 1 - - I0 =FINDLOC(I,1) - J0 =FINDLOC(J,1) - - cnt_code = cnt_grid(I0(1), J0(1)) - st_code = st_grid (I0(1), J0(1)) - - if(cnt_code > 300) then - CNT_CODE = 257 - endif - - if(st_code <= 50) then - write (10, '(i10, 2I4, 1x, a48, a20)') n, cnt_code, st_code, CNT_NAME(FINDLOC(INDEX_RANGE, CNT_CODE)), ST_NAME (ST_CODE) - else - write (10, '(i10, 2I4, 1x, a48, a20)') n, cnt_code, st_code, CNT_NAME(FINDLOC(INDEX_RANGE, CNT_CODE)), 'OUTSIDE USA' - endif - - END DO - - close (10, status = 'keep') - close (20, status = 'keep') - END SUBROUTINE map_country_codes - - ! ------------------------------------------------------------------------------------------- - - SUBROUTINE get_country_codes (index_RANGE, ST_NAME, CNT_NAME, ST_NAME_ABR, CNT_NAME_ABR) - - implicit none - - INTEGER, dimension (N_GADM ), TARGET :: index_RANGE_DATA - character*20, dimension (N_STATES), TARGET :: ST_NAME_DATA - character*48, dimension (N_GADM ), TARGET :: CNT_NAME_DATA - INTEGER, dimension (:), pointer, intent (inout), optional :: index_RANGE - character*20, dimension (:), pointer, intent (inout), optional :: ST_NAME - character*48, dimension (:), pointer, intent (inout), optional :: CNT_NAME - character*2, dimension (:), pointer, intent (inout), optional :: ST_NAME_ABR - character*3, dimension (:), pointer, intent (inout), optional :: CNT_NAME_ABR - - DATA ST_NAME_DATA / & - 'AK 1 Alaska ' ,& - 'AL 2 Alabama ' ,& - 'AZ 3 Arizona ' ,& - 'AR 4 Arkansas ' ,& - 'CA 5 California ' ,& - 'CO 6 Colorado ' ,& - 'CT 7 Connecticut ' ,& - 'DE 8 Delaware ' ,& - 'FL 9 Florida ' ,& - 'GA 10 Georgia ' ,& - 'HI 11 Hawaii ' ,& - 'IA 12 Iowa ' ,& - 'ID 13 Idaho ' ,& - 'IL 14 Illinois ' ,& - 'IN 15 Indiana ' ,& - 'KS 16 Kansas ' ,& - 'KY 17 Kentucky ' ,& - 'LA 18 Louisiana ' ,& - 'MA 19 Massachusetts ' ,& - 'MD 20 Maryland ' ,& - 'ME 21 Maine ' ,& - 'MI 22 Michigan ' ,& - 'MN 23 Minnesota ' ,& - 'MO 24 Missouri ' ,& - 'MS 25 Mississippi ' ,& - 'MT 26 Montana ' ,& - 'NC 27 NorthCarolina ' ,& - 'ND 28 NorthDakota ' ,& - 'NE 29 Nebraska ' ,& - 'NH 30 NewHampshire ' ,& - 'NJ 31 NewJersey ' ,& - 'NM 32 NewMexico ' ,& - 'NV 33 Nevada ' ,& - 'NY 34 NewYork ' ,& - 'OH 35 Ohio ' ,& - 'OK 36 Oklahoma ' ,& - 'OR 37 Oregon ' ,& - 'PA 38 Pennsylvania ' ,& - 'RI 39 RhodeIsland ' ,& - 'SC 40 SouthCarolina ' ,& - 'SD 41 SouthDakota ' ,& - 'TN 42 Tennessee ' ,& - 'TX 43 Texas ' ,& - 'UT 44 Utah ' ,& - 'VA 45 Virginia ' ,& - 'VT 46 Vermont ' ,& - 'WA 47 Washington ' ,& - 'WI 48 Wisconsin ' ,& - 'WV 49 WestVirginia ' ,& - 'WY 50 Wyoming ' / - - DATA CNT_NAME_DATA / & - 'ABW 14 Aruba ' ,& - 'AFG 1 Afghanistan ' ,& - 'AGO 8 Angola ' ,& - 'AIA 9 Anguilla ' ,& - 'ALA 3 Aland ' ,& - 'ALB 4 Albania ' ,& - 'AND 7 Andorra ' ,& - 'ARE 241 United Arab Emirates ' ,& - 'ARG 12 Argentina ' ,& - 'ARM 13 Armenia ' ,& - 'ASM 6 American Samoa ' ,& - 'ATA 10 Antarctica ' ,& - 'ATF 82 French Southern Territories ' ,& - 'ATG 11 Antigua and Barbuda ' ,& - 'AUS 15 Australia ' ,& - 'AUT 16 Austria ' ,& - 'AZE 17 Azerbaijan ' ,& - 'BDI 39 Burundi ' ,& - 'BEL 23 Belgium ' ,& - 'BEN 25 Benin ' ,& - 'BES 29 Bonaire, Sint Eustatius and Saba ' ,& - 'BFA 38 Burkina Faso ' ,& - 'BGD 20 Bangladesh ' ,& - 'BGR 37 Bulgaria ' ,& - 'BHR 19 Bahrain ' ,& - 'BHS 18 Bahamas ' ,& - 'BIH 30 Bosnia and Herzegovina ' ,& - 'BLM 190 Saint-Barthelemy ' ,& - 'BLR 22 Belarus ' ,& - 'BLZ 24 Belize ' ,& - 'BMU 26 Bermuda ' ,& - 'BOL 28 Bolivia ' ,& - 'BRA 33 Brazil ' ,& - 'BRB 21 Barbados ' ,& - 'BRN 36 Brunei ' ,& - 'BTN 27 Bhutan ' ,& - 'BVT 32 Bouvet Island ' ,& - 'BWA 31 Botswana ' ,& - 'CAF 46 Central African Republic ' ,& - 'CAN 42 Canada ' ,& - 'CCK 52 Cocos Islands ' ,& - 'CHE 223 Switzerland ' ,& - 'CHL 48 Chile ' ,& - 'CHN 49 China ' ,& - 'CIV 57 Cote dIvoire ' ,& - 'CMR 41 Cameroon ' ,& - 'COD 0 Democratic Republic of the Congo ' ,& - 'COG 185 Republic of Congo ' ,& - 'COK 55 Cook Islands ' ,& - 'COL 53 Colombia ' ,& - 'COM 54 Comoros ' ,& - 'CPV 43 Cape Verde ' ,& - 'CRI 56 Costa Rica ' ,& - 'CUB 59 Cuba ' ,& - 'CUW 60 Curacao ' ,& - 'CXR 50 Christmas Island ' ,& - 'CYM 45 Cayman Islands ' ,& - 'CYP 61 Cyprus ' ,& - 'CZE 62 Czech Republic ' ,& - 'DEU 86 Germany ' ,& - 'DJI 65 Djibouti ' ,& - 'DMA 66 Dominica ' ,& - 'DNK 64 Denmark ' ,& - 'DOM 67 Dominican Republic ' ,& - 'DZA 5 Algeria ' ,& - 'ECU 68 Ecuador ' ,& - 'EGY 69 Egypt ' ,& - 'ERI 72 Eritrea ' ,& - 'ESH 253 Western Sahara ' ,& - 'ESP 215 Spain ' ,& - 'EST 73 Estonia ' ,& - 'ETH 74 Ethiopia ' ,& - 'FIN 78 Finland ' ,& - 'FJI 77 Fiji ' ,& - 'FLK 75 Falkland Islands ' ,& - 'FRA 79 France ' ,& - 'FRO 76 Faroe Islands ' ,& - 'FSM 146 Micronesia ' ,& - 'GAB 83 Gabon ' ,& - 'GBR 242 United Kingdom ' ,& - 'GEO 85 Georgia ' ,& - 'GGY 95 Guernsey ' ,& - 'GHA 87 Ghana ' ,& - 'GIB 88 Gibraltar ' ,& - 'GIN 96 Guinea ' ,& - 'GLP 92 Guadeloupe ' ,& - 'GMB 84 Gambia ' ,& - 'GNB 97 Guinea-Bissau ' ,& - 'GNQ 71 Equatorial Guinea ' ,& - 'GRC 89 Greece ' ,& - 'GRD 91 Grenada ' ,& - 'GRL 90 Greenland ' ,& - 'GTM 94 Guatemala ' ,& - 'GUF 80 French Guiana ' ,& - 'GUM 93 Guam ' ,& - 'GUY 98 Guyana ' ,& - 'HKG 102 Hong Kong ' ,& - 'HMD 100 Heard Island and McDonald Islands ' ,& - 'HND 101 Honduras ' ,& - 'HRV 58 Croatia ' ,& - 'HTI 99 Haiti ' ,& - 'HUN 103 Hungary ' ,& - 'IDN 106 Indonesia ' ,& - 'IMN 110 Isle of Man ' ,& - 'IND 105 India ' ,& - 'IOT 34 British Indian Ocean Territory ' ,& - 'IRL 109 Ireland ' ,& - 'IRN 107 Iran ' ,& - 'IRQ 108 Iraq ' ,& - 'ISL 104 Iceland ' ,& - 'ISR 111 Israel ' ,& - 'ITA 112 Italy ' ,& - 'JAM 113 Jamaica ' ,& - 'JEY 115 Jersey ' ,& - 'JOR 116 Jordan ' ,& - 'JPN 114 Japan ' ,& - 'KAZ 117 Kazakhstan ' ,& - 'KEN 118 Kenya ' ,& - 'KGZ 122 Kyrgyzstan ' ,& - 'KHM 40 Cambodia ' ,& - 'KIR 119 Kiribati ' ,& - 'KNA 193 Saint Kitts and Nevis ' ,& - 'KOR 213 South Korea ' ,& - 'KWT 121 Kuwait ' ,& - 'LAO 123 Laos ' ,& - 'LBN 125 Lebanon ' ,& - 'LBR 127 Liberia ' ,& - 'LBY 128 Libya ' ,& - 'LCA 194 Saint Lucia ' ,& - 'LIE 129 Liechtenstein ' ,& - 'LKA 217 Sri Lanka ' ,& - 'LSO 126 Lesotho ' ,& - 'LTU 130 Lithuania ' ,& - 'LUX 131 Luxembourg ' ,& - 'LVA 124 Latvia ' ,& - 'MAC 132 Macao ' ,& - 'MAF 191 Saint-Martin ' ,& - 'MAR 152 Morocco ' ,& - 'MCO 148 Monaco ' ,& - 'MDA 147 Moldova ' ,& - 'MDG 134 Madagascar ' ,& - 'MDV 137 Maldives ' ,& - 'MEX 145 Mexico ' ,& - 'MHL 140 Marshall Islands ' ,& - 'MKD 133 Macedonia ' ,& - 'MLI 138 Mali ' ,& - 'MLT 139 Malta ' ,& - 'MMR 154 Myanmar ' ,& - 'MNE 150 Montenegro ' ,& - 'MNG 149 Mongolia ' ,& - 'MNP 168 Northern Mariana Islands ' ,& - 'MOZ 153 Mozambique ' ,& - 'MRT 142 Mauritania ' ,& - 'MSR 151 Montserrat ' ,& - 'MTQ 141 Martinique ' ,& - 'MUS 143 Mauritius ' ,& - 'MWI 135 Malawi ' ,& - 'MYS 136 Malaysia ' ,& - 'MYT 144 Mayotte ' ,& - 'NAM 155 Namibia ' ,& - 'NCL 159 New Caledonia ' ,& - 'NER 162 Niger ' ,& - 'NFK 165 Norfolk Island ' ,& - 'NGA 163 Nigeria ' ,& - 'NIC 161 Nicaragua ' ,& - 'NIU 164 Niue ' ,& - 'NLD 158 Netherlands ' ,& - 'NOR 169 Norway ' ,& - 'NPL 157 Nepal ' ,& - 'NRU 156 Nauru ' ,& - 'NZL 160 New Zealand ' ,& - 'OMN 170 Oman ' ,& - 'PAK 171 Pakistan ' ,& - 'PAN 174 Panama ' ,& - 'PCN 180 Pitcairn Islands ' ,& - 'PER 178 Peru ' ,& - 'PHL 179 Philippines ' ,& - 'PLW 172 Palau ' ,& - 'PNG 175 Papua New Guinea ' ,& - 'POL 181 Poland ' ,& - 'PRI 183 Puerto Rico ' ,& - 'PRK 166 North Korea ' ,& - 'PRT 182 Portugal ' ,& - 'PRY 177 Paraguay ' ,& - 'PSE 173 Palestina ' ,& - 'PYF 81 French Polynesia ' ,& - 'QAT 184 Qatar ' ,& - 'REU 186 Reunion ' ,& - 'ROU 187 Romania ' ,& - 'RUS 188 Russia ' ,& - 'RWA 189 Rwanda ' ,& - 'SAU 200 Saudi Arabia ' ,& - 'SDN 218 Sudan ' ,& - 'SEN 201 Senegal ' ,& - 'SGP 205 Singapore ' ,& - 'SGS 212 South Georgia and the South Sandwich Is ' ,& - 'SHN 192 Saint Helena ' ,& - 'SJM 220 Svalbard and Jan Mayen ' ,& - 'SLB 209 Solomon Islands ' ,& - 'SLE 204 Sierra Leone ' ,& - 'SLV 70 El Salvador ' ,& - 'SMR 198 San Marino ' ,& - 'SOM 210 Somalia ' ,& - 'SPM 195 Saint Pierre and Miquelon ' ,& - 'SRB 202 Serbia ' ,& - 'SSD 214 South Sudan ' ,& - 'STP 199 Sao Tome and Principe ' ,& - 'SUR 219 Suriname ' ,& - 'SVK 207 Slovakia ' ,& - 'SVN 208 Slovenia ' ,& - 'SWE 222 Sweden ' ,& - 'SWZ 221 Swaziland ' ,& - 'SXM 206 Sint Maarten ' ,& - 'SYC 203 Seychelles ' ,& - 'SYR 224 Syria ' ,& - 'TCA 237 Turks and Caicos Islands ' ,& - 'TCD 47 Chad ' ,& - 'TGO 230 Togo ' ,& - 'THA 228 Thailand ' ,& - 'TJK 226 Tajikistan ' ,& - 'TKL 231 Tokelau ' ,& - 'TKM 236 Turkmenistan ' ,& - 'TLS 229 Timor-Leste ' ,& - 'TON 232 Tonga ' ,& - 'TTO 233 Trinidad and Tobago ' ,& - 'TUN 234 Tunisia ' ,& - 'TUR 235 Turkey ' ,& - 'TUV 238 Tuvalu ' ,& - 'TWN 225 Taiwan ' ,& - 'TZA 227 Tanzania ' ,& - 'UGA 239 Uganda ' ,& - 'UKR 240 Ukraine ' ,& - 'UMI 244 United States Minor Outlying Islands ' ,& - 'URY 245 Uruguay ' ,& - 'USA 243 United States ' ,& - 'UZB 246 Uzbekistan ' ,& - 'VAT 248 Vatican City ' ,& - 'VCT 196 Saint Vincent and the Grenadines ' ,& - 'VEN 249 Venezuela ' ,& - 'VGB 35 British Virgin Islands ' ,& - 'VIR 251 Virgin Islands, U.S. ' ,& - 'VNM 250 Vietnam ' ,& - 'VUT 247 Vanuatu ' ,& - 'WLF 252 Wallis and Futuna ' ,& - 'WSM 197 Samoa ' ,& - 'XAD 2 Akrotiri and Dhekelia ' ,& - 'XCA 44 Caspian Sea ' ,& - 'XCL 51 Clipperton Island ' ,& - 'XKO 120 Kosovo ' ,& - 'XNC 167 Northern Cyprus ' ,& - 'XPI 176 Paracel Islands ' ,& - 'XSP 216 Spratly Islands ' ,& - 'YEM 254 Yemen ' ,& - 'ZAF 211 South Africa ' ,& - 'ZMB 255 Zambia ' ,& - 'ZWE 256 Zimbabwe ' ,& - 'UNK 257 Unknown '/ - - DATA INDEX_RANGE_DATA / & - 14 ,& - 1 ,& - 8 ,& - 9 ,& - 3 ,& - 4 ,& - 7 ,& - 241 ,& - 12 ,& - 13 ,& - 6 ,& - 10 ,& - 82 ,& - 11 ,& - 15 ,& - 16 ,& - 17 ,& - 39 ,& - 23 ,& - 25 ,& - 29 ,& - 38 ,& - 20 ,& - 37 ,& - 19 ,& - 18 ,& - 30 ,& - 190 ,& - 22 ,& - 24 ,& - 26 ,& - 28 ,& - 33 ,& - 21 ,& - 36 ,& - 27 ,& - 32 ,& - 31 ,& - 46 ,& - 42 ,& - 52 ,& - 223 ,& - 48 ,& - 49 ,& - 57 ,& - 41 ,& - 0 ,& - 185 ,& - 55 ,& - 53 ,& - 54 ,& - 43 ,& - 56 ,& - 59 ,& - 60 ,& - 50 ,& - 45 ,& - 61 ,& - 62 ,& - 86 ,& - 65 ,& - 66 ,& - 64 ,& - 67 ,& - 5 ,& - 68 ,& - 69 ,& - 72 ,& - 253 ,& - 215 ,& - 73 ,& - 74 ,& - 78 ,& - 77 ,& - 75 ,& - 79 ,& - 76 ,& - 146 ,& - 83 ,& - 242 ,& - 85 ,& - 95 ,& - 87 ,& - 88 ,& - 96 ,& - 92 ,& - 84 ,& - 97 ,& - 71 ,& - 89 ,& - 91 ,& - 90 ,& - 94 ,& - 80 ,& - 93 ,& - 98 ,& - 102 ,& - 100 ,& - 101 ,& - 58 ,& - 99 ,& - 103 ,& - 106 ,& - 110 ,& - 105 ,& - 34 ,& - 109 ,& - 107 ,& - 108 ,& - 104 ,& - 111 ,& - 112 ,& - 113 ,& - 115 ,& - 116 ,& - 114 ,& - 117 ,& - 118 ,& - 122 ,& - 40 ,& - 119 ,& - 193 ,& - 213 ,& - 121 ,& - 123 ,& - 125 ,& - 127 ,& - 128 ,& - 194 ,& - 129 ,& - 217 ,& - 126 ,& - 130 ,& - 131 ,& - 124 ,& - 132 ,& - 191 ,& - 152 ,& - 148 ,& - 147 ,& - 134 ,& - 137 ,& - 145 ,& - 140 ,& - 133 ,& - 138 ,& - 139 ,& - 154 ,& - 150 ,& - 149 ,& - 168 ,& - 153 ,& - 142 ,& - 151 ,& - 141 ,& - 143 ,& - 135 ,& - 136 ,& - 144 ,& - 155 ,& - 159 ,& - 162 ,& - 165 ,& - 163 ,& - 161 ,& - 164 ,& - 158 ,& - 169 ,& - 157 ,& - 156 ,& - 160 ,& - 170 ,& - 171 ,& - 174 ,& - 180 ,& - 178 ,& - 179 ,& - 172 ,& - 175 ,& - 181 ,& - 183 ,& - 166 ,& - 182 ,& - 177 ,& - 173 ,& - 81 ,& - 184 ,& - 186 ,& - 187 ,& - 188 ,& - 189 ,& - 200 ,& - 218 ,& - 201 ,& - 205 ,& - 212 ,& - 192 ,& - 220 ,& - 209 ,& - 204 ,& - 70 ,& - 198 ,& - 210 ,& - 195 ,& - 202 ,& - 214 ,& - 199 ,& - 219 ,& - 207 ,& - 208 ,& - 222 ,& - 221 ,& - 206 ,& - 203 ,& - 224 ,& - 237 ,& - 47 ,& - 230 ,& - 228 ,& - 226 ,& - 231 ,& - 236 ,& - 229 ,& - 232 ,& - 233 ,& - 234 ,& - 235 ,& - 238 ,& - 225 ,& - 227 ,& - 239 ,& - 240 ,& - 244 ,& - 245 ,& - 243 ,& - 246 ,& - 248 ,& - 196 ,& - 249 ,& - 35 ,& - 251 ,& - 250 ,& - 247 ,& - 252 ,& - 197 ,& - 2 ,& - 44 ,& - 51 ,& - 120 ,& - 167 ,& - 176 ,& - 216 ,& - 254 ,& - 211 ,& - 255 ,& - 256 ,& - 257 / - - if(present(index_RANGE )) index_RANGE => index_RANGE_DATA - if(present(ST_NAME )) ST_NAME => ST_NAME_DATA - if(present(CNT_NAME )) CNT_NAME => CNT_NAME_DATA - if(present(ST_NAME_ABR )) ST_NAME_ABR => ST_NAME_DATA (:)(1:2) - if(present(CNT_NAME_ABR)) CNT_NAME_ABR=> CNT_NAME_DATA(:)(1:3) - - END SUBROUTINE get_country_codes - - END MODULE process_hres_data + dxy = 360./GC + do k = 1, GC + xg(k) = (k-1)*dxy -180. + dxy/2. + end do + do k = 1, GR + yg(k) = (k-1)*dxy -90. + dxy/2. + end do + + DO n = 1, n_land + x0 = tile_lon(n) + y0 = tile_lat(n) + I = 0 + J = 0 + WHERE ((xg >= x0).and.(xg < x0 + dxy)) I = 1 + WHERE ((yg >= y0).and.(yg < y0 + dxy)) J = 1 + + I0 =FINDLOC(I,1) + J0 =FINDLOC(J,1) + + cnt_code = cnt_grid(I0(1), J0(1)) + st_code = st_grid (I0(1), J0(1)) + + if(cnt_code > 300) then + CNT_CODE = 257 + endif + + if(st_code <= 50) then + write (10, '(i10, 2I4, 1x, a48, a20)') n, cnt_code, st_code, CNT_NAME(FINDLOC(INDEX_RANGE, CNT_CODE)), ST_NAME (ST_CODE) + else + write (10, '(i10, 2I4, 1x, a48, a20)') n, cnt_code, st_code, CNT_NAME(FINDLOC(INDEX_RANGE, CNT_CODE)), 'OUTSIDE USA' + endif + + END DO + close (10, status = 'keep') + END SUBROUTINE map_country_codes + + ! ------------------------------------------------------------------------------------------- + + SUBROUTINE get_country_codes (index_RANGE, ST_NAME, CNT_NAME, ST_NAME_ABR, CNT_NAME_ABR) + + implicit none + + INTEGER, dimension (N_GADM ), TARGET :: index_RANGE_DATA + character*20, dimension (N_STATES), TARGET :: ST_NAME_DATA + character*48, dimension (N_GADM ), TARGET :: CNT_NAME_DATA + INTEGER, dimension (:), pointer, intent (inout), optional :: index_RANGE + character*20, dimension (:), pointer, intent (inout), optional :: ST_NAME + character*48, dimension (:), pointer, intent (inout), optional :: CNT_NAME + character*2, dimension (:), pointer, intent (inout), optional :: ST_NAME_ABR + character*3, dimension (:), pointer, intent (inout), optional :: CNT_NAME_ABR + + DATA ST_NAME_DATA / & + 'AK 1 Alaska ' ,& + 'AL 2 Alabama ' ,& + 'AZ 3 Arizona ' ,& + 'AR 4 Arkansas ' ,& + 'CA 5 California ' ,& + 'CO 6 Colorado ' ,& + 'CT 7 Connecticut ' ,& + 'DE 8 Delaware ' ,& + 'FL 9 Florida ' ,& + 'GA 10 Georgia ' ,& + 'HI 11 Hawaii ' ,& + 'IA 12 Iowa ' ,& + 'ID 13 Idaho ' ,& + 'IL 14 Illinois ' ,& + 'IN 15 Indiana ' ,& + 'KS 16 Kansas ' ,& + 'KY 17 Kentucky ' ,& + 'LA 18 Louisiana ' ,& + 'MA 19 Massachusetts ' ,& + 'MD 20 Maryland ' ,& + 'ME 21 Maine ' ,& + 'MI 22 Michigan ' ,& + 'MN 23 Minnesota ' ,& + 'MO 24 Missouri ' ,& + 'MS 25 Mississippi ' ,& + 'MT 26 Montana ' ,& + 'NC 27 NorthCarolina ' ,& + 'ND 28 NorthDakota ' ,& + 'NE 29 Nebraska ' ,& + 'NH 30 NewHampshire ' ,& + 'NJ 31 NewJersey ' ,& + 'NM 32 NewMexico ' ,& + 'NV 33 Nevada ' ,& + 'NY 34 NewYork ' ,& + 'OH 35 Ohio ' ,& + 'OK 36 Oklahoma ' ,& + 'OR 37 Oregon ' ,& + 'PA 38 Pennsylvania ' ,& + 'RI 39 RhodeIsland ' ,& + 'SC 40 SouthCarolina ' ,& + 'SD 41 SouthDakota ' ,& + 'TN 42 Tennessee ' ,& + 'TX 43 Texas ' ,& + 'UT 44 Utah ' ,& + 'VA 45 Virginia ' ,& + 'VT 46 Vermont ' ,& + 'WA 47 Washington ' ,& + 'WI 48 Wisconsin ' ,& + 'WV 49 WestVirginia ' ,& + 'WY 50 Wyoming ' / + + DATA CNT_NAME_DATA / & + 'ABW 14 Aruba ' ,& + 'AFG 1 Afghanistan ' ,& + 'AGO 8 Angola ' ,& + 'AIA 9 Anguilla ' ,& + 'ALA 3 Aland ' ,& + 'ALB 4 Albania ' ,& + 'AND 7 Andorra ' ,& + 'ARE 241 United Arab Emirates ' ,& + 'ARG 12 Argentina ' ,& + 'ARM 13 Armenia ' ,& + 'ASM 6 American Samoa ' ,& + 'ATA 10 Antarctica ' ,& + 'ATF 82 French Southern Territories ' ,& + 'ATG 11 Antigua and Barbuda ' ,& + 'AUS 15 Australia ' ,& + 'AUT 16 Austria ' ,& + 'AZE 17 Azerbaijan ' ,& + 'BDI 39 Burundi ' ,& + 'BEL 23 Belgium ' ,& + 'BEN 25 Benin ' ,& + 'BES 29 Bonaire, Sint Eustatius and Saba ' ,& + 'BFA 38 Burkina Faso ' ,& + 'BGD 20 Bangladesh ' ,& + 'BGR 37 Bulgaria ' ,& + 'BHR 19 Bahrain ' ,& + 'BHS 18 Bahamas ' ,& + 'BIH 30 Bosnia and Herzegovina ' ,& + 'BLM 190 Saint-Barthelemy ' ,& + 'BLR 22 Belarus ' ,& + 'BLZ 24 Belize ' ,& + 'BMU 26 Bermuda ' ,& + 'BOL 28 Bolivia ' ,& + 'BRA 33 Brazil ' ,& + 'BRB 21 Barbados ' ,& + 'BRN 36 Brunei ' ,& + 'BTN 27 Bhutan ' ,& + 'BVT 32 Bouvet Island ' ,& + 'BWA 31 Botswana ' ,& + 'CAF 46 Central African Republic ' ,& + 'CAN 42 Canada ' ,& + 'CCK 52 Cocos Islands ' ,& + 'CHE 223 Switzerland ' ,& + 'CHL 48 Chile ' ,& + 'CHN 49 China ' ,& + 'CIV 57 Cote dIvoire ' ,& + 'CMR 41 Cameroon ' ,& + 'COD 0 Democratic Republic of the Congo ' ,& + 'COG 185 Republic of Congo ' ,& + 'COK 55 Cook Islands ' ,& + 'COL 53 Colombia ' ,& + 'COM 54 Comoros ' ,& + 'CPV 43 Cape Verde ' ,& + 'CRI 56 Costa Rica ' ,& + 'CUB 59 Cuba ' ,& + 'CUW 60 Curacao ' ,& + 'CXR 50 Christmas Island ' ,& + 'CYM 45 Cayman Islands ' ,& + 'CYP 61 Cyprus ' ,& + 'CZE 62 Czech Republic ' ,& + 'DEU 86 Germany ' ,& + 'DJI 65 Djibouti ' ,& + 'DMA 66 Dominica ' ,& + 'DNK 64 Denmark ' ,& + 'DOM 67 Dominican Republic ' ,& + 'DZA 5 Algeria ' ,& + 'ECU 68 Ecuador ' ,& + 'EGY 69 Egypt ' ,& + 'ERI 72 Eritrea ' ,& + 'ESH 253 Western Sahara ' ,& + 'ESP 215 Spain ' ,& + 'EST 73 Estonia ' ,& + 'ETH 74 Ethiopia ' ,& + 'FIN 78 Finland ' ,& + 'FJI 77 Fiji ' ,& + 'FLK 75 Falkland Islands ' ,& + 'FRA 79 France ' ,& + 'FRO 76 Faroe Islands ' ,& + 'FSM 146 Micronesia ' ,& + 'GAB 83 Gabon ' ,& + 'GBR 242 United Kingdom ' ,& + 'GEO 85 Georgia ' ,& + 'GGY 95 Guernsey ' ,& + 'GHA 87 Ghana ' ,& + 'GIB 88 Gibraltar ' ,& + 'GIN 96 Guinea ' ,& + 'GLP 92 Guadeloupe ' ,& + 'GMB 84 Gambia ' ,& + 'GNB 97 Guinea-Bissau ' ,& + 'GNQ 71 Equatorial Guinea ' ,& + 'GRC 89 Greece ' ,& + 'GRD 91 Grenada ' ,& + 'GRL 90 Greenland ' ,& + 'GTM 94 Guatemala ' ,& + 'GUF 80 French Guiana ' ,& + 'GUM 93 Guam ' ,& + 'GUY 98 Guyana ' ,& + 'HKG 102 Hong Kong ' ,& + 'HMD 100 Heard Island and McDonald Islands ' ,& + 'HND 101 Honduras ' ,& + 'HRV 58 Croatia ' ,& + 'HTI 99 Haiti ' ,& + 'HUN 103 Hungary ' ,& + 'IDN 106 Indonesia ' ,& + 'IMN 110 Isle of Man ' ,& + 'IND 105 India ' ,& + 'IOT 34 British Indian Ocean Territory ' ,& + 'IRL 109 Ireland ' ,& + 'IRN 107 Iran ' ,& + 'IRQ 108 Iraq ' ,& + 'ISL 104 Iceland ' ,& + 'ISR 111 Israel ' ,& + 'ITA 112 Italy ' ,& + 'JAM 113 Jamaica ' ,& + 'JEY 115 Jersey ' ,& + 'JOR 116 Jordan ' ,& + 'JPN 114 Japan ' ,& + 'KAZ 117 Kazakhstan ' ,& + 'KEN 118 Kenya ' ,& + 'KGZ 122 Kyrgyzstan ' ,& + 'KHM 40 Cambodia ' ,& + 'KIR 119 Kiribati ' ,& + 'KNA 193 Saint Kitts and Nevis ' ,& + 'KOR 213 South Korea ' ,& + 'KWT 121 Kuwait ' ,& + 'LAO 123 Laos ' ,& + 'LBN 125 Lebanon ' ,& + 'LBR 127 Liberia ' ,& + 'LBY 128 Libya ' ,& + 'LCA 194 Saint Lucia ' ,& + 'LIE 129 Liechtenstein ' ,& + 'LKA 217 Sri Lanka ' ,& + 'LSO 126 Lesotho ' ,& + 'LTU 130 Lithuania ' ,& + 'LUX 131 Luxembourg ' ,& + 'LVA 124 Latvia ' ,& + 'MAC 132 Macao ' ,& + 'MAF 191 Saint-Martin ' ,& + 'MAR 152 Morocco ' ,& + 'MCO 148 Monaco ' ,& + 'MDA 147 Moldova ' ,& + 'MDG 134 Madagascar ' ,& + 'MDV 137 Maldives ' ,& + 'MEX 145 Mexico ' ,& + 'MHL 140 Marshall Islands ' ,& + 'MKD 133 Macedonia ' ,& + 'MLI 138 Mali ' ,& + 'MLT 139 Malta ' ,& + 'MMR 154 Myanmar ' ,& + 'MNE 150 Montenegro ' ,& + 'MNG 149 Mongolia ' ,& + 'MNP 168 Northern Mariana Islands ' ,& + 'MOZ 153 Mozambique ' ,& + 'MRT 142 Mauritania ' ,& + 'MSR 151 Montserrat ' ,& + 'MTQ 141 Martinique ' ,& + 'MUS 143 Mauritius ' ,& + 'MWI 135 Malawi ' ,& + 'MYS 136 Malaysia ' ,& + 'MYT 144 Mayotte ' ,& + 'NAM 155 Namibia ' ,& + 'NCL 159 New Caledonia ' ,& + 'NER 162 Niger ' ,& + 'NFK 165 Norfolk Island ' ,& + 'NGA 163 Nigeria ' ,& + 'NIC 161 Nicaragua ' ,& + 'NIU 164 Niue ' ,& + 'NLD 158 Netherlands ' ,& + 'NOR 169 Norway ' ,& + 'NPL 157 Nepal ' ,& + 'NRU 156 Nauru ' ,& + 'NZL 160 New Zealand ' ,& + 'OMN 170 Oman ' ,& + 'PAK 171 Pakistan ' ,& + 'PAN 174 Panama ' ,& + 'PCN 180 Pitcairn Islands ' ,& + 'PER 178 Peru ' ,& + 'PHL 179 Philippines ' ,& + 'PLW 172 Palau ' ,& + 'PNG 175 Papua New Guinea ' ,& + 'POL 181 Poland ' ,& + 'PRI 183 Puerto Rico ' ,& + 'PRK 166 North Korea ' ,& + 'PRT 182 Portugal ' ,& + 'PRY 177 Paraguay ' ,& + 'PSE 173 Palestina ' ,& + 'PYF 81 French Polynesia ' ,& + 'QAT 184 Qatar ' ,& + 'REU 186 Reunion ' ,& + 'ROU 187 Romania ' ,& + 'RUS 188 Russia ' ,& + 'RWA 189 Rwanda ' ,& + 'SAU 200 Saudi Arabia ' ,& + 'SDN 218 Sudan ' ,& + 'SEN 201 Senegal ' ,& + 'SGP 205 Singapore ' ,& + 'SGS 212 South Georgia and the South Sandwich Is ' ,& + 'SHN 192 Saint Helena ' ,& + 'SJM 220 Svalbard and Jan Mayen ' ,& + 'SLB 209 Solomon Islands ' ,& + 'SLE 204 Sierra Leone ' ,& + 'SLV 70 El Salvador ' ,& + 'SMR 198 San Marino ' ,& + 'SOM 210 Somalia ' ,& + 'SPM 195 Saint Pierre and Miquelon ' ,& + 'SRB 202 Serbia ' ,& + 'SSD 214 South Sudan ' ,& + 'STP 199 Sao Tome and Principe ' ,& + 'SUR 219 Suriname ' ,& + 'SVK 207 Slovakia ' ,& + 'SVN 208 Slovenia ' ,& + 'SWE 222 Sweden ' ,& + 'SWZ 221 Swaziland ' ,& + 'SXM 206 Sint Maarten ' ,& + 'SYC 203 Seychelles ' ,& + 'SYR 224 Syria ' ,& + 'TCA 237 Turks and Caicos Islands ' ,& + 'TCD 47 Chad ' ,& + 'TGO 230 Togo ' ,& + 'THA 228 Thailand ' ,& + 'TJK 226 Tajikistan ' ,& + 'TKL 231 Tokelau ' ,& + 'TKM 236 Turkmenistan ' ,& + 'TLS 229 Timor-Leste ' ,& + 'TON 232 Tonga ' ,& + 'TTO 233 Trinidad and Tobago ' ,& + 'TUN 234 Tunisia ' ,& + 'TUR 235 Turkey ' ,& + 'TUV 238 Tuvalu ' ,& + 'TWN 225 Taiwan ' ,& + 'TZA 227 Tanzania ' ,& + 'UGA 239 Uganda ' ,& + 'UKR 240 Ukraine ' ,& + 'UMI 244 United States Minor Outlying Islands ' ,& + 'URY 245 Uruguay ' ,& + 'USA 243 United States ' ,& + 'UZB 246 Uzbekistan ' ,& + 'VAT 248 Vatican City ' ,& + 'VCT 196 Saint Vincent and the Grenadines ' ,& + 'VEN 249 Venezuela ' ,& + 'VGB 35 British Virgin Islands ' ,& + 'VIR 251 Virgin Islands, U.S. ' ,& + 'VNM 250 Vietnam ' ,& + 'VUT 247 Vanuatu ' ,& + 'WLF 252 Wallis and Futuna ' ,& + 'WSM 197 Samoa ' ,& + 'XAD 2 Akrotiri and Dhekelia ' ,& + 'XCA 44 Caspian Sea ' ,& + 'XCL 51 Clipperton Island ' ,& + 'XKO 120 Kosovo ' ,& + 'XNC 167 Northern Cyprus ' ,& + 'XPI 176 Paracel Islands ' ,& + 'XSP 216 Spratly Islands ' ,& + 'YEM 254 Yemen ' ,& + 'ZAF 211 South Africa ' ,& + 'ZMB 255 Zambia ' ,& + 'ZWE 256 Zimbabwe ' ,& + 'UNK 257 Unknown '/ + + DATA INDEX_RANGE_DATA / & + 14 ,& + 1 ,& + 8 ,& + 9 ,& + 3 ,& + 4 ,& + 7 ,& + 241 ,& + 12 ,& + 13 ,& + 6 ,& + 10 ,& + 82 ,& + 11 ,& + 15 ,& + 16 ,& + 17 ,& + 39 ,& + 23 ,& + 25 ,& + 29 ,& + 38 ,& + 20 ,& + 37 ,& + 19 ,& + 18 ,& + 30 ,& + 190 ,& + 22 ,& + 24 ,& + 26 ,& + 28 ,& + 33 ,& + 21 ,& + 36 ,& + 27 ,& + 32 ,& + 31 ,& + 46 ,& + 42 ,& + 52 ,& + 223 ,& + 48 ,& + 49 ,& + 57 ,& + 41 ,& + 0 ,& + 185 ,& + 55 ,& + 53 ,& + 54 ,& + 43 ,& + 56 ,& + 59 ,& + 60 ,& + 50 ,& + 45 ,& + 61 ,& + 62 ,& + 86 ,& + 65 ,& + 66 ,& + 64 ,& + 67 ,& + 5 ,& + 68 ,& + 69 ,& + 72 ,& + 253 ,& + 215 ,& + 73 ,& + 74 ,& + 78 ,& + 77 ,& + 75 ,& + 79 ,& + 76 ,& + 146 ,& + 83 ,& + 242 ,& + 85 ,& + 95 ,& + 87 ,& + 88 ,& + 96 ,& + 92 ,& + 84 ,& + 97 ,& + 71 ,& + 89 ,& + 91 ,& + 90 ,& + 94 ,& + 80 ,& + 93 ,& + 98 ,& + 102 ,& + 100 ,& + 101 ,& + 58 ,& + 99 ,& + 103 ,& + 106 ,& + 110 ,& + 105 ,& + 34 ,& + 109 ,& + 107 ,& + 108 ,& + 104 ,& + 111 ,& + 112 ,& + 113 ,& + 115 ,& + 116 ,& + 114 ,& + 117 ,& + 118 ,& + 122 ,& + 40 ,& + 119 ,& + 193 ,& + 213 ,& + 121 ,& + 123 ,& + 125 ,& + 127 ,& + 128 ,& + 194 ,& + 129 ,& + 217 ,& + 126 ,& + 130 ,& + 131 ,& + 124 ,& + 132 ,& + 191 ,& + 152 ,& + 148 ,& + 147 ,& + 134 ,& + 137 ,& + 145 ,& + 140 ,& + 133 ,& + 138 ,& + 139 ,& + 154 ,& + 150 ,& + 149 ,& + 168 ,& + 153 ,& + 142 ,& + 151 ,& + 141 ,& + 143 ,& + 135 ,& + 136 ,& + 144 ,& + 155 ,& + 159 ,& + 162 ,& + 165 ,& + 163 ,& + 161 ,& + 164 ,& + 158 ,& + 169 ,& + 157 ,& + 156 ,& + 160 ,& + 170 ,& + 171 ,& + 174 ,& + 180 ,& + 178 ,& + 179 ,& + 172 ,& + 175 ,& + 181 ,& + 183 ,& + 166 ,& + 182 ,& + 177 ,& + 173 ,& + 81 ,& + 184 ,& + 186 ,& + 187 ,& + 188 ,& + 189 ,& + 200 ,& + 218 ,& + 201 ,& + 205 ,& + 212 ,& + 192 ,& + 220 ,& + 209 ,& + 204 ,& + 70 ,& + 198 ,& + 210 ,& + 195 ,& + 202 ,& + 214 ,& + 199 ,& + 219 ,& + 207 ,& + 208 ,& + 222 ,& + 221 ,& + 206 ,& + 203 ,& + 224 ,& + 237 ,& + 47 ,& + 230 ,& + 228 ,& + 226 ,& + 231 ,& + 236 ,& + 229 ,& + 232 ,& + 233 ,& + 234 ,& + 235 ,& + 238 ,& + 225 ,& + 227 ,& + 239 ,& + 240 ,& + 244 ,& + 245 ,& + 243 ,& + 246 ,& + 248 ,& + 196 ,& + 249 ,& + 35 ,& + 251 ,& + 250 ,& + 247 ,& + 252 ,& + 197 ,& + 2 ,& + 44 ,& + 51 ,& + 120 ,& + 167 ,& + 176 ,& + 216 ,& + 254 ,& + 211 ,& + 255 ,& + 256 ,& + 257 / + + if(present(index_RANGE )) index_RANGE => index_RANGE_DATA + if(present(ST_NAME )) ST_NAME => ST_NAME_DATA + if(present(CNT_NAME )) CNT_NAME => CNT_NAME_DATA + if(present(ST_NAME_ABR )) ST_NAME_ABR => ST_NAME_DATA (:)(1:2) + if(present(CNT_NAME_ABR)) CNT_NAME_ABR=> CNT_NAME_DATA(:)(1:3) + + END SUBROUTINE get_country_codes + +END MODULE process_hres_data ! ---------------------------------------------------------------------------------------------- diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 index c742a1f24..5de460b47 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.F90 @@ -3,9 +3,10 @@ module LogRectRasterizeMod use MAPL_SORTMOD - use rmTinyCatchParaMod, ONLY: SRTM_maxcat use MAPL_ExceptionHandling - use MAPL_Constants, only: PI=>MAPL_PI_R8 + use MAPL_Constants, only: PI=>MAPL_PI_R8 + use MAPL + use, intrinsic :: iso_fortran_env, only: INT32, REAL64 implicit none private @@ -20,24 +21,32 @@ module LogRectRasterizeMod !EOP public LRRasterize - public ReadRaster +! public ReadRaster public WriteRaster public Writetiling + public WritetilingNC4 + public ReadTilingNC4 public Sorttiling - public Opentiling - public Closetiling - public WriteLine + public MAPL_UNDEF_R8 + ! SRTM_maxcat = number of Pfafstetter catchments defined in raster file produced by Kristine Version in 2013 + ! (based on DEMs from 3.0-arcsec HydroSHEDS/SRTM south of 60N, + ! 7.5-arcsec GMTED2010 north of 60N, and + ! CGIAR/SRTM where HydroSHEDS/SRTM is undefined [typically islands]) - integer, parameter :: PUSHLEFT = 10000 - real(kind=8) , parameter :: Zero = 0.0 + INTEGER, PARAMETER, public:: SRTM_maxcat = 291284 - integer, parameter :: NX = 8640 - integer, parameter :: NY = 4320 + ! ------------------------------------------------------------------------------------------------------------- + integer, parameter :: PUSHLEFT = 10000 + real(REAL64), parameter :: Zero = 0.0d0 + + integer, parameter :: NX = 8640 + integer, parameter :: NY = 4320 + real(REAL64), parameter :: MAPL_UNDEF_R8 = 1.0D15 + + real(REAL64) :: garea_ + integer :: ctg_ - real(kind=8) :: garea_ - integer :: ctg_ - interface LRRasterize module procedure LRRasterize2File module procedure LRRasterize2File0 @@ -77,42 +86,38 @@ subroutine WriteRaster(File, Raster, Zip) return end subroutine WriteRaster - - - - -subroutine ReadRaster(File, Raster, Zip) - character*(*), intent(IN) :: File - integer, intent(IN) :: Raster(:,:) - logical, optional :: Zip - - logical :: DoZip, Opened - integer :: nx, ny - - nx = size(Raster,1) - ny = size(Raster,2) - - if(present(Zip)) then - DoZip = Zip - else - DoZip = .false. - endif - - if(DoZip) then - print *, "Reading zipped raster files not supported" - call exit(1) - else - call READRST(RASTER(1,1),nx,ny,trim(FILE)//CHAR(0)) - end if - - return -end subroutine ReadRaster +! subroutine ReadRaster(File, Raster, Zip) +! character*(*), intent(IN) :: File +! integer, intent(IN) :: Raster(:,:) +! logical, optional :: Zip +! +! logical :: DoZip, Opened +! integer :: nx, ny +! +! nx = size(Raster,1) +! ny = size(Raster,2) +! +! if(present(Zip)) then +! DoZip = Zip +! else +! DoZip = .false. +! endif +! +! if(DoZip) then +! print *, "Reading zipped raster files not supported" +! call exit(1) +! else +! call READRST(RASTER(1,1),nx,ny,trim(FILE)//CHAR(0)) +! end if +! +! return +! end subroutine ReadRaster subroutine SortTiling(Raster,rTable,iTable) integer, intent(INOUT) :: Raster(:,:), iTable(0:,:) - real(kind=8), intent(INOUT) :: rTable(:,:) + real(REAL64), intent(INOUT) :: rTable(:,:) integer, dimension(size(iTable,2)) :: old, new integer*8, dimension(size(iTable,2)) :: key, key0 @@ -162,12 +167,34 @@ subroutine SortTiling(Raster,rTable,iTable) return end subroutine SortTiling +! -------------------------------------------------------------------------------------------- + subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zip, Verb, rc) + + ! Write ASCII tile file + ! + ! We have ascii tile files that support either 1 or 2 grids. The most typcal case for GEOS is a tile file with + ! 2 grids (although to generate the final file, we generate a lot of intermediate tile files with a single grid). + ! For the 2-grid tile file, the pfaf index number should be in column 9 (basically that file has 3 groups, + ! each of which has 4 columns: the "global" info part (type, area, lat, lon), and then for each grid we have + ! (index1 (i.e. "i"), index2 (i.e. "j"), weight, dummy). Here "dummy" is a variable, used internally for + ! bookkeeping purposes, but it is totally ignored by GEOS, MAPL, etc. So, for the typical case, ATM and OCN + ! grids, columns 1-4 represent the global variables, then the next 4 columns refer to the ATM grid (but this + ! is to a large extend an artifact of the ordering of the "combine" calls that generate the final tile file). + ! Then for type=0 (i.e., "ocean") the last 4 columns are the i, j, weight, dummy of the ocean grid. + ! But for type=100 (i.e., land) the convention is the first index, i.e. column 9, is the pfaf index + ! (that is, the index of the Pfafstetter hydrological catchment). + ! I do not think we use the content of column 10 anywhere in the model. + ! So my bottom line is the pfaf index should be in column 9. If it appears in column 8, it won't do any harm + ! to the atmosphere, but we cannot use it properly to do river routing inside the land model. + ! (From https://github.com/GEOS-ESM/GEOSgcm_GridComp/pull/1028#issuecomment-2599275578, lightly edited.) + + character*(*), intent(IN) :: File character*(*), intent(IN) :: GridName(:) integer, intent(IN) :: nx,ny integer, intent(IN) :: iTable(0:,:) - real(kind=8), intent(IN) :: rTable(:,:) + real(REAL64), intent(IN) :: rTable(:,:) integer, intent(IN) :: IM(:), JM(:), ipx(:) logical, optional, intent(IN) :: Zip logical, optional, intent(IN) :: Verb @@ -177,10 +204,12 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi ! ! iTable(0) :: Surface type ! iTable(1) :: tile count -! iTable(2) :: I_1 I of first grid +! iTable(2) :: I_1 I of 1st grid ! iTable(3) :: J_1 -! iTable(4) :: I_2 I of 2nd grid +! iTable(4) :: I_2 I of 2nd grid *OR* for land tiles: index of Pfafstetter catchment (see comment above) ! iTable(5) :: J_2 +! iTable(6) :: kk_1 (dummy variable for internal bookkeeping) +! iTable(7) :: kk_2 (dummy variable for internal bookkeeping) ! ! rTable(1) :: sum of lons ! rTable(2) :: sum of lats @@ -188,22 +217,23 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi ! rTable(4) :: of first grid box area ! rTable(5) :: of 2nd grid box area - logical :: DoZip, Opened - integer :: j, unit, ng, ip, l, i, k, ix + logical :: DoZip, Opened + integer :: j, unit, ng, ip, l, i, k, ix character*1000 :: Line - integer :: ii(size(GridName)), jj(size(GridName)), kk(size(GridName)) - real(kind=8) :: fr(size(GridName)) - real(kind=8) :: xc, yc, area - real(kind=8) :: garea, ctg(size(Gridname)) - real(kind=8) :: sphere, error - integer :: status + integer :: ii(size(GridName)), jj(size(GridName)), kk(size(GridName)) + real(REAL64) :: fr(size(GridName)) + real(REAL64) :: xc, yc, area + real(REAL64) :: garea, ctg(size(Gridname)) + real(REAL64) :: sphere, error + integer :: status, tmp_in1, tmp_in2, ncat + logical :: file_exists ip = size(iTable,2) ng = size(GridName) _ASSERT(IP==size(rTable,2),'needs informative message') - _ASSERT(NG==size(IM),'needs informative message') - _ASSERT(NG==size(JM),'needs informative message') + _ASSERT(NG==size(IM), 'needs informative message') + _ASSERT(NG==size(JM), 'needs informative message') if(present(Zip)) then DoZip = Zip @@ -249,8 +279,8 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi ! Write tile info, one line per tile. #define LINE_FORMAT '(I10,3E20.12,9(2I10,E20.12,I10))' -#define LINE_VARIABLES iTable(0,k),area,xc,yc, (ii(l),jj(l),fr(l),kk(l),l=1,ng) - +#define LINE_VARIABLES iTable(0,k),area,xc,yc, (ii(l),jj(l),fr(l),kk(l),l=1,ng) ! for *land* tiles, ii(2) = index of Pfafstetter catchment + garea = 0.0 ctg = 0.0 @@ -264,10 +294,11 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi do l=0,ng-1 ii(l+1) = iTable(2 +L*2,K) jj(l+1) = iTable(3 +L*2,K) + ! kk = "dummy" variable, used internally for bookkeeping purposes, ignored by GEOS, MAPL, etc if(ng==1) then - kk(l+1) = K + kk(l+1) = K else - kk(l+1) = iTable(6 +L,K) + kk(l+1) = iTable(6 +L,K) end if if(rTable(4+L,K)/=0.0) then fr (l+1) = area / rTable(4+L,K) @@ -286,7 +317,7 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi end do if(present(Verb)) then - sphere = 4.*pi + sphere = 4.*PI error = (sphere-garea)/garea if(Verb) then print '(A,3e20.13)','Stats for the globe:',garea, sphere, error @@ -305,11 +336,470 @@ subroutine WriteTilingIR(File, GridName, im, jm, ipx, nx, ny, iTable, rTable, Zi close(UNIT) end if - return end subroutine WriteTilingIR +! ----------------------------------------------------------------------------------------- + +subroutine WriteTilingNC4(File, GridName, im, jm, nx, ny, iTable, rTable, N_PfafCat, rc) + + character(*), intent(IN) :: File + character(*), intent(IN) :: GridName(:) + integer, intent(IN) :: IM(:), JM(:) + integer, intent(IN) :: nx, ny + integer, intent(IN) :: iTable(:,0:) + real(REAL64), intent(IN) :: rTable(:,:) + integer, optional, intent(in) :: N_PfafCat + integer, optional, intent(out):: rc + + integer :: k, ll, ng, ip, status, n_pfafcat_ + + character(len=:), allocatable :: attr + type (Variable) :: v + type (NetCDF4_FileFormatter) :: formatter + character(len=4) :: ocn_str + type (FileMetadata) :: metadata + integer, allocatable :: II(:), JJ(:), KK(:), pfaf(:) + real(REAL64), allocatable :: fr(:) + logical :: EASE + integer, parameter :: deflate_level = 1 + + ng = size(GridName) + ip = size(iTable,1) + + EASE = .false. + if (index(GridName(1), 'EASE') /=0) EASE = .true. + + ! number of Pfafstetter catchments defined in underlying raster file + + n_pfafcat_ = SRTM_maxcat + + if (present(N_PfafCat)) n_pfafcat_ = N_PfafCat + + call metadata%add_dimension('tile', ip) + + ! ------------------------------------------------------------------- + ! + ! create nc4 variables and write metadata + + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + + attr = 'Grid'//trim(ocn_str)//'_Name' + call metadata%add_attribute( attr, trim(GridName(ll))) + attr = 'IM'//trim(ocn_str) + call metadata%add_attribute( attr, IM(ll)) + attr = 'JM'//trim(ocn_str) + call metadata%add_attribute( attr, JM(ll)) + enddo + + attr = 'raster_nx' + call metadata%add_attribute( attr, nx) + attr = 'raster_ny' + call metadata%add_attribute( attr, ny) + attr = 'N_PfafCat' + call metadata%add_attribute( attr, n_pfafcat_) + attr = 'N_Grids' + call metadata%add_attribute( attr, ng) + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'tile_type') + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('typ', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'radian2') + call v%add_attribute('long_name', 'tile_area') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%add_attribute("_FillValue", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('area', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_center_of_mass_longitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%add_attribute("_FillValue", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('com_lon', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_center_of_mass_latitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%add_attribute("_FillValue", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('com_lat', v) + + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'GRID'//trim(ocn_str)//'_i_index_of_tile_in_global_grid') + call v%add_attribute("missing_value", MAPL_UNDEFINED_INTEGER) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('i_indg'//trim(ocn_str), v) + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'GRID'//trim(ocn_str)//'_j_index_of_tile_in_global_grid') + call v%set_deflation(DEFLATE_LEVEL) + call v%add_attribute("missing_value", MAPL_UNDEFINED_INTEGER) + call metadata%add_variable('j_indg'//trim(ocn_str), v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'GRID'//trim(ocn_str)//'_area_fraction_of_tile_in_grid_cell') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%add_attribute("_FillValue", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('frac_cell'//trim(ocn_str), v) + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'internal_dummy_index_of_tile') + call v%add_attribute("missing_value", MAPL_UNDEFINED_INTEGER) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('dummy_index'//trim(ocn_str), v) + enddo + + v = Variable(type=PFIO_INT32, dimensions='tile') + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'Pfafstetter_index_of_tile') + call v%add_attribute("missing_value", MAPL_UNDEFINED_INTEGER) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('pfaf_index', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_minimum_longitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('min_lon', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_maximum_longitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('max_lon', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_minimum_latitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('min_lat', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'degree') + call v%add_attribute('long_name', 'tile_maximum_latitude') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('max_lat', v) + + v = Variable(type=PFIO_REAL64, dimensions='tile') + call v%add_attribute('units', 'm') + call v%add_attribute('long_name', 'tile_mean_elevation') + call v%add_attribute("missing_value", MAPL_UNDEF_R8) + call v%set_deflation(DEFLATE_LEVEL) + call metadata%add_variable('elev', v) + + ! ------------------------------------------------------------------- + ! + ! write data into nc4 file + + call formatter%create(File, mode=PFIO_NOCLOBBER, rc=status) + call formatter%write(metadata, rc=status) + call formatter%put_var('typ', iTable(:,0), rc=status) + call formatter%put_var('area', rTable(:,3), rc=status) + call formatter%put_var('com_lon', rTable(:,1), rc=status) + call formatter%put_var('com_lat', rTable(:,2), rc=status) + + allocate(fr(ip), pfaf(ip)) + fr = MAPL_UNDEF_R8 + + do ll = 1, ng + if (ng == 1) then + if (EASE) then + KK = iTable(:,4) + pfaf = KK + else + KK =[(k, k=1,ip)] + endif + else + KK = iTable(:,5+ll) + endif + + II = iTable(:,ll*2 ) + JJ = iTable(:,ll*2 + 1) + + where( rTable(:,3+ll) /=0.0) + fr = rTable(:,3)/rTable(:,3+ll) + endwhere + + if (ll == 1) then + ocn_str='' + else + ocn_str='_ocn' + endif + + if (ll == 2) then + pfaf = MAPL_UNDEFINED_INTEGER + where (iTable(:,0) == 100) + pfaf = II + endwhere + where (iTable(:,0) == 19) + pfaf = 190000000 + endwhere + where (iTable(:,0) == 20) + pfaf = 200000000 + endwhere + + where (iTable(:,0) /=0 ) + II = MAPL_UNDEFINED_INTEGER + JJ = MAPL_UNDEFINED_INTEGER + fr = MAPL_UNDEF_R8 + endwhere + endif + + call formatter%put_var('i_indg' //trim(ocn_str), II, rc=status) + call formatter%put_var('j_indg' //trim(ocn_str), JJ, rc=status) + call formatter%put_var('frac_cell' //trim(ocn_str), fr, rc=status) + call formatter%put_var('dummy_index'//trim(ocn_str), KK, rc=status) + + if (EASE .or. ll == 2) call formatter%put_var('pfaf_index', pfaf, rc=status) + + enddo + + call formatter%put_var('min_lon', rTable(:, 6), rc=status) + call formatter%put_var('max_lon', rTable(:, 7), rc=status) + call formatter%put_var('min_lat', rTable(:, 8), rc=status) + call formatter%put_var('max_lat', rTable(:, 9), rc=status) + call formatter%put_var('elev', rTable(:,10), rc=status) + + call formatter%close(rc=status) + + if (present(rc)) rc = status + +end subroutine WriteTilingNC4 + +! ------------------------------------------------------------------------------------- + +subroutine ReadTilingNC4(File, GridName, im, jm, nx, ny, n_Grids, iTable, rTable, N_PfafCat, AVR,rc) + + character(*), intent(IN) :: File + character(*), optional, intent(out) :: GridName(:) + integer, optional, intent(out) :: IM(:), JM(:) + integer, optional, intent(out) :: nx, ny, n_Grids + integer, optional, allocatable, intent(out) :: iTable(:,:) + real(REAL64), optional, allocatable, intent(out) :: rTable(:,:) + integer, optional, intent(out) :: N_PfafCat + real, optional, allocatable, intent(out) :: AVR(:,:) ! used by GEOSgcm + integer, optional, intent(out) :: rc + + type (Attribute), pointer :: ref + character(len=:), allocatable :: attr + type (NetCDF4_FileFormatter) :: formatter + type (FileMetadata) :: meta + character(len=4) :: ocn_str + integer :: ng, ntile, status, ll + class(*), pointer :: attr_val(:) + class(*), pointer :: char_val + integer, allocatable :: tmp_int(:) + real(REAL64), allocatable :: fr(:) + + integer, parameter :: NumGlobalVars =4 + integer, parameter :: NumLocalVars =4 + integer :: NumCol + integer, allocatable :: iTable_(:,:) + real(REAL64), allocatable :: rTable_(:,:) + + call formatter%open(File, pFIO_READ, rc=status) + meta = formatter%read(rc=status) + + ntile = meta%get_dimension('tile') + + ref => meta%get_attribute('N_Grids') + attr_val => ref%get_values() + select type (attr_val) + type is (integer(INT32)) + ng = attr_val(1) + endselect + if (present(n_Grids)) then + n_Grids = ng + endif + + if (present(nx)) then + ref => meta%get_attribute('raster_nx') + attr_val => ref%get_values() + select type(attr_val) + type is (integer(INT32)) + nx = attr_val(1) + endselect + endif + if (present(ny)) then + ref => meta%get_attribute('raster_ny') + attr_val => ref%get_values() + select type (attr_val) + type is (integer(INT32)) + ny = attr_val(1) + endselect + endif + + if (present(N_PfafCat)) then + ref => meta%get_attribute('N_PfafCat') + attr_val => ref%get_values() + select type (attr_val) + type is (integer(INT32)) + N_PfafCat = attr_val(1) + endselect + endif + + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + + if (present(GridName)) then + attr = 'Grid'//trim(ocn_str)//'_Name' + ref =>meta%get_attribute(attr) + char_val => ref%get_value() + select type(char_val) + type is(character(*)) + GridName(ll) = char_val + class default + print('unsupported subclass (not string) of attribute named '//attr) + end select + endif + if (present(IM)) then + attr = 'IM'//trim(ocn_str) + ref =>meta%get_attribute(attr) + attr_val => ref%get_values() + select type(attr_val) + type is( integer(INT32)) + IM(ll) = attr_val(1) + end select + endif + if (present(JM)) then + attr = 'JM'//trim(ocn_str) + ref =>meta%get_attribute(attr) + attr_val => ref%get_values() + select type(attr_val) + type is(integer(INT32)) + JM(ll) = attr_val(1) + end select + endif + enddo + + if (present(iTable) .or. present(AVR) ) then + allocate(iTable_(ntile,0:7)) + allocate(tmp_int(ntile)) + call formatter%get_var('typ', iTable_(:,0)) + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + + call formatter%get_var('i_indg' //trim(ocn_str), tmp_int, rc=status) + iTable_(:,ll*2) = tmp_int + call formatter%get_var('j_indg' //trim(ocn_str), tmp_int, rc=status) + iTable_(:,ll*2+1) = tmp_int + call formatter%get_var('dummy_index'//trim(ocn_str), tmp_int, rc=status) + if ( ng == 1) then + iTable_(:,4) = tmp_int + ! set this 7th column to 1. This is to reproduce a potential bug + ! when it is ease grid and mask file is not GEOS5_10arcsec_mask + iTable_(:,7) = 1 + else + iTable_(:,5+ll) = tmp_int + endif + enddo + call formatter%get_var('pfaf_index', tmp_int, rc=status) + if (ng == 2) then + where (iTable_(:,0) == 100) + iTable_(:,4) = tmp_int + endwhere + endif + endif + + if (present(rTable) .or. present(AVR) ) then + allocate(rTable_(ntile,10)) + call formatter%get_var('com_lon', rTable_(:,1), rc=status) + call formatter%get_var('com_lat', rTable_(:,2), rc=status) + call formatter%get_var('area', rTable_(:,3), rc=status) + do ll = 1, ng + if (ll == 1) then + ocn_str = '' + else + ocn_str = '_ocn' + endif + call formatter%get_var('frac_cell' //trim(ocn_str), rTable_(:,3+ll), rc=status) + enddo + call formatter%get_var('min_lon', rTable_(:, 6), rc=status) + call formatter%get_var('max_lon', rTable_(:, 7), rc=status) + call formatter%get_var('min_lat', rTable_(:, 8), rc=status) + call formatter%get_var('max_lat', rTable_(:, 9), rc=status) + call formatter%get_var('elev', rTable_(:,10), rc=status) + endif + + if (present(AVR)) then + ! In GEOSgcm, it already assumes ng = 2, so NumCol = 10 + NumCol = NumGlobalVars+NumLocalVars*ng + allocate(AVR(ntile, NumCol)) + AVR(:, 1) = iTable_(:,0) + ! for EASE grid, the second collum is replaced by the area + AVR(:, 2) = rTable_(:,3) + AVR(:, 3) = rTable_(:,1) + AVR(:, 4) = rTable_(:,2) + + AVR(:, 5) = iTable_(:,2) + AVR(:, 6) = iTable_(:,3) + AVR(:, 7) = rTable_(:,4) + if (ng == 1) then + AVR(:,8) = iTable_(:,4) + else + AVR(:, 8) = iTable_(:,6) + + AVR(:, 9) = iTable_(:,4) + AVR(:, 10) = iTable_(:,5) + AVR(:, 11) = rTable_(:,5) + AVR(:, 12) = iTable_(:,7) + endif + endif + + if (present(iTable)) then + call move_alloc(iTable_, iTable) + endif + + if (present(rTable)) then + call move_alloc(rTable_, rTable) + do ll = 1, ng + where ( rTable(:,3+ll) /=0.0 ) rTable(:,3+ll) = rTable(:,3)/rTable(:,3+ll) + enddo + endif + + if (present(rc)) rc= status + +end subroutine ReadTilingNC4 + +! ---------------------------------------------------------------------------------- subroutine OpenTiling(Unit, File, GridName, im, jm, ip, nx, ny, Zip, Verb) + integer, intent(OUT) :: Unit character*(*), intent(IN) :: File character*(*), intent(IN) :: GridName @@ -380,16 +870,16 @@ subroutine OpenTiling(Unit, File, GridName, im, jm, ip, nx, ny, Zip, Verb) end if return -end subroutine OpenTiling - +end subroutine OpenTiling +! -------------------------------------------------------------------------- subroutine WriteLine(File, Unit, iTable, rTable, k, Zip, Verb) character*(*), intent(IN) :: File integer, intent(IN) :: Unit, k integer, intent(IN) :: iTable(0:) - real(kind=8), intent(IN) :: rTable(:) + real(REAL64), intent(IN) :: rTable(:) logical, optional, intent(IN) :: Zip logical, optional, intent(IN) :: Verb @@ -411,8 +901,8 @@ subroutine WriteLine(File, Unit, iTable, rTable, k, Zip, Verb) logical :: DoZip character*1000 :: Line integer :: ii, jj - real(kind=8) :: fr - real(kind=8) :: xc, yc, area + real(REAL64) :: fr + real(REAL64) :: xc, yc, area if(present(Zip)) then DoZip = Zip @@ -478,7 +968,7 @@ subroutine CloseTiling(FIle, Unit, ip, Zip, Verb) ! rTable(5) :: of 2nd grid box area logical :: DoZip - real(kind=8) :: sphere, error + real(REAL64) :: sphere, error character*1000 :: Line Line="" @@ -490,7 +980,7 @@ subroutine CloseTiling(FIle, Unit, ip, Zip, Verb) endif if(present(Verb)) then - sphere = 4.*pi + sphere = 4.*PI error = (sphere-garea_)/garea_ if(Verb) then print '(A,3e20.13)','Stats for the globe:',garea_, sphere, error @@ -511,9 +1001,6 @@ subroutine CloseTiling(FIle, Unit, ip, Zip, Verb) end subroutine CloseTiling - - - end module LogRectRasterizeMod diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H index f2cf014ab..523b264f6 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rasterize.H @@ -54,22 +54,22 @@ character*(*), intent(INOUT) :: GridName ! Raster file name #ifdef MESH - real(kind=8), intent(INOUT) :: xv(:,:) ! X coordinates of vertices - real(kind=8), intent(INOUT) :: yv(:,:) ! Y coordinates of vertices + real(REAL64), intent(INOUT) :: xv(:,:) ! X coordinates of vertices + real(REAL64), intent(INOUT) :: yv(:,:) ! Y coordinates of vertices #else - real(kind=8), intent(INOUT) :: xv(:,:,:) ! X coordinates of vertices - real(kind=8), intent(INOUT) :: yv(:,:,:) ! Y coordinates of vertices + real(REAL64), intent(INOUT) :: xv(:,:,:) ! X coordinates of vertices + real(REAL64), intent(INOUT) :: yv(:,:,:) ! Y coordinates of vertices #endif integer, optional, intent(IN) :: nc,nr ! Raster field sizes - real(kind=8), optional, intent(IN) :: xmn ! LL x of LL raster cell (-180) - real(kind=8), optional, intent(IN) :: ymn ! LL y of LL raster cell ( -90) - real(kind=8), optional, intent(IN) :: xmx ! UR x of UR raster cell ( 180) - real(kind=8), optional, intent(IN) :: ymx ! UR y of UR raster cell ( 90) + real(REAL64), optional, intent(IN) :: xmn ! LL x of LL raster cell (-180) + real(REAL64), optional, intent(IN) :: ymn ! LL y of LL raster cell ( -90) + real(REAL64), optional, intent(IN) :: xmx ! UR x of UR raster cell ( 180) + real(REAL64), optional, intent(IN) :: ymx ! UR y of UR raster cell ( 90) logical, optional, intent(IN) :: verb ! Verbose logical, optional, intent(IN) :: here ! write here integer, optional, intent(IN) :: SurfaceType integer, optional, intent(IN) :: jseg - real(kind=8), optional :: tol + real(REAL64), optional :: tol integer, optional, intent(out) :: rc character*(128) :: TileFile @@ -191,42 +191,42 @@ integer, intent(INOUT) :: Raster(:,:) ! Raster field to be filled #ifdef MESH - real(kind=8), intent(INOUT) :: xv(:,: ) ! X coordinates of vertices - real(kind=8), intent(INOUT) :: yv(:,: ) ! Y coordinates of vertices + real(REAL64), intent(INOUT) :: xv(:,: ) ! X coordinates of vertices + real(REAL64), intent(INOUT) :: yv(:,: ) ! Y coordinates of vertices #else - real(kind=8), intent(INOUT) :: xv(:,:,:) ! X coordinates of vertices - real(kind=8), intent(INOUT) :: yv(:,:,:) ! Y coordinates of vertices + real(REAL64), intent(INOUT) :: xv(:,:,:) ! X coordinates of vertices + real(REAL64), intent(INOUT) :: yv(:,:,:) ! Y coordinates of vertices #endif character*(*), intent(IN ) :: TileFile - real(kind=8), optional, intent(IN) :: xmn ! LL x of LL raster cell (-180) - real(kind=8), optional, intent(IN) :: ymn ! LL y of LL raster cell ( -90) - real(kind=8), optional, intent(IN) :: xmx ! UR x of UR raster cell ( 180) - real(kind=8), optional, intent(IN) :: ymx ! UR y of UR raster cell ( 90) + real(REAL64), optional, intent(IN) :: xmn ! LL x of LL raster cell (-180) + real(REAL64), optional, intent(IN) :: ymn ! LL y of LL raster cell ( -90) + real(REAL64), optional, intent(IN) :: xmx ! UR x of UR raster cell ( 180) + real(REAL64), optional, intent(IN) :: ymx ! UR y of UR raster cell ( 90) logical, optional, intent(IN) :: verb ! Verbose integer, optional, intent(IN) :: SurfaceType integer, optional, intent(IN) :: jseg - real(kind=8), optional :: tol + real(REAL64), optional :: tol integer, optional, intent(out) :: rc ! X abd Y bounds of each polygon - real(kind=8) :: xmin, xmax - real(kind=8) :: ymin, ymax - real(kind=8) :: minx, miny - real(kind=8) :: maxx, maxy + real(REAL64) :: xmin, xmax + real(REAL64) :: ymin, ymax + real(REAL64) :: minx, miny + real(REAL64) :: maxx, maxy ! x and y coordinates of the Raster grid - real(kind=8), dimension(size(Raster,1)) :: xs, xcs, xss - real(kind=8), dimension(size(Raster,2)) :: ys, ycs, yss, da + real(REAL64), dimension(size(Raster,1)) :: xs, xcs, xss + real(REAL64), dimension(size(Raster,2)) :: ys, ycs, yss, da integer :: IM, JM, NV ! Shape of input grid - real(kind=8) :: dx, dy, dxi, dyi ! Grid spacing of raster grid + real(REAL64) :: dx, dy, dxi, dyi ! Grid spacing of raster grid integer :: xsize, ysize ! Dimensions of Raster grid integer :: i, j, jn, n, ib, jb, fill, uType, js, k - real(kind=8) :: range, d2r, r2d, ddx, grid_ymin, grid_ymax, xc, yc, Area, xx + real(REAL64) :: range, d2r, r2d, ddx, grid_ymin, grid_ymax, xc, yc, Area, xx logical :: DoZip, uVerb integer :: idx, ct integer :: count0,count1,count_rate @@ -235,18 +235,18 @@ character*(128) :: GridName, TilFile integer, allocatable :: iTable(:,:) - real(kind=8), allocatable :: rTable(:,:) + real(REAL64), allocatable :: rTable(:,:) integer :: useg, unit, fq integer, dimension(POLYSIZE) & :: nxt - real(kind=8), dimension(POLYSIZE) & + real(REAL64), dimension(POLYSIZE) & :: xvc, yvc, xvs, yvs, xrd, yrd, x3, y3, z3, & dx3, dy3, dz3, x31, x32, y31, y32, z31, z32, & dx4, dy4, x4, y4, xu, yu - real(kind=8) :: tol_ + real(REAL64) :: tol_ ! Process optionals @@ -558,14 +558,14 @@ subroutine FillPoly(sh) - real(kind=8), intent(IN) :: sh + real(REAL64), intent(IN) :: sh logical :: IsIn integer :: i1, i2, jj1 integer :: ii, jj, n1, n2, jx integer, save :: j1, j2 integer :: HALO=10 - real(kind=8) :: x0, y0 + real(REAL64) :: x0, y0 if (abs(miny+90._8) < 1.e-10_8) then diff --git a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 index 6f853606a..c06c0755b 100644 --- a/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 +++ b/GEOSagcm_GridComp/GEOSphysics_GridComp/GEOSsurface_GridComp/Utils/Raster/makebcs/rmTinyCatchParaMod.F90 @@ -9,43 +9,55 @@ module rmTinyCatchParaMod use LDAS_DateTimeMod use MAPL_ConstantsMod - use MAPL_Base, ONLY: MAPL_UNDEF - use lsm_routines, ONLY: sibalb - + use MAPL_Base, ONLY: MAPL_UNDEF + use lsm_routines, ONLY: sibalb + use LogRectRasterizeMod, ONLY: SRTM_maxcat, WritetilingNC4, MAPL_UNDEF_R8 + use, intrinsic :: iso_fortran_env, only: REAL64 implicit none + logical, parameter :: error_file=.true. integer, parameter :: n_SoilClasses = 253 - real, parameter :: zks = 2.0 + real, parameter :: zks = 2.0 integer, parameter :: i_raster = 8640, j_raster=4320 integer, parameter :: ncat_gswp2 = 15238 - REAL, PARAMETER :: undef = 1.e+20 - integer, parameter :: arr_len = 1734915,ip1 =0 - real, parameter :: dx_gswp2 =1.,dy_gswp2=1. + REAL, PARAMETER :: undef = 1.e+20 + integer, parameter :: arr_len = 1734915 + integer, parameter :: ip1 =0 ! index offset for land tiles within all vector of all tiles (ip1=0 => land tiles are first) + real, parameter :: dx_gswp2 =1.,dy_gswp2=1. integer, parameter :: MAX_NOF_GRID = ncat_gswp2 integer, PARAMETER :: nbdep=150, NAR=1000,nwt=81,nrz=41 - real, parameter :: slice=0.1, lim =5.,grzdep =1.1 - logical, parameter :: bug =.false. - include 'netcdf.inc' + real, parameter :: slice=0.1, lim =5.,grzdep =1.1 + logical, parameter :: bug =.false. + + include 'netcdf.inc' + logical :: preserve_soiltype = .false. + + ! Bugfix for Target_mean_land_elev: + ! Previously, the hardcoded value 614.649 m was used as the target mean land elevation. + ! This was incorrect because it did not account for the proper cosine-lat-weighted mean over land. + ! The correct value, 656.83 m, is derived from NCAR GMTED TOPO 30arcsec dataset. + ! This ensures that land elevation adjustment is based on the correct reference mean land elevation. + real*8, parameter :: Target_mean_land_elev = 656.83D0 ! cosine-lat-weighted mean land elev from NCAR GMTED TOPO 30arcsec + private - - public remove_tiny_tiles,modis_alb_on_tiles - public catchment_def,soil_para_high - public create_soil_types_files,compute_mosaic_veg_types + + public Target_mean_land_elev + public modis_alb_on_tiles + public supplemental_tile_attributes, soil_para_high + public create_soil_types_files, compute_mosaic_veg_types public cti_stat_file, create_model_para_woesten - public create_model_para, modis_lai,regridraster,regridrasterreal - public i_raster, j_raster,regridraster1,regridraster2,n_SoilClasses,zks - public mineral_perc, process_gswp2_veg,center_pix, soil_class - public tgen, sat_param,REFORMAT_VEGFILES,base_param,ts_param - public :: Get_MidTime, Time_Interp_Fac, compute_stats - public :: ascat_r0, jpl_canoph, NC_VarID, init_bcs_config - - INTEGER, PARAMETER, public:: SRTM_maxcat = 291284 - + public create_model_para, regridraster, regridrasterreal + public i_raster, j_raster, regridraster1, regridraster2, n_SoilClasses, zks + public mineral_perc, process_gswp2_veg, center_pix, soil_class + public REFORMAT_VEGFILES + public Get_MidTime, Time_Interp_Fac + public ascat_r0, jpl_canoph, NC_VarID, init_bcs_config + ! The following variables define the details of the BCS version (data sources). ! Initialize to dummy values here and set to desired values in init_bcs_config(). - + logical, public, save :: use_PEATMAP = .false. logical, public, save :: jpl_height = .false. logical, public, save :: IRRIGBCS = .false. @@ -55,9 +67,9 @@ module rmTinyCatchParaMod character*10, public, save :: SNOWALB = 'UNDEF' character*5, public, save :: OUTLETV = 'UNDEF' REAL, public, save :: GNU = MAPL_UNDEF - + character*512 :: MAKE_BCS_INPUT_DIR - + type :: mineral_perc real :: clay_perc real :: silt_perc @@ -65,9 +77,9 @@ module rmTinyCatchParaMod end type mineral_perc contains - - SUBROUTINE init_bcs_config (LBCSV) - + + SUBROUTINE init_bcs_config(LBCSV) + ! determine BCs details from land BCs version string (LBCSV) ! ! LAIBCS: Leaf-Area-Index data set. DEFAULT : MODGEO @@ -100,12 +112,10 @@ SUBROUTINE init_bcs_config (LBCSV) ! v2 : Outlet locations file produced by run_routing_raster.py using routing information encoded ! in SRTM-based Pfafstetter catchments and Greenland outlets info provided by Lauren Andrews. - implicit none - character(*), intent (in) :: LBCSV ! land BCs version select case (trim(LBCSV)) - + case ("F25") LAIBCS = 'GSWP2' SOILBCS = 'NGDC' @@ -115,7 +125,7 @@ SUBROUTINE init_bcs_config (LBCSV) GNU = 2.17 use_PEATMAP = .false. jpl_height = .false. - + case ("GM4", "ICA") LAIBCS = 'GSWP2' SOILBCS = 'NGDC' @@ -136,7 +146,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .false. jpl_height = .false. - case ("NL4") + case ("NL4") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -146,7 +156,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .false. jpl_height = .true. - case ("NL5") + case ("NL5") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -156,7 +166,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .true. - case ("v06") + case ("v06") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -166,7 +176,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .true. - case ("v07") + case ("v07") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -175,8 +185,8 @@ SUBROUTINE init_bcs_config (LBCSV) GNU = 1.0 use_PEATMAP = .true. jpl_height = .false. - - case ("v08") + + case ("v08") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -186,7 +196,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .false. jpl_height = .false. - case ("v09") + case ("v09") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -196,7 +206,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .false. - case ("v10") + case ("v10") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -206,7 +216,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .false. - case ("v11") + case ("v11") LAIBCS = 'MODGEO' SOILBCS = 'HWSD' MODALB = 'MODIS2' @@ -216,7 +226,13 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .true. - case ("v12") + case ("v12","v13") + + ! "v12" and "v13" are identical except for: + ! - topography used for the atm (processed outside of make_bcs) + ! - bug fix for land elevation in catchment.def file + ! - generation of nc4-formatted tile file + LAIBCS = 'MODGEO' SOILBCS = 'HWSD_b' MODALB = 'MODIS2' @@ -226,7 +242,7 @@ SUBROUTINE init_bcs_config (LBCSV) use_PEATMAP = .true. jpl_height = .true. - case ("v13") + case ("v14") LAIBCS = 'MODGEO' SOILBCS = 'HWSD_b' MODALB = 'MODIS2' @@ -238,33 +254,35 @@ SUBROUTINE init_bcs_config (LBCSV) IRRIGBCS = .true. case default - + print *,'init_bcs_config(): unknown land boundary conditions version (LBCSV)' stop - + end select - + END SUBROUTINE init_bcs_config -! _____________________________________________________________________________________________ -! - - SUBROUTINE Get_MidTime ( & - yr1,mn1,dy1,yr2,mn2,dy2, & - MIDT) - implicit none - real, intent (in) :: yr1,mn1,dy1,yr2,mn2,dy2 - type(date_time_type), intent(out ) :: MIDT - type(date_time_type) :: TIME1, TIME2 - integer :: TIMEDIF - + ! -------------------------------------------------------------------------------------------- + + SUBROUTINE Get_MidTime ( & + yr1,mn1,dy1,yr2,mn2,dy2, & + MIDT) + + real, intent(in) :: yr1,mn1,dy1,yr2,mn2,dy2 + type(date_time_type), intent(out) :: MIDT + + ! ------------ + + type(date_time_type) :: TIME1, TIME2 + integer :: TIMEDIF + TIME1%year = NINT(yr1) + 2001 TIME1%month = NINT(mn1) TIME1%day = NINT(dy1) TIME1%hour = 0 TIME1%min = 0 TIME1%sec = 0 - + call get_dofyr_pentad(TIME1) MIDT = TIME1 @@ -275,144 +293,136 @@ SUBROUTINE Get_MidTime ( & TIME2%min = 59 TIME2%sec = 59 call get_dofyr_pentad(TIME2) - + TIMEDIF = datetime2_minus_datetime1(TIME1,TIME2) TIMEDIF = TIMEDIF/2 - + call augment_date_time(TIMEDIF, MIDT) -! print *,'MIDTIME' -! print *,'TIME1:', time1 -! print *,'MIDT :', midt -! print *,'TIME2:', time2 - + + ! print *,'MIDTIME' + ! print *,'TIME1:', time1 + ! print *,'MIDT :', midt + ! print *,'TIME2:', time2 + END SUBROUTINE Get_MidTime + + ! --------------------------------------------------------------------------------------------- + + SUBROUTINE Time_Interp_Fac (TIME0, TIME1, TIME2, FAC1, FAC2) -! -! --------------------------------------------------------------------------------------------- -! - -SUBROUTINE Time_Interp_Fac (TIME0, TIME1, TIME2, FAC1, FAC2) - -implicit none -! PURPOSE: -! ======== -! -! Compute interpolation factors, fac, to be used -! in the calculation of the instantaneous boundary -! conditions, ie: -! -! q(i,j) = fac1*q1(i,j) + (1.-fac1)*q2(i,j) -! -! where: -! q(i,j) => Boundary Data valid at time0 -! q1(i,j) => Boundary Data centered at time1 -! q2(i,j) => Boundary Data centered at time2 - -! INPUT: -! ====== -! time0 : Time of current timestep -! time1 : Time of boundary data 1 -! time2 : Time of boundary data 2 - -! OUTPUT: -! ======= -! fac1 : Interpolation factor for Boundary Data 1 -! - + ! PURPOSE: + ! ======== + ! + ! Compute interpolation factors, fac, to be used + ! in the calculation of the instantaneous boundary + ! conditions, ie: + ! + ! q(i,j) = fac1*q1(i,j) + (1.-fac1)*q2(i,j) + ! + ! where: + ! q(i,j) => Boundary Data valid at time0 + ! q1(i,j) => Boundary Data centered at time1 + ! q2(i,j) => Boundary Data centered at time2 + + ! INPUT: + ! ====== + ! time0 : Time of current timestep + ! time1 : Time of boundary data 1 + ! time2 : Time of boundary data 2 + + ! OUTPUT: + ! ======= + ! fac1 : Interpolation factor for Boundary Data 1 + ! + type(date_time_type), intent(in ) :: TIME0, TIME1, TIME2 - real, intent(out) :: FAC1 - real, intent(out) :: FAC2 + real, intent(out) :: FAC1 + real, intent(out) :: FAC2 real :: TimeDif1 real :: TimeDif -! print *,'Interpolation' -! print *,'TIME1:', time1 -! print *,'TIME0:', time0 -! print *,'TIME2:', time2 + ! print *,'Interpolation' + ! print *,'TIME1:', time1 + ! print *,'TIME0:', time0 + ! print *,'TIME2:', time2 + TimeDif1 = real(datetime2_minus_datetime1(TIME0,TIME2)) TimeDif = real(datetime2_minus_datetime1(TIME1,TIME2)) - + FAC1 = TimeDif1/TimeDif - + FAC2 = 1.-FAC1 + + ! print *,fac1,fac2 + + END SUBROUTINE Time_Interp_Fac + + ! --------------------------------------------------------------------- + + SUBROUTINE process_gswp2_veg (nc,nr,regrid,vname, n_land, tile_id,merge) + + integer, intent(in) :: nc, nr + logical, intent(in) :: regrid + integer, intent(in) :: n_land + integer, intent(in) :: tile_id(:,:) + character(*), intent(in) :: vname -! print *,fac1,fac2 - -END SUBROUTINE Time_Interp_Fac - - -! --------------------------------------------------------------------- -! --------------------------------------------------------------------- -SUBROUTINE process_gswp2_veg (nc,nr,regrid,vname,fnameRst,merge) - -implicit none - integer, intent(in) :: nc,nr - real, dimension (:), allocatable :: catforc,vecforc,catcount - integer, allocatable, target, dimension (:,:) :: gswp2_mask - integer, allocatable, dimension (:,:) :: tile_id - integer, parameter :: MAX_NOF_GRID = 15238 - REAL, ALLOCATABLE :: mon_climate(:,:) - integer :: ierr, ncid,iret, maxcat - integer :: i1,k1,n,iv,year,smon,imon,mon,i,j,status - REAL, PARAMETER :: undef = 1.e+20,UNDEF_GSWP2=-9999. - integer :: k,ncatch - integer :: yr,mn,yr1,mn1 - logical :: regrid - integer, pointer :: Raster(:,:) - character(*) :: vname,fnameRst - character*100 :: fname + integer, intent(in), optional :: merge + + ! ------------------------------------------------------------- - integer, intent(in), optional :: merge + integer, parameter :: MAX_NOF_GRID = 15238 + REAL, PARAMETER :: undef = 1.e+20 + REAL, PARAMETER :: UNDEF_GSWP2 = -9999. + + real, allocatable, dimension(:) :: catforc,vecforc,catcount + integer, allocatable, target, dimension(:,:) :: gswp2_mask + REAL, ALLOCATABLE :: mon_climate(:,:) + integer :: ierr, ncid,iret + integer :: i1,k1,n,iv,year,smon,imon,mon,i,j,status + integer :: k,ncatch + integer :: yr,mn,yr1,mn1 + integer, pointer :: Raster(:,:) + character*512 :: fname + + ! ----------------------------------------------------------------- - open (10,file=trim(fnameRst)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - + allocate (gswp2_mask (1:i_raster,1:j_raster)) - allocate (tile_id (1:nc,1:nr)) - - do j=1,nr - read(10)tile_id(:,j) - end do - close (10,status='keep') - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) open (10,file=trim(MAKE_BCS_INPUT_DIR)//'/shared/mask/mapping_2.5_grid_to_gswp2_tile_index.rst',& - form='unformatted',status='old',action='read',convert='little_endian') - + form='unformatted',status='old',action='read',convert='little_endian') + do j =1,j_raster - read (10) gswp2_mask(:,j) + read (10) gswp2_mask(:,j) end do close (10,status='keep') - + if(regrid) then allocate(raster(nc,nr),stat=STATUS); VERIFY_(STATUS) else raster => gswp2_mask end if - + if(regrid) then call RegridRaster(gswp2_mask,raster) - endif - - fname='clsm/catchment.def' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)maxcat - close (10,status='keep') - + endif + allocate(vecforc(1:MAX_NOF_GRID)) - allocate(catforc(maxcat)) - allocate(catcount(maxcat)) - allocate(mon_climate(1:maxcat,1:12)) + allocate(catforc(n_land)) + allocate(catcount(n_land)) + allocate(mon_climate(1:n_land,1:12)) mon_climate(:,:)=0. catforc=0. - + mon_climate(:,:)=0. - + iret = NF_OPEN(trim(MAKE_BCS_INPUT_DIR)//'/land/veg/lai_grn/'//trim(vname)//'_uk.nc',NF_NOWRITE, ncid) - + ASSERT_(iret==NF_NOERR) - + if (present (merge)) then open (31,file='clsm/lai.dat.gswp2', & form='unformatted',status='unknown',convert='little_endian') @@ -424,1087 +434,399 @@ SUBROUTINE process_gswp2_veg (nc,nr,regrid,vname,fnameRst,merge) endif do year=82,98 - + smon=(year-82)*12 imon=0 do mon=smon+1,smon+12 imon=imon+1 iret = NF_GET_VARA_REAL(ncid, 6,(/1,mon/),(/MAX_NOF_GRID,1/),vecforc) - ASSERT_(iret==NF_NOERR) - catforc =1.e-20 - catcount=0 + ASSERT_(iret==NF_NOERR) + catforc =1.e-20 + catcount=0 DO j =1,nr - DO I = 1,nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.maxcat)) then - if ((Raster(i,j).ge.1).and.(Raster(i,j).le.MAX_NOF_GRID)) then - catforc(tile_id(i,j)) = catforc(tile_id(i,j)) + & - vecforc(Raster(i,j)) - catcount(tile_id(i,j)) = catcount(tile_id(i,j)) + 1. - endif - endif - END DO + DO I = 1,nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.n_land)) then + if ((Raster(i,j).ge.1).and.(Raster(i,j).le.MAX_NOF_GRID)) then + catforc(tile_id(i,j)) = catforc(tile_id(i,j)) + & + vecforc(Raster(i,j)) + catcount(tile_id(i,j)) = catcount(tile_id(i,j)) + 1. + endif + endif + END DO END DO - do i = 1, maxcat - if(catcount(i).gt.0.) catforc(i) = catforc (i) /catcount(i) - end do + do i = 1, n_land + if(catcount(i).gt.0.) catforc(i) = catforc (i) /catcount(i) + end do mon_climate(:,imon)=mon_climate(:,imon)+catforc(:)/17. - - END DO + + END DO END DO ! Year iret = NF_CLOSE(ncid) ASSERT_(iret==NF_NOERR) - fname='clsm/catchment.def' - - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*) ncatch - close(10,status='keep') - + ncatch = n_land + do K=0,13 - yr = (k+11)/12 - mn = mod(k+11,12)+1 - yr1= (k+12)/12 - mn1= mod(k+12,12)+1 - write(31) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,ncatch,1/)) - write(31) mon_climate(:,mod(k+11,12)+1) - end do + yr = (k+11)/12 + mn = mod(k+11,12)+1 + yr1= (k+12)/12 + mn1= mod(k+12,12)+1 + write(31) float((/yr,mn,1,0,0,0,yr1,mn1,1,0,0,0,ncatch,1/)) + write(31) mon_climate(:,mod(k+11,12)+1) + end do close(31,status='keep') - + deallocate(catforc) deallocate(mon_climate) deallocate(vecforc) deallocate(catcount) deallocate(gswp2_mask) - deallocate(tile_id) - if(regrid) then - deallocate(raster) - endif - -END SUBROUTINE process_gswp2_veg - - -! --------------------------------------------------------------------- -!---------------------------------------------------------------------- - -SUBROUTINE modis_lai (nx,ny,regrid,gfile) - -implicit none -type (date_time_type) :: before_time,after_time,end_time -character*300 :: fout,fname -character(*) :: gfile -integer :: i, n, k,j,ncatch -integer :: yr,mn,dy,yr1,mn1,dy1 -real, dimension (:,:), target, allocatable :: lai_grid -real, dimension (:), allocatable :: lai,count -character*5 :: mmdd -integer, allocatable, dimension (:,:) :: tile_id -integer :: i_sib,j_sib -integer :: nx,ny,status -logical :: regrid -real, pointer :: Raster(:,:) - -allocate(tile_id(1:nx,1:ny)) -i_sib = i_raster -j_sib = j_raster - -fname=trim(gfile)//'.rst' -open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') - -before_time%year =2001 -before_time%month =1 -before_time%day =1 -before_time%hour =0 -before_time%min =0 -before_time%sec =0 -before_time%pentad =1 -before_time%dofyr =1 - -end_time%year =2001 -end_time%month =12 -end_time%day =31 -end_time%hour =23 -end_time%min =59 -end_time%sec =59 -end_time%pentad =73 -end_time%dofyr =365 - -after_time = before_time - -do j =1,8 - call augment_date_time (86400, after_time) -end do - -fname='clsm/catchment.def' - -open (10,file=fname,status='old',action='read',form='formatted') -read (10,*) ncatch -close(10,status='keep') - -allocate (lai_grid (1:i_sib,1:j_sib)) -allocate (lai (1:ncatch)) -allocate (count (1:ncatch)) - -call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) -fname = trim(MAKE_BCS_INPUT_DIR)//'/MODIS_8-DayClim/' & -//'MOD15A2.YYYY.12.27.global_2.5min.data' - -!write (*,'(a120)')trim(fname) -!write (*,'(2(f2.0,2f3.0,3f2.0),f9.0,f2.0)') float((/0,12,27,0,0,0,1,1,1,0,0,0,ncatch,1/)) -open (20,file=trim(fname),form='unformatted',convert='little_endian', & - action='read',status='old') - -do j =1,j_raster - read (20) lai_grid (:,j) -end do -close(20,status='keep') -lai = 0. -count = 0. - -if(regrid) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) -else - raster => lai_grid -end if - -if(regrid) then - call RegridRasterReal(lai_grid,raster) -endif - - -do j=1,ny - do i=1,nx - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.ncatch)) then - if((raster (i,j).ge.0.).and.(raster (i,j).le.10.)) then - lai (tile_id(i,j)) = & - lai(tile_id(i,j)) + raster(i,j) - count(tile_id(i,j)) = & - count(tile_id(i,j)) + 1. - endif - endif - end do -end do - -DO n =1,ncatch - if(count(n)/=0.) lai(n)=lai(n)/count(n) -END DO - -fout = 'clsm/lai.dat' -open (30,file=trim(fout),form='unformatted',convert='little_endian', & - action='write',status='unknown') - -write(30) float((/0,12,27,0,0,0,1,1,1,0,0,0,ncatch,1/)) -write (30) lai - -do while (datetime_le_refdatetime(before_time,end_time)) - - yr = before_time%year -2000 !(k+11)/12 - mn = before_time%month !mod(k+11,12)+1 - dy = before_time%day - yr1= after_time%year -2000 !(k+12)/12 - mn1= after_time%month !mod(k+12,12)+1 - dy1= after_time%day - write (mmdd,'(i2.2,a1,i2.2)'),mn,'.',dy - - fname =trim(MAKE_BCS_INPUT_DIR)//'/MODIS_8-DayClim/' & - //'MOD15A2.YYYY.'//mmdd//'.global_2.5min.data' - - open (20,file=trim(fname),form='unformatted',convert='little_endian', & - action='read',status='old') - do j =1,j_raster - read (20) lai_grid (:,j) - end do - close (20,status='keep') - - if(regrid) then - call RegridRasterReal(lai_grid,raster) - else - raster => lai_grid - endif - - lai = 0. - count = 0. - - do j=1,ny - do i=1,nx - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.ncatch)) then - if((raster (i,j).ge.0.).and.(raster (i,j).le.10.)) then - lai (tile_id(i,j)) = & - lai(tile_id(i,j)) + raster(i,j) - count(tile_id(i,j)) = & - count(tile_id(i,j)) + 1. - endif - endif - end do - end do - -DO n =1,ncatch - if(count(n)/=0.) lai(n)=lai(n)/count(n) -END DO - if(mmdd.eq.'12.27') dy1 = 1 -! write(*,'(2(f2.0,2f3.0,3f2.0),f9.0,f2.0)') float((/yr,mn,dy,0,0,0,yr1,mn1,dy1,0,0,0,ncatch,1/)) - write(30) float((/yr,mn,dy,0,0,0,yr1,mn1,dy1,0,0,0,ncatch,1/)) - write (30) lai - - do j =1,8 - call augment_date_time (86400, before_time) - call augment_date_time (86400, after_time ) - end do -end do - -fname = trim(MAKE_BCS_INPUT_DIR)//'/MODIS_8-DayClim/' & -//'MOD15A2.YYYY.01.01.global_2.5min.data' - -!write (*,'(a120)')trim(fname) -open (20,file=trim(fname),form='unformatted',convert='little_endian', & - action='read',status='old') - -do j =1,j_raster - read (20) lai_grid (:,j) -end do -close(20,status='keep') - -if(regrid) then - call RegridRasterReal(lai_grid,raster) - else - raster => lai_grid -endif - -lai = 0. -count = 0. - -do j=1,ny - do i=1,ny - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.ncatch)) then - if((raster (i,j).ge.0.).and.(raster (i,j).le.10.)) then - lai (tile_id(i,j)) = & - lai(tile_id(i,j)) + raster(i,j) - count(tile_id(i,j)) = & - count(tile_id(i,j)) + 1. - endif - endif - end do -end do - -DO n =1,ncatch - if(count(n)/=0.) lai(n)=lai(n)/count(n) -END DO - -! write(*,'(2(f2.0,2f3.0,3f2.0),f9.0,f2.0)') float((/2,1,1,0,0,0,2,1,9,0,0,0,ncatch,1/)) -write(30) float((/2,1,1,0,0,0,2,1,9,0,0,0,ncatch,1/)) -write(30) lai - if(regrid) then deallocate(raster) endif -close(30,status='keep') - -END SUBROUTINE modis_lai - -!---------------------------------------------------------------------- - - SUBROUTINE soil_para_high (nx,ny,regrid,gfile,F25Tag) - - implicit none - real, dimension(12) :: lbee,lpsis,lporo,lcond,lwpwet, & - atau2,btau2,atau5,btau5 - REAL, ALLOCATABLE :: soildepth (:) - INTEGER :: soil_class_top,soil_class_com,soil_gswp,swit - REAL :: BEE, PSIS, POROS,COND,WPWET - integer :: n,maxcat,count,k1,i1,i,j - character*100 :: path,fname,fout,metpath - character(*) :: gfile - character*10 :: dline - CHARACTER*20 :: version,resoln,continent - integer :: iret,ncid,ncid1 - real, allocatable, target, dimension (:,:) :: SOIL_HIGH - integer, allocatable, dimension (:,:) :: tile_id - REAL, ALLOCATABLE :: count_soil(:) - integer :: tindex, pfafindex,i_sib,j_sib - integer :: nx,ny,status - real, allocatable, dimension(:) :: soildepth_gswp2 - integer, allocatable, dimension (:) :: land_gswp2 - logical :: regrid - real, pointer :: Raster(:,:) - logical, intent (in), optional :: F25Tag - logical :: file_exists - real, allocatable, dimension (:,:) :: parms4file - - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1 -! -! ------------------------------------------------------------------ + + END SUBROUTINE process_gswp2_veg - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - ! - ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION - ! - !$ running_omp = .true. ! conditional compilation + !---------------------------------------------------------------------- ! - ! ECHO BASIC OMP VARIABLES + ! SUBROUTINE modis_lai (nx,ny,regrid,gfile) ! - !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! apparently not used; removed by reichle, 24 Dec 2024 ! - !$OMP SINGLE - ! - !$ n_threads = omp_get_num_threads() - ! - !$ write (*,*) 'running_omp = ', running_omp - !$ write (*,*) - !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' - !$ write (*,*) - !$OMP ENDSINGLE - ! - !$OMP CRITICAL - !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' - !$OMP ENDCRITICAL - ! - !$OMP BARRIER - ! - !$OMP ENDPARALLEL - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - - data lbee /3.30, 3.80, 4.34, 5.25, 3.63, 5.96, 7.32, & - 8.41, 8.34, 9.70, 10.78, 12.93/ - data lpsis /-0.05, -0.07, -0.16, -0.65, -0.84, -0.24, & - -0.12, -0.63, -0.28, -0.12, -0.58, -0.27/ - data lporo /0.373, 0.386, 0.419, 0.476, 0.471, 0.437, & - 0.412, 0.478, 0.447, 0.415, 0.478, 0.450/ - data lcond /2.45e-05, 1.75e-05, 8.35e-06, 2.36e-06, & - 1.1e-06, 4.66e-06, 6.31e-06, 1.44e-06, & - 2.72e-06, 4.25e-06, 1.02e-06, 1.33e-06/ - data lwpwet /0.033,0.051,0.086,0.169,0.045,0.148,0.156, & - 0.249,0.211,0.199,0.286,0.276/ - - data atau2/0.0030065,0.0276075,0.0200614,0.0165152, & - 0.0165152,0.0168748,0.0308809,0.0329365, & - 0.0437085,0.0466403,0.0956670,0.1257360/ - - data btau2/0.0307900,0.0196558,0.0299702,0.0443406, & - 0.0443406,0.0359961,0.0234851,0.0370919, & - 0.0312746,0.0249973,0.0222786,0.0193874/ - - data atau5/0.0067424,0.0766189,0.0540989,0.0439714, & - 0.0439714,0.0457011,0.0589881,0.0885157, & - 0.1175960,0.0692305,0.1348880,0.1535540/ - - data btau5/0.0569718,0.0492634,0.0678898,0.0786387, & - 0.0786387,0.0737872,0.0713841,0.0742609, & - 0.0693533,0.0745496,0.0732726,0.0718882/ - - i_sib = i_raster - j_sib = j_raster - - fname='clsm/catchment.def' - - open (10,file=fname,status='old',action='read',form='formatted') - read(10,*) maxcat - close (10,status='keep') - - allocate(soildepth(maxcat)) - allocate(soil_high(1:i_raster,1:j_raster)) - allocate(count_soil(1:maxcat)) - allocate(tile_id(1:nx,1:ny)) - - inquire(file='clsm/catch_params.nc4', exist=file_exists) - - if(file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (parms4file (1:maxcat, 1:10)) - endif - - soil_high =-9999. - fname=trim(gfile)//'.rst' - - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - - if (present(F25Tag)) then - - iret = NF_OPEN(trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v1/SoilDepth.nc',NF_NOWRITE, ncid1) - ASSERT_(iret==NF_NOERR) - allocate (soildepth_gswp2(1: ncat_gswp2)) - allocate (land_gswp2 (1: ncat_gswp2)) - iret = NF_GET_VARA_INT (ncid1, 3,(/1/),(/ncat_gswp2/),land_gswp2) - ASSERT_(iret==NF_NOERR) - iret = NF_GET_VARA_REAL(ncid1, 4,(/1/),(/ncat_gswp2/),soildepth_gswp2) - ASSERT_(iret==NF_NOERR) - iret = NF_CLOSE(ncid1) - ASSERT_(iret==NF_NOERR) - - k1 = i_raster/360 - - do n = 1,ncat_gswp2 - - j = (land_gswp2(n)-1)/360 + 1 - i = land_gswp2(n) - (j - 1)*360 - j = 181 - j - soil_high((i-1)*k1+1:i*k1,(j-1)*k1+1:j*k1) = soildepth_gswp2(n) - - end do - deallocate (soildepth_gswp2,land_gswp2) - else - - open (10,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v1/soil_depth_2.5.rst',& - form='unformatted',status='old',action='read',convert='little_endian') - - do j =1,j_raster - read (10) soil_high(:,j) - end do - close (10,status='keep') - - endif - - if(regrid) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) - else - raster => soil_high - end if - - if(regrid) then - call RegridRasterReal(soil_high,raster) - endif - - soildepth =0. - count_soil = 0. + !---------------------------------------------------------------------- + + SUBROUTINE soil_para_high (nx,ny,regrid, n_land, tile_id, F25Tag) + + integer, intent(in) :: nx, ny + logical, intent(in) :: regrid + integer, intent(in) :: n_land + integer, intent(in) :: tile_id(:,:) + logical, intent (in), optional :: F25Tag - do j=1,ny - do i=1,nx - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.maxcat)) then - if(raster(i,j).eq.-9999.) then -! write (*,*)'soil_high UNDEF',i,j,tile_id(i,j),raster(i,j) - ! stop - endif - if (raster(i,j).gt.0.) then - - soildepth(tile_id(i,j)) = & - soildepth(tile_id(i,j)) + raster(i,j) - count_soil(tile_id(i,j)) = & - count_soil(tile_id(i,j)) + 1. - endif - endif - end do - end do + ! ----------------------------------------------------------- + + real, dimension(12) :: lbee,lpsis,lporo,lcond,lwpwet, & + atau2,btau2,atau5,btau5 + REAL, ALLOCATABLE :: soildepth (:) + INTEGER :: soil_class_top,soil_class_com,soil_gswp,swit + REAL :: BEE, PSIS, POROS,COND,WPWET + integer :: n,count,k1,i1,i,j + character*512 :: path,fname,fout,metpath + + CHARACTER*512 :: version,resoln,continent + integer :: iret,ncid,ncid1 + real, allocatable, target, dimension (:,:) :: SOIL_HIGH + REAL, ALLOCATABLE :: count_soil(:) + integer :: tindex, pfafindex,i_sib,j_sib + integer :: status + real, allocatable, dimension(:) :: soildepth_gswp2 + integer, allocatable, dimension (:) :: land_gswp2 - DO n =1,maxcat - if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) - if (present(F25Tag)) then - soildepth(n) = max(soildepth(n),1.) - else - soildepth(n) = max(soildepth(n),1.334) - endif - END DO + real, pointer :: Raster(:,:) - soildepth = soildepth*1000. - -! Openning files - - fname='clsm/soil_text.top' - open (10,file=fname,status='old',action='read',form='formatted') - fname='clsm/soil_text.com' - open (11,file=fname,status='old',action='read',form='formatted') - fout='clsm/soil_param.first' - open (21,file=fout,status='unknown',action='write',form='formatted') - fout='clsm/tau_param.dat' - open (22,file=fout,status='unknown',action='write',form='formatted') - - swit =0 - DO n=1 , maxcat - read (10,*) tindex,pfafindex, soil_class_top - write (22,'(i10,i8,4f10.7)')tindex,pfafindex,atau2(soil_class_top), & - btau2(soil_class_top),atau5(soil_class_top),btau5(soil_class_top) - read (11,*) tindex,pfafindex, soil_class_com - - !if (soil_class_com.eq.4) then - ! soil_gswp = 5 - !elseif (soil_class_com.eq.5) then - ! soil_gswp = 6 - !elseif (soil_class_com.eq.6) then - ! soil_gswp = 4 - !elseif (soil_class_com.eq.8) then - ! soil_gswp = 9 - !elseif (soil_class_com.eq.9) then - ! soil_gswp = 8 - !else - ! soil_gswp = soil_class_com - !endif - - soil_gswp = soil_class_com - - cond=lcond(soil_gswp)/exp(-1.*zks*gnu) - wpwet=lwpwet(soil_gswp)/lporo(soil_gswp) - write (21,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)')tindex,pfafindex, & - soil_class_top,soil_class_com,lBEE(soil_gswp), lPSIS(soil_gswp), & - lPORO(soil_gswp),COND,WPWET,soildepth(n) - - if (allocated (parms4file)) then - - parms4file (n, 1) = lBEE(soil_gswp) - parms4file (n, 2) = COND - parms4file (n, 3) = lPORO(soil_gswp) - parms4file (n, 4) = lPSIS(soil_gswp) - parms4file (n, 5) = WPWET - parms4file (n, 6) = soildepth(n) - parms4file (n, 7) = atau2(soil_class_top) - parms4file (n, 8) = btau2(soil_class_top) - parms4file (n, 9) = atau5(soil_class_top) - parms4file (n,10) = btau5(soil_class_top) - - endif - - END DO - close (10,status='delete') - close (11,status='delete') - close (21,status='keep') - close (22,status='keep') - - if(file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/maxcat/), parms4file (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/maxcat/), parms4file (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/maxcat/), parms4file (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/maxcat/), parms4file (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/maxcat/), parms4file (:, 5)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/maxcat/), parms4file (:, 6)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU2') ,(/1/),(/maxcat/), parms4file (:, 7)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU2') ,(/1/),(/maxcat/), parms4file (:, 8)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU5') ,(/1/),(/maxcat/), parms4file (:, 9)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU5') ,(/1/),(/maxcat/), parms4file (:,10)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - DEALLOCATE (parms4file) - endif - - deallocate (soildepth, soil_high) - if(regrid) then - deallocate(raster) - endif - END SUBROUTINE soil_para_high -! -! ==================================================================== -! - SUBROUTINE remove_tiny_tiles ( & - dateline,poles,gout) - - IMPLICIT NONE - INTEGER :: ip,ip2,nc_gcm,nr_gcm,nc_ocean,nr_ocean,pick_val,k,nc,nr - INTEGER :: typ,pfs,ig,jg,indx,indx_old,j_dum,ierr,n,count,count_remain,i_dum - REAL :: lat,lon,mx_frac,da,tarea - REAL(KIND=8) :: fr_gcm,fr_ocean,fr_cat,lats,dx,dy,d2r - INTEGER :: im,jm,i,j,jk,ik,jx - INTEGER :: l,imn,imx,jmn,jmx - CHARACTER*30 :: version - CHARACTER*128 :: fname,gname,gout,gpath - character*300 :: string1, string2 - integer(kind=4), allocatable, dimension(:,:) :: grid - integer(kind=4), allocatable, dimension(:,:) :: grida - REAL (kind=8), PARAMETER :: threshold=0.01,RADIUS=MAPL_RADIUS,pi= MAPL_PI - real(kind=8), allocatable, dimension(:) :: tile_frac,total_area,pfaf,tile_area(:),lon_c(:),lat_c(:),int_c(:) - character*2 :: dateline,poles - integer, allocatable, dimension(:) :: rev_indx - real, allocatable, dimension(:,:):: tile_frac_2d - integer(kind=4),allocatable :: GRIDX(:,:) + logical :: file_exists + real, allocatable, dimension (:,:) :: parms4file + + + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ ! - nc=i_raster - nr=j_raster - dx = 360._8/nc - dy = 180._8/nr - d2r = PI/180._8 - - print *,'Revised tile space..:','clsm/'//trim(gout)//'-Pfaf.notiny' + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1 + ! + ! ------------------------------------------------------------------ - gname='til/'//trim(gout)//'-Pfafstetter' - fname= trim(gname)//'.til' - - print *,'Any tile whose geographic area is <',threshold - print *,'of the AGCM grid box will be dissolved and' - print *,'the largest geographic neighbor will annex it!' - print *,'----------------------------------------------' - - open (10,file=trim(fname),status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - read (10,'(a)')version - read (10,*)nc_ocean - read (10,*)nr_ocean - - count=0 - - do n = 1,ip - - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_old,pfs,j_dum,fr_cat,j_dum - - if (typ == 100) ip2 = n - if ((typ == 100).and.(fr_gcm < threshold)) count =count +1 - if(ierr /= 0)write (*,*)'Problem reading',fname + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + + data lbee /3.30, 3.80, 4.34, 5.25, 3.63, 5.96, 7.32, & + 8.41, 8.34, 9.70, 10.78, 12.93/ + data lpsis /-0.05, -0.07, -0.16, -0.65, -0.84, -0.24, & + -0.12, -0.63, -0.28, -0.12, -0.58, -0.27/ + data lporo /0.373, 0.386, 0.419, 0.476, 0.471, 0.437, & + 0.412, 0.478, 0.447, 0.415, 0.478, 0.450/ + data lcond /2.45e-05, 1.75e-05, 8.35e-06, 2.36e-06, & + 1.1e-06, 4.66e-06, 6.31e-06, 1.44e-06, & + 2.72e-06, 4.25e-06, 1.02e-06, 1.33e-06/ + data lwpwet /0.033,0.051,0.086,0.169,0.045,0.148,0.156, & + 0.249,0.211,0.199,0.286,0.276/ + + data atau2/0.0030065,0.0276075,0.0200614,0.0165152, & + 0.0165152,0.0168748,0.0308809,0.0329365, & + 0.0437085,0.0466403,0.0956670,0.1257360/ + + data btau2/0.0307900,0.0196558,0.0299702,0.0443406, & + 0.0443406,0.0359961,0.0234851,0.0370919, & + 0.0312746,0.0249973,0.0222786,0.0193874/ + + data atau5/0.0067424,0.0766189,0.0540989,0.0439714, & + 0.0439714,0.0457011,0.0589881,0.0885157, & + 0.1175960,0.0692305,0.1348880,0.1535540/ + + data btau5/0.0569718,0.0492634,0.0678898,0.0786387, & + 0.0786387,0.0737872,0.0713841,0.0742609, & + 0.0693533,0.0745496,0.0732726,0.0718882/ - end do + i_sib = i_raster + j_sib = j_raster + + allocate(soildepth(n_land)) + allocate(soil_high(1:i_raster,1:j_raster)) + allocate(count_soil(1:n_land)) + + inquire(file='clsm/catch_params.nc4', exist=file_exists) - write (*,*)'# of small catchments to be removed ', count - if (count < ip2/100) then - - print *,'Too few tiny tiles, thus exiting .............' - print *,'CLSM parameters will be generated for ........' - print *,trim(gname) - string1 ='til/'//trim(gout)//'-Pfafstetter.til'//' '//& - 'clsm/'//trim(gout)//'-Pfaf.notiny.til' - call execute_command_line ('cp '//trim(string1)) - string1 ='rst/'//trim(gout)//'-Pfafstetter.rst'//' '//& - 'clsm/'//trim(gout)//'-Pfaf.notiny.rst' - call execute_command_line ('cp '//trim(string1)) - print *,'and, copied those those files to clsm/.' - - stop + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:n_land, 1:10)) endif - - ! - IM = nc/nc_gcm ! i-Pixels in GCM box - JM = nr/(nr_gcm-1) ! j-Pixels in interior GCM box. Pole boxes have half as many. - if (index(poles,'PE')/=0) JM = nr/(nr_gcm) ! pole edge case - allocate(GRID (nc,jm)) ! Enough space for all pixels in non-pole GCM latitude - allocate(GRIDA (nc,jm)) ! Enough space for all pixels in non-pole GCM latitude - allocate(tile_frac(ip)) - grid=0 - grida=0 - - fname='rst/'//trim(gout)//'-Pfafstetter.rst' - open (10,file=trim(fname),status='old',action='read',form='unformatted',convert='little_endian') - fname='clsm/'//trim(gout)//'-catchs_nosmall_rst' - open (11,file=trim(fname),status='unknown',action='write',form='unformatted',convert='little_endian') - - do j=1,nr_gcm ! loop over GCM latitudes - if(j==1.or.j==nr_gcm) then - jx=jm/2 ! pole latitudes are half as large - if (index(poles,'PE')/=0) jx=jm - else - jx=jm - endif + + soil_high =-9999. + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + + if (present(F25Tag)) then - allocate(tile_frac_2d(im,jx)) - do jk=1,jx ! Read raster data for one row of atmos grid points - if (index(dateline,'DE')/=0) then - read (10) grid(:,jk) - else - read (10) grid(im/2+1:,jk),grid(1:im/2,jk) - endif - if(maxval(grid(:,jk)).gt.ip) print *,'MAX EXCEED',maxval(grid(:,jk)),ip,jk - enddo - - grida=grid + iret = NF_OPEN(trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v1/SoilDepth.nc',NF_NOWRITE, ncid1) + ASSERT_(iret==NF_NOERR) + allocate (soildepth_gswp2(1: ncat_gswp2)) + allocate (land_gswp2 (1: ncat_gswp2)) + iret = NF_GET_VARA_INT (ncid1, 3,(/1/),(/ncat_gswp2/),land_gswp2) + ASSERT_(iret==NF_NOERR) + iret = NF_GET_VARA_REAL(ncid1, 4,(/1/),(/ncat_gswp2/),soildepth_gswp2) + ASSERT_(iret==NF_NOERR) + iret = NF_CLOSE(ncid1) + ASSERT_(iret==NF_NOERR) - do i=1,nc_gcm ! loop over GCM longitudes - tile_frac = 0 - tile_frac_2d = 0 + k1 = i_raster/360 + + do n = 1,ncat_gswp2 - allocate(gridx(im,jx)) - gridx(1:im,1:jx)= grid(1+(I-1)*IM:I*IM,1:JX) - ! - ! We don't touch ocean, ice and lakes pixels - do jk=1,jx - do ik = 1,im - if(gridx(ik,jk) > ip2)gridx(ik,jk)=0 - end do - end do - - ! We don't have to process 100% ocean, lake or ice pixels - if (sum(gridx) /= 0) then - ! - do jk=1,jx - ! do ik=1+(I-1)*IM,I*IM - do ik = 1,im - if(gridx(ik,jk) /= 0) then - tile_frac(gridx(ik,jk)) = tile_frac(gridx(ik,jk)) + & - 1./FLOAT(im*jx) - endif - end do - end do - ! - do n= 1,ip2 - if (tile_frac(n) > threshold) then - do jk=1,jx - do ik = 1,im - if(gridx(ik,jk) == n)then - tile_frac_2d(ik,jk) = tile_frac(n) - endif - end do - end do - end if - end do - ! - if(sum(tile_frac_2d)>0.)then - do n= 1,ip2 - if ((tile_frac(n) > 0.).and.(tile_frac(n) mx_frac) then - mx_frac = tile_frac_2d(k,jmn) - pick_val = gridx(k,jmn) - endif - end do - ! - do k=imn,imx - if(tile_frac_2d(k,jmx) > mx_frac) then - mx_frac = tile_frac_2d(k,jmx) - pick_val = gridx(k,jmx) - endif - end do - ! - do k=jmn,jmx - if(tile_frac_2d(imn,k) > mx_frac) then - mx_frac = tile_frac_2d(imn,k) - pick_val = gridx(imn,k) - endif - end do - ! - do k=jmn,jmx - if(tile_frac_2d(imx,k) > mx_frac) then - mx_frac = tile_frac_2d(imx,k) - pick_val = gridx(imx,k) - endif - end do - ! - if(pick_val >0) grida ((I-1)*IM+ik ,jk) = & - pick_val - if(pick_val >0) exit - l =l+1 - end do - endif - end do - end do - endif - end do - endif - endif ! We don't have to process 100% ocean, lake or ice pixels + j = (land_gswp2(n)-1)/360 + 1 + i = land_gswp2(n) - (j - 1)*360 + j = 181 - j + soil_high((i-1)*k1+1:i*k1,(j-1)*k1+1:j*k1) = soildepth_gswp2(n) - deallocate(gridx) - end do ! loop over GCM longitudes - deallocate(tile_frac_2d) - - ! print *,maxval(grid),minval(grid) - ! print *,maxval(grida(:,1:jx)),minval(grida(:,1:jx)),jx - - do jk=1,jx ! Read raster data for one row of atmos grid points - write (11) grida(:,jk) - enddo - end do ! loop over GCM latitudes - ! - close (10,status='keep') - close (11,status='keep') - - open (11,file=trim(fname),status='unknown',action='read',form='unformatted',convert='little_endian') - tile_frac=0. - - do j=1,nr_gcm ! loop over GCM latitudes - grid=0 + end do + deallocate (soildepth_gswp2,land_gswp2) + else - if(j==1.or.j==nr_gcm) then - jx=jm/2 ! pole latitudes are half as large - if (index(poles,'PE')/=0) jx=jm - else - jx=jm - endif + open (10,file=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_depth/v1/soil_depth_2.5.rst',& + form='unformatted',status='old',action='read',convert='little_endian') - do jk=1,jx ! Read raster data for one row of atmos grid points - read (11) grid(:,jk) - enddo - - do i=1,nc_gcm ! loop over GCM longitudes - do jk=1,jx - do ik=1+(I-1)*IM,I*IM - - tile_frac(grid(ik,jk)) = tile_frac(grid(ik,jk)) + 1./FLOAT(im*jx) - - end do - enddo + do j =1,j_raster + read (10) soil_high(:,j) end do - enddo - ! - close (11,status='keep') - ! - count=0 - count_remain=0 - allocate(rev_indx(ip)) - rev_indx=0 - do n=1,ip - if(tile_frac(n) > 0.) then - count = count + 1 - rev_indx(n) = count - if((n > ip1).and.(n <= ip2))then - if ( tile_frac(n) < threshold) count_remain =count_remain + 1 - endif - end if - end do - ! - write(*,*)'# of small catchments after merging',count_remain - write(*,*)'# of tiles in the before removing tiny tiles :',ip - write(*,*)'# of tiles in the after removing tiny tiles :',count - open (11,file=trim(fname),status='unknown',action='read',form='unformatted',convert='little_endian') - fname='clsm/'//trim(gout)//'-Pfaf.notiny.rst' - open (12,file=trim(fname),status='unknown',action='write',form='unformatted',convert='little_endian') + close (10,status='keep') + + endif - deallocate (grid,grida) - allocate(GRID (nc,1)) ! Enough space for all pixels in non-pole GCM latitude - allocate(GRIDA (nc,1)) ! Enough space for all pixels in non-pole GCM latitude + if(regrid) then + allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) + else + raster => soil_high + end if - grid=0 - grida=0 + if(regrid) then + call RegridRasterReal(soil_high,raster) + endif - allocate(total_area(ip)) - allocate(tile_area(ip)) - allocate(lon_c(ip)) - allocate(lat_c(ip)) - allocate(int_c(ip)) - - lon_c=0. - lat_c=0. - int_c=0. - tile_area=0. - total_area=0. - da = radius*radius*pi*pi/24./24./180./180./1000000. - - do jk =1,nr - lats = -90._8 + (jk - 0.5_8)*dy - read (11) grid(:,1) - do ik = 1,nc - grida(ik,1)=rev_indx(grid(ik,1)) - total_area(rev_indx(grid(ik,1)))=total_area(rev_indx(grid(ik,1))) +1. - tile_area(rev_indx(grid(ik,1)))=tile_area(rev_indx(grid(ik,1))) + & - (sin(d2r*(lats+0.5*dy)) - & - sin(d2r*(lats-0.5*dy)) )*(dx*d2r) - -! da*cos((-90.+float(jk)/24. -1./48.)*pi/180.) - - lat_c(rev_indx(grid(ik,1)))=lat_c(rev_indx(grid(ik,1))) +& - (-90.+float(jk)/24. -1./48.) - - if (index(dateline,'DE')/=0) then - lon_c(rev_indx(grid(ik,1)))=lon_c(rev_indx(grid(ik,1))) + & - (-180.+float(ik)/24. -1./48.) - else - if(ik.le.im/2)then - - lon_c(rev_indx(grid(ik,1)))=lon_c(rev_indx(grid(ik,1))) +& - (-360.-180.+float(nc-im/2+ik)/24. -1./48.) - else - lon_c(rev_indx(grid(ik,1)))=lon_c(rev_indx(grid(ik,1))) + & - (-180.+float(ik-im/2)/24. -1./48.) + soildepth =0. + count_soil = 0. + + do j=1,ny + do i=1,nx + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.n_land)) then + if(raster(i,j).eq.-9999.) then + ! write (*,*)'soil_high UNDEF',i,j,tile_id(i,j),raster(i,j) + ! stop + endif + if (raster(i,j).gt.0.) then + + soildepth(tile_id(i,j)) = & + soildepth(tile_id(i,j)) + raster(i,j) + count_soil(tile_id(i,j)) = & + count_soil(tile_id(i,j)) + 1. endif endif - int_c(rev_indx(grid(ik,1)))=int_c(rev_indx(grid(ik,1))) + 1. end do - if (index(dateline,'DE')/=0) then - write (12) grida(:,1) - else - write (12) grida(im/2+1:,1),grida(1:im/2,1) - endif end do - close (11,status='delete') - close (12,status='keep') - do n=1,ip - if(rev_indx(n)>0)then - lat_c(rev_indx(n))=lat_c(rev_indx(n))/int_c(rev_indx(n)) - lon_c(rev_indx(n))=lon_c(rev_indx(n))/int_c(rev_indx(n)) - if(lon_c(rev_indx(n)).lt.-180.)lon_c(rev_indx(n))=lon_c(rev_indx(n))+360. - endif - enddo - ! - gname='til/'//trim(gout)//'-Pfafstetter' - fname= trim(gname)//'.til' - ! - open (10,file=trim(fname),status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - read (10,'(a)')version - read (10,*)nc_ocean - read (10,*)nr_ocean - - allocate(pfaf(36716)) - pfaf=0. - - do n = 1,ip - - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,j_dum,pfs,indx_old,fr_cat,j_dum - - if(n <= ip2) then - if (rev_indx(n)>0)pfaf(indx_old)=pfaf(indx_old) +& - total_area(rev_indx(n)) + DO n =1,n_land + if(count_soil(n)/=0.) soildepth(n)=soildepth(n)/count_soil(n) + if (present(F25Tag)) then + soildepth(n) = max(soildepth(n),1.) + else + soildepth(n) = max(soildepth(n),1.334) endif - end do - close (10,status='keep') - fname= trim(gname)//'.til' - ! - open (10,file=trim(fname),status='old',action='read',form='formatted') - fname='clsm/'//trim(gout)//'-Pfaf.notiny.til' - open (20,file=trim(fname),status='unknown',action='write',form='formatted') - read (10,*)ip - write (20,*)COUNT, 8640,4320 - read (10,*)j_dum - write (20,*)j_dum - read (10,'(a)')version - write(20,'(a)')version - read (10,*)nc_gcm - write (20,*)nc_gcm - read (10,*)nr_gcm - write (20,*)nr_gcm - read (10,'(a)')version - write (20,'(a)')version - read (10,*)nc_ocean - write (20,*)nc_ocean - read (10,*)nr_ocean - write (20,*)nr_ocean + END DO - do n = 1,ip + soildepth = soildepth*1000. + + ! Openning files + + fname='clsm/soil_text.top' + open (10,file=fname,status='old',action='read',form='formatted') + fname='clsm/soil_text.com' + open (11,file=fname,status='old',action='read',form='formatted') + fout='clsm/soil_param.first' + open (21,file=fout,status='unknown',action='write',form='formatted') + fout='clsm/tau_param.dat' + open (22,file=fout,status='unknown',action='write',form='formatted') + + swit =0 + DO n=1 , n_land + read (10,*) tindex,pfafindex, soil_class_top + write (22,'(i10,i8,4f10.7)')tindex,pfafindex,atau2(soil_class_top), & + btau2(soil_class_top),atau5(soil_class_top),btau5(soil_class_top) + read (11,*) tindex,pfafindex, soil_class_com - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_old,pfs,i_dum,fr_cat,j_dum - - if(n <= ip2)then - if (rev_indx(n)>0) then - - write(20,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tile_area(rev_indx(n)),lon_c(rev_indx(n)),lat_c(rev_indx(n)),ig,jg, & - tile_frac(n),indx_old,pfs,i_dum,total_area(rev_indx(n))/pfaf(i_dum),rev_indx(n) - - endif - else - if (rev_indx(n)>0)write(20,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tile_area(rev_indx(n)),lon_c(rev_indx(n)),lat_c(rev_indx(n)),ig,jg, & - tile_frac(n),indx_old,pfs,i_dum,fr_cat,rev_indx(n) - + !if (soil_class_com.eq.4) then + ! soil_gswp = 5 + !elseif (soil_class_com.eq.5) then + ! soil_gswp = 6 + !elseif (soil_class_com.eq.6) then + ! soil_gswp = 4 + !elseif (soil_class_com.eq.8) then + ! soil_gswp = 9 + !elseif (soil_class_com.eq.9) then + ! soil_gswp = 8 + !else + ! soil_gswp = soil_class_com + !endif + + soil_gswp = soil_class_com + + cond=lcond(soil_gswp)/exp(-1.*zks*gnu) + wpwet=lwpwet(soil_gswp)/lporo(soil_gswp) + write (21,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)')tindex,pfafindex, & + soil_class_top,soil_class_com,lBEE(soil_gswp), lPSIS(soil_gswp), & + lPORO(soil_gswp),COND,WPWET,soildepth(n) + + if (allocated (parms4file)) then + + parms4file (n, 1) = lBEE(soil_gswp) + parms4file (n, 2) = COND + parms4file (n, 3) = lPORO(soil_gswp) + parms4file (n, 4) = lPSIS(soil_gswp) + parms4file (n, 5) = WPWET + parms4file (n, 6) = soildepth(n) + parms4file (n, 7) = atau2(soil_class_top) + parms4file (n, 8) = btau2(soil_class_top) + parms4file (n, 9) = atau5(soil_class_top) + parms4file (n,10) = btau5(soil_class_top) + endif - end do - - write(*,*)'Surface Area of the Earth',sum(tile_area) - write(*,*)'Land area of the Earth',sum(tile_area(rev_indx(ip1+1):rev_indx(ip2))) - close (10,status='keep') - close (20,status='keep') + + END DO + close (10,status='delete') + close (11,status='delete') + close (21,status='keep') + close (22,status='keep') - END SUBROUTINE remove_tiny_tiles - - -! --------------------------------------------------------------------- -! --------------------------------------------------------------------- -! --------------------------------------------------------------------- + if(file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/n_land/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/n_land/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/n_land/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/n_land/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/n_land/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/n_land/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU2') ,(/1/),(/n_land/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU2') ,(/1/),(/n_land/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ATAU5') ,(/1/),(/n_land/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BTAU5') ,(/1/),(/n_land/), parms4file (:,10)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif + + deallocate (soildepth, soil_high) + if(regrid) then + deallocate(raster) + endif + END SUBROUTINE soil_para_high - SUBROUTINE modis_alb_on_tiles (nx,ny,ease_grid,regrid,gfilet,gfiler) + ! ==================================================================== + ! + ! SUBROUTINE remove_tiny_tiles ( & + ! dateline,poles,gout) + ! + ! ***** subroutine not used as of Dec 2024; removed by rreichle, 20 Dec 2024 ***** + ! + ! END SUBROUTINE remove_tiny_tiles + ! + ! --------------------------------------------------------------------- + ! --------------------------------------------------------------------- + ! --------------------------------------------------------------------- + + SUBROUTINE modis_alb_on_tiles (nx,ny,regrid, n_land, tile_id) + + integer, intent(in) :: nx, ny + logical, intent(in) :: regrid + integer, intent(in) :: n_land + integer, intent(in) :: tile_id(:,:) - implicit none - CHARACTER*20 :: version,resoln,continent - character*100 :: path,fname,fout,metpath - character (*) :: gfilet,gfiler - character*10 :: dline - integer :: n,ip,maxcat,count,k1,i1,i + ! ----------------------------------------------- + + CHARACTER*512 :: version,resoln,continent + character*512 :: path,fname,fout,metpath + integer :: n,count,k1,i1,i integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean REAL :: lat,lon,fr_gcm,fr_cat,tarea - INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 + INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3,ip2 INTEGER :: laiid,year,mon,smon,imon,iret - integer,allocatable :: tile_id(:,:) integer :: ialbt,ialbs,yy,j,month character*2 :: bw character*5 :: cyy - character*300 :: albtype, albspec + character*512 :: albtype, albspec real, allocatable, target, dimension (:,:) :: alb_in real, allocatable, dimension (:) :: alb_count,alb_out - character*300 :: ifile,ofile - integer :: nx,ny,status - logical :: regrid, ease_grid + character*512 :: ifile,ofile + integer :: status real,pointer :: raster (:,:) - fname=trim(gfilet)//'.til' - - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum - - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - end do - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ,pfs,lon,lat,ig,jg,fr_gcm - else - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,j_dum,pfs,j_dum,fr_cat,j_dum - endif - if (typ == 100) ip2 = n - if(ierr /= 0)write (*,*)'Problem reading' - end do - - close (10,status='keep') - - maxcat = ip2 - - fname=trim(gfiler)//'.rst' - - open (10,file=fname,status='old',action='read', & - form='unformatted',convert='little_endian') - allocate(tile_id(1:nx,1:ny)) - - do j=1,ny - read(10)tile_id(:,j) - end do - - close (10,status='keep') + ip2 = ip1 + n_land allocate(alb_in(1:i_raster,1:j_raster)) - allocate(alb_out(1:maxcat)) - allocate(alb_count(1:maxcat)) + allocate(alb_out(1:n_land)) + allocate(alb_count(1:n_land)) if(regrid) then - allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) - else - raster => alb_in + allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) + else + raster => alb_in end if - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) do ialbt = 2,2 do ialbs = 1,2 @@ -1522,531 +844,133 @@ SUBROUTINE modis_alb_on_tiles (nx,ny,ease_grid,regrid,gfilet,gfiler) ofile='clsm/AlbMap.'//bw//'.2x5.'//trim(cyy)//'.monthly-tile.' & //albspec(1:index(albspec,'/')-1)//'.dat' - open (20,file=trim(ifile),form='unformatted',& + open (20,file=trim(ifile),form='unformatted',& convert='big_endian', & action='read',status='old') - open (30,file=trim(ofile),form='unformatted', & - convert='big_endian', & - action='write',status='unknown') - - do month =1,12 - read (20) alb_in - if(regrid) then - call RegridRasterReal(alb_in,raster) - else - raster = alb_in - endif - - alb_out = 0. - alb_count = 0. - do j=1,ny - do i=1,nx - if((tile_id(i,j).gt.ip1).and.(tile_id(i,j).le.ip2)) then - if(raster(i,j).eq.undef) then -! write (*,*)'raster UNDEF',i,j,month,albtype,albspec -! stop - endif - if ((raster(i,j).gt.0.).and.(raster(i,j).ne.undef)) then - alb_out(tile_id(i,j)-ip1) = & - alb_out(tile_id(i,j)-ip1) + raster(i,j) - alb_count(tile_id(i,j)-ip1) = & - alb_count(tile_id(i,j)-ip1) + 1. - endif - endif - end do - end do - - do n = 1,maxcat - if (alb_count(n).gt.0)then - alb_out(n) = alb_out(n)/alb_count(n) - else -! print *,'No albedo for the tile :',n - alb_out(n) = alb_out(n-1) - endif - end do - write (30) alb_out - end do - close (20,status='keep') - close (30,status='keep') - - end do - end do - end do - - deallocate (tile_id,alb_in,alb_out,alb_count) + open (30,file=trim(ofile),form='unformatted', & + convert='big_endian', & + action='write',status='unknown') + + do month =1,12 + read (20) alb_in + if(regrid) then + call RegridRasterReal(alb_in,raster) + else + raster = alb_in + endif + + alb_out = 0. + alb_count = 0. + do j=1,ny + do i=1,nx + if((tile_id(i,j).gt.ip1).and.(tile_id(i,j).le.ip2)) then + if(raster(i,j).eq.undef) then + ! write (*,*)'raster UNDEF',i,j,month,albtype,albspec + ! stop + endif + if ((raster(i,j).gt.0.).and.(raster(i,j).ne.undef)) then + alb_out(tile_id(i,j)-ip1) = & + alb_out(tile_id(i,j)-ip1) + raster(i,j) + alb_count(tile_id(i,j)-ip1) = & + alb_count(tile_id(i,j)-ip1) + 1. + endif + endif + end do + end do + + do n = 1,n_land + if (alb_count(n).gt.0)then + alb_out(n) = alb_out(n)/alb_count(n) + else + ! print *,'No albedo for the tile :',n + alb_out(n) = alb_out(n-1) + endif + end do + write (30) alb_out + end do + close (20,status='keep') + close (30,status='keep') + + end do + end do + end do + + deallocate (alb_in,alb_out,alb_count) if(regrid) then deallocate(raster) - endif + endif END SUBROUTINE modis_alb_on_tiles + + !---------------------------------------------------------------------- + ! + ! The following subroutines were already commented out as of 24 Dec 2024. + ! Removed by rreichle, 24 Dec 2024. + ! + ! SUBROUTINE modis_scale_para (ease_grid,gfile) + ! + ! SUBROUTINE make_75 (nx,ny,regrid,path,gfile) + ! + ! subroutine pick_cat(sam,clr) + ! + !---------------------------------------------------------------------- + + SUBROUTINE supplemental_tile_attributes(nx,ny,regrid,dateline,fnameTil, Rst_id) + + ! 1) get supplemental tile attributes not provided in MAPL-generated (ASCII) tile file, + ! incl. min/max lat/lon of each tile and tile elevation + ! 2) write nc4-formatted til file (incl. supplemental tile attributes) + + integer, intent(in) :: nx, ny -!---------------------------------------------------------------------- - -! SUBROUTINE modis_scale_para (ease_grid,gfile) -! -! implicit none -! type (date_time_type) :: gf_green_time,af_green_time,end_time, & -! bf_lai_time,af_lai_time,date_time_new -! logical :: ease_grid -! CHARACTER*20 :: version,resoln,continent -! integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean -! REAL :: latt,lont,fr_gcm,fr_cat,tsteps,zth, slr,tarea -! INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 -! character*100 :: path,fname,fout,metpath -! character (*) :: gfile -! integer :: n,maxcat,ip -! integer :: ialbt,ialbs,yy,j,month,unit1,unit2,unit3 -! character*2 :: bw -! character*5 :: cyy -! character*300 :: albtype, albspec -! character*30, dimension (2,2) :: sibname -! character*30, dimension (2,2) :: geosname -! integer, allocatable, dimension (:) :: vegcls -! real, allocatable, dimension (:) :: & -! modisalb,scale_fac,albvf,albnf, lat,lon, & -! green,lai,lai_before,lai_after,grn_before,grn_after -! real, allocatable, dimension (:) :: & -! calbvf,calbnf, zero_array, one_array, albvr,albnr -! character*300 :: ifile1,ifile2,ofile -! integer, dimension(12), parameter :: days_in_month_nonleap = & -! (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) -! integer :: day, hour, min ,secs_in_day,k -! real :: yr,mn,dy,yr1,mn1,dy1,dum, slice1,slice2 -! -! ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! ! -! ! NOTE: "!$" is for conditional compilation -! ! -! logical :: running_omp = .false. -! ! -! !$ integer :: omp_get_thread_num, omp_get_num_threads -! ! -! integer :: n_threads=1 -! ! -! ! ------------------------------------------------------------------ -! -! ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- -! ! -! ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION -! ! -! !$ running_omp = .true. ! conditional compilation -! ! -! ! ECHO BASIC OMP VARIABLES -! ! -! !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) -! ! -! !$OMP SINGLE -! ! -! !$ n_threads = omp_get_num_threads() -! ! -! !$ write (*,*) 'running_omp = ', running_omp -! !$ write (*,*) -! !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' -! !$ write (*,*) -! !$OMP ENDSINGLE -! ! -! !$OMP CRITICAL -! !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' -! !$OMP ENDCRITICAL -! ! -! !$OMP BARRIER -! ! -! !$OMP ENDPARALLEL -! ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- -! -! data sibname /'albvr','albnr', & -! 'albvf','albnf'/ -! data geosname /'visdr','nirdr', & -! 'visdf','nirdf'/ -! -! fname='clsm/catchment.def' -! open (10,file=fname,status='old',action='read',form='formatted') -! read (10,*)maxcat -! allocate (albvf (1:maxcat)) -! allocate (albnf (1:maxcat)) -! allocate (calbvf (1:maxcat)) -! allocate (calbnf (1:maxcat)) -! allocate (modisalb (1:maxcat)) -! allocate (lai (1:maxcat)) -! allocate (green (1:maxcat)) -! allocate (lai_before (1:maxcat)) -! allocate (grn_before (1:maxcat)) -! allocate (lai_after (1:maxcat)) -! allocate (grn_after (1:maxcat)) -! allocate (vegcls (1:maxcat)) -! allocate (zero_array (1:maxcat)) -! allocate (one_array (1:maxcat)) -! allocate (albvr (1:maxcat)) -! allocate (albnr (1:maxcat)) -! close (10,status='keep') -! -! date_time_new%year =2002 -! date_time_new%month =1 -! date_time_new%day =1 -! date_time_new%hour =0 -! date_time_new%min =0 -! date_time_new%sec =0 -! date_time_new%pentad =1 -! date_time_new%dofyr =1 -! -! gf_green_time = date_time_new -! af_green_time = date_time_new -! end_time = date_time_new -! bf_lai_time = date_time_new -! af_lai_time = date_time_new -! -! fname=trim(gfile)//'.til' -! -! open (10,file=fname,status='old',action='read',form='formatted') -! fname='clsm/mosaic_veg_typs_fracs' -! open (20,file=fname,status='old',action='read',form='formatted') -! -! read (10,*)ip -! read (10,*)j_dum -! -! do n = 1, j_dum -! read (10,'(a)')version -! read (10,*)nc_gcm -! read (10,*)nr_gcm -! end do -! -! do n = 1,ip -! if (ease_grid) then -! read(10,*,IOSTAT=ierr) typ,pfs,lon,lat,ig,jg,fr_gcm -! else -! read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & -! typ,tarea,lont,latt,ig,jg,fr_gcm,indx_dum,pfs,j_dum,fr_cat,j_dum -! endif -! if (typ == 100) then -! ip2 = n -! read (20,'(i10,i8,2(2x,i3),2(2x,f6.4))') & -! indr1,indr1,vegcls(ip2),indr1,fr_gcm,fr_gcm -! endif -! if(ierr /= 0)write (*,*)'Problem reading' -! end do -! close (10,status='keep') -! close (20,status='keep') -! -! cyy='00-04' -! albvf =0. -! albnf =0. -! calbvf =0. -! calbnf =0. -! modisalb =0. -! zero_array = 0. -! one_array = 1. -! albvr = 0. -! albnr = 0. -! -! unit1 =10 -! unit2 =20 -! unit3 =30 -! -! do ialbt = 2,2 -! do ialbs = 1,2 -! -! if(ialbt.eq.1)albtype='BlackSky/' -! if(ialbt.eq.2)albtype='WhiteSky/' -! if(ialbt.eq.1)bw='BS' -! if(ialbt.eq.2)bw='WS' -! if(ialbs.eq.1)albspec='0.3_0.7/' -! if(ialbs.eq.2)albspec='0.7_5.0/' -! ifile1='clsm/AlbMap.'//bw//'.2x5.'//trim(cyy)//'.monthly-tile.' & -! //albspec(1:index(albspec,'/')-1)//'.dat' -! ! write (*,*) 'MODIS file: ', unit1,trim(ifile1) -! ! write (*,*) '-----------------------------' -! -! ifile2='clsm/sibalb1.'//trim(sibname(ialbs,ialbt))//'.climatology' -! ! write (*,*) 'SiB file: ', unit2, trim(ifile2) -! -! ofile='clsm/modis_scale_factor.'//trim(sibname(ialbs,ialbt))//'.clim' -! -! ! write (*,*) 'Scale factor: ', unit3, trim(ofile) -! -! open (unit1,file=trim(ifile1),form='unformatted',convert='big_endian', & -! action='read',status='old') -! open (unit2,file=trim(ifile2),form='unformatted',convert='big_endian', & -! action='write',status='unknown') -! open (unit3,file=trim(ofile),form='unformatted',convert='big_endian', & -! action='write',status='unknown') -! -! unit1 = unit1 + 1 -! unit2 = unit2 + 1 -! unit3 = unit3 + 1 -! end do -! end do -! -! fname='clsm/lai.dat' -! open (40,file=fname,status='old',action='read',form='unformatted', & -! convert='little_endian') -! read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(40) lai_before -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,bf_lai_time) -! -! read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(40) lai_after -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) -! -! fname='clsm/green.dat' -! open (41,file=fname,status='old',action='read',form='unformatted', & -! convert='little_endian') -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_before -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,gf_green_time) -! -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_after -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) -! -! do month=1,12 -! -! write (*,'(a48,i3)') ' Computing MODIS scale parameters for month: ',month -! -! calbvf =0. -! calbnf =0. -! albvf =0. -! albnf =0. -! tsteps =0. -! -! do day = 1,days_in_month_nonleap(month) -! -! if (datetime_le_refdatetime(date_time_new,af_lai_time)) then -! -! else -! lai_before = lai_after -! bf_lai_time = af_lai_time -! read(40) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(40) lai_after -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_lai_time) -! endif -! call Time_Interp_Fac (date_time_new, bf_lai_time, af_lai_time, slice1, slice2) -! lai = (slice1*lai_before + slice2*lai_after) -! ! print *,'LAI' -! ! print *,bf_lai_time -! ! print *,af_lai_time -! ! print *,slice1,slice2 -! ! print *,minval(lai),maxval(lai) -! -! if (datetime_le_refdatetime(date_time_new,af_green_time)) then -! -! else -! grn_before = grn_after -! gf_green_time = af_green_time -! read(41) yr,mn,dy,dum,dum,dum,yr1,mn1,dy1 -! read(41) grn_after -! call Get_MidTime(yr,mn,dy,yr1,mn1,dy1,af_green_time) -! -! endif -! call Time_Interp_Fac (date_time_new, gf_green_time, af_green_time, slice1, slice2) -! green = (slice1*grn_before + slice2*grn_after) -! ! print *,'GREEN' -! ! print *,gf_green_time -! ! print *,af_green_time -! ! print *,slice1,slice2 -! ! print *,minval(green),maxval(green) -! -! call augment_date_time(86400,date_time_new) -! -! tsteps = tsteps + 1. -! -! call sibalb ( & -! MAXCAT,vegcls,lai,green, zero_array, & -! one_array,one_array,one_array,one_array, & -! ALBVR, ALBNR, albvf, albnf) -! -! calbvf = calbvf + albvf -! calbnf = calbnf + albnf -! -! end do -! -! calbvf = calbvf/tsteps -! calbnf = calbnf/tsteps -! -! unit1 =10 -! unit2 =20 -! unit3 =30 -! -! do ialbt = 2,2 -! do ialbs = 1,2 -! -! read (unit1) (modisalb(n),n=1,maxcat) -! if(unit2==20)write (unit2) (calbvf(n),n=1,maxcat) -! if(unit2==21)write (unit2) (calbnf(n),n=1,maxcat) -! -! if(unit2==20) modisalb = modisalb/(calbvf + 1.e-20) -! if(unit2==21) modisalb = modisalb/(calbnf + 1.e-20) -! -! do n =1, maxcat -! if(modisalb(n).le.0)then -! print *,'Negative MODIS scale param at cell',n, modisalb(n) -! print *,'Set to 1' -! modisalb(n)=1 -! endif -! -! if(modisalb(n).gt.100)then -! print *,'Too large MODIS scale param',n, modisalb(n) -! print *,'Set to 1' -! modisalb(n)=1 -! endif -! -! enddo -! -! write (unit3) (modisalb(n),n=1,maxcat) -! -! unit1 = unit1 + 1 -! unit2 = unit2 + 1 -! unit3 = unit3 + 1 -! end do -! end do -! -! end do -! -! deallocate (modisalb,albvf,albnf) -! deallocate (green,lai) -! deallocate (vegcls) -! deallocate (calbvf,calbnf) -! deallocate (zero_array, one_array, albvr, albnr) -! -! unit1 =10 -! unit2 =20 -! unit3 =30 -! -! do ialbt = 2,2 -! do ialbs = 1,2 -! -! close (unit1, status='keep') -! close (unit2, status='keep') -! close (unit3, status='keep') -! -! unit1 = unit1 + 1 -! unit2 = unit2 + 1 -! unit3 = unit3 + 1 -! end do -! end do -! -! close (40, status='keep') -! close (41, status='keep') -! -! END SUBROUTINE modis_scale_para -! -! !---------------------------------------------------------------------- -! -! SUBROUTINE make_75 (nx,ny,regrid,path,gfile) -! implicit none -! integer nc,nr,i,j,i1,i2,j1,j2,cls,ip, ii, jj,xc,xr -! integer, allocatable :: catid(:,:),catold(:,:),cat75(:,:) -! integer sam(3,3) -! character*100 filename,path -! character (*) :: gfile -! integer :: nx,ny -! logical :: regrid -! -! nc = i_raster -! nr = j_raster -! -! filename=trim(path)//'global.cat_id.catch.DL' -! open (9,file=filename,form='formatted',status='old') -! -! filename=trim(gfile)//'.rst' -! -! open (10,file=filename,convert='little_endian', & -! form='unformatted',status='old',action='read') -! -! allocate(catid(nc,nr)) -! allocate(catold(nc,nr)) -! catid=0 -! catold=0 -! -! do j=1,nr -! read (9,*)(catold(i,j),i=1,nc) -! read (10)(catid(i,j),i=1,nc) -! do i=1,nc -! if((catold(i,j).eq.0).or.(catold(i,j).gt.5999900))catid(i,j)=0 -! end do -! end do -! -! close(9,status='keep') -! close(10,status='keep') -! -! deallocate(catold) -! allocate(cat75(nc/3,nr/3)) -! -! cat75=0 -! -! filename=trim(gfile)//'.7.5.rst' -! -! open (11,file=filename,convert='little_endian',form='unformatted',status='unknown') -! -! do j=1,1440 -! j2=J*3 -! j1=j2-2 -! do i=1,2880 -! i2=i*3 -! i1=i2-2 -! sam(1:3,1:3)=catid(i1:i2,j1:j2) -! call pick_cat(sam,cat75(i,j)) -! ! write(*,*)cat75(i,j) -! ! pause -! end do -! write (11)(cat75(i,j),i=1,2880) -! end do -! deallocate(catid) -! deallocate(cat75) -! -! end SUBROUTINE make_75 -! -! !---------------------------------------------------------------------- -! -! subroutine pick_cat(sam,clr) -! implicit none -! -! integer sam(9),num_val(9),i,j,cls(1),clr(1) -! num_val(1:9)=0 -! clr=0 -! do i=1,9 -! do j=1,9 -! if(sam(i).eq.sam(j))num_val(i)=num_val(i)+1 -! end do -! end do -! clr=sam(maxloc(num_val)) -! -! end subroutine pick_cat -! -! -!---------------------------------------------------------------------- - - SUBROUTINE catchment_def (nx,ny,regrid,dateline,gfilet,gfiler) - - implicit none + logical, intent(in) :: regrid + + character(*), intent(in) :: dateline + + character(*), intent(in) :: fnameTil ! file name (w/o extension) of tile file + integer, intent(in) :: Rst_id(:,:) + + ! --------------------------------------------------------- INTEGER, allocatable, dimension(:) :: CATID - integer :: n,ip,maxcat,count,k1,i1,i,j,i_sib,j_sib - INTEGER, allocatable, dimension (:) :: id,I_INDEX,J_INDEX - integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean - REAL :: lat,lon,fr_gcm,fr_cat,tarea - INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 - REAL (kind=8), PARAMETER :: RADIUS=MAPL_RADIUS,pi= MAPL_PI - character*100 :: path,fname,fout,metpath - character*200 :: gtopo30 - character (*) :: gfilet,gfiler - character*10 :: dline - CHARACTER*20 :: version,resoln,continent - REAL, ALLOCATABLE :: limits(:,:) - REAL :: mnx,mxx,mny,mxy,dx,dy,d2r,lats,sum1,sum2,dx_gcm,dy_gcm - REAL, dimension (:), allocatable :: tile_ele, tile_area,tile_area_land - integer :: nx,ny,status - logical :: regrid - real, pointer :: Raster(:,:) + integer :: n, ip, n_land, i, j, i_sib, j_sib, status + INTEGER, allocatable, dimension(:) :: id, I_INDEX, J_INDEX + integer :: nc_gcm, nr_gcm, nc_ocean, nr_ocean + REAL :: lat, lon, fr_gcm, fr_cat, tarea + INTEGER :: typ, pfs, ig, jg, j_dum, i_dum, ierr, indx_dum, ip2 + + REAL (REAL64), PARAMETER :: RADIUS=MAPL_RADIUS, pi= MAPL_PI - character*2 :: dateline - real*4, allocatable , target :: q0 (:,:) + character*512 :: fname + character*512 :: gtopo30 + CHARACTER*512 :: version + REAL, allocatable :: limits(:,:) + + REAL :: mnx,mxx,mny,mxy,dx,dy,d2r,lats,sum1,dx_gcm,area_rst + + REAL, allocatable, dimension(:) :: tile_ele, tile_area,tile_area_rst + integer :: IM(2), JM(2) + + real, pointer :: Raster(:,:) + real :: mean_land_elev + + real*4, allocatable, target :: q0 (:,:) + real(REAL64), allocatable :: rTable(:,:) + integer, allocatable :: iTable(:,:) + character(len=512) :: gName(2) + logical, allocatable :: IsOcean(:) + + ! ----------------------------------------------------- + ! + ! get elevation (q0) from "gtopo30" raster file ("srtm30_withKMS_2.5x2.5min.data") + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) gtopo30 = trim(MAKE_BCS_INPUT_DIR)//'/land/topo/v1/srtm30_withKMS_2.5x2.5min.data' allocate (q0(1:i_raster,1:j_raster)) i_sib = nx j_sib = ny - + dx = 360._8/i_sib dy = 180._8/j_sib d2r = PI/180._8 @@ -2054,119 +978,143 @@ SUBROUTINE catchment_def (nx,ny,regrid,dateline,gfilet,gfiler) open (10,file=trim(gtopo30),form='unformatted',status='old') read (10) q0 close (10,status='keep') - + if(regrid) then allocate(raster(nx,ny),stat=STATUS); VERIFY_(STATUS) else raster => q0 end if - + if(regrid) then call RegridRasterReal(q0,raster) endif + ! ----------------------------------------------------------- + ! + ! read ASCII-formatted tile file (*.til) + ! + ! ip = number of tiles in global domain (all types, incl. land, landice, lake, & ocean) + ! ip1 = index offset for land tiles in *.til files (ip1=0 implies that land tiles first in *.til file) + ! ip2 = ip1 + n_land = end index of land tiles (where n_land is number of land tiles in global *.til file) + allocate (catid(1:i_sib)) catid=0 - fname=trim(gfilet)//'.til' + fname=trim(fnameTil)//'.til' open (10,file=fname,status='old',action='read',form='formatted') read (10,*)ip - allocate(id(ip)) - allocate(i_index(ip)) - allocate(j_index(ip)) - allocate(tile_area(ip)) + + allocate(id( ip)) + allocate(i_index( ip)) + allocate(j_index( ip)) + allocate(tile_area(ip)) + id=0 read (10,*)j_dum - + IM = 0 + JM = 0 + gName = ['',''] do n = 1, j_dum read (10,'(a)')version read (10,*)nc_gcm read (10,*)nr_gcm + gName(n) = trim(adjustl(version)) + IM(n) = nc_gcm + JM(n) = nr_gcm end do ! dx_gcm = 360./float(nc_gcm) -! dy_gcm = 180./float(nr_gcm) - + + allocate(iTable(ip,0:7)) + allocate(rTable(ip,10)) + rTable = MAPL_UNDEF_r8 + + allocate(IsOcean(ip)) + IsOcean = .false. + do n = 1,ip - - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,j_dum,fr_cat,j_dum - tile_area(n) = tarea - id(n)=pfs - i_index(n) = ig - j_index(n) = jg + + read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & + typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,i_dum,fr_cat,j_dum + + if(ierr /= 0) write (*,*)'Problem reading ' // trim(fname) + + tile_area(n) = tarea + id(n) = pfs + i_index(n) = ig + j_index(n) = jg if (typ == 100) ip2 = n - if(ierr /= 0)write (*,*)'Problem reading' + if (typ == 0 ) IsOcean(n) = .true. + + iTable(n,0) = typ + rTable(n,3) = tarea + rTable(n,1) = lon + rTable(n,2) = lat + iTable(n,2) = ig + iTable(n,3) = jg + rTable(n,4) = fr_gcm + iTable(n,6) = indx_dum + iTable(n,4) = pfs + iTable(n,5) = i_dum + rTable(n,5) = fr_cat + iTable(n,7) = j_dum end do close (10,status='keep') + + n_land=ip2-ip1 ! = number of land tiles + + ! --------------------------------------------------------------- + ! + ! compute supplemental tile info: mean elevation and min/max lat/lon of each tile + + allocate(tile_ele( 1:ip)) + allocate(tile_area_rst(1:ip)) - maxcat=ip2-ip1 - -! Tile elevation - allocate(tile_ele(1:maxcat)) - allocate(tile_area_land(1:maxcat)) - tile_ele = 0. - tile_area_land = 0. - - fname=trim(gfiler)//'.rst' - open (10,file=fname,status='old',action='read',form='unformatted',convert='little_endian') + tile_ele = 0. + tile_area_rst = 0. ! total area of raster grid cells contributing to each tile - do j=1,j_sib + allocate(limits( 1:ip,1:4)) - lats = -90._8 + (j - 0.5_8)*dy - read (10)(catid(i),i=1,i_sib) + limits(:,1) = 360. + limits(:,2) = -360. + limits(:,3) = 90. + limits(:,4) = -90. - do i=1,i_sib - if((catid(i) > ip1).and.(catid(i) <= ip2))then - tile_ele(catid(i)-ip1) = tile_ele(catid(i)-ip1) + raster(i,j)* & - (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) - tile_area_land(catid(i)-ip1) = tile_area_land(catid(i)-ip1) + & - (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) - endif - enddo - enddo - tile_ele = tile_ele/tile_area_land - close (10, status='keep') + ! read raster file with tile IDs - ! adjustment Global Mean Topography to 614.649 (615.662 GTOPO 30) m - ! -------------------------------------------- - sum1=0. - sum2=0. - do j=1,maxcat - sum1 = sum1 + tile_ele(j)*tile_area(j) - enddo - if(sum1/sum(tile_area(1:maxcat)).ne. 614.649D0 ) then -! print *,sum1/sum(tile_area(1:maxcat)) - tile_ele =tile_ele*(614.649D0 / (sum1/sum(tile_area(1:maxcat)))) - sum1=0. - sum2=0. - do j=1,maxcat - sum1 = sum1 + tile_ele(j)*tile_area(j) - enddo -! print *,sum1/sum(tile_area(1:maxcat)) - endif - + do j=1,j_sib + + ! latitude and area of raster grid cells associated with lat index j + + lats = -90._8 + (j - 0.5_8)*dy + + ! preserve zero-diff + !area_rst = (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) -! catchment def file -! ------------------ - allocate(limits(1:maxcat,1:4)) - limits(:,1)=360. - limits(:,2)=-360. - limits(:,3)=90. - limits(:,4)=-90. + ! read tile IDs for lat index j + catid(:) = rst_id(:,j) - fname=trim(gfiler)//'.rst' - open (10,file=fname,status='old',action='read',form='unformatted',convert='little_endian') - - do j=1,j_sib + ! compute average elevation weighted by area of contributing raster grid cells + + do i=1,i_sib + if (.not. IsOcean(catid(i)-ip1)) then + + tile_ele( catid(i)-ip1) = tile_ele( catid(i)-ip1) + raster(i,j)* & + (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) + + tile_area_rst(catid(i)-ip1) = tile_area_rst(catid(i)-ip1) + & + (sin(d2r*(lats+0.5*dy)) -sin(d2r*(lats-0.5*dy)))*(dx*d2r) + + endif + enddo + mny=-90. + float(j-1)*180./float(j_sib) mxy=-90. + float(j) *180./float(j_sib) - read (10)(catid(i),i=1,i_sib) + if (index(dateline,'DE')/=0) then - do i=1,i_sib - if((catid(i) > ip1).and.(catid(i) <= ip2))then + if( .not. IsOcean(catid(i)- ip1))then mnx =-180. + float(i-1)*360./float(i_sib) mxx =-180. + float(i) *360./float(i_sib) if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx @@ -2176,63 +1124,128 @@ SUBROUTINE catchment_def (nx,ny,regrid,dateline,gfilet,gfiler) endif end do else - do i=1,i_sib- i_sib/nc_gcm/2 - if((catid(i) > ip1).and.(catid(i) <= ip2))then - mnx =-180. + float(i-1)*360./float(i_sib) - mxx =-180. + float(i) *360./float(i_sib) - if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx - if(mxx .gt.limits(catid(i)-ip1,2))limits(catid(i)-ip1,2)=mxx - if(mny .lt.limits(catid(i)-ip1,3))limits(catid(i)-ip1,3)=mny - if(mxy .gt.limits(catid(i)-ip1,4))limits(catid(i)-ip1,4)=mxy - endif - end do - do i=i_sib- i_sib/nc_gcm/2 +1,i_sib - if((catid(i) > ip1).and.(catid(i) <= ip2))then - mnx =-360. -180. + float(i-1)*360./float(i_sib) - mxx =-360. -180. + float(i) *360./float(i_sib) - if(mnx < -180. ) mnx = mnx + 360. - if(mxx <= -180.) mxx = mxx + 360. - if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx - if(mxx .gt.limits(catid(i)-ip1,2))limits(catid(i)-ip1,2)=mxx - if(mny .lt.limits(catid(i)-ip1,3))limits(catid(i)-ip1,3)=mny - if(mxy .gt.limits(catid(i)-ip1,4))limits(catid(i)-ip1,4)=mxy - endif - end do - - endif - - end do - close(10,status='keep') - - open (10,file='clsm//catchment.def', & - form='formatted',status='unknown') - write (10,*)maxcat - - do j=1,maxcat - if(limits(j,1).lt.-180.) limits(j,1)= limits(j,1)+360. - if(limits(j,2).le.-180.) limits(j,2)= limits(j,2)+360. - ! if(trim(dateline)=='DC')then - ! limits(j,1) = max(limits(j,1),(i_index(j)-1)*dx_gcm -180. - dx_gcm/2.) - ! limits(j,2) = min(limits(j,2),(i_index(j)-1)*dx_gcm -180. + dx_gcm/2.) + do i=1,i_sib- i_sib/nc_gcm/2 + if( .not. IsOcean(catid(i) - ip1)) then + mnx =-180. + float(i-1)*360./float(i_sib) + mxx =-180. + float(i) *360./float(i_sib) + if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx + if(mxx .gt.limits(catid(i)-ip1,2))limits(catid(i)-ip1,2)=mxx + if(mny .lt.limits(catid(i)-ip1,3))limits(catid(i)-ip1,3)=mny + if(mxy .gt.limits(catid(i)-ip1,4))limits(catid(i)-ip1,4)=mxy + endif + end do + do i=i_sib- i_sib/nc_gcm/2 +1,i_sib + if( .not. IsOcean(catid(i) - ip1)) then + mnx =-360. -180. + float(i-1)*360./float(i_sib) + mxx =-360. -180. + float(i) *360./float(i_sib) + if(mnx < -180.) mnx = mnx + 360. + if(mxx <= -180.) mxx = mxx + 360. + if(mnx .lt.limits(catid(i)-ip1,1))limits(catid(i)-ip1,1)=mnx + if(mxx .gt.limits(catid(i)-ip1,2))limits(catid(i)-ip1,2)=mxx + if(mny .lt.limits(catid(i)-ip1,3))limits(catid(i)-ip1,3)=mny + if(mxy .gt.limits(catid(i)-ip1,4))limits(catid(i)-ip1,4)=mxy + endif + end do + endif + enddo + + ! finalize min/max lat/lon + + where (limits(:,1).lt.-180.) limits(:,1) = limits(:,1) + 360.0 + where (limits(:,2).le.-180.) limits(:,2) = limits(:,2) + 360.0 + + ! finalize elevation + + where ( .not. IsOcean) tile_ele = tile_ele/tile_area_rst + + ! adjust global mean (land) topography to 614.649 (615.662 GTOPO 30) m + + sum1=0. + + do j=1,n_land + sum1 = sum1 + tile_ele(j)*tile_area(j) + enddo + + mean_land_elev = sum1/sum(tile_area(1:n_land)) + + if ( mean_land_elev .ne. Target_mean_land_elev ) then + + print *, 'Global mean land elevation before adjustment [m]: ', mean_land_elev + + tile_ele(1:n_land) = tile_ele(1:n_land)*(Target_mean_land_elev / mean_land_elev) + + ! verify adjustment + + sum1=0. + + do j=1,n_land + sum1 = sum1 + tile_ele(j)*tile_area(j) + enddo + + print *, 'Global mean land elevation after scaling to SRTM [m]: ', sum1/sum(tile_area(1:n_land)) + + endif + + ! -------------------------------------------------------------------------- + ! + ! write (ASCII) catchment.def file (land tiles only!) + + open (10,file='clsm//catchment.def', & + form='formatted',status='unknown') + write (10,*) n_land + + do j=1,n_land + ! if(trim(dateline)=='DC')then + ! limits(j,1) = max(limits(j,1),(i_index(j)-1)*dx_gcm -180. - dx_gcm/2.) + ! limits(j,2) = min(limits(j,2),(i_index(j)-1)*dx_gcm -180. + dx_gcm/2.) ! endif write (10,'(i10,i8,5(2x,f9.4))')j+ip1,id(j+ip1),limits(j,1), & limits(j,2),limits(j,3),limits(j,4),tile_ele(j) end do - + close(10,status='keep') + + ! -------------------------------------------------------------------------- + ! + ! write nc4-formatted tile file (all tile types) + + rTable(1:ip,6:9) = limits + rTable(1:ip, 10) = tile_ele(1:ip) + ! re-define rTable(:,4) and rTable(:,5). + ! fr will be re-created in WriteTilingNC4 + where (rTable(:,4) /=0.0) + rTable(:,4) = rTable(:,3)/rTable(:,4) + endwhere + where (rTable(:,5) /=0.0) + rTable(:,5) = rTable(:,3)/rTable(:,5) + endwhere + + fname=trim(fnameTil)//'.nc4' + if (im(2) == 0) then ! one grid + call WriteTilingNC4(fname, [gName(1)], [im(1)], [jm(1)], nx, ny, iTable, rTable, N_PfafCat=SRTM_maxcat, rc=status) + else ! two grids + call WriteTilingNC4(fname, gName, im, jm, nx, ny, iTable, rTable, N_PfafCat=SRTM_maxcat, rc=status) + endif + + deallocate (rTable, iTable) deallocate (limits) deallocate (catid) deallocate (q0) if(regrid) then deallocate(raster) - endif - END SUBROUTINE catchment_def + endif + + END SUBROUTINE supplemental_tile_attributes -!---------------------------------------------------------------------- + !---------------------------------------------------------------------- - SUBROUTINE create_soil_types_files (nx,ny,ease_grid,gfilet,gfiler) - - implicit none + SUBROUTINE create_soil_types_files( nx, ny, n_land, tile_pfs, catid ) + + integer, intent(in) :: nx, ny + integer, intent(in) :: n_land + integer, intent(in) :: tile_pfs(:) + INTEGER, target,intent(in) :: CATID(:,:) + ! This program reads global 5'x5' soil texture classification, ! then find the dominant Soil Classes for the GCM ! http://www.ngdc.noaa.gov/seg/eco/cdroms/reynolds/reynolds/reynolds.htm @@ -2261,7 +1274,6 @@ SUBROUTINE create_soil_types_files (nx,ny,ease_grid,gfilet,gfiler) PARAMETER(col=4320,row=2160) INTEGER, allocatable :: SIB_LAY(:,:) - INTEGER, allocatable, target :: CATID(:,:) INTEGER, allocatable :: SOIL1(:,:) INTEGER, allocatable :: SOIL2(:,:) INTEGER tem1 (13),tem2(13),tem3(13) @@ -2269,281 +1281,251 @@ SUBROUTINE create_soil_types_files (nx,ny,ease_grid,gfilet,gfiler) INTEGER IDVAL,STEX INTEGER (kind=1), allocatable :: gtext(:,:) INTEGER irrecs, c1,c2,r1,r2 - CHARACTER*200 ifile,ifile2,ofile1,ofile2,fname - CHARACTER (*) :: gfiler,gfilet - character*10 :: dline - CHARACTER*20 :: version,resoln + CHARACTER*512 ifile,ifile2,ofile1,ofile2,fname + CHARACTER*512 :: version,resoln INTEGER, allocatable, dimension (:) :: id !indx,id,indx_old integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean REAL :: lat,lon,fr_gcm,fr_cat,tarea INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 - integer :: nx,ny,status - logical :: ease_grid - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1 - -! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- -! -! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION -! -!$ running_omp = .true. ! conditional compilation -! -! ECHO BASIC OMP VARIABLES -! -!$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) -! -!$OMP SINGLE -! -!$ n_threads = omp_get_num_threads() -! -!$ write (*,*) 'running_omp = ', running_omp -!$ write (*,*) -!$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' -!$ write (*,*) -!$OMP ENDSINGLE -! -!$OMP CRITICAL -!$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' -!$OMP ENDCRITICAL -! -!$OMP BARRIER -! -!$OMP ENDPARALLEL -! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + integer :: status + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ + ! + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1 + + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + colsib = nx rowsib = ny ! ! Compute the number of input records per row. irrecs = nint (col / 4.0) ! - allocate(catid(1:nx,1:ny)) - catid =0 - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - + ifile=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/v1/'//'dtex_tp1.bin' ifile2=trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/soil_properties/v1/'//'dtex_sb1.bin' ofile1='clsm/soil_text.top' ofile2='clsm/soil_text.com' - fname=trim(gfilet)//'.til' + ip = size(tile_pfs,1) + allocate(id(1:ip), source = tile_pfs) - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)ip - read (10,*)j_dum + ip2 = ip1 + n_land + + ! write(*,*)'Finished reading CAT_IDs' - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm + ! Top layer soil classification 0-30cm + ! + open (unit=11, file=ifile, form='unformatted', status='old', & + convert = 'big_endian') + + ! + allocate(gtext(1:col,1:row)) + allocate(SIB_LAY(1:nx,1:ny)) + gtext(:,:)=0 + SIB_LAY(:,:)=0 + k=0 + do j=row,1,-1 + ! do i=1,irrecs + ! k=k+1 + ! c1 = (4*i)-3 + ! c2 = (4*i) + ! read (unit=11, rec=k) (gtext(ii,j), ii=c1,c2) + read (unit=11) (gtext(i,j), i=1,col) + ! end do end do - - allocate(id(ip)) - id=0 - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ,pfs,lon,lat,ig,jg,fr_gcm - else - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,j_dum,fr_cat,j_dum - endif - id(n)=pfs - if (typ == 100) ip2 = n - - if(ierr /= 0)write (*,*)'Problem reading' - end do - - close (10,status='keep') -! - fname=trim(gfiler)//'.rst' - - open (1,file=fname,form='unformatted',status='old', convert='little_endian') - - do j=1,ny - read (1)(catid(i,j),i=1,nx) - end do - - close(1,status='keep') - ! write(*,*)'Finished reading CAT_IDs' - - ! Top layer soil classification 0-30cm - ! - open (unit=11, file=ifile, form='unformatted', status='old', & - convert = 'big_endian') - - ! - allocate(gtext(1:col,1:row)) - allocate(SIB_LAY(1:nx,1:ny)) - gtext(:,:)=0 - SIB_LAY(:,:)=0 - k=0 - do j=row,1,-1 -! do i=1,irrecs -! k=k+1 -! c1 = (4*i)-3 -! c2 = (4*i) -! read (unit=11, rec=k) (gtext(ii,j), ii=c1,c2) - read (unit=11) (gtext(i,j), i=1,col) -! end do - end do - - close (11,status='keep') -! - do j=1,rowsib - jsol=CEILING(j/(ny/real(row))) - do i=1,colsib - isol=CEILING(i/(nx/real(col))) - SIB_LAY(i,j)=gtext(isol,jsol) - end do - end do - - deallocate(gtext) - ! - ! Top layer on 2x2.5 - allocate(soil1(ip2,1:13)) - soil1(:,:)=0 - do j=1,rowsib - do i=1,colsib - if((catid(i,j) > ip1).and.(catid(i,j) <= ip2))then - IDVAL=catid(i,j) - STEX=SIB_LAY(i,j) - SOIL1(IDVAL,STEX+1)=SOIL1(IDVAL,STEX+1)+1 - end if - end do - end do - ! - ! write(*,*)'Finished reading top layer' - deallocate(sib_lay) - ! - ! Bottom layer soil classification 30-100cm - ! -! open (unit=11, file=ifile2, form='unformatted', status='old',access='direct',recl=1, & -! convert = 'big_endian') - open (unit=11, file=ifile2, form='unformatted', status='old', & - convert = 'big_endian') - - ! - allocate(gtext(1:col,1:row)) - allocate(SIB_LAY(1:colsib,1:rowsib)) - gtext(:,:)=0 - SIB_LAY(:,:)=0 - k=0 - do j=row,1,-1 -! do i=1,irrecs -! k=k+1 -! c1 = (4*i)-3 -! c2 = (4*i) -! read (unit=11, rec=k) (gtext(ii,j), ii=c1,c2) - read (unit=11) (gtext(i,j), i=1,col) -! end do - end do - ! - close (11,status='keep') - - do j=1,rowsib - jsol=CEILING(j/(ny/real(row))) - do i=1,colsib - isol=CEILING(i/(nx/real(col))) - SIB_LAY(i,j)=gtext(isol,jsol) - end do - end do - deallocate(gtext) - ! write(*,*)'Finished reading bottom layer' - ! - ! Bottom layer on 2x2.5 - allocate(soil2(ip2,1:13)) - soil2(:,:)=0 - do j=1,rowsib - do i=1,colsib - if((catid(i,j) > ip1).and.(catid(i,j) <= ip2))then - IDVAL=catid(i,j) - - STEX=SIB_LAY(i,j) - SOIL2(IDVAL,STEX+1)=SOIL2(IDVAL,STEX+1)+1 - endif - end do - end do - deallocate(sib_lay) - ! -! write(*,*)'Finished counting pixels for each catchment' - k=0 - allocate(top(ip2,2)) - allocate(com(ip2,2)) - top=0 - com=0 - do j=1,ip2 - tem1(1:13)=SOIL1(j,1:13) - tem2(1:13)=SOIL2(j,1:13) - - tem3(:)=3*tem1(:)+7*tem2(:) - if((sum(tem3).gt.0).and.(sum(tem1).eq.0))then - tem1(:)=tem3(:) - write(*,*)'Filled from the bottom layer',j - end if - if(sum(tem1).gt.0)then -! k=k+1 -! ! -! clr1=maxloc(tem1) -! clr2=maxloc(tem3) -! top(k,1)=j -! top(k,2)=clr1(1)-1 -! com(k,1)=j -! com(k,2)=clr2(1)-1 - k=k+1 - ! - clr1=maxloc(tem1) - clr2=maxloc(tem3) - top(j,1)=j - top(j,2)=clr1(1)-1 - com(j,1)=j - com(j,2)=clr2(1)-1 + + close (11,status='keep') + ! + do j=1,rowsib + jsol=CEILING(j/(ny/real(row))) + do i=1,colsib + isol=CEILING(i/(nx/real(col))) + SIB_LAY(i,j)=gtext(isol,jsol) + end do + end do + + deallocate(gtext) + ! + ! Top layer on 2x2.5 + allocate(soil1(n_land,1:13)) + soil1(:,:)=0 + do j=1,rowsib + do i=1,colsib + if((catid(i,j) > ip1).and.(catid(i,j) <= ip2))then + IDVAL=catid(i,j) + STEX=SIB_LAY(i,j) + SOIL1(IDVAL,STEX+1)=SOIL1(IDVAL,STEX+1)+1 end if end do + end do + ! + ! write(*,*)'Finished reading top layer' + deallocate(sib_lay) + ! + ! Bottom layer soil classification 30-100cm + ! + ! open (unit=11, file=ifile2, form='unformatted', status='old',access='direct',recl=1, & + ! convert = 'big_endian') + open (unit=11, file=ifile2, form='unformatted', status='old', & + convert = 'big_endian') + + ! + allocate(gtext(1:col,1:row)) + allocate(SIB_LAY(1:colsib,1:rowsib)) + gtext(:,:)=0 + SIB_LAY(:,:)=0 + k=0 + do j=row,1,-1 + ! do i=1,irrecs + ! k=k+1 + ! c1 = (4*i)-3 + ! c2 = (4*i) + ! read (unit=11, rec=k) (gtext(ii,j), ii=c1,c2) + read (unit=11) (gtext(i,j), i=1,col) + ! end do + end do + ! + close (11,status='keep') + + do j=1,rowsib + jsol=CEILING(j/(ny/real(row))) + do i=1,colsib + isol=CEILING(i/(nx/real(col))) + SIB_LAY(i,j)=gtext(isol,jsol) + end do + end do + deallocate(gtext) + ! write(*,*)'Finished reading bottom layer' + ! + ! Bottom layer on 2x2.5 + allocate(soil2(n_land,1:13)) + soil2(:,:)=0 + do j=1,rowsib + do i=1,colsib + if((catid(i,j) > ip1).and.(catid(i,j) <= ip2))then + IDVAL=catid(i,j) + + STEX=SIB_LAY(i,j) + SOIL2(IDVAL,STEX+1)=SOIL2(IDVAL,STEX+1)+1 + endif + end do + end do + deallocate(sib_lay) + ! + ! write(*,*)'Finished counting pixels for each catchment' + k=0 + allocate(top(n_land,2)) + allocate(com(n_land,2)) + top=0 + com=0 + do j=1,n_land + tem1(1:13)=SOIL1(j,1:13) + tem2(1:13)=SOIL2(j,1:13) + + tem3(:)=3*tem1(:)+7*tem2(:) + if((sum(tem3).gt.0).and.(sum(tem1).eq.0))then + tem1(:)=tem3(:) + write(*,*)'Filled from the bottom layer',j + end if + if(sum(tem1).gt.0)then + ! k=k+1 + ! ! + ! clr1=maxloc(tem1) + ! clr2=maxloc(tem3) + ! top(k,1)=j + ! top(k,2)=clr1(1)-1 + ! com(k,1)=j + ! com(k,2)=clr2(1)-1 + k=k+1 + ! + clr1=maxloc(tem1) + clr2=maxloc(tem3) + top(j,1)=j + top(j,2)=clr1(1)-1 + com(j,1)=j + com(j,2)=clr2(1)-1 + end if + end do + ! + open (unit=11, file=ofile1, form='formatted', status='unknown') + open (unit=12, file=ofile2, form='formatted', status='unknown') + + ! + if(top(1,2).eq.0)top(1,2)= 3 + if(com(1,2).eq.0)com(1,2)= 9 + + do j=1,n_land + + if(top(j,2).eq.0)top(j,2)=top(j-1,2) + if(com(j,2).eq.0)com(j,2)=com(j-1,2) + + ! if(com(j,1).gt.0)then + ! if(j.gt.1)then + ! if(top(j,2).eq.0)top(j,2)=top(j-1,2) + ! if(com(j,2).eq.0)com(j,2)=com(j-1,2) + ! end if ! - open (unit=11, file=ofile1, form='formatted', status='unknown') - open (unit=12, file=ofile2, form='formatted', status='unknown') - - ! - if(top(1,2).eq.0)top(1,2)= 3 - if(com(1,2).eq.0)com(1,2)= 9 - - do j=1,ip2 - - if(top(j,2).eq.0)top(j,2)=top(j-1,2) - if(com(j,2).eq.0)com(j,2)=com(j-1,2) - - ! if(com(j,1).gt.0)then - ! if(j.gt.1)then - ! if(top(j,2).eq.0)top(j,2)=top(j-1,2) - ! if(com(j,2).eq.0)com(j,2)=com(j-1,2) - ! end if - ! - write(11,*)j,id(j),top(j,2) - write(12,*)j,id(j),com(j,2) - - end do - close(11) - close(12) - deallocate (CATID,soil1,soil2,top,com,id) - + write(11,*)j,id(j),top(j,2) + write(12,*)j,id(j),com(j,2) + + end do + close(11) + close(12) + deallocate (soil1,soil2,top,com,id) + END SUBROUTINE create_soil_types_files - -!---------------------------------------------------------------------- - - SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) - - implicit none + + !---------------------------------------------------------------------- + + SUBROUTINE compute_mosaic_veg_types( nx, ny, regrid, n_land, tile_pfs, Rst_id) + + integer, intent(in) :: nx, ny + + logical, intent(in) :: regrid + + integer, intent(in) :: n_land + integer, intent(in) :: tile_pfs(:) + integer, intent(in) :: Rst_id(:,:) + + ! ----------------------------- + integer*1, allocatable , dimension (:,:) :: sib_veg2 integer, allocatable , target , dimension (:,:) :: sib_veg integer, allocatable :: mos_veg(:,:) @@ -2553,55 +1535,31 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) REAL, allocatable :: veg(:,:),bare_frac(:),zdep2_g(:,:) REAL :: fmax0,dummy,tem(6),mfrac,sfrac,bfrac - integer :: n,ip,maxcat,count,k1,i1,i + integer :: n,ip,count,k1,i1,i INTEGER, allocatable, dimension (:) :: id ! indx,id,indx_old integer :: nc_gcm,nr_gcm,nc_ocean,nr_ocean REAL :: lat,lon,fr_gcm,fr_cat,tarea - INTEGER :: typ,pfs,ig,jg,i_dum,j_dum,ierr,indx_dum,indr1,indr2,indr3 ,ip2 - character*100 :: fname,fout - character (*) :: gfiler,gfilet - character*10 :: dline - CHARACTER*20 :: version,resoln,continent + INTEGER :: ig,jg,i_dum,j_dum,ierr,indx_dum,indr1,indr2,indr3,ip2 + character*512 :: fname,fout + CHARACTER*512 :: version,resoln,continent character*2 :: chyear integer :: mon,smon,imon,year - integer :: nx,ny,status - logical :: regrid,ease_grid + integer :: status integer, pointer :: Raster(:,:) real, pointer, dimension (:) :: z2, z0 real, dimension (6) :: VGZ2 = (/35.0, 20.0, 17.0, 0.6, 0.5, 0.6/) ! Dorman and Sellers (1989) logical :: file_exists integer :: ncid - fname=trim(gfilet)//'.til' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)ip - allocate(id(1:ip)) - - read (10,*)j_dum - - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - end do - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ,pfs,lon,lat,ig,jg,fr_gcm - else - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,i_dum,fr_cat,j_dum - endif - id(n)=pfs - if (typ == 100) ip2 = n - if(ierr /= 0)write (*,*)'Problem reading' - end do - close (10,status='keep') - maxcat=ip2 + ip = size(tile_pfs,1) + + ip2 = ip1 + n_land + + allocate(id(1:ip), source = tile_pfs) allocate(sib_veg2(1:i_raster,1:j_raster)) allocate(sib_veg (1:i_raster,1:j_raster)) - + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) open (10,file=trim(MAKE_BCS_INPUT_DIR)//'/land/veg/pft/v1/sib22.5_v2.0.dat',form='unformatted', & status='old',action='read',convert='big_endian') @@ -2614,17 +1572,13 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) else raster => sib_veg end if - + if(regrid) then call RegridRaster(sib_veg,raster) - endif - - fname=trim(gfiler)//'.rst' - - open (10,file=fname,status='old',action='read',form='unformatted',convert='little_endian') + endif - allocate(veg(1:maxcat,1:6)) - allocate(zdep2_g(1:maxcat,1:1)) + allocate(veg(1:n_land,1:6)) + allocate(zdep2_g(1:n_land,1:1)) veg=0. zdep2_g=0. @@ -2633,14 +1587,14 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) do j=1,ny - read (10)(catid(i),i=1,nx) + catid(:) = Rst_id(:,j) do i=1,nx if((catid(i) > ip1).and.(catid(i) <= ip2))then zdep2_g(catid(i)-ip1,1)=zdep2_g(catid(i)-ip1,1)+1. if(raster(i,j).eq.0) then -! write (*,*)'Warning : SiB2 =0, an ocean pixel found !' + ! write (*,*)'Warning : SiB2 =0, an ocean pixel found !' elseif (raster(i,j).eq.1) then veg(catid(i)-ip1,1)=veg(catid(i)-ip1,1) + 1. elseif (raster(i,j).eq.2) then @@ -2657,12 +1611,12 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) elseif (raster(i,j).eq.7) then veg(catid(i)-ip1,5)=veg(catid(i)-ip1,5) + 1. elseif (raster(i,j).eq.8) then -! if (j >= NINT(float(ny)*(140./180.))) then -! veg(catid(i)-ip1,6)=veg(catid(i)-ip1,6) + 1. -! else -! veg(catid(i)-ip1,5)=veg(catid(i)-ip1,5) + 1. -! endif - if ((j > NINT(float(ny)*(40./180.))).and.(j < NINT(float(ny)*(140./180.)))) then + ! if (j >= NINT(float(ny)*(140./180.))) then + ! veg(catid(i)-ip1,6)=veg(catid(i)-ip1,6) + 1. + ! else + ! veg(catid(i)-ip1,5)=veg(catid(i)-ip1,5) + 1. + ! endif + if ((j > NINT(float(ny)*(40./180.))).and.(j < NINT(float(ny)*(140./180.)))) then veg(catid(i)-ip1,5)=veg(catid(i)-ip1,5) + 1. else veg(catid(i)-ip1,6)=veg(catid(i)-ip1,6) + 1. @@ -2670,29 +1624,27 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) elseif (raster(i,j).eq.9) then veg(catid(i)-ip1,4)=veg(catid(i)-ip1,4) + 1. elseif (raster(i,j).eq.10) then -! write (*,*)'Warning : SiB2 =10, a water pixel found !' + ! write (*,*)'Warning : SiB2 =10, a water pixel found !' elseif (raster(i,j).eq.11) then -! write (*,*)'Warning : SiB2 =11, an ice pixel found !' + ! write (*,*)'Warning : SiB2 =11, an ice pixel found !' elseif (raster(i,j).eq.100) then -! write (*,*)'Warning : SiB2 =100, NODATA pixel found !' + ! write (*,*)'Warning : SiB2 =100, NODATA pixel found !' endif endif enddo enddo - close(10,status='keep') - - allocate(mos_veg(1:maxcat,1:2)) - allocate(veg_frac(1:maxcat,1:3)) + allocate(mos_veg(1:n_land,1:2)) + allocate(veg_frac(1:n_land,1:3)) mos_veg=0 veg_frac=0. k=0 - do j=1,maxcat + do j=1,n_land tem(1:6)=veg(j,1:6) - + if(sum(tem).le.0.)write(*,*) 'Warning no veg types',j -! if(sum(tem).le.0.) stop + ! if(sum(tem).le.0.) stop if(sum(tem).gt.0)then k=k+1 @@ -2749,78 +1701,81 @@ SUBROUTINE compute_mosaic_veg_types (nx,ny,ease_grid,regrid,gfilet,gfiler) veg_frac(k,2)=0. write(*,*)k,tem write(*,*)mos_veg(j,1),mos_veg(j,2),veg_frac(j,1),veg_frac(j,2),veg_frac(j,3) - endif + endif end do deallocate(veg) - - ! Canopy height and ASCAT roughness length - - call ascat_r0 (nx,ny,gfiler, z0) - + + ! Canopy height and ASCAT roughness length + + call ascat_r0 (nx,ny, n_land, Rst_id, z0) + if(jpl_height) then - call jpl_canoph (nx,ny,gfiler, z2) + call jpl_canoph (nx,ny, n_land, Rst_id, z2) else - allocate (z2(1:maxcat)) - endif + allocate (z2(1:n_land)) + endif open (10,file='clsm/mosaic_veg_typs_fracs', & form='formatted',status='unknown') - do j=1,maxcat + do j=1,n_land if (mos_veg(j,1) == 0) then - if(.not.jpl_height) z2(j) = VGZ2(mos_veg(j,1)) - mos_veg(j,1) = mos_veg(j-1,1) - mos_veg(j,2) = mos_veg(j-1,2) - write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & - j+ip1,id(j+ip1),mos_veg(j-1,1),mos_veg(j-1,2),veg_frac(j,1),veg_frac(j,2),z2(j), z0 (j) + if(.not.jpl_height) z2(j) = VGZ2(mos_veg(j,1)) + mos_veg(j,1) = mos_veg(j-1,1) + mos_veg(j,2) = mos_veg(j-1,2) + write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & + j+ip1,id(j+ip1),mos_veg(j-1,1),mos_veg(j-1,2),veg_frac(j,1),veg_frac(j,2),z2(j), z0 (j) else - if(.not.jpl_height) z2(j) = VGZ2(mos_veg(j,1)) - write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & - j+ip1,id(j+ip1),mos_veg(j,1),mos_veg(j,2),veg_frac(j,1),veg_frac(j,2),z2(j), z0 (j) + if(.not.jpl_height) z2(j) = VGZ2(mos_veg(j,1)) + write (10,'(i10,i8,2(2x,i3),2(2x,f6.2),2x,f6.3,2x,f10.7)') & + j+ip1,id(j+ip1),mos_veg(j,1),mos_veg(j,2),veg_frac(j,1),veg_frac(j,2),z2(j), z0 (j) endif end do close(10,status='keep') - + inquire(file='clsm/catch_params.nc4', exist=file_exists) - + if(file_exists) then status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'OLD_ITY'),(/1/),(/maxcat/),real(mos_veg(:,1))) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'OLD_ITY'),(/1/),(/n_land/),real(mos_veg(:,1))) ; VERIFY_(STATUS) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) endif - + inquire(file='clsm/vegdyn.data', exist=file_exists) - + if(file_exists) then status = NF_OPEN ('clsm/vegdyn.data', NF_WRITE, ncid ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ),(/1/),(/maxcat/),real(mos_veg(:,1))) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'Z2CH' ),(/1/),(/maxcat/),z2 ) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ASCATZ0'),(/1/),(/maxcat/),Z0 ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ITY' ),(/1/),(/n_land/),real(mos_veg(:,1))) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'Z2CH' ),(/1/),(/n_land/),z2 ) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ASCATZ0'),(/1/),(/n_land/),Z0 ) ; VERIFY_(STATUS) STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) else open (20,file='clsm/vegdyn.data',status='unknown',action='write',form='unformatted', & convert='little_endian') - + write (20) real(mos_veg(:,1)) write (20) z2 (:) write (20) z0 (:) close (20) endif - + deallocate (sib_veg2,sib_veg,mos_veg,veg_frac,zdep2_g,id, z0, z2) if(regrid) then deallocate(raster) - endif - + endif + END SUBROUTINE compute_mosaic_veg_types -!---------------------------------------------------------------------- + !---------------------------------------------------------------------- + + SUBROUTINE cti_stat_file ( MaskFile, n_land, tile_pfs, til_j_dum) + character(*), intent(in) :: MaskFile + integer, intent(in) :: n_land, tile_pfs(:), til_j_dum(:) - SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) + ! ---------------------------------------------- - IMPLICIT NONE INTEGER, PARAMETER :: nbcat=36716,nofvar=6 - INTEGER :: n,i,ip, itext(SRTM_maxcat,2),ix, jx,ip2, maxcat - INTEGER :: typ,pfs,ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 + INTEGER :: n,i,ip, itext(SRTM_maxcat,2),ix, jx,ip2 + INTEGER :: pfs, ig,jg,j_dum,ierr,indx_dum,indr1,indr2,indr3 INTEGER*8 :: idum8 INTEGER :: ncat,i_dum INTEGER, dimension(:), allocatable :: colin2cat @@ -2832,46 +1787,18 @@ SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) REAL :: fr REAL, allocatable, dimension (:,:) :: var REAL, allocatable, dimension (:) :: dummy - logical :: ease_grid - CHARACTER*20 :: version - character*100 :: fname - character(*) :: gfile - character(*) :: MaskFile + CHARACTER*512 :: version + character*512 :: fname - fname=trim(gfile)//'.til' - open (10,file=fname,status='old',action='read',form='formatted') - read (10,*)ip + ip = size(tile_pfs,1) allocate(indx_old(ip)) allocate(id(ip)) - indx_old=0 - id=0 - - read (10,*)j_dum - do n = 1, j_dum - read (10,'(a)')version - read (10,*)nc_gcm - read (10,*)nr_gcm - end do - - do n = 1,ip - if (ease_grid) then - read(10,*,IOSTAT=ierr) typ,pfs !,lon,lat,ig,jg,fr_gcm,i_dum - else - read(10,'(I10,3E20.12,9(2I10,E20.12,I10))',IOSTAT=ierr) & - typ,tarea,lon,lat,ig,jg,fr_gcm,indx_dum,pfs,i_dum,fr_cat,j_dum - endif - - id(n)=pfs - indx_old(n) = j_dum - if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) indx_old(n) = pfs - if (typ == 100) ip2 = n - if (ierr /= 0) write (*,*)'Problem reading',fname - if (ierr /= 0) stop - end do - - close (10,status='keep') - + ip2 = ip1 + n_land + id = tile_pfs + indx_old = til_j_dum + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) indx_old = tile_pfs + allocate(colin2cat(1:6000000)) colin2cat=0 call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) @@ -2885,11 +1812,11 @@ SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) read (10,*) ncat do n=1,ncat - if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then - read (10,*)indx_dum,idum8 - else - read (10,*)j_dum,indx_dum - endif + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + read (10,*)indx_dum,idum8 + else + read (10,*)j_dum,indx_dum + endif colin2cat(indx_dum)=n end do close (10,status='keep') @@ -2904,7 +1831,7 @@ SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) fname='clsm/cti_stats.dat' open (20,file=fname,form='formatted', status='unknown') - write (20,*)ip2 + write (20,*) n_land read (10,*)ncat allocate(var(1:ncat,1:nofvar)) @@ -2931,475 +1858,604 @@ SUBROUTINE cti_stat_file (ease_grid,gfile, MaskFile) end do close (10,status='keep') -! - do i=1,ip - - if((i > ip1).and.(i <= ip2))then - if(((id(i).ge.5000142).and.(id(i).le.5025829)))then - write(20,'(i10,i8,5(1x,f8.4),i5,e18.3)')i,id(i),var(indx_old(i),1)*11.1/9.1,var(indx_old(i),2), & - var(indx_old(i),3),var(indx_old(i),4),var(indx_old(i),5),itext(indx_old(i),2), & - var(indx_old(i),6) - else + ! + do i=ip1+1,ip2 + if(((id(i).ge.5000142).and.(id(i).le.5025829)))then + write(20,'(i10,i8,5(1x,f8.4),i5,e18.3)')i,id(i),var(indx_old(i),1)*11.1/9.1,var(indx_old(i),2), & + var(indx_old(i),3),var(indx_old(i),4),var(indx_old(i),5),itext(indx_old(i),2), & + var(indx_old(i),6) + else - write(20,'(i10,i8,5(1x,f8.4),i5,e18.3)')i,id(i),var(indx_old(i),1),var(indx_old(i),2), & - var(indx_old(i),3),var(indx_old(i),4),var(indx_old(i),5),itext(indx_old(i),2), & - var(indx_old(i),6) - endif + write(20,'(i10,i8,5(1x,f8.4),i5,e18.3)')i,id(i),var(indx_old(i),1),var(indx_old(i),2), & + var(indx_old(i),3),var(indx_old(i),4),var(indx_old(i),5),itext(indx_old(i),2), & + var(indx_old(i),6) endif - end do close (20,status='keep') deallocate (colin2cat,var,id,indx_old) END SUBROUTINE cti_stat_file - -!--------------------------------------------------------------------- - - SUBROUTINE create_model_para (MaskFile) - - implicit none - integer i,n,k, tindex1,pfaf1,nbcatch - integer soil_gswp - real meanlu,stdev,minlu,maxlu,coesk,rzdep - real minlat,maxlat,minlon,maxlon - real,allocatable, dimension (:) :: & - BEE, PSIS,POROS,COND,WPWET,soildepth, tile_lon, tile_lat - REAL, allocatable, dimension(:) :: TOPMEAN, TOPVAR, TOPSKEW - REAL ST(NAR), AC(NAR),COESKEW - REAL, allocatable, dimension (:) :: & - ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & - ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & - tsa1, tsa2,tsb1, tsb2, & - taberr1,taberr2,normerr1,normerr2, & - taberr3,taberr4,normerr3,normerr4 - integer, dimension(12) :: tile_pick - integer, allocatable, dimension (:) :: soil_class_top,soil_class_com,tindex2,pfaf2 - real watdep(nwt,nrz),wan(nwt,nrz),rzexcn(nwt,nrz),frc(nwt,nrz) - real, allocatable, dimension (:,:,:,:) :: & - gwatdep,gwan,grzexcn,gfrc - real :: wtdep,wanom,rzaact,fracl,profdep,dist_save,tile_distance - character*200 :: pathout,fname,fout,losfile - character*10 :: dline - CHARACTER*20 :: version,resoln,continent - character*6 rdep,ext - integer :: iwt,irz,group - character(*) :: MaskFile - logical :: picked - - integer :: ncid, status - logical :: file_exists - real, allocatable, dimension (:,:) :: parms4file + + !--------------------------------------------------------------------- -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1, li, ui -! -integer, dimension(:), allocatable :: low_ind, upp_ind -! -! ------------------------------------------------------------------ + SUBROUTINE create_model_para (MaskFile, nbcatch, tile_lon, tile_lat, tile_pfs) - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - ! - ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION - ! - !$ running_omp = .true. ! conditional compilation - ! - ! ECHO BASIC OMP VARIABLES - ! - !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) - ! - !$OMP SINGLE - ! - !$ n_threads = omp_get_num_threads() - ! - !$ write (*,*) 'running_omp = ', running_omp - !$ write (*,*) - !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' - !$ write (*,*) - !$OMP ENDSINGLE - ! - !$OMP CRITICAL - !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' - !$OMP ENDCRITICAL - ! - !$OMP BARRIER - ! - !$OMP ENDPARALLEL - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - -!c------------------------------------------------------------------------- - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - losfile =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/soil_water_loss/v1/loss_perday' -!c opening files - - - allocate (gwatdep(1:nwt,1:nrz,1:12,1:2)) - allocate (gwan (1:nwt,1:nrz,1:12,1:2)) - allocate (grzexcn(1:nwt,1:nrz,1:12,1:2)) - allocate (gfrc (1:nwt,1:nrz,1:12,1:2)) - - do n =1,12 - if(n.lt.10)write(ext,'(i1.1)')n - if(n.ge.10)write(ext,'(i2.2)')n - do i =1,2 - if (i==1) rdep='.rz75.' - if (i==2) rdep='.rz1.' - open (120,file=trim(losfile)//trim(rdep)//trim(ext), & - form='formatted',status='old') - - do iwt=1,nwt - do irz=1,nrz - read(120,2000) wtdep,wanom,rzaact,fracl - 2000 format(1x,4e16.8) - gwatdep(iwt,irz,n,i)=wtdep - gwan(iwt,irz,n,i)=wanom - grzexcn(iwt,irz,n,i)=rzaact - gfrc(iwt,irz,n,i)=amin1(fracl,1.) - enddo + character(*), intent(in) :: MaskFile + integer, intent(in) :: nbcatch + real, intent(in) :: tile_lon(:), tile_lat(:) + integer, intent(in) :: tile_pfs(:) + + ! -------------------------------------------- + + integer i,n,k, tindex1,pfaf1 + integer soil_gswp + real meanlu,stdev,minlu,maxlu,coesk,rzdep + real minlat,maxlat,minlon,maxlon + real,allocatable, dimension (:) :: & + BEE, PSIS,POROS,COND,WPWET,soildepth + REAL, allocatable, dimension(:) :: TOPMEAN, TOPVAR, TOPSKEW + REAL ST(NAR), AC(NAR),COESKEW + REAL, allocatable, dimension (:) :: & + ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & + ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & + tsa1, tsa2,tsb1, tsb2, & + taberr1,taberr2,normerr1,normerr2, & + taberr3,taberr4,normerr3,normerr4 + integer, dimension(12) :: tile_pick + integer, allocatable, dimension (:) :: soil_class_top,soil_class_com,tindex2,pfaf2 + real watdep(nwt,nrz),wan(nwt,nrz),rzexcn(nwt,nrz),frc(nwt,nrz) + real, allocatable, dimension (:,:,:,:) :: & + gwatdep,gwan,grzexcn,gfrc + real :: wtdep,wanom,rzaact,fracl,profdep,dist_save,tile_distance + character*512 :: pathout,fname,fout,losfile + CHARACTER*512 :: version,resoln,continent + character*6 :: rdep,ext + integer :: iwt,irz,group + logical :: picked + + integer :: ncid, status + logical :: file_exists + real, allocatable, dimension (:,:) :: parms4file + + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ + ! + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1, li, ui + ! + integer, dimension(:), allocatable :: low_ind, upp_ind + ! + ! ------------------------------------------------------------------ + + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + + !c------------------------------------------------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + losfile =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/soil_water_loss/v1/loss_perday' + !c opening files + + + allocate (gwatdep(1:nwt,1:nrz,1:12,1:2)) + allocate (gwan (1:nwt,1:nrz,1:12,1:2)) + allocate (grzexcn(1:nwt,1:nrz,1:12,1:2)) + allocate (gfrc (1:nwt,1:nrz,1:12,1:2)) + + do n =1,12 + if(n.lt.10)write(ext,'(i1.1)')n + if(n.ge.10)write(ext,'(i2.2)')n + do i =1,2 + if (i==1) rdep='.rz75.' + if (i==2) rdep='.rz1.' + open (120,file=trim(losfile)//trim(rdep)//trim(ext), & + form='formatted',status='old') + + do iwt=1,nwt + do irz=1,nrz + read(120,2000) wtdep,wanom,rzaact,fracl +2000 format(1x,4e16.8) + gwatdep(iwt,irz,n,i)=wtdep + gwan(iwt,irz,n,i)=wanom + grzexcn(iwt,irz,n,i)=rzaact + gfrc(iwt,irz,n,i)=amin1(fracl,1.) + enddo enddo close (120,status='keep') - end do - end do - fname='clsm/soil_param.first' - open (10,file=fname,action='read', & - form='formatted',status='old') - - fname='clsm/cti_stats.dat' - open (11,file=fname,action='read', & - form='formatted',status='old') - - fname='clsm/catchment.def' - open (12,file=fname,action='read', & - form='formatted',status='old') - - fout='clsm/ar.new' - open (20,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm//bf.dat' - open (30,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm//ts.dat' - open (40,file=fout,action='write', & - form='formatted',status='unknown') - - if (error_file) then - fout='clsm/ar_rmse.dat' - open (21,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm/bf_rmse.dat' - open (31,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm/bad_sat_param.tiles' - open (41,file=fout,action='write', & - form='formatted',status='unknown') - endif - fout='clsm/soil_param.dat' - open (42,file=fout,action='write', & - form='formatted',status='unknown') - read (11,*)nbcatch - read (12,*)nbcatch - - allocate (tile_lon(1:nbcatch)) - allocate (tile_lat(1:nbcatch)) - allocate (TOPMEAN (1:nbcatch)) - allocate (TOPVAR (1:nbcatch)) - allocate (TOPSKEW (1:nbcatch)) - allocate (ARS1 (1:nbcatch)) - allocate (ARS2 (1:nbcatch)) - allocate (ARS3 (1:nbcatch)) - allocate (ARA1 (1:nbcatch)) - allocate (ARA2 (1:nbcatch)) - allocate (ARA3 (1:nbcatch)) - allocate (ARA4 (1:nbcatch)) - allocate (ARW1 (1:nbcatch)) - allocate (ARW2 (1:nbcatch)) - allocate (ARW3 (1:nbcatch)) - allocate (ARW4 (1:nbcatch)) - allocate (BF1 (1:nbcatch)) - allocate (BF2 (1:nbcatch)) - allocate (BF3 (1:nbcatch)) - allocate (TSA1 (1:nbcatch)) - allocate (TSA2 (1:nbcatch)) - allocate (TSB1 (1:nbcatch)) - allocate (TSB2 (1:nbcatch)) - allocate (TABERR1 (1:nbcatch)) - allocate (TABERR2 (1:nbcatch)) - allocate (TABERR3 (1:nbcatch)) - allocate (TABERR4 (1:nbcatch)) - allocate (NORMERR1 (1:nbcatch)) - allocate (NORMERR2 (1:nbcatch)) - allocate (NORMERR3 (1:nbcatch)) - allocate (NORMERR4 (1:nbcatch)) - allocate (BEE (1:nbcatch)) - allocate (PSIS (1:nbcatch)) - allocate (POROS (1:nbcatch)) - allocate (COND (1:nbcatch)) - allocate (WPWET (1:nbcatch)) - allocate (soildepth (1:nbcatch)) - allocate (soil_class_top (1:nbcatch)) - allocate (soil_class_com (1:nbcatch)) - allocate (tindex2 (1:nbcatch)) - allocate (pfaf2 (1:nbcatch)) - - do n=1,nbcatch - - read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev,minlu,maxlu,coesk - read(10,*) tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n),PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) - - if(tindex1.ne.tindex2(n))then - write(*,*)'Warnning 1: tindex mismatched' - stop - endif - - read (12,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - - if(pfaf1.ne.pfaf2(n)) then - write(*,*)'Warnning 1: pfafstetter mismatched' - stop - endif - - if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then - TOPMEAN(n) = meanlu - else - TOPMEAN(n) = 0.961*meanlu-1.957 - endif - - TOPVAR(n) = stdev*stdev - TOPSKEW(n) = coesk*stdev*stdev*stdev - - if (TOPVAR(n) .eq. 0. .or. coesk .eq. 0. .or. topskew(n) .eq. 0.) then - write(*,*) 'Problem: undefined values:' - write(*,*) TOPMEAN(n),TOPVAR(n),coesk,minlu,maxlu - stop - endif - END DO - - inquire(file='clsm/catch_params.nc4', exist=file_exists) - - if(file_exists) then - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (parms4file (1:nbcatch, 1:25)) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ),(/1/),(/nbcatch/),BEE (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'COND' ),(/1/),(/nbcatch/),COND (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'POROS'),(/1/),(/nbcatch/),POROS(:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ),(/1/),(/nbcatch/),PSIS (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'WPWET'),(/1/),(/nbcatch/),WPWET(:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR'),(/1/),(/nbcatch/),soildepth (:)) ; VERIFY_(STATUS) - parms4file (:,12) = BEE (:) - parms4file (:,16) = COND (:) - parms4file (:,18) = POROS (:) - parms4file (:,19) = PSIS (:) - parms4file (:,24) = WPWET (:) - parms4file (:,25) = soildepth(:) - endif - - rewind(10) - - allocate(low_ind(n_threads)) - allocate(upp_ind(n_threads)) - low_ind(1) = 1 - upp_ind(n_threads) = nbcatch - - if (running_omp) then - do i=1,n_threads-1 - - upp_ind(i) = low_ind(i) + (nbcatch/n_threads) - 1 - low_ind(i+1) = upp_ind(i) + 1 - - end do - end if - - -!$OMP PARALLELDO DEFAULT(NONE) & -!$OMP SHARED( BEE, PSIS,POROS,COND,WPWET,soildepth, & -!$OMP TOPMEAN, TOPVAR, TOPSKEW, & -!$OMP ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & -!$OMP ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & -!$OMP tsa1, tsa2,tsb1, tsb2, & -!$OMP taberr1,taberr2,normerr1,normerr2, & -!$OMP taberr3,taberr4,normerr3,normerr4, & -!$OMP gwatdep,gwan,grzexcn,gfrc,soil_class_com, & -!$OMP n_threads, low_ind, upp_ind ) & -!$OMP PRIVATE(k,li,ui,n,i,watdep,wan,rzexcn,frc,ST,AC, & -!$OMP COESKEW,profdep) - - do k=1,n_threads - - li = low_ind(k) - ui = upp_ind(k) - - do n=li,ui -! if ((n == 877).or.(n == 880).or.(n == 881)) then -! print *,n -! endif -! print *,n -! pause -! c Gamma distribution - CALL TGEN ( & - TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & - ST,AC,COESKEW) - -!c write(*,*) 'tgen4 ok' - -!c Areal fractioning parameters -! print *,'tileid:' ,n - CALL SAT_PARAM( & - BEE(n),PSIS(n),POROS(n),COND(n), & - WPWET(n), ST, AC, COESKEW,n, & - soildepth(n), & - ars1(n),ars2(n),ars3(n), & - ara1(n),ara2(n),ara3(n),ara4(n), & - arw1(n),arw2(n),arw3(n),arw4(n), & - taberr1(n),taberr2(n),taberr3(n),taberr4(n), & - normerr1(n),normerr2(n),normerr3(n),normerr4(n)) - - - CALL BASE_PARAM( & - BEE(n),PSIS(n),POROS(n),COND(n), & - ST, AC, & - bf1(n),bf2(n),bf3(n), & - taberr1(n),taberr2(n),normerr1(n),normerr2(n) & - ) - - profdep=soildepth(n)/1000. - profdep=amax1(1.,profdep) - if (grzdep .gt. .75*profdep) then - i=1 - else - i=2 - end if + end do + end do + fname='clsm/soil_param.first' + open (10,file=fname,action='read', & + form='formatted',status='old') + + fname='clsm/cti_stats.dat' + open (11,file=fname,action='read', & + form='formatted',status='old') + + fout='clsm/ar.new' + open (20,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm//bf.dat' + open (30,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm//ts.dat' + open (40,file=fout,action='write', & + form='formatted',status='unknown') + + if (error_file) then + fout='clsm/ar_rmse.dat' + open (21,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm/bf_rmse.dat' + open (31,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm/bad_sat_param.tiles' + open (41,file=fout,action='write', & + form='formatted',status='unknown') + endif + fout='clsm/soil_param.dat' + open (42,file=fout,action='write', & + form='formatted',status='unknown') + read (11,*) n ! read off nbcatch + + allocate (TOPMEAN (1:nbcatch)) + allocate (TOPVAR (1:nbcatch)) + allocate (TOPSKEW (1:nbcatch)) + allocate (ARS1 (1:nbcatch)) + allocate (ARS2 (1:nbcatch)) + allocate (ARS3 (1:nbcatch)) + allocate (ARA1 (1:nbcatch)) + allocate (ARA2 (1:nbcatch)) + allocate (ARA3 (1:nbcatch)) + allocate (ARA4 (1:nbcatch)) + allocate (ARW1 (1:nbcatch)) + allocate (ARW2 (1:nbcatch)) + allocate (ARW3 (1:nbcatch)) + allocate (ARW4 (1:nbcatch)) + allocate (BF1 (1:nbcatch)) + allocate (BF2 (1:nbcatch)) + allocate (BF3 (1:nbcatch)) + allocate (TSA1 (1:nbcatch)) + allocate (TSA2 (1:nbcatch)) + allocate (TSB1 (1:nbcatch)) + allocate (TSB2 (1:nbcatch)) + allocate (TABERR1 (1:nbcatch)) + allocate (TABERR2 (1:nbcatch)) + allocate (TABERR3 (1:nbcatch)) + allocate (TABERR4 (1:nbcatch)) + allocate (NORMERR1 (1:nbcatch)) + allocate (NORMERR2 (1:nbcatch)) + allocate (NORMERR3 (1:nbcatch)) + allocate (NORMERR4 (1:nbcatch)) + allocate (BEE (1:nbcatch)) + allocate (PSIS (1:nbcatch)) + allocate (POROS (1:nbcatch)) + allocate (COND (1:nbcatch)) + allocate (WPWET (1:nbcatch)) + allocate (soildepth (1:nbcatch)) + allocate (soil_class_top (1:nbcatch)) + allocate (soil_class_com (1:nbcatch)) + allocate (tindex2 (1:nbcatch)) + allocate (pfaf2 (1:nbcatch)) + + do n=1,nbcatch + + read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev,minlu,maxlu,coesk + read(10,*) tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & + BEE(n),PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) + + if(tindex1.ne.tindex2(n))then + write(*,*)'Warnning 1: tindex mismatched' + stop + endif + + if(tile_pfs(n).ne.pfaf2(n)) then + write(*,*)'Warnning 1: pfafstetter mismatched' + stop + endif + + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + TOPMEAN(n) = meanlu + else + TOPMEAN(n) = 0.961*meanlu-1.957 + endif + + TOPVAR(n) = stdev*stdev + TOPSKEW(n) = coesk*stdev*stdev*stdev + + if (TOPVAR(n) .eq. 0. .or. coesk .eq. 0. .or. topskew(n) .eq. 0.) then + write(*,*) 'Problem: undefined values:' + write(*,*) TOPMEAN(n),TOPVAR(n),coesk,minlu,maxlu + stop + endif + END DO + + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:nbcatch, 1:25)) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ),(/1/),(/nbcatch/),BEE (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'COND' ),(/1/),(/nbcatch/),COND (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'POROS'),(/1/),(/nbcatch/),POROS(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ),(/1/),(/nbcatch/),PSIS (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'WPWET'),(/1/),(/nbcatch/),WPWET(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR'),(/1/),(/nbcatch/),soildepth (:)) ; VERIFY_(STATUS) + parms4file (:,12) = BEE (:) + parms4file (:,16) = COND (:) + parms4file (:,18) = POROS (:) + parms4file (:,19) = PSIS (:) + parms4file (:,24) = WPWET (:) + parms4file (:,25) = soildepth(:) + endif + + rewind(10) + + allocate(low_ind(n_threads)) + allocate(upp_ind(n_threads)) + low_ind(1) = 1 + upp_ind(n_threads) = nbcatch + + if (running_omp) then + do i=1,n_threads-1 + + upp_ind(i) = low_ind(i) + (nbcatch/n_threads) - 1 + low_ind(i+1) = upp_ind(i) + 1 + + end do + end if + + + !$OMP PARALLELDO DEFAULT(NONE) & + !$OMP SHARED( BEE, PSIS,POROS,COND,WPWET,soildepth, & + !$OMP TOPMEAN, TOPVAR, TOPSKEW, & + !$OMP ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & + !$OMP ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & + !$OMP tsa1, tsa2,tsb1, tsb2, & + !$OMP taberr1,taberr2,normerr1,normerr2, & + !$OMP taberr3,taberr4,normerr3,normerr4, & + !$OMP gwatdep,gwan,grzexcn,gfrc,soil_class_com, & + !$OMP n_threads, low_ind, upp_ind ) & + !$OMP PRIVATE(k,li,ui,n,i,watdep,wan,rzexcn,frc,ST,AC, & + !$OMP COESKEW,profdep) + + do k=1,n_threads + + li = low_ind(k) + ui = upp_ind(k) + + do n=li,ui + ! if ((n == 877).or.(n == 880).or.(n == 881)) then + ! print *,n + ! endif + ! print *,n + ! pause + ! c Gamma distribution + CALL TGEN ( & + TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & + ST,AC,COESKEW) + + !c write(*,*) 'tgen4 ok' + + !c Areal fractioning parameters + ! print *,'tileid:' ,n + CALL SAT_PARAM( & + BEE(n),PSIS(n),POROS(n),COND(n), & + WPWET(n), ST, AC, COESKEW,n, & + soildepth(n), & + ars1(n),ars2(n),ars3(n), & + ara1(n),ara2(n),ara3(n),ara4(n), & + arw1(n),arw2(n),arw3(n),arw4(n), & + taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + normerr1(n),normerr2(n),normerr3(n),normerr4(n)) + + + CALL BASE_PARAM( & + BEE(n),PSIS(n),POROS(n),COND(n), & + ST, AC, & + bf1(n),bf2(n),bf3(n), & + taberr1(n),taberr2(n),normerr1(n),normerr2(n) & + ) + + profdep=soildepth(n)/1000. + profdep=amax1(1.,profdep) + if (grzdep .gt. .75*profdep) then + i=1 + else + i=2 + end if watdep (:,:) = gwatdep (:,:,soil_class_com(n),i) wan (:,:) = gwan (:,:,soil_class_com(n),i) rzexcn (:,:) = grzexcn (:,:,soil_class_com(n),i) frc (:,:) = gfrc (:,:,soil_class_com(n),i) - CALL TS_PARAM( & - BEE(n),PSIS(n),POROS(n), & - ST, AC, & - watdep,wan,rzexcn,frc, & - tsa1(n),tsa2(n),tsb1(n),tsb2(n) & - ) - - END DO - END DO - !$OMP ENDPARALLELDO - tile_pick = 0 - - DO n=1,nbcatch - if((arw1(n).ne.9999.).and.(ars1(n).ne.9999.))then - if(tile_pick(soil_class_com(n)) == 0) tile_pick(soil_class_com(n)) = n - endif - end do - - DO n=1,nbcatch - !c Third subroutine for the parameters related to the transfers - !c to the water table - ! - ! Writing the parameters, in the same order as in catchment.def - ! if((ars1(n).lt.0.).and.(ars2(n).le.0.3).and.(ars3(n).le.0.04).and.(arw1(n).ne.9999.))then - if((arw1(n).ne.9999.).and.(ars1(n).ne.9999.))then - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(n),ars2(n),ars3(n), & - ara1(n),ara2(n),ara3(n),ara4(n), & - arw1(n),arw2(n),arw3(n),arw4(n) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(n),tsa2(n),tsb1(n),tsb2(n) - - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) - - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(n) - parms4file (n, 2) = ara2(n) - parms4file (n, 3) = ara3(n) - parms4file (n, 4) = ara4(n) - parms4file (n, 5) = ars1(n) - parms4file (n, 6) = ars2(n) - parms4file (n, 7) = ars3(n) - parms4file (n, 8) = arw1(n) - parms4file (n, 9) = arw2(n) - parms4file (n,10) = arw3(n) - parms4file (n,11) = arw4(n) - parms4file (n,13) = bf1(n) - parms4file (n,14) = bf2(n) - parms4file (n,15) = bf3(n) - parms4file (n,17) = gnu - parms4file (n,20) = tsa1(n) - parms4file (n,21) = tsa2(n) - parms4file (n,22) = tsb1(n) - parms4file (n,23) = tsb2(n) - endif - else - - if(preserve_soiltype) then - picked=.false. - ! Group3 - ! category 1 : Sand - ! category 2 : Loamy Sand - ! category 3 : Sandy Loam - ! category 8 : Silty Clay Loam - ! Group2 - ! category 4 : Silt Loam - ! category 5 : Silt - ! category 6 : Loam - ! category 7 : Sandy Clay Loam - ! Group1 - ! category 9 : Clay Loam - ! category 10 : Sandy Clay - ! category 11 : Silty Clay - ! category 12 : Clay - - if ((soil_class_com(n)>=9).and.(soil_class_com(n)<=12)) then - group=1 - else if ((soil_class_com(n)>=4).and.(soil_class_com(n)<=7)) then - group=2 - else - group=3 + CALL TS_PARAM( & + BEE(n),PSIS(n),POROS(n), & + ST, AC, & + watdep,wan,rzexcn,frc, & + tsa1(n),tsa2(n),tsb1(n),tsb2(n) & + ) + + END DO + END DO + !$OMP ENDPARALLELDO + tile_pick = 0 + + DO n=1,nbcatch + if((arw1(n).ne.9999.).and.(ars1(n).ne.9999.))then + if(tile_pick(soil_class_com(n)) == 0) tile_pick(soil_class_com(n)) = n + endif + end do + + DO n=1,nbcatch + !c Third subroutine for the parameters related to the transfers + !c to the water table + ! + ! Writing the parameters, in the same order as in catchment.def + ! if((ars1(n).lt.0.).and.(ars2(n).le.0.3).and.(ars3(n).le.0.04).and.(arw1(n).ne.9999.))then + if((arw1(n).ne.9999.).and.(ars1(n).ne.9999.))then + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(n),ars2(n),ars3(n), & + ara1(n),ara2(n),ara3(n),ara4(n), & + arw1(n),arw2(n),arw3(n),arw4(n) + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(n),tsa2(n),tsb1(n),tsb2(n) + + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & + BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) + + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(n) + parms4file (n, 2) = ara2(n) + parms4file (n, 3) = ara3(n) + parms4file (n, 4) = ara4(n) + parms4file (n, 5) = ars1(n) + parms4file (n, 6) = ars2(n) + parms4file (n, 7) = ars3(n) + parms4file (n, 8) = arw1(n) + parms4file (n, 9) = arw2(n) + parms4file (n,10) = arw3(n) + parms4file (n,11) = arw4(n) + parms4file (n,13) = bf1(n) + parms4file (n,14) = bf2(n) + parms4file (n,15) = bf3(n) + parms4file (n,17) = gnu + parms4file (n,20) = tsa1(n) + parms4file (n,21) = tsa2(n) + parms4file (n,22) = tsb1(n) + parms4file (n,23) = tsb2(n) endif - - if(tile_pick(soil_class_com(n)) > 0) then - k = tile_pick(soil_class_com(n)) - picked=.true. - if (error_file) then - write (41,*)n,k + else + + if(preserve_soiltype) then + picked=.false. + ! Group3 + ! category 1 : Sand + ! category 2 : Loamy Sand + ! category 3 : Sandy Loam + ! category 8 : Silty Clay Loam + ! Group2 + ! category 4 : Silt Loam + ! category 5 : Silt + ! category 6 : Loam + ! category 7 : Sandy Clay Loam + ! Group1 + ! category 9 : Clay Loam + ! category 10 : Sandy Clay + ! category 11 : Silty Clay + ! category 12 : Clay + + if ((soil_class_com(n)>=9).and.(soil_class_com(n)<=12)) then + group=1 + else if ((soil_class_com(n)>=4).and.(soil_class_com(n)<=7)) then + group=2 + else + group=3 + endif + + if(tile_pick(soil_class_com(n)) > 0) then + k = tile_pick(soil_class_com(n)) + picked=.true. + if (error_file) then + write (41,*)n,k + endif + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(k),ars2(k),ars3(k), & + ara1(k),ara2(k),ara3(k),ara4(k), & + arw1(k),arw2(k),arw3(k),arw4(k) + ars1(n)=ars1(k) + ars2(n)=ars2(k) + ars3(n)=ars3(k) + ara1(n)=ara1(k) + ara2(n)=ara2(k) + ara3(n)=ara3(k) + ara4(n)=ara4(k) + arw1(n)=arw1(k) + arw2(n)=arw2(k) + arw3(n)=arw3(k) + arw4(n)=arw4(k) + + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(k),tsa2(k),tsb1(k),tsb2(k) + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & + BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(k) + parms4file (n, 2) = ara2(k) + parms4file (n, 3) = ara3(k) + parms4file (n, 4) = ara4(k) + parms4file (n, 5) = ars1(k) + parms4file (n, 6) = ars2(k) + parms4file (n, 7) = ars3(k) + parms4file (n, 8) = arw1(k) + parms4file (n, 9) = arw2(k) + parms4file (n,10) = arw3(k) + parms4file (n,11) = arw4(k) + parms4file (n,12) = BEE(k) + parms4file (n,13) = bf1(k) + parms4file (n,14) = bf2(k) + parms4file (n,15) = bf3(k) + parms4file (n,16) = COND(k) + parms4file (n,17) = gnu + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,20) = tsa1(k) + parms4file (n,21) = tsa2(k) + parms4file (n,22) = tsb1(k) + parms4file (n,23) = tsb2(k) + parms4file (n,24) = wpwet (k) + parms4file (n,25) = soildepth(k) + endif + else + + do k =n-1,1,-1 + + if (group == 1) then + if ((soil_class_com(k)>=9).and.(soil_class_com(k)<=12))picked=.true. + endif + + if (group == 2) then + if ((soil_class_com(k)>=4).and.(soil_class_com(k)<=7)) picked=.true. + endif + + if (group == 3) then + if (((soil_class_com(k)>=1).and.(soil_class_com(k)<=3)).or. & + (soil_class_com(k)==8)) picked=.true. + endif + + if (picked) then + if (error_file) then + write (41,*)n,k + endif + + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(k),ars2(k),ars3(k), & + ara1(k),ara2(k),ara3(k),ara4(k), & + arw1(k),arw2(k),arw3(k),arw4(k) + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(k),tsa2(k),tsb1(k),tsb2(k) + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & + BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) + ars1(n)=ars1(k) + ars2(n)=ars2(k) + ars3(n)=ars3(k) + ara1(n)=ara1(k) + ara2(n)=ara2(k) + ara3(n)=ara3(k) + ara4(n)=ara4(k) + arw1(n)=arw1(k) + arw2(n)=arw2(k) + arw3(n)=arw3(k) + arw4(n)=arw4(k) + + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(k) + parms4file (n, 2) = ara2(k) + parms4file (n, 3) = ara3(k) + parms4file (n, 4) = ara4(k) + parms4file (n, 5) = ars1(k) + parms4file (n, 6) = ars2(k) + parms4file (n, 7) = ars3(k) + parms4file (n, 8) = arw1(k) + parms4file (n, 9) = arw2(k) + parms4file (n,10) = arw3(k) + parms4file (n,11) = arw4(k) + parms4file (n,12) = BEE(k) + parms4file (n,13) = bf1(k) + parms4file (n,14) = bf2(k) + parms4file (n,15) = bf3(k) + parms4file (n,16) = COND(k) + parms4file (n,17) = gnu + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,20) = tsa1(k) + parms4file (n,21) = tsa2(k) + parms4file (n,22) = tsb1(k) + parms4file (n,23) = tsb2(k) + parms4file (n,24) = wpwet (k) + parms4file (n,25) = soildepth(k) + endif + exit + endif + + if((k==1) .and. (.not. picked)) then + print *,'Warning ar.new is bad at n=',n + stop + endif + end do endif + + + ! write(30,'(i8,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) + ! write(40,'(i8,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + ! tsa1(n),tsa2(n),tsb1(n),tsb2(n) + else + + dist_save = 1000000. + k = 0 + do i = 1,nbcatch + if(i /= n) then + if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then + + tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & + (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) + if(tile_distance < dist_save) then + k = i + dist_save = tile_distance + endif + endif + endif + enddo + write (41,*)n,k write(20,'(i10,i8,f5.2,11(2x,e14.7))') & tindex2(n),pfaf2(n),gnu, & ars1(k),ars2(k),ars3(k), & ara1(k),ara2(k),ara3(k),ara4(k), & arw1(k),arw2(k),arw3(k),arw4(k) - ars1(n)=ars1(k) - ars2(n)=ars2(k) - ars3(n)=ars3(k) - ara1(n)=ara1(k) - ara2(n)=ara2(k) - ara3(n)=ara3(k) - ara4(n)=ara4(k) - arw1(n)=arw1(k) - arw2(n)=arw2(k) - arw3(n)=arw3(k) - arw4(n)=arw4(k) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) + tsa1(k),tsa2(k),tsb1(k),tsb2(k) write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) if (allocated (parms4file)) then @@ -3429,4335 +2485,3842 @@ SUBROUTINE create_model_para (MaskFile) parms4file (n,24) = wpwet (k) parms4file (n,25) = soildepth(k) endif - else - - do k =n-1,1,-1 - - if (group == 1) then - if ((soil_class_com(k)>=9).and.(soil_class_com(k)<=12))picked=.true. - endif - - if (group == 2) then - if ((soil_class_com(k)>=4).and.(soil_class_com(k)<=7)) picked=.true. - endif - - if (group == 3) then - if (((soil_class_com(k)>=1).and.(soil_class_com(k)<=3)).or. & - (soil_class_com(k)==8)) picked=.true. - endif - - if (picked) then - if (error_file) then - write (41,*)n,k - endif - - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) - ars1(n)=ars1(k) - ars2(n)=ars2(k) - ars3(n)=ars3(k) - ara1(n)=ara1(k) - ara2(n)=ara2(k) - ara3(n)=ara3(k) - ara4(n)=ara4(k) - arw1(n)=arw1(k) - arw2(n)=arw2(k) - arw3(n)=arw3(k) - arw4(n)=arw4(k) - - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(k) - parms4file (n, 2) = ara2(k) - parms4file (n, 3) = ara3(k) - parms4file (n, 4) = ara4(k) - parms4file (n, 5) = ars1(k) - parms4file (n, 6) = ars2(k) - parms4file (n, 7) = ars3(k) - parms4file (n, 8) = arw1(k) - parms4file (n, 9) = arw2(k) - parms4file (n,10) = arw3(k) - parms4file (n,11) = arw4(k) - parms4file (n,12) = BEE(k) - parms4file (n,13) = bf1(k) - parms4file (n,14) = bf2(k) - parms4file (n,15) = bf3(k) - parms4file (n,16) = COND(k) - parms4file (n,17) = gnu - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) - parms4file (n,20) = tsa1(k) - parms4file (n,21) = tsa2(k) - parms4file (n,22) = tsb1(k) - parms4file (n,23) = tsb2(k) - parms4file (n,24) = wpwet (k) - parms4file (n,25) = soildepth(k) - endif - exit - endif - - if((k==1) .and. (.not. picked)) then - print *,'Warning ar.new is bad at n=',n - stop - endif - end do endif - - -! write(30,'(i8,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) -! write(40,'(i8,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & -! tsa1(n),tsa2(n),tsb1(n),tsb2(n) - else + endif - dist_save = 1000000. - k = 0 - do i = 1,nbcatch - if(i /= n) then - if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then - - tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & - (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) - if(tile_distance < dist_save) then - k = i - dist_save = tile_distance - endif - endif - endif - enddo - write (41,*)n,k - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.3)') tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(k) - parms4file (n, 2) = ara2(k) - parms4file (n, 3) = ara3(k) - parms4file (n, 4) = ara4(k) - parms4file (n, 5) = ars1(k) - parms4file (n, 6) = ars2(k) - parms4file (n, 7) = ars3(k) - parms4file (n, 8) = arw1(k) - parms4file (n, 9) = arw2(k) - parms4file (n,10) = arw3(k) - parms4file (n,11) = arw4(k) - parms4file (n,12) = BEE(k) - parms4file (n,13) = bf1(k) - parms4file (n,14) = bf2(k) - parms4file (n,15) = bf3(k) - parms4file (n,16) = COND(k) - parms4file (n,17) = gnu - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) - parms4file (n,20) = tsa1(k) - parms4file (n,21) = tsa2(k) - parms4file (n,22) = tsb1(k) - parms4file (n,23) = tsb2(k) - parms4file (n,24) = wpwet (k) - parms4file (n,25) = soildepth(k) - endif - endif - endif - - if (error_file) then - write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & - normerr1(n),normerr2(n),normerr3(n),normerr4(n) - write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) - endif - - END DO - -! Write(*,*) 'END COMPUTING MODEL PARA' - - close(10,status='keep') - close(20,status='keep') - close(30,status='keep') - close(40,status='keep') - close(11,status='keep') - close(12,status='keep') - close(42,status='keep') - if (error_file) then - close(21,status='delete') - close(31,status='delete') - close(41,status='keep') - endif - - if(file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA1' ) ,(/1/),(/nbcatch/), parms4file (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA2' ) ,(/1/),(/nbcatch/), parms4file (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA3' ) ,(/1/),(/nbcatch/), parms4file (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA4' ) ,(/1/),(/nbcatch/), parms4file (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS1' ) ,(/1/),(/nbcatch/), parms4file (:, 5)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS2' ) ,(/1/),(/nbcatch/), parms4file (:, 6)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS3' ) ,(/1/),(/nbcatch/), parms4file (:, 7)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW1' ) ,(/1/),(/nbcatch/), parms4file (:, 8)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW2' ) ,(/1/),(/nbcatch/), parms4file (:, 9)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW3' ) ,(/1/),(/nbcatch/), parms4file (:,10)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW4' ) ,(/1/),(/nbcatch/), parms4file (:,11)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), parms4file (:,12)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF1' ) ,(/1/),(/nbcatch/), parms4file (:,13)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF2' ) ,(/1/),(/nbcatch/), parms4file (:,14)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF3' ) ,(/1/),(/nbcatch/), parms4file (:,15)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), parms4file (:,16)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'GNU' ) ,(/1/),(/nbcatch/), parms4file (:,17)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), parms4file (:,18)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), parms4file (:,19)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA1' ) ,(/1/),(/nbcatch/), parms4file (:,20)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA2' ) ,(/1/),(/nbcatch/), parms4file (:,21)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB1' ) ,(/1/),(/nbcatch/), parms4file (:,22)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB2' ) ,(/1/),(/nbcatch/), parms4file (:,23)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), parms4file (:,24)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), parms4file (:,25)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - DEALLOCATE (parms4file) - endif + if (error_file) then + write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + normerr1(n),normerr2(n),normerr3(n),normerr4(n) + write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) + endif + + END DO + + ! Write(*,*) 'END COMPUTING MODEL PARA' + + close(10,status='keep') + close(20,status='keep') + close(30,status='keep') + close(40,status='keep') + close(11,status='keep') + close(12,status='keep') + close(42,status='keep') + if (error_file) then + close(21,status='delete') + close(31,status='delete') + close(41,status='keep') + endif + + if(file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA1' ) ,(/1/),(/nbcatch/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA2' ) ,(/1/),(/nbcatch/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA3' ) ,(/1/),(/nbcatch/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA4' ) ,(/1/),(/nbcatch/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS1' ) ,(/1/),(/nbcatch/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS2' ) ,(/1/),(/nbcatch/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS3' ) ,(/1/),(/nbcatch/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW1' ) ,(/1/),(/nbcatch/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW2' ) ,(/1/),(/nbcatch/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW3' ) ,(/1/),(/nbcatch/), parms4file (:,10)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW4' ) ,(/1/),(/nbcatch/), parms4file (:,11)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), parms4file (:,12)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF1' ) ,(/1/),(/nbcatch/), parms4file (:,13)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF2' ) ,(/1/),(/nbcatch/), parms4file (:,14)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF3' ) ,(/1/),(/nbcatch/), parms4file (:,15)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), parms4file (:,16)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'GNU' ) ,(/1/),(/nbcatch/), parms4file (:,17)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), parms4file (:,18)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), parms4file (:,19)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA1' ) ,(/1/),(/nbcatch/), parms4file (:,20)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA2' ) ,(/1/),(/nbcatch/), parms4file (:,21)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB1' ) ,(/1/),(/nbcatch/), parms4file (:,22)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB2' ) ,(/1/),(/nbcatch/), parms4file (:,23)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), parms4file (:,24)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), parms4file (:,25)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif END SUBROUTINE create_model_para -!-------------------------------------------------------------------- - - SUBROUTINE create_model_para_woesten (Maskfile) - - implicit none - real, allocatable, dimension (:) :: a_sand,a_clay,a_silt,a_oc, & - atile_sand,atile_clay, tile_lon, tile_lat, grav_vec, soc_vec,& - poc_vec,a_sand_surf,a_clay_surf,wpwet_surf,poros_surf, pmap - -!obsolete20220428 real, allocatable, dimension (:,:) :: good_clay, good_sand -!obsolete20220428 integer, allocatable, dimension (:,:) :: tile_add, tile_pick -!obsolete20220428 type (mineral_perc) :: min_percs -!obsolete20220428 integer :: CF1, CF2, CF3, CF4 - - integer i,j,n,k, tindex1,pfaf1,nbcatch - integer soil_gswp - real meanlu,stdev,minlu,maxlu,coesk,rzdep - real minlat,maxlat,minlon,maxlon - real,allocatable, dimension (:) :: & - BEE, PSIS,POROS,COND,WPWET,soildepth - REAL, allocatable, dimension(:) :: TOPMEAN, TOPVAR, TOPSKEW - REAL ST(NAR), AC(NAR),COESKEW - REAL, allocatable, dimension (:) :: & - ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & - ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & - tsa1, tsa2,tsb1, tsb2, & - taberr1,taberr2,normerr1,normerr2, & - taberr3,taberr4,normerr3,normerr4 - - integer, allocatable, dimension (:) :: soil_class_com,tindex2,pfaf2, & - soil_class_top - real watdep(nwt,nrz),wan(nwt,nrz),rzexcn(nwt,nrz),frc(nwt,nrz) - real, allocatable, dimension (:,:,:) :: & - gwatdep,gwan,grzexcn,gfrc - real :: wtdep,wanom,rzaact,fracl,profdep,dist_save, & - ncells_top, ncells_top_pro,ncells_sub_pro,tile_distance - character*200 :: pathout,fname,fout,losfile - character*10 :: dline - CHARACTER*20 :: version,resoln,continent - character*6 rdep,ext - character (*) :: MaskFile - integer :: iwt,irz,group - logical :: picked - logical :: file_exists - REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file - integer :: ncid, status - -! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ -! -! NOTE: "!$" is for conditional compilation -! -logical :: running_omp = .false. -! -!$ integer :: omp_get_thread_num, omp_get_num_threads -! -integer :: n_threads=1, li, ui -! -integer, dimension(:), allocatable :: low_ind, upp_ind -! -! ------------------------------------------------------------------ - - ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- - ! - ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION - ! - !$ running_omp = .true. ! conditional compilation - ! - ! ECHO BASIC OMP VARIABLES - ! - !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) - ! - !$OMP SINGLE - ! - !$ n_threads = omp_get_num_threads() - ! - !$ write (*,*) 'running_omp = ', running_omp - !$ write (*,*) - !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' - !$ write (*,*) - !$OMP ENDSINGLE - ! - !$OMP CRITICAL - !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' - !$OMP ENDCRITICAL - ! - !$OMP BARRIER - ! - !$OMP ENDPARALLEL - -!c------------------------------------------------------------------------- - - ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ - ! only in the parameters for the peat class #253. The file *.peatmap contains - ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). - ! - ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND - ! - ! K_s COND [m/s] - ! NLv4 7.86e-7 5.81e-6 - ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 - - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - - if(use_PEATMAP) then - fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.peatmap' - else - fname = trim(MAKE_BCS_INPUT_DIR)//'land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat' - endif - open (11, file=trim(fname), form='formatted',status='old', & - action = 'read') - read (11,'(a)')fout ! read header line - - losfile =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/soil_water_loss/v2/loss_pd_top/loss_perday_rz1m_' - - allocate (a_sand (1:n_SoilClasses)) - allocate (a_silt (1:n_SoilClasses)) - allocate (a_clay (1:n_SoilClasses)) - allocate (a_oc (1:n_SoilClasses)) - allocate (gwatdep(1:nwt,1:nrz,1:n_SoilClasses)) - allocate (gwan (1:nwt,1:nrz,1:n_SoilClasses)) - allocate (grzexcn(1:nwt,1:nrz,1:n_SoilClasses)) - allocate (gfrc (1:nwt,1:nrz,1:n_SoilClasses)) - - do n =1,n_SoilClasses - - ! read sand/clay/orgC for class n defined in SoilClasses-SoilHyd-TauParam.* - - read (11,'(4f7.3)')a_sand(n),a_clay(n),a_silt(n),a_oc(n) - write (fout,'(i2.2,i2.2,i4.4)')nint(a_sand(n)),nint(a_clay(n)),nint(100*a_oc(n)) - - ! open and read loss parameter file for class n (defined through sand/clay/orgC) - - if(n == n_SoilClasses .and. use_PEATMAP) then - open (120,file=trim(losfile)//trim(fout)//'.peat', & - form='formatted',status='old') - else - open (120,file=trim(losfile)//trim(fout), & - form='formatted',status='old') - endif - - do iwt=1,nwt - do irz=1,nrz - read(120,2000) wtdep,wanom,rzaact,fracl - 2000 format(1x,4e16.8) - gwatdep(iwt,irz,n)= wtdep - gwan(iwt,irz,n) = wanom - grzexcn(iwt,irz,n)= rzaact - gfrc(iwt,irz,n) = amin1(fracl,1.) - enddo - enddo - close (120,status='keep') - end do - close (11,status='keep') - deallocate (a_sand,a_silt,a_clay,a_oc) - - ! open files for *reading* - - fname='clsm/soil_param.first' - open (10,file=fname,action='read', & - form='formatted',status='old') - - fname='clsm/cti_stats.dat' - open (11,file=fname,action='read', & - form='formatted',status='old') - - fname='clsm/catchment.def' - open (12,file=fname,action='read', & - form='formatted',status='old') - - ! open files for *writing* - - fout='clsm/ar.new' - open (20,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm//bf.dat' - open (30,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm//ts.dat' - open (40,file=fout,action='write', & - form='formatted',status='unknown') - - if (error_file) then - fout='clsm/ar_rmse.dat' - open (21,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm/bf_rmse.dat' - open (31,file=fout,action='write', & - form='formatted',status='unknown') - - fout='clsm/bad_sat_param.tiles' - open (41,file=fout,action='write', & - form='formatted',status='unknown') - - endif - - fout='clsm/soil_param.dat' - open (42,file=fout,action='write', & - form='formatted',status='unknown') - - read (11,*)nbcatch ! read header line (number of tiles) -- cti_stats.dat - read (12,*)nbcatch ! read header line (number of tiles) -- catchment.def - - allocate (tile_lon(1:nbcatch)) - allocate (tile_lat(1:nbcatch)) - allocate (TOPMEAN (1:nbcatch)) - allocate (TOPVAR (1:nbcatch)) - allocate (TOPSKEW (1:nbcatch)) - allocate (ARS1 (1:nbcatch)) - allocate (ARS2 (1:nbcatch)) - allocate (ARS3 (1:nbcatch)) - allocate (ARA1 (1:nbcatch)) - allocate (ARA2 (1:nbcatch)) - allocate (ARA3 (1:nbcatch)) - allocate (ARA4 (1:nbcatch)) - allocate (ARW1 (1:nbcatch)) - allocate (ARW2 (1:nbcatch)) - allocate (ARW3 (1:nbcatch)) - allocate (ARW4 (1:nbcatch)) - allocate (BF1 (1:nbcatch)) - allocate (BF2 (1:nbcatch)) - allocate (BF3 (1:nbcatch)) - allocate (TSA1 (1:nbcatch)) - allocate (TSA2 (1:nbcatch)) - allocate (TSB1 (1:nbcatch)) - allocate (TSB2 (1:nbcatch)) - allocate (TABERR1 (1:nbcatch)) - allocate (TABERR2 (1:nbcatch)) - allocate (TABERR3 (1:nbcatch)) - allocate (TABERR4 (1:nbcatch)) - allocate (NORMERR1 (1:nbcatch)) - allocate (NORMERR2 (1:nbcatch)) - allocate (NORMERR3 (1:nbcatch)) - allocate (NORMERR4 (1:nbcatch)) - allocate (BEE (1:nbcatch)) - allocate (PSIS (1:nbcatch)) - allocate (POROS (1:nbcatch)) - allocate (COND (1:nbcatch)) - allocate (WPWET (1:nbcatch)) - allocate (soildepth (1:nbcatch)) - allocate (soil_class_top (1:nbcatch)) - allocate (soil_class_com (1:nbcatch)) - allocate (tindex2 (1:nbcatch)) - allocate (pfaf2 (1:nbcatch)) - allocate (atile_clay (1:nbcatch)) - allocate (atile_sand (1:nbcatch)) - allocate (grav_vec (1:nbcatch)) - allocate (soc_vec (1:nbcatch)) - allocate (poc_vec (1:nbcatch)) - allocate (a_sand_surf (1:nbcatch)) - allocate (a_clay_surf (1:nbcatch)) - allocate (wpwet_surf (1:nbcatch)) - allocate (poros_surf (1:nbcatch)) - allocate (pmap (1:nbcatch)) - -!obsolete20220428 allocate (good_clay (1:100,4)) -!obsolete20220428 allocate (good_sand (1:100,4)) -!obsolete20220428 allocate (tile_add (1:100,4)) -!obsolete20220428 allocate (tile_pick (1:100,4)) -!obsolete20220428 tile_add = 0 -!obsolete20220428 tile_pick= 0 -!obsolete20220428 good_clay =0. -!obsolete20220428 good_sand =0. - - do n=1,nbcatch + !-------------------------------------------------------------------- + + SUBROUTINE create_model_para_woesten (Maskfile, nbcatch, tile_lon, tile_lat, tile_pfs) + + character(*), intent(in) :: MaskFile + integer, intent(in) :: nbcatch + real, intent(in) :: tile_lon(:), tile_lat(:) + integer, intent(in) :: tile_pfs(:) + ! ----------------------------------------------- + + real, allocatable, dimension (:) :: a_sand,a_clay,a_silt,a_oc, & + atile_sand,atile_clay, grav_vec, soc_vec,& + poc_vec,a_sand_surf,a_clay_surf,wpwet_surf,poros_surf, pmap + + integer i,j,n,k, tindex1,pfaf1 + integer soil_gswp + real meanlu,stdev,minlu,maxlu,coesk,rzdep + real minlat,maxlat,minlon,maxlon + real,allocatable, dimension (:) :: & + BEE, PSIS,POROS,COND,WPWET,soildepth + REAL, allocatable, dimension(:) :: TOPMEAN, TOPVAR, TOPSKEW + REAL ST(NAR), AC(NAR),COESKEW + REAL, allocatable, dimension (:) :: & + ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & + ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & + tsa1, tsa2,tsb1, tsb2, & + taberr1,taberr2,normerr1,normerr2, & + taberr3,taberr4,normerr3,normerr4 + + integer, allocatable, dimension (:) :: soil_class_com,tindex2,pfaf2, & + soil_class_top + real watdep(nwt,nrz),wan(nwt,nrz),rzexcn(nwt,nrz),frc(nwt,nrz) + real, allocatable, dimension (:,:,:) :: & + gwatdep,gwan,grzexcn,gfrc + real :: wtdep,wanom,rzaact,fracl,profdep,dist_save, & + ncells_top, ncells_top_pro,ncells_sub_pro,tile_distance + character*512 :: pathout,fname,fout,losfile + CHARACTER*512 :: version,resoln,continent + character*6 ::rdep,ext + integer :: iwt,irz,group + logical :: picked + logical :: file_exists + REAL, ALLOCATABLE, DIMENSION (:,:) :: parms4file + integer :: ncid, status + + ! --------- VARIABLES FOR *OPENMP* PARALLEL ENVIRONMENT ------------ + ! + ! NOTE: "!$" is for conditional compilation + ! + logical :: running_omp = .false. + ! + !$ integer :: omp_get_thread_num, omp_get_num_threads + ! + integer :: n_threads=1, li, ui + ! + integer, dimension(:), allocatable :: low_ind, upp_ind + ! + ! ------------------------------------------------------------------ + + ! ----------- OpenMP PARALLEL ENVIRONMENT ---------------------------- + ! + ! FIND OUT WHETHER -omp FLAG HAS BEEN SET DURING COMPILATION + ! + !$ running_omp = .true. ! conditional compilation + ! + ! ECHO BASIC OMP VARIABLES + ! + !$OMP PARALLEL DEFAULT(NONE) SHARED(running_omp,n_threads) + ! + !$OMP SINGLE + ! + !$ n_threads = omp_get_num_threads() + ! + !$ write (*,*) 'running_omp = ', running_omp + !$ write (*,*) + !$ write (*,*) 'parallel OpenMP with ', n_threads, 'threads' + !$ write (*,*) + !$OMP ENDSINGLE + ! + !$OMP CRITICAL + !$ write (*,*) 'thread ', omp_get_thread_num(), ' alive' + !$OMP ENDCRITICAL + ! + !$OMP BARRIER + ! + !$OMP ENDPARALLEL + + !c------------------------------------------------------------------------- + + ! SoilClasses-SoilHyd-TauParam.dat and SoilClasses-SoilHyd-TauParam.peatmap differ + ! only in the parameters for the peat class #253. The file *.peatmap contains + ! the PEATCLSM parameters from Table 2 of Bechtold et al. 2019 (doi:10.1029/2018MS001574). + ! + ! Note: K_s = COND*exp(-zks*gnu) ==> with zks=2 and gnu=1, K_s = 0.135335*COND + ! + ! K_s COND [m/s] + ! NLv4 7.86e-7 5.81e-6 + ! NLv5 3.79e-6 2.80e-5 <== note *typo* in Table 2 of Bechtold et al. 2019, which erroneously lists K_s=2.8e-5 + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + + if(use_PEATMAP) then + fname = trim(MAKE_BCS_INPUT_DIR)//'/land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.peatmap' + else + fname = trim(MAKE_BCS_INPUT_DIR)//'land/soil/SOIL-DATA/SoilClasses-SoilHyd-TauParam.dat' + endif + open (11, file=trim(fname), form='formatted',status='old', & + action = 'read') + read (11,'(a)')fout ! read header line + + losfile =trim(MAKE_BCS_INPUT_DIR)//'/land/soil/soil_water_loss/v2/loss_pd_top/loss_perday_rz1m_' + + allocate (a_sand (1:n_SoilClasses)) + allocate (a_silt (1:n_SoilClasses)) + allocate (a_clay (1:n_SoilClasses)) + allocate (a_oc (1:n_SoilClasses)) + allocate (gwatdep(1:nwt,1:nrz,1:n_SoilClasses)) + allocate (gwan (1:nwt,1:nrz,1:n_SoilClasses)) + allocate (grzexcn(1:nwt,1:nrz,1:n_SoilClasses)) + allocate (gfrc (1:nwt,1:nrz,1:n_SoilClasses)) + + do n =1,n_SoilClasses + + ! read sand/clay/orgC for class n defined in SoilClasses-SoilHyd-TauParam.* + + read (11,'(4f7.3)')a_sand(n),a_clay(n),a_silt(n),a_oc(n) + write (fout,'(i2.2,i2.2,i4.4)')nint(a_sand(n)),nint(a_clay(n)),nint(100*a_oc(n)) + + ! open and read loss parameter file for class n (defined through sand/clay/orgC) + + if(n == n_SoilClasses .and. use_PEATMAP) then + open (120,file=trim(losfile)//trim(fout)//'.peat', & + form='formatted',status='old') + else + open (120,file=trim(losfile)//trim(fout), & + form='formatted',status='old') + endif + + do iwt=1,nwt + do irz=1,nrz + read(120,2000) wtdep,wanom,rzaact,fracl +2000 format(1x,4e16.8) + gwatdep(iwt,irz,n)= wtdep + gwan(iwt,irz,n) = wanom + grzexcn(iwt,irz,n)= rzaact + gfrc(iwt,irz,n) = amin1(fracl,1.) + enddo + enddo + close (120,status='keep') + end do + close (11,status='keep') + deallocate (a_sand,a_silt,a_clay,a_oc) + + ! open files for *reading* + + fname='clsm/soil_param.first' + open (10,file=fname,action='read', & + form='formatted',status='old') + + fname='clsm/cti_stats.dat' + open (11,file=fname,action='read', & + form='formatted',status='old') + + ! open files for *writing* + + fout='clsm/ar.new' + open (20,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm//bf.dat' + open (30,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm//ts.dat' + open (40,file=fout,action='write', & + form='formatted',status='unknown') + + if (error_file) then + fout='clsm/ar_rmse.dat' + open (21,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm/bf_rmse.dat' + open (31,file=fout,action='write', & + form='formatted',status='unknown') + + fout='clsm/bad_sat_param.tiles' + open (41,file=fout,action='write', & + form='formatted',status='unknown') + + endif + + fout='clsm/soil_param.dat' + open (42,file=fout,action='write', & + form='formatted',status='unknown') + + read (11,*) n ! read off header line (number of tiles) -- cti_stats.dat + + allocate (TOPMEAN (1:nbcatch)) + allocate (TOPVAR (1:nbcatch)) + allocate (TOPSKEW (1:nbcatch)) + allocate (ARS1 (1:nbcatch)) + allocate (ARS2 (1:nbcatch)) + allocate (ARS3 (1:nbcatch)) + allocate (ARA1 (1:nbcatch)) + allocate (ARA2 (1:nbcatch)) + allocate (ARA3 (1:nbcatch)) + allocate (ARA4 (1:nbcatch)) + allocate (ARW1 (1:nbcatch)) + allocate (ARW2 (1:nbcatch)) + allocate (ARW3 (1:nbcatch)) + allocate (ARW4 (1:nbcatch)) + allocate (BF1 (1:nbcatch)) + allocate (BF2 (1:nbcatch)) + allocate (BF3 (1:nbcatch)) + allocate (TSA1 (1:nbcatch)) + allocate (TSA2 (1:nbcatch)) + allocate (TSB1 (1:nbcatch)) + allocate (TSB2 (1:nbcatch)) + allocate (TABERR1 (1:nbcatch)) + allocate (TABERR2 (1:nbcatch)) + allocate (TABERR3 (1:nbcatch)) + allocate (TABERR4 (1:nbcatch)) + allocate (NORMERR1 (1:nbcatch)) + allocate (NORMERR2 (1:nbcatch)) + allocate (NORMERR3 (1:nbcatch)) + allocate (NORMERR4 (1:nbcatch)) + allocate (BEE (1:nbcatch)) + allocate (PSIS (1:nbcatch)) + allocate (POROS (1:nbcatch)) + allocate (COND (1:nbcatch)) + allocate (WPWET (1:nbcatch)) + allocate (soildepth (1:nbcatch)) + allocate (soil_class_top (1:nbcatch)) + allocate (soil_class_com (1:nbcatch)) + allocate (tindex2 (1:nbcatch)) + allocate (pfaf2 (1:nbcatch)) + allocate (atile_clay (1:nbcatch)) + allocate (atile_sand (1:nbcatch)) + allocate (grav_vec (1:nbcatch)) + allocate (soc_vec (1:nbcatch)) + allocate (poc_vec (1:nbcatch)) + allocate (a_sand_surf (1:nbcatch)) + allocate (a_clay_surf (1:nbcatch)) + allocate (wpwet_surf (1:nbcatch)) + allocate (poros_surf (1:nbcatch)) + allocate (pmap (1:nbcatch)) + + do n=1,nbcatch + + ! read cti_stats.dat + + read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev & + ,minlu,maxlu,coesk + + ! read soil_param.first + ! + ! WARNING: Immediately after the present do loop, BEE, COND, POROS, PSIS, WPWET, and + ! soildepth will be read again (and thus overwritten) with the values from + ! the catch_params.nc4 file. It is unclear if the values in soil_param.first + ! and catch_params.nc4 differ. See comments below. + + read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4)') & + tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & + BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & + grav_vec(n),soc_vec(n),poc_vec(n), & + a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) + if(tindex1.ne.tindex2(n))then + write(*,*)'Warnning 1: tindex mismatched' + stop + endif + + if(tile_pfs(n).ne.pfaf2(n)) then + write(*,*)'Warnning 1: pfafstetter mismatched' + stop + endif + if((use_PEATMAP).and.(soil_class_top(n) == 253)) then + meanlu = 9.3 + stdev = 0.12 + minlu = 8.5 + maxlu = 11.5 + coesk = 0.25 + endif + + if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then + TOPMEAN(n) = meanlu + else + TOPMEAN(n) = 0.961*meanlu-1.957 + endif + + TOPVAR(n) = stdev*stdev + TOPSKEW(n) = coesk*stdev*stdev*stdev + + if ( TOPVAR(n) .eq. 0. .or. coesk .eq. 0. & + .or. topskew(n) .eq. 0.) then + write(*,*) 'Problem: undefined values:' + write(*,*) TOPMEAN(n),TOPVAR(n),coesk, & + minlu,maxlu + stop + endif + END DO ! n=1,nbcatch + + inquire(file='clsm/catch_params.nc4', exist=file_exists) + + if(file_exists) then + + ! Read BEE, COND, POROS, PSIS, WPWET, and soildepth from nc4 file. + ! It is unclear if parameters in nc4 file differ from those in soil_param.first, which were read + ! in the do loop just above. + ! Probably, the parameters differ by roundoff because soil_param.first is an ASCII file and + ! catch_params.nc4 is a netcdf file. Consequently, the parameters from the nc4 file are used + ! in the calculation of the ar.new, bf.dat, and ts.dat parameters, which comes next. + ! To maintain consistency between the parameters in soil_param.first and soil_param.dat where + ! no changes are needed, soil_param.first needs to be read again below (so as to overwrite + ! the values from the nc4 file). + ! Why the parameters from the nc4 file are read here in the first place remains a mystery. + ! Removing this read, however, will (almost certainly) result in non-zero-diff changes + ! for existing bcs datasets. + ! - reichle, 28 April 2022 + + status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) + allocate (parms4file (1:nbcatch, 1:25)) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), BEE (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), COND (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), POROS(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), PSIS (:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), WPWET(:)) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), soildepth (:)) ; VERIFY_(STATUS) + parms4file (:,12) = BEE (:) + parms4file (:,16) = COND (:) + parms4file (:,18) = POROS (:) + parms4file (:,19) = PSIS (:) + parms4file (:,24) = wpwet (:) + parms4file (:,25) = soildepth(:) + endif + + rewind(10) ! soil_param.first (so soil_param.first can be read again below...) + + allocate(low_ind(n_threads)) + allocate(upp_ind(n_threads)) + low_ind(1) = 1 + upp_ind(n_threads) = nbcatch + + if (running_omp) then + do i=1,n_threads-1 + + upp_ind(i) = low_ind(i) + (nbcatch/n_threads) - 1 + low_ind(i+1) = upp_ind(i) + 1 + + end do + end if + + + !$OMP PARALLELDO DEFAULT(NONE) & + !$OMP SHARED( BEE, PSIS,POROS,COND,WPWET,soildepth, & + !$OMP TOPMEAN, TOPVAR, TOPSKEW, & + !$OMP ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & + !$OMP ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & + !$OMP tsa1, tsa2,tsb1, tsb2, & + !$OMP taberr1,taberr2,normerr1,normerr2, & + !$OMP taberr3,taberr4,normerr3,normerr4, & + !$OMP gwatdep,gwan,grzexcn,gfrc,soil_class_com, & + !$OMP n_threads, low_ind, upp_ind, use_PEATMAP ) & + !$OMP PRIVATE(k,li,ui,n,i,watdep,wan,rzexcn,frc,ST,AC, & + !$OMP COESKEW,profdep) + + do k=1,n_threads + + li = low_ind(k) + ui = upp_ind(k) + + do n=li,ui + + CALL TGEN ( & + TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & + ST,AC,COESKEW) + + ! compute areal fractioning parameters (ar.new) + + CALL SAT_PARAM( & + BEE(n),PSIS(n),POROS(n),COND(n), & + WPWET(n), ST, AC, COESKEW,n, & + soildepth(n), & + ars1(n),ars2(n),ars3(n), & + ara1(n),ara2(n),ara3(n),ara4(n), & + arw1(n),arw2(n),arw3(n),arw4(n), & + taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + normerr1(n),normerr2(n),normerr3(n),normerr4(n)) + + ! compute base flow parameters (bf.dat) + + CALL BASE_PARAM( & + BEE(n),PSIS(n),POROS(n),COND(n), & + ST, AC, & + bf1(n),bf2(n),bf3(n), & + taberr1(n),taberr2(n),normerr1(n),normerr2(n) & + ) + + + watdep (:,:) = gwatdep (:,:,soil_class_com(n)) + wan (:,:) = gwan (:,:,soil_class_com(n)) + rzexcn (:,:) = grzexcn (:,:,soil_class_com(n)) + frc (:,:) = gfrc (:,:,soil_class_com(n)) + + ! compute time scale parameters (rzexc-catdef) (ts.dat) + + CALL TS_PARAM( & + BEE(n),PSIS(n),POROS(n), & + ST, AC, & + watdep,wan,rzexcn,frc, & + tsa1(n),tsa2(n),tsb1(n),tsb2(n) & + ) + + if(soil_class_com(n) == 253 .and. use_PEATMAP) then + + ! Michel Bechtold paper - PEATCLSM_fitting_CLSM_params.R produced these data values. + + ars1(n) = -7.9514018e-03 + ars2(n) = 6.2297356e-02 + ars3(n) = 1.9187240e-03 + ara1(n) = 8.9551220e+00 + ara2(n) = 9.8149664e+02 + ara3(n) = 8.9551220e+00 + ara4(n) = 9.8149664e+02 + arw1(n) = 9.9466055e-03 + arw2(n) = 1.0881960e-02 + arw3(n) = 1.5309287e-05 + arw4(n) = 1.0000000e-04 + + bf1(n) = 4.6088086e+02 + bf2(n) = 1.4237401e-01 + bf3(n) = 6.9803000e+00 + + tsa1(n) = -2.417581e+00 + tsa2(n) = -4.784762e+00 + tsb1(n) = -3.700285e-03 + tsb2(n) = -2.392484e-03 + + endif + END DO + END DO + !$OMP ENDPARALLELDO + + + ! ---------------------------------------------------------------------------------------- + ! + ! write ar.new, bf.dat, ts.dat, and soil_param.dat + + DO n=1,nbcatch + + ! Read soil_param.first again...; this is (almost certainly) needed to maintain consistency + ! between soil_param.first and soil_param.dat, see comments above. + + read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & + tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & + BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & + grav_vec(n),soc_vec(n),poc_vec(n), & + a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) , & + wpwet_surf(n),poros_surf(n), pmap(n) + + ! This revised if block replaces the complex, nested if block commented out above + + if ( (ars1(n)==9999.) .or. (arw1(n)==9999.) ) then + + ! some parameter values are no-data --> find nearest tile k with good parameters + + dist_save = 1000000. + k = 0 + do i = 1,nbcatch + if(i /= n) then + if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then + + tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & + (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) + if(tile_distance < dist_save) then + k = i + dist_save = tile_distance + endif + endif + endif + enddo + ! record in file clsm/bad_sat_param.tiles + write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken + + ! Overwrite parms4file when filling in parameters from neighboring tile k. + ! For "good" tiles, keep parms4file as read earlier from catch_params.nc4, + ! which is why this must be done within the "then" block of the "if" statement. + ! This is necessary for backward 0-diff compatibility of catch_params.nc4. + + parms4file (n,12) = BEE(k) + parms4file (n,16) = COND(k) + parms4file (n,18) = POROS(k) + parms4file (n,19) = PSIS(k) + parms4file (n,24) = wpwet(k) + parms4file (n,25) = soildepth(k) + + else + + ! nominal case, all parameters are good + + k = n + + end if + + ! for current tile n, write parameters of tile k into ar.new (20), bf.dat (30), ts.dat (40), + ! and soil_param.dat (42) + + write(20,'(i10,i8,f5.2,11(2x,e14.7))') & + tindex2(n),pfaf2(n),gnu, & + ars1(k),ars2(k),ars3(k), & + ara1(k),ara2(k),ara3(k),ara4(k), & + arw1(k),arw2(k),arw3(k),arw4(k) + + write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) + + write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & + tsa1(k),tsa2(k),tsb1(k),tsb2(k) + + write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & + tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & + BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & + grav_vec(k),soc_vec(k),poc_vec(k), & + a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & + wpwet_surf(k),poros_surf(k), pmap(k) + + ! record ar.new, bf.dat, and ts.dat parameters for later writing into catch_params.nc4 + + if (allocated (parms4file)) then + parms4file (n, 1) = ara1(k) + parms4file (n, 2) = ara2(k) + parms4file (n, 3) = ara3(k) + parms4file (n, 4) = ara4(k) + parms4file (n, 5) = ars1(k) + parms4file (n, 6) = ars2(k) + parms4file (n, 7) = ars3(k) + parms4file (n, 8) = arw1(k) + parms4file (n, 9) = arw2(k) + parms4file (n,10) = arw3(k) + parms4file (n,11) = arw4(k) + parms4file (n,13) = bf1(k) + parms4file (n,14) = bf2(k) + parms4file (n,15) = bf3(k) + parms4file (n,17) = gnu + parms4file (n,20) = tsa1(k) + parms4file (n,21) = tsa2(k) + parms4file (n,22) = tsb1(k) + parms4file (n,23) = tsb2(k) + endif + + if (error_file) then + write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & + normerr1(n),normerr2(n),normerr3(n),normerr4(n) + write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) + endif + + END DO ! n=1,nbcatch + + ! Write(*,*) 'END COMPUTING MODEL PARA' + + close(10,status='keep') + close(11,status='keep') + close(20,status='keep') + close(30,status='keep') + close(40,status='keep') + close(42,status='keep') + + + if (error_file) then + close(21,status='delete') + close(31,status='delete') + close(41,status='keep') + endif + + if(file_exists) then + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA1' ) ,(/1/),(/nbcatch/), parms4file (:, 1)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA2' ) ,(/1/),(/nbcatch/), parms4file (:, 2)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA3' ) ,(/1/),(/nbcatch/), parms4file (:, 3)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA4' ) ,(/1/),(/nbcatch/), parms4file (:, 4)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS1' ) ,(/1/),(/nbcatch/), parms4file (:, 5)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS2' ) ,(/1/),(/nbcatch/), parms4file (:, 6)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS3' ) ,(/1/),(/nbcatch/), parms4file (:, 7)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW1' ) ,(/1/),(/nbcatch/), parms4file (:, 8)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW2' ) ,(/1/),(/nbcatch/), parms4file (:, 9)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW3' ) ,(/1/),(/nbcatch/), parms4file (:,10)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW4' ) ,(/1/),(/nbcatch/), parms4file (:,11)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), parms4file (:,12)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF1' ) ,(/1/),(/nbcatch/), parms4file (:,13)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF2' ) ,(/1/),(/nbcatch/), parms4file (:,14)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF3' ) ,(/1/),(/nbcatch/), parms4file (:,15)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), parms4file (:,16)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'GNU' ) ,(/1/),(/nbcatch/), parms4file (:,17)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), parms4file (:,18)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), parms4file (:,19)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA1' ) ,(/1/),(/nbcatch/), parms4file (:,20)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA2' ) ,(/1/),(/nbcatch/), parms4file (:,21)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB1' ) ,(/1/),(/nbcatch/), parms4file (:,22)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB2' ) ,(/1/),(/nbcatch/), parms4file (:,23)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), parms4file (:,24)) ; VERIFY_(STATUS) + status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), parms4file (:,25)) ; VERIFY_(STATUS) + STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) + DEALLOCATE (parms4file) + endif + + END SUBROUTINE create_model_para_woesten + + + !--------------------------------------------------------------------- + + SUBROUTINE TS_PARAM( & + BEE,PSIS,POROS, & + VALX, PX, & + watdep,wan,rzexcn,frc, & + tsa1,tsa2,tsb1,tsb2 & + ) + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c Given pre-computed 1-D relationships between a "local" root zone excess c + !c and a "local" catchment deficit, the timescale of the bulk vertical c + !c transfer between the two bulk prognostic variables is computed using c + !c the distribution of the local deficit established from the distribution c + !c of the topographic index, then an approximated function of catdef and c + !c rzex is derived. c + !c c + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER NAR0 + REAL, intent (in) :: BEE, PSIS, POROS + REAL, intent (in) :: VALX(NAR), PX(NAR) + real, intent (inout) :: watdep(nwt,nrz),wan(nwt,nrz), & + rzexcn(nwt,nrz),frc(nwt,nrz) + real, intent (out) :: tsa1, tsa2 ,tsb1, tsb2 + + integer :: tex,iwt,irz,n,idep,k, index1,i0 + REAL VALX0(NAR), PX0(NAR),sumta,sumta2,timean,zbar, rzw + REAL :: term1, term2, sumdef, suma, frcsat,rzexc, rzact + real zdep(nar),def(nar),wrz(nar),wbin(500),rze(nar) + real catd(2,2),tsc(2,2), satfrc,sumfrac,sumz,frac + real, parameter :: frcmax = .041 + real wtdep,wanom,rzaact,fracl,profdep,rzdep + + ! logical bug + + !c---------------------------------------------------------------- + !c Is loss.dat compatible with rzdep = 0.49 ??? + + rzdep = grzdep + + !c Convert fractions to "per-hour" values + do iwt=1,nwt + do irz=1,nrz + frc(iwt,irz)=1.-((1.-frc(iwt,irz))**(1./24.)) + enddo + enddo + + nar0=0 + do n=1,nar + if (px(n) .ne. 0.) then + nar0=nar0+1 + valx0(nar0)=valx(n) + px0(nar0)=px(n) + endif + enddo + + sumta=0. + sumta2=0. + suma=0. + do n=1,nar0 + sumta=sumta+px0(n)*valx0(n) + sumta2=sumta2+px0(n)*valx0(n)*valx0(n) + suma=suma+px0(n) + enddo + + timean=sumta/suma + + !c**** Loop over two water table depths + do idep=1,2 + if(idep.eq.1) zbar=1.5 ! zbar in meters + if(idep.eq.2) zbar=2.0 + + !c**** Compute array of water table depths: + do k=1,nar0 + term1=(1/gnu)*(valx0(k)-timean) + zdep(k)=zbar-term1 + if(zdep(k) .lt. 0.) zdep(k)=0. + enddo + !c write(*,*)" End water table depth" + !c**** Compute array of moisture deficits: + do k=1,nar0 + term1=(psis-zdep(k))/psis + term1=term1**(1.-1./bee) + term2=-psis*(bee/(bee-1.))*(term1-1.) + def(k)=poros*(zdep(k)-term2) + enddo + + !c**** Add deficits to produce catdef: + sumdef=0. + do k=1,nar0 + sumdef=sumdef+def(k)*px0(k)*1000. + enddo + !c write(*,*)" End catchment deficit" + !c**** Compute array of root zone moisture (degree of wetness in root zone): + do k=1,nar0 + + if(zdep(k).eq.0.) then + wrz(k)=1. + elseif(zdep(k)-rzdep.lt.0.) then + term1=((psis-zdep(k))/psis)**(1.-1./bee) + wrz(k)=(-psis/zdep(k))*(bee/(bee-1.)) & + *(term1-1.) + frcsat=1.-zdep(k)/rzdep + wrz(k)=(1.-frcsat)*wrz(k)+frcsat*1. + else + term1=((psis-zdep(k))/psis)**(1.-1./bee) + term2=((psis-zdep(k)+rzdep)/psis) & + **(1.-1./bee) + wrz(k)=(-psis/rzdep)*(bee/(bee-1.)) & + *(term1-term2) + endif + enddo + + !c Loop over two root zone excess values: + do irz=1,2 + if(irz.eq.1) rzexc=-0.1*poros + if(irz.eq.2) rzexc=0.1*poros + + !c Determine actual root zone excess + rzact=0. + do k=1,nar0 + rze(k)=rzexc + rzw=wrz(k)*poros + if(rzw+rze(k) .gt. poros) rze(k)=poros-rzw + if(rzw+rze(k) .lt. 0.) rze(k)=rzw + rzact=rzact+rze(k)*px0(k) + enddo + !c write(*,*)" End root zone excess" + !c Compute the average timescale + + satfrc=0. + do k=1,nar0 + if(zdep(k).lt.0.) satfrc=satfrc+px0(k) + enddo + + sumfrac=0. + sumz=0. + do k=1,nar0 + sumz=sumz+zdep(k)*px0(k) + if(zdep(k) .lt. 1.) frac=frcmax + if(zdep(k) .ge. 1.) then + index1=1+int(((zdep(k)*100.)-99)/5.) + if(index1.gt.nwt) index1 = nwt + frac=amin1(frc(index1,1),frcmax) + do i0=2,nrz + if(rze(k) .ge. rzexcn(index1,i0)) & + frac=amin1(frc(index1,i0),frcmax) + enddo + endif + sumfrac=sumfrac+frac*px0(k) + enddo + !c write(*,*)" End average time scale" + catd(idep,irz)=sumdef + tsc(idep,irz)=sumfrac + + enddo + enddo + + tsb1=(alog(tsc(2,2))-alog(tsc(1,2)))/(catd(2,2)-catd(1,2)) + tsb2=(alog(tsc(2,1))-alog(tsc(1,1)))/(catd(2,1)-catd(1,1)) + tsa1=alog(tsc(2,2))-tsb1*catd(2,2) + tsa2=alog(tsc(2,1))-tsb2*catd(2,1) + + END SUBROUTINE TS_PARAM + + !********************************************************************* + + SUBROUTINE BASE_PARAM( & + BEE,PSIS,POROS,COND, & + VALX, PX, & + bf1,bf2,bf3, & + taberr1,taberr2,normerr1,normerr2 & + ) + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c New way to get baseflow: we parametrize the relationship between c + !c catdef and zbar (two parameters bf1 and bf2). c + !c Then, in the LSM/catchment.f/base.f, we use the original relation c + !c from TOPMODEL to infer baseflow from catdef and the mean of the c + !c topographic index (topmean=bf3, a third parameter). c + !c c + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER IDMAX,i1,i2,i,icount + + REAL, intent (in) :: BEE, PSIS,POROS,COND,VALX(NAR),PX(NAR) + real zbar(nbdep),catdef(nbdep),bflow(nbdep) + real, intent (out) :: bf1,bf2,bf3,taberr1,taberr2,normerr1,normerr2 + integer :: n,idep + real suma,sumta,timean + + real catfit(nbdep),bfit(nbdep),dfit(nbdep),catmean,bfmean + real catref(nbdep),bref(nbdep) + real err1, err2 + ! logical, intent (in) :: bug + + sumta=0. + suma=0. + do n=1,nar + sumta=sumta+px(n)*valx(n) + suma=suma+px(n) + enddo + timean=sumta/suma + bf3 = timean + + !c**** Loop over water table depths + + do idep=1,nbdep + + !c write(*,*) 'idep=',idep + + CALL BASIDEP( & + IDEP, & + BEE,PSIS,POROS,COND, & + VALX,PX,TIMEAN,SUMA, & + ZBAR,CATDEF,BFLOW) + + enddo + + + i1=10 ! zbar= 0 m + i2=35 ! zbar= 2.5 m + + bf2=zbar(i2)*SQRT(catdef(i1)) & + /(SQRT(catdef(i2))-SQRT(catdef(i1))) + bf1=catdef(i1)/(bf2*bf2) + + if (bf1 .le. 0) write(*,*) 'bf1 le 0 for i=',i + if (bf2 .le. 0) write(*,*) 'bf2 le 0 for i=',i + + !c Errors: Root mean square errors: only for points where catdef GT 0.5mm + + do idep=1,nbdep + catref(idep)=0. + bref(idep)=0. + enddo + catmean=0. + bfmean=0. + icount=0 + do idep=1,nbdep + if (catdef(idep) .gt. lim) then + icount=icount+1 + catref(icount)=catdef(idep) + bref(icount)=bflow(idep) + catfit(icount)=bf1*(zbar(idep)+bf2) & + *(zbar(idep)+bf2) + dfit(icount)=SQRT(catdef(idep)/bf1)-bf2 + bfit(icount)=cond*exp(-timean-gnu*dfit(icount)) & + /gnu + catmean=catmean+catdef(idep) + bfmean=bfmean+bflow(idep) + endif + enddo + catmean=catmean/icount + bfmean=bfmean/icount + if (icount.gt.1) then + call RMSE(catref,catfit,icount,err1) + call RMSE(bref,bfit,icount,err2) + + taberr1=err1 + taberr2=err2 + normerr1=err1/catmean + normerr2=err2/bfmean + endif + !c--------------------------------------------------------------------- + + END SUBROUTINE BASE_PARAM + + ! ************************************************************************ + + SUBROUTINE BASIDEP( & + IDEP, & + BEE,PSIS,POROS,COND, & + VALX,PX,TIMEAN,SUMA, & + ZBAR,CATDEF,BFLOW) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c This program returns the eight parameters for the areal fractioning c + !c c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER, intent (in) :: idep + integer nref, nind,nmax,indmin,locmax,shift,ord,locmin,ordref,width,k + REAL, intent (in) :: BEE, PSIS, POROS, COND,VALX(NAR), PX(NAR), & + suma,timean + real :: dx,sumdef,dz + real, intent (out) :: catdef(nbdep),bflow(nbdep),zbar(idep) + real term1,term2,sum + real zdep(nar),locdef(nar) + ! logical bug + + !c------------------------------------------------------------------------- + !c integral(f(x)dx)=1. for a pdf + !c here px=f(x)dx + + dx=valx(1)-valx(2) + + if (bug) write(*,*) 'IDEP=',IDEP,' dx=',dx, 'gnu=',gnu + + !c the loops over idmax and nbdep are initiated in sta_params4.f + + zbar(idep)=float(idep-10)*slice ! zdep in meters + + !c**** Compute array of water table depths: + do k=1,nar + term1=(1/gnu)*(valx(k)-timean) + zdep(k)=AMAX1(0.,zbar(idep)-term1) + enddo + + !c variable change must be reflected in dx + dz=dx/gnu + + if (bug) write(*,*) 'basidep: ok1' + + !c**** Compute array of moisture deficits: + do k=1,nar + term1=(psis-zdep(k))/psis + term1=term1**(1.-1./bee) + term2=-psis*(bee/(bee-1.))*(term1-1.) + locdef(k)=zdep(k)-term2 + enddo + + !c**** Add deficits to produce catdef: + sumdef=0. + do k=1,nar + sumdef=sumdef+locdef(k)*px(k) + enddo + catdef(idep)=poros*1000.*sumdef/suma + + if (bug) write(*,*) 'basidep: ok2' + + bflow(idep)=cond*exp(-timean-gnu*zbar(idep))/gnu + + if (bug) write(*,*) 'basidep: ok3' + + END SUBROUTINE BASIDEP + + !***************************************************************************** + + SUBROUTINE SAT_PARAM( & + BEE,PSIS,POROS,COND, & + WPWET,VALX, PX, COESKEW,PFC, & + soildepth, & + ARS1,ARS2,ARS3, & + ARA1,ARA2,ARA3,ARA4, & + ARW1,ARW2,ARW3,ARW4, & + taberr1,taberr2,taberr3,taberr4, & + normerr1,normerr2,normerr3,normerr4, & + DBG_UNIT) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c This program returns the eleven parameters for the areal fractioning c + !c c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER, intent (in) :: pfc + REAL, intent (in) :: BEE,PSIS,POROS,COND,WPWET, & + VALX(NAR), PX(NAR) + REAL, intent (in) :: soildepth, COESKEW + REAL, intent (inout) :: ARS1,ARS2,ARS3, & + ARA1,ARA2,ARA3,ARA4, & + ARW1,ARW2,ARW3,ARW4, & + taberr1,taberr2,taberr3,taberr4, & + normerr1,normerr2,normerr3,normerr4 + INTEGER idep,n,k,i,icount,iref + integer nar0 + integer nref, nind,nmax,indmin,locmax,shift,ord,locmin + integer loc1,loc2,loc3,loc0,flag + REAL VALX0(NAR), PX0(NAR) + integer :: adjust,loc2save,inc,dec + real sumta,suma,timean,upval,loval,profdep + real rjunk,rjunk2 + integer, intent (in), optional :: DBG_UNIT + real catdef(nbdep),wmin(nbdep),ar1(nbdep),aa(nbdep),aabis(nbdep) + real ar2(nbdep),ar3(nbdep),swsrf2(nbdep),swsrf3(nbdep),rzeq(nbdep) + real zbar0,catdef0,wmin0,RZDEP,wminsave(nbdep) + + real x1,x2,x3,x4,w1,w1_0,w2,w3,w4,ref1 + real y0,f1,f2,f3,g1,g2,g3,df,dg,dx,bf,bg,delta,z1,z2 + + real nar1(nbdep),nar2(nbdep),nmean2(nbdep),neq(nbdep) + real shape, nwm, area1,cdi,nar3(nbdep),nmean3 + real err1,err2,err3,err4,sum + real tabact(nbdep),tabfit(nbdep) + + integer :: mp,isvd,j,first_loop + ! REAL*8, allocatable :: A(:,:),AP(:,:) + ! REAL*8, allocatable :: B(:) + REAL*8, allocatable, target :: A(:,:) + REAL*8, allocatable, target :: B(:) + REAL*8, pointer :: AP(:,:) + REAL*8, pointer :: BP(:) + REAL*8 V(3,3),W(3),ANS(3),sdmax,sdmin,wbrac + + real :: cdcr1,cdcr2,term1,term2,zmet + logical :: smooth,ars_svd_loop + logical, parameter :: bug=.false. + logical, parameter :: SingValDecomp = .true. + integer, parameter :: nl=4, nr=4, m=4, NP=50 + real :: savgol_coeff(NP) + integer :: savgol_ind(NP) + integer :: nbdepl,istart + + ref1 = 100. + ! print *,'PFC', pfc + if (bug) write(*,*) 'starting sat_param' + + if(SingValDecomp) then + savgol_ind(1)=0 + j=3 + do i=2, nl+1 + savgol_ind(i)=i-j + j=j+2 + end do + + j=2 + do i=nl+2, nl+nr+1 + savgol_ind(i)=i-j + j=j+2 + end do + call savgol(savgol_coeff,nl+nr+1,nl,nr,0,m) + endif + + profdep = soildepth + rzdep =grzdep + profdep=profdep/1000. + profdep=amax1(1.,profdep) + if (rzdep .gt. .75*profdep) then + rzdep=0.75*profdep + end if + + zmet=profdep + term1=-1.+((psis-zmet)/psis)** & + ((bee-1.)/bee) + term2=psis*bee/(bee-1) + cdcr1=1000.*poros*(zmet-(-term2*term1)) + cdcr2=(1-wpwet)*poros*1000.*zmet + !c mean of the topographic index distribution + + nar0=0 + do n=1,nar + if (px(n) .ne. 0.) then + nar0=nar0+1 + valx0(nar0)=valx(n) + px0(nar0)=px(n) + endif + enddo + + sumta=0. + suma=0. + do n=1,nar0 + sumta=sumta+px0(n)*valx0(n) + suma=suma+px0(n) + enddo + timean=sumta/suma + + if (bug) write(*,*) 'ok 0: sumta,suma,nar0=',sumta,suma,nar0 + + !c**** Loop over water table depths + + do idep=1,nbdep + + CALL FUNCIDEP( & + NAR0,IDEP, & + BEE,PSIS,POROS,COND,RZDEP,WPWET, & + VALX0,PX0,COESKEW,TIMEAN,SUMA, & + CATDEF,AR1,WMIN,AA,AABIS, & + AR2,AR3,SWSRF2,SWSRF3,RZEQ) + enddo + + nbdepl = 100 + if(catdef(50) > cdcr1 + 20.) nbdepl = 50 + if(soildepth > 6500.) nbdepl = nbdep + + if (bug) write(*,*) 'funcidep loop ok' + + !c**** for wmin's adjustment, we need an estimate of its limit toward INF + adjust =0 + ZBAR0=10. + CALL FUNCZBAR( & + NAR0,ZBAR0, & + BEE,PSIS,POROS,COND,RZDEP,WPWET, & + VALX0,PX0,COESKEW,TIMEAN,SUMA, & + CATDEF0,WMIN0) + + if (bug) write(*,*) 'funczbar ok' + + if (wmin0 == 0.9999900) then + do idep=1,nbdep-1 + if(catdef(idep).le.cdcr1+10.) then + if((wmin(idep) - wmin(idep +1)) > -0.01) then + wmin0=wmin(idep) + endif + endif + enddo + wmin0 = 0.1*(nint(wmin0*100000.)/10000) -0.02 + endif + + if(present(dbg_unit)) then + write (dbg_unit,*) nbdep,nbdepl,wmin0,cdcr1,cdcr2 + write (dbg_unit,*) catdef + write (dbg_unit,*) ar1 + write (dbg_unit,*) wmin + endif + + !c**** AR1 adjustment: 3 points + limit in INF = 0. + + if (bug) write(*,*) 'STARTING AR1' + + ! Singular value decomposition + loc1=1 + loc3=nbdepl + loc2=loc3 + + do idep = 1,loc2 + if(ar1(idep) < 1.e-10) then + loc3 = idep - 1 + exit + endif + end do + + first_loop = 0 + ars_svd_loop = .TRUE. + DO while (ars_svd_loop) + + first_loop = first_loop + 1 + mp = loc3-loc1+1 + + allocate(A(mp,3)) + allocate(AP(mp,3)) + allocate(B(mp)) + + a=0. + ap=0. + b=0. + v=0. + w=0. + ans=0. + + do isvd=loc1,loc3 + A(isvd-loc1+1,1)=catdef(isvd) + A(isvd-loc1+1,2)=-catdef(isvd)*ar1(isvd) + A(isvd-loc1+1,3)=-ar1(isvd)*((catdef(isvd))**2.) + B(isvd-loc1+1)=ar1(isvd)-1. + end do + + ap = a + call svdcmp(ap,mp,3,w,v) + sdmax=0. + do j=1,3 + if(w(j).gt.sdmax)sdmax=w(j) + end do + sdmin=sdmax*1.0e-6 + do j=1,3 + if(w(j).lt.sdmin)w(j)=0. + end do + + call svbksb(ap,w,v,mp,3,b,ans) + + ars1 = real(ans(1)) + ars2 = real(ans(2)) + ars3 = real(ans(3)) + + flag=0 + call curve1(ars1,ars2,ars3,cdcr2,flag) + deallocate (A, AP, B) + + IF(FLAG == 1) THEN + LOC3 = NBDEP + LOC1 =1 + IF(first_loop > 1) ars_svd_loop=.FALSE. + ELSE + ars_svd_loop=.FALSE. + ENDIF + END DO + + IF (FLAG.EQ.1) then + + flag=0 + loc1=1 + do idep=1,nbdepl + if (catdef(idep) .le. 20.) loc1=idep + enddo + + loc3=1 + do idep=1,nbdepl -1 + if ((ar1(idep) >= 0.0001).and.(catdef(idep) <= cdcr1)) loc3=idep + 1 + enddo + + if (loc3.le.loc1+1) then + loc1=MIN(loc3-4,loc1-4) + loc1=MAX(1,loc1) + endif + + !c below is what was used for no regression, but it's not equivalent to the + !c IDL program + loc2=AINT(loc1-1+(loc3-loc1)*3./5.)+1 + + w1=ar1(loc1) + w2=ar1(loc2) + w3=ar1(loc3) + + if(w3.eq.0.)then +95 loc3=loc3-1 + if(loc3.eq.loc2)loc2=loc2-1 + w3=ar1(loc3) + w2=ar1(loc2) + if(w3.eq.0.)goto 95 + endif + w4=0. + + if((loc1.ge.loc2).or.(loc2.ge.loc3))then + loc1=10 + loc2=14 + loc3=18 + endif + +115 x1=catdef(loc1) + x2=catdef(loc2) + x3=catdef(loc3) + w1=ar1(loc1) + w2=ar1(loc2) + w3=ar1(loc3) + + if (bug) then + write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 + write(*,*) 'x1,x2,x3=',x1,x2,x3 + write(*,*) 'w1,w2,w3=',w1,w2,w3 + endif + + y0=w4 + f1=(1.-w1)/(w1-y0)/x1 + f2=(1.-w2)/(w2-y0)/x2 + f3=(1.-w3)/(w3-y0)/x3 + g1=(1.-y0)/(w1-y0) + g2=(1.-y0)/(w2-y0) + g3=(1.-y0)/(w3-y0) + df=f2-f1 + dg=g2-g1 + dx=x2-x1 + bf=f1-x1*df/dx + bg=g1-x1*dg/dx + + ars1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) + ars2 = bf+ars1*bg + ars3 = (df+ars1*dg)/dx + + delta=ars2*ars2-4*ars3 + upval=1.+200.*ars1 + loval=1.+200.*ars2+40000.*ars3 + z1=0. + z2=0. + + if (delta .ge. 0.) then !if 8 + z1=(-ars2-SQRT(delta))/2./ars3 + z2=(-ars2+SQRT(delta))/2./ars3 + endif + + if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & + (z2 .gt. 0. .and. z1 .lt. cdcr1) .or. & + ((upval/loval).lt.-.01)) then !if 7 + z1=0. + z2=0. + if (loc1 .eq. 10) then + loc1=1 +1 else + loc1=1 + do idep=1,nbdepl + if (catdef(idep) .gt. 60.) then + loc1=idep + if(loc1.ge.loc3-1)then + ! write(*,*)'Loc1 exceeded loc3 in 2nd attempt' + loc1=loc3-5 + endif + goto 46 + endif + enddo + endif +46 loc2=loc1+AINT(float(loc3-loc1)*3./5.)+1 + if(loc2.ge.loc3)loc2=loc3-1 + loc2save=loc2 + INC=1 + DEC=0 + +47 w1=ar1(loc1) + w2=ar1(loc2) + x1=catdef(loc1) + x2=catdef(loc2) + + if (bug) then + write(*,*) 'z1,z2=',z1,z2,' -> ar1, 2nd try' + write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 + write(*,*) 'x1,x2,x3=',x1,x2,x3 + write(*,*) 'w1,w2,w3=',w1,w2,w3 + endif + + f1=(1.-w1)/(w1-y0)/(x1 + 1.e-20) + f2=(1.-w2)/(w2-y0)/(x2 + 1.e-20) + g1=(1.-y0)/(w1-y0 + 1.e-20 ) + g2=(1.-y0)/(w2-y0 + 1.e-20) + df=f2-f1 + dg=g2-g1 + dx=x2-x1 + bf=f1-x1*df/dx + bg=g1-x1*dg/dx + + ars1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) + ars2 = bf+ars1*bg + ars3 = (df+ars1*dg)/dx + delta=ars2*ars2-4*ars3 + upval=1.+200.*ars1 + loval=1.+200.*ars2+40000.*ars3 + + if (delta .ge. 0.) then !if 6 + z1=(-ars2-SQRT(delta))/2./ars3 + z2=(-ars2+SQRT(delta))/2./ars3 + end if + + if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & + (z2 .gt. 0. .and. z1 .lt. cdcr1) .or. & + ((upval/loval).lt.-.01)) then !if 5 + !c Sarith --- + z1=0. + z2=0. + IF(INC.EQ.1)loc2=loc2+1 + IF(DEC.EQ.1)LOC2=LOC2-1 + if(inc.eq.1)then !if 4 + if(loc2.ge.loc3)then !if 3 + ! WRITE(*,*)'INCREASING LOC2 FAILED' + INC=0 + DEC=1 + loc2=loc2save + else + adjust=ADJUST+1 + goto 47 + end if !if 3 + endif !if 4 + + if(dec.eq.1)then !if 2 + if(loc2.eq.loc1)then !if 1 + ! WRITE(*,*)'Decreasing too failed' + INC=1 + DEC=0 + ars1=9999. !ars1old + ars2=9999. !ars2old + ars3=9999. !ars3old + ! write(*,*) 'AR1: PROBLEM for pfc=',pfc + else + adjust=ADJUST+1 + !c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST + goto 47 + end if !if 1 + endif !if 2 + endif !if 5 + !c endif !if 6 + endif !if 7 + + !c endif !if 8 + flag=0 + call curve1(ars1,ars2,ars3,cdcr2,flag) + + IF (FLAG.EQ.1)then + ! WRITE(*,*)'Curve problem in the catchment pfc=',pfc + ars1=9999. + ars2=9999. + ars3=9999. + ! write(*,*) 'Pick values from icatch-1' + flag=0 + end if + endif + + adjust=0 + + if (bug) write(*,*) 'ar1 adjustment ok' + + !c**** WMIN adjustment: 3 points + limit in INF = wmin0 + + if (bug) write(*,*) 'STARTING WMIN' + + w4=wmin0 + y0=w4 + + ! write(*,*) 'wmin=',(wmin(idep),idep=1,50) + + loc1=1 + do idep=1,nbdepl + if (catdef(idep) <= 10.) loc1=idep + enddo + + loc3=1 + do idep=1,nbdepl - 2 + if ((wmin(idep) >= wmin0).and.(catdef(idep) <= cdcr1)) loc3=idep + 2 + enddo + + loc2=loc1 + 2 + do idep=1,nbdepl -1 + if ((wmin(idep) >= wmin0).and.(catdef(idep) <= cdcr1/2.))loc2=idep + 1 + enddo + + !c For global catch + INC=1 + DEC=0 + + if(loc3.eq.loc2)loc2=loc2-2 + if(loc2 <= loc1) loc1= loc1-2 +44 loc2save=loc2 + if(loc1 < 1) then + loc1 =1 + loc2 =2 + loc3 =3 + endif + + w1=wmin(loc1) + w2=wmin(loc2) + w3=wmin(loc3) + x1=catdef(loc1) + x2=catdef(loc2) + x3=catdef(loc3) + + if (bug) then + write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 + write(*,*) 'x1,x2,x3=',x1,x2,x3 + write(*,*) 'w1,w2,w3,w4=',w1,w2,w3,w4 + endif + + f1=(1.-w1)/(w1-y0)/x1 + f2=(1.-w2)/(w2-y0)/x2 + f3=(1.-w3)/(w3-y0)/x3 + g1=(1.-y0)/(w1-y0) + g2=(1.-y0)/(w2-y0) + g3=(1.-y0)/(w3-y0) + df=f2-f1 + dg=g2-g1 + dx=x2-x1 + bf=f1-x1*df/dx + bg=g1-x1*dg/dx + + arw1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) + arw2 = bf+arw1*bg + arw3 = (df+arw1*dg)/dx + arw4 = y0 + + !c wmin=arw4+(1.-arw4)*(1.+arw1*catdef(idep)) + !c /(1.+arw2*catdef(idep)+arw3*catdef(idep)*catdef(idep)) + !c we want to check the roots of the denominator + + delta=arw2*arw2-4*arw3 + + if (delta .ge. 0.) then !if 8 + + z1=(-arw2-SQRT(delta))/2./arw3 + z2=(-arw2+SQRT(delta))/2./arw3 + + if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & + (z2 .gt. 0. .and. z1 .lt. cdcr1)) then !if 7 + + w1_0=w1 + w1=(1.+w1_0)/2. + x1=x1/4. + + ! if (gnu .eq. 3.26/1.5) then + ! w1=(1.+w1_0)/3. ! already difficult + ! w3=wmin(nint(cdcr1)) ! with gnu=3.26 + ! x3=catdef(nint(cdcr1)) + ! f3=(1.-w3)/(w3-y0)/x3 + ! g3=(1.-y0)/(w3-y0) + ! endif + + f1=(1.-w1)/(w1-y0)/x1 + g1=(1.-y0)/(w1-y0) + df=f2-f1 + dg=g2-g1 + dx=x2-x1 + bf=f1-x1*df/dx + bg=g1-x1*dg/dx + + if (bug) then + write(*,*) 'z1,z2=',z1,z2,' -> wmin, 2nd try' + write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 + write(*,*) 'x1,x2,x3=',x1,x2,x3 + write(*,*) 'w1,w2,w3=',w1,w2,w3 + write(*,*) 'wmin0=',wmin0 + endif + + arw1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) + arw2 = bf+arw1*bg + arw3 = (df+arw1*dg)/dx + arw4 = y0 + + delta=arw2*arw2-4*arw3 + + if (delta .ge. 0.) then !if 6 + z1=(-arw2-SQRT(delta))/2./arw3 + z2=(-arw2+SQRT(delta))/2./arw3 + + if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & + (z2 .gt. 0. .and. z1 .lt. cdcr1)) then !if 5 + !c Sarith --- + IF(INC.EQ.1)loc2=loc2+1 + IF(DEC.EQ.1)LOC2=LOC2-1 + if(inc.eq.1)then !if 4 + if(loc2.eq.loc3)then !if 3 + ! WRITE(*,*)'INCREASING LOC2 FAILED: WMIN' + INC=0 + DEC=1 + loc2=loc2save + else + adjust=ADJUST+1 + !c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST + goto 44 + end if !if 3 + endif !if 4 + if(dec.eq.1)then !if 2 + if(loc2.eq.loc1)then !if 1 + ! WRITE(*,*)'Decreasing too failed: WMIN' + INC=1 + DEC=0 + + arw1=9999. + arw2=9999. + arw3=9999. + arw4=9999. + + else + adjust=ADJUST+1 + !c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST + goto 44 + end if !if 1 + endif !if 2 + endif !if 5 + endif !if 6 + + endif !if 7 + endif !if 8 + adjust=0 + ! endif ! pfc=12821 + flag=0 + + call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) + + IF (FLAG.EQ.1) THEN + arw1=9999. !arw1old + arw2=9999. !arw2old + arw3=9999. !arw3old + arw4=9999. !arw4old + flag=0 + endif + + if(arw1==9999.) then + ! Singular Value Decomposition + + w4=wmin0 + y0=w4 + + loc1=1 + loc3=nbdepl + + mp = loc3-loc1+1 + + if(mp.lt.3)then + + write(*,*)'WMIN Note: not sufficient points MP = ',mp + print *,w4,cdcr1,catdef(loc3),wmin(loc3) + arw1 = 9999. + arw2 = 9999. + arw3 = 9999. + arw4 = 9999. + else + + mp = 1 + istart =1 + w4 = wmin(istart) + + if(w4 <=0) then + do idep=2,nbdepl + if(wmin(idep) > 0.) istart = idep + if(wmin(idep) > 0.) exit + enddo + endif + + w4 = wmin(istart) + + do idep=istart+1,nbdepl + ! if(wmin(idep).lt.w4) then + if((wmin(idep) - w4).lt.0.0005) then + w4 = wmin(idep) + mp = mp +1 + endif + enddo + loc3 = mp + allocate(A(mp,3)) + allocate(AP(mp,3)) + allocate(B(mp)) + allocate(BP(mp)) + smooth = .false. + do idep=istart,nbdepl-1 + if(catdef(idep).le.cdcr1+10.) then + if((wmin(idep) - wmin(idep +1)) < -0.01) smooth = .true. + endif + enddo + if(smooth) then + wminsave = wmin + ! Apply filter to input data + do i=istart, nbdepl-nr + wmin(i)=0. + do j=1, nl+nr+1 + if (i+savgol_ind(j).gt.0) then !skip left points that do not exist + wmin(i)=wmin(i)+savgol_coeff(j)*wminsave(i+savgol_ind(j)) + endif + end do + enddo + wmin (istart:istart+4) = wminsave (istart:istart+4) + + endif + + j = 1 + w4 = wmin(istart) + do isvd=1,size(wmin) + if (j <= mp) then + if(isvd == 1) then + wbrac=(wmin(isvd + istart -1)-y0)/(1.-y0 + 1.e-20) + A(j,1)=catdef(isvd + istart -1) + A(j,2)=-catdef(isvd + istart -1)*wbrac + A(j,3)=-wbrac*((catdef(isvd + istart -1))**2.) + B(j)=wbrac-1. + j = j + 1 + else + if((wmin(isvd + istart -1).lt.w4).and.(wmin(isvd + istart -1).gt.y0)) then + wbrac=(wmin(isvd + istart -1)-y0)/(1.-y0 + 1.e-20) + A(j,1)=catdef(isvd + istart -1) + A(j,2)=-catdef(isvd + istart -1)*wbrac + A(j,3)=-wbrac*((catdef(isvd + istart -1))**2.) + B(j)=wbrac-1. + w4 = wmin(isvd + istart -1) + j = j + 1 + endif + endif + endif + end do + + j = j -1 + mp = j + ap => a (1:j,:) + bp => b (1:j) + ap(j,1) = catdef(nbdep) + ap(j,2) = 0. + ap(j,3) = 0. + bp (j) = -1. + + call svdcmp(ap,mp,3,w,v) + + sdmax=0. + do j=1,3 + if(w(j).gt.sdmax)sdmax=w(j) + end do + + sdmin=sdmax*1.0e-6 + do j=1,3 + if(w(j).lt.sdmin)w(j)=0. + end do + + call svbksb(ap,w,v,mp,3,bp,ans) + + arw1 = real(ans(1)) + arw2 = real(ans(2)) + arw3 = real(ans(3)) + arw4 = y0 + + !c wmin=arw4+(1.-arw4)*(1.+arw1*catdef(idep)) + !c /(1.+arw2*catdef(idep)+arw3*catdef(idep)*catdef(idep)) + !c we want to check the roots of the denominator + + adjust=0 + flag=0 + + call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) + + IF (FLAG.EQ.1) THEN + ! WRITE(*,*)'Curve2 problem in the catchment:pfc=',pfc + + arw1 = 9999. + arw2 = 9999. + arw3 = 9999. + arw4 = 9999. + + flag=0 + end if + deallocate (A, B ) + NULLIFY (AP, BP) + end if + endif + + if(present(dbg_unit)) then + write (dbg_unit,*) ars1,ars2,ars3 + write (dbg_unit,*) arw1,arw2,arw3,arw4 + endif + + if (bug) write(*,*) 'wmin adjustment ok' + + !c**** SHAPE PARAMETER ADJUSTMENT: with a straight if coeskew > 0.25 + !c with 2 segments if not + + if (bug) write(*,*) 'STARTING SHAPE' + + x3=catdef(nbdepl) + w3=aa(nbdepl) + x1=0. + + if (coeskew .lt. 0.25) then + w1=0.1 + loc2=20 + do idep=1,nbdepl + if (catdef(idep) .gt. ref1) then + loc2=idep + goto 45 + endif + enddo +45 x2=catdef(loc2) + w2=aabis(loc2) + ara1 = (w1-w2)/(x1-x2) + ara2 = w1-ara1*x1 + ara3 = (w2-w3)/(x2-x3) + ara4 = w2-ara3*x2 + else + w1=1. + x2=x1 + w2=w1 + ara3 = (w2-w3)/(x2-x3) + ara4 = w2-ara3*x2 + ara1 = ara3 + ara2 = ara4 + endif + + if (bug) write(*,*) 'x1,w1,x2,w2,x3,w3',x1,w1,x2,w2,x3,w3 + + !**** RMSE checking: on ar1, ar2, swsrf2 and rzeq + + do idep=1,nbdepl + if(catdef(idep) <= cdcr1) then + nar1(idep)=AMIN1(1.,AMAX1(0.,(1.+ars1*catdef(idep)) & + /(1.+ars2*catdef(idep) & + +ars3*catdef(idep)*catdef(idep)))) + + nwm=AMIN1(1.,AMAX1(0.,arw4+(1.-arw4)* & + (1.+arw1*catdef(idep)) & + /(1.+arw2*catdef(idep) & + +arw3*catdef(idep)*catdef(idep)))) + + !c we have to first determine if there is one or two segments + if (ara1 .ne. ara3) then + cdi=(ara4-ara2)/(ara1-ara3) + else + cdi=0. + endif + + if (catdef(idep) .ge. cdi) then + shape=ara3*catdef(idep)+ara4 + else + shape=ara1*catdef(idep)+ara2 + endif + shape =AMIN1(40.,shape) + area1=exp(-shape*(1.-nwm))*(shape*(1.-nwm)+1.) + + !c the threshold for truncation problems is higher than the "usual" + !c E-8 to E-10, because it plays together with the uncertainties coming + !c from the approximation of the parameters nwm, nar1 and shape. + if (area1 .ge. 1.-1.E-8) then + nar1(idep)=1. + nar2(idep)=0. + nar3(idep)=0. + nmean2(idep)=0. + nmean3=0. + neq(idep)=1. + else + + if (nwm .gt. wpwet) then + nar2(idep)=1.-nar1(idep) + else + nar2(idep)=AMAX1(0.,((shape*(wpwet-nwm)+1.) & + *exp(-shape*(wpwet-nwm)) & + - (shape*(1.-nwm)+1.)*exp(-shape*(1.-nwm))) & + * (1.-nar1(idep))/(1.-area1)) + endif + + nar3(idep)=1.-nar1(idep)-nar2(idep) + + if (nar3(idep) .lt. 1.E-8) then ! for nwm le wpwet + + nmean2(idep)=AMAX1(0.,AMIN1(1.,(nwm + 2./shape + & + shape*exp(-shape*(1.-nwm))* & + (nwm+nwm/shape-1.-2./shape-2./(shape*shape))) & + /(1.-area1))) + nmean3=0. + + else + + !c WARNING: I think the two values below are false. + !c But it is never used in this context, because nwm > wpwet !! + nmean2(idep)=AMAX1(0.,AMIN1(1.,-shape*(exp(-shape*& + (wpwet-nwm))* (nwm*wpwet & + +nwm/shape-wpwet*wpwet & + -2.*wpwet/shape-2./(shape*shape)) & + - exp(-shape*(1.-nwm))* & + (nwm+nwm/shape-1.-2./shape-2./(shape*shape)))& + * (1.-nar1(idep))/(1.-area1) / (nar2(idep)+1.e-20))) + + nmean3=AMAX1(0.,AMIN1(1.,(nwm+2./shape + & + shape*exp(-shape*(wpwet-nwm))* & + (nwm*wpwet+nwm/shape-wpwet & + *wpwet-2.*wpwet/shape & + -2./(shape*shape))) * (1.-nar1(idep)) & + /(1.-area1)/(nar3(idep) + 1.e-20))) + endif + + neq(idep)=nar1(idep)+nar2(idep)*nmean2(idep) & + +nar3(idep)*nmean3 + + if (area1 .ge. 1.-1.E-5) then + nmean2(idep)=1. + nmean3=0. + neq(idep)=1. + endif + + endif + endif + enddo + + if (bug) write(*,*) 'shape adjustment ok' + !c + !c RMSE + + !c ERR1 + icount=0 + iref=0 + sum=0. + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + tabact(i)=0. + tabfit(i)=0. + endif + enddo + + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + if (catdef(i) .gt. lim) then + icount=icount+1 + sum=sum+ar1(i) + tabfit(icount)=nar1(i) + tabact(icount)=ar1(i) + endif + endif + enddo + + if(icount.gt.1) then + sum=sum/icount + call RMSE(tabact,tabfit,icount,err1) + taberr1=err1 + normerr1=err1/sum + endif + !c ERR2 + icount=0 + iref=0 + sum=0. + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + tabact(i)=0. + tabfit(i)=0. + endif + enddo + + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + if (catdef(i) .gt. lim) then + icount=icount+1 + sum=sum+ar2(i) + tabfit(icount)=nar2(i) + tabact(icount)=ar2(i) + endif + endif + enddo + + if(icount.gt.1) then + sum=sum/icount + call RMSE(tabact,tabfit,icount,err2) + taberr2=err2 + normerr2=err2/sum + endif + + !c ERR3 + icount=0 + iref=0 + sum=0. + do i=1,nbdep + if(catdef(i) <= cdcr1) then + tabact(i)=0. + tabfit(i)=0. + endif + enddo + + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + if (catdef(i) .gt. lim) then + icount=icount+1 + sum=sum+swsrf2(i) + tabfit(icount)=nmean2(i) + tabact(icount)=swsrf2(i) + endif + endif + enddo + + if(icount.gt.1) then + sum=sum/icount + call RMSE(tabact,tabfit,icount,err3) + taberr3=err3 + normerr3=err3/sum + endif + !c ERR4 + icount=0 + iref=0 + sum=0. + do i=1,nbdepl + tabact(i)=0. + tabfit(i)=0. + enddo + + do i=1,nbdepl + if(catdef(i) <= cdcr1) then + if (catdef(i) .gt. lim) then + icount=icount+1 + sum=sum+rzeq(i) + tabfit(icount)=neq(i) + tabact(icount)=rzeq(i) + endif + endif + enddo + + if(icount.gt.1) then + sum=sum/icount + call RMSE(tabact,tabfit,icount,err4) + taberr4=err4 + normerr4=err4/sum + endif + END SUBROUTINE SAT_PARAM + ! + + ! ****************************************************************** + + !c + SUBROUTINE CURVE1(ars1,ars2,ars3,cdcr2,flag) + REAL ars1,ars2,ars3,y,x,yp,cdcr2 + INTEGER i,flag + !c + yp=1. + if (abs(ars1+ars2+ars3).le.1.e25) then + do i=0,CEILING(cdcr2) + x=float(i) + if(x > cdcr2) x = cdcr2 + y=(1.+ars1*x)/(1.+ars2*x+ars3*x*x + 1.e-20) + if((y.gt.0.0).and.(((yp -y) .lt. -1.e-4).or.(y.gt.1.)))then + flag=1 + goto 99 + endif + yp=y + end do +99 continue + else + flag=1 + endif + + end SUBROUTINE CURVE1 + + + ! ****************************************************************** + + SUBROUTINE CURVE2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) + REAL arw1,arw2,arw3,arw4,y,x,yp,cdcr1, wpwet + INTEGER i,flag + !c + yp=1. + if (abs(arw1+arw2+arw3+arw4).le.1.e25) then + do i=0,CEILING(cdcr1) + x=float(i) + if(x > cdcr1) x = cdcr1 + y=arw4+(1.-arw4)*(1.+arw1*x)/(1.+arw2*x+arw3*x*x + 1.e-20) + if ((y .lt. wpwet).or.((yp -y) .lt. -1.e-4).or.(y.gt.1.)) then + flag=1 + goto 99 + endif + yp=y + end do +99 continue + else + flag=1 + endif + end SUBROUTINE CURVE2 + + ! ****************************************************************** + + subroutine tgen ( & + TOPMEAN,TOPVAR,TOPSKEW, & + STO,ACO,COESKEW) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! c + ! The difference between tgen4 and tgen3 is that tgen4 deals with arrays c + ! of topmean, topvar and topskew and 2-dim arrays of st and ac. c + ! c + ! This routine determine the theoretical gamma distribution for the c + ! soil-topographic indexes (Sivapalan et al., 1987), knowing the three c + ! first moments, the min and the max of the observed topographic indexes c + ! in a given catchment. c + ! c + ! Routine from Dave Wolock. c + ! Modified by Agnes (11-06-98): we don't use min and max anymore, and c + ! this strongly improves the behavior for negative skewnesses. It also c + ! improves in general the matching of the moments. c + ! c + ! We also add a correction on the skewness to have gamma distributions c + ! that start and end from the x-axis. It is based on the fact that if c + ! TOPETA=1, the gamma is an exponential distribution, and if TOPETA<1, c + ! then the gamma distribution increases towards the infinite when x c + ! decreases towards 0. c + ! To eliminate some numerical pb due to teh discretization of the gamma c + ! distribution, we choose skewness=MAX(MIN(1.9, skewness),-1.6) c + ! c + ! WE MAY NEED TO COMPUTE IN DOUBLE RESOLUTION !!!! BECAUSE OF THE SMALL c + ! BIN WIDTH + ! c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + real, parameter :: VALMAX=50. + REAL, intent (in) :: TOPMEAN,TOPVAR,TOPSKEW + REAL, intent (out) :: COESKEW + REAL, dimension (NAR), intent (out) :: STO,ACO + + INTEGER I + REAL ST(NAR),AC(NAR) + REAL TOPETA,TOPLAM,TOPSCAL,GAMLN,SCALE,ACLN + real cumac, cum2,cum3 + + !------------------------------------------------------------------------- + + ! topmean is the mean of the ln(a/tanB) distribution + ! topvar is the variance (2nd moment centered around the mean) of the ... + ! topskew is the skew (3rd moment centerd around the mean) of the ... + ! compute the coefficient of skew or skewness (coeskew) + + COESKEW=TOPSKEW/TOPVAR**1.5 + if (coeskew .ge. 0.) then + COESKEW=AMAX1(0.005, AMIN1(1.9, COESKEW)) + else + COESKEW=AMAX1(-1.6, AMIN1(-0.005, COESKEW)) + endif + + ! compute the gamma parameters, eta (topeta) and lambda (toplam), and topscal + ! which is the translation parameter + + TOPETA=4./COESKEW**2 + TOPLAM=SQRT(TOPETA)/SQRT(TOPVAR) + TOPSCAL=TOPMEAN-TOPETA/TOPLAM + + ! evaluate the gamma function + + CALL GAMMLN (TOPETA,GAMLN) + + CUMAC=0.0 + + ! compute the frequency distribution of ln(a/tanB) + ! st(i) are the values of ln(a/tanB) + ! ac(i) are the relative frequency values (they should sum to 1) + + DO I=1,NAR + + ST(I)=(FLOAT(I)-0.95)*(VALMAX-TOPSCAL)/FLOAT(NAR)+TOPSCAL + SCALE=ST(I)-TOPSCAL + + ! below is the logarithmic form of the gamma distribution; this is required + ! because the numerical estimate of the logarithm of the gamma function + ! is more stable than the one of the gamma function. + + ACLN=TOPETA*ALOG(TOPLAM)+(TOPETA-1.)*ALOG(SCALE) & + -TOPLAM*SCALE-GAMLN + + IF(ACLN.LT.-10.) THEN + AC(I)=0. + ELSE + AC(I)=EXP(ACLN) + ENDIF + + CUMAC=CUMAC+AC(I) + + ENDDO + + ! we want the relative frequencies to sum 1. + + IF (CUMAC.eq.0.) THEN + ! write(*,*) 'distrib sum=',CUMAC + stop + endif + CUM2=0. + DO I=1,NAR + AC(I) = AC(I) / CUMAC + CUM2=CUM2+AC(I) + ENDDO + + ! if the real distribution of the topographic indices is negativeley skewed, + ! we symetrize the gamma distribution (depending on coeskew**2 and always + ! positively skewed), centering on topmean, which preserves topmean and + ! topvar, and re-establishes a negative skewness. + + IF (COESKEW.LT.0.) then + + do i=1,nar + STO(I)=2.*TOPMEAN-ST(I) + ACO(I)=AC(I) + + enddo + ELSE + ! if (n .eq. idmax) then + ! write(*,*) 'last catchment' + ! endif + do i=1,nar + STO(I)=ST(-I+NAR+1) + ACO(I)=AC(-I+NAR+1) + enddo + ENDIF + + ! sum=0. + ! do i=1,nar + ! sum=sum+sto(i)*aco(i) + ! end do + + ! sum=0. + ! do i=1,nar + ! sum=sum+aco(i) + ! end do + + + END subroutine tgen + + ! ******************************************************************** + + SUBROUTINE GAMMLN (XX,GAMLN) + + DOUBLE PRECISION :: COF(6),STP,HALF,ONE,FPF,X,TMP,SER + REAL, intent(in) :: XX + REAL, intent(out) :: GAMLN + integer :: j + + DATA COF /76.18009173D0,-86.50532033D0,24.01409822D0, & + -1.231739516D0,.120858003D-2,-.536382D-5/ + STP = 2.50662827465D0 + HALF= 0.5D0 + ONE = 1.0D0 + FPF = 5.5D0 + + X=XX-ONE + TMP=X+FPF + TMP=(X+HALF)*LOG(TMP)-TMP + SER=ONE + + DO J=1,6 + X=X+ONE + SER=SER+COF(J)/X + END DO + + GAMLN=TMP+LOG(STP*SER) + + END SUBROUTINE GAMMLN + + ! ******************************************************************** + + SUBROUTINE FUNCIDEP( & + NAR0,IDEP, &!I + BEE,PSIS,POROS,COND,RZDEP,WPWET, &!I + VALX,PX,COESKEW,TIMEAN,SUMA, &!I + CATDEF,AR1,WMIN,AA,AABIS, &!O + AR2,AR3,SWSRF2,SWSRF3,RZEQ) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c This program returns the eight parameters for the areal fractioning c + !c c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + integer, intent (in) :: NAR0,idep + REAL, intent (in) :: BEE, PSIS, POROS, COND, RZDEP, WPWET, COESKEW + REAL, intent (inout) :: VALX(NAR), PX(NAR),TIMEAN,SUMA + ! logical, intent(in) :: bug + real, dimension (nbdep), intent (inout) :: CATDEF,AR1,WMIN,AA, & + AABIS,AR2,AR3,SWSRF2,SWSRF3,RZEQ + INTEGER :: width, nref, nind,nmax,indmin,locmax,shift,ord,locmin,ordref + integer :: indimax10,indmin0,k,n,n1,n2 + real dx,zbar + + real test,term1,term2,sum + real zdep(nar),locdef(nar),wrz(nar),frcunsat + real valtest(nbdep,nar),ptest(nbdep,nar),denstest(nbdep,nar) + real dtest(nbdep,nar),cump + real x1,x2,y1,y2,wa,wb + real densaux(nar),densaux2(nar),densmax,aux10 + real :: dz, sumdef + !c------------------------------------------------------------------------- + + !c integral(f(x)dx)=1. for a pdf + !c here px=f(x)dx + dx=valx(1)-valx(2) + + if (bug) write(*,*) 'IDEP=',IDEP,' dx=',dx + + !c the loops over idmax and nbdep are initiated in sta_params4.f + + zbar=float(idep-10)*slice ! zdep in meters + + !c**** Compute array of water table depths: + do k=1,nar0 + term1=(1/gnu)*(valx(k)-timean) + zdep(k)=AMAX1(0.,zbar-term1) + enddo + + !c variable change must be reflected in dx + dz=dx/gnu + + if (bug) write(*,*) 'funcidep: ok1' + + !c**** Compute array of moisture deficits: + do k=1,nar0 + term1=(psis-zdep(k))/psis + term1=term1**(1.-1./bee) + term2=-psis*(bee/(bee-1.))*(term1-1.) + locdef(k)=zdep(k)-term2 + enddo + + !c**** Add deficits to produce catdef: + sumdef=0. + do k=1,nar0 + sumdef=sumdef+locdef(k)*px(k) + enddo + catdef(idep)=poros*1000.*sumdef/suma + + if (bug) write(*,*) 'funcidep: ok2' + + !c**** Compute array of root zone moisture (degree of wetness in root zone): + do k=1,nar0 + term1=((psis-zdep(k))/psis) & + **(1.-1./bee) + if(zdep(k).le.0.) then + wrz(k)=1. + elseif(zdep(k)-rzdep.lt.0.) then + term2=(-psis/zdep(k))*(bee/(bee-1.)) & + *(term1-1.) + frcunsat=zdep(k)/rzdep + wrz(k)=frcunsat*term2+(1.-frcunsat)*1. + else + term2=((psis-zdep(k)+rzdep) & + /psis)**(1.-1./bee) + wrz(k)=(-psis/rzdep)*(bee/ & + (bee-1.))*(term1-term2) + endif + + enddo + + if (bug) write(*,*) 'funcidep: ok3' + + !c**** compute the densities and dx + !c**** we use a usefull property that is due to the construction of the + !c**** gamma distribution in tgen3.f : this distribution is continuous, + !c**** with decreasing values on ln(a/tanb) when n goes from 1 to nar0 + + !c first we gather in the same bin all the bins with values ge 1 + nref=1 + nind=1 + ptest(idep,1)=0. + do k=1,nar0 + if (wrz(k) .eq. 1.) then + nref=nref+1 + ptest(idep,1) = ptest(idep,1) + px(k) + endif + enddo + if (nref .gt. 1) then + nind=2 + valtest(idep,1)=1. + endif + nmax=nar0-nref+nind + if (bug) write(*,*) 'nmax,nind,nar0,nref=',nmax,nind,nar0,nref + + !c definition of the probabilities ptest + if (nmax .eq. 1) then ! all the bins have values ge 1 + dtest(idep,1) = 0.0001 + ptest(idep,1) = 1. + else ! distribution in ar2/ar3 + do n=0,nmax-nind + valtest(idep,nind+n)=wrz(nref+n) + ptest(idep,nind+n)=px(nref+n) + enddo + + !c we have to define dtest, the size of each bin + if (nmax .eq. 2) then + dtest(idep,2) = valtest(idep,1)-valtest(idep,2) + dtest(idep,1) = dtest(idep,2)/2. + else ! nmax .gt. 2 + do n=2,nmax-1 + dtest(idep,n)=(valtest(idep,n-1)-valtest(idep,n+1))/2. + enddo + dtest(idep,1) = dtest(idep,2)/2. + dtest(idep,nmax) = dtest(idep,nmax-1) + endif + endif + + if (bug) write(*,*) 'funcidep: ok4' + + !c we can now define the probability density: denstest=ptest/dtest + !c where ptest is the probability and dtest the size of the bin + do n=1,nmax + if (ptest(idep,n) .eq. 0.) then + denstest(idep,n)=0. + else + denstest(idep,n)=ptest(idep,n)/dtest(idep,n) + endif + enddo + + if (bug) write(*,*) 'funcidep: ok5' + + !c NOW we can estimate the parameters for the approximated distrib + !c from the actual distrib + + !c 1. AR1=saturated area and AR2 and AR3 + averages of the RZ wetness + !c in the different fractions + + ar1(idep)=0. + ar2(idep)=0. + ar3(idep)=0. + swsrf3(idep)=0. + swsrf2(idep)=0. + rzeq(idep)=0. + + if(valtest(idep,1).eq.1.) ar1(idep)=dtest(idep,1)*denstest(idep,1) + + if (nmax .gt. 1) then + do n=nind,nmax + if (valtest(idep,n) .lt. wpwet) then + ar3(idep)=ar3(idep)+denstest(idep,n)*dtest(idep,n) + swsrf3(idep)=swsrf3(idep)+valtest(idep,n)* & + denstest(idep,n)*dtest(idep,n) + else + ar2(idep)=ar2(idep)+denstest(idep,n)*dtest(idep,n) + swsrf2(idep)=swsrf2(idep)+valtest(idep,n)* & + denstest(idep,n)*dtest(idep,n) + endif + enddo + endif + + test=ar1(idep)+ar2(idep)+ar3(idep) + if (test .gt. 1.+1.e-5 .or. test .lt. 1.-1.e-5) then + ! write(*,*) 'PROBLEM at depth ',zbar + ! write(*,*) ' ar1+ar2+ar3=',test + ! write(*,*) ' ar1=',ar1(idep),' ar2=',ar2(idep),' ar3=', & + ! ar3(idep) + endif + + ar1(idep)=ar1(idep)/test + ar2(idep)=ar2(idep)/test + ar3(idep)=ar3(idep)/test + if (ar2(idep) .ne. 0.) swsrf2(idep)=swsrf2(idep)/ar2(idep) + if (ar3(idep) .ne. 0.) swsrf3(idep)=swsrf3(idep)/ar3(idep) + + rzeq(idep)=ar1(idep)+ar2(idep)*swsrf2(idep)+ar3(idep)*swsrf3(idep) + + if (bug) write(*,*) 'funcidep: ok6' + + !c 2. Maximum density -> shape parameter + !c -> wmin + + locmax=3 + shift=15 + ordref=1 + do n=1,nmax + densaux2(n)=denstest(idep,n) + enddo + + if (nmax .ge. shift*2) then + + !c we start with sliding mean to facilitate the search for the maximum + + ord=MIN(ordref,nmax/shift) + + call smtot(densaux2,nmax,ord,densaux) + ! print *,nmax,ord,shift,densaux(shift-14),shift-14,size(densaux) + do n=nmax,shift,-1 + if (densaux(n) .gt. densaux(n-1) .and. & + densaux(n) .gt. densaux(n-2) .and. & + densaux(n) .gt. densaux(n-3) .and. & + densaux(n) .gt. densaux(n-4) .and. & + densaux(n) .gt. densaux(n-5) .and. & + densaux(n) .gt. densaux(n-6) .and. & + densaux(n) .gt. densaux(n-7) .and. & + densaux(n) .gt. densaux(n-8) .and. & + densaux(n) .gt. densaux(n-9) .and. & + densaux(n) .gt. densaux(n-10) .and. & + densaux(n) .gt. densaux(n-11) .and. & + densaux(n) .gt. densaux(n-12) .and. & + densaux(n) .gt. densaux(n-13) .and. & + densaux(n) .gt. densaux(n-14))then ! .and. & + ! densaux(n) .gt. densaux(n-15)) then + locmax=n + goto 30 + endif + enddo + + else + + aux10=-9999. + indimax10=3 + do n=1,nmax + if (densaux2(n) .gt. aux10) then + aux10=densaux2(n) + indimax10=n + endif + enddo + locmax=MAX(3,indimax10) + ! add protection here in case nmax <3 . why 3 ? + if (locmax > nmax) locmax = nmax + endif ! if (nmax .ge. shift+1) +30 densmax=denstest(idep,locmax) + aa(idep)=exp(1.)*densmax + + if (bug) write(*,*) 'funcidep: ok7' + + !c WMIN=lowest value where the density is strictly gt densmax/100. + + indmin=1 + indmin0=0 + do n=1,nmax + if (denstest(idep,n) .gt. 0.) indmin0=n + if (denstest(idep,n) .gt. densmax/100. .and. & + valtest(idep,n) .lt. valtest(idep,locmax)) indmin=n + enddo + if (indmin .eq.0) indmin=indmin0 + + if (indmin .le. 2) then + wmin(idep) = 0.99999 + else + x1=valtest(idep,indmin) + wmin(idep)=x1 + endif + + if (bug) write(*,*) 'funcidep: ok8; first wmin=',wmin(idep) + + !c for negative or low coeskew the previous wmin doesn't give good results... + !c wmin is higher !!! + + if (coeskew .lt. 1. ) then + + if (locmax .gt. 3 .and. indmin .ge. locmax+4) then + n2=MAX(locmax+1,(indmin-locmax)/2+locmax) + x2=valtest(idep,n2) + y2=denstest(idep,n2) + n1=locmax + x1=valtest(idep,n1) + y1=denstest(idep,n1) + wa=(y2-y1)/(x2-x1) + wb=y1-wa*x1 + wmin(idep)=AMAX1(wmin(idep),-wb/wa) + endif + + !c wmin is even higher in some cases !!! + if (coeskew .lt. 0.2 ) wmin(idep)=wmin(idep)+0.01 + + endif + + if (bug) write(*,*) 'funcidep: ok9; 2nd wmin=',wmin(idep) + + if (valtest(idep,locmax) .le. wmin(idep)) then ! doesn't make sense + wmin(idep)=valtest(idep,locmax)-dx + endif + aabis(idep)=1./(valtest(idep,locmax)-wmin(idep)+1.e-20) + + if (bug) write(*,*) 'funcidep: ok10' + + END SUBROUTINE FUNCIDEP + + ! ******************************************************************** + + SUBROUTINE FUNCZBAR( & + NAR0,ZBAR, & + BEE,PSIS,POROS,COND,RZDEP,WPWET, & + VALX,PX,COESKEW,TIMEAN,SUMA, & + CATDEF,WMIN) + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c c + !c This program returns the eight parameters for the areal fractioning c + !c c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + INTEGER , intent (in) :: NAR0 + integer nref,nind,nmax,indmin,locmax,shift,ord,locmin,ordref + integer indimax10,indmin0 + REAL, intent (in) :: BEE, PSIS, POROS, COND, RZDEP, WPWET, COESKEW + REAL, intent (inout) :: VALX(NAR), PX(NAR),TIMEAN,SUMA,zbar + real, intent (inout) :: catdef,wmin + + REAL dx,dz,sumdef + real term1,term2 + real zdep(nar),locdef(nar),wrz(nar),frcunsat + real valtest(nar),ptest(nar),denstest(nar),dtest(nar) + real x1,x2,y1,y2,wa,wb + integer n1,n2,k,n + real densaux(nar),densaux2(nar),densmax,aux10 + + !c------------------------------------------------------------------------- + !c integral(f(x)dx)=1. for a pdf + !c here px=f(x)dx + dx=valx(1)-valx(2) + + !c**** Compute array of water table depths: + do k=1,nar0 + term1=(1/gnu)*(valx(k)-timean) + zdep(k)=AMAX1(0.,zbar-term1) + enddo + + !c variable change must be reflected in dx + dz=dx/gnu + + !c**** Compute array of moisture deficits: + do k=1,nar0 + term1=(psis-zdep(k))/psis + term1=term1**(1.-1./bee) + term2=-psis*(bee/(bee-1.))*(term1-1.) + locdef(k)=zdep(k)-term2 + enddo + + !c**** Add deficits to produce catdef: + sumdef=0. + do k=1,nar0 + sumdef=sumdef+locdef(k)*px(k) + enddo + catdef=poros*1000.*sumdef/suma + + !c**** Compute array of root zone moisture (degree of wetness in root zone): + do k=1,nar0 + term1=((psis-zdep(k))/psis) & + **(1.-1./bee) + if(zdep(k).le.0.) then + wrz(k)=1. + elseif(zdep(k)-rzdep.lt.0.) then + term2=(-psis/zdep(k))*(bee/(bee-1.)) & + *(term1-1.) + frcunsat=zdep(k)/rzdep + wrz(k)=frcunsat*term2+(1.-frcunsat)*1. + else + term2=((psis-zdep(k)+rzdep) & + /psis)**(1.-1./bee) + wrz(k)=(-psis/rzdep)*(bee/ & + (bee-1.))*(term1-term2) + endif + enddo + + !c**** compute the densities and dx + !c**** we use a usefull property that is due to the construction of the + !c**** gamma distribution in tgen3.f : this distribution is continuous, + !c**** with decreasing values on ln(a/tanb) when n goes from 1 to nar0 + !c first we gather in the same bin all the bins with values ge 1 + nref=1 + nind=1 + ptest(1)=0. + do k=1,nar0 + if (wrz(k) .eq. 1.) then + nref=nref+1 + ptest(1) = ptest(1) + px(k) + endif + enddo + if (nref .gt. 1) then + nind=2 + valtest(1)=1. + endif + nmax=nar0-nref+nind + + !c definition of the probabilities ptest + if (nmax .eq. 1) then ! all the bins have values ge 1 + dtest(1) = 0.0001 + ptest(1) = 1. + else ! distribution in ar2/ar3 + do n=0,nmax-nind + valtest(nind+n)=wrz(nref+n) + ptest(nind+n)=px(nref+n) + enddo + + !c we have to define dtest, the size of each bin + if (nmax .eq. 2) then + dtest(2) = valtest(1)-valtest(2) + dtest(1) = dtest(2)/2. + else ! nmax .gt. 2 + do n=2,nmax-1 + dtest(n)=(valtest(n-1)-valtest(n+1))/2. + enddo + dtest(1) = dtest(2)/2. + dtest(nmax) = dtest(nmax-1) + endif + endif + + !c we can now define the probability density: denstest=ptest/dtest + !c where ptest is the probability and dtest the size of the bin + do n=1,nmax + if (ptest(n) .eq. 0.) then + denstest(n)=0. + else + denstest(n)=ptest(n)/dtest(n) + endif + enddo + + !c NOW we can estimate the parameters for the approximated distrib + !c from the actual distrib + + !c 2. Maximum density -> shape parameter + !c -> wmin + + locmax=3 + shift=15 + ordref=1 + do n=1,nmax + densaux2(n)=denstest(n) + enddo + + if (nmax .ge. shift*2) then + + !c we start with sliding mean to facilitate the search for the maximum + + ord=MIN(ordref,nmax/shift) + call smtot(densaux2,nmax,ord,densaux) + + do n=nmax,shift,-1 + if (densaux(n) .gt. densaux(n-1) .and. & + densaux(n) .gt. densaux(n-2) .and. & + densaux(n) .gt. densaux(n-3) .and. & + densaux(n) .gt. densaux(n-4) .and. & + densaux(n) .gt. densaux(n-5) .and. & + densaux(n) .gt. densaux(n-6) .and. & + densaux(n) .gt. densaux(n-7) .and. & + densaux(n) .gt. densaux(n-8) .and. & + densaux(n) .gt. densaux(n-9) .and. & + densaux(n) .gt. densaux(n-10) .and. & + densaux(n) .gt. densaux(n-11) .and. & + densaux(n) .gt. densaux(n-12) .and. & + densaux(n) .gt. densaux(n-13) .and. & + densaux(n) .gt. densaux(n-14)) then ! .and. & + !densaux(n) .gt. densaux(n-15)) then + locmax=n + goto 30 + endif + enddo + + else + + aux10=-9999. + indimax10=3 + do n=1,nmax + if (densaux2(n) .gt. aux10) then + aux10=densaux2(n) + indimax10=n + endif + enddo + locmax=MAX(3,indimax10) + ! in case nmax < 3. why hard coded 3? + if(locmax > nmax) locmax = nmax + endif ! if (nmax .ge. shift+1) + +30 densmax=denstest(locmax) + + !c WMIN=lowest value where the density is strictly gt densmax/100. + + indmin=1 + indmin0=0 + do n=1,nmax + if (denstest(n) .gt. 0.) indmin0=n + if (denstest(n) .gt. densmax/100. .and. & + valtest(n) .lt. valtest(locmax)) indmin=n + enddo + if (indmin .eq. 0) indmin=indmin0 + + if (indmin .le. 2) then + wmin = 0.99999 + else + x1=valtest(indmin) + wmin=x1 + endif + + !c for negative or low coeskew the previous wmin doesn't give good results... + !c wmin is higher !!! + + if (coeskew .lt. 1. ) then + + if (locmax .gt. 3 .and. indmin .ge. locmax+4) then + + n2=MAX(locmax+1,(indmin-locmax)/2+locmax) + x2=valtest(n2) + y2=denstest(n2) + n1=locmax + x1=valtest(n1) + y1=denstest(n1) + wa=(y2-y1)/(x2-x1) + wb=y1-wa*x1 + wmin=AMAX1(wmin,-wb/wa) + endif + + !c wmin is even higher in some cases !!! + if (coeskew .lt. 0.2 ) wmin=wmin+0.01 + + endif + + END SUBROUTINE FUNCZBAR + + ! ****************************************************************** + + SUBROUTINE RMSE(XX,YY,LEN,ERROR) + + !c--------------------------------------------------------------------------- + !c Computes the root-mean square error ERROR between two one-dimensional + !c random variables XX and YY of same length LEN + !c--------------------------------------------------------------------------- + + INTEGER, intent (in) :: LEN + REAL, intent (in) :: XX(LEN),YY(LEN) + REAL, intent (out) :: ERROR + INTEGER :: I + + !c--------------------------------------------------------------------------- + error=0. + do i=1,len + if(abs(xx(i)-yy(i)) >=1.e-10) then + error=error+(xx(i)-yy(i))*(xx(i)-yy(i)) + endif + enddo + error=SQRT(error/float(len)) + + END SUBROUTINE RMSE + + ! ****************************************************************** + + SUBROUTINE SMTOT(XX,LEN,ORD,YY) + + !c--------------------------------------------------------------------------- + !c Runs a sliding average of order ORD through the one-dimensional array XX + !c of length LEN and returns the smoothed YY + !!c--------------------------------------------------------------------------- + + INTEGER, intent(in) :: LEN + + INTEGER :: ORD,WIDTH,i,ini,n,fin ! replaced var name "end" w/ "fin" to fix auto-indent, reichle, 24 Dec 2024 + + REAL, intent(in) :: XX(NAR) + REAL, intent(out) :: YY(NAR) + + !c--------------------------------------------------------------------------- + do i=1,nar + yy(i)=0. + enddo + + width=ord*2+1 + if (width .gt. len/2) then + write(*,*) 'the order for the sliding average is too large !!!' + write(*,*) 'regard with the length of the array to be smoothed' + stop + endif + + do i=1,len + ini=MAX(1,i-ord) + fin=MIN(len,i+ord) + yy(i)=0. + do n=ini,fin + yy(i)=yy(i)+xx(n) + enddo + yy(i)=yy(i)/(fin-ini+1) + enddo + + END SUBROUTINE SMTOT + + ! ----------------------------------------------------------------------------------- + + subroutine RegridRaster(Rin,Rout) + + ! primitive regridding of integer values from 2-dim array Rin to 2-dim array Rout + ! + ! If Rout is higher-resolution than Rin, result should be fine: + ! An Rout grid cell is assigned the value of the Rin grid cell that + ! contains the center of the Rout grid cell (oversampling). + ! If Rin is higher-resolution than Rout, result is questionable: + ! An Rout grid cell is assigned the value of the Rin grid cell that is + ! near the *corner* of the Rout grid cell. See notes below. + + integer, intent(IN) :: Rin( :,:) + integer, intent(OUT) :: Rout(:,:) + + REAL(REAL64) :: xx, yy + integer :: i, j, ii, jj + integer :: Nx_in, Ny_in, Nx_out, Ny_out + + Nx_in = size(Rin ,1) + Ny_in = size(Rin ,2) + + Nx_out = size(Rout,1) + Ny_out = size(Rout,2) + + !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then + if (.false.) then + + ! avoid loop through output grid cells + + Rout = Rin ! [??] MAY NOT BE 0-DIFF B/C OF MIXED-MODE ARITHMETIC IN LOOP!?!?!? + + else + + ! NOTE: float() yields real*4 but xx was declared real*8 + + xx = Nx_in/float(Nx_out) ! WARNING: mixed mode arithmentic!!! + yy = Ny_in/float(Ny_out) ! WARNING: mixed mode arithmentic!!! + + do j=1,Ny_out + + ! NOTE: When Rin is finer resolution than Rout, the below use of + ! ii = (i-1)*xx + 1 (1a) + ! jj = (j-1)*yy + 1 (1b) + ! implies that Rout(i,j) is assigned the Rin(ii,jj) value near a corner of + ! the (ii,jj) output grid cell, which effectively results in a shift of the + ! data by 1/2 of the width of the output grid cell. This shift could + ! presumably minimized by using + ! ii = NINT( (i-1)*xx + xx/2 ) (2a) + ! jj = NINT( (j-1)*yy + yy/2 ) (2b) + ! + ! HOWEVER, equations (2a) and (2b) are preferable when Rout is finer resolution + ! than Rin, in which case Rout should just be oversampling of Rin. + + jj = (j-1)*yy + 1 ! WARNING: mixed mode arithmetic!!! Note implied "floor()" operator. + do i=1,Nx_out + ii = (i-1)*xx + 1 ! WARNING: mixed mode arithmetic!!! Note implied "floor()" operator. + Rout(i,j) = Rin(ii,jj) + end do + end do + + end if + + end subroutine RegridRaster + + ! ----------------------------------------------------------------------------------- + + subroutine RegridRaster1(Rin,Rout) + + ! same as RegridRaster() but for gridded integer*1 values + + integer*1, intent(IN) :: Rin( :,:) + integer*1, intent(OUT) :: Rout(:,:) + + REAL(REAL64) :: xx, yy + integer :: i, j, ii, jj + integer :: Nx_in, Ny_in, Nx_out, Ny_out + + Nx_in = size(Rin ,1) + Ny_in = size(Rin ,2) + + Nx_out = size(Rout,1) + Ny_out = size(Rout,2) + + !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then + if (.false.) then + + Rout = Rin - ! read cti_stats.dat + else - read(11,'(i10,i8,5(1x,f8.4))') tindex1,pfaf1,meanlu,stdev & - ,minlu,maxlu,coesk - - ! read soil_param.first - ! - ! WARNING: Immediately after the present do loop, BEE, COND, POROS, PSIS, WPWET, and - ! soildepth will be read again (and thus overwritten) with the values from - ! the catch_params.nc4 file. It is unclear if the values in soil_param.first - ! and catch_params.nc4 differ. See comments below. - - read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4)') & - tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & - grav_vec(n),soc_vec(n),poc_vec(n), & - a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) - if(tindex1.ne.tindex2(n))then - write(*,*)'Warnning 1: tindex mismatched' - stop - endif - - ! read catchment.def - - read (12,*) tindex1,pfaf1,minlon,maxlon,minlat,maxlat - tile_lon(n) = (minlon + maxlon)/2. - tile_lat(n) = (minlat + maxlat)/2. - - if(pfaf1.ne.pfaf2(n)) then - write(*,*)'Warnning 1: pfafstetter mismatched' - stop - endif - if((use_PEATMAP).and.(soil_class_top(n) == 253)) then - meanlu = 9.3 - stdev = 0.12 - minlu = 8.5 - maxlu = 11.5 - coesk = 0.25 - endif - - if (index(MaskFile,'GEOS5_10arcsec_mask') /= 0) then - TOPMEAN(n) = meanlu - else - TOPMEAN(n) = 0.961*meanlu-1.957 - endif - - TOPVAR(n) = stdev*stdev - TOPSKEW(n) = coesk*stdev*stdev*stdev - - if ( TOPVAR(n) .eq. 0. .or. coesk .eq. 0. & - .or. topskew(n) .eq. 0.) then - write(*,*) 'Problem: undefined values:' - write(*,*) TOPMEAN(n),TOPVAR(n),coesk, & - minlu,maxlu - stop - endif - END DO ! n=1,nbcatch - - inquire(file='clsm/catch_params.nc4', exist=file_exists) - - if(file_exists) then - - ! Read BEE, COND, POROS, PSIS, WPWET, and soildepth from nc4 file. - ! It is unclear if parameters in nc4 file differ from those in soil_param.first, which were read - ! in the do loop just above. - ! Probably, the parameters differ by roundoff because soil_param.first is an ASCII file and - ! catch_params.nc4 is a netcdf file. Consequently, the parameters from the nc4 file are used - ! in the calculation of the ar.new, bf.dat, and ts.dat parameters, which comes next. - ! To maintain consistency between the parameters in soil_param.first and soil_param.dat where - ! no changes are needed, soil_param.first needs to be read again below (so as to overwrite - ! the values from the nc4 file). - ! Why the parameters from the nc4 file are read here in the first place remains a mystery. - ! Removing this read, however, will (almost certainly) result in non-zero-diff changes - ! for existing bcs datasets. - ! - reichle, 28 April 2022 - - status = NF_OPEN ('clsm/catch_params.nc4', NF_WRITE, ncid) ; VERIFY_(STATUS) - allocate (parms4file (1:nbcatch, 1:25)) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), BEE (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), COND (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), POROS(:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), PSIS (:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), WPWET(:)) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), soildepth (:)) ; VERIFY_(STATUS) - parms4file (:,12) = BEE (:) - parms4file (:,16) = COND (:) - parms4file (:,18) = POROS (:) - parms4file (:,19) = PSIS (:) - parms4file (:,24) = wpwet (:) - parms4file (:,25) = soildepth(:) - endif - - rewind(10) ! soil_param.first (so soil_param.first can be read again below...) - - allocate(low_ind(n_threads)) - allocate(upp_ind(n_threads)) - low_ind(1) = 1 - upp_ind(n_threads) = nbcatch - - if (running_omp) then - do i=1,n_threads-1 - - upp_ind(i) = low_ind(i) + (nbcatch/n_threads) - 1 - low_ind(i+1) = upp_ind(i) + 1 - - end do - end if + xx = Nx_in/float(Nx_out) + yy = Ny_in/float(Ny_out) + do j=1,Ny_out + jj = (j-1)*yy + 1 + do i=1,Nx_out + ii = (i-1)*xx + 1 + Rout(i,j) = Rin(ii,jj) + end do + end do -!$OMP PARALLELDO DEFAULT(NONE) & -!$OMP SHARED( BEE, PSIS,POROS,COND,WPWET,soildepth, & -!$OMP TOPMEAN, TOPVAR, TOPSKEW, & -!$OMP ARS1,ARS2,ARS3, ARA1,ARA2,ARA3,ARA4, & -!$OMP ARW1,ARW2,ARW3,ARW4,bf1, bf2, bf3, & -!$OMP tsa1, tsa2,tsb1, tsb2, & -!$OMP taberr1,taberr2,normerr1,normerr2, & -!$OMP taberr3,taberr4,normerr3,normerr4, & -!$OMP gwatdep,gwan,grzexcn,gfrc,soil_class_com, & -!$OMP n_threads, low_ind, upp_ind, use_PEATMAP ) & -!$OMP PRIVATE(k,li,ui,n,i,watdep,wan,rzexcn,frc,ST,AC, & -!$OMP COESKEW,profdep) + end if - do k=1,n_threads + end subroutine RegridRaster1 - li = low_ind(k) - ui = upp_ind(k) + ! ----------------------------------------------------------------------------------- - do n=li,ui + subroutine RegridRaster2(Rin,Rout) - CALL TGEN ( & - TOPMEAN(n),TOPVAR(n),TOPSKEW(n), & - ST,AC,COESKEW) - - ! compute areal fractioning parameters (ar.new) - - CALL SAT_PARAM( & - BEE(n),PSIS(n),POROS(n),COND(n), & - WPWET(n), ST, AC, COESKEW,n, & - soildepth(n), & - ars1(n),ars2(n),ars3(n), & - ara1(n),ara2(n),ara3(n),ara4(n), & - arw1(n),arw2(n),arw3(n),arw4(n), & - taberr1(n),taberr2(n),taberr3(n),taberr4(n), & - normerr1(n),normerr2(n),normerr3(n),normerr4(n)) - - ! compute base flow parameters (bf.dat) - - CALL BASE_PARAM( & - BEE(n),PSIS(n),POROS(n),COND(n), & - ST, AC, & - bf1(n),bf2(n),bf3(n), & - taberr1(n),taberr2(n),normerr1(n),normerr2(n) & - ) - - - watdep (:,:) = gwatdep (:,:,soil_class_com(n)) - wan (:,:) = gwan (:,:,soil_class_com(n)) - rzexcn (:,:) = grzexcn (:,:,soil_class_com(n)) - frc (:,:) = gfrc (:,:,soil_class_com(n)) - - ! compute time scale parameters (rzexc-catdef) (ts.dat) - - CALL TS_PARAM( & - BEE(n),PSIS(n),POROS(n), & - ST, AC, & - watdep,wan,rzexcn,frc, & - tsa1(n),tsa2(n),tsb1(n),tsb2(n) & - ) - - if(soil_class_com(n) == 253 .and. use_PEATMAP) then - - ! Michel Bechtold paper - PEATCLSM_fitting_CLSM_params.R produced these data values. - - ars1(n) = -7.9514018e-03 - ars2(n) = 6.2297356e-02 - ars3(n) = 1.9187240e-03 - ara1(n) = 8.9551220e+00 - ara2(n) = 9.8149664e+02 - ara3(n) = 8.9551220e+00 - ara4(n) = 9.8149664e+02 - arw1(n) = 9.9466055e-03 - arw2(n) = 1.0881960e-02 - arw3(n) = 1.5309287e-05 - arw4(n) = 1.0000000e-04 - - bf1(n) = 4.6088086e+02 - bf2(n) = 1.4237401e-01 - bf3(n) = 6.9803000e+00 - - tsa1(n) = -2.417581e+00 - tsa2(n) = -4.784762e+00 - tsb1(n) = -3.700285e-03 - tsb2(n) = -2.392484e-03 - - endif - END DO - END DO - !$OMP ENDPARALLELDO - -! This code block is obsolete because it was only needed if preserve_soiltype==.true, but -! preserve_soiltype was hardwired to .false. above. -! -reichle, 28 April 2022 -! -!obsolete20220428 CF1 =0 -!obsolete20220428 CF2 =0 -!obsolete20220428 CF3 =0 -!obsolete20220428 CF4 =0 -!obsolete20220428 -!obsolete20220428 DO n=1,nbcatch -!obsolete20220428 -!obsolete20220428 if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then -!obsolete20220428 -!obsolete20220428 ! determine organic carbon class ("group") from soil class -!obsolete20220428 -!obsolete20220428 if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then -!obsolete20220428 group=1 -!obsolete20220428 else if ((soil_class_com(n) > 84).and.(soil_class_com(n)<=168)) then -!obsolete20220428 group=2 -!obsolete20220428 else if ((soil_class_com(n) >168).and.(soil_class_com(n)< N_SoilClasses)) then -!obsolete20220428 group=3 -!obsolete20220428 else -!obsolete20220428 group=4 ! peat -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 ! assemble scalar structure that holds mineral percentages of tile n -!obsolete20220428 -!obsolete20220428 min_percs%clay_perc = atile_clay(n) -!obsolete20220428 min_percs%sand_perc = atile_sand(n) -!obsolete20220428 min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc -!obsolete20220428 -!obsolete20220428 ! "soil_class" is an integer function (defined below) that assigns -!obsolete20220428 ! an integer soil class [1-100] for a given mineral percentage triplet -!obsolete20220428 -!obsolete20220428 ! "tile_pick" contains the number (ID) n of a sample tile for each -!obsolete20220428 ! soil class -!obsolete20220428 -!obsolete20220428 if(tile_pick(soil_class (min_percs),group) == 0) then -!obsolete20220428 -!obsolete20220428 ! assign tile n as the sample tile for its soil class in "tile_pick" -!obsolete20220428 -!obsolete20220428 tile_pick(soil_class (min_percs),group) = n -!obsolete20220428 -!obsolete20220428 ! Assign sand/clay from tile n to "good_clay" and "good_sand" for its class???? -!obsolete20220428 ! Why is "good_sand" dimension (100,4) when CF[x] seems to count the -!obsolete20220428 ! number of tiles within each organic carbon subclass ("group")?? -!obsolete20220428 -!obsolete20220428 select case (group) -!obsolete20220428 -!obsolete20220428 case (1) -!obsolete20220428 -!obsolete20220428 CF1 = CF1 + 1 -!obsolete20220428 good_clay (CF1,group) = atile_clay(n) -!obsolete20220428 good_sand (CF1,group) = atile_sand(n) -!obsolete20220428 tile_add (CF1,group) = n -!obsolete20220428 -!obsolete20220428 case (2) -!obsolete20220428 CF2 = CF2 + 1 -!obsolete20220428 good_clay (CF2,group) = atile_clay(n) -!obsolete20220428 good_sand (CF2,group) = atile_sand(n) -!obsolete20220428 tile_add (CF2,group) = n -!obsolete20220428 -!obsolete20220428 case (3) -!obsolete20220428 CF3 = CF3 + 1 -!obsolete20220428 good_clay (CF3,group) = atile_clay(n) -!obsolete20220428 good_sand (CF3,group) = atile_sand(n) -!obsolete20220428 tile_add (CF3,group) = n -!obsolete20220428 -!obsolete20220428 case (4) -!obsolete20220428 CF4 = CF4 + 1 -!obsolete20220428 good_clay (CF4,group) = atile_clay(n) -!obsolete20220428 good_sand (CF4,group) = atile_sand(n) -!obsolete20220428 tile_add (CF4,group) = n -!obsolete20220428 -!obsolete20220428 end select -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 endif ! (ars1(n).ne.9999.).and.(arw1(n).ne.9999.) -!obsolete20220428 -!obsolete20220428 END DO ! n=1,nbcatch - - ! ---------------------------------------------------------------------------------------- - ! - ! write ar.new, bf.dat, ts.dat, and soil_param.dat - - DO n=1,nbcatch - - ! Read soil_param.first again...; this is (almost certainly) needed to maintain consistency - ! between soil_param.first and soil_param.dat, see comments above. - - read(10,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & - BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & - grav_vec(n),soc_vec(n),poc_vec(n), & - a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n) , & - wpwet_surf(n),poros_surf(n), pmap(n) + ! same as RegridRaster() but for gridded integer*2 values + integer(kind=2), intent(IN) :: Rin( :,:) + integer(kind=2), intent(OUT) :: Rout(:,:) -! This code block was obsolete because only one set of write statements is needed/desired. -! Repeating near-verbatim copies of write statements was bad coding practice. -! - reichle, 28 April 2022 -! -!obsolete20220428 if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then -!obsolete20220428 -!obsolete20220428 ! nominal case, all parameter values are good -!obsolete20220428 -!obsolete20220428 ! write ar.new -!obsolete20220428 -!obsolete20220428 write(20,'(i10,i8,f5.2,11(2x,e14.7))') & -!obsolete20220428 tindex2(n),pfaf2(n),gnu, & -!obsolete20220428 ars1(n),ars2(n),ars3(n), & -!obsolete20220428 ara1(n),ara2(n),ara3(n),ara4(n), & -!obsolete20220428 arw1(n),arw2(n),arw3(n),arw4(n) -!obsolete20220428 -!obsolete20220428 ! write bf.dat -!obsolete20220428 -!obsolete20220428 write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(n),bf2(n),bf3(n) -!obsolete20220428 -!obsolete20220428 ! write ts.dat -!obsolete20220428 -!obsolete20220428 write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & -!obsolete20220428 tsa1(n),tsa2(n),tsb1(n),tsb2(n) -!obsolete20220428 -!obsolete20220428 ! write soil_param.dat -!obsolete20220428 -!obsolete20220428 write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & -!obsolete20220428 tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & -!obsolete20220428 BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n), & -!obsolete20220428 grav_vec(n),soc_vec(n),poc_vec(n), & -!obsolete20220428 a_sand_surf(n),a_clay_surf(n),atile_sand(n),atile_clay(n), & -!obsolete20220428 wpwet_surf(n),poros_surf(n), pmap(n) -!obsolete20220428 -!obsolete20220428 if (allocated (parms4file)) then -!obsolete20220428 parms4file (n, 1) = ara1(n) -!obsolete20220428 parms4file (n, 2) = ara2(n) -!obsolete20220428 parms4file (n, 3) = ara3(n) -!obsolete20220428 parms4file (n, 4) = ara4(n) -!obsolete20220428 parms4file (n, 5) = ars1(n) -!obsolete20220428 parms4file (n, 6) = ars2(n) -!obsolete20220428 parms4file (n, 7) = ars3(n) -!obsolete20220428 parms4file (n, 8) = arw1(n) -!obsolete20220428 parms4file (n, 9) = arw2(n) -!obsolete20220428 parms4file (n,10) = arw3(n) -!obsolete20220428 parms4file (n,11) = arw4(n) -!obsolete20220428 parms4file (n,13) = bf1(n) -!obsolete20220428 parms4file (n,14) = bf2(n) -!obsolete20220428 parms4file (n,15) = bf3(n) -!obsolete20220428 parms4file (n,17) = gnu -!obsolete20220428 parms4file (n,20) = tsa1(n) -!obsolete20220428 parms4file (n,21) = tsa2(n) -!obsolete20220428 parms4file (n,22) = tsb1(n) -!obsolete20220428 parms4file (n,23) = tsb2(n) -!obsolete20220428 endif - - -! This code block is obsolete because it was only needed if preserve_soiltype==.true, but -! preserve_soiltype was hardwired to .false. above. -! -reichle, 28 April 2022 -! -!obsolete20220428 else ! (ars1(n).ne.9999.) .or. (arw1(n)==9999.) -!obsolete20220428 -!obsolete20220428 ! exception, some parameter values are no-data -!obsolete20220428 -!obsolete20220428 if(preserve_soiltype) then -!obsolete20220428 -!obsolete20220428 ! look for a tile with a similar soil class -!obsolete20220428 -!obsolete20220428 ! NOTE: preserve_soiltype=.false. hardwired as of 28 Apr 2022 -!obsolete20220428 -!obsolete20220428 if ((soil_class_com(n)>=1).and.(soil_class_com(n)<=84)) then -!obsolete20220428 group=1 -!obsolete20220428 else if ((soil_class_com(n)> 84).and.(soil_class_com(n)<=168)) then -!obsolete20220428 group=2 -!obsolete20220428 else if ((soil_class_com(n)> 168).and.(soil_class_com(n)< N_SoilClasses)) then -!obsolete20220428 group=3 -!obsolete20220428 else -!obsolete20220428 group=4 -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 min_percs%clay_perc = atile_clay(n) -!obsolete20220428 min_percs%sand_perc = atile_sand(n) -!obsolete20220428 min_percs%silt_perc = 100. - min_percs%clay_perc - min_percs%sand_perc -!obsolete20220428 -!obsolete20220428 if(tile_pick(soil_class (min_percs),group) > 0) then -!obsolete20220428 -!obsolete20220428 k = tile_pick(soil_class (min_percs),group) -!obsolete20220428 -!obsolete20220428 else -!obsolete20220428 -!obsolete20220428 select case (group) -!obsolete20220428 -!obsolete20220428 case (1) -!obsolete20220428 j = center_pix (good_clay(1:CF1,group),good_sand(1:CF1,group), & -!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) -!obsolete20220428 k = tile_add (j,group) -!obsolete20220428 case (2) -!obsolete20220428 j = center_pix (good_clay(1:CF2,group),good_sand(1:CF2,group), & -!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) -!obsolete20220428 k = tile_add (j,group) -!obsolete20220428 case (3) -!obsolete20220428 j = center_pix (good_clay(1:CF3,group),good_sand(1:CF3,group), & -!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) -!obsolete20220428 k = tile_add (j,group) -!obsolete20220428 case (4) -!obsolete20220428 j = center_pix (good_clay(1:CF4,group),good_sand(1:CF4,group), & -!obsolete20220428 min_percs%clay_perc,min_percs%sand_perc,min_percs%silt_perc,.true.) -!obsolete20220428 k = tile_add (j,group) -!obsolete20220428 end select -!obsolete20220428 print *,'NO Similar SoilClass :',soil_class (min_percs),group,n,k -!obsolete20220428 -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 if (error_file) then -!obsolete20220428 ! record in file clsm/bad_sat_param.tiles -!obsolete20220428 write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken -!obsolete20220428 -!obsolete20220428 ! write (41,*)tindex2(n),pfaf2(n),soil_class_top(n),soil_class_com(n), & -!obsolete20220428 ! BEE(n), PSIS(n),POROS(n),COND(n),WPWET(n),soildepth(n) -!obsolete20220428 ! write (41,*)tindex2(k),pfaf2(k),soil_class_top,soil_class_com(k), & -!obsolete20220428 ! BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k) -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 -!obsolete20220428 ! write ar.new, bf.dat, ts.dat, and soil_param.dat -!obsolete20220428 -!obsolete20220428 write(20,'(i10,i8,f5.2,11(2x,e14.7))') & -!obsolete20220428 tindex2(n),pfaf2(n),gnu, & -!obsolete20220428 ars1(k),ars2(k),ars3(k), & -!obsolete20220428 ara1(k),ara2(k),ara3(k),ara4(k), & -!obsolete20220428 arw1(k),arw2(k),arw3(k),arw4(k) -!obsolete20220428 write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) -!obsolete20220428 write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & -!obsolete20220428 tsa1(k),tsa2(k),tsb1(k),tsb2(k) -!obsolete20220428 -!obsolete20220428 write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & -!obsolete20220428 tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & -!obsolete20220428 BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & -!obsolete20220428 grav_vec(k),soc_vec(k),poc_vec(k), & -!obsolete20220428 a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & -!obsolete20220428 wpwet_surf(k),poros_surf(k), pmap (k) -!obsolete20220428 -!obsolete20220428 if (allocated (parms4file)) then -!obsolete20220428 parms4file (n, 1) = ara1(k) -!obsolete20220428 parms4file (n, 2) = ara2(k) -!obsolete20220428 parms4file (n, 3) = ara3(k) -!obsolete20220428 parms4file (n, 4) = ara4(k) -!obsolete20220428 parms4file (n, 5) = ars1(k) -!obsolete20220428 parms4file (n, 6) = ars2(k) -!obsolete20220428 parms4file (n, 7) = ars3(k) -!obsolete20220428 parms4file (n, 8) = arw1(k) -!obsolete20220428 parms4file (n, 9) = arw2(k) -!obsolete20220428 parms4file (n,10) = arw3(k) -!obsolete20220428 parms4file (n,11) = arw4(k) -!obsolete20220428 parms4file (n,12) = BEE(k) -!obsolete20220428 parms4file (n,13) = bf1(k) -!obsolete20220428 parms4file (n,14) = bf2(k) -!obsolete20220428 parms4file (n,15) = bf3(k) -!obsolete20220428 parms4file (n,16) = COND(k) -!obsolete20220428 parms4file (n,17) = gnu -!obsolete20220428 parms4file (n,18) = POROS(k) -!obsolete20220428 parms4file (n,19) = PSIS(k) -!obsolete20220428 parms4file (n,20) = tsa1(k) -!obsolete20220428 parms4file (n,21) = tsa2(k) -!obsolete20220428 parms4file (n,22) = tsb1(k) -!obsolete20220428 parms4file (n,23) = tsb2(k) -!obsolete20220428 parms4file (n,24) = wpwet (k) -!obsolete20220428 parms4file (n,25) = soildepth(k) -!obsolete20220428 endif -!obsolete20220428 -!obsolete20220428 else ! .not. preserve_soiltype - - - ! This revised if block replaces the complex, nested if block commented out above - - if ( (ars1(n)==9999.) .or. (arw1(n)==9999.) ) then - - ! some parameter values are no-data --> find nearest tile k with good parameters - - dist_save = 1000000. - k = 0 - do i = 1,nbcatch - if(i /= n) then - if((ars1(i).ne.9999.).and.(arw1(i).ne.9999.)) then - - tile_distance = (tile_lon(i) - tile_lon(n)) * (tile_lon(i) - tile_lon(n)) + & - (tile_lat(i) - tile_lat(n)) * (tile_lat(i) - tile_lat(n)) - if(tile_distance < dist_save) then - k = i - dist_save = tile_distance - endif - endif - endif - enddo - ! record in file clsm/bad_sat_param.tiles - write (41,*)n,k ! n="bad" tile, k=tile from which parameters are taken - - ! Overwrite parms4file when filling in parameters from neighboring tile k. - ! For "good" tiles, keep parms4file as read earlier from catch_params.nc4, - ! which is why this must be done within the "then" block of the "if" statement. - ! This is necessary for backward 0-diff compatibility of catch_params.nc4. - - parms4file (n,12) = BEE(k) - parms4file (n,16) = COND(k) - parms4file (n,18) = POROS(k) - parms4file (n,19) = PSIS(k) - parms4file (n,24) = wpwet(k) - parms4file (n,25) = soildepth(k) - - else - - ! nominal case, all parameters are good - - k = n - - end if - - ! for current tile n, write parameters of tile k into ar.new (20), bf.dat (30), ts.dat (40), - ! and soil_param.dat (42) - - write(20,'(i10,i8,f5.2,11(2x,e14.7))') & - tindex2(n),pfaf2(n),gnu, & - ars1(k),ars2(k),ars3(k), & - ara1(k),ara2(k),ara3(k),ara4(k), & - arw1(k),arw2(k),arw3(k),arw4(k) - - write(30,'(i10,i8,f5.2,3(2x,e13.7))')tindex2(n),pfaf2(n),gnu,bf1(k),bf2(k),bf3(k) - - write(40,'(i10,i8,f5.2,4(2x,e13.7))')tindex2(n),pfaf2(n),gnu, & - tsa1(k),tsa2(k),tsb1(k),tsb2(k) - - write(42,'(i10,i8,i4,i4,3f8.4,f12.8,f7.4,f10.4,3f7.3,4f7.3,2f10.4, f8.4)') & - tindex2(n),pfaf2(n),soil_class_top(k),soil_class_com(k), & - BEE(k), PSIS(k),POROS(k),COND(k),WPWET(k),soildepth(k), & - grav_vec(k),soc_vec(k),poc_vec(k), & - a_sand_surf(k),a_clay_surf(k),atile_sand(k),atile_clay(k) , & - wpwet_surf(k),poros_surf(k), pmap(k) - - ! record ar.new, bf.dat, and ts.dat parameters for later writing into catch_params.nc4 - - if (allocated (parms4file)) then - parms4file (n, 1) = ara1(k) - parms4file (n, 2) = ara2(k) - parms4file (n, 3) = ara3(k) - parms4file (n, 4) = ara4(k) - parms4file (n, 5) = ars1(k) - parms4file (n, 6) = ars2(k) - parms4file (n, 7) = ars3(k) - parms4file (n, 8) = arw1(k) - parms4file (n, 9) = arw2(k) - parms4file (n,10) = arw3(k) - parms4file (n,11) = arw4(k) - parms4file (n,13) = bf1(k) - parms4file (n,14) = bf2(k) - parms4file (n,15) = bf3(k) - parms4file (n,17) = gnu - parms4file (n,20) = tsa1(k) - parms4file (n,21) = tsa2(k) - parms4file (n,22) = tsb1(k) - parms4file (n,23) = tsb2(k) - endif - -!obsolete20220428 endif ! if (preserve_soiltype) then -!obsolete20220428 -!obsolete20220428 endif ! if((ars1(n).ne.9999.).and.(arw1(n).ne.9999.))then - - if (error_file) then - write(21,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),taberr3(n),taberr4(n), & - normerr1(n),normerr2(n),normerr3(n),normerr4(n) - write(31,*)tindex2(n),pfaf2(n),taberr1(n),taberr2(n),normerr1(n),normerr2(n) - endif - - END DO ! n=1,nbcatch - -! Write(*,*) 'END COMPUTING MODEL PARA' - - close(10,status='keep') - close(11,status='keep') - close(12,status='keep') - close(20,status='keep') - close(30,status='keep') - close(40,status='keep') - close(42,status='keep') - - - if (error_file) then - close(21,status='delete') - close(31,status='delete') - close(41,status='keep') - endif - - if(file_exists) then - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA1' ) ,(/1/),(/nbcatch/), parms4file (:, 1)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA2' ) ,(/1/),(/nbcatch/), parms4file (:, 2)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA3' ) ,(/1/),(/nbcatch/), parms4file (:, 3)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARA4' ) ,(/1/),(/nbcatch/), parms4file (:, 4)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS1' ) ,(/1/),(/nbcatch/), parms4file (:, 5)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS2' ) ,(/1/),(/nbcatch/), parms4file (:, 6)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARS3' ) ,(/1/),(/nbcatch/), parms4file (:, 7)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW1' ) ,(/1/),(/nbcatch/), parms4file (:, 8)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW2' ) ,(/1/),(/nbcatch/), parms4file (:, 9)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW3' ) ,(/1/),(/nbcatch/), parms4file (:,10)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'ARW4' ) ,(/1/),(/nbcatch/), parms4file (:,11)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BEE' ) ,(/1/),(/nbcatch/), parms4file (:,12)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF1' ) ,(/1/),(/nbcatch/), parms4file (:,13)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF2' ) ,(/1/),(/nbcatch/), parms4file (:,14)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'BF3' ) ,(/1/),(/nbcatch/), parms4file (:,15)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'COND' ) ,(/1/),(/nbcatch/), parms4file (:,16)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'GNU' ) ,(/1/),(/nbcatch/), parms4file (:,17)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'POROS') ,(/1/),(/nbcatch/), parms4file (:,18)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'PSIS' ) ,(/1/),(/nbcatch/), parms4file (:,19)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA1' ) ,(/1/),(/nbcatch/), parms4file (:,20)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSA2' ) ,(/1/),(/nbcatch/), parms4file (:,21)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB1' ) ,(/1/),(/nbcatch/), parms4file (:,22)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'TSB2' ) ,(/1/),(/nbcatch/), parms4file (:,23)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'WPWET') ,(/1/),(/nbcatch/), parms4file (:,24)) ; VERIFY_(STATUS) - status = NF_PUT_VARA_REAL(NCID,NC_VarID(NCID,'DP2BR') ,(/1/),(/nbcatch/), parms4file (:,25)) ; VERIFY_(STATUS) - STATUS = NF_CLOSE (NCID) ; VERIFY_(STATUS) - DEALLOCATE (parms4file) - endif + REAL(REAL64) :: xx, yy + integer :: i, j, ii, jj + integer :: Nx_in, Ny_in, Nx_out, Ny_out - END SUBROUTINE create_model_para_woesten + Nx_in = size(Rin ,1) + Ny_in = size(Rin ,2) + Nx_out = size(Rout,1) + Ny_out = size(Rout,2) -!--------------------------------------------------------------------- - - SUBROUTINE TS_PARAM( & - BEE,PSIS,POROS, & - VALX, PX, & - watdep,wan,rzexcn,frc, & - tsa1,tsa2,tsb1,tsb2 & - ) - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c Given pre-computed 1-D relationships between a "local" root zone excess c -!c and a "local" catchment deficit, the timescale of the bulk vertical c -!c transfer between the two bulk prognostic variables is computed using c -!c the distribution of the local deficit established from the distribution c -!c of the topographic index, then an approximated function of catdef and c -!c rzex is derived. c -!c c -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - INTEGER NAR0 - REAL, intent (in) :: BEE, PSIS, POROS - REAL, intent (in) :: VALX(NAR), PX(NAR) - real, intent (inout) :: watdep(nwt,nrz),wan(nwt,nrz), & - rzexcn(nwt,nrz),frc(nwt,nrz) - real, intent (out) :: tsa1, tsa2 ,tsb1, tsb2 - - integer :: tex,iwt,irz,n,idep,k, index1,i0 - REAL VALX0(NAR), PX0(NAR),sumta,sumta2,timean,zbar, rzw - REAL :: term1, term2, sumdef, suma, frcsat,rzexc, rzact - real zdep(nar),def(nar),wrz(nar),wbin(500),rze(nar) - real catd(2,2),tsc(2,2), satfrc,sumfrac,sumz,frac - real, parameter :: frcmax = .041 - real wtdep,wanom,rzaact,fracl,profdep,rzdep - -! logical bug - -!c---------------------------------------------------------------- -!c Is loss.dat compatible with rzdep = 0.49 ??? - - rzdep = grzdep - -!c Convert fractions to "per-hour" values - do iwt=1,nwt - do irz=1,nrz - frc(iwt,irz)=1.-((1.-frc(iwt,irz))**(1./24.)) - enddo - enddo - - nar0=0 - do n=1,nar - if (px(n) .ne. 0.) then - nar0=nar0+1 - valx0(nar0)=valx(n) - px0(nar0)=px(n) - endif - enddo - - sumta=0. - sumta2=0. - suma=0. - do n=1,nar0 - sumta=sumta+px0(n)*valx0(n) - sumta2=sumta2+px0(n)*valx0(n)*valx0(n) - suma=suma+px0(n) - enddo - - timean=sumta/suma - -!c**** Loop over two water table depths - do idep=1,2 - if(idep.eq.1) zbar=1.5 ! zbar in meters - if(idep.eq.2) zbar=2.0 - -!c**** Compute array of water table depths: - do k=1,nar0 - term1=(1/gnu)*(valx0(k)-timean) - zdep(k)=zbar-term1 - if(zdep(k) .lt. 0.) zdep(k)=0. - enddo -!c write(*,*)" End water table depth" -!c**** Compute array of moisture deficits: - do k=1,nar0 - term1=(psis-zdep(k))/psis - term1=term1**(1.-1./bee) - term2=-psis*(bee/(bee-1.))*(term1-1.) - def(k)=poros*(zdep(k)-term2) - enddo - -!c**** Add deficits to produce catdef: - sumdef=0. - do k=1,nar0 - sumdef=sumdef+def(k)*px0(k)*1000. - enddo -!c write(*,*)" End catchment deficit" -!c**** Compute array of root zone moisture (degree of wetness in root zone): - do k=1,nar0 - - if(zdep(k).eq.0.) then - wrz(k)=1. - elseif(zdep(k)-rzdep.lt.0.) then - term1=((psis-zdep(k))/psis)**(1.-1./bee) - wrz(k)=(-psis/zdep(k))*(bee/(bee-1.)) & - *(term1-1.) - frcsat=1.-zdep(k)/rzdep - wrz(k)=(1.-frcsat)*wrz(k)+frcsat*1. - else - term1=((psis-zdep(k))/psis)**(1.-1./bee) - term2=((psis-zdep(k)+rzdep)/psis) & - **(1.-1./bee) - wrz(k)=(-psis/rzdep)*(bee/(bee-1.)) & - *(term1-term2) - endif - enddo - -!c Loop over two root zone excess values: - do irz=1,2 - if(irz.eq.1) rzexc=-0.1*poros - if(irz.eq.2) rzexc=0.1*poros - -!c Determine actual root zone excess - rzact=0. - do k=1,nar0 - rze(k)=rzexc - rzw=wrz(k)*poros - if(rzw+rze(k) .gt. poros) rze(k)=poros-rzw - if(rzw+rze(k) .lt. 0.) rze(k)=rzw - rzact=rzact+rze(k)*px0(k) - enddo -!c write(*,*)" End root zone excess" -!c Compute the average timescale - - satfrc=0. - do k=1,nar0 - if(zdep(k).lt.0.) satfrc=satfrc+px0(k) - enddo - - sumfrac=0. - sumz=0. - do k=1,nar0 - sumz=sumz+zdep(k)*px0(k) - if(zdep(k) .lt. 1.) frac=frcmax - if(zdep(k) .ge. 1.) then - index1=1+int(((zdep(k)*100.)-99)/5.) - if(index1.gt.nwt) index1 = nwt - frac=amin1(frc(index1,1),frcmax) - do i0=2,nrz - if(rze(k) .ge. rzexcn(index1,i0)) & - frac=amin1(frc(index1,i0),frcmax) - enddo - endif - sumfrac=sumfrac+frac*px0(k) - enddo -!c write(*,*)" End average time scale" - catd(idep,irz)=sumdef - tsc(idep,irz)=sumfrac - - enddo - enddo - - tsb1=(alog(tsc(2,2))-alog(tsc(1,2)))/(catd(2,2)-catd(1,2)) - tsb2=(alog(tsc(2,1))-alog(tsc(1,1)))/(catd(2,1)-catd(1,1)) - tsa1=alog(tsc(2,2))-tsb1*catd(2,2) - tsa2=alog(tsc(2,1))-tsb2*catd(2,1) - - END SUBROUTINE TS_PARAM - -!********************************************************************* - - SUBROUTINE BASE_PARAM( & - BEE,PSIS,POROS,COND, & - VALX, PX, & - bf1,bf2,bf3, & - taberr1,taberr2,normerr1,normerr2 & - ) - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c New way to get baseflow: we parametrize the relationship between c -!c catdef and zbar (two parameters bf1 and bf2). c -!c Then, in the LSM/catchment.f/base.f, we use the original relation c -!c from TOPMODEL to infer baseflow from catdef and the mean of the c -!c topographic index (topmean=bf3, a third parameter). c -!c c -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - INTEGER IDMAX,i1,i2,i,icount - - REAL, intent (in) :: BEE, PSIS,POROS,COND,VALX(NAR),PX(NAR) - real zbar(nbdep),catdef(nbdep),bflow(nbdep) - real, intent (out) :: bf1,bf2,bf3,taberr1,taberr2,normerr1,normerr2 - integer :: n,idep - real suma,sumta,timean - - real catfit(nbdep),bfit(nbdep),dfit(nbdep),catmean,bfmean - real catref(nbdep),bref(nbdep) - real err1, err2 -! logical, intent (in) :: bug - - sumta=0. - suma=0. - do n=1,nar - sumta=sumta+px(n)*valx(n) - suma=suma+px(n) - enddo - timean=sumta/suma - bf3 = timean - -!c**** Loop over water table depths - - do idep=1,nbdep - -!c write(*,*) 'idep=',idep - - CALL BASIDEP( & - IDEP, & - BEE,PSIS,POROS,COND, & - VALX,PX,TIMEAN,SUMA, & - ZBAR,CATDEF,BFLOW) - - enddo - - - i1=10 ! zbar= 0 m - i2=35 ! zbar= 2.5 m - - bf2=zbar(i2)*SQRT(catdef(i1)) & - /(SQRT(catdef(i2))-SQRT(catdef(i1))) - bf1=catdef(i1)/(bf2*bf2) - - if (bf1 .le. 0) write(*,*) 'bf1 le 0 for i=',i - if (bf2 .le. 0) write(*,*) 'bf2 le 0 for i=',i - -!c Errors: Root mean square errors: only for points where catdef GT 0.5mm - - do idep=1,nbdep - catref(idep)=0. - bref(idep)=0. - enddo - catmean=0. - bfmean=0. - icount=0 - do idep=1,nbdep - if (catdef(idep) .gt. lim) then - icount=icount+1 - catref(icount)=catdef(idep) - bref(icount)=bflow(idep) - catfit(icount)=bf1*(zbar(idep)+bf2) & - *(zbar(idep)+bf2) - dfit(icount)=SQRT(catdef(idep)/bf1)-bf2 - bfit(icount)=cond*exp(-timean-gnu*dfit(icount)) & - /gnu - catmean=catmean+catdef(idep) - bfmean=bfmean+bflow(idep) - endif - enddo - catmean=catmean/icount - bfmean=bfmean/icount - if (icount.gt.1) then - call RMSE(catref,catfit,icount,err1) - call RMSE(bref,bfit,icount,err2) - - taberr1=err1 - taberr2=err2 - normerr1=err1/catmean - normerr2=err2/bfmean - endif -!c--------------------------------------------------------------------- - - END SUBROUTINE BASE_PARAM - -! ************************************************************************ - - SUBROUTINE BASIDEP( & - IDEP, & - BEE,PSIS,POROS,COND, & - VALX,PX,TIMEAN,SUMA, & - ZBAR,CATDEF,BFLOW) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c This program returns the eight parameters for the areal fractioning c -!c c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - implicit none - INTEGER, intent (in) :: idep - integer nref, nind,nmax,indmin,locmax,shift,ord,locmin,ordref,width,k - REAL, intent (in) :: BEE, PSIS, POROS, COND,VALX(NAR), PX(NAR), & - suma,timean - real :: dx,sumdef,dz - real, intent (out) :: catdef(nbdep),bflow(nbdep),zbar(idep) - real term1,term2,sum - real zdep(nar),locdef(nar) -! logical bug - -!c------------------------------------------------------------------------- -!c integral(f(x)dx)=1. for a pdf -!c here px=f(x)dx - - dx=valx(1)-valx(2) - - if (bug) write(*,*) 'IDEP=',IDEP,' dx=',dx, 'gnu=',gnu - -!c the loops over idmax and nbdep are initiated in sta_params4.f - - zbar(idep)=float(idep-10)*slice ! zdep in meters - -!c**** Compute array of water table depths: - do k=1,nar - term1=(1/gnu)*(valx(k)-timean) - zdep(k)=AMAX1(0.,zbar(idep)-term1) - enddo - -!c variable change must be reflected in dx - dz=dx/gnu - - if (bug) write(*,*) 'basidep: ok1' - -!c**** Compute array of moisture deficits: - do k=1,nar - term1=(psis-zdep(k))/psis - term1=term1**(1.-1./bee) - term2=-psis*(bee/(bee-1.))*(term1-1.) - locdef(k)=zdep(k)-term2 - enddo - -!c**** Add deficits to produce catdef: - sumdef=0. - do k=1,nar - sumdef=sumdef+locdef(k)*px(k) - enddo - catdef(idep)=poros*1000.*sumdef/suma - - if (bug) write(*,*) 'basidep: ok2' - - bflow(idep)=cond*exp(-timean-gnu*zbar(idep))/gnu - - if (bug) write(*,*) 'basidep: ok3' - - END SUBROUTINE BASIDEP - -!***************************************************************************** - - SUBROUTINE SAT_PARAM( & - BEE,PSIS,POROS,COND, & - WPWET,VALX, PX, COESKEW,PFC, & - soildepth, & - ARS1,ARS2,ARS3, & - ARA1,ARA2,ARA3,ARA4, & - ARW1,ARW2,ARW3,ARW4, & - taberr1,taberr2,taberr3,taberr4, & - normerr1,normerr2,normerr3,normerr4, & - DBG_UNIT) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c This program returns the eleven parameters for the areal fractioning c -!c c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - IMPLICIT NONE - - INTEGER, intent (in) :: pfc - REAL, intent (in) :: BEE,PSIS,POROS,COND,WPWET, & - VALX(NAR), PX(NAR) - REAL, intent (in) :: soildepth, COESKEW - REAL, intent (inout) :: ARS1,ARS2,ARS3, & - ARA1,ARA2,ARA3,ARA4, & - ARW1,ARW2,ARW3,ARW4, & - taberr1,taberr2,taberr3,taberr4, & - normerr1,normerr2,normerr3,normerr4 - INTEGER idep,n,k,i,icount,iref - integer nar0 - integer nref, nind,nmax,indmin,locmax,shift,ord,locmin - integer loc1,loc2,loc3,loc0,flag - REAL VALX0(NAR), PX0(NAR) - integer :: adjust,loc2save,inc,dec - real sumta,suma,timean,upval,loval,profdep - real rjunk,rjunk2 - integer, intent (in), optional :: DBG_UNIT - real catdef(nbdep),wmin(nbdep),ar1(nbdep),aa(nbdep),aabis(nbdep) - real ar2(nbdep),ar3(nbdep),swsrf2(nbdep),swsrf3(nbdep),rzeq(nbdep) - real zbar0,catdef0,wmin0,RZDEP,wminsave(nbdep) - - real x1,x2,x3,x4,w1,w1_0,w2,w3,w4,ref1 - real y0,f1,f2,f3,g1,g2,g3,df,dg,dx,bf,bg,delta,z1,z2 - - real nar1(nbdep),nar2(nbdep),nmean2(nbdep),neq(nbdep) - real shape, nwm, area1,cdi,nar3(nbdep),nmean3 - real err1,err2,err3,err4,sum - real tabact(nbdep),tabfit(nbdep) - - integer :: mp,isvd,j,first_loop -! REAL*8, allocatable :: A(:,:),AP(:,:) -! REAL*8, allocatable :: B(:) - REAL*8, allocatable, target :: A(:,:) - REAL*8, allocatable, target :: B(:) - REAL*8, pointer :: AP(:,:) - REAL*8, pointer :: BP(:) - REAL*8 V(3,3),W(3),ANS(3),sdmax,sdmin,wbrac - - real :: cdcr1,cdcr2,term1,term2,zmet - logical :: smooth,ars_svd_loop - logical, parameter :: bug=.false. - logical, parameter :: SingValDecomp = .true. - integer, parameter :: nl=4, nr=4, m=4, NP=50 - real :: savgol_coeff(NP) - integer :: savgol_ind(NP) - integer :: nbdepl,istart - - ref1 = 100. -! print *,'PFC', pfc - if (bug) write(*,*) 'starting sat_param' - - if(SingValDecomp) then - savgol_ind(1)=0 - j=3 - do i=2, nl+1 - savgol_ind(i)=i-j - j=j+2 - end do - - j=2 - do i=nl+2, nl+nr+1 - savgol_ind(i)=i-j - j=j+2 - end do - call savgol(savgol_coeff,nl+nr+1,nl,nr,0,m) - endif - - profdep = soildepth - rzdep =grzdep - profdep=profdep/1000. - profdep=amax1(1.,profdep) - if (rzdep .gt. .75*profdep) then - rzdep=0.75*profdep - end if - - zmet=profdep - term1=-1.+((psis-zmet)/psis)** & - ((bee-1.)/bee) - term2=psis*bee/(bee-1) - cdcr1=1000.*poros*(zmet-(-term2*term1)) - cdcr2=(1-wpwet)*poros*1000.*zmet -!c mean of the topographic index distribution - - nar0=0 - do n=1,nar - if (px(n) .ne. 0.) then - nar0=nar0+1 - valx0(nar0)=valx(n) - px0(nar0)=px(n) - endif - enddo - - sumta=0. - suma=0. - do n=1,nar0 - sumta=sumta+px0(n)*valx0(n) - suma=suma+px0(n) - enddo - timean=sumta/suma - - if (bug) write(*,*) 'ok 0: sumta,suma,nar0=',sumta,suma,nar0 - -!c**** Loop over water table depths - - do idep=1,nbdep - - CALL FUNCIDEP( & - NAR0,IDEP, & - BEE,PSIS,POROS,COND,RZDEP,WPWET, & - VALX0,PX0,COESKEW,TIMEAN,SUMA, & - CATDEF,AR1,WMIN,AA,AABIS, & - AR2,AR3,SWSRF2,SWSRF3,RZEQ) - enddo - - nbdepl = 100 - if(catdef(50) > cdcr1 + 20.) nbdepl = 50 - if(soildepth > 6500.) nbdepl = nbdep - - if (bug) write(*,*) 'funcidep loop ok' - -!c**** for wmin's adjustment, we need an estimate of its limit toward INF - adjust =0 - ZBAR0=10. - CALL FUNCZBAR( & - NAR0,ZBAR0, & - BEE,PSIS,POROS,COND,RZDEP,WPWET, & - VALX0,PX0,COESKEW,TIMEAN,SUMA, & - CATDEF0,WMIN0) - - if (bug) write(*,*) 'funczbar ok' - - if (wmin0 == 0.9999900) then - do idep=1,nbdep-1 - if(catdef(idep).le.cdcr1+10.) then - if((wmin(idep) - wmin(idep +1)) > -0.01) then - wmin0=wmin(idep) - endif - endif - enddo - wmin0 = 0.1*(nint(wmin0*100000.)/10000) -0.02 - endif - - if(present(dbg_unit)) then - write (dbg_unit,*) nbdep,nbdepl,wmin0,cdcr1,cdcr2 - write (dbg_unit,*) catdef - write (dbg_unit,*) ar1 - write (dbg_unit,*) wmin - endif + !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then + if (.false.) then -!c**** AR1 adjustment: 3 points + limit in INF = 0. + Rout = Rin - if (bug) write(*,*) 'STARTING AR1' + else - ! Singular value decomposition - loc1=1 - loc3=nbdepl - loc2=loc3 + xx = Nx_in/float(Nx_out) + yy = Ny_in/float(Ny_out) - do idep = 1,loc2 - if(ar1(idep) < 1.e-10) then - loc3 = idep - 1 - exit - endif - end do - - first_loop = 0 - ars_svd_loop = .TRUE. - DO while (ars_svd_loop) - - first_loop = first_loop + 1 - mp = loc3-loc1+1 - - allocate(A(mp,3)) - allocate(AP(mp,3)) - allocate(B(mp)) - - a=0. - ap=0. - b=0. - v=0. - w=0. - ans=0. - - do isvd=loc1,loc3 - A(isvd-loc1+1,1)=catdef(isvd) - A(isvd-loc1+1,2)=-catdef(isvd)*ar1(isvd) - A(isvd-loc1+1,3)=-ar1(isvd)*((catdef(isvd))**2.) - B(isvd-loc1+1)=ar1(isvd)-1. - end do - - ap = a - call svdcmp(ap,mp,3,w,v) - sdmax=0. - do j=1,3 - if(w(j).gt.sdmax)sdmax=w(j) - end do - sdmin=sdmax*1.0e-6 - do j=1,3 - if(w(j).lt.sdmin)w(j)=0. - end do - - call svbksb(ap,w,v,mp,3,b,ans) - - ars1 = real(ans(1)) - ars2 = real(ans(2)) - ars3 = real(ans(3)) - - flag=0 - call curve1(ars1,ars2,ars3,cdcr2,flag) - deallocate (A, AP, B) - - IF(FLAG == 1) THEN - LOC3 = NBDEP - LOC1 =1 - IF(first_loop > 1) ars_svd_loop=.FALSE. - ELSE - ars_svd_loop=.FALSE. - ENDIF - END DO - - IF (FLAG.EQ.1) then - - flag=0 - loc1=1 - do idep=1,nbdepl - if (catdef(idep) .le. 20.) loc1=idep - enddo - - loc3=1 - do idep=1,nbdepl -1 - if ((ar1(idep) >= 0.0001).and.(catdef(idep) <= cdcr1)) loc3=idep + 1 - enddo - - if (loc3.le.loc1+1) then - loc1=MIN(loc3-4,loc1-4) - loc1=MAX(1,loc1) - endif - -!c below is what was used for no regression, but it's not equivalent to the -!c IDL program - loc2=AINT(loc1-1+(loc3-loc1)*3./5.)+1 - - w1=ar1(loc1) - w2=ar1(loc2) - w3=ar1(loc3) - - if(w3.eq.0.)then - 95 loc3=loc3-1 - if(loc3.eq.loc2)loc2=loc2-1 - w3=ar1(loc3) - w2=ar1(loc2) - if(w3.eq.0.)goto 95 - endif - w4=0. - - if((loc1.ge.loc2).or.(loc2.ge.loc3))then - loc1=10 - loc2=14 - loc3=18 - endif - - 115 x1=catdef(loc1) - x2=catdef(loc2) - x3=catdef(loc3) - w1=ar1(loc1) - w2=ar1(loc2) - w3=ar1(loc3) - - if (bug) then - write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 - write(*,*) 'x1,x2,x3=',x1,x2,x3 - write(*,*) 'w1,w2,w3=',w1,w2,w3 - endif - - y0=w4 - f1=(1.-w1)/(w1-y0)/x1 - f2=(1.-w2)/(w2-y0)/x2 - f3=(1.-w3)/(w3-y0)/x3 - g1=(1.-y0)/(w1-y0) - g2=(1.-y0)/(w2-y0) - g3=(1.-y0)/(w3-y0) - df=f2-f1 - dg=g2-g1 - dx=x2-x1 - bf=f1-x1*df/dx - bg=g1-x1*dg/dx - - ars1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) - ars2 = bf+ars1*bg - ars3 = (df+ars1*dg)/dx - - delta=ars2*ars2-4*ars3 - upval=1.+200.*ars1 - loval=1.+200.*ars2+40000.*ars3 - z1=0. - z2=0. - - if (delta .ge. 0.) then !if 8 - z1=(-ars2-SQRT(delta))/2./ars3 - z2=(-ars2+SQRT(delta))/2./ars3 - endif - - if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & - (z2 .gt. 0. .and. z1 .lt. cdcr1) .or. & - ((upval/loval).lt.-.01)) then !if 7 - z1=0. - z2=0. - if (loc1 .eq. 10) then - loc1=1 -1 else - loc1=1 - do idep=1,nbdepl - if (catdef(idep) .gt. 60.) then - loc1=idep - if(loc1.ge.loc3-1)then - ! write(*,*)'Loc1 exceeded loc3 in 2nd attempt' - loc1=loc3-5 - endif - goto 46 - endif - enddo - endif -46 loc2=loc1+AINT(float(loc3-loc1)*3./5.)+1 - if(loc2.ge.loc3)loc2=loc3-1 - loc2save=loc2 - INC=1 - DEC=0 - -47 w1=ar1(loc1) - w2=ar1(loc2) - x1=catdef(loc1) - x2=catdef(loc2) - - if (bug) then - write(*,*) 'z1,z2=',z1,z2,' -> ar1, 2nd try' - write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 - write(*,*) 'x1,x2,x3=',x1,x2,x3 - write(*,*) 'w1,w2,w3=',w1,w2,w3 - endif - - f1=(1.-w1)/(w1-y0)/(x1 + 1.e-20) - f2=(1.-w2)/(w2-y0)/(x2 + 1.e-20) - g1=(1.-y0)/(w1-y0 + 1.e-20 ) - g2=(1.-y0)/(w2-y0 + 1.e-20) - df=f2-f1 - dg=g2-g1 - dx=x2-x1 - bf=f1-x1*df/dx - bg=g1-x1*dg/dx - - ars1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) - ars2 = bf+ars1*bg - ars3 = (df+ars1*dg)/dx - delta=ars2*ars2-4*ars3 - upval=1.+200.*ars1 - loval=1.+200.*ars2+40000.*ars3 - - if (delta .ge. 0.) then !if 6 - z1=(-ars2-SQRT(delta))/2./ars3 - z2=(-ars2+SQRT(delta))/2./ars3 - end if - - if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & - (z2 .gt. 0. .and. z1 .lt. cdcr1) .or. & - ((upval/loval).lt.-.01)) then !if 5 - !c Sarith --- - z1=0. - z2=0. - IF(INC.EQ.1)loc2=loc2+1 - IF(DEC.EQ.1)LOC2=LOC2-1 - if(inc.eq.1)then !if 4 - if(loc2.ge.loc3)then !if 3 - ! WRITE(*,*)'INCREASING LOC2 FAILED' - INC=0 - DEC=1 - loc2=loc2save - else - adjust=ADJUST+1 - goto 47 - end if !if 3 - endif !if 4 - - if(dec.eq.1)then !if 2 - if(loc2.eq.loc1)then !if 1 - ! WRITE(*,*)'Decreasing too failed' - INC=1 - DEC=0 - ars1=9999. !ars1old - ars2=9999. !ars2old - ars3=9999. !ars3old - ! write(*,*) 'AR1: PROBLEM for pfc=',pfc - else - adjust=ADJUST+1 - !c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST - goto 47 - end if !if 1 - endif !if 2 - endif !if 5 - !c endif !if 6 - endif !if 7 - - !c endif !if 8 - flag=0 - call curve1(ars1,ars2,ars3,cdcr2,flag) - - IF (FLAG.EQ.1)then - ! WRITE(*,*)'Curve problem in the catchment pfc=',pfc - ars1=9999. - ars2=9999. - ars3=9999. - ! write(*,*) 'Pick values from icatch-1' - flag=0 - end if - endif - - adjust=0 - - if (bug) write(*,*) 'ar1 adjustment ok' - -!c**** WMIN adjustment: 3 points + limit in INF = wmin0 - - if (bug) write(*,*) 'STARTING WMIN' - - w4=wmin0 - y0=w4 - -! write(*,*) 'wmin=',(wmin(idep),idep=1,50) - - loc1=1 - do idep=1,nbdepl - if (catdef(idep) <= 10.) loc1=idep - enddo - - loc3=1 - do idep=1,nbdepl - 2 - if ((wmin(idep) >= wmin0).and.(catdef(idep) <= cdcr1)) loc3=idep + 2 - enddo - - loc2=loc1 + 2 - do idep=1,nbdepl -1 - if ((wmin(idep) >= wmin0).and.(catdef(idep) <= cdcr1/2.))loc2=idep + 1 - enddo - -!c For global catch - INC=1 - DEC=0 - - if(loc3.eq.loc2)loc2=loc2-2 - if(loc2 <= loc1) loc1= loc1-2 - 44 loc2save=loc2 - if(loc1 < 1) then - loc1 =1 - loc2 =2 - loc3 =3 - endif - - w1=wmin(loc1) - w2=wmin(loc2) - w3=wmin(loc3) - x1=catdef(loc1) - x2=catdef(loc2) - x3=catdef(loc3) - - if (bug) then - write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 - write(*,*) 'x1,x2,x3=',x1,x2,x3 - write(*,*) 'w1,w2,w3,w4=',w1,w2,w3,w4 - endif - - f1=(1.-w1)/(w1-y0)/x1 - f2=(1.-w2)/(w2-y0)/x2 - f3=(1.-w3)/(w3-y0)/x3 - g1=(1.-y0)/(w1-y0) - g2=(1.-y0)/(w2-y0) - g3=(1.-y0)/(w3-y0) - df=f2-f1 - dg=g2-g1 - dx=x2-x1 - bf=f1-x1*df/dx - bg=g1-x1*dg/dx - - arw1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) - arw2 = bf+arw1*bg - arw3 = (df+arw1*dg)/dx - arw4 = y0 - -!c wmin=arw4+(1.-arw4)*(1.+arw1*catdef(idep)) -!c /(1.+arw2*catdef(idep)+arw3*catdef(idep)*catdef(idep)) -!c we want to check the roots of the denominator - - delta=arw2*arw2-4*arw3 - - if (delta .ge. 0.) then !if 8 - - z1=(-arw2-SQRT(delta))/2./arw3 - z2=(-arw2+SQRT(delta))/2./arw3 - - if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & - (z2 .gt. 0. .and. z1 .lt. cdcr1)) then !if 7 - - w1_0=w1 - w1=(1.+w1_0)/2. - x1=x1/4. - -! if (gnu .eq. 3.26/1.5) then -! w1=(1.+w1_0)/3. ! already difficult -! w3=wmin(nint(cdcr1)) ! with gnu=3.26 -! x3=catdef(nint(cdcr1)) -! f3=(1.-w3)/(w3-y0)/x3 -! g3=(1.-y0)/(w3-y0) -! endif - - f1=(1.-w1)/(w1-y0)/x1 - g1=(1.-y0)/(w1-y0) - df=f2-f1 - dg=g2-g1 - dx=x2-x1 - bf=f1-x1*df/dx - bg=g1-x1*dg/dx - - if (bug) then - write(*,*) 'z1,z2=',z1,z2,' -> wmin, 2nd try' - write(*,*) 'loc1,loc2,loc3=',loc1,loc2,loc3 - write(*,*) 'x1,x2,x3=',x1,x2,x3 - write(*,*) 'w1,w2,w3=',w1,w2,w3 - write(*,*) 'wmin0=',wmin0 - endif - - arw1 = -(f3-bf-x3*df/dx)/(g3-bg-x3*dg/dx + 1.e-10) - arw2 = bf+arw1*bg - arw3 = (df+arw1*dg)/dx - arw4 = y0 - - delta=arw2*arw2-4*arw3 - - if (delta .ge. 0.) then !if 6 - z1=(-arw2-SQRT(delta))/2./arw3 - z2=(-arw2+SQRT(delta))/2./arw3 - - if ((z1 .gt. 0. .and. z1 .lt. cdcr1) .or. & - (z2 .gt. 0. .and. z1 .lt. cdcr1)) then !if 5 -!c Sarith --- - IF(INC.EQ.1)loc2=loc2+1 - IF(DEC.EQ.1)LOC2=LOC2-1 - if(inc.eq.1)then !if 4 - if(loc2.eq.loc3)then !if 3 -! WRITE(*,*)'INCREASING LOC2 FAILED: WMIN' - INC=0 - DEC=1 - loc2=loc2save - else - adjust=ADJUST+1 -!c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST - goto 44 - end if !if 3 - endif !if 4 - if(dec.eq.1)then !if 2 - if(loc2.eq.loc1)then !if 1 -! WRITE(*,*)'Decreasing too failed: WMIN' - INC=1 - DEC=0 - - arw1=9999. - arw2=9999. - arw3=9999. - arw4=9999. - - else - adjust=ADJUST+1 -!c write(*,*)'ADJUSTING AR1 CYCLE =',ADJUST - goto 44 - end if !if 1 - endif !if 2 - endif !if 5 - endif !if 6 - - endif !if 7 - endif !if 8 - adjust=0 -! endif ! pfc=12821 - flag=0 - - call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) - - IF (FLAG.EQ.1) THEN - arw1=9999. !arw1old - arw2=9999. !arw2old - arw3=9999. !arw3old - arw4=9999. !arw4old - flag=0 - endif + do j=1,Ny_out + jj = (j-1)*yy + 1 + do i=1,Nx_out + ii = (i-1)*xx + 1 + Rout(i,j) = Rin(ii,jj) + end do + end do - if(arw1==9999.) then -! Singular Value Decomposition + end if - w4=wmin0 - y0=w4 + end subroutine RegridRaster2 - loc1=1 - loc3=nbdepl + ! ----------------------------------------------------------------------------------- - mp = loc3-loc1+1 + subroutine RegridRasterReal(Rin,Rout) - if(mp.lt.3)then + ! same as RegridRaster() but for gridded real values - write(*,*)'WMIN Note: not sufficient points MP = ',mp - print *,w4,cdcr1,catdef(loc3),wmin(loc3) - arw1 = 9999. - arw2 = 9999. - arw3 = 9999. - arw4 = 9999. - else - - mp = 1 - istart =1 - w4 = wmin(istart) + real, intent(IN) :: Rin( :,:) + real, intent(OUT) :: Rout(:,:) - if(w4 <=0) then - do idep=2,nbdepl - if(wmin(idep) > 0.) istart = idep - if(wmin(idep) > 0.) exit - enddo - endif + REAL(REAL64) :: xx, yy + integer :: i, j, ii, jj + integer :: Nx_in, Ny_in, Nx_out, Ny_out - w4 = wmin(istart) + Nx_in = size(Rin ,1) + Ny_in = size(Rin ,2) - do idep=istart+1,nbdepl -! if(wmin(idep).lt.w4) then - if((wmin(idep) - w4).lt.0.0005) then - w4 = wmin(idep) - mp = mp +1 - endif - enddo - loc3 = mp - allocate(A(mp,3)) - allocate(AP(mp,3)) - allocate(B(mp)) - allocate(BP(mp)) - smooth = .false. - do idep=istart,nbdepl-1 - if(catdef(idep).le.cdcr1+10.) then - if((wmin(idep) - wmin(idep +1)) < -0.01) smooth = .true. - endif - enddo - if(smooth) then - wminsave = wmin - ! Apply filter to input data - do i=istart, nbdepl-nr - wmin(i)=0. - do j=1, nl+nr+1 - if (i+savgol_ind(j).gt.0) then !skip left points that do not exist - wmin(i)=wmin(i)+savgol_coeff(j)*wminsave(i+savgol_ind(j)) - endif - end do - enddo - wmin (istart:istart+4) = wminsave (istart:istart+4) - - endif - - j = 1 - w4 = wmin(istart) - do isvd=1,size(wmin) - if (j <= mp) then - if(isvd == 1) then - wbrac=(wmin(isvd + istart -1)-y0)/(1.-y0 + 1.e-20) - A(j,1)=catdef(isvd + istart -1) - A(j,2)=-catdef(isvd + istart -1)*wbrac - A(j,3)=-wbrac*((catdef(isvd + istart -1))**2.) - B(j)=wbrac-1. - j = j + 1 - else - if((wmin(isvd + istart -1).lt.w4).and.(wmin(isvd + istart -1).gt.y0)) then - wbrac=(wmin(isvd + istart -1)-y0)/(1.-y0 + 1.e-20) - A(j,1)=catdef(isvd + istart -1) - A(j,2)=-catdef(isvd + istart -1)*wbrac - A(j,3)=-wbrac*((catdef(isvd + istart -1))**2.) - B(j)=wbrac-1. - w4 = wmin(isvd + istart -1) - j = j + 1 - endif - endif - endif - end do - - j = j -1 - mp = j - ap => a (1:j,:) - bp => b (1:j) - ap(j,1) = catdef(nbdep) - ap(j,2) = 0. - ap(j,3) = 0. - bp (j) = -1. - - call svdcmp(ap,mp,3,w,v) - - sdmax=0. - do j=1,3 - if(w(j).gt.sdmax)sdmax=w(j) - end do - - sdmin=sdmax*1.0e-6 - do j=1,3 - if(w(j).lt.sdmin)w(j)=0. - end do - - call svbksb(ap,w,v,mp,3,bp,ans) - - arw1 = real(ans(1)) - arw2 = real(ans(2)) - arw3 = real(ans(3)) - arw4 = y0 - -!c wmin=arw4+(1.-arw4)*(1.+arw1*catdef(idep)) -!c /(1.+arw2*catdef(idep)+arw3*catdef(idep)*catdef(idep)) -!c we want to check the roots of the denominator - - adjust=0 - flag=0 - - call curve2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) - - IF (FLAG.EQ.1) THEN - ! WRITE(*,*)'Curve2 problem in the catchment:pfc=',pfc - - arw1 = 9999. - arw2 = 9999. - arw3 = 9999. - arw4 = 9999. - - flag=0 - end if - deallocate (A, B ) - NULLIFY (AP, BP) - end if - endif - - if(present(dbg_unit)) then - write (dbg_unit,*) ars1,ars2,ars3 - write (dbg_unit,*) arw1,arw2,arw3,arw4 - endif - - if (bug) write(*,*) 'wmin adjustment ok' - -!c**** SHAPE PARAMETER ADJUSTMENT: with a straight if coeskew > 0.25 -!c with 2 segments if not - - if (bug) write(*,*) 'STARTING SHAPE' - - x3=catdef(nbdepl) - w3=aa(nbdepl) - x1=0. - - if (coeskew .lt. 0.25) then - w1=0.1 - loc2=20 - do idep=1,nbdepl - if (catdef(idep) .gt. ref1) then - loc2=idep - goto 45 - endif - enddo - 45 x2=catdef(loc2) - w2=aabis(loc2) - ara1 = (w1-w2)/(x1-x2) - ara2 = w1-ara1*x1 - ara3 = (w2-w3)/(x2-x3) - ara4 = w2-ara3*x2 - else - w1=1. - x2=x1 - w2=w1 - ara3 = (w2-w3)/(x2-x3) - ara4 = w2-ara3*x2 - ara1 = ara3 - ara2 = ara4 - endif - - if (bug) write(*,*) 'x1,w1,x2,w2,x3,w3',x1,w1,x2,w2,x3,w3 - -!**** RMSE checking: on ar1, ar2, swsrf2 and rzeq - - do idep=1,nbdepl - if(catdef(idep) <= cdcr1) then - nar1(idep)=AMIN1(1.,AMAX1(0.,(1.+ars1*catdef(idep)) & - /(1.+ars2*catdef(idep) & - +ars3*catdef(idep)*catdef(idep)))) - - nwm=AMIN1(1.,AMAX1(0.,arw4+(1.-arw4)* & - (1.+arw1*catdef(idep)) & - /(1.+arw2*catdef(idep) & - +arw3*catdef(idep)*catdef(idep)))) - -!c we have to first determine if there is one or two segments - if (ara1 .ne. ara3) then - cdi=(ara4-ara2)/(ara1-ara3) - else - cdi=0. - endif - - if (catdef(idep) .ge. cdi) then - shape=ara3*catdef(idep)+ara4 - else - shape=ara1*catdef(idep)+ara2 - endif - shape =AMIN1(40.,shape) - area1=exp(-shape*(1.-nwm))*(shape*(1.-nwm)+1.) - -!c the threshold for truncation problems is higher than the "usual" -!c E-8 to E-10, because it plays together with the uncertainties coming -!c from the approximation of the parameters nwm, nar1 and shape. - if (area1 .ge. 1.-1.E-8) then - nar1(idep)=1. - nar2(idep)=0. - nar3(idep)=0. - nmean2(idep)=0. - nmean3=0. - neq(idep)=1. - else - - if (nwm .gt. wpwet) then - nar2(idep)=1.-nar1(idep) - else - nar2(idep)=AMAX1(0.,((shape*(wpwet-nwm)+1.) & - *exp(-shape*(wpwet-nwm)) & - - (shape*(1.-nwm)+1.)*exp(-shape*(1.-nwm))) & - * (1.-nar1(idep))/(1.-area1)) - endif - - nar3(idep)=1.-nar1(idep)-nar2(idep) - - if (nar3(idep) .lt. 1.E-8) then ! for nwm le wpwet - - nmean2(idep)=AMAX1(0.,AMIN1(1.,(nwm + 2./shape + & - shape*exp(-shape*(1.-nwm))* & - (nwm+nwm/shape-1.-2./shape-2./(shape*shape))) & - /(1.-area1))) - nmean3=0. + Nx_out = size(Rout,1) + Ny_out = size(Rout,2) - else + !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then + if (.false.) then -!c WARNING: I think the two values below are false. -!c But it is never used in this context, because nwm > wpwet !! - nmean2(idep)=AMAX1(0.,AMIN1(1.,-shape*(exp(-shape*& - (wpwet-nwm))* (nwm*wpwet & - +nwm/shape-wpwet*wpwet & - -2.*wpwet/shape-2./(shape*shape)) & - - exp(-shape*(1.-nwm))* & - (nwm+nwm/shape-1.-2./shape-2./(shape*shape)))& - * (1.-nar1(idep))/(1.-area1) / (nar2(idep)+1.e-20))) - - nmean3=AMAX1(0.,AMIN1(1.,(nwm+2./shape + & - shape*exp(-shape*(wpwet-nwm))* & - (nwm*wpwet+nwm/shape-wpwet & - *wpwet-2.*wpwet/shape & - -2./(shape*shape))) * (1.-nar1(idep)) & - /(1.-area1)/(nar3(idep) + 1.e-20))) - endif - - neq(idep)=nar1(idep)+nar2(idep)*nmean2(idep) & - +nar3(idep)*nmean3 - - if (area1 .ge. 1.-1.E-5) then - nmean2(idep)=1. - nmean3=0. - neq(idep)=1. - endif + Rout = Rin - endif - endif - enddo + else - if (bug) write(*,*) 'shape adjustment ok' -!c -!c RMSE - -!c ERR1 - icount=0 - iref=0 - sum=0. - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - tabact(i)=0. - tabfit(i)=0. - endif - enddo + xx = Nx_in/float(Nx_out) + yy = Ny_in/float(Ny_out) - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - if (catdef(i) .gt. lim) then - icount=icount+1 - sum=sum+ar1(i) - tabfit(icount)=nar1(i) - tabact(icount)=ar1(i) - endif - endif - enddo + do j=1,Ny_out + jj = (j-1)*yy + 1 + do i=1,Nx_out + ii = (i-1)*xx + 1 + Rout(i,j) = Rin(ii,jj) + end do + end do - if(icount.gt.1) then - sum=sum/icount - call RMSE(tabact,tabfit,icount,err1) - taberr1=err1 - normerr1=err1/sum - endif -!c ERR2 - icount=0 - iref=0 - sum=0. - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - tabact(i)=0. - tabfit(i)=0. - endif - enddo + end if - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - if (catdef(i) .gt. lim) then - icount=icount+1 - sum=sum+ar2(i) - tabfit(icount)=nar2(i) - tabact(icount)=ar2(i) - endif - endif - enddo + end subroutine RegridRasterReal - if(icount.gt.1) then - sum=sum/icount - call RMSE(tabact,tabfit,icount,err2) - taberr2=err2 - normerr2=err2/sum - endif - -!c ERR3 - icount=0 - iref=0 - sum=0. - do i=1,nbdep - if(catdef(i) <= cdcr1) then - tabact(i)=0. - tabfit(i)=0. - endif - enddo + !--------------------------------------------------------------------- + + SUBROUTINE svbksb(u,w,v,m,n,b,x) + + INTEGER m,mp,n,np,NMAX + REAL*8 b(m),u(m,n),v(n,n),w(n),x(n) + PARAMETER (NMAX=500) !Maximum anticipated value of n + !------------------------------------------------------------------------------------------- + ! Solves A · X = B for a vector X, where A is specified by the arrays u, w, v as returned by + ! svdcmp. m and n are the dimensions of a, and will be equal for square matrices. b(1:m) is + ! the input right-hand side. x(1:n) is the output solution vector. No input quantities are + ! destroyed, so the routine may be called sequentially with different b’s. + !------------------------------------------------------------------------------------------- + + INTEGER i,j,jj + REAL*8 s,tmp(NMAX) + do j=1,n !Calculate UTB. + s=0. + if(w(j).ne.0.)then !Nonzero result only if wj is nonzero. + do i=1,m + s=s+u(i,j)*b(i) + end do + s=s/(w(j) + 1.d-20) !This is the divide by wj . + endif + tmp(j)=s + end do + do j=1,n !Matrix multiply by V to get answer. + s=0. + do jj=1,n + s=s+v(j,jj)*tmp(jj) + end do + x(j)=s + end do + return + END SUBROUTINE svbksb + + !--------------------------------------------------------------------- + + SUBROUTINE svdcmp(a,m,n,w,v) + + INTEGER m,n,NMAX + REAL*8, intent (inout) :: a(m,n) + REAL*8, intent (out) :: v(n,n),w(n) + PARAMETER (NMAX=500) !Maximum anticipated value of n. + !-------------------------------------------------------------------------------------- + ! Given a matrix A(1:m,1:n), this routine computes its singular value decomposition, + ! A = U · W · Vt. The matrix U replaces A on output. The diagonal matrix of singular + ! values W is output as a vector W(1:n). The matrix V (not the transpose Vt) is output + ! as V(1:n,1:n). + !-------------------------------------------------------------------------------------- + + INTEGER i,its,j,jj,k,l,nm + REAL*8 anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX) + real*8, parameter :: EPS=epsilon(1.0d0) + g=0.d0 !Householder reduction to bidiagonal form. + scale=0.d0 + anorm=0.d0 + c =0.d0 + f =0.d0 + g =0.d0 + h =0.d0 + s =0.d0 + x =0.d0 + y =0.d0 + z =0.d0 + rv1=0.d0 + w = 0.d0 + v = 0.d0 + do i=1,n + l=i+1 + rv1(i)=scale*g + g=0.d0 + s=0.d0 + scale=0.d0 + if(i.le.m)then + do k=i,m + scale=scale+abs(a(k,i)) + end do + if(scale.ne.0.d0)then + do k=i,m + a(k,i)=a(k,i)/scale + s=s+a(k,i)*a(k,i) + end do + f=a(i,i) + g=-dsign(dsqrt(s),f) + h=f*g-s + a(i,i)=f-g + do j=l,n + s=0.d0 + do k=i,m + s=s+a(k,i)*a(k,j) + end do + f=s/h + do k=i,m + a(k,j)=a(k,j)+f*a(k,i) + end do + end do + do k=i,m + a(k,i)=scale*a(k,i) + end do + endif + endif + w(i)=scale *g + g=0.d0 + s=0.d0 + scale=0.d0 + if((i.le.m).and.(i.ne.n))then + do k=l,n + scale=scale+abs(a(i,k)) + end do + if(scale.ne.0.d0)then + do k=l,n + a(i,k)=a(i,k)/scale + s=s+a(i,k)*a(i,k) + end do + f=a(i,l) + g=-sign(sqrt(s),f) + h=f*g-s + a(i,l)=f-g + do k=l,n + rv1(k)=a(i,k)/h + end do + do j=l,m + s=0.d0 + do k=l,n + s=s+a(j,k)*a(i,k) + end do + do k=l,n + a(j,k)=a(j,k)+s*rv1(k) + end do + end do + do k=l,n + a(i,k)=scale*a(i,k) + end do + endif + endif + anorm=max(anorm,(abs(w(i))+abs(rv1(i)))) + end do !do i=1,n + + do i=n,1,-1 !Accumulation of right-hand transformations. + if(i.lt.n)then + if(g.ne.0.d0)then + do j=l,n !Double division to avoid possible underflow. + v(j,i)=(a(i,j)/a(i,l))/g + end do + do j=l,n + s=0.d0 + do k=l,n + s=s+a(i,k)*v(k,j) + end do + do k=l,n + v(k,j)=v(k,j)+s*v(k,i) + end do + end do + endif + do j=l,n + v(i,j)=0.d0 + v(j,i)=0.d0 + end do + endif + v(i,i)=1.d0 + g=rv1(i) + l=i + end do + + do i=min(m,n),1,-1 !Accumulation of left-hand transformations. + l=i+1 + g=w(i) + do j=l,n + a(i,j)=0.d0 + end do + if(g.ne.0.d0)then + g=1.d0/g + do j=l,n + s=0.d0 + do k=l,m + s=s+a(k,i)*a(k,j) + end do + f=(s/a(i,i))*g + do k=i,m + a(k,j)=a(k,j)+f*a(k,i) + end do + end do + do j=i,m + a(j,i)=a(j,i)*g + end do + else + do j= i,m + a(j,i)=0.d0 + end do + endif + a(i,i)=a(i,i)+1.d0 + end do - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - if (catdef(i) .gt. lim) then - icount=icount+1 - sum=sum+swsrf2(i) - tabfit(icount)=nmean2(i) - tabact(icount)=swsrf2(i) + do k=n,1,-1 !Diagonalization of the bidiagonal form: Loop over + !singular values, and over allowed iterations. + do its=1,30 + do l=k,1,-1 !Test for splitting. + nm=l-1 !Note that rv1(1) is always zero. + if( abs(rv1(l)) <= EPS*anorm ) goto 2 + if( abs(w(nm) ) <= EPS*anorm ) goto 1 + end do +1 c=0.d0 !Cancellation of rv1(l), if l > 1. + s=1.d0 + do i=l,k + f=s*rv1(i) + rv1(i)=c*rv1(i) + if( abs(f) <= EPS*anorm ) goto 2 + g=w(i) + h=pythag(f,g) + w(i)=h + h=1.d0/h + c= (g*h) + s=-(f*h) + do j=1,m + y=a(j,nm) + z=a(j,i) + a(j,nm)=(y*c)+(z*s) + a(j,i)=-(y*s)+(z*c) + end do + end do +2 z=w(k) + if(l.eq.k)then !Convergence. + if(z.lt.0.d0)then !Singular value is made nonnegative. + w(k)=-z + do j=1,n + v(j,k)=-v(j,k) + end do endif + goto 3 + endif + if(its.eq.30) print *, 'no convergence in svdcmp' + ! if(its.ge.4) print *, 'its = ',its + x=w(l) !Shift from bottom 2-by-2 minor. + nm=k-1 + y=w(nm) + g=rv1(nm) + h=rv1(k) + f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y) + g=pythag(f,1.d0) + f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x + c=1.d0 !Next QR transformation: + s=1.d0 + do j=l,nm + i=j+1 + g=rv1(i) + y=w(i) + h=s*g + g=c*g + z=pythag(f,h) + rv1(j)=z + c=f/z + s=h/z + f= (x*c)+(g*s) + g=-(x*s)+(g*c) + h=y*s + y=y*c + do jj=1,n + x=v(jj,j) + z=v(jj,i) + v(jj,j)= (x*c)+(z*s) + v(jj,i)=-(x*s)+(z*c) + end do + z=pythag(f,h) + w(j)=z !Rotation can be arbitrary if z = 0. + if(z.ne.0.d0)then + z=1.d0/z + c=f*z + s=h*z endif - enddo + f= (c*g)+(s*y) + x=-(s*g)+(c*y) + do jj=1,m + y=a(jj,j) + z=a(jj,i) + a(jj,j)= (y*c)+(z*s) + a(jj,i)=-(y*s)+(z*c) + end do + end do !j=l;nm + rv1(l)=0.d0 + rv1(k)=f + w(k)=x + end do !its=1,30 +3 continue + end do !k=n,1,-1 + return + END SUBROUTINE svdcmp + ! + ! ________________________________________________________________________________ + ! + REAL*8 FUNCTION pythag(a,b) + REAL*8 a,b + !Computes sqrt(a**2 + b**2) without destructive underflow or overflow. + REAL*8 absa,absb + absa=abs(a) + absb=abs(b) + if(absa.gt.absb)then + pythag=absa*sqrt(1.+(absb/absa)**2) + else + if(absb.eq.0.)then + pythag=0. + else + pythag=absb*sqrt(1.+(absa/absb)**2) + endif + endif + return + END FUNCTION pythag + ! + ! ________________________________________________________________________________ + ! + + SUBROUTINE savgol(c,np,nl,nr,ld,m) + + INTEGER ld,m,nl,np,nr,MMAX + real c(np) + PARAMETER (MMAX=6) + !-------------------------------------------------------------------------------------------- + !USES lubksb,ludcmp given below. + !Returns in c(1:np), in wrap-around order (see reference) consistent with the argument respns + !in routine convlv, a set of Savitzky-Golay filter coefficients. nl is the number of leftward + !(past) data points used, while nr is the number of rightward (future) data points, making + !the total number of data points used nl +nr+1. ld is the order of the derivative desired + !(e.g., ld = 0 for smoothed function). m is the order of the smoothing polynomial, also + !equal to the highest conserved moment; usual values are m = 2 or m = 4. + !-------------------------------------------------------------------------------------------- + INTEGER d,icode,imj,ipj,j,k,kk,mm,indx(MMAX+1) + real fac,sum,a(MMAX+1,MMAX+1),b(MMAX+1) + if(np.lt.nl+nr+1.or.nl.lt.0.or.nr.lt.0.or.ld.gt.m.or.m.gt.MMAX & + .or.nl+nr.lt.m) pause ' Bad args in savgol.' + do ipj=0,2*m !Set up the normal equations of the desired leastsquares fit. + sum=0. + if(ipj.eq.0) sum=1. + do k=1,nr + sum=sum+dfloat(k)**ipj + end do + do k=1,nl + sum=sum+dfloat(-k)**ipj + end do + mm=min(ipj,2*m-ipj) + do imj=-mm,mm,2 + a(1+(ipj+imj)/2,1+(ipj-imj)/2)=sum + end do + end do - if(icount.gt.1) then - sum=sum/icount - call RMSE(tabact,tabfit,icount,err3) - taberr3=err3 - normerr3=err3/sum - endif -!c ERR4 - icount=0 - iref=0 - sum=0. - do i=1,nbdepl - tabact(i)=0. - tabfit(i)=0. - enddo + call ludcmp(a,m+1,MMAX+1,indx,d,icode) !Solve them: LU decomposition. - do i=1,nbdepl - if(catdef(i) <= cdcr1) then - if (catdef(i) .gt. lim) then - icount=icount+1 - sum=sum+rzeq(i) - tabfit(icount)=neq(i) - tabact(icount)=rzeq(i) - endif - endif - enddo + do j=1,m+1 + b(j)=0. + end do + b(ld+1)=1. !Right-hand side vector is unit vector, depending on which derivative we want. - if(icount.gt.1) then - sum=sum/icount - call RMSE(tabact,tabfit,icount,err4) - taberr4=err4 - normerr4=err4/sum - endif - END SUBROUTINE SAT_PARAM -! + call lubksb(a,m+1,MMAX+1,indx,b) !Backsubstitute, giving one row of the inverse matrix. -! ****************************************************************** - -!c - SUBROUTINE CURVE1(ars1,ars2,ars3,cdcr2,flag) - REAL ars1,ars2,ars3,y,x,yp,cdcr2 - INTEGER i,flag -!c - yp=1. - if (abs(ars1+ars2+ars3).le.1.e25) then - do i=0,CEILING(cdcr2) - x=float(i) - if(x > cdcr2) x = cdcr2 - y=(1.+ars1*x)/(1.+ars2*x+ars3*x*x + 1.e-20) - if((y.gt.0.0).and.(((yp -y) .lt. -1.e-4).or.(y.gt.1.)))then - flag=1 - goto 99 - endif - yp=y - end do - 99 continue - else - flag=1 - endif - - end SUBROUTINE CURVE1 - - -! ****************************************************************** - - SUBROUTINE CURVE2(arw1,arw2,arw3,arw4,cdcr1,WPWET,flag) - REAL arw1,arw2,arw3,arw4,y,x,yp,cdcr1, wpwet - INTEGER i,flag -!c - yp=1. - if (abs(arw1+arw2+arw3+arw4).le.1.e25) then - do i=0,CEILING(cdcr1) - x=float(i) - if(x > cdcr1) x = cdcr1 - y=arw4+(1.-arw4)*(1.+arw1*x)/(1.+arw2*x+arw3*x*x + 1.e-20) - if ((y .lt. wpwet).or.((yp -y) .lt. -1.e-4).or.(y.gt.1.)) then - flag=1 - goto 99 - endif - yp=y - end do -99 continue - else - flag=1 - endif - end SUBROUTINE CURVE2 - -! ****************************************************************** - - subroutine tgen ( & - TOPMEAN,TOPVAR,TOPSKEW, & - STO,ACO,COESKEW) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! c -! The difference between tgen4 and tgen3 is that tgen4 deals with arrays c -! of topmean, topvar and topskew and 2-dim arrays of st and ac. c -! c -! This routine determine the theoretical gamma distribution for the c -! soil-topographic indexes (Sivapalan et al., 1987), knowing the three c -! first moments, the min and the max of the observed topographic indexes c -! in a given catchment. c -! c -! Routine from Dave Wolock. c -! Modified by Agnes (11-06-98): we don't use min and max anymore, and c -! this strongly improves the behavior for negative skewnesses. It also c -! improves in general the matching of the moments. c -! c -! We also add a correction on the skewness to have gamma distributions c -! that start and end from the x-axis. It is based on the fact that if c -! TOPETA=1, the gamma is an exponential distribution, and if TOPETA<1, c -! then the gamma distribution increases towards the infinite when x c -! decreases towards 0. c -! To eliminate some numerical pb due to teh discretization of the gamma c -! distribution, we choose skewness=MAX(MIN(1.9, skewness),-1.6) c -! c -! WE MAY NEED TO COMPUTE IN DOUBLE RESOLUTION !!!! BECAUSE OF THE SMALL c -! BIN WIDTH -! c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - IMPLICIT NONE - - real, parameter :: VALMAX=50. - REAL, intent (in) :: TOPMEAN,TOPVAR,TOPSKEW - REAL, intent (out) :: COESKEW - REAL, dimension (NAR), intent (out) :: STO,ACO - - INTEGER I - REAL ST(NAR),AC(NAR) - REAL TOPETA,TOPLAM,TOPSCAL,GAMLN,SCALE,ACLN - real cumac, cum2,cum3 - -!------------------------------------------------------------------------- - -! topmean is the mean of the ln(a/tanB) distribution -! topvar is the variance (2nd moment centerd around the mean) of the ... -! topskew is the skew (3rd moment centerd around the mean) of the ... -! compute the coefficient of skew or skewness (coeskew) - - COESKEW=TOPSKEW/TOPVAR**1.5 - if (coeskew .ge. 0.) then - COESKEW=AMAX1(0.005, AMIN1(1.9, COESKEW)) - else - COESKEW=AMAX1(-1.6, AMIN1(-0.005, COESKEW)) - endif - -! compute the gamma parameters, eta (topeta) and lambda (toplam), and topscal -! which is the translation parameter - - TOPETA=4./COESKEW**2 - TOPLAM=SQRT(TOPETA)/SQRT(TOPVAR) - TOPSCAL=TOPMEAN-TOPETA/TOPLAM - -! evaluate the gamma function - - CALL GAMMLN (TOPETA,GAMLN) - - CUMAC=0.0 - -! compute the frequency distribution of ln(a/tanB) -! st(i) are the values of ln(a/tanB) -! ac(i) are the relative frequency values (they should sum to 1) - - DO I=1,NAR - - ST(I)=(FLOAT(I)-0.95)*(VALMAX-TOPSCAL)/FLOAT(NAR)+TOPSCAL - SCALE=ST(I)-TOPSCAL - -! below is the logarithmic form of the gamma distribution; this is required -! because the numerical estimate of the logarithm of the gamma function -! is more stable than the one of the gamma function. - - ACLN=TOPETA*ALOG(TOPLAM)+(TOPETA-1.)*ALOG(SCALE) & - -TOPLAM*SCALE-GAMLN - - IF(ACLN.LT.-10.) THEN - AC(I)=0. - ELSE - AC(I)=EXP(ACLN) - ENDIF - - CUMAC=CUMAC+AC(I) - - ENDDO - -! we want the relative frequencies to sum 1. - - IF (CUMAC.eq.0.) THEN -! write(*,*) 'distrib sum=',CUMAC - stop - endif - CUM2=0. - DO I=1,NAR - AC(I) = AC(I) / CUMAC - CUM2=CUM2+AC(I) - ENDDO - -! if the real distribution of the topographic indices is negativeley skewed, -! we symetrize the gamma distribution (depending on coeskew**2 and always -! positively skewed), centering on topmean, which preserves topmean and -! topvar, and re-establishes a negative skewness. - - IF (COESKEW.LT.0.) then - - do i=1,nar - STO(I)=2.*TOPMEAN-ST(I) - ACO(I)=AC(I) - - enddo - ELSE -! if (n .eq. idmax) then -! write(*,*) 'last catchment' -! endif - do i=1,nar - STO(I)=ST(-I+NAR+1) - ACO(I)=AC(-I+NAR+1) - enddo - ENDIF - -! sum=0. -! do i=1,nar -! sum=sum+sto(i)*aco(i) -! end do - -! sum=0. -! do i=1,nar -! sum=sum+aco(i) -! end do - - - END subroutine tgen - - ! ******************************************************************** + do kk=1,np !Zero the output array (it may be bigger than the number + c(kk)=0. !of coefficients). + end do + do k=-nl,nr !Each Savitzky-Golay coefficient is the dot product + sum=b(1) !of powers of an integer with the inverse matrix row. + fac=1. + do mm=1,m + fac=fac*k + sum=sum+b(mm+1)*fac + end do + kk=mod(np-k,np)+1 !Store in wrap-around order. + c(kk)=sum + end do + return + END SUBROUTINE savgol + + !*************************************************************** + !* Given an N x N matrix A, this routine replaces it by the LU * + !* decomposition of a rowwise permutation of itself. A and N * + !* are input. INDX is an output vector which records the row * + !* permutation effected by the partial pivoting; D is output * + !* as -1 or 1, depending on whether the number of row inter- * + !* changes was even or odd, respectively. This routine is used * + !* in combination with LUBKSB to solve linear equations or to * + !* invert a matrix. Return code is 1, if matrix is singular. * + !*************************************************************** + Subroutine LUDCMP(A,N,NP,INDX,D,CODE) + INTEGER, PARAMETER :: NMAX=100 + REAL, PARAMETER :: TINY=1E-12 + real AMAX,DUM, SUM, A(NP,NP),VV(NMAX) + INTEGER CODE, D, INDX(N),NP,N,I,J,K,IMAX + + D=1; CODE=0 + + DO I=1,N + AMAX=0. + DO J=1,N + IF (ABS(A(I,J)).GT.AMAX) AMAX=ABS(A(I,J)) + END DO ! j loop + IF(AMAX.LT.TINY) THEN + CODE = 1 + RETURN + END IF + VV(I) = 1. / AMAX + END DO ! i loop + + DO J=1,N + DO I=1,J-1 + SUM = A(I,J) + DO K=1,I-1 + SUM = SUM - A(I,K)*A(K,J) + END DO ! k loop + A(I,J) = SUM + END DO ! i loop + AMAX = 0. + DO I=J,N + SUM = A(I,J) + DO K=1,J-1 + SUM = SUM - A(I,K)*A(K,J) + END DO ! k loop + A(I,J) = SUM + DUM = VV(I)*ABS(SUM) + IF(DUM.GE.AMAX) THEN + IMAX = I + AMAX = DUM + END IF + END DO ! i loop + + IF(J.NE.IMAX) THEN + DO K=1,N + DUM = A(IMAX,K) + A(IMAX,K) = A(J,K) + A(J,K) = DUM + END DO ! k loop + D = -D + VV(IMAX) = VV(J) + END IF + + INDX(J) = IMAX + IF(ABS(A(J,J)) < TINY) A(J,J) = TINY + + IF(J.NE.N) THEN + DUM = 1. / A(J,J) + DO I=J+1,N + A(I,J) = A(I,J)*DUM + END DO ! i loop + END IF + END DO ! j loop + + RETURN + END Subroutine LUDCMP + + + !****************************************************************** + !* Solves the set of N linear equations A . X = B. Here A is * + !* input, not as the matrix A but rather as its LU decomposition, * + !* determined by the routine LUDCMP. INDX is input as the permuta-* + !* tion vector returned by LUDCMP. B is input as the right-hand * + !* side vector B, and returns with the solution vector X. A, N and* + !* INDX are not modified by this routine and can be used for suc- * + !* cessive calls with different right-hand sides. This routine is * + !* also efficient for plain matrix inversion. * + !****************************************************************** + Subroutine LUBKSB(A,N,NP,INDX,B) + INTEGER :: II,I,J,LL,N,NP + real SUM, A(NP,NP),B(N) + INTEGER INDX(N) + + II = 0 + + DO I=1,N + LL = INDX(I) + SUM = B(LL) + B(LL) = B(I) + IF(II.NE.0) THEN + DO J=II,I-1 + SUM = SUM - A(I,J)*B(J) + END DO ! j loop + ELSE IF(SUM.NE.0.) THEN + II = I + END IF + B(I) = SUM + END DO ! i loop + + DO I=N,1,-1 + SUM = B(I) + IF(I < N) THEN + DO J=I+1,N + SUM = SUM - A(I,J)*B(J) + END DO ! j loop + END IF + B(I) = SUM / A(I,I) + END DO ! i loop + + RETURN + END Subroutine LUBKSB + + ! + ! ==================================================================== + ! + + INTEGER FUNCTION center_pix (x,y,x0,y0,z0,ext_point) - SUBROUTINE GAMMLN (XX,GAMLN) - - implicit none - DOUBLE PRECISION :: COF(6),STP,HALF,ONE,FPF,X,TMP,SER - REAL, intent(in) :: XX - REAL, intent(out) :: GAMLN - integer :: j + real, dimension (:), intent(in ) :: x,y - DATA COF /76.18009173D0,-86.50532033D0,24.01409822D0, & - -1.231739516D0,.120858003D-2,-.536382D-5/ - STP = 2.50662827465D0 - HALF= 0.5D0 - ONE = 1.0D0 - FPF = 5.5D0 - - X=XX-ONE - TMP=X+FPF - TMP=(X+HALF)*LOG(TMP)-TMP - SER=ONE + real, intent(inout) :: x0,y0,z0 + logical, intent(in ) :: ext_point - DO J=1,6 - X=X+ONE - SER=SER+COF(J)/X - END DO + ! ------------------------------------------------------ - GAMLN=TMP+LOG(STP*SER) - - END SUBROUTINE GAMMLN - - ! ******************************************************************** + real, allocatable, dimension (:,:) :: length_m + real, allocatable, dimension (:) :: length + + integer :: i,j,npix,ii + + real :: zi, zj + + npix = size (x) + allocate (length_m (1:npix,1:npix)) + allocate (length (1:npix)) + length_m =0. + length =0. + + do i = 1,npix + zi = 100. - x(i) - y(i) + if (.not. ext_point) then + x0 = x(i) + y0 = y(i) + z0 = zi + endif - SUBROUTINE FUNCIDEP( & - NAR0,IDEP, &!I - BEE,PSIS,POROS,COND,RZDEP,WPWET, &!I - VALX,PX,COESKEW,TIMEAN,SUMA, &!I - CATDEF,AR1,WMIN,AA,AABIS, &!O - AR2,AR3,SWSRF2,SWSRF3,RZEQ) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c This program returns the eight parameters for the areal fractioning c -!c c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - implicit none - integer, intent (in) :: NAR0,idep - REAL, intent (in) :: BEE, PSIS, POROS, COND, RZDEP, WPWET, COESKEW - REAL, intent (inout) :: VALX(NAR), PX(NAR),TIMEAN,SUMA -! logical, intent(in) :: bug - real, dimension (nbdep), intent (inout) :: CATDEF,AR1,WMIN,AA, & - AABIS,AR2,AR3,SWSRF2,SWSRF3,RZEQ - INTEGER :: width, nref, nind,nmax,indmin,locmax,shift,ord,locmin,ordref - integer :: indimax10,indmin0,k,n,n1,n2 - real dx,zbar - - real test,term1,term2,sum - real zdep(nar),locdef(nar),wrz(nar),frcunsat - real valtest(nbdep,nar),ptest(nbdep,nar),denstest(nbdep,nar) - real dtest(nbdep,nar),cump - real x1,x2,y1,y2,wa,wb - real densaux(nar),densaux2(nar),densmax,aux10 - real :: dz, sumdef -!c------------------------------------------------------------------------- - -!c integral(f(x)dx)=1. for a pdf -!c here px=f(x)dx - dx=valx(1)-valx(2) - - if (bug) write(*,*) 'IDEP=',IDEP,' dx=',dx - -!c the loops over idmax and nbdep are initiated in sta_params4.f - - zbar=float(idep-10)*slice ! zdep in meters - -!c**** Compute array of water table depths: - do k=1,nar0 - term1=(1/gnu)*(valx(k)-timean) - zdep(k)=AMAX1(0.,zbar-term1) - enddo - -!c variable change must be reflected in dx - dz=dx/gnu - - if (bug) write(*,*) 'funcidep: ok1' - -!c**** Compute array of moisture deficits: - do k=1,nar0 - term1=(psis-zdep(k))/psis - term1=term1**(1.-1./bee) - term2=-psis*(bee/(bee-1.))*(term1-1.) - locdef(k)=zdep(k)-term2 - enddo - -!c**** Add deficits to produce catdef: - sumdef=0. - do k=1,nar0 - sumdef=sumdef+locdef(k)*px(k) - enddo - catdef(idep)=poros*1000.*sumdef/suma - - if (bug) write(*,*) 'funcidep: ok2' - -!c**** Compute array of root zone moisture (degree of wetness in root zone): - do k=1,nar0 - term1=((psis-zdep(k))/psis) & - **(1.-1./bee) - if(zdep(k).le.0.) then - wrz(k)=1. - elseif(zdep(k)-rzdep.lt.0.) then - term2=(-psis/zdep(k))*(bee/(bee-1.)) & - *(term1-1.) - frcunsat=zdep(k)/rzdep - wrz(k)=frcunsat*term2+(1.-frcunsat)*1. - else - term2=((psis-zdep(k)+rzdep) & - /psis)**(1.-1./bee) - wrz(k)=(-psis/rzdep)*(bee/ & - (bee-1.))*(term1-term2) - endif - - enddo - - if (bug) write(*,*) 'funcidep: ok3' - -!c**** compute the densities and dx -!c**** we use a usefull property that is due to the construction of the -!c**** gamma distribution in tgen3.f : this distribution is continuous, -!c**** with decreasing values on ln(a/tanb) when n goes from 1 to nar0 - -!c first we gather in the same bin all the bins with values ge 1 - nref=1 - nind=1 - ptest(idep,1)=0. - do k=1,nar0 - if (wrz(k) .eq. 1.) then - nref=nref+1 - ptest(idep,1) = ptest(idep,1) + px(k) - endif - enddo - if (nref .gt. 1) then - nind=2 - valtest(idep,1)=1. - endif - nmax=nar0-nref+nind - if (bug) write(*,*) 'nmax,nind,nar0,nref=',nmax,nind,nar0,nref - -!c definition of the probabilities ptest - if (nmax .eq. 1) then ! all the bins have values ge 1 - dtest(idep,1) = 0.0001 - ptest(idep,1) = 1. - else ! distribution in ar2/ar3 - do n=0,nmax-nind - valtest(idep,nind+n)=wrz(nref+n) - ptest(idep,nind+n)=px(nref+n) - enddo - -!c we have to define dtest, the size of each bin - if (nmax .eq. 2) then - dtest(idep,2) = valtest(idep,1)-valtest(idep,2) - dtest(idep,1) = dtest(idep,2)/2. - else ! nmax .gt. 2 - do n=2,nmax-1 - dtest(idep,n)=(valtest(idep,n-1)-valtest(idep,n+1))/2. - enddo - dtest(idep,1) = dtest(idep,2)/2. - dtest(idep,nmax) = dtest(idep,nmax-1) - endif - endif - - if (bug) write(*,*) 'funcidep: ok4' - -!c we can now define the probability density: denstest=ptest/dtest -!c where ptest is the probability and dtest the size of the bin - do n=1,nmax - if (ptest(idep,n) .eq. 0.) then - denstest(idep,n)=0. - else - denstest(idep,n)=ptest(idep,n)/dtest(idep,n) - endif - enddo - - if (bug) write(*,*) 'funcidep: ok5' - -!c NOW we can estimate the parameters for the approximated distrib -!c from the actual distrib - -!c 1. AR1=saturated area and AR2 and AR3 + averages of the RZ wetness -!c in the different fractions - - ar1(idep)=0. - ar2(idep)=0. - ar3(idep)=0. - swsrf3(idep)=0. - swsrf2(idep)=0. - rzeq(idep)=0. - - if(valtest(idep,1).eq.1.) ar1(idep)=dtest(idep,1)*denstest(idep,1) - - if (nmax .gt. 1) then - do n=nind,nmax - if (valtest(idep,n) .lt. wpwet) then - ar3(idep)=ar3(idep)+denstest(idep,n)*dtest(idep,n) - swsrf3(idep)=swsrf3(idep)+valtest(idep,n)* & - denstest(idep,n)*dtest(idep,n) - else - ar2(idep)=ar2(idep)+denstest(idep,n)*dtest(idep,n) - swsrf2(idep)=swsrf2(idep)+valtest(idep,n)* & - denstest(idep,n)*dtest(idep,n) - endif - enddo - endif - - test=ar1(idep)+ar2(idep)+ar3(idep) - if (test .gt. 1.+1.e-5 .or. test .lt. 1.-1.e-5) then -! write(*,*) 'PROBLEM at depth ',zbar -! write(*,*) ' ar1+ar2+ar3=',test -! write(*,*) ' ar1=',ar1(idep),' ar2=',ar2(idep),' ar3=', & -! ar3(idep) - endif - - ar1(idep)=ar1(idep)/test - ar2(idep)=ar2(idep)/test - ar3(idep)=ar3(idep)/test - if (ar2(idep) .ne. 0.) swsrf2(idep)=swsrf2(idep)/ar2(idep) - if (ar3(idep) .ne. 0.) swsrf3(idep)=swsrf3(idep)/ar3(idep) - - rzeq(idep)=ar1(idep)+ar2(idep)*swsrf2(idep)+ar3(idep)*swsrf3(idep) - - if (bug) write(*,*) 'funcidep: ok6' - -!c 2. Maximum density -> shape parameter -!c -> wmin - - locmax=3 - shift=15 - ordref=1 - do n=1,nmax - densaux2(n)=denstest(idep,n) - enddo - - if (nmax .ge. shift*2) then - -!c we start with sliding mean to facilitate the search for the maximum - - ord=MIN(ordref,nmax/shift) - - call smtot(densaux2,nmax,ord,densaux) -! print *,nmax,ord,shift,densaux(shift-14),shift-14,size(densaux) - do n=nmax,shift,-1 - if (densaux(n) .gt. densaux(n-1) .and. & - densaux(n) .gt. densaux(n-2) .and. & - densaux(n) .gt. densaux(n-3) .and. & - densaux(n) .gt. densaux(n-4) .and. & - densaux(n) .gt. densaux(n-5) .and. & - densaux(n) .gt. densaux(n-6) .and. & - densaux(n) .gt. densaux(n-7) .and. & - densaux(n) .gt. densaux(n-8) .and. & - densaux(n) .gt. densaux(n-9) .and. & - densaux(n) .gt. densaux(n-10) .and. & - densaux(n) .gt. densaux(n-11) .and. & - densaux(n) .gt. densaux(n-12) .and. & - densaux(n) .gt. densaux(n-13) .and. & - densaux(n) .gt. densaux(n-14))then ! .and. & -! densaux(n) .gt. densaux(n-15)) then - locmax=n - goto 30 - endif - enddo - - else - - aux10=-9999. - indimax10=3 - do n=1,nmax - if (densaux2(n) .gt. aux10) then - aux10=densaux2(n) - indimax10=n - endif - enddo - locmax=MAX(3,indimax10) - ! add protection here in case nmax <3 . why 3 ? - if (locmax > nmax) locmax = nmax - endif ! if (nmax .ge. shift+1) - 30 densmax=denstest(idep,locmax) - aa(idep)=exp(1.)*densmax - - if (bug) write(*,*) 'funcidep: ok7' - -!c WMIN=lowest value where the density is strictly gt densmax/100. - - indmin=1 - indmin0=0 - do n=1,nmax - if (denstest(idep,n) .gt. 0.) indmin0=n - if (denstest(idep,n) .gt. densmax/100. .and. & - valtest(idep,n) .lt. valtest(idep,locmax)) indmin=n - enddo - if (indmin .eq.0) indmin=indmin0 - - if (indmin .le. 2) then - wmin(idep) = 0.99999 - else - x1=valtest(idep,indmin) - wmin(idep)=x1 - endif - - if (bug) write(*,*) 'funcidep: ok8; first wmin=',wmin(idep) - -!c for negative or low coeskew the previous wmin doesn't give good results... -!c wmin is higher !!! - - if (coeskew .lt. 1. ) then - - if (locmax .gt. 3 .and. indmin .ge. locmax+4) then - n2=MAX(locmax+1,(indmin-locmax)/2+locmax) - x2=valtest(idep,n2) - y2=denstest(idep,n2) - n1=locmax - x1=valtest(idep,n1) - y1=denstest(idep,n1) - wa=(y2-y1)/(x2-x1) - wb=y1-wa*x1 - wmin(idep)=AMAX1(wmin(idep),-wb/wa) - endif - -!c wmin is even higher in some cases !!! - if (coeskew .lt. 0.2 ) wmin(idep)=wmin(idep)+0.01 - - endif - - if (bug) write(*,*) 'funcidep: ok9; 2nd wmin=',wmin(idep) - - if (valtest(idep,locmax) .le. wmin(idep)) then ! doesn't make sense - wmin(idep)=valtest(idep,locmax)-dx - endif - aabis(idep)=1./(valtest(idep,locmax)-wmin(idep)+1.e-20) + do j = i,npix + zj = 100. - x(j) - y(j) + ! length_m (i,j) = abs (x(j) - x0) + & + ! abs (y(j) - y0) + abs (zj - z0) + ! + length_m (i,j) = ((x(j) - x0)*(x(j) - x0) & + + (y(j) - y0)*(y(j) - y0) & + + (zj - z0)*(zj - z0))**0.5 + length_m (j,i) = length_m (i,j) + end do + length (i) = sum(length_m (i,:)) + end do - if (bug) write(*,*) 'funcidep: ok10' + center_pix = minloc(length,dim=1) - END SUBROUTINE FUNCIDEP - - ! ******************************************************************** + END FUNCTION center_pix - SUBROUTINE FUNCZBAR( & - NAR0,ZBAR, & - BEE,PSIS,POROS,COND,RZDEP,WPWET, & - VALX,PX,COESKEW,TIMEAN,SUMA, & - CATDEF,WMIN) - -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -!c c -!c This program returns the eight parameters for the areal fractioning c -!c c -!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - implicit none - INTEGER , intent (in) :: NAR0 - integer nref,nind,nmax,indmin,locmax,shift,ord,locmin,ordref - integer indimax10,indmin0 - REAL, intent (in) :: BEE, PSIS, POROS, COND, RZDEP, WPWET, COESKEW - REAL, intent (inout) :: VALX(NAR), PX(NAR),TIMEAN,SUMA,zbar - real, intent (inout) :: catdef,wmin - - REAL dx,dz,sumdef - real term1,term2 - real zdep(nar),locdef(nar),wrz(nar),frcunsat - real valtest(nar),ptest(nar),denstest(nar),dtest(nar) - real x1,x2,y1,y2,wa,wb - integer n1,n2,k,n - real densaux(nar),densaux2(nar),densmax,aux10 - -!c------------------------------------------------------------------------- -!c integral(f(x)dx)=1. for a pdf -!c here px=f(x)dx - dx=valx(1)-valx(2) - -!c**** Compute array of water table depths: - do k=1,nar0 - term1=(1/gnu)*(valx(k)-timean) - zdep(k)=AMAX1(0.,zbar-term1) - enddo - -!c variable change must be reflected in dx - dz=dx/gnu - -!c**** Compute array of moisture deficits: - do k=1,nar0 - term1=(psis-zdep(k))/psis - term1=term1**(1.-1./bee) - term2=-psis*(bee/(bee-1.))*(term1-1.) - locdef(k)=zdep(k)-term2 - enddo - -!c**** Add deficits to produce catdef: - sumdef=0. - do k=1,nar0 - sumdef=sumdef+locdef(k)*px(k) - enddo - catdef=poros*1000.*sumdef/suma - -!c**** Compute array of root zone moisture (degree of wetness in root zone): - do k=1,nar0 - term1=((psis-zdep(k))/psis) & - **(1.-1./bee) - if(zdep(k).le.0.) then - wrz(k)=1. - elseif(zdep(k)-rzdep.lt.0.) then - term2=(-psis/zdep(k))*(bee/(bee-1.)) & - *(term1-1.) - frcunsat=zdep(k)/rzdep - wrz(k)=frcunsat*term2+(1.-frcunsat)*1. - else - term2=((psis-zdep(k)+rzdep) & - /psis)**(1.-1./bee) - wrz(k)=(-psis/rzdep)*(bee/ & - (bee-1.))*(term1-term2) - endif - enddo - -!c**** compute the densities and dx -!c**** we use a usefull property that is due to the construction of the -!c**** gamma distribution in tgen3.f : this distribution is continuous, -!c**** with decreasing values on ln(a/tanb) when n goes from 1 to nar0 -!c first we gather in the same bin all the bins with values ge 1 - nref=1 - nind=1 - ptest(1)=0. - do k=1,nar0 - if (wrz(k) .eq. 1.) then - nref=nref+1 - ptest(1) = ptest(1) + px(k) - endif - enddo - if (nref .gt. 1) then - nind=2 - valtest(1)=1. - endif - nmax=nar0-nref+nind - -!c definition of the probabilities ptest - if (nmax .eq. 1) then ! all the bins have values ge 1 - dtest(1) = 0.0001 - ptest(1) = 1. - else ! distribution in ar2/ar3 - do n=0,nmax-nind - valtest(nind+n)=wrz(nref+n) - ptest(nind+n)=px(nref+n) - enddo - -!c we have to define dtest, the size of each bin - if (nmax .eq. 2) then - dtest(2) = valtest(1)-valtest(2) - dtest(1) = dtest(2)/2. - else ! nmax .gt. 2 - do n=2,nmax-1 - dtest(n)=(valtest(n-1)-valtest(n+1))/2. - enddo - dtest(1) = dtest(2)/2. - dtest(nmax) = dtest(nmax-1) - endif - endif - -!c we can now define the probability density: denstest=ptest/dtest -!c where ptest is the probability and dtest the size of the bin - do n=1,nmax - if (ptest(n) .eq. 0.) then - denstest(n)=0. - else - denstest(n)=ptest(n)/dtest(n) - endif - enddo - -!c NOW we can estimate the parameters for the approximated distrib -!c from the actual distrib - -!c 2. Maximum density -> shape parameter -!c -> wmin - - locmax=3 - shift=15 - ordref=1 - do n=1,nmax - densaux2(n)=denstest(n) - enddo - - if (nmax .ge. shift*2) then - -!c we start with sliding mean to facilitate the search for the maximum - - ord=MIN(ordref,nmax/shift) - call smtot(densaux2,nmax,ord,densaux) - - do n=nmax,shift,-1 - if (densaux(n) .gt. densaux(n-1) .and. & - densaux(n) .gt. densaux(n-2) .and. & - densaux(n) .gt. densaux(n-3) .and. & - densaux(n) .gt. densaux(n-4) .and. & - densaux(n) .gt. densaux(n-5) .and. & - densaux(n) .gt. densaux(n-6) .and. & - densaux(n) .gt. densaux(n-7) .and. & - densaux(n) .gt. densaux(n-8) .and. & - densaux(n) .gt. densaux(n-9) .and. & - densaux(n) .gt. densaux(n-10) .and. & - densaux(n) .gt. densaux(n-11) .and. & - densaux(n) .gt. densaux(n-12) .and. & - densaux(n) .gt. densaux(n-13) .and. & - densaux(n) .gt. densaux(n-14)) then ! .and. & - !densaux(n) .gt. densaux(n-15)) then - locmax=n - goto 30 - endif - enddo - - else - - aux10=-9999. - indimax10=3 - do n=1,nmax - if (densaux2(n) .gt. aux10) then - aux10=densaux2(n) - indimax10=n - endif - enddo - locmax=MAX(3,indimax10) - ! in case nmax < 3. why hard coded 3? - if(locmax > nmax) locmax = nmax - endif ! if (nmax .ge. shift+1) - - 30 densmax=denstest(locmax) - -!c WMIN=lowest value where the density is strictly gt densmax/100. - - indmin=1 - indmin0=0 - do n=1,nmax - if (denstest(n) .gt. 0.) indmin0=n - if (denstest(n) .gt. densmax/100. .and. & - valtest(n) .lt. valtest(locmax)) indmin=n - enddo - if (indmin .eq. 0) indmin=indmin0 - - if (indmin .le. 2) then - wmin = 0.99999 - else - x1=valtest(indmin) - wmin=x1 - endif - -!c for negative or low coeskew the previous wmin doesn't give good results... -!c wmin is higher !!! - - if (coeskew .lt. 1. ) then - - if (locmax .gt. 3 .and. indmin .ge. locmax+4) then - - n2=MAX(locmax+1,(indmin-locmax)/2+locmax) - x2=valtest(n2) - y2=denstest(n2) - n1=locmax - x1=valtest(n1) - y1=denstest(n1) - wa=(y2-y1)/(x2-x1) - wb=y1-wa*x1 - wmin=AMAX1(wmin,-wb/wa) - endif - -!c wmin is even higher in some cases !!! - if (coeskew .lt. 0.2 ) wmin=wmin+0.01 - - endif - - END SUBROUTINE FUNCZBAR - -! ****************************************************************** - - SUBROUTINE RMSE(XX,YY,LEN,ERROR) - -!c--------------------------------------------------------------------------- -!c Computes the root-mean square error ERROR between two one-dimensional -!c random variables XX and YY of same length LEN -!c--------------------------------------------------------------------------- - - IMPLICIT NONE - - INTEGER, intent (in) :: LEN - REAL, intent (in) :: XX(LEN),YY(LEN) - REAL, intent (out) :: ERROR - INTEGER :: I - -!c--------------------------------------------------------------------------- - error=0. - do i=1,len - if(abs(xx(i)-yy(i)) >=1.e-10) then - error=error+(xx(i)-yy(i))*(xx(i)-yy(i)) - endif - enddo - error=SQRT(error/float(len)) - - END SUBROUTINE RMSE - -! ****************************************************************** - SUBROUTINE SMTOT(XX,LEN,ORD,YY) - -!c--------------------------------------------------------------------------- -!c Runs a sliding average of order ORD through the one-dimensional array XX -!c of length LEN and returns the smoothed YY -!!c--------------------------------------------------------------------------- - - IMPLICIT NONE - - INTEGER, intent (in) :: LEN - INTEGER :: ORD,WIDTH,i,ini,n,end - REAL, intent (in) :: XX(NAR) - REAL, intent (out) :: YY(NAR) - -!c--------------------------------------------------------------------------- - do i=1,nar - yy(i)=0. - enddo - - width=ord*2+1 - if (width .gt. len/2) then - write(*,*) 'the order for the sliding average is too large !!!' - write(*,*) 'regard with the length of the array to be smoothed' - stop - endif - - do i=1,len - ini=MAX(1,i-ord) - end=MIN(len,i+ord) - yy(i)=0. - do n=ini,end - yy(i)=yy(i)+xx(n) - enddo - yy(i)=yy(i)/(end-ini+1) - enddo - - END SUBROUTINE SMTOT - -! ----------------------------------------------------------------------------------- - -subroutine RegridRaster(Rin,Rout) - - ! primitive regridding of integer values from 2-dim array Rin to 2-dim array Rout ! - ! If Rout is higher-resolution than Rin, result should be fine: - ! An Rout grid cell is assigned the value of the Rin grid cell that - ! contains the center of the Rout grid cell (oversampling). - ! If Rin is higher-resolution than Rout, result is questionable: - ! An Rout grid cell is assigned the value of the Rin grid cell that is - ! near the *corner* of the Rout grid cell. See notes below. - - integer, intent(IN) :: Rin( :,:) - integer, intent(OUT) :: Rout(:,:) - - REAL(KIND=8) :: xx, yy - integer :: i, j, ii, jj - integer :: Nx_in, Ny_in, Nx_out, Ny_out - - Nx_in = size(Rin ,1) - Ny_in = size(Rin ,2) + !---------------------------------------------------------- + ! - Nx_out = size(Rout,1) - Ny_out = size(Rout,2) - - !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then - if (.false.) then - - ! avoid loop through output grid cells - - Rout = Rin ! [??] MAY NOT BE 0-DIFF B/C OF MIXED-MODE ARITHMETIC IN LOOP!?!?!? - - else - - ! NOTE: float() yields real*4 but xx was declared real*8 - - xx = Nx_in/float(Nx_out) ! WARNING: mixed mode arithmentic!!! - yy = Ny_in/float(Ny_out) ! WARNING: mixed mode arithmentic!!! - - do j=1,Ny_out - - ! NOTE: When Rin is finer resolution than Rout, the below use of - ! ii = (i-1)*xx + 1 (1a) - ! jj = (j-1)*yy + 1 (1b) - ! implies that Rout(i,j) is assigned the Rin(ii,jj) value near a corner of - ! the (ii,jj) output grid cell, which effectively results in a shift of the - ! data by 1/2 of the width of the output grid cell. This shift could - ! presumably minimized by using - ! ii = NINT( (i-1)*xx + xx/2 ) (2a) - ! jj = NINT( (j-1)*yy + yy/2 ) (2b) - ! - ! HOWEVER, equations (2a) and (2b) are preferable when Rout is finer resolution - ! than Rin, in which case Rout should just be oversampling of Rin. - - jj = (j-1)*yy + 1 ! WARNING: mixed mode arithmetic!!! Note implied "floor()" operator. - do i=1,Nx_out - ii = (i-1)*xx + 1 ! WARNING: mixed mode arithmetic!!! Note implied "floor()" operator. - Rout(i,j) = Rin(ii,jj) - end do - end do - - end if - -end subroutine RegridRaster + INTEGER FUNCTION soil_class (min_perc) -! ----------------------------------------------------------------------------------- + ! Function returns a unique soil class [1-100], -subroutine RegridRaster1(Rin,Rout) + type(mineral_perc), intent (in) :: min_perc - ! same as RegridRaster() but for gridded integer*1 values + ! ------------------------------------------------ + + integer :: clay_row, sand_row, silt_row - integer*1, intent(IN) :: Rin( :,:) - integer*1, intent(OUT) :: Rout(:,:) + clay_row = ceiling((100.- min_perc%clay_perc)/10.) + if(clay_row == 0 ) clay_row = 1 + if(clay_row == 11) clay_row = 10 - REAL(KIND=8) :: xx, yy - integer :: i, j, ii, jj - integer :: Nx_in, Ny_in, Nx_out, Ny_out - - Nx_in = size(Rin ,1) - Ny_in = size(Rin ,2) + sand_row = ceiling((min_perc%sand_perc)/10.) + if(sand_row == 0 ) sand_row = 1 + if(sand_row == 11) sand_row = 10 - Nx_out = size(Rout,1) - Ny_out = size(Rout,2) - - !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then - if (.false.) then - - Rout = Rin - - else - - xx = Nx_in/float(Nx_out) - yy = Ny_in/float(Ny_out) - - do j=1,Ny_out - jj = (j-1)*yy + 1 - do i=1,Nx_out - ii = (i-1)*xx + 1 - Rout(i,j) = Rin(ii,jj) - end do - end do - - end if - -end subroutine RegridRaster1 - -! ----------------------------------------------------------------------------------- - -subroutine RegridRaster2(Rin,Rout) - - ! same as RegridRaster() but for gridded integer*2 values - - integer(kind=2), intent(IN) :: Rin( :,:) - integer(kind=2), intent(OUT) :: Rout(:,:) - - REAL(KIND=8) :: xx, yy - integer :: i, j, ii, jj - integer :: Nx_in, Ny_in, Nx_out, Ny_out - - Nx_in = size(Rin ,1) - Ny_in = size(Rin ,2) + silt_row = ceiling((min_perc%silt_perc)/10.) + if(silt_row == 0 ) silt_row = 1 + if(silt_row == 11) silt_row = 10 - Nx_out = size(Rout,1) - Ny_out = size(Rout,2) - - !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then - if (.false.) then - - Rout = Rin - - else - - xx = Nx_in/float(Nx_out) - yy = Ny_in/float(Ny_out) - - do j=1,Ny_out - jj = (j-1)*yy + 1 - do i=1,Nx_out - ii = (i-1)*xx + 1 - Rout(i,j) = Rin(ii,jj) - end do - end do - - end if - -end subroutine RegridRaster2 - -! ----------------------------------------------------------------------------------- - -subroutine RegridRasterReal(Rin,Rout) - - ! same as RegridRaster() but for gridded real values - - real, intent(IN) :: Rin( :,:) - real, intent(OUT) :: Rout(:,:) - - REAL(KIND=8) :: xx, yy - integer :: i, j, ii, jj - integer :: Nx_in, Ny_in, Nx_out, Ny_out - - Nx_in = size(Rin ,1) - Ny_in = size(Rin ,2) + if(clay_row == 1) soil_class=1 - Nx_out = size(Rout,1) - Ny_out = size(Rout,2) - - !if ( (Nx_in==Nx_out) .and. (Ny_in==Ny_out) ) then - if (.false.) then - - Rout = Rin - - else - - xx = Nx_in/float(Nx_out) - yy = Ny_in/float(Ny_out) - - do j=1,Ny_out - jj = (j-1)*yy + 1 - do i=1,Nx_out - ii = (i-1)*xx + 1 - Rout(i,j) = Rin(ii,jj) - end do - end do - - end if - -end subroutine RegridRasterReal - -!--------------------------------------------------------------------- - - SUBROUTINE svbksb(u,w,v,m,n,b,x) - implicit none - INTEGER m,mp,n,np,NMAX - REAL*8 b(m),u(m,n),v(n,n),w(n),x(n) - PARAMETER (NMAX=500) !Maximum anticipated value of n - !------------------------------------------------------------------------------------------- - ! Solves A · X = B for a vector X, where A is specified by the arrays u, w, v as returned by - ! svdcmp. m and n are the dimensions of a, and will be equal for square matrices. b(1:m) is - ! the input right-hand side. x(1:n) is the output solution vector. No input quantities are - ! destroyed, so the routine may be called sequentially with different b’s. - !------------------------------------------------------------------------------------------- - - INTEGER i,j,jj - REAL*8 s,tmp(NMAX) - do j=1,n !Calculate UTB. - s=0. - if(w(j).ne.0.)then !Nonzero result only if wj is nonzero. - do i=1,m - s=s+u(i,j)*b(i) - end do - s=s/(w(j) + 1.d-20) !This is the divide by wj . - endif - tmp(j)=s - end do - do j=1,n !Matrix multiply by V to get answer. - s=0. - do jj=1,n - s=s+v(j,jj)*tmp(jj) - end do - x(j)=s - end do - return - END SUBROUTINE svbksb - -!--------------------------------------------------------------------- - - SUBROUTINE svdcmp(a,m,n,w,v) - implicit none - INTEGER m,n,NMAX - REAL*8, intent (inout) :: a(m,n) - REAL*8, intent (out) :: v(n,n),w(n) - PARAMETER (NMAX=500) !Maximum anticipated value of n. - !-------------------------------------------------------------------------------------- - ! Given a matrix A(1:m,1:n), this routine computes its singular value decomposition, - ! A = U · W · Vt. The matrix U replaces A on output. The diagonal matrix of singular - ! values W is output as a vector W(1:n). The matrix V (not the transpose Vt) is output - ! as V(1:n,1:n). - !-------------------------------------------------------------------------------------- - - INTEGER i,its,j,jj,k,l,nm - REAL*8 anorm,c,f,g,h,s,scale,x,y,z,rv1(NMAX) - real*8, parameter :: EPS=epsilon(1.0d0) - g=0.d0 !Householder reduction to bidiagonal form. - scale=0.d0 - anorm=0.d0 - c =0.d0 - f =0.d0 - g =0.d0 - h =0.d0 - s =0.d0 - x =0.d0 - y =0.d0 - z =0.d0 - rv1=0.d0 - w = 0.d0 - v = 0.d0 - do i=1,n - l=i+1 - rv1(i)=scale*g - g=0.d0 - s=0.d0 - scale=0.d0 - if(i.le.m)then - do k=i,m - scale=scale+abs(a(k,i)) - end do - if(scale.ne.0.d0)then - do k=i,m - a(k,i)=a(k,i)/scale - s=s+a(k,i)*a(k,i) - end do - f=a(i,i) - g=-dsign(dsqrt(s),f) - h=f*g-s - a(i,i)=f-g - do j=l,n - s=0.d0 - do k=i,m - s=s+a(k,i)*a(k,j) - end do - f=s/h - do k=i,m - a(k,j)=a(k,j)+f*a(k,i) - end do - end do - do k=i,m - a(k,i)=scale*a(k,i) - end do - endif - endif - w(i)=scale *g - g=0.d0 - s=0.d0 - scale=0.d0 - if((i.le.m).and.(i.ne.n))then - do k=l,n - scale=scale+abs(a(i,k)) - end do - if(scale.ne.0.d0)then - do k=l,n - a(i,k)=a(i,k)/scale - s=s+a(i,k)*a(i,k) - end do - f=a(i,l) - g=-sign(sqrt(s),f) - h=f*g-s - a(i,l)=f-g - do k=l,n - rv1(k)=a(i,k)/h - end do - do j=l,m - s=0.d0 - do k=l,n - s=s+a(j,k)*a(i,k) - end do - do k=l,n - a(j,k)=a(j,k)+s*rv1(k) - end do - end do - do k=l,n - a(i,k)=scale*a(i,k) - end do - endif - endif - anorm=max(anorm,(abs(w(i))+abs(rv1(i)))) - end do !do i=1,n - - do i=n,1,-1 !Accumulation of right-hand transformations. - if(i.lt.n)then - if(g.ne.0.d0)then - do j=l,n !Double division to avoid possible underflow. - v(j,i)=(a(i,j)/a(i,l))/g - end do - do j=l,n - s=0.d0 - do k=l,n - s=s+a(i,k)*v(k,j) - end do - do k=l,n - v(k,j)=v(k,j)+s*v(k,i) - end do - end do - endif - do j=l,n - v(i,j)=0.d0 - v(j,i)=0.d0 - end do - endif - v(i,i)=1.d0 - g=rv1(i) - l=i - end do - - do i=min(m,n),1,-1 !Accumulation of left-hand transformations. - l=i+1 - g=w(i) - do j=l,n - a(i,j)=0.d0 - end do - if(g.ne.0.d0)then - g=1.d0/g - do j=l,n - s=0.d0 - do k=l,m - s=s+a(k,i)*a(k,j) - end do - f=(s/a(i,i))*g - do k=i,m - a(k,j)=a(k,j)+f*a(k,i) - end do - end do - do j=i,m - a(j,i)=a(j,i)*g - end do - else - do j= i,m - a(j,i)=0.d0 - end do - endif - a(i,i)=a(i,i)+1.d0 - end do - - do k=n,1,-1 !Diagonalization of the bidiagonal form: Loop over - !singular values, and over allowed iterations. - do its=1,30 - do l=k,1,-1 !Test for splitting. - nm=l-1 !Note that rv1(1) is always zero. - if( abs(rv1(l)) <= EPS*anorm ) goto 2 - if( abs(w(nm) ) <= EPS*anorm ) goto 1 - end do -1 c=0.d0 !Cancellation of rv1(l), if l > 1. - s=1.d0 - do i=l,k - f=s*rv1(i) - rv1(i)=c*rv1(i) - if( abs(f) <= EPS*anorm ) goto 2 - g=w(i) - h=pythag(f,g) - w(i)=h - h=1.d0/h - c= (g*h) - s=-(f*h) - do j=1,m - y=a(j,nm) - z=a(j,i) - a(j,nm)=(y*c)+(z*s) - a(j,i)=-(y*s)+(z*c) - end do - end do -2 z=w(k) - if(l.eq.k)then !Convergence. - if(z.lt.0.d0)then !Singular value is made nonnegative. - w(k)=-z - do j=1,n - v(j,k)=-v(j,k) - end do - endif - goto 3 - endif - if(its.eq.30) print *, 'no convergence in svdcmp' - ! if(its.ge.4) print *, 'its = ',its - x=w(l) !Shift from bottom 2-by-2 minor. - nm=k-1 - y=w(nm) - g=rv1(nm) - h=rv1(k) - f=((y-z)*(y+z)+(g-h)*(g+h))/(2.0*h*y) - g=pythag(f,1.d0) - f=((x-z)*(x+z)+h*((y/(f+sign(g,f)))-h))/x - c=1.d0 !Next QR transformation: - s=1.d0 - do j=l,nm - i=j+1 - g=rv1(i) - y=w(i) - h=s*g - g=c*g - z=pythag(f,h) - rv1(j)=z - c=f/z - s=h/z - f= (x*c)+(g*s) - g=-(x*s)+(g*c) - h=y*s - y=y*c - do jj=1,n - x=v(jj,j) - z=v(jj,i) - v(jj,j)= (x*c)+(z*s) - v(jj,i)=-(x*s)+(z*c) - end do - z=pythag(f,h) - w(j)=z !Rotation can be arbitrary if z = 0. - if(z.ne.0.d0)then - z=1.d0/z - c=f*z - s=h*z - endif - f= (c*g)+(s*y) - x=-(s*g)+(c*y) - do jj=1,m - y=a(jj,j) - z=a(jj,i) - a(jj,j)= (y*c)+(z*s) - a(jj,i)=-(y*s)+(z*c) - end do - end do !j=l;nm - rv1(l)=0.d0 - rv1(k)=f - w(k)=x - end do !its=1,30 -3 continue - end do !k=n,1,-1 - return - END SUBROUTINE svdcmp -! -! ________________________________________________________________________________ -! - REAL*8 FUNCTION pythag(a,b) - REAL*8 a,b - !Computes sqrt(a**2 + b**2) without destructive underflow or overflow. - REAL*8 absa,absb - absa=abs(a) - absb=abs(b) - if(absa.gt.absb)then - pythag=absa*sqrt(1.+(absb/absa)**2) - else - if(absb.eq.0.)then - pythag=0. - else - pythag=absb*sqrt(1.+(absa/absb)**2) - endif - endif - return - END FUNCTION pythag -! -! ________________________________________________________________________________ -! - - SUBROUTINE savgol(c,np,nl,nr,ld,m) - implicit none - INTEGER ld,m,nl,np,nr,MMAX - real c(np) - PARAMETER (MMAX=6) -!-------------------------------------------------------------------------------------------- -!USES lubksb,ludcmp given below. -!Returns in c(1:np), in wrap-around order (see reference) consistent with the argument respns -!in routine convlv, a set of Savitzky-Golay filter coefficients. nl is the number of leftward -!(past) data points used, while nr is the number of rightward (future) data points, making -!the total number of data points used nl +nr+1. ld is the order of the derivative desired -!(e.g., ld = 0 for smoothed function). m is the order of the smoothing polynomial, also -!equal to the highest conserved moment; usual values are m = 2 or m = 4. -!-------------------------------------------------------------------------------------------- -INTEGER d,icode,imj,ipj,j,k,kk,mm,indx(MMAX+1) -real fac,sum,a(MMAX+1,MMAX+1),b(MMAX+1) -if(np.lt.nl+nr+1.or.nl.lt.0.or.nr.lt.0.or.ld.gt.m.or.m.gt.MMAX & - .or.nl+nr.lt.m) pause ' Bad args in savgol.' - do ipj=0,2*m !Set up the normal equations of the desired leastsquares fit. - sum=0. - if(ipj.eq.0) sum=1. - do k=1,nr - sum=sum+dfloat(k)**ipj - end do - do k=1,nl - sum=sum+dfloat(-k)**ipj - end do - mm=min(ipj,2*m-ipj) - do imj=-mm,mm,2 - a(1+(ipj+imj)/2,1+(ipj-imj)/2)=sum - end do - end do - - call ludcmp(a,m+1,MMAX+1,indx,d,icode) !Solve them: LU decomposition. - - do j=1,m+1 - b(j)=0. - end do - b(ld+1)=1. !Right-hand side vector is unit vector, depending on which derivative we want. - - call lubksb(a,m+1,MMAX+1,indx,b) !Backsubstitute, giving one row of the inverse matrix. - - do kk=1,np !Zero the output array (it may be bigger than the number - c(kk)=0. !of coefficients). - end do - do k=-nl,nr !Each Savitzky-Golay coefficient is the dot product - sum=b(1) !of powers of an integer with the inverse matrix row. - fac=1. - do mm=1,m - fac=fac*k - sum=sum+b(mm+1)*fac - end do - kk=mod(np-k,np)+1 !Store in wrap-around order. - c(kk)=sum - end do - return -END SUBROUTINE savgol - -!*************************************************************** -!* Given an N x N matrix A, this routine replaces it by the LU * -!* decomposition of a rowwise permutation of itself. A and N * -!* are input. INDX is an output vector which records the row * -!* permutation effected by the partial pivoting; D is output * -!* as -1 or 1, depending on whether the number of row inter- * -!* changes was even or odd, respectively. This routine is used * -!* in combination with LUBKSB to solve linear equations or to * -!* invert a matrix. Return code is 1, if matrix is singular. * -!*************************************************************** - Subroutine LUDCMP(A,N,NP,INDX,D,CODE) -INTEGER, PARAMETER :: NMAX=100 -REAL, PARAMETER :: TINY=1E-12 - real AMAX,DUM, SUM, A(NP,NP),VV(NMAX) - INTEGER CODE, D, INDX(N),NP,N,I,J,K,IMAX - - D=1; CODE=0 - - DO I=1,N - AMAX=0. - DO J=1,N - IF (ABS(A(I,J)).GT.AMAX) AMAX=ABS(A(I,J)) - END DO ! j loop - IF(AMAX.LT.TINY) THEN - CODE = 1 - RETURN - END IF - VV(I) = 1. / AMAX - END DO ! i loop - - DO J=1,N - DO I=1,J-1 - SUM = A(I,J) - DO K=1,I-1 - SUM = SUM - A(I,K)*A(K,J) - END DO ! k loop - A(I,J) = SUM - END DO ! i loop - AMAX = 0. - DO I=J,N - SUM = A(I,J) - DO K=1,J-1 - SUM = SUM - A(I,K)*A(K,J) - END DO ! k loop - A(I,J) = SUM - DUM = VV(I)*ABS(SUM) - IF(DUM.GE.AMAX) THEN - IMAX = I - AMAX = DUM - END IF - END DO ! i loop - - IF(J.NE.IMAX) THEN - DO K=1,N - DUM = A(IMAX,K) - A(IMAX,K) = A(J,K) - A(J,K) = DUM - END DO ! k loop - D = -D - VV(IMAX) = VV(J) - END IF - - INDX(J) = IMAX - IF(ABS(A(J,J)) < TINY) A(J,J) = TINY - - IF(J.NE.N) THEN - DUM = 1. / A(J,J) - DO I=J+1,N - A(I,J) = A(I,J)*DUM - END DO ! i loop - END IF - END DO ! j loop - - RETURN - END Subroutine LUDCMP - - -!****************************************************************** -!* Solves the set of N linear equations A . X = B. Here A is * -!* input, not as the matrix A but rather as its LU decomposition, * -!* determined by the routine LUDCMP. INDX is input as the permuta-* -!* tion vector returned by LUDCMP. B is input as the right-hand * -!* side vector B, and returns with the solution vector X. A, N and* -!* INDX are not modified by this routine and can be used for suc- * -!* cessive calls with different right-hand sides. This routine is * -!* also efficient for plain matrix inversion. * -!****************************************************************** - Subroutine LUBKSB(A,N,NP,INDX,B) - INTEGER :: II,I,J,LL,N,NP - real SUM, A(NP,NP),B(N) - INTEGER INDX(N) - - II = 0 - - DO I=1,N - LL = INDX(I) - SUM = B(LL) - B(LL) = B(I) - IF(II.NE.0) THEN - DO J=II,I-1 - SUM = SUM - A(I,J)*B(J) - END DO ! j loop - ELSE IF(SUM.NE.0.) THEN - II = I - END IF - B(I) = SUM - END DO ! i loop - - DO I=N,1,-1 - SUM = B(I) - IF(I < N) THEN - DO J=I+1,N - SUM = SUM - A(I,J)*B(J) - END DO ! j loop - END IF - B(I) = SUM / A(I,I) - END DO ! i loop - - RETURN - END Subroutine LUBKSB + if(clay_row > 1) soil_class= & + (clay_row - 1)*(clay_row - 1) + (clay_row - sand_row) + silt_row -! -! ==================================================================== -! + end FUNCTION soil_class -INTEGER FUNCTION center_pix (x,y,x0,y0,z0,ext_point) - -implicit none - -real, dimension (:), intent (in) :: x,y -real, allocatable, dimension (:,:) :: length_m -real, allocatable, dimension (:) :: length -real, intent (inout) :: x0,y0,z0 -integer :: i,j,npix,ii -logical, intent(in) :: ext_point -real :: zi, zj - -npix = size (x) -allocate (length_m (1:npix,1:npix)) -allocate (length (1:npix)) -length_m =0. -length =0. - -do i = 1,npix - zi = 100. - x(i) - y(i) - if (.not. ext_point) then - x0 = x(i) - y0 = y(i) - z0 = zi - endif - - do j = i,npix - zj = 100. - x(j) - y(j) -! length_m (i,j) = abs (x(j) - x0) + & -! abs (y(j) - y0) + abs (zj - z0) -! - length_m (i,j) = ((x(j) - x0)*(x(j) - x0) & - + (y(j) - y0)*(y(j) - y0) & - + (zj - z0)*(zj - z0))**0.5 - length_m (j,i) = length_m (i,j) - end do - length (i) = sum(length_m (i,:)) -end do + ! ----------------------------------------------------------------------------------- -center_pix = minloc(length,dim=1) + SUBROUTINE REFORMAT_VEGFILES -END FUNCTION center_pix + character*512 :: tmp_string + integer :: n_tiles + real, dimension (:), allocatable :: var_array + character*512 :: header + real :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 + integer :: month -! -!---------------------------------------------------------- -! + tmp_string = 'mkdir -p '//'clsm/g5fmt' + call execute_command_line(tmp_string) + tmp_string = '/bin/mv '//'clsm/lai.dat ' //'clsm/g5fmt/.' + call execute_command_line(tmp_string) + tmp_string = '/bin/mv '//'clsm/green.dat ' //'clsm/g5fmt/.' + call execute_command_line(tmp_string) -INTEGER FUNCTION soil_class (min_perc) + open (10,file='clsm/g5fmt/lai.dat' , form = 'unformatted', & + convert='little_endian',status='old',action='read' ) + open (11,file='clsm/g5fmt/green.dat', form = 'unformatted', & + convert='little_endian',status='old',action='read' ) -! Function returns a unique soil class [1-100], + open (20,file='clsm/lai.dat', form = 'unformatted', & + convert='big_endian',status='unknown',action='write' ) + open (21,file='clsm/green.dat', form = 'unformatted', & + convert='big_endian',status='unknown',action='write' ) -IMPLICIT NONE -type(mineral_perc), intent (in) :: min_perc -!real, intent (in) :: clay_perc,silt_perc,sand_perc -integer :: clay_row, sand_row, silt_row + open (30,file='clsm/catchment.def', form = 'formatted',status='old',action='read' ) + read (30,*) n_tiles + close(30,status='keep') -clay_row = ceiling((100.- min_perc%clay_perc)/10.) -if(clay_row == 0 ) clay_row = 1 -if(clay_row == 11) clay_row = 10 + allocate (var_array (1:n_tiles)) -sand_row = ceiling((min_perc%sand_perc)/10.) -if(sand_row == 0 ) sand_row = 1 -if(sand_row == 11) sand_row = 10 + read (10) header + read (10) var_array + read (11) header + read (11) var_array -silt_row = ceiling((min_perc%silt_perc)/10.) -if(silt_row == 0 ) silt_row = 1 -if(silt_row == 11) silt_row = 10 + do month =1,12 -if(clay_row == 1) soil_class=1 + read (10) a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 + read (10) var_array + print '(12f3.0,f4.00,f2.0,a6,2f6.2)',a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,'LAI ',minval(var_array),maxval(var_array) + write (20)var_array(:) + read (11) a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 + read (11) var_array + print '(12f3.0,f4.00,f2.0,a6,2f6.2)',a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,'GREEN ',minval(var_array),maxval(var_array) + write (21)var_array(:) + end do -if(clay_row > 1) soil_class= & - (clay_row - 1)*(clay_row - 1) + (clay_row - sand_row) + silt_row + END SUBROUTINE REFORMAT_VEGFILES -end FUNCTION soil_class + ! + ! -------------------------------------------------------- + ! + ! SUBROUTINE compute_stats (ndata,cti_val,mu,sig,sk) + ! + ! Subroutine not used as of 24 Dec 2024; removed by reichle, 24 Dec 2024 + ! + ! ----------------------------------------------------------------------------------- + + SUBROUTINE ascat_r0 (nc,nr, ntiles,tile_id, z0) -! ----------------------------------------------------------------------------------- -! ----------------------------------------------------------------------------------- -! ----------------------------------------------------------------------------------- + ! 1) ASCAT roughness + ! /discover/nobackup/adarmeno/projects/k14/arlems-roughness.x3600_y1800_t1.nc4 -SUBROUTINE REFORMAT_VEGFILES - implicit none - character*400 :: tmp_string - integer :: n_tiles - real, dimension (:), allocatable :: var_array - character*40 :: header - real :: a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 - integer :: month - - tmp_string = 'mkdir -p '//'clsm/g5fmt' - call execute_command_line(tmp_string) - tmp_string = '/bin/mv '//'clsm/lai.dat ' //'clsm/g5fmt/.' - call execute_command_line(tmp_string) - tmp_string = '/bin/mv '//'clsm/green.dat ' //'clsm/g5fmt/.' - call execute_command_line(tmp_string) - - open (10,file='clsm/g5fmt/lai.dat' , form = 'unformatted', & - convert='little_endian',status='old',action='read' ) - open (11,file='clsm/g5fmt/green.dat', form = 'unformatted', & - convert='little_endian',status='old',action='read' ) - - open (20,file='clsm/lai.dat', form = 'unformatted', & - convert='big_endian',status='unknown',action='write' ) - open (21,file='clsm/green.dat', form = 'unformatted', & - convert='big_endian',status='unknown',action='write' ) - - open (30,file='clsm/catchment.def', form = 'formatted',status='old',action='read' ) - read (30,*) n_tiles - close(30,status='keep') - - allocate (var_array (1:n_tiles)) - - read (10) header - read (10) var_array - read (11) header - read (11) var_array - - do month =1,12 - - read (10) a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 - read (10) var_array - print '(12f3.0,f4.00,f2.0,a6,2f6.2)',a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,'LAI ',minval(var_array),maxval(var_array) - write (20)var_array(:) - read (11) a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14 - read (11) var_array - print '(12f3.0,f4.00,f2.0,a6,2f6.2)',a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,'GREEN ',minval(var_array),maxval(var_array) - write (21)var_array(:) - end do - -END SUBROUTINE REFORMAT_VEGFILES + integer, intent(in) :: nc, nr + integer, intent(in) :: ntiles + INTEGER, intent(in) :: tile_id(:,:) -! -! -------------------------------------------------------- -! + real, pointer, dimension (:), intent(inout) :: z0 -SUBROUTINE compute_stats (ndata,cti_val,mu,sig,sk) - -implicit none -integer, intent(in) :: ndata -real, intent(inout), dimension(ndata) :: cti_val -real, intent(out) :: mu,sig,sk -integer :: i,j -real :: del - - mu = sum(cti_val(1:ndata))/float(ndata) - sig = 0. - sk = 0. - del = 0. - - do i = 1,ndata - del = CTI_VAL(i) - mu - sig = sig + del**2 - sk = sk + (del*del*del) - end do - - sig = sig/float(ndata-1) - sig = sqrt(sig) - sk = sk/(sig**3 + 1.e-10)/float(ndata) - -END SUBROUTINE compute_stats + integer , parameter :: N_lon_ascat = 3600, N_lat_ascat = 1800 + integer :: i,j, status, varid, ncid + REAL, ALLOCATABLE, dimension (:) :: count_pix + REAL, ALLOCATABLE, dimension (:,:) :: z0_grid, data_grid + character*512 :: fout -! ----------------------------------------------------------------------------------- - - SUBROUTINE ascat_r0 (nc,nr,gfiler, z0) - - implicit none - - ! 1) ASCAT roughness - ! /discover/nobackup/adarmeno/projects/k14/arlems-roughness.x3600_y1800_t1.nc4 - - integer, intent (in) :: nc, nr - real, pointer, dimension (:), intent (inout) :: z0 - character(*), intent (in) :: gfiler - integer , parameter :: N_lon_ascat = 3600, N_lat_ascat = 1800 - integer :: i,j, status, varid, ncid - integer :: NTILES - REAL, ALLOCATABLE, dimension (:) :: count_pix - REAL, ALLOCATABLE, dimension (:,:) :: z0_grid, data_grid - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id - character*100 :: fout - - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') + ! READ ASCAT source data and regrid + ! --------------------------------- + + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/misc/roughness_length/v1/arlems-roughness.x3600_y1800_t1.nc4', NF_NOWRITE, ncid) - ! READ ASCAT source data and regrid - ! --------------------------------- + allocate (z0_grid (1 : NC , 1 : NR)) + allocate (data_grid (1 : N_lon_ascat, 1 : N_lat_ascat)) - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/misc/roughness_length/v1/arlems-roughness.x3600_y1800_t1.nc4', NF_NOWRITE, ncid) - - allocate (z0_grid (1 : NC , 1 : NR)) - allocate (data_grid (1 : N_lon_ascat, 1 : N_lat_ascat)) + status = NF_INQ_VARID (ncid,'roughness',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_REAL (ncid,VarID, (/1,1,1/),(/N_lon_ascat, N_lat_ascat,1/), data_grid) ; VERIFY_(STATUS) - status = NF_INQ_VARID (ncid,'roughness',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_REAL (ncid,VarID, (/1,1,1/),(/N_lon_ascat, N_lat_ascat,1/), data_grid) ; VERIFY_(STATUS) + call RegridRasterReal(data_grid, z0_grid) - call RegridRasterReal(data_grid, z0_grid) + status = NF_CLOSE(ncid) - status = NF_CLOSE(ncid) + ! Grid to tile + ! ------------ - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file + ! Reading tile-id raster file - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(gfiler)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do + allocate (z0 (1:NTILES)) + allocate (count_pix (1:NTILES)) + + z0 = 0. + count_pix = 0. + + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + + ! z0 0. < 0.1 + if((z0_grid(i,j) >= 2.0e-6).and.(z0_grid(i,j) <= 0.1)) then + z0 (tile_id(i,j)) = z0 (tile_id(i,j)) + z0_grid(i,j) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + + endif + end do + end do + + where (count_pix > 0.) z0 = z0/count_pix + where (z0 == 0.) z0 = 2.0e-6 + + deallocate (count_pix) + deallocate (z0_grid) - close (10,status='keep') - - allocate (z0 (1:NTILES)) - allocate (count_pix (1:NTILES)) - - z0 = 0. - count_pix = 0. - - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - - ! z0 0. < 0.1 - if((z0_grid(i,j) >= 2.0e-6).and.(z0_grid(i,j) <= 0.1)) then - z0 (tile_id(i,j)) = z0 (tile_id(i,j)) + z0_grid(i,j) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif - - endif - end do - end do - - where (count_pix > 0.) z0 = z0/count_pix - where (z0 == 0.) z0 = 2.0e-6 - - deallocate (count_pix) - deallocate (z0_grid) - deallocate (tile_id) - END SUBROUTINE ascat_r0 - ! ---------------------------------------------------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------------------------------------------------- + + SUBROUTINE jpl_canoph (nc,nr, ntiles, tile_id, z2) - SUBROUTINE jpl_canoph (nc,nr,gfiler, z2) + ! 1) JPL Canopy Height + ! /discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4 - implicit none + integer, intent(in) :: nc, nr, ntiles + integer, intent(in) :: tile_id(:,:) + real, pointer, dimension(:), intent(inout) :: z2 - ! 1) JPL Canopy Height - ! /discover/nobackup/projects/gmao/bcs_shared/make_bcs_inputs/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4 - - integer, intent (in) :: nc, nr - real, pointer, dimension (:), intent (inout) :: z2 - character(*), intent (in) :: gfiler - integer , parameter :: N_lon_jpl = 43200, N_lat_jpl = 21600 - integer :: i,j, status, varid, ncid - integer :: NTILES - REAL, ALLOCATABLE, dimension (:) :: count_pix - INTEGER, ALLOCATABLE, dimension (:,:) :: data_grid, z2_grid - INTEGER, ALLOCATABLE, dimension (:,:) :: tile_id - character*100 :: fout + ! ---------------------------------------------------------- - ! Reading number of tiles - ! ----------------------- - - open (20, file = 'clsm/catchment.def', form = 'formatted', status = 'old', action = 'read') - - read (20, *) NTILES - - close (20, status = 'keep') + integer , parameter :: N_lon_jpl = 43200, N_lat_jpl = 21600 - ! READ JPL source data files and regrid - ! ------------------------------------- + ! ---------------------------------------------------------- - call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) - status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4', NF_NOWRITE, ncid) - - allocate (z2_grid (1 : NC , 1 : NR)) - allocate (data_grid (1 : N_lon_jpl, 1 : N_lat_jpl)) + integer :: i,j, status, varid, ncid + REAL, ALLOCATABLE, dimension (:) :: count_pix + INTEGER, ALLOCATABLE, dimension (:,:) :: data_grid, z2_grid + character*512 :: fout - status = NF_INQ_VARID (ncid,'CanopyHeight',VarID) ; VERIFY_(STATUS) - status = NF_GET_VARA_INT (ncid,VarID, (/1,1/),(/N_lon_jpl, N_lat_jpl/), data_grid) ; VERIFY_(STATUS) - - call RegridRaster(data_grid, z2_grid) + ! READ JPL source data files and regrid + ! ------------------------------------- - status = NF_CLOSE(ncid) + call get_environment_variable ("MAKE_BCS_INPUT_DIR",MAKE_BCS_INPUT_DIR) + status = NF_OPEN (trim(MAKE_BCS_INPUT_DIR)//'/land/veg/veg_height/v1/Simard_Pinto_3DGlobalVeg_JGR.nc4', NF_NOWRITE, ncid) - ! Grid to tile - ! ------------ - - ! Reading tile-id raster file + allocate (z2_grid (1 : NC , 1 : NR)) + allocate (data_grid (1 : N_lon_jpl, 1 : N_lat_jpl)) - allocate(tile_id(1:nc,1:nr)) - - open (10,file=trim(gfiler)//'.rst',status='old',action='read', & - form='unformatted',convert='little_endian') - - do j=1,nr - read(10)tile_id(:,j) - end do + status = NF_INQ_VARID (ncid,'CanopyHeight',VarID) ; VERIFY_(STATUS) + status = NF_GET_VARA_INT (ncid,VarID, (/1,1/),(/N_lon_jpl, N_lat_jpl/), data_grid) ; VERIFY_(STATUS) - close (10,status='keep') - - allocate (z2 (1:NTILES)) - allocate (count_pix (1:NTILES)) - - z2 = 0. - count_pix = 0. + call RegridRaster(data_grid, z2_grid) - do j = 1,nr - do i = 1, nc - if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then + status = NF_CLOSE(ncid) - if(z2_grid(i,j) >= 0.) then - z2 (tile_id(i,j)) = z2 (tile_id(i,j)) + real (z2_grid(i,j)) - count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. - endif + ! Grid to tile + ! ------------ - endif - end do - end do - - where (count_pix > 0.) z2 = z2/count_pix - where (z2 < 0.01) z2 = 0.01 ! to ensure Z2 >= MIN_VEG_HEIGHT + ! Reading tile-id raster file - deallocate (count_pix) - deallocate (z2_grid) - deallocate (tile_id) - - END SUBROUTINE jpl_canoph - ! ---------------------------------------------------------------------- + allocate (z2 (1:NTILES)) + allocate (count_pix (1:NTILES)) - integer function NC_VarID (NCFID, VNAME) - - integer, intent (in) :: NCFID - character(*), intent (in) :: VNAME - integer :: status + z2 = 0. + count_pix = 0. - STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,NC_VarID) - IF (STATUS .NE. NF_NOERR) & - CALL HANDLE_ERR(STATUS, trim(VNAME)) - - end function NC_VarID + do j = 1,nr + do i = 1, nc + if((tile_id(i,j).gt.0).and.(tile_id(i,j).le.NTILES)) then - ! ----------------------------------------------------------------------- + if(z2_grid(i,j) >= 0.) then + z2 (tile_id(i,j)) = z2 (tile_id(i,j)) + real (z2_grid(i,j)) + count_pix (tile_id(i,j)) = count_pix (tile_id(i,j)) + 1. + endif + + endif + end do + end do + + where (count_pix > 0.) z2 = z2/count_pix + where (z2 < 0.01) z2 = 0.01 ! to ensure Z2 >= MIN_VEG_HEIGHT - SUBROUTINE HANDLE_ERR(STATUS, Line) + deallocate (count_pix) + deallocate (z2_grid) - INTEGER, INTENT (IN) :: STATUS - CHARACTER(*), INTENT (IN) :: Line + END SUBROUTINE jpl_canoph - IF (STATUS .NE. NF_NOERR) THEN - PRINT *, trim(Line),': ',NF_STRERROR(STATUS) - STOP 'Stopped' - ENDIF + ! ---------------------------------------------------------------------- + + integer function NC_VarID (NCFID, VNAME) - END SUBROUTINE HANDLE_ERR + integer, intent (in) :: NCFID + character(*), intent (in) :: VNAME + integer :: status + + STATUS = NF_INQ_VARID (NCFID, trim(VNAME) ,NC_VarID) + IF (STATUS .NE. NF_NOERR) & + CALL HANDLE_ERR(STATUS, trim(VNAME)) + + end function NC_VarID + + ! ----------------------------------------------------------------------- + + 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 + + ! ----------------------------------------------------------------------------------- -! ----------------------------------------------------------------------------------- - END module rmTinyCatchParaMod diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/1440x1080/ice_in b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/1440x1080/ice_in index 6d5284c6d..02c184725 100644 --- a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/1440x1080/ice_in +++ b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/1440x1080/ice_in @@ -62,9 +62,9 @@ grid_format = 'nc' grid_type = 'tripole' grid_subtype = 'geosmom' - grid_ice = 'B' + grid_ice = 'C' grid_atm = 'A' - grid_ocn = 'B' + grid_ocn = 'C' grid_file = 'cice6_grid.nc' kmt_file = 'cice6_kmt.nc' bathymetry_file = 'cice6_global.bathy.nc' @@ -115,7 +115,7 @@ &thermo_nml kitd = 1 - ktherm = 1 + ktherm = 2 conduct = 'bubbly' ksno = 0.3d0 a_rapid_mode = 0.5e-3 @@ -174,22 +174,22 @@ / &shortwave_nml - shortwave = 'ccsm3' + shortwave = 'dEdd' albedo_type = 'ccsm3' albicev = 0.78 albicei = 0.36 albsnowv = 0.98 albsnowi = 0.70 ahmax = 0.3 - R_ice = 0. - R_pnd = 0. - R_snw = 1.5 + R_ice = -1. + R_pnd = -1. + R_snw = -1. dT_mlt = 1.5 rsnw_mlt = 1500. - kalg = 0.6 - sw_redist = .true. - sw_frac = 0.9d0 - sw_dtemp = 0.02d0 + kalg = 0.0 + sw_redist = .true. + sw_frac = 0.9d0 + sw_dtemp = 0.02d0 / &ponds_nml diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/540x458/ice_in b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/540x458/ice_in index ae56ccdc0..56164fe63 100644 --- a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/540x458/ice_in +++ b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/540x458/ice_in @@ -62,9 +62,9 @@ grid_format = 'nc' grid_type = 'tripole' grid_subtype = 'geosmom' - grid_ice = 'B' + grid_ice = 'C' grid_atm = 'A' - grid_ocn = 'B' + grid_ocn = 'C' grid_file = 'cice6_grid.nc' kmt_file = 'cice6_kmt.nc' bathymetry_file = 'cice6_global.bathy.nc' @@ -470,7 +470,7 @@ f_snowfrac = 'x' f_snow = 'x' f_snow_ai = 'm' - f_rain = 'x' + f_rain = 'm' f_rain_ai = 'm' f_sst = 'm' f_sss = 'm' @@ -492,7 +492,7 @@ f_alidf_ai = 'x' f_albice = 'md' f_albsno = 'md' - f_albpnd = 'x' + f_albpnd = 'md' f_coszen = 'x' f_flat = 'md' f_flat_ai = 'md' diff --git a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/72x36/ice_in b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/72x36/ice_in index f23ada4de..01c600044 100644 --- a/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/72x36/ice_in +++ b/GEOSogcm_GridComp/GEOSseaice_GridComp/CICE_GEOSPlug/cice6_app/72x36/ice_in @@ -115,7 +115,7 @@ &thermo_nml kitd = 1 - ktherm = 1 + ktherm = 2 conduct = 'bubbly' ksno = 0.3d0 a_rapid_mode = 0.5e-3 @@ -293,8 +293,6 @@ restart_hbrine = .false. tr_zaero = .false. modal_aero = .false. - optics_file = 'unknown' - optics_file_fieldname = 'modalBCabsorptionParameter5band' skl_bgc = .false. z_tracers = .false. dEdd_algae = .false.