655 lines
26 KiB
Fortran
655 lines
26 KiB
Fortran
! $Id: ksparse.f,v 1.1 2009/06/09 21:51:54 daven Exp $
|
|
SUBROUTINE KSPARSE
|
|
!
|
|
!******************************************************************************
|
|
! Subroutine KSPARSE sets up the sparse-matrix arrays, and also arrays for
|
|
! day & night chemistry for SMVGEAR II. (M. Jacobson 1997; bdf, bmy, 4/18/03)
|
|
!
|
|
! NOTES:
|
|
! (1 ) Now direct some output to "smv2.log" file. Now call GEOS_CHEM_STOP
|
|
! to deallocate all arrays and stop the run safely. Now also force
|
|
! double-precision with "D" exponents. (bmy, 4/18/03)
|
|
!******************************************************************************
|
|
!
|
|
! References to F90 modules
|
|
USE ERROR_MOD, ONLY : GEOS_CHEM_STOP
|
|
|
|
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 K K SSSSSSS PPPPPPP A RRRRRRR SSSSSSS EEEEEEE
|
|
C K K S P P A A R R S E
|
|
C KK SSSSSSS PPPPPPP A A RRRRRRR SSSSSSS EEEEEEE
|
|
C K K S P AAAAAAA R R S E
|
|
C K K SSSSSSS P A A R R SSSSSSS EEEEEEE
|
|
C
|
|
C *********************************************************************
|
|
C * THIS ROUTINE SETS UP SPARSE-MATRIX AND OTHER ARRAYS. IT ALSO *
|
|
C * SETS ARRAYS FOR GAS-PHASE, AQUEOUS-PHASE, OR ANY OTHER TYPE *
|
|
C * OF CHEMISTRY. FINALLY, IT SETS ARRAYS FOR BOTH DAY AND NIGHT *
|
|
C * CHEMISTRY OF EACH TYPE. *
|
|
C * *
|
|
C * HOW TO CALL SUBROUTINE: *
|
|
C * ---------------------- *
|
|
C * CALL KSPARSE.F FROM JSPARSE.F WITH *
|
|
C * NCS = 1..NCSGAS FOR GAS CHEMISTRY *
|
|
C *********************************************************************
|
|
C
|
|
C *********************************************************************
|
|
C * SETS UP ARRAYS FOR DECOMPOSITION / BACK-SUBSTITUTION OF SPARSE *
|
|
C * MATRICES BY REMOVING ALL CALCULATIONS INVOLVING A ZERO. *
|
|
C *********************************************************************
|
|
C
|
|
C *********************************************************************
|
|
C *********************************************************************
|
|
C ** SET ARRAYS TO TAKE ADVANTAGE OF SPARSE MATRICES **
|
|
C *********************************************************************
|
|
C *********************************************************************
|
|
C
|
|
C IFSUN = 1 THEN DAY-CHEMISTRY; = 2 THEN NIGHT CHEMISTRY
|
|
C NCSP = NCS FOR DAYTIME GAS CHEM
|
|
C NCSP = NCS +ICS FOR NIGHTTIME GAS CHEM
|
|
C
|
|
C KOUNT0A = # INITIAL MATRIX SPOTS FILLED W/O SPARSE-MATRIX REDUCTIONS
|
|
C KOUNT0 = # INITIAL MATRIX SPOTS FILLED WITH SPARSE-MATRIX REDUCTIONS
|
|
C KNTARRAY = # FINAL MATRIX SPOTS FILLED W/O SPARSE-MATRIX REDUCTIONS
|
|
C IARRAY2 = # FINAL MATRIX SPOTS FILLED WITH SPARSE-MATRIX REDUCTIONS
|
|
C ICNTA = # OPERATIONS IN DECOMP LOOP 1 W/O SPARSE-MATRIX REDUCTIONS
|
|
C ICNTB = # OPERATIONS IN DECOMP LOOP 1 WITH SPARSE-MATRIX REDUCTIONS
|
|
C JCNTA = # OPERATIONS IN DECOMP LOOP 2 W/O SPARSE-MATRIX REDUCTIONS
|
|
C JCNTB = # OPERATIONS IN DECOMP LOOP 2 WITH SPARSE-MATRIX REDUCTIONS
|
|
C KCNTA = # OPERATIONS IN BACK-SUP LOOP 1 W/O SPARSE-MATRIX REDUCTIONS
|
|
C KCNTB = # OPERATIONS IN BACK-SUB LOOP 1 WITH SPARSE-MATRIX REDUCTIONS
|
|
C MCNTA = # OPERATIONS IN BACK-SUP LOOP 2 W/O SPARSE-MATRIX REDUCTIONS
|
|
C MCNTB = # OPERATIONS IN BACK-SUB LOOP 2 WITH SPARSE-MATRIX REDUCTIONS
|
|
C
|
|
C LZERO = 1 IF AN ARRAY SPOT IS FILLED WITH A NON-ZERO VALUE. LZERO
|
|
C IS UPDATED AS WE SIMULATE THE ORDER OF CALCULATIONS DURING
|
|
C A PRACTICE L-U DECOMPOSITION
|
|
C
|
|
|
|
INTEGER KOUNT0A,KOUNT0,ICNTA,ICNTB
|
|
INTEGER KCNTA,KCNTB,MCNTA,MCNTV,IARRAY2,J,K,J1,I,I1,I2,KNTARRAY
|
|
INTEGER IZIL,NREMAIN,NFIVE,NFOUR,NTHREE,NTWO,NONE,IC,KA,KB,KC,KD
|
|
! Bug fix (gcc)
|
|
!INTEGER IA,KZIL,MC,JCNTA,JCNTB,MCNTA,MCNTB,KE,MZIL
|
|
INTEGER IA,KZIL,MC,JCNTA,JCNTB,MCNTB,KE,MZIL
|
|
|
|
INTEGER, SAVE :: MCNT,KCNT,ICNT,JCNT,MZTOT,IJTOT,KZTOT,IDECOMP
|
|
INTEGER, SAVE :: MCCOUNT,ICCOUNT,JCCOUNT,KCCOUNT,KBSUB,MBSUB
|
|
|
|
IF (IFNEVER.EQ.0) THEN
|
|
IFNEVER = 1
|
|
ICNT = 0
|
|
JCNT = 0
|
|
KCNT = 0
|
|
MCNT = 0
|
|
ICCOUNT = 0
|
|
JCCOUNT = 0
|
|
KCCOUNT = 0
|
|
MCCOUNT = 0
|
|
IDECOMP = 0
|
|
KBSUB = 0
|
|
MBSUB = 0
|
|
IJTOT = 0
|
|
KZTOT = 0
|
|
MZTOT = 0
|
|
ENDIF
|
|
C
|
|
KOUNT0A = 0
|
|
KOUNT0 = 0
|
|
ICNTA = 0
|
|
ICNTB = 0
|
|
JCNTA = 0
|
|
JCNTB = 0
|
|
KCNTA = 0
|
|
KCNTB = 0
|
|
MCNTA = 0
|
|
MCNTB = 0
|
|
IARRAY2 = 0
|
|
C
|
|
DO 522 J = 1, ISCHANG(NCS)
|
|
DO 520 K = 1, ISCHANG(NCS)
|
|
KOUNT0A = KOUNT0A + 1
|
|
IF (LZERO(K,J).EQ.1) KOUNT0 = KOUNT0 + 1
|
|
JARRAYPT(K,J) = 0
|
|
520 CONTINUE
|
|
522 CONTINUE
|
|
C
|
|
C *********************************************************************
|
|
C ** ARRAYS FOR DECOMPOSITION (LUDCMP) **
|
|
C *********************************************************************
|
|
C IZILCH = # OF CALCULATIONS WITH NON-ZERO VALUES DURING MATRIX DECOMP
|
|
C IZERO = EACH OCCURRENCE OF EACH IZILCH CALCULATION
|
|
C
|
|
DO 562 J = 1, ISCHANG(NCS)
|
|
JZILCH(J) = 0
|
|
J1 = J - 1
|
|
C
|
|
C ------------------- FIRST LOOP OF DECOMPOSTION ----------------------
|
|
C
|
|
DO 542 I = 2, ISCHANG(NCS)
|
|
IZILCH(J,I) = 0
|
|
I1 = J1
|
|
IF (I.LE.J1) I1 = I - 1
|
|
DO 540 K = 1, I1
|
|
ICNTA = ICNTA + 1
|
|
IF (LZERO(I,K).EQ.1.AND.LZERO(K,J).EQ.1) THEN
|
|
IZILCH(J,I) = IZILCH(J,I) + 1
|
|
ICNT = ICNT + 1
|
|
ICNTB = ICNTB + 1
|
|
IZEROK(ICNT) = K
|
|
LZERO(I,J) = 1
|
|
ENDIF
|
|
540 CONTINUE
|
|
542 CONTINUE
|
|
C
|
|
C ------------------- SECOND LOOP OF DECOMPOSTION ---------------------
|
|
C
|
|
C JZILCH = # OF CALCULATIONS WITH NON-ZERO VALUES TO FILL LOWER
|
|
C PART OF DECOMPOSED MATRIX
|
|
C
|
|
DO 560 I = J+1, ISCHANG(NCS)
|
|
JCNTA = JCNTA + 1
|
|
IF (LZERO(I,J).EQ.1) THEN
|
|
JZILCH(J) = JZILCH(J) + 1
|
|
JCNT = JCNT + 1
|
|
JCNTB = JCNTB + 1
|
|
JZERO(JCNT) = I
|
|
ENDIF
|
|
560 CONTINUE
|
|
562 CONTINUE
|
|
C
|
|
C *********************************************************************
|
|
C ** ARRAYS FOR BACK-SUBSTITUTION (LUBKSB) **
|
|
C *********************************************************************
|
|
C JZILCH AND KZILCH HAVE SAME NUMBER OF TOTAL ELEMENTS
|
|
C BOTH CONTAIN NON-ZEROS IN LOWER TRIANGLULAR MATRIX
|
|
C
|
|
C
|
|
C ------------------ FIRST LOOP OF BACK-SUBSTITUTION ------------------
|
|
C
|
|
DO 572 I = 2, ISCHANG(NCS)
|
|
KZILCH(I) = 0
|
|
I1 = I - 1
|
|
DO 570 J = 1, I1
|
|
KCNTA = KCNTA + 1
|
|
IF (LZERO(I,J).EQ.1) THEN
|
|
KZILCH(I) = KZILCH(I) + 1
|
|
KCNTB = KCNTB + 1
|
|
KCNT = KCNT + 1
|
|
IARRAY2 = IARRAY2 + 1
|
|
KZERO(KCNT) = J
|
|
JARRAYPT(I,J) = IARRAY2
|
|
ENDIF
|
|
570 CONTINUE
|
|
572 CONTINUE
|
|
C
|
|
C ----------------- SECOND LOOP OF BACK-SUBSTITUTION ------------------
|
|
C
|
|
C MZILCH CONTAINS NON-ZEROS FOR UPPER TRIANGULAR MATRIX, WHERE BACK-
|
|
C SUBSTITUTION OCCURS.
|
|
C
|
|
DO 577 I = ISCHANG(NCS), 1, -1
|
|
MZILCH(I) = 0
|
|
I2 = I + 1
|
|
DO 575 J = I+1, ISCHANG(NCS)
|
|
MCNTA = MCNTA + 1
|
|
IF (LZERO(I,J).EQ.1) THEN
|
|
MZILCH(I) = MZILCH(I) + 1
|
|
MCNTB = MCNTB + 1
|
|
MCNT = MCNT + 1
|
|
IARRAY2 = IARRAY2 + 1
|
|
MZERO(MCNT) = J
|
|
JARRAYPT(I,J) = IARRAY2
|
|
ENDIF
|
|
575 CONTINUE
|
|
577 CONTINUE
|
|
C
|
|
C *********************************************************************
|
|
C * FILL JARRAYPT WITH REMAINING ARRAY POINTS (ALONG DIAGONAL) *
|
|
C *********************************************************************
|
|
C
|
|
DO 580 I = 1, ISCHANG(NCS)
|
|
IARRAY2 = IARRAY2 + 1
|
|
JARRAYPT(I,I) = IARRAY2
|
|
580 CONTINUE
|
|
C
|
|
IARRAY(NCSP) = IARRAY2
|
|
KNTARRAY = KCNTA + MCNTA + ISCHANG(NCS)
|
|
C
|
|
C *********************************************************************
|
|
C *** CHANGE IZERO AND JZERO ARRAYS SO THEIR VALUES POINT TO NEW ***
|
|
C *** ARRAY POSITIONS DEFINED IN JARRAYPT ***
|
|
C *********************************************************************
|
|
C
|
|
C JARRAYPT = IDENTIFIES THE ONE-DIMENSIONAL ARRAY POINT FOR EACH TWO-
|
|
C DIMENSIONAL POINT I,J
|
|
C IARRAY = THE LENGTH OF THE ONE-DIMENSIONAL ARRAY HOLDING ALL
|
|
C SPARSE MATRIX POINTS = SPARSE-MATRIX DIMENSION
|
|
C IZER2 = USED TO IDENTIFY THE 1-D ARRAY POINT FOR EACH K,J VALUE
|
|
C FOUND IN THE FIRST MAJOR LOOP OF MATRIX DECOMPOSITION
|
|
C IZERO = USED TO FIND THE 1-D ARRAY POINT FOR EACH I,K VALUE
|
|
C FOUND IN THE SAME LOOP.
|
|
C
|
|
DO 595 J = 1, ISCHANG(NCS)
|
|
C
|
|
C ------------------- FIRST LOOP OF DECOMPOSTION ----------------------
|
|
C
|
|
IJTLO(J,NCSP) = IJTOT + 1
|
|
DO 605 I = 2, ISCHANG(NCS)
|
|
IZIL = IZILCH(J,I)
|
|
IF (IZIL.GT.0) THEN
|
|
IJTOT = IJTOT + 1
|
|
NREMAIN = IZIL
|
|
NFIVE = (NREMAIN + 0.0001d0) / 5
|
|
NREMAIN = NREMAIN - NFIVE * 5
|
|
NFOUR = (NREMAIN + 0.0001d0) / 4
|
|
NREMAIN = NREMAIN - NFOUR * 4
|
|
NTHREE = (NREMAIN + 0.0001d0) / 3
|
|
NREMAIN = NREMAIN - NTHREE * 3
|
|
NTWO = (NREMAIN + 0.0001d0) / 2
|
|
NREMAIN = NREMAIN - NTWO * 2
|
|
NONE = (NREMAIN + 0.0001d0)
|
|
NREMAIN = NREMAIN - NONE
|
|
C
|
|
|
|
IJVAL(IJTOT) = JARRAYPT(I,J)
|
|
IDL5( IJTOT) = IDECOMP + 1
|
|
IDH5( IJTOT) = IDECOMP + NFIVE
|
|
IDL4( IJTOT) = IDH5(IJTOT) + 1
|
|
IDH4( IJTOT) = IDH5(IJTOT) + NFOUR
|
|
IDL3( IJTOT) = IDH4(IJTOT) + 1
|
|
IDH3( IJTOT) = IDH4(IJTOT) + NTHREE
|
|
IDL2( IJTOT) = IDH3(IJTOT) + 1
|
|
IDH2( IJTOT) = IDH3(IJTOT) + NTWO
|
|
IDL1( IJTOT) = IDH2(IJTOT) + 1
|
|
IDH1( IJTOT) = IDH2(IJTOT) + NONE
|
|
IDECOMP = IDH1(IJTOT)
|
|
C
|
|
DO 601 IC = IDL5(IJTOT), IDH5(IJTOT)
|
|
KA = IZEROK(ICCOUNT+1)
|
|
KB = IZEROK(ICCOUNT+2)
|
|
KC = IZEROK(ICCOUNT+3)
|
|
KD = IZEROK(ICCOUNT+4)
|
|
KE = IZEROK(ICCOUNT+5)
|
|
ICCOUNT = ICCOUNT + 5
|
|
IKDECA(IC) = JARRAYPT(I,KA)
|
|
IKDECB(IC) = JARRAYPT(I,KB)
|
|
IKDECC(IC) = JARRAYPT(I,KC)
|
|
IKDECD(IC) = JARRAYPT(I,KD)
|
|
IKDECE(IC) = JARRAYPT(I,KE)
|
|
KJDECA(IC) = JARRAYPT(KA,J)
|
|
KJDECB(IC) = JARRAYPT(KB,J)
|
|
KJDECC(IC) = JARRAYPT(KC,J)
|
|
KJDECD(IC) = JARRAYPT(KD,J)
|
|
KJDECE(IC) = JARRAYPT(KE,J)
|
|
601 CONTINUE
|
|
C
|
|
DO 602 IC = IDH5(IJTOT) + 1, IDH4(IJTOT)
|
|
KA = IZEROK(ICCOUNT+1)
|
|
KB = IZEROK(ICCOUNT+2)
|
|
KC = IZEROK(ICCOUNT+3)
|
|
KD = IZEROK(ICCOUNT+4)
|
|
ICCOUNT = ICCOUNT + 4
|
|
IKDECA(IC) = JARRAYPT(I,KA)
|
|
IKDECB(IC) = JARRAYPT(I,KB)
|
|
IKDECC(IC) = JARRAYPT(I,KC)
|
|
IKDECD(IC) = JARRAYPT(I,KD)
|
|
KJDECA(IC) = JARRAYPT(KA,J)
|
|
KJDECB(IC) = JARRAYPT(KB,J)
|
|
KJDECC(IC) = JARRAYPT(KC,J)
|
|
KJDECD(IC) = JARRAYPT(KD,J)
|
|
602 CONTINUE
|
|
C
|
|
DO 603 IC = IDH4(IJTOT) + 1, IDH3(IJTOT)
|
|
KA = IZEROK(ICCOUNT+1)
|
|
KB = IZEROK(ICCOUNT+2)
|
|
KC = IZEROK(ICCOUNT+3)
|
|
ICCOUNT = ICCOUNT + 3
|
|
IKDECA(IC) = JARRAYPT(I,KA)
|
|
IKDECB(IC) = JARRAYPT(I,KB)
|
|
IKDECC(IC) = JARRAYPT(I,KC)
|
|
KJDECA(IC) = JARRAYPT(KA,J)
|
|
KJDECB(IC) = JARRAYPT(KB,J)
|
|
KJDECC(IC) = JARRAYPT(KC,J)
|
|
603 CONTINUE
|
|
C
|
|
DO 604 IC = IDH3(IJTOT) + 1, IDH2(IJTOT)
|
|
KA = IZEROK(ICCOUNT+1)
|
|
KB = IZEROK(ICCOUNT+2)
|
|
ICCOUNT = ICCOUNT + 2
|
|
IKDECA(IC) = JARRAYPT(I,KA)
|
|
IKDECB(IC) = JARRAYPT(I,KB)
|
|
KJDECA(IC) = JARRAYPT(KA,J)
|
|
KJDECB(IC) = JARRAYPT(KB,J)
|
|
604 CONTINUE
|
|
C
|
|
DO 606 IC = IDH2(IJTOT) + 1, IDH1(IJTOT)
|
|
KA = IZEROK(ICCOUNT+1)
|
|
ICCOUNT = ICCOUNT + 1
|
|
IKDECA(IC) = JARRAYPT(I,KA)
|
|
KJDECA(IC) = JARRAYPT(KA,J)
|
|
606 CONTINUE
|
|
|
|
ENDIF
|
|
605 CONTINUE
|
|
C
|
|
|
|
IJTHI(J,NCSP) = IJTOT
|
|
C
|
|
C ------------------ DIAGONAL TERM OF DECOMPOSTION --------------------
|
|
C
|
|
JARRDIAG(J,NCSP) = JARRAYPT(J,J)
|
|
C
|
|
C ------------------- SECOND LOOP OF DECOMPOSTION ---------------------
|
|
C
|
|
JLOZ1(J,NCSP) = JCCOUNT + 1
|
|
DO 635 I = 1, JZILCH(J)
|
|
JCCOUNT = JCCOUNT + 1
|
|
IA = JZERO(JCCOUNT)
|
|
JZEROA(JCCOUNT) = JARRAYPT(IA,J)
|
|
635 CONTINUE
|
|
JHIZ1(J,NCSP) = JCCOUNT
|
|
C
|
|
595 CONTINUE
|
|
|
|
C
|
|
C *********************************************************************
|
|
C ** CREATE MORE BACK-SUBSTITUTION ARRAYS TO INCREASE EFFICIENCY **
|
|
C *********************************************************************
|
|
C
|
|
C ------------------ FIRST LOOP OF BACK-SUBSTITUTION ------------------
|
|
C
|
|
KZTLO(NCSP) = KZTOT + 1
|
|
DO 620 I = 2, ISCHANG(NCS)
|
|
KZIL = KZILCH(I)
|
|
IF (KZIL.GT.0) THEN
|
|
KZTOT = KZTOT + 1
|
|
NREMAIN = KZIL
|
|
NFIVE = (NREMAIN + 0.0001d0) / 5
|
|
NREMAIN = NREMAIN - NFIVE * 5
|
|
NFOUR = (NREMAIN + 0.0001d0) / 4
|
|
NREMAIN = NREMAIN - NFOUR * 4
|
|
NTHREE = (NREMAIN + 0.0001d0) / 3
|
|
NREMAIN = NREMAIN - NTHREE * 3
|
|
NTWO = (NREMAIN + 0.0001d0) / 2
|
|
NREMAIN = NREMAIN - NTWO * 2
|
|
NONE = (NREMAIN + 0.0001d0)
|
|
NREMAIN = NREMAIN - NONE
|
|
C
|
|
|
|
IKZTOT(KZTOT) = I
|
|
KBL5( KZTOT) = KBSUB + 1
|
|
KBH5( KZTOT) = KBSUB + NFIVE
|
|
KBL4( KZTOT) = KBH5(KZTOT) + 1
|
|
KBH4( KZTOT) = KBH5(KZTOT) + NFOUR
|
|
KBL3( KZTOT) = KBH4(KZTOT) + 1
|
|
KBH3( KZTOT) = KBH4(KZTOT) + NTHREE
|
|
KBL2( KZTOT) = KBH3(KZTOT) + 1
|
|
KBH2( KZTOT) = KBH3(KZTOT) + NTWO
|
|
KBL1( KZTOT) = KBH2(KZTOT) + 1
|
|
KBH1( KZTOT) = KBH2(KZTOT) + NONE
|
|
KBSUB = KBH1(KZTOT)
|
|
C
|
|
DO 611 KC = KBL5(KZTOT), KBH5(KZTOT)
|
|
KZEROA(KC) = KZERO(KCCOUNT+1)
|
|
KZEROB(KC) = KZERO(KCCOUNT+2)
|
|
KZEROC(KC) = KZERO(KCCOUNT+3)
|
|
KZEROD(KC) = KZERO(KCCOUNT+4)
|
|
KZEROE(KC) = KZERO(KCCOUNT+5)
|
|
KCCOUNT = KCCOUNT + 5
|
|
611 CONTINUE
|
|
C
|
|
DO 612 KC = KBL4(KZTOT), KBH4(KZTOT)
|
|
KZEROA(KC) = KZERO(KCCOUNT+1)
|
|
KZEROB(KC) = KZERO(KCCOUNT+2)
|
|
KZEROC(KC) = KZERO(KCCOUNT+3)
|
|
KZEROD(KC) = KZERO(KCCOUNT+4)
|
|
KCCOUNT = KCCOUNT + 4
|
|
612 CONTINUE
|
|
C
|
|
DO 613 KC = KBL3(KZTOT), KBH3(KZTOT)
|
|
KZEROA(KC) = KZERO(KCCOUNT+1)
|
|
KZEROB(KC) = KZERO(KCCOUNT+2)
|
|
KZEROC(KC) = KZERO(KCCOUNT+3)
|
|
KCCOUNT = KCCOUNT + 3
|
|
613 CONTINUE
|
|
C
|
|
|
|
DO 614 KC = KBL2(KZTOT), KBH2(KZTOT)
|
|
KZEROA(KC) = KZERO(KCCOUNT+1)
|
|
KZEROB(KC) = KZERO(KCCOUNT+2)
|
|
KCCOUNT = KCCOUNT + 2
|
|
614 CONTINUE
|
|
C
|
|
DO 615 KC = KBL1(KZTOT), KBH1(KZTOT)
|
|
KZEROA(KC) = KZERO(KCCOUNT+1)
|
|
KCCOUNT = KCCOUNT + 1
|
|
615 CONTINUE
|
|
ENDIF
|
|
620 CONTINUE
|
|
KZTHI(NCSP) = KZTOT
|
|
C
|
|
C ----------------- SECOND LOOP OF BACK-SUBSTITUTION ------------------
|
|
C
|
|
|
|
DO 640 I = ISCHANG(NCS), 1, -1
|
|
MZIL = MZILCH(I)
|
|
IF (MZIL.GT.0) THEN
|
|
MZTOT = MZTOT + 1
|
|
NREMAIN = MZIL
|
|
NFIVE = (NREMAIN + 0.0001d0) / 5
|
|
NREMAIN = NREMAIN - NFIVE * 5
|
|
NFOUR = (NREMAIN + 0.0001d0) / 4
|
|
NREMAIN = NREMAIN - NFOUR * 4
|
|
NTHREE = (NREMAIN + 0.0001d0) / 3
|
|
NREMAIN = NREMAIN - NTHREE * 3
|
|
NTWO = (NREMAIN + 0.0001d0) / 2
|
|
NREMAIN = NREMAIN - NTWO * 2
|
|
NONE = (NREMAIN + 0.0001d0)
|
|
NREMAIN = NREMAIN - NONE
|
|
C
|
|
IMZTOT(I,NCSP) = MZTOT
|
|
MBL5( MZTOT) = MBSUB + 1
|
|
MBH5( MZTOT) = MBSUB + NFIVE
|
|
MBL4( MZTOT) = MBH5(MZTOT) + 1
|
|
MBH4( MZTOT) = MBH5(MZTOT) + NFOUR
|
|
MBL3( MZTOT) = MBH4(MZTOT) + 1
|
|
MBH3( MZTOT) = MBH4(MZTOT) + NTHREE
|
|
MBL2( MZTOT) = MBH3(MZTOT) + 1
|
|
MBH2( MZTOT) = MBH3(MZTOT) + NTWO
|
|
MBL1( MZTOT) = MBH2(MZTOT) + 1
|
|
MBH1( MZTOT) = MBH2(MZTOT) + NONE
|
|
MBSUB = MBH1(MZTOT)
|
|
C
|
|
DO 631 MC = MBL5(MZTOT), MBH5(MZTOT)
|
|
MZEROA(MC) = MZERO(MCCOUNT+1)
|
|
MZEROB(MC) = MZERO(MCCOUNT+2)
|
|
MZEROC(MC) = MZERO(MCCOUNT+3)
|
|
MZEROD(MC) = MZERO(MCCOUNT+4)
|
|
MZEROE(MC) = MZERO(MCCOUNT+5)
|
|
MCCOUNT = MCCOUNT + 5
|
|
631 CONTINUE
|
|
C
|
|
DO 632 MC = MBL4(MZTOT), MBH4(MZTOT)
|
|
MZEROA(MC) = MZERO(MCCOUNT+1)
|
|
MZEROB(MC) = MZERO(MCCOUNT+2)
|
|
MZEROC(MC) = MZERO(MCCOUNT+3)
|
|
MZEROD(MC) = MZERO(MCCOUNT+4)
|
|
MCCOUNT = MCCOUNT + 4
|
|
632 CONTINUE
|
|
C
|
|
DO 633 MC = MBL3(MZTOT), MBH3(MZTOT)
|
|
MZEROA(MC) = MZERO(MCCOUNT+1)
|
|
MZEROB(MC) = MZERO(MCCOUNT+2)
|
|
MZEROC(MC) = MZERO(MCCOUNT+3)
|
|
MCCOUNT = MCCOUNT + 3
|
|
633 CONTINUE
|
|
C
|
|
DO 634 MC = MBL2(MZTOT), MBH2(MZTOT)
|
|
MZEROA(MC) = MZERO(MCCOUNT+1)
|
|
MZEROB(MC) = MZERO(MCCOUNT+2)
|
|
MCCOUNT = MCCOUNT + 2
|
|
634 CONTINUE
|
|
C
|
|
DO 636 MC = MBL1(MZTOT), MBH1(MZTOT)
|
|
MZEROA(MC) = MZERO(MCCOUNT+1)
|
|
MCCOUNT = MCCOUNT + 1
|
|
636 CONTINUE
|
|
ENDIF
|
|
640 CONTINUE
|
|
C
|
|
C *********************************************************************
|
|
C ** CHECK DIMENSIONS AND PRINT OUT ARRAY SAVINGS **
|
|
C *********************************************************************
|
|
C
|
|
IF (ICNT .GT. MXCOUNT2 .OR. JCNT .GT. MXCOUNT3 .OR.
|
|
1 KCNT .GT. MXCOUNT3 .OR. MCNT .GT. MXCOUNT3 .OR.
|
|
2 ICCOUNT .GT. MXCOUNT2 .OR. JCCOUNT .GT. MXCOUNT3 .OR.
|
|
3 KCCOUNT .GT. MXCOUNT3 .OR. MCCOUNT .GT. MXCOUNT3 .OR.
|
|
4 IJTOT .GT. MXCOUNT3 .OR. IDECOMP .GT. MXCOUNT3 .OR.
|
|
5 KZTOT .GT. MXCOUNT4 .OR. KBSUB .GT. MXCOUNT4 .OR.
|
|
6 MZTOT .GT. MXCOUNT4 .OR. MBSUB .GT. MXCOUNT4 .OR.
|
|
7 IARRAY2 .GT. MXARRAY) THEN
|
|
C
|
|
WRITE(6,705)
|
|
1 MXCOUNT2, ICNT, MXCOUNT3, JCNT,
|
|
2 MXCOUNT3, KCNT, MXCOUNT3, MCNT,
|
|
3 MXCOUNT2, ICCOUNT, MXCOUNT3, JCCOUNT,
|
|
4 MXCOUNT3, KCCOUNT, MXCOUNT3, MCCOUNT,
|
|
5 MXCOUNT3, IJTOT, MXCOUNT3, IDECOMP,
|
|
6 MXCOUNT4, KZTOT, MXCOUNT4, KBSUB,
|
|
7 MXCOUNT4, MZTOT, MXCOUNT4, MBSUB,
|
|
8 MXARRAY, IARRAY2
|
|
CALL GEOS_CHEM_STOP
|
|
ENDIF
|
|
C
|
|
705 FORMAT('KSPARSE: ONE OF THE DIMENSIONS BELOW IS TOO SMALL:',/,
|
|
1 'DIMENSION: MXCOUNT2 = ',I5,' VARIABLE: ICNT = ',I5,/,
|
|
2 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: JCNT = ',I5,/,
|
|
3 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: KCNT = ',I5,/,
|
|
4 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: MCNT = ',I5,/,
|
|
5 'DIMENSION: MXCOUNT2 = ',I5,' VARIABLE: ICCOUNT = ',I5,/,
|
|
6 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: JCCOUNT = ',I5,/,
|
|
7 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: KCCOUNT = ',I5,/,
|
|
8 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: MCCOUNT = ',I5,/,
|
|
9 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: IJTOT = ',I5,/,
|
|
1 'DIMENSION: MXCOUNT3 = ',I5,' VARIABLE: IDECOMP = ',I5,/,
|
|
2 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: KZTOT = ',I5,/,
|
|
3 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: KBSUB = ',I5,/,
|
|
4 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: MZTOT = ',I5,/,
|
|
5 'DIMENSION: MXCOUNT4 = ',I5,' VARIABLE: MBSUB = ',I5,/,
|
|
6 'DIMENSION: MXARRAY = ',I5,' VARIABLE: IARRAY2 = ',I5)
|
|
C
|
|
WRITE(IO93,655)NCSP,KOUNT0A,KOUNT0,KNTARRAY,IARRAY2,ICNTA,ICNTB,
|
|
1 JCNTA,JCNTB,KCNTA,KCNTB,MCNTA,MCNTB
|
|
C
|
|
655 FORMAT(/'PARAM POSS MATRIX POINTS -- NONZEROS -- NCSP=',I4/
|
|
1 'INITMAT ',4X,I8,9X,I8/
|
|
2 'FINMAT ',4X,I8,9X,I8/
|
|
3 'DECOMP1 ',4X,I8,9X,I8/
|
|
4 'DECOMP2 ',4X,I8,9X,I8/
|
|
5 'BACKSB1 ',4X,I8,9X,I8/
|
|
6 'BACKSB2 ',4X,I8,9X,I8/)
|
|
C
|
|
C *********************************************************************
|
|
C * SET COEFFICIENTS OF THE INTEGRATION METHOD *
|
|
C *********************************************************************
|
|
C
|
|
C PARAMETERS USED IN SMVGEAR
|
|
C --------------------------
|
|
C PERTST = COEFFICIENTS USED TO SELECT THE STEP-SIZE AND ORDER. THUS,
|
|
C ONLY ABOUT ONE-PERCENT ACCURACY NEEDED. SEE GEAR(1971)
|
|
C OR HINDMARSH '73 UCID-30059.
|
|
C ASET = PARAMETERS FOR DETERMINING THE ORDER OF THE INTEGRATION METHOD
|
|
C AND FOR CALCULATION THE MATRIX P.
|
|
C MSTEP = MAXIMUM NUMBER OF CORRECTOR ITERATIONS ALLOWED
|
|
C HMIN = MINIMUM TIME-STEP ALLOWED (SEC)
|
|
C MAXORD = MAXIMUM ORDER OF THE METHOD USED
|
|
C MBETWEEN = MAXIMUM NUMBER OF STEPS BETWEEN CALLS TO PDERIV
|
|
C NQQ = ORDER OF THE INTEGRATION METHOD
|
|
C
|
|
IF (IFDID.EQ.0) THEN
|
|
IFDID = 1
|
|
C
|
|
! Now force double-precision with "D" exponents (bmy, 4/18/03)
|
|
DATA PERTST /
|
|
1 2.0d0, 4.5d0, 7.333d0, 10.42d0, 13.7d0, 17.15d0, 1.0d0,
|
|
3 3.0d0, 6.0d0, 9.167d0, 12.5d0, 15.98d0, 1.0d0, 1.0d0,
|
|
5 1.0d0, 1.0d0, 0.5d0, 0.1667d0, 0.04133d0, 0.008267d0, 1.0d0/
|
|
|
|
C
|
|
C ADAMS-MOULTON COEFFICIENTS
|
|
C
|
|
C 2 2.0, 12.0, 24.0, 37.89, 53.33, 70.08, 87.97,
|
|
C 4 12.0, 24.0, 37.89, 53.33, 70.08, 87.97, 1.0,
|
|
C 6 1.0, 1.0, 2.0, 1.0, 0.3157, 0.07407, 0.0139 /
|
|
C
|
|
MSTEP = 3
|
|
HMIN = 1.0d-15
|
|
MAXORD = 5
|
|
MBETWEEN = 50
|
|
C
|
|
DO 800 NQQ = 1, 7
|
|
ENQQ1(NQQ) = 0.5d0 / FLOAT(NQQ )
|
|
ENQQ2(NQQ) = 0.5d0 / FLOAT(NQQ + 1)
|
|
ENQQ3(NQQ) = 0.5d0 / FLOAT(NQQ + 2)
|
|
CONPST(NQQ) = 1.0d0 / (PERTST(NQQ,1) * ENQQ3(NQQ))
|
|
CONP15(NQQ) = 1.5d0 * CONPST(NQQ)
|
|
PERTS2(NQQ,1) = PERTST(NQQ,1) * PERTST(NQQ,1)
|
|
PERTS2(NQQ,2) = PERTST(NQQ,2) * PERTST(NQQ,2)
|
|
PERTS2(NQQ,3) = PERTST(NQQ,3) * PERTST(NQQ,3)
|
|
800 CONTINUE
|
|
C
|
|
DO 830 I2 = 1, 6
|
|
ASET(I2,2) = 1.0d0
|
|
ASET(I2,8) = 0.d0
|
|
830 CONTINUE
|
|
C
|
|
ASET(1,1) = 1.0d0
|
|
C
|
|
ASET(2,1) = 2.0d0 / 3.0d0
|
|
ASET(2,3) = 1.0d0 / 3.0d0
|
|
C
|
|
ASET(3,1) = 6.0d0 / 11.0d0
|
|
ASET(3,3) = 6.0d0 / 11.0d0
|
|
ASET(3,4) = 1.0d0 / 11.0d0
|
|
C
|
|
ASET(4,1) = 12.0d0 / 25.0d0
|
|
ASET(4,3) = .70d0
|
|
ASET(4,4) = .20d0
|
|
ASET(4,5) = .020d0
|
|
C
|
|
ASET(5,1) = 60.0d0 / 137.0d0
|
|
ASET(5,3) = 225.0d0 / 274.0d0
|
|
ASET(5,4) = 85.0d0 / 274.0d0
|
|
ASET(5,5) = 15.0d0 / 274.0d0
|
|
ASET(5,6) = 1.0d0 / 274.0d0
|
|
C
|
|
ASET(6,1) = 180.0d0 / 441.0d0
|
|
ASET(6,3) = 406.0d0 / 441.0d0
|
|
ASET(6,4) = 735.0d0 / 1764.0d0
|
|
ASET(6,5) = 175.0d0 / 1764.0d0
|
|
ASET(6,6) = 21.0d0 / 1764.0d0
|
|
ASET(6,7) = 1.0d0 / 1764.0d0
|
|
C
|
|
ENDIF
|
|
C ENDIF IFDID.EQ.0
|
|
C
|
|
C *********************************************************************
|
|
C ********************** END OF SUBROUTINE KSPARSE ********************
|
|
C *********************************************************************
|
|
C
|
|
RETURN
|
|
END SUBROUTINE KSPARSE
|