*DECK REORT SUBROUTINE REORT (NCOMP, Y, YP, YHP, NIV, W, S, P, IP, STOWA, + IFLAG) C***BEGIN PROLOGUE REORT C***SUBSIDIARY C***PURPOSE Subsidiary to BVSUP C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (REORT-S, DREORT-D) C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C ********************************************************************** C INPUT C ********* C Y, YP and YHP = homogeneous solution matrix and particular C solution vector to be orthonormalized. C IFLAG = 1 -- store YHP into Y and YP, test for C reorthonormalization, orthonormalize if needed, C save restart data. C 2 -- store YHP into Y and YP, reorthonormalization, C no restarts. C (preset orthonormalization mode) C 3 -- store YHP into Y and YP, reorthonormalization C (when INHOMO=3 and X=XEND). C ********************************************************************** C OUTPUT C ********* C Y, YP = orthonormalized solutions. C NIV = number of independent vectors returned from DMGSBV. C IFLAG = 0 -- reorthonormalization was performed. C 10 -- solution process must be restarted at the last C orthonormalization point. C 30 -- solutions are linearly dependent, problem must C be restarted from the beginning. C W, P, IP = orthonormalization information. C ********************************************************************** C C***SEE ALSO BVSUP C***ROUTINES CALLED MGSBV, SDOT, STOR1, STWAY C***COMMON BLOCKS ML15TO, ML18JR, ML8SZ C***REVISION HISTORY (YYMMDD) C 750601 DATE WRITTEN C 890531 Changed all specific intrinsics to generic. (WRB) C 890831 Modified array declarations. (WRB) C 890921 Realigned order of variables in certain COMMON blocks. C (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910722 Updated AUTHOR section. (ALS) C***END PROLOGUE REORT C DIMENSION Y(NCOMP,*),YP(*),W(*),S(*),P(*),IP(*), 1 STOWA(*),YHP(NCOMP,*) C C ********************************************************************** C COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFC COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /ML18JR/ AE,RE,TOL,NXPTS,NIC,NOPG,MXNON,NDISK,NTAPE,NEQ, 1 INDPVT,INTEG,NPS,NTP,NEQIVP,NUMORT,NFCC, 2 ICOCO C C ********************************************************************** C***FIRST EXECUTABLE STATEMENT REORT NFCP=NFC+1 C C CHECK TO SEE IF ORTHONORMALIZATION TEST IS TO BE PERFORMED C IF (IFLAG .NE. 1) GO TO 5 KNSWOT=KNSWOT+1 IF (KNSWOT .GE. NSWOT) GO TO 5 IF ((XEND-X)*(X-XOT) .LT. 0.) RETURN 5 CALL STOR1(Y,YHP,YP,YHP(1,NFCP),1,0,0) C C **************************************** C C ORTHOGONALIZE THE HOMOGENEOUS SOLUTIONS Y C AND PARTICULAR SOLUTION YP. C NIV=NFC CALL MGSBV(NCOMP,NFC,Y,NCOMP,NIV,MFLAG,S,P,IP,INHOMO,YP,W,WCND) C C **************************************** C C CHECK FOR LINEAR DEPENDENCE OF THE SOLUTIONS. C IF (MFLAG .EQ. 0) GO TO 25 IF (IFLAG .EQ. 2) GO TO 15 IF (NSWOT .GT. 1 .OR. LOTJP .EQ. 0) GO TO 20 15 IFLAG=30 RETURN C C RETRIEVE DATA FOR A RESTART AT LAST ORTHONORMALIZATION POINT C 20 CALL STWAY(Y,YP,YHP,1,STOWA) LOTJP=1 NSWOT=1 KNSWOT=0 MNSWOT=MNSWOT/2 TND=TND+1. IFLAG=10 RETURN C C **************************************** C 25 IF (IFLAG .NE. 1) GO TO 60 C C TEST FOR ORTHONORMALIZATION C IF (WCND .LT. 50.*TOL) GO TO 60 DO 30 IJK=1,NFCP IF (S(IJK) .GT. 1.0E+20) GO TO 60 30 CONTINUE C C USE LINEAR EXTRAPOLATION ON LOGARITHMIC VALUES OF THE NORM C DECREMENTS TO DETERMINE NEXT ORTHONORMALIZATION CHECKPOINT. C OTHER CONTROLS ON THE NUMBER OF STEPS TO THE NEXT CHECKPOINT C ARE ADDED FOR SAFETY PURPOSES. C NSWOT=KNSWOT KNSWOT=0 LOTJP=0 WCND=LOG10(WCND) IF (WCND .GT. TND+3.) NSWOT=2*NSWOT IF (WCND .GE. PWCND) GO TO 40 DX=X-PX DND=PWCND-WCND IF (DND .GE. 4) NSWOT=NSWOT/2 DNDT=WCND-TND IF (ABS(DX*DNDT) .GT. DND*ABS(XEND-X)) GO TO 40 XOT=X+DX*DNDT/DND GO TO 50 40 XOT=XEND 50 NSWOT=MIN(MNSWOT,NSWOT) PWCND=WCND PX=X RETURN C C **************************************** C C ORTHONORMALIZATION NECESSARY SO WE NORMALIZE THE HOMOGENEOUS C SOLUTION VECTORS AND CHANGE W ACCORDINGLY. C 60 NSWOT=1 KNSWOT=0 LOTJP=1 KK = 1 L=1 DO 70 K = 1,NFCC SRP=SQRT(P(KK)) IF (INHOMO .EQ. 1) W(K)=SRP*W(K) VNORM=1./SRP P(KK)=VNORM KK = KK + NFCC + 1 - K IF (NFC .EQ. NFCC) GO TO 63 IF (L .NE. K/2) GO TO 70 63 DO 65 J = 1,NCOMP 65 Y(J,L) = Y(J,L)*VNORM L=L+1 70 CONTINUE C IF (INHOMO .NE. 1 .OR. NPS .EQ. 1) GO TO 100 C C NORMALIZE THE PARTICULAR SOLUTION C YPNM=SDOT(NCOMP,YP,1,YP,1) IF (YPNM .EQ. 0.0) YPNM = 1.0 YPNM = SQRT(YPNM) S(NFCP) = YPNM DO 80 J = 1,NCOMP 80 YP(J) = YP(J) / YPNM DO 90 J = 1,NFCC 90 W(J) = C * W(J) C 100 IF (IFLAG .EQ. 1) CALL STWAY(Y,YP,YHP,0,STOWA) IFLAG=0 RETURN END