Add files via upload
This commit is contained in:
Xuesong (Steve)
699
code/modified/physproc.f
Normal file
699
code/modified/physproc.f
Normal file
@ -0,0 +1,699 @@
|
||||
! $Id: physproc.f,v 1.2 2009/08/17 03:59:52 daven Exp $
|
||||
SUBROUTINE PHYSPROC( SUNCOS, SUNCOSB )
|
||||
!
|
||||
!******************************************************************************
|
||||
! Subroutine PHYSPROC is the driver for SMVGEAR II chemistry. It calls both
|
||||
! CALCRATE to compute the rxn rates and the SMVGEAR solver routine.
|
||||
! (M. Jacobson 1993; bdf, bmy, 4/18/03, 9/29/03)
|
||||
!
|
||||
! NOTES:
|
||||
! (1 ) For GEOS-CHEM we had to remove ABSHUM, AIRDENS, CSPEC, IXSAVE, IYSAVE,
|
||||
! and T3 from "comode.h" and to declare these allocatable in F90 module
|
||||
! "comode_mod.f". This allows us to only allocate these if we are
|
||||
! doing a fullchem run. Now references TIMESTAMP_STRING from
|
||||
! "time_mod.f". Now pass SUNCOSB via the arg list. Now force double
|
||||
! precision with the "D" exponent. (bmy, 4/18/03)
|
||||
! (2 ) Comment out section that computes photorates from original SMVGEAR II
|
||||
! file "photrate.dat"...this is not needed. Remove TFROMID, it's not
|
||||
! used anywhere else. Remove references to LASTCHEM, this is mpt
|
||||
! initialized anywhere. Now reference CSUMA, CSUMC, ERRMX2 from
|
||||
! "comode_mod.f". (bmy, 7/30/03)
|
||||
! (3 ) LINUX has a problem putting a function call w/in a WRITE statement.
|
||||
! Now save output from TIMESTAMP_STRING to STAMP and print that.
|
||||
! (bmy, 9/29/03)
|
||||
! (4 ) Fixed case of small KULOOP (phs, 10/5/07)
|
||||
!******************************************************************************
|
||||
!
|
||||
! References to F90 modules (bmy, 10/19/00)
|
||||
USE COMODE_MOD, ONLY : ABSHUM, AIRDENS, CSPEC, CSUMA,
|
||||
& CSUMC, ERRMX2, IXSAVE, IYSAVE, T3, R_KPP
|
||||
USE TIME_MOD, ONLY : TIMESTAMP_STRING
|
||||
|
||||
IMPLICIT NONE
|
||||
|
||||
# include "CMN_SIZE" ! Size parameters
|
||||
# include "comode.h" ! SMVGEAR II arrays
|
||||
C
|
||||
C *********************************************************************
|
||||
C ************ WRITTEN BY MARK JACOBSON (1993) ************
|
||||
C *** (C) COPYRIGHT, 1993 BY MARK Z. JACOBSON ***
|
||||
C *** U.S. COPYRIGHT OFFICE REGISTRATION NO. TXu 670-279 ***
|
||||
C *** (650) 723-6836 ***
|
||||
C *********************************************************************
|
||||
C
|
||||
C PPPPPPP H H Y Y SSSSSSS PPPPPPP RRRRRRR OOOOOOO CCCCCCC
|
||||
C P P H H Y Y S P P R R O O C
|
||||
C PPPPPPP HHHHHHH Y SSSSSSS PPPPPPP RRRRRRR O O C
|
||||
C P H H Y S P R R O O C
|
||||
C P H H Y SSSSSSS P P P OOOOOOO CCCCCCC
|
||||
C
|
||||
C *********************************************************************
|
||||
C * THIS SUBROUTINE CALLS CALCRATE.F AND SMVGEAR.F. TO SOLVE GAS- *
|
||||
C * PHASE CHEMICAL EQUATIONS. THE ROUTINE DIVIDES THE GRID DOMAIN *
|
||||
C * INTO GRID BLOCKS, AND THE CODE VECTORIZES AROUND THE NUMBER OF *
|
||||
C * GRID CELLS IN EACH BLOCK. *
|
||||
C * *
|
||||
C *********************************************************************
|
||||
C
|
||||
C *********************************************************************
|
||||
C **************** UPDATE 24-HOUR CLOCK ****************
|
||||
C *********************************************************************
|
||||
C CHEMINTV = TIME INTERVAL FOR CHEMISTRY
|
||||
C IRCHEM = COUNTS # CHEMINTV TIME-INTERVALS
|
||||
C
|
||||
! Arguments
|
||||
REAL*8, INTENT(IN) :: SUNCOS(MAXIJ), SUNCOSB(MAXIJ)
|
||||
|
||||
! Local variables
|
||||
INTEGER IDLAST,IMLAST,NMINADD,NHRADD,NDAYADD,NMONADD,NYEARAD
|
||||
INTEGER MLOOP,LOREORD,ILNCS,IHNCS,JLOOP,NBLOCKUSE,IAVBLOK,IAVGSIZE
|
||||
INTEGER JLOOPN,JOLD,JNEW,KLOOP,NSUNRISE,NSUNSET,JLOOPC,NNORISE
|
||||
INTEGER JLLAST,IT,IRADD,LVAL,IRVAL,IRADD1,JREORD,IPAR,JPAR,JPAR1
|
||||
INTEGER NSUMBLOCK,NCELLROW,NBLOCKROW,ICG,I,NGCOUNT,NGHI,IAVG
|
||||
INTEGER IREMAIN,IUSESIZE,NREBLOCK,L
|
||||
INTEGER IX,IY,IJWINDOW,KBLK2,NK
|
||||
|
||||
INTEGER COUNTER,JGAS
|
||||
REAL*8 S1CON,S2CON,ARGS,CONSTQ,SNOON,CONTEMP,DIFCONC,PLODYN
|
||||
REAL*8 PR3,RIS,RST,TBEGIN,TFINISH,VALLOW,CLO1,CLO2,SUMFRACS
|
||||
REAL*8 SUMRMS,SUMHI,SUMRMSH,CMOD,CGOOD,FRACDIF,FRACABS,AVGERR
|
||||
REAL*8 RMSCUR,AVGHI,RMSCURH,FSTEPT,FITS,TSTEPIT,PHIDYN
|
||||
REAL*8 GMU
|
||||
|
||||
! For LINUX fix (bmy, 9/29/03)
|
||||
CHARACTER(LEN=16) :: STAMP
|
||||
|
||||
!=================================================================
|
||||
! PHYSPROC begins here!
|
||||
!=================================================================
|
||||
IRCHEM = IRCHEM + 1
|
||||
TIME = TIME + CHEMINTV
|
||||
TSPMIDC = MOD(TSPMIDC + CHEMINTV,SCDAY)
|
||||
COUNTER = 0
|
||||
|
||||
! Return if we have turned off SMVGEAR
|
||||
IF (IFSOLVE.EQ.0) RETURN
|
||||
|
||||
! Echo timestamp
|
||||
STAMP = TIMESTAMP_STRING()
|
||||
WRITE( 6, 100 ) STAMP
|
||||
100 FORMAT( ' - PHYSPROC: Trop chemistry at ', a )
|
||||
C
|
||||
C *********************************************************************
|
||||
C *********************************************************************
|
||||
C NCS = 1..NCSGAS --> DO GAS CHEMISTRY
|
||||
C LOREORD = 1 IF REORDERING; = 2 IF NO REORDERING
|
||||
C
|
||||
|
||||
|
||||
IF (IFREORD.EQ.1.AND.NTLOOP.GT.1) THEN
|
||||
LOREORD = 1
|
||||
ELSE
|
||||
LOREORD = 2
|
||||
ENDIF
|
||||
C
|
||||
ILNCS = 1
|
||||
IHNCS = NCSGAS
|
||||
C
|
||||
C *********************************************************************
|
||||
C * REORDER CELLS AND BLOCKS THEN SOLVE CHEMICAL ODES *
|
||||
C *********************************************************************
|
||||
C ISREORD = 1: THEN REORDER GRID CELLS AND GRID BLOCKS FOR CHEMISTY;
|
||||
C = 2: SOLVE CHEMISTRY
|
||||
C JREORDER = GIVES ORIGINAL GRID-CELL FROM RE-ORDERED GRID-CELL
|
||||
C LREORDER = JREORDER
|
||||
C NBLOCKUSE = # OF ORIGINAL BLOCKS (ISREORD EQ LOREORD) OR
|
||||
C # OF BLOCKS AFTER REORDERING (ISREORD NE LOREORD)
|
||||
C NCS = 1..NCSGAS FOR GAS CHEMISTRY
|
||||
C NCSP = NCS FOR DAYTIME GAS CHEM
|
||||
C = NCS + ICS FOR NIGHTTIME GAS CHEM
|
||||
C
|
||||
DO 860 NCS = ILNCS, IHNCS
|
||||
C
|
||||
DO 855 ISREORD = LOREORD, 2
|
||||
C
|
||||
!write(6,*) 'value of isreord= ',isreord
|
||||
IF (ISREORD.EQ.LOREORD) THEN
|
||||
C
|
||||
C *********************************************************************
|
||||
C DETERMINE BLOCK SIZES FOR CHEMISTRY
|
||||
C *********************************************************************
|
||||
C CHEMISTRY IN ONE REGION OF THE ATMOSPHERE
|
||||
C *********************************************************************
|
||||
C IGLOBCHEM = -2 --> SOLVE ALL GAS CHEMISTRY WITH COMBINATION OF U/R/S SETS
|
||||
C = -1 --> SOLVE ALL GAS CHEMISTRY WITH COMBINATION OF R/S SETS
|
||||
C = 0 --> SOLVE ALL GAS CHEMISTRY WITH EITHER U, R, OR S SETS
|
||||
C = 1 --> SOLVE EACH REGION SEPARATELY WITH U, R, OR S SET
|
||||
C
|
||||
IF (IGLOBCHEM.LE.0) THEN
|
||||
!NTLOOPUSE = NTLOOPNCS(NCS)
|
||||
|
||||
! updated ntloop calc in ruralbox.f
|
||||
NTLOOPUSE = NTLOOP
|
||||
DO 320 JLOOP = 1, NTLOOPUSE
|
||||
320 JREORDER(JLOOP) = JLOOP
|
||||
C
|
||||
ELSE
|
||||
|
||||
C
|
||||
C *********************************************************************
|
||||
C GLOBAL CHEMISTRY - ASSUME THREE REGIONS OF THE ATMOSPHERE
|
||||
C URBAN, TROPOSPHERIC, STRATOSPHERIC
|
||||
C *********************************************************************
|
||||
C NCS = 1..NCSGAS FOR GAS CHEMISTRY
|
||||
C PRESS3 = MODEL VERTICAL LAYER CENTER PRESSURE (MB)
|
||||
C PLOURB = PRES (MB), BELOW WHICH URBAN, URBAN/TROP, OR ALL CHEMISTRY OCCURS
|
||||
C PLOTROP = PRES (MB), BELOW WHICH TROP, URBAN/TROP, OR ALL CHEMISTRY OCCURS
|
||||
C = ABOVE WHICH STRAT OR ALL CHEMISTRY OCCURS
|
||||
C
|
||||
IF (NCS.EQ.NCSURBAN) THEN
|
||||
NTLOOPUSE = NTLOOPNCS(NCS)
|
||||
DO JLOOP = 1, NTLOOPUSE
|
||||
JREORDER(JLOOP) = NCSLOOP(JLOOP,NCS)
|
||||
ENDDO
|
||||
ELSEIF (NCS.EQ.NCSTROP) THEN
|
||||
NTLOOPUSE = NTLOOPNCS(NCS)
|
||||
DO JLOOP = 1, NTLOOPUSE
|
||||
JREORDER(JLOOP) = NCSLOOP(JLOOP,NCS)
|
||||
ENDDO
|
||||
ELSEIF (NCS.EQ.NCSSTRAT) THEN
|
||||
NTLOOPUSE = NTLOOPNCS(NCS)
|
||||
DO JLOOP = 1, NTLOOPUSE
|
||||
JREORDER(JLOOP) = NCSLOOP(JLOOP,NCS)
|
||||
ENDDO
|
||||
ENDIF
|
||||
C
|
||||
ENDIF
|
||||
C ENDIF IGLOBCHEM.EQ.0
|
||||
C
|
||||
C *********************************************************************
|
||||
C DETERMINE ORIGINAL NUMBER OF GRID BLOCKS
|
||||
C *********************************************************************
|
||||
C NBLOCKUSE = ORIGINAL NUMBER OF GRID BLOCKS FOR PREDICTING STIFFNESS
|
||||
C IUSESIZE = # OF GRID CELLS IN EACH GRID BLOCK
|
||||
C NBLOCKUSE = HERE, TOTAL NUMBER OF GRID CELLS FOR CHEMISTRY CALCULATIONS
|
||||
C JLOWVAR = LOWEST GRID CELL NUMBER - 1 IN EACH GRID BLOCK
|
||||
C
|
||||
! Comment out write statements for now (bmy, 4/1/03)
|
||||
!write(6,*) 'in physproc, iglobchem= ',iglobchem
|
||||
!write(6,*) 'val of ntloopuse= ',ntloopuse
|
||||
|
||||
NBLOCKUSE = 1 + NTLOOPUSE / (KULOOP + 0.0001d0)
|
||||
IAVBLOK = 1 + NTLOOPUSE / (NBLOCKUSE + 0.0001d0)
|
||||
IAVGSIZE = MIN0(IAVBLOK,KULOOP)
|
||||
C
|
||||
JLOOPLO = 0
|
||||
IREMAIN = NTLOOPUSE
|
||||
C
|
||||
DO 200 KBLK = 1, NBLOCKUSE
|
||||
IUSESIZE = MIN(IAVGSIZE,MAX(IREMAIN,0))
|
||||
JLOWVAR(KBLK) = JLOOPLO
|
||||
KTLPVAR(KBLK) = IUSESIZE
|
||||
IREMAIN = IREMAIN - IUSESIZE
|
||||
JLOOPLO = JLOOPLO + IUSESIZE
|
||||
200 CONTINUE
|
||||
|
||||
! Added fix for small (1 to 3) KULOOP (10/5/07, phs)
|
||||
IF (IREMAIN /= 0) THEN
|
||||
DO WHILE ( IREMAIN /= 0 )
|
||||
NBLOCKUSE = NBLOCKUSE + 1
|
||||
IUSESIZE = MIN(IAVGSIZE,MAX(IREMAIN,0))
|
||||
JLOWVAR(NBLOCKUSE) = JLOOPLO
|
||||
KTLPVAR(NBLOCKUSE) = IUSESIZE
|
||||
IREMAIN = IREMAIN - IUSESIZE
|
||||
JLOOPLO = JLOOPLO + IUSESIZE
|
||||
END DO
|
||||
ENDIF
|
||||
|
||||
C
|
||||
C *********************************************************************
|
||||
C NUMBER OF GRID BLOCKS AFTER REORDERING
|
||||
C *********************************************************************
|
||||
C
|
||||
ELSE
|
||||
NBLOCKUSE = NREBLOCK
|
||||
ENDIF
|
||||
C ENDIF ISREORD.EQ.LOREORD
|
||||
C
|
||||
C *********************************************************************
|
||||
C SET LREORDER ARRAY
|
||||
C *********************************************************************
|
||||
C LREORDER = GIVES ORIGINAL GRID CELL FROM RE-ORDERED CELL
|
||||
C
|
||||
|
||||
DO 340 JLOOPN = 1, NTLOOPUSE
|
||||
340 LREORDER(JLOOPN) = JREORDER(JLOOPN)
|
||||
C
|
||||
C *********************************************************************
|
||||
C START GRID BLOCK LOOP
|
||||
C *********************************************************************
|
||||
C
|
||||
|
||||
Write(6,*) 'about to start chemistry with NCS= ',ncs
|
||||
!write(6,*) ' val of nblockuse = ',nblockuse
|
||||
!$OMP PARALLEL DO
|
||||
!$OMP+DEFAULT( SHARED )
|
||||
!$OMP+PRIVATE( JLOOP,KLOOP,KBLK2,JNEW,JOLD )
|
||||
!$OMP+SCHEDULE( DYNAMIC )
|
||||
DO 640 KBLK2 = 1, NBLOCKUSE
|
||||
KBLK = KBLK2
|
||||
JLOOPLO = JLOWVAR(KBLK)
|
||||
KTLOOP = KTLPVAR(KBLK)
|
||||
C
|
||||
IF (KTLOOP.EQ.0) GOTO 640
|
||||
|
||||
!write(*,*) 'In physproc: ',KBLK,NBLOCKUSE,KTLOOP
|
||||
C
|
||||
C *********************************************************************
|
||||
C * PLACE LARGE DOMAIN GAS ARRAY (# CM-3) INTO SMALLER BLOCK ARRAY *
|
||||
C *********************************************************************
|
||||
C CINIT = INITIAL CONC (MOLEC. CM-3), USED TO CALCULATE RATES IN CALCRATE
|
||||
C CORIG = INITIAL CONC (MOLEC. CM-3), USED TO RESTART SMVGEAR IF A FAILURE
|
||||
C NTSPEC = NUMBER OF ACTIVE PLUS INACTIVE GASES.
|
||||
C MAPPL = MAPS ORIGINAL SPECIES NUMBERS TO SPECIES NUMBERS
|
||||
C RE-ORDERED FOR CHEMISTRY.
|
||||
C
|
||||
DO 572 JOLD = 1, NTSPEC(NCS)
|
||||
JNEW = MAPPL(JOLD,NCS)
|
||||
DO 570 KLOOP = 1, KTLOOP
|
||||
JLOOP = JREORDER(JLOOPLO+KLOOP)
|
||||
CBLK( KLOOP,JOLD) = CSPEC(JLOOP,JOLD)
|
||||
CORIG(KLOOP,JNEW) = CSPEC(JLOOP,JOLD)
|
||||
570 CONTINUE
|
||||
572 CONTINUE
|
||||
|
||||
C
|
||||
C *********************************************************************
|
||||
C * CALCULATE REACTION RATE COEFFICIENTS *
|
||||
C *********************************************************************
|
||||
C
|
||||
|
||||
CALL CALCRATE(SUNCOS)
|
||||
|
||||
DO KLOOP = 1, KTLOOP
|
||||
JLOOP = JREORDER(JLOOPLO+KLOOP)
|
||||
DO NK = 1, NTRATES(NCS)
|
||||
R_KPP(JLOOP,NK) = RRATE_FOR_KPP(KLOOP,NK)
|
||||
ENDDO
|
||||
ENDDO
|
||||
|
||||
C
|
||||
C *********************************************************************
|
||||
C * SOLVE CHEMICAL ODES *
|
||||
C *********************************************************************
|
||||
C
|
||||
! adj_group: now use KPP
|
||||
! CALL SMVGEAR
|
||||
|
||||
C
|
||||
C *********************************************************************
|
||||
C * REPLACE BLOCK CONCENTRATIONS (# CM-3) INTO DOMAIN CONCENTRATIONS *
|
||||
C *********************************************************************
|
||||
C ISREORD = 1: CALL CALCRATE TO FIND STIFFNESS OF EACH GRID-CELL
|
||||
C ISREORD = 2: SET CHEMISTRY RATES AND SOLVE EQUATIONS
|
||||
C GQSCHEM = CHANGE IN (# OF MOLECULES) OVER THE ENTIRE GRID OF EACH
|
||||
C SPECIES AS A RESULT OF CHEMISTRY.
|
||||
C GRIDVH = GRID CELL VOLUME (CM3)
|
||||
C CNEW = # CM-3
|
||||
C C = # CM-3
|
||||
C
|
||||
IF (ISREORD.EQ.2) THEN
|
||||
DO 620 JNEW = 1, ISCHANG(NCS)
|
||||
JOLD = INEWOLD(JNEW,NCS)
|
||||
DO 620 KLOOP = 1, KTLOOP
|
||||
JLOOP = JREORDER(JLOOPLO+KLOOP)
|
||||
CSPEC(JLOOP,JOLD) = MAX(CNEW(KLOOP,JNEW),SMAL2)
|
||||
620 CONTINUE
|
||||
ENDIF
|
||||
C
|
||||
640 CONTINUE
|
||||
!$OMP END PARALLEL DO
|
||||
C CONTINUE KBLK = 1, NBLOCKUSE
|
||||
C
|
||||
C *********************************************************************
|
||||
C * REORDER GRID-CELLS FROM LEAST TO MOST STIFF *
|
||||
C *********************************************************************
|
||||
C AT SUNRISE/SET REORDER CELLS SO THOSE WITH SIMILAR SUNRISE GROUP TOGETHER
|
||||
C OTHERWISE, REORDER CELLS SO THOSE WITH SIMILAR STIFFNESS GROUP TOGETHER
|
||||
C JREORDER = GIVES ORIGINAL GRID-CELL FROM RE-ORDERED GRID-CELL
|
||||
C LREORDER = GIVES ORIGINAL GRID CELL FROM RE-ORDERED CELL, EXCEPT,
|
||||
C WHEN CELL IS A VIRTUAL BOUNDARY CELL, THEN LREORDER
|
||||
C GIVES ORIGINAL EDGE CELL FROM RE-ORDERED V. B. CELL
|
||||
C JLOOPC = IDENTIFIES AN EDGE CELL FOR EACH VIRTUAL BOUNDARY CELL;
|
||||
C OTHERWISE, IDENTIFIES THE JLOOP CELL
|
||||
C
|
||||
|
||||
!==============================================================
|
||||
! New additions to reordering based on Loretta's implementation
|
||||
! (bdf, 4/1/03)
|
||||
!==============================================================
|
||||
IF (ISREORD.EQ.1) THEN
|
||||
NSUNRISE = 0
|
||||
NSUNSET = 0
|
||||
|
||||
DO 660 JLOOP = 1, NTLOOPUSE
|
||||
JLOOPC = LREORDER(JLOOP)
|
||||
IX = IXSAVE(JLOOPC)
|
||||
IY = IYSAVE(JLOOPC)
|
||||
IJWINDOW = (IY-1)*IIPAR + IX
|
||||
|
||||
IF( SUNCOS(IJWINDOW) .GT. -.25 .AND.
|
||||
& SUNCOS(IJWINDOW) .LT. .25 ) THEN
|
||||
ITWO(JLOOP) = 1
|
||||
NSUNRISE = NSUNRISE + 1
|
||||
CSUMA(JLOOP) = SUNCOS(IJWINDOW) -
|
||||
& ABS( SUNCOSB(IJWINDOW) )
|
||||
ELSE
|
||||
ITWO(JLOOP) = 0
|
||||
CSUMA(JLOOP) = ERRMX2(JLOOP)
|
||||
ENDIF
|
||||
660 CONTINUE
|
||||
|
||||
NNORISE = NTLOOPUSE - NSUNRISE - NSUNSET
|
||||
|
||||
DO 670 JLOOP = 1, NTLOOPUSE
|
||||
LREORDER(JLOOP) = JREORDER(JLOOP)
|
||||
CSUMC( JLOOP) = CSUMA( JLOOP)
|
||||
670 CONTINUE
|
||||
C
|
||||
C *********************************************************************
|
||||
C REORDER GRID-CELLS SO ALL CELLS WHERE SUNSET OCCURS ARE AT END
|
||||
C LREORDER AND CSUMC ARE USED HERE ONLY TO STORE VALUES
|
||||
C OF JREORDER AND CSUMA TEMPORARILY AND ARE USED ELSEWHERE
|
||||
C FOR A DIFFERENT PURPOSE.
|
||||
C *********************************************************************
|
||||
C
|
||||
JLLAST = NTLOOPUSE
|
||||
DO 700 JLOOP = 1, NTLOOPUSE
|
||||
IF (ITWO(JLOOP).EQ.2) THEN
|
||||
JREORDER(JLLAST) = LREORDER(JLOOP)
|
||||
CSUMA( JLLAST) = CSUMC( JLOOP)
|
||||
JLLAST = JLLAST - 1
|
||||
ENDIF
|
||||
700 CONTINUE
|
||||
C
|
||||
C *********************************************************************
|
||||
C NOW REORDER GRID-CELLS SO ALL CELLS WHERE SUNRISE OCCURS ARE
|
||||
C IMMEDIATELY BEFORE CELLS WHERE SUNSET OCCURS
|
||||
C *********************************************************************
|
||||
C
|
||||
DO 705 JLOOP = 1, NTLOOPUSE
|
||||
IF (ITWO(JLOOP).EQ.1) THEN
|
||||
JREORDER(JLLAST) = LREORDER(JLOOP)
|
||||
CSUMA( JLLAST) = CSUMC( JLOOP)
|
||||
JLLAST = JLLAST - 1
|
||||
ENDIF
|
||||
705 CONTINUE
|
||||
C
|
||||
C *********************************************************************
|
||||
C FINALLY, PLACE ALL OTHER GRID CELLS BEFORE SUNRISE AND SUNSET CELLS.
|
||||
C JLLAST WILL EQUAL ZERO AFTER THIS LOOP
|
||||
C *********************************************************************
|
||||
C
|
||||
DO 710 JLOOP = 1, NTLOOPUSE
|
||||
IF (ITWO(JLOOP).EQ.0) THEN
|
||||
JREORDER(JLLAST) = LREORDER(JLOOP)
|
||||
CSUMA( JLLAST) = CSUMC( JLOOP)
|
||||
JLLAST = JLLAST - 1
|
||||
ENDIF
|
||||
710 CONTINUE
|
||||
C
|
||||
C *********************************************************************
|
||||
C REORDER GRID-CELLS IN THREE STEPS:
|
||||
C 1) WHERE NO SUNRISE/SET, FROM LEAST TO MOST STIFF
|
||||
C (SMALLER ERRMX2 (CSUMA) -->LESS STIFF)
|
||||
C CSUMA = ERRMX2
|
||||
C 2) WHERE SUNRISE OCCURS, FROM TIME OF SUNRISE
|
||||
C CSUMA = TIME OF SUNRISE (IN SECONDS PAST MIDNIGHT)
|
||||
C 3) WHERE SUNSET OCCURS, FROM TIME OF SUNSET
|
||||
C CSUMA = TIME OF SUNSET (IN SECONDS PAST MIDNIGHT)
|
||||
C
|
||||
C SORT USING HEAPSORT ROUTINE (NUMERICAL RECIPES), AN N(logb2)N PROCESS
|
||||
C THIS REORDERING SCHEME IS VERY FAST, ALTHOUGH COMPLICATED.
|
||||
C ERRMX2 FROM SMVGEAR: DENOTES STIFFNESS (LARGER VALUE --> MORE STIFF).
|
||||
C *********************************************************************
|
||||
C
|
||||
DO 760 IT = 1, 3
|
||||
IF (IT.EQ.1) THEN
|
||||
IRADD = 0.d0
|
||||
LVAL = IRADD + NNORISE * 0.5d0 + 1
|
||||
IRVAL = IRADD + NNORISE
|
||||
ELSEIF (IT.EQ.2) THEN
|
||||
IRADD = NNORISE
|
||||
LVAL = IRADD + NSUNRISE * 0.5d0 + 1
|
||||
IRVAL = IRADD + NSUNRISE
|
||||
ELSEIF (IT.EQ.3) THEN
|
||||
IRADD = NNORISE + NSUNRISE
|
||||
LVAL = IRADD + NSUNSET * 0.5d0 + 1
|
||||
IRVAL = IRADD + NSUNSET
|
||||
ENDIF
|
||||
C
|
||||
IRADD1 = IRADD + 1
|
||||
C
|
||||
IF (IRVAL.GT.IRADD1) THEN
|
||||
C
|
||||
800 IF (LVAL.GT.IRADD1) THEN
|
||||
LVAL = LVAL - 1
|
||||
VALLOW = CSUMA( LVAL)
|
||||
JREORD = JREORDER(LVAL)
|
||||
ELSE
|
||||
VALLOW = CSUMA( IRVAL)
|
||||
JREORD = JREORDER(IRVAL)
|
||||
CSUMA( IRVAL) = CSUMA( IRADD1)
|
||||
JREORDER(IRVAL) = JREORDER(IRADD1)
|
||||
IRVAL = IRVAL - 1
|
||||
IF (IRVAL.EQ.IRADD1) THEN
|
||||
CSUMA( IRADD1) = VALLOW
|
||||
JREORDER( IRADD1) = JREORD
|
||||
GOTO 760
|
||||
ENDIF
|
||||
ENDIF
|
||||
IPAR = LVAL
|
||||
JPAR = LVAL + LVAL - IRADD
|
||||
C
|
||||
820 IF (JPAR.LE.IRVAL) THEN
|
||||
IF (JPAR.LT.IRVAL) THEN
|
||||
JPAR1 = JPAR + 1
|
||||
IF (CSUMA(JPAR).LT.CSUMA(JPAR1)) JPAR = JPAR1
|
||||
ENDIF
|
||||
IF (VALLOW.LT.CSUMA(JPAR)) THEN
|
||||
CSUMA( IPAR) = CSUMA( JPAR)
|
||||
JREORDER(IPAR) = JREORDER(JPAR)
|
||||
IPAR = JPAR
|
||||
JPAR = JPAR + JPAR - IRADD
|
||||
GOTO 820
|
||||
ENDIF
|
||||
ENDIF
|
||||
C
|
||||
CSUMA( IPAR) = VALLOW
|
||||
JREORDER(IPAR) = JREORD
|
||||
GOTO 800
|
||||
C
|
||||
ENDIF
|
||||
C ENDIF IRVAL.GT.0
|
||||
760 CONTINUE
|
||||
C
|
||||
C *********************************************************************
|
||||
C DETERMINE HOW MANY BLOCKS ARE NEEDED IN EACH REORDER GROUP (SUNRISE,
|
||||
C SUNSET, STIFFNESS) AFTER REORDERING
|
||||
C *********************************************************************
|
||||
C NBLOCKROW = # BLOCKS OF EACH REORDER GROUP (STIFFNESS, SUNRISE, SUNSET)
|
||||
C IUSESIZE = # OF GRID CELLS IN EACH GRID BLOCK
|
||||
C NCELLROW = # OF GRID CELLS IN EACH REORDER GROUP
|
||||
C NNORISE = # OF STIFFNESS (NON-SUNRISE, NON-SUNSET) CELLS
|
||||
C NSUNRISE = # OF SUNRISE CELLS
|
||||
C NSUNSET = # OF SUNSET CELLS
|
||||
C NREBLOCK = COUNTS NUMBER OF NEW BLOCKS
|
||||
C
|
||||
|
||||
NSUMBLOCK = 0
|
||||
NREBLOCK = 0
|
||||
JLOOPLO = 0
|
||||
C
|
||||
!write(6,*) 'norise,sunrise,sunset=',nnorise,nsunrise,nsunset
|
||||
DO 770 IT = 1, 3
|
||||
IF (IT.EQ.1) THEN
|
||||
NCELLROW = NNORISE
|
||||
NBLOCKROW = 1 + NCELLROW / (KULOOP + 0.0001d0)
|
||||
ELSEIF (IT.EQ.2) THEN
|
||||
NCELLROW = NSUNRISE
|
||||
!NBLOCKROW = 1 + NCELLROW * 3./ (KULOOP + 0.0001d0)
|
||||
NBLOCKROW = 1 + NCELLROW / (KULOOP + 0.0001d0)
|
||||
ELSEIF (IT.EQ.3) THEN
|
||||
NCELLROW = NSUNSET
|
||||
!NBLOCKROW = 1 + NCELLROW * 3./ (KULOOP + 0.0001d0)
|
||||
NBLOCKROW = 1 + NCELLROW / (KULOOP + 0.0001d0)
|
||||
ENDIF
|
||||
C
|
||||
NSUMBLOCK = NSUMBLOCK + NBLOCKROW
|
||||
C
|
||||
IF (NSUMBLOCK.GT.MXBLOCK) THEN
|
||||
! write(6,*) 'val of mxblock= ',mxblock
|
||||
! WRITE(6,*)'PHYSPROC: NSUMBLOCK>MXBLOCK. INCREASE MXBLOCK ',
|
||||
! 1 NSUMBLOCK, NNORISE, NSUNRISE, NSUNSET, KULOOP
|
||||
STOP
|
||||
ENDIF
|
||||
C
|
||||
IF (NCELLROW.EQ.0) THEN
|
||||
NBLOCKROW = 0
|
||||
ELSE
|
||||
IAVBLOK = 1 + NCELLROW / (NBLOCKROW + 0.0001d0)
|
||||
IAVGSIZE = MIN(IAVBLOK,KULOOP)
|
||||
IREMAIN = NCELLROW
|
||||
C
|
||||
!write(6,*) 'it,nblockrow,iavesize= ',it,nblockrow,iavgsize
|
||||
DO 765 KBLK = 1, NBLOCKROW
|
||||
NREBLOCK = NREBLOCK + 1
|
||||
IUSESIZE = MIN(IAVGSIZE,MAX(IREMAIN,0))
|
||||
JLOWVAR(NREBLOCK) = JLOOPLO
|
||||
KTLPVAR(NREBLOCK) = IUSESIZE
|
||||
IREMAIN = IREMAIN - IUSESIZE
|
||||
JLOOPLO = JLOOPLO + IUSESIZE
|
||||
765 CONTINUE
|
||||
ENDIF
|
||||
770 CONTINUE
|
||||
C770 CONTINUE IT = 1, 3
|
||||
C
|
||||
ENDIF
|
||||
C ENDIF ISREORD.EQ.1
|
||||
C
|
||||
855 CONTINUE
|
||||
860 CONTINUE
|
||||
C CONTINUE ISREORD = 1, 2
|
||||
C CONTINUE NCS = ILNCS, IHNCS
|
||||
C
|
||||
C *********************************************************************
|
||||
C * EITHER WRITE OUTPUT TO COMPARE.OUT IF ITESTGEAR=2 OR COMPARE *
|
||||
C * ACCURATE RESULTS FROM COMPARE.DAT TO MODEL RESULTS IF ITESTGEAR=1 *
|
||||
C *********************************************************************
|
||||
C AVGERR = ABSOLUTE-VALUE AVERAGE SPECIES ERROR OVER ALL NGCOUNT SPECIES
|
||||
C AVGHI = ABSOLUTE-VALUE AVERAGE SPECIES ERROR OVER ALL NGHI SPECIES
|
||||
C CMODEL = CONCENTRATION FROM MODEL RESULTS
|
||||
C GEARCONC = CONCENTRATION FROM FILE compare.dat
|
||||
C NGCOUNT = # SPECIES WITH CONCENTRATION GREATER THAN CLO1
|
||||
C NGHI = # SPECIES WITH CONCENTRATION GREATER THAN CLO2
|
||||
C NOCC = # OF TIMES ERRORS ARE CALCULATED (ONCE EACH TIME-INTERVAL)
|
||||
C RMSCUR = ROOT-MEAN-SQUARE ERROR OVER ALL NGCOUNT SPECIES
|
||||
C RMSCURH = ROOT-MEAN-SQUARE ERROR OVER ALL NGHI SPECIES
|
||||
C
|
||||
C OTHER PARAMETERS DEFINED IN DEFINE.DAT
|
||||
C
|
||||
IF (ITESTGEAR.GT.0) THEN
|
||||
NCS = 1
|
||||
IF (IRCHEM.EQ.1) WRITE(IOUT,980)
|
||||
ICG = ISCHANG(NCS)
|
||||
CLO1 = 1.0d-05
|
||||
CLO2 = 1.0d+03
|
||||
C
|
||||
DO 970 JNEW = 1, ICG
|
||||
JOLD = INEWOLD(JNEW,NCS)
|
||||
CMODEL(JNEW) = CSPEC(LLOOP,JOLD)
|
||||
970 CONTINUE
|
||||
C
|
||||
IF (ITESTGEAR.EQ.2) THEN
|
||||
WRITE(KCPD,996) TIME,DELT,IRCHEM,(NAMENCS(INEWOLD(I,NCS),NCS),
|
||||
1 CMODEL(I),I=1,ICG)
|
||||
ENDIF
|
||||
C
|
||||
IF (ITESTGEAR.EQ.1) THEN
|
||||
SUMFRACS = 0.d0
|
||||
SUMRMS = 0.d0
|
||||
SUMHI = 0.d0
|
||||
SUMRMSH = 0.d0
|
||||
NGCOUNT = 0
|
||||
NGHI = 0
|
||||
C WRITE(IOUT,982)
|
||||
IF (IRCHEM.EQ.1) WRITE(IOUT,988)
|
||||
C
|
||||
DO 975 JNEW = 1, ICG
|
||||
JOLD = INEWOLD(JNEW,NCS)
|
||||
CMOD = CMODEL(JNEW)
|
||||
CGOOD = GEARCONC(JNEW,IRCHEM,NCS)
|
||||
IF (CGOOD.GT.CLO1.AND.CMOD.GT.CLO1.AND.CGOOD.GT.1.d-5*
|
||||
1 CPREV(JNEW)) THEN
|
||||
FRACDIF = (CMOD - CGOOD) / CGOOD
|
||||
FRACABS = ABS(FRACDIF)
|
||||
SUMFRACS = SUMFRACS + FRACABS
|
||||
SUMRMS = SUMRMS + FRACABS * FRACABS
|
||||
NGCOUNT = NGCOUNT + 1
|
||||
IF (CGOOD.GT.CLO2.AND.CMOD.GT.CLO2) THEN
|
||||
SUMHI = SUMHI + FRACABS
|
||||
SUMRMSH = SUMRMSH + FRACABS * FRACABS
|
||||
NGHI = NGHI + 1
|
||||
IAVG = 2
|
||||
ELSE
|
||||
IAVG = 1
|
||||
ENDIF
|
||||
ELSE
|
||||
FRACDIF = 0.d0
|
||||
IAVG = 0
|
||||
ENDIF
|
||||
CPREV(JNEW) = CGOOD
|
||||
C WRITE(IOUT,984) NAMENCS(JOLD,NCS),CGOOD,CMOD,FRACDIF*100.,IAVG
|
||||
975 CONTINUE
|
||||
C
|
||||
IF (NGCOUNT.GT.0) THEN
|
||||
AVGERR = 100.d0 * SUMFRACS / NGCOUNT
|
||||
RMSCUR = 100.d0 * SQRT(SUMRMS / NGCOUNT)
|
||||
ELSE
|
||||
AVGERR = 0.d0
|
||||
RMSCUR = 0.d0
|
||||
ENDIF
|
||||
C
|
||||
IF (NGHI.GT.0) THEN
|
||||
AVGHI = 100.d0 * SUMHI / NGHI
|
||||
RMSCURH = 100.d0 * SQRT(SUMRMSH / NGHI)
|
||||
ELSE
|
||||
AVGHI = 0.d0
|
||||
RMSCURH = 0.d0
|
||||
ENDIF
|
||||
C
|
||||
SUMAVGE = SUMAVGE + AVGERR
|
||||
SUMAVHI = SUMAVHI + AVGHI
|
||||
SUMRMSE = SUMRMSE + RMSCUR
|
||||
SUMRMHI = SUMRMHI + RMSCURH
|
||||
NOCC = NOCC + 1
|
||||
C
|
||||
FSTEPT = FLOAT(NPDERIV)
|
||||
FITS = FLOAT(NSUBFUN)
|
||||
C
|
||||
TOTSTEP = TOTSTEP + FSTEPT
|
||||
TOTIT = TOTIT + FITS
|
||||
TELAPS = TELAPS + XELAPS
|
||||
WRITE(IOUT,992) IRCHEM,TIME,FSTEPT,FITS,FITS/FSTEPT,
|
||||
1 NGCOUNT,NGHI,AVGERR,AVGHI,RMSCUR,RMSCURH
|
||||
ENDIF
|
||||
ENDIF
|
||||
C
|
||||
C *********************************************************************
|
||||
C * FORMATS *
|
||||
C *********************************************************************
|
||||
|
||||
980 FORMAT(20X,'RESULTS FROM SUBROUTINE CALCRATE.F')
|
||||
C982 FORMAT(4X,'SPECIES',5X,'GEARCONC MODEL % ERROR IFAVG')
|
||||
C984 FORMAT(A14,2(1X,1PE11.4),2X,0PF8.2,'%',3X,I1)
|
||||
988 FORMAT(/8X,'STATISTICS FROM COMPARISON OF SMVGEAR RESULTS TO ',
|
||||
1 'compare.dat'//
|
||||
1 'IRCHEM,ELAPST PDERIV SUBFUN SF/PD #AVG #HI ',
|
||||
1 'AVGERR AVGI RMS RMSHI')
|
||||
992 FORMAT(I3,1X,3(F8.0,1X),F6.2,1X,I3,1X,I3,4(1X,0PF7.2))
|
||||
994 FORMAT('***********************************OVERALL************',
|
||||
1 '***********************')
|
||||
996 FORMAT('CONC (# CM-3 OR M L-1) AT TIME=',1PE10.2,' SECONDS. ',
|
||||
1 'DELT=',E10.2,' . RUN =',I3/3(A13,'=',E11.4,1X))
|
||||
998 FORMAT('END')
|
||||
1000 FORMAT('END 9.9999E+99')
|
||||
1002 FORMAT(/3X,'FINAL STATISTICS FROM SMVGEAR. GRID-BLOCK = ',I4/
|
||||
1 '# CALLS TO SUBROUTINE SUBFUN = ',I8/
|
||||
2 '# CALLS TO SUBROUTINE PDERIV = ',I8/
|
||||
3 '# SUCCESSFUL TIME-STEPS = ',I8/
|
||||
4 '# CORRECTOR ITERATION FAILURES (IFAIL) = ',I8/
|
||||
5 '# CORRECTOR FAILURES AFTER PDERIV CALLED (NFAIL) = ',I8/
|
||||
6 '# ACCUMULATED ERROR TEST FAILURES (LFAIL) = ',I8)
|
||||
C
|
||||
C *********************************************************************
|
||||
C ********************* END OF SUBROUTINE PHYSPROC.F ******************
|
||||
C *********************************************************************
|
||||
C
|
||||
RETURN
|
||||
END SUBROUTINE PHYSPROC
|
||||
Reference in New Issue
Block a user