Add files via upload
This commit is contained in:
Xuesong (Steve)
314
code/backsub.f
Normal file
314
code/backsub.f
Normal file
@ -0,0 +1,314 @@
|
||||
! $Id: backsub.f,v 1.1 2009/06/09 21:51:53 daven Exp $
|
||||
SUBROUTINE BACKSUB
|
||||
!
|
||||
!******************************************************************************
|
||||
! Subroutine BACKSUB does the back-substitution on the decomposed matrix.
|
||||
! (M. Jacobson 1997; bdf, bmy, 4/1/03, 7/9/03)
|
||||
!
|
||||
! NOTES:
|
||||
! (1 ) Comment out counter variable NUM_BACKSUB, you can get the same info
|
||||
! w/ a profiling run. (bmy, 7/9/03)
|
||||
!******************************************************************************
|
||||
!
|
||||
IMPLICIT NONE
|
||||
|
||||
# include "CMN_SIZE" ! Size parameters
|
||||
# include "comode.h" ! SMVGEAR II arrays
|
||||
|
||||
! Local variables
|
||||
INTEGER IJ,I,KZT,KL5,KH5,KL4,KH4,KL3,KH3,KL2,KH2,KL1,KH1,KC
|
||||
INTEGER J0,IJ0,IJ1,IJ2,IJ3,IJ4,J1,J2,J3,J4,K,MZT,ML5,MH5,ML4,MH4
|
||||
INTEGER ML3,MH3,ML2,MH2,ML1,MH1,MC
|
||||
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 BBBBBBB A CCCCCCC K K SSSSSSS U U BBBBBBB
|
||||
C B B A A C K K S U U B B
|
||||
C BBBBBBB A A C K K SSSSSSS U U BBBBBBB
|
||||
C B B AAAAAAA C K K S U U B B
|
||||
C BBBBBBB A A CCCCCCC K K SSSSSSS UUUUUUUU BBBBBBB
|
||||
C
|
||||
C *********************************************************************
|
||||
C ******* PERFORM BACK-SUBSTITUTIONS ON THE DECOMPOSED MATRIX *******
|
||||
C *********************************************************************
|
||||
|
||||
C *********************************************************************
|
||||
C * THIS SUBROUTINE SOLVES THE LINEAR SET OF EQUATIONS Ax = B FOR x, *
|
||||
C * THE CORRECTION VECTOR, WHERE "A" IS THE L-U DECOMPOSTION OF THE *
|
||||
C * ORIGINAL MATRIX, *
|
||||
C * *
|
||||
C * P = I - H x Bo x J, *
|
||||
C * *
|
||||
C * I = IDENTITY MATRIX, H = TIME-STEP, Bo = A COEFFICIENT THAT *
|
||||
C * DEPENDS ON THE ORDER OF THE INTEGRATION METHOD, AND J IS THE *
|
||||
C * MATRIX OF PARTIAL DERIVATIVES. B IS SENT FROM SMVGEAR AS A *
|
||||
C * CORRECTED VALUE OF THE FIRST DERIVATIVES OF THE ORDINARY DIFFER- *
|
||||
C * ENTIAL EQUATIONS. SUBROUTINE DECOMP.F SOLVED FOR "A", THE *
|
||||
C * DECOMPOSED MATRIX. SEE PRESS ET AL. (1992) NUMERICAL RECIPES. *
|
||||
C * CAMBRIDGE UNIVERSITY PRESS, FOR A BETTER DESCRIPTION OF THE BACK- *
|
||||
C * SUBSTITUTION PROCESS. *
|
||||
C * *
|
||||
C * THIS BACK-SUBSTITUTION PROCESS USES SPARSE-MATRIX TECHNIQUES, *
|
||||
C * VECTORIZES AROUND THE GRID-CELL DIMENSION, AND USES NO PARTIAL *
|
||||
C * PIVOTING. TESTS BY SHERMAN & HINDMARSH (1980) LAWRENCE LIVERMORE *
|
||||
C * REP. UCRL-84102 AND BY US HAVE CONFIRMED THAT THE REMOVAL OF *
|
||||
C * PARTIAL PIVOTING HAS LITTLE EFFECT ON RESULTS. *
|
||||
C * *
|
||||
C * HOW TO CALL SUBROUTINE: *
|
||||
C * ---------------------- *
|
||||
C * CALL BACKSUB.F FROM SMVGEAR.F WITH *
|
||||
C * NCS = 1..NCSGAS FOR GAS CHEMISTRY *
|
||||
C * NCSP = NCS FOR DAYTIME GAS CHEM *
|
||||
C * NCSP = NCS +ICS FOR NIGHTTIME GAS CHEM *
|
||||
C *********************************************************************
|
||||
C
|
||||
C *********************************************************************
|
||||
C * BACKSUB LOOP # 1 *
|
||||
C * FIRST, ADJUST RIGHT SIDE OF Ax = B USING LOWER TRIANGULAR MATRIX *
|
||||
C *********************************************************************
|
||||
C SUM 1,2,3,4, OR 5 TERMS AT A TIME TO IMPROVE VECTORIZATION.
|
||||
C
|
||||
C KTLOOP = NUMBER OF GRID-CELLS IN A GRID-BLOCK
|
||||
C ISCHAN = ORDER OF MATRIX
|
||||
C CC2 = ARRAY HOLDING VALUES OF DECOMPOSED MATRIX.
|
||||
C GLOSS = ARRAY INITIALLY HOLDING RIGHT SIDE OF EQUATION. THESE
|
||||
C VALUES ARE CONVERTED TO THE SOLUTION DURING BACK-SUBSTITUTION.
|
||||
C KZEROA,..= ARRAYS IDENTIFYING TERMS IN GLOSS ARRAY
|
||||
C
|
||||
IJ = 1
|
||||
DO 310 KZT = KZTLO(NCSP), KZTHI(NCSP)
|
||||
I = IKZTOT(KZT)
|
||||
KL5 = KBL5( KZT)
|
||||
KH5 = KBH5( KZT)
|
||||
KL4 = KBL4( KZT)
|
||||
KH4 = KBH4( KZT)
|
||||
KL3 = KBL3( KZT)
|
||||
KH3 = KBH3( KZT)
|
||||
KL2 = KBL2( KZT)
|
||||
KH2 = KBH2( KZT)
|
||||
KL1 = KBL1( KZT)
|
||||
KH1 = KBH1( KZT)
|
||||
C
|
||||
C *********************** SUM 5 TERMS AT A TIME *********************
|
||||
C
|
||||
DO 105 KC = KL5, KH5
|
||||
IJ0 = IJ
|
||||
IJ1 = IJ + 1
|
||||
IJ2 = IJ + 2
|
||||
IJ3 = IJ + 3
|
||||
IJ4 = IJ + 4
|
||||
IJ = IJ + 5
|
||||
J0 = KZEROA(KC)
|
||||
J1 = KZEROB(KC)
|
||||
J2 = KZEROC(KC)
|
||||
J3 = KZEROD(KC)
|
||||
J4 = KZEROE(KC)
|
||||
DO 100 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
2 - CC2(K,IJ1) * GLOSS(K,J1)
|
||||
3 - CC2(K,IJ2) * GLOSS(K,J2)
|
||||
4 - CC2(K,IJ3) * GLOSS(K,J3)
|
||||
5 - CC2(K,IJ4) * GLOSS(K,J4)
|
||||
100 CONTINUE
|
||||
105 CONTINUE
|
||||
C
|
||||
C *********************** SUM 4 TERMS AT A TIME *********************
|
||||
C
|
||||
DO 155 KC = KL4, KH4
|
||||
IJ0 = IJ
|
||||
IJ1 = IJ + 1
|
||||
IJ2 = IJ + 2
|
||||
IJ3 = IJ + 3
|
||||
IJ = IJ + 4
|
||||
J0 = KZEROA(KC)
|
||||
J1 = KZEROB(KC)
|
||||
J2 = KZEROC(KC)
|
||||
J3 = KZEROD(KC)
|
||||
DO 150 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
2 - CC2(K,IJ1) * GLOSS(K,J1)
|
||||
3 - CC2(K,IJ2) * GLOSS(K,J2)
|
||||
4 - CC2(K,IJ3) * GLOSS(K,J3)
|
||||
150 CONTINUE
|
||||
155 CONTINUE
|
||||
C
|
||||
C *********************** SUM 3 TERMS AT A TIME *********************
|
||||
C
|
||||
DO 205 KC = KL3, KH3
|
||||
IJ0 = IJ
|
||||
IJ1 = IJ + 1
|
||||
IJ2 = IJ + 2
|
||||
IJ = IJ + 3
|
||||
J0 = KZEROA(KC)
|
||||
J1 = KZEROB(KC)
|
||||
J2 = KZEROC(KC)
|
||||
DO 200 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
2 - CC2(K,IJ1) * GLOSS(K,J1)
|
||||
3 - CC2(K,IJ2) * GLOSS(K,J2)
|
||||
200 CONTINUE
|
||||
205 CONTINUE
|
||||
C
|
||||
C *********************** SUM 2 TERMS AT A TIME *********************
|
||||
C
|
||||
DO 255 KC = KL2, KH2
|
||||
IJ0 = IJ
|
||||
IJ1 = IJ + 1
|
||||
IJ = IJ + 2
|
||||
J0 = KZEROA(KC)
|
||||
J1 = KZEROB(KC)
|
||||
DO 250 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
2 - CC2(K,IJ1) * GLOSS(K,J1)
|
||||
250 CONTINUE
|
||||
255 CONTINUE
|
||||
C
|
||||
C *********************** SUM 1 TERM AT A TIME **********************
|
||||
C
|
||||
DO 305 KC = KL1, KH1
|
||||
IJ0 = IJ
|
||||
IJ = IJ + 1
|
||||
J0 = KZEROA(KC)
|
||||
DO 300 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
300 CONTINUE
|
||||
305 CONTINUE
|
||||
310 CONTINUE
|
||||
C
|
||||
C *********************************************************************
|
||||
C * BACKSUB LOOP # 2 *
|
||||
C * BACKSUBSTITE WITH UPPER TRIANGULAR MATRIX TO FIND SOLUTION *
|
||||
C *********************************************************************
|
||||
C AGAIN, SUM UP SEVERAL TERMS AT A TIME TO IMPROVE VECTORIZATION.
|
||||
C VDIAG = DIAGONAL TERM FROM L-U DECOMPOSTION.
|
||||
C GLOSS = SOLUTION ON OUTPUT
|
||||
C
|
||||
DO 710 I = ISCHAN, 1, -1
|
||||
MZT = IMZTOT(I,NCSP)
|
||||
IF (MZT.GT.0) THEN
|
||||
ML5 = MBL5( MZT)
|
||||
MH5 = MBH5( MZT)
|
||||
ML4 = MBL4( MZT)
|
||||
MH4 = MBH4( MZT)
|
||||
ML3 = MBL3( MZT)
|
||||
MH3 = MBH3( MZT)
|
||||
ML2 = MBL2( MZT)
|
||||
MH2 = MBH2( MZT)
|
||||
ML1 = MBL1( MZT)
|
||||
MH1 = MBH1( MZT)
|
||||
C
|
||||
C *********************** SUM 5 TERMS AT A TIME *********************
|
||||
C
|
||||
DO 405 MC = ML5, MH5
|
||||
IJ0 = IJ
|
||||
IJ1 = IJ + 1
|
||||
IJ2 = IJ + 2
|
||||
IJ3 = IJ + 3
|
||||
IJ4 = IJ + 4
|
||||
IJ = IJ + 5
|
||||
J0 = MZEROA(MC)
|
||||
J1 = MZEROB(MC)
|
||||
J2 = MZEROC(MC)
|
||||
J3 = MZEROD(MC)
|
||||
J4 = MZEROE(MC)
|
||||
DO 400 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
2 - CC2(K,IJ1) * GLOSS(K,J1)
|
||||
3 - CC2(K,IJ2) * GLOSS(K,J2)
|
||||
4 - CC2(K,IJ3) * GLOSS(K,J3)
|
||||
5 - CC2(K,IJ4) * GLOSS(K,J4)
|
||||
400 CONTINUE
|
||||
405 CONTINUE
|
||||
C
|
||||
C *********************** SUM 4 TERMS AT A TIME *********************
|
||||
C
|
||||
DO 455 MC = ML4, MH4
|
||||
IJ0 = IJ
|
||||
IJ1 = IJ + 1
|
||||
IJ2 = IJ + 2
|
||||
IJ3 = IJ + 3
|
||||
IJ = IJ + 4
|
||||
J0 = MZEROA(MC)
|
||||
J1 = MZEROB(MC)
|
||||
J2 = MZEROC(MC)
|
||||
J3 = MZEROD(MC)
|
||||
DO 450 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
2 - CC2(K,IJ1) * GLOSS(K,J1)
|
||||
3 - CC2(K,IJ2) * GLOSS(K,J2)
|
||||
4 - CC2(K,IJ3) * GLOSS(K,J3)
|
||||
450 CONTINUE
|
||||
455 CONTINUE
|
||||
C
|
||||
C *********************** SUM 3 TERMS AT A TIME *********************
|
||||
C
|
||||
DO 505 MC = ML3, MH3
|
||||
IJ0 = IJ
|
||||
IJ1 = IJ + 1
|
||||
IJ2 = IJ + 2
|
||||
IJ = IJ + 3
|
||||
J0 = MZEROA(MC)
|
||||
J1 = MZEROB(MC)
|
||||
J2 = MZEROC(MC)
|
||||
DO 500 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
2 - CC2(K,IJ1) * GLOSS(K,J1)
|
||||
3 - CC2(K,IJ2) * GLOSS(K,J2)
|
||||
500 CONTINUE
|
||||
505 CONTINUE
|
||||
C
|
||||
C *********************** SUM 2 TERMS AT A TIME *********************
|
||||
C
|
||||
DO 555 MC = ML2, MH2
|
||||
IJ0 = IJ
|
||||
IJ1 = IJ + 1
|
||||
IJ = IJ + 2
|
||||
J0 = MZEROA(MC)
|
||||
J1 = MZEROB(MC)
|
||||
DO 550 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
2 - CC2(K,IJ1) * GLOSS(K,J1)
|
||||
550 CONTINUE
|
||||
555 CONTINUE
|
||||
C
|
||||
C *********************** SUM 1 TERM AT A TIME **********************
|
||||
C
|
||||
DO 605 MC = ML1, MH1
|
||||
IJ0 = IJ
|
||||
IJ = IJ + 1
|
||||
J0 = MZEROA(MC)
|
||||
DO 600 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I)
|
||||
1 - CC2(K,IJ0) * GLOSS(K,J0)
|
||||
600 CONTINUE
|
||||
605 CONTINUE
|
||||
ENDIF
|
||||
C ENDIF MZT.GT.0
|
||||
C
|
||||
C *************** ADJUST GLOSS WITH DIAGONAL ELEMENT ****************
|
||||
C
|
||||
DO 700 K = 1, KTLOOP
|
||||
GLOSS(K,I) = GLOSS(K,I) * VDIAG(K,I)
|
||||
700 CONTINUE
|
||||
710 CONTINUE
|
||||
C
|
||||
C *********************************************************************
|
||||
C ******************** END OF SUBROUTINE BACKSUB **********************
|
||||
C *********************************************************************
|
||||
C
|
||||
RETURN
|
||||
END SUBROUTINE BACKSUB
|
||||
Reference in New Issue
Block a user