![]() ![]() |
![]() |
File: [Development] / JSOC / proj / vfisv / apps / inv_utils.f90
(download)
Revision: 1.6, Tue Apr 10 21:17:03 2012 UTC (11 years, 1 month ago) by keiji Branch: MAIN CVS Tags: Ver_LATEST, Ver_9-5, Ver_9-41, Ver_9-4, Ver_9-3, Ver_9-2, Ver_9-1, Ver_9-0, Ver_8-8, Ver_8-7, Ver_8-6, Ver_8-5, Ver_8-4, Ver_8-3, Ver_8-2, Ver_8-12, Ver_8-11, Ver_8-10, Ver_8-1, Ver_8-0, Ver_7-1, Ver_7-0, Ver_6-4, Ver_6-3, Ver_6-2, HEAD Changes since 1.5: +39 -107 lines *** empty log message *** |
MODULE INV_UTILS ! ! J M Borrero ! Dec 14, 2009 ! HAO-NCAR for HMI-Stanford ! ! By RCE (June 8, 2010): in SUBROUTINE SVDSOL(DMODEL, CONV_FLAG) added ! conv_flag to flag the convergence of the SVD solving routine. If SVD ! doesn't converge, then CONV_FLAG takes value 0. Changes propagate into SVDCMP.f90. ! This flag is an indication for INVERT to set the results of the inversions ! to NaN for a particular pixel. ! ! By RCE, Jan 2011: fixed a bug in the GET_ERROR routine. CONTAINS !--------------------------------------------------- PURE SUBROUTINE GET_TOTPOL(OBS,TOTPOL) USE CONS_PARAM USE FILT_PARAM IMPLICIT NONE REAL(DP), INTENT(IN), DIMENSION(NBINS*4) :: OBS REAL(DP), INTENT(OUT) :: TOTPOL REAL(DP), DIMENSION(NBINS) :: I, Q, U, V ! I=OBS(1:NBINS) Q=OBS(NBINS+1:2*NBINS)/I U=OBS(2*NBINS+1:3*NBINS)/I V=OBS(3*NBINS+1:4*NBINS)/I ! TOTPOL=SUM(SQRT(Q**2D0+U**2D0+V**2D0)) END SUBROUTINE GET_TOTPOL !---------------------------------------------------- PURE SUBROUTINE SORT_OBS(OBS_LONG,OBS) USE FILT_PARAM IMPLICIT NONE REAL(DP), INTENT(IN), DIMENSION(NBINS*4) :: OBS_LONG REAL(DP), INTENT(OUT), DIMENSION(NBINS,4) :: OBS ! OBS(:,1) = OBS_LONG(1:NBINS) OBS(:,2) = OBS_LONG(NBINS+1:2*NBINS) OBS(:,3) = OBS_LONG(2*NBINS+1:3*NBINS) OBS(:,4) = OBS_LONG(3*NBINS+1:4*NBINS) ! END SUBROUTINE SORT_OBS !---------------------------------------------------- SUBROUTINE GET_WEIGHT (OBS,WEIGHTS) ! USE LINE_PARAM USE CONS_PARAM USE FILT_PARAM IMPLICIT NONE REAL(DP), INTENT(IN), DIMENSION(NBINS,4) :: OBS REAL(DP), DIMENSION(4) :: WEIGHTS ! ! By RCE, Feb 2011: Now the weights are passed by the wrapper to the code. ! We normalize them to the maximum WEIGHTS(:) = WEIGHTS(:)/MAXVAL(WEIGHTS(:)) ! By RCE: and we divide them by the noise WEIGHTS(:) = WEIGHTS(:)/NOISE(:) !----------------------------------------------------------- ! JM Borrero: Apr 15, 2010 ! WEIGHTS(1)=(0.8D0*ABS(1.01D0-MAXVAL(OBS(:,1)))+0.2D0)/NOISE(:) ! Change weights only if you know what you are doing !!! !----------------------------------------------------------- END SUBROUTINE GET_WEIGHT !---------------------------------------------------- PURE SUBROUTINE GET_CHI2(MODEL,SYN,OBS,WEIGHTS,REGUL_FLAG,C2) ! USE INV_PARAM USE CONS_PARAM USE FILT_PARAM IMPLICIT NONE REAL(DP), INTENT(IN), DIMENSION(4) :: WEIGHTS REAL(DP), INTENT(IN), DIMENSION(NBINS,4) :: OBS, SYN INTEGER, INTENT(IN) :: REGUL_FLAG REAL(DP), INTENT(IN), DIMENSION(10) :: MODEL REAL(DP), INTENT(OUT) :: C2 REAL(DP), DIMENSION(1) :: DUM INTEGER :: I C2=0D0 DO I=1,4 C2=C2+(1D0/NUMFREE_DEG)*(WEIGHTS(I)**2D0)*SUM(((OBS(:,I)-SYN(:,I)))**2D0) ENDDO IF (REGUL_FLAG .EQ. 1) THEN CALL REGULARIZATION(0, MODEL, C2,DUM,DUM) ENDIF END SUBROUTINE GET_CHI2 !------------------------------------------------------ ! By RCE, Jan 30, 2012 ! REGULARIZATION routine: calculates regularization term ! for chi2. Currently based on eta0: r = eps*(eta0-C)^2 ! If this changes, then change derivative too (REGULDER) ! DERIVS determines which derivatives are updated ! 0: Only CHI2 ! 1: CHI2 and DIVC ! 2: CHI2 and HESS ! 3: CHI2, DIVC and HESS !------------------------------------------------------ PURE SUBROUTINE REGULARIZATION(DERIVS,MODEL,CHI2,DIVC,HESS) USE CONS_PARAM USE INV_PARAM INTEGER, INTENT(IN) :: DERIVS REAL(DP), INTENT(IN), DIMENSION(10) :: MODEL REAL(DP), INTENT (INOUT) :: CHI2 REAL(DP), INTENT(INOUT), DIMENSION(NUMFREE_PARAM) :: DIVC REAL(DP), INTENT(INOUT), DIMENSION(NUMFREE_PARAM,NUMFREE_PARAM) :: HESS REAL(DP) :: EPS,C EPS=2.00D-3 C=5D0 ! With first parameter we can be sure that it always goes ! into position 1. Got to watch out for other derivatives. if (free(1).eq..true.) then chi2=chi2+EPS*(MODEL(1)-C)**2D0 if (mod(derivs,2).eq.1) then divc(1)=divc(1)-2*EPS*(MODEL(1)-C)*NORM(1) if (derivs.ge.2) then hess(1,1)=hess(1,1)+2*eps*NORM(1)**2 endif endif endif END SUBROUTINE REGULARIZATION !------------------------------------------------------ SUBROUTINE NORMALIZE_DSYN(DSYN) ! ! By RCE, May 20, 2011: We use the NORM vector initialized in ! LIM_INIT ! USE FILT_PARAM USE CONS_PARAM USE INV_PARAM IMPLICIT NONE REAL(DP), INTENT(INOUT), DIMENSION(10,NBINS,4) :: DSYN INTEGER :: I DO I=1,10 DSYN(I,:,:)=DSYN(I,:,:)*NORM(I) ENDDO END SUBROUTINE NORMALIZE_DSYN !------------------------------------------------------- PURE SUBROUTINE ZERO_DSYN (DSYN) USE CONS_PARAM USE FILT_PARAM USE INV_PARAM IMPLICIT NONE REAL(DP), INTENT(INOUT), DIMENSION(10,NBINS,4) :: DSYN INTEGER :: I DO I=1,10 IF (FREE(I).EQ..FALSE.) THEN DSYN(I,:,:)=0D0 ENDIF ENDDO ! END SUBROUTINE ZERO_DSYN ! !-------------------------------------------------------- ! PURE SUBROUTINE GET_LAMBDA(DELTACHI2,LAMBDA_OLD,LAMBDA_NEW) ! USE CONS_PARAM USE INV_PARAM IMPLICIT NONE REAL(DP), INTENT(IN) :: DELTACHI2,LAMBDA_OLD REAL(DP), INTENT(OUT) :: LAMBDA_NEW IF (DELTACHI2.GE.DELTACHIMIN) THEN ! Things got better LAMBDA_NEW=LAMBDA_OLD/LAMBDA_DOWN !IF (LAMBDA_NEW.LE.1E-4) LAMBDA_NEW=1E-4 LAMBDA_NEW=MAX(LAMBDA_NEW,LAMBDA_MIN) ELSE ! Things got worse LAMBDA_NEW=LAMBDA_UP*LAMBDA_OLD IF (LAMBDA_OLD.gt.0.01) LAMBDA_NEW=2D0*LAMBDA_NEW ENDIF END SUBROUTINE GET_LAMBDA ! !-------------------------------------------------------- ! ! Routine that computes the divergence of chi2 ! The divergence is -1/2*partial(chi2)/partial(parameter) ! So although the derivative has a negative sign, the ! divergence doesn't ! JS: Yet, the factor 1/2 appears not to have been applied below. ! Similarly the Hessian does not have a factor of 1/2, so math ! appears consistent, but comments not. SUBROUTINE GET_DIVC(SYN,OBS,DSYN,WEIGHTS,DIVC) ! USE CONS_PARAM USE FILT_PARAM USE INV_PARAM IMPLICIT NONE REAL(DP), INTENT(IN), DIMENSION(NBINS,4) :: OBS, SYN REAL(DP), INTENT(IN), DIMENSION(10,NBINS,4) :: DSYN REAL(DP), INTENT(IN), DIMENSION(4) :: WEIGHTS REAL(DP), INTENT(INOUT), DIMENSION(NUMFREE_PARAM) :: DIVC INTEGER :: I, J ! DIVC(:)=0D0 DO I=1,NUMFREE_PARAM DO J=1,4 DIVC(I)=DIVC(I)+(2D0/NUMFREE_DEG)*(WEIGHTS(J)**2D0) & *SUM((OBS(:,J)-SYN(:,J))*DSYN(FREELOC(I),:,J)) ENDDO ENDDO END SUBROUTINE GET_DIVC ! !-------------------------------------------------------- ! SUBROUTINE RANDOM_MODEL_JUMP(MODELR) USE CONS_PARAM USE INV_PARAM USE RAN_MOD IMPLICIT NONE REAL(DP), INTENT(INOUT), DIMENSION(10) :: MODELR REAL(DP), DIMENSION(10) :: INMODEL REAL(DP), DIMENSION(10) :: RAN INTEGER :: I REAL(DP) :: SSUM,SRATIO !-------------------------------------------- ! JM Borrero: Apr 15, 2010 ! Modified to include and normal distribution ! instead of uniform distribution !-------------------------------------------- INMODEL=MODELR ! Save input model MODELR(2) = 90D0 + 10D0*NORMAL(0D0,1D0) modelr(1)=normal(5D0,5D0) modelr(5)=normal(25D0,10D0) modelr(6)=inmodel(6)*normal(1D0,0.5D0) modelr(3)=inmodel(3)+normal(0D0,45D0) ssum=(inmodel(8)+inmodel(9))*normal(1D0,0.01D0) sratio=0.2D0+0.3D0*ran1() modelr(8)=ssum*sratio/(1+sratio) modelr(9)=ssum/(1+sratio) ! Checking that perturbation did not go too far CALL FINE_TUNE_MODEL(MODELR) END SUBROUTINE RANDOM_MODEL_JUMP ! !-------------------------------------------------------- ! SUBROUTINE FINE_TUNE_MODEL(MODEL) USE INV_PARAM USE CONS_PARAM IMPLICIT NONE REAL(DP), INTENT(INOUT), DIMENSION(10) :: MODEL INTEGER :: REV, I REAL(DP) :: S0,S1,SS ! We use the variable limits defined in LIM_INIT (called from wrapper) ! Save inout values S0=MODEL(8) S1=MODEL(9) SS=S0+S1 MODEL(8)=MAX(S0,LOWER_LIMIT(8)) MODEL(9)=SS-MODEL(8) ! Keep sum unchanged ! Check all the limits except the angles and non-free parameters DO I = 1, 10 IF ((FREE(I).EQ..TRUE.) .AND. (I .NE. 2) .AND. (I .NE. 3)) THEN IF (MODEL(I) .LT. LOWER_LIMIT(I)) MODEL(I) = LOWER_LIMIT(I) IF (MODEL(I) .GT. UPPER_LIMIT(I)) MODEL(I) = UPPER_LIMIT(I) ENDIF ENDDO MODEL(8)=MAX(S0,0.15D0*SS) ! Use S0+S1 instead of ICONT MODEL(9)=SS-MODEL(8) ! Keep sum unchanged ! Check the angles independently so that they vary between 0 and 180. ! All negatives Inclination treated here to be positive and between 0,PI IF (MODEL(2).LT.-360D0) THEN REV=ABS((INT(MODEL(2)/360D0))) MODEL(2)=MODEL(2)+360D0*REV ENDIF IF (MODEL(2).LT.0D0 .AND. MODEL(2).GT.-90D0) MODEL(2)=-MODEL(2) IF (MODEL(2).LT.-90D0 .AND. MODEL(2).GT.-180D0) MODEL(2)=-MODEL(2) IF (MODEL(2).LT.-180 .AND. MODEL(2).GT.-270D0) MODEL(2)=360D0+MODEL(2) IF (MODEL(2).LT.-270D0 .AND. MODEL(2).GT. -360D0) MODEL(2)=360D0+MODEL(2) ! All positive inclination larger than PI or 2PI put between 0,PI IF (MODEL(2).GT.360D0) THEN REV=INT(MODEL(2)/360D0) MODEL(2)=MODEL(2)-360D0*REV ENDIF IF (MODEL(2).GT.180) MODEL(2)=360D0-MODEL(2) ! Shift azimuthal angles IF (MODEL(3).GT.360D0) THEN REV=INT(MODEL(3)/360D0) MODEL(3)=MODEL(3)-360D0*REV ENDIF IF (MODEL(3).GT.180) MODEL(3)=MODEL(3)-180D0 IF (MODEL(3).LT.-360D0) THEN REV=ABS((INT(MODEL(3)/360D0))) MODEL(3)=MODEL(3)+360D0*REV ENDIF IF (MODEL(3).LT.-180) MODEL(3)=MODEL(3)+180D0 IF (MODEL(3).LT.0) MODEL(3)=MODEL(3)+180D0 END SUBROUTINE FINE_TUNE_MODEL ! !-------------------------------------------------------- ! SUBROUTINE GET_HESS(DSYN,WEIGHTS,HESS) ! NOTE that the Hessian doesn't have the (1+lambda) Marquardt factor ! scaling in the diagonal elements of the matrix. This is now included ! in the routine that calculates the model improvement (GET_DMODEL). USE CONS_PARAM USE FILT_PARAM USE INV_PARAM IMPLICIT NONE REAL(DP), INTENT(IN), DIMENSION(10,NBINS,4) :: DSYN REAL(DP), INTENT(IN), DIMENSION(4) :: WEIGHTS REAL(DP), INTENT(INOUT), DIMENSION(NUMFREE_PARAM,NUMFREE_PARAM) :: HESS REAL(DP) :: HELP INTEGER :: I, J, K DO I=1,NUMFREE_PARAM DO J=1,I HELP=0D0 DO K=1,4 HELP=HELP+(WEIGHTS(K)**2D0)*SUM(DSYN(FREELOC(I),:,K)*DSYN(FREELOC(J),:,K)) ENDDO HESS(I,J)=(2D0/NUMFREE_DEG)*HELP HESS(J,I)=(2D0/NUMFREE_DEG)*HELP ENDDO ENDDO END SUBROUTINE GET_HESS ! !------------------------------------------------------------ ! SUBROUTINE GET_DMODEL(MODEL, REGUL_FLAG, DIVC, HESS, LAMBDA, DMODEL, CONV_FLAG) ! ! JS: Appears to solve HESS DMODEL = DIVC USE INV_PARAM USE CONS_PARAM USE FILT_PARAM IMPLICIT NONE REAL(DP), INTENT(IN), DIMENSION(10) :: MODEL INTEGER, INTENT(IN) :: REGUL_FLAG REAL(DP), INTENT(IN) :: LAMBDA REAL(DP), DIMENSION(15*NUMFREE_PARAM) :: WORK REAL(DP), DIMENSION(NUMFREE_PARAM,NUMFREE_PARAM) :: VT, U, WINV, HINV, V, HESS1 REAL(DP), DIMENSION(NUMFREE_PARAM) :: PLUSMODEL, W, DIVC1 REAL(DP), INTENT(INOUT), DIMENSION(NUMFREE_PARAM) :: DIVC REAL(DP), INTENT(INOUT), DIMENSION(NUMFREE_PARAM,NUMFREE_PARAM) :: HESS REAL(DP) :: WMAX, DUM, MX INTEGER :: I, J, INFO REAL(DP), DIMENSION(10) :: DMODEL INTEGER :: CONV_FLAG DMODEL=0D0 ! In case parameter is not free or SVD fails. ! Marquardt (1+ lambda) factor applied to diagonal of Hessian matrix DIVC1=DIVC DO I = 1, NUMFREE_PARAM DO J = 1, NUMFREE_PARAM HESS1(j,i) = HESS(j,i) ENDDO HESS1(i,i)=HESS1(i,i)*(1D0+LAMBDA) ENDDO ! Regularize, if desired IF (REGUL_FLAG .EQ. 1) THEN CALL REGULARIZATION(3, MODEL, DUM,DIVC1,HESS1) ENDIF ! By RCE: call LAPACK SVD CALL DGESVD('A','A',NUMFREE_PARAM,NUMFREE_PARAM,HESS1,NUMFREE_PARAM,W,U & ,NUMFREE_PARAM,VT,NUMFREE_PARAM,WORK,15*NUMFREE_PARAM,INFO) IF (INFO.NE.0) THEN PRINT*,'ERROR IN SVD' CONV_FLAG = 1 ELSE CONV_FLAG=0 ! By RCE: transpose VT matrix to obtain V and use it in SVBKSB DO I = 1, NUMFREE_PARAM DO J = 1, NUMFREE_PARAM V(i,j) = VT(j,i) ENDDO ENDDO WMAX=MAXVAL(W) DO I=1,NUMFREE_PARAM IF (W(I).LT.SVDTOL*WMAX) W(I)=0D0 ENDDO CALL SVBKSB(U,W,V,NUMFREE_PARAM,NUMFREE_PARAM,NUMFREE_PARAM, & NUMFREE_PARAM,DIVC1,PLUSMODEL) DO I=1,NUMFREE_PARAM MX=PLUSMODEL(I) IF ((MX.eq.(MX+1D0)).or.(abs(MX).gt.1D10)) then CONV_FLAG=2 ELSE DMODEL(FREELOC(I))=MX ENDIF ENDDO ENDIF END SUBROUTINE GET_DMODEL ! !------------------------------------------------------------ ! PURE SUBROUTINE NORMALIZE_DMODEL(DMODEL) ! ! By RCE, April 2012: normalization vector defined in LIM_INIT ! USE CONS_PARAM USE INV_PARAM IMPLICIT NONE REAL(DP), INTENT(INOUT), DIMENSION(10) :: DMODEL INTEGER :: I DO I=1,10 DMODEL(I)=DMODEL(I)*NORM(I) ENDDO ! END SUBROUTINE NORMALIZE_DMODEL ! !------------------------------------------------------------ ! PURE SUBROUTINE CUT_DMODEL(DMODEL,MODEL) ! ! BY RCE April 2012: New limits for DMODEL by Jesper Schou. ! Defined in LIM_INIT ! USE CONS_PARAM USE INV_PARAM IMPLICIT NONE REAL(DP), INTENT(INOUT), DIMENSION(10) :: DMODEL REAL(DP), INTENT(IN), DIMENSION(10) :: MODEL INTEGER :: I DO I=1,10 IF (RLIMIT(I).EQ.0D0) THEN ! Use absolute limits DMODEL(I)=MIN(MAX(DMODEL(I),-DLIMIT(I)),DLIMIT(I)) ELSE DMODEL(I)=MIN(MAX(MODEL(I)+DMODEL(I),MODEL(I)/RLIMIT(I)),MODEL(I)*RLIMIT(I))-MODEL(I) ENDIF ENDDO ! END SUBROUTINE CUT_DMODEL ! !------------------------------------------------------------ ! SUBROUTINE GET_ERR(HESS, CHI2,SIGMA,CONV_FLAG) ! ! The variances and co-variances are the elements of the inverse of the ! Hessian matrix when the algorithm has converged. The errors are scaled ! by chi2 over the number of degrees of freedom. USE CONS_PARAM USE INV_PARAM USE LINE_PARAM IMPLICIT NONE REAL(DP), DIMENSION(NUMFREE_PARAM,NUMFREE_PARAM) :: VT, U, COV REAL(DP), DIMENSION(15*NUMFREE_PARAM) :: WORK REAL(DP), DIMENSION(NUMFREE_PARAM) :: W REAL(DP) :: CHI2 REAL(DP), DIMENSION(10,10) :: COV_DUMMY REAL(DP), DIMENSION(16) :: SIGMA REAL(DP), INTENT(INOUT), DIMENSION(NUMFREE_PARAM,NUMFREE_PARAM) :: HESS INTEGER :: I, J, INFO, NFREE INTEGER, INTENT(OUT) :: CONV_FLAG ! ! Use LAPACK for calculating SVD of the HESSIAN W(:)=0D0 CALL DGESVD('A','A',NUMFREE_PARAM,NUMFREE_PARAM,HESS,NUMFREE_PARAM, & W,U,NUMFREE_PARAM,VT,NUMFREE_PARAM,WORK,15*NUMFREE_PARAM,INFO) IF (INFO.NE.0) THEN PRINT*,'ERROR IN SVD' CONV_FLAG=1 SIGMA=0D0 ELSE CONV_FLAG=0 DO I=1,NUMFREE_PARAM DO J=1,NUMFREE_PARAM COV(I,J)=CHI2/DBLE(NUMFREE_DEG)*SUM(U(I,:)*U(J,:)/W(:)) ! Re-normalizing the derivatives: COV(I,J)=COV(I,J)*(NORM(FREELOC(I))*NORM(FREELOC(J))) ENDDO ENDDO ! DO I=1,NUMFREE_PARAM DO J=1,NUMFREE_PARAM COV_DUMMY(FREELOC(I),FREELOC(J))=COV(I,J) ENDDO ENDDO !-------------------------------- ! Variances (square root of) !-------------------------------- DO I=1,10 SIGMA(I)=SQRT(COV_DUMMY(I,I)) ENDDO !-------------------------------- ! Covariances (normalized) !-------------------------------- ! B-Gamma SIGMA(11)=COV_DUMMY(6,2)/SIGMA(6)/SIGMA(2) ! B-Phi SIGMA(12)=COV_DUMMY(6,3)/SIGMA(6)/SIGMA(3) ! Gamma-Phi SIGMA(13)=COV_DUMMY(2,3)/SIGMA(2)/SIGMA(3) ! B-Alpha SIGMA(14)=COV_DUMMY(6,10)/SIGMA(6)/SIGMA(10) ! Gamma-Alpha SIGMA(15)=COV_DUMMY(2,10)/SIGMA(10)/SIGMA(2) ! Phi-Alpha SIGMA(16)=COV_DUMMY(3,10)/SIGMA(3)/SIGMA(10) ENDIF END SUBROUTINE GET_ERR !------------------------------------------- END MODULE INV_UTILS !CVSVERSIONINFO "$Id: inv_utils.f90,v 1.6 2012/04/10 22:17:03 keiji Exp $"
Karen Tian |
Powered by ViewCVS 0.9.4 |