!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE CONJGRAD(KN,PB,PX,PWORK,KDW,KITER,PRESID 2,5
S ,MATVEC,KINFO,LDPRINT,kelem,cdfam)
#if defined (DOC)
*
***s/r CONJGRAD - Solution of a linear system AX - B = 0 with a conjugate
* . gradient method (A is assumed to be a symmetric positive
* . definite matrix)
*
* . Reference : Gollub, G.H. and C.F. van Loan, 1983
* . Matrix Computations. John Hopkins University Press
* . The algorithm used here corresponds to eq.(10.3-3)
* . in this reference
*
*Author : P. Gauthier *ARMA/AES January 23, 1996
*Revision:
* S. Pellerin *ARMA/AES Aug. 98.
* - Built-up of O matrix based on assimilated elements
* and observation family instead of NPOS
* (agument to matvec call).
*
* JM Belanger CMDA/SMC Jan 2001
* . 32 bits conversion
* (Replace BLAS single precision by double)
*
*Arguments
* . KN : order of the system
* . PB(KN) : right-hand-side of the system
* . PX : initial first estimate of the solution
* . PWORK(KN,4) : workspace needed by the algorithm (4*KN)
* . KDW : unused parameter introduced to make the interface identical
* . to that of CG of the Templates library
* . KITER : -INPUT- maximum number of iterations allowed
* . -OUTPUT- actual number of iterations required to achieve convergence
* . PRESID : accuracy criterion ||AX -B||/||B|| < PRESID
* . MATVEC (external subroutine)
* The user must provide a subroutine to perform the
* matrix-vector product
*
* y := alpha*A*x + beta*y,
*
* where alpha and beta are scalars, x and y are vectors,
* and A is a matrix. Vector x must remain unchanged.
* The solution is over-written on vector y.
*
* The call is:
*
* CALL MATVEC( ALPHA, X, BETA, Y )
* . kelem : variable (observation) code (BUFR)
* . cdfam : family of the observation
*
* . PSOLVE (external subroutine) - THIS OPTION IS NOT USED FOR NOW -
* The user must provide a subroutine to perform the
* preconditioner solve routine for the linear system
*
* M*x = b,
*
* where x and b are vectors, and M a matrix. Vector b must
* remain unchanged.
* The solution is over-written on vector x.
*
* The call is:
*
* CALL PSOLVE( X, B )
*
* The call sequence for the subroutine should then include psolve
* ex:
*
* SUBROUTINE CONJGRAD(KN,PB,PX,PWORK,KDW,KITER,PRESID
* S ,MATVEC,PSOLVE,KINFO,LDPRINT)
* EXTERNAL MATVEC, DDOT, DAXPY,DCOPY, PSOLVE, DOTOBS, DNRM2
*
* The preconditioner is passed into the routine in a common block.
*
* The matrix is passed into the routine in a common block.
* . KINFO : -OUTPUT- status parameter
* . LDPRINT: -INPUT - Switch to control printing
#endif
IMPLICIT NONE
#include "comlun.cdk"
*
* Global Variables
*
* Arguments
*
INTEGER KN, KINFO, KITER, KDW, kelem
REAL*8 PX(KN), PB(KN), PWORK(KN,5), PRESID
LOGICAL LDPRINT
character*2 cdfam
*
* Local variables
*
INTEGER JITER, ITERMAX,IZ, IR, IP, IQ, IX, JOUT, ITERTEMP
INTEGER IKOUNT,jj
REAL*8 DDOT,ZRHOM1, ZRHOM2, ZBETAM1,ZALPHA, ZERR0, ZERRABS
S , ZERRREL,ZONE,ZMONE, beta, DNRM2
EXTERNAL MATVEC, DDOT, DAXPY, DOTOBS, DNRM2
*
* 1. Initial set-ups
*
100 CONTINUE
C
9000 FORMAT(//,6X,' CONJGRAD- solving with a conjugate gradient '
S ,'algorithm',//)
IF ( LDPRINT) THEN
WRITE(NULOUT,FMT=9000)
ENDIF
C
ITERMAX = KITER
IZ = 1
IR = 2
IP = 3
IQ = 4
IX = 5
*
KINFO = 1
ZONE = 1.0
ZMONE = -1.0
*
* . 1.1 Compute the initial gradient
*
CALL DCOPY(KN,PX(1),1,PWORK(1,IX),1)
CALL DCOPY(KN,PB(1),1,PWORK(1,IR),1)
beta=1.0D0
CALL MATVEC(ZMONE,PWORK(1,IX),beta,PWORK(1,IR),kelem,cdfam)
ZERR0 = DNRM2(KN,PB(1),1)
*
* 2. Main iterative loop
*
200 CONTINUE
IKOUNT=0
DO JOUT = 1, KITER, KN
ITERTEMP = MIN(KN,KITER -JOUT + 1)
DO JITER = 1, ITERTEMP
*
* . This assumes that the identity is a good preconditioner
*
CALL DCOPY(KN,PWORK(1,IR),1,PWORK(1,IZ),1)
*
CALL DOTOBS(KN,PWORK(1,IR),PWORK(1,IZ),ZRHOM1)
C ZRHOM1 = DDOT(KN,PWORK(1,IR),1,PWORK(1,IZ),1)
IF (JITER.EQ.1) THEN
CALL DCOPY(KN,PWORK(1,IZ),1,PWORK(1,IP),1)
ELSE
ZBETAM1 = ZRHOM1/ZRHOM2
CALL DCOPY(KN,PWORK(1,IZ),1,PWORK(1,IQ),1)
CALL DAXPY(KN,ZBETAM1,PWORK(1,IP),1,PWORK(1,IQ),1)
CALL DCOPY(KN,PWORK(1,IQ),1,PWORK(1,IP),1)
END IF
CALL MATVEC(ZONE,PWORK(1,IP),0.0D0,PWORK(1,IQ),kelem,cdfam)
CALL DOTOBS(KN,PWORK(1,IP),PWORK(1,IQ),ZALPHA)
* ZALPHA = DDOT(KN,PWORK(1,IP),1,PWORK(1,IQ),1)
ZALPHA = ZRHOM1/ZALPHA
CALL DAXPY(KN,ZALPHA,PWORK(1,IP),1,PWORK(1,IX),1)
CALL DAXPY(KN,-ZALPHA,PWORK(1,IQ),1,PWORK(1,IR),1)
ZRHOM2 = ZRHOM1
*
* Test if convergence has been achieved
*
CALL DCOPY(KN,PB(1),1,PWORK(1,IQ),1)
CALL MATVEC(ZMONE,PWORK(1,IX),ZONE,PWORK(1,IQ),kelem,cdfam)
ZERRABS = DNRM2(KN,PWORK(1,IQ),1)
ZERRREL = ZERRABS/ZERR0
IKOUNT = IKOUNT + 1
IF(ZERRREL.LE.PRESID) THEN
KITER = JITER + JOUT - 1
KINFO = 0
GOTO 300
END IF
END DO
END DO
*
* 3.
*
300 CONTINUE
IF (KINFO.NE.0) THEN
WRITE(NULOUT,9301)KINFO
END IF
*
* Move result to output field
* =====================================
CALL DCOPY(KN,PWORK(1,IX),1,PX(1),1)
* =====================================
*
IF ( LDPRINT ) THEN
WRITE(NULOUT,9300)ITERMAX, IKOUNT, ZERR0, ZERRABS, ZERRREL
ENDIF
9301 FORMAT(//,'In CONJGRAD, convergence has not been achieved. KINFO = ',I2)
9300 FORMAT(4X,'Max. Number of Iterations requested: ',I6,/
S ,4X,'Number of Iterations : ',I6,/
S ,4X,'Norm of Initial residual : ',G12.6,/
S ,4X,'Norm of Final residual : ',G12.6,/
S ,4x,'Accuracy achieved : ',G12.6)
*
RETURN
END