C HFD, 20230329, fixed duplicated DIMENSION attributes; C Change in SUBROUTINE RPSCLIMATE to avoid redefinition of loop var; C Same for SUBROUTINE RPSLAI; C HFD, 20230405: code adapted to process dynamic land cover and LAI C At this point, only US region, US_XX clim scenario are supported C HFD, 20230407: all variables are now explicitly declared C HFD, 20230410: changed order of COMMON/LANDCHANGE/ variables (integer var to the end) C This allows compilation with -fdefault-real-8 flag C Did the same for the COMMON/CELLINFO/ block C HFD, 20230517: Now reading SCENARIO from configuration file (e.g., rcp45, rcp85...) C**********************************************************************C C C C *** SUBROUTINE USERINPUT *** C C Read USER input data from GENERAL.TXT C C C C**********************************************************************C SUBROUTINE USERINPUT IMPLICIT NONE COMMON/BASIC/NGRID,NYEAR,NLC,BYEAR,IYSTART,IYEND,POP_FLAG, & REGION,CLIMATE_FLAG COMMON/GROUNDWATER/ GROUNDWATER(2200,9), GW_CHG COMMON/LANDCHANGE/FPERD, LAI_CHG, FOR_CONV_TO COMMON/CLIMATECHANGE/PPT_CHG,TEMP_CHG COMMON/DEMANDCHANGE/DOM_CHG, IND_CHG, IRR_CHG, LIV_CHG, MIN_CHG, &THR_CHG, PUS_CHG, AQU_CHG, POP_CHG COMMON/NEWINPUT/GCM,SCENARIO INTEGER NLC, POP_FLAG, FOR_CONV_TO INTEGER BYEAR INTEGER NGRID, NYEAR REAL FPERD, LAI_CHG, PPT_CHG, TEMP_CHG REAL POP_CHG, GW_CHG REAL DOM_CHG, IND_CHG, IRR_CHG, LIV_CHG, MIN_CHG, THR_CHG, &PUS_CHG, AQU_CHG CHARACTER*4 HEADNG(20) CHARACTER*5 CLIMATE_FLAG CHARACTER*2 REGION CHARACTER*100 GCM, SCENARIO !Previously undeclared INTEGER IYEND, IYSTART REAL GROUNDWATER C --- Read in data from GENERAL.TXT READ(1,1000) HEADNG 1000 FORMAT(20A4) READ (1,*) REGION READ (1,*) CLIMATE_FLAG READ (1,*) GCM READ (1,*) SCENARIO READ (1,*) NGRID !now defined in the config file READ (1,*) NYEAR !now defined in the config file READ (1,*) IYSTART READ (1,*) IYEND READ (1,*) FPERD READ (1,*) FOR_CONV_TO READ (1,*) LAI_CHG READ (1,*) PPT_CHG READ (1,*) TEMP_CHG READ(1,*) POP_FLAG READ(1,*) POP_CHG READ (1,*) GW_CHG READ (1,*) DOM_CHG READ (1,*) IND_CHG READ (1,*) IRR_CHG READ (1,*) LIV_CHG READ (1,*) MIN_CHG READ (1,*) THR_CHG READ (1,*) PUS_CHG READ (1,*) AQU_CHG RETURN END C**********************************************************************C C C C *** SUBROUTINE RPSDF *** C C set up column headings in output files C C C C**********************************************************************C SUBROUTINE RPSDF IMPLICIT NONE COMMON/BASIC/NGRID,NYEAR,NLC,BYEAR,IYSTART,IYEND,POP_FLAG, & REGION,CLIMATE_FLAG CHARACTER*5 CLIMATE_FLAG CHARACTER*2 REGION !Previously undeclared INTEGER NGRID,NYEAR,NLC,BYEAR,IYSTART,IYEND,POP_FLAG C-----PRINT TITLE FOR MONTHLY RUNOFF OUTPUT FILE MONTHRUNOFF.TXT WRITE (78, 1050) 1050 FORMAT('CELL',',','YEAR',',','MONTH',',', &'RAIN_MM',',','SOLPSAT',',','SNWPK_MM',',','PET_MM', &',','PAET_MM',',','AET_MM',',','AETPETR',',', &'RO_MM') C-----PRINT TITLE FOR ANNUAL RUNOFF OUTPUT ANNUALRUNOFF.TXT WRITE (79, 1060) 1060 FORMAT ('CELL',',','YEAR',',','RAIN',',','SOLPSAT',',','PET',',', &'AET',',','AETPETR',',','RUNOFF',',','RUN_P',',','ET_P',',', &'RUNET_P',',','MAXSWE') C-----PRINT TITLE FOR AVG ANNUAL RUNOFF OUTPUT AVGANNRUNOFF.TXT WRITE (80, 1070) 1070 FORMAT ('CELL',',','RAIN',',','TEMP',',','MAX_SWE',',','SOLPSAT', &',','PET',',','AET',',','AETPETR',',','RUNOFF',',','RUN_P',',', &'ET_P',',','RUNET_P') C-----PRINT TITLE FOR ANNUAL R FACTOR OUTPUT WRITE (81, 1071) 1071 FORMAT ('CELL',',','YEAR',',','RAIN',',','R_NEARING',',','R_ANN') C-----PRINT TITLE FOR AVERAGEANNUAL R FACTOR OUTPUT WRITE (82, 1072) 1072 FORMAT ('CELL',',','RAIN',',','R_FACTOR') C-----PRINT TITLE FOR ANNUAL BIODIVERSITY OUTPUT ANNUALBIO.TXT c WRITE (700, 700) c700 FORMAT ('CELL',',','YEAR,TREE_BIO',',','MAMM_BIO', c &',','BIRD_BIO',',','AMPH_BIO',',','REPT_BIO',',','VERT_BIO', c &',','AET',',','PET') C-----PRINT TITLE FOR AVG ANNUAL BIODIVERSITY OUTPUT AVGANNBIO.TXT c WRITE (800, 6000) c6000 FORMAT ('CELL',',','YRS',',','TREE_BIO',',','MAMM_BIO', c &',','BIRD_BIO',',','AMPH_BIO',',','REPT_BIO',',','VERT_BIO') C-----PRINT TITLE FOR MONTHLY MEAN WATER BALANCE OUTPUT MOMEANRUNOFF.TXT WRITE (803, 501) 501 FORMAT ('HUC8',',','MONTH',',','PPT_MM',',','TEMP_C',',', &'SWE_MM',',','SOLPSAT',',','PET_MM',',','AET_MM',',','RO_MM') RETURN END C**********************************************************************C C C C *** SUBROUTINE RPSINT *** C C Read in landuse data from CELLINFO.TXT, calcuate change in C C landuse based on percent forest decrease (if desired), write C C to BASICOUT.TXT C C READ IN SOIL PROPERTIES FROM SOILINFO.TXT C C READ IN CELL AREA AND ELEVATION FROM HUCAREA.TXT C C C C**********************************************************************C SUBROUTINE RPSINT IMPLICIT NONE COMMON/BASIC/NGRID,NYEAR,NLC,BYEAR,IYSTART,IYEND,POP_FLAG, & REGION,CLIMATE_FLAG COMMON/CELLINFO/LADUSE(4000,200,10),LATUDE(4000),LONGI(4000), & TAREA(4000),HUCNO(4000) COMMON/IMPERVIOUS/IMPERV(4000,10) COMMON/SOIL/LZTWM(2200), LZFPM(2200), LZFSM(2200), LZSK(2200), > LZPK(2200), UZTWM(2200), UZFWM(2200), UZK(2200), ZPERC(2200), > REXP(2200), PFREE(2200), SMC(12) COMMON/LANDCHANGE/FPERD, LAI_CHG, FOR_CONV_TO COMMON/HUC/ HUCAREA(2200) COMMON/ELEVATION/HUCELE(2200) INTEGER ID, HUCNO, NLC, I, J, NGRID, IDHUC,HUCN,FOR_CONV_TO INTEGER NYEAR REAL LATUDE,LONGI, LADUSE,TAREA REAL LZTWM, LZFPM, LZFSM, LZSK, > LZPK, UZTWM, UZFWM, UZK, ZPERC, > REXP, PFREE, SMC REAL FPERD CHARACTER*8 DUMY(30), DUMY7(30) CHARACTER*5 CLIMATE_FLAG CHARACTER*2 REGION REAL IMPERV INTEGER YEAR !Previously undeclared INTEGER BYEAR, IYEND, IYSTART, K, POP_FLAG REAL A, B, HUCAREA, HUCELE, LAI_CHG C --- READ LAND COVER DATA FOR EACH CELL IN THE CELLINFO.TXT FILE C --- ASSIGN VALUE TO NGRID BASED ON NUMBER OF CELLS (ROWS) IN CELLINFO.TXT READ (2,500) DUMY 500 FORMAT (30A8) IF (REGION.EQ.'US') THEN READ (10,500) DUMY NLC = 10 ELSEIF (REGION.EQ.'MX'.OR.REGION.EQ.'RW') THEN NLC = 8 ENDIF DO 17 J=1,NYEAR DO 10 I=1,NGRID IF (REGION.EQ.'US') THEN READ(2,*) YEAR, ID, HUCNO(I), LATUDE(I), LONGI(I), > (LADUSE(I,J,K),K=1, NLC),TAREA(I) ELSEIF (REGION.EQ.'MX'.OR.REGION.EQ.'RW') THEN READ(2,*) YEAR, HUCNO(I), LATUDE(I), LONGI(I), > (LADUSE(I,J,K),K=1, NLC),TAREA(I) ENDIF 10 CONTINUE 17 CONTINUE IF (REGION.EQ.'US') THEN DO 11 I=1,NGRID READ(10,*) A, B, (IMPERV(I,K),K=1, NLC) 11 CONTINUE ENDIF 222 FORMAT(' ERROR: INVALID LAND COVER SELECTED FOR FOREST', &' CONVERSION'/) C-- DO NOT ALLOW FOREST LAND COVER CHANGE TO FOREST IF(FOR_CONV_TO.EQ.2.OR.FOR_CONV_TO.EQ.3.OR.FOR_CONV_TO.EQ.4) THEN WRITE (*,222) WRITE (77,222) STOP ENDIF C-- FOR RWANDA DO NOT ALLOW FOREST LAND COVER CHANGE TO W/U/B IF(REGION.EQ.'RW')THEN IF(FOR_CONV_TO.EQ.8) THEN WRITE (*,222) WRITE (77,222) STOP ENDIF ENDIF C ---- APPLY USER SPECIFIED FOREST LAND COVER DECREASE FRACTION TO OTHER LAND COVER C ----FOREST DECREASE FRACTION RANGES BETWEEN -1.00 - 0.00 DO 27 J=1, NYEAR DO 20 I=1, NGRID IF (REGION.EQ.'US') THEN C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO CROP LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE CROP LAND COVER IF (FOR_CONV_TO.EQ.1) THEN LADUSE(I,J,1) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,1) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO GRASS LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE GRASS LAND COVER ELSEIF (FOR_CONV_TO.EQ.5) THEN LADUSE(I,J,5) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,5) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO SHRUB LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE SHRUB LAND COVER ELSEIF (FOR_CONV_TO.EQ.6) THEN LADUSE(I,J,6) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,6) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO WETLAND LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE WETLAND LAND COVER ELSEIF (FOR_CONV_TO.EQ.7) THEN LADUSE(I,J,7) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,7) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO OPEN WATER LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE OPEN WATER LAND COVER ELSEIF (FOR_CONV_TO.EQ.8) THEN LADUSE(I,J,8) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,8) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO URBAN LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE URBAN LAND COVER ELSEIF (FOR_CONV_TO.EQ.9) THEN LADUSE(I,J,9) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,9) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO BARREN LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE BARREN LAND COVER ELSEIF (FOR_CONV_TO.EQ.10) THEN LADUSE(I,J,10) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,10) ENDIF ELSEIF (REGION.EQ.'MX'.OR.REGION.EQ.'RW') THEN C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO CROP LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE CROP LAND COVER IF (FOR_CONV_TO.EQ.1) THEN LADUSE(I,J,1) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,1) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO GRASS LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE GRASS LAND COVER ELSEIF (FOR_CONV_TO.EQ.5) THEN LADUSE(I,J,5) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,5) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO SHRUB LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE SHRUB LAND COVER ELSEIF (FOR_CONV_TO.EQ.6) THEN LADUSE(I,J,6) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,6) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO SAVANNA LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE SAVANNA LAND COVER ELSEIF (FOR_CONV_TO.EQ.7) THEN LADUSE(I,J,7) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,7) C -- IF USER SPECIFIES TO CONVERT SOME FOREST TO WATER/URBAN/BARREN LAND COVER, APPLY THE FOREST C -- LANDCOVER REDUCTION TO THE WATER/URBAN/BARREN LAND COVER IF(REGION.EQ.'MX')THEN ELSEIF (FOR_CONV_TO.EQ.8) THEN LADUSE(I,J,8) = -FPERD * (LADUSE(I,J,2) + LADUSE(I,J,3) & +LADUSE(I,J,4)) + LADUSE(I,J,8) ENDIF ENDIF ENDIF LADUSE(I,J,2) = LADUSE(I,J,2)*(1+FPERD) LADUSE(I,J,3) = LADUSE(I,J,3)*(1+FPERD) LADUSE(I,J,4) = LADUSE(I,J,4)*(1+FPERD) 20 CONTINUE 27 CONTINUE C --- Read SOIL PARAMETERS for each active cell READ (7,550) DUMY 550 FORMAT (30A8) DO 15 I=1, NGRID IF (REGION.EQ.'US') THEN READ(7,*) ID, HUCNO(I), UZTWM(I), UZFWM(I), UZK(I), ZPERC(I), &REXP(I), LZTWM(I), LZFSM(I), LZFPM(I), LZSK(I), &LZPK(I), PFREE(I) ELSEIF (REGION.EQ.'MX'.OR.REGION.EQ.'RW') THEN READ(7,*) HUCNO(I), UZTWM(I), UZFWM(I), UZK(I), ZPERC(I), &REXP(I), LZTWM(I), LZFSM(I), LZFPM(I), LZSK(I), &LZPK(I), PFREE(I) ENDIF C -- CONVERT FLOW RATES IN UNITS OF 1/D TO MONTHLY RATES UZK(I)=UZK(I)*30 LZSK(I)=LZSK(I)*30 LZPK(I)=LZPK(I)*30 15 CONTINUE C--- READ IN CELL AREA AND ELEVATION DATA C--- FOR US REGION, READ IN HUC AREA, ELEV from HUCAREA.TXT IF (REGION.EQ.'US') THEN READ (11, 50) DUMY7 50 FORMAT (30A8) DO 60 I = 1, NGRID READ (11, *) IDHUC, HUCN, HUCAREA(I),HUCELE(I) 60 CONTINUE C --- FOR MX REGION, CALCULATE HUC AREA BY GRID SIZE, AND ASSUME ELEVATION = 0 M ELSEIF(REGION.EQ.'MX') THEN DO 61 I = 1, NGRID HUCAREA(I) = 50000.0*50000.0 HUCELE(I) = 0.0 61 CONTINUE C --- FOR RW REGION, READ IN HUC AREA, ELEV from HUCAREA.TXT ELSEIF(REGION.EQ.'RW') THEN READ (11, 50) DUMY7 DO 62 I = 1, NGRID READ (11, *) HUCN, HUCAREA(I) 62 CONTINUE ENDIF RETURN END C**********************************************************************C C C C *** SUBROUTINE RPSCLIMATE *** C C Input MONTHLY CLIMATE DATA C C C C**********************************************************************C SUBROUTINE RPSCLIMATE IMPLICIT NONE COMMON/BASIC/NGRID,NYEAR,NLC,BYEAR,IYSTART,IYEND,POP_FLAG, & REGION,CLIMATE_FLAG COMMON/CLIMATE/ RAIN(4000,200,12), TEMP(4000,200, 12) COMMON/CLIMATECHANGE/PPT_CHG,TEMP_CHG INTEGER HUCNO(4000), NYEAR, NGRID, YEAR, BYEAR INTEGER I, J, M, M2 REAL RAIN, TEMP REAL PPT_CHG, TEMP_CHG CHARACTER*10 TEMPHEAD (10) CHARACTER*5 CLIMATE_FLAG CHARACTER*2 REGION !Previously undeclared INTEGER IYEND, IYSTART, NLC, POP_FLAG C -- READ IN MONTHLY CLIMATE DATA C -- ASSIGN FIRST YEAR OF CLIMATE DATA TO BYEAR C -- CALCULATE NUMBER OF YEARS OF CLIMATE DATA AND ASSIGN TO NYEAR C -- REQUIRES CLIMATE DATA TO BE SORTED BY YEAR, CELL, THEN MONTH READ(4,900) TEMPHEAD 900 FORMAT(10A10) DO 5000 J=1,NYEAR DO 5001 I=1,NGRID DO 5002 M=1,12 READ(4,*) HUCNO(I), YEAR, M2, RAIN(I,J,M), & TEMP(I,J,M) !HFD sanity check IF(M2.NE.M) THEN WRITE(*,*) 'ERROR: M2.NE.M, aborting...' STOP ENDIF IF (I.EQ.1 .AND. J.EQ.1 .AND. M.EQ.1) THEN BYEAR = YEAR ENDIF 5002 CONTINUE 5001 CONTINUE 5000 CONTINUE IF (IYSTART.LT.BYEAR) THEN WRITE (*,33) WRITE (77,33) 33 FORMAT(' ERROR: START YEAR MUST BE >= FIRST YEAR OF CLIMATE', &' DATA'/) STOP ENDIF IF (IYEND.GT.(BYEAR+NYEAR-1)) THEN WRITE (*,34) WRITE (77,34) 34 FORMAT(' ERROR: END YEAR MUST BE <= LAST YEAR OF CLIMATE', &' DATA'/) STOP ENDIF C -- ADJUST CLIMATE DATA BY USER SPECIFIED PPT AND TEMPERATURE CHANGES DO 5003 J=1,NYEAR DO 5004 I=1,NGRID DO 5005 M=1,12 RAIN(I,J,M) = RAIN(I,J,M) * (1 + PPT_CHG) TEMP(I,J,M) = TEMP(I,J,M) + TEMP_CHG 5005 CONTINUE 5004 CONTINUE 5003 CONTINUE RETURN END C**********************************************************************C C C C *** SUBROUTINE RPSWATERUSE *** C C Read in return flow rate from RETURNFLOW.TXT C C Read in water use by water resource region from HUCREGION.TXT C C Read in population info from POPULATION.TXT C C READ IN GROUNDWATER USE BY SECTOR from GROUNDWATER.TXT C C READ IN SURFACE WATER USE BY SECTOR from WATERUSE.TXT C C calculate change in irrigation water use if desired C C Read in huc node info from NODEHUC.TXT C C Read in average monthly flows from AVGMONFLOW.TXT C C C C**********************************************************************C SUBROUTINE RPSWATERUSE IMPLICIT NONE COMMON/BASIC/NGRID,NYEAR,NLC,BYEAR,IYSTART,IYEND,POP_FLAG, & REGION,CLIMATE_FLAG COMMON/POPULATION/POPULATION(2200, 200) COMMON/HUCREGION/DMC(18,4),IRRC(18,4), PPC(18,4) COMMON/RETURNFLOW/ RETURNFLOW(2200,8) COMMON/GROUNDWATER/ GROUNDWATER(2200,9), GW_CHG COMMON/WATERUSE/ WATERUSE(2200,10), HUCWUSE(2200),PERCAP(2200) COMMON/DEMANDCHANGE/DOM_CHG, IND_CHG, IRR_CHG, LIV_CHG, MIN_CHG, &THR_CHG, PUS_CHG, AQU_CHG, POP_CHG REAL POPULATION,PERCAP,BASEPOP(2200) REAL RETURNFLOW, WATERUSE REAL GROUNDWATER, HUCWUSE REAL DMC, IRRC, PPC, GW_CHG REAL DOM_CHG, IND_CHG, IRR_CHG, LIV_CHG, MIN_CHG, THR_CHG, &PUS_CHG, AQU_CHG, POP_CHG INTEGER POP_FLAG CHARACTER*10 DUMY4(30),DUMY7(30),DUMY6(30),DUMY2(30) INTEGER HUCN, BYEAR CHARACTER*5 CLIMATE_FLAG CHARACTER*2 REGION !Previously undeclared INTEGER I, IDHUC, IREGION, IYEND, IYSTART, J, JYEAR, NGRID, & NLC, NYEAR C---READ IN RETURN FLOW RATE from RETURNFLOW.TXT READ (15, 50) DUMY7 50 FORMAT (30A10) DO 65 I=1, NGRID READ (15, *) IDHUC, HUCN,(RETURNFLOW(I,J), J=1, 8) C WRITE (77,86) IDHUC, HUCN,(RETURNFLOW(I,J), J=1, 8) 86 FORMAT(2I12, 8F10.3) 65 CONTINUE C-- READ IN water resource region water use info from HUCREGION.TXT READ (12,50) DUMY7 DO 55 I = 1, 18 READ (12, *) IREGION, (DMC(I,J), J=1,4), > (IRRC(I,J), J=1,4), (PPC(I,J), J=1,4) C WRITE (77, 98) IREGION, (DMC(I,J), J=1,4), C > (IRRC(I,J), J=1,4), (PPC(I,J), J=1,4) 55 CONTINUE 98 FORMAT (I10, 12F10.5) C-- READ IN population info from POPULATION.TXT READ (13, 50) DUMY2 DO 300 I = 1, NGRID C ---J=51 => YEAR = 2010 C ---J=101 => YEAR = 2060 DO 400 J=51, 101 READ (13, *) HUCN, JYEAR, POPULATION(I, J) IF(J.EQ.51)THEN BASEPOP(I)= POPULATION(I, J) ENDIF 1000 FORMAT(2I10, F12.3) 400 CONTINUE 300 CONTINUE C ----POP_FLAG=8000, TIME VARIABLE POPULATION 2010-2060 IF (POP_FLAG .EQ. 8000) THEN DO 211 I=1, NGRID C --- ASSIGN YEAR 2010 POPULATION DATA TO YEARS BEFORE 2010 DO 311 J=1, 50 POPULATION(I,J) = POPULATION(I,51) 311 CONTINUE C --- ASSIGN YEAR 2060 POPULATION DATA TO YEARS AFTER 2060 UP TO 2100 DO 312 J=102, 141 POPULATION(I,J) = POPULATION(I,101) 312 CONTINUE 211 CONTINUE C ---POP_FLAG BETWEEN 2010 AND 2060, CONSTANT POPULATION FOR ALL YEARS (1960-2100) USING POPULATION DATA FOR YEAR ENTERED ELSEIF (POP_FLAG .LT. 8000) THEN DO 214 I=1,NGRID DO 314 J=1,141 POPULATION(I,J) = POPULATION(I,(POP_FLAG - (1960 - 1))) 314 CONTINUE 214 CONTINUE ENDIF C ----ADJUST POPULATION BASED ON USER INPUT DO 218 I=1,NGRID DO 318 J=1,141 POPULATION(I,J) = POPULATION(I,J) * (1 + POP_CHG) 318 CONTINUE 218 CONTINUE C--READ IN GROUNDWATER WITHDRAWAL DATA BY SECTOR (8 SECTORS PLUS TOTAL) IN MILLION GALLON/day READ (14, 50) DUMY4 DO 80 I = 1, NGRID READ (14, *) IDHUC, HUCN, (GROUNDWATER(I, J), J=1, 9) C WRITE (77, 1100) IDHUC, HUCN, (GROUNDWATER(I, J), J=1, 9) C J=1 -> DOMESTIC C J=2 -> INDUSTRIAL C J=3 -> IRRIGATION C J=4 -> LIVESTOCK C J=5 -> MINING C J=6 -> THERMOPOWER C J=7 -> PUBLIC SUPPLY C J=8 -> AQUACULTURE C J=9 -> TOTAL 1100 FORMAT (2I12, 9F12.3) 80 CONTINUE C -- ADJUST GROUNDWATER WITHDRAWAL DATA BY USER SPECIFIED FRACTION C -- GW_CHG- RANGE: -1.00 - INF (E.G. 20% DECREASE = -0.20, 20% INCREASE = 0.20, NO CHANGE = 0.00) DO 81 I = 1,NGRID DO 82 J = 1,9 GROUNDWATER(I, J) = GROUNDWATER(I, J) * (1 + GW_CHG) 82 CONTINUE 81 CONTINUE C--READ IN SURFACE WATER USE BY SECTOR (8 SECTORS PLUS TOTAL) READ (16, 50) DUMY6 DO 90 I = 1, NGRID READ (16, *) IDHUC, HUCN, (WATERUSE(I,J), J=1, 10) C WRITE (77,1200) IDHUC,HUCN, (WATERUSE (I,J), J=1,10) C J=1 -> DOMESTIC C J=2 -> INDUSTRIAL C J=3 -> IRRIGATION C J=4 -> LIVESTOCK C J=5 -> MINING C J=6 -> THERMOPOWER C J=7 -> PUBLIC SUPPLY C J=8 -> AQUACULTURE C J=9 -> TOTAL C J=10 -> PUBLIC SUPPLY DELIVERIES TO DOMESTIC 1200 FORMAT(2I15, 10F12.3) 90 CONTINUE DO 99 I = 1, NGRID C -- COMPUTE ACTUAL BASELINE PER CAPITA WATER USE FROM DOMESTIC AND PUBLIC SUPPLY DELIVERIES TO DOMESTIC SECTOR C -- USING 2010 POPULATION AND 2005 DOM+PS_DEL_MO WATER USE IF (BASEPOP(I).EQ.0) THEN PERCAP(I)=0 ELSE PERCAP(I)=(WATERUSE(I,10)+WATERUSE(I,1))/(BASEPOP(I)) ENDIF C -- IF DOMESTIC WATER USE IS TO BE CALCULATED BASED ON POPULATION (POP_FLAG NOT EQUAL TO 9000) IF (POP_FLAG.NE.9000) THEN C -- 2005 USGS PUBLIC SUPPLY SECTOR CONTRIBUTES TO DOMESTIC AND INDUSTRIAL SECTORS C -- SET PUBLIC SUPPLY WATER USE TO THE DIFFERENCE BETWEEN PUBLIC SUPPLY AND PS_DEL_DOM C -- THIS REPRESENTS THE PUBLIC SUPPLY DELIVERY TO SECTORS OTHER THAN DOMESTIC (THESE WILL REMAIN CONSTANT WRT POPULATION) WATERUSE(I,7) = WATERUSE(I,7) - WATERUSE(I,10) ENDIF C -- ADJUST WATER DEMAND DATA BY USER SPECIFIED FRACTION FOR EACH SECTOR C -- *_CHG- RANGE: -1.00 - INF (E.G. 20% DECREASE = -0.20, 20% INCREASE = 0.20, NO CHANGE = 0.00) WATERUSE(I,1) = WATERUSE(I,1) * (1 + DOM_CHG) WATERUSE(I,2) = WATERUSE(I,2) * (1 + IND_CHG) WATERUSE(I,3) = WATERUSE(I,3) * (1 + IRR_CHG) WATERUSE(I,4) = WATERUSE(I,4) * (1 + LIV_CHG) WATERUSE(I,5) = WATERUSE(I,5) * (1 + MIN_CHG) WATERUSE(I,6) = WATERUSE(I,6) * (1 + THR_CHG) WATERUSE(I,7) = WATERUSE(I,7) * (1 + PUS_CHG) WATERUSE(I,8) = WATERUSE(I,8) * (1 + AQU_CHG) 99 CONTINUE C ----------------------------------------------------------- RETURN END C**********************************************************************C C C C *** SUBROUTINE RPSLAI *** C C Input MONTHLY MEAN LAI C C C C**********************************************************************C SUBROUTINE RPSLAI IMPLICIT NONE COMMON/BASIC/NGRID,NYEAR,NLC,BYEAR,IYSTART,IYEND,POP_FLAG, & REGION,CLIMATE_FLAG COMMON/LAI/LAI(4000,200,12,10) COMMON/LANDCHANGE/FPERD, LAI_CHG, FOR_CONV_TO INTEGER NLC,HUCNO(4000), YEAR, NGRID INTEGER I, J, M, M2 INTEGER NYEAR CHARACTER*11 TEMPHEAD3 (11) CHARACTER*5 CLIMATE_FLAG CHARACTER*2 REGION REAL LAI REAL LAI_CHG !Previously undeclared INTEGER BYEAR, IYEND, IYSTART, POP_FLAG, FOR_CONV_TO, K REAL FPERD C --- READ IN LAI DATA FROM LANDLAI.TXT DO 205 J=1, NYEAR DO 201 I=1, NGRID DO 401 M=1, 12 IF (J .EQ. 1 .AND. I .EQ. 1 .AND. M .EQ. 1) THEN READ (8, 902) TEMPHEAD3 902 FORMAT (30A11) ENDIF C --- LAI* IS THE LAI FOR LANDUSE * (10 TOTAL IN LANDLAI.TXT FOR US, 8 FOR MX AND RW) READ(8,*) YEAR,HUCNO(I),M2,(LAI(I,J,M,K),K=1, NLC) !HFD, sanity check IF(M2.NE.M) THEN WRITE(*,*) 'ERROR: M2.NE.M, aborting...' STOP ENDIF 401 CONTINUE 201 CONTINUE 205 CONTINUE C --- ADJUST FOREST LAI BY USER SPECIFIED LAI CHANGE FRACTION C --- LAI_CHG RANGES FROM -1.00 - INF DO 207 J=1, NYEAR DO 204 I=1, NGRID DO 404 M=1, 12 LAI(I,J,M,2) = LAI(I,J,M,2) * (1+LAI_CHG) LAI(I,J,M,3) = LAI(I,J,M,3) * (1+LAI_CHG) LAI(I,J,M,4) = LAI(I,J,M,4) * (1+LAI_CHG) 404 CONTINUE 204 CONTINUE 207 CONTINUE RETURN END