C ALGORITHM 789, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 25,NO. 1, March, 1999, P. 58-- 69. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Doc/ # Doc/EXTRAS/ # Doc/EXTRAS/drived.f # Doc/EXTRAS/makepqwd.f # Doc/EXTRAS/sleign2.doc # Doc/EXTRAS/sleign2.hlp # Doc/EXTRAS/sleign2.txt # Doc/EXTRAS/sleign2d.f # Doc/EXTRAS/sleign2x.tex # Doc/EXTRAS/xamplesd.f # Doc/bsample.lnk # Doc/bstandrd.lnk # Doc/d02kef.doc # Doc/d02kef.lnk # Doc/evsimp.lnk # Doc/filelist # Doc/librarie.dir # Doc/marcomod.lnk # Doc/nagf90.mk # Doc/read.me # Doc/salftn90.mk # Doc/sample.lnk # Doc/slattrib.bat # Doc/sledgemd.lnk # Doc/sleig2md.lnk # Doc/sleignmd.lnk # Doc/slpkzip.bat # Doc/slsetup.bat # Doc/sltar.bat # Doc/standard.lnk # Doc/standard\sledge48.m # Src/ # Src/Fortran90/ # Src/Fortran90/Dp/ # Src/Fortran90/Dp/d02kef/ # Src/Fortran90/Dp/d02kef/d02kef.f # Src/Fortran90/Dp/marcopak/ # Src/Fortran90/Dp/marcopak/marcomod.f # Src/Fortran90/Dp/probsets/ # Src/Fortran90/Dp/probsets/sample.f # Src/Fortran90/Dp/probsets/standard.f # Src/Fortran90/Dp/sldriver/ # Src/Fortran90/Dp/sldriver/batchio.f # Src/Fortran90/Dp/sldriver/dbmod.f # Src/Fortran90/Dp/sldriver/errflags.hlp # Src/Fortran90/Dp/sldriver/evsimp.f # Src/Fortran90/Dp/sldriver/initpuff.hlp # Src/Fortran90/Dp/sldriver/playback.dat # Src/Fortran90/Dp/sldriver/safeio.f # Src/Fortran90/Dp/sldriver/sample.lst # Src/Fortran90/Dp/sldriver/samplrun.dat # Src/Fortran90/Dp/sldriver/samplrun.out # Src/Fortran90/Dp/sldriver/slbrows.hlp # Src/Fortran90/Dp/sldriver/slconsts.f # Src/Fortran90/Dp/sldriver/sld02k.hlp # Src/Fortran90/Dp/sldriver/sldriver.f # Src/Fortran90/Dp/sldriver/slhelp0.hlp # Src/Fortran90/Dp/sldriver/slpset.f # Src/Fortran90/Dp/sldriver/sltstpak.f # Src/Fortran90/Dp/sldriver/sltstvar.f # Src/Fortran90/Dp/sldriver/slutil.f # Src/Fortran90/Dp/sldriver/solvrs.f # Src/Fortran90/Dp/sldriver/standard.lst # Src/Fortran90/Dp/sldriver/standard/ # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/ # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.01 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.02 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.07 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.15 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.20 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.21 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.22 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.28 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.29 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.35 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.36 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.41 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.01 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.02 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.05 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.07 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.15 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.18 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.19 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.20 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.21 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.22 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.23 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.28 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.29 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.30 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.32 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.34 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.35 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.36 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.40 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.41 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.43 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/sdtru.56 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/sdtru.57 # Src/Fortran90/Dp/sledge/ # Src/Fortran90/Dp/sledge/sledgemd.f # Src/Fortran90/Dp/sleign/ # Src/Fortran90/Dp/sleign/sleignmd.f # Src/Fortran90/Dp/sleign2/ # Src/Fortran90/Dp/sleign2/sleig2md.f # This archive created: Fri Oct 22 10:00:04 1999 export PATH; PATH=/bin:$PATH if test ! -d 'Doc' then mkdir 'Doc' fi cd 'Doc' if test ! -d 'EXTRAS' then mkdir 'EXTRAS' fi cd 'EXTRAS' if test -f 'drived.f' then echo shar: will not over-write existing file "'drived.f'" else cat << SHAR_EOF > 'drived.f' PROGRAM DRIVE C C ********** C OCTOBER 15, 1995; P.B. BAILEY, W.N. EVERITT, B. GARBOW AND A. ZETTL C ********** C This program solves the boundary value problem defined by C the differential equation C C -(py')' + q*y = lambda*w*y C C and appropriate boundary conditions. If the problem is regular, C the boundary conditions can be of periodic type. C C Program usage is facilitated by a large HELP subroutine. C C ********** C .. Scalars in Common .. INTEGER IND,MDTHZ LOGICAL ADDD DOUBLE PRECISION AA,BB,CC,DTHDAA,DTHDBB,EPSMIN,HPI,PI,THETU,THETV, 1 TMID,TWOPI,UB,UL,UR,VB,VL,VR,Z C .. C .. Local Scalars .. INTEGER I,I1,I2,IFLAG,INTAB,NANS,NEND,NIVP,NUMEIG,NUMEIG1,NUMEIG2 LOGICAL REGA,REGB,EIGV,PEIGF,PERIOD,RITE,SINGA,SINGB, 1 SKIPB,WREGA,WREGB,YEH CHARACTER*1 ANSCH,HQ,YN CHARACTER*9 INFM,INFP CHARACTER*19 FILLA,FILLB CHARACTER*32 CHA,CHB,CHANS,CH1,CH2,CH3,CH4,CH5,CH6,FMT,TAPE2 CHARACTER*70 CHTXT DOUBLE PRECISION A,ALFA,ALFA1,ALFA2,A1,A2,B,BETA,BETA1,BETA2, 1 B1,B2,CIRCLA,CIRCLB,EIG,OSCILA,OSCILB,P0ATA,P0ATB, 2 QFATA,QFATB,SINGATA,SINGATB,THA,THB,TOL,TOLL C .. C .. Local Arrays .. INTEGER ICOL(2),IIS(50) CHARACTER*2 COL(32) CHARACTER*39 BLNK(2),STAR(2),STR(2) DOUBLE PRECISION EES(50),SLFN(9),TTS(50) C .. C .. External Subroutines .. EXTERNAL DRAW,EXAMP,HELP,LSTDIR,SLEIGN2,PERIO C .. C .. External Functions .. CHARACTER*32 FMT2 EXTERNAL FMT2 C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,ATAN2,MIN,MOD C .. C .. Common blocks .. COMMON /EPP2/CC,UL,UR,VL,VR,UB,VB,IND COMMON /RNDOFF/EPSMIN COMMON /ZEE/Z COMMON /PIE/PI,TWOPI,HPI COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ COMMON /THET/THETU,THETV C .. DATA COL/'01','02','03','04','05','06','07','08','09','10','11', 1 '12','13','14','15','16','17','18','19','20','21','22', 2 '23','24','25','26','27','28','29','30','31','32'/ C CALL EXAMP() C WRITE(*,*) WRITE(*,*) ' This program solves the boundary value problem ' WRITE(*,*) ' defined by the differential equation ' WRITE(*,*) WRITE(*,*) ' -(py'')'' + q*y = lambda*w*y ' WRITE(*,*) WRITE(*,*) ' together with appropriate boundary conditions. ' WRITE(*,*) WRITE(*,*) ' HELP may be called at any point where the program ' WRITE(*,*) ' halts and displays (h?) by pressing "h ". ' WRITE(*,*) ' To RETURN from HELP, press "r ". ' WRITE(*,*) ' To QUIT at any program halt, press "q ". ' WRITE(*,*) ' WOULD YOU LIKE AN OVERVIEW OF HELP ? (Y/N) (h?) ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H' .OR. HQ.EQ.'y' .OR. HQ.EQ.'Y') 1 CALL HELP(1) WRITE(*,*) WRITE(*,*) ' DO YOU REQUIRE INFORMATION ON THE RANGE OF ' WRITE(*,*) ' BOUNDARY CONDITIONS AVAILABLE ? (Y/N) (h?) ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H' .OR. HQ.EQ.'y' .OR. HQ.EQ.'Y') 1 CALL HELP(7) 10 CONTINUE WRITE(*,*) ' DO YOU WANT A RECORD KEPT OF THE PROBLEMS ' WRITE(*,*) ' AND RESULTS ? (Y/N) (h?) ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(8) GO TO 10 END IF READ(CHANS,9020) YN RITE = YN.EQ.'y' .OR. YN.EQ.'Y' .OR. YN.EQ.'yes' .OR. YN.EQ.'YES' IF (RITE) THEN 20 CONTINUE WRITE(*,*) ' SPECIFY NAME OF THE OUTPUT RECORD FILE: (h?) ' READ(*,9010) CHANS IF (CHANS.EQ.'q' .OR. CHANS.EQ.'Q') THEN GO TO 460 ELSE IF (CHANS.EQ.'h' .OR. CHANS.EQ.'H') THEN CALL HELP(8) GO TO 20 ELSE TAPE2 = CHANS WRITE(*,*) ' ENTER SOME HEADER LINE (<=70 CHARACTERS): ' WRITE(*,*) READ(*,9030) CHTXT END IF C OPEN(2,FILE=TAPE2,STATUS='NEW') C WRITE(2,*) ' ',TAPE2 WRITE(2,*) WRITE(2,*) CHTXT WRITE(2,*) END IF C OPEN(21,FILE='test.out') C C DEFINITIONS OF SOME STRINGS. C INFP = '+INFINITY' INFM = '-INFINITY' CH1 = 'REGULAR * ' CH2 = 'WEAKLY REGULAR * ' CH3 = 'LIMIT CIRCLE, NON-OSCILLATORY * ' CH4 = 'LIMIT CIRCLE, OSCILLATORY * ' CH5 = 'LIMIT POINT * ' CH6 = 'UNSPEC.(NOT LCO), DEFAULT B.C.* ' STAR(1) = ' **************************************' STAR(2) = '***************************************' BLNK(1) = ' * ' BLNK(2) = ' *' FILLA = '*******************' FILLB = ' *' C 30 CONTINUE SKIPB = .FALSE. C 40 CONTINUE WRITE(*,*) ' ************************************************** ' WRITE(*,*) ' * INDICATE THE KIND OF PROBLEM INTERVAL (a,b): * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (CHECK THAT THE COEFFICIENTS p,q,w ARE WELL * ' WRITE(*,*) ' * DEFINED THROUGHOUT THE INTERVAL open(a,b).) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) FINITE, (a,b) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) SEMI-INFINITE, (a,+INFINITY) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) SEMI-INFINITE, (-INFINITY,b) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (4) DOUBLY INFINITE, (-INFINITY,+INFINITY) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ************************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(9) GO TO 40 END IF READ(CHANS,'(I32)') INTAB IF (RITE) THEN IF (INTAB.EQ.1) WRITE(2,*) ' The interval is (a,b) .' IF (INTAB.EQ.2) WRITE(2,*) ' The interval is (a,+inf).' IF (INTAB.EQ.3) WRITE(2,*) ' The interval is (-inf,b). ' IF (INTAB.EQ.4) WRITE(2,*) ' The interval is (-inf,+inf).' END IF IF (INTAB.LT.1 .OR. INTAB.GT.4) GO TO 40 C 50 CONTINUE WRITE(*,*) P0ATA = -1.0D0 QFATA = 1.0D0 SINGATA = -1.0D0 CIRCLA = -1.0D0 OSCILA = -1.0D0 REGA = .FALSE. WREGA = .FALSE. SINGA = .FALSE. C IF (INTAB.EQ.1 .OR. INTAB.EQ.2) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C 60 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * INPUT a: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' a = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(10) GO TO 60 END IF READ(CHANS,'(F32.0)') A IF (RITE) WRITE(2,*) ' a = ',A IF (INTAB.EQ.2) B = A + 1.0D0 END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C 70 CONTINUE STR(1) = ' * IS THIS PROBLEM: ' STR(2) = ' *' WRITE(*,9110) STAR WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (1) REGULAR AT a ? ' STR(2) = ' *' WRITE(*,9110) STR STR(1) = ' * (I.E., THE FUNCTIONS p, q, & w' STR(2) = ' ARE BOUNDED CONTINUOUS NEAR a; *' WRITE(*,9110) STR STR(1) = ' * p & w ARE POSITIVE AT a.) ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (2) WEAKLY REGULAR AT a ? ' STR(2) = ' *' WRITE(*,9110) STR STR(1) = ' * (I.E., THE FUNCTIONS 1/p, q, &' STR(2) = ' w ALL ARE FINITELY INTEGRABLE ON *' WRITE(*,9110) STR STR(1) = ' * SOME INTERVAL [a,a+e] FOR e >' STR(2) = ' 0; p & w ARE POSITIVE NEAR a.) *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (3) LIMIT CIRCLE, NON-OSCILLATORY ' STR(2) = 'AT a ? *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (4) LIMIT CIRCLE, OSCILLATORY AT a' STR(2) = ' ? *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (5) LIMIT POINT AT a ? ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (6) NOT SPECIFIED (BUT NOT LIMIT C' STR(2) = 'IRCLE OSCILLATORY) WITH DEFAULT *' WRITE(*,9110) STR STR(1) = ' * BOUNDARY CONDITION AT a ? ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * ENTER THE NUMBER OF YOUR CHOICE: (h)' STR(2) = '? *' WRITE(*,9110) STR WRITE(*,9110) STAR WRITE(*,*) C C SPECIFY TYPE OF BOUNDARY CONDITION AT a. C READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(4) GO TO 70 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.6) GO TO 70 C C SET CHARACTER STRING CHA ACCORDING TO BOUNDARY CONDITION AT a. C IF (NANS.EQ.1) THEN REGA = .TRUE. CHA = CH1 IF (RITE) WRITE(2,*) ' Endpoint a is Regular. ' ELSE IF (NANS.EQ.2) THEN WREGA = .TRUE. CHA = CH2 IF (RITE) WRITE(2,*) ' Endpoint a is Weakly Regular. ' ELSE IF (NANS.EQ.3) THEN CIRCLA = 1.0D0 CHA = CH3 IF (RITE) WRITE(2,*) ' Endpoint a is Limit Circle,', 1 ' Non-Oscillatory. ' ELSE IF (NANS.EQ.4) THEN CIRCLA = 1.0D0 OSCILA = 1.0D0 CHA = CH4 IF (RITE) WRITE(2,*) ' Endpoint a is Limit Circle,', 1 ' Oscillatory. ' ELSE IF (NANS.EQ.5) THEN CHA = CH5 IF (RITE) WRITE(2,*) ' Endpoint a is Limit Point. ' ELSE CHA = CH6 IF (RITE) WRITE(2,*) ' Endpoint a is Singular, unspecified. ' END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C IF (.NOT.REGA .AND. INTAB.LE.2) THEN 80 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * IS p = 0. AT a ? (Y/N) (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(11) GO TO 80 END IF READ(CHANS,9020) YN YEH = YN.EQ.'y' .OR. YN.EQ.'Y' IF (.NOT.(YEH .OR. YN.EQ.'n' .OR. YN.EQ.'N')) GO TO 80 IF (YEH) P0ATA = 1.0D0 IF (RITE) THEN IF (YEH) THEN WRITE(2,*) ' p is zero at a. ' ELSE WRITE(2,*) ' p is not zero at a. ' END IF END IF 90 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * ARE THE COEFFICIENT FUNCTIONS q & w * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * FINITE AT THE ENDPOINT a ? (Y/N) (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(11) GO TO 90 END IF READ(CHANS,9020) YN YEH = YN.EQ.'y' .OR. YN.EQ.'Y' IF (.NOT.(YEH .OR. YN.EQ.'n' .OR. YN.EQ.'N')) GO TO 90 IF (.NOT.YEH) QFATA = -1.0D0 IF (RITE) THEN IF (YEH) THEN WRITE(2,*) ' q and w are both finite at a. ' ELSE WRITE(2,*) ' q and w are not both finite at a. ' END IF END IF IF (P0ATA.LT.0.0D0 .AND. QFATA.GT.0.0D0) THEN IF (RITE) 1 WRITE(2,*) 'This problem appears to be Regular at a.' WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * THIS PROBLEM APPEARS TO BE REGULAR AT a. * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) CHA = CH1 END IF END IF SINGA = .NOT.(REGA .OR. WREGA) IF (SINGA) SINGATA = 1.0D0 IF (SKIPB) GO TO 150 C 100 CONTINUE WRITE(*,*) P0ATB = -1.0D0 QFATB = 1.0D0 SINGATB = -1.0D0 CIRCLB = -1.0D0 OSCILB = -1.0D0 REGB = .FALSE. WREGB = .FALSE. SINGB = .FALSE. C IF (INTAB.EQ.1 .OR. INTAB.EQ.3) THEN 110 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * INPUT b: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' b = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(10) GO TO 110 END IF READ(CHANS,'(F32.0)') B IF (RITE) WRITE(2,*) ' b = ',B IF (INTAB.EQ.3) A = B - 1.0D0 END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C 120 CONTINUE STR(1) = ' * IS THIS PROBLEM: ' STR(2) = ' *' WRITE(*,9110) STAR WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (1) REGULAR AT b ? ' STR(2) = ' *' WRITE(*,9110) STR STR(1) = ' * (I.E., THE FUNCTIONS p, q, & w' STR(2) = ' ARE BOUNDED CONTINUOUS NEAR b; *' WRITE(*,9110) STR STR(1) = ' * p & w ARE POSITIVE AT b.) ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (2) WEAKLY REGULAR AT b ? ' STR(2) = ' *' WRITE(*,9110) STR STR(1) = ' * (I.E., THE FUNCTIONS 1/p, q, &' STR(2) = ' w ALL ARE FINITELY INTEGRABLE ON *' WRITE(*,9110) STR STR(1) = ' * SOME INTERVAL [b-e,b] FOR e >' STR(2) = ' 0; p & w ARE POSITIVE NEAR b.) *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (3) LIMIT CIRCLE, NON-OSCILLATORY ' STR(2) = 'AT b ? *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (4) LIMIT CIRCLE, OSCILLATORY AT b' STR(2) = ' ? *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (5) LIMIT POINT AT b ? ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (6) NOT SPECIFIED (BUT NOT LIMIT C' STR(2) = 'IRCLE OSCILLATORY) WITH DEFAULT *' WRITE(*,9110) STR STR(1) = ' * BOUNDARY CONDITION AT b ? ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * ENTER THE NUMBER OF YOUR CHOICE: (h?' STR(2) = ') *' WRITE(*,9110) STR WRITE(*,9110) STAR WRITE(*,*) C C SPECIFY TYPE OF BOUNDARY CONDITION AT b. C READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(4) GO TO 120 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.6) GO TO 120 C C SET CHARACTER STRING CHB ACCORDING TO BOUNDARY CONDITION AT b. C WRITE(*,*) IF (NANS.EQ.1) THEN REGB = .TRUE. CHB = CH1 IF (RITE) WRITE(2,*) ' Endpoint b is Regular. ' ELSE IF (NANS.EQ.2) THEN WREGB = .TRUE. CHB = CH2 IF (RITE) WRITE(2,*) ' Endpoint b is Weakly Regular. ' ELSE IF (NANS.EQ.3) THEN CIRCLB = 1.0D0 CHB = CH3 IF (RITE) WRITE(2,*) ' Endpoint b is Limit Circle,', 1 ' Non-Oscillatory. ' ELSE IF (NANS.EQ.4) THEN CIRCLB = 1.0D0 OSCILB = 1.0D0 CHB = CH4 IF (RITE) WRITE(2,*) ' Endpoint b is Limit Circle,', 1 ' Oscillatory. ' ELSE IF (NANS.EQ.5) THEN CHB = CH5 IF (RITE) WRITE(2,*) ' Endpoint b is Limit Point. ' ELSE CHB = CH6 IF (RITE) WRITE(2,*) ' Endpoint b is Singular, unspecified. ' END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C IF (.NOT.REGB .AND. (INTAB.EQ.1 .OR. INTAB.EQ.3)) THEN 130 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * IS p = 0. AT b ? (Y/N) (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(11) GO TO 130 END IF READ(CHANS,9020) YN YEH = YN.EQ.'y' .OR. YN.EQ.'Y' IF (.NOT.(YEH .OR. YN.EQ.'n' .OR. YN.EQ.'N')) GO TO 130 IF (YEH) P0ATB = 1.0D0 IF (RITE) THEN IF (YEH) THEN WRITE(2,*) ' p is zero at b. ' ELSE WRITE(2,*) ' p is not zero at b. ' END IF END IF 140 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * ARE THE COEFFICIENT FUNCTIONS q & w * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * FINITE AT THE ENDPOINT b ? (Y/N) (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(11) GO TO 140 END IF READ(CHANS,9020) YN YEH = YN.EQ.'y' .OR. YN.EQ.'Y' IF (.NOT.(YEH .OR. YN.EQ.'n' .OR. YN.EQ.'N')) GO TO 140 IF (.NOT.YEH) QFATB = -1.0D0 IF (RITE) THEN IF (YEH) THEN WRITE(2,*) ' q and w are both finite at b. ' ELSE WRITE(2,*) ' q and w are not both finite at b. ' END IF END IF IF (P0ATB.LT.0.0D0 .AND. QFATB.GT.0.0D0) THEN IF (RITE) 1 WRITE(2,*) 'This problem appears to be Regular at b.' WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * THIS PROBLEM APPEARS TO BE REGULAR AT b. * ' WRITE(*,*) ' ********************************************* ' CHB = CH1 END IF END IF SINGB = .NOT.(REGB .OR. WREGB) IF (SINGB) SINGATB = 1.0D0 150 CONTINUE WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) ' ************************************************ ' WRITE(*,*) ' * THIS PROBLEM IS ON THE INTERVAL * ' WRITE(*,*) ' * * ' IF (INTAB.EQ.1) THEN WRITE(*,9070) A,B WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPOINT a IS ',CHA WRITE(*,*) ' * ',FILLB IF (P0ATA.GT.0.0D0) THEN WRITE(*,*) ' * p IS ZERO AT a ',FILLB WRITE(*,*) ' * ',FILLB END IF IF (QFATA.LT.0.0D0) THEN WRITE(*,*) ' * q & w ARE NOT BOUNDED AT a ',FILLB WRITE(*,*) ' * ',FILLB END IF WRITE(*,*) ' * ENDPOINT b IS ',CHB WRITE(*,*) ' * ',FILLB IF (P0ATB.GT.0.0D0) THEN WRITE(*,*) ' * p IS ZERO AT b ',FILLB WRITE(*,*) ' * ',FILLB END IF IF (QFATB.LT.0.0D0) THEN WRITE(*,*) ' * q & w ARE NOT BOUNDED AT b ',FILLB WRITE(*,*) ' * ',FILLB END IF ELSE IF (INTAB.EQ.2) THEN WRITE(*,9080) A,INFP WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPOINT a IS ',CHA WRITE(*,*) ' * ',FILLB IF (P0ATA.GT.0.0D0) THEN WRITE(*,*) ' * p IS ZERO AT a ',FILLB WRITE(*,*) ' * ',FILLB END IF IF (QFATA.LT.0.0D0) THEN WRITE(*,*) ' * q & w ARE NOT BOUNDED AT a ',FILLB WRITE(*,*) ' * ',FILLB END IF WRITE(*,*) ' * ENDPT +INF IS ',CHB WRITE(*,*) ' * ',FILLB ELSE IF (INTAB.EQ.3) THEN WRITE(*,9090) INFM,B WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPT -INF IS ',CHA WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPOINT b IS ',CHB WRITE(*,*) ' * ',FILLB IF (P0ATB.GT.0.0D0) THEN WRITE(*,*) ' * p IS ZERO AT b ',FILLB WRITE(*,*) ' * ',FILLB END IF IF (QFATB.LT.0.0D0) THEN WRITE(*,*) ' * q & w ARE NOT BOUNDED AT b ',FILLB WRITE(*,*) ' * ',FILLB END IF ELSE WRITE(*,9100) INFM,INFP WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPT -INF IS ',CHA WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPT +INF IS ',CHB WRITE(*,*) ' * ',FILLB END IF WRITE(*,*) ' * IS THIS THE PROBLEM YOU WANT ? (Y/N) (h?) * ' WRITE(*,*) ' ************************************************ ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 150 END IF READ(CHANS,9020) YN IF (YN.NE.'y' .AND. YN.NE.'Y') THEN 160 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * DO YOU WANT TO RE-DO * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) ENDPOINT a * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) ENDPOINT b * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) BOTH ENDPOINTS a AND b ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 160 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.3) GO TO 160 IF (NANS.EQ.1) THEN SKIPB = .TRUE. IF (RITE) WRITE(2,*) ' Redo endpoint a. ' GO TO 50 ELSE IF (NANS.EQ.2) THEN IF (RITE) WRITE(2,*) ' Redo endpoint b. ' GO TO 100 ELSE IF (RITE) WRITE(2,*) ' Redo both endpoints a and b. ' GO TO 30 END IF END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C C AT THIS POINT THE DIFFERENTIAL EQUATION AND THE INTERVAL OF C INTEREST HAVE BEEN DEFINED AND CHARACTERIZED. C 170 CONTINUE IF (RITE) WRITE(2,*) '----------------------------------------' IF (RITE) WRITE(2,*) WRITE(*,*) WRITE(*,*) ' *************************************************' WRITE(*,*) ' * DO YOU WANT TO COMPUTE *' WRITE(*,*) ' * *' WRITE(*,*) ' * (1) AN EIGENVALUE, OR SERIES OF EIGENVALUES *' WRITE(*,*) ' * *' WRITE(*,*) ' * (2) SOLUTION TO AN INITIAL VALUE PROBLEM ? *' WRITE(*,*) ' * *' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) *' WRITE(*,*) ' *************************************************' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 170 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.2) GO TO 170 EIGV = .TRUE. IF (NANS.EQ.2) THEN EIGV = .FALSE. GO TO 350 END IF C C THIS IS THE ENTRY POINT FOR COMPUTING A NEW EIGENVALUE C OR A SERIES OF EIGENVALUES. C 180 CONTINUE IF ((REGA .OR. WREGA) .AND. (REGB .OR. WREGB)) THEN WRITE(*,*) ' ******************************************** ' WRITE(*,*) ' * IS THE BOUNDARY CONDITION PERIODIC ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (I.E., y(b) = c*y(a) * ' WRITE(*,*) ' * & p(b)*y''(b) = (1/c)*p(a)*y''(a) ) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * ANSWER (Y/N): (h?) * ' WRITE(*,*) ' ******************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 180 END IF READ(CHANS,9020) YN PERIOD = YN.EQ.'y' .OR. YN.EQ.'Y' END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) IF (PERIOD) GO TO 310 IF (SINGATA.LT.0.0D0) THEN 190 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * IS THE BOUNDARY CONDITION AT a * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) THE DIRICHLET CONDITION * ' WRITE(*,*) ' * (I.E., y(a) = 0.0) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) THE NEUMANN CONDITION * ' WRITE(*,*) ' * (I.E., y''(a) = 0.0) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) A MORE GENERAL LINEAR * ' WRITE(*,*) ' * BOUNDARY CONDITION * ' WRITE(*,*) ' * A1*[y(a)] + A2*[py''](a) = 0 ? *' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 190 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.3) GO TO 190 IF (NANS.EQ.1) THEN A1 = 1.0D0 A2 = 0.0D0 IF (RITE) WRITE(2,*) ' Dirichlet B.C. at a. ' ELSE IF (NANS.EQ.2) THEN A1 = 0.0D0 A2 = 1.0D0 IF (RITE) WRITE(2,*) ' Neumann B.C. at a. ' ELSE 200 CONTINUE WRITE(*,*) ' *************************************** ' WRITE(*,*) ' * CHOOSE A1,A2: (h?) * ' WRITE(*,*) ' *************************************** ' WRITE(*,*) WRITE(*,*) ' A1,A2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 200 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) A1,A2 IF (RITE) WRITE(2,*) ' A1,A2 = ',a1,a2 END IF ELSE IF (CIRCLA.GT.0.0D0) THEN 210 CONTINUE IF (RITE) THEN WRITE(2,*) ' The B.C. at a is ' WRITE(2,*) ' A1*[y,u](a) + A2*[y,v](a) = 0. ' END IF WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * THE BOUNDARY CONDITION AT a IS * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * A1*[y,u](a) + A2*[y,v](a) = 0, * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS A1 AND A2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE A1,A2: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) WRITE(*,*) ' A1,A2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 210 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) A1,A2 IF (RITE) WRITE(2,*) ' A1,A2 = ',A1,A2 END IF IF (SINGATB.LT.0.0D0) THEN 220 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * IS THE BOUNDARY CONDITION AT b * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) THE DIRICHLET CONDITION * ' WRITE(*,*) ' * (I.E., y(b) = 0.0) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) THE NEUMANN CONDITION * ' WRITE(*,*) ' * (I.E., y''(b) = 0.0) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) A MORE GENERAL LINEAR * ' WRITE(*,*) ' * BOUNDARY CONDITION * ' WRITE(*,*) ' * B1*[y(b)] + B2*[py''](b) = 0 ? *' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 220 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.3) GO TO 220 IF (NANS.EQ.1) THEN B1 = 1.0D0 B2 = 0.0D0 IF (RITE) WRITE(2,*) ' Dirichlet B.C. at b. ' ELSE IF (NANS.EQ.2) THEN B1 = 0.0D0 B2 = 1.0D0 IF (RITE) WRITE(2,*) ' Neumann B.C. at b. ' ELSE 230 CONTINUE WRITE(*,*) ' *************************************** ' WRITE(*,*) ' * CHOOSE B1,B2: (h?) * ' WRITE(*,*) ' *************************************** ' WRITE(*,*) WRITE(*,*) ' B1,B2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 230 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) B1,B2 IF (RITE) WRITE(2,*) ' B1,B2 = ',b1,b2 END IF ELSE IF (CIRCLB.GT.0.0D0) THEN 240 CONTINUE IF (RITE) THEN WRITE(2,*) ' The B.C. at b is ' WRITE(2,*) ' B1*[y,u](b) + B2*[y,v](b) = 0. ' END IF WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * THE BOUNDARY CONDITION AT b IS * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * B1*[y,u](b) + B2*[y,v](b) = 0, * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS B1 AND B2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE B1,B2: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) WRITE(*,*) ' B1,B2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 240 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) B1,B2 IF (RITE) WRITE(2,*) ' B1,B2 = ',B1,B2 END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C C THIS IS THE ENTRY POINT FOR COMPUTING AN EIGENVALUE C OR A SERIES OF EIGENVALUES IN THE NON-PERIODIC CASE. C 250 CONTINUE IF (RITE) 1 WRITE(2,*) ' *******************************'//FILLA WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * DO YOU WANT TO COMPUTE * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) A SINGLE EIGENVALUE * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) A SERIES OF EIGENVALUES ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(13) GO TO 250 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.2) GO TO 250 IF (NANS.EQ.1) THEN 260 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * INPUT NUMEIG, EIG, TOL: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) WRITE(*,*) ' NUMEIG,EIG,TOL = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(14) GO TO 260 END IF EIG = 0.0D0 TOL = 0.0D0 CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 IF (I.EQ.3) THEN I2 = ICOL(2) - ICOL(1) - 1 FMT = '(I'//COL(I1)//',1X,F'//COL(I2) 1 //'.0,1X,F'//COL(30-I1-I2)//'.0)' READ(CHANS,FMT) NUMEIG,EIG,TOL ELSE IF (I.EQ.2) THEN FMT = '(I'//COL(I1)//',1X,F'//COL(31-I1)//'.0)' READ(CHANS,FMT) NUMEIG,EIG ELSE FMT = '(I'//COL(I1)//')' READ(CHANS,FMT) NUMEIG END IF IF (RITE) WRITE(2,*) ' NUMEIG,EIG,TOL = ',NUMEIG,EIG,TOL WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C I2 = NUMEIG CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,I2,EIG,TOL,IFLAG,0,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) IFLAG = MIN(IFLAG,4) WRITE(*,*) ' *******************************'//FILLA IF (IFLAG.LE.2) THEN WRITE(*,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(*,9050) TOL,IFLAG IF (RITE) THEN WRITE(2,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(2,9050) TOL,IFLAG WRITE(2,*) ' *******************************'//FILLA END IF ELSE WRITE(*,9040) NUMEIG,IFLAG IF (RITE) WRITE(2,9040) NUMEIG,IFLAG IF (IFLAG.EQ.3) THEN WRITE(*,9230) I2 WRITE(*,9250) EIG IF (RITE) THEN WRITE(2,9230) I2 WRITE(2,9250) EIG END IF END IF WRITE(*,*) ' *******************************'//FILLA END IF 270 CONTINUE IF (IFLAG.LE.2) THEN WRITE(*,*) ' * '//FILLB WRITE(*,*) ' * PLOT EIGENFUNCTION ? (Y/N) (h?)'// 1 ' *' WRITE(*,*) ' *******************************'//FILLA WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 270 END IF READ(CHANS,9020) YN PEIGF = YN.EQ.'y' .OR. YN.EQ.'Y' IF (PEIGF) GO TO 420 END IF ELSE 280 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * INPUT NUMEIG1, NUMEIG2, TOL (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) WRITE(*,*) ' NUMEIG1,NUMEIG2,TOL = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(14) GO TO 280 END IF TOLL = 0.0D0 CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 IF (I.EQ.3) THEN I2 = ICOL(2) - ICOL(1) - 1 FMT = '(I'//COL(I1)//',1X,I'//COL(I2) 1 //',1X,F'//COL(30-I1-I2)//'.0)' READ(CHANS,FMT) NUMEIG1,NUMEIG2,TOLL ELSE FMT = '(I'//COL(I1)//',1X,I'//COL(31-I1)//')' READ(CHANS,FMT) NUMEIG1,NUMEIG2 END IF IF (RITE) WRITE(2,*) ' NUMEIG1,NUMEIG2,TOL = ', 1 NUMEIG1,NUMEIG2,TOLL C I = 0 DO 290 NUMEIG = NUMEIG1,NUMEIG2 TOL = TOLL EIG = 0.0D0 I2 = NUMEIG CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,I2,EIG,TOL,IFLAG,0,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) IFLAG = MIN(IFLAG,4) IF (IFLAG.LE.2) THEN WRITE(*,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(*,9050) TOL,IFLAG IF (RITE) THEN WRITE(2,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(2,9050) TOL,IFLAG END IF ELSE WRITE(*,9040) NUMEIG,IFLAG IF (RITE) WRITE(2,9040) NUMEIG,IFLAG IF (IFLAG.EQ.3 .AND. NUMEIG.EQ.NUMEIG2) THEN WRITE(*,9230) I2 WRITE(*,9250) EIG IF (RITE) THEN WRITE(2,9230) I2 WRITE(2,9250) EIG END IF END IF END IF I = I + 1 EES(I) = EIG TTS(I) = TOL IIS(I) = IFLAG 290 CONTINUE IF (RITE) 1 WRITE(2,*) ' *******************************'//FILLA WRITE(*,*) I = 0 DO 300 NUMEIG = NUMEIG1,NUMEIG2 I = I + 1 WRITE(*,9060) I+NUMEIG1-1,EES(I),TTS(I),IIS(I) 300 CONTINUE END IF WRITE(*,*) GO TO 430 C C THIS IS THE ENTRY POINT FOR COMPUTING AN EIGENVALUE C IN A PERIODIC TYPE PROBLEM. C 310 CONTINUE WRITE(*,*) ' ******************************************** ' WRITE(*,*) ' * IS THIS PROBLEM: * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) PERIODIC ? * ' WRITE(*,*) ' * (I.E., y(b) = y(a) * ' WRITE(*,*) ' * & p(b)*y''(b) = p(a)*y''(a) ) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) SEMI-PERIODIC ? * ' WRITE(*,*) ' * (I.E., y(b) = -y(a) * ' WRITE(*,*) ' * & p(b)*y''(b) = -p(a)*y''(a) ) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) GENERAL PERIODIC TYPE ? * ' WRITE(*,*) ' * (I.E., y(b) = c*y(a) * ' WRITE(*,*) ' * & p(b)*y''(b) = p(a)*y''(a)/c *' WRITE(*,*) ' * for some number c .NE. 0. ) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h)? * ' WRITE(*,*) ' ******************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 310 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.3) GO TO 310 IF (NANS.EQ.1) THEN CC = 1.0D0 IF (RITE) WRITE(2,*) ' The B.C. is Periodic. ' ELSE IF (NANS.EQ.2) THEN CC = -1.0D0 IF (RITE) WRITE(2,*) ' The B.C. is Semi-Periodic. ' ELSE 320 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * INPUT c: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' c = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 320 END IF READ(CHANS,'(F32.0)') CC IF (RITE) WRITE(2,*) ' The B.C. is General Periodic type. ' IF (RITE) WRITE(2,*) ' Parameter c = ',CC END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 330 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * INPUT NUMEIG,TOL: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) WRITE(*,*) ' NUMEIG,TOL = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(17) GO TO 330 END IF TOL = 0.0D0 CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 IF (I.EQ.2) THEN FMT = '(I'//COL(I1)//',1X,F'//COL(31-I1)//'.0)' READ(CHANS,FMT) NUMEIG,TOL ELSE FMT = '(I'//COL(I1)//')' READ(CHANS,FMT) NUMEIG END IF IF (RITE) WRITE(2,*) ' NUMEIG,TOL = ',NUMEIG,TOL IF (NUMEIG.LT.0) THEN WRITE(*,*) ' NUMEIG MUST BE .GE. 0 ' GO TO 330 END IF CALL PERIO(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB, 1 A1,A2,B1,B2,NUMEIG,EIG,TOL,IFLAG,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) IF (IFLAG.NE.1) IFLAG = 2 WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*)' **************************************************' WRITE(*,*)' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(*,9050) TOL,IFLAG WRITE(*,*)' **************************************************' IF (RITE) WRITE(2,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG IF (RITE) WRITE(2,9050) TOL,IFLAG WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 340 CONTINUE WRITE(*,*) WRITE(*,*) ' *************************************************' WRITE(*,*) ' * PLOT EIGENFUNCTION ? (Y/N) (h?) *' WRITE(*,*) ' *************************************************' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 340 END IF READ(CHANS,9020) YN PEIGF = YN.EQ.'y' .OR. YN.EQ.'Y' IF (PEIGF) THEN THA = ATAN2(VB,CC-UB) IF (THA.LT.0.0D0) THA = THA + PI THB = ATAN(CC*CC*TAN(THA)) IF (THB.LE.0.0D0) THB = THB + PI I = MOD(NUMEIG,2) IF ((CC.GT.0.0D0 .AND. I.EQ.1) .OR. 1 (CC.LT.0.0D0 .AND. I.EQ.0)) NUMEIG = NUMEIG + 1 A1 = COS(THA) A2 = -SIN(THA) B1 = COS(THB) B2 = -SIN(THB) SLFN(1) = 0.0D0 SLFN(2) = -1.0D0 SLFN(3) = THA SLFN(4) = 0.0D0 SLFN(5) = 1.0D0 SLFN(6) = THB SLFN(7) = 0.0D0 SLFN(8) = .00001 SLFN(9) = Z GO TO 420 END IF C C END OF COMPUTING AN EIGENVALUE. C IF (RITE) WRITE(2,*) ' *******************************'//FILLA GO TO 430 C C THIS IS THE ENTRY POINT FOR PLOTTING A NEW INITIAL VALUE PROBLEM. C 350 CONTINUE WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) ' *********************************************** ' WRITE(*,*) ' * DO YOU WANT TO COMPUTE THE SOLUTION TO: * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) AN INITIAL VALUE PROBLEM FROM ONE * ' WRITE(*,*) ' * END OF THE INTERVAL TO THE OTHER * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) INITIAL VALUE PROBLEMS FROM BOTH * ' WRITE(*,*) ' * ENDS TO A MIDPOINT ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' *********************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 350 END IF READ(CHANS,'(I32)') NIVP IF (NIVP.LT.1 .OR. NIVP.GT.2) GO TO 350 IF (NIVP.EQ.1) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 360 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * WHICH IS THE INITIAL POINT: a OR b ? (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) WRITE(*,*) ' INITIAL POINT IS ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 360 END IF READ(CHANS,9020) ANSCH IF (ANSCH.EQ.'a' .OR. ANSCH.EQ.'A') THEN NEND = 1 IF (RITE) WRITE(2,*) ' The Initial Point for this', 1 ' Initial Value Problem is a. ' IF (SINGATA.LT.0.0D0 .OR. CIRCLA.GT.0.0D0) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 370 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************ ' WRITE(*,*) ' * THE INITIAL CONDITIONS AT a ARE * ' WRITE(*,*) ' * * ' IF (SINGATA.LT.0.0D0) THEN WRITE(*,*) ' * y(a)=alfa1, py''(a)=alfa2 *' ELSE WRITE(*,*) ' * [y,u](a)=alfa1, [y,v](a)=alfa2 * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS alfa1, alfa2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE alfa1,alfa2: (h?) * ' WRITE(*,*) ' ************************************ ' WRITE(*,*) WRITE(*,*) ' alfa1,alfa2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 370 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) ALFA1,ALFA2 IF (RITE) WRITE(2,*) ' alfa1,alfa2 = ',ALFA1,ALFA2 A1 = ALFA2 A2 = -ALFA1 END IF ELSE IF (ANSCH.EQ.'b' .OR. ANSCH.EQ.'B') THEN NEND = 2 IF (RITE) WRITE(2,*) ' The Initial Point for this', 1 ' Initial Value Problem is b. ' IF (SINGATB.LT.0.0D0 .OR. CIRCLB.GT.0.0D0) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 380 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************ ' WRITE(*,*) ' * THE INITIAL CONDITIONS AT b ARE * ' WRITE(*,*) ' * * ' IF (SINGATB.LT.0.0D0) THEN WRITE(*,*) ' * y(b)=beta1, py''(b)=beta2 *' ELSE WRITE(*,*) ' * [y,u](b)=beta1, [y,v](b)=beta2 * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS beta1, beta2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE beta1,beta2: (h?) * ' WRITE(*,*) ' ************************************ ' WRITE(*,*) WRITE(*,*) ' beta1,beta2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 380 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) BETA1,BETA2 IF (RITE) WRITE(2,*) ' beta1,beta2 = ',BETA1,BETA2 B1 = BETA2 B2 = -BETA1 END IF END IF ELSE IF (NIVP.EQ.2) THEN NEND = 3 IF (SINGATA.LT.0.0D0 .OR. CIRCLA.GT.0.0D0) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 390 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************ ' WRITE(*,*) ' * THE INITIAL CONDITIONS AT a ARE * ' WRITE(*,*) ' * * ' IF (SINGATA.LT.0.0D0) THEN WRITE(*,*) ' * y(a)=alfa1, py''(a)=alfa2 *' ELSE WRITE(*,*) ' * [y,u](a)=alfa1, [y,v](a)=alfa2 * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS alfa1, alfa2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE alfa1,alfa2: (h?) * ' WRITE(*,*) ' ************************************ ' WRITE(*,*) WRITE(*,*) ' alfa1,alfa2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 390 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) ALFA1,ALFA2 A1 = ALFA2 A2 = -ALFA1 END IF IF (SINGATB.LT.0.0D0 .OR. CIRCLB.GT.0.0D0) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 400 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************ ' WRITE(*,*) ' * THE INITIAL CONDITIONS AT b ARE * ' WRITE(*,*) ' * * ' IF (SINGATB.LT.0.0D0) THEN WRITE(*,*) ' * y(b)=beta1, py''(b)=beta2 *' ELSE WRITE(*,*) ' * [y,u](b)=beta1, [y,v](b)=beta2 * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS beta1, beta2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE beta1,beta2: (h?) * ' WRITE(*,*) ' ************************************ ' WRITE(*,*) WRITE(*,*) ' beta1,beta2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 400 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) BETA1,BETA2 B1 = BETA2 B2 = -BETA1 END IF END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C C THIS IS THE ENTRY POINT FOR PLOTTING A SOLUTION OF THE INITIAL C VALUE PROBLEM AFTER THE EIGENPARAMETER HAS BEEN CHOSEN. C 410 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************************ ' WRITE(*,*) ' * WHAT VALUE SHOULD BE USED FOR THE * ' WRITE(*,*) ' * EIGENPARAMETER, EIG ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * INPUT EIG = (h?) * ' WRITE(*,*) ' ************************************************ ' WRITE(*,*) WRITE(*,*) ' EIG = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 410 END IF READ(CHANS,'(F32.0)') EIG C C THE FOLLOWING CALL SETS THE STAGE IN SLEIGN2 -- I.E., SAMPLES C THE COEFFICIENTS AND SETS THE INITIAL INTERVAL. C NUMEIG = 0 TOL = .001 CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,NUMEIG,EIG,TOL,IFLAG,-1,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) IF (NIVP.EQ.1 .AND. NEND.EQ.1) TMID = BB IF (NIVP.EQ.1 .AND. NEND.EQ.2) TMID = AA C C ACTUALLY, WE MAY HAVE TO AVOID AA OR BB IN SOME CASES, C WHICH WILL BE TAKEN CARE OF LATER. C ALFA = 0.0D0 IF ((NIVP.EQ.1 .AND. NEND.EQ.1 .AND. .NOT.SINGA) .OR. NIVP.EQ.2) 1 ALFA = SLFN(3) BETA = PI IF ((NIVP.EQ.1 .AND. NEND.EQ.2 .AND. .NOT.SINGB) .OR. NIVP.EQ.2) 1 BETA = SLFN(6) SLFN(3) = ALFA SLFN(6) = BETA SLFN(4) = 0.0D0 SLFN(7) = 0.0D0 SLFN(8) = .01 C C THE FOLLOWING CALL COMPUTES VALUES OF THE SOLUTION FOR PLOTTING. C 420 CONTINUE WRITE(*,*) CALL DRAW(A1,A2,B1,B2,NUMEIG,EIG,SLFN,SINGATA,SINGATB,CIRCLA, 1 CIRCLB,OSCILA,OSCILB,REGA,REGB,NIVP,NEND,EIGV,RITE) WRITE(*,*) C 430 CONTINUE IF (EIGV) THEN WRITE(*,*) ' Press any key to continue. ' READ(*,9010) CHANS 440 CONTINUE CALL CHOICE(1) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 440 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.5) GO TO 440 IF (NANS.EQ.1 .AND. PERIOD) GO TO 330 IF (NANS.EQ.1 .AND. .NOT.PERIOD) GO TO 250 IF (NANS.EQ.2) GO TO 180 IF (NANS.EQ.3) GO TO 30 EIGV = .FALSE. IF (NANS.EQ.4) GO TO 350 GO TO 460 ELSE 450 CONTINUE WRITE(*,*) ' Press any key to continue. ' READ(*,9010) CHANS CALL CHOICE(2) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 450 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.5) GO TO 450 IF (NANS.EQ.1) GO TO 410 IF (NANS.EQ.2) GO TO 350 IF (NANS.EQ.3) GO TO 30 EIGV = .TRUE. IF (NANS.EQ.4) GO TO 180 END IF 460 CONTINUE CLOSE(21) CLOSE(2) STOP 9010 FORMAT(A32) 9020 FORMAT(A1) 9030 FORMAT(A70) 9040 FORMAT(1X,' NUMEIG = ',I5,' IFLAG = ',I3) 9050 FORMAT(1X,' * TOL = ',E14.5,2X,' IFLAG = ',I3,' *') 9060 FORMAT(1X,' NUMEIG = ',I5,2X,' EIG = ',E18.9,2X,' TOL = ', 1 E14.5,' IFLAG = ',I3) 9070 FORMAT(1X,1X,6H* (,F12.7,1H,,F12.7,1H),' *') 9080 FORMAT(1X,1X,6H* (,F12.7,1H,,A12 ,1H),' *') 9090 FORMAT(1X,1X,6H* (,A12 ,1H,,F12.7,1H),' *') 9100 FORMAT(1X,1X,6H* (,A12 ,1H,,A12 ,1H),' *') 9110 FORMAT(1X,2A39) 9230 FORMAT(1X,' * THERE SEEMS TO BE NO EIGENVALUE OF INDEX *'/ 1 1X,' * GREATER THAN',I5,' *') 9250 FORMAT(1X,' * THERE MAY BE A CONTINUOUS SPECTRUM BEGINNING *'/ 1 1X,' * AT ABOUT',1PE8.1,' *') END SUBROUTINE CHOICE(I) INTEGER I C ********** C THIS PROGRAM DISPLAYS THE CHOICES FOR PROBLEM CONTINUATION. C ********** WRITE(*,*) ' *********************************************** ' WRITE(*,*) ' * WHAT WOULD YOU LIKE TO DO NOW ? * ' WRITE(*,*) ' * * ' IF (I.EQ.1) THEN WRITE(*,*) ' * (1) SAME EIGENVALUE PROBLEM, DIFFERENT * ' WRITE(*,*) ' * NUMEIG, EIG, OR TOL * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) SAME EIGENVALUE PROBLEM, SAME (a,b) * ' WRITE(*,*) ' * AND p,q,w,u,v BUT DIFFERENT * ' WRITE(*,*) ' * BOUNDARY CONDITIONS A1,A2,B1,B2 * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) INTERVAL CHANGE, PROBLEM RESTART * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (4) AN INITIAL VALUE PROBLEM * ' ELSE WRITE(*,*) ' * (1) SAME INITIAL VALUE PROBLEM, * ' WRITE(*,*) ' * DIFFERENT LAMBDA * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) NEW INITIAL VALUE PROBLEM * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) INTERVAL CHANGE, PROBLEM RESTART * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (4) AN EIGENVALUE PROBLEM * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * (5) QUIT * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' *********************************************** ' WRITE(*,*) RETURN END SUBROUTINE DRAW(A1,A2,B1,B2, 1 NUMEIG,EIG,SLFN,SINGATA,SINGATB,CIRCLA,CIRCLB, 2 OSCILA,OSCILB,REGA,REGB,NIVP,NEND,EIGV,RITE) INTEGER NUMEIG,NIVP,NEND LOGICAL REGA,REGB,EIGV,RITE DOUBLE PRECISION A1,A2,B1,B2,EIG, 1 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB DOUBLE PRECISION SLFN(10) C ********** C ********** C .. Scalars in Common .. INTEGER IND,MDTHZ LOGICAL ADDD DOUBLE PRECISION AA,BB,DTHDAA,DTHDBB,EIGSAV,HPI,PI,TMID,TWOPI C .. C .. Arrays in Common .. INTEGER NT(2) DOUBLE PRECISION TT(7,2),YY(7,3,2) C .. C .. Local Scalars .. INTEGER I,ISLFUN,JJ,K,KFLAG,MM,NF,NPTS,NV LOGICAL ENDA,ENDB,WREGA,WREGB,LCOA,LCOB,LCIRCA,LCIRCB, 1 OSCA,OSCB,SINGA,SINGB CHARACTER*1 HQ,YN CHARACTER*32 CHANS,TAPE DOUBLE PRECISION BRYU,BRYV,CA,CB,DD,EIGPI,FA,FB,FAC,FZ,GEE, 1 HU,HUI,HV,HVI,PHI,PUP,PUPI,PVP,PVPI,PYP,RHO,RHOZ, 2 SIG,SQ,T,THETAZ,TH,TI,TMP,U,UI,V,VI,X,XI,XJMP,XJMPS,Y,Z C .. C .. Local Arrays .. CHARACTER*55 XC(8) DOUBLE PRECISION SLFUN(1000,2),PLOTF(1000,6),XT(1000,2), 1 UTHZ(3),UTH(3) C .. C .. External Subroutines .. EXTERNAL DXDT,EIGENF,HELP,MESH,QPLOT,THZTOTH,UV C .. C .. Intrinsic Functions .. INTRINSIC ABS,INT C .. C .. Common blocks .. COMMON /TEMP/TT,YY,NT COMMON /DATAF/EIGSAV,IND COMMON /PIE/PI,TWOPI,HPI COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ C .. C Definition of some logicals. C SINGA = SINGATA.GT.0.0D0 WREGA = .NOT.REGA .AND. .NOT.SINGA SINGB = SINGATB.GT.0.0D0 WREGB = .NOT.REGB .AND. .NOT.SINGB LCIRCA = CIRCLA.GT.0.0D0 LCIRCB = CIRCLB.GT.0.0D0 OSCA = OSCILA.GT.0.0D0 LCOA = LCIRCA .AND. OSCA OSCB = OSCILB.GT.0.0D0 LCOB = LCIRCB .AND. OSCB EIGPI = NUMEIG*PI C C Definition of some character strings. C XC(1) = ' * (1) THE SOLUTION Y * ' XC(2) = ' * (2) THE QUASI-DERIVATIVE p*Y'' *' XC(3) = ' * (3) THE BOUNDARY CONDITION FUNCTION Y OR [Y,U] * ' XC(4) = ' * (4) THE BOUNDARY CONDITION FUNCTION p*Y'' OR [Y,V]*' XC(5) = ' * (5) THE PRUFER ANGLE, THETA * ' XC(6) = ' * (6) THE PRUFER MODULUS, RHO * ' XC(7) = ' * (1) x IN THE INTERVAL (a,b) * ' XC(8) = ' * (2) t IN THE INTERVAL (-1,1) * ' C C NV = 1 MEANS THE INDEPENDENT VARIABLE IS X. C NV = 2 MEANS THE INDEPENDENT VARIABLE IS T. C C NF = 1 MEANS THE EIGENFUNCTION Y IS WANTED. C NF = 2 MEANS THE QUASI-DERIVATIVE P*Y' IS WANTED. C NF = 3 MEANS BOUNDARY CONDITION FUNCTION Y OR [Y,U] IS WANTED. C NF = 4 MEANS BOUNDARY CONDITION FUNCTION P*Y' OR [Y,V] IS WANTED. C NF = 5 MEANS THE PRUFER ANGLE THETA IS WANTED. C NF = 6 MEANS THE PRUFER MODULUS RHO IS WANTED. C C IF AN EIGENVALUE HAS BEEN COMPUTED (EIGV = .TRUE.), C THE RELEVANT VALUES HAVE BEEN STORED IN ARRAY SLFN, AND C NEED TO BE COPIED INTO THE FIRST COLUMN OF ARRAY SLFUN. C DO 10 I = 1,9 SLFUN(I,1) = SLFN(I) 10 CONTINUE C CALL MESH(EIG,SLFUN(10,1),ISLFUN) C C THE POINTS GENERATED BY MESH MAY NOT BE WITHIN THE INTERVAL C (AA,BB). WE WANT TO ENSURE THAT WE USE ONLY SUCH POINTS C AS ARE WITHIN THE INTERVAL. C K = 0 DO 20 I = 1,ISLFUN IF (SLFUN(9+I,1).GT.AA .AND. SLFUN(9+I,1).LT.BB) THEN K = K + 1 SLFUN(9+K,1) = SLFUN(9+I,1) END IF 20 CONTINUE ISLFUN = K C C WE ALSO WANT TO BE SURE AN INITIAL ENDPOINT IS AA OR BB UNLESS THE C POINT IS LIMIT CIRCLE, AND THAT THE LAST POINT IS NOT AA OR BB. C IF ((EIGV .OR. NEND.EQ.1 .OR. NIVP.EQ.2) .AND. .NOT.LCIRCA) THEN ISLFUN = ISLFUN + 1 DO 30 I = ISLFUN,2,-1 SLFUN(9+I,1) = SLFUN(8+I,1) 30 CONTINUE SLFUN(9+1,1) = AA END IF IF ((EIGV .OR. NEND.EQ.2 .OR. NIVP.EQ.2) .AND. .NOT.LCIRCB) THEN SLFUN(ISLFUN+10,1) = BB ISLFUN = ISLFUN + 1 END IF C C NEAR AN OSCILLATORY ENDPOINT THE POINTS MAY BE SO CLOSE THAT WE C COULDN'T SEE THE ACTUAL CURVE EVEN IF WE PLOTTED IT. SO WE WANT C TO REMOVE POINTS FROM THAT END UP TO WHERE THEY ARE NOT SO CLOSE. C IF (OSCA) THEN JJ = 0 DO 40 I = 1,ISLFUN IF (ABS(SLFUN(9+I,1)-SLFUN(10+I,1)).LT.0.0D001) JJ = JJ + 1 40 CONTINUE IF (JJ.GT.0) THEN ISLFUN = ISLFUN - JJ DO 50 I = 1,ISLFUN SLFUN(9+I,1) = SLFUN(9+I+JJ,1) 50 CONTINUE END IF END IF IF (OSCB) THEN JJ = 0 DO 60 I = ISLFUN,1,-1 IF (ABS(SLFUN(9+I,1)-SLFUN(8+I,1)).LT.0.0D001) JJ = JJ + 1 60 CONTINUE IF (JJ.GT.0) ISLFUN = ISLFUN - JJ END IF C C FINALLY, IN THE CASE OF AN INITIAL VALUE PROBLEM, C WE CANNOT AFFORD TO INTEGRATE TO THE OTHER END B (OR A) C UNLESS BOTH ENDS ARE REGULAR. C IF (NIVP.EQ.1 .AND. .NOT.(REGA .AND. REGB)) THEN ISLFUN = ISLFUN - 1 IF (NEND.EQ.2) THEN DO 70 I = 1,ISLFUN SLFUN(9+I,1) = SLFUN(10+I,1) 70 CONTINUE END IF END IF C DO 80 I = 1,ISLFUN XT(9+I,2) = SLFUN(9+I,1) 80 CONTINUE C C WARNING: THE VALUES RETURNED IN SLFUN BY EIGENF DEPEND C ON THE VALUE OF KFLAG IN THE CALL TO EIGENF: C C IF KFLAG = 1, THE VALUES IN SLFUN(9+I,1) ARE THE C EIGENFUNCTION Y ITSELF. C C IF KFLAG = 2, THE VALUES IN THE TWO COLUMNS OF SLFUN ARE C SLFUN(9+I,1) = THETA(9+I) C SLFUN(9+I,2) = EFF(9+I) C WHERE C RHO = EXP(EFF) C Y = RHO*SIN(THETA) C P*Y' = RHO*COS(THETA)*Z C C HERE, WE SET KFLAG = 2 SO THAT EIGENF WILL RETURN EFF, ENABLING C US TO DEAL WITH IT BEFORE FORMING THE FUNCTION Y = RHO*SIN . C KFLAG = 2 EIGSAV = EIG CALL EIGENF(EIGPI,A1,A2,B1,B2,REGA,SINGA,LCIRCA,OSCA, 1 REGB,SINGB,LCIRCB,OSCB,SLFUN,ISLFUN,KFLAG) C C IT MAY HAPPEN THAT THETA(I) HAS A JUMP OF MM*PI AT TMID. C IN THIS CASE, WE NEED TO SUBTRACT MM*PI FROM THETA(I). C IF (EIGV) THEN JJ = 0 XJMPS = HPI DO 90 I = 1,ISLFUN-1 XJMP = SLFUN(10+I,1) - SLFUN(9+I,1) IF (ABS(XJMP).GT.XJMPS) THEN XJMPS = ABS(XJMP) JJ = I END IF 90 CONTINUE IF (JJ.NE.0) THEN XJMP = SLFUN(10+JJ,1) - SLFUN(9+JJ,1) MM = INT(XJMP/PI) IF ((SLFUN(10+JJ,1)-MM*PI).LT.SLFUN(9+JJ,1)) MM = MM - 1 DO 100 I = JJ,ISLFUN-1 SLFUN(10+I,1) = SLFUN(10+I,1) - MM*PI 100 CONTINUE END IF END IF C*********************************************************************** C * C SLEIGN2 NORMALIZES THE WAVEFUNCTION TO HAVE L2-NORM 1.0D0, BUT FOR AN C INITIAL VALUE PROBLEM WE WANT TO HAVE THE VALUE (Y) AND SLOPE (P*Y') C (OR [Y,U] AND [Y,V]) AT THE END TO BE THOSE SPECIFIED FOR THE C INITIAL CONDITIONS. SO HERE WE MUST RE-NORMALIZE FOR THIS PURPOSE. C C THE VALUES IN THE ARRAYS TT AND YY COME FROM THE INTEGRATIONS C IN SUBROUTINE WR. C ENDA = (NEND.EQ.1 .OR. NIVP.EQ.2) .AND. (LCIRCA .OR. WREGA) IF (ENDA) THEN NPTS = 7 IF (LCOA) NPTS = NT(1) DO 110 I = 2,NPTS T = TT(I,1) PHI = YY(I,1,1) GEE = YY(I,3,1) SIG = EXP(GEE) IF (LCIRCA) THEN CALL DXDT(T,TMP,X) CALL UV(X,U,PUP,V,PVP,HU,HV) DD = U*PVP - V*PUP SQ = SQRT(A1**2+A2**2) BRYU = -DD*SIN(PHI)*SIG*SQ BRYV = DD*COS(PHI)*SIG*SQ END IF 110 CONTINUE END IF ENDB = (NEND.EQ.2 .OR. NIVP.EQ.2) .AND. (LCIRCB .OR. WREGB) IF (ENDB) THEN NPTS = 7 IF (LCOB) NPTS = NT(2) DO 120 I = 2,NPTS T = TT(I,2) PHI = YY(I,1,2) GEE = YY(I,3,2) SIG = EXP(GEE) IF (LCIRCB) THEN CALL DXDT(T,TMP,X) CALL UV(X,U,PUP,V,PVP,HU,HV) DD = U*PVP - V*PUP SQ = SQRT(B1**2+B2**2) BRYU = -DD*SIN(PHI)*SIG*SQ BRYV = DD*COS(PHI)*SIG*SQ END IF 120 CONTINUE END IF C Z = SLFUN(9,1) ENDA = (NEND.EQ.1 .OR. NIVP.EQ.2) .AND. LCIRCA CA = 0.0D0 IF (.NOT.(EIGV .OR. ENDA) .AND. NEND.NE.2) THEN FA = SLFUN(4,1) CA = 0.5*LOG(A2**2+(A1/Z)**2) - FA END IF ENDB = (NEND.EQ.2 .OR. NIVP.EQ.2) .AND. LCIRCB CB = 0.0D0 IF (.NOT.(EIGV .OR. ENDB) .AND. NEND.NE.1) THEN FB = SLFUN(7,1) CB = 0.5*LOG(B2**2+(B1/Z)**2) - FB END IF C DO 130 I = 1,ISLFUN IF (XT(9+I,2).LE.TMID .AND. .NOT.LCIRCA) THEN SLFUN(9+I,2) = SLFUN(9+I,2) + CA ELSE IF (XT(9+I,2).GT.TMID .AND. .NOT.LCIRCB) THEN SLFUN(9+I,2) = SLFUN(9+I,2) + CB END IF 130 CONTINUE C UTHZ(2) = 0.0D0 UTHZ(3) = 0.0D0 DO 140 I = 1,ISLFUN TI = XT(9+I,2) CALL DXDT(TI,TMP,XI) XT(9+I,1) = XI THETAZ = SLFUN(9+I,1) FZ = SLFUN(9+I,2) RHOZ = EXP(FZ) Y = RHOZ*SIN(THETAZ) PYP = Z*RHOZ*COS(THETAZ) RHO = SQRT(Y**2+PYP**2) PLOTF(9+I,1) = Y PLOTF(9+I,2) = PYP PLOTF(9+I,3) = Y PLOTF(9+I,4) = PYP UTHZ(1) = THETAZ CALL THZTOTH(UTHZ,Z,UTH) TH = UTH(1) PLOTF(9+I,5) = TH PLOTF(9+I,6) = RHO C IF ((ENDA .AND. TI.LE.TMID) .OR. 1 (ENDB .AND .TI.GT.TMID)) THEN CALL UV(XI,UI,PUPI,VI,PVPI,HUI,HVI) DD = UI*PVPI - VI*PUPI BRYU = PUPI*Y - PYP*UI BRYV = PVPI*Y - PYP*VI C C RENORMALIZE. C IF (ENDA .AND. TI.LE.TMID) THEN FAC = SQRT(A1**2+A2**2) ELSE FAC = SQRT(B1**2+B2**2) END IF BRYU = FAC*BRYU BRYV = FAC*BRYV PLOTF(9+I,3) = BRYU PLOTF(9+I,4) = BRYV END IF 140 CONTINUE C C IN THE CASE OF NIVP = 2 WE HAVE COMPUTED THE SOLUTIONS C TO TWO INITIAL VALUE PROBLEMS FROM THE TWO ENDS. C IF (.NOT.ENDA .AND. .NOT.ENDB) WE SHOULD NOW HAVE C C Y(A) = -A2 (ALFA1) ; Y(B) = -B2 (BETA1) C PY'(A) = A1 (ALFA2) ; PY'(B) = B1 (BETA2) C C IT SOMETIMES HAPPENS THAT THE VALUES AT THE FINAL END HAVE GROWN C SO LARGE THAT THE REST OF THE CURVE IS TOTALLY SUBMERGED. C IN SUCH CASES WE WANT TO REMOVE THE POINTS WITH THE LARGE VALUES. C * C********************************************************************* 150 CONTINUE WRITE(*,*) ' ****************************************************' WRITE(*,*) ' * WHICH FUNCTION DO YOU WANT TO PLOT ? *' WRITE(*,*) ' * *' WRITE(*,*) XC(1) WRITE(*,*) XC(2) WRITE(*,*) XC(3) WRITE(*,*) XC(4) WRITE(*,*) XC(5) WRITE(*,*) XC(6) WRITE(*,*) ' * *' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) *' WRITE(*,*) ' ****************************************************' WRITE(*,*) READ(*,1) CHANS READ(CHANS,2) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') RETURN IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 150 END IF READ(CHANS,'(I32)') NF 160 CONTINUE WRITE(*,*) ' ****************************************************' WRITE(*,*) ' * WHICH DO YOU WANT AS THE INDEPENDENT VARIABLE ? *' WRITE(*,*) ' * *' WRITE(*,*) XC(7) WRITE(*,*) XC(8) WRITE(*,*) ' * *' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) *' WRITE(*,*) ' ****************************************************' WRITE(*,*) C READ(*,1) CHANS READ(CHANS,2) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') RETURN IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 160 END IF READ(CHANS,'(I32)') NV CALL QPLOT(ISLFUN,XT,NV,PLOTF,NF) C 170 CONTINUE WRITE(*,*) WRITE(*,*) ' DO YOU WANT TO SAVE THE PLOT FILE ? (Y/N) (h?)' READ(*,1) CHANS READ(CHANS,2) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') STOP IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 170 END IF READ(CHANS,2) YN IF (YN.EQ.'y' .OR. YN.EQ.'Y') THEN WRITE(*,*) ' SPECIFY NAME OF FILE FOR PLOTTING ' READ(*,'(A)') TAPE OPEN(1,FILE=TAPE,STATUS='NEW') DO 180 I = 1,ISLFUN WRITE(1,*) XT(9+I,NV),PLOTF(9+I,NF) 180 CONTINUE CLOSE(1) WRITE(*,*) ' THE PLOT FILE HAS BEEN WRITTEN TO ',TAPE IF (RITE) WRITE(2,*) ' The plot file has been written to ',TAPE END IF WRITE(*,*) 190 CONTINUE WRITE(*,*) ' PLOT ANOTHER FUNCTION ? (Y/N) (h?)' READ(*,1) CHANS READ(CHANS,2) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') STOP IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 190 END IF READ(CHANS,2) YN IF (YN.EQ.'y' .OR. YN.EQ.'Y') GO TO 150 RETURN 1 FORMAT(A32) 2 FORMAT(A1) END SUBROUTINE EIGENF(EIGPI,A1,A2,B1,B2,AOK,SINGA,LCIRCA,OSCA, 1 BOK,SINGB,LCIRCB,OSCB,SLFUN,ISLFUN,KFLAG) INTEGER ISLFUN,KFLAG LOGICAL AOK,SINGA,LCIRCA,OSCA,BOK,SINGB,LCIRCB,OSCB DOUBLE PRECISION EIGPI,A1,A2,B1,B2 DOUBLE PRECISION SLFUN(1000,2) C ********** C WARNING: DANGER! The array SLFUN here is two-dimensional, whereas C it is one-dimensional in subroutine SLEIGN2. C ********** C .. Scalars in Common .. INTEGER MDTHZ LOGICAL ADDD DOUBLE PRECISION AA,BB,DTHDAA,DTHDBB,HPI,PI,TMID,TWOPI C .. C .. Local Scalars .. INTEGER I,IFLAG,J,NMID LOGICAL LCIRC,OK,SING DOUBLE PRECISION DTHDAT,DTHDBT,DTHDET,EFF,T,THT,TM C .. C .. Local Arrays .. DOUBLE PRECISION ERL(3),ERR(3),YL(3),YR(3) C .. C .. External Subroutines .. EXTERNAL INTEG C .. C .. Intrinsic Functions .. INTRINSIC EXP,SIN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ C .. C C WARNING: In this program it is assumed that the points T C in SLFUN all lie within the interval (AA,BB). C C Calculate selected eigenfunction values by integration (over T). C NMID = 0 DO 10 I=1,ISLFUN IF (SLFUN(9+I,1).LE.TMID) NMID = I 10 CONTINUE IF (NMID.GT.0) THEN T = AA YL(1) = SLFUN(3,1) YL(2) = 0.0D0 YL(3) = 0.0D0 LCIRC = LCIRCA OK = AOK SING = SINGA EFF = 0.0D0 DO 20 J=1,NMID TM = SLFUN(J+9,1) IF (TM.LT.AA .OR. TM.GT.BB) THEN WRITE(*,*) ' t.lt.aa .or. t.gt.bb ' STOP END IF THT = YL(1) DTHDAT = DTHDAA*EXP(-2.0*EFF) DTHDET = YL(2) IF (TM.GT.AA) THEN CALL INTEG(T,THT,DTHDAT,DTHDET,TM,A1,A2,SLFUN(8,1), 1 YL,ERL,LCIRC,OK,SING,OSCA,IFLAG) IF (OSCA) THEN EFF = YL(3) ELSE LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YL(3) END IF END IF IF (KFLAG.EQ.1) THEN SLFUN(J+9,1) = SIN(YL(1))*EXP(EFF+SLFUN(4,1)) ELSE SLFUN(J+9,1) = YL(1) SLFUN(J+9,2) = EFF + SLFUN(4,1) END IF T = TM IF (T.GT.-1.0D0) OK = .TRUE. IF (T.LT.-0.9 .AND .OSCA) THEN OK = .FALSE. T = AA YL(1) = SLFUN(3,1) YL(2) = 0.0D0 YL(3) = 0.0D0 END IF 20 CONTINUE END IF IF (NMID.LT.ISLFUN) THEN T = BB YR(1) = SLFUN(6,1) - EIGPI YR(2) = 0.0D0 YR(3) = 0.0D0 LCIRC = LCIRCB OK = BOK SING = SINGB EFF = 0.0D0 DO 30 J=ISLFUN,NMID+1,-1 TM = SLFUN(J+9,1) IF (TM.LT.AA .OR. TM.GT.BB) THEN WRITE(*,*) ' t.lt.aa .or. t.gt.bb ' STOP END IF THT = YR(1) DTHDBT = DTHDBB*EXP(-2.0*EFF) DTHDET = YR(2) IF (TM.LT.BB) THEN CALL INTEG(T,THT,DTHDBT,DTHDET,TM,B1,B2,SLFUN(8,1), 1 YR,ERR,LCIRC,OK,SING,OSCB,IFLAG) IF (OSCB) THEN EFF = YR(3) ELSE LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YR(3) END IF END IF IF (KFLAG.EQ.1) THEN SLFUN(J+9,1) = SIN(YR(1)+EIGPI)*EXP(EFF+SLFUN(7,1)) IF (ADDD) SLFUN(J+9,1) = -SLFUN(J+9,1) ELSE SLFUN(J+9,1) = YR(1) + EIGPI IF (ADDD) SLFUN(J+9,1) = SLFUN(J+9,1) + PI IF (OSCA .OR. OSCB) SLFUN(J+9,1) = 1 SLFUN(J+9,1) - MDTHZ*PI SLFUN(J+9,2) = EFF + SLFUN(7,1) END IF T = TM IF (T.LT.1.0D0) OK = .TRUE. IF (T.GT.0.9 .AND. OSCB) THEN OK = .FALSE. T = BB YR(1) = SLFUN(6,1) - EIGPI YR(2) = 0.0D0 YR(3) = 0.0D0 END IF 30 CONTINUE END IF RETURN END SUBROUTINE FZERO(F,B,C,R,RE,AE,IFLAG) INTEGER IFLAG DOUBLE PRECISION F,B,C,R,RE,AE EXTERNAL F C ********** C ********** C .. Local Scalars .. INTEGER IC,KOUNT DOUBLE PRECISION A,ACBS,ACMB,AW,CMB,DIF,DIFS,FA,FB,FC,FX,FZ, 1 P,Q,RW,TOL,Z C .. C .. Intrinsic Functions .. INTRINSIC ABS,MAX,MIN,SIGN C .. DIF = 1000.0D0 Z = R IF (R.LE.MIN(B,C).OR.R.GE.MAX(B,C)) Z = C RW = MAX(RE,0.0D0) AW = MAX(AE,0.0D0) IC = 0 FZ = F(Z) FB = F(B) KOUNT = 2 IF (FZ*FB.LT.0.0D0) THEN C = Z FC = FZ ELSE IF (Z.NE.C) THEN FC = F(C) KOUNT = 3 IF (FZ*FC.LT.0.0D0) THEN B = Z FB = FZ END IF END IF A = C FA = FC ACBS = ABS(B-C) FX = MAX(ABS(FB),ABS(FC)) C 10 CONTINUE IF (ABS(FC).LT.ABS(FB)) THEN A = B FA = FB B = C FB = FC C = A FC = FA END IF CMB = 0.5*(C-B) ACMB = ABS(CMB) TOL = RW*ABS(B) + AW IFLAG = 1 IF (ACMB.LE.TOL) THEN IF (FB*FC.GE.0.0D0) IFLAG = 4 IF (ABS(FB).GT.FX) IFLAG = 3 RETURN END IF IFLAG = 2 IF (FB.EQ.0.0D0) RETURN IFLAG = 5 IF (KOUNT.GE.500) RETURN C P = (B-A)*FB Q = FA - FB IF (P.LT.0.0D0) THEN P = -P Q = -Q END IF A = B FA = FB IC = IC + 1 IF (IC.GE.4) THEN IF (8.0*ACMB.GE.ACBS) B = 0.5*(C+B) ELSE IC = 0 ACBS = ACMB IF (P.LE.ABS(Q)*TOL) THEN B = B + SIGN(TOL,CMB) ELSE IF (P.GE.CMB*Q) THEN B = 0.5*(C+B) ELSE B = B + P/Q END IF END IF FB = F(B) DIFS = DIF DIF = FB - FC IF (DIF.EQ.DIFS) THEN IFLAG = 6 RETURN END IF KOUNT = KOUNT + 1 IF (FB*FC.GE.0.0D0) THEN C = A FC = FA END IF GO TO 10 END subroutine help(nh) integer i,n,nh character*36 x(23),y(23) character*1 ans c GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),NH c 1 CONTINUE write(*,*) 'H1: Overview of HELP.' x(1)=' This ASCII text file is supplied a' y(1)='s a separate file with the SLEIGN2 ' x(2)='package; it can be accessed on-line ' y(2)='in both MAKEPQW (if used) and DRIVE.' x(3)=' HELP contains information to aid t' y(3)='he user in entering data on the ' x(4)='coefficient functions p,q,w; on the ' y(4)='limit circle boundary condition ' x(5)='functions u,v; on the end-point clas' y(5)='sifications of the differential ' x(6)='equation; on DEFAULT entry; on eigen' y(6)='value indexes; on IFLAG information;' x(7)='and on the general use of the progra' y(7)='m SLEIGN2. ' x(8)=' The 17 sections of HELP are: ' y(8)=' ' x(9)=' ' y(9)=' ' x(10)=' H1: Overview of HELP. ' y(10)=' ' x(11)=' H2: File name entry. ' y(11)=' ' x(12)=' H3: The differential equation. ' y(12)=' ' x(13)=' H4: End-point classification. ' y(13)=' ' x(14)=' H5: DEFAULT entry. ' y(14)=' ' x(15)=' H6: Limit-circle boundary condit' y(15)='ions. ' do 101 i = 1,15 write(*,*) x(i),y(i) 101 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' H7: General boundary conditions.' y(1)=' ' x(2)=' H8: Recording the results. ' y(2)=' ' x(3)=' H9: Type and choice of interval.' y(3)=' ' x(4)=' H10: Entry of end-points. ' y(4)=' ' x(5)=' H11: End-point values of p,q,w. ' y(5)=' ' x(6)=' H12: Initial value problems. ' y(6)=' ' x(7)=' H13: Indexing of eigenvalues. ' y(7)=' ' x(8)=' H14: Entry of eigenvalue index, i' y(8)='nitial guess, and tolerance. ' x(9)=' H15: IFLAG information. ' y(9)=' ' x(10)=' H16: Plotting. ' y(10)=' ' x(11)=' H17: Indexing of eigenvalues for ' y(11)='periodic-type problems. ' x(12)=' ' y(12)=' ' x(13)=' HELP can be accessed at each point' y(13)=' in MAKEPQW and DRIVE where the user' x(14)='is asked for input, by pressing "h <' y(14)='ENTER>"; this places the user at the' x(15)='appropriate HELP section. Once in H' y(15)='ELP, the user can scroll the further' x(16)='HELP sections by repeatedly pressing' y(16)=' "h ", or jump to a specific ' x(17)='HELP section Hn (n=1,2,...17) by typ' y(17)='ing "Hn "; to return to the ' x(18)='place in the program from which HELP' y(18)=' is called, press "r ". ' do 102 i = 1,18 write(*,*) x(i),y(i) 102 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 2 CONTINUE write(*,*) 'H2: File name entry.' x(1)=' MAKEPQW is used to create a FORTRA' y(1)='N file containing the coefficients ' x(2)='p(x),q(x),w(x), defining the differe' y(2)='ntial equation, and the boundary ' x(3)='condition functions u(x),v(x) if req' y(3)='uired. The file must be given a NEW' x(4)='filename which is acceptable to your' y(4)=' FORTRAN compiler. For example, it ' x(5)='might be called bessel.f or bessel.f' y(5)='or depending upon your compiler. ' x(6)=' The same naming considerations app' y(6)='ly if the FORTRAN file is prepared ' x(7)='other than with the use of MAKEPQW. ' y(7)=' ' do 201 i = 1,7 write(*,*) x(i),y(i) 201 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 3 CONTINUE write(*,*) 'H3: The differential equation.' x(1)=' The prompt "Input p (or q or w) ="' y(1)=' requests you to type in a FORTRAN ' x(2)='expression defining the function p(x' y(2)='), which is one of the three coeffi-' x(3)='cient functions defining the Sturm-L' y(3)='iouville differential equation ' x(4)=' ' y(4)=' ' x(5)=' -(p*y'')'' + q*y = ' y(5)=' lambda*w*y (*) ' x(6)=' ' y(6)=' ' x(7)='to be considered on some interval (a' y(7)=',b) of the real line. The actual ' x(8)='interval used in a particular proble' y(8)='m can be chosen later, and may be ' x(9)='either the whole interval (a,b) wher' y(9)='e the coefficient functions p,q,w, ' x(10)='etc. are defined or any sub-interval' y(10)=' (a'',b'') of (a,b); a = -infinity ' x(11)='and/or b = +infinity are allowable c' y(11)='hoices for the end-points. ' x(12)=' The coefficient functions p,q,w of' y(12)=' the differential equation may be ' x(13)='chosen arbitrarily but must satisfy ' y(13)='the following conditions: ' x(14)=' (1) p,q,w are real-valued througho' y(14)='ut (a,b). ' x(15)=' (2) p,q,w are piece-wise continuou' y(15)='s and defined throughout the ' x(16)=' interior of the interval (a,b)' y(16)='. ' x(17)=' (3) p and w are strictly positive ' y(17)='in (a,b). ' x(18)=' For better error analysis in the n' y(18)='umerical procedures, condition ' x(19)='(2) above is often replaced with ' y(19)=' ' x(20)=' (2'') p,q,w are four times continuo' y(20)='usly differentiable on (a,b). ' x(21)=' The behavior of p,q,w near the end' y(21)='-points a and b is critical to the ' x(22)='classification of the differential e' y(22)='quation (see H4 and H11). ' do 301 i = 1,22 write(*,*) x(i),y(i) 301 continue write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 4 CONTINUE write(*,*) 'H4: End-point classification.' x(1)=' The correct classification of the ' y(1)='end-points a and b is essential to ' x(2)='the working of the SLEIGN2 program. ' y(2)=' To classify the end-points, it is ' x(3)='convenient to choose a point c in (a' y(3)=',b); i.e., a < c < b. Subject to ' x(4)='the general conditions on the coeffi' y(4)='cient functions p,q,w (see H3): ' x(5)=' (1) a is REGULAR (say R) if -infin' y(5)='ity < a, p,q,w are piece-wise ' x(6)=' continuous on [a,c], and p(a) ' y(6)='> 0 and w(a) > 0. ' x(7)=' (2) a is WEAKLY REGULAR (say WR) i' y(7)='f -infinity < a, a is not R, and ' x(8)=' |c ' y(8)=' ' x(9)=' integral | {1/p+|q|+w} < +infi' y(9)='nity. ' x(10)=' |a ' y(10)=' ' x(11)=' ' y(11)=' ' x(12)=' If end-point a is neither R nor ' y(12)='WR, then a is SINGULAR; that is, ' x(13)=' either -infinity = a, or -infinity' y(13)=' < a and ' x(14)=' |c ' y(14)=' ' x(15)=' integral | {1/p+|q|+w} = +infi' y(15)='nity. ' x(16)=' |a ' y(16)=' ' x(17)=' (3) The SINGULAR end-point a is LI' y(17)='MIT-CIRCLE NON-OSCILLATORY (say ' x(18)=' LCNO) if for some real lambda ' y(18)='ALL real-valued solutions y of the ' x(19)=' differential equation ' y(19)=' ' x(20)=' ' y(20)=' ' x(21)=' -(p*y'')'' + q*y = ' y(21)=' lambda*w*y on (a,c] (*) ' x(22)=' ' y(22)=' ' x(23)=' satisfy the conditions: ' y(23)=' ' do 401 i = 1,23 write(*,*) x(i),y(i) 401 continue read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' |c ' y(1)=' ' x(2)=' integral | { w*y*y } < +infini' y(2)='ty, and ' x(3)=' |a ' y(3)=' ' x(4)=' y has at most a finite number ' y(4)='of zeros in (a,c]. ' x(5)=' (4) The SINGULAR end-point a is LI' y(5)='MIT-CIRCLE OSCILLATORY (say LCO) if ' x(6)='for some real lambda ALL real-valued' y(6)=' solutions of the differential ' x(7)='equation (*) satisfy the conditions:' y(7)=' ' x(8)=' |c ' y(8)=' ' x(9)=' integral | { w*y*y } < +infini' y(9)='ty, and ' x(10)=' |a ' y(10)=' ' x(11)=' y has an infinite number of ze' y(11)='ros in (a,c]. ' x(12)=' (5) The SINGULAR end-point a is LI' y(12)='MIT POINT (say LP) if for some real ' x(13)='lambda at least one solution of the ' y(13)='differential equation (*) satisfies ' x(14)='the condition: ' y(14)=' ' x(15)=' |c ' y(15)=' ' x(16)=' integral | {w*y*y} = +infinity' y(16)='. ' x(17)=' |a ' y(17)=' ' x(18)=' There is a similar classification ' y(18)='of the end-point b into one of the ' x(19)='five distinct cases R, WR, LCNO, LCO' y(19)=', LP. ' do 402 i = 1,19 write(*,*) x(i),y(i) 402 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' Although the classification of sin' y(1)='gular end-points invokes a real ' x(2)='value of the parameter lambda, this ' y(2)='classification is invariant in ' x(3)='lambda; all real choices of lambda l' y(3)='ead to the same classification. ' x(4)=' In determining the classification ' y(4)='of singular end-points for the ' x(5)='differential equation (*), it is oft' y(5)='en convenient to start with the ' x(6)='choice lambda = 0 in attempting to f' y(6)='ind solutions (particularly when ' x(7)='q = 0 on (a,b)); however, see exampl' y(7)='e 7 below. ' x(8)=' See H6 on the use of maximal domai' y(8)='n functions to determine the ' x(9)='classification at singular end-point' y(9)='s. ' do 403 i = 1,9 write(*,*) x(i),y(i) 403 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N write(*,*) ' EXAMPLES: ' x(1)=' 1. -y'''' = lambda*y is R at both en' y(1)='d-points of (a,b) when a and b are ' x(2)=' finite. ' y(2)=' ' x(3)=' 2. -y'''' = lambda*y on (-infinity,i' y(3)='nfinity) is LP at both end-points. ' x(4)=' 3. -(sqrt(x)*y''(x))'' = lambda*(1./' y(4)='sqrt(x))*y(x) on (0,infinity) is ' x(5)=' WR at 0 and LP at +infinity (ta' y(5)='ke lambda = 0 in (*)). See ' x(6)=' examples.f, #10 (Weakly Regular' y(6)='). ' x(7)=' 4. -((1-x*x)*y''(x))'' = lambda*y(x)' y(7)=' on (-1,1) is LCNO at both ends ' x(8)=' (take lambda = 0 in (*)). See ' y(8)='xamples.f, #1 (Legendre). ' x(9)=' 5. -y''''(x) + C*(1/(x*x))*y(x) = la' y(9)='mbda*y(x) on (0,infinity) is LP at ' x(10)=' infinity and at 0 is (take lamb' y(10)='da = 0 in (*)): ' x(11)=' LP for C .ge. 3/4 ; ' y(11)=' ' x(12)=' LCNO for -1/4 .le. C .lt. 3/4' y(12)=' (but C .ne. 0); ' x(13)=' LCO for C .lt. -1/4. ' y(13)=' ' x(14)=' 6. -(x*y''(x))'' - (1/x)*y(x) = lamb' y(14)='da*y(x) on (0,infinity) is LCO at 0 ' x(15)=' and LP at +infinity (take lambd' y(15)='a = 0 in (*) with solutions ' x(16)=' cos(ln(x)) and sin(ln(x))). Se' y(16)='e xamples.f, #7 (BEZ). ' x(17)=' 7. -(x*y''(x))'' - x*y(x) = lambda*(' y(17)='1/x)*y(x) on (0,infinity) is LP at 0' x(18)=' and LCO at infinity (take lambd' y(18)='a = -1/4 in (*) with solutions ' x(19)=' cos(x)/sqrt(x) and sin(x)/sqrt(' y(19)='x)). See xamples.f, ' x(20)=' #6 (Sears-Titchmarsh). ' y(20)=' ' do 404 i = 1,20 write(*,*) x(i),y(i) 404 continue write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 5 CONTINUE write(*,*) 'H5: DEFAULT entry.' x(1)=' The complete range of problems for' y(1)=' which SLEIGN2 is applicable can ' x(2)='only be reached by appropriate entri' y(2)='es under end-point classification ' x(3)='and boundary conditions. However, t' y(3)='here is a DEFAULT application which ' x(4)='requires no detailed entry of end-po' y(4)='int classification or boundary ' x(5)='conditions, subject to: ' y(5)=' ' x(6)=' 1) The DEFAULT application CANNOT ' y(6)='be used at a LCO end-point. ' x(7)=' 2) If an end-point a is R, then th' y(7)='e Dirichlet boundary condition ' x(8)=' y(a) = 0 is automatically used.' y(8)=' ' x(9)=' 3) If an end-point a is WR, then t' y(9)='he following boundary condition ' x(10)=' is automatically applied: ' y(10)=' ' x(11)=' if p(a) = 0, and both q(a),w(' y(11)='a) are bounded, then the Dirichlet ' x(12)=' boundary condition y(a) = 0 i' y(12)='s used, or ' x(13)=' if p(a) > 0, and q(a) and/or ' y(13)='w(a)) are not bounded, then the ' x(14)=' Neumann boundary condition (p' y(14)='y'')(a) = 0 is used. ' x(15)=' If p(a) = 0, and q(a) and/or w(' y(15)='a) are not bounded, then no reliable' x(16)=' information can be given on the' y(16)=' DEFAULT boundary condition. ' x(17)=' 4) If an end-point is LCNO, then i' y(17)='n most cases the principal or ' x(18)=' Friedrichs boundary condition i' y(18)='s applied (see H6). ' x(19)=' 5) If an end-point is LP, then the' y(19)=' normal LP procedure is applied ' x(20)=' (see H7(1.)). ' y(20)=' ' x(21)='If you choose the DEFAULT condition,' y(21)=' then no entry is required for the ' x(22)='u,v boundary condition functions. ' y(22)=' ' do 501 i = 1,22 write(*,*) x(i),y(i) 501 continue write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 6 CONTINUE write(*,*) 'H6: Limit-circle boundary conditions.' x(1)=' At an end-point a, the limit-circl' y(1)='e type separated boundary condition ' x(2)='is of the form (similar remarks thro' y(2)='ughout apply to the end-point b) ' x(3)=' ' y(3)=' ' x(4)=' A1*[y,u](a) + A2*[y,v](a) = 0' y(4)=', (**) ' x(5)=' ' y(5)=' ' x(6)='where y is a solution of the differe' y(6)='ntial equation ' x(7)=' ' y(7)=' ' x(8)=' -(p*y'')'' + q*y = lambda*w*y on' y(8)=' (a,b). (*) ' x(9)=' ' y(9)=' ' x(10)='Here A1, A2 are real numbers; u and ' y(10)='v are boundary condition functions; ' x(11)='and for real-valued y and u the form' y(11)=' [y,u] is defined by ' x(12)=' ' y(12)=' ' x(13)=' [y,u](x) = y(x)*(pu'')(x) - u(x' y(13)=')*(py'')(x) for x in (a,b). ' x(14)=' ' y(14)=' ' x(15)=' The object of this section is to p' y(15)='rovide help in choosing appropriate ' x(16)='functions u and v in (**), given the' y(16)=' differential equation (*). Full ' x(17)='details of the boundary conditions f' y(17)='or (*) are discussed in H7; here it ' x(18)='is sufficient to say that the limit-' y(18)='circle type boundary condition (**) ' x(19)='can be applied at any end-point in t' y(19)='he LCNO, LCO classification, but ' x(20)='also in the R, WR classification sub' y(20)='ject to the appropriate choice of ' x(21)='u and v. ' y(21)=' ' do 601 i = 1,21 write(*,*) x(i),y(i) 601 continue write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' Let (*) be R, WR, LCNO, or LCO at ' y(1)='end-point a and choose c in (a,b). ' x(2)='Then either ' y(2)=' ' x(3)=' u and v are a pair of linearly i' y(3)='ndependent solutions of (*) on (a,c]' x(4)=' for any chosen real values of lamb' y(4)='da, or ' x(5)=' u and v are a pair of real-value' y(5)='d maximal domain functions defined ' x(6)=' on (a,c] satisfying [u,v](a) .ne. ' y(6)='0. The maximal domain D(a,c] is ' x(7)=' defined by ' y(7)=' ' x(8)=' ' y(8)=' ' x(9)=' D(a,c] = {f:(a,c]->R:: f,pf'' ' y(9)='in AC(a,c]; ' x(10)=' f, ((-pf'')''+qf)/w' y(10)=' in L2((a,c;w)} ' x(11)=' ' y(11)=' ' x(12)=' It is known that for all f,g in D(' y(12)='a,c] the limit ' x(13)=' ' y(13)=' ' x(14)=' [f,g](a) = lim[f,g](x) as x->' y(14)='a ' x(15)=' ' y(15)=' ' x(16)=' exists and is finite. If (*) is L' y(16)='CNO or LCO at a, then all solutions ' x(17)=' of (*) belong to D(a,c] for all va' y(17)='lues of lambda. ' do 602 i = 1,17 write(*,*) x(i),y(i) 602 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' The boundary condition (**) is ess' y(1)='ential in the LCNO and LCO cases but' x(2)='can also be used with advantage in s' y(2)='ome R and WR cases. In the R, WR, ' x(3)='and LCNO cases, but not in the LCO c' y(3)='ase, the boundary condition ' x(4)='functions can always be chosen so th' y(4)='at ' x(5)=' lim u(x)/v(x) = 0 as x->a, ' y(5)=' ' x(6)='and it is recommended that this norm' y(6)='alisation be effected; this has been' x(7)='done in the examples given below. In' y(7)=' this case, the boundary condition ' x(8)='[y,u](a) = 0 (i.e., A1 = 1, A2 = 0 i' y(8)='n (**)) is called the principal or ' x(9)='Friedrichs boundary condition. ' y(9)=' ' x(10)=' ' y(10)=' ' x(11)=' In the case when end-points a and ' y(11)='b are, independently, in R, WR, ' x(12)='LCNO, or LCO classification, it may ' y(12)='be that symmetry or other reasons ' x(13)='permit one set of boundary condition' y(13)=' functions to be used at both end- ' x(14)='points (see xamples.f, #1 (Legendre)' y(14)='). In other cases, different pairs ' x(15)='must be chosen for each end-point (s' y(15)='ee xamples.f: #16 (Jacobi), ' x(16)='#18 (Dunsch), and #19 (Donsch)). ' y(16)=' ' x(17)=' ' y(17)=' ' x(18)=' Note that a solution pair u,v is a' y(18)='lways a maximal domain pair, but not' x(19)='necessarily vice versa. ' y(19)=' ' do 603 i = 1,19 write(*,*) x(i),y(i) 603 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' EXAMPLES: ' y(1)=' ' x(2)='1. -y''''(x) = lambda*y(x) on [0,pi] i' y(2)='s R at 0 and R at pi. ' x(3)=' At 0, with lambda = 0, a solution' y(3)=' pair is u(x) = x, v(x) = 1. ' x(4)=' At pi, with lambda = 1, a solutio' y(4)='n pair is ' x(5)=' u(x) = sin(x), v(x) = cos(x). ' y(5) =' ' x(6)='2. -(sqrt(x)*y''(x))'' = lambda*y(x)/s' y(6)='qrt(x) on (0,1] is ' x(7)=' WR at 0 and R at 1. ' y(7)=' ' x(8)=' (The general solutions of this eq' y(8)='uation are ' x(9)=' u(x) = cos(2*sqrt(x*lambda)), v' y(9)='(x) = sin(2*sqrt(x*lambda)).) ' x(10)=' At 0, with lambda = 0, a solution' y(10)=' pair is ' x(11)=' u(x) = 2*sqrt(x), v(x) = 1. ' y(11)=' ' x(12)=' At 1, with lambda = pi*pi/4, a so' y(12)='lution pair is ' x(13)=' u(x) = sin(pi*sqrt(x)), v(x) = ' y(13)='cos(pi*sqrt(x)). ' x(14)=' At 1, with lambda = 0, a solution' y(14)=' pair is ' x(15)=' u(x) = 2*(1-sqrt(x)), v(x) = 1.' y(15)=' ' x(16)=' See also xamples.f, #10 (Weakly R' y(16)='egular). ' x(17)='3. -((1-x*x)*y''(x))'' = lambda*y(x) o' y(17)='n (-1,1) is LCNO at both ends. ' x(18)=' At +-1, with lambda = 0, a soluti' y(18)='on pair is ' x(19)=' u(x) = 1, v(x) = 0.5*log((1+x)/' y(19)='(1-x)). ' x(20)=' At 1, a maximal domain pair is u(' y(20)='x) = 1, v(x) = log(1-x) ' x(21)=' At -1, a maximal domain pair is u' y(21)='(x) = 1, v(x) = log(1+x). ' x(22)=' See also xamples.f, #1 (Legendre)' y(22)='. ' do 604 i = 1,22 write(*,*) x(i),y(i) 604 continue write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)='4. -y''''(x) - (1/(4x*x))*y(x) = lambd' y(1)='a*y(x) on (0,infinity) is ' x(2)=' LCNO at 0 and LP at +infinity. ' y(2)=' ' x(3)=' At 0, a maximal domain pair is ' y(3)=' ' x(4)=' u(x) = sqrt(x), v(x) = sqrt(x)*' y(4)='log(x). ' x(5)=' See also xamples.f, #2 (Bessel). ' y(5)=' ' x(6)='5. -y''''(x) - 5*(1/(4*x*x))*y(x) = la' y(6)='mbda*y(x) on (0,infinity) is ' x(7)=' LCO at 0 and LP at +infinity. ' y(7)=' ' x(8)=' At 0, with lambda = 0, a solution' y(8)=' pair is ' x(9)=' u(x) = sqrt(x)*cos(log(x)), v(x' y(9)=') = sqrt(x)*sin(log(x)) ' x(10)=' See also xamples.f, #20 (Krall). ' y(10)=' ' x(11)='6. -y''''(x) - (1/x)*y(x) = lambda*y(x' y(11)=') on (0,infinity) is ' x(12)=' LCNO at 0 and LP at +infinity.' y(12)=' ' x(13)=' At 0, a maximal domain pair is ' y(13)=' ' x(14)=' u(x) = x, v(x) = 1 -x*log(x). ' y(14)=' ' x(15)=' See also xamples.f, #4(Boyd). ' y(15)=' ' x(16)='7. -((1/x)*y''(x))'' + (k/(x*x) + k*k/' y(16)='x)*y(x) = lambda*y(x) on (0,1], ' x(17)=' with k real and .ne. 0, is LCNO' y(17)=' at 0 and R at 1. ' x(18)=' At 0, a maximal domain pair is ' y(18)=' ' x(19)=' u(x) = x*x, v(x) = x - 1/k. ' y(19)=' ' x(20)=' See also xamples.f, #8 (Laplace T' y(20)='idal Wave). ' do 605 i = 1,20 write(*,*) x(i),y(i) 605 continue write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 7 CONTINUE write(*,*) 'H7: General boundary conditions.' x(1)=' Boundary conditions for Sturm-Liou' y(1)='ville boundary value problems ' x(2)=' ' y(2)=' ' x(3)=' -(p*y'')'' + q*y = ' y(3)=' lambda*w*y (*) ' x(4)=' ' y(4)=' ' x(5)='on an interval (a,b) are either ' y(5)=' ' x(6)=' SEPARATED, with at most one cond' y(6)='ition at end-point a and at most ' x(7)=' one condition at end-point b, or ' y(7)=' ' x(8)=' COUPLED, when both a and b are, ' y(8)='independently, in one of the end- ' x(9)=' point classifications R, WR, LCNO,' y(9)=' LCO, in which case two independent ' x(10)=' ent boundary conditions are requir' y(10)='ed which link the solution values ' x(11)=' near a to those near b. ' y(11)=' ' x(12)='The SLEIGN2 program allows for all s' y(12)='eparated conditions; and special ' x(13)='cases of the coupled conditions -- t' y(13)='he so-called periodic boundary ' x(14)='conditions applicable only when the ' y(14)='interval (a,b) is finite and both ' x(15)='a and b are R. ' y(15)=' ' do 701 i = 1,15 write(*,*) x(i),y(i) 701 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N write(*,*) ' Separated Conditions: ' write(*,*) ' --------------------- ' x(1)=' The boundary conditions to be sele' y(1)='cted depend upon the classification ' x(2)='of the differential equation at the ' y(2)='end-point, say, a: ' x(3)=' 1. If the end-point a is LP, the' y(3)='n no boundary condition is required ' x(4)=' or allowed. ' y(4)=' ' x(5)=' 2. If the end-point a is R or WR' y(5)=', then a separated boundary ' x(6)=' condition is of the form ' y(6)=' ' x(7)=' A1*y(a) + A2*(py'')(a) = 0,' y(7)=' ' x(8)=' where A1, A2 are real constants yo' y(8)='u must choose, not both zero. ' x(9)=' 3. If the end-point a is LCNO or' y(9)=' LCO, then a separated boundary ' x(10)=' condition is of the form ' y(10)=' ' x(11)=' A1*[y,u](a) + A2*[y,v](a) =' y(11)=' 0, ' x(12)=' where A1, A2 are real constants yo' y(12)='u must choose, not both zero; ' x(13)=' here, u,v are the pair of boundary' y(13)=' condition functions you have ' x(14)=' previously selected when the input' y(14)=' FORTRAN file was being prepared. ' x(15)=' 4. If the end-point a is LCNO an' y(15)='d the boundary condition pair ' x(16)=' u,v has been chosen so that ' y(16)=' ' x(17)=' lim u(x)/v(x) = 0 as x->a ' y(17)=' ' x(18)=' (which is always possible), then A' y(18)='1 = 1, A2 = 0 (i.e., [y,u](a) = 0) ' x(19)=' gives the principal (Friedrichs) b' y(19)='oundary condition at a. ' do 702 i = 1,19 write(*,*) x(i),y(i) 702 continue write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' 5. If a is R or WR and boundary ' y(1)='condition functions u,v have been ' x(2)=' entered in the FORTRAN input file,' y(2)=' then (3.,4.) above apply to ' x(3)=' entering separated boundary condit' y(3)='ions at such an end-point; the ' x(4)=' boundary conditions in this form a' y(4)='re equivalent to the point-wise ' x(5)=' conditions in (2.) (subject to car' y(5)='e in choosing A1, A2). This ' x(6)=' singular form of a regular boundar' y(6)='y condition may be particularly ' x(7)=' effective in the WR case if the bo' y(7)='undary condition form in (2.) leads ' x(8)=' to numerical difficulties. ' y(8)=' ' x(9)=' ' y(9)=' ' x(10)=' Conditions (2.,3.,4.,5.) apply sim' y(10)='ilarly at end-point b. ' x(11)=' ' y(11)=' ' x(12)=' 6. If a is R, WR, LCNO, or LCO a' y(12)='nd b is LP, then only a separated ' x(13)=' condition at a is required and all' y(13)='owed (or instead at b if a and b ' x(14)=' are interchanged). ' y(14)=' ' x(15)=' 7. If both end-points a and b ar' y(15)='e LP, then no boundary conditions ' x(16)=' are required or allowed. ' y(16)=' ' x(17)=' ' y(17)=' ' x(18)=' The indexing of eigenvalues for bo' y(18)='undary value problems with separated' x(19)=' conditions is discussed in H13. ' y(19)=' ' do 703 i = 1,19 write(*,*) x(i),y(i) 703 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),n write(*,*) ' Coupled Conditions: ' write(*,*) ' ------------------- ' x(1)=' 8. Periodic-type boundary condit' y(1)='ions on (a,b) apply only when ' x(2)=' both end-points a and b are R; the' y(2)='se conditions are of the form ' x(3)=' ' y(3)=' ' x(4)=' y(b) = c*y(a), (py'')(b) = (' y(4)='py'')(a)/c, ' x(5)=' ' y(5)=' ' x(6)=' where c may be chosen to be any re' y(6)='al number not equal to 0. The case ' x(7)=' c = 1 is called periodic, the case' y(7)=' c = -1 is called semi-periodic. ' x(8)=' ' y(8)=' ' x(9)=' The indexing of eigenvalues for pe' y(9)='riodic-type boundary conditions is ' x(10)=' discussed in H17. ' y(10)=' ' do 704 i = 1,10 write(*,*) x(i),y(i) 704 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 8 CONTINUE write(*,*) 'H8: Recording the results.' x(1)=' If you choose to have a record kep' y(1)='t of the results, then the following' x(2)='information is stored in a file with' y(2)=' the name you select: ' x(3)=' ' y(3)=' ' x(4)=' 1. The file name. ' y(4)=' ' x(5)=' 2. The header line prompted for (u' y(5)='p to 32 characters of your choice). ' x(6)=' 3. The interval (a,b) which was us' y(6)='ed. ' x(7)=' ' y(7)=' ' x(8)=' For SEPARATED boundary conditions:' y(8)=' ' x(9)=' 4. The end-point classification. ' y(9)=' ' x(10)=' 5. A summary of coefficient inform' y(10)='ation at WR, LCNO, LCO end-points. ' x(11)=' 6. The boundary condition constant' y(11)='s (A1,A2), (B1,B2) if entered. ' x(12)=' 7. (NUMEIG,EIG,TOL) or (NUMEIG1,NU' y(12)='MEIG2,TOL), as entered. ' x(13)=' ' y(13)=' ' x(14)=' For COUPLED boundary conditions: ' y(14)=' ' x(15)=' 8. The boundary condition paramete' y(15)='r, c. ' x(16)=' ' y(16)=' ' x(17)=' For ALL boundary conditions: ' y(17)=' ' x(18)=' 9. The computed eigenvalue, EIG, a' y(18)='nd its estimated accuracy, TOL. ' x(19)=' 10. IFLAG reported (see H15). ' y(19)=' ' do 801 i = 1,19 write(*,*) x(i),y(i) 801 continue write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 9 CONTINUE write(*,*) 'H9: Type and choice of interval.' x(1)=' You may enter any interval (a,b) f' y(1)='or which the coefficients p,q,w are ' x(2)='well defined by your FORTRAN stateme' y(2)='nts in the input file, provided that' x(3)='(a,b) contains no interior singulari' y(3)='ities. ' do 901 i = 1,3 write(*,*) x(i),y(i) 901 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 10 CONTINUE write(*,*) 'H10: Entry of end-points.' x(1)=' End-points a and b must be entered' y(1)=' as real numbers. There is no ' x(2)='symbolic entry; e.g., pi must be ent' y(2)='ered as 3.14159... to an appropriate' x(3)='number of decimal places. ' y(3)=' ' do 1001 i = 1,3 write(*,*) x(i),y(i) 1001 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 11 CONTINUE write(*,*) 'H11: End-point values of p,q,w.' x(1)=' The program SLEIGN2 needs to know ' y(1)='whether the coefficient functions ' x(2)='p(x),q(x),w(x) defined by the FORTRA' y(2)='N expressions entered in the input ' x(3)='file can be evaluated numerically wi' y(3)='thout running into difficulty. If, ' x(4)='for example, either q or w is unboun' y(4)='ded at a, or p(a) is 0, then SLEIGN2' x(5)='needs to know this so that a is not ' y(5)='chosen for functional evaluation. ' do 1101 i = 1,5 write(*,*) x(i),y(i) 1101 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 12 CONTINUE write(*,*) 'H12: Initial value problems.' x(1)=' The initial value problem facility' y(1)=' for Sturm-Liouville problems ' x(2)=' ' y(2)=' ' x(3)=' -(p*y'')'' + q*y = ' y(3)=' lambda*w*y (*) ' x(4)=' ' y(4)=' ' x(5)='allows for the computation of a solu' y(5)='tion of (*) with a user-chosen ' x(6)='value lambda and any one of the foll' y(6)='owing initial conditions: ' x(7)=' 1. From end-point a of any classif' y(7)='ication except LP towards ' x(8)='end-point b of any classification, ' y(8)=' ' x(9)=' 2. From end-point b of any classif' y(9)='ication except LP back towards ' x(10)='end-point a of any classification, ' y(10)=' ' x(11)=' 3. From end-points a and b of any ' y(11)='classifications except LP towards an' x(12)='interior point of (a,b) selected by ' y(12)='the program. ' x(13)=' ' y(13)=' ' x(14)=' Initial values at a are of the for' y(14)='m y(a) = alpha1, (p*y'')a = alpha2, ' x(15)='when a is R or WR; and [y,u](a) = al' y(15)='pha1, [y,v](a) = alpha2, when a is ' x(16)='LCNO or LCO. ' y(16)=' ' x(17)=' Initial values at b are of the for' y(17)='m y(b) = beta1, (p*y'')b = beta2, ' x(18)='when b is R or WR; and [y,u](b) = be' y(18)='ta1, [y,v](b) = beta2, when b is ' x(19)='LCNO or LCO. ' y(19)=' ' x(20)=' In (*), lambda is a user-chosen re' y(20)='al number; while in the above ' x(21)='initial values, (alpha1,alpha2) and ' y(21)='(beta1,beta2) are user-chosen pairs ' x(22)='of real numbers not both zero. ' y(22)=' ' do 1201 i = 1,22 write(*,*) x(i),y(i) 1201 continue write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' In the initial value case (3.) abo' y(1)='ve when the interval (a,b) is ' x(2)='finite, the interior point selected ' y(2)='by the program is generally near the' x(3)='midpoint of (a,b); when (a,b) is inf' y(3)='inite, no general rule can be given.' x(4)='Also if, given (alpha1,alpha2) and (' y(4)='beta1,beta2), the lambda chosen is ' x(5)='an eigenvalue of the associated boun' y(5)='dary value problem, the computed ' x(6)='solution may not be the correspondin' y(6)='g eigenfunction -- the signs of the ' x(7)='computed solutions on either side of' y(7)=' the interior point may be opposite.' x(8)=' The output for a solution of an in' y(8)='itial value problem is in the form ' x(9)='of stored numerical data which can b' y(9)='e plotted on the screen (see H16), ' x(10)='or printed out in graphical form if ' y(10)='graphics software is available. ' do 1202 i = 1,10 write(*,*) x(i),y(i) 1202 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 13 continue write(*,*) 'H13: Indexing of eigenvalues.' x(1)=' The indexing of eigenvalues is an ' y(1)='automatic facility in SLEIGN2. The ' x(2)='following general results hold for t' y(2)='he separated boundary condition ' x(3)='problem (see H7): ' y(3)=' ' x(4)=' 1. If neither end-point a or b is ' y(4)='LP or LCO, then the spectrum of the ' x(5)='eigenvalue problem is discrete (eige' y(5)='nvalues only), simple (eigenvalues ' x(6)='all of multiplicity 1), and bounded ' y(6)='below with a single cluster point at' x(7)='+infinity. The eigenvalues are inde' y(7)='xed as {lambda(n): n=0,1,2,...}, ' x(8)='where lambda(n) < lambda(n+1) (n=0,1' y(8)=',2,...), lim lambda(n) -> +infinity;' x(9)='and if {psi(n): n=0,1,2,...} are the' y(9)=' corresponding eigenfunctions, then ' x(10)='psi(n) has exactly n zeros in the op' y(10)='en interval (a,b). ' x(11)=' 2. If neither end-point a or b is ' y(11)='LP but at least one end-point is ' x(12)='LCO, then the spectrum is discrete a' y(12)='nd simple as for (1.), but with ' x(13)='cluster points at both +infinity and' y(13)=' -infinity. The eigenvalues are ' x(14)='indexed as {lambda(n): n=0,1,-1,2,-2' y(14)=',...}, where ' x(15)='lambda(n) < lambda(n+1) (n=...-2,-1,' y(15)=',0,1,2,...) with lambda(0) the ' x(16)='smallest non-negative eigenvalue and' y(16)=' lim lambda(n) -> +infinity or ' x(17)='-> -infinity with n; and if {psi(n):' y(17)=' n=0,1,-1,2,-2,...} are the ' x(18)='corresponding eigenfunctions, then e' y(18)='very psi(n) has infinitely many ' x(19)='zeros in (a,b). ' y(19)=' ' do 1301 i = 1,19 write(*,*) x(i),y(i) 1301 continue write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' 3. If one or both end-points is LP' y(1)=', then there can be one or more ' x(2)='intervals of continuous spectrum for' y(2)=' the boundary value problem in ' x(3)='addition to some (necessarily simple' y(3)=') eigenvalues. For these ' x(4)='essentially more difficult problems,' y(4)=' SLEIGN2 can be used as an ' x(5)='investigative tool to give qualitati' y(5)='ve and possibly quantitative ' x(6)='information on the spectrum. ' y(6)=' ' x(7)=' For example, if a problem has a' y(7)=' single interval of continuous ' x(8)='spectrum bounded below by K, then th' y(8)='ere may be any number of eigenvalues' x(9)='below K. In some cases, SLEIGN2 can' y(9)=' compute K, and determine the number' x(10)='of these eigenvalues and compute the' y(10)='m. In this respect, see xamples.f: ' x(11)='#13 (Hydrogen Atom), #17 (Morse Osci' y(11)='llator), #21 (Fourier), and ' x(12)='#27 (Joergens) as examples of succes' y(12)='s; and #2 (Mathieu), #14 (Marletta),' x(13)='and #28 (Behnke-Goerisch) as example' y(13)='s of failure. ' x(14)=' The problem need not have a con' y(14)='tinuous spectrum, in which case if ' x(15)='its discrete spectrum is bounded bel' y(15)='ow, then the eigenvalues are indexed' x(16)='and the eigenfunctions have zero cou' y(16)='nts as in (1.). If, on the other ' x(17)='hand, the discrete spectrum is unbou' y(17)='nded below, then all the ' x(18)='eigenfunctions have infinitely many ' y(18)='zeros in the interval. ' do 1302 i = 1,18 write(*,*) x(i),y(i) 1302 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' In respect to the three classes of' y(1)=' end-points, the following ' x(2)='identified examples from xamples.f i' y(2)='llustrate the spectral property ' x(3)='of these boundary value problems: ' y(3)=' ' x(4)=' 1. Neither end-point is LP or LCO.' y(4)=' ' x(5)=' #1 (Legendre) ' y(5)=' ' x(6)=' #2 (Bessel) with -1/4 < c < 3' y(6)='/4 ' x(7)=' #4 (Boyd) ' y(7)=' ' x(8)=' #5 (Latzko) ' y(8)=' ' x(9)=' 2. Neither end-point is LP, but at' y(9)=' least one is LCO. ' x(10)=' #6 (Sears-Titchmarsh) ' y(10)=' ' x(11)=' #7 (BEZ) ' y(11)=' ' x(12)=' #19 (Donsch) ' y(12)=' ' x(13)=' 3. At least one end-point is LP. ' y(13)=' ' x(14)=' #13 (Hydrogen Atom) ' y(14)=' ' x(15)=' #14 (Marletta) ' y(15)=' ' x(16)=' #20 (Krall) ' y(16)=' ' x(17)=' #21 (Fourier) on [0,infinity) ' y(17)=' ' do 1303 i = 1,17 write(*,*) x(i),y(i) 1303 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 14 CONTINUE write(*,*) 'H14: Entry of eigenvalue index, initial guess,'// 1 ' and tolerance.' x(1)=' For SEPARATED boundary condition p' y(1)='roblems (see H7), SLEIGN2 calls for ' x(2)='input information options to compute' y(2)=' either ' x(3)=' 1. a single eigenvalue, or ' y(3)=' ' x(4)=' 2. a series of eigenvalues. ' y(4)=' ' x(5)='In each case indexing of eigenvalues' y(5)=' is called for (see H13). ' x(6)=' (1.) above asks for data triples N' y(6)='UMEIG, EIG, TOL separated by commas.' x(7)='Here NUMEIG is the integer index of ' y(7)='the desired eigenvalue; NUMEIG can ' x(8)='be negative only when the problem is' y(8)=' LCO at one or both end-points. ' x(9)='EIG allows for the entry of an initi' y(9)='al guess for the requested ' x(10)='eigenvalue (if an especially good on' y(10)='e is available), or can be set to 0 ' x(11)='in which case an initial guess is ge' y(11)='nerated by SLEIGN2 itself. ' x(12)='TOL is the desired accuracy of the c' y(12)='omputed eigenvalue. It is an ' x(13)='absolute accuracy if the magnitude o' y(13)='f the eigenvalue is 1 or less, and ' x(14)='is a relative accuracy otherwise. T' y(14)='ypical values might be .001 for ' x(15)='moderate accuracy and .0000001 for h' y(15)='igh accuracy in single precision. ' x(16)='If TOL is set to 0, the maximum achi' y(16)='evable accuracy is requested. ' x(17)=' If the input data list is truncate' y(17)='d with a "/" after NUMEIG or EIG, ' x(18)='then the remaining elements default ' y(18)='to 0. ' do 1401 i = 1,18 write(*,*) x(i),y(i) 1401 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' (2.) above asks for data triples N' y(1)='UMEIG1, NUMEIG2, TOL separated by ' x(2)='commas. Here NUMEIG1 and NUMEIG2 ar' y(2)='e the first and last integer indices' x(3)='of the sequence of desired eigenvalu' y(3)='es, NUMEIG1 < NUMEIG2; they can be ' x(4)='negative only when the problem is LC' y(4)='O at one or both end-points. ' x(5)='TOL is the desired accuracy of the c' y(5)='omputed eigenvalues. It is an ' x(6)='absolute accuracy if the magnitude o' y(6)='f an eigenvalue is 1 or less, and ' x(7)='is a relative accuracy otherwise. T' y(7)='ypical values might be .001 for ' x(8)='moderate accuracy and .0000001 for h' y(8)='igh accuracy in single precision. ' x(9)='If TOL is set to 0, the maximum achi' y(9)='evable accuracy is requested. ' x(10)=' If the input data list is truncate' y(10)='d with a "/" after NUMEIG2, then TOL' x(11)='defaults to 0. ' y(11)=' ' x(12)=' ' y(12)=' ' x(13)=' For COUPLED periodic-type boundary' y(13)=' condition problems (see H7 and ' x(14)='H17), SLEIGN2 asks only for NUMEIG, ' y(14)='the non-negative integer index of ' x(15)='the desired eigenvalue; TOL is set i' y(15)='nternally. ' do 1402 i = 1,15 write(*,*) x(i),y(i) 1402 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 15 CONTINUE write(*,*) 'H15: IFLAG information.' x(1)=' All results are reported by SLEIGN' y(1)='2 with a flag identification. There' x(2)='are four values of IFLAG: ' y(2)=' ' x(3)=' ' y(3)=' ' x(4)=' 1 - The computed eigenvalue has an' y(4)=' estimated accuracy within the ' x(5)=' tolerance requested. ' y(5)=' ' x(6)=' ' y(6)=' ' x(7)=' 2 - The computed eigenvalue does n' y(7)='ot have an estimated accuracy within' x(8)=' the tolerance requested, but i' y(8)='s the best the program could obtain.' x(9)=' ' y(9)=' ' x(10)=' 3 - There seems to be no eigenvalu' y(10)='e of index equal to NUMEIG. ' x(11)=' ' y(11)=' ' x(12)=' 4 - The program has been unable to' y(12)=' compute the requested eigenvalue. ' do 1501 i = 1,12 write(*,*) x(i),y(i) 1501 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 16 CONTINUE write(*,*) 'H16: Plotting.' x(1)=' After computing a single eigenvalu' y(1)='e (see H14(1.)), but not a sequence ' x(2)='of eigenvalues (see H14(2.)), the ei' y(2)='genfunction can be plotted. If this' x(3)='is desired, respond "y" when asked s' y(3)='o that SLEIGN2 will compute some ' x(4)='eigenfunction data and store them. ' y(4)=' ' x(5)=' One can ask that the eigenfunction' y(5)=' data be in the form of either ' x(6)='points (x,y) for x in (a,b), or poin' y(6)='ts (t,y) for t in the standardized ' x(7)='interval (-1,1) mapped onto from (a,' y(7)='b); the t- choice can be especially ' x(8)='helpful when the original interval i' y(8)='s infinite. Additionally, one can ' x(9)='ask for a plot of the so-called Pruf' y(9)='er angle, in x- or t- variables. ' x(10)=' In both forms, once the choice has' y(10)=' been made of the function to be ' x(11)='plotted, a crude plot is displayed o' y(11)='n the monitor screen and you are ' x(12)='asked whether you wish to save the c' y(12)='omputed plot points in a file. ' do 1601 i = 1,12 write(*,*) x(i),y(i) 1601 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 17 CONTINUE write(*,*) 'H17: Indexing of eigenvalues for'// 1 ' periodic-type problems.' x(1)=' The indexing of eigenvalues is an ' y(1)='automatic facility in SLEIGN2. The ' x(2)='following general result holds for t' y(2)='he periodic-type boundary condition ' x(3)='problem (see H7): ' y(3)=' ' x(4)=' The spectrum of the eigenvalue pro' y(4)='blem is discrete (eigenvalues only),' x(5)='and bounded below with a single clus' y(5)='ter point at +infinity. In general,' x(6)='the spectrum is not simple, but no e' y(6)='igenvalue exceeds multiplicity 2. ' x(7)='The eigenvalues are indexed as {lamb' y(7)='da(n): n=0,1,2,...}, where ' x(8)='lambda(n) .le. lambda(n+1) (n=0,1,2,' y(8)='...), lim lambda(n) -> +infinity. ' x(9)=' The connection between the index n' y(9)=' and the number of zeros of the ' x(10)='corresponding eigenfunction psi(x,n)' y(10)=' is not as simple as for separated ' x(11)='conditions; that is, psi(x,n) need n' y(11)='ot have exactly n zeros in (a,b). ' x(12)=' The following identified examples ' y(12)='from xamples.f are of special ' x(13)='interest: ' y(13)=' ' x(14)=' #11 (Plum) on [0,pi] ' y(14)=' ' x(15)=' #21 (Fourier) on [0,pi] ' y(15)=' ' x(16)=' #25 (Meissner) on [-0.5,0.5] ' y(16)=' ' do 1701 i = 1,16 write(*,*) x(i),y(i) 1701 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N go to 1 999 FORMAT(A1,I2) end SUBROUTINE MESH(EIG,TS,NN) INTEGER NN DOUBLE PRECISION EIG DOUBLE PRECISION TS(991) C ********** C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Local Scalars .. INTEGER I,IJ,IMAX,IMAXP,J,JJ,JM,JP,M PARAMETER (IMAX = 100) PARAMETER (IMAXP = IMAX + 1) DOUBLE PRECISION DELL,DELL0,DEN,DT,FACTOR,PX,QQ,QX, 1 SAV,SUM,S1,T1,WX,X C .. C .. Local Arrays .. INTEGER JL(5) DOUBLE PRECISION TT(IMAXP),DELT(IMAXP),T(1000),S(1000) C .. C .. External Subroutines .. EXTERNAL DXDT C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. Intrinsic Functions .. INTRINSIC MIN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. TT(1) = -1.0D0 SAV = -1.0D0 M = 0 DO 10 I = 2,IMAX TT(I) = -1.0D0 + (2.0*(I-1))/IMAX CALL DXDT(TT(I),DT,X) PX = P(X) QX = Q(X) WX = W(X) QQ = DT**2*(EIG*WX-QX)/PX DEN = 3.0*HPI IF (QQ.GT.HPI**2) DEN = 3.0*SQRT(QQ) DELT(I) = 1.0D0/DEN IF (QQ*SAV.LT.0.0D0) THEN M = M + 1 JL(M) = I IF (QQ.LT.0.0D0) JL(M) = -I SAV = -SAV END IF 10 CONTINUE TT(IMAXP) = 1.0D0 DELT(1) = DELT(2) DELT(IMAXP) = DELT(IMAX) DO 30 I = 1,M DO 20 J = 1,8 IJ = J + JL(I) - 6 IF (JL(I).LT.0) IJ = J - JL(I) - 4 IF (IJ.GE.1.AND.IJ.LE.IMAXP) DELT(IJ) = MIN(.033D0,DELT(IJ)) 20 CONTINUE 30 CONTINUE SUM = 0.0D0 DO 40 I = 1,IMAXP SUM = SUM + DELT(I) 40 CONTINUE FACTOR = 5.0/SUM C ------------------------------------------------------ C GENERATE MESH POINTS IN (0,1): C J = 1 T(J) = .001 DO 50 I = 1,IMAX IF (TT(I).LE.T(J) .AND. TT(I+1).GE.T(J)) THEN JJ = I GO TO 60 END IF 50 CONTINUE 60 CONTINUE T1 = T(1) 70 CONTINUE DELL0 = MIN(DELT(JJ),DELT(JJ+1)) DELL = FACTOR*DELL0 80 CONTINUE IF (T1.LE.TT(JJ+1)) T1 = T1 + DELL IF (T1.LE.TT(JJ+1)) THEN J = J + 1 T(J) = T1 IF (J.LE.495) GO TO 80 ELSE IF (T1.GT.TT(JJ+1) .AND. T1.LE.TT(JJ+2)) THEN J = J + 1 T(J) = T1 END IF JJ = JJ + 1 IF (JJ.LT.IMAXP .AND. J.LE.495) GO TO 70 JP = J C ------------------------------------------------------ C GENERATE MESH POINTS IN (-1,0): C J = 1 S(J) = -.001 DO 90 I = 1,IMAX IF (TT(I).LE.S(J) .AND. TT(I+1).GE.S(J)) THEN JJ = I + 1 GO TO 100 END IF 90 CONTINUE 100 CONTINUE S1 = S(J) 110 CONTINUE DELL0 = MIN(DELT(JJ-1),DELT(JJ)) DELL = FACTOR*DELL0 120 CONTINUE IF (S1.GE.TT(JJ-1)) S1 = S1 - DELL IF (S1.GE.TT(JJ-1)) THEN J = J + 1 S(J) = S1 IF (J.LE.495) GO TO 120 ELSE IF (S1.LT.TT(JJ-1) .AND. S1.GE.TT(JJ-2)) THEN J = J + 1 S(J) = S1 END IF JJ = JJ - 1 IF (JJ.GT.1 .AND. J.LE.495) GO TO 110 JM = J C ------------------------------------------------------ DO 130 I = 1,JM TS(I) = S(JM+1-I) 130 CONTINUE DO 140 I = 1,JP TS(JM+I) = T(I) 140 CONTINUE C NN = JM + JP RETURN END SUBROUTINE QPLOT(ISLFUN,XT,NV,PLOTF,NF) INTEGER ISLFUN,NV,NF DOUBLE PRECISION PLOTF(1000,6),XT(1000,2) C ********** C THIS PROGRAM TRIES TO DRAW GRAPHS. C ********** C .. Local Scalars .. INTEGER I,II,IZ,J,K,L,MMAX,NMAX PARAMETER (NMAX = 75, MMAX = 22) DOUBLE PRECISION DZ,REM,X,XK,XKP,XMAX,XMIN,Y,YK,YKP,YMAX,YMIN C .. C .. Local Arrays .. DOUBLE PRECISION A(1000,2) CHARACTER*1 AX(NMAX,MMAX) C .. C .. Intrinsic Functions .. INTRINSIC ABS,INT,MAX,MIN C .. XMAX = -1000000. XMIN = 1000000. YMAX = -1000000. YMIN = 1000000. DZ = YMIN DO 10 I = 1,ISLFUN X = XT(9+I,NV) Y = PLOTF(9+I,NF) XMAX = MAX(XMAX,X) XMIN = MIN(XMIN,X) YMAX = MAX(YMAX,Y) YMIN = MIN(YMIN,Y) A(I,1) = X A(I,2) = Y IF (ABS(Y).LT.DZ) THEN DZ = ABS(Y) IZ = I END IF 10 CONTINUE C IF (YMIN*YMAX.LE.0.0D0) THEN Y = MAX(1.0D0,YMAX-YMIN) ELSE Y = MAX(1.0D0,ABS(YMIN),ABS(YMAX)) END IF DO 20 I = 1,ISLFUN A(I,2) = A(I,2)/Y 20 CONTINUE YMAX = YMAX/Y YMIN = YMIN/Y C DO 30 I = 1,ISLFUN A(I,1) = A(I,1) - XMIN IF (YMIN*YMAX.LE.0.0D0) A(I,2) = A(I,2) - YMIN 30 CONTINUE C C NOW MIN(X) = 0. AND MIN(Y) = 0. C X = XMAX - XMIN DO 40 I = 1,ISLFUN A(I,1) = NMAX*A(I,1)/X A(I,2) = MMAX*A(I,2) 40 CONTINUE C DO 60 J = 1,NMAX DO 50 K = 1,MMAX AX(J,K) = ' ' 50 CONTINUE 60 CONTINUE C DO 80 J = 2,NMAX II = 0 X = J - 0.5 DO 70 I = 1,ISLFUN IF (A(I,1).LE.X) II = I 70 CONTINUE C C LINE PK,PKP IS: Y-YK = (X-XK)*(YKP-YK)/(XKP-XK) C THIS LINE MEETS THE LINE X = J - 0.5 WHERE: C XK = A(II,1) XKP = A(II+1,1) YK = A(II,2) YKP = A(II+1,2) Y = YK + (X-XK)*(YKP-YK)/(XKP-XK) C K = MMAX - INT(Y) REM = Y + (K-MMAX) IF (REM.LE.0.25) THEN AX(J,K) = '_' ELSE IF (REM.LE.0.50) THEN AX(J,K) = '.' ELSE IF (REM.LE.0.75) THEN AX(J,K) = '+' ELSE AX(J,K) = '"' END IF 80 CONTINUE C IF (YMIN*YMAX.LT.0.0D0) THEN L = INT(A(IZ,2)) ELSE IF (YMAX.GT.0.0D0) THEN L = 0 ELSE L = 22 END IF K = MMAX - L DO 90 J = 1,NMAX IF (AX(J,K).EQ.' ') AX(J,K) = '.' 90 CONTINUE WRITE(*,*) DO 100 K = 1,MMAX WRITE(*,'(1X,80A1)') (AX(J,K),J=1,NMAX) 100 CONTINUE RETURN END SUBROUTINE LSTDIR(CHANS,I,ICOL) INTEGER I,ICOL(2) CHARACTER*32 CHANS C .. Local Scalars .. INTEGER J C .. I = 1 DO 10 J = 1,32 IF (CHANS(J:J).EQ.',' .OR. CHANS(J:J).EQ.'/') THEN ICOL(I) = J IF (CHANS(J:J).EQ.'/') THEN CHANS(J:J) = ' ' RETURN END IF I = I + 1 END IF 10 CONTINUE RETURN END CHARACTER*32 FUNCTION FMT2(I1) INTEGER I1 C .. Local Arrays .. CHARACTER*2 COL(32) C .. DATA COL/'01','02','03','04','05','06','07','08','09','10','11', 1 '12','13','14','15','16','17','18','19','20','21','22', 2 '23','24','25','26','27','28','29','30','31','32'/ C FMT2 = '(F'//COL(I1)//'.0,1X,F'//COL(31-I1)//'.0)' RETURN END SHAR_EOF fi # end of overwriting check if test -f 'makepqwd.f' then echo shar: will not over-write existing file "'makepqwd.f'" else cat << SHAR_EOF > 'makepqwd.f' PROGRAM MAKEPQW C C THIS PROGRAM IS DATED AUGUST 11, 1995, AND GENERATES THE FORTRAN C COEFFICIENT FUNCTIONS P(X), Q(X), W(X), AND SUBROUTINE UV WHICH C DEFINES THE BOUNDARY CONDITION FUNCTIONS U(X), V(X) FOR SLEIGN2. C C THE DIFFERENTIAL EQUATION IS OF THE FORM C C -(p*y')' + q*y = lambda*w*y C C .. Local Scalars .. CHARACTER*1 HQ CHARACTER*16 CHANS,TAPE1 CHARACTER*62 STR DOUBLE PRECISION C C .. C .. External Subroutines .. EXTERNAL LC C .. WRITE(*,*) WRITE(*,*) ' HELP may be called at any point where the program ' WRITE(*,*) ' halts and displays (h?) by pressing "h ". ' WRITE(*,*) ' To RETURN from HELP, press "r ". ' WRITE(*,*) ' To QUIT at any program halt, press "q ". ' WRITE(*,*) ' WOULD YOU LIKE AN OVERVIEW OF HELP ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y' .OR. 1 HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(1) END IF C 100 CONTINUE WRITE(*,*) ' SPECIFY OUTPUT FILE NAME (h?) ' READ(*,16) CHANS IF (CHANS.EQ.'q' .OR. CHANS.EQ.'Q') THEN STOP ELSE IF (CHANS.EQ.'h' .OR. CHANS.EQ.'H') THEN CALL HELP(2) GO TO 100 ELSE TAPE1 = CHANS END IF OPEN(1,FILE=TAPE1,STATUS='NEW') WRITE(1,'(A)') 'C' WRITE(1,'(A)') 'C ' // TAPE1 C WRITE(*,*) ' THE DIFFERENTIAL EQUATION IS OF THE FORM: ' WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y ' WRITE(*,*) C 200 CONTINUE WRITE(*,*) ' INPUT (h?) p = ' READ(*,62) STR HQ = STR IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 200 ELSE WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' FUNCTION P(X)' WRITE(1,'(A)') ' DOUBLE PRECISION P,X' WRITE(1,'(A)') ' P = ' // STR WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' END IF C 300 CONTINUE WRITE(*,*) ' INPUT (h?) q = ' READ(*,62) STR HQ = STR IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 300 ELSE WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' FUNCTION Q(X)' WRITE(1,'(A)') ' DOUBLE PRECISION Q,X' WRITE(1,'(A)') ' Q = ' // STR WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' END IF C 400 CONTINUE WRITE(*,*) ' INPUT (h?) w = ' READ(*,62) STR HQ = STR IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 400 ELSE WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' FUNCTION W(X)' WRITE(1,'(A)') ' DOUBLE PRECISION W,X' WRITE(1,'(A)') ' W = ' // STR WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' END IF C 500 CONTINUE WRITE(*,*) ' DO YOU REQUIRE INFORMATION ON END-POINT ' WRITE(*,*) ' CLASSIFICATION ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y' .OR. 1 HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(4) GO TO 500 ELSE IF (HQ.EQ.'e' .OR. HQ.EQ.'E') THEN GO TO 800 ELSE END IF C 600 CONTINUE WRITE(*,*) ' DO YOU REQUIRE INFORMATION ON DEFAULT CLASSIFI-' WRITE(*,*) ' CATION AND BOUNDARY CONDITIONS ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y' .OR. 1 HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(5) GO TO 600 ELSE END IF C 700 CONTINUE WRITE(*,*) ' DO YOU REQUIRE INFORMATION ON LIMIT CIRCLE ' WRITE(*,*) ' BOUNDARY CONDITIONS ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y' .OR. 1 HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(6) GO TO 700 ELSE END IF C 800 CONTINUE WRITE(*,*) ' DO YOU WANT TO USE A LIMIT CIRCLE ' WRITE(*,*) ' BOUNDARY CONDITION ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(6) GO TO 800 ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y') THEN WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' SUBROUTINE UV(X,U,PUP,V,PVP,HU,HV)' WRITE(1,'(A)') ' DOUBLE PRECISION X,U,PUP,V,PVP,HU,HV' 900 CONTINUE WRITE(*,*) ' DO YOU WANT TO USE TWO DIFFERENT PAIRS OF ' WRITE(*,*) ' FUNCTIONS U(X),V(X) ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(6) GO TO 900 ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y') THEN 1000 CONTINUE WRITE(*,*) ' ASSUMING THAT ONE PAIR OF FUNCTIONS ' WRITE(*,*) ' U(X),V(X) IS FOR a < X < c, AND ' WRITE(*,*) ' THE OTHER PAIR IS FOR c <= X < b, ' WRITE(*,*) ' WHAT IS THE VALUE OF c ? (h?) ' WRITE(*,*) WRITE(*,*) ' c = ' READ(*,16) CHANS HQ = CHANS IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(6) GO TO 1000 ELSE READ(CHANS,'(F16.0)') C END IF WRITE(*,*) WRITE(*,*) ' FOR a < X < c :' WRITE(*,*) WRITE(1,'(A,1PE12.5,A)') ' IF (X.LT.',C,') THEN' CALL LC(9) WRITE(*,*) WRITE(*,*) ' FOR c <= X < b :' WRITE(*,*) WRITE(1,'(A)') ' ELSE' CALL LC(9) WRITE(1,'(A)') ' END IF' ELSE WRITE(*,*) CALL LC(6) END IF ELSE WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' SUBROUTINE UV' END IF WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' C WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' SUBROUTINE EXAMP' WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' CLOSE(1) STOP 1 FORMAT(A1) 16 FORMAT(A16) 62 FORMAT(A62) END C SUBROUTINE LC(INDENT) INTEGER INDENT C .. Local Scalars .. CHARACTER*57 STR C .. IF (INDENT.EQ.6) THEN WRITE(*,*) ' INPUT u = ' READ(*,57) STR WRITE(1,'(A)') ' U = ' // STR WRITE(*,*) ' INPUT v = ' READ(*,57) STR WRITE(1,'(A)') ' V = ' // STR WRITE(*,*) ' INPUT pu'' = ' READ(*,57) STR WRITE(1,'(A)') ' PUP = ' // STR WRITE(*,*) ' INPUT pv'' = ' READ(*,57) STR WRITE(1,'(A)') ' PVP = ' // STR WRITE(*,*) ' INPUT -(pu'')'' + q*u = ' READ(*,57) STR WRITE(1,'(A)') ' HU = ' // STR WRITE(*,*) ' INPUT -(pv'')'' + q*v = ' READ(*,57) STR WRITE(1,'(A)') ' HV = ' // STR ELSE WRITE(*,*) ' INPUT u = ' READ(*,57) STR WRITE(1,'(A)') ' U = ' // STR WRITE(*,*) ' INPUT v = ' READ(*,57) STR WRITE(1,'(A)') ' V = ' // STR WRITE(*,*) ' INPUT pu'' = ' READ(*,57) STR WRITE(1,'(A)') ' PUP = ' // STR WRITE(*,*) ' INPUT pv'' = ' READ(*,57) STR WRITE(1,'(A)') ' PVP = ' // STR WRITE(*,*) ' INPUT -(pu'')'' + q*u = ' READ(*,57) STR WRITE(1,'(A)') ' HU = ' // STR WRITE(*,*) ' INPUT -(pv'')'' + q*v = ' READ(*,57) STR WRITE(1,'(A)') ' HV = ' // STR END IF RETURN 57 FORMAT(A57) END c subroutine help(nh) integer i,n,nh character*36 x(23),y(23) character*1 ans c GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),NH c 1 CONTINUE write(*,*) 'H1: Overview of HELP.' x(1)=' This ASCII text file is supplied a' y(1)='s a separate file with the SLEIGN2 ' x(2)='package; it can be accessed on-line ' y(2)='in both MAKEPQW (if used) and DRIVE.' x(3)=' HELP contains information to aid t' y(3)='he user in entering data on the ' x(4)='coefficient functions p,q,w; on the ' y(4)='limit circle boundary condition ' x(5)='functions u,v; on the end-point clas' y(5)='sifications of the differential ' x(6)='equation; on DEFAULT entry; on eigen' y(6)='value indexes; on IFLAG information;' x(7)='and on the general use of the progra' y(7)='m SLEIGN2. ' x(8)=' The 17 sections of HELP are: ' y(8)=' ' x(9)=' ' y(9)=' ' x(10)=' H1: Overview of HELP. ' y(10)=' ' x(11)=' H2: File name entry. ' y(11)=' ' x(12)=' H3: The differential equation. ' y(12)=' ' x(13)=' H4: End-point classification. ' y(13)=' ' x(14)=' H5: DEFAULT entry. ' y(14)=' ' x(15)=' H6: Limit-circle boundary condit' y(15)='ions. ' do 101 i = 1,15 write(*,*) x(i),y(i) 101 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' H7: General boundary conditions.' y(1)=' ' x(2)=' H8: Recording the results. ' y(2)=' ' x(3)=' H9: Type and choice of interval.' y(3)=' ' x(4)=' H10: Entry of end-points. ' y(4)=' ' x(5)=' H11: End-point values of p,q,w. ' y(5)=' ' x(6)=' H12: Initial value problems. ' y(6)=' ' x(7)=' H13: Indexing of eigenvalues. ' y(7)=' ' x(8)=' H14: Entry of eigenvalue index, i' y(8)='nitial guess, and tolerance. ' x(9)=' H15: IFLAG information. ' y(9)=' ' x(10)=' H16: Plotting. ' y(10)=' ' x(11)=' H17: Indexing of eigenvalues for ' y(11)='periodic-type problems. ' x(12)=' ' y(12)=' ' x(13)=' HELP can be accessed at each point' y(13)=' in MAKEPQW and DRIVE where the user' x(14)='is asked for input, by pressing "h <' y(14)='ENTER>"; this places the user at the' x(15)='appropriate HELP section. Once in H' y(15)='ELP, the user can scroll the further' x(16)='HELP sections by repeatedly pressing' y(16)=' "h ", or jump to a specific ' x(17)='HELP section Hn (n=1,2,...17) by typ' y(17)='ing "Hn "; to return to the ' x(18)='place in the program from which HELP' y(18)=' is called, press "r ". ' do 102 i = 1,18 write(*,*) x(i),y(i) 102 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 2 CONTINUE write(*,*) 'H2: File name entry.' x(1)=' MAKEPQW is used to create a FORTRA' y(1)='N file containing the coefficients ' x(2)='p(x),q(x),w(x), defining the differe' y(2)='ntial equation, and the boundary ' x(3)='condition functions u(x),v(x) if req' y(3)='uired. The file must be given a NEW' x(4)='filename which is acceptable to your' y(4)=' FORTRAN compiler. For example, it ' x(5)='might be called bessel.f or bessel.f' y(5)='or depending upon your compiler. ' x(6)=' The same naming considerations app' y(6)='ly if the FORTRAN file is prepared ' x(7)='other than with the use of MAKEPQW. ' y(7)=' ' do 201 i = 1,7 write(*,*) x(i),y(i) 201 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 3 CONTINUE write(*,*) 'H3: The differential equation.' x(1)=' The prompt "Input p (or q or w) ="' y(1)=' requests you to type in a FORTRAN ' x(2)='expression defining the function p(x' y(2)='), which is one of the three coeffi-' x(3)='cient functions defining the Sturm-L' y(3)='iouville differential equation ' x(4)=' ' y(4)=' ' x(5)=' -(p*y'')'' + q*y = ' y(5)=' lambda*w*y (*) ' x(6)=' ' y(6)=' ' x(7)='to be considered on some interval (a' y(7)=',b) of the real line. The actual ' x(8)='interval used in a particular proble' y(8)='m can be chosen later, and may be ' x(9)='either the whole interval (a,b) wher' y(9)='e the coefficient functions p,q,w, ' x(10)='etc. are defined or any sub-interval' y(10)=' (a'',b'') of (a,b); a = -infinity ' x(11)='and/or b = +infinity are allowable c' y(11)='hoices for the end-points. ' x(12)=' The coefficient functions p,q,w of' y(12)=' the differential equation may be ' x(13)='chosen arbitrarily but must satisfy ' y(13)='the following conditions: ' x(14)=' (1) p,q,w are real-valued througho' y(14)='ut (a,b). ' x(15)=' (2) p,q,w are piece-wise continuou' y(15)='s and defined throughout the ' x(16)=' interior of the interval (a,b)' y(16)='. ' x(17)=' (3) p and w are strictly positive ' y(17)='in (a,b). ' x(18)=' For better error analysis in the n' y(18)='umerical procedures, condition ' x(19)='(2) above is often replaced with ' y(19)=' ' x(20)=' (2'') p,q,w are four times continuo' y(20)='usly differentiable on (a,b). ' x(21)=' The behavior of p,q,w near the end' y(21)='-points a and b is critical to the ' x(22)='classification of the differential e' y(22)='quation (see H4 and H11). ' do 301 i = 1,22 write(*,*) x(i),y(i) 301 continue write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 4 CONTINUE write(*,*) 'H4: End-point classification.' x(1)=' The correct classification of the ' y(1)='end-points a and b is essential to ' x(2)='the working of the SLEIGN2 program. ' y(2)=' To classify the end-points, it is ' x(3)='convenient to choose a point c in (a' y(3)=',b); i.e., a < c < b. Subject to ' x(4)='the general conditions on the coeffi' y(4)='cient functions p,q,w (see H3): ' x(5)=' (1) a is REGULAR (say R) if -infin' y(5)='ity < a, p,q,w are piece-wise ' x(6)=' continuous on [a,c], and p(a) ' y(6)='> 0 and w(a) > 0. ' x(7)=' (2) a is WEAKLY REGULAR (say WR) i' y(7)='f -infinity < a, a is not R, and ' x(8)=' |c ' y(8)=' ' x(9)=' integral | {1/p+|q|+w} < +infi' y(9)='nity. ' x(10)=' |a ' y(10)=' ' x(11)=' ' y(11)=' ' x(12)=' If end-point a is neither R nor ' y(12)='WR, then a is SINGULAR; that is, ' x(13)=' either -infinity = a, or -infinity' y(13)=' < a and ' x(14)=' |c ' y(14)=' ' x(15)=' integral | {1/p+|q|+w} = +infi' y(15)='nity. ' x(16)=' |a ' y(16)=' ' x(17)=' (3) The SINGULAR end-point a is LI' y(17)='MIT-CIRCLE NON-OSCILLATORY (say ' x(18)=' LCNO) if for some real lambda ' y(18)='ALL real-valued solutions y of the ' x(19)=' differential equation ' y(19)=' ' x(20)=' ' y(20)=' ' x(21)=' -(p*y'')'' + q*y = ' y(21)=' lambda*w*y on (a,c] (*) ' x(22)=' ' y(22)=' ' x(23)=' satisfy the conditions: ' y(23)=' ' do 401 i = 1,23 write(*,*) x(i),y(i) 401 continue read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' |c ' y(1)=' ' x(2)=' integral | { w*y*y } < +infini' y(2)='ty, and ' x(3)=' |a ' y(3)=' ' x(4)=' y has at most a finite number ' y(4)='of zeros in (a,c]. ' x(5)=' (4) The SINGULAR end-point a is LI' y(5)='MIT-CIRCLE OSCILLATORY (say LCO) if ' x(6)='for some real lambda ALL real-valued' y(6)=' solutions of the differential ' x(7)='equation (*) satisfy the conditions:' y(7)=' ' x(8)=' |c ' y(8)=' ' x(9)=' integral | { w*y*y } < +infini' y(9)='ty, and ' x(10)=' |a ' y(10)=' ' x(11)=' y has an infinite number of ze' y(11)='ros in (a,c]. ' x(12)=' (5) The SINGULAR end-point a is LI' y(12)='MIT POINT (say LP) if for some real ' x(13)='lambda at least one solution of the ' y(13)='differential equation (*) satisfies ' x(14)='the condition: ' y(14)=' ' x(15)=' |c ' y(15)=' ' x(16)=' integral | {w*y*y} = +infinity' y(16)='. ' x(17)=' |a ' y(17)=' ' x(18)=' There is a similar classification ' y(18)='of the end-point b into one of the ' x(19)='five distinct cases R, WR, LCNO, LCO' y(19)=', LP. ' do 402 i = 1,19 write(*,*) x(i),y(i) 402 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' Although the classification of sin' y(1)='gular end-points invokes a real ' x(2)='value of the parameter lambda, this ' y(2)='classification is invariant in ' x(3)='lambda; all real choices of lambda l' y(3)='ead to the same classification. ' x(4)=' In determining the classification ' y(4)='of singular end-points for the ' x(5)='differential equation (*), it is oft' y(5)='en convenient to start with the ' x(6)='choice lambda = 0 in attempting to f' y(6)='ind solutions (particularly when ' x(7)='q = 0 on (a,b)); however, see exampl' y(7)='e 7 below. ' x(8)=' See H6 on the use of maximal domai' y(8)='n functions to determine the ' x(9)='classification at singular end-point' y(9)='s. ' do 403 i = 1,9 write(*,*) x(i),y(i) 403 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N write(*,*) ' EXAMPLES: ' x(1)=' 1. -y'''' = lambda*y is R at both en' y(1)='d-points of (a,b) when a and b are ' x(2)=' finite. ' y(2)=' ' x(3)=' 2. -y'''' = lambda*y on (-infinity,i' y(3)='nfinity) is LP at both end-points. ' x(4)=' 3. -(sqrt(x)*y''(x))'' = lambda*(1./' y(4)='sqrt(x))*y(x) on (0,infinity) is ' x(5)=' WR at 0 and LP at +infinity (ta' y(5)='ke lambda = 0 in (*)). See ' x(6)=' examples.f, #10 (Weakly Regular' y(6)='). ' x(7)=' 4. -((1-x*x)*y''(x))'' = lambda*y(x)' y(7)=' on (-1,1) is LCNO at both ends ' x(8)=' (take lambda = 0 in (*)). See ' y(8)='xamples.f, #1 (Legendre). ' x(9)=' 5. -y''''(x) + C*(1/(x*x))*y(x) = la' y(9)='mbda*y(x) on (0,infinity) is LP at ' x(10)=' infinity and at 0 is (take lamb' y(10)='da = 0 in (*)): ' x(11)=' LP for C .ge. 3/4 ; ' y(11)=' ' x(12)=' LCNO for -1/4 .le. C .lt. 3/4' y(12)=' (but C .ne. 0); ' x(13)=' LCO for C .lt. -1/4. ' y(13)=' ' x(14)=' 6. -(x*y''(x))'' - (1/x)*y(x) = lamb' y(14)='da*y(x) on (0,infinity) is LCO at 0 ' x(15)=' and LP at +infinity (take lambd' y(15)='a = 0 in (*) with solutions ' x(16)=' cos(ln(x)) and sin(ln(x))). Se' y(16)='e xamples.f, #7 (BEZ). ' x(17)=' 7. -(x*y''(x))'' - x*y(x) = lambda*(' y(17)='1/x)*y(x) on (0,infinity) is LP at 0' x(18)=' and LCO at infinity (take lambd' y(18)='a = -1/4 in (*) with solutions ' x(19)=' cos(x)/sqrt(x) and sin(x)/sqrt(' y(19)='x)). See xamples.f, ' x(20)=' #6 (Sears-Titchmarsh). ' y(20)=' ' do 404 i = 1,20 write(*,*) x(i),y(i) 404 continue write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 5 CONTINUE write(*,*) 'H5: DEFAULT entry.' x(1)=' The complete range of problems for' y(1)=' which SLEIGN2 is applicable can ' x(2)='only be reached by appropriate entri' y(2)='es under end-point classification ' x(3)='and boundary conditions. However, t' y(3)='here is a DEFAULT application which ' x(4)='requires no detailed entry of end-po' y(4)='int classification or boundary ' x(5)='conditions, subject to: ' y(5)=' ' x(6)=' 1) The DEFAULT application CANNOT ' y(6)='be used at a LCO end-point. ' x(7)=' 2) If an end-point a is R, then th' y(7)='e Dirichlet boundary condition ' x(8)=' y(a) = 0 is automatically used.' y(8)=' ' x(9)=' 3) If an end-point a is WR, then t' y(9)='he following boundary condition ' x(10)=' is automatically applied: ' y(10)=' ' x(11)=' if p(a) = 0, and both q(a),w(' y(11)='a) are bounded, then the Dirichlet ' x(12)=' boundary condition y(a) = 0 i' y(12)='s used, or ' x(13)=' if p(a) > 0, and q(a) and/or ' y(13)='w(a)) are not bounded, then the ' x(14)=' Neumann boundary condition (p' y(14)='y'')(a) = 0 is used. ' x(15)=' If p(a) = 0, and q(a) and/or w(' y(15)='a) are not bounded, then no reliable' x(16)=' information can be given on the' y(16)=' DEFAULT boundary condition. ' x(17)=' 4) If an end-point is LCNO, then i' y(17)='n most cases the principal or ' x(18)=' Friedrichs boundary condition i' y(18)='s applied (see H6). ' x(19)=' 5) If an end-point is LP, then the' y(19)=' normal LP procedure is applied ' x(20)=' (see H7(1.)). ' y(20)=' ' x(21)='If you choose the DEFAULT condition,' y(21)=' then no entry is required for the ' x(22)='u,v boundary condition functions. ' y(22)=' ' do 501 i = 1,22 write(*,*) x(i),y(i) 501 continue write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 6 CONTINUE write(*,*) 'H6: Limit-circle boundary conditions.' x(1)=' At an end-point a, the limit-circl' y(1)='e type separated boundary condition ' x(2)='is of the form (similar remarks thro' y(2)='ughout apply to the end-point b) ' x(3)=' ' y(3)=' ' x(4)=' A1*[y,u](a) + A2*[y,v](a) = 0' y(4)=', (**) ' x(5)=' ' y(5)=' ' x(6)='where y is a solution of the differe' y(6)='ntial equation ' x(7)=' ' y(7)=' ' x(8)=' -(p*y'')'' + q*y = lambda*w*y on' y(8)=' (a,b). (*) ' x(9)=' ' y(9)=' ' x(10)='Here A1, A2 are real numbers; u and ' y(10)='v are boundary condition functions; ' x(11)='and for real-valued y and u the form' y(11)=' [y,u] is defined by ' x(12)=' ' y(12)=' ' x(13)=' [y,u](x) = y(x)*(pu'')(x) - u(x' y(13)=')*(py'')(x) for x in (a,b). ' x(14)=' ' y(14)=' ' x(15)=' The object of this section is to p' y(15)='rovide help in choosing appropriate ' x(16)='functions u and v in (**), given the' y(16)=' differential equation (*). Full ' x(17)='details of the boundary conditions f' y(17)='or (*) are discussed in H7; here it ' x(18)='is sufficient to say that the limit-' y(18)='circle type boundary condition (**) ' x(19)='can be applied at any end-point in t' y(19)='he LCNO, LCO classification, but ' x(20)='also in the R, WR classification sub' y(20)='ject to the appropriate choice of ' x(21)='u and v. ' y(21)=' ' do 601 i = 1,21 write(*,*) x(i),y(i) 601 continue write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' Let (*) be R, WR, LCNO, or LCO at ' y(1)='end-point a and choose c in (a,b). ' x(2)='Then either ' y(2)=' ' x(3)=' u and v are a pair of linearly i' y(3)='ndependent solutions of (*) on (a,c]' x(4)=' for any chosen real values of lamb' y(4)='da, or ' x(5)=' u and v are a pair of real-value' y(5)='d maximal domain functions defined ' x(6)=' on (a,c] satisfying [u,v](a) .ne. ' y(6)='0. The maximal domain D(a,c] is ' x(7)=' defined by ' y(7)=' ' x(8)=' ' y(8)=' ' x(9)=' D(a,c] = {f:(a,c]->R:: f,pf'' ' y(9)='in AC(a,c]; ' x(10)=' f, ((-pf'')''+qf)/w' y(10)=' in L2((a,c;w)} ' x(11)=' ' y(11)=' ' x(12)=' It is known that for all f,g in D(' y(12)='a,c] the limit ' x(13)=' ' y(13)=' ' x(14)=' [f,g](a) = lim[f,g](x) as x->' y(14)='a ' x(15)=' ' y(15)=' ' x(16)=' exists and is finite. If (*) is L' y(16)='CNO or LCO at a, then all solutions ' x(17)=' of (*) belong to D(a,c] for all va' y(17)='lues of lambda. ' do 602 i = 1,17 write(*,*) x(i),y(i) 602 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' The boundary condition (**) is ess' y(1)='ential in the LCNO and LCO cases but' x(2)='can also be used with advantage in s' y(2)='ome R and WR cases. In the R, WR, ' x(3)='and LCNO cases, but not in the LCO c' y(3)='ase, the boundary condition ' x(4)='functions can always be chosen so th' y(4)='at ' x(5)=' lim u(x)/v(x) = 0 as x->a, ' y(5)=' ' x(6)='and it is recommended that this norm' y(6)='alisation be effected; this has been' x(7)='done in the examples given below. In' y(7)=' this case, the boundary condition ' x(8)='[y,u](a) = 0 (i.e., A1 = 1, A2 = 0 i' y(8)='n (**)) is called the principal or ' x(9)='Friedrichs boundary condition. ' y(9)=' ' x(10)=' ' y(10)=' ' x(11)=' In the case when end-points a and ' y(11)='b are, independently, in R, WR, ' x(12)='LCNO, or LCO classification, it may ' y(12)='be that symmetry or other reasons ' x(13)='permit one set of boundary condition' y(13)=' functions to be used at both end- ' x(14)='points (see xamples.f, #1 (Legendre)' y(14)='). In other cases, different pairs ' x(15)='must be chosen for each end-point (s' y(15)='ee xamples.f: #16 (Jacobi), ' x(16)='#18 (Dunsch), and #19 (Donsch)). ' y(16)=' ' x(17)=' ' y(17)=' ' x(18)=' Note that a solution pair u,v is a' y(18)='lways a maximal domain pair, but not' x(19)='necessarily vice versa. ' y(19)=' ' do 603 i = 1,19 write(*,*) x(i),y(i) 603 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' EXAMPLES: ' y(1)=' ' x(2)='1. -y''''(x) = lambda*y(x) on [0,pi] i' y(2)='s R at 0 and R at pi. ' x(3)=' At 0, with lambda = 0, a solution' y(3)=' pair is u(x) = x, v(x) = 1. ' x(4)=' At pi, with lambda = 1, a solutio' y(4)='n pair is ' x(5)=' u(x) = sin(x), v(x) = cos(x). ' y(5) =' ' x(6)='2. -(sqrt(x)*y''(x))'' = lambda*y(x)/s' y(6)='qrt(x) on (0,1] is ' x(7)=' WR at 0 and R at 1. ' y(7)=' ' x(8)=' (The general solutions of this eq' y(8)='uation are ' x(9)=' u(x) = cos(2*sqrt(x*lambda)), v' y(9)='(x) = sin(2*sqrt(x*lambda)).) ' x(10)=' At 0, with lambda = 0, a solution' y(10)=' pair is ' x(11)=' u(x) = 2*sqrt(x), v(x) = 1. ' y(11)=' ' x(12)=' At 1, with lambda = pi*pi/4, a so' y(12)='lution pair is ' x(13)=' u(x) = sin(pi*sqrt(x)), v(x) = ' y(13)='cos(pi*sqrt(x)). ' x(14)=' At 1, with lambda = 0, a solution' y(14)=' pair is ' x(15)=' u(x) = 2*(1-sqrt(x)), v(x) = 1.' y(15)=' ' x(16)=' See also xamples.f, #10 (Weakly R' y(16)='egular). ' x(17)='3. -((1-x*x)*y''(x))'' = lambda*y(x) o' y(17)='n (-1,1) is LCNO at both ends. ' x(18)=' At +-1, with lambda = 0, a soluti' y(18)='on pair is ' x(19)=' u(x) = 1, v(x) = 0.5*log((1+x)/' y(19)='(1-x)). ' x(20)=' At 1, a maximal domain pair is u(' y(20)='x) = 1, v(x) = log(1-x) ' x(21)=' At -1, a maximal domain pair is u' y(21)='(x) = 1, v(x) = log(1+x). ' x(22)=' See also xamples.f, #1 (Legendre)' y(22)='. ' do 604 i = 1,22 write(*,*) x(i),y(i) 604 continue write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)='4. -y''''(x) - (1/(4x*x))*y(x) = lambd' y(1)='a*y(x) on (0,infinity) is ' x(2)=' LCNO at 0 and LP at +infinity. ' y(2)=' ' x(3)=' At 0, a maximal domain pair is ' y(3)=' ' x(4)=' u(x) = sqrt(x), v(x) = sqrt(x)*' y(4)='log(x). ' x(5)=' See also xamples.f, #2 (Bessel). ' y(5)=' ' x(6)='5. -y''''(x) - 5*(1/(4*x*x))*y(x) = la' y(6)='mbda*y(x) on (0,infinity) is ' x(7)=' LCO at 0 and LP at +infinity. ' y(7)=' ' x(8)=' At 0, with lambda = 0, a solution' y(8)=' pair is ' x(9)=' u(x) = sqrt(x)*cos(log(x)), v(x' y(9)=') = sqrt(x)*sin(log(x)) ' x(10)=' See also xamples.f, #20 (Krall). ' y(10)=' ' x(11)='6. -y''''(x) - (1/x)*y(x) = lambda*y(x' y(11)=') on (0,infinity) is ' x(12)=' LCNO at 0 and LP at +infinity.' y(12)=' ' x(13)=' At 0, a maximal domain pair is ' y(13)=' ' x(14)=' u(x) = x, v(x) = 1 -x*log(x). ' y(14)=' ' x(15)=' See also xamples.f, #4(Boyd). ' y(15)=' ' x(16)='7. -((1/x)*y''(x))'' + (k/(x*x) + k*k/' y(16)='x)*y(x) = lambda*y(x) on (0,1], ' x(17)=' with k real and .ne. 0, is LCNO' y(17)=' at 0 and R at 1. ' x(18)=' At 0, a maximal domain pair is ' y(18)=' ' x(19)=' u(x) = x*x, v(x) = x - 1/k. ' y(19)=' ' x(20)=' See also xamples.f, #8 (Laplace T' y(20)='idal Wave). ' do 605 i = 1,20 write(*,*) x(i),y(i) 605 continue write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 7 CONTINUE write(*,*) 'H7: General boundary conditions.' x(1)=' Boundary conditions for Sturm-Liou' y(1)='ville boundary value problems ' x(2)=' ' y(2)=' ' x(3)=' -(p*y'')'' + q*y = ' y(3)=' lambda*w*y (*) ' x(4)=' ' y(4)=' ' x(5)='on an interval (a,b) are either ' y(5)=' ' x(6)=' SEPARATED, with at most one cond' y(6)='ition at end-point a and at most ' x(7)=' one condition at end-point b, or ' y(7)=' ' x(8)=' COUPLED, when both a and b are, ' y(8)='independently, in one of the end- ' x(9)=' point classifications R, WR, LCNO,' y(9)=' LCO, in which case two independent ' x(10)=' ent boundary conditions are requir' y(10)='ed which link the solution values ' x(11)=' near a to those near b. ' y(11)=' ' x(12)='The SLEIGN2 program allows for all s' y(12)='eparated conditions; and special ' x(13)='cases of the coupled conditions -- t' y(13)='he so-called periodic boundary ' x(14)='conditions applicable only when the ' y(14)='interval (a,b) is finite and both ' x(15)='a and b are R. ' y(15)=' ' do 701 i = 1,15 write(*,*) x(i),y(i) 701 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N write(*,*) ' Separated Conditions: ' write(*,*) ' --------------------- ' x(1)=' The boundary conditions to be sele' y(1)='cted depend upon the classification ' x(2)='of the differential equation at the ' y(2)='end-point, say, a: ' x(3)=' 1. If the end-point a is LP, the' y(3)='n no boundary condition is required ' x(4)=' or allowed. ' y(4)=' ' x(5)=' 2. If the end-point a is R or WR' y(5)=', then a separated boundary ' x(6)=' condition is of the form ' y(6)=' ' x(7)=' A1*y(a) + A2*(py'')(a) = 0,' y(7)=' ' x(8)=' where A1, A2 are real constants yo' y(8)='u must choose, not both zero. ' x(9)=' 3. If the end-point a is LCNO or' y(9)=' LCO, then a separated boundary ' x(10)=' condition is of the form ' y(10)=' ' x(11)=' A1*[y,u](a) + A2*[y,v](a) =' y(11)=' 0, ' x(12)=' where A1, A2 are real constants yo' y(12)='u must choose, not both zero; ' x(13)=' here, u,v are the pair of boundary' y(13)=' condition functions you have ' x(14)=' previously selected when the input' y(14)=' FORTRAN file was being prepared. ' x(15)=' 4. If the end-point a is LCNO an' y(15)='d the boundary condition pair ' x(16)=' u,v has been chosen so that ' y(16)=' ' x(17)=' lim u(x)/v(x) = 0 as x->a ' y(17)=' ' x(18)=' (which is always possible), then A' y(18)='1 = 1, A2 = 0 (i.e., [y,u](a) = 0) ' x(19)=' gives the principal (Friedrichs) b' y(19)='oundary condition at a. ' do 702 i = 1,19 write(*,*) x(i),y(i) 702 continue write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' 5. If a is R or WR and boundary ' y(1)='condition functions u,v have been ' x(2)=' entered in the FORTRAN input file,' y(2)=' then (3.,4.) above apply to ' x(3)=' entering separated boundary condit' y(3)='ions at such an end-point; the ' x(4)=' boundary conditions in this form a' y(4)='re equivalent to the point-wise ' x(5)=' conditions in (2.) (subject to car' y(5)='e in choosing A1, A2). This ' x(6)=' singular form of a regular boundar' y(6)='y condition may be particularly ' x(7)=' effective in the WR case if the bo' y(7)='undary condition form in (2.) leads ' x(8)=' to numerical difficulties. ' y(8)=' ' x(9)=' ' y(9)=' ' x(10)=' Conditions (2.,3.,4.,5.) apply sim' y(10)='ilarly at end-point b. ' x(11)=' ' y(11)=' ' x(12)=' 6. If a is R, WR, LCNO, or LCO a' y(12)='nd b is LP, then only a separated ' x(13)=' condition at a is required and all' y(13)='owed (or instead at b if a and b ' x(14)=' are interchanged). ' y(14)=' ' x(15)=' 7. If both end-points a and b ar' y(15)='e LP, then no boundary conditions ' x(16)=' are required or allowed. ' y(16)=' ' x(17)=' ' y(17)=' ' x(18)=' The indexing of eigenvalues for bo' y(18)='undary value problems with separated' x(19)=' conditions is discussed in H13. ' y(19)=' ' do 703 i = 1,19 write(*,*) x(i),y(i) 703 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),n write(*,*) ' Coupled Conditions: ' write(*,*) ' ------------------- ' x(1)=' 8. Periodic-type boundary condit' y(1)='ions on (a,b) apply only when ' x(2)=' both end-points a and b are R; the' y(2)='se conditions are of the form ' x(3)=' ' y(3)=' ' x(4)=' y(b) = c*y(a), (py'')(b) = (' y(4)='py'')(a)/c, ' x(5)=' ' y(5)=' ' x(6)=' where c may be chosen to be any re' y(6)='al number not equal to 0. The case ' x(7)=' c = 1 is called periodic, the case' y(7)=' c = -1 is called semi-periodic. ' x(8)=' ' y(8)=' ' x(9)=' The indexing of eigenvalues for pe' y(9)='riodic-type boundary conditions is ' x(10)=' discussed in H17. ' y(10)=' ' do 704 i = 1,10 write(*,*) x(i),y(i) 704 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 8 CONTINUE write(*,*) 'H8: Recording the results.' x(1)=' If you choose to have a record kep' y(1)='t of the results, then the following' x(2)='information is stored in a file with' y(2)=' the name you select: ' x(3)=' ' y(3)=' ' x(4)=' 1. The file name. ' y(4)=' ' x(5)=' 2. The header line prompted for (u' y(5)='p to 32 characters of your choice). ' x(6)=' 3. The interval (a,b) which was us' y(6)='ed. ' x(7)=' ' y(7)=' ' x(8)=' For SEPARATED boundary conditions:' y(8)=' ' x(9)=' 4. The end-point classification. ' y(9)=' ' x(10)=' 5. A summary of coefficient inform' y(10)='ation at WR, LCNO, LCO end-points. ' x(11)=' 6. The boundary condition constant' y(11)='s (A1,A2), (B1,B2) if entered. ' x(12)=' 7. (NUMEIG,EIG,TOL) or (NUMEIG1,NU' y(12)='MEIG2,TOL), as entered. ' x(13)=' ' y(13)=' ' x(14)=' For COUPLED boundary conditions: ' y(14)=' ' x(15)=' 8. The boundary condition paramete' y(15)='r, c. ' x(16)=' ' y(16)=' ' x(17)=' For ALL boundary conditions: ' y(17)=' ' x(18)=' 9. The computed eigenvalue, EIG, a' y(18)='nd its estimated accuracy, TOL. ' x(19)=' 10. IFLAG reported (see H15). ' y(19)=' ' do 801 i = 1,19 write(*,*) x(i),y(i) 801 continue write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 9 CONTINUE write(*,*) 'H9: Type and choice of interval.' x(1)=' You may enter any interval (a,b) f' y(1)='or which the coefficients p,q,w are ' x(2)='well defined by your FORTRAN stateme' y(2)='nts in the input file, provided that' x(3)='(a,b) contains no interior singulari' y(3)='ities. ' do 901 i = 1,3 write(*,*) x(i),y(i) 901 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 10 CONTINUE write(*,*) 'H10: Entry of end-points.' x(1)=' End-points a and b must be entered' y(1)=' as real numbers. There is no ' x(2)='symbolic entry; e.g., pi must be ent' y(2)='ered as 3.14159... to an appropriate' x(3)='number of decimal places. ' y(3)=' ' do 1001 i = 1,3 write(*,*) x(i),y(i) 1001 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 11 CONTINUE write(*,*) 'H11: End-point values of p,q,w.' x(1)=' The program SLEIGN2 needs to know ' y(1)='whether the coefficient functions ' x(2)='p(x),q(x),w(x) defined by the FORTRA' y(2)='N expressions entered in the input ' x(3)='file can be evaluated numerically wi' y(3)='thout running into difficulty. If, ' x(4)='for example, either q or w is unboun' y(4)='ded at a, or p(a) is 0, then SLEIGN2' x(5)='needs to know this so that a is not ' y(5)='chosen for functional evaluation. ' do 1101 i = 1,5 write(*,*) x(i),y(i) 1101 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 12 CONTINUE write(*,*) 'H12: Initial value problems.' x(1)=' The initial value problem facility' y(1)=' for Sturm-Liouville problems ' x(2)=' ' y(2)=' ' x(3)=' -(p*y'')'' + q*y = ' y(3)=' lambda*w*y (*) ' x(4)=' ' y(4)=' ' x(5)='allows for the computation of a solu' y(5)='tion of (*) with a user-chosen ' x(6)='value lambda and any one of the foll' y(6)='owing initial conditions: ' x(7)=' 1. From end-point a of any classif' y(7)='ication except LP towards ' x(8)='end-point b of any classification, ' y(8)=' ' x(9)=' 2. From end-point b of any classif' y(9)='ication except LP back towards ' x(10)='end-point a of any classification, ' y(10)=' ' x(11)=' 3. From end-points a and b of any ' y(11)='classifications except LP towards an' x(12)='interior point of (a,b) selected by ' y(12)='the program. ' x(13)=' ' y(13)=' ' x(14)=' Initial values at a are of the for' y(14)='m y(a) = alpha1, (p*y'')a = alpha2, ' x(15)='when a is R or WR; and [y,u](a) = al' y(15)='pha1, [y,v](a) = alpha2, when a is ' x(16)='LCNO or LCO. ' y(16)=' ' x(17)=' Initial values at b are of the for' y(17)='m y(b) = beta1, (p*y'')b = beta2, ' x(18)='when b is R or WR; and [y,u](b) = be' y(18)='ta1, [y,v](b) = beta2, when b is ' x(19)='LCNO or LCO. ' y(19)=' ' x(20)=' In (*), lambda is a user-chosen re' y(20)='al number; while in the above ' x(21)='initial values, (alpha1,alpha2) and ' y(21)='(beta1,beta2) are user-chosen pairs ' x(22)='of real numbers not both zero. ' y(22)=' ' do 1201 i = 1,22 write(*,*) x(i),y(i) 1201 continue write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' In the initial value case (3.) abo' y(1)='ve when the interval (a,b) is ' x(2)='finite, the interior point selected ' y(2)='by the program is generally near the' x(3)='midpoint of (a,b); when (a,b) is inf' y(3)='inite, no general rule can be given.' x(4)='Also if, given (alpha1,alpha2) and (' y(4)='beta1,beta2), the lambda chosen is ' x(5)='an eigenvalue of the associated boun' y(5)='dary value problem, the computed ' x(6)='solution may not be the correspondin' y(6)='g eigenfunction -- the signs of the ' x(7)='computed solutions on either side of' y(7)=' the interior point may be opposite.' x(8)=' The output for a solution of an in' y(8)='itial value problem is in the form ' x(9)='of stored numerical data which can b' y(9)='e plotted on the screen (see H16), ' x(10)='or printed out in graphical form if ' y(10)='graphics software is available. ' do 1202 i = 1,10 write(*,*) x(i),y(i) 1202 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 13 continue write(*,*) 'H13: Indexing of eigenvalues.' x(1)=' The indexing of eigenvalues is an ' y(1)='automatic facility in SLEIGN2. The ' x(2)='following general results hold for t' y(2)='he separated boundary condition ' x(3)='problem (see H7): ' y(3)=' ' x(4)=' 1. If neither end-point a or b is ' y(4)='LP or LCO, then the spectrum of the ' x(5)='eigenvalue problem is discrete (eige' y(5)='nvalues only), simple (eigenvalues ' x(6)='all of multiplicity 1), and bounded ' y(6)='below with a single cluster point at' x(7)='+infinity. The eigenvalues are inde' y(7)='xed as {lambda(n): n=0,1,2,...}, ' x(8)='where lambda(n) < lambda(n+1) (n=0,1' y(8)=',2,...), lim lambda(n) -> +infinity;' x(9)='and if {psi(n): n=0,1,2,...} are the' y(9)=' corresponding eigenfunctions, then ' x(10)='psi(n) has exactly n zeros in the op' y(10)='en interval (a,b). ' x(11)=' 2. If neither end-point a or b is ' y(11)='LP but at least one end-point is ' x(12)='LCO, then the spectrum is discrete a' y(12)='nd simple as for (1.), but with ' x(13)='cluster points at both +infinity and' y(13)=' -infinity. The eigenvalues are ' x(14)='indexed as {lambda(n): n=0,1,-1,2,-2' y(14)=',...}, where ' x(15)='lambda(n) < lambda(n+1) (n=...-2,-1,' y(15)=',0,1,2,...) with lambda(0) the ' x(16)='smallest non-negative eigenvalue and' y(16)=' lim lambda(n) -> +infinity or ' x(17)='-> -infinity with n; and if {psi(n):' y(17)=' n=0,1,-1,2,-2,...} are the ' x(18)='corresponding eigenfunctions, then e' y(18)='very psi(n) has infinitely many ' x(19)='zeros in (a,b). ' y(19)=' ' do 1301 i = 1,19 write(*,*) x(i),y(i) 1301 continue write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' 3. If one or both end-points is LP' y(1)=', then there can be one or more ' x(2)='intervals of continuous spectrum for' y(2)=' the boundary value problem in ' x(3)='addition to some (necessarily simple' y(3)=') eigenvalues. For these ' x(4)='essentially more difficult problems,' y(4)=' SLEIGN2 can be used as an ' x(5)='investigative tool to give qualitati' y(5)='ve and possibly quantitative ' x(6)='information on the spectrum. ' y(6)=' ' x(7)=' For example, if a problem has a' y(7)=' single interval of continuous ' x(8)='spectrum bounded below by K, then th' y(8)='ere may be any number of eigenvalues' x(9)='below K. In some cases, SLEIGN2 can' y(9)=' compute K, and determine the number' x(10)='of these eigenvalues and compute the' y(10)='m. In this respect, see xamples.f: ' x(11)='#13 (Hydrogen Atom), #17 (Morse Osci' y(11)='llator), #21 (Fourier), and ' x(12)='#27 (Joergens) as examples of succes' y(12)='s; and #2 (Mathieu), #14 (Marletta),' x(13)='and #28 (Behnke-Goerisch) as example' y(13)='s of failure. ' x(14)=' The problem need not have a con' y(14)='tinuous spectrum, in which case if ' x(15)='its discrete spectrum is bounded bel' y(15)='ow, then the eigenvalues are indexed' x(16)='and the eigenfunctions have zero cou' y(16)='nts as in (1.). If, on the other ' x(17)='hand, the discrete spectrum is unbou' y(17)='nded below, then all the ' x(18)='eigenfunctions have infinitely many ' y(18)='zeros in the interval. ' do 1302 i = 1,18 write(*,*) x(i),y(i) 1302 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' In respect to the three classes of' y(1)=' end-points, the following ' x(2)='identified examples from xamples.f i' y(2)='llustrate the spectral property ' x(3)='of these boundary value problems: ' y(3)=' ' x(4)=' 1. Neither end-point is LP or LCO.' y(4)=' ' x(5)=' #1 (Legendre) ' y(5)=' ' x(6)=' #2 (Bessel) with -1/4 < c < 3' y(6)='/4 ' x(7)=' #4 (Boyd) ' y(7)=' ' x(8)=' #5 (Latzko) ' y(8)=' ' x(9)=' 2. Neither end-point is LP, but at' y(9)=' least one is LCO. ' x(10)=' #6 (Sears-Titchmarsh) ' y(10)=' ' x(11)=' #7 (BEZ) ' y(11)=' ' x(12)=' #19 (Donsch) ' y(12)=' ' x(13)=' 3. At least one end-point is LP. ' y(13)=' ' x(14)=' #13 (Hydrogen Atom) ' y(14)=' ' x(15)=' #14 (Marletta) ' y(15)=' ' x(16)=' #20 (Krall) ' y(16)=' ' x(17)=' #21 (Fourier) on [0,infinity) ' y(17)=' ' do 1303 i = 1,17 write(*,*) x(i),y(i) 1303 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 14 CONTINUE write(*,*) 'H14: Entry of eigenvalue index, initial guess,'// 1 ' and tolerance.' x(1)=' For SEPARATED boundary condition p' y(1)='roblems (see H7), SLEIGN2 calls for ' x(2)='input information options to compute' y(2)=' either ' x(3)=' 1. a single eigenvalue, or ' y(3)=' ' x(4)=' 2. a series of eigenvalues. ' y(4)=' ' x(5)='In each case indexing of eigenvalues' y(5)=' is called for (see H13). ' x(6)=' (1.) above asks for data triples N' y(6)='UMEIG, EIG, TOL separated by commas.' x(7)='Here NUMEIG is the integer index of ' y(7)='the desired eigenvalue; NUMEIG can ' x(8)='be negative only when the problem is' y(8)=' LCO at one or both end-points. ' x(9)='EIG allows for the entry of an initi' y(9)='al guess for the requested ' x(10)='eigenvalue (if an especially good on' y(10)='e is available), or can be set to 0 ' x(11)='in which case an initial guess is ge' y(11)='nerated by SLEIGN2 itself. ' x(12)='TOL is the desired accuracy of the c' y(12)='omputed eigenvalue. It is an ' x(13)='absolute accuracy if the magnitude o' y(13)='f the eigenvalue is 1 or less, and ' x(14)='is a relative accuracy otherwise. T' y(14)='ypical values might be .001 for ' x(15)='moderate accuracy and .0000001 for h' y(15)='igh accuracy in single precision. ' x(16)='If TOL is set to 0, the maximum achi' y(16)='evable accuracy is requested. ' x(17)=' If the input data list is truncate' y(17)='d with a "/" after NUMEIG or EIG, ' x(18)='then the remaining elements default ' y(18)='to 0. ' do 1401 i = 1,18 write(*,*) x(i),y(i) 1401 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' (2.) above asks for data triples N' y(1)='UMEIG1, NUMEIG2, TOL separated by ' x(2)='commas. Here NUMEIG1 and NUMEIG2 ar' y(2)='e the first and last integer indices' x(3)='of the sequence of desired eigenvalu' y(3)='es, NUMEIG1 < NUMEIG2; they can be ' x(4)='negative only when the problem is LC' y(4)='O at one or both end-points. ' x(5)='TOL is the desired accuracy of the c' y(5)='omputed eigenvalues. It is an ' x(6)='absolute accuracy if the magnitude o' y(6)='f an eigenvalue is 1 or less, and ' x(7)='is a relative accuracy otherwise. T' y(7)='ypical values might be .001 for ' x(8)='moderate accuracy and .0000001 for h' y(8)='igh accuracy in single precision. ' x(9)='If TOL is set to 0, the maximum achi' y(9)='evable accuracy is requested. ' x(10)=' If the input data list is truncate' y(10)='d with a "/" after NUMEIG2, then TOL' x(11)='defaults to 0. ' y(11)=' ' x(12)=' ' y(12)=' ' x(13)=' For COUPLED periodic-type boundary' y(13)=' condition problems (see H7 and ' x(14)='H17), SLEIGN2 asks only for NUMEIG, ' y(14)='the non-negative integer index of ' x(15)='the desired eigenvalue; TOL is set i' y(15)='nternally. ' do 1402 i = 1,15 write(*,*) x(i),y(i) 1402 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 15 CONTINUE write(*,*) 'H15: IFLAG information.' x(1)=' All results are reported by SLEIGN' y(1)='2 with a flag identification. There' x(2)='are four values of IFLAG: ' y(2)=' ' x(3)=' ' y(3)=' ' x(4)=' 1 - The computed eigenvalue has an' y(4)=' estimated accuracy within the ' x(5)=' tolerance requested. ' y(5)=' ' x(6)=' ' y(6)=' ' x(7)=' 2 - The computed eigenvalue does n' y(7)='ot have an estimated accuracy within' x(8)=' the tolerance requested, but i' y(8)='s the best the program could obtain.' x(9)=' ' y(9)=' ' x(10)=' 3 - There seems to be no eigenvalu' y(10)='e of index equal to NUMEIG. ' x(11)=' ' y(11)=' ' x(12)=' 4 - The program has been unable to' y(12)=' compute the requested eigenvalue. ' do 1501 i = 1,12 write(*,*) x(i),y(i) 1501 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 16 CONTINUE write(*,*) 'H16: Plotting.' x(1)=' After computing a single eigenvalu' y(1)='e (see H14(1.)), but not a sequence ' x(2)='of eigenvalues (see H14(2.)), the ei' y(2)='genfunction can be plotted. If this' x(3)='is desired, respond "y" when asked s' y(3)='o that SLEIGN2 will compute some ' x(4)='eigenfunction data and store them. ' y(4)=' ' x(5)=' One can ask that the eigenfunction' y(5)=' data be in the form of either ' x(6)='points (x,y) for x in (a,b), or poin' y(6)='ts (t,y) for t in the standardized ' x(7)='interval (-1,1) mapped onto from (a,' y(7)='b); the t- choice can be especially ' x(8)='helpful when the original interval i' y(8)='s infinite. Additionally, one can ' x(9)='ask for a plot of the so-called Pruf' y(9)='er angle, in x- or t- variables. ' x(10)=' In both forms, once the choice has' y(10)=' been made of the function to be ' x(11)='plotted, a crude plot is displayed o' y(11)='n the monitor screen and you are ' x(12)='asked whether you wish to save the c' y(12)='omputed plot points in a file. ' do 1601 i = 1,12 write(*,*) x(i),y(i) 1601 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 17 CONTINUE write(*,*) 'H17: Indexing of eigenvalues for'// 1 ' periodic-type problems.' x(1)=' The indexing of eigenvalues is an ' y(1)='automatic facility in SLEIGN2. The ' x(2)='following general result holds for t' y(2)='he periodic-type boundary condition ' x(3)='problem (see H7): ' y(3)=' ' x(4)=' The spectrum of the eigenvalue pro' y(4)='blem is discrete (eigenvalues only),' x(5)='and bounded below with a single clus' y(5)='ter point at +infinity. In general,' x(6)='the spectrum is not simple, but no e' y(6)='igenvalue exceeds multiplicity 2. ' x(7)='The eigenvalues are indexed as {lamb' y(7)='da(n): n=0,1,2,...}, where ' x(8)='lambda(n) .le. lambda(n+1) (n=0,1,2,' y(8)='...), lim lambda(n) -> +infinity. ' x(9)=' The connection between the index n' y(9)=' and the number of zeros of the ' x(10)='corresponding eigenfunction psi(x,n)' y(10)=' is not as simple as for separated ' x(11)='conditions; that is, psi(x,n) need n' y(11)='ot have exactly n zeros in (a,b). ' x(12)=' The following identified examples ' y(12)='from xamples.f are of special ' x(13)='interest: ' y(13)=' ' x(14)=' #11 (Plum) on [0,pi] ' y(14)=' ' x(15)=' #21 (Fourier) on [0,pi] ' y(15)=' ' x(16)=' #25 (Meissner) on [-0.5,0.5] ' y(16)=' ' do 1701 i = 1,16 write(*,*) x(i),y(i) 1701 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N go to 1 999 FORMAT(A1,I2) end SHAR_EOF fi # end of overwriting check if test -f 'sleign2.doc' then echo shar: will not over-write existing file "'sleign2.doc'" else cat << SHAR_EOF > 'sleign2.doc' H0: File name entry: This program will create a FORTRAN file containing the coefficients p(x),q(x),w(x), defining the differential equation, and the boundary condition functions u(x),v(x) if required. This file has to be given a filename which is acceptable to your FORTRAN compiler. For example, it might be called bessel.f or bessel.for depending upon your compiler. ----------------------------------------------- H1: The differential equation: The prompt "Input p (or q or w) =" requests you to type in a FORTRAN expression defining the function p(x), which is one of the three coeffi- cient functions defining the Sturm-Liouville differential equation -(p*y')' + q*y = lambda*w*y (*) to be considered on some interval (a,b) of the real line. The actual interval used in a particular problem can be chosen later, and may be either the whole interval (a,b) where the coefficient functions p,q,w, etc. are defined or any sub-interval (a',b') of (a,b); a = -infinity and/or b = +infinity are allowable choices for the end-points. The coefficient functions p,q,w of the differential equation may be chosen arbitrarily but must satisfy the following conditions: (1) p,q,w must be real-valued throughout (a,b) (2) p,q,w are piece-wise continuous and defined throughout the interior of the interval (a,b) (3) both p and w must be strictly positive in (a,b) For reliable error analysis in the numerical procedures condition (iii) above is often replaced with (iii)' p,q,w are four times continuously differentiable on (a,b). The values of p,q,w at the end-points a and b are critical to the classification of the differential equation. (See H2 and H9.) ----------------------------------------------- H2: End-point classification: The correct classification of the end-points a and b is essential to a correct working of the SLEIGN2 program. To classify the end-points it is convenient to choose a point c in (a,b); i.e. a < c < b. Subject to the general conditions on the coefficients p,q,w above: (1) a is REGULAR (say R) if -infinity < a, and p,q,w are piece-wise continuous on [a,c], and p(a) > 0 and w(a) > 0. (2) a is WEAKLY REGULAR (say WR) if -infinity < a, a is not R, and |c integral | {1/p+|q|+w} < +infinity. |a Note: if end-point a is not R or WR, then a is SINGULAR. I.e. either -infinity = a, or -infinity < a and |c integral | {1/p+|q|+w} = +infinity. |a (3) SINGULAR end-point a is LIMIT CIRCLE NON-OSCILLATORY (say LCNO) if for some real lambda ALL solutions y of the differential equation -(p*y')' + q*y = lambda*w*y on (a,c] (*) satisfy the two conditions: |c 1. integral | { w*y*y } < +infinity. |a 2. y has at most a finite number of zeros in (a,c] (4) SINGULAR end-point a is LIMIT-CIRCLE OSCILLATORY (say LCO) if for some real lambda ALL solutions y of the differential equation (*) satis- fy the two conditions: |c 1. integral | { w*y*y } < +infinity. |a 2. y has an infinite number of zeros in (a,c] (5) SINGULAR end-point a is LIMIT POINT (say LP) if for some real lambda at least one solution of the differential equation (*) satisfies the condition: |c integral | {w*y*y} = +infinity |a There is a similar classification of the end-point b into one of the five distinct cases R, WR, LCNO, LCO, LP. Although the classification of singular end-points invokes a real value of the parameter lambda, the classification is invariant in lambda; all real choices of lambda lead to the same classification. In determining the classification of singular end-points invoking the differential equation (*), it is often convenient to start with the choice lambda=0 in attempting to find solutions (particularly is this the case when q =0 on (a,b)); however see example 7 below. See H4 below on the use of maximal domain functions to determine the classification at singular end-points. EXAMPLES: 1. -y'' = lambda*y is R at both end-points of (a,b) when a & b are fin- ite. 2. -y'' = lambda*y on (-infinity, +infinity) is LP at both end-points. 3. -(sqrt(x)*y'(x))' = lambda*(1./sqrt(x))*y(x) on (0,+infinity) is WR at 0 and LP at +infinity. (take lambda = 0 in (*)); see xamples.x, #10 (weakly regular). 4. -((1-x*x)*y'(x))' = lambda*y(x) on (-1,1) is LCNO at both ends (take lambda=0 in (*)); see xamples.x #1 (Legendre). 5. -y''(x) + C*(1/(x*x))*y(x) = lambda*y(x) on (0,+infinity) is LP at +infinity (take lambda = 0 in (*)), and at 0 is: (i) LP for C .ge. 3/4 ; (ii) LCNO for -1/4 .le. C .lt. 3/4 (but C .ne. 0); (iii) LCO for C .lt. -1/4 (in all cases take lambda = 0 in (*)); 6. -(x*y'(x))' - (1/x)*y(x) = lambda*y(x) on (0,+infinity) is LCO at 0 and LP at +infinity (take lambda = 0 in (*) with solutions cos(ln(x)) and sin(ln(x))); see xamples.x #7 (BEZ) 7. -(x*y'(x))' - x*y(x) = lambda*(1/x)*y(x) on (0,+infinity) is LP at 0 and LCO at +infinity (take lambda = -1/4 in (*) with solutions cos(x)/ sqrt(x) and sin(x)/sqrt(x)); see xamples.x #6 (Sears-Titchmarsh) ----------------------------------------------- H3: DEFAULT entry: The complete range of problems for which SLEIGN2 is applicable can only be reached by appropriate entries under end-point classification and boundary conditions. However there is a DEFAULT application which re- quires no detailed entry of end-point classification or boundary condi- tions, subject to: (i) the DEFAULT application CAN NOT be used at a LCO end-point (ii) if an end-point a is R, then the Dirichlet boundary condition y(a) = 0 is automatically used. (iii) if an end-point a is WR, then the following boundary conditions are automatically applied: (1) if p(a)=0, and both q(a),w(a) are bounded, then Dirichlet y(a) = 0. (2) if p(a) > 0, and q(a) and/or w(a) are not bounded, then Neumann (py')(a) = 0. (3) if p(a)=0, and q(a) and/or w( a) are not bounded, then no reliable information can be given on the DEFAULT boundary condition. (iv) if an end-point is LCNO, then in most cases the principal or Friedr ichs boundary condition is applied (see H4). (v) if an end-point is LP, then in most cases the normal LP procedure is applied. If you choose the DEFAULT condition , then no entry is required for the u,v boundary condition functions. ----------------------------------------------- H4: Limit-circle boundary conditions: At an end-point a the limit-circle type separated boundary condition is of the form (similar remarks throughout apply to the end-point b) A1*[y,u](a) + A2*[y,v](a) = 0 (**) where y is a solution of the differential equation -(p*y')' + q*y = lambda*w*y on (a,b); (*) here A1, A2 are real numbers (not both zero); u and v are boundary con- dition functions; and for real-valued y and u the form [y,u] is defined by [y,u](x) = y(x)*(pu')(x) - u(x)*(py')(x) for x in (a,b). The object of this section is to provide help in choosing appropriate functions u and v in (**), given the differential equation (*). Full details of the boundary conditions for (*) are discussed in H5; here it is sufficient to say that the limit-circle type boundary condition (**) can be applied at any end-point in the LCNO, LCO classification, but also in the R, WR classification subject to the appropriate choice of u and v. Let (*) be R, WR, LCNO at end-point a; choose c in (a,b); then either (i) u and v are a pair of linearly independent solutions of (*) on (a,c] for any chosen real values of lambda, or (ii) u and v are a pair of real-valued maximal domain functions defined on (a,c] satisfying [u,v](a) .ne. 0. The maximal domain D(a,c] is defined by D(a,c] = {f:(a,c]->R:: f,pf' in AC(a,c]; f, ((-pf')'+qf)/w in L2((a,c;w)} It is known that for all f,g in D(a,c] the limit [f,g](a) = lim[f,g](x) as x->a exists and is finite. If (*) is LCNO or LCO at a, then all solutions of (*) belong to D(a,c] for all values of lambda. The boundary condition (**) is essential in the LCNO and LCO cases but can also be used with advantage in some R and WR cases. In the R, WR and LCNO cases but not in the LCO case, the boundary condi- tion functions can always be chosen so that lim u(x)/v(x) = 0 as x->a, and it is recommended that this normalisation be effected; this has been done in the examples given below. In this case the boundary condition [y ,u](a)=0 (i.e.A1=1,A2=0 in (**)) is called the principal or Friedrichs b oundary condition. There are similar definitions when the end-point b is R, WR, LCNO or LCO In the case when both end-points a and b are, independently, in R, WR, LCNO or LCO classification it may be that symmetry allows for one set of boundary condition functions to be used at both end-points (see Example 3 (Legendre) below); in other cases different pairs have to be chosen, one pair for each end-point; see xamples.x #16(Jacobi), #18(Dunsch), #19 (Donsch). Note that a solution pair u,v is always a maximal domain pair, but not necessarily vice versa. EXAMPLES: 1. -y''(x) = lambda*y(x) on [0,pi] is R at 0 and R at pi. At 0, with lambda=0, a solution pair is u(x) = x, v(x) = 1. At pi, with lambda=1, a solution pair is u(x) = sin(x),v(x) = cos(x). 2. -(sqrt(x)*y'(x))' = lambda*y(x)/sqrt(x) on (0,1] is WR at 0 and R at 1. (The general solutions of this equation are cos(2*sqrt(x*lambda)), sin(2*sqrt(x*lambda)) At 0 with lambda = 0, a solution pair is u(x) = 2*sqrt(x), v(x) = 1. At 1 with lambda = pi*pi/4 a solution pair is u(x) = sin(pi*sqrt(x)), v(x) = cos(pi*sqrt(x)). At 1 with lambda = 0, a solution pair is u(x) = 2*(1-sqrt(x)), v(x) = 1. See also xamples.x #10 (Weakly Regular). 3. -((1-x*x)*y'(x))' = lambda*y(x) on (-1,1) is LCNO at both ends. At +-1, with lambda = 0, a solution pair is u(x) = 1, v(x) = 0.5*log((1+x)/(1-x)). At +1 a maximal domain pair is u(x) = 1 , v(x) = log(1-x) At -1 a maximal domain pair is u(x) = 1, v(x) = log(1+x). See also xamples.x #1 (Legendre). 4. -y''(x) - (1/(4x*x))*y(x) = lambda*y(x) on (0,+infinity) is LCNO at 0 and LP at +infinity. At 0 a maximal domain pair is u(x) = sqrt(x), v(x) = sqrt(x)*log(x). See also xamples.x #2 (Bessel). 5. -y''(x) - 5*(1/(4*x*x))*y(x) = lambda*y(x) on (0,+infinity) is LCO at 0 and LP at +infinity. At 0 with lambda = 0, a solution pair is u(x) = sqrt(x)*cos(log(x)), v(x) = sqrt(x)*sin(log(x)) See also xamples.x #20 (Krall). 6. -y''(x) - (1/x)*y(x) = lambda*y(x) on (0,+infinity) is LCNO at 0 and LP at +infinity. At 0 a maximal domain pair is u(x) = x, v(x) = 1 -x*log(x) . See xamples.x #4(Boyd). 7. -((1/x)*y'(x))' + (k/(x*x) + k*k/x)*y(x) = lambda*y(x) on (0,1], with k real and .ne. 0, is LCNO at 0 and R at 1. At 0 a maximal domain pair is u(x) = x*x, v(x) = x - 1/k . See also xamples.x #8 (Laplace Tidal Wave). ----------------------------------------------- H5: Boundary conditions: Boundary conditions for Sturm-Liouville boundary value problems on an interval (a,b) are either (i) separated, with at most one condition at end-point a and at most one condition at end-point b, or (ii) coupled, when both a and b are, independently, in one of the end- point classifications R, WR, LCNO, LCO, in which case two independ- ent boundary conditions are required which link the solution values near a to those near b. The SLEIGN2 program allows for all separated conditions; and special cases of the coupled conditions--the periodic-type boundary condi- tions applicable only when the interval (a,b) is finite and both a and b are R. Separated Conditions -------------------- 2. The boundary conditions to be selected depend upon the classification of the differential equation at the end-point. 3. If the end-point is LP, then no boundary condition is required or allowed. 4. If the end-point a is R or WR, then a separated boundary condition is of the form A1*y(a) + A2*(py')(a) = 0, where A1, A2 are real constants you must choose, but not both zero. 5. If the end-point a is LCNO or LCO, then a separated boundary condi- tion is of the form A1*[y,u](a) + A2*[y,v](a) = 0, where A1, A2 are real constants you must choose, but not both zero; here u,v are the pair of boundary condition functions you have previously se- lected when the program MAKEPQW was being run. 6. If the end-point a is LCNO and the boundary condition pair u,v has been chosen so that lim u(x)/v(x) = 0 as x->a (which is always possible) then A1 =1, A2 = 0 ( i.e. [y,u](a) = 0 ) gives the principal (Friedrichs) boundary condition at a. 7. If a is R or WR and boundary condition functions u,v have been enter- ed in MAKEPQW, then both 5. and 6. above apply to entering separated boundary conditions at such an end-point; the boundary conditions in this form are equivalent to the point-wise conditions in 4. (subject to care in choosing A1, A2); this singular form of a regular boundary con- dition may be particularly effective in the WR case if the boundary con- dition form in 4. leads to numerical difficulties. 8. Conditions 4., 5., 6., 7. apply similarly at end-point b. 9. If a is R, WR, LCNO, or LCO and b is LP, then only a separated condi tion at a is required and allowed; similarly if a and b are interchanged 10. If both end-points a and b are LP, then no boundary conditions are required or allowed. 11. The indexing of eigenvalues for boundary value problems with sepa- rated conditions is discussed below in H11. Coupled Conditions ------------------ 12. The periodic-type boundary conditions on (a,b) apply only when both end-points a and b are R; these conditions are of the form y(b) = c*y(a) & (py')(b) = (py')(a)/c , where c may be chosen to be any real number not equal to 0. 13. The case c = 1 is called periodic; the case c = -1 is called semi- periodic. 14. The indexing of eigenvalues for periodic-type boundary conditions is discussed below in H15 . ---------------------------------------------- H6: Recording the results: If you choose to have a record kept of the results, then the following information is stored in a file with the name you select: (i) the file name (ii) the interval (a,b) which was used. For SEPARATED boundary conditions, (iii) the end-point classification (iv) a summary of coefficient information at WR, LCNO, LCO end-points (v) boundary condition constants (A1,A2), (B1,B2) if entered (vi) NUMEIG, EIG, TOL or NUMEIG1, NUMEIG2, TOL as entered (vii) the computed eigenvalue, EIG, and its estimated accuracy, TOL (viii) IFLAG reported. For COUPLED boundary conditions (ix) boundary condition parameter c (x) EIG value computed; TOL report (xi) IFLAG report. ---------------------------------------------- H7: Type and choice of interval: ---------------------- You may enter any interval (a,b) for which the coefficients p,q,w are well defined by your FORTRAN statements in MAKEPQW, provided that (a,b) contains no interior singularities. ---------------------------------------------- H8: Entry of end-points: ---------- End-points a and b must be entered as real numbers; there is no sym- bolic entry, e.g. pi must be entered as 3.14159... to a chosen number of decimal places. ---------------------------------------------- H9: End-point values of p,q,w: --------------------- The program SLEIGN2 needs to know whether or not the coefficient func- tions p(x), q(x), w(x) defined by the FORTRAN expressions you entered in MAKEPQW can be evaluated numerically without running into difficulty. If, for example, either q or w has an infinite limit at a, or if p(a) is 0, then SLEIGN2 needs to know so that only nearby values of x are used. ---------------------------------------------- H10: Initial Value Problems ---------------------- (1) The boundary value problems consist of the Sturm-Liouville differen- tial equation -(p*y')' + q*y = lambda*w*y on(a,b) (*) with either separate or coupled boundary conditions, as given in H5. (2) The initial value problem facility allows for the computation of a solution of (*), with a user-chosen value of lambda, for user-chosen in- itial conditions either (i) from end-point a, if R,WR,LCNO,LCO but not LP, towards end- point b of any classification or (ii) from end-point b, if R,WR,LCNO,LCO but not LP, towards end- point a of any classification or (iii) from end-points a and b, both satisfying the end-point re- quirements in (i) and (ii) above respectively, towards an in- terior point of the interval (a,b), selected by the program. The initial values to determine uniquely the computed solution are of the form (iv) at end-point a if a is R or WR then y(a)=alpha1, (p*y')(a)=alpha2 if a is LCNO or LCO then [y,u](a)=alpha1, [y,v](a)=alpha2 (v) at end-point b if b is R or WR then y(b)= beta1, (p*y')(b)=beta2 if b is LCNO or LCO then [y,u](b)=beta1, [y,v](b)=beta2 where alpha1,alpha2,beta1,beta2 are user-chosen real numbers with alpha1,alpha2 not both zero, and beta1,beta2 not both zero. Note that the value of the parameter lambda in (*) has to be chosen by the user, and may be any real number. In the case (iii) above when the interval (a,b) is finite, the inter- ior point selected by the program is generally near to the mid-point of (a,b); when (a,b) is not finite no general rule can be given. In the case (iii) above if, given alpha1,alpha2 and beta1,beta2, the parameter lambda is chosen to be an eigenvalue of the associated bound- ary value problem, the computed solution may or may not be a given eig- enfunction; the signs of the two computed solutions either side of the interior point, may be different. The output for a solution of an initial value problem is in the form of stored numerical data. This leads to a screen plot, or can be print- ed out in graph form if graphics software is available. ---------------------------------------------- H11: Indexing of Eigenvalues ----------------------- The indexing of eigenvalues is an automatic facility in SLEIGN2. The following general results hold for the separated boundary condition problem (see H5 above): 1. If both end-points a and b are independently R, WR, LCNO, then the spectrum of the eigenvalue problem is discrete (consists only of eigen- values), simple (all eigenvalues are of multiplicity one), bounded below with a single cluster point at +infinity. These eigenvalues are index- ed as {lambda(n): n=0,1,2,...}, where (i) lambda(n) < lambda(n+1) (n=0,1,2,...), lim lambda(n) = +infinity. (ii) if {psi(x,n): n=0,1,2...} are the corresponding eigenfunctions, th en psi(x,n) has exactly n zeros in the open interval (a,b). 2. If both end-points a and b are independently in R, WR, LCNO, LCO and at least one end-point is LCO, then the spectrum is discrete, simple, but with cluster points at both +infinity and -infinity; the eigenvalues are indexed as {lambda(n): n=0,1,-1,2,-2,..}, where (i) lambda(n) < lambda(n+1) (n=..-2,-1,0,1,2,..) lambda(n) -> +infinity or -infinity with n tending to + - infinity (ii) the program automatically indexes lambda(0) as the smallest non- negative eigenvalue. (iii) if {psi(n): n=0,1,-1,2,-2,..} are the corresponding eigenfunc- tions, then every psi(n) has infinitely many zeros in (a,b) 3. If one or both end-points is LP, then the spectral sets of the bound- ary value problem can contain one or more intervals of continuous spec- trum, with possibly some (necessarily simple) eigenvalues. For these essentially more difficult spectral problems, SLEIGN2 can be used as an investigative tool to give qualitative information on the spectrum. If the continuous spectrum is bounded below, then there may be a fin- ite or infinite number of eigenvalues below the lower bound, and SLEIGN2 may be able to detect these eigenvalue's indices and compute their val- ues. It can happen in this case, i.e. at least one end-point is LP, that the spectrum is discrete, consisting only of simple eigenvalues with cluster at one or both of +infinity, -infinity. If also the spectrum is bounded below, then the eigenvalues can be indexed as in 1. above; i.e. {lambda(n): n=0,1,2,..} with lambda(n) -> +infinity. In these circumstances, if {psi(x,n): n=0,1,2..} represents the corre- sponding set of eigenfunctions, then psi(n) has exactly n zeros in the open interval (a,b). If the discrete spectrum is unbounded below, then all the eigenfunc- tions have infinitely many zeros in the open interval (a,b). EXAMPLES. In respect of the points 1,2 and 3 above, the following identified ex- amples illustrate the spectral properties of these boundary value prob- lems. 1. See xamples.x: #1 (Legendre) #2 (Bessel) with -1/4 < c < 3/4 #4 (Boyd) #5 (Latzko) 2. See xamples.x: #6 (Sears-Titchmarsh) #7 (BEZ) #19 (Donsch) 3. See xamples.x: #21 (Fourier) on [0,+infinity) #13 (Hydrogen atom) #14 (Marletta) #20 (Krall) ---------------------------------------------- H12: Entry for eigenvalue index and tolerance: ------------------------------ For SEPARATED boundary condition problems (see H5 above), SLEIGN2 calls for input information options to compute (1) A single eigenvalue (2) A series of eigenvalues. In each case indexing of eigenvalues is called for; see H11 above. Entry (1) above asks you to supply data in the form (1') NUMEIG, EIG, TOL Here NUMEIG is the index of the desired eigenvalue, and requires input of a positive, negative, or zero integer; negative integers are allowed only in the case when the problem is LCO at one or both end-points. EIG allows for the entry of an initial guess for the requested eigenval- ue, if an especially good one is available, or one can enter 0. as defau lt input--i.e. no initial guess is provided. In the latter case an init ial guess is computed by SLEIGN2. If the guess desired is zero, enter any small number, like 0.001. TOL is the accuracy you are asking for in the computed eigenvalue. It is an absolute accuracy if the magnitude of the eigenvalue is less than or equal to 1, but is a relative accuracy otherwise. Typical values would be .001 for nominal accuracy, or perhaps .0000001 for extreme accuracy. There are DEFAULT entries: NUMEIG/ for which the program sets EIG and TOL, and NUMEIG,EIG/ for which the program sets TOL. Entry (2) above asks you to supply data in the form (2') NUMEIG1, NUMEIG2, TOL Here two integers n1, n2 should be entered with n1 < n2; as with (1') above negative integers are allowed only in the LCO case. TOL has the same meaning as above. There is a DEFAULT entry NUMEIG1,NUMEIG2/ for which the program sets TOL. In all these DEFAULT modes the program tries to get the most accur- acy it is capable of. For COUPLED periodic-type boundary conditions (see H5 and H15) the program calls for data in the form NUMEIG = Here NUMEIG is the index of the requested eigenvalue and requires input of a non-negative integer. In this mode the program sets its own TOL. ---------------------------------------------- H13: IFLAG information All results are reported with a flag identification. The flags carry the following meanings: IFLAG = 1 - successful problem solution. = 2 - integrator tolerance cannot be reduced further. = 3 - no more improvement = 4 - An internal consistency check failed = 6 - in SECANT-METHOD, ABS(DE) .LT. EPSMIN = 7 - iterations are stuck in a loop = 8 - number of iterations has reached the set limit = 9 - residual truncation error dominates = 10 - improper input parameters = 11 - NUMEIG exceeds actual highest eigenvalue index = 12 - failed to get a bracket = 13 - AA cannot be moved in any further. = 14 - BB cannot be moved in any further. = 51 - integration failure after 1st call to INTEG = 52 - integration failure after 2nd call to INTEG = 53 - integration failure after 3rd call to INTEG = 54 - integration failure after 4th call to INTEG ---------------------------------------------- H14: Plotting After computing a single eigenvalue, see H12 (1) above, (but NOT after computing a series of eigenvalues, see H12 (2) ) it is possible to have the eigenfunction plotted. If this is desired, enter 'y' for yes, so that SLEIGN2 will compute some points on the eigenfunction and store the data. One can have the eigenfunction data in the form of points (xi,yi) with the xi selected points in (a,b), or in the form of points (ti,yi) where the ti are points in a standardized interval (-1,1): i.e. the int- erval (a,b) has been mapped onto (-1,1). This latter choice can be es- pecially helpful when the original interval is infinite. Additionally, one can have a plot of the so-called Pruefer angle or mo dulus in either the x- or t- variable. In either case, once the choice has been made of which function is to be plotted, a crude plot is displayed on the monitor screen before ask- ing whether or not you wish to save the computed plot points in a file. ---------------------------------------------- H15: Periodic-type problems The indexing of eigenvalues is an automatic facility in SLEIGN2. The following general result holds for the periodic-type boundary condition problem. Recall that these problems require both the end-points a and b to be R. The spectrum of the boundary value problem is discrete (consists only of eigenvalues), bounded below with a single cluster point at +infinity. In general the spectrum is not simple; there may be one or more eigen- values of multiplicity two, but none of higher multiplicity. These eigenvalues are indexed as {lambda(n): n=0,1,2,...} where lambda(0).le.lambda(1).le.lambda(2).le.....le.lambda(n).le... (*) and lambda(n)->+infinity as n->+infinity. Note that in (*) there can be at most two consecutive .le. since the multiplicity of any eigenvalue cannot exceed 2. The connection between the index n and the number of zeros of the cor- responding eigenfunction psi(x,n) is not as simple as it is in the case of separated conditions; in particular psi(x,n) need not have exactly n zeros in the open interval (a,b). Examples of special interest: (i) xamples.x #21 (Fourier) on [0,pi] (ii) xamples.x #11 (Plum) on [0,pi] (iii) xamples.x #25 (Meissner) on [-0.5,0.5] . ---------------------------------------------- SHAR_EOF fi # end of overwriting check if test -f 'sleign2.hlp' then echo shar: will not over-write existing file "'sleign2.hlp'" else cat << SHAR_EOF > 'sleign2.hlp' There are four fortran files in the SLEIGN2 package: makepqw.f, drive.f, SLEIGN2.f and xamples.f. To run one of the examples in the examples.f file on a UNIX machine with a fortran compiler do the following: f77 examples.f drive.f sleign2.f -o xamples.x then run examples.x whenever you want to work an example from this list. To run your own problem proceed as follows: Step1: f77 makepqw.f -o makepqw.x Step2: makepqw.x (This interactive program will ask you for a file name - this must end in .f e.g. problem.f) This file contains the subroutines for p,q,w and, if nessecary, the functions u and v which are used to define singular boundary conditions. Step3: f77 problem.f drive.f sleign2.f -o problem.x Step4: problem.x (You will be asked to provide the information the code needs to identify and run the S-L problem. (At each point where input is requested help is available - just type h return. Type r, return, to get back to the point where help was requested.) Continue. The above procedures may have to be modified slightly for non UNIX environments, e.g. DOS or APPLE. Enjoy and good luck! Paul Bailey, Norrie Everitt and Tony Zettl. SHAR_EOF fi # end of overwriting check if test -f 'sleign2.txt' then echo shar: will not over-write existing file "'sleign2.txt'" else cat << SHAR_EOF > 'sleign2.txt' From: CBS%UK.AC.CRANFIELD::EDU.NIU.MATH::ZETTL 2-OCT-1994 22:11:38.56 To: PRYCE CC: Subj: Re: sleign2 Via: UK.AC.CRANFIELD; Sun, 2 Oct 94 22:11 BST Received: from clinch.math.niu.edu by xss001.ccc.cranfield.ac.uk with SMTP (PP) id <17221-0@xss001.ccc.cranfield.ac.uk>; Sun, 2 Oct 1994 22:10:07 +0100 Received: from eiger.niu.edu (eiger.math.niu.edu) by clinch.math.niu.edu (4.1/SMI-4.1) id AA19431; Sun, 2 Oct 94 16:09:17 CDT From: zettl@edu.niu.math (Anton Zettl) Message-Id: <9410022109.AA19431@clinch.math.niu.edu> Subject: Re: sleign2 To: PRYCE@uk.ac.cranfield.rmcs (JOHN PRYCE, APPLIED & COMPUTATIONAL MATHS GROUP, RMCS SHRIVENHAM, SWINDON SN6 8LA, UK) Date: Sun, 2 Oct 1994 16:07:39 -0500 (CDT) In-Reply-To: <"xss001.ccc.296:06.08.94.09.05.44"@cranfield.ac.uk> from "JOHN PRYCE, APPLIED & COMPUTATIONAL MATHS GROUP, RMCS SHRIVENHAM, SWINDON SN6 8LA, UK" at Sep 6, 94 10:07:00 am X-Mailer: ELM [version 2.4 PL23] Mime-Version: 1.0 Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Length: 7677 Sender: zettl@edu.niu.math Introduction to SLEIGN2. The main purpose of this program is to compute eigenvalues and eigenfunctions of regular and singular Sturm-Liouville problems. These consist of a second order linear differential equation -(py')' + qy = (lambda) w y on (a,b) together with boundary conditions (BC). The nature of the BC depends on the regular or singular classification of the end points. For both cases the BC fall into two major classes : separated and coupled. The former are two separate conditions, one at each end-point; the latter are two coupled conditions linking the values of the solution at the two end-points a and b. A number lambda for which there is a nontrivial solution satisfying the BC is called an eigenvalue and such a solution is a (corresponding) eigenfunction. If one or both endpoints are LP (see below or section 2 of "HELP" for a definition) there may be points lambda in the spectrum in addition to eigenvalues i.e. there may be continuous spectrum. In the theory of S-L problems the coefficients 1/p and q and the weight function w are assumed to be real valued and locally Lebesgue integrable. To meet the needs of numerical computing techniques we make the stronger assumptions : (i) The interval (a,b) of R may be bounded or unbounded; in the regular case it is compact and denoted by [a,b]. (ii) p, q, and w are real-valued functions on (a,b) (iii) p,q,w, are piecewise continuous on (a,b) (iv) p and w are strictly positive on (a,b). For reliable error analysis in the numerical procedures condition (iii) above is often replaced with (iii)' p,q,w are four times continuously differentiable on (a,b). To study S-L problems using operator theory one associates a self-adjoint operator in the w-weighted Hilbert space of square-integrable functions on (a,b) with each S-L problem in such a way that the spectrum of the problem is the spectrum of the operator. In the case of a regular problem the spectrum consists entirely of eigenvalues and these are bounded below. This is still so for the case when each end-point is either regular or singular limit-circle nonoscillatory (LCNO). In case one end-point is limit-circle oscillatory (LCO) and the other is not limit-point (LP) then there are still only eigenvalues in the spectrum but these are not bounded below. (The spectrum is never bounded above.) If one or both endpoints is LP the spectrum may be extremely complicated. There may be no eigenvalues, finitely many, or infinitely many. Some may be embedded in the continuous spectrum. For p=1,w=1, q(x) =sin(x) on (-inf,+inf) there are no eigenvalues and the continuous spectrum consists of the union of an infinite number of disjoint compact intervals. (SLEIGN2 can be used to compute this spectrum - see example 12 in the code.) See "HELP" for a definition of the terms LCO etc. S-L problems are classified into various classes based on the classification of the end-points and on whether the boundary conditions are separated(S) or coupled(C). We have the following categories: 1. R/R, S 2. R/R, C 3. R/LCNO or LCNO/R, S 4. R/LCNO or LCNO/R, C 5. R/LCO or LCO/R , S 6. R/LCO or LCO/R , C 7. LCNO/LCO or LCO/LCNO or LCO/LCO, S 8. LCNO/LCO or LCO/LCNO or LCO/LCO, C 9. LP/R or LP/LCNO or LP/LCO or R/LP or LCNO/LP or LCO/LP 10. LP/LP For 9. there is only a separated condition condition at the non-LP end-point and for 10. there are no boundary conditions at either end. There are only three other major general purpose codes for computing eigenvalues and eigenfunctions of Sturm-Liouville problems : The NAG library code, SLEDGE, and the earlier code SLEIGN. We have not had an opportunity to use the newly revised version of the NAG code (the earlier version was modeled on SLEIGN) so our comments here are confined to the other two codes. SLEDGE uses a method based on piecewise constant approximations of the coefficients of the differential equation; SLEIGN and SLEIGN2 both are based on the Pruefer transformation. Both SLEIGN and SLEDGE are designed to automatically handle end-points which are either regular or singular but non-oscillatory. And in the latter case if an end-point is LCNO the Friedrichs condition is usually the one chosen by the code. SLEDGE can also determine the LP/LC classification; SLEIGN and SLEIGN2 do not. For problems with LC end-points, whether LCNO or LCO, SLEIGN2 is the only general purpose code in existence which can handle arbitrary separated boundary conditions. It is also the only code which can handle coupled boundary conditions, in particular periodic-type conditions including the classical periodic and semi-periodic ones. In addition to the above mentioned capabilities to compute eigenvalues and eigenfunctions SLEIGN2 also computes the solution of an initial value problem with the users choice of lambda and either a regular or SINGULAR initial condition. When combined with the algorithm established in [BEWZ] SLEIGN2 can be used to approximate the continuous spectrum. An important feature of the SLEIGN2 program is its user friendly interface. The whole package consists of the following files: 1. A brief "readme" file with basic information on how to run the code. 2. This intoduction 3.makepqw.f - This is an interactive fortran file to input the coefficient functions p,q,w and,if necessary, the functions u,v which define the singular boundary conditions. 4.drive.f - This is an interactive fortran file containing the driver, parts of "help", and a "user friendly" interface. 5.sleign2.f - The main code for the computation of eigenvalues and eigenfunctions. 6.xamples.f - A fortran file with 25 examples ready to run. These examples were chosen to illustrate various features of the code. 7.xamples.comm - Contains information about the examples. 8. HELP - A file with information about end-point classifications, boundary conditions etc. It is a separate text file and parts of it can also be accessed from both makepqw and drive : At each point where the user is asked for some input there is an option for help - just type "h" return and you will be placed at the appropriate section of HELP; to return to the point in the program where help was called just type "r" return. The 16 components of HELP are: H0 File name entry H1 The Sturm-Liouville differential equation H2 End-point classifications with examples H3 Default classification and boundary condition entry H4 LC(limit-circle) boundary conditions with examples H5 Regular and singular, separated and coupled boundary conditions H6 Recording results H7 Type and choice of intervals H8 Entry of end-points H9 Value of coefficients p,q,w at end points a and b H10 Boundary and initial value problems H11 Indexing of eigenvalues H12 Entry for eigenvalues and for tolerances H13 Flag information for output H14 Plotting results H15 Periodic-type boundary conditions When an eigenfunction has been computed it is stored and can be examined: (i) by printing out the numerical data (ii) by using the discrete graph plotter in the program (iii) by using a local graph plotter. THIS SINGLE PRECISION VERSION OF THE CODE HAS BEEN PREPARED FOR TESTING PRIOR TO RELEASE. IT IS INTENDED TO BE USED TO TEST THE VIABILITY OF THE ALGORITHMS USED ON THE CLASSES OF PROBLEMS MENTIONS ABOVE. THE FINAL VERSION WILL BE AVAILABLE IN SINGLE AND IN DOUBLE PRECISION. SHAR_EOF fi # end of overwriting check if test -f 'sleign2d.f' then echo shar: will not over-write existing file "'sleign2d.f'" else cat << SHAR_EOF > 'sleign2d.f' C OCTOBER 15, 1995; P.B. BAILEY, W.N. EVERITT, B. GARBOW AND A. ZETTL C C This program is for an equation of the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) C SUBROUTINE SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,NUMEIG,EIG,TOL,IFLAG,ISLFUN,SLFUN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) INTEGER INTAB,NUMEIG,IFLAG,ISLFUN DOUBLE PRECISION A,B,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2,EIG,TOL, 1 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB DOUBLE PRECISION SLFUN(9) C ********** C C This subroutine is designed for the calculation of a specified C eigenvalue, EIG, of a Sturm-Liouville problem for the equation C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C with user-supplied coefficient functions p, q, and w. C The problem may be either nonsingular or singular. In the C nonsingular case, boundary conditions of the form C C A1*y(a) + A2*p(a)*y'(a) = 0 C B1*y(b) + B2*p(b)*y'(b) = 0 C C are prescribed by specifying the numbers A1, A2, B1, and B2. C The index of the desired eigenvalue is specified in NUMEIG C and its requested accuracy in TOL. Initial data for the C associated eigenfunction are also computed along with values C at selected points, if desired, in array SLFUN. C C In addition to the coefficient functions p, q, and w, the user C must supply subroutine UV to describe the boundary condition C when the problem is limit circle. UV can be a dummy subroutine C if the problem is not limit circle. C C The SUBROUTINE statement is C C SUBROUTINE sleign2(a,b,intab,p0ata,qfata,p0atb,qfatb,a1,a2, C b1,b2,numeig,eig,tol,iflag,islfun,slfun, C singata,singatb,circla,circlb,oscila,oscilb) C C where C C A and B are input variables defining the interval. If the C interval is finite, A must be less than B. (See INTAB below.) C C INTAB is an integer input variable specifying the nature of the C interval. It can have four values. C C INTAB = 1 - A and B are finite. C INTAB = 2 - A is finite and B is infinite (+). C INTAB = 3 - A is infinite (-) and B is finite. C INTAB = 4 - A is infinite (-) and B is infinite (+). C C If either A or B is infinite, it is classified singular and C its value is ignored. C C P0ATA, QFATA, P0ATB, and QFATB are input variables set to C 1.0 or -1.0 as the following properties of p, q, and w at C the interval endpoints are true or false, respectively. C C P0ATA - p(a) is zero. (If true, A is singular.) C QFATA - q(a) and w(a) are finite. (If false, A is singular.) C P0ATB - p(b) is zero. (If true, B is singular.) C QFATB - q(b) and w(b) are finite. (If false, B is singular.) C C A1 and A2 are input variables set to prescribe the boundary C condition at A. C C B1 and B2 are input variables set to prescribe the boundary C condition at B. C C NUMEIG is an integer variable. On input, it should be set to C the index of the desired eigenvalue (increasing sequence where C index 0 corresponds to the lowest eigenvalue -- if the C eigenvalues are bounded below -- or to the smallest nonegative C eigenvalue otherwise). On output, it is unchanged unless the C problem (apparently) lacks eigenvalue NUMEIG, in which case it C is reset to the index of the largest eigenvalue that seems to C exist. C C EIG is a variable set on input to 0.0 or to an initial guess of C the eigenvalue. If EIG is set to 0.0, SLEIGN2 will generate C the initial guess. On output, EIG holds the calculated C eigenvalue if IFLAG (see below) signals success. C C TOL is a variable set on input to the desired accuracy of the C eigenvalue. On output, TOL is reset to the accuracy estimated C to have been achieved if IFLAG (see below) signals success. C This accuracy estimate is absolute if EIG is less than one C in magnitude, and relative otherwise. In addition, prefixing C TOL with a negative sign, removed after interrogation, serves C as a flag to request trace output from the calculation. C C IFLAG is an integer output variable set as follows: C C IFLAG = 0 - improper input parameters. C IFLAG = 1 - successful problem solution, within tolerance. C IFLAG = 2 - best problem result, not within tolerance. C IFLAG = 3 - NUMEIG exceeds actual highest eigenvalue index. C IFLAG = 4 - RAY and EIG fail to agree after 5 tries. C IFLAG = 6 - in SECANT-METHOD, ABS(DE) .LT. EPSMIN . C IFLAG = 7 - iterations are stuck in a loop. C IFLAG = 8 - number of iterations has reached the set limit. C IFLAG = 9 - residual truncation error dominates. C IFLAG = 10 - integrator tolerance cannot be reduced. C IFLAG = 11 - no more improvement. C IFLAG = 12 - failed to get a bracket. C IFLAG = 13 - AA cannot be moved in any further. C IFLAG = 14 - BB cannot be moved in any further. C IFLAG = 51 - integration failure after 1st call to INTEG. C IFLAG = 52 - integration failure after 2nd call to INTEG. C IFLAG = 53 - integration failure after 3rd call to INTEG. C IFLAG = 54 - integration failure after 4th call to INTEG. C C ISLFUN is an integer input variable set to the number of C selected eigenfunction values desired. If no values are C desired, set ISLFUN to zero. C C SLFUN is an array of length at least 9. On output, the first 9 C locations contain the integration interval and initial data C that completely determine the eigenfunction. C C SLFUN(1) - point where two pieces of eigenfunction Y match. C SLFUN(2) - left endpoint XAA of the (truncated) interval. C SLFUN(3) - value of THETA at XAA. (Y = RHO*sin(THETA)) C SLFUN(4) - value of F at XAA. (RHO = exp(F)) C SLFUN(5) - right endpoint XBB of the (truncated) interval. C SLFUN(6) - value of THETA at XBB. C SLFUN(7) - value of F at XBB. C SLFUN(8) - final value of integration accuracy parameter EPS. C SLFUN(9) - the constant Z in the polar form transformation. C C F(XAA) and F(XBB) are chosen so that the eigenfunction is C continuous in the interval (XAA,XBB) and has weighted (by W) C L2-norm of 1.0 on the interval. If ISLFUN is positive, then C on input the further ISLFUN locations of SLFUN specify the C points, in ascending order, where the eigenfunction values C are desired and on output contain the values themselves. C C SINGATA is an input variable set positive if endpoint A C is singular, and negative or zero if A is nonsingular. C C SINGATB is an input variable set positive if endpoint B C is singular, and negative or zero if B is nonsingular. C C CIRCLA is an input variable set positive if endpoint A has C a limit-circle singularity, and negative or zero if not. C C CIRCLB is an input variable set positive if endpoint B has C a limit-circle singularity, and negative or zero if not. C C OSCILA is an input variable set positive if the limit-circle C singularity at A is oscillatory, and negative or zero if not. C C OSCILB is an input variable set positive if the limit-circle C singularity at B is oscillatory, and negative or zero if not. C C Subprograms called C C user-supplied ..... p,q,w,uv C C sleign2-supplied .. aabb,alfbet,dxdt,eigenf,epslon,estpac,integ, C setmid,tfromi,thum C C This version dated 7/23/95. C Paul B. Bailey, Albuquerque, New Mexico C Burton S. Garbow, Park Forest, Illinois C C ********** C .. Scalars in Common .. INTEGER INTSAV,IND DOUBLE PRECISION ASAV,BSAV,C1,C2,EIGSAV,EPSMIN,Z, 1 PI,TWOPI,HPI,TSAVEL,TSAVER C .. C .. Arrays in Common .. INTEGER JAY(100) DOUBLE PRECISION TEE(100),ZEE(100) C .. C .. Local Scalars .. INTEGER I,IA,IB,IMAX,IMIN,IOUT,JFLAG,KFLAG,MF,ML, 1 NEIG,K,JJL,JJR,IE,IMID,NITER,NRAY,LOOP2,LOOP3, 2 MDTHZ LOGICAL AOK,BOK,BRACKT,CONVRG,FYNYT,FYNYT1,LOGIC, 1 NEWTON,ONEDIG,PRIN,THEGT0,THELT0,OLDNEWT,SINGA, 2 SINGB,LCIRCA,LCIRCB,OSCA,OSCB,ENDA,ENDB,LIMUP, 3 ADDD,EXIT,FIRSTT,NEWTONF,LIMA,LIMB,BRS, 4 BRSS,CHNGEPS,TRUNKA,TRUNKB DOUBLE PRECISION AA,AAA,AAF,ALFA,BB,BBB,BBF,BETA, 1 C,CHNG,CL,CR,DE,DEDW,DEN,DERIVL,DERIVR,DIST, 2 DT,DTHDA,DTHDAA,DTHDB, 3 DTHDBB,DTHDE,DTHDEA,DTHDEB,DTHETA,DTHOLD,E,EEE, 4 EIGLO,EIGLT,EIGRT,EIGUP,EL,EMAX,EMIN,EOLD,EPS, 5 ER1,ER2,ESTERR,FLO,FMAX,FUP,GUESS,ONE,PIN, 6 PSIL,PSIPL,PSIPR,PSIR,PX,QX,RAY,WX, 7 SL,SQL,SQR,SR,T,T1,T2,T3,TAU,THRESH,TMID,TMP, 8 U,UL,UR,V,WL,X,X50,XAA,XBB,XMID,XSAV,ZAV, 9 TS,ELIMA,ELIMB,ELIMUP,SUM,SUM0,UT,EU,WU,FOLD,BALLPK, A BESTEIG,BESTEST,OLDEST,EPSM,THA,THB,XT,PUP,PVP,HU,HV, B DTHZ,REMZ,OLDRAY,SAVRAY,RLX,EIGPI,FNEW,AAL,BBL,EPSL, C CHNGLIM,DTHOLDY,AAS,BBS,DTHDAAX,DTHDBBX,DUM, D RATL1,RATL2,RATL3,RATR1,RATR2,RATR3,SL1,SL2,SL3, E TAUM,ADTHETA,FLOUP,PT2,PT3,SAVAA,SAVBB,SAVERR, F BESTAA,BESTBB,BESTMID,BESTEPS,SR1,SR2,SR3 C .. C .. Local Arrays .. DOUBLE PRECISION DS(99),PS(99),QS(99),WS(99),DELT(99),PSS(99), 1 XS(99),YL(3),YR(3),ERL(3),ERR(3),YZL(3),YZR(3) C .. C .. External Functions .. DOUBLE PRECISION EPSLON,P,Q,W,TFROMI EXTERNAL EPSLON,P,Q,W,TFROMI C .. C .. External Subroutines .. EXTERNAL AABB,ALFBET,DXDT,EIGFCN,ESTPAC,INTEG,SETMID,THUM,UV C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,COS,EXP,INT,LOG,MAX,MIN,SIGN,SIN,SQRT,TAN C .. C .. Common blocks .. COMMON /DATADT/ASAV,BSAV,C1,C2,INTSAV COMMON /DATAF/EIGSAV,IND COMMON /RNDOFF/EPSMIN COMMON /ZEE/Z COMMON /TEEZ/TEE COMMON /ZEEZ/JAY,ZEE COMMON /PIE/PI,TWOPI,HPI COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ COMMON /TSAVE/TSAVEL,TSAVER C .. C Set constants EPSMIN, the computer unit roundoff error, and PI. C (Variable ONE set to 1.0 eases precision conversion.) C ONE = 1.0 EPSMIN = EPSLON(ONE) PI = 4.0*ATAN(ONE) TWOPI = 2.0*PI HPI = 0.5*PI do 3 I=1,99 PSS(I) = 0.0D0 3 continue C C Set output device number. C IOUT = 6 C C Check input parameters for errors. If errors, return IFLAG = 0. C LOGIC = 1.LE.INTAB .AND. INTAB.LE.4 .AND. 1 P0ATA*QFATA*P0ATB*QFATB.NE.0.0 IF (INTAB.EQ.1) LOGIC = LOGIC .AND. A.LT.B IF (.NOT.LOGIC) THEN IFLAG = 0 GO TO 150 END IF C C Set PRIN = .true. to trigger trace printout of successive steps. C PRIN = .FALSE. IF (TOL.LT.0.0) PRIN = .TRUE. C C Set EPS to the (initial) integration accuracy. C EPS = 0.0001 C C Set logical variables. C AOK = INTAB.LT.3 .AND. P0ATA.LT.0.0 .AND. QFATA.GT.0.0 BOK = (INTAB.EQ.1 .OR. INTAB.EQ.3) .AND. 1 P0ATB.LT.0.0 .AND. QFATB.GT.0.0 SINGA = SINGATA.GT.0.0 SINGB = SINGATB.GT.0.0 LCIRCA = CIRCLA.GT.0.0 LCIRCB = CIRCLB.GT.0.0 OSCA = OSCILA.GT.0.0 OSCB = OSCILB.GT.0.0 TRUNKA = (SINGA .AND. .NOT.LCIRCA) .OR. OSCA TRUNKB = (SINGB .AND. .NOT.LCIRCB) .OR. OSCB EIGPI = NUMEIG*PI NEIG = NUMEIG - 1 WRITE(21,*) ' NUMEIG = ',NUMEIG C C Initial C1 and C2, used in the mapping between X and T intervals. C C1 = 1.0 C2 = 0.0 C DO (SAVE-INPUT-DATA) ASAV = A BSAV = B INTSAV = INTAB TAU = ABS(TOL) TAUM = MAX(TAU,EPSMIN) C END (SAVE-INPUT-DATA) C C Initialize the arrays JAY and ZEE if either end is oscillatory. C IF (OSCA .OR. OSCB) THEN DO 5 K=1,100 JAY(K) = 0 ZEE(K) = 1.0 5 CONTINUE END IF C C Evaluate P, Q, W to obtain preliminary information about the C differential equation. C C DO (SAMPLE-COEFFICIENTS) THRESH = 1.0E+17 10 CONTINUE CALL DXDT(EPSMIN,TMP,X50) XS(50) = X50 TS = EPSMIN PX = P(X50) QX = Q(X50) WX = W(X50) PS(50) = PX QS(50) = QX/PX WS(50) = WX/PX C C EMIN = min(Q/W), achieved at X for index value IMIN. C EMAX = max(Q/W), achieved at X for index value IMAX. C MF and ML are the least and greatest index values, respectively. C XSAV = X50 EMIN = 0.0 IF (QX.NE.0.0) EMIN = QX/WX EMAX = EMIN IMIN = 50 IMAX = 50 DO 20 I=49,1,-1 T = TFROMI(I) CALL DXDT(T,TMP,X) XS(I) = X PX = P(X) QX = Q(X) WX = W(X) PS(I) = PX QS(I) = QX/PX WS(I) = WX/PX DS(I) = XSAV - X DELT(I) = 0.5*(TS-T) XSAV = X TS = T C C Try to avoid overflow by stopping when functions are large near A C or when w is small near A. C FYNYT = (ABS(WX)+ABS(QX)+1.0/ABS(PX)).LE.THRESH 1 .AND. WX.GT.EPSMIN IF (QX.NE.0.0 .AND. QX/WX.LT.EMIN) THEN EMIN = QX/WX IMIN = I END IF IF (QX.NE.0.0 .AND. QX/WX.GT.EMAX) THEN EMAX = QX/WX IMAX = I END IF MF = I IF (.NOT.FYNYT) GO TO 30 20 CONTINUE 30 CONTINUE AAA=T IF (.NOT.SINGA) AAA = -1.0 XSAV = X50 DO 40 I=51,99 T = TFROMI(I) CALL DXDT(T,TMP,X) XS(I) = X PX = P(X) QX = Q(X) WX = W(X) PS(I) = PX QS(I) = QX/PX WS(I) = WX/PX DS(I-1) = X - XSAV DELT(I-1) = 0.5*(T-TS) XSAV = X TS = T C C Try to avoid overflow by stopping when functions are large near B C or when w is small near A. C FYNYT1 = (ABS(QX)+ABS(WX)+1.0/ABS(PX)).LE.THRESH 1 .AND. WX.GT.EPSMIN IF (QX.NE.0.0 .AND. QX/WX.LT.EMIN) THEN EMIN = QX/WX IMIN = I END IF IF (QX.NE.0.0 .AND. QX/WX.GT.EMAX) THEN EMAX = QX/WX IMAX = I END IF ML = I - 1 IF (.NOT.FYNYT1) GO TO 50 40 CONTINUE 50 CONTINUE BBB = T IF (.NOT.SINGB) BBB = 1.0 LOGIC = C1.EQ.1.0 .AND. (.NOT.FYNYT .OR. .NOT.FYNYT1) C C Modify (T,X) transformation corresponding to truncated interval. C IF (LOGIC) THEN C1 = 0.5*(BBB-AAA) C2 = 0.5*(AAA+BBB) GO TO 10 END IF IF (OSCA .OR. OSCB) CALL THUM(MF,ML,XS) C C Here we try to determine 'sigma0'. Initially, we will be C satisfied to determine eliml and elimr, the limiting values C of q/w, if they exist. C LIMA = .FALSE. IF (SINGA .AND. .NOT.LCIRCA) THEN RATL1 = QS(MF)/WS(MF) RATL2 = QS(MF+1)/WS(MF+1) RATL3 = QS(MF+2)/WS(MF+2) SL1 = RATL1/(XS(MF+1)-XS(MF)) SL2 = RATL2/(XS(MF+2)-XS(MF+1)) SL3 = RATL3/(XS(MF+3)-XS(MF+2)) IF (ABS(SL2).GE.ABS(SL1) .AND. ABS(SL2).LE.ABS(SL3)) THEN ELIMA = RATL1 LIMA = PS(MF).EQ.PS(MF+1) WRITE(*,*) ' There is a limit at a, LIMIT = ',ELIMA WRITE(21,*) ' THERE IS A LIMIT AT a, LIMIT = ',ELIMA END IF END IF LIMB = .FALSE. IF (SINGB .AND. .NOT.LCIRCB) THEN RATR1 = QS(ML)/WS(ML) RATR2 = QS(ML-1)/WS(ML-1) RATR3 = QS(ML-2)/WS(ML-2) SR1 = RATR1/(XS(ML)-XS(ML-1)) SR2 = RATR2/(XS(ML-1)-XS(ML-2)) SR3 = RATR3/(XS(ML-2)-XS(ML-3)) IF (ABS(SR2).GE.ABS(SR1) .AND. ABS(SR2).LE.ABS(SR3)) THEN ELIMB = RATR1 LIMB = PS(ML).EQ.PS(ML-1) WRITE(*,*) ' There is a limit at b, LIMIT = ',ELIMB WRITE(21,*) ' THERE IS A LIMIT AT b, LIMIT = ',ELIMB END IF END IF LIMUP = .FALSE. ELIMUP = EMAX IF (LIMA .OR. LIMB) THEN LIMUP = .TRUE. IF (.NOT.LIMB) THEN ELIMUP = ELIMA ELSE IF (.NOT.LIMA) THEN ELIMUP = ELIMB ELSE ELIMUP = MIN(ELIMA,ELIMB) END IF WRITE(21,*) ' THE CONTINUOUS SPECTRUM HAS A LOWER ' WRITE(21,*) ' BOUND, SIGMA0 = ',ELIMUP END IF C END (SAMPLE-COEFFICIENTS) PIN = EIGPI + PI IF (EIG.EQ.0.0) THEN C DO (ESTIMATE-EIG) SUM0 = 0.0 IF (OSCA .OR. OSCB) THEN EEE = 0.0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) SUM0 = SUM END IF EEE = MIN(ELIMUP,EMAX) C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) 55 CONTINUE IF (.NOT.LIMUP .AND. 1 ABS(SUM).GE.10.0*MAX(1.0,ABS(PIN))) THEN IF (SUM.GE.10.0*PIN) THEN IF (EEE.GE.1.0) THEN EEE = EEE/10.0 ELSE IF (EEE.LT.-1.0) THEN EEE = 10.0*EEE ELSE EEE = EEE - 1.0 END IF ELSE IF (EEE.LE.-1.0) THEN EEE = EEE/10.0 ELSE IF (EEE.GT.1.0) THEN EEE = 10.0*EEE ELSE EEE = EEE + 1.0 END IF END IF C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) GO TO 55 END IF EU = EEE WU = SUM IF (SUM.GE.PIN) THEN EL = EU WL = WU 60 CONTINUE IF (WL.GE.PIN) THEN EU = EL WU = WL EEE = EL - ((WL-PIN+3.0)/U)**2 - 1.0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS, 1 DELT,PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EL = EEE WL = SUM GO TO 60 END IF ELSE EL = EEE WL = SUM END IF IF (LIMUP .AND. WU.LT.PIN) THEN EEE = ELIMUP ELSE IF (U.EQ.0.0) THEN EEE = EMAX + 1.0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EU = EEE WU = SUM END IF 70 CONTINUE IF (WU.LE.PIN) THEN EL = EU WL = WU EEE = EU + ((PIN-WU+3.0)/U)**2 + 1.0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS, 1 DELT,PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EU = EEE WU = SUM GO TO 70 END IF 80 CONTINUE IF (ABS(IMAX-IMIN).GE.2 .AND. EU.LE.EMAX) THEN IE = (IMAX+IMIN)/2 EEE = QS(IE)/WS(IE) C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS, 1 DELT,PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) IF (SUM.GT.PIN) THEN IMAX = IE WU = SUM EU = EEE ELSE IMIN = IE WL = SUM EL = EEE END IF GO TO 80 END IF C C Improve approximation for EIG using bisection or secant method. C Substitute 'ballpark' estimate if approximation grows too large. C DEDW = (EU-EL)/(WU-WL) FOLD = 0.0 IF (INTAB.EQ.1) BALLPK = (PIN/(A-B))**2 IF (INTAB.EQ.1) WRITE(21,*) ' BALLPK = ',BALLPK LOGIC = .TRUE. 90 CONTINUE IF (LOGIC) THEN LOGIC = (WL.LT.PIN-1.0 .OR. WU.GT.PIN+1.0) EEE = EL + DEDW*(PIN-WL) FNEW = MIN(PIN-WL,WU-PIN) IF (FNEW.GT.0.4*FOLD .OR. FNEW.LE.1.0) 1 EEE = 0.5*(EL+EU) IF (INTAB.EQ.1 .AND. ABS(EEE).GT.1.0E3*BALLPK) THEN EEE = BALLPK GO TO 100 ELSE IF (INTAB.NE.1 .AND. ABS(EEE).GT.1.0E6) THEN EEE = 1.0 GO TO 100 ELSE FOLD = FNEW C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS, 1 DELT,PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) IF (SUM.LT.PIN) THEN EL = EEE WL = SUM ELSE EU = EEE WU = SUM END IF DEDW = (EU-EL)/(WU-WL) GO TO 90 END IF END IF END IF C END (ESTIMATE-EIG) END IF 100 CONTINUE GUESS = EIG IF (LIMUP .AND. EEE.GE.ELIMUP) EEE = ELIMUP - 0.01 C DO (SET-INITIAL-INTERVAL-AND-MATCHPOINT) IF (GUESS.NE.0.0) THEN EEE=EIG C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) END IF C C Choose initial interval as large as possible that avoids overflow. C JJL and JJR are boundary indices for nonnegativity of EIG*W-Q. C AA = -1.0 IF (SINGA) AA = TFROMI(JJL) BB = 1.0 IF (SINGB) BB = TFROMI(JJR) AA = MIN(-0.01,AA) BB = MAX(0.01,BB) AA = MIN(AA,-0.95) BB = MAX(BB,0.95) IF (OSCA) AA = -0.9999 IF (OSCB) BB = 0.9999 AAF = AAA BBF = BBB C C Determine boundary values ALFA and BETA for theta at A and B. C Z = 1.0 CALL ALFBET(A,INTAB,AA,A1,A2,EEE,P0ATA,QFATA,SINGA,LCIRCA, 1 ALFA,KFLAG,DERIVL) CALL ALFBET(B,INTAB,BB,B1,B2,EEE,P0ATB,QFATB,SINGB,LCIRCB, 1 BETA,JFLAG,DERIVR) IF (SINGB) BETA = PI - BETA C C Take boundary conditions into account in estimation of EIG. C PIN = EIGPI + BETA - ALFA IF (OSCA) PIN = PIN + ALFA IF (OSCB) PIN = PIN + PI - BETA IF (GUESS.EQ.0.0) THEN EEE = EL + DEDW*(PIN-WL) IF (.NOT.(OSCA .OR. OSCB) .AND. ABS(EEE).GT.1000.0) 1 EEE = SIGN(1000.0,EEE) IF (INTAB.EQ.1 .AND. ABS(EEE).GT.1.0E3*BALLPK) EEE = BALLPK END IF C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(OSCA.OR.OSCB,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) C C Choose the constant Z . C IF (U.GT.0.0) Z = ZAV/UT C C Reset boundary values ALFA and BETA . C CALL ALFBET(A,INTAB,AA,A1,A2,EEE,P0ATA,QFATA,SINGA,LCIRCA, 1 ALFA,KFLAG,DERIVL) CALL ALFBET(B,INTAB,BB,B1,B2,EEE,P0ATB,QFATB,SINGB,LCIRCB, 1 BETA,JFLAG,DERIVR) IF (SINGB) BETA = PI - BETA IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' alfa=',ALFA,' beta=',BETA WRITE(21,'(A,E22.14,A,E22.14)') 1 ' ALFA=',ALFA,' BETA=',BETA C C Choose initial matching point TMID . C IMID = 50 TMID = 0.5*(AA+BB) IF (PRIN) WRITE(IOUT,'(A,E15.7,A,F11.8,A,E15.7)') 1 ' estim=',EEE,' tmid=',TMID,' z=',Z IF (PRIN) WRITE(IOUT,'(A,F11.8,A,F11.8,A,F11.8,A,F11.8)') 1 ' aaa=',AAA,' aa=',AA,' bb=',BB,' bbb=',BBB WRITE(21,'(A,E15.7,A,F11.8,A,E15.7)') 1 ' estim=',EEE,' tmid=',TMID,' z=',Z WRITE(21,'(A,F11.8,A,F11.8,A,F11.8,A,F11.8)') 1 ' aaa=',AAA,' aa=',AA,' bb=',BB,' bbb=',BBB C END (SET-INITIAL-INTERVAL-AND-MATCHPOINT) IF (EIG.EQ.0.0 .AND. LIMUP .AND. EEE.GE.ELIMUP) 1 EEE = ELIMUP - 0.01 C DO (RESET-TMID) CALL SETMID(MF,ML,EEE,QS,WS,IMID,TMID) C END (RESET-TMID) IF (OSCA .OR. OSCB) THEN Z = 1.0 C DO (PREP-ZEEZ) DO 85 I=1,100 TEE(I) = 1.0 IF (JAY(I).NE.0) TEE(I) = TFROMI(JAY(I)) 85 CONTINUE C END (PREP-ZEEZ) END IF IF (ISLFUN.EQ.-1) THEN SLFUN(1) = TMID SLFUN(2) = AA SLFUN(3) = ALFA SLFUN(5) = BB SLFUN(6) = BETA + EIGPI SLFUN(9) = Z ADDD = .FALSE. MDTHZ = 0 IFLAG = 1 RETURN END IF C C End preliminary work, begin main task of computing EIG. C C Logical variables have the following meanings if true. C AOK - endpoint A is not singular. C BOK - endpoint B is not singular. C BRACKT - EIG has been bracketed. C CONVRG - convergence test for EIG has been successfully passed. C NEWTON - Newton iteration may be employed. C THELT0 - lower bound for EIG has been found. C THEGT0 - upper bound for EIG has been found. C LIMIT - upper bound exists with boundary conditions satisfied. C ONEDIG - most significant digit can be expected to be correct. C EIG = EEE NRAY = 1 OLDRAY = 1.0E+9 EXIT = .FALSE. FIRSTT = .TRUE. LOOP2 = 0 LOOP3 = 0 BESTEIG = EIG BESTEST = 1.0E+9 OLDEST = BESTEST ADTHETA = 1.0E+9 NEWTONF = .FALSE. CHNGEPS = .FALSE. EPSM = EPSMIN ENDA = .FALSE. ENDB = .FALSE. TSAVEL = -1.0 TSAVER = 1.0 BRS = .FALSE. BRSS = .FALSE. SAVERR = 1.0E+9 AAL = AA BBL = BB EPSL = EPS 110 CONTINUE C DO (INITIAL-IZE) BRACKT = .FALSE. CONVRG = .FALSE. THELT0 = .FALSE. THEGT0 = .FALSE. EIGLO = EMIN - 1.0 FLO = -5.0 FUP = 5.0 EIGLT = 0.0 EIGRT = 0.0 EIGUP = EMAX + 1.0 IF (LIMUP) EIGUP = MIN(EMAX,ELIMUP) DTHOLD = 1.0 C END (INITIAL-IZE) WRITE(21,*) WRITE(21,*) '---------------------------------------------' WRITE(21,*) ' INITIAL GUESS FOR EIG = ',EIG WRITE(21,*) ' aa,bb = ',AA,BB C DO UNTIL(CONVRG .OR. EXIT) DO 120 NITER = 1,40 WRITE(*,*) WRITE(*,*) ' ******************** ' C DO (SET-TMID-AND-BOUNDARY-CONDITIONS) WRITE(*,*) ' set tmid and boundary conditions ' V = EIG*WS(IMID) - QS(IMID) C IF (V.LE.0.0) DO (RESET-TMID) IF (V.LE.0.0) CALL SETMID(MF,ML,EIG,QS,WS,IMID,TMID) C END (RESET-TMID) C DO (RESET-BOUNDARY-CONDITIONS) DERIVL = 0.0 IF (SINGA) CALL ALFBET(A,INTAB,AA,A1,A2,EIG, 1 P0ATA,QFATA,.TRUE.,LCIRCA,ALFA,KFLAG,DERIVL) DERIVR = 0.0 IF (SINGB) THEN CALL ALFBET(B,INTAB,BB,B1,B2,EIG,P0ATB,QFATB, 1 .TRUE.,LCIRCB,BETA,JFLAG,DERIVR) BETA = PI - BETA END IF IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' alfa=',ALFA,' beta=',BETA WRITE(21,'(A,E22.14,A,E22.14)') 1 ' ALFA=',ALFA,' BETA=',BETA C END (RESET-BOUNDARY-CONDITIONS) C C Check that boundary conditions can be satisfied at singular C endpoints. If not, try for slightly altered EIG consistent C with boundary conditions. C IF (LIMUP .AND. EIG.NE.GUESS .AND. .NOT.BRACKT) THEN KFLAG = 1 IF (SINGA .AND. .NOT.LCIRCA) CALL ALFBET(A,INTAB,AA, 1 A1,A2,EIG,P0ATA,QFATA,.TRUE.,.FALSE.,TMP,KFLAG,TMP) JFLAG = 1 IF (SINGB .AND. .NOT.LCIRCB) CALL ALFBET(B,INTAB,BB, 1 B1,B2,EIG,P0ATB,QFATB,.TRUE.,.FALSE.,TMP,JFLAG,TMP) IF ((KFLAG.NE.1 .OR. JFLAG.NE.1) .AND. 1 (THELT0 .AND. EIGLO.LT.ELIMUP)) THEN EIGUP = MIN(ELIMUP+2.0*EPSMIN,EIGUP) IF (EIG.NE.EIGLO .AND. EIG.NE.EIGUP) THEN EIG = 0.05*EIGLO + 0.95*EIGUP ELSE IFLAG = 11 WRITE(21,*) ' IFLAG = 11 ' EXIT = .TRUE. GO TO 130 END IF END IF END IF C END (SET-TMID-AND-BOUNDARY-CONDITIONS) C DO (OBTAIN-DTHETA-WITH-ONE-CORRECT-DIGIT) IF (PRIN) WRITE(IOUT,'(/A,E22.14,A,E10.3,A,E10.3)') 1 ' guess=',EIG,' eps=',EPS,' tmid=',TMID C DO (INTEGRATE-FOR-DTHETA) C DO (SET-INITIAL-CONDITIONS) THA = ALFA DTHDEA = DERIVL DTHDAA = 0.0 IF (SINGA .AND. .NOT.LCIRCA) THEN CALL DXDT(AA,DT,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z C = EIG*WX - QX DTHDAA = -(COS(ALFA)**2/PX + C*SIN(ALFA)**2)*DT C C Two special cases for DTHDAA . C IF (C.GE.0.0 .AND. P0ATA.LT.0.0 .AND. QFATA.LT.0.0) 1 DTHDAA = DTHDAA + ALFA*DT/(X-A) IF (C.GE.0.0 .AND. P0ATA.GT.0.0 .AND. QFATA.GT.0.0) 1 DTHDAA = DTHDAA + (ALFA-0.5*PI)*DT/(X-A) END IF THB = BETA DTHDEB = -DERIVR DTHDBB = 0.0 IF (SINGB .AND. .NOT.LCIRCB) THEN CALL DXDT(BB,DT,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z C = EIG*WX - QX DTHDBB = -(COS(BETA)**2/PX + C*SIN(BETA)**2)*DT C C Two special cases for DTHDBB . C IF (C.GE.0.0 .AND. P0ATB.LT.0.0 .AND. QFATB.LT.0.0) 1 DTHDBB = DTHDBB + (PI-BETA)*DT/(B-X) IF (C.GE.0.0 .AND. P0ATB.GT.0.0 .AND. QFATB.GT.0.0) 1 DTHDBB = DTHDBB + (0.5*PI-BETA)*DT/(B-X) END IF C END (SET-INITIAL-CONDITIONS) EIGSAV = EIG C C YL = (theta,d(theta)/d(eig),d(theta)/da) C YL(1) = ALFA YL(2) = DTHDEA YL(3) = 0.0 C CALL INTEG(AA,THA,DTHDAA,DTHDEA,TMID,A1,A2,EPS,YL,ERL, 1 LCIRCA,AOK,SINGA,OSCA,IFLAG) IF (IFLAG.EQ.5) THEN IFLAG = 51 WRITE(21,*) ' IFLAG = 51 ' EXIT = .TRUE. GO TO 130 END IF DTHDA = DTHDAA*EXP(-2.0*YL(3)) C C YR = (theta,d(theta)/d(eig),d(theta)/db) C YR(1) = BETA + EIGPI - PI YR(2) = DTHDEB YR(3) = 0.0 C CALL INTEG(BB,THB,DTHDBB,DTHDEB,TMID,B1,B2,EPS,YR,ERR, 1 LCIRCB,BOK,SINGB,OSCB,IFLAG) IF (IFLAG.EQ.5) THEN IFLAG = 52 WRITE(21,*) ' IFLAG = 52 ' EXIT = .TRUE. GO TO 130 END IF DTHDB = DTHDBB*EXP(-2.0*YR(3)) C ER1 = ERL(1) - ERR(1) ER2 = ERL(2) - ERR(2) C IF (OSCA .OR. OSCB) THEN Z = 1.0 CALL DXDT(TMID,TMP,XT) CALL UV(XT,U,PUP,V,PVP,HU,HV) EIGSAV = 0.0 CALL INTEG(AA,THA,DTHDAA,DTHDEA,TMID,A1,A2,EPS, 1 YZL,ERL,LCIRCA,AOK,SINGA,OSCA,IFLAG) IF (IFLAG.EQ.5) THEN IFLAG = 53 WRITE(21,*) ' IFLAG = 53 ' EXIT = .TRUE. GO TO 130 END IF CALL INTEG(BB,THB,DTHDBB,DTHDEB,TMID,B1,B2,EPS, 1 YZR,ERR,LCIRCB,BOK,SINGB,OSCB,IFLAG) IF (IFLAG.EQ.5) THEN IFLAG = 54 WRITE(21,*) ' IFLAG = 54 ' EXIT = .TRUE. GO TO 130 END IF EIGSAV = EIG DTHZ = YZR(1) - YZL(1) MDTHZ = DTHZ/PI REMZ = DTHZ - MDTHZ*PI IF (DTHZ.LT.0.0 .AND. REMZ.LT.0.0) THEN MDTHZ = MDTHZ - 1 REMZ = REMZ + PI END IF IF (REMZ.GT.3.14) MDTHZ = MDTHZ + 1 END IF C C Record the environment parameters of this most recent C successful integration. C AAS = AA BBS = BB C C DTHETA measures theta difference from left and right integrations. C C DO (FORM-DTHETA) DTHETA = YL(1) - YR(1) - EIGPI IF (OSCA .OR. OSCB) DTHETA = DTHETA + MDTHZ*PI DTHDE = YL(2) - YR(2) C END (FORM-DTHETA) ADTHETA = ABS(DTHETA) ONEDIG = (ABS(ER1).LE.0.5*ABS(DTHETA) .AND. 1 ABS(ER2).LE.0.5*ABS(DTHDE)) .OR. 2 MAX(ADTHETA,ABS(ER1)).LT.1.0E-6 FIRSTT = .FALSE. C END (INTEGRATE-FOR-DTHETA) CHNGEPS = .FALSE. CONVRG = .FALSE. OLDNEWT = NEWTON NEWTON = ABS(DTHETA).LT.0.06 .AND. BRACKT IF (NEWTON) 1 ONEDIG = ONEDIG .OR. ABS(DTHETA+ER1).LT.0.5*DTHOLD IF (PRIN) WRITE(IOUT,'(A,E15.7,A,E15.7)') 1 ' dtheta=',DTHETA,' dthde=',DTHDE IF (PRIN) WRITE(IOUT,'(/A,E15.7,A,E15.7)') 1 ' thetal=',YL(1),' thetar=',YR(1) C END (OBTAIN-DTHETA-WITH-ONE-CORRECT-DIGIT) IF (.NOT.ONEDIG .AND. BRS) THEN EXIT = .TRUE. WRITE(21,*) ' NOT ONEDIG ' GO TO 130 END IF C DO (SET-BRACKET-DATA) WRITE(*,*) ' set-bracket ' IF (DTHETA.GT.0.0) THEN IF (.NOT.THEGT0 .OR. EIG.LE.EIGUP) THEN THEGT0 = .TRUE. EIGUP = EIG FUP = DTHETA EIGRT = EIG - DTHETA/DTHDE END IF ELSE IF (.NOT.THELT0 .OR. EIG.GE.EIGLO) THEN THELT0 = .TRUE. EIGLO = EIG FLO = DTHETA EIGLT = EIG - DTHETA/DTHDE END IF END IF C C EIG is bracketed when both THEGT0=.true. and THELT0=.true. C BRACKT = THELT0 .AND. THEGT0 IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' eigrt=',EIGRT,' eigup=',EIGUP IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' eiglt=',EIGLT,' eiglo=',EIGLO C END (SET-BRACKET-DATA) IF (BRACKT) LOOP2 = 0 C DO (TEST-FOR-CONVERGENCE) C C Measure convergence after adding separate contributions to error. C FLOUP = MIN(ABS(FLO),ABS(FUP)) T1 = (ABS(DTHETA)+MAX(ABS(ERL(1)),ABS(ERR(1))))/ABS(DTHDE) T2 = (1.0+AA)*ABS(DTHDA)/ABS(DTHDE) T3 = (1.0-BB)*ABS(DTHDB)/ABS(DTHDE) WRITE(21,*) ' FLO,FUP,FLOUP = ',FLO,FUP,FLOUP WRITE(21,*) ' DTHDE,DTHDA,DTHDB = ',DTHDE,DTHDA,DTHDB PT2 = (AAF-AA)*DTHDA/DTHDE PT3 = (BBF-BB)*DTHDB/DTHDE IF (.NOT.TRUNKA) THEN T2 = 0.0 PT2 = 0.0 END IF IF (.NOT.TRUNKB) THEN T3 = 0.0 PT3 = 0.0 END IF ESTERR = T1 + T2 + T3 ESTERR = ESTERR/MAX(ONE,ABS(EIG)) CONVRG = ESTERR.LE.TAUM .AND. NEWTON WRITE(21,*) ' T1,T2,T3 = ',T1,T2,T3 WRITE(21,*) ' PT2,PT3 = ',PT2,PT3 WRITE(21,*) ' TMID,EPS = ',TMID,EPS WRITE(21,*) ' ONEDIG,BRACKT,NEWTON,CONVRG = ', 1 ONEDIG,BRACKT,NEWTON,CONVRG WRITE(21,*) ' EIG,DTHETA,ESTERR = ',EIG,DTHETA,ESTERR IF (BRACKT .AND. (ESTERR.LT.BESTEST .OR. .NOT.BRS) .AND. 1 ADTHETA.LT.0.1) THEN BESTAA = AA BESTBB = BB BESTMID = TMID BESTEPS = EPS BESTEIG = EIG BESTEST = ESTERR BRS = BRACKT IF (BRS) BRSS = BRS WRITE(21,*) ' BESTEIG,BESTEST = ',BESTEIG,BESTEST WRITE(21,*) ' BRS = ',BRS END IF IF (THEGT0) WRITE(21,*) ' EIGUP = ',EIGUP IF (THELT0) WRITE(21,*) ' EIGLO = ',EIGLO WRITE(21,*) '---------------------------------------------' IF (PRIN) WRITE(IOUT,'(A,L2)') ' converge=',CONVRG IF (PRIN .AND. .NOT.CONVRG) WRITE(IOUT,'(A,E15.7)') 1 ' estim. acc.=',ESTERR C END (TEST-FOR-CONVERGENCE) IF (CONVRG) THEN WRITE(*,*) ' number of iterations was ',NITER WRITE(21,*) ' NUMBER OF ITERATIONS WAS ',NITER WRITE(*,*) '-----------------------------------------------' GO TO 130 ELSE IF (NEWTON) THEN IF (OLDNEWT .AND. ADTHETA.GT.0.8*ABS(DTHOLD)) THEN WRITE(21,*) ' ADTHETA,DTHOLD = ',ADTHETA,DTHOLD WRITE(21,*) ' NEWTON DID NOT IMPROVE EIG ' NEWTONF = .TRUE. LOOP3 = LOOP3 + 1 ELSE IF (TRUNKA .OR. TRUNKB) THEN ENDA = ADTHETA.LT.1.0 .AND. ABS(PT2).GT.MAX(TAUM,T1) 1 .AND. TRUNKA ENDB = ADTHETA.LT.1.0 .AND. ABS(PT3).GT.MAX(TAUM,T1) 1 .AND. TRUNKB IF (ENDA .OR. ENDB) THEN NEWTON = .FALSE. ELSE IF ((T2+T3).GT.T1 .AND. ADTHETA.LT.1.0 .AND. 1 (AA.LE.AAF .AND. BB.GE.BBF)) THEN WRITE(*,*) ' RESIDUAL TRUNCATION ERROR DOMINATES ' EXIT = .TRUE. IFLAG = 9 WRITE(21,*) ' IFLAG = 9 ' GO TO 130 END IF END IF IF (NEWTONF .OR. ENDA .OR. ENDB) THEN WRITE(21,*) ' NEWTONF,ENDA,ENDB = ',NEWTONF,ENDA,ENDB EXIT = .TRUE. GO TO 130 END IF C DO (NEWTON'S-METHOD) WRITE(*,*) ' Newton''s method ' RLX = 1.2 IF (BRACKT) RLX = 1.0 EIG = EIG - RLX*DTHETA/DTHDE IF (EIG.LE.EIGLO .OR. EIG.GE.EIGUP) 1 EIG = 0.5*(EIGLO+EIGUP) WRITE(21,*) ' NEWTON: EIG = ',EIG C END (NEWTON'S-METHOD) ELSE IF (BRACKT) THEN WRITE(*,*) ' bracket ' C DO (SECANT-METHOD) WRITE(*,*) ' do secant method ' FMAX = MAX(-FLO,FUP) EOLD = EIG EIG = 0.5*(EIGLO+EIGUP) IF (FMAX.LE.1.5) THEN U = -FLO/(FUP-FLO) DIST = EIGUP - EIGLO EIG = EIGLO + U*DIST V = MIN(EIGLT,EIGRT) IF (EIG.LE.V) EIG = 0.5*(EIG+V) V = MAX(EIGLT,EIGRT) IF (EIG.GE.V) EIG = 0.5*(EIG+V) DE = EIG - EOLD IF (ABS(DE).LT.EPSMIN) THEN TOL = ABS(DE)/MAX(ONE,ABS(EIG)) IFLAG = 6 EXIT = .TRUE. GO TO 130 END IF END IF WRITE(21,*) ' SECANT: EIG = ',EIG C END (SECANT-METHOD) ELSE C DO (TRY-FOR-BRACKET) LOOP2 = LOOP2 + 1 IF (LOOP2.GT.9 .AND. .NOT.LIMUP) THEN IFLAG = 12 WRITE(21,*) ' IFLAG = 12 ' EXIT = .TRUE. GO TO 130 END IF IF (EIG.EQ.EEE) THEN IF (GUESS.NE.0.0) DEDW = 1.0/DTHDE CHNG = -0.6*(DEDW+1.0/DTHDE)*DTHETA IF (EIG.NE.0.0 .AND. ABS(CHNG).GT.0.1*ABS(EIG)) 1 CHNG = -0.1*SIGN(EIG,DTHETA) ELSE CHNG = -1.2*DTHETA/DTHDE IF (CHNG.EQ.0.) CHNG = 0.1*MAX(1.0,ABS(EIG)) WRITE(21,*) ' IN BRACKET, 1,CHNG = ',CHNG C C Limit change in EIG to a factor of 10. C IF (ABS(CHNG).GT.(1.0+10.0*ABS(EIG))) THEN CHNG = SIGN(1.0+10.0*ABS(EIG),CHNG) WRITE(21,*) ' IN BRACKET, 2,CHNG = ',CHNG ELSE IF (ABS(EIG).GE.1.0 .AND. 1 ABS(CHNG).LT.0.1*ABS(EIG)) THEN CHNG = 0.1*SIGN(EIG,CHNG) WRITE(21,*) ' IN BRACKET, 3,CHNG = ',CHNG END IF IF (DTHOLD.LT.0.0 .AND. LIMUP .AND. 1 CHNG.GT.(ELIMUP-EIG)) THEN CHNG = 0.95*(ELIMUP-EIG) WRITE(21,*) ' ELIMUP,EIG,CHNG = ', 1 ELIMUP,EIG,CHNG IF (CHNG.LT.EPSMIN) THEN WRITE(*,*) ' ELIMUP,EIG = ',ELIMUP,EIG WRITE(21,*) ' IN BRACKET, CHNG.LT.EPSMIN ' ENDA = TRUNKA .AND. AA.GT.AAF .AND. 1 (0.5*DTHETA+(AAF-AA)*DTHDA).GT.0.0 ENDB = TRUNKB .AND. BB.LT.BBF .AND. 1 (0.5*DTHETA-(BBF-BB)*DTHDB).GT.0.0 IF (.NOT.(ENDA .OR. ENDB)) THEN NUMEIG = NEIG - INT(-DTHETA/PI) WRITE(*,*) ' new numeig = ',NUMEIG WRITE(21,*) ' NEW NUMEIG = ',NUMEIG END IF IFLAG = 3 GO TO 150 END IF END IF END IF EOLD = EIG CHNGLIM = 2.0*ESTERR*MAX(ONE,ABS(EIG)) WRITE(21,*) ' CHNGLIM = ',CHNGLIM IF (ADTHETA.LT.0.06 .AND. ABS(CHNG).GT.CHNGLIM .AND. 1 CHNGLIM.NE.0.0) CHNG = SIGN(CHNGLIM,CHNG) IF ((THELT0 .AND. CHNG.LT.0.0) .OR. 1 (THEGT0 .AND. CHNG.GT.0.0)) CHNG = -CHNG EIG = EIG + CHNG WRITE(21,*) ' BRACKET: EIG = ',EIG C END (TRY-FOR-BRACKET) END IF END IF IF (IFLAG.EQ.3) GO TO 130 IF (NITER.GE.3 .AND. DTHOLDY.EQ.DTHETA) THEN IFLAG = 7 WRITE(21,*) ' IFLAG = 7 ' EXIT = .TRUE. GO TO 130 END IF DTHOLDY = DTHOLD DTHOLD = DTHETA WRITE(*,*) ' number of iterations was ',NITER WRITE(*,*) '-----------------------------------------------' 120 CONTINUE IFLAG = 8 WRITE(21,*) ' IFLAG = 8 ' EXIT = .TRUE. 130 CONTINUE IF (AA.EQ.AAL .AND. BB.EQ.BBL .AND. EPS.LT.EPSL .AND. 1 ESTERR.GE.0.5*SAVERR) GO TO 140 EPSL = EPS AAL = AA BBL = BB TOL = BESTEST EIG = BESTEIG IF (EXIT) THEN WRITE(21,*) ' EXIT ' IF (FIRSTT) THEN IF (IFLAG.EQ.51 .OR. IFLAG.EQ.53) THEN IF (AA.LT.-0.1) THEN WRITE(*,*) ' FIRST COMPLETE INTEGRATION FAILED. ' WRITE(21,*) ' FIRST COMPLETE INTEGRATION FAILED. ' IF (AA.EQ.-1.0) GO TO 150 AAF = AA CALL AABB(AA,-ONE) WRITE(21,*) ' aa MOVED FROM ',AAf,' IN TO ',AA EXIT = .FALSE. GO TO 110 ELSE WRITE(21,*) ' aa.GE.-0.1 ' IFLAG = 13 GO TO 150 END IF ELSE IF (IFLAG.EQ.52 .OR. IFLAG.EQ.54) THEN IF (BB.GT.0.1) THEN WRITE(*,*) ' FIRST COMPLETE INTEGRATION FAILED. ' WRITE(21,*) ' FIRST COMPLETE INTEGRATION FAILED. ' IF (BB.EQ.1.0) GO TO 150 BBF = BB CALL AABB(BB,-ONE) WRITE(21,*) ' bb MOVED FROM ',BBf,' IN TO ',BB EXIT = .FALSE. GO TO 110 ELSE WRITE(21,*) ' bb.LE.0.1 ' IFLAG = 14 GO TO 150 END IF END IF ELSE IF (IFLAG.EQ.51 .OR. IFLAG.EQ.53) THEN WRITE(*,*) ' A COMPLETE INTEGRATION FAILED. ' WRITE(21,*) ' A COMPLETE INTEGRATION FAILED. ' IF (CHNGEPS) THEN EPS = 5.0*EPS EPSM = EPS WRITE(21,*) ' EPS INCREASED TO ',EPS ELSE AAF = AA CALL AABB(AA,-ONE) WRITE(21,*) ' aa MOVED FROM ',AAf,' IN TO ',AA END IF EXIT = .FALSE. GO TO 110 ELSE IF (IFLAG.EQ.52 .OR. IFLAG.EQ.54) THEN WRITE(*,*) ' A COMPLETE INTEGRATION FAILED. ' WRITE(21,*) ' A COMPLETE INTEGRATION FAILED. ' IF (CHNGEPS) THEN EPS = 5.0*EPS EPSM = EPS WRITE(21,*) ' EPS INCREASED TO ',EPS ELSE BBF = BB CALL AABB(BB,-ONE) WRITE(21,*) ' bb MOVED FROM ',BBf,' IN TO ',BB END IF EXIT = .FALSE. GO TO 110 ELSE IF (IFLAG.EQ.6) THEN WRITE(*,*) ' IN SECANT, CHNG.LT.EPSMIN ' WRITE(21,*) ' IN SECANT, CHNG.LT.EPSMIN ' GO TO 140 ELSE IF (IFLAG.EQ.7) THEN WRITE(*,*) ' DTHETA IS REPEATING ' WRITE(21,*) ' DTHETA IS REPEATING ' GO TO 140 ELSE IF (IFLAG.EQ.8) THEN WRITE(*,*) ' NUMBER OF ITERATIONS REACHED SET LIMIT ' WRITE(21,*) ' NUMBER OF ITERATIONS REACHED SET LIMIT ' GO TO 140 ELSE IF (IFLAG.EQ.9) THEN WRITE(21,*) ' RESIDUAL TRUNCATION ERROR DOMINATES ' GO TO 140 ELSE IF (IFLAG.EQ.11) THEN WRITE(*,*) ' IN TRY FOR BRACKET, CHNG.LT.EPSMIN ' WRITE(21,*) ' IN TRY FOR BRACKET, CHNG.LT.EPSMIN ' GO TO 140 ELSE IF (IFLAG.EQ.12) THEN WRITE(*,*) ' FAILED TO GET A BRACKET. ' WRITE(21,*) ' FAILED TO GET A BRACKET. ' GO TO 140 ELSE IF (NEWTONF .OR. .NOT.ONEDIG) THEN IF (LOOP3.GE.3) THEN WRITE(21,*) ' NEWTON IS NOT GETTING ANYWHERE ' NEWTONF = .FALSE. GO TO 140 END IF WRITE(21,*) ' BESTEST,OLDEST = ',BESTEST,OLDEST IF (EPS.GT.EPSM .AND. BESTEST.LT.OLDEST) THEN CHNGEPS = .TRUE. SAVERR = ESTERR EPS = 0.2*EPS WRITE(*,*) ' EPS REDUCED TO ',EPS WRITE(21,*) ' EPS REDUCED TO ',EPS EXIT = .FALSE. NEWTON = .FALSE. OLDEST = BESTEST GO TO 110 ELSE IF (EPS.LE.EPSM) THEN WRITE(*,*) ' EPS CANNOT BE REDUCED FURTHER. ' WRITE(21,*) ' EPS CANNOT BE REDUCED FURTHER. ' IFLAG = 2 GO TO 140 ELSE WRITE(*,*) ' no more improvement ' WRITE(21,*) ' NO MORE IMPROVEMENT ' GO TO 140 END IF END IF ELSE IF (ENDA) THEN CALL AABB(AA,ONE) AA = MAX(AA,AAA) IF (AA.LE.AAF) THEN WRITE(21,*) ' NO MORE IMPROVEMENT ' GO TO 140 END IF WRITE(*,*) ' aa MOVED OUT TO ',AA WRITE(21,*) ' aa MOVED OUT TO ',AA EXIT = .FALSE. GO TO 110 ELSE IF (ENDB) THEN CALL AABB(BB,ONE) BB = MIN(BB,BBB) IF (BB.GE.BBF) THEN WRITE(21,*) ' NO MORE IMPROVEMENT ' GO TO 140 END IF WRITE(*,*) ' bb MOVED OUT TO ',BB WRITE(21,*) ' bb MOVED OUT TO ',BB EXIT = .FALSE. GO TO 110 END IF END IF 140 CONTINUE C C If CONVRG is false, check that any truncation error might possibly C be reduced or that the integrations might be done more accurately. C IF (.NOT.CONVRG .AND. IFLAG.LT.50 .AND. IFLAG.NE.11) THEN SAVAA = AA SAVBB = BB IF (EPS.GT.EPSM .AND. ESTERR.LT.0.5*SAVERR) THEN WRITE(21,*) ' SAVERR,ESTERR = ',SAVERR,ESTERR SAVERR = ESTERR EPS = 0.2*EPS WRITE(*,*) ' EPS REDUCED TO ',EPS WRITE(21,*) ' 2,EPS REDUCED TO ',EPS EXIT = .FALSE. NEWTON = .FALSE. OLDEST = BESTEST GO TO 110 ELSE IF (ABS(PT2).GT.TAUM .OR. ABS(PT3).GT.TAUM) THEN IF ((AAS-AAF).GT.2.0*EPSMIN .AND. ABS(PT2).GT.TAUM) THEN CALL AABB(AA,ONE) AA = MAX(AA,AAA) IF (AA.GT.AAF .AND. AA.LT.SAVAA) THEN WRITE(*,*) ' aa MOVED OUT TO ',AA WRITE(21,*) ' 3,aa MOVED OUT TO ',AA EXIT = .FALSE. END IF END IF IF ((BBF-BBS).GT.2.0*EPSMIN .AND. ABS(PT3).GT.TAUM) THEN CALL AABB(BB,ONE) BB = MIN(BB,BBB) IF (BB.GT.SAVBB .AND. BB.LT.BBF) THEN WRITE(*,*) ' bb MOVED OUT TO ',BB WRITE(21,*) ' 3,bb MOVED OUT TO ',BB EXIT = .FALSE. END IF END IF IF (.NOT.EXIT .AND. (AA.NE.SAVAA .OR. BB.NE.SAVBB)) 1 GO TO 110 END IF END IF IF (PRIN) WRITE(IOUT,'(A,I7,A,E22.14,A,E10.3)') 1 ' numeig=',NUMEIG,' eig=',EIG,' tol=',TOL WRITE(21,*) 'NUMEIG = ',NUMEIG,' EIG = ',EIG,' TOL = ',TOL IF (BRSS .AND. BESTEST.LT.0.05) THEN C DO (COMPUTE-EIGENFUNCTION-DATA) C C Convert from T to X values, fill 7 of first 9 locations of SLFUN. C CALL DXDT(TMID,TMP,XMID) CALL DXDT(AA,TMP,XAA) CALL DXDT(BB,TMP,XBB) SLFUN(1) = XMID SLFUN(2) = XAA SLFUN(3) = ALFA SLFUN(5) = XBB SLFUN(6) = BETA + EIGPI SLFUN(8) = EPS SLFUN(9) = Z C C Compute SLFUN(4), SLFUN(7) towards normalizing the eigenfunction. C EIGSAV = EIG THA = ALFA DTHDAAX = 0.0 YL(1) = 0.0 YL(2) = 0.0 YL(3) = 0.0 CALL INTEG(AA,THA,DTHDAAX,DTHDEA,TMID,A1,A2,EPS,YL,ERL, 1 LCIRCA,AOK,SINGA,OSCA,JFLAG) THB = BETA DTHDBBX = 0.0 CALL INTEG(BB,THB,DTHDBBX,DTHDEB,TMID,B1,B2,EPS,YR,ERR, 1 LCIRCB,BOK,SINGB,OSCB,JFLAG) YR(1) = YR(1) + EIGPI SL = SIN(YL(1)) SR = SIN(YR(1)) CL = COS(YL(1)) CR = COS(YR(1)) UL = (YL(2)-DTHDEA*EXP(-2.0*YL(3)))*Z UR = (YR(2)-DTHDEB*EXP(-2.0*YR(3)))*Z DUM = 0.5*LOG(UL-UR) SLFUN(4) = -YL(3) - DUM SLFUN(7) = -YR(3) - DUM C END (COMPUTE-EIGENFUNCTION-DATA) C DO (CHECK-MATCHING-VALUES-OF-EIGENFUNCTION) C C Perform final check on EIG. Return IFLAG = 2 C if not accurate enough. C DEN = UL*SR*SR - UR*SL*SL E = ABS(SR)/SQRT(DEN) PSIL = E*SL PSIPL = E*CL*Z SQL = E*E*UL E = ABS(SL)/SQRT(DEN) PSIR = E*SR PSIPR = E*CR*Z SQR = E*E*UR ADDD = PSIL*PSIR.LT.0.0 .AND. PSIPL*PSIPR.LT.0.0 RAY = EIG + (PSIL*PSIPL-PSIR*PSIPR)/(SQL-SQR) IF (PRIN) THEN WRITE(IOUT,'(A,E22.14)') ' ray=',RAY WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' psil=',PSIL,' psir=',PSIR WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' psipl=',PSIPL,' psipr=',PSIPR WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' sql=',SQL,' sqr=',SQR END IF C END (CHECK-MATCHING-VALUES-OF-EIGENFUNCTION) C C If next condition is .true., then something is apparently wrong C with the accuracy of EIG. Bisect and go through the loop again. C WRITE(21,*) ' EIG,RAY = ',EIG,RAY IF (ABS(RAY-EIG).GT.2.0*TAUM*MAX(ONE,ABS(EIG))) THEN NRAY = NRAY + 1 WRITE(*,*) ' nray = ',nray WRITE(21,*) ' NRAY,RAY,OLDRAY = ',NRAY,RAY,OLDRAY IF (ESTERR.GE.0.5*SAVERR) THEN IFLAG = 2 GO TO 150 END IF EIG = 0.5*(EIG+RAY) SAVRAY = OLDRAY OLDRAY = RAY IF (OLDRAY.NE.SAVRAY .AND. NRAY.LT.3) GO TO 110 END IF C DO (GENERATE-EIGENFUNCTION-VALUES) CALL EIGFCN(EIGPI,A1,A2,B1,B2,AOK,SINGA,LCIRCA,OSCA, 1 BOK,SINGB,LCIRCB,OSCB,SLFUN,ISLFUN) C END (GENERATE-EIGENFUNCTION-VALUES) IFLAG = 1 END IF C C IF THE ESTIMATED ACCURACY IMPLIES THAT THE COMPUTED VALUE C OF THE EIGENVALUE IS UNCERTAIN, SIGNAL BY IFLAG = 2. C IF ((ABS(EIG).LE.ONE .AND. TOL.GE.ABS(EIG)) .OR. 1 (ABS(EIG).GT.ONE .AND. TOL.GE.ONE)) IFLAG = 2 C 150 CONTINUE WRITE(21,*) ' BEST aa,bb,TMID,EPS = ', 1 BESTAA,BESTBB,BESTMID,BESTEPS WRITE(21,*) ' BRS,BESTEIG,BESTEST = ',BRS,BESTEIG,BESTEST WRITE(21,*) ' IFLAG = ',IFLAG WRITE(21,*) '********************************************' WRITE(21,*) RETURN END SUBROUTINE AABB(TEND,OUT) DOUBLE PRECISION TEND,OUT C ********** C C This subroutine moves aa or bb further out or closer in. C TEND is either aa or bb. If OUT is positive, TEND is moved C further out, and if OUT is negative, TEND is moved closer in. C C ********** C .. Local Scalars .. INTEGER J DOUBLE PRECISION DIF,REM,TTEND C .. C .. Intrinsic Functions .. INTRINSIC ABS,LOG10,SIGN C .. REM = 1.0 - ABS(TEND) J = LOG10(5.0/REM) IF (OUT.GT.0.0) J = J + 1 DIF = 10.0**(-J) TTEND = SIGN(1.0-DIF,TEND) IF (TTEND.EQ.TEND) THEN IF (OUT.LT.0.0) TTEND = SIGN(1.0-10.0*DIF,TEND) IF (OUT.GT.0.0) TTEND = SIGN(1.0-0.1*DIF,TEND) END IF TEND = TTEND RETURN END SUBROUTINE ALFBET(XEND,INTAB,TT,COEF1,COEF2,EIG,P0,QF,SING, 1 LCIRC,VALUE,IFLAG,DERIV) INTEGER INTAB,IFLAG LOGICAL SING,LCIRC DOUBLE PRECISION XEND,TT,COEF1,COEF2,EIG,P0,QF,VALUE,DERIV C ********** C C This subroutine computes a boundary value for a specified endpoint C of the interval for a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. It is called C from SLEIGN2. Both regular and singular endpoints are treated. C C Subprograms called C C user-supplied ..... p,q,w C C sleign2-supplied .. dxdt,extrap C C ********** C .. Scalars in Common .. DOUBLE PRECISION Z C .. C .. Local Scalars .. LOGICAL LOGIC DOUBLE PRECISION C,CD,D,HH,ONE,PI,PUP,PVP,PX,QX,WX,T,TEMP,TTS, 1 U,V,X,XDENOM,XNUM C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. External Subroutines .. EXTERNAL DXDT,EXTRAP,UV C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,SIGN,SQRT C .. C .. Common blocks .. COMMON /ZEE/Z C .. C Set machine dependent constant. C C PI (variable ONE set to 1.0 eases precision conversion). ONE = 1.0 PI = 4.0*ATAN(ONE) C IFLAG = 1 DERIV = 0.0 IF (.NOT.SING) THEN VALUE = 0.5*PI IF (COEF1.NE.0.0) VALUE = ATAN(-Z*COEF2/COEF1) LOGIC = (TT.LT.0.0 .AND. VALUE.LT.0.0) .OR. 1 (TT.GT.0.0 .AND. VALUE.LE.0.0) IF (LOGIC) VALUE = VALUE + PI ELSE IF (LCIRC) THEN CALL DXDT(TT,TEMP,X) CALL UV(X,U,PUP,V,PVP,TEMP,TEMP) XNUM = COEF1*U+COEF2*V XDENOM = (COEF1*PUP+COEF2*PVP)/Z VALUE = ATAN2(XNUM,XDENOM) IF (XNUM.LT.0.0) VALUE = VALUE + 2.0*PI ELSE LOGIC = (INTAB.EQ.2 .AND. TT.GT.0.0) .OR. 1 (INTAB.EQ.3 .AND. TT.LT.0.0) .OR. 2 INTAB.EQ.4 .OR. (P0.GT.0.0 .AND. QF.LT.0.0) IF (LOGIC) THEN T = SIGN(ONE,TT) TTS = TT CALL EXTRAP(T,TTS,EIG,VALUE,DERIV,IFLAG) ELSE CALL DXDT(TT,TEMP,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z C = 2.0*(EIG*WX-QX) IF (C.LT.0.0) THEN VALUE = 0.0 IF (P0.GT.0.0) VALUE = 0.5*PI ELSE HH = ABS(XEND-X) D = 2.0*HH/PX CD = C*D*HH IF (P0.GT.0.0) THEN VALUE = C*HH IF (CD.LT.1.0) VALUE = VALUE/(1.0+SQRT(1.0-CD)) VALUE = VALUE + 0.5*PI ELSE VALUE = D IF (CD.LT.1.0) VALUE = VALUE/(1.0+SQRT(1.0-CD)) END IF END IF END IF END IF RETURN END SUBROUTINE DXDT(T,DT,X) DOUBLE PRECISION T,DT,X C ********** C C This subroutine transforms coordinates from T on (-1,1) to C X on (A,B) in the solution of a Sturm-Liouville problem. C It is called from subroutines SLEIGN2, ALFBET, F, and EXTRAP. C C ********** C .. Scalars in Common .. INTEGER INTAB DOUBLE PRECISION A,B,C1,C2 C .. C .. Local Scalars .. DOUBLE PRECISION U C .. C .. Intrinsic Functions .. INTRINSIC ABS C .. C .. Common blocks .. COMMON /DATADT/A,B,C1,C2,INTAB C .. U = C1*T + C2 GO TO (10,20,30,40), INTAB 10 CONTINUE DT = C1*0.5*(B-A) X = 0.5*((B+A)+(B-A)*U) RETURN 20 CONTINUE DT = C1*2.0/(1.0-U)**2 X = A + (1.0+U)/(1.0-U) RETURN 30 CONTINUE DT = C1*2.0/(1.0+U)**2 X = B - (1.0-U)/(1.0+U) RETURN 40 CONTINUE DT = C1/(1.0-ABS(U))**2 X = U/(1.0-ABS(U)) RETURN END SUBROUTINE EIGFCN(EIGPI,A1,A2,B1,B2,AOK,SINGA,LCIRCA,OSCA, 1 BOK,SINGB,LCIRCB,OSCB,SLFUN,ISLFUN) INTEGER ISLFUN LOGICAL AOK,SINGA,LCIRCA,OSCA,BOK,SINGB,LCIRCB,OSCB DOUBLE PRECISION EIGPI,A1,A2,B1,B2 DOUBLE PRECISION SLFUN(ISLFUN+9) C ********** C ********** C .. Scalars in Common .. INTEGER MDTHZ LOGICAL ADDD DOUBLE PRECISION AA,BB,DTHDAA,DTHDBB,TMID C .. C .. Local Scalars .. INTEGER I,IFLAG,J,NMID LOGICAL LCIRC,OK,SING DOUBLE PRECISION DTHDAT,DTHDBT,DTHDET,EFF,T,THT,TM C .. C .. Local Arrays .. DOUBLE PRECISION ERL(3),ERR(3),YL(3),YR(3) C .. C .. External Subroutines .. EXTERNAL INTEG C .. C .. Intrinsic Functions .. INTRINSIC EXP,SIN C .. C .. Common blocks .. COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ C .. C C WARNING: In this program it is assumed that the points T C in SLFUN all lie within the interval (AA,BB). C C Calculate selected eigenfunction values by integration (over T). C NMID = 0 DO 10 I=1,ISLFUN IF (SLFUN(9+I).LE.TMID) NMID = I 10 CONTINUE IF (NMID.GT.0) THEN T = AA YL(1) = SLFUN(3) YL(2) = 0.0 YL(3) = 0.0 LCIRC = LCIRCA OK = AOK SING = SINGA EFF = 0.0 DO 20 J=1,NMID TM = SLFUN(J+9) IF (TM.LT.AA .OR. TM.GT.BB) THEN WRITE(*,*) ' t.lt.aa .or. t.gt.bb ' STOP END IF THT = YL(1) DTHDAT = DTHDAA*EXP(-2.0*EFF) DTHDET = YL(2) IF (TM.GT.AA) THEN CALL INTEG(T,THT,DTHDAT,DTHDET,TM,A1,A2,SLFUN(8), 1 YL,ERL,LCIRC,OK,SING,OSCA,IFLAG) IF (OSCA) THEN EFF = YL(3) ELSE LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YL(3) END IF END IF SLFUN(J+9) = SIN(YL(1))*EXP(EFF+SLFUN(4)) T = TM IF (T.GT.-1.0) OK = .TRUE. IF (T.LT.-0.9 .AND .OSCA) THEN OK = .FALSE. T = AA YL(1) = SLFUN(3) YL(2) = 0.0 YL(3) = 0.0 END IF 20 CONTINUE END IF IF (NMID.LT.ISLFUN) THEN T = BB YR(1) = SLFUN(6) - EIGPI YR(2) = 0.0 YR(3) = 0.0 LCIRC = LCIRCB OK = BOK SING = SINGB EFF = 0.0 DO 30 J=ISLFUN,NMID+1,-1 TM = SLFUN(J+9) IF (TM.LT.AA .OR. TM.GT.BB) THEN WRITE(*,*) ' t.lt.aa .or. t.gt.bb ' STOP END IF THT = YR(1) DTHDBT = DTHDBB*EXP(-2.0*EFF) DTHDET = YR(2) IF (TM.LT.BB) THEN CALL INTEG(T,THT,DTHDBT,DTHDET,TM,B1,B2,SLFUN(8), 1 YR,ERR,LCIRC,OK,SING,OSCB,IFLAG) IF (OSCB) THEN EFF = YR(3) ELSE LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YR(3) END IF END IF SLFUN(J+9) = SIN(YR(1)+EIGPI)*EXP(EFF+SLFUN(7)) IF (ADDD) SLFUN(J+9) = -SLFUN(J+9) T = TM IF (T.LT.1.0) OK = .TRUE. IF (T.GT.0.9 .AND. OSCB) THEN OK = .FALSE. T = BB YR(1) = SLFUN(6) - EIGPI YR(2) = 0.0 YR(3) = 0.0 END IF 30 CONTINUE END IF RETURN END SUBROUTINE ESTPAC(IOSC,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS,TAU, 1 IA,IB,JJL,JJR,SUM,U,UT,ZAV) INTEGER MF,ML,IA,IB,JJL,JJR LOGICAL IOSC DOUBLE PRECISION EEE,SUM0,TAU,SUM,U,UT,ZAV DOUBLE PRECISION QS(ML),WS(ML),DS(ML),DELT(ML),PS(ML),PSS(ML) C ********** C C This subroutine estimates the change in 'phase angle' in the C eigenvalue determination of a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. C C The subroutine approximates the (trapezoidal rule) integral of C C sqrt((eig*w-q)/p) C C where the integral is taken over those X in (A,B) for which C C (eig*w-q)/p .gt. 0 C C ********** C .. Local Scalars .. INTEGER J,JJ,JSAV,MF1 DOUBLE PRECISION PSUM,RT,RTSAV,V,WW,WSAV,DPSUM,DPSUMT,ZAVJ,ZAVSAV C .. C .. Arrays in Common .. INTEGER JAY(100) DOUBLE PRECISION ZEE(100) C .. C .. Intrinsic Functions .. INTRINSIC ABS,MAX,MIN,SIGN,SQRT C .. C .. Common blocks .. COMMON /ZEEZ/JAY,ZEE C .. IA = MF IB = 80 C C SUM accumulates the integral approximation. U measures the total C length of subintervals where (EIG*W-Q)/P .gt. 0.0. ZAV is the C average value of sqrt((EIG*W-Q)*P) over those subintervals. C IF (.NOT.IOSC) THEN JJL = 99 JJR = 1 SUM = 0.0 U = 0.0 UT = 0.0 ZAV = 0.0 WSAV = EEE*WS(MF) - QS(MF) IF (WSAV.GT.0.0) THEN RTSAV = SIGN(SQRT(WSAV),PS(MF)) ELSE RTSAV = 0.0 END IF DO 10 J=MF+1,ML WW = EEE*WS(J) - QS(J) IF (WW.GT.0.0) THEN IF (J.GT.80) IB = J U = U + DS(J-1) UT = UT + DELT(J-1) RT = SIGN(SQRT(WW),PS(J)) ELSE RT = 0.0 IF (U.EQ.0.0 .AND. RTSAV.EQ.0.0 .AND. IA.LE.19) 1 IA = IA + 1 END IF IF (WW.EQ.0.0 .OR.WSAV.EQ.0.0 .OR. WW.EQ.SIGN(WW,WSAV)) THEN V = RT + RTSAV ELSE V = (WW*RT+WSAV*RTSAV)/ABS(WW-WSAV) END IF WSAV = WW RTSAV = RT PSUM = DS(J-1)*V IF (EEE.EQ.0.0) THEN PSS(J) = PSUM ELSE DPSUM = PSUM - PSS(J) DPSUMT = DPSUM*DELT(J-1)/DS(J-1) IF (DPSUMT.GT.0.001*TAU) THEN JJL = MIN(JJL,J) JJR = MAX(JJR,J) END IF END IF SUM = SUM + PSUM IF (U.GT.0.0) ZAV = ZAV + DELT(J-1)*V*ABS(PS(J)+PS(J-1)) 10 CONTINUE SUM = 0.5*SUM - SUM0 ZAV = 0.25*ZAV ELSE JJ = 1 JAY(1) = MF 20 CONTINUE SUM = 0.0 U = 0.0 UT = 0.0 ZAV = 0.0 ZAVJ = 0.0 MF1 = JAY(JJ) WSAV = EEE*WS(MF1) - QS(MF1) IF (WSAV.GT.0.0) THEN RTSAV = SIGN(SQRT(WSAV),PS(MF1)) ELSE RTSAV = 0.0 END IF DO 30 J=MF1+1,ML WW = EEE*WS(J) - QS(J) IF (WW.GT.0.0) THEN IF (J.GT.80) IB = J U = U + DS(J-1) UT = UT + DELT(J-1) RT = SIGN(SQRT(WW),PS(J)) ELSE RT = 0.0 IF (U.EQ.0.0 .AND. RTSAV.EQ.0.0 .AND. IA.LE.19) 1 IA = IA + 1 END IF IF (WW.EQ.0.0 .OR. WSAV.EQ.0.0 .OR. 1 WW.EQ.SIGN(WW,WSAV)) THEN V = RT + RTSAV ELSE V = (WW*RT+WSAV*RTSAV)/ABS(WW-WSAV) END IF WSAV = WW RTSAV = RT PSUM = DS(J-1)*V SUM = SUM + PSUM IF (U.GT.0.0) ZAV = ZAV + DELT(J-1)*V*ABS(PS(J)+PS(J-1)) IF (U.NE.0.0) THEN IF (ZAVJ.EQ.0.0) JSAV = J ZAVJ = 0.25*ZAV/UT IF (J.EQ.JSAV) ZAVSAV = ZAVJ IF (2.0*ZAVJ.LT.ZAVSAV .OR. ZAVJ.GT.2.0*ZAVSAV) THEN JJ = JJ + 1 JAY(JJ) = J ZEE(JJ) = 0.5*(ZAVJ+ZAVSAV) GO TO 40 END IF END IF 30 CONTINUE 40 CONTINUE IF (J.GT.ML) THEN JJ = JJ + 1 JAY(JJ) = ML ZEE(JJ) = 0.5*(ZAVJ+ZAVSAV) END IF IF (J.LT.ML) GO TO 20 SUM = 0.5*SUM ZAV = 0.25*ZAV END IF IB = IB + 1 RETURN END SUBROUTINE EXTRAP(T,TT,EIG,VALUE,DERIV,IFLAG) INTEGER IFLAG DOUBLE PRECISION T,TT,EIG,VALUE,DERIV C ********** C C This subroutine is called from ALFBET in determining boundary C values at a singular endpoint of the interval for a C Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. C C EXTRAP, which in turn calls INTPOL, extrapolates the function C C arctan(1.0/sqrt(-p*(eig*w-q))) C C from its values for T within (-1,1) to an endpoint. C C Subprograms called C C user-supplied ..... p,q,w C C sleign2-supplied .. dxdt,intpol C C ********** C .. Scalars in Common .. DOUBLE PRECISION Z C .. C .. Local Scalars .. INTEGER KGOOD DOUBLE PRECISION ANS,CTN,ERROR,PROD,PX,QX,WX,T1,TEMP,X C .. C .. Local Arrays .. DOUBLE PRECISION FN1(5),XN(5) C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. External Subroutines .. EXTERNAL DXDT,INTPOL C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,SQRT,TAN C .. C .. Common blocks .. COMMON /ZEE/Z C .. IFLAG = 1 KGOOD = 0 T1 = TT 10 CONTINUE CALL DXDT(T1,TEMP,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z PROD = -PX*(EIG*WX-QX) IF (PROD.LE.0.0) THEN T1 = 0.5*(T1+T) IF ((1.0+(T1-T)**2).GT.1.0) GO TO 10 IF (PROD.GT.-1.0E-6) VALUE = 2.0*ATAN(1.0) IFLAG = 5 WRITE(21,*) ' In EXTRAP, iflag = 5' RETURN ELSE KGOOD = KGOOD + 1 XN(KGOOD) = T1 FN1(KGOOD) = ATAN(1.0/SQRT(PROD)) T1 = 0.5*(T+T1) IF (KGOOD.LT.5) GO TO 10 END IF T1 = 0.01 CALL INTPOL(5,XN,FN1,T,T1,3,ANS,ERROR) VALUE = ABS(ANS) CTN = 1.0/TAN(VALUE) DERIV = 0.5*PX*WX/CTN/(1.0+CTN**2) TT = XN(1) RETURN END SUBROUTINE F(U,Y,YP) DOUBLE PRECISION U DOUBLE PRECISION Y(2),YP(3) C ********** C C This subroutine evaluates the derivative functions for use with C integrator GERK in solving a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. C C Subprograms called C C user-supplied ..... p,q,w C C sleign2-supplied .. dxdt C C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EIG,Z C .. C .. Local Scalars .. DOUBLE PRECISION C,C2,DT,QX,WX,S,S2,T,TH,V,WW,X,XP C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. External Subroutines .. EXTERNAL DXDT C .. C .. Intrinsic Functions .. INTRINSIC COS,MOD,SIN C .. C .. Common blocks .. COMMON /DATAF/EIG,IND COMMON /ZEE/Z C .. IF (MOD(IND,2).EQ.1) THEN T = U TH = Y(1) ELSE T = Y(1) TH = U END IF CALL DXDT(T,DT,X) XP = Z/P(X) QX = Q(X)/Z WX = W(X)/Z V = EIG*WX - QX S = SIN(TH) C = COS(TH) S2 = S*S C2 = C*C YP(1) = DT*(XP*C2+V*S2) IF (IND.EQ.1) THEN WW = (XP-V)*S*C YP(2) = DT*(-2.0*WW*Y(2)+WX*S2) YP(3) = DT*WW ELSE IF (IND.EQ.2) THEN YP(2) = YP(2)/YP(1) YP(3) = YP(3)/YP(1) YP(1) = 1.0/YP(1) ELSE IF (IND.EQ.3) THEN ELSE YP(1) = 1.0/YP(1) END IF RETURN END DOUBLE PRECISION FUNCTION FF(ALFLAM) DOUBLE PRECISION ALFLAM C ********** C ********** C .. Scalars in Common .. INTEGER IND,INDD DOUBLE PRECISION CC,EIGSAV,HPI,PI,THETU,THETV,TWOPI, 1 UL,UR,VL,VR,UB,VB,Z C .. C .. Local Scalars .. INTEGER LFLAG LOGICAL AOK,BOK,LCIRCA,LCIRCB,OSCA,OSCB,SINGA,SINGB DOUBLE PRECISION AA,BB,DTHDAA,DTHDBB,DTHDEA,DTHDEB,DUM,EPS,LAMBDA, 1 PVPB,PVPL,PVPR,RHOB,RHOL,RHOR,THA,THB,THL,THR,TMID, 1 EPSMIN C .. C .. Local Arrays .. DOUBLE PRECISION ERR(3),Y(3) C .. C .. External Subroutines .. EXTERNAL INTEG C .. C .. Intrinsic Functions .. INTRINSIC COS,EXP,SIN C .. C .. Common blocks .. COMMON /EPP2/CC,UL,UR,VL,VR,UB,VB,IND COMMON /DATAF/EIGSAV,INDD COMMON /ZEE/Z COMMON /PIE/PI,TWOPI,HPI COMMON /THET/THETU,THETV COMMON /RNDOFF/EPSMIN C .. C C (THIS ROUTINE IS BEING MODIFIED FOR PERIODIC PROBLEMS WHICH C ARE NOT NECESSARILY REGULAR, BUT IS NOT YET COMPLETE.) C AOK = .TRUE. LCIRCA = .FALSE. SINGA = .FALSE. OSCA = .FALSE. BOK = .TRUE. LCIRCB = .FALSE. SINGB = .FALSE. OSCB = .FALSE. C AA = -1.0 BB = 1.0 C C SET TMID SO THAT IT IS NOT IN THE EXACT MIDDLE. C TMID = 0.1*PI C INDD = 1 LAMBDA = ALFLAM EIGSAV = LAMBDA EPS = EPSMIN C IF (IND.GE.2) GO TO 10 C 50 CONTINUE C C FOR U: C THA = HPI Y(1) = THA Y(2) = 1.0 Y(3) = 0.0 DTHDAA = 0.0 DTHDEA = 1.0 LFLAG = 1 CALL INTEG(AA,THA,DTHDAA,DTHDEA,TMID,DUM,DUM,EPS,Y,ERR, 1 LCIRCA,AOK,SINGA,OSCA,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 50 END IF RHOL = EXP(Y(3)) THL = Y(1) UL = RHOL*SIN(THL) C THB = HPI Y(1) = THB Y(2) = 1.0 Y(3) = 0.0 DTHDBB = 0.0 DTHDEB = 1.0 LFLAG = 1 CALL INTEG(BB,THB,DTHDBB,DTHDEB,TMID,DUM,DUM,EPS,Y,ERR, 1 LCIRCB,BOK,SINGB,OSCB,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 50 END IF RHOR = EXP(Y(3)) THR = Y(1) UR = RHOR*SIN(THR) C C FOR V: C THA = 0.0 Y(1) = THA Y(2) = 1.0 Y(3) = 0.0 DTHDAA = 0.0 DTHDEA = 1.0 LFLAG = 1 CALL INTEG(AA,THA,DTHDAA,DTHDEA,TMID,DUM,DUM,EPS,Y,ERR, 1 LCIRCA,AOK,SINGA,OSCA,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 50 END IF RHOL = EXP(Y(3)) THL = Y(1) VL = RHOL*SIN(THL) PVPL = Z*RHOL*COS(THL) C THB = 0.0 Y(1) = THB Y(2) = 1.0 Y(3) = 0.0 DTHDBB = 0.0 DTHDEB = 1.0 LFLAG = 1 CALL INTEG(BB,THB,DTHDBB,DTHDEB,TMID,DUM,DUM,EPS,Y,ERR, 1 LCIRCB,BOK,SINGB,OSCB,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 50 END IF RHOR = EXP(Y(3)) THR = Y(1) VR = RHOR*SIN(THR) PVPR = Z*RHOR*COS(THR) FF = (VR*(UL*PVPL-1.0)-CC*VL*(UR*PVPR-1.0))*(VL-VR/CC) - 1 VL*VR*(UL-CC*UR)*(PVPL-PVPR/CC) RETURN C 10 CONTINUE C C FOR U: C THA = HPI Y(1) = THA Y(2) = 1.0 Y(3) = 0.0 DTHDAA = 0.0 DTHDEA = 1.0 LFLAG = 1 CALL INTEG(AA,THA,DTHDAA,DTHDEA,BB,DUM,DUM,EPS,Y,ERR, 1 LCIRCA,AOK,SINGA,OSCA,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 10 END IF RHOB = EXP(Y(3)) THB = Y(1) THETU = THB UB = RHOB*SIN(THB) C C FOR V: C THA = 0.0 Y(1) = THA Y(2) = 1.0 Y(3) = 0.0 DTHDAA = 0.0 DTHDEA = 1.0 LFLAG = 1 CALL INTEG(AA,THA,DTHDAA,DTHDEA,BB,DUM,DUM,EPS,Y,ERR, 1 LCIRCA,AOK,SINGA,OSCA,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 10 END IF RHOB = EXP(Y(3)) THB = Y(1) THETV = THB VB = RHOB*SIN(THB) PVPB = Z*RHOB*COS(THB) FF = CC*PVPB + UB/CC - 2.0 RETURN END SUBROUTINE FIT(TH1,TH,TH2) DOUBLE PRECISION TH1,TH,TH2 C ********** C C This program converts TH into an 'equivalent' angle between C TH1 and TH2. We assume TH1.LT.TH2 and PI.LE.(TH2-TH1). C C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Intrinsic Functions .. INTRINSIC AINT C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. IF (TH.LT.TH1) TH = TH + AINT((TH1-TH+PI)/PI)*PI IF (TH.GT.TH2) TH = TH - AINT((TH-TH2+PI)/PI)*PI RETURN END SUBROUTINE FZ(UU,Y,YP) DOUBLE PRECISION UU DOUBLE PRECISION Y(2),YP(3) C ********** C C This subroutine evaluates the derivative of the function PHI C in the regularization at a singular endpoint. C C Here, HU means -(PUP)' + QU. C C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EIG C .. C .. Local Scalars .. DOUBLE PRECISION AU,AV,A1122,A12,A21,B1122,B12,B21,C,C2,D,DT, 1 HU,HV,PHI,PUP,PVP,S,SC,S2,T,U,V,WW,WX,X C .. C .. External Functions .. DOUBLE PRECISION W EXTERNAL W C .. C .. External Subroutines .. EXTERNAL DXDT,UV C .. C .. Intrinsic Functions .. INTRINSIC COS,MOD,SIN C .. C .. Common blocks .. COMMON /DATAF/EIG,IND C .. IF (MOD(IND,2).EQ.1) THEN T = UU PHI = Y(1) ELSE T = Y(1) PHI = UU END IF CALL DXDT(T,DT,X) CALL UV(X,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP WX = W(X) S = SIN(PHI) C = COS(PHI) S2 = S*S C2 = C*C SC = S*C B1122 = WX*U*V B12 = WX*V*V B21 = -WX*U*U AU = EIG*WX*U - HU AV = EIG*WX*V - HV A1122 = U*AV + V*AU A12 = V*AV A21 = -U*AU YP(1) = -DT*(A1122*SC+A12*S2-A21*C2)/D IF (IND.EQ.1) THEN WW = 2.0*(A12+A21)*SC + A1122*(C2-S2) YP(2) = -DT*(WW*Y(2)+2.0*B1122*SC+B12*S2-B21*C2)/D YP(3) = 0.5*DT*WW/D ELSE IF (IND.EQ.2) THEN YP(2) = YP(2)/YP(1) YP(3) = YP(3)/YP(1) YP(1) = 1.0/YP(1) ELSE IF (IND.EQ.3) THEN ELSE YP(1) = 1.0/YP(1) END IF RETURN END SUBROUTINE GERKZ(F,NEQ,Y,TIN,TOUT,REPS,AEPS,LFLAG,ER,WORK,IWORK) INTEGER NEQ,LFLAG INTEGER IWORK(5) DOUBLE PRECISION TIN,TOUT,REPS,AEPS DOUBLE PRECISION Y(3),ER(3),WORK(27) EXTERNAL F C ********** C ********** C .. Scalars in Common .. DOUBLE PRECISION EPSMIN,Z C .. C .. Local Scalars .. INTEGER I,J,K,L,LLFLAG DOUBLE PRECISION T,TOUTS C .. C .. Arrays in Common .. INTEGER JAY(100) DOUBLE PRECISION TEE(100),ZEE(100) C .. C .. Local Arrays .. DOUBLE PRECISION U(3) C .. C .. External Subroutines .. EXTERNAL GERK,THTOTHZ,THZTOTH C .. C .. Intrinsic Functions INTRINSIC MAX,MIN C .. C .. Common blocks .. COMMON /RNDOFF/EPSMIN COMMON /ZEE/Z COMMON /TEEZ/TEE COMMON /ZEEZ/JAY,ZEE C .. T = TIN IF (TIN.LT.TOUT) THEN DO 10 I=1,19 IF (TEE(I)-EPSMIN.LE.TIN .AND. TIN.LT.TEE(I+1)+EPSMIN) J = I IF (TEE(I)-EPSMIN.LT.TOUT.AND.TOUT.LE.TEE(I+1)+EPSMIN) L = I 10 CONTINUE DO 30 K=J,L TOUTS = MIN(TOUT,TEE(K+1)) Z = ZEE(K+1) IF (Z.EQ.0.0) Z = 1.0 CALL THTOTHZ(Y,Z,U) LLFLAG = 1 20 CONTINUE CALL GERK(F,NEQ,U,T,TOUTS,REPS,AEPS,LLFLAG,ER,WORK,IWORK) IF (LLFLAG.GT.3) THEN WRITE(21,*) ' llflag = ',LLFLAG LFLAG = 5 RETURN END IF IF (LLFLAG.EQ.3 .OR. LLFLAG.EQ.-2) GO TO 20 CALL THZTOTH(U,Z,Y) 30 CONTINUE ELSE DO 40 I=20,2,-1 IF (TEE(I-1)-EPSMIN.LT.TIN .AND. TIN.LE.TEE(I)+EPSMIN) J = I IF (TEE(I-1)-EPSMIN.LE.TOUT.AND.TOUT.LT.TEE(I)+EPSMIN) L = I 40 CONTINUE DO 60 K=J,L,-1 TOUTS = MAX(TOUT,TEE(K-1)) Z = ZEE(K) IF (Z.EQ.0.0) Z = 1.0 CALL THTOTHZ(Y,Z,U) LLFLAG = 1 50 CONTINUE CALL GERK(F,NEQ,U,T,TOUTS,REPS,AEPS,LLFLAG,ER,WORK,IWORK) IF (LLFLAG.GT.3) THEN WRITE(21,*) ' llflag = ',LLFLAG LFLAG = 5 RETURN END IF IF (LLFLAG.EQ.3 .OR. LLFLAG.EQ.-2) GO TO 50 CALL THZTOTH(U,Z,Y) 60 CONTINUE END IF TIN = T LFLAG = LLFLAG RETURN END SUBROUTINE INTEG(TEND,THEND,DTHDAA,DTHDE,TMID,COEF1,COEF2, 1 EPS,Y,ER,LCIRC,OK,SING,OSC,IFLAG) INTEGER IFLAG LOGICAL LCIRC,OK,SING,OSC DOUBLE PRECISION TEND,THEND,DTHDAA,DTHDE,TMID,COEF1,COEF2,EPS DOUBLE PRECISION Y(3),ER(3) CHARACTER*16 PREC C ********** C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EIG,HPI,PI,TSAVEL,TSAVER,TWOPI,Z C .. C .. Arrays in Common .. INTEGER NT(2) DOUBLE PRECISION TT(7,2),YY(7,3,2) C .. C .. Local Scalars .. INTEGER I,J,KFLAG,K2PI,LFLAG,M LOGICAL LOGIC DOUBLE PRECISION D,DDD,EFF,HU,HV,PHI,PHI0,PUP,PVP,T,TMP,U,V,XT0, 1 ZSAV,C,DTHIN,DUM,DPHIDE,DPHIDAA,FAC2,P1,PYPZ,PYPZ0, 2 Q1,RHOSQ,S,TSTAR,TINTHZ,TH0,TH,THBAR,THETA, 3 THIN,THU,THV,THU0,THV0,TIN,TOUT,W1,XSTAR,XT,YSTAR,YZ,YZ0 C .. C .. Local Arrays .. INTEGER IWORK(5) DOUBLE PRECISION ERZ(3),WORK(27),YP(3),YU(3) C .. C .. External Subroutines .. EXTERNAL DXDT,F,FZ,INTEGT,GERK,GERKZ,SETTHU,UV,UVPHI,WR C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. Intrinsic Functions .. INTRINSIC ATAN2,EXP,LOG,MIN,SIGN C .. C .. Common blocks .. COMMON /DATAF/EIG,IND COMMON /ZEE/Z COMMON /PIE/PI,TWOPI,HPI COMMON /TEMP/TT,YY,NT COMMON /TSAVE/TSAVEL,TSAVER C .. C C Note: The input values of THEND and DTHDAA are overwritten C when integrating from a limit circle endpoint. C PREC = 'DOUBLE PRECISION' IFLAG = 1 IND = 1 IF (OSC) THEN IF (.NOT.OK) THEN LOGIC = .FALSE. ELSE IF (TEND.LE.TMID) THEN LOGIC = TEND.GE.TSAVEL ELSE LOGIC = TEND.LE.TSAVER END IF C IF (LOGIC) THEN TINTHZ = TEND TH = THEND DTHIN = DTHDE Y(1) = TH Y(2) = DTHIN EFF = Y(3) ELSE C DO (INTEGRATE-FOR-PHI-OSC) ZSAV = Z Z = 1.0 T = TEND PHI0 = ATAN2(COEF2,COEF1) IF (TMID.GT.TEND) THEN J = 1 ELSE J = 2 END IF C C We want -PI/2 .lt. PHI0 .le. PI/2. C IF (COEF1.LT.0.0) PHI0 = PHI0 - SIGN(PI,COEF2) Y(1) = PHI0 Y(2) = 0.0 Y(3) = 0.0 CALL DXDT(T,TMP,XT0) CALL FZ(T,Y,YP) DPHIDAA = -YP(1) CALL UV(XT0,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP C C Set THU0 and THV0. C THU0 = ATAN2(U,PUP) IF (U.LT.0.0) THU0 = THU0 + TWOPI CALL SETTHU(XT0,THU0) THV0 = ATAN2(V,PVP) IF (V.LT.0.0) THV0 = THV0 + TWOPI 10 CONTINUE IF (THV0.LT.THU0) THEN THV0 = THV0 + TWOPI GO TO 10 END IF C C Set TH0 and copy into THEND, overwriting its input value. C Also, redefine DTHDAA, overwriting its input value. C CALL UVPHI(U,PUP,V,PVP,THU0,THV0,PHI0,TH0) THEND = TH0 C = COS(PHI0) S = SIN(PHI0) YZ0 = U*C + V*S PYPZ0 = PUP*C + PVP*S DUM = ABS(COS(TH0)) IF (DUM.GE.0.5) THEN FAC2 = -D*(DUM/PYPZ0)**2 ELSE FAC2 = -D*(SIN(TH0)/YZ0)**2 END IF DTHDAA = DPHIDAA*FAC2 TOUT = TMID I = 2 TT(I,J) = T YY(I,1,J) = Y(1) YY(I,2,J) = Y(2) YY(I,3,J) = Y(3) KFLAG = -1 C C TSAVEL, TSAVER presumed set by an earlier call with EIG .ne. 0. C IF (EIG.EQ.0.0) THEN IF (T.LE.TSAVEL) TOUT = TSAVEL IF (T.GT.TSAVER) TOUT = TSAVER KFLAG = 1 END IF 20 CONTINUE CALL GERK(FZ,3,Y,T,TOUT,EPS,EPS,KFLAG,ER,WORK,IWORK) IF (KFLAG.GT.3) THEN WRITE(*,*) ' KFLAG1 = 5 ' IFLAG = 5 RETURN END IF IF (KFLAG.EQ.3) GO TO 20 IF (Y(3).LT.-15.0) Y(3) = -15.0 PHI = Y(1) C C Store up to seven values of (T,PHI) for later reference. C I = I + 1 IF (I.LE.7) THEN TT(I,J) = T YY(I,1,J) = PHI YY(I,2,J) = Y(2) YY(I,3,J) = Y(3) END IF IF (10.0*ABS(PHI-PHI0).GE.PI) GO TO 30 IF (KFLAG.EQ.-2) GO TO 20 30 CONTINUE IF (T.LE.TOUT) THEN TSAVEL = T ELSE TSAVER = T END IF NT(J) = I DPHIDE = Y(2) TINTHZ = T CALL DXDT(T,TMP,XT) CALL UV(XT,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP C C Set THU and THV. C THU = ATAN2(U,PUP) IF (U.LT.0.0) THU = THU + TWOPI CALL SETTHU(XT,THU) THV = ATAN2(V,PVP) IF (V.LT.0.0) THV = THV + TWOPI 40 CONTINUE IF (THV.LT.THU) THEN THV = THV + TWOPI GO TO 40 END IF C C Now define TH in terms of PHI, THU, and THV. C CALL UVPHI(U,PUP,V,PVP,THU,THV,PHI,TH) YZ = U*COS(PHI) + V*SIN(PHI) PYPZ = PUP*COS(PHI) + PVP*SIN(PHI) Y(1) = TH S = SIN(TH) C = COS(TH) DUM = ABS(C) IF (DUM.GE.0.5) THEN FAC2 = -D*(DUM/PYPZ)**2 ELSE FAC2 = -D*(S/YZ)**2 END IF DTHIN = FAC2*DPHIDE Y(2) = DTHIN Z = ZSAV RHOSQ = EXP(2.0*Y(3))*(YZ**2+PYPZ**2) EFF = 0.5*LOG(RHOSQ*(S**2+(C/Z)**2)) Y(3) = EFF C END (INTEGRATE-FOR-PHI-OSC) END IF IF (TINTHZ.NE.TMID) THEN TIN = TINTHZ TOUT = TMID THIN = TH C DO (INTEGRATE-FOR-THETAZ) C C The following block of code replaces what was used for C non-limit-circle problems, with a few changes. C T = TIN Y(1) = THIN Y(2) = DTHIN Y(3) = 0.0 50 CONTINUE CALL GERKZ(F,3,Y,T,TOUT,EPS,EPS,LFLAG,ERZ,WORK,IWORK) IF (LFLAG.GT.3) THEN WRITE(21,*) ' LFLAGZ = ',LFLAG IFLAG = 5 RETURN END IF IF (LFLAG.EQ.3 .OR. LFLAG.EQ.-2) GO TO 50 C END (INTEGRATE-FOR-THETAZ) Y(3) = Y(3) + EFF Z = 1.0 END IF ELSE IF (LCIRC) THEN C DO (INTEGRATE-FOR-PHI-NONOSC) T = TEND IF (COEF1.LT.0.0) THEN COEF1 = -COEF1 COEF2 = -COEF2 END IF PHI0 = ATAN2(COEF2,COEF1) C C We want -PI/2 .lt. PHI0 .le. PI/2. C Y(1) = PHI0 Y(2) = 0.0 Y(3) = 0.0 CALL DXDT(T,TMP,XT) CALL FZ(T,Y,YP) DPHIDAA = -YP(1) CALL UV(XT,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP YZ0 = U*COEF1 + V*COEF2 PYPZ0 = (PUP*COEF1+PVP*COEF2)/Z C C Set TH0 and copy into THEND, overwriting its input value. C Also, redefine DTHDAA, overwriting its input value. C TH0 = ATAN2(YZ0,PYPZ0) IF (YZ0.LT.0.0) TH0 = TH0 + TWOPI THEND = TH0 DUM = ABS(COS(TH0)) IF (DUM.GE.0.5) THEN FAC2 = (-D/Z)*(DUM/PYPZ0)**2 ELSE FAC2 = (-D/Z)*(SIN(TH0)/YZ0)**2 END IF DTHDAA = FAC2*DPHIDAA C C In the next piece, we assume TH0 .ge. 0. C M = 0 IF (TH0.EQ.0.0) M = -1 IF (TH0.GT.PI .OR. (TH0.EQ.PI. AND. T.LT.TMID)) M = 1 PHI = PHI0 K2PI = 0 YZ0 = U*COS(PHI0) + V*SIN(PHI0) IF (TMID.GT.TEND) THEN J = 1 TSTAR = -0.99999 IF (PREC(1:1).NE.'R') TSTAR = -0.9999999999D0 ELSE J = 2 TSTAR = 0.99999 IF (PREC(1:1).NE.'R') TSTAR = 0.9999999999D0 END IF DPHIDE = 0.0 CALL WR(FZ,EPS,TSTAR,PHI0,PHI0,DPHIDE,TOUT,Y, 1 TT(1,J),YY(1,1,J),ERZ,WORK,IWORK) T = TOUT DDD = MIN(0.01,ABS(TMID-TOUT)) TOUT = TOUT + DDD*(TMID-TOUT)/ABS(TMID-TOUT) KFLAG = 1 CALL GERK(FZ,3,Y,T,TOUT,EPS,EPS,KFLAG,ER,WORK,IWORK) TT(7,J) = T YY(7,1,J) = Y(1) YY(7,2,J) = Y(2) YY(7,3,J) = Y(3) 60 CONTINUE T = TOUT CALL DXDT(T,TMP,XT) CALL UV(XT,U,PUP,V,PVP,HU,HV) PHI = Y(1) S = SIN(PHI) C = COS(PHI) YZ = U*C + V*S IF (YZ*YZ0 .LT. 0.0) K2PI = K2PI + 1 YZ0 = YZ IF (KFLAG.GT.3) THEN WRITE(*,*) ' KFLAG2 = ',KFLAG IFLAG = 5 RETURN END IF IF (KFLAG.EQ.3 .OR. KFLAG.EQ.-2) GO TO 60 C C Convert from PHI to THETA. C DPHIDE = Y(2) D = U*PVP-V*PUP PYPZ = (PUP*C+PVP*S)/Z THBAR = ATAN2(YZ,PYPZ) IF (TMID.GT.TEND .AND. THBAR.LT.TH0 .AND. PHI.LT.PHI0) 1 THBAR = THBAR + TWOPI IF (TMID.LT.TEND .AND. THBAR.GT.TH0 .AND. PHI.GT.PHI0) 1 THBAR = THBAR - TWOPI TH = THBAR - M*PI IF (TH.LT.-PI) TH = TH + TWOPI IF (TH.GT.TWOPI) TH = TH - TWOPI IF (TMID.LT.TEND .AND. K2PI.GT.1) TH = TH - (K2PI-1)*TWOPI IF (TMID.GT.TEND .AND. K2PI.GT.1) TH = TH + (K2PI-1)*TWOPI IF (TMID.GT.TEND .AND. TH*TH0.LT.0.0) TH = TH + TWOPI C C We now have YZ, PYPZ, PHI and TH. C DUM = ABS(COS(TH)) IF (DUM.GE.0.5) THEN FAC2 = -(D/Z)*(DUM/PYPZ)**2 ELSE FAC2 = -(D/Z)*(SIN(TH)/YZ)**2 END IF DTHIN = FAC2*DPHIDE THETA = ATAN2(YZ,Z*PYPZ) S = SIN(THETA) C = COS(THETA) RHOSQ = EXP(2.0*Y(3))*(YZ**2+(Z*PYPZ)**2) EFF = 0.5*LOG(RHOSQ*(S**2+(C/Z)**2)) C END (INTEGRATE-FOR-PHI-NONOSC) TIN = TOUT TOUT = TMID THIN = TH C DO (INTEGRATE-FOR-THETA) CALL INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C END (INTEGRATE-FOR-THETA) Y(3) = Y(3) + EFF ELSE IF (.NOT.OK .AND. .NOT.SING) THEN C C This is the 'weakly regular' case. C IF (TMID.GT.TEND) THEN J = 1 TSTAR = -0.99999 IF (PREC(1:1).NE.'R') TSTAR = -0.9999999999D0 ELSE J = 2 TSTAR = 0.99999 IF (PREC(1:1).NE.'R') TSTAR = 0.9999999999D0 END IF CALL DXDT(TSTAR,TMP,XSTAR) P1 = 1.0/P(XSTAR) Q1 = Q(XSTAR) W1 = W(XSTAR) YSTAR = THEND + 0.5*(TSTAR-TEND)* 1 (P1*COS(THEND)**2+(EIG*W1-Q1)*SIN(THEND)**2) CALL WR(F,EPS,TSTAR,YSTAR,THEND,DTHDE,TOUT,YU, 1 TT(1,J),YY(1,1,J),ERZ,WORK,IWORK) T = TOUT DDD = MIN(0.01,ABS(TMID-TOUT)) TOUT = TOUT + DDD*(TMID-TOUT)/ABS(TMID-TOUT) KFLAG = 1 CALL GERK(F,3,YU,T,TOUT,EPS,EPS,KFLAG,ER,WORK,IWORK) TT(7,J) = T YY(7,1,J) = YU(1) YY(7,2,J) = YU(2) YY(7,3,J) = YU(3) TIN = TOUT TOUT = TMID THIN = YU(1) DTHIN = YU(2) C DO (INTEGRATE-FOR-THETA) CALL INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C END (INTEGRATE-FOR-THETA) ELSE C C This is the regular (not weakly regular) or limit point case. C TIN = TEND TOUT = TMID THIN = THEND DTHIN = DTHDE C DO (INTEGRATE-FOR-THETA) CALL INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C END (INTEGRATE-FOR-THETA) END IF RETURN END SUBROUTINE INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) INTEGER IFLAG,IWORK(5) DOUBLE PRECISION TIN,TOUT,THIN,DTHIN,EPS DOUBLE PRECISION Y(3),ER(3),WORK(27) C ********** C C Integrate for theta. C C ********** C .. Local Scalars .. INTEGER LFLAG DOUBLE PRECISION T C .. C .. External Subroutines .. EXTERNAL F C .. C DO (INTEGRATE-FOR-TH) T = TIN Y(1) = THIN Y(2) = DTHIN Y(3) = 0.0 LFLAG = 1 10 CONTINUE CALL GERK(F,3,Y,T,TOUT,EPS,EPS,LFLAG,ER,WORK,IWORK) IF (LFLAG.EQ.3) GO TO 10 IF (LFLAG.GT.3) THEN WRITE(21,*) ' LFLAG = ',LFLAG IFLAG = 5 RETURN END IF THIN = Y(1) DTHIN = Y(2) C END (INTEGRATE-FOR-TH) RETURN END SUBROUTINE INTPOL(N,XN,FN,X,ABSERR,MAXDEG,ANS,ERROR) INTEGER N,MAXDEG DOUBLE PRECISION X,ABSERR,ANS,ERROR DOUBLE PRECISION XN(N),FN(N) C ********** C C This subroutine forms an interpolating polynomial for data pairs. C It is called from EXTRAP in solving a Sturm-Liouville problem. C C ********** C .. Local Scalars .. INTEGER I,I1,II,IJ,IK,IKM1,J,K,L,LIMIT DOUBLE PRECISION PROD C .. C .. Local Arrays .. INTEGER INDEX(10) DOUBLE PRECISION V(10,10) C .. C .. Intrinsic Functions .. INTRINSIC ABS,MIN C .. L = MIN(MAXDEG,N-2) + 2 LIMIT = MIN(L,N-1) DO 10 I = 1,N V(I,1) = ABS(XN(I)-X) INDEX(I) = I 10 CONTINUE DO 30 I=1,LIMIT DO 20 J=I+1,N II = INDEX(I) IJ = INDEX(J) IF (V(II,1).GT.V(IJ,1)) THEN INDEX(I) = IJ INDEX(J) = II END IF 20 CONTINUE 30 CONTINUE PROD = 1.0 I1 = INDEX(1) ANS = FN(I1) V(1,1) = FN(I1) DO 50 K=2,L IK = INDEX(K) V(K,1) = FN(IK) DO 40 I=1,K-1 II = INDEX(I) V(K,I+1) = (V(I,I)-V(K,I))/(XN(II)-XN(IK)) 40 CONTINUE IKM1 = INDEX(K-1) PROD = (X-XN(IKM1))*PROD ERROR = PROD*V(K,K) IF(ABS(ERROR).LE.ABSERR) RETURN ANS = ANS + ERROR 50 CONTINUE ANS = ANS - ERROR RETURN END SUBROUTINE LPOL(KEIGS,XN,FN,X,F) INTEGER KEIGS DOUBLE PRECISION X,F DOUBLE PRECISION XN(KEIGS),FN(KEIGS) C ********** C ********** C .. C .. Local variables .. DOUBLE PRECISION X12,X13,X14,X15,X21,X23,X24,X25,X31,X32,X34,X35, 1 X41,X42,X43,X45,X51,X52,X53,X54,XX1,XX2,XX3,XX4,XX5 C .. X12 = XN(1) - XN(2) X13 = XN(1) - XN(3) X23 = XN(2) - XN(3) X21 = -X12 X31 = -X13 X32 = -X23 XX1 = X - XN(1) XX2 = X - XN(2) XX3 = X - XN(3) IF (KEIGS.GE.4) THEN X14 = XN(1) - XN(4) X24 = XN(2) - XN(4) X34 = XN(3) - XN(4) X41 = -X14 X42 = -X24 X43 = -X34 XX4 = X - XN(4) END IF IF (KEIGS.EQ.5) THEN X15 = XN(1) - XN(5) X25 = XN(2) - XN(5) X35 = XN(3) - XN(5) X45 = XN(4) - XN(5) X51 = -X15 X52 = -X25 X53 = -X35 X54 = -X45 XX5 = X - XN(5) END IF IF (KEIGS.EQ.3) THEN F = XX2*XX3*FN(1)/(X12*X13) + 1 XX1*XX3*FN(2)/(X21*X23) + 2 XX1*XX2*FN(3)/(X31*X32) ELSE IF (KEIGS.EQ.4) THEN F = XX2*XX3*XX4*FN(1)/(X12*X13*X14) + 1 XX1*XX3*XX4*FN(2)/(X21*X23*X24) + 2 XX1*XX2*XX4*FN(3)/(X31*X32*X34) + 3 XX1*XX2*XX3*FN(4)/(X41*X42*X43) ELSE F = XX2*XX3*XX4*XX5*FN(1)/(X12*X13*X14*X15) + 1 XX1*XX3*XX4*XX5*FN(2)/(X21*X23*X24*X25) + 2 XX1*XX2*XX4*XX5*FN(3)/(X31*X32*X34*X35) + 3 XX1*XX2*XX3*XX5*FN(4)/(X41*X42*X43*X45) + 4 XX1*XX2*XX3*XX4*FN(5)/(X51*X52*X53*X54) END IF RETURN END C SUBROUTINE PERIO(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB, 1 A1,A2,B1,B2,NUMEIG,EIG,TOL,IFLAG,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) INTEGER INTAB,NUMEIG,IFLAG DOUBLE PRECISION A,B,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2,EIG,TOL, 1 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB DOUBLE PRECISION SLFN(9) C ********** C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EPSMIN,CC,UB,UL,UR,VB,VL,VR,Z C .. C .. Local Scalars .. INTEGER JFLAG DOUBLE PRECISION A1D,A1N,A2D,A2N,B1N,B1D,B2N,B2D DOUBLE PRECISION AE,EIGLO,EIGUP,LAMBDA,LAMUP,RE,TOLL,TOLS C .. C .. External Subroutines .. EXTERNAL FZERO,SLEIGN2 C .. C .. External Functions .. EXTERNAL FF C .. C .. Intrinsic Functions .. C .. C .. Common blocks .. COMMON /EPP2/CC,UL,UR,VL,VR,UB,VB,IND COMMON /RNDOFF/EPSMIN COMMON /ZEE/Z C .. C C Get upper and lower bounds as accurately as possible. C TOLL = 0.0 TOLS = TOL C A1N = 0.0 A2N = 1.0 B1N = 0.0 B2N = 1.0 TOL = TOLL EIG = 0.0 CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1N,A2N, 1 B1N,B2N,NUMEIG,EIG,TOL,IFLAG,0,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) WRITE(*,*) ' eiglo,iflag = ',EIG,IFLAG EIGLO = EIG - 0.1 C A1D = 1.0 A2D = 0.0 B1D = 1.0 B2D = 0.0 TOL = TOLL EIG = 0.0 CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1D,A2D, 1 B1D,B2D,NUMEIG,EIG,TOL,IFLAG,0,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) WRITE(*,*) ' eigup,iflag = ',EIG,IFLAG EIGUP = EIG + 0.1 LAMBDA = 0.5*(EIGLO+EIGUP) C C The following call to SLEIGN2 sets the stage for INTEG. C TOL = .001 CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,NUMEIG,LAMBDA,TOL,IFLAG,-1,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) Z = 1.0 C EIG = EIGLO LAMUP = EIGUP RE = TOLS AE = RE C C IND = 2 selects the classical function d(LAMBDA) in function FF. C IND = 2 CALL FZERO(FF,EIG,LAMUP,LAMBDA,RE,AE,JFLAG) IF (JFLAG.NE.1) WRITE(*,*) ' jflag = ',JFLAG IFLAG = JFLAG TOL = ABS(EIG-LAMUP)/MAX(1.0,ABS(EIG)) WRITE(*,*) ' EIGLO,EIGUP = ',EIGLO,EIGUP C RETURN END SUBROUTINE SETMID(MF,ML,EIG,QS,WS,IMID,TMID) INTEGER MF,ML,IMID DOUBLE PRECISION EIG,QS(*),WS(*),TMID C ********** C C This procedures tests the interval sample points in the order C 50,51,49,52,48,...,etc. for the first one where the expression C (lambda*w-q) is positive. This point is designated TMID. C C ********** C .. Local Scalars .. INTEGER I,J DOUBLE PRECISION S C .. C .. External Functions .. DOUBLE PRECISION TFROMI EXTERNAL TFROMI C .. S = -1.0 DO 10 J=1,100 I = 50 + S*(J/2) S = -S IF (I.LT.MF .OR. I.GT.ML) GO TO 20 IF (EIG*WS(I)-QS(I).GT.0.0) THEN IMID = I TMID = TFROMI(IMID) GO TO 20 END IF 10 CONTINUE 20 CONTINUE WRITE(*,*) ' new tmid = ',TMID RETURN END SUBROUTINE SETTHU(X,THU) DOUBLE PRECISION X,THU C ********** c c This subroutine establishes a definite value for THU, c the phase angle for the function U, including an c appropriate integer multiple of pi c It needs the numbers MMW(*) found in THUM c C ********** C .. Scalars in Common .. INTEGER MMWD DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Arrays in Common .. INTEGER MMW(98) DOUBLE PRECISION YS(197) C .. C .. Local Scalars .. INTEGER I C .. C .. Common blocks .. COMMON /PASS/YS,MMW,MMWD COMMON /PIE/PI,TWOPI,HPI C .. DO 10 I=1,MMWD IF (X.GE.YS(MMW(I)) .AND. X.LE.YS(MMW(I)+1)) THEN IF (THU.GT.PI) THEN THU = THU + (I-1)*TWOPI RETURN ELSE THU = THU + I*TWOPI RETURN END IF END IF 10 CONTINUE DO 20 I=1,MMWD IF (X.GE.YS(MMW(I))) THU = THU + TWOPI 20 CONTINUE RETURN END DOUBLE PRECISION FUNCTION TFROMI(I) INTEGER I C ********** C C This function associates the value of an interval sample point C with its index. C C ********** IF (I.LT.8) THEN TFROMI = -1.0 + 0.1/4.0**(8-I) ELSE IF (I.GT.92) THEN TFROMI = 1.0 - 0.1/4.0**(I-92) ELSE TFROMI = 0.0227*(I-50) END IF RETURN END SUBROUTINE THTOTHZ(Y,Z,U) DOUBLE PRECISION Z DOUBLE PRECISION Y(3),U(3) C ********** C THIS PROGRAM CONVERTS FROM TH TO THZ WHERE C TAN(TH)=PSI/(P*PSI') C AND C TAN(THZ)=Z*PSI/(P*PSI'), C OR C TAN(THZ)=Z*TAN(TH) . C SO WE HAVE C DTHZ=Z*(COS(THZ)/COS(TH))**2 * DTH , C OR C DTH=(1/Z)*(COS(TH)/COS(THZ))**2 * DTHZ . C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Local Scalars .. INTEGER K DOUBLE PRECISION DTH,DTHZ,DUM,FAC,PIK,REMTH,TH,THZ C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,COS,LOG,SIN,TAN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. TH = Y(1) DTH = Y(2) K = TH/PI IF (TH.LT.0.0) K = K - 1 PIK = K*PI REMTH = TH - PIK IF (4.0*REMTH.LE.PI) THEN THZ = ATAN(Z*TAN(REMTH)) + PIK ELSE IF (4.0*REMTH.GE.3.0*PI) THEN THZ = ATAN(Z*TAN(REMTH)) + PIK + PI ELSE THZ = ATAN(TAN(REMTH-HPI)/Z) + PIK + HPI END IF DUM = ABS(COS(THZ)) IF (DUM.GE.0.5) THEN FAC = Z*(DUM/COS(TH))**2 ELSE FAC = (SIN(THZ)/SIN(TH))**2/Z END IF DTHZ = FAC*DTH U(1) = THZ U(2) = DTHZ U(3) = Y(3) - 0.5*LOG(Z*FAC) RETURN END SUBROUTINE THUM(MF,ML,XS) INTEGER MF,ML DOUBLE PRECISION XS(*) C ********** C C YS IS LIKE XS, BUT HAS TWICE AS MANY POINTS. C MMW(N) IS THE VALUE OF THE INDEX I OF U(I), MF .LE. I .LE. 2*ML-2, C WHERE U FOR THE Nth TIME CHANGES SIGN FROM - TO + C AND WHERE P*U' IS POSITIVE. C MMWD IS THE NUMBER OF SUCH POINTS OF U. C C ********** C .. Scalars in Common .. INTEGER MMWD C .. C .. Arrays in Common .. INTEGER MMW(98) DOUBLE PRECISION YS(197) C .. C .. Local Scalars .. INTEGER I,N DOUBLE PRECISION PUP,PUP1,U,U1,tmp C .. C .. Common blocks .. COMMON /PASS/YS,MMW,MMWD C .. DO 10 I=1,98 YS(2*I-1) = XS(I) YS(2*I) = 0.5*(XS(I)+XS(I+1)) 10 CONTINUE YS(197) = XS(99) N = 0 U1 = 0.0 PUP1 = 0.0 DO 20 I=2*MF-1,2*ML-1 CALL UV(YS(I),U,PUP,tmp,tmp,tmp,tmp) IF (U1.LT.0.0 .AND. U.GT.0.0 .AND. PUP1.GT.0.0) THEN N = N + 1 MMW(N) = I - 1 END IF U1 = U PUP1 = PUP 20 CONTINUE MMWD = N RETURN END SUBROUTINE THZTOTH(U,Z,Y) DOUBLE PRECISION Z DOUBLE PRECISION U(3),Y(3) C ********** C THIS PROGRAM CONVERTS FROM THZ TO TH WHERE C TAN(TH)=PSI/(P*PSI') C AND C TAN(THZ)=Z*PSI/(P*PSI'), C OR C TAN(THZ)=Z*TAN(TH) . C SO WE HAVE C DTHZ=Z*(COS(THZ)/COS(TH))**2 * DTH , C OR C DTH=(1/Z)*(COS(TH)/COS(THZ))**2 * DTHZ . C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Local Scalars .. INTEGER K DOUBLE PRECISION DTH,DTHZ,DUM,FAC,PIK,REMTHZ,TH,THZ C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,COS,LOG,SIN,TAN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. THZ = U(1) DTHZ = U(2) K = THZ/PI IF (THZ.LT.0.0) K = K - 1 PIK = K*PI REMTHZ = THZ - PIK IF (4.0*REMTHZ.LE.PI) THEN TH = ATAN(TAN(REMTHZ)/Z) + PIK ELSE IF (4.0*REMTHZ.GE.3.0*PI) THEN TH = ATAN(TAN(REMTHZ)/Z) + PIK + PI ELSE TH = ATAN(Z*TAN(REMTHZ-HPI)) + PIK + HPI END IF DUM = ABS(COS(TH)) IF (DUM.GE.0.5) THEN FAC = (DUM/COS(THZ))**2/Z ELSE FAC = Z*(SIN(TH)/SIN(THZ))**2 END IF DTH = FAC*DTHZ Y(1) = TH Y(2) = DTH Y(3) = U(3) + 0.5*LOG(Z/FAC) RETURN END SUBROUTINE UVPHI(U,PUP,V,PVP,THU,THV,PHI,TH) DOUBLE PRECISION U,PUP,V,PVP,THU,THV,PHI,TH C ********** C C This program finds TH appropriate to THU, THV, and PHI, where C THU is the phase angle for U, and THV is the phase angle for V. C C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Local Scalars .. DOUBLE PRECISION C,D,PYP,S,Y C .. C .. External Subroutines .. EXTERNAL FIT C .. C .. Intrinsic Functions .. INTRINSIC ATAN2,COS,SIN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. TH = THU IF (PHI.EQ.0.0) RETURN IF (THV-THU.LT.PI) THEN TH = THV IF (PHI.EQ.-HPI) RETURN TH = THV - PI IF (PHI.EQ.HPI) RETURN ELSE TH = THV - PI IF (PHI.EQ.-HPI) RETURN TH = THV - TWOPI IF (PHI.EQ.HPI) RETURN END IF C = COS(PHI) S = SIN(PHI) Y = U*C + V*S PYP = PUP*C + PVP*S TH = ATAN2(Y,PYP) IF (Y.LT.0.0) TH = TH + TWOPI D = U*PVP - V*PUP IF (D*PHI.GT.0.0) THEN CALL FIT(THU-PI,TH,THU) ELSE CALL FIT(THU,TH,THU+PI) END IF RETURN END SUBROUTINE WR(FG,EPS,TSTAR,YSTAR,THEND,DTHDE,TOUT,Y, 1 TT,YY,ERR,WORK,IWORK) INTEGER IWORK(5) DOUBLE PRECISION EPS,TSTAR,YSTAR,THEND,DTHDE,TOUT DOUBLE PRECISION Y(3),TT(7),YY(7,3),ERR(3),WORK(27) EXTERNAL FG C ********** C C This subroutine integrates Y' = F(T,Y) from t = +/-1.0 to THEND C even when F cannot be evaluated at t. (T*,Y*) is chosen as a C nearby point, and the equation is integrated from there and C checked for consistency with having integrated from t. If not, C a different (T*,Y*) is chosen until consistency is achieved. C C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EIG,EPSMIN C .. C .. Local Scalars .. INTEGER I,K,KFLAG DOUBLE PRECISION CHNG,D2F,D2G,D3F,D3G,D4F,D4G,HT,HU,OLDSS2,OLDYY2, 1 ONE,SLO,SOUT,SUMM,SUP,T,TEN5,TIN,U,UOUT,USTAR,YLO,YOUT,YUP C .. C .. Local Arrays .. DOUBLE PRECISION DF(4),DG(4),FF(6),GG(5),S(3),SS(6,3),UU(6) C .. C .. External Subroutines .. EXTERNAL GERK,LPOL C .. C .. Intrinsic Functions .. INTRINSIC ABS,SIGN C .. C .. Common blocks COMMON /DATAF/EIG,IND COMMON /RNDOFF/EPSMIN C .. ONE = 1.0 TEN5 = 100000.0 C C Integrate Y' = F(T,Y,YP). C TIN = SIGN(ONE,TSTAR) HT = TSTAR - TIN TT(1) = TIN YY(1,1) = THEND YY(1,2) = DTHDE YY(1,3) = 0.0 TT(2) = TSTAR YY(2,1) = YSTAR YY(2,2) = DTHDE YY(2,3) = 0.0 YLO = -TEN5 YUP = TEN5 C C Normally IND = 1 or 3; IND is set to 2 or 4 when Y is to be used C as the independent variable in FG(T,Y,YP), instead of the usual T. C Before leaving this subroutine, IND is reset to 1. C 10 CONTINUE T = TSTAR Y(1) = YY(2,1) Y(2) = YY(2,2) Y(3) = YY(2,3) KFLAG = 1 IND = 1 DO 30 K = 3,6 TOUT = T + HT 20 CONTINUE CALL GERK(FG,3,Y,T,TOUT,EPS,EPS,KFLAG,ERR,WORK,IWORK) IF (KFLAG.GT.3) THEN WRITE(*,*) ' KFLAG3 = 5 ' END IF IF (KFLAG.EQ.3) GO TO 20 YOUT = Y(1) TT(K) = T YY(K,1) = YOUT YY(K,2) = Y(2) YY(K,3) = Y(3) 30 CONTINUE IND = 3 DO 40 I = 2,6 CALL FG(TT(I),YY(I,1),FF(I)) 40 CONTINUE CALL LPOL(5,TT(2),FF(2),TT(1),FF(1)) IF (ABS(FF(1)).LE.500.0) THEN C C Now we want to apply some criterion to see if these results are C consistent with having integrated from (TT(1),YY(1,1). C DO 50 I = 1,4 DF(I) = FF(I+1) - FF(I) 50 CONTINUE D2F = DF(4) - DF(3) D3F = DF(4) - 2.0*DF(3) + DF(2) D4F = DF(4) - 3.0*DF(3) + 3.0*DF(2) - DF(1) SUMM = HT*(FF(5)-3.5*DF(4)+53.0*D2F/12.0 1 -55.0*D3F/24.0+251.0*D4F/720.0) C C Presumably, YY(2,1) should be YY(1,1) + SUMM. C OLDYY2 = YY(2,1) YY(2,1) = YY(1,1) + SUMM C C Also improve the value of Y(2) at TSTAR. C YY(2,2) = 0.5*(YY(1,2)+YY(3,2)) YY(2,3) = 0.5*(YY(1,3)+YY(3,3)) CHNG = YY(2,1) - OLDYY2 IF (CHNG.GE.0.0 .AND. OLDYY2.GT.YLO) YLO = OLDYY2 IF (CHNG.LE.0.0 .AND. OLDYY2.LT.YUP) YUP = OLDYY2 IF ((YY(2,1).GE.YUP .AND. YLO.GT.-TEN5) .OR. 1 (YY(2,1).LE.YLO .AND. YUP.LT.TEN5)) 2 YY(2,1) = 0.5*(YLO+YUP) IF (ABS(YY(2,1)-OLDYY2).GT.EPSMIN) GO TO 10 ELSE C C Here, Y' is assumed infinite at T = TIN. In this case, C it cannot be expected to approximate Y with a polynomial, C so the independent and dependent variables are interchanged. C The points are assumed equally spaced. C HU = (YY(6,1)-YY(1,1))/5.0 UU(1) = YY(1,1) SS(1,1) = TT(1) SS(1,2) = DTHDE SS(1,3) = 0.0 UU(2) = UU(1) + HU SS(2,1) = TSTAR SS(2,2) = DTHDE SS(2,3) = 0.0 USTAR = UU(2) SLO = -TEN5 SUP = TEN5 60 CONTINUE U = USTAR S(1) = SS(2,1) S(2) = SS(2,2) S(3) = SS(2,3) KFLAG = 1 IND = 2 DO 80 K = 3,6 UOUT = U + HU 70 CONTINUE CALL GERK(FG,3,S,U,UOUT,EPS,EPS,KFLAG,ERR, 1 WORK,IWORK) IF (KFLAG.GT.3) THEN WRITE(*,*) ' KFLAG4 = 5 ' END IF IF (KFLAG.EQ.3) GO TO 70 SOUT = S(1) UU(K) = U SS(K,1) = SOUT SS(K,2) = S(2) SS(K,3) = S(3) 80 CONTINUE IND = 4 DO 90 I = 2,5 CALL FG(UU(I),SS(I,1),GG(I)) 90 CONTINUE GG(1) = 0.0 DO 100 I = 1,4 DG(I) = GG(I+1) - GG(I) 100 CONTINUE D2G = DG(4) - DG(3) D3G = DG(4) - 2.0*DG(3) + DG(2) D4G = DG(4) - 3.0*DG(3) + 3.0*DG(2) - DG(1) SUMM = HU*(GG(5)-3.5*DG(4)+53.0*D2G/12.0 1 -55.0*D3G/24.0+251.0*D4G/720.0) C C Presumably, SS(2,1) should be SS(1,1) + SUMM. C OLDSS2 = SS(2,1) SS(2,1) = SS(1,1) + SUMM IF (SS(2,1).LE.-1.0) SS(2,1) = -1.0 + EPSMIN IF (SS(2,1).GE.1.0) SS(2,1) = 1.0 - EPSMIN C C Also improve the value of Y(2) at TSTAR. C SS(2,2) = 0.5*(SS(1,2)+SS(3,2)) SS(2,3) = 0.5*(SS(1,3)+SS(3,3)) CHNG = SS(2,1) - OLDSS2 IF (CHNG.GE.0.0 .AND. OLDSS2.GT.SLO) SLO = OLDSS2 IF (CHNG.LE.0.0 .AND. OLDSS2.LT.SUP) SUP = OLDSS2 IF ((SS(2,1).GE.SUP .AND. SLO.GT.-TEN5) .OR. 1 (SS(2,1).LE.SLO .AND. SUP.LT.TEN5)) 2 SS(2,1) = 0.5*(SLO+SUP) IF (ABS(SS(2,1)-OLDSS2).GT.EPSMIN) GO TO 60 END IF IF (IND.EQ.4) THEN DO 110 I = 1,6 TT(I) = SS(I,1) YY(I,1) = UU(I) YY(I,2) = SS(I,2) YY(I,3) = SS(I,3) 110 CONTINUE END IF TOUT = TT(6) IND = 1 RETURN END SUBROUTINE GERK(F, NEQN, Y, T, TOUT, RELERR, ABSERR, IFLAG, * GERROR, WORK, IWORK) C C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C C WRITTEN BY H.A.WATTS AND L.F.SHAMPINE C SANDIA LABORATORIES C C GERK IS DESIGNED TO SOLVE SYSTEMS OF DIFFERENTIAL EQUATIONS C WHEN IT IS IMPORTANT TO HAVE A READILY AVAILABLE GLOBAL ERROR C ESTIMATE. PARALLEL INTEGRATION IS PERFORMED TO YIELD TWO C SOLUTIONS ON DIFFERENT MESH SPACINGS AND GLOBAL EXTRAPOLATION C IS APPLIED TO PROVIDE AN ESTIMATE OF THE GLOBAL ERROR IN THE C MORE ACCURATE SOLUTION. C C FOR IBM SYSTEM 360 AND 370 AND OTHER MACHINES OF SIMILAR C ARITHMETIC CHARACTERISTICS, THIS CODE SHOULD BE CONVERTED TO C DOUBLE PRECISION. C C******************************************************************* C ABSTRACT C******************************************************************* C C SUBROUTINE GERK INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN)) C WHERE THE Y(I) ARE GIVEN AT T . C TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TOUT C BUT IT CAN BE USED AS A ONE-STEP INTEGRATOR TO ADVANCE THE C SOLUTION A SINGLE STEP IN THE DIRECTION OF TOUT. ON RETURN, AN C ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T IS PROVIDED C AND THE PARAMETERS IN THE CALL LIST ARE SET FOR CONTINUING THE C INTEGRATION. THE USER HAS ONLY TO CALL GERK AGAIN (AND PERHAPS C DEFINE A NEW VALUE FOR TOUT). ACTUALLY, GERK IS MERELY AN C INTERFACING ROUTINE WHICH ALLOCATES VIRTUAL STORAGE IN THE C ARRAYS WORK, IWORK AND CALLS SUBROUTINE GERKS FOR THE SOLUTION. C GERKS IN TURN CALLS SUBROUTINE FEHL WHICH COMPUTES AN APPROX- C IMATE SOLUTION OVER ONE STEP. C C GERK USES THE RUNGE-KUTTA-FEHLBERG (4,5) METHOD DESCRIBED C IN THE REFERENCE C E.FEHLBERG , LOW-ORDER CLASSICAL RUNGE-KUTTA FORMULAS WITH C STEPSIZE CONTROL , NASA TR R-315 C C C THE PARAMETERS REPRESENT- C F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES C YP(I)=DY(I)/DT C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT T C T -- INDEPENDENT VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED C RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR C LOCAL ERROR TEST. AT EACH STEP THE CODE REQUIRES THAT C ABS(LOCAL ERROR) .LE. RELERR*ABS(Y) + ABSERR C FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION C VECTORS. C IFLAG -- INDICATOR FOR STATUS OF INTEGRATION C GERROR(*) -- VECTOR WHICH ESTIMATES THE GLOBAL ERROR AT T. C THAT IS, GERROR(I) APPROXIMATES Y(I)-TRUE C SOLUTION(I). C WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO GERK WHICH C IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED C AT LEAST 3+8*NEQN C IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL C TO GERK WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST C BE DIMENSIONED AT LEAST 5 C C C******************************************************************* C FIRST CALL TO GERK C******************************************************************* C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE C ARRAYS IN THE CALL LIST - Y(NEQN), WORK(3+8*NEQN), IWORK(5), C DECLARE F IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE F(T,Y,YP) C AND INITIALIZE THE FOLLOWING PARAMETERS- C C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED. (NEQN .GE. 1) C Y(*) -- VECTOR OF INITIAL CONDITIONS C T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED. C T=TOUT IS ALLOWED ON THE FIRST CALL ONLY,IN WHICH CASE C GERK RETURNS WITH IFLAG=2 IF CONTINUATION IS POSSIBLE. C RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES C WHICH MUST BE NON-NEGATIVE BUT MAY BE CONSTANTS. WE CAN C USUALLY EXPECT THE GLOBAL ERRORS TO BE SOMEWHAT SMALLER C THAN THE REQUESTED LOCAL ERROR TOLERANCES. TO AVOID C LIMITING PRECISION DIFFICULTIES THE CODE ALWAYS USES C THE LARGER OF RELERR AND AN INTERNAL RELATIVE ERROR C PARAMETER WHICH IS MACHINE DEPENDENT. C IFLAG -- +1,-1 INDICATOR TO INITIALIZE THE CODE FOR EACH NEW C PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG= C -1 ONLY WHEN ONE-STEP INTEGRATOR CONTROL IS ESSENTIAL. C IN THIS CASE, GERK ATTEMPTS TO ADVANCE THE SOLUTION A C SINGLE STEP IN THE DIRECTION OF TOUT EACH TIME IT IS C CALLED. SINCE THIS MODE OF OPERATION RESULTS IN EXTRA C COMPUTING OVERHEAD, IT SHOULD BE AVOIDED UNLESS NEEDED. C C C******************************************************************* C OUTPUT FROM GERK C******************************************************************* C C Y(*) -- SOLUTION AT T C T -- LAST POINT REACHED IN INTEGRATION. C IFLAG = 2 -- INTEGRATION REACHED TOUT. INDICATES SUCCESSFUL C RETURN AND IS THE NORMAL MODE FOR CONTINUING C INTEGRATION. C =-2 -- A SINGLE SUCCESSFUL STEP IN THE DIRECTION OF C TOUT HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING C INTEGRATION ONE STEP AT A TIME. C = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN C 9000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS C IS APPROXIMATELY 500 STEPS. C = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION C VANISHED MAKING A PURE RELATIVE ERROR TEST C IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE. C USING THE ONE-STEP INTEGRATION MODE FOR ONE STEP C IS A GOOD WAY TO PROCEED. C = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED C ACCURACY COULD NOT BE ACHIEVED USING SMALLEST C ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR C TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE C ATTEMPTED. C = 6 -- GERK IS BEING USED INEFFICIENTLY IN SOLVING C THIS PROBLEM. TOO MUCH OUTPUT IS RESTRICTING THE C NATURAL STEPSIZE CHOICE. USE THE ONE-STEP C INTEGRATOR MODE. C = 7 -- INVALID INPUT PARAMETERS C THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS C SATISFIED - NEQN .LE. 0 C T=TOUT AND IFLAG .NE. +1 OR -1 C RELERR OR ABSERR .LT. 0. C IFLAG .EQ. 0 OR .LT. -2 OR .GT. 7 C GERROR(*) -- ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T C WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO C INTEREST TO THE USER BUT NECESSARY FOR SUBSEQUENT C CALLS. WORK(1),...,WORK(NEQN) CONTAIN THE FIRST C DERIVATIVES OF THE SOLUTION VECTOR Y AT T. C WORK(NEQN+1) CONTAINS THE STEPSIZE H TO BE C ATTEMPTED ON THE NEXT STEP. IWORK(1) CONTAINS C THE DERIVATIVE EVALUATION COUNTER. C C C******************************************************************* C SUBSEQUENT CALLS TO GERK C******************************************************************* C C SUBROUTINE GERK RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE C THE INTEGRATION. IF THE INTEGRATION REACHED TOUT, THE USER NEED C ONLY DEFINE A NEW TOUT AND CALL GERK AGAIN. IN THE ONE-STEP C INTEGRATOR MODE (IFLAG=-2) THE USER MUST KEEP IN MIND THAT EACH C STEP TAKEN IS IN THE DIRECTION OF THE CURRENT TOUT. UPON C REACHING TOUT (INDICATED BY CHANGING IFLAG TO 2), THE USER MUST C THEN DEFINE A NEW TOUT AND RESET IFLAG TO -2 TO CONTINUE IN THE C ONE-STEP INTEGRATOR MODE. C C IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS C TO CONTINUE (IFLAG=3 CASE), HE JUST CALLS GERK AGAIN. THE C FUNCTION COUNTER IS THEN RESET TO 0 AND ANOTHER 9000 FUNCTION C EVALUATIONS ARE ALLOWED. C C HOWEVER, IN THE CASE IFLAG=4, THE USER MUST FIRST ALTER THE C ERROR CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE C INTEGRATION CAN PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED. C C ALSO, IN THE CASE IFLAG=5, IT IS NECESSARY FOR THE USER TO C RESET IFLAG TO 2 (OR -2 WHEN THE ONE-STEP INTEGRATION MODE IS C BEING USED) AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH C BEFORE THE INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, C EXECUTION WILL BE TERMINATED. THE OCCURRENCE OF IFLAG=5 C INDICATES A TROUBLE SPOT (SOLUTION IS CHANGING RAPIDLY, C SINGULARITY MAY BE PRESENT) AND IT OFTEN IS INADVISABLE TO C CONTINUE. C C IF IFLAG=6 IS ENCOUNTERED, THE USER SHOULD USE THE ONE-STEP C INTEGRATION MODE WITH THE STEPSIZE DETERMINED BY THE CODE. IF C THE USER INSISTS UPON CONTINUING THE INTEGRATION WITH GERK IN C THE INTERVAL MODE, HE MUST RESET IFLAG TO 2 BEFORE CALLING GERK C AGAIN. OTHERWISE,EXECUTION WILL BE TERMINATED. C C IF IFLAG=7 IS OBTAINED, INTEGRATION CAN NOT BE CONTINUED UNLESS C THE INVALID INPUT PARAMETERS ARE CORRECTED. C C IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN C INFORMATION REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, C WORK AND IWORK SHOULD NOT BE ALTERED. C C******************************************************************* C C .. SCALAR ARGUMENTS .. INTEGER IFLAG,NEQN DOUBLE PRECISION ABSERR,RELERR,T,TOUT C .. C .. ARRAY ARGUMENTS .. INTEGER IWORK(5) DOUBLE PRECISION GERROR(NEQN),WORK(3+8*NEQN),Y(NEQN) C .. C .. SUBROUTINE ARGUMENTS .. EXTERNAL F C .. C .. LOCAL SCALARS .. INTEGER K1,K1M,K2,K3,K4,K5,K6,K7,K8 C .. C .. EXTERNAL SUBROUTINES .. EXTERNAL GERKS C .. C COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY K1M = NEQN + 1 K1 = K1M + 1 K2 = K1 + NEQN K3 = K2 + NEQN K4 = K3 + NEQN K5 = K4 + NEQN K6 = K5 + NEQN K7 = K6 + NEQN K8 = K7 + NEQN C ******************************************************************* C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, C HE MUST USE GERKS DIRECTLY. C ******************************************************************* CALL GERKS(F, NEQN, Y, T, TOUT, RELERR, ABSERR, IFLAG, * GERROR, WORK(1), WORK(K1M), WORK(K1), WORK(K2), WORK(K3), * WORK(K4), WORK(K5), WORK(K6), WORK(K7), WORK(K8), * WORK(K8+1), IWORK(1), IWORK(2), IWORK(3), IWORK(4), IWORK(5)) RETURN END SUBROUTINE GERKS(F, NEQN, Y, T, TOUT, RELERR, ABSERR, IFLAG, * GERROR, YP, H, F1, F2, F3, F4, F5, YG, YGP, SAVRE, SAVAE, * NFE, KOP, INIT, JFLAG, KFLAG) C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C ******************************************************************* C GERKS INTEGRATES A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL C EQUATIONS AS DESCRIBED IN THE COMMENTS FOR GERK. THE ARRAYS C YP,F1,F2,F3,F4,F5,YG AND YGP (OF DIMENSION AT LEAST NEQN) AND C THE VARIABLES H,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,AND KFLAG ARE C USED INTERNALLY BY THE CODE AND APPEAR IN THE CALL LIST TO C ELIMINATE LOCAL RETENTION OF VARIABLES BETWEEN CALLS. C ACCORDINGLY, THEY SHOULD NOT BE ALTERED. ITEMS OF POSSIBLE C INTEREST ARE C YP - DERIVATIVE OF SOLUTION VECTOR AT T C H - AN APPROPRIATE STEPSIZE TO BE USED FOR THE NEXT STEP C NFE- COUNTER ON THE NUMBER OF DERIVATIVE FUNCTION C EVALUATIONS. C ******************************************************************* C .. SCALAR ARGUMENTS .. INTEGER IFLAG,INIT,JFLAG,KFLAG,KOP,NEQN,NFE DOUBLE PRECISION ABSERR,H,RELERR,SAVAE,SAVRE,T,TOUT C .. C .. ARRAY ARGUMENTS .. DOUBLE PRECISION F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN), 1 GERROR(NEQN),Y(NEQN),YG(NEQN),YGP(NEQN),YP(NEQN) C .. C .. SUBROUTINE ARGUMENTS .. EXTERNAL F C .. C .. LOCAL SCALARS .. INTEGER K,MAXNFE,MFLAG LOGICAL HFAILD,OUTPUT DOUBLE PRECISION A,AE,DT,EE,EEOET,ESTTOL,ET,HH,HMIN,ONE,REMIN,RER, 1 S,SCALE,TOL,TOLN,TS,U,U26,YPK C .. C .. EXTERNAL FUNCTIONS .. DOUBLE PRECISION EPSLON EXTERNAL EPSLON C .. C .. EXTERNAL SUBROUTINES .. EXTERNAL FEHL C .. C .. INTRINSIC FUNCTIONS .. INTRINSIC ABS,MAX,MIN,SIGN C .. C ******************************************************************* C REMIN IS A TOLERANCE THRESHOLD WHICH IS ALSO DETERMINED BY THE C INTEGRATION METHOD. IN PARTICULAR, A FIFTH ORDER METHOD WILL C GENERALLY NOT BE CAPABLE OF DELIVERING ACCURACIES NEAR LIMITING C PRECISION ON COMPUTERS WITH LONG WORDLENGTHS. DATA REMIN /3.E-11/ C ******************************************************************* C THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER C OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE. C AS SET,THIS CORRESPONDS TO ABOUT 500 STEPS. DATA MAXNFE /9000/ C ******************************************************************* C U - THE COMPUTER UNIT ROUNDOFF ERROR U IS THE SMALLEST POSITIVE C VALUE REPRESENTABLE IN THE MACHINE SUCH THAT 1.+ U .GT. 1. C (VARIABLE ONE SET TO 1.0 EASES PRECISION CONVERSION.) C ONE = 1.0 U = EPSLON(ONE) C ******************************************************************* C CHECK INPUT PARAMETERS IF (NEQN.LT.1) GO TO 10 IF ((RELERR.LT.0.) .OR. (ABSERR.LT.0.)) GO TO 10 MFLAG = ABS(IFLAG) IF ((MFLAG.GE.1) .AND. (MFLAG.LE.7)) GO TO 20 C INVALID INPUT 10 IFLAG = 7 RETURN C IS THIS THE FIRST CALL 20 IF (MFLAG.EQ.1) GO TO 70 C CHECK CONTINUATION POSSIBILITIES IF (T.EQ.TOUT) GO TO 10 IF (MFLAG.NE.2) GO TO 30 C IFLAG = +2 OR -2 IF (INIT.EQ.0) GO TO 60 IF (KFLAG.EQ.3) GO TO 50 IF ((KFLAG.EQ.4) .AND. (ABSERR.EQ.0.)) GO TO 40 IF ((KFLAG.EQ.5) .AND. (RELERR.LE.SAVRE) .AND. * (ABSERR.LE.SAVAE)) GO TO 40 GO TO 70 C IFLAG = 3,4,5,6, OR 7 30 IF (IFLAG.EQ.3) GO TO 50 IF ((IFLAG.EQ.4) .AND. (ABSERR.GT.0.)) GO TO 60 C INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO C THE INSTRUCTIONS PERTAINING TO IFLAG=4,5,6 OR 7 40 STOP C ******************************************************************* C RESET FUNCTION EVALUATION COUNTER 50 NFE = 0 IF (MFLAG.EQ.2) GO TO 70 C RESET FLAG VALUE FROM PREVIOUS CALL 60 IFLAG = JFLAG C SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT C INPUT CHECKING 70 JFLAG = IFLAG KFLAG = 0 C SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS SAVRE = RELERR SAVAE = ABSERR C RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS C 32U+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING C FROM IMPOSSIBLE ACCURACY REQUESTS RER = MAX(RELERR,32.*U+REMIN) U26 = 26.*U DT = TOUT - T IF (MFLAG.EQ.1) GO TO 80 IF (INIT.EQ.0) GO TO 90 GO TO 110 C ******************************************************************* C INITIALIZATION -- C SET INITIALIZATION COMPLETION INDICATOR,INIT C SET INDICATOR FOR TOO MANY OUTPUT POINTS,KOP C EVALUATE INITIAL DERIVATIVES C COPY INITIAL VALUES AND DERIVATIVES FOR THE C PARALLEL SOLUTION C SET COUNTER FOR FUNCTION EVALUATIONS,NFE C ESTIMATE STARTING STEPSIZE 80 INIT = 0 KOP = 0 A = T CALL F(A, Y, YP) NFE = 1 IF (T.NE.TOUT) GO TO 90 IFLAG = 2 RETURN 90 INIT = 1 H = ABS(DT) TOLN = 0. DO 100 K=1,NEQN YG(K) = Y(K) YGP(K) = YP(K) TOL = RER*ABS(Y(K)) + ABSERR IF (TOL.LE.0.) GO TO 100 TOLN = TOL YPK = ABS(YP(K)) IF (YPK*H**5.GT.TOL) H = (TOL/YPK)**0.2 100 CONTINUE IF (TOLN.LE.0.) H = 0. H = MAX(H,U26*MAX(ABS(T),ABS(DT))) C ******************************************************************* C SET STEPSIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT 110 H = SIGN(H,DT) C TEST TO SEE IF GERK IS BEING SEVERELY IMPACTED BY TOO MANY C OUTPUT POINTS IF (ABS(H).GT.2.*ABS(DT)) KOP = KOP + 1 IF (KOP.NE.100) GO TO 120 KOP = 0 IFLAG = 6 RETURN 120 IF (ABS(DT).GT.U26*ABS(T)) GO TO 140 C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN DO 130 K=1,NEQN YG(K) = YG(K) + DT*YGP(K) Y(K) = Y(K) + DT*YP(K) 130 CONTINUE A = TOUT CALL F(A, YG, YGP) CALL F(A, Y, YP) NFE = NFE + 2 GO TO 230 C INITIALIZE OUTPUT POINT INDICATOR 140 OUTPUT = .FALSE. C TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION, C SCALE THE ERROR TOLERANCES SCALE = 2./RER AE = SCALE*ABSERR C ******************************************************************* C ******************************************************************* C STEP BY STEP INTEGRATION 150 HFAILD = .FALSE. C SET SMALLEST ALLOWABLE STEPSIZE HMIN = U26*ABS(T) C ADJUST STEPSIZE IF NECESSARY TO HIT THE OUTPUT POINT. C LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEPSIZE C AND THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE. DT = TOUT - T IF (ABS(DT).GE.2.*ABS(H)) GO TO 170 IF (ABS(DT).GT.ABS(H)) GO TO 160 C THE NEXT SUCCESSFUL STEP WILL COMPLETE THE INTEGRATION TO THE C OUTPUT POINT OUTPUT = .TRUE. H = DT GO TO 170 160 H = 0.5*DT C ******************************************************************* C CORE INTEGRATOR FOR TAKING A SINGLE STEP C ******************************************************************* C THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW C IN COMPUTING THE ERROR TOLERANCE FUNCTION ET. C TO AVOID PROBLEMS WITH ZERO CROSSINGS, RELATIVE ERROR IS C MEASURED USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION C AT THE BEGINNING AND END OF A STEP. C THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF C SIGNIFICANCE. C TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED C TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T. C PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO C SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE C CHATTERING ON PROBLEMS HAVING DISCONTINUITIES. C TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE C STEPSIZE IT ESTIMATES WILL SUCCEED. C AFTER A STEP FAILURE, THE STEPSIZE IS NOT ALLOWED TO INCREASE C FOR THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE C EFFICIENT ON PROBLEMS HAVING DISCONTINUITIES AND MORE C EFFECTIVE IN GENERAL SINCE LOCAL EXTRAPOLATION IS BEING USED C AND THE ERROR ESTIMATE MAY BE UNRELIABLE OR UNACCEPTABLE WHEN C A STEP FAILS. C ******************************************************************* C TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS. C IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H 170 IF (NFE.LE.MAXNFE) GO TO 180 C TOO MUCH WORK IFLAG = 3 KFLAG = 3 RETURN C ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H 180 CALL FEHL(F, NEQN, YG, T, H, YGP, F1, F2, F3, F4, F5, F1) NFE = NFE + 5 C COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR C ESTIMATES AND REMOVE SCALING OF TOLERANCES. NOTE THAT RELATIVE C ERROR IS MEASURED WITH RESPECT TO THE AVERAGE MAGNITUDES OF THE C OF THE SOLUTION AT THE BEGINNING AND END OF THE STEP. EEOET = 0. DO 200 K=1,NEQN ET = ABS(YG(K)) + ABS(F1(K)) + AE IF (ET.GT.0.) GO TO 190 C INAPPROPRIATE ERROR TOLERANCE IFLAG = 4 KFLAG = 4 RETURN 190 EE = ABS((-2090.*YGP(K)+(21970.*F3(K)-15048.*F4(K))) * +(22528.*F2(K)-27360.*F5(K))) EEOET = MAX(EEOET,EE/ET) 200 CONTINUE ESTTOL = ABS(H)*EEOET*SCALE/752400. IF (ESTTOL.LE.1.) GO TO 210 C UNSUCCESSFUL STEP C REDUCE THE STEPSIZE , TRY AGAIN C THE DECREASE IS LIMITED TO A FACTOR OF 1/10 HFAILD = .TRUE. OUTPUT = .FALSE. S = 0.1 IF (ESTTOL.LT.59049.) S = 0.9/ESTTOL**0.2 H = S*H IF (ABS(H).GT.HMIN) GO TO 170 C REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE IFLAG = 5 KFLAG = 5 RETURN C SUCCESSFUL STEP C STORE ONE-STEP SOLUTION YG AT T+H C AND EVALUATE DERIVATIVES THERE 210 TS = T T = T + H DO 220 K=1,NEQN YG(K) = F1(K) 220 CONTINUE A = T CALL F(A, YG, YGP) NFE = NFE + 1 C NOW ADVANCE THE Y SOLUTION OVER TWO STEPS OF C LENGTH H/2 AND EVALUATE DERIVATIVES THERE HH = 0.5*H CALL FEHL(F, NEQN, Y, TS, HH, YP, F1, F2, F3, F4, F5, Y) TS = TS + HH A = TS CALL F(A, Y, YP) CALL FEHL(F, NEQN, Y, TS, HH, YP, F1, F2, F3, F4, F5, Y) A = T CALL F(A, Y, YP) NFE = NFE + 12 C CHOOSE NEXT STEPSIZE C THE INCREASE IS LIMITED TO A FACTOR OF 5 C IF STEP FAILURE HAS JUST OCCURRED, NEXT C STEPSIZE IS NOT ALLOWED TO INCREASE S = 5. IF (ESTTOL.GT.1.889568E-4) S = 0.9/ESTTOL**0.2 IF (HFAILD) S = MIN(S,ONE) H = SIGN(MAX(S*ABS(H),HMIN),H) C ******************************************************************* C END OF CORE INTEGRATOR C ******************************************************************* C SHOULD WE TAKE ANOTHER STEP IF (OUTPUT) GO TO 230 IF (IFLAG.GT.0) GO TO 150 C ******************************************************************* C ******************************************************************* C INTEGRATION SUCCESSFULLY COMPLETED C ONE-STEP MODE IFLAG = -2 GO TO 240 C INTERVAL MODE 230 T = TOUT IFLAG = 2 240 DO 250 K=1,NEQN GERROR(K) = (YG(K)-Y(K))/31. 250 CONTINUE RETURN END SUBROUTINE FEHL(F, NEQN, Y, T, H, YP, F1, F2, F3, F4, F5, S) C FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD C ******************************************************************* C FEHL INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT=F(T,Y(1),---,Y(NEQN)) C WHERE THE INITIAL VALUES Y(I) AND THE INITIAL DERIVATIVES C YP(I) ARE SPECIFIED AT THE STARTING POINT T. FEHL ADVANCES C THE SOLUTION OVER THE FIXED STEP H AND RETURNS C THE FIFTH ORDER (SIXTH ORDER ACCURATE LOCALLY) SOLUTION C APPROXIMATION AT T+H IN ARRAY S(I). C F1,---,F5 ARE ARRAYS OF DIMENSION NEQN WHICH ARE NEEDED C FOR INTERNAL STORAGE. C THE FORMULAS HAVE BEEN GROUPED TO CONTROL LOSS OF SIGNIFICANCE. C FEHL SHOULD BE CALLED WITH AN H NOT SMALLER THAN 13 UNITS OF C ROUNDOFF IN T SO THAT THE VARIOUS INDEPENDENT ARGUMENTS CAN BE C DISTINGUISHED. C ******************************************************************* C .. SCALAR ARGUMENTS .. INTEGER NEQN DOUBLE PRECISION H,T C .. C .. ARRAY ARGUMENTS .. DOUBLE PRECISION F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN), 1 S(NEQN),Y(NEQN),YP(NEQN) C .. C .. SUBROUTINE ARGUMENTS .. EXTERNAL F C .. C .. LOCAL SCALARS .. INTEGER K DOUBLE PRECISION CH C .. CH = 0.25*H DO 10 K=1,NEQN F5(K) = Y(K) + CH*YP(K) 10 CONTINUE CALL F(T+0.25*H, F5, F1) CH = 0.09375*H DO 20 K=1,NEQN F5(K) = Y(K) + CH*(YP(K)+3.*F1(K)) 20 CONTINUE CALL F(T+0.375*H, F5, F2) CH = H/2197. DO 30 K=1,NEQN F5(K) = Y(K) + CH*(1932.*YP(K)+(7296.*F2(K)-7200.*F1(K))) 30 CONTINUE CALL F(T+12./13.*H, F5, F3) CH = H/4104. DO 40 K=1,NEQN F5(K) = Y(K) + CH*((8341.*YP(K)-845.*F3(K))+(29440.*F2(K) * -32832.*F1(K))) 40 CONTINUE CALL F(T+H, F5, F4) CH = H/20520. DO 50 K=1,NEQN F1(K) = Y(K) + CH*((-6080.*YP(K)+(9295.*F3(K)-5643.*F4(K))) * +(41040.*F1(K)-28352.*F2(K))) 50 CONTINUE CALL F(T+0.5*H, F1, F5) C COMPUTE APPROXIMATE SOLUTION AT T+H CH = H/7618050. DO 60 K=1,NEQN S(K) = Y(K) + CH*((902880.*YP(K)+(3855735.*F3(K)-1371249.* * F4(K)))+(3953664.*F2(K)+277020.*F5(K))) 60 CONTINUE RETURN END DOUBLE PRECISION FUNCTION EPSLON (X) DOUBLE PRECISION X C C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. C DOUBLE PRECISION A,B,C,EPS,FOUR,THREE C C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS C SATISFYING THE FOLLOWING TWO ASSUMPTIONS, C 1. THE BASE USED IN REPRESENTING FLOATING POINT C NUMBERS IS NOT A POWER OF THREE. C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO C THE ACCURACY USED IN FLOATING POINT VARIABLES C THAT ARE STORED IN MEMORY. C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING C ASSUMPTION 2. C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, C B HAS A ZERO FOR ITS LAST BIT OR DIGIT, C C IS NOT EXACTLY EQUAL TO ONE, C EPS MEASURES THE SEPARATION OF 1.0 FROM C THE NEXT LARGER FLOATING POINT NUMBER. C FOUR = 4.0 THREE = 3.0 A = FOUR/THREE 10 B = A - 1.0 C = B + B + B EPS = ABS(C-1.0) IF (EPS .EQ. 0.0) GO TO 10 EPSLON = EPS*ABS(X) RETURN END SHAR_EOF fi # end of overwriting check if test -f 'sleign2x.tex' then echo shar: will not over-write existing file "'sleign2x.tex'" else cat << SHAR_EOF > 'sleign2x.tex' \documentstyle[12pt]{article} \topmargin 0in \textheight 8in \oddsidemargin 0in \evensidemargin 0in \textwidth 6.5in \pagestyle{empty} \newfont{\msbm}{msbm10 scaled\magstephalf} \newcommand{\Z}{\mbox{\msbm Z}} \newcommand{\dfrac}{\displaystyle\frac} \newcommand{\ul}{\underline} \newenvironment{romlist}{\begin{list}{(\roman{romnum})} {\usecounter{romnum}\setlength{\topsep}{1pt} \setlength{\itemsep}{1pt}} \rm}{\end{list}} \newcommand{\zettleq}{\raise.08in\hbox{.} \!\!\! =\!\!\!\raise-.03in\hbox{.} } \begin{document} \baselineskip=24pt \begin{center} SLEIGN2 \end{center} \vspace*{.2in} \noindent {\bf Commentary on the individual examples in xamples.f} These examples have been chosen to illustrate the capabilities and limitations of the program SLEIGN2. Many of the examples have been chosen from special cases of the well known and well studied ``special functions" of mathematical analysis. All possible cases of end-point classifications are represented; general separated regular and singular boundary conditions may be applied to these examples as appropriate. Also coupled periodic-type boundary conditions can be used in the regular case. For some of these examples it is possible to give explicit information on the spectrum of associated boundary value problems; this can take the form of providing explicit formulas for eigenvalues against which the program calculated results can be compared. In all cases of limit-circle end-points boundary condition functions $u$ and $v$ have been entered as part of the example data. In the case of limit-circle non-oscillatory end-points we use the convention that the boundary condition function $u$ determines the principal or Friedrichs boundary condition. On selecting a numbered example the the differential equation is displayed in FORTRAN, and details of the end-point classification given. If information on the form of the boundary condition functions $u$ and $v$ is required then the user should scroll through the xamples.f file to the appropriate numbered part of the $u, \ v$ section. Some regular and weakly regular problems can be more successfully run using the limit-circle non-oscillatory (LCNO) algorithm; details are given below for some of the examples. It should be noted that for the limit-circle oscillatory problems it is sometimes difficult to compute numerically more than a few of the eigenvalues. One example is included for which the program fails; see Laguerre \#22. This problem has a discrete spectrum and for one particular boundary condition the eigenvalues are known explicitly. In this case numerical values to confirm the details of the spectrum can be obtained by use of the Liouville transformation; this leads to the Laguerre/Liouville example \#23 for which the program is successful. The Liouville transformation has also been applied to the Jacobi equation, \#16 to yield the Jacobi/Liouville example \#24. The Liouville transformation is sometimes useful to get a Sturm-Liouville differential equation into a form more suitable for numerical computation. {\bf Parameters.} Many of the examples involve the choice of one or more parameters; the range of these parameters is given when the numbered differential equation is displayed. If a choice of parameter is made outside of the stated range the program may abort. {\bf Remarks on the individual examples.} \begin{enumerate} \item%1 {\bf Classical Legendre equation} \begin{itemize} \item[(i)] The Legendre polynomials are obtained by taking the principal (Friedrichs) boundary condition at both end-points $\pm 1:$ enter $A1=1, \; A2=0, \; B1 = 1 , B2 = 0 $ i.e. take the boundary condition function $u$ at $ \pm 1$; eigenvalues: $\lambda_n = (n+1/2 ) (n+ 1/2) \ ; n = 0,1,2, \cdots $; eigenfunctions: Legendre polynomials $P_n(x)$. \item[(ii)] Enter $A1=0, \; A2 = 1, \; B1 = 0, \; B2=1, $ i.e. use the b.c. function $v$ at $\pm 1$; eigenvalues: $\mu_n ; n=0,1,2,\cdots $ no explicit formula is available; eigenfunctions: are logarithmically unbounded at $\pm 1$. Observe that $\mu_n < \lambda_n < \mu_{n+1} \ ; n=0,1,2 \cdots $. \cite{T}: Chapter IV. \end{itemize} \item %2 {\bf Bessel equation}\\ This is the Liouville form of the classical Bessel equation. \begin{itemize} \item[(1)] Problems on $(0,1] $ with $y(1) = 0$ \begin{itemize} \item[(i)] $0 \leq \nu < 1 , \; \nu \neq \dfrac{1}{2} $; the Friedrichs case: $A1=1$, $A2 =0$ yields the classical Fourier-Bessel series; $ \lambda_n = j_{\nu,n}^2 $ where $\{ j_{\nu,n}, n : n=0,1,2,...\}$ are the zeros (positive) of the Bessel function $J_{\nu}(x)$. \item[(ii)] $\nu \geq 1$; limit-point at $0$ so unique boundary value problem with $ \lambda_n = j_{\nu,n}^2 $ as before \item[(iii)] these are similar to (i) and (ii) when $\nu < 0$ \end{itemize} \item[(2)] Problems on $[1, \infty );$ continuous spectrum on $[0, \infty )$ \begin{itemize} \item[(i)] for Dirichlet and Neumann b.c. at $1$ there are no eigenvalues. \item[(ii)] for $A1 = A2 = 1$ at $1$ there is one isolated eigenvalue. \end{itemize} \item[(3)] Problems on $(0, \infty);$ continuous spectrum on $[0, \infty)$ \begin{itemize} \item[(i)] no eigenvalues if $\nu \geq 1$ \item[(ii)] for $0 \leq \nu < 1 $ the Friedrichs case is given by $A1=1$, $A2=0$; there are no eigenvalues \item[(iii)] if $A1 = 5, \; A2=1$ there is one isolated eigenvalue near -46.64.\\ \hfill \cite{T}: Chapter IV and \cite{W}: Chapter XVIII. \end{itemize} \end{itemize} \item %3 {\bf The Halvorsen equation} This equation is $R$ at $0$ and LCNO at $+ \infty$ so that the spectrum is discrete and bounded below for all b.c.. However, this example illustrates that even a regular end-point can cause difficulties for computation. The program fails on $R$ at $0$; is successful for $WR$ at $0$; is successful for LCNO at $0$ (use $u(x) = x, \ v(x) = 1$ at $0$; the given $u$ and $v$ at $\infty $ and employ the double limit-circle entry at $0$ and $\infty $ with $c=1$ - see "Help" h4 for more details). At $0$, with $u(x) = x$ and $v(x) =1$, the principal entry is $A1 = 1, \ A2 = 0$; at $\infty $ with $u(x) = 1, \ v(x) = x$ the principal entry is also $A1=1, \; A2=0$ but note the interchange of $u$ and $v$. \item %4 {\bf The Boyd equation} This equation arises in a model studying eddies in the atmosphere; see \cite{B}. There is no explicit formula for the eigenvalues of any particular boundary condition; eigenfunctions can be given in terms of Whittaker functions; see \cite{BEZ}; example 3. \item%5 {\bf The regularized Boyd equation} This is a WR form of equation 4; the singularity at zero has been regularized using quasi-derivatives. There is a close relationship between the examples 4 and 5; in particular they have the same eigenvalues - see \cite{AEZ}. For a general discussion of regularization using non-principal solutions see \cite{NZ}. For numerical results see \cite{BEZ}; example 3. \item %6 {\bf The Sears-Titchmarsh equation} This differential equations has one LP and one LCO end-point. For details of boundary value problems on $[1, \infty )$ see \cite{BEZ}: example 4. The equation was studied originally in \cite{T}; Chapter IV; but see \cite{ST}. For problems on $[1, \infty)$, with separated boundary conditions, the spectrum is simple and discrete but unbounded above and below. Numerical results are given in \cite{BEZ}: example 4. \item %7 {\bf The BEZ equation} This equation is similar to equation 6. On the interval $(0, 1]$ there is a singularity at $0$ in LCO; the equation is R at 1. For numerical results see \cite{BEZ}: example 5. \item %8 {\bf The LaPlace tidal wave equation} This equation is a particular case of the move general equation with this name; for details and references see \cite{H} There are no representations for solutions in terms of the well-known special functions. Thus to determine boundary conditions at the LCNO end-point $0$ use has to be made of maximal domain functions; see the $u, \ v$ section for this equation. Numerical results are given in \cite{BEZ}: example 8. \item %9 {\bf The Latzko equation} This differential equation has a long and celebrated history; see \cite{F}: pages 43 to 45. There is a LCNO singularity at 1 which requires the use of maximal domain functions; see the $u, \ v$ section. The end-point $0$ is WR due to the fact that $w(0) = 0$. This example is similar in some respects to the Legendre equation of example 1. For numerical results see \cite{BEZ}: example 7. \item%10 {\bf A weakly regular equation} This is a devised example to illustrate the computational difficulties of weakly regular problems. The differential equation gives $p(0) = 0$ and $w(0) = \infty $ but nevertheless $0$ is a regular end-point in the Lebesgue integral sense, but has to be classified as weakly regular in the computational sense. The Liouville normal form of this equation is the Fourier equation; see example 21. There are explicit solutions of this equation when $\lambda = 0$ given by $$ cos (2x^{1/2} \surd \lambda ) \ \ ; sin (2x^{1/2} \surd \lambda ) / \surd \lambda . $$ If $0$ is treated as a LCNO end-point then $u, \ v$ boundary condition functions are $$ u(x) = 2x^{1/2} \ \ ; v(x) = 1 . $$ {\bf WR at 0} The regular condition $D \; y(0) = 0 $ is equivalent to the singular condition $[y,u](0) = 0$ {\bf LCNO} \\ Similarly the regular condition $N \; (py')(0) = 0$ is equivalent to the singular condition $ [y, \ v] (0) = 0$. The following indicated boundary value problems have the given explicit formulae for the eigenvalues: $$ y(0) = 0 {\mbox{ or }} [y, \ u] (0) = 0 {\mbox{ and }} y(1) = 0 \; \; \lambda_n = ((n+1) \pi)^2 /4 \ (n=0, 1,... ) $$ $$ (py)'(0) = 0 {\mbox{ or }} [y,v](0) = 0 {\mbox{ and }} (py')(1) = 0 \; \; \lambda_n = ((n+ \dfrac{1}{2} ) \pi ) ^2 /4 \ (n=0,1, ...). $$ \item %11 {\bf The Plum equation} Plum \cite{P} computed the first seven periodic eigenvalues using a numerical homotopy method together with interval arithmetic and obtained rigorous bounds for these seven computed eigenvalues. \item %12 {\bf The Mathieu equation} The classical Mathieu equation has a celebrated history and voluminous literature. There are no eigenvalues for this problem on $(- \infty , + \infty )$. There may be one negative eigenvalue of the problem on $[0, \infty)$ depending on the boundary condition at the end-point $0$. The continuous (essential) spectrum is the same for the whole line or half-line problems and consists of an infinite number of disjoint closed intervals. The endpoints of these - and thus the spectrum of the problem - can be characterized in terms of periodic and semi-periodic eigenvalues of S-L problems on the compact interval $[0, 2 \pi]$. These can be computed with SLEIGN2. These remarks also apply to the general S-L equation with periodic coefficients of the same period; the so-called Hill's equation. Of special interest is the starting point of the continuous spectrum - this is also the oscillation number of the equation. It can be computed with SLEIGN2. For the Mathieu equation ($p=1, \ q=sin(x), w=1$) on both the whole line and the half line it is appr. -0.378. \item %13 {\bf The hydrogen atom equation} This is the classical one-dimensional equation for quantum modelling of the hydrogen atom; see \cite{T}: Chapter IV. For the parameter $L=0$ the equation is LCNO at end-point $0$; the boundary condition $A1=1, \; A2=0$ gives the Friedrichs extension which leads to the classical eigenvalues and eigenfunctions. For $L>0$ the end-point zero is LP. For all these boundary value problems the continuous spectrum is $[0, \infty )$, and there are a countably infinite number of negative eigenvalues with a single cluster point at 0. The eigenvalues for the classical i.e. Friedrichs case are given by $$ \lambda_n = - \dfrac{1}{4(L+n-1)^2} \, , \ n=0,1,2, \ldots $$ \item %14 {\bf The Marletta equation} This equation is R at 0 and LP at $\infty $; there is a continuous spectrum on $[0, \infty )$; there is an isolated negative eigenvalue for some boundary condition at 0. Both codes SLEIGN2 and SLEDGE report a second eigenvalue near 0, this may be due to the fact that there is a solution which is NOT in $L^2 (0, \infty)$ but is "nearly" in this space, thus deceiving these codes; details are in the Marletta certification report on SLEIGN (not SLEIGN2) \cite{M}. \item %15 { \bf The harmonic oscillator equation} This is another classic equation. It is also the Liouville normal form of the differential equation for the Hermite orthogonal polynomials. On the whole real line the boundary value problem requires no boundary conditions at the end-points of $\pm \infty $. Thus there is a unique self-adjoint extension with discrete spectrum given by : $$ \{ \lambda_n = 2n+1 ; \; n=0, 1,2,...\}. $$ For a classical treatment see \cite{T}; Chapter IV, section 2. \item %16 {\bf The Jacobi equation} To obtain the classical orthogonal polynomials use the Friedrichs extension. This is determined by the boundary conditions as follows: \\ Endpoint +1 : $$ -1 < \alpha < 0, \ -1 < \beta, \ WR, \ (py')(1) =0 $$ $$ 0 \le \alpha < 1 : LCNO, \quad \ [y,u](1) = 0 = [y,v](1) =0. $$ $$ 1 \le \alpha : \ LP $$ Endpoint -1 : $$ -1 < \beta < 0, \ -1 < \alpha \ WR, \ (py')(-1) =0 $$ $$ 0 \le \beta < 1 : LCNO, \quad \ [y,u](-1) = 0 = [y,v](-1) =0. $$ $$ 1 \le \beta : \ LP $$ For the classical orthogonal polynomials the eigenvalues are given by : $$ \lambda_n = n(n + \alpha + \beta + 1), \ n = 0,1,2, \ldots $$ \item % 17 {\bf The rotation Morse oscillator equation} This classical problem has continuous spectrum $[0, \inf ]$ and 26 negative eigenvalues. \item %18 {\bf The Dunsch equation} Discussed in chapter VIII, pp. 1510-1520 of \cite{DS}. For $ 0 < \alpha < 1/2 $ , and $0 < \beta < 1/2$ we choose : \\ $$ at -1 : \ u_-(x) = (1 + x)^{\alpha}, \quad v_-(x) = (1+x)^{-\alpha} $$ $$ at +1 : \ u_+(x) = (1 + x)^{\beta }, \quad v_+(x) = (1+x)^{-\beta} $$ Note that these $u$ and $v$ are not solutions but maximal domain functions. D and S state on p.1519 that the boundary value problem determined by $$ [y,u_-](-1) = 0 = [y,u_+](1) $$ has eigenvalues given by : $$ \lambda_n = (n + \alpha + \beta + 1)(n + \alpha + \beta), n = 0, 1, 2, \ldots $$ \item %19 {\bf The Donsch equation} This is a modification of problem 18 which illustrates an LCNO/LCO mix. Replace $\alpha$ in 18 by $ i \gamma$. This changes the singularity at -1 from LCNO to LCO. Take $\gamma > 0$ and $ 0 \le \beta < 1/2 $. $$ At +1 : u(x) = (1-x)^{\beta}, \quad v(x) = (1-x)^{-\beta} $$ $$ At -1 : u(x) = cos(log(1+x)), \quad v(x) = sin(log(1+x)) $$ Again these $u$ and $v$ are not solutions but maximal domain functions. \item %20. { \bf The Krall equation} This example should be seen as a special case of the Bessel equation 2 above. Solutions can be obtained in terms of the modified Bessel functions. To help with the computations for this example the spectrum is translated by a term $+1$; this simple devise is used for convenience. For problems with separated conditions at end-points $0$ and $\infty $ there is a continuous spectrum on $[1, \infty )$ with a discrete (and simple) spectrum on $(- \infty , 1)$. This discrete spectrum has cluster points at $- \infty $ and $1$. With the $u, \; v$ boundary condition function as given, in particular $u(x) = x^{1/2} \; cos (k \ log(x))$, the problem with boundary condition $[y, u](0) = 0$ has eigenvalues given explicitly by: \begin{itemize} \item[(i)] suppose $\Gamma (1+i) = \alpha + i \beta $ and $ \mu > 0$ satisfies $ tan(log (\dfrac{1}{2} \mu )) = - \alpha / \beta $ \item[(ii)] $\theta = im (log ( \Gamma (1+i))) $ \item[(iii)] $log (\dfrac{1}{2} \mu ) = \dfrac{\pi}{2} + \theta + s \pi \; \; s = 0, \pm 1, \pm 2, ... $ \item[(iv)] $- \mu_s^2 = - (2exp (\theta + \dfrac{1}{2} \pi ))^2 \; exp (2s \pi ) \; s=0, \pm 1 , \pm 2 ... $ \end{itemize} then the eigenvalues are $ \lambda_n = - \mu_{-(n+1)}^2 + 1 \ (n\in \Z )$. SLEIGN2 can compute only six of these eigenvalues on our Sun workstation, $\lambda_{-3}$ to $\lambda_2 $; other eigenvalues are, numerically, too close to 1 or too close to $-\infty $. We have $$ \lambda_2 \; \zettleq \; 0.999997 \quad \lambda_{-3} \; \zettleq \; -14,519,130. $$ See \cite{K}. \item % 21 {\bf The Fourier equation} This is a simple constant coefficient equation whose eigenvalues, for any self-adjoint boundary condition, can be characterized in terms of a transcendental equation involving only trigonometric functions. \item % 22 {\bf The Laguerre equation} This is the classical form of the differential equation which for parameter $ \alpha > 1 $ produces the Laguerre polynomials as eigenfunctions; for the appropriate boundary condition at 0, when required, the eigenvalues are then (remarkably!) independent of $ \alpha $ and given by $ \lambda_n = n \; (n=0, 1,2,...)$; see \cite{AS}; Chapter 22, section 22.6. SLEIGN2 fails to compute eigenvalues with this differential equation on $(0, \infty )$ on our Sun workstation; this appears to be due to numerical problems resulting from the exponentially small coefficients; however, see example 23 below. \item %23 {\bf The Laguerre/Liouville equation} This is the Liouville normal form of the Laguerre equation. It seems to be in a form more suitable for eigenvalue computations in contrast to the previous example. The Laguerre polynomials are produced when $ \alpha > -1$. For $\alpha \geq 1$ the LP condition holds at 0. For $0 \leq \alpha < 1$ the appropriate boundary condition is $[y,u] (0) = 0; $ for $ -1 < \alpha < 0 $ use $[y, \ v] (0) = 0$. In all these cases $ \lambda_n = n \; (n=0, 1, 2, ...)$. \item %24 {\bf The Jacobi/Liouville equation} This is the Liouville normal form of the Jacobi equation of example 16. \item%25 {\bf The Meissner equation} This equation arose in a model of a one dimensional crystal. For this constant coefficient equation with a weight function which has a jump discontinuity the eigenvalues can be characterized as roots of a transcendental equation involving only trig. and inverse trig. functions. There are infinitely many simple eigenvalues and infinitely many double ones for the periodic case; they are given by: {\bf Periodic boundary conditions on $(-0.5, 0.5)$.} We have $\lambda_0 = 0$ and $$ \lambda_{4n+1} = ( 2m \pi + \alpha)^2 ; \ \ \lambda_{4n+2} = ( 2(n+1) \pi - \alpha))^2 ; $$ $$ \ \lambda_{4n+3} \ = \ \ \lambda_{4n+4} = ( 2(n+1) \pi ))^2 ; \ n=0,1,2, \ldots $$ where $ \alpha \, = \, cos^{-1}(-7/8) $ {\bf Semi-Periodic eigenvalues} With $ \beta = cos^{-1}( (1 + \sqrt(33))/16)$ and $ \gamma = cos^{-1}( (1 - \sqrt(33))/16)$ these are all simple and given by : $$ \lambda_{4n} \, = \, ( 2n \pi \, + \, \beta)^2 ; \ \lambda_{4n+1} \, = \, ( 2n \pi \, + \, \gamma )^2 ; \ \lambda_{4n+2} \, = \, ( 2(n+1) \pi \, - \, \gamma )^2 ; \ $$ $$ \lambda_{4n+3} \, = \, ( 2(n+1) \pi \, - \, \beta)^2 ; \ n =0, 1, 2, \ldots $$ See \cite{E} and \cite{Hoc}. \end{enumerate} \begin{thebibliography}{999} \bibitem{AS} M.Abramovitz and I.Stegun, {\em Handbook of Mathematical Functions with formulas and graphs and mathematical tables}, Dover Publications Inc., New York, 1965. \bibitem{AEZ} F.V.Atkinson, W.N.Everitt and A.Zettl, {\em Regularization of Sturm-Liouville problem with an interior singularity using quasi-derivatives} Diff. and Int. Equations 1 (1988), 213-222. \bibitem{BEZ} P.B.Bailey, W.N.Everitt and A.Zettl, {\em Computing eigenvalues of singular Sturm-Liouville problems}, Results in Mathematics, v.20(1991), 391-423. \bibitem{B} J.P.Boyd, {\em Sturm-Liouville eigenvalue problems with an interior pole}, J.Math. Physics, 22(1981), 1575-1590. \bibitem{DS} N.Dunford and J.T.Schwartz, {\em Linear Operators, part II}, Interscience Publishers, New York, 1963. \bibitem{E} M.S.P. Eastham, {\em The spectral theory of periodic differential equations}, Scottish Academic Press, Edinburgh and London, 1973. \bibitem{EGZ} W.N.Everitt, J.Gunson and A.Zettl, {\em Some comments on Sturm-Liouville eigenvalue problems with interior singularities}, J. Appl. Math. Phys. (ZAMP) 38 (1987), 813-838. \bibitem{F} G.Fichera, {\em Numerical and quantitative analysis}, Pitman Press, London, 1978. \bibitem{H} M.S.Homer, {\em Boundary value problems for the La Place tidal wave equation}, Proc. Roy. Soc. of London (A) 428 (1990), 157-180. \bibitem{Hoc} H.Hochstadt, {\em A special Hill's equation with discontinuous coefficients}, Amer. Math. Monthly, 70(1963), 18-26. \bibitem{K} A.M.Krall, {\em Boundary value problems for an eigenvalue problem with a singular potential}, J. Diff. Equations, 45 (1982), 128-138. \bibitem{M} M.Marletta, {\em Numerical tests of the SLEIGN software for Sturm-Liouville problems}, ACM TOMS, v17(1991), 501-503. \bibitem{NZ} H.-D.Niessen and A.Zettl, {\em Singular Sturm-Liouville problems; the Friedrichs extension and comparison of eigenvalues}, Proc. London Math. Soc. 64 (1992), 545-578. \bibitem{P} M.Plum, {\em Eigenvalue inclusions for second-order ordinary differential operators by a numerical homotopy method}, ZAMP, v41(1990), 205-226. \bibitem{ST} D.B.Sears and E.C.Titchmarsh, {\em Some eigenfunction formulae}, Quart. J. Math. Oxford (2) 1 (1950), 165-175. \bibitem{T} E.C. Tichmarsh, {\em Eigenfunction expansions associated with second order differential equations}, v. I, Clarendon Press, Oxford; 1962. \bibitem{W} G.N.Watson, {\em A treatise on the theory of Bessel functions}, Cambridge University Press, Cambridge, England, 1958. \end{thebibliography} \end{document} SHAR_EOF fi # end of overwriting check if test -f 'xamplesd.f' then echo shar: will not over-write existing file "'xamplesd.f'" else cat << SHAR_EOF > 'xamplesd.f' C OCTOBER 15, 1995; P.B. BAILEY, W.N. EVERITT, B. GARBOW AND A. ZETTL C SUBROUTINE EXAMP() CHARACTER ANS INTEGER MUMBER,NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA C C THIS SUBROUTINE CONTAINS A SELECTION OF COEFFICIENT FUNCTIONS C p,q,w (AND POSSIBLY SUITABLE FUNCTIONS u,v TO DETERMINE SINGULAR C B.C.) WHICH DEFINE SOME INTERESTING STURM-LIOUVILLE BOUNDARY C VALUE PROBLEMS. IT CAN BE CALLED BY THE MAIN PROGRAM, DRIVE. C WRITE(*,*) ' Here is a collection of 29 differential equations ' WRITE(*,*) ' which can be used with SLEIGN2. By typing an ' WRITE(*,*) ' integer from 1 to 29, one of these differential ' WRITE(*,*) ' equations is selected, whereupon its coefficient ' WRITE(*,*) ' functions p,q,w will be displayed along with a ' WRITE(*,*) ' brief description of its singular points. The' WRITE(*,*) ' endpoints a, b of the interval over which the ' WRITE(*,*) ' differential equation is integrated are specified ' WRITE(*,*) ' later; any interval which does not contain ' WRITE(*,*) ' singular points in its interior is acceptable. ' WRITE(*,*) WRITE(*,*) ' DO YOU WISH TO CONTINUE ? (Y/N) ' READ(*,9010) ANS IF (.NOT.(ANS.EQ.'y' .OR. ANS.EQ.'Y')) STOP 30 CONTINUE WRITE(*,*) WRITE(*,*) ' 1 IS THE LEGENDRE EQUATION ' WRITE(*,*) ' 2 IS THE BESSEL EQUATION ' WRITE(*,*) ' 3 IS THE HALVORSEN EQUATION ' WRITE(*,*) ' 4 IS THE BOYD EQUATION ' WRITE(*,*) ' 5 IS THE REGULARIZED BOYD EQUATION ' WRITE(*,*) ' 6 IS THE SEARS-TITCHMARSH EQUATION ' WRITE(*,*) ' 7 IS THE BEZ EQUATION ' WRITE(*,*) ' 8 IS THE LAPLACE TIDAL WAVE EQUATION ' WRITE(*,*) ' 9 IS THE LATZKO EQUATION ' WRITE(*,*) ' 10 IS A WEAKLY REGULAR EQUATION ' WRITE(*,*) ' 11 IS THE PLUM EQUATION ' WRITE(*,*) ' 12 IS THE MATHIEU PERIODIC EQUATION ' WRITE(*,*) ' 13 IS THE HYDROGEN ATOM EQUATION ' WRITE(*,*) ' 14 IS THE MARLETTA EQUATION ' WRITE(*,*) ' 15 IS THE HARMONIC OSCILLATOR EQUATION ' WRITE(*,*) WRITE(*,*) ' Press any key to continue. ' READ(*,9010) ANS 9010 FORMAT(A1) WRITE(*,*) ' 16 IS THE JACOBI EQUATION ' WRITE(*,*) ' 17 IS THE ROTATION MORSE OSCILLATOR EQUATION ' WRITE(*,*) ' 18 IS THE DUNSCH EQUATION ' WRITE(*,*) ' 19 IS THE DONSCH EQUATION ' WRITE(*,*) ' 20 IS THE KRALL EQUATION ' WRITE(*,*) ' 21 IS THE FOURIER EQUATION ' WRITE(*,*) ' 22 IS THE LAGUERRE EQUATION ' WRITE(*,*) ' 23 IS THE LAGUERRE/LIOUVILLE FORM EQUATION ' WRITE(*,*) ' 24 IS THE JACOBI/LIOUVILLE FORM EQUATION ' WRITE(*,*) ' 25 IS THE MEISSNER EQUATION ' WRITE(*,*) ' 26 IS THE LOHNER EQUATION ' WRITE(*,*) ' 27 IS THE JOERGENS EQUATION ' WRITE(*,*) ' 28 IS THE BEHNKE-GOERISCH EQUATION ' WRITE(*,*) ' 29 IS THE WHITTAKER EQUATION ' WRITE(*,*) WRITE(*,*) ' ENTER THE NUMBER OF YOUR CHOICE: ' READ(*,*) NUMBER IF (NUMBER.LT.1 .OR. NUMBER.GT.29) GO TO 30 MUMBER = NUMBER GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-1,1) ' WRITE(*,*) WRITE(*,*) ' p = 1 - x*x, q = 1/4, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT -1. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT +1. ' GO TO 40 C 2 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = (nu*nu-0.25)/x*x, w = 1 ' WRITE(*,*) ' (nu a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT FOR ALL nu AT + INFINITY' WRITE(*,*) ' AT 0: LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -1.LT.nu.LT.1 BUT nu*nu.NE.0.25. ' WRITE(*,*) ' REGULAR FOR nu*nu = 0.25. ' WRITE(*,*) ' LIMIT POINT FOR nu*nu.GE.1.0. ' MUMBER = 101 GO TO 40 C 3 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0, w = exp(-2/x)/x**4 ' WRITE(*,*) WRITE(*,*) ' WEAKLY REGULAR AT 0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT +INFINITY. ' GO TO 40 C 4 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity,0) ' WRITE(*,*) ' AND on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = -1/x, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT 0+ AND 0-. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 5 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity,0) ' WRITE(*,*) ' AND on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = r*r, q = -r*r*(ln|x|)**2, w = r*r ' WRITE(*,*) ' where r = exp(-(x*ln(|x|)-x)) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' WEAKLY REGULAR AT 0+ AND 0-. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 6 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = x, q = -x, w = 1/x ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT 0. ' WRITE(*,*) ' LIMIT CIRCLE, OSCILLATORY AT +INFINITY. ' GO TO 40 C 7 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity,0) ' WRITE(*,*) ' AND on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = x, q = -1/x, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT CIRCLE, OSCILLATORY AT 0+ AND 0-. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 8 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1/x, q = (k/x**2) + (k**2/x), w = 1 ' WRITE(*,*) ' (k a non-zero parameter) ' WRITE(*,*) WRITE(*,*) 'AT 0: LIMIT CIRCLE, NON-OSCILLATORY FOR ALL k. ' WRITE(*,*) 'AT +INFINITY: LIMIT POINT AT FOR ALL k. ' MUMBER = 102 GO TO 40 C 9 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,1) ' WRITE(*,*) WRITE(*,*) ' p = 1 - x**7, q = 0, w = x**7 ' WRITE(*,*) WRITE(*,*) ' WEAKLY REGULAR AT 0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT +1. ' GO TO 40 C 10 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = sqrt(x), q = 0, w = 1/sqrt(x) ' WRITE(*,*) WRITE(*,*) ' WEAKLY REGULAR AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 11 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 100*cos(x)**2, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 12 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 2*k*cos(2x), w = 1 ' WRITE(*,*) ' (k a non-zero parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 103 GO TO 40 C 13 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = k/x + h/x**2, w = 1 ' WRITE(*,*) ' q = k/x + h/x**2 + 1 if h.lt.-0.25 ' WRITE(*,*) ' (h,k parameters) ' WRITE(*,*) WRITE(*,*) 'LIMIT POINT FOR ALL h,k AT +INFINITY ' WRITE(*,*) 'AT 0: ' WRITE(*,*) ' REGULAR for h = k = 0. ' WRITE(*,*) ' LIMIT-CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR h = 0 AND ALL k.NE.0. ' WRITE(*,*) ' LIMIT-CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -0.25.LE.h.LT.0.75 BUT h.NE.0, AND ALL k. ' WRITE(*,*) ' LIMIT-CIRCLE, OSCILLATORY ' WRITE(*,*) ' FOR h.LT.-0.25 AND ALL k. ' WRITE(*,*) ' (Here, 1 has been added to q so that ' WRITE(*,*) ' at least some eigenvalues are positive.) ' WRITE(*,*) ' LIMIT POINT FOR h.GE.0.75 AND ALL k. ' MUMBER = 104 GO TO 40 C 14 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 3.0*(X-31.0)/(4.0*(X+1.0)*(4.0+X)**2), ' WRITE(*,*) ' w = 1 ' WRITE(*,*) WRITE(*,*) ' REGULAR AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 15 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = x*x, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 16 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-1,1) ' WRITE(*,*) WRITE(*,*) ' p = (1-x)**(alpha+1)*(1+x)**(beta+1), ' WRITE(*,*) ' q = 0, w = (1-x)**alpha*(1+x)**beta ' WRITE(*,*) ' (alpha, beta parameters) ' WRITE(*,*) WRITE(*,*) ' AT -1.0: ' WRITE(*,*) ' LIMIT POINT FOR beta.LE.-1. ' WRITE(*,*) ' WEAKLY REGULAR FOR -1.LT.beta.LT.0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.beta.LT.1. ' WRITE(*,*) ' LIMIT POINT FOR beta.GE.1. ' WRITE(*,*) ' AT +1.0: ' WRITE(*,*) ' LIMIT POINT FOR alpha.LE.-1. ' WRITE(*,*) ' WEAKLY REGULAR FOR -1.LT.alpha.LT.0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.alpha.LT.1. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.1. ' MUMBER = 105 GO TO 40 C 17 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 2/x**2 - 2000(2e-e*e), w = 1 ' WRITE(*,*) ' where e = exp(-1.7(x-1.3)) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 18 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-1,1) ' WRITE(*,*) WRITE(*,*) ' p = 1 - x*x, q = 2*alpha**2/(1+x) + 2*beta**2/(1-x),' WRITE(*,*) ' w = 1 (alpha, beta non-negative parameters) ' WRITE(*,*) WRITE(*,*) 'AT -1.0: ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.alpha.LT.0.5. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.0.5. ' WRITE(*,*) 'AT +1.0: ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.beta.LT.0.5. ' WRITE(*,*) ' LIMIT POINT FOR beta.GE.0.5. ' MUMBER = 106 GO TO 40 C 19 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-1,1) ' WRITE(*,*) WRITE(*,*) ' p = 1 - x*x, q = -2*gamma**2/(1+x) +2*beta**2/(1-x),' WRITE(*,*) ' w = 1 (gamma, beta parameters) ' WRITE(*,*) WRITE(*,*) 'AT -1.0: ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY FOR gamma = 0.' WRITE(*,*) ' LIMIT CIRCLE, OSCILLATORY FOR gamma.GT.0. ' WRITE(*,*) 'AT +1.0: ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.beta.LT.0.5. ' WRITE(*,*) ' LIMIT POINT FOR beta.GE.0.5. ' MUMBER = 107 GO TO 40 C 20 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 1 - (k**2+0.25)/x**2, w = 1 ' WRITE(*,*) ' (k a positive parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT CIRCLE, OSCILLATORY AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 108 GO TO 40 C 21 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 22 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = x**(alpha+1)*exp(-x), w = x**alpha*exp(-x) ' WRITE(*,*) ' q = 0 (alpha a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT FOR ALL alpha AT +INFINITY' WRITE(*,*) 'AT 0: ' WRITE(*,*) ' LIMIT POINT FOR alpha.LE.-1. ' WRITE(*,*) ' WEAKLY REGULAR FOR -1.LT.alpha.LT.0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.alpha.LT.1. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.1. ' MUMBER = 109 GO TO 40 C 23 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, w = 1 ' WRITE(*,*) ' q = (alpha**2-0.25)/x**2 - (alpha+1)/2 + x**2/16' WRITE(*,*) ' (alpha a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT FOR ALL alpha AT +INFINITY' WRITE(*,*) 'AT 0: ' WRITE(*,*) ' LIMIT POINT FOR alpha.LE.-1. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -1.LT.alpha.LT.1 BUT alpha**2.NE.0.25. ' WRITE(*,*) ' REGULAR FOR alpha**2 = 0.25. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.1. ' MUMBER = 110 GO TO 40 C 24 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-pi/2,pi/2) ' WRITE(*,*) WRITE(*,*) ' p = 1, w = 1 ' WRITE(*,*) ' q = (beta**2-0.25)/(4*tan((x+pi/2)/2)**2)+ ' WRITE(*,*) ' (alpha**2-0.25)/(4*tan((x-pi/2)/2)**2)- ' WRITE(*,*) ' (4*alpha*beta+4*alpha+4*beta+3)/8 ' WRITE(*,*) ' (alpha, beta parameters) ' WRITE(*,*) WRITE(*,*) 'AT -pi/2: ' WRITE(*,*) ' LIMIT POINT FOR beta.LE.-1. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -1.LT.beta.LT.1 BUT beta**2.NE.0.25.' WRITE(*,*) ' REGULAR FOR beta**2 = 0.25. ' WRITE(*,*) ' LIMIT POINT FOR beta.GE.1. ' WRITE(*,*) 'AT +pi/2: ' WRITE(*,*) ' LIMIT POINT FOR alpha.LE.-1. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -1.LT.alpha.LT.1 BUT alpha**2.NE.0.25.' WRITE(*,*) ' REGULAR FOR alpha**2 = 0.25. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.1. ' MUMBER = 111 GO TO 40 C 25 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0 ' WRITE(*,*) ' w = 1 when x.le.0. ' WRITE(*,*) ' = 9 when x.gt.0. ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 26 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = -1000*x, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 27 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0.25*exp(2*x) - k*exp(x), w = 1 ' WRITE(*,*) ' (k a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 112 GO TO 40 C 28 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = k*cos(x)**2, w = 1 ' WRITE(*,*) ' (k a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 113 GO TO 40 C 29 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0.25 + (k**2-1)/(4*x**2)), w = 1/x ' WRITE(*,*) ' (k a positive parameter .GE. 1) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 114 GO TO 40 C 40 CONTINUE WRITE(*,*) WRITE(*,*) ' IS THIS THE CORRECT DIFFERENTIAL EQUATION ? (Y/N) ' READ(*,9010) ANS IF (.NOT.(ANS.EQ.'y' .OR. ANS.EQ.'Y')) GO TO 30 IF (MUMBER.EQ.NUMBER) RETURN C C Now enter any parameters needed for these D.E.'s, or defaults. C MUMBER = MUMBER - 100 GO TO (41,42,43,44,45,46,47,48,49,50,51,52,53,54), MUMBER C 41 CONTINUE NU = 1.0 WRITE(*,*) ' Choose real parameter nu, nu = ' READ(*,*) NU RETURN C 42 CONTINUE K = 1.0 WRITE(*,*) ' Choose real parameter k.ne.0., k = ' READ(*,*) K RETURN C 43 CONTINUE K = 1.0 WRITE(*,*) ' Choose real parameter k = ' READ(*,*) K RETURN C 44 CONTINUE H = 1.0 K = 1.0 WRITE(*,*) ' Choose real parameters h,k = ' READ(*,*) H,K RETURN C 45 CONTINUE BETA = 0.1 ALPHA = 0.1 WRITE(*,*) ' Choose real parameters beta,alpha = ' READ(*,*) BETA,ALPHA RETURN C 46 CONTINUE ALPHA = 0.1 BETA = 0.1 WRITE(*,*) ' Choose real parameters alpha,beta = ' READ(*,*) ALPHA,BETA RETURN C 47 CONTINUE GAMMA = 0.1 BETA = 0.1 WRITE(*,*) ' Choose real parameters gamma,beta = ' READ(*,*) GAMMA,BETA RETURN C 48 CONTINUE K = 1.0 WRITE(*,*) ' Choose real parameter k.gt.0., k = ' READ(*,*) K RETURN C 49 CONTINUE ALPHA = 0.1 WRITE(*,*) ' Choose real parameter alpha = ' READ(*,*) ALPHA RETURN C 50 CONTINUE ALPHA = 0.1 WRITE(*,*) ' Choose real parameter alpha = ' READ(*,*) ALPHA RETURN C 51 CONTINUE BETA = 0.1 ALPHA = 0.1 WRITE(*,*) ' Choose real parameters beta,alpha = ' READ(*,*) BETA,ALPHA RETURN C 52 CONTINUE K = 0.1 WRITE(*,*) ' Choose real parameter k = ' READ(*,*) K RETURN C 53 CONTINUE K = 0.1 WRITE(*,*) ' Choose real parameter k = ' READ(*,*) K RETURN C 54 CONTINUE K = 0.1 WRITE(*,*) ' Choose real parameter k = ' READ(*,*) K RETURN END C DOUBLE PRECISION FUNCTION P(X) DOUBLE PRECISION X INTEGER NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE P = 1.0 - X*X RETURN C 2 CONTINUE P = 1.0 RETURN C 3 CONTINUE P = 1.0 RETURN C 4 CONTINUE P = 1.0 RETURN C 5 CONTINUE P = EXP(-2.0*(X*LOG(ABS(X))-X)) RETURN C 6 CONTINUE P = X RETURN C 7 CONTINUE P = X RETURN C 8 CONTINUE P = 1.0/X RETURN C 9 CONTINUE P = 1.0 - X**7 RETURN C 10 CONTINUE P = SQRT(X) RETURN C 11 CONTINUE P = 1.0 RETURN C 12 CONTINUE P = 1.0 RETURN C 13 CONTINUE P = 1.0 RETURN C 14 CONTINUE P = 1.0 RETURN C 15 CONTINUE P = 1.0 RETURN C 16 CONTINUE IF (ALPHA.NE.-1.0 .AND. BETA.NE.-1.0) THEN P = (1.0-X)**(ALPHA+1.0)*(1.0+X)**(BETA+1.0) ELSE IF (ALPHA.NE.-1.0 .AND. BETA.EQ.-1.0) THEN P = (1.0-X)**(ALPHA+1.0) ELSE IF (ALPHA.EQ.-1.0 .AND. BETA.NE.-1.0) THEN P = (1.0+X)**(BETA+1.0) ELSE P = 1.0 END IF RETURN C 17 CONTINUE P = 1.0 RETURN C 18 CONTINUE P = 1.0 - X*X RETURN C 19 CONTINUE P = 1.0 - X*X RETURN C 20 CONTINUE P = 1.0 RETURN C 21 CONTINUE P = 1.0 RETURN C 22 CONTINUE P = EXP(-X) IF (ALPHA.NE.-1.0) P = P*X**(ALPHA+1.0) RETURN C 23 CONTINUE P = 1.0 RETURN C 24 CONTINUE P = 1.0 RETURN C 25 CONTINUE P = 1.0 RETURN C 26 CONTINUE P = 1.0 RETURN C 27 CONTINUE P = 1.0 RETURN C 28 CONTINUE P = 1.0 RETURN C 29 CONTINUE P = 1.0 RETURN END C DOUBLE PRECISION FUNCTION Q(X) DOUBLE PRECISION X INTEGER NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA,E,HPI COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA c GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE Q = 0.25 RETURN C 2 CONTINUE Q = 0.0 IF (NU.NE.-0.5 .AND. NU.NE.0.5) Q = (NU*NU-0.25)/X**2 RETURN C 3 CONTINUE Q = 0.0 RETURN C 4 CONTINUE Q = -1.0/X RETURN C 5 CONTINUE Q = -EXP(-2.0*(X*LOG(ABS(X))-X))*LOG(ABS(X))**2 RETURN C 6 CONTINUE Q = -X RETURN C 7 CONTINUE Q = -1.0/X RETURN C 8 CONTINUE Q = K/X**2 + K**2/X RETURN C 9 CONTINUE Q = 0.0 RETURN C 10 CONTINUE Q = 0.0 RETURN C 11 CONTINUE Q = 100.0*COS(X)**2 RETURN C 12 CONTINUE Q = 2.0*K*COS(2.0*X) RETURN C 13 CONTINUE Q = K/X + H/(X*X) IF (H .LT. -0.25) Q = Q + 1.0 RETURN C 14 CONTINUE Q = 3.0*(X-31.0)/(4.0*(X+1.0)*(X+4.0)**2) RETURN C 15 CONTINUE Q = X*X RETURN C 16 CONTINUE Q = 0.0 RETURN C 17 CONTINUE L = 1.0 E = EXP(-1.7*(X-1.3)) Q = L*(L+1.0)/X**2 - 2000.0*E*(2.0-E) RETURN C 18 CONTINUE IF (ALPHA.NE.0.0 .AND. BETA.NE.0.0) THEN Q = 2.0*ALPHA**2/(1.0+X) + 2.0*BETA**2/(1.0-X) ELSE IF (ALPHA.EQ.0.0 .AND. BETA.NE.0.0) THEN Q = 2.0*BETA**2/(1.0-X) ELSE IF (ALPHA.NE.0.0 .AND. BETA.EQ.0.0) THEN Q = 2.0*ALPHA**2/(1.0+X) ELSE Q = 0.0 END IF RETURN C 19 CONTINUE Q = -2.0*GAMMA**2/(1.0+X) + 2.0*BETA**2/(1.0-X) RETURN C 20 CONTINUE Q = 1.0 - (K**2+0.25)/X**2 RETURN C 21 CONTINUE Q = 0.0 RETURN C 22 CONTINUE Q = 0.0 RETURN C 23 CONTINUE Q = -(ALPHA+1.0)/2.0 + X**2/16.0 IF (ALPHA.NE.0.5 .AND. ALPHA.NE.-0.5) Q = Q + (ALPHA**2-0.25)/X**2 RETURN C 24 CONTINUE HPI = 2.0*ATAN(1.0) IF (BETA*BETA.NE.0.25 .AND. ALPHA*ALPHA.NE.0.25) THEN Q = (BETA**2-0.25)/(4.0*TAN((X+HPI)/2.0)**2) + 1 (ALPHA**2-0.25)/(4.0*TAN((X-HPI)/2.0)**2) - 2 (ALPHA*BETA+ALPHA+BETA+0.75)/2.0 ELSE IF (BETA*BETA.EQ.0.25 .AND. ALPHA*ALPHA.NE.0.25) THEN Q = (ALPHA**2-0.25)/(4.0*TAN((X-HPI)/2.0)**2) - 1 (ALPHA*BETA+ALPHA+BETA+0.75)/2.0 ELSE IF (BETA*BETA.NE.0.25 .AND. ALPHA*ALPHA.EQ.0.25) THEN Q = (BETA**2-0.25)/(4.0*TAN((X+HPI)/2.0)**2) - 1 (ALPHA*BETA+ALPHA+BETA+0.75)/2.0 ELSE Q = -(ALPHA*BETA+ALPHA+BETA+0.75)/2.0 END IF RETURN C 25 CONTINUE Q = 0.0 RETURN C 26 CONTINUE Q = -1000.0*X RETURN C 27 CONTINUE E = EXP(X) Q = E*(0.25*E-K) RETURN C 28 CONTINUE Q = K*COS(X)**2 RETURN C 29 CONTINUE Q = 0.25 + (K**K-1.0)/(4.0*X**2) RETURN END C DOUBLE PRECISION FUNCTION W(X) DOUBLE PRECISION X INTEGER NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE W = 1.0 RETURN C 2 CONTINUE W = 1.0 RETURN C 3 CONTINUE W = 0.0 IF (X.NE.0.0) W = EXP(-2.0/X)/X**4 RETURN C 4 CONTINUE W = 1.0 RETURN C 5 CONTINUE W = EXP(-2.0*(X*LOG(ABS(X))-X)) RETURN C 6 CONTINUE W = 1.0/X RETURN C 7 CONTINUE W = 1.0 RETURN C 8 CONTINUE W = 1.0 RETURN C 9 CONTINUE W = X**7 RETURN C 10 CONTINUE W = 1.0/SQRT(X) RETURN C 11 CONTINUE W = 1.0 RETURN C 12 CONTINUE W = 1.0 RETURN C 13 CONTINUE W = 1.0 RETURN C 14 CONTINUE W = 1.0 RETURN C 15 CONTINUE W = 1.0 RETURN C 16 CONTINUE IF (ALPHA.NE.0.0 .AND. BETA.NE.0.0) THEN W = (1.0-X)**ALPHA*(1.0+X)**BETA ELSE IF (ALPHA.NE.0.0 .AND. BETA.EQ.0.0) THEN W = (1.0-X)**ALPHA ELSE IF (ALPHA.EQ.0.0 .AND. BETA.NE.0.0) THEN W = (1.0+X)**BETA ELSE W = 1.0 END IF RETURN C 17 CONTINUE W = 1.0 RETURN C 18 CONTINUE W = 1.0 RETURN C 19 CONTINUE W = 1.0 RETURN C 20 CONTINUE W = 1.0 RETURN C 21 CONTINUE W = 1.0 RETURN C 22 CONTINUE W = EXP(-X) IF (ALPHA.NE.0.0) W = W*(X**ALPHA) RETURN C 23 CONTINUE W = 1.0 RETURN C 24 CONTINUE W = 1.0 RETURN C 25 CONTINUE W = 9.0 IF (X.LE.0.0) W = 1.0 RETURN C 26 CONTINUE W = 1.0 RETURN C 27 CONTINUE W = 1.0 RETURN C 28 CONTINUE W = 1.0 RETURN C 29 CONTINUE W = 1.0/X RETURN END C SUBROUTINE UV(X,U,PUP,V,PVP,HU,HV) DOUBLE PRECISION X,U,PUP,V,PVP,HU,HV INTEGER NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA,E,TX,HPI,L2,SQ,C,S COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA DOUBLE PRECISION Q EXTERNAL Q C C HERE, HU MEANS -(pu')' + qu. C GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE U = 1.0 PUP = 0.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PVP = 1.0 HU = 0.25*U HV = 0.25*V RETURN C 2 CONTINUE IF (NU.NE.-0.5 .AND. NU.NE.0.5 .AND. NU.NE.0.0) THEN U = X**(NU+0.5) PUP = (NU+0.5)*X**(NU-0.5) V = X**(-NU+0.5) PVP = (-NU+0.5)*X**(-NU-0.5) ELSE IF (NU.EQ.-0.5) THEN U = X PUP = 1.0 V = 1.0 PVP = 0.0 ELSE IF (NU.EQ.0.5) THEN U = X PUP = 1.0 V = -1.0 PVP = 0.0 ELSE IF (NU.EQ.0.0) THEN U = SQRT(X) PUP = 0.5/U V = U*LOG(X) PVP = (0.5*LOG(X)+1.0)/U END IF HU = 0.0 HV = 0.0 RETURN C 3 CONTINUE U = 1.0 V = X PUP = 0.0 PVP = 1.0 HU = 0.0 HV = 0.0 RETURN C 4 CONTINUE TX = LOG(ABS(X)) U = X PUP = 1.0 V = 1.0 - X*TX PVP = -1.0 - TX HU = -1.0 HV = TX RETURN C 5 CONTINUE RETURN C 6 CONTINUE U = (COS(X)+SIN(X))/SQRT(X) V = (COS(X)-SIN(X))/SQRT(X) PUP = -0.5*U + X*V PVP = -0.5*V - X*U HU = -0.25*U/X HV = -0.25*V/X RETURN C 7 CONTINUE TX = LOG(ABS(X)) U = COS(TX) V = SIN(TX) PUP = -V PVP = U HU = 0.0 HV = 0.0 RETURN C 8 CONTINUE V = X - 1.0/K U = X*X PVP = 1.0/X PUP = 2.0 HU = K + X*K**2 HV = K**2 RETURN C 9 CONTINUE U = 1.0 V = -LOG(1.0-X) PUP = 0.0 PVP = (((((X+1.0)*X+1.0)*X+1.0)*X+1.0)*X+1.0)*X+1.0 HU = 0.0 HV = -(((((6.0*X+5.0)*X+4.0)*X+3.0)*X+2.0)*X+1.0) RETURN C 10 CONTINUE U = 2.0*SQRT(X) V = 1.0 PUP = 1.0 PVP = 0.0 HU = 0.0 HV = 0.0 RETURN C 11 CONTINUE RETURN C 12 CONTINUE RETURN C 13 CONTINUE IF (H .GT. -0.25) THEN L = SQRT(H+0.25) IF (H.EQ.0.0) THEN U = X V = 1.0 + K*X*LOG(X) PUP = 1.0 PVP = K*(1.0+LOG(X)) HU = K HV = K*K*LOG(X) ELSE U = X**(0.5+L) V = X**(0.5-L) + (K/(1.0-2.0*L))*X**(1.5-L) PUP = (0.5+L)*X**(L-0.5) PVP = (0.5-L)*X**(-L-0.5) + K*(1.5-L)/(1.0-2.0*L)*X**(0.5-L) HU = K*X**(L-0.5) HV = K**2/(1.0-2.0*L)*X**(0.5-L) END IF ELSE IF (H .LT. -0.25) THEN L2 = -(H+0.25) L = SQRT(L2) C = COS(L*LOG(X)) S = SIN(L*LOG(X)) SQ = SQRT(X) U = SQ*((1.-0.25*K*X/H)*C + 0.5*K*L*X*S) V = SQ*((1.-0.25*K*X/H)*S + 0.5*K*L*X*C) PUP = (0.5*C - L*S)/SQ - 0.5*K*SQ*((0.5-H)*C + L*S)/H PVP = (0.5*S + L*C)/SQ + 0.5*K*SQ*((H-0.5)*S + L*C)/H HU = 0.5*K*K*SQ*((H+0.5)*C + L*S)/(H*H) + U HV = 0.5*K*K*SQ*((H+0.5)*S - L*C)/(H*H) + V ELSE IF (H .EQ. -0.25) THEN SQ = SQRT(X) U = SQ + K*X*SQ V = 2.0*SQ + (SQ + K*X*SQ)*LOG(X) PUP = 0.5*(1.0/SQ + 3.*K*SQ) PVP = 2.0/SQ + K*SQ + 0.5*(1.0/SQ + 3.0*K*SQ)*LOG(X) HU = K*K*SQ HV = K*K*SQ*LOG(X) ENDIF RETURN C 14 CONTINUE RETURN C 15 CONTINUE RETURN C 16 CONTINUE IF (X.LT.0.0) THEN IF (BETA.GT.-1.0 .AND. BETA.LT.0.0) THEN U = (1.0+X)**(-BETA) V = 1.0 IF (ALPHA.NE.-1.0) THEN PUP = -BETA*(1.0-X)**(ALPHA+1.0) HU = -BETA*(ALPHA+1.0)*(1.0-X)**ALPHA ELSE PUP = -BETA HU = 0.0 END IF PVP = 0.0 HV = 0.0 ELSE IF (BETA.EQ.0.0) THEN U = 1.0 V = LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 2.0*(1.0-X)**ALPHA HU = 0.0 HV = 2.0*ALPHA*(1.0-X)**(ALPHA-1.0) ELSE IF (BETA.GT.0.0 .AND. BETA.LT.1.0) THEN U = 1.0 V = (1.0+X)**(-BETA) PUP = 0.0 IF (ALPHA.NE.-1.0) THEN PVP = -BETA*(1.0-X)**(ALPHA+1.0) HV = -BETA*(ALPHA+1.0)*(1.0-X)**ALPHA ELSE PVP = -BETA HV = 0.0 END IF HU = 0.0 END IF ELSE IF (X.GE.0.0) THEN IF (ALPHA.GT.-1.0 .AND. ALPHA.LT.0.0) THEN U = (1.0-X)**(-ALPHA) V = 1.0 IF (BETA.NE.-1.0) THEN PUP = ALPHA*(1.0+X)**(BETA+1.0) HU = -ALPHA*(BETA+1.0)*(1.0+X)**BETA ELSE PUP = ALPHA HU = 0.0 END IF PVP = 0.0 HV = 0.0 ELSE IF (ALPHA.EQ.0.0) THEN U = 1.0 V = LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 2.0*(1.0+X)**BETA HU = 0.0 HV = -2.0*BETA*(1.0+X)**(BETA-1.0) ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.1.0) THEN U = 1.0 V = (1.0-X)**(-ALPHA) PUP = 0.0 HU = 0.0 IF (BETA.NE.-1.0) THEN PVP = ALPHA*(1.0+X)**(BETA+1.0) HV = -ALPHA*(BETA+1.0)*(1.0+X)**BETA ELSE PVP = ALPHA HV = 0.0 END IF END IF END IF RETURN C 17 CONTINUE RETURN C 18 CONTINUE IF (X.LT.0.0) THEN IF (ALPHA.EQ.0.0) THEN U = 1.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 1.0 HU = Q(X) HV = Q(X)*V ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.0.5) THEN U = (1.0+X)**ALPHA V = (1.0+X)**(-ALPHA) PUP = ALPHA*(1.0-X)*U PVP = -ALPHA*(1.0-X)*V HU = ALPHA*(ALPHA+1.0)*U + 2.0*BETA**2*U/(1.0-X) HV = ALPHA*(ALPHA-1.0)*V + 2.0*BETA**2*V/(1.0-X) ELSE END IF ELSE IF (X.GE.0.0) THEN IF (BETA.EQ.0.0) THEN U = 1.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 1.0 HU = Q(X) HV = Q(X)*V ELSE IF (BETA.GT.0.0 .AND. BETA.LT.0.5) THEN U = (1.0-X)**BETA V = (1.0-X)**(-BETA) PUP = -BETA*(1.0+X)*U PVP = BETA*(1.0+X)*V HU = BETA*(BETA+1.0)*U + 2.0*ALPHA**2*U/(1.0+X) HV = BETA*(BETA-1.0)*V + 2.0*ALPHA**2*V/(1.0+X) ELSE END IF END IF RETURN C 19 CONTINUE IF (X.LT.0.0) THEN IF (GAMMA.EQ.0.0) THEN U = 1.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 1.0 HU = Q(X)*U HV = Q(X)*V ELSE U = COS(GAMMA*LOG(1.0+X)) V = SIN(GAMMA*LOG(1.0+X)) PUP = -GAMMA*(1.0-X)*V PVP = GAMMA*(1.0-X)*U HU = -GAMMA**2*U - GAMMA*V + 2.0*BETA**2*U/(1.0-X) HV = -GAMMA**2*V + GAMMA*U + 2.0*BETA**2*V/(1.0-X) END IF ELSE IF (X.GE.0.0) THEN IF (BETA.EQ.0.0) THEN U = 1.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 1.0 HU = Q(X)*U HV = Q(X)*V ELSE IF (BETA.GT.0.0 .AND. BETA.LT.0.5) THEN U = (1.0-X)**BETA V = (1.0-X)**(-BETA) PUP = -BETA*(1.0+X)*U PVP = BETA*(1.0+X)*V HU = BETA*(BETA+1.0)*U - 2.0*GAMMA**2*U/(1.0+X) HV = BETA*(BETA-1.0)*V - 2.0*GAMMA**2*V/(1.0+X) ELSE END IF END IF RETURN C 20 CONTINUE U = SQRT(X)*COS(K*LOG(X)) V = SQRT(X)*SIN(K*LOG(X)) PUP = 0.5*U/X - K*V/X PVP = 0.5*V/X + K*U/X HU = U HV = V RETURN C 21 CONTINUE RETURN C 22 CONTINUE E = EXP(-X) IF (ALPHA.GT.-1.0 .AND. ALPHA.LT.0.0) THEN U = X**(-ALPHA) V = 1.0 PUP = -ALPHA*E PVP = 0.0 HU = -ALPHA*E HV = 0.0 ELSE IF (ALPHA.EQ.0.0) THEN U = 1.0 V = LOG(X) PUP = 0.0 PVP = E HU = 0.0 HV = E ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.1.0) THEN U = 1.0 V = X**(-ALPHA) PUP = 0.0 PVP = -ALPHA*E HU = 0.0 HV = -ALPHA*E ELSE END IF RETURN C 23 CONTINUE IF (ALPHA.GT.-1.0 .AND. ALPHA.LT.0.0) THEN IF (ALPHA.NE.-0.5) THEN U = X**(0.5-ALPHA) V = X**(0.5+ALPHA) PUP = (0.5-ALPHA)*X**(-0.5-ALPHA) PVP = (0.5+ALPHA)*X**(-0.5+ALPHA) ELSE U = X V = 1.0 PUP = 1.0 PVP = 0.0 END IF TX = X**2/16.0-(ALPHA+1.0)/2.0 HU = TX*U HV = TX*V ELSE IF (ALPHA.EQ.0.0) THEN U = SQRT(X) V = U*LOG(X) PUP = 0.5/U PVP = (1.0+0.5*LOG(X))/U HU = (X**2/16.0-0.5)*U HV = (X**2/16.0-0.5)*V ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.1.0) THEN IF (ALPHA.NE.0.5) THEN U = X**(0.5+ALPHA) V = X**(0.5-ALPHA) PUP = (0.5+ALPHA)*X**(-0.5+ALPHA) PVP = (0.5-ALPHA)*X**(-0.5-ALPHA) ELSE U = X V = 1.0 PUP = 1.0 PVP = 0.0 END IF TX = X**2/16.0-(ALPHA+1.0)/2.0 HU = TX*U HV = TX*V ELSE END IF RETURN C 24 CONTINUE HPI = 2.0*ATAN(1.0) IF (X.GE.0.0) THEN IF (ALPHA.GT.-1.0 .AND. ALPHA.LT.0.0) THEN U = (HPI-X)**(0.5-ALPHA) V = (HPI-X)**(0.5+ALPHA) PUP = -(0.5-ALPHA)*(HPI-X)**(-0.5-ALPHA) PVP = -(0.5+ALPHA)*(HPI-X)**(-0.5+ALPHA) HU = (0.25-ALPHA**2)*(HPI-X)**(-1.5-ALPHA) + Q(X)*U HV = (0.25-ALPHA**2)*(HPI-X)**(-1.5+ALPHA) + Q(X)*V ELSE IF (ALPHA.EQ.0.0) THEN U = SQRT(HPI-X) V = U*LOG(HPI-X) PUP = -0.5/U PVP = -(1.0+0.5*LOG(HPI-X))/U HU = 0.25/((HPI-X)*U) + Q(X)*U HV = 0.25*LOG(HPI-X)/((HPI-X)*U) + Q(X)*V ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.1.0) THEN U = (HPI-X)**(0.5+ALPHA) V = (HPI-X)**(0.5-ALPHA) PUP = -(0.5+ALPHA)*(HPI-X)**(-0.5+ALPHA) PVP = -(0.5-ALPHA)*(HPI-X)**(-0.5-ALPHA) HU = (0.25-ALPHA**2)*(HPI-X)**(-1.5+ALPHA) + Q(X)*U HV = (0.25-ALPHA**2)*(HPI-X)**(-1.5-ALPHA) + Q(X)*V END IF ELSE IF (BETA.GT.-1.0 .AND. BETA.LT.0.0) THEN U = (HPI+X)**(0.5-BETA) V = (HPI+X)**(0.5+BETA) PUP = (0.5-BETA)*(HPI+X)**(-0.5-BETA) PVP = (0.5+BETA)*(HPI+X)**(-0.5+BETA) HU = (0.25-BETA**2)*(HPI+X)**(-1.5-BETA) + Q(X)*U HV = (0.25-BETA**2)*(HPI+X)**(-1.5+BETA) + Q(X)*V ELSE IF (BETA.EQ.0.0) THEN U = SQRT(HPI+X) V = U*LOG(HPI+X) PUP = 0.5/U PVP = (1.0+0.5*LOG(HPI+X))/U HU = 0.25/((HPI+X)*U) + Q(X)*U HV = 0.25*LOG(HPI+X)/((HPI+X)*U) + Q(X)*V ELSE IF (BETA.GT.0.0 .AND. BETA.LT.1.0) THEN U = (HPI+X)**(0.5+BETA) V = (HPI+X)**(0.5-BETA) PUP = (0.5+BETA)*(HPI+X)**(-0.5+BETA) PVP = (0.5-BETA)*(HPI+X)**(-0.5-BETA) HU = (0.25-BETA**2)*(HPI+X)**(-1.5+BETA) + Q(X)*U HV = (0.25-BETA**2)*(HPI+X)**(-1.5-BETA) + Q(X)*V END IF END IF RETURN C 25 CONTINUE RETURN C 26 CONTINUE RETURN C 27 CONTINUE RETURN C 28 CONTINUE RETURN C 29 CONTINUE RETURN END SHAR_EOF fi # end of overwriting check cd .. if test -f 'bsample.lnk' then echo shar: will not over-write existing file "'bsample.lnk'" else cat << SHAR_EOF > 'bsample.lnk' *Make SAMPLE.EXE using the object files listed *and also the DLLs for the solvers: * SLEDGE * SLEIGN * SL02F * SLEIGN2 lo sldriver lo slutil lo solvrs lo dbmod lo slconsts lo sltstvar lo slpset lo sltstpak lo batchio lo ..\probsets\sample file bsample.exe SHAR_EOF fi # end of overwriting check if test -f 'bstandrd.lnk' then echo shar: will not over-write existing file "'bstandrd.lnk'" else cat << SHAR_EOF > 'bstandrd.lnk' *Make bstandrd.EXE using the object files listed *and also the DLLs for the solvers: * SLEDGE * SLEIGN * SL02F * SLEIGN2 lo sldriver lo slutil lo solvrs lo dbmod lo slconsts lo sltstvar lo slpset lo sltstpak lo batchio lo ..\probsets\standard file bstandrd.exe SHAR_EOF fi # end of overwriting check if test -f 'd02kef.doc' then echo shar: will not over-write existing file "'d02kef.doc'" else cat << SHAR_EOF > 'd02kef.doc' IMPORTANT: For a complete specification of the routine see the NAG Fortran Library Handbook. Terms marked //...// may be implementation dependent. A. Purpose //D02KEF// finds a specified eigenvalue of a regular singular second-order Sturm-Liouville system of the form (p(x)y')' + Q(x;lambda)y = 0 on a finite or infinite range (a,b) with boundary conditions at a and b, using a Pruefer transformation and a shooting method. It also reports values of the eigenfunction and its derivatives. Provision is made for discontinuities in the coefficient functions or their derivatives. B. Specification SUBROUTINE //D02KEF//(XPOINT, M, MATCH, COEFFN, BDYVAL, K, 1 TOL, ELAM, DELAM, HMAX, MAXIT, MAXFUN, 2 MONIT, REPORT, IFAIL) INTEGER NXP, IC1, K, MAXIT, MAXFUN, IFAIL //real// XPOINT(M), TOL, ELAM, DELAM, HMAX(2,M) EXTERNAL COEFFN, BDYVAL, MONIT, REPORT C. Parameters 1: XPOINT(M) - //real// array. Input On entry: the points where the boundary conditions computed by BDYVAL are to be imposed, and also any break-points, i.e. XPOINT(1) to XPOINT(m) must contain values x(1),...,x(m) such that x(1) <= x(2) < x(3) < ... < x(m-1) <= x(m) with the following meanings: (a) x(1) and x(m) are the left and right end-points, a and b, of the domain of definition of the Sturm-Liouville system if these are finite. If either a or b is infinite, the corresponding value x(1) or x(m) may be a more-or-less arbitrarily `large' number of appropriate sign. (b) x(2) and x(m-1) are the Boundary Matching Points (BMP's), that is the points at which the left and right boundary conditions computed in BDYVAL are imposed. If the left-hand end-point is a regular point then the user should set x(2) = x(1) (= a), while if it is a singular point the user must set x(2) > x(1). Similarly x(m-1) = x(m) (= b) if the right-hand end-point is regular, and x(m-1) < x(m) if it is singular. (c) The remaining m - 4 points x(3),...,x(m-2), if any, define `break-points' which divide the interval [x(2),x(m-1)] into m - 3 sub-intervals i(1) = [x(2),x(3)], ..., i(m-3) = [x(m-2),x(m-1)] Numerical integration of the differential equation is stopped and restarted at each break-point. In simple cases no break-points are needed. However if p(x) or q(x;lambda) are given by different formulae in different parts of the range, then integration is more efficient if the range is broken up by break-points in the appropriate way. Similarly points where any jumps occur in p(x) or q(x;lambda), or in their derivatives up to the fifth order, should appear as break-points. Constraint: X(1) <= X(2) < ... < X(M-1) <= X(M). 2: M - INTEGER. Input On entry: the number of points in the array XPOINT. Constraint: M >= 4. 3: MATCH - INTEGER. Input/Output On entry: MATCH must be set to the index of the `break-point' to be used as the matching point (see Section 8.3 of the routine document in the NAG Fortran Library Manual). If MATCH is set to a value outside the range [2,m-1] then a default value is taken, corresponding to the break-point nearest the centre of the interval [XPOINT(2),XPOINT(m-1)]. On exit: the index of the break-point actually used as the matching point. 4: COEFFN - SUBROUTINE, supplied by the user. External Procedure COEFFN must compute the values of the coefficient functions p(x) and q(x;lambda) for given values of x and lambda. Section 3 of the routine document in the NAG Fortran Library Manual states conditions which p and q must satisfy. Its specification is: | SUBROUTINE COEFFN(P, Q, DQDL, X, ELAM, JINT) | //real// P, Q, DQDL, X, ELAM | INTEGER JINT | 1: P - //real//. Output | On exit: the value of p(x) for the current value of x. | 2: Q - //real//. Output | On exit: the value of q(x;lambda) for the current value of x | and the current trial value of lambda. | 3: DQDL - //real//. Output | On exit: the value of (pd q)/(pd lambda)(x;lambda) for the | current value of x and the current trial value of lambda. | However DQDL is only used in error estimation and an | approximation (say to within 20%) will suffice. | 4: X - //real//. Input | On entry: the current value of x. | 5: ELAM - //real//. Input | On entry: the current trial value of the eigenvalue parameter | lambda. | 6: JINT - INTEGER. Input | On entry: the index j of the sub-interval i(j) (see | specification of XPOINT) in which x lies. | See Sections 8.4 and 9 of the routine document in the NAG | Fortran Library Manual for examples. COEFFN must be declared as | EXTERNAL in the (sub)program from which //D02KEF// is called. | Parameters denoted as Input must **not** be changed by this | procedure. 5: BDYVAL - SUBROUTINE, supplied by the user. External Procedure BDYVAL must define the boundary conditions. For each end-point, BDYVAL must return (in YL or YR) values of y(x) and p(x)y'(x) which are consistent with the boundary conditions at the end-points; only the ratio of the values matters. Here x is a given point (XL or XR) equal to, or close to, the end-point. For a **regular** end-point (a, say), x = a; and a boundary condition of the form c(1)y(a) + c(2)y'(a) = 0 can be handled by returning constant values in YL, e.g. YL(1) = c(2) and YL(2) = -c(1)p(a). For a **singular** end-point however, YL(1) and YL(2) will in general be functions of XL and ELAM, and YR(1) and YR(2) functions of XR and ELAM, usually derived analytically from a power-series or asymptotic expansion. Examples are given in Sections 8.5 and 9 of the routine document in the NAG Fortran Library Manual. Its specification is: | SUBROUTINE BDYVAL(XL, XR, ELAM, YL, YR) | //real// XL, XR, ELAM, YL(3), YR(3) | 1: XL - //real//. Input | On entry: if a is a regular end-point of the system (so that | a = x(1) = x(2)), then XL contains a. If a is a singular | point (so that a <= x(1) < x(2)), then XL contains a point x | such that x(1) < x <= x(2)). | 2: XR - //real//. Input | On entry: if b is a regular end-point of the system (so that | x(m-1) = x(m) = b), then XR contains b. If b is a singular | point (so that x(m-1) < x(m) <= b), then XR contains a point | x such that x(m-1) <= x < x(m). | 3: ELAM - //real//. Input | On entry: the current trial value of lambda. | 4: YL(3) - //real// array. Output | On exit: YL(1) and YL(2) should contain values of y(x) and | p(x)y'(x) respectively (not both zero) which are consistent | with the boundary condition at the left-hand end-point, given | by x = XL. YL(3) should not be set. | 5: YR(3) - //real// array. Output | On exit: YR(1) and YR(2) should contain values of y(x) and | p(x)y'(x) respectively (not both zero) which are consistent | with the boundary condition at the right-hand end-point, | given by x = XR. YR(3) should not be set. | BDYVAL must be declared as EXTERNAL in the (sub)program from | which //D02KEF// is called. Parameters denoted as Input must | **not** be changed by this procedure. 6: K - INTEGER. Input On entry: the index k of the required eigenvalue when the eigenvalues are ordered lambda(0) < lambda (1) < lambda(2) < ... < lambda(k) < ... . Constraint: K >= 0. 7: TOL - //real//. Input On entry: the tolerance parameter which determines the accuracy of the computed eigenvalue. The error estimate held in DELAM on exit satisfies the mixed absolute/relative error test DELAM <= TOL*max(1.0,abs(ELAM)) (*) where ELAM is the final estimate of the eigenvalue. DELAM is usually somewhat smaller than the right-hand side of (*) but not several orders of magnitude smaller. Constraint: TOL > 0.0. 8: ELAM - //real//. Input/Output On entry: an initial estimate of the eigenvalue lambda-tilde. On exit: the final computed estimate, whether or not an error occurred. 9: DELAM - //real//. Input/Output On entry: an indication of the scale of the problem in the lambda-direction. DELAM holds the initial `search step' (positive or negative). Its value is not critical but the first two trial evaluations are made at ELAM and ELAM + DELAM, so the routine will work most efficiently if the eigenvalue lies between these values. A reasonable choice (if a closer bound is not known) is half the distance between adjacent eigenvalues in the neighbourhood of the one sought. In practice, there will often be a problem, similar to the one in hand but with known eigenvalues, which will help one to choose initial values for ELAM and DELAM. If DELAM = 0.0 on entry, it is given the default value of 0.25*max(1.0,abs(ELAM)). On exit: with IFAIL = 0, DELAM holds an estimate of the absolute error in the computed eigenvalue, that is abs(lambda-tilde-ELAM) approximately equal to DELAM. (In Section 8.2 of the routine document in the NAG Fortran Library Manual we discuss the assumptions under which this is true.) The true error is rarely more than twice, or less than a tenth, of the estimated error. With IFAIL <> 0, DELAM may hold an estimate of the error, or its initial value, depending on the value of IFAIL. See Section D for further details. 10: HMAX(2,M) - //real// array. Input/Output On entry: HMAX(1,j) a maximum step size to be used by the differential equation code in the jth sub-interval i(j) (as described in the specification of parameter XPOINT), for j = 1,2,...,m-3. If it is zero the routine generates a maximum step size internally. It is recommended that HMAX(1,j) be set to zero unless the coefficient functions p and q have features (such as a narrow peak) within the jth sub-interval that could be `missed' if a long step were taken. In such a case HMAX(1,j) should be set to about half the distance over which the feature should be observed. Too small a value will increase the computing time for the routine. See Section 8 of the routine document in the NAG Fortran Library Manual for further suggestions. The rest of the array is used as workspace. On exit: HMAX(1,m-1) and HMAX(1,m) contain the sensitivity coefficients sigma(l),sigma(r), described in Section 8.6 of the routine document in the NAG Fortran Library Manual. Other entries contain diagnostic output in case of an error (see Section D). 11: MAXIT - INTEGER. Input/Output On entry: a bound on n(r), the number of root-finding iterations allowed, that is the number of trial values of lambda that are used. If MAXIT <= 0, no such bound is assumed. (See also under MAXFUN.) Suggested value: MAXIT = 0. On exit: MAXIT will have been decreased by the number of iterations actually performed, whether or not it was positive on entry. 12: MAXFUN - INTEGER. Input On entry: a bound on n(f), the number of calls to COEFFN made in any one root-finding iteration. If MAXFUN <= 0, no such bound is assumed. Suggested value: MAXFUN = 0. MAXFUN and MAXIT may be used to limit the computational cost of a call to //D02KEF//, which is roughly proportional to n(r)*n(f). 13: MONIT - SUBROUTINE, supplied by the user. External Procedure MONIT is called by //D02KEF// at the end of each root-finding iteration and allows the user to monitor the course of the computation by printing out the parameters (see Section 8 of the routine document in the NAG Fortran Library Manual for an example). If no monitoring is required, the dummy subroutine D02KAY may be used. (D02KAY is included in the NAG Fortran Library. In some implementations of the Library the name is changed to KAYD02: refer to the Users' Note for your implementation.) Its specification is: | SUBROUTINE MONIT(MAXIT, IFLAG, ELAM, FINFO) | INTEGER MAXIT, IFLAG | //real// ELAM, FINFO(15) | 1: MAXIT - INTEGER. Input | On entry: the current value of the parameter MAXIT of | //D02KEF//; this is decreased by one at each iteration. | 2: IFLAG - INTEGER. Input | On entry: IFLAG describes what phase the computation is in, | as follows: | IFLAG < 0 | an error occurred in the computation of the `miss-distance' | at this iteration; an error exit from //D02KEF// with | IFAIL = -IFLAG will follow. | IFLAG = 1 | the routine is trying to bracket the eigenvalue | lambda-tilde. | IFLAG = 2 | the routine is converging to the eigenvalue lambda-tilde | (having already bracketed it). | 3: ELAM - //real//. Input | On entry: the current trial value of lambda. | 4: FINFO(15) - //real// array. Input | On entry: information about the behaviour of the shooting | method, and diagnostic information in the case of errors. It | should **not** normally be printed in full if no error has | occurred (that is, if IFLAG > 0), though the first few | components may be of interest to the user. In case of an | error (IFLAG < 0) all the components of FINFO should be | printed. The contents of FINFO are as follows: | FINFO(1): the current value of the `miss-distance' or | `residual' function f(lambda) on which the shooting method is | based. (See Section 8.2 of the routine document in the NAG | Fortran Library Manual for further notes on it.) FINFO(1) is | set to zero if IFLAG < 0. | FINFO(2): an estimate of the quantity | partial derivative(lambda) defined as follows. Consider the | perturbation in the miss-distance f(lambda) that would result | if the local error, in the solution of the differential | equation, were always positive and equal to its maximum | permitted value. Then partial derivative(lambda) is the | perturbation in lambda that would have the same effect on | f(lambda). Thus, at the zero of | f(lambda),abs(partial derivative(lambda)) is an approximate | bound on the perturbation of the zero (that is the | eigenvalue) caused by errors in numerical solution. If | partial derivative(lambda) is very large then it is possible | that there has been a programming error in COEFFN such that q | is independent of lambda. If this is the case, an error exit | with IFAIL = 5 should follow. FINFO(2) is set to zero if | IFLAG < 0. | FINFO(3): the number of internal iterations, using the same | value of lambda and tighter accuracy tolerances, needed to | bring the accuracy (that is the value of | partial derivative(lambda)) to an acceptable value. Its value | should normally be 1.0, and should almost never exceed 2.0. | FINFO(4): the number of calls to COEFFN at this iteration. | FINFO(5): the number of successful steps taken by the | internal differential equation solver at this iteration. A | step is successful if it is used to advance the integration | (cf. COUT(8) in specification of //D02PAF//). | FINFO(6): the number of unsuccessful steps used by the | internal integrator at this iteration (cf. COUT(9) in | specification of //D02PAF//). | FINFO(7): the number of successful steps at the maximum step | size taken by the internal integrator at this iteration (cf. | COUT(3) in specification of //D02PAF//). | FINFO(8): is not used. | FINFO(9) to FINFO(15): set to zero, unless IFLAG < 0 in which | case they hold the following values describing the point of | failure: | FINFO(9): contains the index of the sub-interval where | failure occurred, in the range 1 to m - 3. In case of an | error in BDYVAL, it is set to 0 or m - 2 depending on whether | the left or right boundary condition caused the error. | FINFO(10): the value f the independent variable x, the point | at which error occurred. In case of an error in BDYVAL, it is | set to the value of XL or XR as appropriate (see the | specification of BDYVAL). | FINFO(11), FINFO(12), FINFO(13): the current values of the | Pruefer dependent variables beta, phi and rho respectively. | These are set to zero in case of an error in BDYVAL. | FINFO(14): the local-error tolerance being used by the | internal integrator at the point of failure. This is set to | zero in the case of an error in BDYVAL. | FINFO(15): the last integration mesh point. This is set to | zero in the case of an error in BDYVAL. | MONIT must be declared as EXTERNAL in the (sub)program from | which //D02KEF// is called. Parameters denoted as Input must | **not** be changed by this procedure. 14: REPORT - SUBROUTINE, supplied by the user. External Procedure This routine provides the means by which the user may compute the eigenfunction y(x) and its derivative at each integration mesh point x. (See Section 8 of the routine document in the NAG Fortran Library Manual for an example). Its specification is: | SUBROUTINE REPORT (X, V, JINT) | INTEGER JINT | //real// X, V(3) | 1: X - //real//. Input | On entry: the current value of the independent variable x. | See Section 8.3 of the routine document in the NAG Fortran | Library Manual for the order in which values of x are | supplied. | 2: V(3) - //real// array. Input | On entry: V(1), V(2), V(3) hold the current values of the | Pruefer variables beta, phi, rho respectively. | 3: JINT - INTEGER. Input | On entry: JINT indicates the sub-interval between | break-points in which X lies exactly as for the routine | COEFFN, **except** that at the extreme left end-point (when | x = XPOINT(2)) JINT is set to 0 and at the extreme right | end-point (when x = x(r) = XPOINT(m-1)) JINT is set to m - 2. | REPORT must be declared as EXTERNAL in the (sub)program from | which //D02KEF// is called. Parameters denoted as Input must | **not** be changed by this procedure. 15: IFAIL - INTEGER. Input/Output On entry: IFAIL must be set to 0, -1 or 1. For users not familiar with this parameter (described in Chapter P01 in the NAG Fortran Library Manual or this HELP system) the recommended value is 0. On exit: IFAIL = 0 unless the routine detects an error (see Section D). D. Error Indicators and Warnings Errors detected by the routine: IFAIL = 1 A parameter error. All parameters (except IFAIL) are left unchanged. The reason for the error is shown by the value of HMAX(2,1) as follows: HMAX(2,1) = 1: M < 4; HMAX(2,1) = 2: K < 0; HMAX(2,1) = 3: TOL <= 0.0; HMAX(2,1) = 4: XPOINT(1) to XPOINT(m) are not in ascending order. HMAX(2,2) gives the position i in XPOINT where this was detected. IFAIL = 2 At some call to BDYVAL, invalid values were returned, that is, either YL(1) = YL(2) = 0.0, or YR(1) = YR(2) = 0.0 (a programming error in BDYVAL). See the last call of MONIT for details. This error exit will also occur if p(x) is zero at the point where the boundary condition is imposed. Probably BDYVAL was called with XL equal to a singular end-point a or with XR equal to a singular end-point b. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 3 At some point between XL and XR the value of p(x) computed by COEFFN became zero or changed sign. See the last call of MONIT for details. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 4 MAXIT > 0 on entry, and after MAXIT iterations the eigenvalue had not been found to the required accuracy. IFAIL = 5 The `bracketing' phase (with parameter IFLAG of MONIT equal to 1) failed to bracket the eigenvalue within ten iterations. This is caused by an error in formulating the problem (for example, q is independent of lambda), or by very poor initial estimates of ELAM, DELAM. On exit ELAM and ELAM + DELAM give the end-points of the interval within which no eigenvalue was located by the routine. IFAIL = 6 MAXFUN > 0 on entry, and the last iteration was terminated because more than MAXFUN calls to COEFFN were used. See the last call of MONIT for details. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 7 To obtain the desired accuracy the local error tolerance was set so small at the start of some sub-interval that the differential equation solver could not choose an initial step size large enough to make significant progress. See the last call of MONIT for diagnostics. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 8 At some point inside a sub-interval the step size in the differenital equation solver was reduced to a value too small to make significant progress (for the same reasons as with IFAIL = 7). This could be due to pathological behaviour of p(x) and q(x;lambda) or to an unreasonable accuracy requirement or to the current value of lambda making the equations `stiff'. See the last call of MONIT for details. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 9 TOL is too small for the problem being solved and the //machine precision// is being used. The final value of ELAM should be a very good approximation to the eigenvalue. IFAIL = 10 //C05AZF//, called by //D02KEF//, has terminated with the error exit corresponding to a pole of the residual function f(lambda). This error exit should not occur, but if it does, try solving the problem again with a smaller value for TOL. IFAIL = 11 A serious error has occurred in D02KDY. Check all subroutine calls and array dimensions. Seek expert help. HMAX(2,1) holds the failure exit number from D02KDY. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 12 A serious error has occurred in //C05AZF//. Check all subroutine calls and array dimensions. Seek expert help. HMAX(2,1) holds the failure exit number from C05AZF. HMAX(2,2) holds the value of parameter IND of //C05AZF//. SHAR_EOF fi # end of overwriting check if test -f 'd02kef.lnk' then echo shar: will not over-write existing file "'d02kef.lnk'" else cat << SHAR_EOF > 'd02kef.lnk' *Form DLL for D02KEF *None of its subordinate routines are to be visible from outside liboffset 41000000 suppress lo d02kef entry d02kef file d02kef.lib SHAR_EOF fi # end of overwriting check if test -f 'evsimp.lnk' then echo shar: will not over-write existing file "'evsimp.lnk'" else cat << SHAR_EOF > 'evsimp.lnk' lo evsimp lo sltstpak lo \sl\probsets\standard file SHAR_EOF fi # end of overwriting check if test -f 'filelist' then echo shar: will not over-write existing file "'filelist'" else cat << SHAR_EOF > 'filelist' filelist slattrib.bat sltar.bat slpkzip.bat librarie.dir slsetup.bat read.me PROBSETS/standard.f PROBSETS/sample.f D02KEF/d02kef.lnk D02KEF/d02kef.f D02KEF/d02kef.doc SLEDGE/sledgemd.lnk SLEDGE/sledgemd.f SLEIGN2/sleig2md.f SLEIGN2/sleig2md.lnk SLEIGN2/EXTRAS/sleign2x.tex SLEIGN2/EXTRAS/drived.f SLEIGN2/EXTRAS/sleign2.doc SLEIGN2/EXTRAS/sleign2.hlp SLEIGN2/EXTRAS/sleign2.txt SLEIGN2/EXTRAS/makepqwd.f SLEIGN2/EXTRAS/sleign2d.f SLEIGN2/EXTRAS/xamplesd.f MARCOPAK/marcomod.lnk MARCOPAK/marcomod.f SLDRIVER/safeio.f SLDRIVER/slpset.f SLDRIVER/slhelp0.hlp SLDRIVER/sld02k.hlp SLDRIVER/batchio.f SLDRIVER/standard.lnk SLDRIVER/sltstpak.f SLDRIVER/dbmod.f SLDRIVER/sldriver.f SLDRIVER/slconsts.f SLDRIVER/bstandrd.lnk SLDRIVER/solvrs.f SLDRIVER/slutil.f SLDRIVER/sample.lnk SLDRIVER/slbrows.hlp SLDRIVER/errflags.hlp SLDRIVER/evsimp.f SLDRIVER/evsimp.lnk SLDRIVER/sltstvar.f SLDRIVER/nagf90.mk SLDRIVER/salftn90.mk SLDRIVER/initpuff.hlp SLDRIVER/bsample.lnk SLDRIVER/samplrun.dat SLDRIVER/samplrun.out SLDRIVER/standard/keep.me SLDRIVER/standard/TRUEVALS/evtru.29 SLDRIVER/standard/TRUEVALS/evtru.40 SLDRIVER/standard/TRUEVALS/evtru.01 SLDRIVER/standard/TRUEVALS/evtru.19 SLDRIVER/standard/TRUEVALS/evtru.36 SLDRIVER/standard/TRUEVALS/evtru.35 SLDRIVER/standard/TRUEVALS/evtru.34 SLDRIVER/standard/TRUEVALS/evtru.41 SLDRIVER/standard/TRUEVALS/evtru.07 SLDRIVER/standard/TRUEVALS/evtru.20 SLDRIVER/standard/TRUEVALS/eftru.01 SLDRIVER/standard/TRUEVALS/eftru.21 SLDRIVER/standard/TRUEVALS/eftru.28 SLDRIVER/standard/TRUEVALS/eftru.36 SLDRIVER/standard/TRUEVALS/eftru.29 SLDRIVER/standard/TRUEVALS/eftru.02 SLDRIVER/standard/TRUEVALS/sdtru.57 SLDRIVER/standard/TRUEVALS/sdtru.56 SLDRIVER/standard/TRUEVALS/evtru.32 SLDRIVER/standard/TRUEVALS/evtru.28 SLDRIVER/standard/TRUEVALS/evtru.30 SLDRIVER/standard/TRUEVALS/evtru.15 SLDRIVER/standard/TRUEVALS/evtru.18 SLDRIVER/standard/TRUEVALS/evtru.21 SLDRIVER/standard/TRUEVALS/evtru.43 SLDRIVER/standard/TRUEVALS/evtru.23 SLDRIVER/standard/TRUEVALS/evtru.05 SLDRIVER/standard/TRUEVALS/evtru.02 SLDRIVER/standard/TRUEVALS/evtru.22 SLDRIVER/standard/TRUEVALS/eftru.07 SLDRIVER/standard/TRUEVALS/eftru.20 SLDRIVER/standard/TRUEVALS/eftru.22 SLDRIVER/standard/TRUEVALS/eftru.35 SLDRIVER/standard/TRUEVALS/eftru.41 SLDRIVER/standard/TRUEVALS/eftru.15 SLDRIVER/sample/keep.me LATEX/sltstpak.tex LATEX/slref.bib LATEX/graph2.eps LATEX/sldriver.tex LATEX/epsf.tex LATEX/jdpdefs.tex LATEX/sltstalg.tex LATEX/graph1.eps LATEX/esub2acm.sty LATEX/sltstalg.bbl LATEX/sltstpak.bbl LATEX/sldriver.bbl SLEIGN/sleignmd.lnk SLEIGN/sleignmd.f SHAR_EOF fi # end of overwriting check if test -f 'librarie.dir' then echo shar: will not over-write existing file "'librarie.dir'" else cat << SHAR_EOF > 'librarie.dir' *sample LIBRARIE.DIR for Salford DBOS system *to make known the Dynamic Link Libraries of Solver code *57000000 onward C:\FTN90\F90LIB.LIB C:\FTN90\F90LIB.LIB *42000000 onward c:\sl\marcopak\marcopak.lib c:\sl\marcopak\marcopak.lib *43000000 onward c:\sl\sledge\sledge.lib c:\sl\sledge\sledge.lib *44000000 onward c:\sl\sleign\sleign.lib c:\sl\sleign\sleign.lib *45000000 onward c:\sl\sleign2\sleign2.lib c:\sl\sleign2\sleign2.lib SHAR_EOF fi # end of overwriting check if test -f 'marcomod.lnk' then echo shar: will not over-write existing file "'marcomod.lnk'" else cat << SHAR_EOF > 'marcomod.lnk' *Form DLL for MARCOMOD (MARCOPAK as a module) *Make the top-level routines SL01F, SL02F, etc visible from outside *but none of their subordinate routines are to be visible liboffset 42000000 lo marcomod file marcopak.lib SHAR_EOF fi # end of overwriting check if test -f 'nagf90.mk' then echo shar: will not over-write existing file "'nagf90.mk'" else cat << SHAR_EOF > 'nagf90.mk' # File:Makefile, revision of Aug 1998 # Purpose: # Manage the files making up the SLDRIVER package, when using the # NAG f90 system under Unix # Author : John Pryce, RMCS, Shrivenham, Swindon, UK #(pryce@rmcs.cranfield.ac.uk) # Disclaimer: # This file is provided as is, with no claim that it operates # correctly in all circumstances. # References: # SLDRIVER User Guide & Tutorial, RMCS Tech. Rep. SEAS/CISE/96/JDP01 # ###################### INSTRUCTIONS FOR USE ############################## #1.This file must be placed in, and invoked from, the 'sldriver' directory #under the home directory of the SL package. This ensures that the #'.mod' (module specification) files are put in this directory. # #2.Set SL to the home directory of the SL package: SL=/nfs/quince/d2/home/cur/trh/SandPit/CALGO/789 # #3.Define the compiler F90=f90 -c LINK=f90 #4.If desired, reset these compilation options: OPTS= #5.The extension of a module specification file: MOD=mod #The following can be typed at the DOS prompt: #COMMAND |EFFECT #------------------------------------------------------------------------ #mk|makes standard.x if necessary, and launches it. #mk standard.x |as above but without launching it. #mk sample |makes sample.x if necessary, and launches it. #mk bstandrd.x |makes bstandrd.x if necessary, doesn't launch it. #mk sample.x |as above but without launching it. #etc... (the above are the most useful). ######################################################################### ## Run the main executable, which uses the STANDARD problem set standard: standard.x standard.x standard.x: sldriver.o slutil.o solvrs.o dbmod.o \ safeio.o sltstpak.o standard.o $(LINK) -o standard.x sldriver.o slutil.o solvrs.o dbmod.o safeio.o \ sltstvar.o slpset.o \ sledgemd.o sleignmd.o sleig2md.o marcomod.o \ sltstpak.o standard.o ## Alternative executable, using SAMPLE problem set sample: sample.x sample.x sample.x: sldriver.o slutil.o solvrs.o dbmod.o \ safeio.o sltstpak.o sample.o $(LINK) -o sample.x sldriver.o slutil.o solvrs.o dbmod.o safeio.o \ sltstvar.o slpset.o \ sledgemd.o sleignmd.o sleig2md.o marcomod.o \ sltstpak.o sample.o ## Batch-run executable, using STANDARD problem set bstandrd.x: sldriver.o slutil.o solvrs.o dbmod.o \ batchio.o sltstpak.o standard.o $(LINK) -o bstandrd.x sldriver.o slutil.o solvrs.o dbmod.o batchio.o \ sltstvar.o slpset.o \ sledgemd.o sleignmd.o sleig2md.o marcomod.o \ sltstpak.o standard.o ## Batch-run executable, using SAMPLE problem set bsample.x: sldriver.o slutil.o solvrs.o dbmod.o \ batchio.o sltstpak.o sample.o $(LINK) -o bsample.x sldriver.o slutil.o solvrs.o dbmod.o batchio.o \ sltstvar.o slpset.o \ sledgemd.o sleignmd.o sleig2md.o marcomod.o \ sltstpak.o sample.o ##Make all the executables: all.x: standard.x bstandrd.x sample.x bsample.x ## General compilation rule .f.o: $(F90) $(OPTS) $< ## The main-program source sldriver.o: sldriver.f dbmod.o safeio.o slutil.o solvrs.o \ slconsts.o slpset.o sltstpak.o $(F90) $(OPTS) sldriver.f ## The database facilities dbmod.o:dbmod.f safeio.o slutil.o slconsts.o slpset.o $(F90) $(OPTS) dbmod.f ## The solver interfaces solvrs.o: solvrs.f safeio.o slutil.o slconsts.o \ sltstpak.o sledge.o sleign.o marcopak.o sleign2.o $(F90) $(OPTS) solvrs.f ## Utilities #safeio.o: safeio.f #$(F90) $(OPTS) safeio.f #batchio.o:batchio.f #$(F90) $(OPTS) batchio.f #slutil.o: slutil.f #$(F90) $(OPTS) slutil.f #slconsts.o: slconsts.f #$(F90) $(OPTS) slconsts.f #slpset.o: slpset.f #$(F90) $(OPTS) slpset.f ## SLTSTPAK: problem/solver interface routines sltstpak.o: sltstpak.f sltstvar.o testmod.$(MOD) $(F90) $(OPTS) sltstpak.f ## Problem-set routines ##BUG HERE! I don't know how to make MK distinguish between different ##problem sets, so at present it only seems to work if one makes the ##standard executable before the sample one (TESTMOD.MOD gets out of ##kilter otherwise?) testmod.mod: standard.o ##testmod.mod: sample.o standard.o: $(SL)/probsets/standard.f sltstvar.o $(F90) $(OPTS) $(SL)/probsets/standard.f sample.o: $(SL)/probsets/sample.f sltstvar.o $(F90) $(OPTS) $(SL)/probsets/sample.f ## The solvers. They live in their own directories. ## Compilation is to be done from within the SLDRIVER directory ## so that the .o and .mod files get stored there. sledge.o: $(SL)/sledge/sledgemd.f $(F90) $(OPTS) $(SL)/sledge/sledgemd.f sleign.o: $(SL)/sleign/sleignmd.f $(F90) $(OPTS) $(SL)/sleign/sleignmd.f marcopak.o: $(SL)/marcopak/marcomod.f $(F90) $(OPTS) $(SL)/marcopak/marcomod.f sleign2.o:$(SL)/sleign2/sleig2md.f $(F90) $(OPTS) $(SL)/sleign2/sleig2md.f SHAR_EOF fi # end of overwriting check if test -f 'read.me' then echo shar: will not over-write existing file "'read.me'" else cat << SHAR_EOF > 'read.me' INSTALLATION INSTRUCTIONS FOR THE SLDRIVER PACKAGE -------------------------------------------------- (Fortran 90 version 4.1) The package comes as an MS-DOS 3.5 in. diskette, containing both a PC and a Unix version of the files. 1.Installation files for PC ------------------------- The diskette contains a self-extracting compressed file SLZIP.EXE created by the PKZIP package, version 2.04g, plus this READ.ME file. It takes up about 0.5Mb, while the uncompressed files occupy around 1.5Mb. The directory structure should be re-created under a subdirectory, for instance C:\SL, by moving to that directory and issuing the command (the -d is essential!) a:slzip -d The resulting directory tree is shown below. C:\SL | SLSETUP.BAT ... Batchfile to compile all code under | Salford FTN90 | SLPKZIP.BAT ... Batchfile to re-create archive disk | +---SLDRIVER ... The main code of the package | | BATCHIO.FOR ... 'batch' version of SAFEIO | | DBMOD.FOR ... database routines module DBMOD | | SAFEIO.FOR ... safe interactive input module SAFEIO | | SLCONSTS.FOR ... global constants used by SLDRIVER | | SLDRIVER.FOR ... main program & module SLMOD | | SLPSET.FOR ... common variables: current SLDRIVER state | | SLTSTPAK.FOR ... general interface of problems to solvers | | SLTSTVAR.FOR ... common variables: current SLTSTPAK state | | SLUTIL.FOR ... utility routines module SLUTIL | | SOLVRS.FOR ... specific solvers interface module SOLVRS | | | +---STANDARD ... To hold output from STANDARD program | | | | | \---TRUEVALS | | Files EVTRU.nn, EFTRU.nn of "true" ev & efn data | | | \---SAMPLE ... To hold output from SAMPLE program | | | \---TRUEVALS | +---PROBSETS | STANDARD.FOR ... Include this problem set to make STANDARD.EXE | SAMPLE.FOR ... and this one to make SAMPLE.EXE | +---SLEIGN ... Bailey-Gordon-Shampine package | SLEIGN.FOR | +---D02KEF ... Pryce package, NAG 1978 | D02KEF.FOR (not used in current SLDRIVER) | +---MARCOPAK ... Marletta-Pryce package | MARCOPAK.FOR | +---SLEDGE ... Fulton-Pruess package | SLEDGE.FOR | +---SLEIGN2 ... Bailey-Everitt-Zettl revision of SLEIGN | SLEIGN2.FOR | | | \---EXTRAS | \---TEX ... Documentation files SLTSTPAK.TEX ... ACM Trans. Math. Softw. articles SLTSTALG.TEX on SLTSTPAK SLDRIVER.TEX ... User guide plus various auxiliary (.bbl, .sty, .eps etc) files 2.Installation files for Unix --------------------------- The diskette contains a compressed file SLTAR.Z which is the result of processing the above directory structure using DOS versions of the utilities dos2unix (to convert DOS newline CR-LF to Unix newline LF), tar (to put the whole file structure into one file) and gzip (to compress the result). Owing to an apparent bug in the tar program I was unable to convert the filenames to lower-case, which is inconvenient but not serious. To install the package under Unix: - Mount the diskette and copy SLTAR.Z to a suitable directory, say sl. - Use gzip -d or equivalent, to decompress. - Use tar -x to recreate the directory structure under the sl directory. I successfully did this on a Sun under Solaris. 3.Modifications to the source code -------------------------------- The source has proved almost platform-independent but will need, at least, the following adjustments: - The program creates files in subdirectories and has to be aware of the path-naming conventions used by the host operating system. This is encapsulated in routine ADDDIR in SLDRIVER.FOR. In this, change the data initialization of the variable OPSYS from 0 to whatever is appropriate for your system. If you do not, the program will still work but it will ask the user for this information at run time. - Each of the solvers has settings of machine precision and other parameters of the arithmetic. With the help of the solver documentation, make any needed changes. - In the BATCHIO version of SAFEIO, there are lines in routine SPAUSE which trap a CTRL-C at the keyboard when using the Salford FTN90 system. If using another compiler, comment out these lines or replace the call to GET_KEY1@ by the appropriate code for your system. 4.Variants -------- Alternative versions of the program are as follows: - To create the SAMPLE program replace the object file of the STANDARD problem set by the SAMPLE file when linking. - To create the `batch' program replace the SAFEIO object file by the BATCHIO file when linking. This gives 4 combinations, STANDARD.EXE, SAMPLE.EXE, BSTANDRD.EXE and BSAMPLE.EXE 5.Creating the executables ------------------------ The source files must be compiled in an order that respects the module dependencies. (The SL-solver codes do not depend on anything else but they must be compiled before SOLVRS.FOR.) Two files are provided which help to automate the process under the Salford Fortran 90 system and should be easily converted for other systems: SLSETUP.BAT is a MS-DOS script in the toplevel directory. It must be invoked from within that directory. If all goes well, this compiles all source, forms DLLs from the solvers (check for address conflicts with any DLLs of your own!) and links STANDARD.EXE, SAMPLE.EXE, BSTANDRD.EXE and BSAMPLE.EXE MAKEFILE in the SLDRIVER directory uses MK, the Salford version of the 'make' utility. It must be invoked from within that directory. E.g. typing mk standard.exe creates or updates STANDARD.EXE, while mk standard runs it, creating it if necessary. Since the source files live in several directories and contain modules, we must be careful to make the module information (.MOD files in Salford system) accessible to the compiler. This has been done by always invoking the compiler from the SLDRIVER directory so that all the .MOD files are put in this directory. 6.A TRIAL RUN Each run of the interactive version of the program produces a 'playback' file PLAYBACK.DAT containing the sequence of commands and data input by the user, which can be re-input to the batch version of the program. File SAMPLRUN.DAT in the SLDRIVER directory is a copy of the playback file produced by a trial run of STANDARD.EXE. It tests each of the four solvers in turn on Problem 1 in the 'Standard' problem set: first to find eigenvalues of indices 0 to 10; then to find eigenvalues and eigenfunction values of indices 9 to 10. Finally it tests SLEDGE's Spectral Density Function facility on Problem 48. Type bstandrd < samplrun.dat to test the program bstandrd.exe. Then type standard to test the interactive version, and give it the same sequence of inputs (you have to press ENTER at various points where the batch version does not require this.) In either case you should see output essentially identical to that in the file SAMPLRUN.OUT in the SLDRIVER directory. 7.DOCUMENTATION This is in the LATEX directory. Compiling SLDRIVER.TEX (a LaTeX 2.09 document) will produce the user guide. SHAR_EOF fi # end of overwriting check if test -f 'salftn90.mk' then echo shar: will not over-write existing file "'salftn90.mk'" else cat << SHAR_EOF > 'salftn90.mk' # File: Makefile for SLDRIVER package, revision of Aug 1998 #!Using LINK77 which needs .lnk files (instead of SLINK) # Purpose: # Manage the files making up the SLDRIVER package, when using the # Salford FTN90 system under DOS/Windows 3.1 or Windows 95 # Author : John Pryce, RMCS, Shrivenham, Swindon, UK #(pryce@rmcs.cranfield.ac.uk) # Disclaimer: # This file is provided as is, with no claim that it operates # correctly in all circumstances. # References: # SLDRIVER User Guide & Tutorial, RMCS Tech. Rep. SEAS/CISE/96/JDP01 # ###################### INSTRUCTIONS FOR USE ############################## # This file must be placed in, and invoked from, the 'sldriver' directory #under the home directory of the SL package. This ensures that the #'.$M' (module specification) files are put in this directory. #2.Set SL to the home directory of the SL package: SL=C:\sl4.1 BIN=$(SL)\SLDRIVER # #3.Define the compiler & linking mechanism F90=FTN90 LINK=LINK77 #4.If desired, reset these compilation options. # /BINARY stuff is needed so object file goes in current directory # even if source isn't. #OPTS=/CHECK /SILENT /ERRORLOG /BINARY $(BIN)\$@ OPTS=/CHECK_ALL /SILENT /BINARY $(BIN)\$@ #5.Various file extensions: F=for # Fortran (fixed format) file M=mod # module specification file: O=obj # object file X=exe # executable .SUFFIXES: .$F .$O ## General compilation rule .$F.$O: $(F90) $(OPTS) $< #The following can be typed at the DOS prompt: #COMMAND |EFFECT #------------------------------------------------------------------------ #mk |makes standard.exe if necessary, and launches it. #mk standard.exe |as above but without launching it. #mk sample |makes sample.exe if necessary, and launches it. #mk bstandrd.exe |makes bstandrd.exe if necessary, doesn't launch it. #mk sample.exe |as above but without launching it. #etc... (the above are the most useful). ######################################################################### ## Run the main executable, which uses the STANDARD problem set standard: standard.$X RUN77 standard.$X standard.$X: sldriver.$O slutil.$O solvrs.$O dbmod.$O \ safeio.$O sltstpak.$O standard.$O # $(LINK) -out:standard.$X sldriver.$O slutil.$O solvrs.$O dbmod.$O safeio.$O \ # sltstvar.$O slpset.$O \ # sledge.$O sleign.$O sleign2.$O marcopak.$O \ # sltstpak.$O standard.$O LINK77 standard.lnk ## Alternative executable, using SAMPLE problem set sample: sample.$X RUN77 sample.$X sample.$X: sldriver.$O slutil.$O solvrs.$O dbmod.$O \ safeio.$O sltstpak.$O sample.$O # $(LINK) -out:sample.$X sldriver.$O slutil.$O solvrs.$O dbmod.$O safeio.$O \ # sltstvar.$O slpset.$O \ # sledge.$O sleign.$O sleign2.$O marcopak.$O \ # sltstpak.$O sample.$O LINK77 sample.lnk ## Batch-run executable, using STANDARD problem set bstandrd.$X: sldriver.$O slutil.$O solvrs.$O dbmod.$O \ batchio.$O sltstpak.$O standard.$O # $(LINK) -out:standard.$X sldriver.$O slutil.$O solvrs.$O dbmod.$O batchio.$O \ # sltstvar.$O slpset.$O \ # sledge.$O sleign.$O sleign2.$O marcopak.$O \ # sltstpak.$O standard.$O LINK77 bstandrd.lnk ## Batch-run executable, using SAMPLE problem set bsample.$X: sldriver.$O slutil.$O solvrs.$O dbmod.$O \ batchio.$O sltstpak.$O sample.$O # $(LINK) -out:sample.$X sldriver.$O slutil.$O solvrs.$O dbmod.$O batchio.$O \ # sltstvar.$O slpset.$O \ # sledge.$O sleign.$O sleign2.$O marcopak.$O \ # sltstpak.$O sample.$O LINK77 bsample.lnk ## The main-program source sldriver.$O: sldriver.$F dbmod.$O safeio.$O slutil.$O solvrs.$O \ slconsts.$O slpset.$O sltstpak.$O $(F90) $(OPTS) sldriver.$F ## The database facilities dbmod.$O:dbmod.$F safeio.$O slutil.$O slconsts.$O slpset.$O $(F90) $(OPTS) dbmod.$F ## The solver interfaces solvrs.$O: solvrs.$F safeio.$O slutil.$O slconsts.$O \ sltstpak.$O sledge.$O sleign.$O marcopak.$O sleign2.$O $(F90) $(OPTS) solvrs.$F ## Utilities #safeio.$O: safeio.$F #$(F90) $(OPTS) safeio.$F #batchio.$O:batchio.$F #$(F90) $(OPTS) batchio.$F #slutil.$O: slutil.$F #$(F90) $(OPTS) slutil.$F #slconsts.$O: slconsts.$F #$(F90) $(OPTS) slconsts.$F #slpset.$O: slpset.$F #$(F90) $(OPTS) slpset.$F ## SLTSTPAK: problem/solver interface routines sltstpak.$O: sltstpak.$F sltstvar.$O testmod.$M $(F90) $(OPTS) sltstpak.$F ## Problem-set routines ##BUG HERE! I don't know how to make MK distinguish between different ##problem sets, so at present it only seems to work if one changes this ##rule & deletes standard.$O & sample.$O before running 'make' to ##create the executable for a different problem set. ##(TESTMOD.MOD gets out of kilter otherwise?) testmod.$M: standard.$O ##testmod.$M: sample.$O standard.$O: $(SL)\PROBSETS\standard.$F sltstvar.$O $(F90) $(OPTS) $(SL)\PROBSETS\standard.$F sample.$O: $(SL)\PROBSETS\sample.$F sltstvar.$O $(F90) $(OPTS) $(SL)\PROBSETS\sample.$F ## The solvers. They live in their own directories. ## Compilation is to be done from within the SLDRIVER directory ## so that the .$O and .$M files get stored there. sledge.$O: $(SL)\SLEDGE\sledgemd.$F $(F90) $(OPTS) $(SL)\SLEDGE\sledgemd.$F sleign.$O: $(SL)\SLEIGN\sleignmd.$F $(F90) $(OPTS) $(SL)\SLEIGN\sleignmd.$F marcopak.$O: $(SL)\MARCOPAK\marcomod.$F $(F90) $(OPTS) $(SL)\MARCOPAK\marcomod.$F sleign2.$O:$(SL)\SLEIGN2\sleig2md.$F $(F90) $(OPTS) $(SL)\SLEIGN2\sleig2md.$F SHAR_EOF fi # end of overwriting check if test -f 'sample.lnk' then echo shar: will not over-write existing file "'sample.lnk'" else cat << SHAR_EOF > 'sample.lnk' *Make SAMPLE.EXE using the object files listed *and also the DLLs for the solvers: * SLEDGE * SLEIGN * SL02F * SLEIGN2 lo sldriver lo slutil lo solvrs lo dbmod lo slconsts lo sltstvar lo slpset lo sltstpak lo safeio lo ..\probsets\sample file sample.exe SHAR_EOF fi # end of overwriting check if test -f 'slattrib.bat' then echo shar: will not over-write existing file "'slattrib.bat'" else cat << SHAR_EOF > 'slattrib.bat' rem Remove archive attribute from all files (recursing into subdirectories) attrib -a *.*/s rem Now put back for the ones we want attrib +a slattrib.bat attrib +a slpkzip.bat attrib +a slsetup.bat attrib +a sltar.bat attrib +a librarie.dir attrib +a read.me attrib +a d02kef\d02kef.doc attrib +a d02kef\d02kef.for attrib +a d02kef\d02kef.lnk attrib +a latex\slref.bib attrib +a latex\graph1.eps attrib +a latex\graph2.eps attrib +a latex\jdpdefs.tex attrib +a latex\epsf.tex attrib +a latex\esub2acm.sty attrib +a latex\sldriver.tex attrib +a latex\sldriver.bbl attrib +a latex\sltstalg.tex attrib +a latex\sltstalg.bbl attrib +a latex\sltstpak.tex attrib +a latex\sltstpak.bbl attrib +a marcopak\marcomod.for attrib +a marcopak\marcomod.lnk attrib +a probsets\sample.for attrib +a probsets\standard.for attrib +a sldriver\makefile attrib +a sldriver\samplrun.dat attrib +a sldriver\samplrun.out attrib +a sldriver\batchio.for attrib +a sldriver\dbmod.for attrib +a sldriver\safeio.for attrib +a sldriver\slconsts.for attrib +a sldriver\sldriver.for attrib +a sldriver\slpset.for attrib +a sldriver\sltstpak.for attrib +a sldriver\sltstvar.for attrib +a sldriver\slutil.for attrib +a sldriver\solvrs.for attrib +a sldriver\errflags.hlp attrib +a sldriver\initpuff.hlp attrib +a sldriver\slbrows.hlp attrib +a sldriver\sld02k.hlp attrib +a sldriver\slhelp0.hlp attrib +a sldriver\bsample.lnk attrib +a sldriver\bstandrd.lnk attrib +a sldriver\sample.lnk attrib +a sldriver\standard.lnk attrib +a sldriver\evsimp.for attrib +a sldriver\evsimp.lnk attrib +a sldriver\sample\keep.me attrib +a sldriver\standard\keep.me attrib +a sldriver\standard\truevals\evtru.01 attrib +a sldriver\standard\truevals\evtru.02 attrib +a sldriver\standard\truevals\evtru.05 attrib +a sldriver\standard\truevals\evtru.07 attrib +a sldriver\standard\truevals\evtru.15 attrib +a sldriver\standard\truevals\evtru.18 attrib +a sldriver\standard\truevals\evtru.19 attrib +a sldriver\standard\truevals\evtru.20 attrib +a sldriver\standard\truevals\evtru.21 attrib +a sldriver\standard\truevals\evtru.22 attrib +a sldriver\standard\truevals\evtru.23 attrib +a sldriver\standard\truevals\evtru.28 attrib +a sldriver\standard\truevals\evtru.29 attrib +a sldriver\standard\truevals\evtru.30 attrib +a sldriver\standard\truevals\evtru.32 attrib +a sldriver\standard\truevals\evtru.34 attrib +a sldriver\standard\truevals\evtru.35 attrib +a sldriver\standard\truevals\evtru.36 attrib +a sldriver\standard\truevals\evtru.40 attrib +a sldriver\standard\truevals\evtru.41 attrib +a sldriver\standard\truevals\evtru.43 attrib +a sldriver\standard\truevals\eftru.01 attrib +a sldriver\standard\truevals\eftru.02 attrib +a sldriver\standard\truevals\eftru.07 attrib +a sldriver\standard\truevals\eftru.15 attrib +a sldriver\standard\truevals\eftru.20 attrib +a sldriver\standard\truevals\eftru.21 attrib +a sldriver\standard\truevals\eftru.22 attrib +a sldriver\standard\truevals\eftru.28 attrib +a sldriver\standard\truevals\eftru.29 attrib +a sldriver\standard\truevals\eftru.35 attrib +a sldriver\standard\truevals\eftru.36 attrib +a sldriver\standard\truevals\eftru.41 attrib +a sldriver\standard\truevals\sdtru.56 attrib +a sldriver\standard\truevals\sdtru.57 attrib +a sledge\sledgemd.for attrib +a sledge\sledgemd.lnk attrib +a sleign\sleignmd.for attrib +a sleign\sleignmd.lnk attrib +a sleign2\sleig2md.for attrib +a sleign2\sleig2md.lnk attrib +a sleign2\extras\sleign2.doc attrib +a sleign2\extras\drived.for attrib +a sleign2\extras\makepqwd.for attrib +a sleign2\extras\sleign2d.for attrib +a sleign2\extras\xamplesd.for attrib +a sleign2\extras\sleign2.hlp attrib +a sleign2\extras\sleign2x.tex attrib +a sleign2\extras\sleign2.txt SHAR_EOF fi # end of overwriting check if test -f 'sledgemd.lnk' then echo shar: will not over-write existing file "'sledgemd.lnk'" else cat << SHAR_EOF > 'sledgemd.lnk' *Make DLL for SLEDGEMD (SLEDGE made into a module) *Only SLEDGE & INTERV are visible from outside liboffset 43000000 lo sledgemd file sledge.lib SHAR_EOF fi # end of overwriting check if test -f 'sleig2md.lnk' then echo shar: will not over-write existing file "'sleig2md.lnk'" else cat << SHAR_EOF > 'sleig2md.lnk' *Make DLL for SLEIG2MD (SLEIGN2 as a module) *None of its subordinate routines are to be visible from outside map sleig2md.map xref sleig2md.xrf liboffset 45000000 lo sleig2md file sleign2.lib SHAR_EOF fi # end of overwriting check if test -f 'sleignmd.lnk' then echo shar: will not over-write existing file "'sleignmd.lnk'" else cat << SHAR_EOF > 'sleignmd.lnk' *Make DLL for SLEIGNMD (SLEIGN as a module) *Only routine SLEIGN is visible from outside liboffset 44000000 lo sleignmd file sleign.lib SHAR_EOF fi # end of overwriting check if test -f 'slpkzip.bat' then echo shar: will not over-write existing file "'slpkzip.bat'" else cat << SHAR_EOF > 'slpkzip.bat' rem Batchfile to create distribution archive of SLDRIVER package rem It must live in the top level directory of the package rem (usually C:\SL) and this must be the current directory when it rem is called rem It forms, in this same directory, a self-extracting PKZIP 2.05g rem archive of the files in the package. rem This is left in the file rem slzip.exe rem in the directory referred to by %TEMP%. rem If the lines at the end are uncommented it copies to drive A: rem - this zip file rem - the uncompressed READ.ME file rem - the PKZIP software (not neded for extraction but useful!) rem !! Ensure disk in A: is blank to start with !! rem !!! CONFIGURATION DATA !!! set PK=C:\PK set TEMP=C:\TEMP set PATH=%PK%;%PATH% rem Set 'archive' attribute on all files to be stored & on no others: call slattrib pkzip slzip -rp -i *.* zip2exe slzip del slzip.zip move slzip.exe %TEMP%\slzip.exe rem copy read.me a: rem copy %TEMP%\slzip.exe a:\ rem xcopy %PK% a:\pk\ /s SHAR_EOF fi # end of overwriting check if test -f 'slsetup.bat' then echo shar: will not over-write existing file "'slsetup.bat'" else cat << SHAR_EOF > 'slsetup.bat' rem COPYRIGHT J D PRYCE 1998 rem PURPOSE rem Batchfile to do all the compilation & linking with Salford system rem To be adapted for other Fortran systems. rem USAGE rem To be placed in the top-level directory of the package (usually rem c:\sl) and invoked from there. rem NOTES rem This is provided as an alternative to the MAKEFILE but the latter rem is more convenient when it works. rem ADJUST THE FOLLOWING CONFIGURATION SETTINGS AS NEEDED: rem COPT = options for Salford FTN90 compiler set COPT=/ca/debug rem First we move to the main source-files directory. All compilation rem is done there so that .MOD files are placed there. cd sldriver ftn90 ..\marcopak\marcomod.for%COPT% cd ..\marcopak link77 marcomod.lnk cd ..\sldriver ftn90 ..\sledge\sledgemd.for%COPT% cd ..\sledge link77 sledgemd.lnk cd ..\sldriver ftn90 ..\sleign\sleignmd.for%COPT% cd ..\sleign link77 sleignmd.lnk cd ..\sldriver ftn90 ..\sleign2\sleig2md.for%COPT% cd ..\sleign2 link77 sleig2md.lnk cd ..\sldriver ftn90 slconsts.for%COPT% ftn90 slpset.for%COPT% ftn90 safeio.for%COPT% ftn90 batchio.for%COPT% ftn90 slutil.for%COPT% ftn90 dbmod.for%COPT% ftn90 sltstvar.for%COPT% ftn90 ..\probsets\standard.for%COPT% ftn90 ..\probsets\sample.for%COPT% ftn90 sltstpak.for%COPT% ftn90 solvrs.for%COPT% ftn90 sldriver.for%COPT% link77 standard.lnk link77 sample.lnk link77 bstandrd.lnk link77 bsample.lnk SHAR_EOF fi # end of overwriting check if test -f 'sltar.bat' then echo shar: will not over-write existing file "'sltar.bat'" else cat << SHAR_EOF > 'sltar.bat' rem Batchfile to create Unix format distrib archive of SLDRIVER package rem It forms a new directory structure under \SLUNIX holding the rem DOS2UNIX'ed versions of the files, which it then TAR's and GZIP's rem into a file SLTAR.Z in the main SL directory. rem Uses the DOS versions of Unix tools TAR GZIP etc., must be in Path! rem *********CHANGE THIS CONFIGURATION INFO IF NECESSARY*************** set SU=C:\slunix set SL=C:\sl4.1 rem Set 'archive' attribute on all files to be stored & on no others: cd %SL% call slattrib deltree %SU% md %SU% rem form copy of all these files xcopy %SL% %SU%\ /a/s cd %SU% for %%f in (*.*) do call d2u %%f cd %SU%\d02kef for %%f in (*.*) do call d2u %%f cd %SU%\marcopak for %%f in (*.*) do call d2u %%f cd %SU%\sledge for %%f in (*.*) do call d2u %%f cd %SU%\sleign for %%f in (*.*) do call d2u %%f cd %SU%\sleign2 for %%f in (*.*) do call d2u %%f cd %SU%\sleign2\extras for %%f in (*.*) do call d2u %%f cd %SU%\sldriver for %%f in (*.*) do call d2u %%f cd %SU%\sldriver\standard for %%f in (*.*) do call d2u %%f cd %SU%\sldriver\standard\truevals for %%f in (*.*) do call d2u %%f cd %SU%\sldriver\sample for %%f in (*.*) do call d2u %%f cd %SU%\sldriver\sample\truevals for %%f in (*.*) do call d2u %%f cd %SU%\probsets for %%f in (*.*) do call d2u %%f cd %SU%\latex for %%f in (*.*) do call d2u %%f rem all dos2unix'ed, now archive them cd %SU% tar -f %SL%\sl.tar -cv . cd %SL% gzip -c sl.tar > sltar.z SHAR_EOF fi # end of overwriting check if test -f 'standard.lnk' then echo shar: will not over-write existing file "'standard.lnk'" else cat << SHAR_EOF > 'standard.lnk' *Make STANDARD.EXE using the object files listed *and also the DLLs for the solvers: * SLEDGE * SLEIGN * SL02F * SLEIGN2 lo sldriver lo slutil lo solvrs lo dbmod lo slconsts lo sltstvar lo slpset lo sltstpak lo safeio lo ..\probsets\standard file standard.exe SHAR_EOF fi # end of overwriting check if test -f 'standard\sledge48.m' then echo shar: will not over-write existing file "'standard\sledge48.m'" else cat << SHAR_EOF > 'standard\sledge48.m' %Classification of endpoints: A = F F F F B = T T T F sdf=[ ... 0.00000000000000 0.00000000000000 1.00000000000000 0.00000000000000 2.22222222222222 0.00000000000000 3.75000000000000 0.392099772362319 5.71428571428572 1.35834702624313 8.33333333333333 3.15859111742592 12.0000000000000 6.44669639246795 17.5000000000000 12.5234199239914 26.6666666666667 25.5692176083643 45.0000000000000 59.3153712664915 100.000000000000 205.774698088845 ]; lambda=sdf(:,1); rho=sdf(:,2); %sledge/1 48 1.00D-04 9 10 14.5991 3447308 SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Src' then mkdir 'Src' fi cd 'Src' if test ! -d 'Fortran90' then mkdir 'Fortran90' fi cd 'Fortran90' if test ! -d 'Dp' then mkdir 'Dp' fi cd 'Dp' if test ! -d 'd02kef' then mkdir 'd02kef' fi cd 'd02kef' if test -f 'd02kef.f' then echo shar: will not over-write existing file "'d02kef.f'" else cat << SHAR_EOF > 'd02kef.f' SUBROUTINE C05AZF(X,Y,FX,TOLX,IR,C,IND,IFAIL) C MARK 8 RE-ISSUE. NAG COPYRIGHT 1979. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 12A REVISED. IER-496 (AUG 1986). C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='C05AZF') C .. Scalar Arguments .. DOUBLE PRECISION FX, TOLX, X, Y INTEGER IFAIL, IND, IR C .. Array Arguments .. DOUBLE PRECISION C(17) C .. Local Scalars .. DOUBLE PRECISION AB, DIFF, DIFF1, DIFF2, REL, RMAX, TOL, TOL1 INTEGER I LOGICAL T C .. Local Arrays .. CHARACTER*1 P01REC(1) C .. External Functions .. DOUBLE PRECISION X02AJF, X02AKF INTEGER P01ABF EXTERNAL X02AJF, X02AKF, P01ABF C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, DBLE, SQRT, INT C .. Executable Statements .. I = 0 IF ((IND.GT.0 .AND. IND.LE.4) .OR. IND.EQ.-1) GO TO 20 C USER NOT CHECKED IND OR CHANGED IT I = 2 IND = 0 GO TO 640 20 IF (TOLX.GT.0.D0 .AND. (IR.EQ.0 .OR. IR.EQ.1 .OR. IR.EQ.2)) * GO TO 40 I = 3 IND = 0 GO TO 640 40 REL = 1.D0 AB = 1.D0 IF (IR.EQ.1) REL = 0.D0 IF (IR.EQ.2) AB = 0.D0 IF (IND.EQ.-1) GO TO 80 GO TO (60,100,180,480) IND 60 C(3) = X IND = 2 RETURN 80 C(3) = X 100 IF (FX.NE.0.D0) GO TO 140 120 Y = X IND = 0 I = 0 GO TO 640 140 C(4) = FX C(15) = ABS(FX) C(16) = 0.D0 X = Y Y = C(3) C(2) = C(4) C(5) = X IF (IND.EQ.-1) GO TO 160 IND = 3 RETURN 160 FX = C(1) IND = 3 180 IF (FX.EQ.0.D0) GO TO 120 IF (SIGN(1.D0,FX).NE.SIGN(1.D0,C(2))) GO TO 200 IND = 0 I = 1 GO TO 640 200 C(6) = FX C(13) = SQRT(X02AJF()) C(15) = MAX(C(15),ABS(FX)) C(14) = X02AKF() C(16) = 0.0D0 220 C(1) = C(5) C(2) = C(6) C(17) = 0.D0 240 IF (ABS(C(2)).GE.ABS(C(4))) GO TO 280 IF (C(1).EQ.C(5)) GO TO 260 C(7) = C(5) C(8) = C(6) 260 C(5) = C(3) C(6) = C(4) X = C(1) C(3) = X C(4) = C(2) C(1) = C(5) C(2) = C(6) 280 TOL = 0.5D0*TOLX*MAX(AB,REL*ABS(C(3))) TOL1 = 2.0D0*X02AJF()*MAX(AB,REL*ABS(C(3))) DIFF2 = 0.5D0*(C(1)-C(3)) C(12) = DIFF2 DIFF2 = DIFF2 + C(3) IF (C(12).EQ.0.D0) GO TO 340 IF (ABS(C(12)).LE.TOL) GO TO 580 IF (ABS(C(12)).LE.TOL1) GO TO 340 IF (C(17).LT.2.5D0) GO TO 300 C(11) = C(12) GO TO 460 300 TOL = TOL*SIGN(1.D0,C(12)) DIFF1 = (C(3)-C(5))*C(4) IF (C(17).GT.1.5D0) GO TO 320 DIFF = C(6) - C(4) GO TO 380 320 IF (C(7).NE.C(3) .AND. C(7).NE.C(5)) GO TO 360 340 IND = 0 I = 5 GO TO 640 360 C(9) = (C(8)-C(4))/(C(7)-C(3)) C(10) = (C(8)-C(6))/(C(7)-C(5)) DIFF1 = C(10)*DIFF1 DIFF = C(9)*C(6) - C(10)*C(4) 380 IF (DIFF1.GE.0.D0) GO TO 400 DIFF1 = -DIFF1 DIFF = -DIFF 400 IF (ABS(DIFF1).GT.C(14) .AND. DIFF1.GT.DIFF*TOL) GO TO 420 C(11) = TOL GO TO 460 420 IF (DIFF1.GE.C(12)*DIFF) GO TO 440 C(11) = DIFF1/DIFF GO TO 460 440 C(11) = C(12) 460 C(7) = C(5) C(8) = C(6) C(5) = C(3) C(6) = C(4) C(3) = C(3) + C(11) X = C(3) Y = C(1) IND = 4 RETURN 480 IF (FX.EQ.0.D0) GO TO 120 C(4) = FX RMAX = ABS(FX) IF (C(13)*RMAX.LE.C(15)) GO TO 500 IF (C(16).EQ.1.D0) C(16) = -1.D0 IF (C(16).EQ.0.D0) C(16) = 1.D0 GO TO 520 500 C(16) = 0.D0 520 IF (C(2).GE.0.D0) GO TO 540 T = C(4) .LE. 0.D0 GO TO 560 540 T = C(4) .GE. 0.D0 560 IF (T) GO TO 220 I = INT(C(17)+0.1D0) I = I + 1 IF (C(11).EQ.C(12)) I = 0 C(17) = DBLE(I) GO TO 240 580 IF (C(16).GE.0.D0) GO TO 600 I = 4 GO TO 620 600 Y = C(1) I = 0 620 IND = 0 640 IFAIL = P01ABF(IFAIL,I,SRNAME,0,P01REC) RETURN END SUBROUTINE D02KAY(NIT,IFLAG,ELAM,FINFO) C MARK 11.5 RELEASE. NAG COPYRIGHT 1986. C DUMMY MONIT ROUTINE FOR D02KAF, D02KDF OR D02KEF C .. Scalar Arguments .. DOUBLE PRECISION ELAM INTEGER IFLAG, NIT C .. Array Arguments .. DOUBLE PRECISION FINFO(15) C .. Executable Statements .. RETURN END DOUBLE PRECISION FUNCTION D02KDS(X) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C EXP AVOIDING UNDERFLOW ERROR C .. Scalar Arguments .. DOUBLE PRECISION X C .. External Functions .. DOUBLE PRECISION X02AMF EXTERNAL X02AMF C .. Intrinsic Functions .. INTRINSIC EXP, LOG C .. Executable Statements .. D02KDS = 0.D0 IF (X.GE.LOG(X02AMF())) D02KDS = EXP(X) RETURN END SUBROUTINE D02KDT(V,Y,PYP,K,IFAIL) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 11.5(F77) REVISED. (SEPT 1985.) C .. Scalar Arguments .. DOUBLE PRECISION PYP, Y INTEGER IFAIL, K C .. Array Arguments .. DOUBLE PRECISION V(3) C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION B, PHI, R2 C .. Intrinsic Functions .. INTRINSIC LOG, ATAN2, DBLE C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Executable Statements .. B = V(1) IF (B.LE.ZER) GO TO 100 R2 = Y*Y*B + PYP*PYP/B IF (R2.EQ.ZER) GO TO 80 V(3) = LOG(R2) PHI = ATAN2(Y*B,PYP) IF (K.GE.0) GO TO 20 C INITIAL BOUNDARY CONDITION IF (PHI.LT.ZER) PHI = PHI + PI IF (PHI.GE.PI) PHI = PHI - PI GO TO 40 C FINAL BOUNDARY CONDITION 20 IF (PHI.LE.ZER) PHI = PHI + PI IF (PHI.GT.PI) PHI = PHI - PI PHI = PHI + DBLE(K)*PI 40 V(2) = TWO*PHI IFAIL = 0 60 RETURN 80 IFAIL = 1 GO TO 60 100 IFAIL = 2 GO TO 60 END DOUBLE PRECISION FUNCTION D02KDU(X,COEFFN) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 11.5(F77) REVISED. (SEPT 1985.) C COEFFN C .. Scalar Arguments .. DOUBLE PRECISION X C .. Subroutine Arguments .. EXTERNAL COEFFN C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, * TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION DQDL, P, Q C .. Intrinsic Functions .. INTRINSIC SQRT C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, * PSIGN, MINSC, BP, YL, YR, JINT C .. Executable Statements .. CALL COEFFN(P,Q,DQDL,X,LAMDA,JINT) Q = P*Q P = MINSC*P P = P*P D02KDU = SQRT(SQRT(P*P+Q*Q)) RETURN END SUBROUTINE D02KDV(Y,BNEW,IFAIL) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 12A REVISED. IER-499 (AUG 1986). C .. Scalar Arguments .. DOUBLE PRECISION BNEW INTEGER IFAIL C .. Array Arguments .. DOUBLE PRECISION Y(3) C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION B, BUP, CPHI, SPHI C .. Intrinsic Functions .. INTRINSIC LOG, ATAN2, COS, SIN C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Executable Statements .. B = Y(1) IF (B.LE.ZER .OR. BNEW.LE.ZER) GO TO 20 Y(1) = BNEW BUP = B/BNEW B = BNEW/B CPHI = COS(Y(2)) SPHI = SIN(Y(2)) Y(2) = Y(2) + TWO*ATAN2((B-ONE)*SPHI,B+ONE-(B-ONE)*CPHI) Y(3) = Y(3) + LOG((B+BUP-(B-BUP)*CPHI)/TWO) IFAIL = 0 RETURN 20 IFAIL = 1 RETURN END SUBROUTINE D02KDW(N,X,V,F,COEFFN,COEFF1,M,ARR) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 8 REVISED. IER-227 (APR 1980). C MARK 11.5(F77) REVISED. (SEPT 1985.) C POLYGONAL SCALING METHOD C SEVERAL FORMULAE FOR P,Q OVER RANGE,SELECTED BY JINT C COEFF1, COEFFN C .. Scalar Arguments .. DOUBLE PRECISION X INTEGER M, N C .. Array Arguments .. DOUBLE PRECISION ARR(M), F(N), V(N) C .. Subroutine Arguments .. EXTERNAL COEFF1, COEFFN C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION B, C, DQDL, P, Q, S, T1, T2 C .. Intrinsic Functions .. INTRINSIC ABS, COS, SIN C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Executable Statements .. CALL COEFFN(P,Q,DQDL,X,LAMDA,JINT) C TEST IF P(X) WAS 0 OR CHANGED SIGN EARLIER (PSIGN=0) C OR AT THIS CALL (PSIGN .NE. 0 BUT P*PSIGN .LE. 0) IF (P*PSIGN.LE.ZER) GO TO 20 IF (P.LT.ZER) Q = -Q P = ABS(P) B = V(1) T1 = B/P - Q/B T2 = BP/B C = COS(V(2)) S = SIN(V(2)) F(1) = BP F(2) = B/P + Q/B + T1*C + T2*S F(3) = -T2*C + T1*S RETURN 20 F(1) = ZER F(2) = ZER F(3) = ZER PSIGN = ZER RETURN END SUBROUTINE D02KDY(X,XEND,N,Y,CIN,TOL,FCN,COMM,CONST,COUT,W,IW,IW1, * COEFFN,COEFF1,ARR,M,IFAIL) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 7F REVISED. IER-209 (OCT 1979) C MARK 7G REVISED. IER-216 (FEB 1980) C MARK 8 REVISED. IER-227 (APR 1980), IER-246 (MAY 1980). C MARK 8A REVISED. IER-251 (AUG 1980). C MARK 11 REVISED. IER-419 (FEB 1984). C MARK 11D REVISED. IER-469 (NOV.1985). C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C MARK 13 REVISED. IER-633 (APR 1988). C MARK 14 REVISED. IER-715 (DEC 1989). C MARK 14B REVISED. IER-837 (MAR 1990). C INTEGRATES THE N DIFFERENTIAL EQUATIONS DEFINED C BY FCN FROM X TO XEND. THE VALUES AT X C OF THE SOLUTION MUST BE GIVEN IN Y C AND THE CALCULATED VALUES ARE RETURNED C IN THE SAME VECTOR. THE LOCAL ERROR C PER STEP IS CONTROLLED BY TOL. VARIOUS C OPTIONS ARE CONTROLLED BY CIN AND C THE WORKSPACE W WHICH MUST HAVE C FIRST DIMENSION N1 .GE. N AND C SECOND DIMENSION .GE.7. USEFUL C OUTPUT IS ALSO RETURNED IN CIN AND C W, PERMITTING EFFICIENT INTEGRATION. C C COEFF1, COEFFN, FCN C .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='D02KDY') C .. Scalar Arguments .. DOUBLE PRECISION TOL, X, XEND INTEGER IFAIL, IW, IW1, M, N C .. Array Arguments .. DOUBLE PRECISION ARR(M), CIN(6), COMM(5), CONST(3), COUT(14), * W(IW,IW1), Y(N) C .. Subroutine Arguments .. EXTERNAL COEFF1, COEFFN, FCN C .. Local Scalars .. DOUBLE PRECISION COUT12, EXP, EXPI, FAC, FAC1, FAC2, FAC3, FAC4, * FAC5, FAC6, FAC7, FAC8, FAC9, FNORM, HEST, * HEST1, RAT, RAT1, S, SMALL, T, TOLEST, XORIG, * YNORM INTEGER I, I1, IEND, IND, ISIG, ISTEP, J, K, N2 LOGICAL CALLS, INIT, INTER, REDUCE, START, TEST C .. Local Arrays .. CHARACTER*1 P01REC(1) C .. External Functions .. DOUBLE PRECISION D02PAY, X02AJF, X02AKF INTEGER P01ABF EXTERNAL D02PAY, X02AJF, X02AKF, P01ABF C .. External Subroutines .. EXTERNAL D02KDZ C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, DBLE, SQRT, INT C .. Save statement .. SAVE START C .. Data statements .. DATA FAC/10.D0/, FAC1/0.1D0/, FAC3/2.D0/, * FAC4/0.8D0/, FAC5/0.25D0/, FAC6/0.25D0/, * FAC8/0.2D0/, FAC9/0.2D0/ C .. Executable Statements .. C C SET CONSTANTS C XORIG = X HEST1 = 0.D0 INIT = .FALSE. EXP = FAC6 EXPI = FAC5 IND = 0 ISIG = 0 INTER = .FALSE. ISTEP = 2 N2 = 7 TEST = .FALSE. CALLS = .FALSE. COUT12 = 0.D0 IF (CIN(1).NE.7.D0) GO TO 20 COUT12 = COUT(12) CIN(1) = 1.D0 GO TO 40 20 COUT(12) = 0.D0 40 IF (CIN(1).EQ.0.D0) GO TO 100 DO 60 I = 1, 3 IF (COMM(I).NE.0.D0) GO TO 100 60 CONTINUE IF (CIN(1).NE.5.D0 .OR. COMM(4).LE.0.D0) GO TO 80 TEST = .TRUE. IF (CIN(2).GE.3.D0) GO TO 360 GO TO 860 80 IF (CIN(1).NE.6.D0 .OR. COMM(4).GE.0.D0) GO TO 100 TEST = .TRUE. IF (CIN(2).GE.3.D0) GO TO 360 GO TO 720 C C ARGUMENT TESTS C 100 IF (IW.GE.N .AND. N.GT.0 .AND. IW1.GE.7) GO TO 140 C WORKSPACE WRONGLY DIMENSIONED 120 IND = 1 CIN(1) = -1.D0 GO TO 2620 140 IF (TOL.GT.0.D0) GO TO 160 C ERROR TOLERANCE NOT POSITIVE IND = 1 CIN(1) = -2.D0 GO TO 2620 160 IF (CIN(1).EQ.0.D0) GO TO 180 IF (CIN(1).EQ.1.D0) GO TO 240 IF (CIN(1).GE.2.D0 .AND. CIN(1).LE.6.D0) GO TO 280 C CIN(1) OUT OF RANGE IND = 1 CIN(1) = -3.D0 GO TO 2620 C C SET INPUT AND OUTPUT PARAMETERS C 180 DO 200 I = 2, 5 CIN(I) = 0.D0 200 CONTINUE DO 220 I = 1, 4 COMM(I) = 0.D0 220 CONTINUE CONST(1) = 0.D0 CONST(2) = FAC3 CONST(3) = FAC4 240 COUT(11) = X02AJF() SMALL = X02AKF() COUT(13) = ABS(CIN(3)) COUT(14) = ABS(CIN(4)) CIN(6) = 0.D0 ISTEP = 0 S = 0.D0 DO 260 I = 1, N S = MAX(S,ABS(Y(I))) 260 CONTINUE INIT = .TRUE. COUT(1) = 0.D0 COUT(2) = 0.D0 COUT(3) = 0.D0 COUT(4) = X COUT(5) = X COUT(6) = S COUT(7) = S COUT(8) = 0.D0 COUT(9) = 0.D0 COUT(10) = 0.D0 IF (CIN(1).EQ.0.D0) GO TO 800 GO TO 320 C C ARGUMENT TESTS FOR CIN(1).GT.0. C 280 IF ((COUT(4).GE.COUT(5) .AND. X.LT.COUT(4)) .OR. (COUT(4) * .LT.COUT(5) .AND. X.GE.COUT(4))) GO TO 300 IF (X.EQ.XEND) GO TO 320 IF ((X.GE.COUT(4) .AND. XEND.GE.X) .OR. (X.LT.COUT(4) * .AND. XEND.LT.X)) GO TO 320 300 CIN(1) = 1.D0 INTER = .TRUE. GO TO 240 320 IF (CIN(2).EQ.0.D0 .OR. CIN(2).EQ.1.D0 .OR. CIN(2) * .EQ.2.D0 .OR. CIN(2).EQ.3.D0 .OR. CIN(2).EQ.4.D0) GO TO 340 C CIN(2) OUT OF RANGE IND = 1 CIN(1) = -4.D0 GO TO 2620 340 IF (CIN(2).LT.3.D0) GO TO 420 360 IF (IW1.LT.8) GO TO 120 N2 = 8 DO 380 I = 1, N IF (W(I,7).GT.0.D0) GO TO 380 C SCALING OF TOLERANCE NON-POSITIVE IND = 1 CIN(1) = -5.D0 GO TO 2620 380 CONTINUE IF (CIN(2).EQ.4.D0) GO TO 420 IF (IW1.LT.9) GO TO 120 N2 = 9 DO 400 I = 1, N IF (Y(I).NE.0.D0 .OR. W(I,8).GT.0.D0) GO TO 400 C FLOOR ZERO AND SOLUTION ZERO IN SAME COMPONENT IND = 1 CIN(1) = -6.D0 GO TO 2620 400 CONTINUE 420 IF ( .NOT. TEST) GO TO 440 IF (COMM(4).LT.0.D0) GO TO 720 GO TO 860 440 IF (CONST(1).EQ.0.D0) GO TO 480 IF (CONST(1).EQ.1.D0) GO TO 460 C CONST(1) INVALID IND = 1 CIN(1) = -7.D0 GO TO 2620 460 EXPI = FAC9 EXP = FAC8 480 IF (CONST(2).GE.0.D0 .AND. CONST(3).GE.0.D0) GO TO 520 C CONST(2) OR CONST(3) INVALID 500 IND = 1 CIN(1) = -8.D0 GO TO 2620 520 IF (CONST(2).EQ.0.D0) CONST(2) = FAC3 IF (CONST(3).EQ.0.D0) CONST(3) = FAC4 IF (CONST(2).LE.1.D0/CONST(3) .OR. CONST(2).LE.1.D0 .OR. CONST(3) * .GE.1.D0) GO TO 500 IF (COMM(1).GE.0.D0) GO TO 540 C COMM(1) OUT OF RANGE IND = 1 CIN(1) = -9.D0 GO TO 2620 540 IF (COMM(1).GT.0.D0) CALLS = .TRUE. IF (COMM(2).EQ.0.D0) GO TO 580 IF (COMM(2).GT.0.D0) GO TO 560 C COMM(2) OUT OF RANGE IND = 1 CIN(1) = -10.D0 GO TO 2620 560 IF (COUT(6).LT.COMM(2)) GO TO 580 C INITIAL VECTOR TOO LARGE IND = 1 COMM(2) = 0.D0 CIN(1) = -11.D0 GO TO 2620 580 IF (COMM(3).EQ.0.D0) GO TO 640 IF (IW1.LT.10) GO TO 120 N2 = 8 IF (CIN(2).EQ.3.D0) N2 = 11 IF (IW1.LT.N2) GO TO 120 DO 600 I = 1, N IF (Y(I).NE.W(I,9)) GO TO 600 C INITIAL VECTOR ATTAINS GIVEN VALUE IND = 1 COMM(3) = 0.D0 CIN(1) = -12.D0 GO TO 2620 600 CONTINUE DO 620 I = 1, N W(I,10) = Y(I) 620 CONTINUE C C TEST INPUT PARAMETERS FOR INTERRUPT ON POSITION C 640 IF (COMM(4).GE.0.D0) GO TO 800 IF (CIN(1).GT.1.D0) GO TO 720 IF (X.EQ.XEND .AND. COMM(5).EQ.X) GO TO 880 IF (X.NE.XEND) GO TO 680 C VALUE OF CIN(1) DOES NOT PERMIT EXTRAPOLATION 660 IND = 1 CIN(1) = -13.D0 GO TO 780 680 IF ((X.GE.COMM(5) .AND. XEND.LT.COMM(5)) .OR. (X.LT.COMM(5) * .AND. XEND.GE.COMM(5))) GO TO 800 IF (INTER) GO TO 700 C VALUE OF CIN(1) DOES NOT PERMIT EXTRAPOLATION GO TO 660 C ORDER OF POINTS X,COUT(4) AND COUT(5) INCORRECT 700 IND = 1 CIN(1) = -14.D0 GO TO 780 720 IF (X.EQ.COUT(5) .OR. X.EQ.COUT(4)) GO TO 700 IF ((X.GE.COUT(4) .AND. COUT(4).LT.COUT(5)) .OR. (X.LT.COUT(4) * .AND. COUT(4).GE.COUT(5))) GO TO 700 IF (X.EQ.XEND) GO TO 880 IF (SIGN(1.D0,XEND-X).NE.SIGN(1.D0,X-COUT(5))) GO TO 700 IF (COMM(5).EQ.COUT(5) .OR. COMM(5).EQ.XEND) GO TO 740 IF (SIGN(1.D0,COMM(5)-COUT(5)).NE.SIGN(1.D0,COMM(5)-XEND)) * GO TO 740 C INTERRUPT POINT NOT IN RANGE IND = 1 CIN(1) = -15.D0 GO TO 780 740 IF (COMM(5).EQ.COUT(5) .OR. COMM(5).EQ.X) GO TO 760 IF (SIGN(1.D0,COMM(5)-COUT(5)).EQ.SIGN(1.D0,COMM(5)-X)) * GO TO 800 760 CIN(1) = 6.D0 780 COMM(4) = 0.D0 GO TO 2620 C C SET DEFAULTS C 800 IF (TEST) GO TO 860 IF (ABS(CIN(4)).GT.ABS(CIN(3)) .OR. CIN(4).EQ.0.D0) GO TO 820 C USER SET HMIN.GT.HMAX IND = 1 CIN(1) = -16.D0 GO TO 2620 820 COUT(13) = MAX(2.D0*COUT(11)*ABS(XEND-X),ABS(CIN(3))) FAC7 = 0.5D0 IF (CIN(1).GE.2.D0) FAC7 = 1.D0 COUT(14) = FAC7*ABS(XEND-X) IF (CIN(4).EQ.0.D0) GO TO 840 COUT(14) = MIN(ABS(COUT(14)),ABS(CIN(4))) 840 IF (CIN(1).GE.2.D0) GO TO 860 CALL FCN(N,X,Y,W(1,1),COEFFN,COEFF1,M,ARR) IF (CALLS) COMM(1) = COMM(1) - 1.D0 C C INITIALISATION C 860 IF (X.NE.XEND) GO TO 920 IF (CIN(1).LE.1.D0) GO TO 900 IF (CIN(1).NE.2.D0 .OR. CIN(6).NE.0.D0) GO TO 900 C REPEATED CALL WITH X=XEND IND = 1 CIN(1) = -17.D0 GO TO 2620 C C RETURN WHEN X=XEND C 880 COMM(4) = 0.D0 900 CIN(5) = 0.D0 CIN(6) = 0.D0 CIN(1) = 2.D0 GO TO 2620 C C X.NE.XEND INITIALLY C 920 IEND = 0 REDUCE = .FALSE. RAT1 = 1.D0 IF (CIN(1).EQ.0.D0) GO TO 960 IF (CIN(1).EQ.1.D0) CIN(6) = CIN(5) IF (CIN(6).EQ.0.0D0) GO TO 940 IF (SIGN(1.D0,CIN(6)).NE.SIGN(1.D0,XEND-X)) CIN(6) = 0.D0 940 IF (CIN(2).EQ.2.D0) FAC2 = SMALL/COUT(11) IF (ABS(CIN(6)).GE.COUT(13) .AND. CIN(1).GE.2.D0) GO TO 1500 960 ISTEP = 0 START = .TRUE. IF (CIN(6).NE.0.D0) GO TO 1160 C C ESTIMATE STEP C CIN(1) = 1.D0 FNORM = 0.D0 YNORM = 0.D0 DO 980 I = 1, N YNORM = MAX(YNORM,ABS(Y(I))) FNORM = MAX(FNORM,ABS(W(I,1))) 980 CONTINUE TOLEST = TOL J = INT(CIN(2)+0.1D0) + 1 GO TO (1000,1140,1020,1040,1080) J 1000 S = MAX(1.D0,YNORM) GO TO 1120 1020 S = MAX(YNORM,FAC2) GO TO 1120 1040 DO 1060 I = 1, N T = W(I,7)*MAX(W(I,8),ABS(Y(I))) IF (I.EQ.1) S = T S = MIN(S,T) 1060 CONTINUE GO TO 1120 1080 DO 1100 I = 1, N IF (I.EQ.1) S = W(1,7) S = MIN(S,W(I,7)) 1100 CONTINUE 1120 TOLEST = TOLEST*S 1140 S = SQRT(COUT(11)) CIN(6) = (XEND-X)*(TOLEST*COUT(11))**EXPI*MAX(S,YNORM) * /MAX(S,FNORM) 1160 DO 1180 I = 1, N W(I,4) = Y(I) W(I,5) = W(I,1) 1180 CONTINUE IF (ABS(CIN(6)).LT.COUT(13)) CIN(6) = SIGN(COUT(13),XEND-X) IF (ABS(CIN(6)).GT.COUT(14)) CIN(6) = SIGN(COUT(14),CIN(6)) ISIG = 1 GO TO 1600 C C RETURN FOR INITIAL STEP C 1200 IF (COMM(1).GT.0.D0 .OR. .NOT. CALLS) GO TO 1260 C TOO MANY FCN CALLS TAKEN STARTING 1220 IND = 7 DO 1240 I = 1, N Y(I) = W(I,4) 1240 CONTINUE COUT(9) = COUT(9) + 1.D0 GO TO 2620 1260 IF (ABS(HEST).LT.ABS(CIN(6))) GO TO 1280 C C ESTIMATED STEP LARGER THAN INITIAL STEP C IF (ABS(CIN(6))*CONST(2).GT.COUT(14)) GO TO 1420 IF (ABS(HEST).GT.COUT(14)) HEST = SIGN(COUT(14),HEST) IF (REDUCE) GO TO 1420 IF (ABS(HEST).LT.CONST(2)*CONST(2)*ABS(CIN(6))) GO TO 1420 CIN(6) = HEST GO TO 1460 1280 IF (ABS(CIN(6)).GT.COUT(13)) GO TO 1340 C ERROR TOLERANCE TOO SMALL FOR INITIAL STEP 1300 COUT(9) = COUT(9) + 1.D0 DO 1320 I = 1, N Y(I) = W(I,4) 1320 CONTINUE IND = 4 GO TO 2620 C C ESTIMATED STEP SMALLER THAN INITIAL STEP C 1340 T = CIN(6)/CONST(2) IF (ABS(HEST).GT.ABS(T)) GO TO 1420 T = T*FAC1 IF (ABS(HEST).LT.ABS(T)) HEST = T CIN(6) = HEST IF (ABS(CIN(6)).LT.COUT(13)) CIN(6) = SIGN(COUT(13),XEND-X) GO TO 1440 C C INSIGNIFICANT ERROR ESTIMATE ON INITIAL STEP C 1360 CONTINUE IF (REDUCE) GO TO 1380 IF (ABS(CIN(6)).EQ.COUT(14)) GO TO 1400 CIN(6) = CIN(6)*FAC IF (ABS(CIN(6)).GT.COUT(14)) CIN(6) = SIGN(COUT(14),CIN(6)) GO TO 1460 1380 IF (ISIG.EQ.3) GO TO 1300 ISIG = 3 CIN(6) = CIN(6)/FAC3 GO TO 1440 C C INITIAL STEP ACCEPTED C 1400 HEST = CIN(6) 1420 START = .FALSE. GO TO 2000 C C INITIAL STEP REJECTED TRY AGAIN C 1440 REDUCE = .TRUE. 1460 DO 1480 I = 1, N Y(I) = W(I,2) 1480 CONTINUE COUT(9) = COUT(9) + 1.D0 GO TO 1560 C C TAKE A STEP, CHECK AGAINST LENGTH OF RANGE C 1500 IF (ISTEP.LT.2) ISTEP = ISTEP + 1 1520 IF (D02PAY(X,CIN(6),XEND)*SIGN(1.0D0,XEND-X).LT.0.0D0) * GO TO 1560 IF (ISTEP.EQ.-1) GO TO 1540 CIN(6) = XEND - X RAT1 = ABS(COUT(4)-X)/ABS(CIN(6)) 1540 IEND = 1 1560 DO 1580 I = 1, N W(I,4) = W(I,2) W(I,5) = W(I,3) 1580 CONTINUE 1600 CALL D02KDZ(X,CIN(6),N,Y,FCN,W,IW,N2,COEFFN,COEFF1,M,ARR) IF (CALLS) COMM(1) = COMM(1) - 4.D0 C C ESTIMATE NEW STEP C IF (CIN(2).GE.3.D0) GO TO 1800 S = 0.D0 T = 0.D0 J = 0 DO 1620 I = 1, N IF (S.GT.ABS(W(I,6))) GO TO 1620 J = I T = W(I,N2) S = ABS(W(I,6)) 1620 CONTINUE IF (T.EQ.0.D0) GO TO 1680 1640 RAT = RAT1 IF (START) GO TO 1360 IF (J.NE.INT(COUT(10)+0.1D0)) GO TO 1980 HEST = CIN(6) IF (ABS(HEST).EQ.COUT(14) .OR. IEND.EQ.1) GO TO 1980 IF (ABS(HEST).LT.ABS(HEST1)) GO TO 1660 HEST1 = HEST RAT = CONST(2) GO TO 1980 1660 IND = 3 GO TO 2620 1680 J = 0 K = INT(CIN(2)+0.1D0) + 1 GO TO (1720,1700,1760) K 1700 RAT = (TOL/S)**EXP GO TO 1980 1720 T = 1.D0 DO 1740 I = 1, N T = MAX(T,ABS(Y(I))) 1740 CONTINUE RAT = (TOL*T/S)**EXP GO TO 1980 1760 T = FAC2 DO 1780 I = 1, N T = MAX(T,ABS(Y(I))) 1780 CONTINUE RAT = (TOL*T/S)**EXP GO TO 1980 1800 IF (CIN(2).EQ.4.D0) GO TO 1840 DO 1820 I = 1, N C RELATIVE ERROR FAILURE IF (W(I,8).GT.0.0D0) GO TO 1820 IF ((Y(I).GE.0.0D0 .AND. W(I,2).GE.0.0D0) .OR. (Y(I) * .LT.0.0D0 .AND. W(I,2).LT.0.0D0)) GO TO 1820 IND = 6 GO TO 2620 1820 CONTINUE 1840 J = -1 I1 = 0 DO 1960 I = 1, N IF (W(I,6).NE.0.D0) GO TO 1880 IF (W(I,N2).EQ.0.D0) GO TO 1860 IF (I1.EQ.0) J = I GO TO 1960 1860 IF (J.LT.0) J = I GO TO 1960 1880 IF (CIN(2).EQ.4.D0) GO TO 1900 T = MAX(W(I,8),ABS(Y(I)))*W(I,7)/ABS(W(I,6)) GO TO 1920 1900 T = W(I,7)/ABS(W(I,6)) 1920 IF (I1.EQ.0) GO TO 1940 IF (S.LE.T) GO TO 1960 1940 S = T J = 0 I1 = 1 IF (W(I,N2).EQ.1.D0) J = I 1960 CONTINUE IF (J.NE.0) GO TO 1640 RAT = (TOL*S)**EXP 1980 HEST = RAT*CIN(6) IF (START) GO TO 1200 C C TEST ESTIMATED STEP C 2000 IF (ABS(HEST).GE.ABS(CIN(6))) GO TO 2140 C C STEP REJECTED C RAT1 = 1 IEND = 0 IF (ISTEP.LT.0) GO TO 2100 COUT12 = 1.D0 IF (X.EQ.XORIG) COUT(12) = 1.D0 HEST = HEST*CONST(3) COUT(9) = COUT(9) + 1.D0 DO 2020 I = 1, N Y(I) = W(I,2) W(I,3) = W(I,5) W(I,2) = W(I,4) 2020 CONTINUE T = CIN(6)/CONST(2) IF (ABS(HEST).LT.ABS(T)) HEST = T CIN(6) = HEST IF (ABS(CIN(6)).GE.COUT(13)) GO TO 2060 C STEP LENGTH TOO SMALL 2040 IND = 2 GO TO 2620 2060 IF (COMM(1).GT.0.D0 .OR. .NOT. CALLS) GO TO 1520 IF (ISTEP.LT.2) GO TO 1220 C TOO MANY FCN CALLS 2080 IND = 5 GO TO 2620 C C STEP REJECTED AFTER INTERRUPT IN FIRST STEP C 2100 IF (COMM(1).LT.0.D0) GO TO 1220 CIN(6) = (X-COUT(4))*0.5D0 IF (ABS(CIN(6)).LT.COUT(13)) GO TO 2040 X = COUT(4) DO 2120 I = 1, N Y(I) = W(I,4) W(I,1) = W(I,5) 2120 CONTINUE COUT(9) = COUT(9) + 2.D0 INIT = .TRUE. ISTEP = 0 GO TO 1600 C C STEP ACCEPTED C 2140 COUT(5) = COUT(4) COUT(4) = X X = X + CIN(6) HEST1 = 0.D0 COUT(10) = DBLE(J) COUT(8) = COUT(8) + 1.D0 IF ( .NOT. INIT) GO TO 2160 INIT = .FALSE. CIN(5) = CIN(6) COUT(1) = CIN(6) COUT(2) = CIN(6) GO TO 2180 2160 IF (ABS(CIN(6)).LT.ABS(COUT(1))) COUT(1) = CIN(6) IF (ABS(CIN(6)).GT.ABS(COUT(2))) COUT(2) = CIN(6) 2180 IF (HEST.EQ.CIN(6) .AND. ABS(HEST).EQ.COUT(14)) GO TO 2260 HEST = HEST*CONST(3) IF (ABS(CIN(6)).EQ.COUT(14) .OR. IEND.EQ.1) COUT(3) = COUT(3) + * 1.D0 IF (COUT12.EQ.0.D0) GO TO 2200 COUT12 = 0.D0 HEST = 0.5D0*(HEST+CIN(6)) 2200 IF (IEND.EQ.1) GO TO 2220 T = CONST(2)*CIN(6) IF (ABS(HEST).GT.ABS(T)) HEST = T IF (ABS(HEST).GT.COUT(14)) HEST = SIGN(COUT(14),HEST) IF (ABS(HEST).LT.COUT(13)) HEST = SIGN(COUT(13),XEND-X) GO TO 2240 2220 CIN(6) = CIN(6)*RAT1 IF (ABS(CIN(6)).GE.ABS(HEST)) GO TO 2260 2240 CIN(6) = HEST 2260 S = 0.D0 DO 2280 I = 1, N S = MAX(S,ABS(Y(I))) 2280 CONTINUE COUT(6) = MAX(S,COUT(6)) COUT(7) = MIN(S,COUT(7)) CALL FCN(N,X,Y,W(1,1),COEFFN,COEFF1,M,ARR) IF (CIN(1).EQ.0.D0) GO TO 2580 IF (COMM(3).EQ.0.D0) GO TO 2320 DO 2300 I = 1, N IF (ABS(Y(I)-W(I,9)).LT.ABS(W(I,10)-W(I,9))) W(I,10) = Y(I) 2300 CONTINUE 2320 IF ( .NOT. CALLS) GO TO 2340 COMM(1) = COMM(1) - 1.D0 IF (COMM(1).LE.0.D0) GO TO 2080 2340 IF (IEND.EQ.1) GO TO 2600 IF (ISTEP.GE.0) GO TO 2360 ISTEP = -ISTEP GO TO (2460,2440,2620,2520) ISTEP C C TEST INTERRUPTS C 2360 IF (COMM(3).EQ.0.D0) GO TO 2420 DO 2400 I = 1, N IF (Y(I).EQ.W(I,9)) GO TO 2380 IF ((W(I,2).GE.W(I,9) .AND. Y(I).GE.W(I,9)) .OR. (W(I,2) * .LT.W(I,9) .AND. Y(I).LT.W(I,9))) GO TO 2400 C COMPONENTS ACHIEVE GIVEN VALUE 2380 CIN(1) = 3.D0 IF (ISTEP.EQ.0) GO TO 2540 GO TO 2460 2400 CONTINUE C NORM OF SOLUTION TOO LARGE TOO CONTINUE 2420 IF (COMM(2).EQ.0.D0 .OR. COUT(6).LT.COMM(2)) GO TO 2480 CIN(1) = 4.D0 IF (ISTEP.EQ.0) GO TO 2540 2440 COMM(2) = 0.0D0 GO TO 2620 2460 COMM(3) = 0.0D0 GO TO 2620 2480 IF (COMM(4).EQ.0.D0) GO TO 2560 IF (COMM(4).LT.0.D0) GO TO 2500 C INTERRUPT EVERY STEP CIN(1) = 5.D0 IF (ISTEP.EQ.0) GO TO 2540 GO TO 2620 2500 IF ((COMM(5).GE.X .AND. XEND.GE.X) .OR. (COMM(5) * .LT.X .AND. XEND.LT.X)) GO TO 2560 C INTERRUPT AT SPECIFIED POINT CIN(1) = 6.D0 IF (ISTEP.EQ.0) GO TO 2540 2520 COMM(4) = 0.0D0 GO TO 2620 2540 IF (COMM(1).LT.0.D0) GO TO 1220 ISTEP = -INT(CIN(1)-1.5D0) GO TO 1520 2560 IF (COMM(1).LT.0.D0) GO TO 2080 2580 IF (IEND.EQ.0) GO TO 1500 C NORMAL RETURN 2600 CIN(1) = 2.D0 X = XEND C C RETURN TO MAIN PROGRAM C 2620 IF (CALLS .AND. COMM(1).EQ.0.D0) COMM(1) = -1.D0 IFAIL = P01ABF(IFAIL,IND,SRNAME,0,P01REC) IF (CIN(1).GE.0.D0 .AND. IFAIL.GT.0) CIN(1) = 8.D0 RETURN END SUBROUTINE D02KDZ(X,H,N,Y,FCN,W,IW1,IW2,COEFFN,COEFF1,M,ARR) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 8 REVISED. IER-227 (APR 1980). C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C COEFF1, COEFFN, FCN C .. Scalar Arguments .. DOUBLE PRECISION H, X INTEGER IW1, IW2, M, N C .. Array Arguments .. DOUBLE PRECISION ARR(M), W(IW1,IW2), Y(N) C .. Subroutine Arguments .. EXTERNAL COEFF1, COEFFN, FCN C .. Local Scalars .. DOUBLE PRECISION EPS, S INTEGER I, N1 C .. Local Arrays .. DOUBLE PRECISION C(10) C .. External Functions .. DOUBLE PRECISION X02AJF EXTERNAL X02AJF C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. Executable Statements .. EPS = X02AJF() C(1) = 1.D0/6.D0 C(2) = 1.D0/3.D0 C(3) = 0.125D0 C(4) = 0.375D0 C(5) = 0.5D0 C(6) = 1.5D0 C(7) = 2.0D0 C(8) = 2.D0/3.D0 C(9) = 0.2D0 C(10) = 4.D0/3.D0 N1 = 6 IF (IW2.EQ.4) N1 = 4 IF (IW2.EQ.6) N1 = 5 DO 20 I = 1, N W(I,3) = Y(I) + C(2)*H*W(I,1) 20 CONTINUE CALL FCN(N,X+C(2)*H,W(1,3),W(1,N1),COEFFN,COEFF1,M,ARR) DO 40 I = 1, N IF (N1.EQ.5) W(I,4) = 0.5D0*(W(I,N1)-W(I,1))*C(2)*H W(I,3) = Y(I) + C(1)*H*(W(I,1)+W(I,N1)) 40 CONTINUE CALL FCN(N,X+C(2)*H,W(1,3),W(1,N1),COEFFN,COEFF1,M,ARR) DO 60 I = 1, N W(I,2) = Y(I) + H*(C(3)*W(I,1)+C(4)*W(I,N1)) 60 CONTINUE CALL FCN(N,X+C(5)*H,W(1,2),W(1,3),COEFFN,COEFF1,M,ARR) DO 100 I = 1, N IF (N1.EQ.4) GO TO 80 W(I,IW2) = -C(2)*W(I,1) - C(10)*W(I,3) + C(6)*W(I,N1) 80 W(I,2) = Y(I) + H*(C(5)*W(I,1)-C(6)*W(I,N1)+C(7)*W(I,3)) 100 CONTINUE CALL FCN(N,X+H,W(1,2),W(1,N1),COEFFN,COEFF1,M,ARR) DO 140 I = 1, N W(I,2) = Y(I) Y(I) = Y(I) + H*(C(1)*(W(I,1)+W(I,N1))+C(8)*W(I,3)) IF (N1.EQ.4) GO TO 120 W(I,3) = W(I,N1) W(I,N1) = C(9)*H*(W(I,IW2)+C(1)*W(I,N1)) S = 0.D0 IF (ABS(W(I,N1)).LE.30.D0*C(9)*EPS*ABS(H)*MAX(ABS(W(I,IW2)) * ,C(1)*ABS(W(I,3)))) S = 1.D0 W(I,IW2) = S 120 W(I,3) = W(I,1) 140 CONTINUE RETURN END SUBROUTINE D02KEF(XPOINT,NXP,IC1,COEFFN,BDYVAL,K,TOL,ELAM,DELAM, * HMAX,MAXIT,MAXFUN,MONIT,REPORT,IFAIL) C MARK 8 RELEASE. NAG COPYRIGHT 1979. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C C MEANING OF COMMON VARIABLES: C ZER,ONE,TWO,PI - CONSTANTS WITH INDICATED VALUES C LAMDA - CURRENT VALUE OF EIGENVALUE ESTIMATE. SET AND USED IN C EIGODE. USED IN AUX,OPTSC. C PSIGN - SAMPLE P(X) VALUE. SET IN PRUFER, USED IN AUX. C MINSC - MINIMUM ALLOWED SCALEFACTOR. SET IN EIGODE, USED IN C OPTSC. C BP - USED BY THE POLYGONAL SCALING METHOD. THE CURRENT C VALUE OF THE DERIVATIVE OF B(X). SET IN PRUFER, USED I C C BDYVAL, COEFFN, MONIT, REPORT C .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='D02KEF') C .. Scalar Arguments .. DOUBLE PRECISION DELAM, ELAM, TOL INTEGER IC1, IFAIL, K, MAXFUN, MAXIT, NXP C .. Array Arguments .. DOUBLE PRECISION HMAX(2,NXP), XPOINT(NXP) C .. Subroutine Arguments .. EXTERNAL BDYVAL, COEFFN, MONIT, REPORT C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION D, DELAM1, DETOL, DETOLL, DETOLR, DMIN, EL0, * EL1, F0, F1, GAMMA, SIGNSI, TEMP0, TEMP1, TEMP2, * TEMP3, TEMP4, TEMP5, TEMP6, TEMP7, TEMP8, TENU, * TOL2, V3BDYL, V3BDYR, V3L, V3R, X, XL, XOLD, XR, * ZETA INTEGER I, IBACK, IC, IFAIL1, IFLAG, ILOOP, IND, ISTAT1, * ISTATE, ITOP, IXP, MAXFN1, NINT, NXP1 C .. Local Arrays .. DOUBLE PRECISION C(17), F(15), V(21), VL(7) CHARACTER*1 P01REC(1) C .. External Functions .. DOUBLE PRECISION D02KDS, D02KDU, X01AAF, X02AJF INTEGER P01ABF EXTERNAL D02KDS, D02KDU, X01AAF, X02AJF, P01ABF C .. External Subroutines .. EXTERNAL C05AZF, D02KDT, D02KDV, D02KEZ C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, LOG, DBLE C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Executable Statements .. ZER = 0.D0 ONE = 1.D0 TWO = 2.D0 PI = X01AAF(0.0D0) TENU = 10.D0*X02AJF() C C PARAMETER CHECKS, DEFAULT VALUES ETC. IF (NXP.LT.4) GO TO 320 IF (K.LT.0) GO TO 340 IF (TOL.LE.ZER) GO TO 360 NINT = NXP - 3 XL = XPOINT(2) XR = XPOINT(NXP-1) C CHECK XPOINT(I) IN ASC. ORDER AND FIND POSN. OF MATCHING C POINT. DMIN = TWO*ABS(XR-XL) NXP1 = NXP - 1 XOLD = XPOINT(1) DO 40 I = 2, NXP1 X = XPOINT(I) IF (X.LT.XOLD) GO TO 380 D = ABS((XL-X)+(XR-X)) IF (D.GT.DMIN) GO TO 20 IC = I DMIN = D 20 XOLD = X 40 CONTINUE IF ((IC1.LT.2) .OR. (IC1.GT.NXP1)) IC1 = IC IC = IC1 I = NXP IF (XPOINT(NXP).LT.XOLD) GO TO 380 C MINSC = ONE/TENU GAMMA = ZER IF (XL.EQ.XR) GO TO 60 MINSC = 4.D0/ABS(XR-XL) GAMMA = (XPOINT(IC)-XL)/(XR-XL) 60 CONTINUE C DO 80 I = 1, NXP HMAX(2,I) = ZER 80 CONTINUE C TOL2 = TOL/TWO DELAM1 = DELAM IF (DELAM1.EQ.ZER) DELAM1 = .25D0*MAX(ONE,ABS(ELAM)) C HAVE REPORT ROUTINE SWITCHED OFF INITIALLY V(6) = ZER C INITIAL RHO VALUES AT XL,XR TAKEN AS ZERO C ON FIRST ITERATION V3L = ZER V3R = ZER C C INITIAL VALUES OF TOLERANCE PARAMS LOG(ETA) AT XL,XR. DETOLL = LOG(1.D-4) DETOLR = DETOLL C INITIALIZE FAIL-FLAG FOR MISS DISTANCE CODE. IFAIL1 = 0 EL1 = ELAM EL0 = ELAM + DELAM1 C INITIAL EVALUATION, F=F(EL1) . ISTATE = 1 LAMDA = EL1 IBACK = 1 GO TO 520 100 IF (IFAIL1.GT.0) GO TO 460 F1 = F(1) C ENTER BRACKETING LOOP. IF (F1.EQ.ZER) GO TO 180 C THROUGHOUT THE ROOTFINDING, MAINTAIN EL1,EL0 AS TWO MOST C RECENT C APPROXIMATIONS, WITH ABS(F(EL0)).GE.ABS(F(EL1)) C IBACK = 2 LAMDA = EL0 ILOOP = 0 120 ILOOP = ILOOP + 1 GO TO 520 140 IF (IFAIL1.GT.0) GO TO 440 EL0 = LAMDA F0 = F(1) IF (ABS(F0).GT.ABS(F1)) GO TO 160 EL0 = EL1 F0 = F1 EL1 = LAMDA F1 = F(1) 160 IF (F1.EQ.ZER) GO TO 180 IF (F0*F1.LT.ZER) GO TO 200 LAMDA = EL1 - TWO*(EL0-EL1) IF (ILOOP.LE.8) GO TO 120 C HERE HAVE FAILED TO BRACKET ROOT AFTER 10 EVALUATIONS IFAIL1 = 5 GO TO 440 C ON FINDING FMISS EXACTLY 0 ON C 1ST EVAL OR WHEN BRACKETING 180 EL0 = EL1 GO TO 280 C ROOT BETWEEN EL0 AND EL1.. START CALLING ROOTFINDER 200 IFLAG = 1 ISTATE = 2 IBACK = 3 IND = -1 C(1) = F0 220 CALL C05AZF(EL1,EL0,F1,TOL2,0,C,IND,IFLAG) IF (IND.EQ.0) GO TO 260 IF (IND.NE.4 .OR. IFLAG.NE.1) GO TO 420 LAMDA = EL1 GO TO 520 240 IF (IFAIL1.GT.0) GO TO 440 F1 = F(1) GO TO 220 C ON EXIT FROM LOOP TEST FAILURE PARAM OF C05AZF 260 IF (IFLAG.NE.0) GO TO 420 C SWITCH REPORT ROUTINE ON AND C REPEAT INTEGRATION 280 V(6) = ONE LAMDA = EL1 IBACK = 4 GO TO 520 300 IF (IFAIL1.GT.0) GO TO 460 IFAIL1 = 0 GO TO 440 C *** C ERROR PROCESSING FOR MAIN ROUTINE C *** C PARAMETER ERROR NXP,K OR TOL 320 HMAX(2,1) = 1.D0 GO TO 400 340 HMAX(2,1) = 2.D0 GO TO 400 360 HMAX(2,1) = 3.D0 GO TO 400 380 HMAX(2,1) = 4.D0 HMAX(2,2) = DBLE(I) 400 IFAIL1 = 1 HMAX(2,2) = ZER IF (HMAX(2,1).EQ.4.D0) HMAX(2,2) = DBLE(I) GO TO 500 420 IFAIL1 = 12 IF (IFLAG.EQ.4) IFAIL1 = 10 IF (IFLAG.EQ.5) IFAIL1 = 9 440 ELAM = EL1 DELAM = ABS(F(2)) + ABS(EL0-EL1) 460 HMAX(2,1) = ZER HMAX(2,2) = ZER IF (IFAIL1.EQ.0) GO TO 500 IF (IFAIL1.EQ.5) DELAM = EL0 - EL1 IF (IFAIL1.NE.11) GO TO 480 HMAX(2,1) = TEMP1 HMAX(2,2) = TEMP2 480 IF (IFAIL1.NE.12) GO TO 500 HMAX(2,1) = DBLE(IFLAG) HMAX(2,2) = DBLE(IND) 500 IFAIL = P01ABF(IFAIL,IFAIL1,SRNAME,0,P01REC) RETURN C *** C CODE TO COMPUTE MISS DISTANCE. C *** 520 F(3) = ZER 540 F(3) = F(3) + ONE IF (IFAIL1.LT.0) GO TO 960 MAXIT = MAXIT - 1 MAXFN1 = MAXFUN F(1) = ZER F(2) = ZER DO 560 I = 4, 15 F(I) = ZER 560 CONTINUE HMAX(1,NXP-1) = ZER HMAX(1,NXP) = ZER YL(3) = ZER YR(3) = ZER CALL BDYVAL(XL,XR,LAMDA,YL,YR) C SET PARAMETERS APPLICABLE TO SHOOTING EITHER DIRECTION. V(7) = MAX(ONE,ABS(LAMDA))*TOL2 C SET PARAMS FOR SHOOTING C FROM XL. JINT = 1 V(1) = D02KDU(XL,COEFFN) CALL D02KDT(V,YL(1),YL(2),-1,IFAIL1) IF (IFAIL1.NE.0) GO TO 900 V3BDYL = V(3) V(3) = V3L V(4) = ZER V(5) = DETOLL + V(3) X = XL IF (V(6).NE.ZER) CALL REPORT(X,V,0) IF (IC.LT.3) GO TO 600 DO 580 IXP = 3, IC JINT = IXP - 2 CALL D02KEZ(X,XPOINT(IXP),V,COEFFN,MAXFN1,HMAX(1,JINT) * ,REPORT,IFAIL1) F(5) = F(5) + V(15) F(6) = F(6) + V(16) F(7) = F(7) + V(10) IF (IFAIL1.NE.0) GO TO 760 580 CONTINUE C 600 DO 620 I = 1, 7 VL(I) = V(I) 620 CONTINUE C C SET PARAMS FOR SHOOTING C FROM XR. JINT = NINT V(1) = D02KDU(XR,COEFFN) CALL D02KDT(V,YR(1),YR(2),K,IFAIL1) IF (IFAIL1.NE.0) GO TO 920 V3BDYR = V(3) V(3) = V3R V(4) = ZER V(5) = DETOLR + V(3) X = XR IF (V(6).NE.ZER) CALL REPORT(X,V,NINT+1) ITOP = NXP - IC IF (2.GT.ITOP) GO TO 660 DO 640 I = 2, ITOP IXP = NXP - I JINT = IXP - 1 CALL D02KEZ(X,XPOINT(IXP),V,COEFFN,MAXFN1,HMAX(1,JINT) * ,REPORT,IFAIL1) F(5) = F(5) + V(15) F(6) = F(6) + V(16) F(7) = F(7) + V(10) IF (IFAIL1.NE.0) GO TO 760 640 CONTINUE C 660 CONTINUE C HAVE NOW SHOT C FROM XL, RESULTS IN VL, C FROM XR, RESULTS IN C V. C CONVERT TO SAME SCALE AND COMPUTE MISS-DISTANCE. CALL D02KDV(VL,V(1),IFAIL1) F(1) = (VL(2)-V(2))/(PI+PI) C COMPUTE ERROR ESTIMATE INFO. TEMP0 = VL(5) - VL(3) TEMP1 = V(5) - V(3) TEMP2 = D02KDS(-ABS(TEMP0-TEMP1)) IF (GAMMA.EQ.ZER .OR. (GAMMA.NE.ONE .AND. TEMP0.LT.TEMP1)) * GO TO 680 TEMP3 = TEMP0 TEMP4 = ONE TEMP5 = TEMP2 GO TO 700 680 TEMP3 = TEMP1 TEMP4 = TEMP2 TEMP5 = ONE 700 TEMP6 = TEMP4*GAMMA + TEMP5*(ONE-GAMMA) TEMP7 = TEMP4*VL(4) - TEMP5*V(4) IF (TEMP7.EQ.0.0D0) TEMP7 = TENU TEMP7 = SIGN(MAX(ABS(TEMP7),TENU*ABS(TEMP6)),TEMP7) F(2) = -TEMP7/TEMP6 ZETA = ABS(F(2)*V(7)) F(2) = ONE/F(2) TEMP8 = -TEMP3 - LOG(ABS(TEMP7)/TWO) V3L = V3L + TEMP8 - VL(3) V3R = V3R + TEMP8 - V(3) SIGNSI = SIGN(ONE,TEMP7) HMAX(1,NXP-1) = -D02KDS(-V3BDYL+V3L)*SIGNSI HMAX(1,NXP) = D02KDS(V3R-V3BDYR)*SIGNSI TEMP2 = TEMP3 + LOG(.75D0*TEMP6*MAX(ZETA,1.D-2)) C DETOL=IDEALISED VALUE OF V(5) FOR NEXT ITERATION) DETOL = TEMP2 + TEMP8 C BUT INTRODUCE CAUTION DETOLL = MIN(DETOLL+TWO,DETOL-V3L) DETOLR = MIN(DETOLR+TWO,DETOL-V3R) C IFAIL1 = 0 IF (MAXIT.EQ.0) IFAIL1 = -1 ISTAT1 = ISTATE 720 CONTINUE C F(4) = MAXFUN - MAXFN1 CALL MONIT(MAXIT,ISTAT1,LAMDA,F) IF (IFAIL1.GT.0) GO TO 740 IF (ZETA.LT.ONE) GO TO 540 740 GO TO (100,140,240,300) IBACK 760 GO TO (780,800,800,820,840,780,840,860,780) * IFAIL1 780 IFAIL1 = 11 TEMP1 = DBLE(IFAIL1) TEMP2 = V(18) GO TO 880 800 IFAIL1 = 8 GO TO 880 820 IFAIL1 = 7 GO TO 880 840 IFAIL1 = 6 GO TO 880 860 IFAIL1 = 3 880 ISTAT1 = -IFAIL1 F(9) = JINT F(10) = X F(11) = V(1) F(12) = V(2) F(13) = V(3) F(14) = V(18) F(15) = V(11) GO TO 720 C BDYVAL ERROR AT XL 900 F(9) = ZER F(10) = XL GO TO 940 C BDYVAL ERROR AT XR 920 F(9) = DBLE(NXP-2) F(10) = XR 940 IFAIL1 = 2 ISTAT1 = -IFAIL1 GO TO 720 C C MAXIT ERROR 960 IFAIL1 = 4 GO TO 740 END SUBROUTINE D02KEZ(X,XEND,V,COEFFN,MAXFUN,HINFO,REPORT,IFAIL) C MARK 8 RELEASE. NAG COPYRIGHT 1979. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 12A REVISED. IER-501 (AUG 1986). C COEFFN, REPORT C .. Scalar Arguments .. DOUBLE PRECISION X, XEND INTEGER IFAIL, MAXFUN C .. Array Arguments .. DOUBLE PRECISION HINFO(2), V(21) C .. Subroutine Arguments .. EXTERNAL COEFFN, REPORT C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION BNEW, CACC1, CACC2, DQDL, EPSDE, FAC1, FAC2, P, * Q, SY, SYOLD, TEMP, V2OLD, X1, XMAXFN, XOLD INTEGER IFAIL1 C .. Local Arrays .. DOUBLE PRECISION CIN(6), COMM(5), CONST(3), W(3,7) C .. External Functions .. DOUBLE PRECISION D02KDS, D02KDU EXTERNAL D02KDS, D02KDU C .. External Subroutines .. EXTERNAL D02KDV, D02KDW, D02KDY C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, LOG, COS, DBLE, SIN C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Data statements .. DATA COMM(1), COMM(2), COMM(3), COMM(4), * COMM(5)/0.D0, 0.D0, 0.D0, 1.D0, 0.D0/, CONST(1), * CONST(2), CONST(3)/0.D0, 0.D0, 0.D0/, * CIN(2)/1.D0/, CACC1/4.D0/ C .. Executable Statements .. CACC2 = LOG(CACC1) CIN(1) = ONE CIN(3) = ZER CIN(4) = HINFO(1) CIN(5) = HINFO(2) C IF MAXFUN.LE.0 ADD ON BIG QUANTITY XMAXFN = ZER IF (MAXFUN.LE.0) XMAXFN = 32767.D0 COMM(1) = DBLE(MAXFUN) + XMAXFN C GIVE CIN(6) A STARTING VALUE AS IT IS USED IN CALCULATING BP CIN(6) = CIN(5) IF (CIN(6).EQ.ZER) CIN(6) = (XEND-X)*0.125D0 C RE-SCALE PRUFER VARIABLES IF NECESSARY BNEW = D02KDU(X,COEFFN) IF (BNEW.NE.V(1)) CALL D02KDV(V,BNEW,IFAIL) C INITIAL EVALUATION OF BP IF (X.EQ.XEND) GO TO 120 X1 = X + CIN(6) C INITIAL EVALUATION OF INTEGRAND FOR SENSITIVITY INTEGRAL CALL COEFFN(P,Q,DQDL,X,LAMDA,JINT) TEMP = MAX(D02KDU(X1,COEFFN)-V(1),-ABS(Q*CIN(6))) BP = TEMP/CIN(6) SY = D02KDS(V(3)-V(5))*DQDL/V(1) C STORE INITIAL P(X) IN COMMON SO AUX CAN CHECK SIGN CHANGE IF (P.EQ.0.0D0) GO TO 180 PSIGN = SIGN(ONE,P) C C MAIN LOOP - ADVANCES INTEGRATION ONE STEP C 20 CONTINUE C SET SOFT FAIL IFAIL1 = 1 C SET LOCAL ERROR TOLERANCE FOR THIS STEP EPSDE = D02KDS(V(5)-V(3)) EPSDE = EPSDE/(ONE+100.D0*EPSDE) C STORE OLD VALUES FOR SENSITIVITY INTEGRAL XOLD = X SYOLD = SY V2OLD = V(2) C CALL D02KDY(X,XEND,3,V,CIN,EPSDE,D02KDW,COMM,CONST,V(8) * ,W,3,7,COEFFN,COEFFN,HINFO,1,IFAIL1) C C PSIGN SET TO 0 SHOWS P(X) ZERO OR CHANGED SIGN IF (PSIGN.EQ.ZER) GO TO 180 IF (IFAIL1.NE.0) GO TO 160 C C ADVANCE ESTIMATE OF SENSITIVITY INTEGRAL CALL COEFFN(P,Q,DQDL,X,LAMDA,JINT) SY = D02KDS(V(3)-V(5))*DQDL/V(1) TEMP = V(2) - V2OLD IF (ABS(TEMP).LE.0.75D0) GO TO 40 FAC1 = ONE - (SIN(V(2))-SIN(V2OLD))/TEMP FAC2 = FAC1 GO TO 60 40 FAC1 = ONE - COS(V2OLD) FAC2 = ONE - COS(V(2)) 60 CONTINUE V(4) = V(4) + (X-XOLD)*(SYOLD*FAC1+SY*FAC2)/TWO C CHECK IF ACCURACY UNNECESSARILY HIGH 80 IF (ABS(V(4)*V(7)).LE.CACC1) GO TO 100 V(4) = V(4)/CACC1 SY = SY/CACC1 V(5) = V(5) + CACC2 GO TO 80 100 CONTINUE C C PREPARE FOR NEXT STEP, AND LOOP BACK IF (V(6).NE.ZER) CALL REPORT(X,V,JINT) IF (X.NE.X1) CALL D02KDV(V,D02KDU(X,COEFFN),IFAIL) IF (X.EQ.XEND) GO TO 120 IF (CIN(1).NE.5.D0) GO TO 200 X1 = X + CIN(6) IF (ABS(XEND-X).LT.ABS(CIN(6))) GO TO 110 TEMP = MAX(D02KDU(X1,COEFFN)-V(1),-ABS(Q*CIN(6))) BP = TEMP/CIN(6) 110 CONTINUE CALL D02KDW(3,X,V,W(1,1),COEFFN,COEFFN,1,HINFO) COMM(1) = COMM(1) - ONE C AND LOOP BACK IF (COMM(1).GT.ZER) GO TO 20 IFAIL1 = 5 GO TO 160 C BEFORE EXIT, SET OUTPUT VALUES ETC. 120 IFAIL = 0 140 MAXFUN = COMM(1) - XMAXFN HINFO(2) = CIN(5) RETURN C C FAILURE EXITS 160 IFAIL = IFAIL1 V(18) = EPSDE GO TO 140 180 IFAIL = 8 V(18) = EPSDE GO TO 140 200 IFAIL = 9 V(18) = CIN(1) GO TO 140 END DOUBLE PRECISION FUNCTION D02PAY(X,H,XEND) C MARK 14 RELEASE. NAG COPYRIGHT 1989. C .. Scalar Arguments .. DOUBLE PRECISION H, X, XEND C .. Local Scalars .. DOUBLE PRECISION TEMP C .. External Functions .. DOUBLE PRECISION D02PAZ, X02AJF EXTERNAL D02PAZ, X02AJF C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN C .. Executable Statements .. TEMP = D02PAZ(X+H) - XEND IF (ABS(TEMP).LE.2.0D0*X02AJF()*MAX(ABS(X),ABS(XEND))) * TEMP = X02AJF()*SIGN(1.0D0,XEND-X) D02PAY = TEMP RETURN END DOUBLE PRECISION FUNCTION D02PAZ(X) C MARK 14 RELEASE. NAG COPYRIGHT 1989. C .. Scalar Arguments .. DOUBLE PRECISION X C .. Executable Statements .. D02PAZ = X RETURN END INTEGER FUNCTION P01ABF(IFAIL,IERROR,SRNAME,NREC,REC) C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C MARK 13 REVISED. IER-621 (APR 1988). C MARK 13B REVISED. IER-668 (AUG 1988). C C P01ABF is the error-handling routine for the NAG Library. C C P01ABF either returns the value of IERROR through the routine C name (soft failure), or terminates execution of the program C (hard failure). Diagnostic messages may be output. C C If IERROR = 0 (successful exit from the calling routine), C the value 0 is returned through the routine name, and no C message is output C C If IERROR is non-zero (abnormal exit from the calling routine), C the action taken depends on the value of IFAIL. C C IFAIL = 1: soft failure, silent exit (i.e. no messages are C output) C IFAIL = -1: soft failure, noisy exit (i.e. messages are output) C IFAIL =-13: soft failure, noisy exit but standard messages from C P01ABF are suppressed C IFAIL = 0: hard failure, noisy exit C C For compatibility with certain routines included before Mark 12 C P01ABF also allows an alternative specification of IFAIL in which C it is regarded as a decimal integer with least significant digits C cba. Then C C a = 0: hard failure a = 1: soft failure C b = 0: silent exit b = 1: noisy exit C C except that hard failure now always implies a noisy exit. C C S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. C C .. Scalar Arguments .. INTEGER IERROR, IFAIL, NREC CHARACTER*(*) SRNAME C .. Array Arguments .. CHARACTER*(*) REC(*) C .. Local Scalars .. INTEGER I, NERR CHARACTER*72 MESS C .. External Subroutines .. EXTERNAL P01ABZ, X04AAF, X04BAF C .. Intrinsic Functions .. INTRINSIC ABS, MOD C .. Executable Statements .. IF (IERROR.NE.0) THEN C Abnormal exit from calling routine IF (IFAIL.EQ.-1 .OR. IFAIL.EQ.0 .OR. IFAIL.EQ.-13 .OR. * (IFAIL.GT.0 .AND. MOD(IFAIL/10,10).NE.0)) THEN C Noisy exit CALL X04AAF(0,NERR) DO 20 I = 1, NREC CALL X04BAF(NERR,REC(I)) 20 CONTINUE IF (IFAIL.NE.-13) THEN WRITE (MESS,FMT=99999) SRNAME, IERROR CALL X04BAF(NERR,MESS) IF (ABS(MOD(IFAIL,10)).NE.1) THEN C Hard failure CALL X04BAF(NERR, * ' ** NAG hard failure - execution terminated' * ) CALL P01ABZ ELSE C Soft failure CALL X04BAF(NERR, * ' ** NAG soft failure - control returned') END IF END IF END IF END IF P01ABF = IERROR RETURN C 99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', * ' =',I6) END SUBROUTINE P01ABZ C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C C Terminates execution when a hard failure occurs. C C ******************** IMPLEMENTATION NOTE ******************** C The following STOP statement may be replaced by a call to an C implementation-dependent routine to display a message and/or C to abort the program. C ************************************************************* C .. Executable Statements .. STOP END DOUBLE PRECISION FUNCTION X01AAF(X) C MARK 8 RE-ISSUE. NAG COPYRIGHT 1980. C MARK 11.5(F77) REVISED. (SEPT 1985.) C C RETURNS THE VALUE OF THE MATHEMATICAL CONSTANT PI. C C X IS A DUMMY ARGUMENT C C IT MAY BE NECESSARY TO ROUND THE REAL CONSTANT IN THE C ASSIGNMENT STATEMENT TO A SMALLER NUMBER OF SIGNIFICANT C DIGITS IN ORDER TO AVOID COMPILATION PROBLEMS. IF SO, THEN C THE NUMBER OF DIGITS RETAINED SHOULD NOT BE LESS THAN C . 2 + INT(FLOAT(IT)*ALOG10(IB)) C WHERE IB IS THE BASE FOR THE REPRESENTATION OF FLOATING- C . POINT NUMBERS C . AND IT IS THE NUMBER OF IB-ARY DIGITS IN THE MANTISSA OF C . A FLOATING-POINT NUMBER. C C .. Scalar Arguments .. DOUBLE PRECISION X C .. Executable Statements .. X01AAF = 3.14159265358979323846264338328D0 RETURN END DOUBLE PRECISION FUNCTION X02AJF() C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS (1/2)*B**(1-P) IF ROUNDS IS .TRUE. C RETURNS B**(1-P) OTHERWISE C C .. Executable Statements .. x02ajf = 1.110223024625157D-16 RETURN END DOUBLE PRECISION FUNCTION X02AKF() C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS B**(EMIN-1) (THE SMALLEST POSITIVE MODEL NUMBER) C C .. Executable Statements .. x02akf = 1d-300 c x02akf = 2.9387358770557188D-39 RETURN END DOUBLE PRECISION FUNCTION X02AMF() C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS THE 'SAFE RANGE' PARAMETER C I.E. THE SMALLEST POSITIVE MODEL NUMBER Z SUCH THAT C FOR ANY X WHICH SATISFIES X.GE.Z AND X.LE.1/Z C THE FOLLOWING CAN BE COMPUTED WITHOUT OVERFLOW, UNDERFLOW OR OTHER C ERROR C C -X C 1.0/X C SQRT(X) C LOG(X) C EXP(LOG(X)) C Y**(LOG(X)/LOG(Y)) FOR ANY Y C C .. Executable Statements .. x02amf = 1d-300 c x02amf = 2.9387358770557188D-39 RETURN END SUBROUTINE X04AAF(I,NERR) C MARK 7 RELEASE. NAG COPYRIGHT 1978 C MARK 7C REVISED IER-190 (MAY 1979) C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 14 REVISED. IER-829 (DEC 1989). C IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER C (STORED IN NERR1). C IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO C VALUE SPECIFIED BY NERR. C C .. Scalar Arguments .. INTEGER I, NERR C .. Local Scalars .. INTEGER NERR1 C .. Save statement .. SAVE NERR1 C .. Data statements .. DATA NERR1/6/ C .. Executable Statements .. IF (I.EQ.0) NERR = NERR1 IF (I.EQ.1) NERR1 = NERR RETURN END SUBROUTINE X04BAF(NOUT,REC) C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C C X04BAF writes the contents of REC to the unit defined by NOUT. C C Trailing blanks are not output, except that if REC is entirely C blank, a single blank character is output. C If NOUT.lt.0, i.e. if NOUT is not a valid Fortran unit identifier, C then no output occurs. C C .. Scalar Arguments .. INTEGER NOUT CHARACTER*(*) REC C .. Local Scalars .. INTEGER I C .. Intrinsic Functions .. INTRINSIC LEN C .. Executable Statements .. IF (NOUT.GE.0) THEN C Remove trailing blanks DO 20 I = LEN(REC), 2, -1 IF (REC(I:I).NE.' ') GO TO 40 20 CONTINUE C Write record to external file 40 WRITE (NOUT,FMT=99999) REC(1:I) END IF RETURN C 99999 FORMAT (A) END SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'marcopak' then mkdir 'marcopak' fi cd 'marcopak' if test -f 'marcomod.f' then echo shar: will not over-write existing file "'marcomod.f'" else cat << SHAR_EOF > 'marcomod.f' module MARCOMOD private public:: sl01f,sl02f,sl02fm,sl03f,sl03fm,sl04f,sl04fm,sl05f, + sl05fm,sl06fm,sl07f,sl07fm contains C SL01F & SL02F complete text (including NAG routines) SUBROUTINE SL01F(A,B,EMIN,EMAX,KMIN,KMAX,COEFFN,SETUP,AINFO,BINFO, & SYM,WK,IWK,KNOB,TOL,IFAIL) C This routine counts the number of eigenvalues in a given range C [emin,emax]. If emax lies in the continuous spectrum and emin C does not, then an estimate will be made of the infimum of the C continuous spectrum and this will be returned in lieu of emax. C The eigenvalues are counted by returning kmin and kmax, the C indices of the lowest and highest index eigenvalues lying in C the interval. C C Brief specification: C C a,b: real. On entry, a and b specify the actual interval (a,b)on which C the (regular or singular) problem is posed. On exit, they C specify the (possibly shorter) interval on which it was solved. C emin, emax: real. On entry, [emin,emax] is the interval in which the C code must count the eigenvalues. If this interval intersects C the continuous spectrum then provided emin does not lie in the C continuous spectrum the routine will locate a number elam such C that the infimum of the continuous spectrum is believed C to occur in (elam,elam+tol). The routine will then use the C interval [emin,elam] in place of [emin,emax]: it will count C the eigenvalues in this interval, and return elam in place C of emax. If emin is in the continuous spectrum or within a C distance tol of the continuous spectrum, the routine will C return with kmin = kmax = -10. C coeffn: subroutine supplied by the user. Specification: C SUBROUTINE coeffn(x,p,q,w) C DOUBLE PRECISION x,p,q,w C C x: On entry, a value of the independent variable in (a,b). C Must be unchanged on exit. C C p,q,w: On exit these must specify the values of the C C coefficients p(x), q(x), w(x). C setup: subroutine supplied by the user. Specification: C SUBROUTINE setup(y,pdy,elam,iend) C INTEGER iend C DOUBLE PRECISION y,pdy,elam C C iend: Specifies the end of the interval at which the b.c.'s C C are to be applied. If iend = 0, then B.C.'s are required C C at the left hand end, while iend = 1 requests b.c.'s at C C the right-hand end. Must not be changed on exit. C C y,pdy: On exit, these must specify values of y(.) and py'(.) C C which are consistent with the B.C.'s at the appropriate C C end. C C elam: On entry, elam specifies the current value of the C C eigenparameter. It is included since in many problems C C the boundary conditions are dependent on this parameter. C kmin, kmax: integers. On exit, these specify respectively the highest and C lowest indices of eigenvalues in [emin,elam], where elam is emax C if emax is not in the continuous spectrum, and is an estimate of C the infimum of the continuous spectrum otherwise. (see C description of emax above). If emin is within a distance tol of C the inf of the continuous spectrum then kmin and kmax will both C be set to -10 on exit. If the routine detects no eigenvalues in C the range [emin,emax] then it will return with kmin > kmax. C knob: integer. The maximum number of endpoint shifts which the routine C is allowed to make in the course of the computation. Default C value of 60 should only be increased in special circumstances. C To select default value set knob < 10 on entry. The minimum C value of knob within the routine is therefore 10. On exit, C knob will have either the default value if selected, or the C value assigned by the user on entry. C ainfo: character*1. On entry ainfo must be set as follows: C If x=a is a finite regular endpoint set ainfo = 'R' or ainfo = 'r'. C If x=a is a finite singular endpoint set ainfo ='S' or ainfo = 's' C If a=-infinity set ainfo = 'I' or ainfo = 'i'. C binfo: character*1. On entry binfo must be set as follows: C If x=b is a finite regular endpoint set binfo = 'R' or binfo = 'r'. C If x=b is a finite singular endpoint set binfo ='S' or binfo = 's' C If b=+infinity set binfo = 'I' or ainfo = 'i'. C sym: logical. If the problem is symmetric about the midpoint (a+b)/2 C (taken as 0 if the endpoints are infinite) then set sym = .true., C otherwise sym should be .false. C wk: real array of dimension precisely (0:iwk,1:4). Used as workspace. C iwk: integer. On entry, iwk must have a value which satisfies C iwk > 10 + knob, C where knob has the value defined by the user if this is > 9, C and is otherwise equal to 60. Unchanged on exit. C tol: real. This parameter controls the computation in various ways. It is C used in the location of the infimum of the continuous spectrum C if necessary (see description of emax given above) and generally C any eigenvalue which lies within the interval [emin,elam] (where C elam = min(emax,inf{Continuous Spectrum}) with at least tol C clearance from each end, should be counted. Unchanged on exit. C ifail: integer. The error flag. C .. Parameters .. INTEGER IPARAM PARAMETER (IPARAM=1) C .. C .. Scalar Arguments .. DOUBLE PRECISION A,B,EMAX,EMIN,TOL INTEGER IFAIL,IWK,KMAX,KMIN,KNOB LOGICAL SYM CHARACTER AINFO*1,BINFO*1 C .. C .. Array Arguments .. DOUBLE PRECISION WK(0:IWK,1:4) C .. C .. Subroutine Arguments .. EXTERNAL COEFFN,SETUP C .. C .. Local Scalars .. INTEGER ASTAT,BSTAT,ICOFUN,IFO,ISING,N,NREC CHARACTER SRNAME*6 C .. C .. Local Arrays .. DOUBLE PRECISION PARAMS(1:IPARAM) CHARACTER REC(2)*80 C .. C .. External Functions .. cc DOUBLE PRECISION X02AJF cc INTEGER P01ABF cc EXTERNAL X02AJF,P01ABF C .. C .. External Subroutines .. cc EXTERNAL CNTER C .. C .. Intrinsic Functions .. INTRINSIC ABS,MAX C .. SRNAME = 'SL01F' ICOFUN = 2 IFO = IFAIL IFAIL = 0 IF (AINFO.EQ.'R' .OR. AINFO.EQ.'r') THEN ASTAT = 0 ELSE IF (AINFO.EQ.'S' .OR. AINFO.EQ.'s') THEN ASTAT = 1 ELSE IF (AINFO.EQ.'I' .OR. AINFO.EQ.'i') THEN ASTAT = 2 ELSE ASTAT = 3 END IF IF (BINFO.EQ.'R' .OR. BINFO.EQ.'r') THEN BSTAT = 0 ELSE IF (BINFO.EQ.'S' .OR. BINFO.EQ.'s') THEN BSTAT = 1 ELSE IF (BINFO.EQ.'I' .OR. BINFO.EQ.'i') THEN BSTAT = 2 ELSE BSTAT = 3 END IF C Check input for errors. IF (IWK.LT.10 .OR. (ASTAT.EQ.3) .OR. (BSTAT.EQ.3) .OR. & (SYM.AND.ASTAT.NE.BSTAT) .OR. EMAX.LT.EMIN+TOL .OR. & TOL.LT.0.D0 .OR. (ASTAT.NE.2.AND.BSTAT.NE.2.AND.B.LE.A) .OR. & ABS(IFO).GT.1) THEN IFAIL = 1 NREC = 1 IF (ASTAT.EQ.3) THEN WRITE (REC,FMT=9010) GO TO 100 END IF IF (BSTAT.EQ.3) THEN WRITE (REC,FMT=9020) GO TO 100 END IF IF (SYM .AND. ASTAT.NE.BSTAT) THEN WRITE (REC,FMT=9030) GO TO 100 END IF IF (IWK.LT.10) THEN WRITE (REC,FMT=9000) IWK GO TO 100 END IF NREC = 2 IF (EMAX.LT.EMIN+TOL) THEN WRITE (REC,FMT=9040) EMIN,EMAX GO TO 100 END IF NREC = 1 IF (TOL.LT.0.D0) THEN WRITE (REC,FMT=9050) TOL GO TO 100 END IF NREC = 2 IF (ASTAT.NE.2 .AND. BSTAT.NE.2 .AND. B.LE.A) THEN WRITE (REC,FMT=9060) A,B GO TO 100 END IF IF (ABS(IFO).GT.1) THEN WRITE (REC,FMT=9070) IFO IFO = -1 GO TO 100 END IF END IF 9000 FORMAT ('** IWK must be at least 10, IWK =',i8) 9010 FORMAT ('** Invalid input value of AINFO') 9020 FORMAT ('** Invalid input value of BINFO') 9030 FORMAT ('** For symmetric problems AINFO must equal BINFO') 9040 FORMAT ('** EMAX-EMIN-TOL must be non-negative,',/,'** EMIN = ', & G18.8,' EMAX = ',G18.8) 9050 FORMAT ('** TOL must be strictly positive, TOL =',g18.8) 9060 FORMAT ('** For regular problems A < B is required ',/,'** A = ', & g18.8,' B = ',g18.8) 9070 FORMAT ('** On entry IFAIL must be -1, 0 or +1 ',/, & '** Input value of IFAIL = ',i8) C END of error trapping IF (ASTAT.NE.0 .AND. BSTAT.EQ.0) THEN ISING = 1 ELSE IF (BSTAT.NE.0 .AND. ASTAT.EQ.0) THEN ISING = 2 ELSE IF (ASTAT.NE.0 .AND. BSTAT.NE.0) THEN ISING = 3 ELSE ISING = 0 END IF IF (ASTAT.EQ.2 .AND. BSTAT.EQ.2) THEN A = -1.D0 B = 1.D0 ICOFUN = 1 GO TO 10 END IF IF (ASTAT.EQ.2 .AND. BSTAT.NE.2) THEN A = -1.D0 B = B/ (1.D0+ABS(B)) ICOFUN = 1 END IF IF (BSTAT.EQ.2 .AND. ASTAT.NE.2) THEN A = A/ (1.D0+ABS(A)) B = 1.D0 ICOFUN = 1 END IF 10 N = IWK CALL CNTER(A,B,EMIN,EMAX,KMIN,KMAX,COEFFN,SETUP,ISING,SYM,WK(0,1), & WK(1,2),WK(1,3),WK(1,4),N,KNOB,TOL,PARAMS,IPARAM, & ICOFUN,IFAIL) IF (IFAIL.NE.0) THEN GO TO (20,30,40,50,60,70,80,90) IFAIL 20 WRITE (REC,FMT=9080) 9080 FORMAT ('** Input parameter error') GO TO 100 30 WRITE (REC,FMT=9090) 9090 FORMAT ('** Integration halted: step-size too small') GO TO 100 40 WRITE (REC,FMT=9100) 9100 FORMAT ('** Invalid boundary conditions') GO TO 100 50 WRITE (REC,FMT=9110) 9110 FORMAT ('** IWK was too small for given TOL') GO TO 100 60 WRITE (REC,FMT=9120) 9120 FORMAT ('** Uncertainty about start of continuous spectrum') GO TO 100 70 WRITE (REC,FMT=9130) 9130 FORMAT ( & '** Too many attempts to find start of continuous spectrum' & ) GO TO 100 80 WRITE (REC,FMT=9140) 9140 FORMAT ('Tighter TOL required for computation of KMAX') GO TO 100 90 WRITE (REC,FMT=9150) 9150 FORMAT ('May be eigenvalues close to EMIN or EMAX') GO TO 100 END IF IF (ICOFUN.EQ.1) THEN A = A/MAX((1.D0-ABS(A)),X02AJF(1.D0)) B = B/MAX((1.D0-ABS(B)),X02AJF(1.D0)) END IF RETURN 100 IFAIL = P01ABF(IFO,IFAIL,SRNAME,NREC,REC) RETURN END SUBROUTINE SL01F C -------------------------------------------------------------------- SUBROUTINE CNTER(A,B,EMIN,EMAX,KMIN,KMAX,COEFFN,SETUP,ISING,ISYMM, & XMESH,PP,QP,WP,N,MAXITS,TOL,PARAMS,IPARAM,ICOFUN, & IFAIL) C .. Scalar Arguments .. DOUBLE PRECISION A,B,EMAX,EMIN,TOL INTEGER ICOFUN,IFAIL,IPARAM,ISING,KMAX,KMIN,MAXITS,N LOGICAL ISYMM C .. C .. Array Arguments .. DOUBLE PRECISION PARAMS(1:IPARAM),PP(1:N),QP(1:N),WP(1:N), & XMESH(0:N) C .. C .. Subroutine Arguments .. EXTERNAL COEFFN,SETUP C .. C .. Local Scalars .. DOUBLE PRECISION AT,ATRUNC,BT,BTRUNC,CSPEC,DLAM,ELAM,FX,H, & PI,RMAX,RTRY,TRUNC,XS,YS INTEGER I,IFLAG,IND,IP1,IR,MAXEVS,NEVS,NP LOGICAL IRELOC C .. C .. Local Arrays .. DOUBLE PRECISION C(17) C .. C .. External Functions .. cc DOUBLE PRECISION DACC,X01AAF,X02ALF cc EXTERNAL DACC,X01AAF,X02ALF C .. C .. External Subroutines .. cc EXTERNAL C05AZF,CEKSPK,COARSE,INITIA C .. C .. Intrinsic Functions .. INTRINSIC ABS,DBLE,INT,LOG,MAX,SQRT C .. C Initial error traps: IF (ABS(IFAIL).GT.1) THEN IFAIL = -ABS(IFAIL) GO TO 60 END IF IF (N.LT.10 .OR. TOL.LE.0.D0 .OR. TOL.GE.1.D0 .OR. B.LE.A .OR. & EMIN.GE. (EMAX-TOL)) THEN IFAIL = 1 GO TO 60 END IF C End of input checks. C Set some constants: PI = X01AAF(1.D0) IF (MAXITS.LT.10) MAXITS = 60 MAXEVS = (LOG(EMAX-EMIN)-LOG(TOL))/LOG(2.D0) + 20 NP = 10 C Stage 1: set up an initial discretisation of the problem. IF (ISING.EQ.0) THEN C Omit the check for continuous spectrum, go straight to the C counting stage. ATRUNC = A BTRUNC = B AT = A BT = B CALL COARSE(NP,ATRUNC,BTRUNC,XMESH,0) CALL INITIA(COEFFN,PP,QP,WP,XMESH,NP,PARAMS,IPARAM,ICOFUN) GO TO 30 ELSE IF (ISING.EQ.1) THEN ATRUNC = A + (B-A)/6.D0 BTRUNC = B ELSE IF (ISING.EQ.2) THEN BTRUNC = B - (B-A)/6.D0 ATRUNC = A ELSE TRUNC = (B-A)/6.D0 ATRUNC = A + TRUNC BTRUNC = B - TRUNC END IF C Get the first mesh and coefficient functions: CALL COARSE(NP,ATRUNC,BTRUNC,XMESH,0) CALL INITIA(COEFFN,PP,QP,WP,XMESH,NP,PARAMS,IPARAM,ICOFUN) C Check to see if emax is in continuous spectrum: IRELOC = .true. AT = ATRUNC BT = BTRUNC CALL CEKSPK(EMAX,A,B,AT,BT,XMESH,PP,QP,WP,NP,N,MAXITS,TOL,COEFFN, & SETUP,IRELOC,ISYMM,CSPEC,DLAM,PARAMS,IPARAM,ICOFUN, & IFAIL) IF (IFAIL.NE.0) GO TO 60 C If emax is not in the continuous spectrum then set the truncated C endpoints and go to the eigenvalue counting stage: IF (CSPEC.LT.0.D0) THEN ATRUNC = AT BTRUNC = BT GO TO 30 END IF C If we are here then it means that emax is in the continuous spectrum. C In such a case, we must also check emin. IRELOC = .true. AT = ATRUNC BT = BTRUNC CALL CEKSPK(EMIN,A,B,AT,BT,XMESH,PP,QP,WP,NP,N,MAXITS,TOL,COEFFN, & SETUP,IRELOC,ISYMM,CSPEC,DLAM,PARAMS,IPARAM,ICOFUN, & IFAIL) IF (IFAIL.NE.0) GO TO 60 IF (CSPEC.GT.0.D0) THEN C In this case emin is also in the continuous spectrum. There are therefore C no eigenvalues in [emin,emax]. Denote this by setting kmin = kmax = -10. KMIN = -10 KMAX = KMIN RETURN END IF C If we are here then it means that the infimum of the continous spectrum C lies somewhere in (emin,emax]. We must find this infimum. We will do so C by using a rootfinding routine (C05AZF). Because we are rootfinding on a C discontinuous function, C05AZF will be using bisection. XS = EMIN YS = EMAX IND = -1 IR = 1 NEVS = 0 FX = -1.D0 C(1) = 1.D0 IFLAG = 1 10 CALL C05AZF(XS,YS,FX,TOL/20.D0,IR,C,IND,IFLAG) IF (IND.EQ.0) THEN IF (IFLAG.NE.0 .AND. IFLAG.NE.5) THEN IFAIL = 5 GO TO 60 END IF GO TO 20 END IF IF (IND.LT.2 .OR. IND.GT.4) THEN IFAIL = 5 GO TO 60 END IF NEVS = NEVS + 1 IF (NEVS.GT.MAXEVS) THEN IFAIL = 6 GO TO 60 END IF IRELOC = .true. AT = ATRUNC BT = BTRUNC CALL CEKSPK(XS,A,B,AT,BT,XMESH,PP,QP,WP,NP,N,MAXITS,TOL,COEFFN, & SETUP,IRELOC,ISYMM,FX,DLAM,PARAMS,IPARAM,ICOFUN,IFAIL) IF (IFAIL.NE.0) GO TO 60 GO TO 10 20 ELAM = XS C We have now found elam, an approximation to the infimum of the continuous C spectrum. We will proceed to the counting stage with EMAX = MAX(EMIN,ELAM-TOL/10.D0) IF (EMAX.LE.EMIN) THEN KMIN = -10 KMAX = KMIN RETURN END IF C Counting stage: we now count the number of eigenvalues in [emin,emax]. C We do this by finding kmin and kmax, respectively the lowest and highest C indices of eigenvalues in this interval. We need to be able to compute C D(emin) and D(emax) to fairly high accuracy. C Stage 1 of counting: find truncated ends. 30 IRELOC = .false. AT = XMESH(0) BT = XMESH(NP) CALL CEKSPK(EMAX,A,B,AT,BT,XMESH,PP,QP,WP,NP,N,MAXITS,TOL,COEFFN, & SETUP,IRELOC,ISYMM,CSPEC,DLAM,PARAMS,IPARAM,ICOFUN, & IFAIL) IF (IFAIL.NE.0) GO TO 60 IF (CSPEC.GT.0.D0) THEN IFAIL = 7 GO TO 60 END IF C We now have truncated ends given by at,bt C and so we can make two extra-accurate evaluations of D(elam). This C will require the use of our stepsize-controlling version of the C Prufer theta-integrator. C Evaluation of D(emin): ELAM = EMIN 40 IF (ISYMM) THEN RMAX = 0.5D0* (A+B) IP1 = NP/2 ELSE RMAX = (ELAM*WP(1)-QP(1))/PP(1) IP1 = 1 DO 50 I = 1,NP - 1 RTRY = (ELAM*WP(I)-QP(I))/PP(I) IF (RMAX.LT.RTRY) THEN IP1 = I RMAX = RTRY END IF 50 CONTINUE RMAX = XMESH(IP1) END IF C H = MIN((XMESH(1)-XMESH(0)), (XMESH(NP)-XMESH(NP-1))) H = (XMESH(NP)-XMESH(0))/DBLE(NP) DLAM = DACC(ELAM,AT,BT,RMAX,COEFFN,SETUP,H,TOL/1.D1,PARAMS,IPARAM, & ICOFUN,IFAIL) IF (IFAIL.NE.0) GO TO 60 C WRITE (6,*) 'ELAM,D/PI:',ELAM,DLAM/(4.D0*ATAN(1.D0)) IF (ELAM.LT.EMAX) THEN IF (DLAM.LE.0.D0) THEN KMIN = 0 IF (DLAM.GT. (-TOL)) IFAIL = 8 ELSE DLAM = DLAM/PI KMIN = INT(DLAM) RMAX = ABS(DLAM-KMIN) IF (RMAX.GT. (1.D0-TOL) .OR. RMAX.LT.TOL) IFAIL = 8 IF ((DLAM-DBLE(KMIN)*PI).NE.0.D0) KMIN = KMIN + 1 END IF ELAM = EMAX GO TO 40 ELSE DLAM = DLAM/PI KMAX = INT(DLAM) RMAX = ABS(DLAM-KMAX) IF (RMAX.GT. (1.D0-TOL) .OR. RMAX.LT.TOL) IFAIL = 8 END IF IF (KMIN.GT.KMAX) THEN KMIN = -10 KMAX = -10 END IF C Ifail = 8 means that there may be an eigenvalue lurking very close to C one of the endpoints, which would be difficult to detect. C Successful termination: A = AT B = BT RETURN 60 RETURN END SUBROUTINE CNTER C ------------------------------------------------------------------- DOUBLE PRECISION FUNCTION DACC(ELAM,A,B,C,COEFFN,SETUP,H,TOL, & PARAMS,IPARAM,ICOFUN,IFAIL) C .. Parameters .. DOUBLE PRECISION ONE,HALF,TRD PARAMETER (ONE=1.D0,HALF=5.D-1,TRD=ONE/3.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION A,B,C,ELAM,H,TOL INTEGER ICOFUN,IFAIL,IPARAM C .. C .. Array Arguments .. DOUBLE PRECISION PARAMS(1:IPARAM) C .. C .. Subroutine Arguments .. EXTERNAL COEFFN,SETUP C .. C .. Local Scalars .. DOUBLE PRECISION ABSERR,DI,DTH1,ERR,FAC,HMAX,HO,P,PDY,PI,Q,SCALE, & SNEW,THETA,THETA1,THETA2,W,X1,XFIN,XMID,XO,Y INTEGER ICNT,KNTRY LOGICAL STEP1,TRANS C .. C .. External Functions .. cc DOUBLE PRECISION SCL,X01AAF,X02AJF cc EXTERNAL SCL,X01AAF,X02AJF C .. C .. External Subroutines .. cc EXTERNAL BCONS,COEFUN,ONESTP C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN2,MAX,MIN,SIGN,SQRT C .. PI = X01AAF(1.D0) IFAIL = 0 STEP1 = .TRUE. HMAX = ABS(H) HO = SIGN(1.D0,H)*MIN(SQRT(TOL),ABS(H)) H = HO ICNT = 0 C Step from a to c XO = A XFIN = C DI = ONE KNTRY = 0 X1 = XO + H CALL COEFUN((XO+X1)*HALF,P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. TRANS = ICOFUN .EQ. 1 .OR. ICOFUN .EQ. 3 CALL BCONS(SETUP,Y,PDY,ELAM,XO,P,Q,W,0,TRANS,IFAIL) IF (IFAIL.NE.0) RETURN THETA = ATAN2(Y,PDY) C ------------------------- Stepping stage ------------------------- 10 THETA1 = THETA THETA2 = THETA SCALE = ONE SNEW = ONE X1 = XO + H IF ((X1-XFIN)*DI.GT.0.D0) X1 = XFIN C Do one-step + two half-steps to integrate with error estimate. XMID = HALF* (XO+X1) CALL COEFUN(XMID,P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) CALL ONESTP(XO,X1,DI,SCALE,THETA1,P,ELAM*W-Q) CALL COEFUN(HALF* (XO+XMID),P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) CALL ONESTP(XO,XMID,DI,SNEW,THETA2,P,ELAM*W-Q) CALL COEFUN(HALF* (XMID+X1),P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) CALL ONESTP(XMID,X1,DI,SNEW,THETA2,P,ELAM*W-Q) THETA1 = SCL(THETA1,ONE/SCALE) THETA2 = SCL(THETA2,ONE/SNEW) C Error estimate: ERR = (THETA1-THETA2)*TRD ABSERR = ABS(ERR) C WRITE (6,6000) XO,XMID,X1,H,ABSERR C6000 FORMAT ('XO,XMID,X1,H,ABSERR:',5G16.6) IF (ABSERR.GT.TOL) THEN C WRITE (6,*) 'Error too large, repeating step' KNTRY = KNTRY + 1 IF (ABS(H).LT.SQRT(X02AJF(H)) .AND. KNTRY.GT.16) THEN IFAIL = 2 RETURN END IF H = H*MIN(8.D-1, (TOL/ABSERR)**TRD) GO TO 10 END IF IF (ABSERR.LT.0.8D0*TOL .AND. KNTRY.EQ.0) THEN C WRITE (6,*) 'Error too small' C IF (step1) WRITE (6,*) 'Repeating step' H = H/MAX(2.D-1, (ABSERR/ (0.8D0*TOL))**TRD) FAC = HMAX*MAX(ONE,XMID**2) H = SIGN(1.D0,H)*MIN(FAC,ABS(H)) IF (STEP1 .AND. ABS(H).LT.FAC) GO TO 10 END IF STEP1 = .FALSE. KNTRY = 0 THETA = THETA2 - ERR XO = X1 ICNT = ICNT + 1 IF ((XFIN-X1)*DI.GT.0.D0) GO TO 10 C --------------------- END of stepping stage ------------------------ C If we have got here then it means that we have finished an integration. IF (DI.GT.0.D0) THEN DTH1 = THETA XO = B XFIN = C DI = -ONE H = HO*DI X1 = XO + H CALL COEFUN((XO+X1)*HALF,P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) CALL BCONS(SETUP,Y,PDY,ELAM,XO,P,Q,W,1,TRANS,IFAIL) IF (IFAIL.NE.0) RETURN THETA = PI - ATAN2(Y,PDY) STEP1 = .TRUE. GO TO 10 END IF DACC = DTH1 - THETA RETURN END FUNCTION DACC C ------------------------------------------------------------------- SUBROUTINE CEKSPK(ELAM,A,B,AT,BT,XMESH,PP,QP,WP,N,NMAX,MAXITS,TOL, & COEFFN,SETUP,IRELOC,ISYMM,CSPEC,DLAM,PARAMS, & IPARAM,ICOFUN,IFAIL) C Routine for spectral analysis. Tells when a value of elam is in the C continuous spectrum. Used as part of a rootfinding process to find C the infimum of the continuous spectrum. C C Brief Specification: C C elam: real. On entry elam must specify the value of lambda to be C tested. Unchanged on exit. C a,b: real. On entry, the endpoints of the whole interval on which C the problem is posed. Unchanged on exit. C at,bt: real. On entry, proposed initial truncation points from which C stepping towards the singular endpoint(s) will take place. C On exit, the points at which the algorithm stopped the C truncation procedure. C xmesh: real array of dimension at least (0:nmax). On entry, the C entries xmesh(0),..,xmesh(n) specify a mesh covering the C interval (at,bt), and must be strictly increasing with C xmesh(0) = at, xmesh(n) = bt. On exit, if ireloc was C .true. on entry then xmesh will be unchanged; otherwise, C xmesh will contain the mesh which was in use when the C interval truncation algorithm stopped, and n will be the C number of intervals in this mesh. C pp,qp,wp: real arrays of dimension at least (1:nmax). On entry, the C entries in pp(1),..,pp(n), qp(1),..,qp(n), wp(1),..,wp(n) C specify coefficient values. On exit they will be unchanged C if ireloc was .true. on entry, otherwise they will be C altered to agree with the new xmesh array (see above). C n: integer. On entry, n specifies the number of intervals in the C current mesh. If ireloc is .true. on entry then n will be C unchanged on exit; otherwise n will be the number of C intervals in the new mesh (see xmesh above). C nmax: integer. On entry, nmax specifies the maximum amount of storage C which is available for meshpoints and coefficient values. C nmax must be strictly greater than n, and must satisfy C nmax > n + maxits C if there is to be no risk failure. Unchanged on exit. C maxits: integer. The maximum number of moves of truncated endpoints C which will be made before declaring that no suitable C truncated endpoints can be found and that elam must lie C in the continuous spectrum. In general maxits = 60 will be C adequate, but at tight tolerances tol it may be advisable C to increase maxit. Unchanged on exit. C tol: real. On entry, the tolerance to which two successive approximations C to D(elam) with different truncated endpoints must agree before C the endpoints are deemed to be satisfactory and elam is C declared not to lie in the continuous spectrum. Unchanged on C exit. C COEFFN, SETUP: subroutines supplied by the user for the evaluation of C coefficients and boundary conditions. C ireloc: logical. Controls whether or not the arrays xmesh, pp, qp, wp, C and the integer n are changed on exit. See above. Unchanged C on exit. C isymm: logical. On entry, isymm = .true. tells the routine that the C problem is symmetric about (a+b)/2. In this case the truncated C interval (at,bt) should be symmetric in the same way. C Unchanged on exit. C cspec: real. This parameter is for output only and serves to tell the user C whether or not elam was found to be in the continuous spectrum. C cspec = -1 on exit ==> elam is not in continuous spectrum. C cspec = +1 on exit ==> elam is in the continuous spectrum. C dlam: real. On exit, this parameter gives the final approximation obtained C for D(elam). Only meaningful if cspec = -1 on exit. C ifail: integer. The error flag. C C END of brief specification. C Declarations: C .. Parameters .. DOUBLE PRECISION HALF,TQTR PARAMETER (HALF=5.D-1,TQTR=7.5d-1) C .. C .. Scalar Arguments .. DOUBLE PRECISION A,AT,B,BT,CSPEC,DLAM,ELAM,TOL INTEGER ICOFUN,IFAIL,IPARAM,MAXITS,N,NMAX LOGICAL IRELOC,ISYMM C .. C .. Array Arguments .. DOUBLE PRECISION PARAMS(1:IPARAM),PP(1:NMAX),QP(1:NMAX), & WP(1:NMAX),XMESH(0:NMAX) C .. C .. Subroutine Arguments .. EXTERNAL COEFFN,SETUP C .. C .. Local Scalars .. DOUBLE PRECISION ATRUNC,BTRUNC,DL1,DL2,DTHA,DTHB,FYNYT,OVFLOW,PDY, & SC,SHIFT,TH,TOLRED,Y,H INTEGER I,I1,I2,IP1,ISING,ISINGO,ITIME,KNTR LOGICAL TRANS C .. C .. External Functions .. cc DOUBLE PRECISION D,DTHETA,X01AAF,X02AHF,X02ALF cc EXTERNAL D,DTHETA,X01AAF,X02AHF,X02ALF C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN2,MIN,SQRT C .. C .. External Subroutines .. cc EXTERNAL BCONS,COEFUN C .. OVFLOW = SQRT(X02ALF(1.D0)) IFAIL = 0 TOLRED = TOL*1.D-1 C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. TRANS = ICOFUN .EQ. 1 .OR. ICOFUN .EQ. 3 C Stage 1: Find out which ends are singular. IF (A.EQ.AT .AND. B.EQ.BT) THEN CSPEC = -1 RETURN ELSE IF (A.LT.AT .AND. B.EQ.BT) THEN ISING = 1 ELSE IF (A.EQ.AT .AND. B.GT.BT) THEN ISING = 2 ELSE ISING = 3 END IF ISINGO = ISING C Stage 2: Initialise the stepping procedure. C Set size of coarse mesh: SHIFT = XMESH(1) - XMESH(0) C Mark ends of input arrays: I1 = 1 I2 = N C END of marking; special action if two singular points: ITIME = 0 KNTR = 0 IF (ISING.EQ.3) THEN ITIME = 1 ISING = 1 END IF C First approximation to D(elam): DL1 = D(ELAM,N,N/2,PP,QP,WP,XMESH,SETUP,TRANS,IFAIL) IF (IFAIL.NE.0) RETURN 10 IF (ISING.EQ.1) THEN C Add a point at the left hand end. IF ((N+1).GT.NMAX) THEN IFAIL = 4 RETURN END IF DO 20 I = N,1,-1 IP1 = I + 1 XMESH(IP1) = XMESH(I) PP(IP1) = PP(I) QP(IP1) = QP(I) WP(IP1) = WP(I) 20 CONTINUE XMESH(1) = XMESH(0) XMESH(0) = XMESH(0) - MIN(SHIFT,TQTR* (XMESH(0)-A)) CALL COEFUN(HALF* (XMESH(1)+XMESH(0)),PP(1),QP(1),WP(1), & COEFFN,PARAMS,IPARAM,ICOFUN) N = N + 1 I1 = I1 + 1 I2 = I2 + 1 END IF C END of adding point at left-hand side. IF (ISING.EQ.2 .OR. ISYMM) THEN C Add point at right hand side. N = N + 1 IF (N.GT.NMAX) THEN IFAIL = 4 RETURN END IF XMESH(N) = XMESH(N-1) + MIN(SHIFT,TQTR* (B-XMESH(N-1))) CALL COEFUN(HALF* (XMESH(N)+XMESH(N-1)),PP(N),QP(N),WP(N), & COEFFN,PARAMS,IPARAM,ICOFUN) END IF DL2 = D(ELAM,N,N/2,PP,QP,WP,XMESH,SETUP,TRANS,IFAIL) IF (IFAIL.NE.0) RETURN C Check for convergence IF (ABS(DL2-DL1).LT.TOLRED) GO TO 30 C If we got past the last block then we have to make another step KNTR = KNTR + 1 IF (KNTR.GE.MAXITS) GO TO 50 H = ABS(XMESH(1) - XMESH(0)) FYNYT = (ELAM*WP(1)-QP(1))/PP(1) IF ((FYNYT.GE.0.0D0.AND.H*SQRT(ABS(FYNYT)).GE.1.0D-2*X02AHF(0.D0)) & .OR.ABS(FYNYT).GE.OVFLOW) GO TO 50 H = ABS(XMESH(N)-XMESH(N-1)) FYNYT = (ELAM*WP(N)-QP(N))/PP(N) IF ((FYNYT.GE.0.0D0.AND.H*SQRT(ABS(FYNYT)).GE.1.0D-2*X02AHF(0.D0)) & .OR.ABS(FYNYT).GE.OVFLOW) GO TO 50 C If we got past the last line then we have not yet decided whether or C not we are in the continuous spectrum. Do another endpoint shift: DL1 = DL2 GO TO 10 C Various exits now follow C First the exit in case where dl2-dl1 has converged - we are not in the C continuous spectrum. 30 IF (ITIME.EQ.1 .AND. .NOT.ISYMM) THEN C We have two endpoints to do and only one has been done -- go back & do C the other. ITIME = 2 ISING = 2 DL1 = DL2 GO TO 10 END IF AT = XMESH(0) BT = XMESH(N) C One last check for continuous spectrum: IF (ISINGO.NE.0) THEN DTHA = 0.D0 DTHB = 0.D0 IF (ISINGO.GT.1) THEN CALL BCONS(SETUP,Y,PDY,ELAM,BT,PP(N),QP(N),WP(N),1,TRANS, & IFAIL) IF (IFAIL.NE.0) RETURN TH = ATAN2(Y,PDY) SC = 1.D0 BTRUNC = BT DTHB = DTHETA(TH,SC,ELAM,BTRUNC,B,COEFFN,PARAMS,IPARAM, & ICOFUN) END IF IF (ISINGO.NE.2) THEN CALL BCONS(SETUP,Y,PDY,ELAM,AT,PP(1),QP(1),WP(1),0,TRANS, & IFAIL) IF (IFAIL.NE.0) RETURN TH = ATAN2(Y,PDY) SC = 1.D0 ATRUNC = XMESH(0) DTHA = DTHETA(TH,SC,ELAM,ATRUNC,A,COEFFN,PARAMS,IPARAM, & ICOFUN) END IF IF ((DTHA+DTHB).GE.1.D1*X01AAF(1.D0)) GO TO 50 END IF IF (IRELOC) THEN N = I2 - I1 + 1 XMESH(0) = XMESH(I1-1) DO 40 I = 1,N IP1 = I1 + I - 1 XMESH(I) = XMESH(IP1) PP(I) = PP(IP1) QP(I) = QP(IP1) WP(I) = WP(IP1) 40 CONTINUE END IF DLAM = DL2 CSPEC = -1.D0 RETURN C Next the case where dl2-dl1 did not converge - we are in the continuous C spectrum 50 AT = XMESH(0) BT = XMESH(N) IF (IRELOC) THEN N = I2 - I1 + 1 XMESH(0) = XMESH(I1-1) DO 60 I = 1,N IP1 = I1 + I - 1 XMESH(I) = XMESH(IP1) PP(I) = PP(IP1) QP(I) = QP(IP1) WP(I) = WP(IP1) 60 CONTINUE END IF DLAM = DL2 CSPEC = 1.D0 RETURN C END of routine END SUBROUTINE CEKSPK C --------------------------------------------------------------------- C --------------------- Source from SL02F ----------------------------- C --------------------------------------------------------------------- SUBROUTINE sl02f(elam,a,b,k,ainfo,binfo,sym,tol,coeffn,setup,n,wk, & iwk,wksmal,ismal,knobs,ifail) C This routine finds the kth eigenvalue elam of a regular or singular Sturm- C Liouville problem C C -(p(x)y'(x))'+q(x)y(x) = elam.w(x).y(x) (a0) and (ifail.ne.12.OR.14) the calculation must be stopped: IF (ifail.EQ.12 .OR. ifail.EQ.14) GO TO 40 IF (ifail.NE.0) GO TO 100 C END OF ERROR TRAPPING. C This has generated a mesh which is appropriate for the highest index C eigenvalue. We now test the mesh on all the other eigenfunctions to make C sure that it is appropriate for the lower index eigenvalues. In the C process we generate coarse-mesh approximations to the lower index C eigenpairs. istart = 0 iend = no icfn = icofun C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1 .OR. icofun.EQ.3) THEN icfn = icofun + 1 END IF 40 IF (m.GT.1) THEN C IFAIL has one of the values 0, 12, 14. IF (ifail.NE.0) GO TO 60 DO 50 i = 1,m C Adapt the mesh appropriately for the K(i)th eigenfunction. C First compute K(i)th coarse-mesh eigenvalue. IF (i.EQ.1) THEN IF (elam(1,i).GT.elam(1,m)) THEN eps = max(eps,half* (elam(1,i)-elam(1,m))) elam(1,i) = elam(1,m) - two*eps END IF END IF IF (i.GT.1 .AND. i.LT.m) THEN IF (elam(1,i).LT.elam(1,i-1) .OR. & elam(1,i).GT.elam(1,m)) THEN elam(1,i) = dble((k(i)-k(i-1))/ (k(m)-k(i-1)))**2 elam(1,i) = elam(1,i-1) + & elam(1,i)* (elam(1,m)-elam(1,i-1)) eps = half* (elam(1,m)-elam(1,i-1)) END IF END IF iq = np/2 trans = .false. toloc = 0.D0 CALL solve(elam(1,i),eps,k(i),np,iq,maxit,setup, & wksmal(1,2),wksmal(1,3),wksmal(1,4), & wksmal(0,1),trans,toloc,iflag) C Error trap: IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF C END of error trap. C Next compute coarse mesh eigenfunction: elam0 = elam(1,i) CALL norfun(wksmal(0,5),wksmal(0,6),wksmal(0,7),smatch, & elam0,zero,k(i),np,iq,wksmal(1,2),wksmal(1,3), & wksmal(1,4),wksmal(0,1),setup,trans,iflag) elam(1,i) = elam0 C Error trap (only possibility is IFLAG = 3) IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF C END of error trap. C Now use coarse mesh eigenfunction to adapt the mesh. shift = .true. IF (i.EQ.1) shift = .false. CALL admesh(elam(1,i),wksmal(1,2),wksmal(1,3),wksmal(1,4), & wksmal(0,1),wksmal(0,5),wksmal(0,6), & wksmal(0,7),wk(1,2),wk(1,3),wk(1,4),wk(0,1),n, & np,tol,iq,shift,istart,iend,params,iparam, & coeffn,icfn,iflag) IF (iflag.NE.0) THEN C Only possibilities are IFAIL = 10 and IFAIL = 11 ifail = iflag GO TO 100 END IF n = iend iend = no 50 CONTINUE C Put the correct function values back into the arrays pp,qp,wp: CALL initia(coeffn,wk(1,2),wk(1,3),wk(1,4),wk(0,1),n,params, & iparam,icfn) C We now have an adapted mesh, and it is stored in the places 0,1,..,iend C on the mesh. This is our fine mesh with which we continue the computation. CALL check(n,wk(1,2),iflag) IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF 60 DO 80 i = 1,m eps = elam(2,i)/10.D0 imatch = 1 dummy = (elam(1,i)*wk(imatch,4)-wk(imatch,3))/wk(imatch,2) DO 70 ii = 1,n compar = (elam(1,i)*wk(ii,4)-wk(ii,3))/wk(ii,2) IF (compar.GT.dummy) THEN imatch = ii dummy = compar END IF 70 CONTINUE IF (sym) imatch = n/2 IF (i.EQ.1) THEN IF (elam(1,i).GT.elam(1,m)) THEN eps = max(eps,half* (elam(1,i)-elam(1,m))) elam(1,i) = elam(1,m) - two*eps END IF END IF IF (i.GT.1 .AND. i.LT.m) THEN IF (elam(1,i).LT.elam(1,i-1) .OR. & elam(1,i).GT.elam(1,m)) THEN elam(1,i) = dble((k(i)-k(i-1))/ (k(m)-k(i-1)))**2 elam(1,i) = elam(1,i-1) + & elam(1,i)* (elam(1,m)-elam(1,i-1)) eps = half* (elam(1,m)-elam(1,i-1)) END IF END IF trans = .false. toloc = tol/10.D0 CALL solve(elam(1,i),eps,k(i),n,imatch,maxit,setup, & wk(1,2),wk(1,3),wk(1,4),wk(0,1),trans,toloc, & iflag) IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF 80 CONTINUE END IF C Now halve the mesh and compute improved approximations: newmsh = 2*n icfn = 2 CALL fillin(n,newmsh,wk(0,1),wk(1,2),wk(1,3),wk(1,4),coeffn, & params,iparam,icfn) imatch = 2*imatch IF (sym) imatch = newmsh/2 n = newmsh C Recompute the eigenvalues: DO 90 i = 1,m eps = elam(2,i)/20.D0 elam0 = elam(1,i) trans = .false. toloc = 0.D0 CALL solve(elam0,eps,k(i),n,imatch,maxit,setup,wk(1,2), & wk(1,3),wk(1,4),wk(0,1),trans,toloc,iflag) IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF C Aitken extrapolation: elam(2,i) = (elam(1,i)-elam0)/3.D0 elam(1,i) = elam0 - elam(2,i) 90 CONTINUE a = wk(0,1) b = wk(n,1) wk(0,2) = imatch IF (ifail.NE.12 .AND. ifail.NE.14) ifail = 0 RETURN 100 IF (ifail.NE.0) THEN C Output error trapping nrec = 1 GO TO (110,120,130,140,150,160,170,180,190, & 200,210,220,230,240) ifail 110 WRITE (rec,FMT=9120) 9120 FORMAT ('** Parameter error') GO TO 250 120 WRITE (rec,FMT=9130) 9130 FORMAT ('** P(X) is not strictly positive') GO TO 250 130 WRITE (rec,FMT=9140) 9140 FORMAT ('** Invalid boundary conditions') GO TO 250 140 WRITE (rec,FMT=9150) k(m) 9150 FORMAT ('** Cannot find eigenvalue with index',I6) GO TO 250 150 WRITE (rec,FMT=9160) 9160 FORMAT ('** Danger of floating overflow near endpoints') GO TO 250 160 WRITE (rec,FMT=9170) maxit 9170 FORMAT ('**',i8, & ' iterations were not enough to locate an eigenvalue') GO TO 250 170 WRITE (rec,FMT=9180) maxit 9180 FORMAT ('** More than ',i8, & ' attempts to bracket an eigenvalue') GO TO 250 180 WRITE (rec,FMT=9190) knobs(1) 9190 FORMAT ('** More than ',i8,' attempts to truncate interval') GO TO 250 190 WRITE (rec,FMT=9200) 9200 FORMAT (' ** Miss-distance non-monotone over a wide range') GO TO 250 200 WRITE (rec,FMT=9210) 9210 FORMAT ('** Meshing routine could make no further progress') GO TO 250 210 WRITE (rec,FMT=9220) 9220 FORMAT ('** Meshing routine ran out of storage') GO TO 250 220 WRITE (rec,FMT=9230) 9230 FORMAT ( & '** Meshing routine ran out of storage and used ad-hoc mesh' & ) GO TO 250 230 WRITE (rec,FMT=9240) 9240 FORMAT ('** Serious internal error: try different TOL') GO TO 250 240 WRITE (rec,FMT=9250) 9250 FORMAT ('** Cannot obtain required accuracy ') GO TO 250 END IF 250 ifail = p01abf(ifo,ifail,srname,nrec,rec) RETURN END SUBROUTINE sl02fm C --------------------------------------------------------------------- SUBROUTINE admesh(elam,ptemp,qtemp,wtemp,xtemp,rlog,theta,scale, & pp,qp,wp,xmesh,n,ntemp,tol,imatch,shift,istart, & iend,params,iparam,coeffn,icofun,ifail) C The mesh is stored in the places xmesh(n),..,xmesh(istart) and the rest of C the array contains no useful information. RLOG(0:ntemp), SCALE(0:ntemp), C THETA(0:ntemp) and ELAM are available to represent the eigenfunction with C which the adaptation of the mesh will be carried out. C Initialising Stage: C Ifail: C .. Parameters .. DOUBLE PRECISION half,safe1,safe2,one,sixth,trd,twelf,zero,two, & tenth,fifth PARAMETER (half=5.D-1,safe1=9.D-1,safe2=8.D-1,one=1.D0, & sixth=one/6.D0,trd=one/3.D0,twelf=half*sixth,zero=0.D0, & two=2.D0,tenth=1.D-1,fifth=two*tenth) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,tol INTEGER icofun,iend,ifail,imatch,iparam,istart,n,ntemp LOGICAL shift C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(0:iend),ptemp(1:ntemp), & qp(1:iend),qtemp(1:ntemp),rlog(0:ntemp), & scale(0:ntemp),theta(0:ntemp),wp(1:iend), & wtemp(1:ntemp),xmesh(0:iend),xtemp(0:ntemp) C .. C .. Local Scalars .. DOUBLE PRECISION errest,errpm,errpp,errqm,errqp,errw1,errw2,errwm, & errwp,gamma,h,omega1,omega2,omega3,p1,p2,p3,q1, & q2,q3,toloc,tolow,w1,w2,w3,weight,x1,x2,x3 INTEGER i,idi,j,k,kntr LOGICAL phase1,repeat C .. C .. Local Arrays .. DOUBLE PRECISION pdyval(0:1),xvals(0:1),yvals(0:1) C .. C .. External Subroutines .. cc EXTERNAL coefun,efun C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min,sign,sqrt C .. C .. External Functions .. cc DOUBLE PRECISION hloc cc EXTERNAL hloc C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. ifail = 0 IF (iend.EQ.istart) RETURN C Local Tolerance: toloc = tol tolow = toloc*safe2 phase1 = .true. repeat = .false. k = 0 kntr = 0 i = istart idi = 1 IF (iend.LT.istart) idi = -1 C We use the array PP as storage for the new mesh being formed. x1 = xmesh(i) x3 = xmesh(i+idi) pp(i) = x1 10 h = x3 - x1 x2 = half* (x1+x3) IF (repeat) THEN p1 = p3 q1 = q3 w1 = w3 ELSE CALL coefun(x1,p1,q1,w1,coeffn,params,iparam,icofun) END IF CALL coefun(x2,p2,q2,w2,coeffn,params,iparam,icofun) CALL coefun(x3,p3,q3,w3,coeffn,params,iparam,icofun) C Do error estimation: ****************************************** IF (x1.LE.x3) THEN errw1 = w1 - w2 errw2 = w3 - w2 errwm = elam*errw1 errwp = elam*errw2 errpp = (one/p3-one/p2) errpm = (one/p1-one/p2) errqp = (q3-q2) errqm = (q1-q2) xvals(0) = x1 xvals(1) = x3 ELSE errw1 = w3 - w2 errw2 = w1 - w2 errwp = elam*errw2 errwm = elam*errw1 errpm = (one/p3-one/p2) errpp = (one/p1-one/p2) errqm = (q3-q2) errqp = (q1-q2) xvals(0) = x3 xvals(1) = x1 END IF IF (phase1) THEN CALL efun(xvals,yvals,pdyval,elam,rlog,theta,scale,xtemp, & ptemp,qtemp,wtemp,1,ntemp,imatch) ELSE IF (x1.LE.x3) THEN IF (.NOT.repeat) THEN yvals(0) = yvals(1) pdyval(0) = pdyval(1) END IF CALL efun(xvals(1),yvals(1),pdyval(1),elam,rlog,theta, & scale,xtemp,ptemp,qtemp,wtemp,0,ntemp,imatch) ELSE IF (.NOT.repeat) THEN yvals(1) = yvals(0) pdyval(1) = pdyval(0) END IF CALL efun(xvals(0),yvals(0),pdyval(0),elam,rlog,theta, & scale,xtemp,ptemp,qtemp,wtemp,0,ntemp,imatch) END IF END IF C END of eigenfunction evaluation. errest = twelf*abs(h* (errw1*min(one,yvals(0)**2)+errw2*min(one, & yvals(1)**2))) errwm = errwm - errqm errwp = errwp - errqp C There are a number of other different error monitors to be used, depending C on whether the behaviour of solutions of the differential equation. C Compute Prufer radius for use: weight = half*sqrt(yvals(0)**2+pdyval(0)**2+yvals(1)**2+ & pdyval(1)**2) C Measure rate of oscillation: omega2 = (elam*w2-q2)/p2 C WEIGHT may be quite small near the endpoints, where other eigenfunctions C do not decay just as fast. Since weight is supposed to take account of these C other eigenfunctions we adjust its value where appropriate: IF (omega2.LT.zero) THEN IF (q2.LT.two*max(one,abs(elam))*w2) THEN C It is not clear that there is any representative rate of decay for nearby C eigenfunctions: a small increase in elam could change everything. weight = max(weight,tenth) ELSE C We can be reasonably confident that the rate of decay of nearby C eigenfunctions will be at least half as fast as that of the present C eigenfunction. gamma = sqrt((two*max(one,elam)*w2-q2)/ (elam*w2-q2)) weight = max(weight,weight**gamma) END IF ELSE weight = max(weight,min(tenth,two*weight)) END IF C First error monitor, valid in regions which are not highly oscillatory. C This controls the components of the eigenfunction which are not linearly C dependent on the exact eigenfunction: errest = max(errest,sixth*weight* & abs(h* (abs(yvals(0)*errwm+yvals(1)*errwp)/sqrt(max(one, & omega2))+abs(errpm*pdyval(0)+errpp*pdyval(1))))) C Second error monitor, uses Simpson's rule to measure a local contribution C to the Green's formula for eigenvalue error: errest = max(errest,sixth*abs(h* ((yvals(0)**2)*errwm+ & (yvals(1)**2)*errwp+errpm* (pdyval(0)**2)+ & errpp* (pdyval(1)**2))))/max(one,abs(elam)) IF ((h**2)*omega2.GT.half) THEN C Safeguard in highly oscillatory regions: in such regions we can control C eigenvalue error by controlling error in Prufer theta: omega1 = sqrt(abs(elam*w1-q1)/p1) omega3 = sqrt(abs(elam*w3-q3)/p3) omega2 = sqrt(omega2) errest = max(errest,abs(two* (p2/w2)*omega2* (omega1- & two*omega2+omega3)*h)/max(one,elam)) END IF C All the error monitors here are O(h**3) for small h. C END of error estimation. ******************************************** C Decide what to do next, depending on size of error: IF (errest.LE.toloc) THEN C Check that the error is not TOO small IF (errest.LT.tolow .AND. k.EQ.0) THEN h = h/max(fifth, (errest/tolow)**trd) IF (phase1) THEN repeat = .true. kntr = kntr + 1 IF (kntr.LT.8) GO TO 10 END IF END IF C the error test has been passed; move to next step if there is one. repeat = .false. phase1 = .false. i = i + idi pp(i) = x3 IF ((xmesh(n)-x3)*idi.LE.zero) THEN C The end of the range has been reached GO TO 20 END IF C If we are here then it means that the meshing must continue. x1 = x3 x3 = x3 + sign(one,h)*min(abs(h),hloc(x3,xmesh,n)) IF ((xmesh(n)-x3)*idi.LE.zero) THEN x3 = xmesh(n) END IF k = 0 GO TO 10 ELSE repeat = .true. C the error test has been failed; reduce the stepsize and repeat step. C Error traps: IF ((iend-i)*idi.LE.zero) THEN C Run out of space ifail = 11 GO TO 40 END IF k = k + 1 IF (k.GE.8) THEN C Coefficients are too nasty ifail = 10 GO TO 40 END IF C END of error traps h = h*min(safe1, (toloc/errest)**trd) x3 = x1 + h GO TO 10 END IF 20 CONTINUE C We now have an adapted mesh, which is stored in the array spaces C pp(istart),..,pp(i). We copy it into the corresponding slots in the array C xmesh. iend = i DO 30 j = istart,iend,idi xmesh(j) = pp(j) 30 CONTINUE 40 RETURN END SUBROUTINE admesh C ------------------------------------------------------------------------ DOUBLE PRECISION FUNCTION HLOC(X,XMESH,N) C .. Parameters .. DOUBLE PRECISION HALF,ONE PARAMETER (HALF=5.D-1,ONE=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION X INTEGER N C .. C .. Array Arguments .. DOUBLE PRECISION XMESH(0:N) C .. C .. Local Scalars .. INTEGER J DOUBLE PRECISION XHI,XLO,HHI,HLO,S C .. IF (X.LE.HALF*(XMESH(0)+XMESH(1))) THEN HLOC = XMESH(1)-XMESH(0) ELSE IF (X.GE.HALF*(XMESH(N-1)+XMESH(N))) THEN HLOC = XMESH(N)-XMESH(N-1) ELSE DO 10 J = 1,N-1 XLO = HALF*(XMESH(J-1)+XMESH(J)) XHI = HALF*(XMESH(J)+XMESH(J+1)) IF (X.GE.XLO.AND.X.LT.XHI) THEN HHI = XMESH(J+1)-XMESH(J) HLO = XMESH(J)-XMESH(J-1) S = (X-XLO)/(XHI-XLO) HLOC = S*HHI + (ONE-S)*HLO RETURN END IF 10 CONTINUE END IF RETURN END FUNCTION HLOC C --------------------------------------------------------------------- C --------------------- Source from SNEW ----------------------------- C --------------------------------------------------------------------- SUBROUTINE eigen(elam0,elam,eps,a,b,k,n,ntemp,imatch,np,ising, & isymm,lknt,maxit,coeffn,setup,pp,qp,wp,xmesh, & ptemp,qtemp,wtemp,xtemp,rlog,theta,scale,tol, & noxtrp,params,iparam,icofun,ifail) C .. Parameters .. DOUBLE PRECISION three,six,smatch,one,zero,two,half,tqtr,p9 PARAMETER (three=3.D0,six=6.D0,smatch=1.D0,one=1.D0,zero=0.D0, & two=2.D0,half=5.D-1,tqtr=three/4.D0,p9=9.D-1) C .. C .. Scalar Arguments .. DOUBLE PRECISION a,b,elam,elam0,eps,tol INTEGER icofun,ifail,imatch,iparam,ising,isymm,k,lknt,maxit,n,np, & ntemp LOGICAL noxtrp C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(1:n),ptemp(1:ntemp),qp(1:n), & qtemp(1:ntemp),rlog(0:ntemp),scale(0:ntemp), & theta(0:ntemp),wp(1:n),wtemp(1:ntemp),xmesh(0:n), & xtemp(0:ntemp) C .. C .. Subroutine Arguments .. EXTERNAL coeffn,setup C .. C .. Local Scalars .. DOUBLE PRECISION atrunc,btrunc,diff,dtha,dthb,elamo,epso,fynyt, & ovflow,pc,pi,qc,rat1,rat2,rat3,rmatch,sc,shift, & store,th,tolmsh,toloc,wc,xc INTEGER i,icfn,idmmy,ifc,ifo,imesh,iq,iref,isingo,itime,itw, & itwm1,knt,lknto,newmsh,nmesh,npo LOGICAL trans C .. C .. External Functions .. cc DOUBLE PRECISION dtheta,x01aaf,x02ahf,x02alf cc EXTERNAL dtheta,x01aaf,x02ahf,x02alf C .. C .. External Subroutines .. cc EXTERNAL check,coarse,coefun,fillin,initia,mmesh,norfun,solve C .. C .. Intrinsic Functions .. INTRINSIC abs,dble,max,min,nint,sqrt C .. C Set a big number to approximate infinity: ovflow = sqrt(x02alf(1.D0)) C .. C Check input for errors (and change in certain cases) C IF (abs(ifail).GT.1) THEN ifail = -abs(ifail) GO TO 150 END IF C IF (n.LT.10 .OR. tol.LE.0.0D0 .OR. eps.LE.0.0D0 .OR. b.LE.a) THEN ifail = 1 GO TO 150 END IF C C End of input checks. C pi = x01aaf(pi) C C Store the input values of certain parameters which may be changed by the C code: C ifo = ifail lknto = lknt isingo = ising elamo = elam0 epso = eps ifail = 0 C trans determines when we are to perform transformation of independent C variables: C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. trans = icofun .EQ. 1 .OR. icofun .EQ. 3 C C Set default values on certain parameters: C IF (maxit.EQ.0) maxit = 100 IF (lknt.EQ.0) lknt = 60 IF (np.LE.5) np = 10 C np is stored so that it may be used to control the maximum mesh size: npo = np C The paramter itime is needed to count how many ends have been truncated if C the problem is singular: itime = 0 C The parameter iref is needed to count how many times we have tried to C find a mesh to give decent accuracy, without success: iref = 0 C C Set the match-point integer for the computation of the initial approximation C to the eigenvalue. C iq = np/2 C C Set up artificial end-points according to the value of the ISING parameter C IF (ising.EQ.0) THEN C The problem is regular atrunc = a btrunc = b ELSE IF (ising.EQ.1) THEN C Singular point at x=a; truncate: atrunc = a + (b-a)/six btrunc = b ELSE IF (ising.EQ.2) THEN C Singular point at x=b; truncate: atrunc = a btrunc = b - (b-a)/six ELSE C Both ends are singular; truncate: atrunc = a + (b-a)/six btrunc = b - (b-a)/six END IF C Set the initial step size for approaching a singular endpoint: shift = (btrunc-atrunc)/np C Compute initial approximation with truncated end-points: C 1: Set up an initial mesh of np points: CALL coarse(np,atrunc,btrunc,xmesh,0) C 2: Set up the arrays of coefficient function values at the mesh centres: CALL initia(coeffn,pp,qp,wp,xmesh,np,params,iparam,icofun) C 3: Check the array PP to see that p is an admissible coefficient function (>0) ifc = 0 CALL check(np,pp,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF C C 4: Solve the discrete S-L problem on the small mesh of np points to get C initial approximation to the eigenvalue: C toloc = tol/10.D0 CALL solve(elam0,eps,k,np,iq,maxit,setup,pp,qp,wp,xmesh,trans, & toloc,ifail) C Special treatment of regular problems: do not need to change the C end-points inview of the estimate obtained. Note also that no failures C are tolerated for regular problems. IF (ising.EQ.0) THEN nmesh = n/2 IF (ifail.NE.0) GO TO 150 C Go straight to the final two sweeps on adapted meshes, with C Richardson extrapolation. GO TO 50 END IF C ******************************************************************** C **Only singular problems from here until the statement labelled 50** C ******************************************************************** C IF (ifail.EQ.7) THEN C This can happen if we truncate too far in and so we reset the ifail and C elam0 to their old values and choose new truncated end-points. ifail = 0 elam0 = elamo END IF C Other types of failure are not to be tolerated! IF (ifail.NE.0) GO TO 150 C We now have an initial estimate of the eigenvalue, from which C we can decide how to truncate the interval. IF (ising.EQ.3) THEN C We pretend that the problem is only singular at x=a and deal with truncation C at that end first. We set itime=1 to denote the fact that we are dealing with C the first of two singular points in this case. itime = 1 ising = 1 END IF C We can now start the sequence of computations which leads to the C choice of the truncated endpoint(s). knt counts the number of attempts C to find each suitable endpoint, and must not exceed lknt. knt = 1 C Add an extra point closer to the singular point under consideration: 20 np = np + 1 iq = np/2 IF (ising.EQ.1) THEN C Add the point between atrunc and a: DO 30 i = np,2,-1 pp(i) = pp(i-1) qp(i) = qp(i-1) wp(i) = wp(i-1) xmesh(i) = xmesh(i-1) 30 CONTINUE xmesh(1) = xmesh(0) xmesh(0) = xmesh(0) - min(shift,tqtr* (xmesh(0)-a)) atrunc = xmesh(0) xc = xmesh(0) + half* (xmesh(1)-xmesh(0)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(1) = pc qp(1) = qc wp(1) = wc END IF IF (isymm.EQ.1) THEN C This is a special case: the interval has two singular endpoints and must be C truncated symmetrically, so we must add an extra point at the other end too: np = np + 1 iq = np/2 END IF IF (ising.EQ.2 .OR. isymm.EQ.1) THEN C Add in an extra mesh-point between btrunc and b. In the case isymm = 1 this C is done purely to preserve symmetry. xmesh(np) = xmesh(np-1) + min(shift,tqtr* (b-xmesh(np-1))) btrunc = xmesh(np) xc = xmesh(np-1) + half* (xmesh(np)-xmesh(np-1)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(np) = pc qp(np) = qc wp(np) = wc END IF C Check that p(x) never vanishes or becomes negative: ifc = 0 CALL check(np,pp,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF C Extra point or points have been added; compute the eigenvalue and see if C the the extra point(s) have made it change by much (store the old value in C elam0 for comparison) elam = elam0 CALL solve(elam,eps,k,np,iq,maxit,setup,pp,qp,wp,xmesh,trans, & toloc,ifail) C WRITE (6,FMT=9000) xmesh(0),xmesh(np),elam,ifail IF (ifail.EQ.7) THEN C This failure can be caused by truncating too much when certain asymptotic C forms are used for the boundary conditions. We must see at which end of the C interval the eigenfunction is oscillating most rapidly, and concentrate on C that end provided this will not risk overflow. rat1 = (elam*wp(1)-qp(1))/pp(1) rat2 = (elam*wp(np)-qp(np))/pp(np) C Check for danger of overflow: rat3 = max(rat1,rat2) IF ((rat3.GE.0.D0.AND.sqrt(abs(rat3)).GE.1.0D-2*x02ahf(0.D0)) & .OR.max(abs(rat1),abs(rat2)).GE.ovflow) THEN a = xmesh(0) b = xmesh(np) GO TO 150 END IF C End of overflow check. Now select the end of the interval with most rapid C oscillations. Note that if the problem has only one singular end then C itime = 0 so there is no danger of treating a regular end as singular. IF (itime.EQ.1 .AND. isymm.NE.1) THEN IF (rat2.GT.rat1) THEN ising = 2 ELSE ising = 1 END IF END IF ifail = 0 elam = elam0 diff = 10.0D0*tol GO TO 40 C End of special treatment for IFAIL = 7 failures. END IF C Other failures (ifail \neq 7) are not tolerated! IF (ifail.NE.0) GO TO 150 diff = abs(elam-elam0)/max(one,abs(elam)) C There is no danger in setting eps = diff; for if diff=0 then we will C not be calling SOLVE without resetting eps to its original value epso. eps = diff 40 knt = knt + 1 elam0 = elam IF (knt.GE.lknt) THEN C Cannot find a suitable end-point in lknt steps ifail = 8 a = xmesh(0) b = xmesh(np) GO TO 150 END IF C Less than lknt steps taken, but endpoints not yet satisfactory: IF (diff.GT.tol) THEN C Check to see if endpoint(s) can be moved without danger of overflow. fynyt = (elam*wp(1)-qp(1))/pp(1) IF ((fynyt.GE.0.D0.AND.sqrt(abs(fynyt)).GE. & 1.0D-2*x02ahf(0.D0)) .OR. abs(fynyt).GE.ovflow) THEN ifail = 5 a = xmesh(0) b = xmesh(np) GO TO 150 END IF fynyt = (elam*wp(np)-qp(np))/pp(np) IF ((fynyt.GE.0.D0.AND.sqrt(abs(fynyt)).GE. & 1.0D-2*x02ahf(0.D0)) .OR. abs(fynyt).GE.ovflow) THEN ifail = 5 a = xmesh(0) b = xmesh(np) GO TO 150 END IF C If we get through the last loop then we can indeed move an endpoint. Loop C back to 20 to do this. GO TO 20 END IF C C If we are doing a problem with TWO SINGULAR POINTS and itime=1 then only the C end of the interval where the eigenfunction oscillates most rapidly has been C dealt with so far. IF (itime.EQ.1 .AND. isymm.NE.1) THEN IF (ising.EQ.1) THEN ising = 2 ELSE ising = 1 END IF elam0 = elam C See, I told you we would reset eps! eps = epso knt = 1 itime = 2 C Loop back to start truncation procedure for the other end. GO TO 20 END IF C ******************************************************************* C **** End of interval truncation for singular problems *********** C ******************************************************************* C We now have some approximations to the eigenvalue, as well as C suitable truncated endpoints. atrunc = xmesh(0) btrunc = xmesh(np) C We are now ready to solve our problem on the truncated interval. We will C compute two approximations in order to get an error estimate. elam0 = elam eps = epso C Our first fine mesh will have only half as many points as our eventual mesh nmesh = n/2 C Find a suitable matching point (it is at this stage that regular problems C come back under consideration -- see the GO TO 50 above). 50 IF (isymm.EQ.1) THEN rmatch = half* (atrunc+btrunc) ELSE rmatch = xmesh(iq) store = elam0*wp(iq) - qp(iq) DO 60 idmmy = 1,np - 1 IF ((elam0*wp(idmmy)-qp(idmmy)).GT.store) THEN store = elam0*wp(idmmy) - qp(idmmy) rmatch = xmesh(idmmy) END IF 60 CONTINUE END IF C C In order to form the mesh for the final two sweeps, we need to know a C decent approximation to the eigenfunction, which we get by using a coarse C mesh of at most ntemp or 100 points. 70 IF (np.LT.min(n/2,ntemp/2,50)) THEN C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1 .OR. icofun.EQ.3) THEN icfn = icofun + 1 DO 80 i = np,1,-1 itw = 2*i itwm1 = itw - 1 xmesh(itw) = xmesh(i) xmesh(itwm1) = half* (xmesh(i)+xmesh(i-1)) 80 CONTINUE np = 2*np GO TO 70 ELSE CALL fillin(np,2*np,xmesh,pp,qp,wp,coeffn,params,iparam, & icofun) np = 2*np GO TO 70 END IF END IF C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1 .OR. icofun.EQ.3) THEN xmesh(0) = xmesh(0)/ (one-abs(xmesh(0))) icfn = icofun + 1 C From now on we abandon transformed coordinates: trans = .false. DO 90 i = 1,np xmesh(i) = xmesh(i)/ (one-abs(xmesh(i))) CALL coefun(half* (xmesh(i-1)+xmesh(i)),pp(i),qp(i),wp(i), & coeffn,params,iparam,icfn) 90 CONTINUE END IF xtemp(0) = xmesh(0) DO 100 i = 1,np xtemp(i) = xmesh(i) ptemp(i) = pp(i) qtemp(i) = qp(i) wtemp(i) = wp(i) 100 CONTINUE ifc = 0 CALL check(np,ptemp,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF ising = isingo eps = epso iq = np/2 toloc = 0.D0 CALL solve(elam0,eps,k,np,iq,maxit,setup,ptemp,qtemp,wtemp,xtemp, & trans,toloc,ifc) C WRITE (6,FMT=*) elam0,np,ifc IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF CALL norfun(rlog,theta,scale,smatch,elam0,zero,k,np,iq,ptemp, & qtemp,wtemp,xtemp,setup,trans,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF C Check all singular problems to make sure we have not strayed into the C continuous spectrum. IF (isingo.NE.0) THEN dtha = zero dthb = zero IF (isingo.GT.1) THEN th = theta(np) sc = scale(np) dthb = dtheta(th,sc,elam0,btrunc,b,coeffn,params,iparam, & icofun) END IF IF (isingo.NE.2) THEN th = theta(0) sc = scale(0) dtha = dtheta(th,sc,elam0,atrunc,a,coeffn,params,iparam, & icofun) END IF IF ((dtha+dthb).GE.two*pi) THEN ifail = 4 ising = isingo lknt = lknto a = atrunc b = btrunc RETURN END IF END IF C End of check for continuous spectrum. C We can now choose the new mesh using an appropriate equidistribution C process. This is done by calling the routine MMESH. C Note the special status of the IFC parameter for this routine. On C entry, it equals the value which IFAIL had on entry to EIGEN, and C if that value was 1, then an emergency mesh will be used if the C routine runs out of space. If this happens then ifc will be set to C 12 on exit. C imesh = nmesh IF (isymm.EQ.1) imesh = (imesh-1)/2 ifc = ifo C Store the eigenvalue corresponding to the eigenfunction which is C used for meshing; this will be useful later. elamo = elam0 C tolmsh = tol 110 CALL mmesh(rmatch,atrunc,0,elam0,coeffn,rlog,theta,scale,xtemp, & ptemp,qtemp,wtemp,np,iq,xmesh,pp,qp,wp,imesh,tolmsh,npo, & params,iparam,icofun,ifc) C C Error handling: C IF (ifc.NE.0) THEN C The routine cannot produce a mesh to meet the users tolerance C within the allocated storage, or has ground to a halt because the C coefficient functions are too pathological C ifail = ifc IF (ifail.NE.12) GO TO 150 END IF C C End of error handling; produce second half of mesh; C in symmetric case we just need to reflect the mesh through the midpoint: C IF (isymm.EQ.1) THEN C Just reflect the mesh through its right-hand endpoint if the problem C is symmetric. nmesh = 2*imesh xmesh(nmesh) = xmesh(0) DO 120 i = 1,imesh xmesh(imesh+i) = two*rmatch - xmesh(imesh-i) pp(imesh+i) = pp(imesh-i+1) qp(imesh+i) = qp(imesh-i+1) wp(imesh+i) = wp(imesh-i+1) 120 CONTINUE ELSE C End of symmetric case. C ifc = ifo CALL mmesh(rmatch,btrunc,imesh,elam0,coeffn,rlog,theta,scale, & xtemp,ptemp,qtemp,wtemp,np,iq,xmesh,pp,qp,wp,nmesh, & tolmsh,npo,params,iparam,icofun,ifc) C C Error handling: C IF (ifc.NE.0) THEN C The routine cannot produce a mesh to meet the users tolerance C within the allocated storage, or has ground to a halt because the C coefficient functions are too pathological C ifail = ifc IF (ifail.NE.12) GO TO 150 END IF C C End of error handling C if no error has occured then nmesh is now set to a new value which C is equal to the actual number of intervals in the computed mesh C and is less than or equal to its input value. C END IF C We now have a mesh which can be stored within the user-specified C storage, and which is adapted in a suitable manner to help achieve C the user-specified tolerance. we compute the first approxmation to C the eigenvalue by using this mesh. C C Check that the array pp has no zero or negative entries: ifc = 0 CALL check(nmesh,pp,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF C C We are now ready for the first of the two final computations. IFAIL now C has one of two values 0 or 12, the second (if it arises) coming from the C use of an emergency mesh. ifc = 0 toloc = tol/100.D0 CALL solve(elam0,eps,k,nmesh,imesh,maxit,setup,pp,qp,wp,xmesh, & trans,toloc,ifc) eps = epso/1.D2 C C Store the eigenvalue estimate for extrapolation later C elam = elam0 C C Error handling: IF (ifc.NE.0) THEN IF (ifail.EQ.12) GO TO 130 ifail = ifc GO TO 150 END IF IF (noxtrp) THEN a = atrunc b = btrunc n = nmesh imatch = imesh ising = isingo lknt = lknto RETURN END IF C Now we halve the mesh-size and repeat the process to obtain a C better eigenvalue approximation. the mesh-size is halved by C adding in all the midpoints of intervals in the current mesh. C the arrays pp,qp,wp also must be updated, and all this is done C by the routine fillin. storage is always adequate since, if it C were not, this would have been detected by the mesh routine above. 130 newmsh = 2*nmesh C Reset match-point index: imesh = 2*imesh icfn = icofun C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1) THEN icfn = 2 ELSE IF (icofun.EQ.3) THEN icfn = 4 END IF CALL fillin(nmesh,newmsh,xmesh,pp,qp,wp,coeffn,params,iparam,icfn) C eps = epso/100.d0 ifc = 0 toloc = 0.D0 CALL solve(elam0,eps,k,newmsh,imesh,maxit,setup,pp,qp,wp,xmesh, & trans,toloc,ifc) C C Error handling: IF (ifc.NE.0) THEN C ic = imesh n = newmsh a = atrunc b = btrunc IF (ifail.GT.1) THEN GO TO 150 ELSE ifail = ifc GO TO 150 END IF END IF C C Error estimate: eps = (elam-elam0)/three elam0 = elam0 - eps IF (abs(eps)/max(one,abs(elam0)).GT.tol** (two/three) .AND. & ifail.EQ.0) THEN C The accuracy achieved is unacceptable. Go back to the meshing stage with C a reduced minimum mesh size. IF (iref.GT.1) THEN C We have already done this too many times. The problem is simply C too nasty. Fail with appropriate error flag ifail = 14 GO TO 140 END IF iref = iref + 1 rat1 = sqrt(abs(max(one,abs(elam0))* (tol** (two/three))/eps)) npo = nint(dble(npo)/ (tqtr*rat1)) tolmsh = tolmsh*min(p9,rat1** (three/two)) elam0 = elamo nmesh = n/2 imesh = nmesh IF (isymm.EQ.1) imesh = (imesh-1)/2 GO TO 110 END IF C Use elam0 to store the eigenvalue corresponding to the coarse-mesh C eigenfunction which was used for automatic meshing: 140 elam = elamo C C Prepare to return to the user; make sure a and b have the same values C as on entry, not to mention ising. also we set n = newmesh so that the C user can see how many mesh-points were used. lknt = lknto ising = isingo n = newmsh imatch = imesh a = atrunc b = btrunc C write(6,*) 'np before exiting EIGEN: ',np C Either an emergency mesh has been used (IFAIL = 12), or else the accuracy C achieved is inadequate (IFAIL = 14), or else the routine has completed C its run successfully. IF (ifail.NE.12 .AND. ifail.NE.14) ifail = 0 150 RETURN C9000 FORMAT (' ALFA: ',G18.12,' BETA: ',G18.12,' ELAM: ',D10.4, C & ' IFAIL ',I2) END SUBROUTINE eigen C-------------------------------------------------------------------- DOUBLE PRECISION FUNCTION dtheta(theta,scale,elam,bt,b,coeffn, & params,iparam,icofun) C .. Parameters .. DOUBLE PRECISION half PARAMETER (half=5.D-1) C .. C .. Scalar Arguments .. DOUBLE PRECISION b,bt,elam,scale,theta INTEGER icofun,iparam C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Local Scalars .. DOUBLE PRECISION di,ovflow,p,q,qbig,s,th,w,x,xend,xo INTEGER icount C .. C .. External Functions .. cc DOUBLE PRECISION x02alf cc EXTERNAL x02alf C .. C .. External Subroutines .. c EXTERNAL coefun,onestp C .. C .. Intrinsic Functions .. INTRINSIC abs,sign,sqrt C .. ovflow = sqrt(x02alf(1.D0)) th = theta s = scale xo = bt xend = half* (b+bt) dtheta = 0.D0 di = sign(1.D0,b-bt) icount = 0 10 x = half* (xo+xend) CALL coefun(x,p,q,w,coeffn,params,iparam,icofun) qbig = elam*w - q CALL onestp(xo,xend,di,s,th,p,qbig) dtheta = (th-theta)*di icount = icount + 1 IF (icount.GE.5) RETURN IF (abs(qbig).GE.ovflow*p) RETURN xo = xend xend = half* (xend+b) GO TO 10 END FUNCTION dtheta C ------------------------------------------------------------------------- SUBROUTINE solve(elam,eps,k,n,ic,maxit,setup,pp,qp,wp,xmesh,trans, & tol,ifail) C .. Parameters .. DOUBLE PRECISION ten PARAMETER (ten=1.D1) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,eps,tol INTEGER ic,ifail,k,maxit,n LOGICAL trans C .. C .. Array Arguments .. DOUBLE PRECISION pp(n),qp(n),wp(n),xmesh(0:n) C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Scalars in Common .. INTEGER icall,int,ip,ival C .. C .. Local Scalars .. DOUBLE PRECISION da,db,fx,pi,pik,rl1,rl2,tight,xs,ys INTEGER ifd,iflag,ind,ir,nevs C .. C .. Local Arrays .. DOUBLE PRECISION c(17) C .. C .. External Functions .. cc DOUBLE PRECISION d,x01aaf,x02ajf cc EXTERNAL d,x01aaf,x02ajf C .. C .. External Subroutines .. cc EXTERNAL c05azf,intval C .. C .. Common blocks .. COMMON icall,int,ip,ival C .. C .. Intrinsic Functions .. INTRINSIC max C .. pi = x01aaf(pi) pik = k*pi tight = max(x02ajf(0.D0)*ten,tol) ifail = 0 iflag = 0 C WE NOW SEEK TO FIND AN INTERVAL [RL1,RL2] CONTAINING THE C ZERO OF THE FUNCTION D(RL)-K*PI int = ip CALL intval(elam,rl1,rl2,eps,da,db,k,n,ic,pp,qp,wp,xmesh,setup, & trans,iflag) int = ip - int C CHECK THAT THE ERROR FLAG HAS NOT BEEN CHANGED IF (iflag.NE.0) THEN ifail = iflag RETURN END IF C WE NOW HAVE AN INTERVAL [A,B] WITH THE PROPERTY THAT C D(A) <= 0 AND D(B) >= 0 xs = rl1 ys = rl2 ind = -1 ir = 0 nevs = 0 fx = da c(1) = db iflag = 1 20 CALL c05azf(xs,ys,fx,tight,ir,c,ind,iflag) IF (ind.EQ.0) THEN IF (iflag.NE.0 .AND. iflag.NE.5) ifail = 13 GO TO 40 END IF IF (ind.LT.2 .OR. ind.GT.4) THEN ifail = 13 RETURN END IF ifd = 0 fx = d(xs,n,ic,pp,qp,wp,xmesh,setup,trans,ifd) - pik IF (ifd.NE.0) THEN ifail = ifd RETURN END IF nevs = nevs + 1 IF (nevs.GT.maxit) GO TO 30 GO TO 20 30 ifail = 6 RETURN 40 elam = xs RETURN END SUBROUTINE solve C--------------------------------------------------------------------- SUBROUTINE fillin(nmesh,newmsh,xmesh,pp,qp,wp,coeffn,params, & iparam,icofun) C HALVES THE SIZE OF A MESH. C .. Scalar Arguments .. INTEGER icofun,iparam,newmsh,nmesh C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(newmsh),qp(newmsh), & wp(newmsh),xmesh(0:newmsh) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Local Scalars .. DOUBLE PRECISION pc,qc,wc,xc INTEGER i,itw,itwm1 C .. C .. Parameters .. DOUBLE PRECISION half PARAMETER (half=5.D-1) C .. C .. External Subroutines .. cc EXTERNAL coefun C .. DO 10 i = nmesh,1,-1 itw = 2*i itwm1 = itw - 1 xmesh(itw) = xmesh(i) xmesh(itwm1) = half* (xmesh(itw)+xmesh(i-1)) xc = half* (xmesh(itw)+xmesh(itwm1)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(itw) = pc qp(itw) = qc wp(itw) = wc xc = half* (xmesh(itwm1)+xmesh(i-1)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(itwm1) = pc qp(itwm1) = qc wp(itwm1) = wc 10 CONTINUE RETURN END SUBROUTINE fillin C--------------------------------------------------------------------- SUBROUTINE coarse(n,a,b,xmesh,ising) C .. Scalar Arguments .. DOUBLE PRECISION a,b INTEGER ising,n C .. C .. Array Arguments .. DOUBLE PRECISION xmesh(0:n) C .. C .. Local Scalars .. DOUBLE PRECISION h INTEGER i C .. C .. Intrinsic Functions .. INTRINSIC dble C .. xmesh(0) = a xmesh(n) = b IF (ising.EQ.0) THEN C THE PROBLEM IS REGULAR, USE A UNIFORM MESH h = (b-a)/dble(n) DO 10 i = 1,n - 1 xmesh(i) = xmesh(i-1) + h 10 CONTINUE ELSE IF (ising.EQ.1) THEN C X = A IS SINGULAR BUT X = B IS NOT h = (b-a)/dble(n-4) xmesh(1) = xmesh(0) + h/16.0D0 xmesh(2) = xmesh(1) + h/16.0D0 xmesh(3) = xmesh(2) + h/8.0D0 xmesh(4) = xmesh(3) + h/4.0D0 xmesh(5) = xmesh(4) + h/2.0D0 DO 20 i = 6,n - 1 xmesh(i) = xmesh(i-1) + h 20 CONTINUE ELSE IF (ising.EQ.2) THEN C X=A IS REGULAR BUT X = B IS SINGULAR h = (b-a)/dble(n-4) xmesh(n-1) = xmesh(n) - h/16.0D0 xmesh(n-2) = xmesh(n-1) - h/16.0D0 xmesh(n-3) = xmesh(n-2) - h/8.0D0 xmesh(n-4) = xmesh(n-3) - h/4.0D0 xmesh(n-5) = xmesh(n-4) - h/2.0D0 DO 30 i = n - 6,1,-1 xmesh(i) = xmesh(i+1) - h 30 CONTINUE ELSE IF (ising.EQ.3) THEN C BOTH ENDS OF THE INTERVAL ARE SINGULAR POINTS. h = (b-a)/dble(n-8) xmesh(1) = xmesh(0) + h/16.0D0 xmesh(2) = xmesh(1) + h/16.0D0 xmesh(3) = xmesh(2) + h/8.0D0 xmesh(4) = xmesh(3) + h/4.0D0 xmesh(5) = xmesh(4) + h/2.0D0 xmesh(n-1) = xmesh(n) - h/16.0D0 xmesh(n-2) = xmesh(n-1) - h/16.0D0 xmesh(n-3) = xmesh(n-2) - h/8.0D0 xmesh(n-4) = xmesh(n-3) - h/4.0D0 xmesh(n-5) = xmesh(n-4) - h/2.0D0 DO 40 i = 6,n - 6 xmesh(i) = xmesh(i-1) + h 40 CONTINUE ELSE C THERE IS AN ERROR IN THE VALUE OF ISING END IF RETURN END SUBROUTINE coarse C--------------------------------------------------------------------- SUBROUTINE initia(coeffn,pp,qp,wp,xmesh,n,params,iparam,icofun) C .. Scalar Arguments .. INTEGER icofun,iparam,n C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(n),qp(n),wp(n),xmesh(0:n) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Scalars in Common .. INTEGER icall,int,ip,ival C .. C .. Local Scalars .. DOUBLE PRECISION pc,qc,wc,xc INTEGER i C .. C .. Common blocks .. COMMON icall,int,ip,ival C .. C .. External Subroutines .. cc EXTERNAL coefun C .. DO 10 i = 1,n xc = 0.5D0* (xmesh(i)+xmesh(i-1)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(i) = pc qp(i) = qc wp(i) = wc 10 CONTINUE RETURN END SUBROUTINE initia C--------------------------------------------------------------------- SUBROUTINE intval(elc,ela,elb,eps,fa,fb,k,n,ic,pp,qp,wp,xmesh, & setup,trans,iflag) C .. Scalar Arguments .. DOUBLE PRECISION ela,elb,elc,eps,fa,fb INTEGER ic,iflag,k,n LOGICAL trans C .. C .. Array Arguments .. DOUBLE PRECISION pp(n),qp(n),wp(n),xmesh(0:n) C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Local Scalars .. DOUBLE PRECISION h,pi,sub INTEGER ifail,inits,nits C .. C .. External Functions .. cc DOUBLE PRECISION d,x01aaf cc EXTERNAL d,x01aaf C .. C .. Intrinsic Functions .. INTRINSIC abs C .. pi = x01aaf(pi) sub = k*pi ela = elc - abs(eps) elb = elc + abs(eps) nits = 0 inits = 0 ifail = 0 iflag = 0 fa = d(ela,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 fb = d(elb,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 10 h = elb - ela IF (nits.GT.50) THEN GO TO 40 END IF IF (fa.GT.0.0D0 .AND. fb.LT.0.0D0) THEN ela = elb elb = ela + 2.D0*h fa = fb fb = d(elb,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 inits = inits + 1 IF (inits.GT.4) GO TO 30 nits = nits + 1 GO TO 10 END IF IF (fa*fb.LE.0.0D0) GO TO 20 IF (fb.LT.0.0D0) THEN ela = elb fa = fb elb = elb + 2.0D0*h fb = d(elb,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 nits = nits + 1 GO TO 10 END IF IF (fa.GT.0.0D0) THEN elb = ela fb = fa ela = ela - 2.0D0*h fa = d(ela,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 nits = nits + 1 GO TO 10 END IF 20 iflag = 0 RETURN 30 iflag = 9 RETURN 40 iflag = 7 RETURN 50 iflag = ifail RETURN END SUBROUTINE intval C--------------------------------------------------------------- SUBROUTINE nrmlse(yl,pdyl,ifail) C .. Scalar Arguments .. DOUBLE PRECISION pdyl,yl INTEGER ifail C .. C .. Local Scalars .. DOUBLE PRECISION s C .. s = yl**2 + pdyl**2 IF (s.EQ.0.0D0) THEN ifail = 3 RETURN END IF IF (yl.LT.0.0D0) THEN yl = -yl pdyl = -pdyl END IF IF (yl.EQ.0.0D0 .AND. pdyl.LT.0.0D0) THEN pdyl = -pdyl END IF ifail = 0 RETURN END SUBROUTINE nrmlse C--------------------------------------------------------------- SUBROUTINE check(n,pp,ifail) C THIS ROUTINE CHECKS THE INPUT TO ROUTINE D TO ENSURE THAT IT MAKES SENSE. C .. Scalar Arguments .. INTEGER ifail,n C .. C .. Array Arguments .. DOUBLE PRECISION pp(n) C .. C .. Local Scalars .. DOUBLE PRECISION rmini INTEGER i C .. C .. Intrinsic Functions .. INTRINSIC min C .. ifail = 0 rmini = 1.0D0 DO 10 i = 1,n rmini = min(rmini,pp(i)) 10 CONTINUE IF (rmini.LE.0.D0) ifail = 2 RETURN END SUBROUTINE check C ----------------------------------------------------------- SUBROUTINE coefun(x,p,q,w,coeffn,params,iparam,icofun) C .. Scalar Arguments .. DOUBLE PRECISION p,q,w,x INTEGER icofun,iparam C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Local Scalars .. DOUBLE PRECISION ex,fac C .. C .. Intrinsic Functions .. INTRINSIC abs C .. C Params is an unused array introduced to enable the code to be C easily adapted to handle problems with parameter-dependent C coefficients. IF (icofun.EQ.1) THEN fac = 1.D0 - abs(x) ex = x/fac fac = fac**2 CALL coeffn(ex,p,q,w) p = p*fac q = q/fac w = w/fac RETURN ELSE CALL coeffn(x,p,q,w) RETURN END IF END SUBROUTINE coefun C --------------------------------------------------------------------- C --------------------- Source from NEWCOMP --------------------------- C --------------------------------------------------------------------- C Routine for single eigenvalue case: SUBROUTINE sl04f(xval,yvals,pdyval,ival,elam,eigfns,wk,iwk,nval,n, & ifail) C Brief Specification: C This routine takes in appropriate information about the normalised C eigenfunction from the routine SL03F and returns the value of the C normalised eigenfunction at the points xval(i),i=1,nval. C VARIABLES: C XVAL: REAL ARRAY of DIMENSION (0:IVAL). A set of points supplied C by the user. The eigenfunction will be evaluated at the C points XVAL(i) for 0 <= i <= NVAL. (n.b. IVAL is the C DIMENSION of XVAL as declared in the calling (sub)program, C NVAL the number of these points at which the eigenfunction C is to be evaluated). The points in XVAL MUST BE ARRANGED C in ASCENDING ORDER, C XVAL(0) <= XVAL(1) <= XVAL(2) <= ... <= XVAL(NVALS). C otherwise SL04F will rearrange them in this order. C YVALS: REAL ARRAY of DIMENSION (0:IVAL). On exit, YVALS(i) is, for each C 0 <= i <= NVALS, the value of the approximate eigenfunction at C the point XVAL(i). C PDYVAL: REAL ARRAY of DIMENSION (0:IVAL). On exit, PDYVAL(i) is, for each C 0 <= i <= NVALS, the value of the approximation to p(x)y'(x) at C x = XVAL(i). Here p(x) is the coefficient from the defining C equation of the Sturm-Liouville problem, C C -(p(x)y')' + q(x)y = Lambda.w(x)y C ELAM: REAL ARRAY of DIMENSION (1:2). Supplied by the preceding call C to the routine SL02F. Unchanged on exit. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4). Supplied by the preceding C call to the routine SL02F. The preceding call to SL02F need C not occur in the same subprogram, but if it does not then the C array wk must be declared to have the same dimensions in the C subprogram from which SL02F is called as in the subprogrm from C which SL04F is called. C Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3). Supplied by the preceding C call to the routine SL03F. C Unchanged on exit. C IWK: The first dimension of wk as declared in the calling C subprogram. Unchanged on exit. C NVALS: One less than the number of points at which the eigenfunction C is required. Unchanged on exit. C N: The number of mesh intervals used by SL02F in computing the C eigenvalue approximation. Supplied by the preceding call to C SL02F. Unchanged on exit. C END of brief specification. C C Additional Information (for me): C eigfns(i,1) = rlog(i) for i=0,1 C eigfns(i,2) = theta(i) for i=0,1 C eigfns(i,3) = scale(i) for i=0,1. C wk: *real* ARRAY of DIMENSION (0:iwk,1:4). The entries in wk are as C follows: C wk(i,1) = xmesh(i) for i=0,n C wk(i,2) = pp(i) for i=1,n C wk(i,3) = qp(i) for i=1,n C wk(i,4) = wp(i) for i=1,n. C C .. Scalar Arguments .. INTEGER ifail,ival,iwk,n,nval C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3),elam(1:2),pdyval(0:ival), & wk(0:iwk,1:4),xval(0:ival),yvals(0:ival) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER ic C .. C .. External Subroutines .. cc EXTERNAL efn1 C .. C Retrieve matchpoint index from sneaky storage: ic = wk(0,2) C Un-do the Richardson extrapolation: elam0 = elam(1) + elam(2) C Compute the eigenfunction and store in arrays: CALL efn1(xval,yvals,pdyval,elam0,eigfns(0,1),eigfns(0,2), & eigfns(0,3),wk(0,1),wk(1,2),wk(1,3),wk(1,4),nval,n,ic) C IFAIL is included just for compatibility. ifail = 0 END SUBROUTINE sl04f C ---------------------------------------------------------------------------- SUBROUTINE sl03f(elam,k,eigfns,wk,iwk,n,setup,ifail) C This routine computes information required by the routine SL04F in order C to evaluate the normalised eigenfunction. C C Brief Specification: C VARIABLES C ELAM: REAL ARRAY of DIMENSION (1:2). Supplied by the preceding call to C SL02F. Unchanged on exit. C K: The index of the eigenvalue and eigenfunction in question. As C supplied to SL02F for the computation of ELAM. Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3) This array must be supplied C by the user and will be used to store the information about the C normalised eigenfunction required by SL03F. C WK: REAL ARRAY of DIMENSION (0:IWK,1:4). Supplied by the preceding C call to the routine SL02F. The preceding call to SL02F need C not occur in the same subprogram, but if it does not then the C array WK must be declared to have the same dimensions in the C subprogram from which SL02F is called as in the subprogrm from C N: INTEGER. The number of mesh intervals used by the routine SL02F C in the computation of the eigenvalue approximation. Supplied by C the preceding call to SL02F and unchanged on exit. C SETUP: User-supplied SUBROUTINE. The same as supplied to SL02F at the C preceding call to SL02F. C IFAIL: INTEGER. This parameter should be zero on exit. If it is not then C it will have the value 3 indicating an error in the routine SETUP. C END of brief specification C .. Parameters .. DOUBLE PRECISION smatch PARAMETER (smatch=1.0D0) C .. C .. Scalar Arguments .. INTEGER ifail,iwk,k,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3),elam(1:2),wk(0:iwk,1:4) C .. C .. Local Scalars .. INTEGER ic,iflag,nrec CHARACTER srname*6 C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. External Functions C .. External Subroutines .. cc EXTERNAL norfn1 C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Intrinsic Functions .. INTRINSIC abs C .. srname = ' SL03F' nrec = 1 iflag = 0 IF (abs(ifail).GT.1) THEN WRITE (rec,FMT=9000) ifail = -1 iflag = 1 ELSE C Retrive matchpoint index from sneaky storage: ic = wk(0,2) C This routine just acts as an interface for NORFUN CALL norfn1(eigfns(0,1),eigfns(0,2),eigfns(0,3),smatch, & elam(1),elam(2),k,n,ic,wk(1,2),wk(1,3),wk(1,4), & wk(0,1),setup,iflag) IF (iflag.NE.0) THEN WRITE (rec,FMT=9010) ELSE C IF iflag is nonzero iflag will have the value 3 C Eigenfunction has been normalised as required ifail = 0 RETURN END IF END IF ifail = p01abf(ifail,iflag,srname,nrec,rec) 9000 FORMAT (' ** Parameter error: ifail out of range') 9010 FORMAT (' ** Invalid boundary conditions') C$st$ Unreachable comments ... END SUBROUTINE sl03f C------------------------------------------------------------------------------ C Routine for many eigenvalue case: SUBROUTINE sl04fm(xval,yvals,pdyval,ival,elam,k,kvals,m,mvals, & eigfns,wk,iwk,nval,n,ifail) C Brief Specification: C This routine takes in appropriate information about the normalised C eigenfunctions from the routine NRMANY and returns the values of the C normalised eigenfunctions at the points xval(i),i=1,nval. C VARIABLES: C XVAL: REAL ARRAY of DIMENSION (0:IVAL). A set of points supplied C by the user. The eigenfunctions with indices KVALS(i), C i = 1,..,MVALS, will be evaluated at the C points XVAL(i) for 0 <= i <= NVAL. (n.b. IVAL is the C DIMENSION of XVAL as declared in the calling (sub)program, C NVAL the number of these points at which the eigenfunction C is to be evaluated). The points in XVAL MUST BE ARRANGED C in ASCENDING ORDER, C XVAL(0) <= XVAL(1) <= XVAL(2) <= ... <= XVAL(NVALS). C Unchanged on exit. C K: INTEGER array of DIMENSION at least (1:M). This array must C contain the same values as the array by the same name supplied to C the routine NRMANY to generate the eigenfunction information C array EIGFNS. Unchanged on exit. C MVALS: INTEGER. There are M eigenfunctions stored in the array EIGFNS. C MVALS specifies how many of these are to be evaluated at each point C in the array XVALS. MVALS <= M. Unchanged on exit. C KVALS: INTEGER array of DIMENSION at least (1:MVALS). On entry, KVALS C must be set by the user to specify the indices KVALS(i), i = C 1,..,MVALS, of the eigenfunctions to be evaluated. Unchanged C on exit. C YVALS: REAL ARRAY of DIMENSION (0:IVAL,1:p) where p>= MVALS. C On exit, YVALS(i,j) is, for each 0 <= i <= NVALS, 1<=j<=MVALS, C the value of the approximate KVALS(j)th eigenfunction at the C point XVAL(i). C PDYVAL: REAL ARRAY of DIMENSION (0:IVAL,1:p) where p>=MVALS C On exit, PDYVAL(i,j) is, for each 0 <= i <= NVALS, 1<=j<=MVALS C the value of the approximation to p(x)y_{KVALS(j)}'(x) at C x = XVAL(i). Here p(x) is the coefficient from the defining C equation of the Sturm-Liouville problem, C C -(p(x)y')' + q(x)y = Lambda.w(x)y C and y_{KVALS(j)} is the KVALS(j)th eigenfunction of this problem. C ELAM: REAL ARRAY of DIMENSION (1:2,1:p) where p >= m. C Supplied by the preceding call to the routine SL02FM. Unchanged C on exit. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4) C Supplied by the preceding call to the routine SL02FM. The C preceding call to SL02FM need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which SL02FM is called as C in the subprogrm from which SL04F is called. C Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3,1:p) where p>=m. C Supplied by the preceding call to the routine NRMANY. Note that C IWK is the dimension of this routine as declared in the calling C (sub)program, and must be the same as first dimension of wk as C declared in the calling subprogram. The preceding call to NRMANY C need not occur in the same subprogram, but if it does not then the C array EIGFNS must be declared to have the same dimensions in the C subprogram from which NRMANY is called as in the subprogrm from C which SL04FM is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of wk as declared in the C calling subprogram. Unchanged on exit. C NVALS: INTEGER. The number of points in XVAL at which the eigenfunction C approximation is to be computed. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by SL02FM in computing C the eigenvalue approximation. Supplied by the preceding call to C SL02FM. Unchanged on exit. C M: INTEGER. The number of eigenvalues computed at the preceding call C to SL02FM. As supplied to SL02FM by the user. Unchanged on exit. C END of brief spec. C C Additional Information (for me): C eigfns(i,1,k) = rlog_{k}(i) for i=0,1,k=1,m, C eigfns(i,2,k) = theta_{k}(i) for i=0,1,k=1,m, C eigfns(i,3,k) = scale_{k}(i) for i=0,1,k=1,m. C wk: *real* ARRAY of DIMENSION (0:n,1:4). The entries in wk are as C follows: C wk(i,1) = xmesh(i) for i=0,n C wk(i,2) = pp(i) for i=1,n C wk(i,3) = qp(i) for i=1,n C wk(i,4) = wp(i) for i=1,n. C C .. Scalar Arguments .. INTEGER ifail,ival,iwk,m,mvals,n,nval C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3,1:m),elam(1:2,1:m), & pdyval(0:ival,1:m),wk(0:iwk,1:4),xval(0:ival), & yvals(0:ival,1:m) INTEGER k(1:m),kvals(1:mvals) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER i,ic,iflag,j,jc,nrec CHARACTER srname*6 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. External Subroutines .. cc EXTERNAL efn1 C .. C Retrieve matchpoint index from sneaky storage: C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. Intrinsic Functions .. INTRINSIC abs C .. ic = wk(0,2) iflag = 0 nrec = 2 IF (mvals.GT.m .OR. mvals.LE.0 .OR. abs(ifail).GT.1) THEN iflag = 1 IF (abs(ifail).GT.1) ifail = -1 WRITE (rec,FMT=9000) ELSE DO 30 i = 1,mvals DO 10 j = 1,m IF (kvals(i).EQ.k(j)) GO TO 20 10 CONTINUE GO TO 40 20 jc = j C Undo each Richarson extrapolation before computing the eigenfunctions: elam0 = elam(1,jc) + elam(2,jc) CALL efn1(xval,yvals(0,i),pdyval(0,i),elam0, & eigfns(0,1,jc),eigfns(0,2,jc),eigfns(0,3,jc), & wk(0,1),wk(1,2),wk(1,3),wk(1,4),nval,n,ic) 30 CONTINUE ifail = 0 RETURN 40 CONTINUE iflag = 2 WRITE (rec,FMT=9010) END IF ifail = p01abf(ifail,iflag,srname,nrec,rec) 9000 FORMAT (' ** Parameter error: MVALS or IFAIL out of range') 9010 FORMAT (' ** Requested eigenfunctions not all available') END SUBROUTINE sl04fm C ------------------------------------------------------------------------ SUBROUTINE sl03fm(elam,k,m,eigfns,wk,iwk,n,setup,ifail) C This routine computes information required by the routine SL04FM in order C to evaluate the normalised eigenfunction. C C Brief Specification: C VARIABLES C ELAM: REAL ARRAY of DIMENSION (1:2,1:p) where p >= m. Supplied by the C preceding call to SL02FM. Unchanged on exit. C K: INTEGER ARRAY of DIMENSION at least (1:M). The array of indices C of the eigenvalues and eigenfunctions in question. As supplied to C SL02FM for the computation of ELAM. Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3,1:p) where p >= m. This array C must be supplied by the user and will be used to store the C information about the normalised eigenfunctions required by SL04FM. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4) C Supplied by the preceding call to the routine SL02FM. The C preceding call to SL02FM need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which SL02FM is called as C in the subprogrm from which SL04F is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of WK as declared in the calling C (sub)program. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by the routine SL02FM C in the computation of the eigenvalue approximation. Supplied by C the preceding call to SL02FM and unchanged on exit. C M: INTEGER. The number of eigenvalues computed at the preceding call C to SL02FM. As supplied to SL02FM by the user. Unchanged on exit. C SETUP: User-supplied SUBROUTINE. The same as supplied to SL02FM at the C preceding call to SL02FM. C IFAIL: INTEGER. This parameter should be zero on exit. If it is not then C it will have the value 3 indicating an error in the routine SETUP. C END of brief specification C C Additional information (for me): C This routine interfaces to NORFN1 and allows the normalisation of many C eigenfunctions at once. C .. Parameters .. DOUBLE PRECISION smatch PARAMETER (smatch=1.0D0) C .. C .. Scalar Arguments .. INTEGER ifail,iwk,m,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3,1:m),elam(1:2,1:m),wk(0:iwk,1:4) INTEGER k(1:m) C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Local Scalars .. INTEGER i,ic,iflag,nrec CHARACTER srname*6 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. External Subroutines .. cc EXTERNAL norfn1 C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. Intrinsic Functions .. INTRINSIC abs C .. iflag = 0 srname = 'SL03FM' nrec = 2 IF (abs(ifail).GT.1) THEN WRITE (rec,FMT=9000) ifail = -1 iflag = 1 ELSE C Retrieve matchpoint index from sneaky storage: ic = wk(0,2) C This routine is just an interface for NORFUN DO 10 i = 1,m CALL norfn1(eigfns(0,1,i),eigfns(0,2,i),eigfns(0,3,i), & smatch,elam(1,i),elam(2,i),k(i),n,ic,wk(1,2), & wk(1,3),wk(1,4),wk(0,1),setup,iflag) IF (iflag.NE.0) GO TO 20 10 CONTINUE C If ifail is nonzero ifail will have the value 3. C Eigenfunctions have been normalised as required ifail = 0 RETURN 20 WRITE (rec,FMT=9010) iflag = 2 END IF ifail = p01abf(ifail,iflag,srname,nrec,rec) 9000 FORMAT (' ** Invalid input value of IFAIL') 9010 FORMAT (' ** Invalid boundary conditions') C$st$ Unreachable comments ... END SUBROUTINE sl03fm C------------------------------------------------------------------------------ SUBROUTINE efun(xval,yvals,pdyval,elam,rlog,theta,scale,xmesh,pp, & qp,wp,nval,n,ic) C .. Parameters .. DOUBLE PRECISION zero,one PARAMETER (zero=0.0D0,one=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam INTEGER ic,n,nval C .. C .. Array Arguments .. DOUBLE PRECISION pdyval(0:nval),pp(1:n),qp(1:n),rlog(0:n), & scale(0:n),theta(0:n),wp(1:n),xmesh(0:n), & xval(0:nval),yvals(0:nval) C .. C .. Local Scalars .. DOUBLE PRECISION di,dummy,erl,rlgtmp,sqrts,stemp,thtmp,xend, & xo INTEGER i,j,jtemp,kdummy C .. C .. External Subroutines .. cc EXTERNAL fulstp C .. C .. Intrinsic Functions .. INTRINSIC cos,sin,sqrt C .. C .. External Functions .. cc DOUBLE PRECISION spexp cc EXTERNAL spexp C .. C rnorm = zero i = 0 j = 0 di = one 10 CONTINUE IF (xval(i).LT.xmesh(0)) di = -one jtemp = j DO 20 kdummy = j,n - 1 IF (xval(i).GT.xmesh(kdummy)) THEN jtemp = kdummy ELSE GO TO 30 END IF 20 CONTINUE GO TO 40 30 CONTINUE 40 j = jtemp xend = xval(i) IF (xend.GT.xmesh(ic)) THEN xo = xmesh(j+1) rlgtmp = rlog(j+1) thtmp = theta(j+1) stemp = scale(j+1) di = -one ELSE rlgtmp = rlog(j) thtmp = theta(j) stemp = scale(j) xo = xmesh(j) END IF CALL fulstp(xo,xend,di,stemp,thtmp,rlgtmp,pp(j+1), & elam*wp(j+1)-qp(j+1),wp(j+1),dummy,1) erl = spexp(rlgtmp) sqrts = sqrt(stemp) yvals(i) = sin(thtmp)*erl/sqrts pdyval(i) = cos(thtmp)*erl*sqrts i = i + 1 IF (i.LE.nval) GO TO 10 END SUBROUTINE efun C------------------------------------------------------------------------------ SUBROUTINE efn1(xval,yvals,pdyval,elam,rlog,theta,scale,xmesh,pp, & qp,wp,nval,n,ic) C .. Parameters .. DOUBLE PRECISION one PARAMETER (one=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam INTEGER ic,n,nval C .. C .. Array Arguments .. DOUBLE PRECISION pdyval(0:nval),pp(1:n),qp(1:n),rlog(0:1), & scale(0:1),theta(0:1),wp(1:n),xmesh(0:n), & xval(0:nval),yvals(0:nval) C .. C .. Local Scalars .. DOUBLE PRECISION di,dummy,p,q,rlgloc,scloc,sgnh,thtloc,w,xend,xo INTEGER i,idi,ifail,ii,j,jsplit C .. C .. External Subroutines .. cc EXTERNAL fulstp,m01caf C .. C .. Intrinsic Functions .. INTRINSIC cos,dble,max,min,sign,sin,sqrt C .. C First order points in ascending order C .. External Functions .. cc DOUBLE PRECISION spexp cc EXTERNAL spexp C .. CALL m01caf(xval(0),1,nval+1,'A',ifail) C Next find which points lie to the right of the match-point and which to C the left. jsplit = -1 DO 10 i = 0,nval C Modify a point if it lies outwith the permitted range: xval(i) = min(xmesh(n),max(xmesh(0),xval(i))) IF (xval(i).LE.xmesh(ic)) jsplit = i 10 CONTINUE i = 1 j = 0 IF (jsplit.EQ.-1) THEN jsplit = 0 GO TO 30 END IF idi = 1 ii = i C Initial conditions rlgloc = rlog(0) thtloc = theta(0) scloc = scale(0) xo = xmesh(0) di = dble(idi) sgnh = sign(one,di) 20 p = pp(ii) q = qp(ii) w = wp(ii) IF (xmesh(i)*sgnh.LT.xval(j)*sgnh) THEN xend = xmesh(i) CALL fulstp(xo,xend,sign(one,xend-xo),scloc,thtloc,rlgloc,p, & elam*w-q,w,dummy,1) i = i + idi ii = ii + idi ELSE xend = xval(j) CALL fulstp(xo,xend,sign(one,xend-xo),scloc,thtloc,rlgloc,p, & elam*w-q,w,dummy,1) dummy = spexp(rlgloc) yvals(j) = sin(thtloc)*dummy/sqrt(scloc) pdyval(j) = cos(thtloc)*dummy*sqrt(scloc) IF (xmesh(i).EQ.xval(j)) THEN i = i + idi ii = ii + idi i = min(i,n) i = max(i,0) ii = min(ii,n) ii = max(ii,0) END IF j = j + idi END IF C If we have evaluated at all required points then bail out: IF (idi.GT.0 .AND. j.GT.jsplit) GO TO 30 IF (idi.LT.0 .AND. j.LT.jsplit) GO TO 40 xo = xend GO TO 20 30 IF (j.LE.nval) THEN C We still have more points to do. rlgloc = rlog(1) thtloc = theta(1) scloc = scale(1) xo = xmesh(n) i = n - 1 idi = -1 ii = i + 1 j = nval di = dble(idi) sgnh = sign(one,di) GO TO 20 END IF 40 RETURN C If we are here then all the required values have been computed. END SUBROUTINE efn1 C------------------------------------------------------------------------------ SUBROUTINE norfun(rlog,theta,scale,smatch,elam0,ep,k,n,ic,pp,qp, & wp,xmesh,setup,trans,ifail) C C This routine computes arrays containing nodal values of the scale-factor, C Prufer radius and Prufer angle, all normalised to agree with each other and C yield an eigenfunction with L2(w)-norm equal to unity. The mesh may be in C the user's coordinates (trans = .false.) or transformed coordinates C (trans = .true.) C VARIABLES: C rlog: *real* ARRAY of DIMENSION at least (0:n) On exit, this contain C the required nodal values of log(r). C theta: *real* ARRAY of DIMENSION at least (0:n). On exit, this contains C the required nodal values of theta. C scale: *real* ARRAY of DIMENSION at least (0:n). On exit, this contains C the required nodal values of the scale-factor. C ELAM0: *real*. The eigenvalue corresponding to the required eigenfunction. C Unchanged on exit. C N,IC: INTEGERs. N is the number of mesh-intervals used by EIGEN in its C computation of the eigenfunction. IC is the integer such that the C point XMESH(IC) was used as the matching point for the computation C of the Prufer miss-distance function. C PP,QP,WP: *real* ARRAYs of DIMENSIONs at least N. These store the values C of the coefficient functions at the midpoints XMESH(i+1/2). C XMESH: *real* ARRAY of DIMENSION at least N. Stores the mesh-points used C by EIGEN in the computation of the eigenfunction. C smatch: the value of the scale-factor at the matching point xmesh(ic). C IFAIL: INTEGER. This parameter should be zero on exit. If it is not then C it will have the value 3 indicating an error in the routine SETUP. C .. Parameters .. C Set up left boundary conditions: DOUBLE PRECISION zero,one,two,half PARAMETER (zero=0.0D0,one=1.0D0,two=2.0D0,half=one/two) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam0,ep,smatch INTEGER ic,ifail,k,n LOGICAL trans C .. C .. Array Arguments .. DOUBLE PRECISION pp(n),qp(n),rlog(0:n),scale(0:n),theta(0:n), & wp(n),xmesh(0:n) C .. C .. Local Scalars .. DOUBLE PRECISION elam,eps,facl,facr,pdy,pi,rgtlog,rlftlg,rnorml, & rnormr,y INTEGER i C .. C .. External Subroutines .. cc EXTERNAL bcons,fulprf C .. C .. Intrinsic Functions .. INTRINSIC atan2,log C .. C .. External Functions .. cc DOUBLE PRECISION spexp,x01aaf cc EXTERNAL spexp,x01aaf C .. C .. Subroutine Arguments .. EXTERNAL setup C .. ifail = 0 pi = x01aaf(0.0D0) elam = elam0 + ep CALL bcons(setup,y,pdy,elam,xmesh(0),pp(1),qp(1),wp(1),0,trans, & ifail) IF (ifail.EQ.0) THEN C If ifail is nonzero ifail = 3 theta(0) = atan2(y,pdy) rlog(0) = zero C Shoot from left-hand end to matching point: rnorml = zero scale(0) = one i = 0 CALL fulprf(i,theta,rlog,scale,rnorml,ic,smatch,elam,pp,qp,wp, & xmesh,n,n,-1) rlftlg = rlog(ic) C Set up right boundary conditions: CALL bcons(setup,y,pdy,elam,xmesh(n),pp(n),qp(n),wp(n),1, & trans,ifail) IF (ifail.EQ.0) THEN C If ifail is nonzero ifail = 3 theta(n) = (k+1)*pi - atan2(y,pdy) rlog(n) = zero C Shoot from right-hand end to matching point: rnormr = zero scale(n) = one i = n CALL fulprf(i,theta,rlog,scale,rnormr,ic,smatch,elam,pp, & qp,wp,xmesh,n,n,-1) rgtlog = rlog(ic) C Choose the normalising factors facl and facr to match up the two halves C of the solution; actually facl and facr here denote the logarithms of the C normalising factors. C To reduce the probability of overflow we consider two cases. C IF (rgtlog.GT.rlftlg) THEN eps = spexp(rlftlg-rgtlog) facl = -log((rnormr*eps)**2+ (rnorml**2))*half facr = facl + rlftlg - rgtlog ELSE eps = spexp(rgtlog-rlftlg) facr = -log((rnorml*eps)**2+ (rnormr**2))*half facl = facr + rgtlog - rlftlg END IF C C The normalising factors have now been computed. C DO 10 i = 0,ic - 1 rlog(i) = rlog(i) + facl 10 CONTINUE DO 20 i = ic,n rlog(i) = rlog(i) + facr 20 CONTINUE C C We now have the following information: C C The scale factors scale(i), the values of rlog(i), and the values of C theta(i), for i=1,..,n, with the theta values scaled in a manner which is C appropriate for the scale factors and the rlog values scaled to agree with C scale-factors and yield an eigenfunction witth L2(w)-norm equal to unity. C END IF END IF END SUBROUTINE norfun C------------------------------------------------------------------------------- SUBROUTINE norfn1(rlog,theta,scale,smatch,elam0,ep,k,n,ic,pp,qp, & wp,xmesh,setup,ifail) C C This routine computes arrays containing end-point values of the scale-factor, C Prufer radius and Prufer angle, all normalised to agree with each other and C yield an eigenfunction with L2(w)-norm equal to unity. C The mesh is assumed to be supplied in the user's original coordinates C and not in transformed coordinates. C VARIABLES: C rlog: *real* ARRAY of DIMENSION at least (0:1) On exit, this contains C the required end-point values of log(r). C theta: *real* ARRAY of DIMENSION at least (0:1). On exit, this contains C the required end-point values of theta. C scale: *real* ARRAY of DIMENSION at least (0:1). On exit, this contains C the required end-point values of the scale-factor. C ELAM0: *real*. The eigenvalue corresponding to the required eigenfunction. C Unchanged on exit. C N,IC: INTEGERs. N is the number of mesh-intervals used by EIGEN in its C computation of the eigenfunction. IC is the integer such that the C point XMESH(IC) was used as the matching point for the computation C of the Prufer miss-distance function. CPP,QP,WP: *real* ARRAYs of DIMENSIONs at least N. These store the values C of the coefficient functions at the midpoints XMESH(i+1/2). C XMESH: *real* ARRAY of DIMENSION at least N. Stores the mesh-points used C by EIGEN in the computation of the eigenfunction. C smatch: the value of the scale-factor at the matching point xmesh(ic). C IFAIL: INTEGER. This parameter should be zero on exit. If it is not then C it will have the value 3 indicating an error in the routine SETUP. C .. Parameters .. C Set up left boundary conditions: DOUBLE PRECISION zero,one,two,half PARAMETER (zero=0.0D0,one=1.0D0,two=2.0D0,half=one/two) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam0,ep,smatch INTEGER ic,ifail,k,n C .. C .. Array Arguments .. DOUBLE PRECISION pp(n),qp(n),rlog(0:1),scale(0:1),theta(0:1), & wp(n),xmesh(0:n) C .. C .. Local Scalars .. DOUBLE PRECISION elam,eps,facl,facr,pdy,pi,rgtlog,rlftlg,rlo, & rnorml,rnormr,rro,sclo,scro,thlo,thro,y INTEGER i LOGICAL trans C .. C .. External Subroutines .. cc EXTERNAL bcons,fulprf C .. C .. Intrinsic Functions .. INTRINSIC atan2,log C .. C .. External Functions .. cc DOUBLE PRECISION spexp,x01aaf cc EXTERNAL spexp,x01aaf C .. C .. Subroutine Arguments .. EXTERNAL setup C .. ifail = 0 pi = x01aaf(0.0D0) elam = elam0 + ep C This routine never works with transformed coordinates. trans = .false. CALL bcons(setup,y,pdy,elam,xmesh(0),pp(1),qp(1),wp(1),0,trans, & ifail) IF (ifail.EQ.0) THEN C If ifail is nonzero ifail = 3 theta(0) = atan2(y,pdy) rlog(0) = zero C Shoot from left-hand end to matching point: rnorml = zero scale(0) = one i = 0 CALL fulprf(i,theta,rlog,scale,rnorml,ic,smatch,elam,pp,qp,wp, & xmesh,1,n,-2) rlftlg = rlog(1) rlo = rlog(0) thlo = theta(0) sclo = scale(0) C Set up right boundary conditions: CALL bcons(setup,y,pdy,elam,xmesh(n),pp(n),qp(n),wp(n),1, & trans,ifail) IF (ifail.EQ.0) THEN C If ifail is nonzero ifail = 3 theta(0) = (k+1)*pi - atan2(y,pdy) rlog(0) = zero C Shoot from right-hand end to matching point: rnormr = zero scale(0) = one i = n CALL fulprf(i,theta,rlog,scale,rnormr,ic,smatch,elam,pp, & qp,wp,xmesh,1,n,-2) rgtlog = rlog(1) rro = rlog(0) thro = theta(0) scro = scale(0) C Choose the normalising factors facl and facr to match up the two halves C of the solution; actually facl and facr here denote the logarithms of the C normalising factors. C To reduce the probability of overflow we consider two cases. C IF (rgtlog.GT.rlftlg) THEN eps = spexp(rlftlg-rgtlog) facl = -log((rnormr*eps)**2+ (rnorml**2))*half facr = facl + rlftlg - rgtlog ELSE eps = spexp(rgtlog-rlftlg) facr = -log((rnorml*eps)**2+ (rnormr**2))*half facl = facr + rgtlog - rlftlg END IF C C The normalising factors have now been computed. C rlog(0) = rlo + facl rlog(1) = rro + facr theta(0) = thlo theta(1) = thro scale(0) = sclo scale(1) = scro C END IF END IF END SUBROUTINE norfn1 C------------------------------------------------------------------------------- SUBROUTINE fulprf(i,thetrr,rlogrr,scale,rnorm,iend,send,elam,pp, & qp,wp,xmesh,idim,ndim,iswtch) C C Integrates the Prufer phase and radius (forward or backward depending on C whether iend islarger or smaller than i) advancing the values of i,theta and s C and accumulating an approximation to the L2(w) integral of the eigenfunction C at each step. C iswtch is a switch parameter. It works as follows: C C iswtch = 1 or 2: both the Prufer radius and the Prufer angle are advanced from C i to iend. C iswtch= -1 or -2: all the information returned by iswtch = 1 is returned, C and in addition the norm of the corresponding eigenfunction is returned. C The arrays thetrr and rlogrr serve as follows: C IF iswtch=(+/-)1, then on entry rlogrr(i), thetrr(i) and scale(i) must C contain the initial values of the log of Prufer radius, C the Prufer angle and scale-factor. On exit, rlogrr(j), C thetrr(j) and scale(j) will contain these Prufer C quantities at each of the points xmesh(j) for j=i,iend. C (n.b.we refer here to the input i; i is changed on exit). C If a rescaling has been necessary, then the initial C log Prufer radius rlog(i) will have been changed to C correspond to the new scaling. C IF iswtch=(+/-)2, then on entry rlogrr(0), thetrr(0) and scale(0) must C contain the initial values of the log of the Prufer radius, C the Prufer angle and the scale-factor. On exit, they C will be unchanged unless rlog(0) has been changed to C correspond to a new scaling of the eigenfunction. The C elements rlogrr(1), thetrr(1) and scale(1) contain the C appropriate Prufer quantities at xmesh(iend). C C In both cases, the scale-factor s at the final point will be send, specified C by the user. C C .. Scalar Arguments .. DOUBLE PRECISION elam,rnorm,send INTEGER i,idim,iend,iswtch,ndim C .. C .. Array Arguments .. DOUBLE PRECISION pp(ndim),qp(ndim),rlogrr(0:idim),scale(0:idim), & thetrr(0:idim),wp(ndim),xmesh(0:ndim) C .. C .. Local Scalars .. DOUBLE PRECISION delta,di,hlfsub,p,q,rlog,s,safe,sbtrct,theta, & twosaf,w INTEGER idi,idummy,ii,iold,ioldo LOGICAL ltf C .. C .. External Functions .. cc DOUBLE PRECISION rescal,scl,spexp,x02amf cc EXTERNAL rescal,scl,spexp,x02amf C .. C .. External Subroutines .. cc EXTERNAL fulstp C .. C .. Intrinsic Functions .. INTRINSIC abs,dble,log,max,sign,sqrt C .. C .. External Functions .. C .. C Set a parameter which can be safely exponentiated: C .. Parameters .. DOUBLE PRECISION one,zero,half PARAMETER (one=1.0D0,zero=0.0D0,half=5.0D-1) C .. twosaf = -log(x02amf(one))*half safe = half*twosaf ltf = abs(iswtch) .EQ. 1 C Store input values of certain parameters: ioldo = i C Set the L2(w) norm to zero before starting the integration rnorm = zero C Start stepping idi = sign(1,iend-i) di = dble(idi) ii = i IF (idi.LT.0) ii = i + 1 IF (ltf) THEN s = scale(i) theta = thetrr(i) rlog = rlogrr(i) ELSE s = scale(0) theta = thetrr(0) rlog = rlogrr(0) C Set scale(1), thetrr(1) and rlogrr(1) in case the range of integration C is null: scale(1) = scale(0) thetrr(1) = thetrr(0) rlogrr(1) = rlogrr(0) END IF 10 CONTINUE C IF (i.NE.iend) THEN iold = i i = i + idi ii = ii + idi p = pp(ii) w = wp(ii) C Q here has same sign as in writeup of 12/1/89 q = wp(ii)*elam - qp(ii) C Integrate over the interval [xmesh(iold),xmesh(i)] C h = xmesh(i) - xmesh(iold) CALL fulstp(xmesh(iold),xmesh(i),di,s,theta,rlog,p,q,w,delta, & sign(1,iswtch)) C Update the logr and theta arrays, and the scale-factor array: IF (ltf) THEN rlogrr(i) = rlog scale(i) = s thetrr(i) = theta ELSE rlogrr(1) = rlog scale(1) = s thetrr(1) = theta END IF C Do some scaling to avoid overflow problems: IF (rlog.GT.safe) THEN C Subtract a suitable amount from every value of logr, and divide the C norm accordingly: IF (sign(1,iswtch).EQ.-1) THEN C The contribution to the norm from a single step cannot exceed 1 for the C normalised eigenfunction: sbtrct = max(delta,twosaf) hlfsub = half*sbtrct rnorm = spexp(-sbtrct)*rnorm delta = delta - sbtrct rlog = rlog - hlfsub IF (ltf) THEN DO 20 idummy = ioldo,i,idi rlogrr(idummy) = rlogrr(idummy) - hlfsub 20 CONTINUE ELSE rlogrr(0) = rlogrr(0) - hlfsub rlogrr(1) = rlogrr(1) - hlfsub END IF ELSE rlog = rlog - safe IF (ltf) THEN DO 30 idummy = ioldo,i,idi rlogrr(idummy) = rlogrr(idummy) - safe 30 CONTINUE ELSE rlogrr(0) = rlogrr(0) - safe rlogrr(1) = rlogrr(1) - safe END IF END IF END IF IF (sign(1,iswtch).EQ.-1) rnorm = rnorm + spexp(delta) GO TO 10 END IF C Integration of the Prufer equations is now complete rnorm = sqrt(rnorm) IF (ltf) THEN thetrr(i) = scl(thetrr(i),send/s) scale(i) = send rlog = rlogrr(i) rlogrr(i) = rescal(s,send,thetrr(i),rlog) ELSE thetrr(1) = scl(thetrr(1),send/s) scale(1) = send rlog = rlogrr(1) rlogrr(1) = rescal(s,send,thetrr(1),rlog) END IF END SUBROUTINE fulprf C------------------------------------------------------------------------------- SUBROUTINE fulstp(xo,xend,di,s,theta,rlog,p,qbig,w,sqrnrm,iswtch) C This routine advances the solutions of both the Prufer r and theta equations C over an interval [xo,xend] on which the coefficient functions are constant. C It also stores in sqrnrm the logarithm of the contribution to the square of C the eigenfunction norm arising from integration across the interval (xo,xend). C VARIABLES: C C xo, xend: the endpoints of the interval over which integration must proceed; C unchanged on exit. C s: the scale-factor in use when the routine is called; this is the C scale-factor appropriate to the input value of theta. On exit, C s will be reset to the output value of the scale-factor if C this is different from the input value C theta: the Prufer angle. On entry, theta must specify the value of the C Prufer angle at the point xo, normalised according to the input C value of the scale-factor s. On exit, theta contains the value of C the Prufer angle at the point xend, normalised according to the C output value of the scale-factor s. C rlog: the logarithm of the Prufer radius, normalised to be appropriate C to the scale-factor s. On input, rlog contains the logarithm of the C Prufer radius at the point xo. On output, rlog contains the C logarithm of the Prufer radius at the point xend. C p,w,qbig: the values of the coefficient functions p and w, and of C elam*w-q = qbig on the interval [xo,xend]. Unchanged on exit. C di: indicates whether xo is greater than or less than xend; C di = 1.0 if xoxend. C iswtch: a switch parameter. With iswtch = 1 the Prufer theta-equation C and the Prufer r-equation are integrated, and with iswtch = -1 C the norm is also accumulated. C C .. Scalar Arguments .. DOUBLE PRECISION di,p,qbig,rlog,s,sqrnrm,theta,w,xend,xo INTEGER iswtch C .. C .. Scalars in Common .. INTEGER icall,igt0,ilt0,int,ip,ismall,ival C .. C .. Local Scalars .. DOUBLE PRECISION alfa,alfah,c2th,c2thn,cth,h,hlog,oldtrm,pdy, & pdynew,phi2t,phit,pi,pi4,psit,rlgnew,rmess,snew, & spth,sqrts,sth,t,tah,term,thtnew,y,ynew C .. C .. External Functions .. cc DOUBLE PRECISION chi,phi,psi,rescal,scl,spexp,sptanh,x01aaf,x02amf cc EXTERNAL chi,phi,psi,rescal,scl,spexp,sptanh,x01aaf,x02amf C .. C .. Intrinsic Functions .. INTRINSIC abs,atan2,cos,log,sign,sin,sqrt,tan C .. C .. External Functions .. C .. C .. Common blocks .. COMMON icall,int,ip,ival,igt0,ilt0,ismall C .. C C .. Parameters .. DOUBLE PRECISION one,two,half,four,qtr,smal,zero PARAMETER (one=1.0D0,two=2.0D0,half=one/two,four=4.0D0, & qtr=one/four,smal=1.0D-1,zero=0.0D0) C .. pi = x01aaf(zero) pi4 = pi*qtr h = xend - xo IF (h.NE.zero) THEN hlog = log(abs(h)) t = h*h*qbig/p C IF (abs(t).GT.smal) THEN snew = sqrt(abs(qbig*p)) alfa = snew/p alfah = h*snew/p thtnew = scl(theta,snew/s) rlgnew = rescal(s,snew,thtnew,rlog) s = snew IF (t.GT.zero) THEN igt0 = igt0 + 1 IF (iswtch.EQ.-1) THEN C Compute the contribution to the square of the L2-norm also. Note the C special precaution which has to be taken to deal with indefinite C problems where w may be zero. rmess = half*w*abs(one- (sin((thtnew+alfah)*two)- & sin(two*thtnew))* (half/alfah))/s IF (rmess.GT.0.0D0) THEN sqrnrm = log(rmess) + two*rlgnew + hlog ELSE C (n.b. x02amf(*) is a very small number, O(1e-39)). sqrnrm = log(x02amf(one)) END IF END IF C Update theta and rlog: theta = thtnew + alfah rlog = rlgnew ELSE ilt0 = ilt0 + 1 c2thn = cos(two*thtnew) theta = scl(thtnew-pi4*di,spexp(-abs(alfah)*two)) + & pi4*di c2th = cos(two*theta) C Update rlog: tah = cos(thtnew-pi4*di) IF (abs(tah).GT.smal) THEN tah = (tan(thtnew-pi4*di))**2 tah = (one+tah)/ (spexp(-abs(alfah)*four)*tah+one) rlog = abs(alfah) + rlgnew - log(tah)*half ELSE oldtrm = log(abs(c2thn)) term = log(abs(c2th)) rlog = (oldtrm-term)*half + rlgnew END IF IF (iswtch.EQ.-1) THEN cth = spexp(-abs(alfah)) cth = two*cth/ (one-cth**2) spth = spexp(-two*abs(alfah)) sth = (sign(one,alfah)/alfa)* (one+spth)/ & (one-spth) - cth**2*h IF (rlgnew.LE.rlog) THEN sth = half*sth* (spexp((rlgnew-rlog)*two)* & sin(thtnew)**2+sin(theta)**2)/s sth = spexp(rlgnew-rlog)*sign(one,alfah)* & sin(theta)* (sin(thtnew)/s)*abs(cth)* & (h/sptanh(alfah)-one/alfa) + sth ELSE sth = half*sth* (sin(thtnew)**2+ & spexp((rlog-rlgnew)*two)*sin(theta)**2)/ & s sth = spexp(rlog-rlgnew)*sign(one,alfah)* & sin(theta)* (sin(thtnew)/s)*abs(cth)* & (h/sptanh(alfah)-one/alfa) + sth END IF IF (abs(w*sth).GT.zero) THEN sqrnrm = log(abs(w*sth)) + two*rlog IF (rlgnew.GT.rlog) sqrnrm = sqrnrm + & two* (rlgnew-rlog) ELSE sqrnrm = log(x02amf(one)) END IF END IF END IF ELSE ismall = ismall + 1 sth = sin(theta) cth = cos(theta) phit = phi(-t) psit = psi(-t) sqrts = sqrt(s) IF (iswtch.EQ.-1) THEN C Compute the contribution to the square of the L2-norm also. phi2t = phit*psit y = sth/sqrts pdy = cth*sqrts rmess = half*w*abs((pdy**2)* (one-phi2t)/ (p*qbig)+ & (y**2)* (one+phi2t)+two*y*pdy* (phit**2)*h/p) IF (rmess.GT.0.0D0) THEN sqrnrm = log(rmess) + rlog*two + hlog ELSE sqrnrm = log(x02amf(one)) END IF END IF theta = atan2((s/p*cth**2+qbig/s*sth**2)*h, & (s/p-qbig/s)*h*sth*cth+chi(-t)) + theta C Update rlog: pdy = sqrts*cth y = sth/sqrts pdynew = pdy*psit - y*h*qbig*phit ynew = h*phit*pdy/p + y*psit rlog = log((pdynew**2)/s+ (ynew**2)*s)*half + rlog END IF END IF END SUBROUTINE fulstp C---------------------------------------------------------------------------- DOUBLE PRECISION FUNCTION rescal(s,snew,thtnew,rlog) C .. Scalar Arguments .. DOUBLE PRECISION rlog,s,snew,thtnew C .. C .. Local Scalars .. DOUBLE PRECISION sinsq C .. C .. Intrinsic Functions .. INTRINSIC abs,log,sin C .. sinsq = sin(thtnew)**2 rescal = rlog - log(abs(1.0D0-sinsq)*snew/s+sinsq*s/snew)*0.5D0 END FUNCTION rescal C---------------------------------------------------------------------------- SUBROUTINE onestp(xo,xend,di,s,theta,p,qbig) C This routine advances the solution of the scaled Prufer equation C across an interval [xo,xend] on which the coefficient functions p, q, C and w are constants. It will be called from the meshing routine, from the C prufer routine below, and also from the routine which computes the C eigenfunction. C C VARIABLES: C C xo, xend: the endpoints of the interval over which integration must proceed; C unchanged on exit. C s: the scale-factor in use when the routine is called; this is the C scale-factor appropriate to the input value of theta. On exit, C s will be reset to the output value of the scale-factor if C this is different from the input value C theta: the Prufer angle. On entry, theta must specify the value of the C Prufer angle at the point xo, normalised according to the input C value of the scale-factor s. On exit, theta contains the value of C the Prufer angle at the point xend, normalised according to the C output value of the scale-factor s. C p,Q: the values of the coefficient function p and of elam*w-q = Q C on the interval [xo,xend]. Unchanged on exit. C di: indicates whether xo is greater than or less than xend; C di = 1.0 if xoxend. C .. Scalar Arguments .. DOUBLE PRECISION di,p,qbig,s,theta,xend,xo C .. C .. Scalars in Common .. INTEGER icall,igt0,ilt0,int,ip,ismall,ival C .. C .. Local Scalars .. DOUBLE PRECISION alfah,cth,h,pi,pi4,snew,sqrtp,sqrtq,sth,t C .. C .. Intrinsic Functions .. INTRINSIC abs,atan2,cos,sin,sqrt C .. C .. External Functions .. cc DOUBLE PRECISION chi,scl,spexp,x01aaf cc EXTERNAL chi,scl,spexp,x01aaf C .. C .. Common blocks .. COMMON icall,int,ip,ival,igt0,ilt0,ismall C .. pi = x01aaf(0.0D0) pi4 = pi/4.0D0 h = xend - xo t = h*h*qbig/p C IF (abs(t).GT.0.1D0) THEN sqrtq = sqrt(abs(qbig)) sqrtp = sqrt(p) snew = sqrtq*sqrtp alfah = (h*sqrtq)/sqrtp theta = scl(theta,snew/s) s = snew IF (t.GT.0.0D0) THEN igt0 = igt0 + 1 theta = theta + alfah ELSE ilt0 = ilt0 + 1 theta = scl(theta-pi4*di,spexp(-abs(alfah)*2.D0)) + pi4*di END IF ELSE ismall = ismall + 1 sth = sin(theta) cth = cos(theta) theta = atan2((s/p*cth**2+qbig/s*sth**2)*h, & (s/p-qbig/s)*h*sth*cth+chi(-t)) + theta END IF END SUBROUTINE onestp C----------------------------------------------------------------------- SUBROUTINE prufer(i,theta,s,iend,send,elam,pp,qp,wp,xmesh) C C Integrates the Prufer phase (forward or backward depending on whether iend is C larger or smaller than i) advancing the values of i,theta and s C .. Scalar Arguments .. DOUBLE PRECISION elam,s,send,theta INTEGER i,iend C .. C .. Array Arguments .. DOUBLE PRECISION pp(*),qp(*),wp(*),xmesh(0:*) C .. C .. Local Scalars .. DOUBLE PRECISION di,p,q INTEGER ii,iold C .. C .. External Subroutines .. cc EXTERNAL onestp C .. C .. External Functions .. cc DOUBLE PRECISION scl cc EXTERNAL scl C .. C .. Intrinsic Functions .. INTRINSIC sign C .. di = sign(1,iend-i) ii = i IF (di.LT.0.0D0) ii = i + 1 10 CONTINUE C IF (i.NE.iend) THEN iold = i i = i + di ii = ii + di p = pp(ii) C Q here has same sign as in writeup of 12/1/89 q = wp(ii)*elam - qp(ii) CALL onestp(xmesh(iold),xmesh(i),di,s,theta,p,q) GO TO 10 END IF theta = scl(theta,send/s) s = send END SUBROUTINE prufer C----------------------------------------------------------------------- DOUBLE PRECISION FUNCTION d(elam,nmesh,imatch,pp,qp,wp,xmesh, & setup,trans,iflag) C DOUBLE PRECISION FUNCTION d(elam,pp,qp,wp,xmesh,nmesh, C * imatch,smatch) C C Computes the miss-distance with xmesh(imatch) taken as the matching point C and smatch as the scale-factor there C C .. Parameters .. DOUBLE PRECISION smatch PARAMETER (smatch=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam INTEGER iflag,imatch,nmesh LOGICAL trans C .. C .. Array Arguments .. DOUBLE PRECISION pp(nmesh),qp(nmesh),wp(nmesh),xmesh(0:nmesh) C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Scalars in Common .. INTEGER icall,igt0,ilt0,int,ip,ismall,ival C .. C .. Local Scalars .. DOUBLE PRECISION pdyl,pdyr,pi,s,thetal,thetar,yl,yr INTEGER i,ifail C .. C .. External Subroutines .. cc EXTERNAL bcons,prufer C .. C .. Intrinsic Functions .. INTRINSIC atan2 C .. C .. External Functions .. cc DOUBLE PRECISION x01aaf cc EXTERNAL x01aaf C .. C .. Common blocks .. COMMON icall,int,ip,ival,igt0,ilt0,ismall C .. pi = x01aaf(0.0D0) IF (nmesh.GT.99) ip = ip + 1 iflag = 0 ifail = 0 C Left leg: CALL bcons(setup,yl,pdyl,elam,xmesh(0),pp(1),qp(1),wp(1),0,trans, & ifail) IF (ifail.NE.3) THEN i = 0 thetal = atan2(yl,pdyl) s = 1.0D0 CALL prufer(i,thetal,s,imatch,smatch,elam,pp,qp,wp,xmesh) C Right leg: CALL bcons(setup,yr,pdyr,elam,xmesh(nmesh),pp(nmesh), & qp(nmesh),wp(nmesh),1,trans,ifail) IF (ifail.NE.3) THEN i = nmesh thetar = pi - atan2(yr,pdyr) s = 1.0D0 CALL prufer(i,thetar,s,imatch,smatch,elam,pp,qp,wp,xmesh) C d = thetal - thetar END IF END IF IF (ifail.NE.0) iflag = ifail END FUNCTION d C ------------------------------------------------------------------- SUBROUTINE bcons(setup,y,pdy,elam,x,p,q,w,iend,trans,ifail) C .. Scalar Arguments .. DOUBLE PRECISION elam,p,pdy,q,w,x,y INTEGER iend,ifail LOGICAL trans C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Local Scalars .. DOUBLE PRECISION qbig,s,xend LOGICAL ising C .. C .. Intrinsic Functions .. INTRINSIC abs,sqrt C .. C .. Parameters .. DOUBLE PRECISION one PARAMETER (one=1.0D0) C .. IF (trans) THEN xend = x/ (one-abs(x)) ELSE xend = x END IF CALL setup(y,pdy,elam,xend,iend,ising) IF (ising) THEN C This end of the interval is singular from the point of view of C boundary conditions. ifail = 0 qbig = elam*w - q IF (qbig.LT.0.0D0) THEN y = 1.0D0 s = -p*qbig pdy = sqrt(s) s = sqrt(y**2+s) y = y/s pdy = pdy/s ELSE s = 1.0D0/p IF (s.GT.qbig) THEN y = 1.0D0 pdy = 0.0D0 ELSE y = 0.0D0 pdy = 1.0D0 END IF END IF ELSE C The end is regular. s = sqrt(y**2+pdy**2) IF (s.EQ.0.0D0) THEN ifail = 3 ELSE y = y/s pdy = pdy/s IF (iend.EQ.1) pdy = -pdy IF (y.LT.0.0D0) THEN y = -y pdy = -pdy END IF IF (y.EQ.0.0D0 .AND. pdy.LT.0.0D0) pdy = -pdy ifail = 0 END IF END IF END SUBROUTINE bcons SUBROUTINE mmesh(xo,xend,ic,elam,coeffn,rlog,theta,scale,xtemp, & ptemp,qtemp,wtemp,ntemp,imatch,xmesh,pp,qp,wp,n, & tol,npo,params,iparam,icofun,ifail) C .. Scalar Arguments .. DOUBLE PRECISION elam,tol,xend,xo INTEGER ic,icofun,ifail,imatch,iparam,n,npo,ntemp C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(1:n),ptemp(1:ntemp),qp(1:n), & qtemp(1:ntemp),rlog(0:ntemp),scale(0:ntemp), & theta(0:ntemp),wp(1:n),wtemp(1:ntemp),xmesh(0:n), & xtemp(0:ntemp) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Local Scalars .. DOUBLE PRECISION big,di,errest,errpm,errpp,errqm,errqp,errw1, & errw2,errwm,errwp,gamma,h,hmax,omega1,omega2, & omega3,p1,p2,p3,q1,q2,q3,ratio,toloc,tolow,w1,w2, & w3,weight,x1,x2,x3,xende,xoo INTEGER i,icfn,icnt,idi,idmy,ifin,ii,irf,kntr,npts LOGICAL infty,phase1,repeat C .. C .. Local Arrays .. DOUBLE PRECISION pdyval(0:1),xvals(0:1),yvals(0:1) C .. C .. External Subroutines .. cc EXTERNAL coarse,coefun,efun,initia C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf,x02amf cc EXTERNAL x02ajf,x02amf C .. C .. Intrinsic Functions .. INTRINSIC abs,cos,exp,int,log,max,min,sin,sqrt C .. C .. Parameters .. DOUBLE PRECISION hlf,two,one,safe,trd,five,ten,safe3,p008,sixth, & zero,tenth,twelf PARAMETER (hlf=5.d-1,two=2.d0,one=1.d0,safe=0.8D0,trd=one/3.d0, & five=5.d0,ten=10.d0,safe3=7.29d-1,p008=8.d-3, & sixth=one/6.d0,zero=0.d0,tenth=one/ten,twelf=hlf*sixth) C .. C This subroutine covers [xo,xend] with a suitable mesh for eigenvalue C computation. toloc = tol tolow = safe*toloc ifin = ifail ifail = 0 i = ic ii = ic + 1 di = one idi = 1 icfn = icofun IF (icofun.EQ.1) THEN icfn = 2 C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. ELSE IF (icofun.EQ.3) THEN icfn = 4 END IF infty = .false. C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1 .OR. icofun.EQ.3) infty = .true. IF (xo.EQ.xend) RETURN xoo = xo xende = xend IF (infty) THEN xoo = xoo/ (one-abs(xoo)) xende = xende/ (one-abs(xende)) END IF IF (xoo.GT.xende) THEN i = n ii = n di = -one idi = -1 END IF icnt = 0 xmesh(i) = xoo C Set the initial mesh-size; first setting: IF (imatch.GE.1) THEN h = abs(xtemp(imatch)-xtemp(imatch-1)) ELSE h = abs(xtemp(imatch)-xtemp(imatch+1)) END IF C Second setting: big = abs((elam*wtemp(imatch)-qtemp(imatch))* & (sin(theta(imatch))**2)/scale(imatch)+ & (one/ptemp(imatch))* (cos(theta(imatch))**2)*scale(imatch))* & exp(two*rlog(imatch)) hmax = abs(xend-xo)/npo h = min(hmax,h,tol/max(x02amf(one),big)) C Initial mesh-size has now been set. C maximum no. of attempts to get right stepsize (set to avoid stepsize C becoming less than machine precision x02ajf(*) in one step): irf = int(log(x02ajf(one))*hlf/log(safe)) kntr = 0 phase1 = .true. repeat = .false. C C This purpose of this routine is to provide a suitably adapted mesh for C the solution of the Sturm-Liouville eigenvalue problem. Mesh adaptation C is based on keeping an estimate of the error per interval below a specified C tolerance. C C General Step (from i to i+idi): 10 x3 = xmesh(i) + h*di x1 = xmesh(i) IF ((x3-xende)*di.GT.zero) x3 = xende xmesh(i+idi) = x3 x2 = hlf* (xmesh(i)+xmesh(i+idi)) IF (.NOT.repeat .AND. .NOT.phase1) THEN C If the step is a repeat after a failure then we dont update at the end C from which we are shooting, otherwise we do. p1 = p3 q1 = q3 w1 = w3 END IF C We only need to evaluate the coefficients at the end from which we are C shooting on the first step, otherwise they are available from the C previous step and have been set above. IF (phase1) CALL coefun(x1,p1,q1,w1,coeffn,params,iparam,icfn) CALL coefun(x2,p2,q2,w2,coeffn,params,iparam,icfn) CALL coefun(x3,p3,q3,w3,coeffn,params,iparam,icfn) IF (x1.LE.x3) THEN errw1 = w1 - w2 errw2 = w3 - w2 errwm = elam*errw1 errwp = elam*errw2 errpp = (one/p3-one/p2) errpm = (one/p1-one/p2) errqp = (q3-q2) errqm = (q1-q2) xvals(0) = x1 xvals(1) = x3 ELSE errw2 = w1 - w2 errw1 = w3 - w2 errwp = elam*errw1 errwm = elam*errw2 errpm = (one/p3-one/p2) errpp = (one/p1-one/p2) errqm = (q3-q2) errqp = (q1-q2) xvals(0) = x3 xvals(1) = x1 END IF C We only need to evaluate the eigenfunction at the end from which we are C shooting on the first step, otherwise it is available from the C previous step: IF (phase1) THEN CALL efun(xvals,yvals,pdyval,elam,rlog,theta,scale,xtemp, & ptemp,qtemp,wtemp,1,ntemp,imatch) ELSE C Two cases to consider depending on stepping direction: IF (idi.GT.0) THEN C Case of repeated step is special; the eigenfunction is not updated. IF (.NOT.repeat) THEN yvals(0) = yvals(1) pdyval(0) = pdyval(1) END IF CALL efun(xvals(1),yvals(1),pdyval(1),elam,rlog,theta, & scale,xtemp,ptemp,qtemp,wtemp,0,ntemp,imatch) ELSE C Case of repeated step is special; the eigenfunction is not updated. IF (.NOT.repeat) THEN yvals(1) = yvals(0) pdyval(1) = pdyval(0) END IF CALL efun(xvals(0),yvals(0),pdyval(0),elam,rlog,theta, & scale,xtemp,ptemp,qtemp,wtemp,0,ntemp,imatch) END IF END IF C END of eigenfunction evaluation. C The most basic error monitor ensures that we get the right normalisation: errest = twelf*abs(h* (errw1*min(one,yvals(0)**2)+errw2*min(one, & yvals(1)**2))) errwm = errwm - errqm errwp = errwp - errqp C There are a number of other different error monitors to be used, depending C on whether the behaviour of solutions of the differential equation. C Compute Prufer radius for use: weight = hlf*sqrt(yvals(0)**2+pdyval(0)**2+yvals(1)**2+ & pdyval(1)**2) C Measure rate of oscillation: omega2 = (elam*w2-q2)/p2 C WEIGHT may be quite small near the endpoints, where other eigenfunctions C do not decay just as fast. Since weight is supposed to take account of these C other eigenfunctions we adjust its value where appropriate: IF (omega2.LT.zero) THEN IF (q2.LT.two*max(one,abs(elam))*w2) THEN C It is not clear that there is any representative rate of decay for nearby C eigenfunctions: a small increase in elam could change everything. weight = max(weight,tenth) ELSE C We can be reasonably confident that the rate of decay of nearby C eigenfunctions will be at least half as fast as that of the present C eigenfunction. gamma = sqrt((two*max(one,elam)*w2-q2)/ (elam*w2-q2)) weight = max(weight,weight**gamma) END IF ELSE weight = max(weight,min(tenth,two*weight)) END IF C First error monitor, valid in regions which are not highly oscillatory. C This controls the components of the eigenfunction which are not linearly C dependent on the exact eigenfunction: errest = max(errest,sixth*weight* & abs(h* (abs(yvals(0)*errwm+yvals(1)*errwp)/sqrt(max(one, & omega2))+abs(errpm*pdyval(0)+errpp*pdyval(1))))) C Second error monitor, uses Simpson's rule to measure a local contribution C to the Green's formula for eigenvalue error: errest = max(errest,sixth*abs(h* ((yvals(0)**2)*errwm+ & (yvals(1)**2)*errwp+errpm* (pdyval(0)**2)+ & errpp* (pdyval(1)**2))))/max(one,abs(elam)) IF ((h**2)*omega2.GT.hlf) THEN C Safeguard in highly oscillatory regions: in such regions we can control C eigenvalue error by controlling error in Prufer theta: omega1 = sqrt(abs(elam*w1-q1)/p1) omega3 = sqrt(abs(elam*w3-q3)/p3) omega2 = sqrt(omega2) errest = max(errest,abs(two* (p2/w2)*omega2* (omega1- & two*omega2+omega3)*h)/max(one,elam)) END IF C All the error monitors here are O(h**3) for small h. repeat = .false. IF (errest.GT.toloc) THEN repeat = .true. ratio = safe IF (toloc.LT.errest*safe3) ratio = (toloc/errest)**trd h = h*ratio icnt = icnt + 1 IF (icnt.LT.irf) GO TO 10 ifail = 10 RETURN END IF IF (errest.LT.tolow .AND. icnt.EQ.0) THEN ratio = five IF (errest.GT.tolow*p008) ratio = (tolow/errest)**trd h = h*ratio IF (infty) THEN h = min(h,hmax* (one+x2**2)) ELSE h = min(h,hmax) END IF C The next piece of code gets the meshing routine 'on-scale' at the first step. IF (phase1) THEN repeat = .true. kntr = kntr + 1 IF (kntr.LT.5) GO TO 10 END IF END IF C General step has been completed successfully, prepare for next step. phase1 = .false. icnt = 0 pp(ii) = p2 qp(ii) = q2 wp(ii) = w2 i = i + idi ii = ii + idi C CHECK THAT we have not reached the end: IF (xmesh(i)*di.GE.xende*di) GO TO 20 C If we have not reached the end then we must make sure that there is at least C one more space in each array for us to continue. IF (ii.GE.n .OR. i.LE.ic) THEN ifail = 11 IF (ifin.EQ.1) GO TO 50 GO TO 40 END IF C Everything checked. GO TO 10 C We have now successfully completed the meshing. If we were meshing backwards C then we must ensure that the mesh nodes obtained are indexed correctly. 20 IF (idi.LT.0) THEN xmesh(ic) = xende DO 30 idmy = 1,n - i xmesh(ic+idmy) = xmesh(i+idmy) pp(ic+idmy) = pp(i+idmy) qp(ic+idmy) = qp(i+idmy) wp(ic+idmy) = wp(i+idmy) 30 CONTINUE x1 = hlf* (xende+xmesh(ic+1)) CALL coefun(x1,p1,q1,w1,coeffn,params,iparam,icfn) pp(ic+1) = p1 qp(ic+1) = q1 wp(ic+1) = w1 n = ic + n - i ELSE n = i xmesh(n) = xende x1 = hlf* (xende+xmesh(n-1)) CALL coefun(x1,p1,q1,w1,coeffn,params,iparam,icfn) pp(n) = p1 qp(n) = q1 wp(n) = w1 END IF 40 RETURN C Eventually we hope to have an emergency mesh installed here 50 IF (ic.EQ.0) THEN npts = min(n/2,400) IF (npts.LT.5) RETURN CALL coarse(npts,xende,xoo,xmesh,1) n = npts CALL initia(coeffn,pp,qp,wp,xmesh,n,params,iparam,icfn) ELSE IF (ic.GT.0) THEN npts = min((n-ic)/2,400) IF (npts.LT.5) RETURN CALL coarse(npts,xoo,xende,xmesh(ic),2) CALL initia(coeffn,pp(ic+1),qp(ic+1),wp(ic+1),xmesh(ic),npts, & params,iparam,icfn) n = npts + ic ELSE RETURN END IF ifail = 12 RETURN END SUBROUTINE mmesh C --------------------------------------------------------------------- C --------------------- Source from EXPECT ---------------------------- C --------------------------------------------------------------------- SUBROUTINE eigint(fun,tol,iopt,k,kvals,elam,expval,m,mvals,wk, & eigfns,iwk,n,ifail) C August 1990: This routine has been superceded by SL05FM C Brief specification: C This routine computes mvals integrals of Fourier type if IOPT = 1, C of expectation type if IOPT = 2; that is, we compute the integrals C \int_{a}^{b}fun(x)(y_{Kvals(j)}(x))^{IOPT}dx (*) C VARIABLES: C FUN: REAL FUNCTION supplied by the user. Its specification is C FUNCTION FUN(x) C REAL x C C and it must define FUN for all a <= x <=b, where [a,b] is the C interval on which the Sturm-Liouville problem is posed. C TOL: REAL. The routine will attempt to ensure that the approximations C to the integrals which are obtained are within TOL of the actual C value of the integral when the exact eigenfunctions are replaced C by the approximate eigenfunctions. However it is impossible to C guarantee that the answer will be within TOL of the actual C integral with the exact eigenfunction because the eigenfunctions C may be very ill-conditioned. C Unchanged on exit. C IOPT: INTEGER. The value of IOPT decides the type of integrals to be C computed (see (*) above). Unchanged on exit. C EXPVAL: REAL ARRAY of DIMENSION at least (0:1,1:m). On exit, EXPVAL(0,j) C (1 <= j <= m) contains an approximation to the integral in C (*) where the eigenfunction concerned is the K(j)th eigenfunction. C EXPVAL(1,j) contains an estimate of the error due to numerical C integration, to allow the user to assess whether or not TOL C was sufficiently small. C ELAM: REAL ARRAY of DIMENSION (0:1,1:p) where p >= m. Supplied by the C preceding call to sl02fm. Unchanged on exit. C K: INTEGER ARRAY of DIMENSION at least (1:M). The array of indices C of the eigenvalues and eigenfunctions stored in the arrays EIGFNS C and ELAM. As supplied to sl02fm for the computation of ELAM. C Unchanged on exit. C MVALS: INTEGER. The number of integrals to be computed. Unchanged on C exit. C KVALS: INTEGER ARRAY of DIMENSION at least (1:MVALS). The indices of the C eigenfunctions for which the integrals are to be computed. Every C integer which appears as an element of this array must also C appear as an element of the array K. Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:IWK,1:3,1:p) where p >= m. This array C must be supplied by the user and will be used to store the C information about the normalised eigenfunctions required by EIGINT. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4,1:p) where p >= m. C Supplied by the preceding call to the routine sl02fm. The C preceding call to sl02fm need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which sl02fm is called as C in the subprogrm from which EIGINT is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of WK as declared in the calling C (sub)program. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by the routine sl02fm C in the computation of the eigenvalue approximation. Supplied by C the preceding call to sl02fm and unchanged on exit. C M: INTEGER. The number of eigenvalues computed at the preceding call C to sl02fm. As supplied to sl02fm by the user. Unchanged on exit. C IFAIL: INTEGER. On entry, IFAIL should be assigned the value 0 or 1. On C successful exit, IFAIL will have the value 0. The only failure C possible is that the routine may not be able to achieve the C accuracy TOL requested by the user, and then IFAIL will have the C value 1 on exit. C END of brief specification. C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER ifail,iopt,iwk,m,mvals,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:iwk,1:3,1:m),elam(0:1,1:m), & expval(0:1,1:m),wk(0:iwk,1:4) INTEGER k(1:m),kvals(1:mvals) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER i,ic,j,jc C .. C .. External Subroutines .. cc EXTERNAL entgrl C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. ifail = 0 IF (iopt.LT.1 .OR. iopt.GT.2) THEN ifail = 1 RETURN END IF C Retrieve the matchpoint index from the sneaky storage: ic = wk(0,2) DO 30 i = 1,mvals C Search for KVALS(i) in the array K DO 10 j = 1,m IF (kvals(i).EQ.k(j)) THEN jc = j GO TO 20 END IF 10 CONTINUE ifail = 2 RETURN 20 elam0 = elam(0,jc) + elam(1,jc) CALL entgrl(expval(0,i),expval(1,i),elam0,fun,tol,wk(0,1), & wk(1,2),wk(1,3),wk(1,4),eigfns(0,1,jc), & eigfns(0,2,jc),eigfns(0,3,jc),n,ic,iopt,ifail) C ifail is only non-zero on exit if an error has been detected. IF (ifail.NE.0) RETURN 30 CONTINUE C C All the required integrals have now been computed RETURN END SUBROUTINE eigint C -------------------------------------------------------------------- SUBROUTINE sl05fm(fun,tol,iopt,k,kvals,elam,expval,m,mvals,wk, & eigfns,iwk,n,ifail) C Brief specification: C This routine computes mvals integrals of Fourier type if IOPT = 1, C of expectation type if IOPT = 2; that is, we compute the integrals C \int_{a}^{b}fun(x)(y_{Kvals(j)}(x))^{IOPT}dx (*) C VARIABLES: C FUN: REAL FUNCTION supplied by the user. Its specification is C FUNCTION FUN(x) C REAL x C C and it must define FUN for all a <= x <=b, where [a,b] is the C interval on which the Sturm-Liouville problem is posed. C TOL: REAL. The routine will attempt to ensure that the approximations C to the integrals which are obtained are within TOL of the actual C value of the integral when the exact eigenfunctions are replaced C by the approximate eigenfunctions. However it is impossible to C guarantee that the answer will be within TOL of the actual C integral with the exact eigenfunction because the eigenfunctions C may be very ill-conditioned. C Unchanged on exit. C IOPT: INTEGER. The value of IOPT decides the type of integrals to be C computed (see (*) above). Unchanged on exit. C EXPVAL: REAL ARRAY of DIMENSION at least (0:1,1:m). On exit, EXPVAL(0,j) C (1 <= j <= m) contains an approximation to the integral in C (*) where the eigenfunction concerned is the K(j)th C eigenfunction, while EXPVAL(1,j) contains an estimate of the C error in EXPVAL(0,j) due to numerical integration, allowing C the user to decide whether or not TOL was sufficiently small. C ELAM: REAL ARRAY of DIMENSION (0:1,1:p) where p >= m. Supplied by the C preceding call to sl02fm. Unchanged on exit. C K: INTEGER ARRAY of DIMENSION at least (1:M). The array of indices C of the eigenvalues and eigenfunctions stored in the arrays EIGFNS C and ELAM. As supplied to sl02fm for the computation of ELAM. C Unchanged on exit. C MVALS: INTEGER. The number of integrals to be computed. Unchanged on C exit. C KVALS: INTEGER ARRAY of DIMENSION at least (1:MVALS). The indices of the C eigenfunctions for which the integrals are to be computed. Every C integer which appears as an element of this array must also C appear as an element of the array K. Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3,1:p) where p >= m. This array C must be supplied by the user and will be used to store the C information about the normalised eigenfunctions required by SL05FM. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4) C Supplied by the preceding call to the routine sl02fm. The C preceding call to sl02fm need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which sl02fm is called as C in the subprogrm from which EIGINT is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of WK as declared in the calling C (sub)program. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by the routine sl02fm C in the computation of the eigenvalue approximation. Supplied by C the preceding call to sl02fm and unchanged on exit. C M: INTEGER. The number of eigenvalues computed at the preceding call C to SL02FM. As supplied to sl02fm by the user. Unchanged on exit. C IFAIL: INTEGER. On entry, IFAIL should be assigned the value 0 or 1. On C successful exit, IFAIL will have the value 0. C END of brief specification. C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER ifail,iopt,iwk,m,mvals,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3,1:m),elam(0:1,1:m), & expval(0:1,1:m),wk(0:iwk,1:4) INTEGER k(1:m),kvals(1:mvals) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER i,ic,iflag,j,jc,nrec CHARACTER srname*6 C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. External Subroutines .. cc EXTERNAL nntgrl C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Intrinsic Functions .. INTRINSIC abs C .. srname = 'SL05FM' IF (iopt.LT.1 .OR. iopt.GT.2 .OR. abs(ifail).GT.1 .OR. & tol.LE.0.0D0 .OR. mvals.GT.m .OR. mvals.LT.0) THEN iflag = 1 IF (abs(ifail).GT.1) ifail = -1 WRITE (rec,FMT=9000) 9000 FORMAT ( & '** Parameter error: IOPT or IFAIL or TOL or MVALS out of range' & ) nrec = 1 GO TO 40 END IF C Retrieve the matchpoint index from the sneaky storage: ic = wk(0,2) DO 30 i = 1,mvals C Search for KVALS(i) in the array K DO 10 j = 1,m IF (kvals(i).EQ.k(j)) THEN jc = j GO TO 20 END IF 10 CONTINUE iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Required eigenfunctions not available') nrec = 1 GO TO 40 20 elam0 = elam(0,jc) + elam(1,jc) CALL nntgrl(expval(0,i),expval(1,i),elam0,fun,tol,wk(0,1), & wk(1,2),wk(1,3),wk(1,4),eigfns(0,1,jc), & eigfns(0,2,jc),eigfns(0,3,jc),n,ic,iopt,iflag) C ifail is only non-zero on exit if an error has been detected. IF (iflag.NE.0) THEN iflag = 3 WRITE (rec,FMT=9020) 9020 FORMAT ('** Automatic step-size control has failed',/, & '** Try increasing TOL') nrec = 2 GO TO 40 END IF 30 CONTINUE C C All the required integrals have now been computed ifail = 0 RETURN 40 ifail = p01abf(ifail,iflag,srname,nrec,rec) RETURN END SUBROUTINE sl05fm C -------------------------------------------------------------------- SUBROUTINE sl05f(fun,tol,iopt,k,elam,expval,wk,eigfns,iwk,n,ifail) C Brief specification: C This routine computes m integrals of Fourier type if IOPT = 1, C of expectation type if IOPT = 2; that is, we compute the integrals C \int_{a}^{b}fun(x)(y_{K(j)}(x))^{IOPT}dx (*) C VARIABLES: C FUN: REAL FUNCTION supplied by the user. Its specification is C FUNCTION FUN(x) C REAL x C C and it must define FUN for all a <= x <=b, where [a,b] is the C interval on which the Sturm-Liouville problem is posed. C TOL: REAL. The routine will attempt to ensure that the approximation C to the integral which is obtained is within TOL of the actual C value of the integral when the exact eigenfunction is replaced C by the approximate eigenfunction. However it is impossible to C guarantee that the answer will be within TOL of the actual C integral with the exact eigenfunction because the eigenfunction C may be very ill-conditioned. C Unchanged on exit. C IOPT: INTEGER. The value of IOPT decides the type of integral to be C computed (see (*) above). Unchanged on exit. C EXPVAL: REAL. On exit, EXPVAL(0) contains an approximation to the C integral in (*) where the eigenfunction concerned is the Kth C eigenfunction. EXPVAL(1) contains an estimate of the error in C EXPVAL(0) due to numerical integration, allowing the user to C decide whether or not TOL was sufficiently small. C ELAM: REAL ARRAY of DIMENSION (0:1). Supplied by the C preceding call to sl02f. Unchanged on exit. C K: INTEGER. The index of the eigenvalue and eigenfunction in question. C As supplied to sl02f for the computation of ELAM. Unchanged on C exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3). This array C must be supplied by the user and will be used to store the C information about the normalised eigenfunctions required by SL05F. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4). C Supplied by the preceding call to the routine sl02f. The C preceding call to sl02f need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which sl02f is called as C in the subprogram from which SL05F is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of WK as declared in the calling C (sub)program. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by the routine sl02f C in the computation of the eigenvalue approximation. Supplied by C the preceding call to sl02f and unchanged on exit. C IFAIL: INTEGER. On entry, IFAIL should be assigned the value 0 or 1. On C successful exit, IFAIL will have the value 0. C END of brief specification. C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER ifail,iopt,iwk,k,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3),elam(0:1),expval(0:1), & wk(0:iwk,1:4) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER ic,iflag,nrec CHARACTER srname*6 C .. C .. External Subroutines .. cc EXTERNAL nntgrl C .. C .. External Functions .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Intrinsic Functions .. INTRINSIC abs C .. srname = ' SL05F' IF (iopt.LT.1 .OR. iopt.GT.2 .OR. abs(ifail).GT.1 .OR. & tol.LE.0.0D0) THEN iflag = 1 IF (abs(ifail).GT.1) ifail = -1 WRITE (rec,FMT=9000) 9000 FORMAT ( & '** Parameter error: IOPT or IFAIL or TOL out of range' & ) nrec = 1 GO TO 10 END IF C Retrieve the matchpoint index from the sneaky storage ic = wk(0,2) elam0 = elam(0) + elam(1) CALL nntgrl(expval(0),expval(1),elam0,fun,tol,wk(0,1),wk(1,2), & wk(1,3),wk(1,4),eigfns(0,1),eigfns(0,2),eigfns(0,3),n, & ic,iopt,iflag) C ifail is only non-zero on exit if an error has been detected. IF (iflag.NE.0) THEN iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Automatic step-size control has failed',/, & '** Try increasing TOL') nrec = 2 GO TO 10 END IF ifail = 0 C C All the required integrals have now been computed RETURN 10 ifail = p01abf(ifail,iflag,srname,nrec,rec) RETURN END SUBROUTINE sl05f C -------------------------------------------------------------------- SUBROUTINE entgrl(expval,errest,elam,fun,tol,xmesh,pp,qp,wp,rlog, & theta,scale,n,ic,iopt,ifail) C .. Parameters .. DOUBLE PRECISION one,two,half,qtr,safe,tosafe,bound,zero, & ffteen INTEGER nvec PARAMETER (one=1.D0,two=2.D0,half=one/two, & qtr=half*half,safe=0.95D0,tosafe=0.8D0,bound=2.D-1, & zero=0.D0,ffteen=1.5D1,nvec=1) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,errest,expval,tol INTEGER ic,ifail,iopt,n C .. C .. Array Arguments .. DOUBLE PRECISION pp(1:n),qp(1:n),rlog(0:n),scale(0:n),theta(0:n), & wp(1:n),xmesh(0:n) C .. C .. Subroutine Arguments .. C .. C .. Local Scalars .. DOUBLE PRECISION abserr,ans4,di,epsilo,err,floc,h,hmax,p,q,ratio, & rl,rln,sc,scn,tend,th,thn,tmid,to,toloc,value,w, & xend,xfin,xmid,xo INTEGER i,icount,idi,ifin,ii,init,ip1,itime,nstep C .. C .. Local Arrays .. DOUBLE PRECISION ans1(1:nvec),ans2(1:nvec),ans3(1:nvec), & fend(1:nvec),fmid(1:nvec),fo(1:nvec) C .. C .. External Subroutines .. cc EXTERNAL quad C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf cc EXTERNAL x02ajf C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. epsilo = x02ajf(1.D0) toloc = safe*tol value = zero errest = zero nstep = 0 itime = 1 init = 0 ifin = ic - 1 idi = 1 di = one icount = 0 h = xmesh(1) - xmesh(0) 10 DO 40 i = init,ifin,idi xo = xmesh(i) ip1 = i + idi hmax = xmesh(ip1) - xmesh(i) h = di*min(abs(h),abs(hmax)) xfin = xmesh(ip1) xend = xo + h ii = i IF (idi.GT.0) ii = ip1 p = pp(ii) q = qp(ii) w = wp(ii) rl = rlog(i) th = theta(i) sc = scale(i) 20 rln = rl thn = th scn = sc C Do one step xmid = half* (xo+xend) to = xo tmid = xmid tend = xend fo(1) = fun(to) fmid(1) = fun(tmid) fend(1) = fun(tend) CALL quad(xo,xend,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec,iopt, & ans1) C Do two half-steps rl = rln th = thn sc = scn floc = fend(1) fend(1) = fmid(1) to = half* (xo+xmid) fmid(1) = fun(to) CALL quad(xo,xmid,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec,iopt, & ans2) fo(1) = fend(1) fend(1) = floc to = half* (xo+xmid) fmid(1) = fun(to) CALL quad(xmid,xend,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec, & iopt,ans3) ans4 = ans2(1) + ans3(1) C Estimate the error err = (ans4-ans1(1))/ffteen errest = errest + err abserr = abs(err) IF (abserr.GT.toloc) THEN ratio = min(half, (toloc/abserr)**qtr) C It is conceivable that a failed step may occur when we are stepping exactly C to the end xfin, in which case (xend-xo) \neq h. In such a case we must C set h = ratio*(xend-xo) for the repeat step, rather than h = ratio*h. C In other cases xend-xo=h and there is nothing to worry about. h = ratio* (xend-xo) xend = xo + h icount = icount + 1 C At most ten attempts to get the stepsize right: IF (icount.LT.10) THEN rl = rln th = thn sc = scn GO TO 20 END IF ifail = 1 GO TO 50 ELSE value = value + ans4 + err IF (((xend-xfin)*di+epsilo).GE.zero) GO TO 30 IF (abserr.LT.toloc*tosafe .AND. icount.EQ.0) THEN C The error is very small and the step before last was not a failure so C we may increase the stepsize. ratio = one/max(bound, (abserr/toloc)**qtr) h = ratio*h END IF C We have completed the last step successfully, and provided the step before C was not a failure we may have increased the step length. icount = 0 xo = xend xend = xo + h IF (((xend-xfin)*di+epsilo).GE.zero) xend = xfin GO TO 20 END IF C Have successfully completed the integration from xmesh(i) to xmesh(i+idi) 30 nstep = nstep + 1 icount = 0 40 CONTINUE C If itime = 1 then we have only done the shooting from xmesh(0) to C xmesh(ic), and we must therefore do the shooting from xmesh(n) to C xmesh(ic). IF (itime.EQ.1) THEN itime = 2 idi = -1 di = -one init = n ifin = ic + 1 h = xmesh(n) - xmesh(n-1) GO TO 10 END IF C Successful completion: ifail = 0 expval = value C PRINT *,'ENTGRL error estimate:',errest RETURN C Unsuccessful completion: 50 expval = zero RETURN END SUBROUTINE entgrl C --------------------------------------------------------------------- SUBROUTINE nntgrl(expval,errest,elam,fun,tol,xmesh,pp,qp,wp,rlog, & theta,scale,n,ic,iopt,ifail) C .. Parameters .. DOUBLE PRECISION one,two,half,qtr,safe,tosafe,bound,zero, & ffteen INTEGER nvec PARAMETER (one=1.D0,two=2.D0,half=one/two, & qtr=half*half,safe=0.95D0,tosafe=0.8D0,bound=2.D-1, & zero=0.D0,ffteen=1.5D1,nvec=1) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,errest,expval,tol INTEGER ic,ifail,iopt,n C .. C .. Array Arguments .. DOUBLE PRECISION pp(1:n),qp(1:n),rlog(0:1),scale(0:1),theta(0:1), & wp(1:n),xmesh(0:n) C .. C .. Subroutine Arguments .. C .. C .. Local Scalars .. DOUBLE PRECISION abserr,ans4,di,epsilo,err,floc,h,hmax,p,q,ratio, & rl,rln,sc,scn,tend,th,thn,tmid,to,toloc,value,w, & xend,xfin,xmid,xo INTEGER i,icount,idi,ifin,ii,init,ip1,itime,nstep C .. C .. Local Arrays .. DOUBLE PRECISION ans1(1:nvec),ans2(1:nvec),ans3(1:nvec), & fend(1:nvec),fmid(1:nvec),fo(1:nvec) C .. C .. External Subroutines .. cc EXTERNAL quad C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf cc EXTERNAL x02ajf C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. epsilo = x02ajf(1.D0) toloc = safe*tol value = zero errest = zero nstep = 0 itime = 1 init = 0 ifin = ic - 1 idi = 1 di = one icount = 0 h = xmesh(1) - xmesh(0) rl = rlog(0) th = theta(0) sc = scale(0) 10 DO 40 i = init,ifin,idi xo = xmesh(i) ip1 = i + idi hmax = xmesh(ip1) - xmesh(i) h = di*min(abs(h),abs(hmax)) xfin = xmesh(ip1) xend = xo + h ii = i IF (idi.GT.0) ii = ip1 p = pp(ii) q = qp(ii) w = wp(ii) C These three lines removed to comply with reduced storage requirements C rl = rlog(i) C th = theta(i) C sc = scale(i) C 20 rln = rl thn = th scn = sc C Do one step xmid = half* (xo+xend) to = xo tmid = xmid tend = xend fo(1) = fun(to) fmid(1) = fun(tmid) fend(1) = fun(tend) CALL quad(xo,xend,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec,iopt, & ans1) C Do two half-steps rl = rln th = thn sc = scn floc = fend(1) fend(1) = fmid(1) to = half* (xo+xmid) fmid(1) = fun(to) CALL quad(xo,xmid,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec,iopt, & ans2) fo(1) = fend(1) fend(1) = floc to = half* (xend+xmid) fmid(1) = fun(to) CALL quad(xmid,xend,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec, & iopt,ans3) ans4 = ans2(1) + ans3(1) C Estimate the error err = (ans4-ans1(1))/ffteen errest = errest + err abserr = abs(err) IF (abserr.GT.toloc) THEN ratio = min(half, (toloc/abserr)**qtr) C It is conceivable that a failed step may occur when we are stepping exactly C to the end xfin, in which case (xend-xo) \neq h. In such a case we must C set h = ratio*(xend-xo) for the repeat step, rather than h = ratio*h. C In other cases xend-xo=h and there is nothing to worry about. h = ratio* (xend-xo) xend = xo + h icount = icount + 1 C At most ten attempts to get the stepsize right: IF (icount.LT.10) THEN rl = rln th = thn sc = scn GO TO 20 END IF ifail = 1 GO TO 50 ELSE value = value + ans4 + err IF (((xend-xfin)*di+epsilo).GE.zero) GO TO 30 IF (abserr.LT.toloc*tosafe .AND. icount.EQ.0) THEN C The error is very small and the step before last was not a failure so C we may increase the stepsize. ratio = one/max(bound, (abserr/toloc)**qtr) h = ratio*h END IF C We have completed the last step successfully, and provided the step before C was not a failure we may have increased the step length. icount = 0 xo = xend xend = xo + h IF (((xend-xfin)*di+epsilo).GE.zero) xend = xfin GO TO 20 END IF C Have successfully completed the integration from xmesh(i) to xmesh(i+idi) 30 nstep = nstep + 1 icount = 0 40 CONTINUE C If itime = 1 then we have only done the shooting from xmesh(0) to C xmesh(ic), and we must therefore do the shooting from xmesh(n) to C xmesh(ic). IF (itime.EQ.1) THEN itime = 2 idi = -1 di = -one init = n ifin = ic + 1 h = xmesh(n) - xmesh(n-1) rl = rlog(1) th = theta(1) sc = scale(1) GO TO 10 END IF C Successful completion: ifail = 0 expval = value C PRINT *,'ENTGRL error estimate:',errest RETURN C Unsuccessful completion: 50 expval = zero RETURN END SUBROUTINE nntgrl C ------------------------------------------------------------------- SUBROUTINE quad(xo,xend,p,q,w,elam,rlog,theta,scale,fo,fmid,fend, & nvec,iopt,ans) C .. Parameters .. DOUBLE PRECISION one,two,half,qtr,three,twtrds,trd,sxteen PARAMETER (one=1.D0,two=2.D0,half=one/two,qtr=half*half, & three=3.D0,twtrds=two/three,trd=one/three,sxteen=16.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,p,q,rlog,scale,theta,w,xend,xo INTEGER iopt,nvec C .. C .. Array Arguments .. DOUBLE PRECISION ans(1:nvec),fend(1:nvec),fmid(1:nvec),fo(1:nvec) C .. C .. Local Scalars .. DOUBLE PRECISION alfa,alfa2,alfa3,alfah,calfah,chqtrt,cntrb1, & cntrb2,cntrb3,cth,cthn,cthnp1,dummy,erl,f0,f1,f2, & gqtrt,h,onovsh,pdy,pdynew,phit,psit,qbig, & qtrt,rln,s2thn,s2thp1,salfah,snew,sqrts,sth,sthn, & sthnp1,t,talfah,term,thn,thnp1,x1,x2,xit,y, & yend,ynew,yo INTEGER i C .. C .. External Functions .. cc DOUBLE PRECISION chi,g,phi,psi,rescal,scl,x02ajf,xi cc EXTERNAL chi,g,phi,psi,rescal,scl,x02ajf,xi C .. C .. External Subroutines .. cc EXTERNAL fulstp C .. C .. Intrinsic Functions .. INTRINSIC abs,atan2,cos,exp,log,sign,sin,sqrt,tanh C .. DO 10 i = 1,nvec ans(i) = 0.D0 10 CONTINUE h = xend - xo IF (abs(h).LE.x02ajf(1.D0)) RETURN C xmid = half* (xo+xend) qbig = elam*w - q t = (h**2)*qbig/p qtrt = t*qtr C Interpolate to f using a quadratic expression C f(x) = f0 + f1*(x-xmid) + f2*(x-xmid)**2 C where the coefficients are given by C END of interpolation to f. IF (iopt.EQ.2) THEN C We require an expectation integral. There are three terms in the integral C arising from the three parts which approximate to f, and there are three C cases depending on the size of the parameter t. IF (abs(t).GT.0.1D0) THEN alfa2 = abs(qbig/p) alfa = sqrt(alfa2) alfah = alfa*h IF (t.GT.0.1D0) THEN snew = sqrt(abs(qbig*p)) thn = scl(theta,snew/scale) rln = rescal(scale,snew,thn,rlog) C In this case the eigenfunction has a very simple expression and all C three terms in the integral can be computed without divide by zero problems. C 1: The constant contribution thnp1 = thn + alfah s2thn = sin(two*thn) s2thp1 = sin(two*thnp1) cntrb1 = half*h - qtr* (s2thp1-s2thn)/alfa C 2: The linear contribution salfah = sin(alfah) calfah = cos(alfah) cntrb2 = h*sin(two*thn+alfah)* (salfah/alfah-calfah)* & qtr/alfa C 3: The quadratic contribution cntrb3 = ((h**3)/sxteen)* (twtrds- & two*cos(two+thn+alfah)* & (salfah/alfah+two*calfah/abs(t)- & two*salfah/ (alfah**3))) C 4: The entire contribution DO 20 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = w*exp(two*rln)* & (f0*cntrb1+f1*cntrb2+f2*cntrb3)/snew 20 CONTINUE theta = thnp1 scale = snew rlog = rln ELSE IF (t.LT. (-0.1D0)) THEN C In this case the integral is a pain to calculate because if it is not done C properly then there is the danger of floating overflow problems. C We need to know the value of the eigenfunction at each end of the interval yo = exp(rlog)*sin(theta)/sqrt(scale) x1 = xo x2 = xend C This call also does the updating of rlog, theta and scale: CALL fulstp(x1,x2,sign(one,h),scale,theta,rlog,p,qbig, & w,dummy,-1) yend = exp(rlog)*sin(theta)/sqrt(scale) C We can now proceed to compute each contribution in turn. C 1: The constant contribution C cntrb1 = sign(one,h)*exp(dummy) C 2: The linear contribution talfah = tanh(alfah) cntrb2 = qtr* (h**2)* (yend-yo)* (yend+yo)* & (one/talfah-one/alfah)/alfah C 3: The quadratic contribution onovsh = sign(one,alfah)*sqrt((one/talfah**2)-one) term = one/alfah - two/ ((alfah**2)*talfah) + & two/ (alfah**3) cntrb3 = ((half*h)**3)* ((yo**2+yend**2)* & (-trd* (onovsh**2)+ (one/talfah)*term)+ & two*yo*yend* (trd/ (talfah)-term)*onovsh) C 4: The full contribution DO 30 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = f0*cntrb1 + w* (f1*cntrb2+f2*cntrb3) 30 CONTINUE C END of case t < -0.1 END IF C END of case ABS(t) > 0.1 ELSE C Case ABS(t) <=0.1. This is by far the worst case since series expansions C of various terms are required for small alfah. Compute the contributions C from each of the terms involved. yo = exp(rlog)*sin(theta)/sqrt(scale) x1 = xo x2 = xend CALL fulstp(x1,x2,sign(one,h),scale,theta,rlog,p,qbig,w, & dummy,-1) yend = exp(rlog)*sin(theta)/sqrt(scale) C 1: The constant term. We do this, and compute the values at the ends of the C interval at the same time, by calling the fulstp routine. cntrb1 = sign(one,h)*exp(dummy) C 2: The linear contribution cntrb2 = ((half*h)**2)* (yend-yo)* (yend+yo)*g(-t) C 3: The quadratic contribution (Uugh!) xit = xi(t) cntrb3 = ((half*h)**3)* (((yend-yo)**2)*xit/ (phi(-t)**2)+ & ((yend+yo)**2)/ (three* (one+psi(-t)))- & half* (yo**2+yend**2)*t*xit) C 4: The full contribution: DO 40 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = f0*cntrb1 + w* (f1*cntrb2+f2*cntrb3) 40 CONTINUE C END of cases for iopt = 2 END IF ELSE IF (iopt.EQ.1) THEN C This case is not so easy -- we require a Fourier integral. IF (abs(t).GT.0.1D0) THEN snew = sqrt(abs(qbig*p)) thn = scl(theta,snew/scale) rln = rescal(scale,snew,thn,rlog) alfa2 = abs(qbig/p) alfa = sqrt(alfa2) alfa3 = alfa*alfa2 alfah = sqrt(abs(t)) IF (t.GT.0.1D0) THEN thnp1 = thn + alfah C Compute the contributions from each of the terms approximating f cthn = cos(thn) cthnp1 = cos(thnp1) sthn = sin(thn) sthnp1 = sin(thnp1) C 1: The constant term cntrb1 = (cthn-cthnp1)/alfa C 2: The linear term cntrb2 = h* (cthnp1+cthn)*half/alfa - & (sthnp1-sthn)/ (alfa2) C 3: The quadratic term cntrb3 = (h**2)*qtr* (cthn-cthnp1)/alfa + & h* (sthnp1+sthn)/ (alfa2) - & two* (cthn-cthnp1)/ (alfa3) C 4: The full contribution DO 50 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = w*exp(rln)* (f0*cntrb1+f1*cntrb2+ & f2*cntrb3)/sqrt(snew) 50 CONTINUE thn = thnp1 ELSE C ** t < -0.1 ** C First compute the values of the eigenfunction at x = xo and xend. yo = exp(rln)*sin(thn)/sqrt(snew) x1 = xo x2 = xend C Advance the values of rln,thn, and the scalefactor snew. CALL fulstp(x1,x2,sign(one,h),snew,thn,rln,p,qbig,w, & dummy,1) C Compute the eigenfunction at the point xend yend = exp(rln)*sin(thn)/sqrt(snew) C Compute the contribution from each of these approximating terms C 1: The Constant Term talfah = tanh(half*alfa*h) cntrb1 = (yend+yo)*talfah/alfa C 2: The Linear Term cntrb2 = (yend-yo)* (half*h/talfah-one/alfa)/alfa C 3: The Quadratic Term cntrb3 = two* (yo+yend)* ((((half*h)**2)+two/alfa2)* & talfah-h/alfa)/alfa C 4: The full contribution DO 60 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = w* (f0*cntrb1+f1*cntrb2+f2*cntrb3) 60 CONTINUE END IF rlog = rln scale = snew theta = thn C END of case where ABS(t) > 0.1 ELSE C The case where ABS(t) <= 0.1 C hlog = log(abs(h)) sth = sin(theta) cth = cos(theta) sqrts = sqrt(scale) phit = phi(-t) psit = psi(-t) erl = exp(rlog) y = sth/sqrts pdy = cth*sqrts C Update rlog and theta: theta = theta + atan2(h* (scale/p*cth**2+ & qbig/scale*sth**2),chi(-t)+ & (scale/p-qbig/scale)*h*sth*cth) ynew = h*phit*pdy/p + y*psit pdynew = pdy*psit - y*h*qbig*phit rlog = rlog + half*log((pdynew**2)/scale+ (ynew**2)*scale) C C Compute the contribution from each of these approximating terms C 1: The Constant Term chqtrt = chi(-qtrt) cntrb1 = half*h*erl* (y+ynew)/chqtrt C 2: The Linear Term gqtrt = g(-qtrt) cntrb2 = (h**2)*qtr*erl* (ynew-y)*gqtrt C 3: The Quadratic Term ??? cntrb3 = ((h*half)**3)*erl* ((ynew+y)/chqtrt)* & (one-two*gqtrt) C 4: The whole contribution: DO 70 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = w* (f0*cntrb1+f1*cntrb2+f2*cntrb3) 70 CONTINUE END IF END IF C If we were integrating backwards then the next line will get the correct C sign for the integral which we actually want. DO 80 i = 1,nvec ans(i) = ans(i)*sign(one,h) 80 CONTINUE RETURN END SUBROUTINE quad C ----------------------------------------------------------------------- DOUBLE PRECISION FUNCTION g(t) C .. Parameters .. DOUBLE PRECISION fac2,fac3,fac4,fac5,fac6,fac7,fac8,fac9,fac10, & fac11,fac12,fac13,fac14,fac15 PARAMETER (fac2=5.D-1,fac3=fac2/3.D0,fac4=fac3/4.D0, & fac5=fac4/5.D0,fac6=fac5/6.D0,fac7=fac6/7.D0, & fac8=fac7/8.D0,fac9=fac8/9.D0,fac10=fac9/10.D0, & fac11=fac10/11.D0,fac12=fac11/12.D0,fac13=fac12/13.D0, & fac14=fac13/14.D0,fac15=fac14/15.D0) DOUBLE PRECISION c0,c1,c2,c3,c4,c5,c6 PARAMETER (c0=fac2-fac3,c1=fac4-fac5,c2=fac6-fac7,c3=fac8-fac9, & c4=fac10-fac11,c5=fac12-fac13,c6=fac14-fac15) C .. C .. Scalar Arguments .. DOUBLE PRECISION t C .. C .. External Functions .. cc DOUBLE PRECISION phi c EXTERNAL phi C .. g = c0 + t* (c1+t* (c2+t* (c3+t* (c4+t* (c5+t*c6)))))/phi(t) RETURN END FUNCTION g C -------------------------------------------------------------------------- DOUBLE PRECISION FUNCTION xi(t) C .. Parameters .. DOUBLE PRECISION fac2,fac3,fac4,fac5,fac6,fac7,fac8,fac9,fac10, & fac11,fac12,fac13,fac14 PARAMETER (fac2=5.D-1,fac3=fac2/3.D0,fac4=fac3/4.D0, & fac5=fac4/5.D0,fac6=fac5/6.D0,fac7=fac6/7.D0, & fac8=fac7/8.D0,fac9=fac8/9.D0,fac10=fac9/10.D0, & fac11=fac10/11.D0,fac12=fac11/12.D0,fac13=fac12/13.D0, & fac14=fac13/14.D0) DOUBLE PRECISION c1,c2,c3,c4,c5,c6,c7 PARAMETER (c1=fac2/5.D0,c2=-fac4/7.D0,c3=fac6/9.D0,c4=-fac8/11.D0, & c5=fac10/13.D0,c6=-fac12/15.D0,c7=fac14/17.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION t C .. xi = c1 + t* (c2+t* (c3+t* (c4+t* (c5+t* (c6+t*c7))))) RETURN END FUNCTION xi C --------------------------------------------------------------------- C --------------------- Source from EXTRA ----------------------------- C --------------------------------------------------------------------- SUBROUTINE sl07fm(elam1,elam2,wk1,wk2,iwk1,iwk2,m1,m2,k1,k2, & eigfn1,eigfn2,n1,n2,i1,i2,fun,tol,ans,ifail) C This routine provides an interface for the routine FCF for computing C Franck-Condon factors. It is designed primarily for the multiple C eigenvalue case where the eigenvalues of each problem have all been C computed on a single mesh, but may also be used for the case where the C eigenvalues have been computed singly. A single Franck-Condon factor, C specified by the integers i1 and i2, is computed at each call. C Failure flags: C IFAIL = 1: Parameter out of range on entry. C IFAIL = 3: An error in SUBROUTINE fcf. Cannot achieve required accuracy. C IFAIL = 2: A parameter error. We do not have the eigenfunctions for the C integrals requested. C C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER i1,i2,ifail,iwk1,iwk2,m1,m2,n1,n2 C .. C .. Array Arguments .. DOUBLE PRECISION ans(0:1),eigfn1(0:1,1:3,1:m1), & eigfn2(0:1,1:3,1:m2),elam1(0:1,1:m1), & elam2(0:1,1:m2),wk1(0:iwk1,1:4),wk2(0:iwk2,1:4) INTEGER k1(1:m1),k2(1:m2) C .. C .. Local Scalars .. DOUBLE PRECISION eig1,eig2 INTEGER i,ic1,ic2,iflag,j1,j2,nrec CHARACTER srname*6 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. External Subroutines .. cc EXTERNAL nfcf C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. Intrinsic Functions .. INTRINSIC abs C .. iflag = 0 srname = 'SL07FM' IF (abs(ifail).GT.1 .OR. tol.LE.0.D0) THEN WRITE (rec,FMT=9000) 9000 FORMAT ('** Parameter error: IFAIL or TOL out of range') IF (abs(ifail).GT.1) ifail = -1 iflag = 1 nrec = 1 GO TO 50 END IF C Check to make sure we have available the eigenfunctions for the integral C requested: DO 10 i = 1,m1 IF (k1(i).EQ.i1) THEN j1 = i GO TO 20 END IF 10 CONTINUE iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Necessary eigenfunctions not both available') nrec = 1 GO TO 50 20 DO 30 i = 1,m2 IF (k2(i).EQ.i2) THEN j2 = i GO TO 40 END IF 30 CONTINUE iflag = 2 WRITE (rec,FMT=9020) 9020 FORMAT ('** Necessary eigenfunctions not both available') nrec = 1 GO TO 50 40 ic1 = wk1(0,2) ic2 = wk2(0,2) iflag = 0 eig1 = elam1(0,j1) + elam1(1,j1) eig2 = elam2(0,j2) + elam2(1,j2) CALL nfcf(eig1,wk1(0,1),wk1(1,2),wk1(1,3),wk1(1,4),eigfn1(0,1,j1), & eigfn1(0,2,j1),eigfn1(0,3,j1),eig2,wk2(0,1),wk2(1,2), & wk2(1,3),wk2(1,4),eigfn2(0,1,j2),eigfn2(0,2,j2), & eigfn2(0,3,j2),n1,n2,ic1,ic2,fun,tol,ans(0),ans(1), & iflag) IF (iflag.NE.0) THEN iflag = 3 WRITE (rec,FMT=9030) 9030 FORMAT ('** Automatic step-size control has failed',/, & '** Try a larger value of TOL') nrec = 2 GO TO 50 END IF ifail = 0 RETURN 50 ifail = p01abf(ifail,iflag,srname,nrec,rec) END SUBROUTINE sl07fm C --------------------------------------------------------------------- SUBROUTINE sl07f(elam1,elam2,wk1,wk2,iwk1,iwk2,eigfn1,eigfn2,n1, & n2,fun,tol,ans,ifail) C This routine provides an interface for the routine FCF for computing C Franck-Condon factors. It is designed for the single C eigenvalue case. A single Franck-Condon factor, is computed at each call. C Failure flags: C IFAIL = 1: Parameter out of range on entry. C IFAIL = 2: An error in SUBROUTINE fcf. Cannot achieve required accuracy. C C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER ifail,iwk1,iwk2,n1,n2 C .. C .. Array Arguments .. DOUBLE PRECISION ans(0:1),eigfn1(0:1,1:3),eigfn2(0:1,1:3), & elam1(0:1),elam2(0:1),wk1(0:iwk1,1:4), & wk2(0:iwk2,1:4) C .. C .. Local Scalars .. DOUBLE PRECISION eig1,eig2 INTEGER ic1,ic2,iflag,nrec CHARACTER srname*6 C .. C .. External Functions .. cc INTEGER p01abf c EXTERNAL p01abf C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. External Subroutines .. cc EXTERNAL nfcf C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. Intrinsic Functions .. INTRINSIC abs C .. iflag = 0 srname = ' SL07F' IF (abs(ifail).GT.1 .OR. tol.LE.0.D0) THEN WRITE (rec,FMT=9000) 9000 FORMAT ('** Parameter error: IFAIL or TOL out of range') IF (abs(ifail).GT.1) ifail = -1 iflag = 1 nrec = 1 GO TO 10 END IF ic1 = wk1(0,2) ic2 = wk2(0,2) iflag = 0 eig1 = elam1(0) + elam1(1) eig2 = elam2(0) + elam2(1) CALL nfcf(eig1,wk1(0,1),wk1(1,2),wk1(1,3),wk1(1,4),eigfn1(0,1), & eigfn1(0,2),eigfn1(0,3),eig2,wk2(0,1),wk2(1,2),wk2(1,3), & wk2(1,4),eigfn2(0,1),eigfn2(0,2),eigfn2(0,3),n1,n2,ic1, & ic2,fun,tol,ans(0),ans(1),iflag) IF (iflag.NE.0) THEN iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Automatic step-size control has failed',/, & '** Try a larger value of TOL') nrec = 2 GO TO 10 END IF ifail = 0 RETURN 10 ifail = p01abf(ifail,iflag,srname,nrec,rec) END SUBROUTINE sl07f C --------------------------------------------------------------------- SUBROUTINE nfcf(elam1,xmesh1,pp1,qp1,wp1,rlog1,theta1,scale1, & elam2,xmesh2,pp2,qp2,wp2,rlog2,theta2,scale2,n1, & n2,ic1,ic2,fun,tol,ans,errest,ifail) C Declarations C .. Parameters .. DOUBLE PRECISION one,two,three,half,trd,qtr,safe,tosafe,bound,zero PARAMETER (one=1.D0,two=2.D0,three=3.D0,half=one/two, & trd=one/three,qtr=half*half,safe=0.95D0,tosafe=0.8D0, & bound=2.D-1,zero=0.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION ans,elam1,elam2,errest,tol INTEGER ic1,ic2,ifail,n1,n2 C .. C .. Array Arguments .. DOUBLE PRECISION pp1(1:n1),pp2(1:n2),qp1(1:n1),qp2(1:n2), & rlog1(0:1),rlog2(0:1),scale1(0:1),scale2(0:1), & theta1(0:1),theta2(0:1),wp1(1:n1),wp2(1:n2), & xmesh1(0:n1),xmesh2(0:n2) C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Local Scalars .. DOUBLE PRECISION abserr,ans1,ans2,ans3,ans4,di,diff,dummy,err,h, & hmax,p1,p2,q1,q2,ratio,rl1,rl2,rln1, & rln2,sc1,sc2,scn1,scn2,th1,th2, & thn1,thn2,toloc,value,w1,w2,x1,x2,x3,xend, & xfin,xhigh,xlow,xmid,xo,xsplit,xstart,xstop INTEGER i,i1,i1high,i1low,i1m1,i2,i2high,i2low,i2m1,icount,idi, & ii1,ii2,ipp,isplit,isplt1,isplt2,itest,iupdat,nstep LOGICAL frstme C .. C .. Local Arrays .. DOUBLE PRECISION rloc(0:1),scloc(0:1),thloc(0:1) C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf cc EXTERNAL x02ajf C .. C .. External Subroutines .. cc EXTERNAL fulprf,fulstp,inrprd C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min C .. C This subroutine computes Franck-Condon factors, given the appropriate C eigenfunctions. errest = zero nstep = 0 C Very first bit: locate a suitable splitting point for the integration. C Locate this point on the mesh XMESH1 (well it has to be somewhere!) toloc = tol*safe icount = 0 i1low = ic1 i1high = ic1 i2low = ic2 i2high = ic2 DO 10 i = ic1,1,-1 IF ((elam1*wp1(i)-qp1(i)).LT.zero) GO TO 20 i1low = i - 1 10 CONTINUE 20 DO 30 i = ic1,n1 IF ((elam1*wp1(i)-qp1(i)).LT.zero) GO TO 40 i1high = i 30 CONTINUE 40 DO 50 i = ic2,1,-1 IF ((elam2*wp2(i)-qp2(i)).LT.zero) GO TO 60 i2low = i - 1 50 CONTINUE 60 DO 70 i = ic2,n2 IF ((elam2*wp2(i)-qp2(i)).LT.zero) GO TO 80 i2high = i 70 CONTINUE 80 IF ((xmesh1(i1high)-xmesh2(i2low))* & (xmesh2(i2high)-xmesh1(i1low)).GE.zero) THEN C There is an overlap of the classically allowed regions. We choose a C matchpoint in this region. xhigh = min(xmesh2(i2high),xmesh1(i1high)) xlow = max(xmesh2(i2low),xmesh1(i1low)) xsplit = half* (xhigh+xlow) diff = abs(xsplit-xmesh1(i1high)) isplt1 = i1high DO 90 i = i1low,i1high - 1 IF (xmesh1(i).GE.xlow .AND. xmesh1(i).LE.xhigh) THEN IF (abs(xmesh1(i)-xsplit).LE.diff) THEN isplt1 = i diff = abs(xmesh1(i)-xsplit) END IF END IF 90 CONTINUE diff = abs(xsplit-xmesh2(i2high)) isplt2 = i2high DO 100 i = i2low,i2high - 1 IF (xmesh2(i).GE.xlow .AND. xmesh2(i).LE.xhigh) THEN IF (abs(xmesh2(i)-xsplit).LE.diff) THEN isplt2 = i diff = abs(xmesh2(i)-xsplit) END IF END IF 100 CONTINUE ELSE C There is no overlap in the classically allowed regions. Use a C heuristic. xsplit = half* (xmesh1(ic1)+xmesh2(ic2)) diff = abs(xsplit-xmesh1(1)) isplt1 = 1 DO 110 i = 2,n1 - 1 IF (abs(xmesh1(i)-xsplit).LE.diff) THEN isplt1 = i diff = abs(xmesh1(i)-xsplit) END IF 110 CONTINUE diff = abs(xsplit-xmesh2(i)) isplt2 = 1 DO 120 i = 2,n2 - 1 IF (abs(xmesh2(i)-xsplit).LE.diff) THEN isplt2 = i diff = abs(xmesh2(i)-xsplit) END IF 120 CONTINUE END IF IF (abs(xmesh1(isplt1)-xsplit).LT.abs(xmesh2(isplt2)-xsplit)) THEN itest = 1 isplit = isplt1 ELSE IF (abs(xmesh1(isplt1)-xsplit).GT. & abs(xmesh2(isplt2)-xsplit)) THEN itest = 2 isplit = isplt2 ELSE IF (xmesh1(isplt1).LE.xmesh2(isplt2)) THEN itest = 1 isplit = isplt1 ELSE itest = 2 isplit = isplt2 END IF C What we just did is by no means foolproof. It is always possible that C there is a part of the range of integration where shooting in one C direction is unstable for one eigenfunction while shooting in a different C direction is unstable for the other eigenfunction. This subroutine assumes C that such an interval does not exist. rl1 = rlog1(0) th1 = theta1(0) sc1 = scale1(0) rl2 = rlog2(0) th2 = theta2(0) sc2 = scale2(0) idi = 1 di = one i1 = 1 i2 = 1 i1m1 = i1 - idi i2m1 = i2 - idi IF (xmesh1(0).EQ.xmesh2(0)) THEN xstart = xmesh1(0) iupdat = 0 ELSE IF (xmesh1(0).LT.xmesh2(0)) THEN xstart = xmesh2(0) iupdat = 1 ELSE xstart = xmesh1(0) iupdat = 2 END IF IF (iupdat.EQ.1) THEN 130 IF ((xmesh1(i1)-xstart)*di.LE.zero) THEN rloc(0) = rl1 thloc(0) = th1 scloc(0) = sc1 C WARNING: this changes i1m1 CALL fulprf(i1m1,thloc,rloc,scloc,dummy,i1,one,elam1,pp1, & qp1,wp1,xmesh1,1,n1,2) rl1 = rloc(1) th1 = thloc(1) sc1 = scloc(1) i1m1 = i1 i1 = i1 + idi GO TO 130 END IF C Integrate RL1, TH1 and SC1 from XMESH1(I1M1) to XSTART. ii1 = max(i1,i1m1) CALL fulstp(xmesh1(i1m1),xstart,di,sc1,th1,rl1,pp1(ii1), & elam1*wp1(ii1)-qp1(ii1),wp1(ii1),dummy,1) ELSE IF (iupdat.EQ.2) THEN 140 IF ((xmesh2(i2)-xstart)*di.LE.zero) THEN rloc(0) = rl2 thloc(0) = th2 scloc(0) = sc2 C WARNING: this changes i2m1 CALL fulprf(i2m1,thloc,rloc,scloc,dummy,i2,one,elam2,pp2, & qp2,wp2,xmesh2,1,n2,2) rl2 = rloc(1) th2 = thloc(1) sc2 = scloc(1) i2m1 = i2 i2 = i2 + idi GO TO 140 END IF C Integrate RL2, TH2 and SC2 from XMESH2(I2M1) to XSTART. ii2 = max(i2,i2m1) CALL fulstp(xmesh2(i2m1),xstart,di,sc2,th2,rl2,pp2(ii2), & elam2*wp2(ii2)-qp2(ii2),wp2(ii2),dummy,1) END IF frstme = .true. value = zero h = min(xmesh1(i1)-xstart,xmesh2(i2)-xstart) C We have now located a suitable starting point and initial conditions. C Integrate forward by a suitable step. C Select correct coefficient function values: 150 ipp = max(i1,i1m1) p1 = pp1(ipp) q1 = qp1(ipp) w1 = wp1(ipp) ipp = max(i2,i2m1) p2 = pp2(ipp) q2 = qp2(ipp) w2 = wp2(ipp) IF ((xmesh1(i1)-xmesh2(i2))*di.LT.zero) THEN xstop = xmesh1(i1) i1m1 = i1 i1 = i1 + idi ELSE xstop = xmesh2(i2) IF (xmesh1(i1).EQ.xmesh2(i2)) THEN i1m1 = i1 i1 = i1 + idi END IF i2m1 = i2 i2 = i2 + idi END IF hmax = min(abs(xmesh1(i1)-xmesh1(i1m1)), & abs(xmesh2(i2)-xmesh2(i2m1))) C Now perform integration from xtart to xstop: xo = xstart xfin = xstop IF (abs(xfin-xo).LT.x02ajf(one)) THEN C This interval is trivial. Do the next one. xstart = xstop GO TO 150 END IF xend = xstart + di*min(abs(xstop-xstart),abs(h),hmax) 160 rln1 = rl1 thn1 = th1 scn1 = sc1 rln2 = rl2 thn2 = th2 scn2 = sc2 xmid = half* (xo+xend) x1 = xo x2 = xmid CALL inrprd(x1,x2,p1,q1,w1,rl1,th1,sc1,elam1,p2,q2,w2,rl2,th2,sc2, & elam2,one,ans2) ans1 = ans2 ans2 = ans2*fun(half* (xo+xmid)) x2 = xmid x3 = xend CALL inrprd(x2,x3,p1,q1,w1,rl1,th1,sc1,elam1,p2,q2,w2,rl2,th2,sc2, & elam2,one,ans3) ans1 = (ans1+ans3)*fun(half* (xo+xend)) ans4 = ans2 + ans3*fun(half* (xmid+xend)) C Estimate the error err = (ans4-ans1)/three errest = errest + err abserr = abs(err) IF (abserr.GT.toloc) THEN ratio = min(half, (toloc/abserr)**trd) C It is conceivable that a failed step may occur when we are stepping exactly C to the end xfin, in which case (xend-xo) neq h. In such a case we must C set h = ratio*(xend-xo) for the repeat step, rather than h = ratio*h. C In other cases xend-xo=h and there is nothing to worry about. xend = xo + ratio* (xend-xo) xend = di*min(di* (xend),di*xfin) icount = icount + 1 C At most three attempts to get the stepsize right: IF (icount.LT.4) THEN rl1 = rln1 th1 = thn1 sc1 = scn1 rl2 = rln2 th2 = thn2 sc2 = scn2 GO TO 160 END IF ifail = 1 GO TO 200 ELSE value = value + (ans4+err) IF (xend*di.GE. (xfin-di*x02ajf(1.D0))*di) GO TO 170 IF (abserr.LT.toloc*tosafe .AND. icount.EQ.0) THEN C The error is very small and the step before last was not a failure so C we may increase the stepsize. ratio = one/max(bound, (abserr/toloc)**qtr) h = di*min(ratio*abs(h),hmax) END IF C We have completed the last step successfully, and provided the step before C was not a failure we may have increased the step length. icount = 0 xo = xend xend = xo + h C Step exactly to the end of the interval if xend >= xfin - x02ajf. In C this eventuality we do not set h = xend-xo since this might result in C excessively small stepsizes for some time thereafter. IF (xend*di.GE. (xfin-di*x02ajf(1.D0))*di) THEN xend = xfin END IF GO TO 160 END IF C Have successfully completed the integration from xo to xfin. 170 nstep = nstep + 1 icount = 0 C Integration from xstart to xstop has now been performed. What next? IF ((itest.EQ.1.AND.idi* (i1-isplit).LE.0) .OR. & (itest.EQ.2.AND.idi* (i2-isplit).LE.0)) THEN C Still another step to do (n.b. itest always has one of the values 1,2) xstart = xstop GO TO 150 END IF IF (frstme) THEN C We have only done one half of the integration. Let us do the other. rl1 = rlog1(1) th1 = theta1(1) sc1 = scale1(1) rl2 = rlog2(1) th2 = theta2(1) sc2 = scale2(1) idi = -1 di = -one i1 = n1 - 1 i2 = n2 - 1 i1m1 = i1 - idi i2m1 = i2 - idi xstart = min(xmesh1(n1),xmesh2(n2)) IF (xmesh1(n1).EQ.xmesh2(n2)) THEN xstart = xmesh1(n1) iupdat = 0 ELSE IF (xmesh1(n1).GT.xmesh2(n2)) THEN xstart = xmesh2(n2) iupdat = 1 ELSE xstart = xmesh1(n1) iupdat = 2 END IF IF (iupdat.EQ.1) THEN 180 IF ((xmesh1(i1)-xstart)*di.LT.zero) THEN rloc(0) = rl1 thloc(0) = th1 scloc(0) = sc1 C WARNING: this changes i1m1 CALL fulprf(i1m1,thloc,rloc,scloc,dummy,i1,one,elam1, & pp1,qp1,wp1,xmesh1,1,n1,2) rl1 = rloc(1) th1 = thloc(1) sc1 = scloc(1) i1m1 = i1 i1 = i1 + idi GO TO 180 END IF C Integrate RL1, TH1 and SC1 from XMESH1(I1M1) to XSTART. ii1 = max(i1,i1m1) CALL fulstp(xmesh1(i1m1),xstart,di,sc1,th1,rl1,pp1(ii1), & elam1*wp1(ii1)-qp1(ii1),wp1(ii1),dummy,1) ELSE IF (iupdat.EQ.2) THEN 190 IF ((xmesh2(i2)-xstart)*di.LT.zero) THEN rloc(0) = rl2 thloc(0) = th2 scloc(0) = sc2 C WARNING: this changes i2m1 CALL fulprf(i2m1,thloc,rloc,scloc,dummy,i2,one,elam2, & pp2,qp2,wp2,xmesh2,1,n2,2) rl2 = rloc(1) th2 = thloc(1) sc2 = scloc(1) i2m1 = i2 i2 = i2 + idi GO TO 190 END IF C Integrate RL2, TH2 and SC2 from XMESH2(I2M1) to XSTART. ii2 = max(i2,i2m1) CALL fulstp(xmesh2(i2m1),xstart,di,sc2,th2,rl2,pp2(ii2), & elam2*wp2(ii2)-qp2(ii2),wp2(ii2),dummy,1) END IF frstme = .false. h = max(xmesh1(i1),xmesh2(i2)) - xstart GO TO 150 END IF C We have now completed the integration. ans = value 200 RETURN END SUBROUTINE nfcf C -------------------------------------------------------------------- SUBROUTINE sl06fm(elam,eigfns,wk,iwk,n,k,m,i1,i2,fun,tol,elem, & ifail) C This routine computes the so-called matrix elements which are of interest C in problems arising in quantum mechanics. It acts as an interface for the C routine matel. C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER i1,i2,ifail,iwk,m,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3,1:m),elam(1:2,1:m),elem(0:1), & wk(0:iwk,1:4) INTEGER k(1:m) C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Local Scalars .. DOUBLE PRECISION elam1,elam2 INTEGER i,ic,iflag,j1,j2,nrec LOGICAL check1,check2 CHARACTER srname*6 C .. C .. External Subroutines .. cc EXTERNAL nmatel C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Intrinsic Functions .. INTRINSIC abs,nint C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. srname = 'SL06FM' IF (abs(ifail).GT.1 .OR. tol.LE.0.D0) THEN IF (abs(ifail).GT.1) ifail = -1 iflag = 1 WRITE (rec,FMT=9000) 9000 FORMAT ('** Parameter error: IFAIL or TOL out of range') nrec = 1 GO TO 30 END IF ic = nint(wk(0,2)) C Check that the requested eigenfunctions are available: check1 = .false. check2 = .false. DO 10 i = 1,m IF (k(i).EQ.i1) THEN j1 = i check1 = .true. END IF IF (k(i).EQ.i2) THEN j2 = i check2 = .true. END IF IF (check1 .AND. check2) GO TO 20 10 CONTINUE iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Necessary eigenfunctions not all available') nrec = 1 GO TO 30 C End of check for eigenfunction availability 20 elam1 = elam(1,j1) + elam(2,j1) elam2 = elam(1,j2) + elam(2,j2) iflag = 0 CALL nmatel(elam1,elam2,eigfns(0,1,j1),eigfns(0,1,j2), & eigfns(0,2,j1),eigfns(0,2,j2),eigfns(0,3,j1), & eigfns(0,3,j2),wk(1,2),wk(1,3),wk(1,4),wk(0,1),n,ic, & tol,fun,elem,iflag) IF (iflag.NE.0) THEN iflag = 3 WRITE (rec,FMT=9020) 9020 FORMAT ('** Autmatic step-size control has failed',/, & '** Try using a larger value of TOL') nrec = 2 GO TO 30 END IF ifail = 0 RETURN 30 ifail = p01abf(ifail,iflag,srname,nrec,rec) RETURN END SUBROUTINE sl06fm C -------------------------------------------------------------------------- SUBROUTINE nmatel(elam1,elam2,rlog1,rlog2,theta1,theta2,scale1, & scale2,pp,qp,wp,xmesh,n,ic,tol,fun,ans,ifail) C This routine computes the value of the matrix element C C Integral(a,b)w(x)Y(1)(x)fun(x)Y(2)(x)dx C C .. Parameters .. DOUBLE PRECISION one,two,three,half,trd,qtr,safe,tosafe,bound,zero PARAMETER (one=1.D0,two=2.D0,three=3.D0,half=one/two, & trd=one/three,qtr=half*half,safe=0.95D0,tosafe=0.8D0, & bound=2.D-1,zero=0.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam1,elam2,tol INTEGER ic,ifail,n C .. C .. Array Arguments .. DOUBLE PRECISION ans(0:1),pp(1:n),qp(1:n),rlog1(0:1),rlog2(0:1), & scale1(0:1),scale2(0:1),theta1(0:1),theta2(0:1), & wp(1:n),xmesh(0:n) C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Local Scalars .. DOUBLE PRECISION abserr,ans1,ans2,ans3,ans4,di,epsilo,err,errest, & h,hmax,p,q,ratio,rl1,rl2,rln1,rln2,sc1,sc2,scn1, & scn2,th1,th2,thn1,thn2,toloc,value,w,xend,xfin, & xmid,xo INTEGER i,icount,idi,ifin,ii,init,ip1,itime,nstep C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf cc EXTERNAL x02ajf C .. C .. External Subroutines .. cc EXTERNAL inrprd C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min C .. toloc = safe*tol value = zero errest = zero nstep = 0 itime = 1 init = 0 ifin = ic - 1 idi = 1 di = one icount = 0 h = xmesh(1) - xmesh(0) rl1 = rlog1(0) th1 = theta1(0) sc1 = scale1(0) rl2 = rlog2(0) th2 = theta2(0) sc2 = scale2(0) 10 DO 40 i = init,ifin,idi xo = xmesh(i) ip1 = i + idi hmax = xmesh(ip1) - xmesh(i) h = di*min(abs(h),abs(hmax)) xfin = xmesh(ip1) C write(9,*) xo,xfin xend = xo + h ii = i IF (idi.GT.0) ii = ip1 p = pp(ii) q = qp(ii) w = wp(ii) 20 rln1 = rl1 thn1 = th1 scn1 = sc1 rln2 = rl2 thn2 = th2 scn2 = sc2 xmid = half* (xo+xend) CALL inrprd(xo,xmid,p,q,w,rl1,th1,sc1,elam1,p,q,w,rl2,th2,sc2, & elam2,one,ans2) ans1 = ans2 ans2 = ans2*fun(half* (xo+xmid)) CALL inrprd(xmid,xend,p,q,w,rl1,th1,sc1,elam1,p,q,w,rl2,th2, & sc2,elam2,one,ans3) ans1 = (ans1+ans3)*fun(half* (xo+xend)) ans4 = ans2 + ans3*fun(half* (xmid+xend)) C Estimate the error err = (ans4-ans1)/three errest = errest + err abserr = abs(err) IF (abserr.GT.toloc) THEN ratio = min(half, (toloc/abserr)**trd) C It is conceivable that a failed step may occur when we are stepping exactly C to the end xfin, in which case (xend-xo) neq h. In such a case we must C set h = ratio*(xend-xo) for the repeat step, rather than h = ratio*h. C In other cases xend-xo=h and there is nothing to worry about. h = ratio* (xend-xo) xend = xo + h icount = icount + 1 C At most three attempts to get the stepsize right: IF (icount.LT.4) THEN rl1 = rln1 th1 = thn1 sc1 = scn1 rl2 = rln2 th2 = thn2 sc2 = scn2 GO TO 20 END IF ifail = 1 GO TO 50 ELSE value = value + ans4 + err IF ((xend-xfin)*di.GE.0.0D0) GO TO 30 IF (abserr.LT.toloc*tosafe .AND. icount.EQ.0) THEN C The error is very small and the step before last was not a failure so C we may increase the stepsize. ratio = one/max(bound, (abserr/toloc)**qtr) h = ratio*h END IF C We have completed the last step successfully, and provided the step before C was not a failure we may have increased the step length. icount = 0 xo = xend xend = xo + h C Step exactly to the end of the interval if xend >= xfin - x02ajf. In C this eventuality we do not set h = xend-xo since this might result in C excessively small stepsizes for some time thereafter. IF (xend*di.GE. (xfin*di-x02ajf(epsilo))) THEN xend = xfin END IF GO TO 20 END IF C Have successfully completed the integration from xmesh(i) to xmesh(i+idi) 30 nstep = nstep + 1 icount = 0 40 CONTINUE C If itime = 1 then we have only done the shooting from xmesh(0) to C xmesh(ic), and we must therefore do the shooting from xmesh(n) to C xmesh(ic). IF (itime.EQ.1) THEN itime = 2 idi = -1 di = -one init = n ifin = ic + 1 h = xmesh(n) - xmesh(n-1) rl1 = rlog1(1) th1 = theta1(1) sc1 = scale1(1) rl2 = rlog2(1) th2 = theta2(1) sc2 = scale2(1) GO TO 10 END IF C Successful completion: ifail = 0 ans(0) = value ans(1) = errest C WRITE (6,FMT=*) 'MATEL error estimate:',errest RETURN C Unsuccessful completion: 50 ans(0) = zero ans(1) = errest RETURN END SUBROUTINE nmatel C -------------------------------------------------------------------------- SUBROUTINE inrprd(xo,xend,p1,q1,w1,rlog1,theta1,scale1,elam1,p2, & q2,w2,rlog2,theta2,scale2,elam2,f,ans) C This routine computes the inner product of two eigenfunctions over C an interval (xo,xend), advancing the Prufer radius, angle and scalefactor C for each eigenfunction as the integration proceeds. C C .. Parameters .. DOUBLE PRECISION half,qtr,two PARAMETER (half=5.D-1,qtr=half*half,two=2.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION ans,elam1,elam2,f,p1,p2,q1,q2,rlog1,rlog2,scale1, & scale2,theta1,theta2,w1,w2,xend,xo C .. C .. Local Scalars .. DOUBLE PRECISION alfa1h,alfa2h,cth1,cth2,dalfa,dalfa2,diff1,diff2, & dtheta,erl1,erl2,h,h2,pdy1nd,pdy1o,pdy2nd,pdy2o, & r01,r11,salfa,signum,snew,sqrnrm,sqrt1,sqrt2, & sth1,sth2,stheta,t1,t1o,t2,t2o,tdiff,y1end,y1o, & y2end,y2o C .. C .. External Functions .. cc DOUBLE PRECISION phi,rescal,scl,x02ajf cc EXTERNAL phi,rescal,scl,x02ajf C .. C .. External Subroutines .. cc EXTERNAL chidif,fulstp,phidif C .. C .. Intrinsic Functions .. INTRINSIC abs,cos,exp,sign,sin,sqrt C .. h = xend - xo h2 = h**2 signum = sign(1.D0,h) t1o = (elam1*w1-q1)/p1 t2o = (elam2*w2-q2)/p2 tdiff = t1o - t2o t1 = t1o*h2 t2 = t2o*h2 IF (abs(tdiff).GT.sqrt(x02ajf(1.D0))) THEN C In this case there is a very simple formula for the integral involving C only the values of the eigenfunctions and their derivatives at each end. C STEP ONE: Compute the values of each eigenfunction and its derivative C at xo and xend. C At xo: erl1 = exp(rlog1) erl2 = exp(rlog2) sth1 = sin(theta1) sth2 = sin(theta2) cth1 = cos(theta1) cth2 = cos(theta2) sqrt1 = sqrt(scale1) sqrt2 = sqrt(scale2) y1o = erl1*sth1/sqrt1 y2o = erl2*sth2/sqrt2 pdy1o = erl1*cth1*sqrt1 pdy2o = erl2*cth2*sqrt2 C At xend: first need to advance the eigenfunctions using the FULSTP routine. CALL fulstp(xo,xend,signum,scale1,theta1,rlog1,p1,elam1*w1-q1, & w1,sqrnrm,1) CALL fulstp(xo,xend,signum,scale2,theta2,rlog2,p2,elam2*w2-q2, & w2,sqrnrm,1) erl1 = exp(rlog1) erl2 = exp(rlog2) sth1 = sin(theta1) sth2 = sin(theta2) cth1 = cos(theta1) cth2 = cos(theta2) sqrt1 = sqrt(scale1) sqrt2 = sqrt(scale2) y1end = erl1*sth1/sqrt1 y2end = erl2*sth2/sqrt2 pdy1nd = erl1*cth1*sqrt1 pdy2nd = erl2*cth2*sqrt2 C We can now write down the required formula for the integral: ans = - ((pdy1nd*y2end-pdy1o*y2o)/p1- & (pdy2nd*y1end-pdy2o*y1o)/p2)*f*w1/tdiff ELSE C (if (ABS(tdiff).LT.0.0001) THEN C This is the case where t1 and t2 are close, and we must use the routines C designed earlier for this case. There are two cases to consider: the first C occurs when both t1 and t2 lie in (-infty,0.1), the second when one of C these quantities lies in (0.1,infty). C The case where t1 and t2 are both less than 0.1 is what the C routines phidif and chidif were designed to handle. IF (t1.LE.0.1D0 .AND. t2.LE.0.1D0) THEN CALL chidif(-t2,-t1,diff1) r11 = diff1*h CALL phidif(-t2,-t1,diff2) r01 = -diff2*h erl1 = exp(rlog1) erl2 = exp(rlog2) sth1 = sin(theta1) sth2 = sin(theta2) cth1 = cos(theta1) cth2 = cos(theta2) sqrt1 = sqrt(scale1) sqrt2 = sqrt(scale2) y1o = erl1*sth1/sqrt1 y2o = erl2*sth2/sqrt2 pdy1o = erl1*cth1*sqrt1 pdy2o = erl2*cth2*sqrt2 C At xend: first need to advance the eigenfunctions using the FULSTP routine. CALL fulstp(xo,xend,signum,scale1,theta1,rlog1,p1, & elam1*w1-q1,w1,sqrnrm,1) CALL fulstp(xo,xend,signum,scale2,theta2,rlog2,p2, & elam2*w2-q2,w2,sqrnrm,1) erl1 = exp(rlog1) erl2 = exp(rlog2) sth1 = sin(theta1) sth2 = sin(theta2) cth1 = cos(theta1) cth2 = cos(theta2) sqrt1 = sqrt(scale1) sqrt2 = sqrt(scale2) y1end = erl1*sth1/sqrt1 y2end = erl2*sth2/sqrt2 pdy1nd = erl1*cth1*sqrt1 pdy2nd = erl2*cth2*sqrt2 ans = ((y1o*y2o+y1end*y2end)*r11+ & (y1o*y2end+y1end*y2o)*r01)*w1*f ELSE C In this case we use a completely different formula, which requires the C updating of the scalefactor. Because in this case at least one of C t1, t2 is greater than 0.1 and the other is at most 0.0001*h**2 different, C it follows that both are positive. snew = sqrt((elam1*w1-q1)*p1) theta1 = scl(theta1,snew/scale1) rlog1 = rescal(scale1,snew,theta1,rlog1) scale1 = snew alfa1h = sqrt(t1) snew = sqrt((elam2*w2-q2)*p2) diff1 = sqrt(t2o) - sqrt(t1o) theta2 = scl(theta2,snew/scale2) rlog2 = rescal(scale2,snew,theta2,rlog2) scale2 = snew alfa2h = sqrt(t2) dtheta = theta1 - theta2 stheta = theta1 + theta2 dalfa = alfa1h - alfa2h dalfa2 = dalfa**2 salfa = alfa1h + alfa2h r11 = half*h* (cos(dtheta)*phi(-dalfa2)- & sin(dtheta)*half*diff1* (phi(-qtr*dalfa2)**2)- & cos(stheta)*sin(salfa)/salfa+ & signum*two*sin(stheta)* (sin(salfa*half)**2)/salfa) ans = w1*f*exp(rlog1+rlog2)*r11/sqrt(scale1*scale2) C Rlog1, rlog2, scale1 and scale2 do not need updating, but theta1 and theta2 C require updating: theta1 = theta1 + h*sqrt(t1o) theta2 = theta2 + h*sqrt(t2o) C C END of case where ABS(tdiff).LT.sqrt(x02ajf(1.d0)) END IF C END of all cases END IF C Compensate for the possible effect of backwards integration: ans = ans*sign(1.D0,xend-xo) RETURN END SUBROUTINE inrprd C ------------------------------------------------------------------------- SUBROUTINE phidrv(t,phi0,phi1,phi2,phi3,phi4,phi5) C .. Parameters .. DOUBLE PRECISION p15,p3,p6 PARAMETER (p15=15.D0,p3=3.D0,p6=6.D0) DOUBLE PRECISION half,qtr,eighth PARAMETER (half=5.D-1,qtr=half*half, C & sxtnth=qtr*qtr, & eighth=half*qtr) DOUBLE PRECISION fac3,fac4,fac5,fac6,fac7,fac8,fac9,fac10,fac11, & fac12,fac13,fac14,fac15,fac16,fac17,fac18,fac19 PARAMETER (fac3=1.D0/6.D0,fac4=fac3/4.D0,fac5=fac4/5.D0, & fac6=fac5/6.D0,fac7=fac6/7.D0,fac8=fac7/8.D0, & fac9=fac8/9.D0,fac10=fac9/1.D1,fac11=fac10/11.D0, & fac12=fac11/12.D0,fac13=fac12/13.D0,fac14=fac13/14.D0, & fac15=fac14/15.D0,fac16=fac15/16.D0,fac17=fac16/17.D0, & fac18=fac17/18.D0,fac19=fac18/19.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION phi0,phi1,phi2,phi3,phi4,phi5,t C .. C .. Local Scalars .. DOUBLE PRECISION epos,psi0,sqrto,to,to2,to3 C .. C .. External Functions .. cc DOUBLE PRECISION phi,psi,x02amf cc EXTERNAL phi,psi,x02amf C .. C .. Intrinsic Functions .. INTRINSIC abs,cos,cosh,log,min,sin,sinh,sqrt C .. epos = (log(x02amf(half))**2)*half to = t IF (abs(t).GT.0.1D0) THEN IF (t.GT.0.1D0) THEN to = min(t,epos) sqrto = sqrt(to) phi0 = sinh(sqrto)/sqrto psi0 = cosh(sqrto) ELSE IF (t.LT. (-0.1D0)) THEN sqrto = sqrt(-to) phi0 = sin(sqrto)/sqrto psi0 = cos(sqrto) ELSE phi0 = phi(to) psi0 = psi(to) END IF to2 = to**2 to3 = to2*to C to4 = to3*to C to5 = to4*to phi1 = (psi0-phi0)*half/to phi2 = ((p3+to)*phi0-p3*psi0)*qtr/to2 phi3 = ((p15+t)*psi0- (p6*t+p15)*phi0)*eighth/to3 C phi4 = ((to2+p45*to+p105)*phi0- (p10*to+p105)*psi0)*sxtnth/to4 C phi5 = ((to2+p105*to+p945)*psi0- (p15*to2+p420*to+p945)*phi0) C & *trtsnd/to5 ELSE C IF (ABS(t).LE.0.1) THEN use Taylor expansions phi0 = phi(t) C Compute the higher derivatives phi1 = fac3 + t* (2.D0*fac5+t* & (3.D0*fac7+t* (4.D0*fac9+t* (5.D0*fac11+ & t*6.D0*fac13)))) phi2 = 2.D0*fac5 + t* (6.D0*fac7+ & t* (12.D0*fac9+t* (20.D0*fac11+t* (30.D0*fac13+ & t*42.D0*fac15)))) phi3 = 6.D0*fac7 + t* (24.D0*fac9+ & t* (60.D0*fac11+t* (120.D0*fac13+t* (210.D0*fac15+ & t*336.D0*fac17)))) C phi4 = 24.*fac9 + t* (120.*fac11+ C & t* (360.*fac13+t* (840.*fac15+t* (1680.*fac17+ C & t*3024.*fac19)))) C phi5 = 120.*fac11 + t* (720.*fac13+ C & t* (2520.*fac15+t* (6720.*fac17+t* (15120.*fac19+ C & t*30240.*fac21)))) END IF RETURN END SUBROUTINE phidrv C ---------------------------------------------------------------------------- SUBROUTINE chidrv(t,chi0,chi1,chi2,chi3,chi4,chi5) C .. Parameters .. DOUBLE PRECISION half PARAMETER (half=0.5D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION chi0,chi1,chi2,chi3,chi4,chi5,t C .. C .. Local Scalars .. DOUBLE PRECISION phi0,phi1,phi2,phi3,phi4,phi5,psi0,psi1,psi2, & psi3,rat0,rat1,rat2,rat3,rat4,rat5,rat6,sqrtt,to C .. C .. External Functions .. cc DOUBLE PRECISION chi,psi,x02amf cc EXTERNAL chi,psi,x02amf C .. C .. External Subroutines .. cc EXTERNAL phidrv C .. C .. Intrinsic Functions .. INTRINSIC abs,cos,cosh,log,min,sqrt,tan,tanh C .. CALL phidrv(t,phi0,phi1,phi2,phi3,phi4,phi5) sqrtt = sqrt(abs(t)) to = min(t, (log(x02amf(half))**2)*half) IF (t.GT.0.1D0) THEN chi0 = sqrtt/tanh(sqrtt) psi0 = cosh(sqrt(to)) ELSE IF (t.LT. (-0.1D0)) THEN chi0 = sqrtt/tan(sqrtt) psi0 = cos(sqrtt) ELSE chi0 = chi(t) psi0 = psi(t) END IF psi1 = half*phi0 psi2 = half*phi1 psi3 = half*phi2 C psi4 = half*phi3 C psi5 = half*phi4 C We now simply type in the expressions which were obtained by MAPLE when C working out the derivative. We must be careful to do this in such a way C that overflow is avoided. This is achieved by defining the following ratios: rat0 = psi1/phi0 rat1 = psi0/phi0 rat2 = phi1/phi0 rat3 = psi2/phi0 rat4 = phi2/phi0 rat5 = psi3/phi0 rat6 = phi3/phi0 C rat7 = psi4/phi0 C rat8 = phi4/phi0 C rat9 = psi5/phi0 C rat10 = phi5/phi0 chi1 = rat0 - rat1*rat2 chi2 = rat3 - rat1*rat4 - 2.D0* (rat0-rat1*rat2)*rat2 chi3 = rat5 - 3.D0*rat3*rat2 + 6.D0*rat0* (rat2**2) - & 3.D0*rat0*rat4 - 6.D0*rat1* (rat2**3) + & 6.D0*rat1*rat2*rat4 - rat1*rat6 C chi4 = rat7 - 4.d0*rat6*rat2 + 12.d0*rat3* (rat2**2) - C & 6.d0*rat3*rat4 - 24.d0*rat0* (rat2**3) + C & 24.d0*rat0*rat2*rat4 - 4.d0*rat0*rat6 + C & 24.d0*rat1* (rat2**4) - 36.d0*rat1* (rat2**2)*rat4 + C & 6.d0*rat1* (rat4**2) + 8.d0*rat1*rat2*rat6 - rat1*rat8 C chi5 = rat9 - 5.d0*rat8*rat2 + 20.d0* (rat2**2)*rat6 - C & 60.d0* (rat2**3)*rat3 - 10.d0*rat3*rat6 - 5.d0*rat0*rat8 - C & rat1*rat10 + 60.d0*rat3*rat0*rat4 + C & 120.d0*rat0* (rat2**4) - 18.d1*rat0* (rat2**2)*rat4 + C & 30.d0*rat0* (rat4**2) + 40.d0*rat0*rat2*rat6 - C & 12.d1*rat1* (rat2**5) + 24.d1*rat1* (rat2**3)*rat4 - C & 90.d0*rat1*rat2* (rat4**2) - 60.d0*rat1* (rat2**2)*rat6 + C & 20.d0*rat1*rat4*rat6 + 10.d0*rat1*rat2*rat8 RETURN END SUBROUTINE chidrv C -------------------------------------------------------------------------- SUBROUTINE chidif(t1,t2,diff) C This routine computes the ratio C C chi(t2)-chi(t1) C --------------- C t2 - t1 C C .. Scalar Arguments .. DOUBLE PRECISION diff,t1,t2 C .. C .. Local Scalars .. DOUBLE PRECISION chi0,chi01,chi02,chi1,chi2,chi3,chi4,chi5,sqrt1, & sqrt2,tdiff,tmid C .. C .. External Functions .. cc DOUBLE PRECISION chi cc EXTERNAL chi C .. C .. External Subroutines .. cc EXTERNAL chidrv C .. C .. Intrinsic Functions .. INTRINSIC abs,sqrt,tan,tanh C .. sqrt1 = sqrt(abs(t1)) sqrt2 = sqrt(abs(t2)) IF (t1.GT.0.1D0) THEN chi01 = sqrt1/tanh(sqrt1) ELSE IF (t1.LT. (-0.1D0)) THEN chi01 = sqrt1/tan(sqrt1) ELSE chi01 = chi(t1) END IF IF (t2.GT.0.1D0) THEN chi02 = sqrt1/tanh(sqrt2) ELSE IF (t2.LT. (-0.1D0)) THEN chi02 = sqrt2/tan(sqrt2) ELSE chi02 = chi(t2) END IF IF (abs(t1-t2).GT.0.01D0) THEN diff = (chi01-chi02)/ (t1-t2) ELSE C Expand in a Taylor series about (t1+t2)/2 tmid = 0.5D0* (t1+t2) CALL chidrv(tmid,chi0,chi1,chi2,chi3,chi4,chi5) tdiff = t2 - t1 diff = chi1 + chi3* (tdiff**2)/24.D0 C & + chi5* (tdiff**4)/ (1920.d0) END IF RETURN END SUBROUTINE chidif C --------------------------------------------------------------------- SUBROUTINE phidif(t1,t2,diff) C .. Scalar Arguments .. DOUBLE PRECISION diff,t1,t2 C .. C .. Local Scalars .. DOUBLE PRECISION drv1,drv3,phi0,phi01,phi02,phi1,phi2,phi3,phi4, & phi5,rat1,rat2,sqrto,tdiff,tmid,to1,to2 C .. C .. External Functions .. cc DOUBLE PRECISION phi,x02amf cc EXTERNAL phi,x02amf C .. C .. External Subroutines .. cc EXTERNAL phidrv C .. C .. Intrinsic Functions .. INTRINSIC abs,log,min,sin,sinh,sqrt C .. to1 = min(t1, (log(x02amf(t1))**2)*5.D-1) to2 = min(t2, (log(x02amf(t2))**2)*5.D-1) IF (abs(t1-t2).GT.0.01D0) THEN IF (t1.GT.0.1D0) THEN sqrto = sqrt(to1) phi01 = sinh(sqrto)/sqrto ELSE IF (t1.LT. (-0.1D0)) THEN sqrto = sqrt(-to1) phi01 = sin(sqrto)/sqrto ELSE phi01 = phi(to1) END IF IF (t2.GT.0.1D0) THEN sqrto = sqrt(to2) phi02 = sinh(sqrto)/sqrto ELSE IF (t2.LT. (-0.1D0)) THEN sqrto = sqrt(-to2) phi02 = sin(sqrto)/sqrto ELSE phi02 = phi(to2) END IF diff = (1.D0/phi01-1.D0/phi02)/ (t1-t2) ELSE C ABS(t1-t2) is very small tmid = 0.5D0* (t1+t2) CALL phidrv(tmid,phi0,phi1,phi2,phi3,phi4,phi5) tdiff = t2 - t1 rat1 = phi1/phi0 rat2 = phi2/phi0 C rat3 = phi3/phi0 C rat4 = phi4/phi0 C rat5 = phi5/phi0 drv1 = -rat1 drv3 = -6.D0* ((rat1**2)-rat2)*rat1 C drv5 = -12.d1* (rat1**5) + 24.d1* (rat1**3)*rat2 - C & 9.d1*rat1* (rat2**2) - 6.d1* (rat1**2)*rat3 + C & 2.d1*rat2*rat3 + 1.d1*rat1*rat4 - rat5 diff = (drv1+ (tdiff**2)*drv3/24.D0)/phi0 C & + (tdiff**4)*drv5/192.d1)/phi0 END IF RETURN END SUBROUTINE phidif C --------------------------------------------------------------------- C --------------------- Source from USEFUN ---------------------------- C --------------------------------------------------------------------- C -------------------- Useful Functions ----------------------------- DOUBLE PRECISION FUNCTION spexp(x) C .. Scalar Arguments .. DOUBLE PRECISION x C .. C .. Local Scalars .. DOUBLE PRECISION eneg LOGICAL first C .. C .. External Functions .. cc DOUBLE PRECISION x02amf cc EXTERNAL x02amf C .. C .. Intrinsic Functions .. INTRINSIC exp,log C .. C .. Save statement .. SAVE first,eneg C .. C .. Data statements .. DATA first/.true./ C .. IF (first) THEN eneg = log(x02amf(x)) first = .false. END IF spexp = x02amf(x) IF (x.GT.eneg) spexp = exp(x) END FUNCTION spexp C ------------------------------------------------------------------- DOUBLE PRECISION FUNCTION sptanh(x) C .. Scalar Arguments .. DOUBLE PRECISION x C .. C .. Local Scalars .. DOUBLE PRECISION loc C .. C .. External Functions .. cc DOUBLE PRECISION spexp cc EXTERNAL spexp C .. C .. Intrinsic Functions .. INTRINSIC abs,sign C .. loc = spexp(-2.0D0*abs(x)) sptanh = sign(1.0D0,x)* (1.0D0-loc)/ (1.0D0+loc) END FUNCTION sptanh C ---------------- Other Useful Functions -------------------------- DOUBLE PRECISION FUNCTION phi(v) C .. Parameters .. DOUBLE PRECISION a0,a1,a2,a3,a4,a5 PARAMETER (a0=1.D0,a1=a0/6.D0,a2=a1/20.D0,a3=a2/42.D0,a4=a3/72.D0, & a5=a4/110.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION v C .. phi = a0 + v* (a1+v* (a2+v* (a3+v* (a4+v*a5)))) END FUNCTION phi DOUBLE PRECISION FUNCTION psi(v) C .. Parameters .. DOUBLE PRECISION b0,b1,b2,b3,b4,b5 PARAMETER (b0=1.D0,b1=b0/2.D0,b2=b1/12.D0,b3=b2/30.D0,b4=b3/56.D0, & b5=b4/90.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION v C .. psi = b0 + v* (b1+v* (b2+v* (b3+v* (b4+v*b5)))) END FUNCTION psi DOUBLE PRECISION FUNCTION chi(v) C .. Scalar Arguments .. DOUBLE PRECISION v C .. C .. External Functions .. cc DOUBLE PRECISION phi,psi cc EXTERNAL phi,psi C .. chi = psi(v)/phi(v) END FUNCTION chi DOUBLE PRECISION FUNCTION scl(th,u) C .. Parameters .. DOUBLE PRECISION one PARAMETER (one=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION th,u C .. C .. Intrinsic Functions .. INTRINSIC atan2,cos,sin C .. scl = th + atan2((u-one)*sin(th)*cos(th),one+ (u-one)*sin(th)**2) END FUNCTION scl C --------------------------------------------------------------------- C --------------------- Source from USEFUN ---------------------------- C --------------------------------------------------------------------- SUBROUTINE c05azf(x,y,fx,tolx,ir,c,ind,ifail) C MARK 8 RE-ISSUE. NAG COPYRIGHT 1979. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 12A REVISED. IER-496 (AUG 1986). C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C .. Parameters .. CHARACTER*6 srname PARAMETER (srname='C05AZF') C .. C .. Scalar Arguments .. DOUBLE PRECISION fx,tolx,x,y INTEGER ifail,ind,ir C .. C .. Array Arguments .. DOUBLE PRECISION c(17) C .. C .. Local Scalars .. DOUBLE PRECISION ab,diff,diff1,diff2,rel,rmax,tol,tol1 INTEGER i LOGICAL t C .. C .. Local Arrays .. CHARACTER p01rec(1)*1 C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf,x02akf cc INTEGER p01abf cc EXTERNAL x02ajf,x02akf,p01abf C .. C .. Intrinsic Functions .. INTRINSIC abs,dble,int,max,sign,sqrt C .. i = 0 IF ((ind.LE.0.OR.ind.GT.4) .AND. ind.NE.-1) THEN C USER NOT CHECKED IND OR CHANGED IT i = 2 ind = 0 ELSE IF (tolx.GT.0.0D0 .AND. (ir.EQ.0.OR.ir.EQ.1.OR.ir.EQ.2)) THEN rel = 1.0D0 ab = 1.0D0 IF (ir.EQ.1) rel = 0.0D0 IF (ir.EQ.2) ab = 0.0D0 IF (ind.EQ.-1) THEN c(3) = x ELSE GO TO (10,30,40,20) ind 10 c(3) = x ind = 2 RETURN 20 IF (fx.EQ.0.0D0) THEN GO TO 80 ELSE c(4) = fx rmax = abs(fx) IF (c(13)*rmax.LE.c(15)) THEN c(16) = 0.0D0 ELSE IF (c(16).EQ.1.0D0) c(16) = -1.0D0 IF (c(16).EQ.0.0D0) c(16) = 1.0D0 END IF IF (c(2).GE.0.0D0) THEN t = c(4) .GE. 0.0D0 ELSE t = c(4) .LE. 0.0D0 END IF IF (t) THEN GO TO 50 ELSE i = int(c(17)+0.1D0) i = i + 1 IF (c(11).EQ.c(12)) i = 0 c(17) = dble(i) GO TO 60 END IF END IF END IF 30 IF (fx.NE.0.0D0) THEN c(4) = fx c(15) = abs(fx) c(16) = 0.0D0 x = y y = c(3) c(2) = c(4) c(5) = x IF (ind.EQ.-1) THEN fx = c(1) ind = 3 ELSE ind = 3 RETURN END IF ELSE GO TO 80 END IF 40 IF (fx.EQ.0.0D0) THEN GO TO 80 ELSE IF (sign(1.0D0,fx).NE.sign(1.0D0,c(2))) THEN c(6) = fx c(13) = sqrt(x02ajf(0.0D0)) c(15) = max(c(15),abs(fx)) c(14) = x02akf(0.0D0) c(16) = 0.0D0 ELSE ind = 0 i = 1 GO TO 90 END IF 50 c(1) = c(5) c(2) = c(6) c(17) = 0.0D0 60 IF (abs(c(2)).LT.abs(c(4))) THEN IF (c(1).NE.c(5)) THEN c(7) = c(5) c(8) = c(6) END IF c(5) = c(3) c(6) = c(4) x = c(1) c(3) = x c(4) = c(2) c(1) = c(5) c(2) = c(6) END IF tol = 0.5D0*tolx*max(ab,rel*abs(c(3))) tol1 = 2.0D0*x02ajf(0.0D0)*max(ab,rel*abs(c(3))) diff2 = 0.5D0* (c(1)-c(3)) c(12) = diff2 diff2 = diff2 + c(3) IF (c(12).NE.0.0D0) THEN IF (abs(c(12)).LE.tol) THEN IF (c(16).GE.0.0D0) THEN y = c(1) i = 0 ELSE i = 4 END IF ind = 0 GO TO 90 ELSE IF (abs(c(12)).GT.tol1) THEN IF (c(17).LT.2.5D0) THEN tol = tol*sign(1.0D0,c(12)) diff1 = (c(3)-c(5))*c(4) IF (c(17).LE.1.5D0) THEN diff = c(6) - c(4) ELSE IF (c(7).NE.c(3) .AND. c(7).NE.c(5)) THEN c(9) = (c(8)-c(4))/ (c(7)-c(3)) c(10) = (c(8)-c(6))/ (c(7)-c(5)) diff1 = c(10)*diff1 diff = c(9)*c(6) - c(10)*c(4) ELSE GO TO 70 END IF IF (diff1.LT.0.0D0) THEN diff1 = -diff1 diff = -diff END IF IF (abs(diff1).LE.c(14) .OR. & diff1.LE.diff*tol) THEN c(11) = tol ELSE IF (diff1.GE.c(12)*diff) THEN c(11) = c(12) ELSE c(11) = diff1/diff END IF ELSE c(11) = c(12) END IF c(7) = c(5) c(8) = c(6) c(5) = c(3) c(6) = c(4) c(3) = c(3) + c(11) x = c(3) y = c(1) ind = 4 RETURN END IF END IF 70 ind = 0 i = 5 GO TO 90 80 y = x ind = 0 i = 0 ELSE i = 3 ind = 0 END IF 90 ifail = p01abf(ifail,i,srname,0,p01rec) END SUBROUTINE c05azf C -------------------------------------------------------------------- SUBROUTINE m01caf(rv,m1,m2,order,ifail) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C M01CAF SORTS A VECTOR OF REAL NUMBERS INTO ASCENDING C OR DESCENDING ORDER. C C M01CAF IS BASED ON SINGLETON'S IMPLEMENTATION OF THE C 'MEDIAN-OF-THREE' QUICKSORT ALGORITHM, BUT WITH TWO C ADDITIONAL MODIFICATIONS. FIRST, SMALL SUBFILES ARE C SORTED BY AN INSERTION SORT ON A SEPARATE FINAL PASS. C SECOND, IF A SUBFILE IS PARTITIONED INTO TWO VERY C UNBALANCED SUBFILES, THE LARGER OF THEM IS FLAGGED FOR C SPECIAL TREATMENT: BEFORE IT IS PARTITIONED, ITS END- C POINTS ARE SWAPPED WITH TWO RANDOM POINTS WITHIN IT; C THIS MAKES THE WORST CASE BEHAVIOUR EXTREMELY UNLIKELY. C C THE MAXIMUM LENGTH OF A SMALL SUBFILE IS DEFINED BY THE C VARIABLE MINQIK, SET TO 15. C C THE ROUTINE ASSUMES THAT THE NUMBER OF ELEMENTS TO BE C SORTED DOES NOT EXCEED MINQIK*2**MAXSTK. C C WRITTEN BY N.M.MACLAREN, UNIVERSITY OF CAMBRIDGE. C REVISED BY NAG CENTRAL OFFICE. C C .. Parameters .. INTEGER maxstk PARAMETER (maxstk=40) CHARACTER*6 srname PARAMETER (srname='M01CAF') INTEGER minqik PARAMETER (minqik=15) C .. C .. Scalar Arguments .. INTEGER ifail,m1,m2 CHARACTER order*1 C .. C .. Array Arguments .. DOUBLE PRECISION rv(m2) C .. C .. Local Scalars .. DOUBLE PRECISION a,rand,x INTEGER i,i1,i2,ierr,ir1,ir2,ir3,istk,j,j1,j2,k,leng,nrec C .. C .. Local Arrays .. INTEGER ihigh(maxstk),ilow(maxstk) CHARACTER p01rec(2)*80 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Intrinsic Functions .. INTRINSIC dble,mod C .. C .. Save statement .. SAVE ir1,ir2,ir3 C .. C .. Data statements .. DATA ir1,ir2,ir3/15223,17795,28707/ C .. C C CHECK THE PARAMETERS AND DECIDE IF QUICKSORT IS NEEDED. C IF (m2.LT.1 .OR. m1.LT.1 .OR. m1.GT.m2) THEN ierr = 1 WRITE (p01rec,FMT=9000) m1,m2 nrec = 2 ELSE IF (order.NE.'A' .AND. order.NE.'a' .AND. order.NE.'D' .AND. & order.NE.'d') THEN ierr = 2 WRITE (p01rec,FMT=9010) order nrec = 1 ELSE IF (m1.EQ.m2) THEN ierr = 0 ELSE ierr = 0 leng = m2 - m1 + 1 IF (leng.GT.minqik) THEN C C INITIALISE AND START QUICKSORT ON THE WHOLE VECTOR. C istk = 0 i = m1 j = m2 10 CONTINUE C C IF THE PREVIOUS PASS WAS BAD, CHANGE THE END VALUES AT C RANDOM. C IF (i.LT.0) THEN i = -i ir1 = 171*mod(ir1,177) - 2* (ir1/177) ir2 = 172*mod(ir2,176) - 35* (ir2/176) ir3 = 170*mod(ir3,178) - 63* (ir3/178) IF (ir1.LT.0) ir1 = ir1 + 30269 IF (ir2.LT.0) ir2 = ir2 + 30307 IF (ir3.LT.0) ir3 = ir3 + 30323 rand = mod(dble(ir1)/30269.0D0+dble(ir2)/30307.0D0+ & dble(ir3)/30323.0D0,1.0D0) k = i + rand* (j-i) x = rv(i) rv(i) = rv(k) rv(k) = x k = i + j - k x = rv(k) rv(k) = rv(j) rv(j) = x END IF C C CALCULATE A MEDIAN BY SINGLETONS METHOD. C k = (i+j)/2 IF (rv(i).GT.rv(j)) THEN x = rv(i) rv(i) = rv(j) rv(j) = x END IF a = rv(k) IF (a.LT.rv(i)) THEN rv(k) = rv(i) rv(i) = a a = rv(k) ELSE IF (a.GT.rv(j)) THEN rv(k) = rv(j) rv(j) = a a = rv(k) END IF C C SPLIT THE VECTOR INTO TWO ASCENDING PARTS. THIS IS WHERE C THE TIME IS SPENT. C i1 = i j1 = j 20 CONTINUE i1 = i1 + 1 IF (rv(i1).LT.a) THEN GO TO 20 ELSE 30 CONTINUE j1 = j1 - 1 IF (rv(j1).GT.a) GO TO 30 IF (i1.LT.j1) THEN x = rv(i1) rv(i1) = rv(j1) rv(j1) = x GO TO 20 END IF END IF C C STACK ONE SUBFILE, IF APPROPRIATE, AND CARRY ON. C i2 = i1 - i j2 = j - j1 IF (j2.LE.i2) THEN IF (i2.GT.minqik) THEN C C TEST FOR VERY UNBALANCED SUBFILES C ( THE DETAILS OF THE TEST ARE FAIRLY ARBITRARY.) C IF (5* (j2+5).LT.i2) i = -i IF (j2.LE.minqik) THEN j = i1 - 1 ELSE istk = istk + 1 ilow(istk) = i ihigh(istk) = i1 - 1 i = j1 + 1 END IF GO TO 10 ELSE IF (istk.GT.0) THEN i = ilow(istk) j = ihigh(istk) istk = istk - 1 GO TO 10 END IF C C DEAL WITH THE CASE WHEN THE SECOND PART IS LARGER. C ELSE IF (j2.GT.minqik) THEN C C TEST FOR VERY UNBALANCED SUBFILES C ( THE DETAILS OF THE TEST ARE FAIRLY ARBITRARY.) C IF (5* (i2+5).LT.j2) j1 = - (j1+2) IF (i2.LE.minqik) THEN i = j1 + 1 ELSE istk = istk + 1 ilow(istk) = j1 + 1 ihigh(istk) = j j = i1 - 1 END IF GO TO 10 ELSE IF (istk.GT.0) THEN i = ilow(istk) j = ihigh(istk) istk = istk - 1 GO TO 10 END IF END IF C C TIDY UP AND DO AN ASCENDING INSERTION SORT. C DO 50 i = m1 + 1,m2 a = rv(i) j = i - 1 IF (a.LT.rv(j)) THEN 40 CONTINUE rv(j+1) = rv(j) j = j - 1 IF (j.GE.m1) THEN IF (a.LT.rv(j)) GO TO 40 END IF rv(j+1) = a END IF 50 CONTINUE C C REVERSE THE ORDER IF NECESSARY AND RETURN. C IF ((order.EQ.'D') .OR. (order.EQ.'d')) THEN DO 60 i = m1, (m1+m2-1)/2 i1 = m1 + m2 - i x = rv(i) rv(i) = rv(i1) rv(i1) = x 60 CONTINUE END IF C END IF IF (ierr.NE.0) THEN ifail = p01abf(ifail,ierr,srname,nrec,p01rec) ELSE ifail = 0 END IF C 9000 FORMAT (' ** On entry, one or more of the following parameter va', & 'lues is illegal',/,' M1 =',I16,' M2 =',I16) 9010 FORMAT (' ** On entry, ORDER has an illegal value: ORDER = ',A1) END SUBROUTINE m01caf C -------------------------------------------------------------------- INTEGER FUNCTION p01abf(ifail,ierror,srname,nrec,rec) C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C MARK 13 REVISED. IER-621 (APR 1988). C MARK 13B REVISED. IER-668 (AUG 1988). C C P01ABF is the error-handling routine for the NAG Library. C C P01ABF either returns the value of IERROR through the routine C name (soft failure), or terminates execution of the program C (hard failure). Diagnostic messages may be output. C C If IERROR = 0 (successful exit from the calling routine), C the value 0 is returned through the routine name, and no C message is output C C If IERROR is non-zero (abnormal exit from the calling routine), C the action taken depends on the value of IFAIL. C C IFAIL = 1: soft failure, silent exit (i.e. no messages are C output) C IFAIL = -1: soft failure, noisy exit (i.e. messages are output) C IFAIL =-13: soft failure, noisy exit but standard messages from C P01ABF are suppressed C IFAIL = 0: hard failure, noisy exit C C For compatibility with certain routines included before Mark 12 C P01ABF also allows an alternative specification of IFAIL in which C it is regarded as a decimal integer with least significant digits C cba. Then C C a = 0: hard failure a = 1: soft failure C b = 0: silent exit b = 1: noisy exit C C except that hard failure now always implies a noisy exit. C C S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. C C .. Scalar Arguments .. INTEGER ierror,ifail,nrec CHARACTER srname* (*) C .. C .. Array Arguments .. CHARACTER rec(*)* (*) C .. C .. Local Scalars .. INTEGER i,nerr CHARACTER mess*72 C .. C .. External Subroutines .. cc EXTERNAL p01abz,x04aaf,x04baf C .. C .. Intrinsic Functions .. INTRINSIC abs,mod C .. IF (ierror.NE.0) THEN C Abnormal exit from calling routine IF (ifail.EQ.-1 .OR. ifail.EQ.0 .OR. ifail.EQ.-13 .OR. & (ifail.GT.0.AND.mod(ifail/10,10).NE.0)) THEN C Noisy exit CALL x04aaf(0,nerr) DO 10 i = 1,nrec CALL x04baf(nerr,rec(i)) 10 CONTINUE IF (ifail.NE.-13) THEN WRITE (mess,FMT=9000) srname,ierror CALL x04baf(nerr,mess) IF (abs(mod(ifail,10)).NE.1) THEN C Hard failure CALL x04baf(nerr, & ' ** NAG hard failure - execution terminated' & ) CALL p01abz ELSE C Soft failure CALL x04baf(nerr, & ' ** NAG soft failure - control returned' & ) END IF END IF END IF END IF p01abf = ierror C 9000 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', & ' =',I6) END FUNCTION p01abf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x01aaf(x) C MARK 8 RE-ISSUE. NAG COPYRIGHT 1980. C MARK 11.5(F77) REVISED. (SEPT 1985.) C C RETURNS THE VALUE OF THE MATHEMATICAL CONSTANT PI. C C X IS A DUMMY ARGUMENT C C IT MAY BE NECESSARY TO ROUND THE REAL CONSTANT IN THE C ASSIGNMENT STATEMENT TO A SMALLER NUMBER OF SIGNIFICANT C DIGITS IN ORDER TO AVOID COMPILATION PROBLEMS. IF SO, THEN C THE NUMBER OF DIGITS RETAINED SHOULD NOT BE LESS THAN C . 2 + INT(FLOAT(IT)*ALOG10(IB)) C WHERE IB IS THE BASE FOR THE REPRESENTATION OF FLOATING- C . POINT NUMBERS C . AND IT IS THE NUMBER OF IB-ARY DIGITS IN THE MANTISSA OF C . A FLOATING-POINT NUMBER. C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x01aaf = 3.14159265358979323846264338328D0 END FUNCTION x01aaf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02agf(x) C MARK 8 RELEASE. NAG COPYRIGHT 1980. C MARK 11.5(F77) REVISED. (SEPT 1985.) C C RETURNS THE SMALLEST POSITIVE FLOATING-POINT NUMBER R C EXACTLY REPRESENTABLE ON THE COMPUTER SUCH THAT -R, 1.0/R, C AND -1.0/R CAN ALL BE COMPUTED WITHOUT OVERFLOW OR UNDERFLOW. C ON MANY MACHINES THE CORRECT VALUE CAN BE DERIVED FROM THOSE C OF X02AAF, X02ABF AND X02ACF AS FOLLOWS C C IF (X02ABF(X)*X02ACF(X).GE.1.0) X02AGF = X02ABF(X) C IF (X02ABF(X)*X02ACF(X).LT.1.0) C * X02AGF = (1.0+X02AAF(X))/X02ACF(X) C C THE CORRECT VALUE SHOULD BE DEFINED AS A CONSTANT, C POSSIBLY IN SOME BINARY, OCTAL OR HEXADECIMAL REPRESENTATION, C AND INSERTED INTO THE ASSIGNMENT STATEMENT BELOW. C C X IS A DUMMY ARGUMENT C C .. Scalar Arguments .. DOUBLE PRECISION x C .. C .. External Functions .. cc DOUBLE PRECISION x02amf cc EXTERNAL x02amf C .. x02agf = x02amf(x) END FUNCTION x02agf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02ahf(x) C MARK 9 RELEASE. NAG COPYRIGHT 1981. C MARK 11.5(F77) REVISED. (SEPT 1985.) C C * MAXIMUM ARGUMENT FOR SIN AND COS * C RETURNS THE LARGEST POSITIVE REAL NUMBER MAXSC SUCH THAT C SIN(MAXSC) AND COS(MAXSC) CAN BE SUCCESSFULLY COMPUTED C BY THE COMPILER SUPPLIED SIN AND COS ROUTINES. C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02ahf = 2.147483648D9 END FUNCTION x02ahf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02ajf(x) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS (1/2)*B**(1-P) IF ROUNDS IS .TRUE. C RETURNS B**(1-P) OTHERWISE C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02ajf = 1.110223024625157D-16 END FUNCTION x02ajf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02akf(x) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS B**(EMIN-1) (THE SMALLEST POSITIVE MODEL NUMBER) C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02akf = 1d-300 c x02akf = 2.9387358770557188D-39 END FUNCTION x02akf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02alf(x) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS (1 - B**(-P)) * B**EMAX (THE LARGEST POSITIVE MODEL C NUMBER) C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02alf = 1d300 c x02alf = 1.7014118346046923D38 END FUNCTION x02alf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02amf(x) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS THE 'SAFE RANGE' PARAMETER C I.E. THE SMALLEST POSITIVE MODEL NUMBER Z SUCH THAT C FOR ANY X WHICH SATISFIES X.GE.Z AND X.LE.1/Z C THE FOLLOWING CAN BE COMPUTED WITHOUT OVERFLOW, UNDERFLOW OR OTHER C ERROR C C -X C 1.0/X C SQRT(X) C LOG(X) C EXP(LOG(X)) C Y**(LOG(X)/LOG(Y)) FOR ANY Y C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02amf = 1d-300 c x02amf = 5.8774717541114401D-39 END FUNCTION x02amf C -------------------------------------------------------------------- SUBROUTINE x04aaf(i,nerr) C MARK 7 RELEASE. NAG COPYRIGHT 1978 C MARK 7C REVISED IER-190 (MAY 1979) C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 14 REVISED. IER-829 (DEC 1989). C IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER C (STORED IN NERR1). C IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO C VALUE SPECIFIED BY NERR. C C .. Scalar Arguments .. INTEGER i,nerr C .. C .. Local Scalars .. INTEGER nerr1 C .. C .. Save statement .. SAVE nerr1 C .. C .. Data statements .. DATA nerr1/6/ C .. IF (i.EQ.0) nerr = nerr1 IF (i.EQ.1) nerr1 = nerr END SUBROUTINE x04aaf C -------------------------------------------------------------------- SUBROUTINE x04baf(nout,rec) C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C C X04BAF writes the contents of REC to the unit defined by NOUT. C C Trailing blanks are not output, except that if REC is entirely C blank, a single blank character is output. C If NOUT.lt.0, i.e. if NOUT is not a valid Fortran unit identifier, C then no output occurs. C C .. Scalar Arguments .. INTEGER nout CHARACTER rec* (*) C .. C .. Local Scalars .. INTEGER i C .. C .. Intrinsic Functions .. INTRINSIC len C .. IF (nout.GE.0) THEN C Remove trailing blanks DO 10 i = len(rec),2,-1 IF (rec(i:i).NE.' ') GO TO 20 10 CONTINUE C Write record to external file 20 WRITE (nout,FMT=9000) rec(1:i) END IF C 9000 FORMAT (A) END SUBROUTINE x04baf C -------------------------------------------------------------------- SUBROUTINE p01abz C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C C Terminates execution when a hard failure occurs. C C ******************** IMPLEMENTATION NOTE ******************** C The following STOP statement may be replaced by a call to an C implementation-dependent routine to display a message and/or C to abort the program. C ************************************************************* STOP END SUBROUTINE p01abz C MARK 11.5 end module MARCOMOD SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'probsets' then mkdir 'probsets' fi cd 'probsets' if test -f 'sample.f' then echo shar: will not over-write existing file "'sample.f'" else cat << SHAR_EOF > 'sample.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1997 **|****+****|****+****|** module TESTMOD use SLTSTVAR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** !Warning by JDP ! The ABINFO routine used by SLEIGN, SLEIGN2 may well be out of date ! since I kept trying new problems frequently ! GTHUHV is currently a dummy routine C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine TSTSET(ISWTCH) C .. Parameters .. C+------------------------------------------------------------------+ C| TSETNM is name given to Test Set by its implementer. | C| NPROBP is total no. of Problems. | C| There must be a Problem number I for every I from 1 to NPROBP. | C| *NOTE* When altering the Problem Set, re-set TSETNM & NPROBP !!! | C+------------------------------------------------------------------+ implicit none integer NPROBP character*8 TSETNM parameter(TSETNM='sample ', NPROBP=10) C These are used in various problems. Some are given a value by the C TSTSET(1) call, which is held for later use, so they need to be C SAVEd. Others are used as temporaries so don't need to be SAVEd: C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C .. Scalar Arguments .. integer ISWTCH C .. Local variables .. double precision TMP,NU,C1,C2 C .. Save statement .. save NU,C1,C2 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** cc print*,'Calling SAMPLE''s TSTSET with ISWTCH=',ISWTCH C Put ISWTCH.EQ.2 case first as this is the most frequently called: if (ISWTCH.eq.2) then C 'COEFFN' call: go to (12,22,32,42,52,62,72,82,92,102) IPROB else if (ISWTCH.eq.-1) then C 'TSTINI' call: C Copy title & total no. of Problems into COMMON variables: TITLE(1:8) = TSETNM NPROB = NPROBP return else if (ISWTCH.eq.0) then C 'SETUP0' call: C Start of new problem so set default values of IPARM, NEPRM: IPARM = 0 NEPRM = 0 go to (10,20,30,40,50,60,70,80,90,100) IPROB else if (ISWTCH.eq.1) then C 'SETUP1' call: go to (11,21,31,41,51,61,71,81,91,101) IPROB else if (ISWTCH.eq.3) then go to (13,23,33,43,53,63,73,83,93,103) IPROB else if (ISWTCH.eq.4) then go to (14,24,34,44,54,64,74,84,94,104) IPROB else C This signals a serious coding error in the Package so: print *,'Invalid ISWTCH',ISWTCH,' and/or IPROB',IPROB, + ' input to TSTSET call' stop end if C***+****|****+****| START OF PROBLEM SET |****+****|****+****|** C Problem #1 10 TITLE = 'Simple equation -u" = lambda u' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 11 A = 0D0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 12 P = 1D0 Q = 0D0 W = 1D0 go to 1002 13 U = A2 PDU = A1 go to 1003 14 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #2 20 TITLE = "transformed -u''=lambda u" NPARM = 1 NEPRM = 0 PARNM = 'NU, must be >0' go to 1000 21 NU = PARM(1) C1 = (NU*NU-1D0)/4D0 C2 = NU+NU-2D0 A = 0D0 B = PI**(1D0/NU) ATYPE = 'LCN' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 22 P = 1D0 Q = C1/(X*X) W = NU*NU*X**C2 go to 1002 23 U = A2 PDU = A1 go to 1003 24 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #3 30 TITLE = "Branko Curgus2: -y''=lambda x y on [-1,1]" NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 31 A = -1D0 B = 1D0 ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 1D0 A1 = 01D0 B2 = 1D0 B1 = 01D0 go to 1001 32 P = 1D0 Q = 0D0 W = X go to 1002 33 U = A2 PDU = A1 go to 1003 34 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #4 40 TITLE = "-u''=lambda u with a lambda-dependent BC" NPARM = 2 NEPRM = 0 PARNM = "A1', A2' where (A1+lam*A1')u(a)=(A2+lam*A2')pu'(a)" go to 1000 41 A = 0d0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0d0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 42 P = 1D0 Q = 0D0 W = 1D0 go to 1002 43 U = A2+EIG*PARM(2) PDU = A1+EIG*PARM(1) go to 1003 44 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #5 50 TITLE = "Branko Curgus4: -(sign(x)y')'=lambda sign(x) y on [-1,1]" NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 51 A = -1d0 B = 1d0 ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 52 P = sign(1D0,X) Q = 0D0 W = P go to 1002 53 U = A2 PDU = A1 go to 1003 54 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #6 60 TITLE = "Klaus 1: -(y'/2)'+(x^2/8(x<0),x^2/2(x>=0)y = lambda y" NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 61 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 62 P = 0.5D0 if (X.lt.0d0) then Q = 0.125d0*X*X else Q = 0.5d0*X*X end if W = 1D0 go to 1002 63 U = A2 PDU = A1 go to 1003 64 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #7 70 TITLE = 'Simple equation -u" = lambda u with u = A1*x+A2 near 0' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 71 A = 0D0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 72 P = 1D0 Q = 0D0 W = 1D0 go to 1002 73 U = A1*X+A2 PDU = A1 go to 1003 74 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #8 80 TITLE = 'Another transformed version of Hinz problem' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 81 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 1D0 A1 = 0D0 B2 = 1D0 B1 = 0D0 go to 1001 82 TMP = 1D0-X P = X*TMP Q = X/(TMP**3)*COS(X/TMP) W = X/(TMP**3) go to 1002 83 U = A2 PDU = A1 go to 1003 84 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #9 90 TITLE = +'Transformed Hinz prob, -(xu'')'' + x cos(x) u = lambda x u' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 91 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 92 P = X Q = X*COS(X) W = X go to 1002 93 U = A2 PDU = A1 go to 1003 94 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #10 100 TITLE = 'Hinz problem -u" + (cos(x) - 1/(4x^2))u = lambda u' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 101 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 102 P = 1D0 Q = COS(X) - 0.25D0/(X*X) W = 1D0 go to 1002 103 U = A2 PDU = A1 go to 1003 104 U = B2 PDU = B1 go to 1004 C***+****|****+****| END OF PROBLEM SET |****+****|****+****|** 1000 continue 1001 continue 1002 continue 1003 continue 1004 continue end subroutine TSTSET C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine ABINFO(P0ATA,QFATA,P0ATB,QFATB) C This is a special routine for SLEIGN, SLEIGN2 C******* THIS ROUTINE APPLIES TO A SPECIFIC TEST SET ONLY ************ C User beware. It may be out of date. implicit none integer NPROB parameter (NPROB=10) C .. Scalar Arguments .. double precision P0ATA,QFATA,P0ATB,QFATB C .. Local Arrays .. integer P0A(1:NPROB),QFA(1:NPROB),P0B(1:NPROB),QFB(1:NPROB) C 1 2 3 4 5 6 7 8 9 10 data P0A/0,0,0,0,0,0,0,0,0,0/ data QFA/1,0,1,1,1,1,1,1,1,0/ data P0B/0,0,0,0,0,0,0,0,0,1/ data QFB/1,1,1,1,1,1,1,1,1,1/ P0ATA = 2*P0A(IPROB) - 1 QFATA = 2*QFA(IPROB) - 1 P0ATB = 2*P0B(IPROB) - 1 QFATB = 2*QFB(IPROB) - 1 C Now special cases need to be handled! C In some problems this info may depend on values of parameters C ... end subroutine ABINFO C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine GTHUHV(IEND,XA,UA,VA,HU,HV) C This routine is used only by SOLVRS in its interface to SLEIGN2. C Its functionality should be incorporated into TSTSET eventually. C******* THIS ROUTINE APPLIES TO THE SAMPLE TEST SET ONLY ************ C When changing the test set, you must put code in here if you wish C the limit-circle facility of SLEIGN2 to work correctly! implicit none integer IEND double precision XA,UA,VA,HU,HV double precision AA,BB,ALPHA,NU,OM,OMSQ,TEMP C Returns the HU,HV info needed by SLEIGN2 as part of its UV routine. C (May be included in main TSTSET eventually) C Arguments: C IEND: (input) 0 or 1 for left or right endpoint C XA: (input) point where boundary condition info is evaluated C For the others, see SLEIGN2's documentation. C Kluge, to set valid fl.pt. values: SLEIGN2 does funny things.. HU = 0D0 HV = 0D0 C Change the labels below to execute appropriate code for any problem C with a LC endpoint. if (ATYPE(1:2).eq.'LC' .or. BTYPE(1:2).eq.'LC') then go to(10,10,10,10,10,10,10,10,10,10) IPROB else C If neither endpoint is LC, UV is not needed so do nothing return end if 10 write(*,*) 'Error in GTHUHV, Problem',IPROB,' has LC endpoint', + ' but no HU,HV info implemented for it' stop C Insert code on these lines: C 120 if (IEND.eq.0) then C HU = ... C HV = ... C else ... C end if C go to 1000 C 1000 end subroutine GTHUHV end module TESTMOD SHAR_EOF fi # end of overwriting check if test -f 'standard.f' then echo shar: will not over-write existing file "'standard.f'" else cat << SHAR_EOF > 'standard.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1997 **|****+****|****+****|** module TESTMOD use SLTSTVAR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C STANDARD Problem Set v1.2 Apr 96 by John Pryce C Revision History C v1.0 with original SLTSTPAK 1994 C v1.1 Apr 96: C - Minor changes to coefficient functions to reduce risk of overflow C - Implement/correct almost all the BC functions for LC problems. C Still some that I haven't managed to solve, on LCN/LCO border! C v1.2 Feb 97: converted to a F90 module. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine TSTSET(ISWTCH) C TSTSET contains the full definition of each problem. C The effect of a call is controlled by the module variable IPROB C (Problem number) and argument ISWTCH(section of code within the C Problem) via a number of computed GOTO statements at the top. C Case ISWTCH=-1: initialization call done once per run C Case ISWTCH=0: SETUP0 code, first setting-up stage C Case ISWTCH=1: SETUP1 code, second setting-up stage after reading C parameter values C Case ISWTCH=2: COEFFN code, evaluate coefficient functions C Case ISWTCH=3: GETBCS(Left) code, evaluate left BC C Case ISWTCH=4: GETBCS(Right) code, evaluate right BC C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Uses module variables described below C * NOTE. For readability the module variables are renamed inside C this routine(PARM becomes PARM etc); the description below uses C the 'standard' names. C The different types of call are: C+------------------------------------------------------------------+ C| Case ISWTCH=-1(called from TSTINI) | C| INITIALIZATION CALL done once per run: | C+------------------------------------------------------------------+ C Copies value of C NPROBP(the no. of Problems in the collection) C TSETNM(the name of the collection) C set in a PARAMETER statement, to module vars NPROB & TITLE, so C they can be transmitted to the Driver by TSTINI. C * NOTE. TSTSET is the only package routine that 'knows' this C information. Encapsulating this data inside TSTSET makes it C replaceable by another TSTSET without changing *any* other C part of the package. C C+------------------------------------------------------------------+ C| PROBLEM-SPECIFIC CALLS: | C| Various computed GOTOs controlled by IPROB cause a jump to | C| label 10*IPROB+ISWTCH, for instance calling TSTSET(3) for | C| Problem 17 will jump to label 173. | C+------------------------------------------------------------------+ C Case ISWTCH=0(called from SETUP0). C Input is the value of IPROB, set by SETUP0. C The title of the problem, number of parameters and the names C of parameters are put in the module variables TITLE, NPARM C and PARNM respectively. C Case ISWTCH=1(called from SETUP1). C Input, as well as the data set up by SETUP0 call, is the C parameter array PARM, set by SETUP1. C The endpoints are put in module variables A and B. C Their types are put in module variables ATYPE and BTYPE. C Their default BC coefficients are put in module variables C A1, A2, B1, B2. C Symmetry information is put in SYM. C Case ISWTCH=2(called from COEFFN). C Input is the value of X, set by COEFFN. C Evaluate p,q,w at x=X and put the result in P,Q,W. C Case ISWTCH=3(called from GETBCS(Left), i.e. GETBCS with IEND=0). C Input is the value of X and PARM(0), aka EIG, set by GETBCS. C Evaluate the LEFT-hand BC information at x=X, lambda=PARM(0), C aka EIG, putting the results in module variables PDU, U. C Case ISWTCH=4(called from GETBCS(Right), i.e. GETBCS with IEND=1). C Input is the value of X and PARM(0), aka EIG, set by GETBCS. C Evaluate the RIGHT-hand BC information at x=X, lambda=PARM(0), C aka EIG, putting the results in module variables PDU, U. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C .. Parameters .. C+------------------------------------------------------------------+ C| TSETNM is name given to Test Set by its implementer. | C| NPROBP is total no. of Problems. | C| There must be a Problem number I for every I from 1 to NPROBP. | C| *NOTE* When altering the Problem Set, re-set TSETNM & NPROBP !!! | C+------------------------------------------------------------------+ implicit none integer NPROBP character*8 TSETNM parameter(TSETNM='standard', NPROBP=60) C .. Local Scalars .. C These are used in various problems. Some are given a value by the C TSTSET(1) call, which is held for later use, so they need to be C SAVEd. Others are used as temporaries so don't need to be SAVEd: C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** double precision ALPHA,BETA,C,D,DE,DESCAL,EXPM2X,EXPMX,L, + LLP1,N,NU,NUSQ,OMEGA,PDUF,PDUNF,R,RE,REX6,T,TEMP,THETA,UF, + UNF,VEL C .. Scalar Arguments .. integer ISWTCH C .. Save statement .. save ALPHA,BETA,C,NU,NUSQ,N, + OMEGA,T,VEL,DE,RE,L,DESCAL,LLP1,REX6 C .. Data statements .. data DE/62D0/,RE/3.56D0/,L/7D0/ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Put ISWTCH.EQ.2 case first as this is the most frequently called: if (ISWTCH.eq.2) then C 'COEFFN' call: go to(12,22,32,42,52,62,72,82,92,102,112,122,132,142,152,162, + 172,182,192,202,212,222,232,242,252,262,272,282,292,302, + 312,322,332,342,352,362,372,382,392,402,412,422,432,442, + 452,462,472,482,492,502,512,522,532,542,552,562,572,582, + 592,602) IPROB else if (ISWTCH.eq.-1) then C 'TSTINI' call: C Copy title & total no. of Problems into module variables: TITLE(1:8) = TSETNM NPROB = NPROBP return else if (ISWTCH.eq.0) then C 'SETUP0' call: C Start of new problem so set default values of IPARM, NEPRM: IPARM = 0 NEPRM = 0 go to(10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160, + 170,180,190,200,210,220,230,240,250,260,270,280,290,300, + 310,320,330,340,350,360,370,380,390,400,410,420,430,440, + 450,460,470,480,490,500,510,520,530,540,550,560,570,580, + 590,600) IPROB else if (ISWTCH.eq.1) then C 'SETUP1' call: go to(11,21,31,41,51,61,71,81,91,101,111,121,131,141,151,161, + 171,181,191,201,211,221,231,241,251,261,271,281,291,301, + 311,321,331,341,351,361,371,381,391,401,411,421,431,441, + 451,461,471,481,491,501,511,521,531,541,551,561,571,581, + 591,601) IPROB else if (ISWTCH.eq.3) then go to(13,23,33,43,53,63,73,83,93,103,113,123,133,143,153,163, + 173,183,193,203,213,223,233,243,253,263,273,283,293,303, + 313,323,333,343,353,363,373,383,393,403,413,423,433,443, + 453,463,473,483,493,503,513,523,533,543,553,563,573,583, + 593,603) IPROB else if (ISWTCH.eq.4) then go to(14,24,34,44,54,64,74,84,94,104,114,124,134,144,154,164, + 174,184,194,204,214,224,234,244,254,264,274,284,294,304, + 314,324,334,344,354,364,374,384,394,404,414,424,434,444, + 454,464,474,484,494,504,514,524,534,544,554,564,574,584, + 594,604) IPROB else C This signals a serious coding error in the Package so: print *,'Invalid ISWTCH',ISWTCH,' and/or IPROB',IPROB, + ' input to TSTSET call' stop end if C***+****|****+****| START OF PROBLEM SET |****+****|****+****|** C Problem #1 C This is parametrized to test the nonlinear-in-eigenparameter facility C of NAG D02Kxx routines 10 TITLE = '-u" + u/(x+alpha)^2 = lambda u' NPARM = 1 NEPRM = 1 PARNM = 'alpha(>0, 0.1 gives standard problem in book)' go to 1000 11 A = 0D0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 12 ALPHA = PARM(1) P = 1D0 Q = 1D0/(X+ALPHA)**2 W = 1D0 if (IPARM .eq. 1) then Q = EIG*W - Q W = 2d0/(X+ALPHA)**3 end if go to 1002 13 U = A2 PDU = A1 go to 1003 14 U = B2 PDU = B1 go to 1004 C For $\lam_k$ see Appendix A C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #2 20 TITLE = 'Mathieu equation -u" + 2r cos(2x) u = lambda u' NPARM = 1 NEPRM = 1 PARNM = 'r' go to 1000 21 A = 0D0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 22 P = 1D0 Q = 2D0*PARM(1)*COS(2D0*X) W = 1D0 if (IPARM .ne. 0) then C Only IPARM=1 allowed, taking PARM(1)=r as eigenparameter Q = PARM(0)*W - Q W = 4D0*SIN(2D0*X) end if go to 1002 23 U = A2 PDU = A1 go to 1003 24 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Regular problems with strongly varying coefficient behaviour C Problem #3 30 TITLE = 'Ref: Klotter, Technisch Schwingungslehre, I, p.12' NPARM = 0 PARNM = ' ' go to 1000 31 A = 8D0/7D0 B = 8D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 32 P = 1D0 Q = 3D0/(4D0*X**2) W = 64*PI*PI/(9D0*X**6) go to 1002 33 U = A2 PDU = A1 go to 1003 34 U = B2 PDU = B1 go to 1004 C $a = 1$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = 2$ \qquad Regular \qquad $u(b) = 0$ C $\lam_k =(k+1)^{2}$, $k = 0,1,\ldots$\\ C Transformation of $-d^2v/dt^2=\lam v$, $v(\pi/3)=0=v(4\pi/3)$ by C $t={4\pi / 3x^2}$, $u=x^{3/2}v$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #4 40 TITLE = 'Truncated Hydrogen equation' NPARM = 1 PARNM = 'Right-hand endpoint b' go to 1000 41 A = 0D0 B = PARM(1) ATYPE = 'LPN' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 42 P = 1D0 Q = -1D0/X + 2D0/X**2 W = 1D0 go to 1002 43 U = A2 PDU = A1 go to 1003 44 U = B2 PDU = B1 go to 1004 C As $b$ is increased some codes run into meshing difficulties, putting C too few meshpoints near 0. C The lower evs well approximate those of the infinite problem. C E.g. with b=1000: C \lambda_0=-6.250000000000E-2, \lambda_9=-2.066115702478E-3, C \lambda_17=-2.5757359232E-4, \lambda_18=2.873901310E-5. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Regular problems with oscillatory coefficients C Problem #5 50 TITLE = 'Version of Mathieu equation, -u" + c cos(x) u = lambda u' NPARM = 1 PARNM = 'c' go to 1000 51 A = 0D0 B = 40D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 52 P = 1D0 Q = PARM(1)*COS(X) W = 1D0 go to 1002 53 U = A2 PDU = A1 go to 1003 54 U = B2 PDU = B1 go to 1004 C The lower eigenvalues form clusters of 6; more and tighter clusters as C $c$ increases. C For $c=5$: $\lam_0=-3.484229$, $\lam_5=-3.484187$, $\lam_6=-0.599543$, C $\lam_11=-0.595603$, $\lam_12=1.932915$, $\lam_17=1.995459$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #6 60 TITLE = 'Truncated Gelfand-Levitan.' NPARM = 0 PARNM = ' ' go to 1000 61 A = 0D0 B = 100D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 1D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 62 P = 1D0 T = 1D0 + X/2D0 + SIN(2D0*X)/4D0 Q = 2D0*(T*SIN(2D0*X)+COS(X)**4)/T**2 W = 1D0 go to 1002 63 U = A2 PDU = A1 go to 1003 64 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a)-(pu')(a) = 0$ \\ C $b = 100$ \qquad Regular \qquad $u(b) = 0$ C $\lam_0 = 0.00024681157 \qquad\lam_{99} = 9.77082852816$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Close-eigenvalue problems C Problem #7 70 TITLE = + 'Coffey-Evans eqn -u" + beta[beta sin(2x)^2 - 2cos(2x)]u = lam u' NPARM = 1 PARNM = 'beta' go to 1000 71 A = -PI/2D0 B = -A ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. BETA = PARM(1) A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 72 P = 1D0 Q = -2D0*BETA*COS(2.D0*X) + (BETA*SIN(2D0*X))**2 W = 1D0 go to 1002 73 U = A2 PDU = A1 go to 1003 74 U = B2 PDU = B1 go to 1004 C $a = -\pi/2 $ \qquad Regular \qquad $u(a) = 0$ \\ C $b = \pi/2 $ \qquad Regular \qquad $u(b) = 0$ C As $\beta$ increases there are very close eigenvalue triplets C $\{\lam_2,\lam_3,\lam_4\}$, $\{\lam_6,\lam_7,\lam_8\}$, \ldots, with C the other evs well separated. $\lam_0$ is very close to zero. \\ C $(\beta=20)\lam_0 = 0.0000000000000 \qquad \lam_3 = 151.46322365766$\\ C $(\beta=30)\lam_0 = 0.0000000000000 \qquad \lam_3 = 231.66492931296$\\ C $(\beta=50)\lam_0 = 0.0000000000000 \qquad \lam_3 = 391.808191489$\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #8 80 TITLE = 'Truncated Lennard-Jones LJ(12,6)' NPARM = 1 PARNM = 'endpoint b' go to 1000 81 A = 0D0 B = PARM(1) ATYPE = 'LPN' BTYPE = 'R' SYM = .FALSE. DESCAL = 1.92D0/16.858056*DE LLP1 = L*(L+1D0) A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 82 P = 1D0 REX6 =(RE/X)**6 Q = DESCAL*REX6*(REX6-2D0) + LLP1/X**2 W = 1D0 go to 1002 83 U = A2 PDU = A1 go to 1003 84 U = B2 PDU = B1 go to 1004 C Shows close evs can happen even with highly asymmetric potentials. C The effect is due to the resonance barrier. C With constants as given, b=38.85 gives approximately the minimum C splitting: C \lam_0=0.0899594272, \lam_1=0.0899769187. C q(x) gets large at 0: left BC u(0.8)=0 is acceptable substitute C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Regular problems that look singular C Problem #9 90 TITLE = + 'Regular with nasty w(x). Ref Fox, BVPs in DEs, Wisconsin 1960' NPARM = 0 PARNM = ' ' go to 1000 91 A = -1D0 B = 1D0 ATYPE = 'WR' BTYPE = 'WR' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 92 P = 1D0/SQRT(1-X**2) Q = 0D0 W = P go to 1002 93 U = A2 PDU = A1 go to 1003 94 U = B2 PDU = B1 go to 1004 C $a = -1$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = 1$ \qquad Regular \qquad $u(b) = 0$ C $\lam_0 = 3.559279966 \qquad \lam_9 = 258.8005854$ C $\lam_{24} = 1572.635284 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #10 100 TITLE = + 'Regular with nasty 1/p(x). Ref: J D Pryce, Num Sol SLPs, 1993' NPARM = 0 PARNM = ' ' go to 1000 101 A = -1D0 B = 1D0 ATYPE = 'WR' BTYPE = 'WR' SYM = .FALSE. A2 = 1D0 A1 = 0D0 B2 = 0D0 B1 = 1D0 go to 1001 102 P = SQRT(1-X**2) Q = 0D0 W = 1D0 go to 1002 103 U = A2 PDU = A1 go to 1003 104 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none C $\lam_0 = 0.3856819?? \qquad \lam_9 = 1031.628??$(values uncertain) C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #11 110 TITLE = 'Regular with nasty q(x). Ref: Pruess/Fulton 133' NPARM = 0 PARNM = ' ' go to 1000 111 A = 0D0 B = 4D0 ATYPE = 'WR' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 112 P = 1D0 Q = LOG(X) W = 1D0 go to 1002 113 U = A2 PDU = A1 go to 1003 114 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a) = 0$ C $b = 4$ \qquad Regular \qquad $u(b) = 0$ C $ \lambda _0 = 1.1248168097 \qquad \lambda _{24} = 385.92821596$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Parametrized singular problems C Problem #12 120 TITLE = 'Bessel`s equation -(xu'')'' + (nu**2/x) u = lambda x u' NPARM = 1 PARNM = 'nu**2(can be <0)' go to 1000 121 A = 0D0 B = 1D0 NUSQ = PARM(1) C Note usual NU is actually i*(this NU) when NUSQ<0: NU = SQRT(ABS(NUSQ)) if (NUSQ.ge.1D0) then ATYPE = 'LPN' else if (NUSQ.ge.0D0) then ATYPE = 'LCN' else ATYPE = 'LCO' end if BTYPE = 'R' SYM = .FALSE. C in all cases: A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 C Remaining bits assume NUSQ & NU have been set: 122 P = X Q = NUSQ/X W = X go to 1002 123 if (NUSQ.ge.1D0) then U = A2 PDU = A1 else if (NUSQ.gt.0D0) then U = A1*(X**NU) + A2/(X**NU) PDU = NU*A1*(X**NU) - NU*A2/(X**NU) else if (NUSQ.eq.0D0) then U = A1 + A2*LOG(X) PDU = A2 else U = A1*COS(NU*LOG(X)) + A2*SIN(NU*LOG(X)) PDU = NU*(-A1*SIN(NU*LOG(X))+A2*COS(NU*LOG(X))) end if go to 1003 124 U = B2 PDU = B1 go to 1004 C $ a = 0 $ \qquad LcN if $0\leq\nu<1$, LpN if $\nu\geq1$ C \qquad Fried. bc: $\nu u(a)-(pu')(a) = 0$ \\ C $ b = 1 $ \qquad Regular \qquad $u(b) = 0$ C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\nu={1\over3}$: $\lam_0=8.4250069295$ \qquad $\lam_9=970.7184494$\\ C $\nu=2$: $\lam_0 = 26.374616427 \qquad \lam_9 = 1136.8036878 $\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #13 130 TITLE = + 'Bessel eqn in normal form. -u" + ((nu**2-1/4)/x**2)u = lam u' NPARM = 1 PARNM = 'nu**2(can be <0)' go to 1000 131 NUSQ = PARM(1) A = 0D0 B = 1D0 C settng NU for NUSQ < 0(as well as >= 0) is useful for LCO case: NU = SQRT(ABS(NUSQ)) if (NUSQ.ge.1D0) then ATYPE = 'LPN' C special case which doesn't occur in the non-normal form else if (NUSQ.eq.0.25D0) then ATYPE = 'R' else if (NUSQ.ge.0D0) then ATYPE = 'LCN' else ATYPE = 'LCO' end if C In all cases take: A2 = 0D0 A1 = 1D0 BTYPE = 'R' SYM = .FALSE. B2 = 0D0 B1 = 1D0 go to 1001 C Remaining bits assume NUSQ & NU have been set: 132 P = 1D0 Q = 0D0 if (NUSQ.ne.0.25D0) Q =(NUSQ-0.25D0)/(X*X) W = 1D0 go to 1002 C BCs handle all cases: 133 if (NUSQ.ge.1D0) then C LPN case U = A2 PDU = A1 else if (NUSQ.eq.0.25D0) then C Regular case U = A1*X + A2 PDU = A1 else if (NUSQ.ge.0D0) then C LCN case, Fried. BC function=x**(1/2+nu), other=x**(1/2-nu) UF = X**(0.5D0+NU) UNF = X**(0.5D0-NU) PDUF =(0.5D0+NU)*UF/X PDUNF =(0.5D0-NU)*UNF/X U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF c print*,'TSTSET#13:X,A1,A2,UF,UNF,PDUF,PDUNF,U,PDU', c + X,A1,A2,UF,UNF,PDUF,PDUNF,U,PDU else C LCO case, BC function RealPart(x**(1/2+i*nu)(a1-i*a2)) TEMP = NU*LOG(X) U =(A1*COS(TEMP)+A2*SIN(TEMP))*SQRT(X) PDU =((0.5D0*A1+NU*A2)*COS(TEMP)-(NU*A1-0.5D0*A2)*SIN(TEMP))/ + SQRT(X) end if go to 1003 134 U = B2 PDU = B1 go to 1004 C Same cases as Problem 12 except for extra Regular case. C BC functions are sqrt(x) times those of Problem 12. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #14 140 TITLE = + 'Ref: Bender & Orzsag. -u" - l(l+1)sech**2(x) u = lambda u' NPARM = 1 PARNM = 'l' go to 1000 141 L = PARM(1) A = -XINFTY B = XINFTY ATYPE = 'LPNO' BTYPE = 'LPNO' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 142 P = 1D0 C Compute sech^2 x without overflow risk: EXPM2X = EXP(-2D0*ABS(X)) Q = -L*(L+1D0) * 4D0*EXPM2X/(1D0+EXPM2X)**2 W = 1D0 go to 1002 143 U = A2 PDU = A1 go to 1003 144 U = B2 PDU = B1 go to 1004 C $a = -\infty $ \qquad LpN/O \\ C $b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: $l$ \qquad \Spc:(0,$\infty $) \qquad C $ \lam_k = -(l+1-k)^{2}$, $k = 1,2,\ldots,l$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #15 150 TITLE = + 'Assoc. Legendre eqn. -((1-x^2)u'')'' + c u/(1-x^2) = lambda u' NPARM = 1 PARNM = 'c(c=0 for usual Legendre, c=1/4 for Chebyshev)' go to 1000 151 A = -1D0 B = 1D0 C = PARM(1) C See note re NU in Prob 12: NU = SQRT(ABS(C)) if (C.ge.1D0) then ATYPE = 'LPN' BTYPE = 'LPN' else if (C.ge.0D0) then ATYPE = 'LCN' BTYPE = 'LCN' else ATYPE = 'LCO' BTYPE = 'LCO' end if C In all cases: A1 = 1D0 A2 = 0D0 B1 = 1D0 B2 = 0D0 SYM = .TRUE. go to 1001 C Remaining bits assume C & NU have been set: 152 P = 1D0 - X**2 Q = C/(1D0-X**2) W = 1D0 go to 1002 153 if (C.ge.1D0) then C LPN case: U = A2 PDU = A1 else if (C.gt.0D0) then C LCN case: TEMP =(1D0-X**2)**(NU*0.5D0) U = A1*TEMP + A2/TEMP PDU = NU*X*(-A1*TEMP+A2/TEMP) else if (C.eq.0D0) then C Also LCN: U = A1 + A2*LOG(1-X**2) PDU = -A2*2D0*X else C LCO case: TEMP = NU*0.5D0*LOG(1-X**2) U = A1*COS(TEMP) + A2*SIN(TEMP) PDU = NU*X*(A1*SIN(TEMP)-A2*COS(TEMP)) end if go to 1003 C Right end is same as left end except A1 A2 become B1 B2: 154 if (C.gt.1D0) then C LPN case: U = B2 PDU = B1 else if (C.gt.0D0) then C LCN case: TEMP =(1D0-X**2)**(NU*0.5D0) U = B1*TEMP + B2/TEMP PDU = NU*X*(-B1*TEMP+B2/TEMP) else if (C.eq.0D0) then C Also LCN: U = B1 + B2*LOG(1-X**2) PDU = -B2*2D0*X else C LCO case: TEMP = NU*0.5D0*LOG(1-X**2) U = B1*COS(TEMP) + B2*SIN(TEMP) PDU = NU*X*(B1*SIN(TEMP)-B2*COS(TEMP)) end if go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \\ C $ \lambda _k =(k+\nu+1)(k+\nu), k = 0,1,...$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #16 160 TITLE = +'Assoc Legendre tfmed. -u" + [(c-1/4)sec(x)^2 - 1/4] u = lambda u' NPARM = 1 PARNM = + 'c(c=0 for usual Legendre, c=1/4 reduces to regular case)' go to 1000 161 A = -PI/2D0 B = PI/2D0 C = PARM(1) NU = SQRT(ABS(C)) if (C.ge.1D0) then ATYPE = 'LPN' BTYPE = 'LPN' else if (C.eq.0.25D0) then ATYPE = 'R' BTYPE = 'R' else if (C.ge.0D0) then ATYPE = 'LCN' BTYPE = 'LCN' else ATYPE = 'LCO' BTYPE = 'LCO' end if C In all cases: A1 = 1D0 A2 = 0D0 B1 = 1D0 B2 = 0D0 SYM = .TRUE. go to 1001 C Remaining bits assume C & NU have been set: 162 P = 1D0 Q =(C-0.25D0)/COS(X)**2 - 0.25D0 W = 1D0 go to 1002 163 if (C.gt.1D0) then C LPN case: U = A2 PDU = A1 else if (C.gt.0D0) then C LCN case: TEMP = COS(X)**NU U =(A1*TEMP+A2/TEMP)*SQRT(COS(X)) PDU = -((0.5D0+NU)*A1*TEMP+ (0.5D0-NU)*A2/TEMP)*SIN(X)/ + SQRT(COS(X)) else if (C.eq.0D0) then if(cos(x).lt.1d-7) print*,'x,x-a,cos x=',x,x-a,cos(x) C Also LCN: U =(A1+A2*LOG(COS(X)))*SQRT(COS(X)) PDU = -(A1+A2*(1D0+0.5D0*LOG(COS(X))))*SIN(X)/SQRT(COS(X)) else C LCO case: TEMP = NU*LOG(COS(X)) U =(A1*COS(TEMP)+A2*SIN(TEMP))*SQRT(COS(X)) PDU =((-0.5D0*COS(TEMP)+NU*SIN(TEMP))*A1+ + (-0.5D0*SIN(TEMP)-NU*COS(TEMP))*A2)*SIN(X)/SQRT(COS(X)) end if go to 1003 C Right end is same as left end except A1 A2 become B1 B2: 164 if (C.gt.1D0) then C LPN case: U = B2 PDU = B1 else if (C.gt.0D0) then C LCN case: TEMP = COS(X)**NU U =(B1*TEMP+B2/TEMP)*SQRT(COS(X)) PDU = -((0.5D0+NU)*B1*TEMP+ (0.5D0-NU)*B2/TEMP)*SIN(X)/ + SQRT(COS(X)) else if (C.eq.0D0) then if(cos(x).lt.1d-7) print*,'x,b-x,cos x=',x,b-x,cos(x) C Also LCN: U =(B1+B2*LOG(COS(X)))*SQRT(COS(X)) PDU = -(B1+B2*(1D0+0.5D0*LOG(COS(X))))*SIN(X)/SQRT(COS(X)) else C LCO case: TEMP = NU*LOG(COS(X)) U =(B1*COS(TEMP)+B2*SIN(TEMP))*SQRT(COS(X)) PDU =((-0.5D0*COS(TEMP)+NU*SIN(TEMP))*B1+ + (-0.5D0*SIN(TEMP)-NU*COS(TEMP))*B2)*SIN(X)/SQRT(COS(X)) end if go to 1004 C Spectrum as for previous problem C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #17 170 TITLE = + 'Anharmonic oscillator(Marletta PhD) -u" + x^alpha u = lambda u' NPARM = 1 PARNM = 'alpha' go to 1000 171 ALPHA = PARM(1) A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPN' A1 = 1D0 A2 = 0D0 B1 = 1D0 B2 = 0D0 SYM = .FALSE. go to 1001 172 P = 1D0 Q = X**ALPHA W = 1D0 go to 1002 173 U = A2 PDU = A1 go to 1003 174 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = +\infty $ \qquad LpN \\ C Number of eigenvalues: $\infty $ \qquad \Spc: none C $\alpha=2$: $\lam_k = 4k+3$, $k = 0,1,2,\ldots$ C $\alpha=3$: $\lam_0 = 3.4505626899 \qquad \lam_{24} = 228.52088139$ C $\alpha=4$: $\lam_0 = 3.7996730298 \qquad \lam_{24} = 397.14132678$ C $\alpha=5$: $\lam_0 = 4.0891593149 \qquad \lam_{24} = 588.17824969$ C As $\alpha$ increases, and for large $k$, choice of mesh at the RH C truncation point seems to become more difficult for Pruess methods C and stiffness makes initial-value methods expensive. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Finite interval singular: LPN, and LCN Friedrichs BC C Problem #18 180 TITLE = 'Bessel, order 0. -(xu'')'' = lambda x u' NPARM = 0 PARNM = ' ' go to 1000 181 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 182 P = X Q = 0D0 W = X go to 1002 183 U = A1 + A2*LOG(X) PDU = A2 go to 1003 184 U = B2 PDU = B1 go to 1004 C $\nu=0$: $\lam_0 = 5.78318596295 \qquad \lam_{19} = 3850.01252885 $\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #19 190 TITLE = 'Bessel, order 1/2. -(xu'')'' + 1/(4x) u = lambda x u' NPARM = 0 PARNM = ' ' go to 1000 191 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 192 P = X Q = 0.25D0/X W = X go to 1002 193 U = A1*sqrt(X) + A2/sqrt(X) PDU = 0.5D0*(A1*sqrt(X) - A2/sqrt(X)) go to 1003 194 U = B2 PDU = B1 go to 1004 C $\lam_k=((k+1)\pi)^2$, this is $-v''=\lam v$ transformed C by $v=x^{\half}u$.\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #20 200 TITLE = 'Legendre eqn. -((1-x^2)u'')'' = lambda u' NPARM = 0 PARNM = ' ' go to 1000 201 A = -1D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'LCN' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .TRUE. C Set C, NU for subsequent invocation of Problem 15 C = 0D0 NU = 0D0 go to 1001 202 P = 1D0 - X**2 Q = 0D0 W = 1D0 go to 1002 203 U = A1 + A2*LOG(1-X**2) PDU = -A2*2D0*X go to 1003 C Right end is same as left end except A1 A2 become B1 B2: 204 U = B1 + B2*LOG(1-X**2) PDU = -B2*2D0*X go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \\ C $ \lambda _k =(k+1)k, k = 0,1,...$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #21 210 TITLE = 'Slightly tricky q(x). -u" -(10/x^1.5) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 211 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 212 P = 1D0 Q = -10D0/(X*SQRT(X)) W = 1D0 go to 1002 C The BC functions can be defined in terms of Bessel fns. C However the following is a more elementary way to define them. C Non-Friedrichs BC was provided by Prof Patrick Parks formerly of RMCS C then at Oxford Centre for Industrial & Applied Mathematics(OCIAM), C Oxford, UK. Sadly died Jan 1994 213 UF = X -(40D0/3D0)*X*SQRT(X) PDUF = 1D0 - 20D0*SQRT(X) UNF = LOG(X)*UF - 0.0025D0 - 0.1D0*SQRT(X) + 320.D0/9.D0*X*SQRT(X) PDUNF = LOG(X)*PDUF + 1.D0 + 40.D0*SQRT(X) - 1.D0/(20.D0*SQRT(X)) U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF go to 1003 214 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \\ C With f, g being UF, UNF above: C Though f ~ const.x, g ~ const, neither 1 nor x is an admissible C function! Check-calculation: with Lu := -u''-(10/x^1.5) u we have C Lf = 40/3, Lg =(40/3)ln(x) - 3200/9 C so f, g, Lf, Lg *are* square-integrable, i.e. f, g are admissible. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #22 220 TITLE = + 'Legendre eqn, Liouville form. -u" -(1/4)sec(x)^2 u = lambda u' C but note Prob 16 can't be invoked for coeff functions C as eigenvalue is shifted by 0.25(could invoke it for BCs though) NPARM = 0 PARNM = ' ' go to 1000 221 A = -PI/2D0 B = PI/2D0 ATYPE = 'LCN' BTYPE = 'LCN' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .TRUE. go to 1001 222 P = 1D0 Q = -0.25D0/(COS(X)**2) W = 1D0 go to 1002 223 U =(A1+A2*LOG(COS(X)))*SQRT(COS(X)) PDU = -(A1+A2*(1D0+0.5D0*LOG(COS(X))))*SIN(X)/SQRT(COS(X)) go to 1003 224 U =(B1+B2*LOG(COS(X)))*SQRT(COS(X)) PDU = -(B1+B2*(1D0+0.5D0*LOG(COS(X))))*SIN(X)/SQRT(COS(X)) go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\lambda _k = k(k+1)+0.25$, $k = 0,1,\ldots $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #23 230 TITLE = +'Generalized hypergeom., -u"+ (-242ch x + 241)/(4sh(x)^2)u=lam u' NPARM = 0 PARNM = ' ' go to 1000 231 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 232 P = 1D0 C Q =(-242D0*COSH(X)+241D0)/(4D0*SINH(X)**2) if (X.le.1D0) then Q =(-121D0*SINH(0.5D0*X)**2 - 0.25D0) /(SINH(X)**2) else EXPMX = EXP(-X) Q =(-121D0*(1D0-EXPMX)**2-EXPMX)*EXPMX /(1D0-EXPMX**2)**2 end if W = 1D0 go to 1002 233 U = SQRT(X)*(A1+A2*LOG(X)) PDU =(A1*0.5D0+A2*(0.5D0*LOG(X)+1D0))/SQRT(X) go to 1003 234 U = B2 PDU = B1 go to 1004 C $ \lambda_k = -(5-k)^2, k=0,1,2,3,4$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #24 240 TITLE = 'Latzko equation. -((1-x^7)u'')'' = lambda x^7 u' NPARM = 0 PARNM = ' ' go to 1000 241 A = 0D0 B = 1D0 ATYPE = 'R' BTYPE = 'LCN' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 242 P = 1D0 - X**7 Q = 0D0 W = X**7 go to 1002 243 U = A2 PDU = A1 go to 1003 244 U = B1 - B2*LOG(1D0-X) PDU = B2*( (((((X+1D0)*X+1D0)*X+1D0)*X+1D0)*X+1D0)*X+1D0 ) go to 1004 C $a = 0$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = 1$ \qquad LcN \qquad BC fns f=1, g=ln(1-x)\\ C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\lam_0 = 8.7274703526 \qquad \lam_2 = 435.06333218$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #25 250 TITLE = 'Transformed regular -(x^4 u'')'' - 2x^2 u = lambda x^4 u' NPARM = 0 PARNM = ' ' go to 1000 251 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 252 P = X**4 Q = -2D0*X**2 W = P go to 1002 253 U = A1/X + A2/(X**2) PDU = -A1*X**2 - 2D0*A2*X go to 1003 254 U = B2 PDU = B1 go to 1004 C This is -v" = lambda v transformed by v = x^2 u. C The p=x^4 may cause difficulty in choosing mesh at x=0 C $\lam_k =((k+1)\pi)^2, k=0,1,...$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #26 260 TITLE = + 'Mysterious exact lam_0=7. -(x^3 u'')'' + x^3 u = lambda x^2 u' NPARM = 0 PARNM = ' ' go to 1000 261 A = 0D0 B = 1D0 ATYPE = 'LPN' BTYPE = 'R' SYM = .FALSE. A2 = 1D0 A1 = 0D0 B2 = 0D0 B1 = 1D0 go to 1001 262 P = X**3 Q = P W = X**2 go to 1002 263 U = A2 PDU = A1 go to 1003 264 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\lam_0 = 7.0000000000 \qquad \lam_9 = 284.53608972 $\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Infinite interval singular: LPN, and LCN Friedrichs BC C Problem #27 270 TITLE = 'Airy equation. -u" + x u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 271 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPN' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 272 P = 1D0 Q = X W = 1D0 go to 1002 273 U = A2 PDU = A1 go to 1003 274 U = B2 PDU = B1 go to 1004 C $ a = 0 $ \qquad Regular \qquad $u(a) = 0$ \\ C $ b = +\infty $ \qquad LpN C Number of eigenvalues: $\infty $ \qquad \Spc: none C Eigenvalues are the zeros of Airy function $\mbox{Ai}(\lam)= C(J_{1/3}+J_{-1/3})({2 / 3}\lam^{1/3})$.\\ C $\lam_0 = 2.3381074104 \qquad \lam_9 = 12.828776753$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #28 280 TITLE = 'Harmonic oscillator. -u" + x^2 u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 281 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 282 P = 1D0 Q = X**2 W = 1D0 go to 1002 283 U = A2 PDU = A1 go to 1003 284 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty$ \qquad \Spc: none \qquad C $\lam_k = 2k+1$, $k = 0,1,\ldots $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #29 290 TITLE = 'Hydrogen atom. -u" + (2/x^2 - 1/x) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 291 A = 0D0 B = XINFTY ATYPE = 'LPN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 292 P = 1D0 Q = -1/X + 2/X**2 W = 1D0 go to 1002 293 U = A2 PDU = A1 go to 1003 294 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc:(0,$\infty $) \qquad C $\lam_k = -1/(2k+4)^2$, $k = 0,1,\dots$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #30 300 TITLE = 'Coulomb potential. -u" - u/x = lambda u' NPARM = 0 PARNM = ' ' go to 1000 301 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 302 P = 1D0 Q = -1D0/X W = 1D0 go to 1002 303 U = A1*X + A2*(1D0-X*LOG(X)) PDU = A1 + A2*(-1D0-LOG(X)) go to 1003 304 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LcN \\ C $b = +\infty \qquad $ LpN/O C Number of eigenvalues: $\infty $. \qquad \Spc:(0,$\infty $)\\ C $ \lam_k = -1/[4(k+1)^2]$, $k = 0,1,\ldots $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #31 310 TITLE = + 'Transformed H-atom. -(x^2 u'')'' -(l(l+1)-x) u = lambda x^2 u' NPARM = 1 PARNM = 'l(integer>=0)' go to 1000 311 A = 0D0 B = XINFTY L = PARM(1) if (L.lt.1D0) then ATYPE = 'LCN' else ATYPE = 'LPN' end if BTYPE = 'LPNO' SYM = .FALSE. A2 = 1D0 A1 = 0D0 B2 = 0D0 B1 = 1D0 go to 1001 312 P = X*X Q = L*(L+1D0) - X W = P go to 1002 C I haven't checked what happens for l that are not integer >=0 C BEWARE! 313 if (L.eq.0D0) then U = A1 + A2*(1D0/X-LOG(X)) PDU = A2*(-1D0-X) else U = A2 PDU = A1 end if go to 1003 314 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $. \qquad \Spc:(0,$\infty $)\\ C $ \lam_k = -1/[4(k+l+1)^2]$, $k = 0,1,\ldots $ C This is Hydrogen atom eqn -v" + (l(l+1)/x^2 - 1/x) v = lambda v C transformed by u = x v. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #32 320 TITLE = 'Laguerre eqn. -u" + (x^2 + (alpha-1/4)/x^2) u = lambda u' NPARM = 1 PARNM = 'alpha(=1 for standard problem)' go to 1000 321 A = 0D0 B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 322 P = 1D0 Q = X**2 + (PARM(1)-0.25)/(X**2) W = 1D0 go to 1002 323 U = A2 PDU = A1 go to 1003 324 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LpN\qquad Fried. bc: $u(a) = 0$ \\ C $b = +\infty $ \qquad LpN \qquad Fried. bc: $u(b) = 0$ C Number of eigenvalues: $\infty C $ \qquad \Spc: none \\ C When $\alpha=1$, $ \lambda _k = 4(k+1), k = 0,1,...$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #33 330 TITLE = + 'Raman Scattering. -u" + (-7x^2 + 0.5x^3 + x^4) u = 0.5 lambda u' NPARM = 0 PARNM = ' ' go to 1000 331 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .FALSE. go to 1001 332 P = 1D0 Q = X*X*(-7D0+X*(0.5D0+X)) W = 0.5D0 go to 1002 333 U = 0D0 PDU = 1D0 go to 1003 334 U = 0D0 PDU = 1D0 go to 1004 C $a = -\infty $ \qquad LpN \\ C $b = \infty $ \qquad LpN C Number of eigenvalues: $\infty $ \qquad \Spc: none C $\lam_0 = -24.5175977072 \qquad \lam_5 = 8.10470769427 $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #34 340 TITLE = +'Pruess LCN/LCO border. -u"/2 -(1/(8x^2)+sech(x)^2) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 341 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 342 P = 0.5D0 C Compute sech^2 x without overflow risk: EXPM2X = EXP(-2D0*ABS(X)) Q = -0.125D0/X**2 - 4D0*EXPM2X/(1D0+EXPM2X)**2 W = 1D0 go to 1002 343 U =(A1+A2*LOG(X))*SQRT(X) PDU = 0.5D0*(A1*0.5D0+A2*(0.5D0*LOG(X)+1D0))/SQRT(X) go to 1003 344 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: 1 \qquad \Spc:(0,$\infty $) \\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Typical problems from chemical physics literature C Problem #35 350 TITLE = + 'Morse(1929) potential. -u" + (9e^(-x)-18e^(-2x))u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 351 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 352 P = 1D0 C Put a 'ceiling' on T hopefully to stop incautious codes C from overflowing with x<<0 C T = EXP(-X) T = EXP(min(22D0,-X)) Q = 9D0*T*(T-2D0) W = 1D0 go to 1002 353 U = A2 PDU = A1 go to 1003 354 U = B2 PDU = B1 go to 1004 C $ a = -\infty $ \qquad LpN \\ C $ b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: 3 \qquad \Spc:(0,$\infty $) \qquad C $\lam_k = -0.25-(3-k)(2-k)$, $k = 0,1,2 $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #36 360 TITLE = 'Morse potential, Secrest et al.(1962)' NPARM = 0 PARNM = ' ' go to 1000 361 A = 0D0 B = XINFTY ATYPE = 'LPN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 362 P = 1D0 T = EXP(-1.7D0*(X-1.3D0)) Q = 2D0/(X**2) + 2000D0*T*(T-2D0) W = 1D0 go to 1002 363 U = A2 PDU = A1 go to 1003 364 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LpN \\ C $b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: 26 \qquad \Spc:(0,$\infty$) C $\lam_0 = -1923.529653 \qquad \lam_1 = -177.2908125 \qquad C \lambda _{13} = -473.29709743 \qquad\lam_{25} = -1.7670126867 $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #37 370 TITLE = + 'Quartic anharmonic oscillator. -u" + (x^4 + x^2) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 371 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 372 P = 1D0 Q = X**2 + X**4 W = 1D0 go to 1002 373 U = A2 PDU = A1 go to 1003 374 U = B2 PDU = B1 go to 1004 C $a = -\infty $ \qquad LpN \\ C $b = \infty $ \qquad LpN \\ C Number of eigenvalues: $\infty $ \qquad \Spc: none C $\lam_0 = 1.3923516415 \qquad \lam_9 = 46.965069501 $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #38 380 TITLE = 'Close-evs problem -u" + (x^4-25x^2) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 381 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 382 P = 1D0 Q =(X**2-25D0)*X**2 W = 1D0 go to 1002 383 U = A2 PDU = A1 go to 1003 384 U = B2 PDU = B1 go to 1004 C $a = -\infty $ \qquad LpN \qquad Fried. bc: $u(a)= 0$ \\ C $b = +\infty $ \qquad LpN \qquad Fried. bc: $u(b) = 0$ C Number of eigenvalues: $\infty $ \qquad \Spc: none\\ C $ \lambda _0 = -149.2194561 \qquad \lambda _1 = -149.2194561 \qquad C \lambda {_40} = 75.69072485$\\ C Double-well version of quartic anharmonic oscillator. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #39 390 TITLE = + 'Morse(Marletta). -u" + 8000[e^(-3x) - 2e^(-3x/2)] u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 391 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 392 P = 1D0 T = EXP(-1.5D0*X) Q = 8D3*T*(T-2D0) W = 1D0 go to 1002 393 U = A2 PDU = A1 go to 1003 394 U = B2 PDU = B1 go to 1004 C $ a = -\infty $ \qquad LpN \\ C $ b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: 60 \qquad \Spc:(0,$\infty $) C With this deep well a large truncated interval seems to be C needed to give good approximations to higher \ev s. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #40 400 TITLE = 'Wicke and Harris(1976), spike at bottom of well' NPARM = 0 PARNM = ' ' go to 1000 401 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 402 P = 1D0 Q = 1250D0*EXP(-83.363D0*(X-2.47826D0)**2) + + 3906.25D0*(1D0-EXP(2.3237D0-X))**2 W = 1D0 go to 1002 403 U = A2 PDU = A1 go to 1003 404 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad regular \qquad $u(a) = 0$ \\ C $b = +\infty $\qquad LpN/O \\ C Number of eigenvalues: 62 \qquad \Spc:(3906.25,$\infty$)\\ C $ \lambda _0 = 163.2238021 \qquad \lambda _9 = 1277.536963 $\\ C This has a spike at the bottom of the well: whether this causes any C trouble to automatic codes is doubtful. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #41 410 TITLE = 'Woods-Saxon potential(Vanden Berghe et al. 1989).' NPARM = 1 PARNM = 'l(>=0)' go to 1000 411 A = 0D0 B = XINFTY L = PARM(1) LLP1 = L*(L+1D0) if (L.eq.0.D0) then ATYPE = 'R' else ATYPE = 'LPN' end if BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 412 P = 1D0 C T is the reciprocal of t as given in SL Book T = EXP(-(X-7D0)/0.6D0) Q = LLP1/(X*X) - 50D0*T/(T+1D0)*(1D0-(5D0/3D0)/(T+1D0)) W = 1D0 go to 1002 413 U = A2 PDU = A1 go to 1003 414 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular($l=0$), LpN($l=1$) \qquad $u(a) = 0$ \\ C $b = +\infty $ \qquad LpN/O \\ C($l=0$):\\ C Number of eigenvalues: 14 \qquad \Spc:(0,$\infty $) \\ C $ \lambda _0 = -49.457788728 \qquad \lambda _{10} = -18.094688282$ \\ C($l=1$):\\ C Number of eigenvalues: 13 \qquad \Spc:(0,$\infty $) \\ C $ \lambda _0 = -48.349481052 \qquad \lambda _{10} = -13.522303353$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #42 420 TITLE = 'Another model potential(Vanden Berghe et al. 1989).' NPARM = 1 PARNM = 'l' go to 1000 421 A = 0D0 B = XINFTY L = PARM(1) if (L.eq.0D0) then ATYPE = 'LCN' else ATYPE = 'LPN' end if BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 422 P = 1D0 Q = L*(L+1D0)/X**2 + (-1D0+5D0*EXP(-2D0*X))/X W = 1D0 go to 1002 423 if (L.eq.0D0) then U = A1*X + A2*(1D0+4D0*X*LOG(X)) PDU = A1 + A2*(4D0*LOG(X)+4D0) else U = A2 PDU = A1 end if go to 1003 424 U = B2 PDU = B1 go to 1004 C $a=0$ \qquad LcN($l=0$), LpN($l=1$) \qquad Fried. bc: $u(a)=0$\\ C $b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: $\infty $ \qquad \Spc:(0,$\infty $) \\ C($l=0$):\\ C $\lambda_0=-0.156358880971 \qquad \lambda _2 = -0.023484895664$\\ C($l=0$):\\ C $ \lambda _0 = -0.061681846633 \qquad \lambda _2 = -0.015501561691$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Borderline Problems C Problem #43 430 TITLE = 'Bessel, LCN/LCO border. -u" + ((alpha-1/4)/x^2)u = lam u' NPARM = 1 PARNM = 'alpha, say in range -0.1 to 0.1' go to 1000 C This is just Problem 13 so code is an exact copy (apart from labels) 431 NUSQ = PARM(1) A = 0D0 B = 1D0 C settng NU for NUSQ < 0(as well as >= 0) is useful for LCO case: NU = SQRT(ABS(NUSQ)) if (NUSQ.ge.1D0) then ATYPE = 'LPN' C special case which doesn't occur in the non-normal form else if (NUSQ.eq.0.25D0) then ATYPE = 'R' else if (NUSQ.ge.0D0) then ATYPE = 'LCN' else ATYPE = 'LCO' end if C In all cases take: A2 = 0D0 A1 = 1D0 BTYPE = 'R' SYM = .FALSE. B2 = 0D0 B1 = 1D0 go to 1001 C Remaining bits assume NUSQ & NU have been set: 432 P = 1D0 Q =(NUSQ-0.25D0)/(X*X) W = 1D0 go to 1002 C BCs handle all cases: 433 if (NUSQ.ge.1D0) then C LPN case U = A2 PDU = A1 else if (NUSQ.eq.0.25D0) then C Regular case U = A1*X + A2 PDU = A1 else if (NUSQ.ge.0D0) then C LCN case, Fried. BC function=x**(1/2+nu), other=x**(1/2-nu) UF = X**(0.5D0+NU) UNF = X**(0.5D0-NU) PDUF =(0.5D0+NU)*UF/X PDUNF =(0.5D0-NU)*UNF/X U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF else C LCO case, BC function RealPart(x**(1/2+i*nu)(a1-i*a2)) TEMP = NU*LOG(X) U =(A1*COS(TEMP)+A2*SIN(TEMP))*SQRT(X) PDU =((0.5D0*A1+NU*A2)*COS(TEMP)-(NU*A1-0.5D0*A2)*SIN(TEMP))/ + SQRT(X) end if go to 1003 434 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LcN $(0\leq\alpha<0.25)$, LcO $(\alpha<0)$ \\ C $b = 1$ \qquad Regular \qquad $u(b) = 0$ C Number of eigenvalues: $\infty\quad(\alpha\geq0)$, C $\pm\infty\quad(\alpha<0)$, \qquad \Spc: none \qquad C $\alpha=0.01$: $\lambda_0=6.540555712 \qquad\lam_{24}=6070.441468$\\ C $\alpha=0$: $\lambda_0=5.78318596295 \qquad\lam_{24}=6045.999522$\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #44 440 TITLE = 'Border of LPN and LCN. -u" + x^(alpha-2) u = lambda u' NPARM = 1 PARNM = 'alpha(near 0)' go to 1000 441 A = 0.D0 B = 1.D0 ALPHA = PARM(1) if (ALPHA.gt.0D0) then ATYPE = 'LCN' else ATYPE = 'LPN' end if BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 442 P = 1D0 Q = X**(ALPHA-2D0) W = 1D0 go to 1002 C The BC function in the book is in terms of Bessel fns. C This one is wrong: only the 1st 2 terms of a series that needs C more & more as alpha decreases to 0 443 if (ALPHA.gt.0D0) then UF = X*(1D0 + X**ALPHA/(ALPHA*(1D0+ALPHA))) PDUF = 1D0+X**ALPHA/ALPHA UNF =(1D0 + X**ALPHA/(ALPHA*(ALPHA-1D0))) PDUNF = X**(ALPHA-1D0)/ALPHA U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF else U = 0D0 PDU = 1D0 end if go to 1003 444 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Changes from LcN to LpN as $\alpha$ decreases thru $-2$ C \qquad Fried. bc: $u(a) = 0$ \\ C $b = 1$ \qquad Regular \qquad $u(b) = 0$ C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\alpha=-1.99$: $\lam_0=15.87305674 \qquad \lam_{24} = 6316.899940$\\ C $\alpha=-2.01$: $\lam_0=15.96808975 \qquad \lam_{24} = 6325.038047$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #45 450 TITLE = 'Border of LCN and LCO. -u" - x^(alpha-2) u = lambda u' NPARM = 1 PARNM = 'alpha(near 0)' go to 1000 451 A = 0D0 B = 1D0 ALPHA = PARM(1) if (ALPHA.gt.0D0) then ATYPE = 'LCN' else ATYPE = 'LCO' end if BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 452 P = 1D0 Q = -X**(ALPHA-2D0) W = 1D0 go to 1002 C I'm not too sure of this one(JDP): C It should be analysed in same way as #44 453 if (ALPHA.gt.0D0) then U = A1*(X-X**(1D0+ALPHA)/(ALPHA*(1D0+ALPHA))) + A2*0D0 PDU = A1*(1D0-X**ALPHA/ALPHA) + A2*0D0 else if (ALPHA.eq.0D0) then U = A1*(SIN(SQRT(0.75)*LOG(X))*SQRT(X)) + A2*0D0 PDU = A1*(SIN(SQRT(0.75)*LOG(X)+PI/6D0)/SQRT(X)) + A2*0D0 else write(*,FMT=*) 'Problem',IPROB,': LCO BCs not implemented yet' stop end if go to 1003 454 U = B2 PDU = B1 go to 1004 C $a=0$ \qquad Changes from LcN to LcO as $\alpha$ decreases thru $0$ C \\ C Number of eigenvalues: $\pm \infty $ \qquad \Spc: none\\ C $\alpha=-1.9$: $\lam_0 = -6152??. \qquad\lam_2 = 11.38??$\\ C $\alpha=-2.01$: requires LcO BC at $x=0$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Singular problems: LCN, Non-Friedrichs BC C Problem #46 460 TITLE = +'Bessel normal form, nonFried. BC, ref. Bailey Everitt Zettl 1991' NPARM = 0 PARNM = ' ' go to 1000 C This is just Problem 13 with \nu=3/4 461 NU = 0.75D0 A = 0D0 B = 1D0 ATYPE = 'LCN' C But with non-default left-hand BC defined by g=x^(-\nu+1/2): A2 = 1D0 A1 = 0D0 BTYPE = 'R' SYM = .FALSE. B2 = 0D0 B1 = 1D0 go to 1001 462 P = 1D0 Q =(5D0/16D0)/(X*X) W = 1D0 go to 1002 463 continue C LCN case, Fried. BC function=x**(1/2+nu), other=x**(1/2-nu) UF = X**(1.25D0) UNF = X**(-0.25D0) PDUF =(1.25D0)*UF/X PDUNF =(-0.25D0)*UNF/X U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF go to 1003 464 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #47 470 TITLE = +'NonFriedrichs, Pryce/Marletta. -(xu'')''+(b/x)^2 u = lam x^(2b)u' NPARM = 1 PARNM = 'b(>0)' go to 1000 471 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' SYM = .FALSE. BETA = PARM(1) A2 = 1.D0 A1 = 0.D0 B2 = 1.D0 B1 = -BETA go to 1001 472 P = X Q = BETA**2/X W = X**(2D0*BETA) go to 1002 473 U = A1*X**(BETA) + A2/X**(BETA) PDU = BETA*(A1*X**(BETA)-A2/X**(BETA)) go to 1003 474 U = B2 PDU = B1 go to 1004 C $a=0$ \qquad LcN \qquad non-Fried. bc: $[x^{-\beta},u](a)=0$\\ C $b=1$ \qquad regular \qquad $u'(b)=-\beta u(b)$\\ C $\lam_0=0$ for all $\beta$. For $\beta>14$(approx.) this appears C to cause severe problems to all codes, see \scref{sngexpts}. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #48 480 TITLE = 'Spectral density fn. example. Ref: Pruess/Fulton 75' NPARM = 0 PARNM = ' ' go to 1000 481 A = 0D0 B = 1D0 ATYPE = 'LPNO' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 482 P = X**4 Q = 0D0 W = X**2 go to 1002 483 U = A2 PDU = A1 go to 1003 484 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: 0 \qquad \Spc:(2.25,$\infty $) \\ C Spectral density $\rho(t) = {2\over 3\pi}(t-2.25)^{1.5}$ C The Frobenius index at 0 depends on lambda, and the p=x^4 can C cause meshing problems. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Singular problems: LCO C Problem #49 490 TITLE = + 'Modified Bessel(Bessel of order nu=i/2). Ref: Pruess/Fulton 33' NPARM = 0 PARNM = ' ' go to 1000 491 A = 0D0 B = 1D0 ATYPE = 'LCO' BTYPE = 'R' SYM = .FALSE. A1 = 1D0 A2 = 0D0 B1 = 1D0 B2 = 0D0 go to 1001 492 P = X Q = -1/(4D0*X) W = X go to 1002 493 TEMP = 0.5D0*LOG(X) U = A1*SIN(TEMP) + A2*COS(TEMP) PDU = 0.5D0*(A1*COS(TEMP)-A2*SIN(TEMP)) go to 1003 494 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LcO \\ C $b = 1$ \qquad Regular \qquad $u(b) = 0$ C Number of eigenvalues: $\pm \infty $ \qquad \Spc: none \\ C General BC at 0 is $[x^{1/2}\sin(\half\ln x+\gamma),u](0)=0$ where C$\gamma$ is constant. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #50 500 TITLE = +'Weierstrass-Mandelbrot. -u" + (c-(omega^2+.25)/x^2) u = lambda u' NPARM = 2 PARNM = +'omega >0 & offset c; c>0 vital for SLEIGN2 to find lambda_0' go to 1000 501 OMEGA = PARM(1) A = 0D0 B = XINFTY ATYPE = 'LCO' BTYPE = 'LPNO' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 502 P = 1D0 Q = PARM(2)-(OMEGA**2+0.25D0)/X**2 W = 1D0 go to 1002 503 TEMP = OMEGA*LOG(X) U =(A2*COS(TEMP)+A1*SIN(TEMP))*SQRT(X) PDU =((0.5D0*A2+OMEGA*A1)*COS(TEMP) - + (OMEGA*A2-0.5D0*A1)*SIN(TEMP))/SQRT(X) go to 1003 504 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $+-\infty$ \qquad \Spc:(0,$\infty $) \qquad C BC functions f=x^(1/2) sin(omega ln(x) + gamma), gamma arbitrary C For c=0 & any gamma the evs are a 2-sided infinite geometric C progression with common ratio exp(2 pi/omega). C For ratio=10 take omega = 2.72875270768368 C For ratio=2 take omega = 9.06472028365439 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #51 510 TITLE = 'Titchmarsh problem. -u" - e^x u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 511 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LCO' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 512 P = 1D0 Q = -EXP(X) W = 1D0 go to 1002 513 U = A2 PDU = A1 go to 1003 514 TEMP = 2D0*EXP(0.5D0*X) U = EXP(-0.25D0*X)*(B1*SIN(TEMP)+B2*COS(TEMP)) PDU = -0.5D0*U + 2D0*EXP(0.25D0*X)*(B1*COS(TEMP)-B2*SIN(TEMP)) go to 1004 C $a = 0$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = +\infty $ \qquad LcO C Number of eigenvalues: $\pm \infty $ \qquad \Spc: none \\ C General BC at $\infty$ is of form $[f,u](\infty)=0$ where C $f=e^{-x/4}\sin(2e^{x/2} + \gamma)$, which is an exact solution of C the DE with $\lam=-1/16$ for any value of the constant $\gamma$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #52 520 TITLE = + 'Limit-circle osc with cont spectrum. -u" -1/x^3 u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 521 A = 0D0 B = XINFTY ATYPE = 'LCO' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 522 P = 1D0 Q = -1D0/X**3 W = 1D0 go to 1002 523 continue C This needed JWKB expansion up to R_3 term (JDP book p41) C to get approximations u,v s.t. Lu,Lv are square integrable. R = X**0.75D0*exp((3D0/64D0)*X) THETA = 2D0/sqrt(X) + (3D0/16D0)*sqrt(X) C = 0.75D0/X + 3D0/64D0 D = (-1D0/X + (3D0/32D0))/sqrt(X) UF = R*cos(THETA) UNF = R*sin(THETA) PDUF = C*UF-D*UNF PDUNF = D*UF+C*UNF U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF go to 1003 524 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LcO, BC functions x^{0.5) Z(2x^{-1/2}) C where Z is a combination of Bessel fns J1 and Y1.\\ C Elementary BC functions from real, imaginary parts of $w$ where C \[w'/w = -ix^{-3/2} + {3\over4}x^{-1} + i{3\over32}x^{-1/2} C + {3\over64}x^0 \] C obtained by terms up to $R_3$ in JWKB expansion (book p41). C $b = +\infty $ \qquad LpN/O \\ C \Spc:(0,$\infty $) \\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problems with discontinuous coefficients C Problem #53 530 TITLE = 'Approximate harmonic oscillator, Pryce 1993' NPARM = 1 PARNM = + 'b (reg BCs u(-b)=u(b)=0 are used, b>=10^35 taken as Infinity)' go to 1000 531 B = MIN(PARM(1),XINFTY) A = -B if (B.lt.XINFTY) then ATYPE = 'R' BTYPE = 'R' else ATYPE = 'LPN' BTYPE = 'LPN' end if A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .TRUE. go to 1001 532 P = 1D0 T = ABS(X) N = FLOAT(INT(T)) Q = N*N + (2*N+1)*(T-N) W = 1D0 go to 1002 533 U = A2 PDU = A1 go to 1003 534 U = B2 PDU = B1 go to 1004 C q is piecewise linear function joining the points(x,x^2) for x an C integer. Codes seem to find automatic endpoint analysis hard, C hence the PARM which allows one to set finite regular endpoints C at which u=0 is imposed. C Number of eigenvalues: $\infty $ \qquad \Spc: none \\ C $\lambda_0=.3456792711$, $\lambda_9=18.079846195$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Extensions to the classical SLP C Problem #54 540 TITLE = 'Indefinite weight function, Marletta PhD 1991' NPARM = 0 PARNM = ' ' go to 1000 541 A = 0D0 B = 1D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 542 P = 1D0 Q = 1D0 if (X.le.0.5D0) then W = 0D0 else W = 1D0 end if go to 1002 543 U = A2 PDU = A1 go to 1003 544 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a)=0$\\ C $b = 1$ \qquad Regular \qquad $u(b)=0$\\ C Number of eigenvalues: $\infty $. C $\lam_k=\mu_k^2+1$ where $\mu_k$ are roots of C $\tan{\mu\over2}+\mu\tanh\half=0$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #55 550 TITLE = 'Indefinite weight fn, Bailey et al. ACM TOMS 1978' NPARM = 0 PARNM = ' ' go to 1000 551 A = -1D0 B = 1D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 552 P = EXP(-X**2) Q = P W = -2D0*X*P go to 1002 553 U = A2 PDU = A1 go to 1003 554 U = B2 PDU = B1 go to 1004 C $a = -1$ \qquad Regular \qquad $u(a)=0$\\ C $b = 1$ \qquad Regular \qquad $u(b)=0$\\ C Number of eigenvalues: $\pm\infty $. C The conversion to self-adjoint form of the problem C u'' - x u' -(1+2\lambda x) u = 0, u(-1)=u(1)=0 C $\lambda_5=250.974149734$. C By the antisymmetry, if lambda is an eigenvalue so is -lambda. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #56 560 TITLE = 'lambda-dependent BC at x=a, Fulton/Pruess 1992' NPARM = 4 PARNM = 'A1 A2 A1'' A2'' in SLEDGE-style BCs'// *', 1 0 0 1 for prob. in book' go to 1000 561 A = 1D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. C The BC at x=a is not adjustable so A1, A2 not set: B2 = 0D0 B1 = 1D0 go to 1001 562 P = 1D0 Q = -0.25D0/X**2 W = 1D0 go to 1002 563 U = PARM(1)-EIG*PARM(3) PDU = PARM(2)-EIG*PARM(4) go to 1003 564 U = B2 PDU = B1 go to 1004 C $a = 1$ \qquad Regular \qquad $\lambda u(a) -(pu')(a) = 0$\\ C $b = \infty$ \qquad LPN/O\\ C Number of eigenvalues: $1$ \qquad \Spc: $(0,\infty)$ \\ C $\lambda_0=-0.02229899486$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #57 570 TITLE = + 'lambda-dependent BC at x=a, Fulton/Pruess private comm. 1992' NPARM = 4 PARNM = 'A1 A2 A1'' A2'' in SLEDGE-style BCs'// *', 1 0 0 1 for prob. in book' go to 1000 571 A = 1D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. C The BC at x=a is not adjustable so A1, A2 not set: B2 = 0D0 B1 = 1D0 go to 1001 572 P = 1D0 Q = -1D0/X W = 1D0 go to 1002 573 U = PARM(1)-EIG*PARM(3) PDU = PARM(2)-EIG*PARM(4) go to 1003 574 U = B2 PDU = B1 go to 1004 C $a = 1$ \qquad Regular \qquad $\lambda u(a) -(pu')(a) = 0$\\ C $b = \infty$ \qquad LPN/O\\ C Number of eigenvalues: $\infty$ \qquad \Spc: $(0,\infty)$ \\ C $\lambda_0=-0.30017359365$ \qquad $\lambda_9=-0.0025669706$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #58 580 TITLE = 'Rossby wave equation, Drazin et al. J Fluid Mech 1982' NPARM = 2 NEPRM = 2 PARNM = 'alpha, c' go to 1000 581 A = -PI B = PI ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 C This problem is quite far from the classical SLP and one cannot C classify it for SLEIGN (q finite at a or b, etc) in a simple way. C In the following section: C BETA is beta, the standard 'linear' eigenparameter. C VEL is called U(x) in the cited paper. C To provide an interface for problems nonlinear in parameters, C for a NAG D02KEF-style solver, if IPARM>0, C writing QQ=beta*w-q, we compute WW=partial d(QQ)/d(alpha), C WW = partial d(QQ)/d(c) according as IPARM is 1 or 2 C and return QQ, WW in variables Q and W. 582 BETA = PARM(0) ALPHA = PARM(1) C = PARM(2) VEL =(X/B)**2 P = 1D0 Q = ALPHA**2 + VEL/(VEL-C) W = 1D0/(VEL-C) if (IPARM .ne. 0) then Q = BETA*W - Q if (IPARM .eq. 1) then W = -2D0*ALPHA else if (IPARM .eq. 2) then W =(BETA-VEL)/(VEL-C)**2 end if end if go to 1002 583 U = A2 PDU = A1 go to 1003 584 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problems contrived to show special features C Problem #59 590 TITLE = 'Ref Gelfand & Levitan, AMS Translations 1955.' NPARM = 0 PARNM = ' ' go to 1000 591 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. A2 = 1D0 A1 = -1D0 B2 = 0D0 B1 = 1D0 go to 1001 592 P = 1D0 T = 1D0 + X/2D0 + SIN(2D0*X)/4D0 Q = 2D0*(T*SIN(2D0*X)+COS(X)**4)/T**2 W = 1D0 go to 1002 593 U = A2 PDU = A1 go to 1003 594 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a)+ (pu')(a) = 0$ \\ C $b = \infty$ \qquad LPN/O \\ C Number of(isolated) eigenvalues: none \qquad \Spc: $(0,\infty)$ \\ C There is an eigenvalue at $\lambda=1$ in the \Spc. \\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #60 600 TITLE = + 'Problem with pseudo-eigenvalue, Pryce 1989, ref Marletta PhD 91' NPARM = 0 PARNM = ' ' go to 1000 601 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. A2 = -8D0 A1 = 5D0 B2 = 0D0 B1 = 1D0 go to 1001 602 P = 1D0 Q =(3D0*(X-31D0))/(4D0*(1D0+X)*(4D0+X)**2) W = 1D0 go to 1002 603 U = A2 PDU = A1 go to 1003 604 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $5u(a)+8(pu')(a) = 0$ \\ C $b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: 1 \qquad \Spc:(0,$\infty $) \qquad C $\lam_0 = -1.185214105$\\ C There is a solution for $\lam=0$ satisfying the BC at 0 and converging C to 0 at $\infty$. However it is not square-integrable, so $0$ is not C an eigenvalue. C***+****|****+****| END OF PROBLEM SET |****+****|****+****|** 1000 continue 1001 continue 1002 continue 1003 continue 1004 continue end subroutine TSTSET C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine ABINFO(P0ATA,QFATA,P0ATB,QFATB) C This routine is used only by SLEIGN & SLEIGN2. C Its functionality should be incorporated into TSTSET eventually. C******* THIS ROUTINE APPLIES TO THE STANDARD TEST SET ONLY ************ implicit none integer NPROB parameter(NPROB=60) C .. Scalar Arguments .. double precision P0ATA,QFATA,P0ATB,QFATB C .. Local Arrays .. integer P0A(1:NPROB),QFA(1:NPROB),P0B(1:NPROB),QFB(1:NPROB) data P0A/ C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 1, 1, 1, C 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 + 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ data QFA/ C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, C 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, C 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1/ data P0B/ C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, C 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ data QFB/ C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, C 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 1, 0, 1, 1, 1, 1, 0, 0, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 1, 1, C 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1/ C***+****|****+****|**** Special Cases Section **|****+****|****+****|** C in several problems this info depends on values of parameters so: goto(999, 999, 999, 999, 999, 999, 999, 999, 999, 999, + 999, 120, 130, 999, 150, 160, 999, 999, 999, 999, + 999, 999, 999, 999, 999, 999, 999, 999, 999, 999, + 999, 999, 999, 999, 999, 999, 999, 999, 999, 999, + 410, 999, 430, 440, 450, 999, 999, 999, 999, 999, + 999, 999, 999, 999, 999, 999, 999, 999, 999, 999) + IPROB C Problem #12, Bessel: q finite at 0 if nusq=0 120 if (PARM(1).eq.0D0) QFATA=1 go to 999 C Problem #13, Bessel LNF: q finite at 0 if nusq=1/4 130 if (PARM(1).eq.0.25D0) QFATA=1 go to 999 C Problem #15, Assoc Legendre: q finite at -1, +1 if c=0 150 if (PARM(1).eq.0D0) then QFATA=1 QFATB=1 end if go to 999 C Problem #16, Assoc Legendre LNF: q finite at -1, +1 if c=1/4 160 if (PARM(1).eq.0.25D0) then QFATA=1 QFATB=1 end if go to 999 C Problem #41, Woods-Saxon: q finite if l = -1 or 0 410 if (PARM(1).eq.-1D0 .or. PARM(1).eq.0D0) QFATA=1 go to 999 C Problem #43, `borderline 1', is a copy of Prob 13 430 if (PARM(1).eq.0.25D0) QFATA=1 go to 999 C Problem #44, `borderline 2': q finite at 0 iff alpha>=2 440 QFATA = 0 if (PARM(1).ge.2D0) QFATA=1 go to 999 C Problem #45, `borderline 3': q behaves like #44 450 QFATA = 0 if (PARM(1).ge.2D0) QFATA=1 go to 999 C***+****|****+****|**** End of Special Cases **|****+****|****+****|** 999 continue P0ATA = 2*P0A(IPROB) - 1 QFATA = 2*QFA(IPROB) - 1 P0ATB = 2*P0B(IPROB) - 1 QFATB = 2*QFB(IPROB) - 1 end subroutine ABINFO C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine GTHUHV(IEND,XA,UA,VA,HU,HV) C This routine is used only by SLEIGN2. C Its functionality should be incorporated into TSTSET eventually. C******* THIS ROUTINE APPLIES TO THE STANDARD TEST SET ONLY ************ implicit none integer IEND double precision XA,UA,VA,HU,HV double precision AA,BB,ALPHA,NU,OM,OMSQ,TEMP C Returns the HU,HV info needed by SLEIGN2 as part of its UV routine. C (May be included in main TSTSET eventually) C Kluge, to set valid fl.pt. values: SLEIGN2 does funny things.. HU = 0D0 HV = 0D0 if (ATYPE(1:2).eq.'LC' .or. BTYPE(1:2).eq.'LC') then go to(10,10,10,10,10,10,10,10,10, 10, 10,120,130, 10,150,160, + 10,180,190,200,210,220,230,240,250, 10, 10, 10, 10,300, + 310, 10, 10,340, 10, 10, 10, 10, 10, 10, 10,420, 10,440, + 450,460,470, 10,490,500,510,520, 10, 10, 10, 10, 10, 10, + 10, 10) IPROB else C If neither endpoint is LC, UV is not needed so do nothing return end if 10 write(*,*) 'Error in UV, Problem',IPROB,' has LC endpoint but', + ' no HU,HV info implemented for it' stop 120 if (IEND.eq.0) then C Whatever the value of PARM(1)=NU**2: HU = 0D0 HV = 0D0 end if go to 1000 130 if (IEND.eq.0) then C Whatever the value of PARM(1)=NU**2: HU = 0D0 HV = 0D0 end if go to 1000 150 continue C Whether IEND is 0 or 1: if (PARM(1).ge.0D0) then NU = sqrt(PARM(1)) HU =(NU*NU+NU)*UA HV =(NU*NU-NU)*VA else C Here UA,VA are Re,Im of(1-x*x)**{i*omega}, nu=i*omega OMSQ = PARM(1) OM = sqrt(-OMSQ) HU = OMSQ*UA-OM*VA HV = OMSQ*VA+OM*UA end if go to 1000 160 continue C Whatever the value of PARM(1)=NU**2 and at both ends: HU = 0D0 HV = 0D0 go to 1000 180 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 190 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 200 continue C At both ends: HU = 0D0 HV = 0D0 go to 1000 210 continue C for truncated series BC functions(see TSTSET) not the Bessel ones HU = 400D0/3D0 HV = HU*log(XA) - 3200D0/9D0 go to 1000 220 continue C At both ends: HU = 0D0 HV = 0D0 go to 1000 230 continue print*,'UV: Prob 23 not implemented yet, program terminated' stop go to 1000 240 if (IEND.eq.1) then HU = 0D0 HV = - (1D0+XA*(2D0+XA*(3D0+XA*(4D0+XA*(5D0+XA*6D0)))) ) end if go to 1000 250 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 300 if (IEND.eq.0) then HU = -1D0 HV = log(XA) end if go to 1000 310 if (IEND.eq.0) then HU = -XA HV = log(XA) print*,'UV: Prob 31 Warning, only valid for l=0' end if go to 1000 340 if (IEND.eq.0) then C Probably no need to worry about overflow in cosh x here: HU = -sqrt(XA)/(cosh(XA)**2) HV = HU*log(XA) end if go to 1000 420 if (IEND.eq.0) then HU = 5D0*exp(-2D0*XA) - 1D0 if (abs(XA).le.1D-4) then TEMP = -2D0+2D0*XA-(4D0/3D0)*XA*XA+ (2D0/3D0)*XA*XA*XA else TEMP = 5D0*(exp(-2D0*XA)-1D0)/XA end if HV = TEMP + (5D0*exp(-2D0*XA)-1D0)*4D0*log(XA) print*,'UV: Prob 42 Warning, only valid for l=0' end if go to 1000 440 if (IEND.eq.0) then print*,'UV: Prob 44, BC fns are known NOT to be correct!' ALPHA = PARM(1) HU = XA**(2D0*ALPHA-1D0)/((ALPHA+1D0)*ALPHA) HV = XA**(2D0*ALPHA-2D0)/(ALPHA*(ALPHA-1D0)) end if go to 1000 450 if (IEND.eq.0) then print*,'UV: Prob 45, BC fns are known NOT to be correct!' ALPHA = PARM(1) C this is false! HU = 0D0 HV = 0D0 end if go to 1000 460 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 470 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 490 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 500 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 510 if (IEND.eq.1) then HU = UA/(-16D0) HV = VA/(-16D0) end if go to 1000 520 if (IEND.eq.0) then AA = (63D0/1024D0)/XA + 9D0/4096D0 BB = (9D0/1024D0)/sqrt(XA) HU = AA*UA - BB*VA HV = AA*VA + BB*UA end if go to 1000 1000 end subroutine GTHUHV end module TESTMOD SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'sldriver' then mkdir 'sldriver' fi cd 'sldriver' if test -f 'batchio.f' then echo shar: will not over-write existing file "'batchio.f'" else cat << SHAR_EOF > 'batchio.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** C BATCHIO is a module with the same name, SAFEIO, and interface as the C interactive SAFEIO package, but intended for use when running a C program non-interactively. Differences: C 1. SPAUSE doesn't wait for ENTER to be pressed but waits 1 second C 2. 'ERR=' on input leads to a STOP. C 3. They echo their input to the screen. C The result is that the screen output in batch mode (using < to C read data from a file) should be identical to that produced by C running interactively, if the data has no errors! module SAFEIO contains C***+****|****+****|**SAFEIO package***|****+****|****+****|****+****|** C Simple 'secure, abortable interactive input' routines C C The following are logical functions which return values through C the argument list and also C either C .TRUE. through the function name meaning 'successful input' C and the input value(s) through its (first) argument C or C .FALSE. through the function name meaning 'aborted by user' C The routines are C GETI(X) - get one Integer value X C GETR(X) - get one Real value X C GETIR(X,XLO,XHI) - get one Integer value X in a Range C GETRR(X,XLO,XHI) - get one Real value X in a Range C GETIS(X,NX) - get NX integer values into array X C GETRS(X,NX) - get NX real values into array X C C The user is to signal 'abort' by typing z or Z (followed by Enter) C C The following is a non-abortable routine requiring a yes/no answer C YESNO() - character*1 function, returns either 'y' or 'n' C The following non-abortable routine waits for ENTER to be pressed C SPAUSE() C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine OPNPBK C Dummy routine end subroutine OPNPBK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine CLOPBK C Dummy routine end subroutine CLOPBK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETI(X) implicit none C .. Scalar Arguments .. integer X character*80 LINE C .. 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETI = .FALSE. return else read (LINE,FMT=*,ERR=30) X GETI = .TRUE. return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') stop end if end function GETI C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETR(X) implicit none C .. Scalar Arguments .. double precision X character*80 LINE C .. 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETR = .FALSE. return else read (LINE,FMT=*,ERR=30) X GETR = .TRUE. return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Real value required, please retype: '')') stop end if end function GETR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETIR(X,XLO,XHI) implicit none C .. Scalar Arguments .. integer X,XHI,XLO C .. character*80 LINE C .. 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETIR = .FALSE. return else read (LINE,FMT=*,ERR=30) X if (X.lt.XLO .or. X.gt.XHI) go to 40 GETIR = .TRUE. return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') stop 40 write (*,FMT=45) XLO,XHI 45 format(1x,'***Not in range',i9,' :',i9,', please retype: ') stop end if end function GETIR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETRR(X,XLO,XHI) implicit none C .. Scalar Arguments .. double precision X,XHI,XLO C .. character*80 LINE C .. 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETRR = .FALSE. return else read (LINE,FMT=*,ERR=30) X if (X.lt.XLO .or. X.gt.XHI) go to 40 GETRR = .TRUE. return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') stop 40 write (*,FMT=45) XLO,XHI 45 format(1x,'***Not in range',i9,' :',i9,', please retype: ') stop end if end function GETRR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETIS(X,NX) implicit none C .. Scalar Arguments .. integer NX C .. C .. Array Arguments .. integer X(NX) C .. C .. Local Scalars .. integer I character*80 LINE C .. I = 1 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETIS = .FALSE. return else read (LINE,FMT=*,ERR=30) (X(I),I=I,NX) GETIS = .TRUE. return 30 write (*,ADVANCE='NO',FMT=35) I 35 format + ('***Integer values required, please retype from item',i2,': ') stop end if end function GETIS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETRS(X,NX) implicit none C .. Scalar Arguments .. integer NX C .. C .. Array Arguments .. double precision X(NX) C .. C .. Local Scalars .. integer I character*80 LINE C .. I = 1 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETRS = .FALSE. return else read (LINE,FMT=*,ERR=30) (X(I),I=I,NX) GETRS = .TRUE. return 30 write (*,ADVANCE='NO',FMT=35) I 35 format + ('***Real values required, please retype from item',i2,': ') stop end if end function GETRS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** character*1 function YESNO(ASK) implicit none character*(*) ASK C .. Local Scalars .. character YN C .. write(*,'(a)',advance='NO') ASK 10 read (*,FMT='(a)',END=40,ERR=30) YN write (*,'(a)') YN if (YN.eq.'y' .or. YN.eq.'Y') then YESNO = 'y' else if (YN.eq.'n' .or. YN.eq.'N') then YESNO = 'n' else go to 30 end if return 30 write (*,ADVANCE='NO', + FMT='(1x,''***Please type one of y,Y,n,N: '')') stop 40 write (*,*) 'Don''t use end-of-file,', + ' it means end of run in most F90 & some F77 systems' write (*,*) 'Sorry!' stop end function YESNO C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SPAUSE double precision DELAY integer CTRL_C parameter (DELAY=1d0, CTRL_C=3) integer ICURR,IRATE,ISTART integer(kind=2) K write (*,FMT='(a)') 'Press ENTER to continue' C read (*,FMT=*,END=100,ERR=100) call SYSTEM_CLOCK(ISTART,IRATE) 50 continue !C start of Salford FTN90-specific code !C Salford FTN90 routine to check if key has been pressed ! call GET_KEY1@(K) ! if (K.eq.CTRL_C) then ! print*,'User-requested Break' ! stop ! end if !C end of Salford FTN90-specific code call SYSTEM_CLOCK(ICURR,IRATE) if (dble(ICURR-ISTART)/dble(IRATE) 'dbmod.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** module DBMOD use SLCONSTS use SLPSET use SAFEIO use SLUTIL implicit none C Unit for reading data files: integer, parameter:: INFIL=18 C***+****|****+****|****+ GENERAL DESCRIPTION ***|****+****|****+****|** C DBMOD contains the routines C DBINIT C EVCHK C EFCHK C SDCHK C UPEVTR C UPEFTR C UPSDTR C UPXMUN C UPLMUN C GTXMTR C GTXMUN C GTLMTR C GTLMUN C EVSCAN C EVDAT C EFSCAN C EFDAT C SDSCAN C SDDAT C & debugging routine C DBSUMM C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C DBMOD handles 3 data objects that are read from an external file of C "true" data values and 'cached' within the program: C Name of | C object |Contents C --------+-------------------------------------------------------------- C 'EVTRUE'|A set of "true" e-vs of a given problem: abstractly, a vector C |of k-values and a corresponding vector of lambda(k), and of C |believed errors in the lambda(k), where the C |k's are a subset of the current range KLO,KHI. C | C 'EFTRUE'|An x-mesh (x(i), i=1, ..., n) plus a set of "true" e-fns of a C |given problem: abstractly, a matrix with rows labelled by k C |values, and columns by i which indexes the x(i). The k,i C |position holds u(x(i)) and pu'(x(i)) for the k-th e-fn. Again C |the k's are a subset of the current range KLO,KHI. They need C |have no relation to the k's of any "true" e-vs for the same C |problem. C | C 'SDTRUE'|A lambda-mesh (lambda(j), j=1, ..., m) plus a corresponding C |vector of "true" Spectral Density Function (SDF) values C |rho(lambda(j) of a given problem, and a vector of believed C |errors in these values. C | C --------+-------------------------------------------------------------- C Also 2 data objects not connected to an external file: C --------+-------------------------------------------------------------- C 'XMSHUN'|A "uniform" x-mesh C | C 'LMSHUN'|A "uniform" lambda-mesh C --------+-------------------------------------------------------------- C C Once an object has got a value, this value is not discarded till it C "has to be". This is for user convenience: meshes and "true" data act C as 'settings' that can be re-used many times. Just when a value is C discarded, is driven by what objects are used by different values of C Calculation-Choices setting CALSET, shown by the Y entries in this C Table below. C For each object we can also determine if 'no value is defined'. C This is shown by the logical expression in the "'Undefd' flag" column C in the table. C | USAGE | ID data |'Undefd' C CALSET = | 1 2 | 3 4 5 6 | 7 8 9 | | flag C ---------+------+------------+---------+------------------+----------+ C 'EVTRUE' | Y | Y | | %IPROB %KLO %KHI | %IPROB=-1 C 'EFTRUE' | | Y Y | | %IPROB %KLO %KHI | %IPROB=-1 C 'SDTRUE' | | | Y Y | %IPROB | %IPROB=-1 C ---------+------+------------+---------+------------------+----------+ C 'XMSHUN' | | Y | | none | %NMESH=-1 C 'LMSHUN' | | | Y | none | %NMESH=-1 C ---------+------+------------+---------+------------------+----------+ C where %IPROB in the ID data of 'EVTRUE' means a 'EVTRUE'%IPROB field C in the (conceptual) record 'EVTRUE'. C When the user invokes 'Solve' from the main menu the program checks C whether the object(s) required by the current CALSET have values that C are usable. C E.g if CALSET=6, the table shows 'EVTRUE' and 'EFTRUE' will be used. C For each, the "true" data cached within the program belongs to a C specific problem & k-range, so the program checks that the %IPROB C field *equals* the currently set IPROB and the %KLO:%KHI range C *contains* the currently set KLO:KHI (so that any "true" e-v, e-fn C data held on file for this k-range must be in the cache). If not, the C database is accessed. C C It is not necessary for any "true" values for this IPROB and k-range C to be present, but a valid x-mesh must be read, or the operation is C aborted. Other CALSET values are similar. C C The items with no ID data can be used *unconditionally* provided a C value is present (in case of 'XMSHUN' the program checks if the mesh C lies wholly within the current interval (A,B) and warns if not, but it C can use the mesh anyway). C C When the user invokes 'Display/change' from the main menu, the C program checks whether the object(s) required by the current CALSET C (1) have defined values, (2) are usable, and reports summary data. The C user then has the options C - update the object(s), as in case of 'Solve'. If this fails for any C object, the current value is left unchanged. (For CALSET=6, the C result may be that 'EVTRUE' is updated and 'EFTRUE' not, or v.v.) C - show values in more detail, if defined. E.g. for CALSET=5, the C x-mesh would be reported. For CALSET=6, each of "true" e-vs, x-mesh, C and "true" e-fn values can be requested. C C x-mesh design points C -------------------- C We expect users to wish to compare different e-fns on the *same* C x-mesh provided they come from the same Problem (same IPROB value) C in the following circumstances: C a. Different solver used C b. Changed e-v index C c. Changed BCs but same endpoints C d. Changed values of Problem-parameters C e. Changing the endpoints a,b from their "original" values. C C - For case d recall that changing parameters can change an C endpoint's classification, e.g. from regular to singular. C - For case e, recall an endpoint that is singular in the Problem C as originally posed can only be moved *inward* from its original C value, but an originally regular point can be moved in either C direction. C C Also, some solvers crash if an e-fn is evaluated *at* a singular C endpoint. But SLEDGE is explicitly designed not to do so, and in C fact the endpoints *must* be given it as part of any mesh, or it C will give an error exit. C C To cope with cases d,e above, SOLVIT *copies* the x-mesh passed to C it and alters it before passing it to the solver as follows. C Remove all points <=a and >=b (where a,b are the *current* C endpoints). Then add a (and similarly b) in the mesh if it is C regular (in particular if it has been moved inward from the C original a value), or if the solver is SLEDGE. The resulting mesh C is output from SOLVIT for use by REPORT. C C Inserting a,b like this improves the look of e-fn graphs! C C AUTO meshes are treated as if the mesh is formed by the SOLVIT call, C used in the REPORT call and forgotten. It can't be re-used; nor C displayed, except as part of the e-fn printout in REPORT. C C***+****|****+****| Details of module variables |****+****|****+****|** C DBPATH: Pathname relative to directory of executable program, where C data files are held. C Concrete storage representing 'EVTRUE': C QEVPRB,QEVKLO,QEVKHI: C 'ID-card' of "true" ev data currently cached in memory. C EVTRU: Row 1 holds "true" e-vs, row 2 holds believed absolute errors C Data for index k is in EVTRU(:,k-QEVKLO+1) C QEVTRU(K) says whether K-th "true" e-v is ABSENT or PRESNT C Ancillary data for 'EVTRUE', used for reporting C NEVBLK: No. of data blocks in file EVTRU.nn C IEVBLK: index of block chosen by user, in range 1:NEVBLK C Concrete storage representing 'EFTRUE': C QEFPRB,QEFKLO,QEFKHI: C 'ID-card' of "true" efn data currently cached in memory. C NXMTR: no. of points in XMSHTR C XMSHTR,EFTR,PDEFTR: C x-mesh, "true" values of u(x), pu'(x) on x-mesh for each k C QEFTRU(K) says whether K-th "true" e-fn is ABSENT or PRESNT C Ancillary data for 'EFTRUE', used for reporting C NEFBLK: No. of data blocks in file EFTRU.nn C IEFBLK: index of block chosen by user, in range 1:NEFBLK C Concrete storage representing 'SDTRUE': C QSDPRB: 'ID card' of lambda-mesh currently cached in memory C NLMTR: no. of points in lambda-mesh C LMSHTR,SDTRU C lambda-mesh, "true" values of SDF rho(lambda) on mesh C Ancillary data for 'SDTRUE', used for reporting C NSDBLK: No. of data blocks in file SDTRU.nn C ISDBLK: index of block chosen by user, in range 1:NSDBLK C Concrete storage representing 'XMSHUN': C NXMUN: no. of points in UNIForm x-mesh C XMSHUN UNIForm x-mesh C Concrete storage representing 'LMSHUN': C NLMUN: no. of points in UNIForm lambda-mesh C LMSHUN UNIForm lambda-mesh C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** character*40 DBPATH C 'EVTRUE': integer QEVPRB,QEVKLO,QEVKHI double precision EVTRU(1:2,1:MAXEVS) integer QEVTRU(1:MAXEVS) integer NEVBLK,IEVBLK C 'EFTRUE': integer:: QEFPRB,QEFKLO,QEFKHI integer NXMTR double precision XMSHTR(1:MAXMSH),EFTR(1:MAXMSH,1:MAXEVS) + ,PDEFTR(1:MAXMSH,1:MAXEVS) integer QEFTRU(1:MAXEVS) integer NEFBLK,IEFBLK C 'SDTRUE': integer QSDPRB integer NLMTR double precision LMSHTR(1:MAXMSH),SDTRU(1:2,1:MAXMSH) integer NSDBLK,ISDBLK C 'XMSHUN': integer NXMUN double precision XMSHUN(1:MAXMSH) C 'LMSHUN': integer NLMUN double precision LMSHUN(1:MAXMSH) C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function EVCHK(IPROB,KLO,KHI) integer IPROB,KLO,KHI EVCHK = QEVPRB.eq.IPROB .and. QEVKLO.eq.KLO .and. QEVKHI.eq.KHI end function EVCHK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function EFCHK(IPROB,KLO,KHI) integer IPROB,KLO,KHI EFCHK = QEFPRB.eq.IPROB .and. QEFKLO.eq.KLO .and. QEFKHI.eq.KHI end function EFCHK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function SDCHK(IPROB) integer IPROB SDCHK = QSDPRB.eq.IPROB end function SDCHK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DBINIT C Set initial state of 'EVTRUE', 'EFTRUE', 'SDTRUE', 'XMSHUN', 'LMSHUN' C to have no data. QEVPRB =-1 QEFPRB =-1 QSDPRB =-1 NXMUN = -1 NLMUN = -1 C and default k-range: does this make sense? QEVKLO = 0 QEVKHI = 9 QEFKLO = 0 QEFKHI = 9 end subroutine DBINIT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPEVTR(IPROB,KLO,KHI,FORCE) C UPEVTR updates DBMOD's 'EVTRUE'=(EVTRU,QEVTRU,QEVPRB,QEVKLO,QEVKHI). C All arguments are input. C If .not.FORCE and already present with 'ID'=(IPROB,KLO,KHI), nothing C is done. C If .not.FORCE and present with same IPROB & enclosing [KLO,KHI] it C doesn't read database file but shifts existing data appropriately. C Else, it gets from database file a block of "true" data with C this ID. C If no file exists, or user aborts, it returns without changing C anything. C It sets ancillary 'EVTRUE' info if it reads file or tries to: C NEVBLK=no. of blocks on data file, 0 if no file C IEVBLK=index. of user-selected block, 0 if no file or user-abort C .. Scalar arguments .. integer IPROB,KLO,KHI logical FORCE C .. Local scalars .. integer I,OFFSET if (QEVPRB.eq.IPROB .and. .not.FORCE) then if (QEVKLO.eq.KLO .and. QEVKHI.eq.KHI) return if (QEVKLO.le.KLO .and. QEVKHI.ge.KHI) then OFFSET = KLO-QEVKLO do 100 I=1,KHI-KLO+1 EVTRU(1,I) = EVTRU(1,I+OFFSET) EVTRU(2,I) = EVTRU(2,I+OFFSET) QEVTRU(I) = QEVTRU(I+OFFSET) 100 continue QEVKLO = KLO QEVKHI = KHI return end if end if C Else access database: call EVSCAN(IPROB,NEVBLK) IEVBLK = 0 if (NEVBLK.eq.0) return write(*,'(''Which block do you want (1 to'',i2, + ''), z to abort? '')',advance='NO') NEVBLK if (.not.GETIR(IEVBLK,1,NEVBLK)) return C Else OK with NEVBLK, IEVBLK both >0 so: C Reset 'EVTRUE's ID data QEVPRB = IPROB QEVKLO = KLO QEVKHI = KHI C Read the actual data: c print*,'UPEVTR calling EVDAT' call EVDAT(IPROB,KLO,KHI,EVTRU,QEVTRU) end subroutine UPEVTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPEFTR(IPROB,KLO,KHI,FORCE) C UPEFTR updates DBMOD's C 'EFTRUE'=(NXMTR,XMSHTR,EFTR,PDEFTR,QEFTRU,QEFPRB,QEFKLO,QEFKHI). C All arguments are input. C If .not.FORCE and already present with 'ID'=(IPROB,KLO,KHI), nothing C is done. C If .not.FORCE and present with same IPROB & *wider* k-range it C doesn't read database file but shifts existing data appropriately C to match the given k-range. C Else, it gets from database file a block of "true" data with C this ID. C If no file exists, or user aborts, it returns without changing C 'EFTRUE'. C It sets ancillary 'EFTRUE' info if it reads file or tries to: C NEFBLK=no. of blocks on data file, 0 if no file C IEFBLK=index. of user-selected block, 0 if no file or user-abort C .. Scalar arguments .. integer IPROB,KLO,KHI logical FORCE C .. Local scalars .. integer I,J,OFFSET if (QEFPRB.eq.IPROB .and. .not.FORCE) then if (QEFKLO.eq.KLO .and. QEFKHI.eq.KHI) return if (QEFKLO.le.KLO .and. QEFKHI.ge.KHI) then OFFSET = KLO-QEFKLO do 30 I=1,KHI-KLO+1 do 20 J=1,NXMTR EFTR(J,I) = EFTR(J,I+OFFSET) PDEFTR(J,I) = PDEFTR(J,I+OFFSET) QEFTRU(I) = QEFTRU(I+OFFSET) 20 continue 30 continue QEFKLO = KLO QEFKHI = KHI return end if end if C Else access database: call EFSCAN(IPROB,NEFBLK) IEFBLK = 0 if (NEFBLK.eq.0) return write(*,'(''Which block do you want (1 to'',i2, + ''), z to abort? '')',advance='NO') NEFBLK if (.not.GETIR(IEFBLK,1,NEFBLK)) return C Else OK with NEFBLK, IEFBLK both >0 so: C Reset 'EFTRUE's ID data QEFPRB = IPROB QEFKLO = KLO QEFKHI = KHI C Read the actual data: c print*,'UPEFTR calling EFDAT' call EFDAT(IPROB,KLO,KHI,NXMTR,XMSHTR,EFTR,PDEFTR,QEFTRU) end subroutine UPEFTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPSDTR(IPROB,FORCE) C All arguments are input. C UPSDTR updates DBMOD's 'SDTRUE'=(NLMTR,LMSHTR,SDTRU,QSDPRB). C If .not.FORCE and already present with 'ID'=(IPROB), nothing is done. C Else, it gets from database file a block of "true" data with C this ID. C If no file exists, or user aborts, it pretends it does and puts C empty info in 'SDTRUE'. C It sets ancillary 'SDTRUE' info if it reads file or tries to: C NSDBLK=no. of blocks on data file, 0 if no file C ISDBLK=index. of user-selected block, 0 if no file or user-abort C .. Scalar arguments .. integer IPROB logical FORCE if (QSDPRB.eq.IPROB .and. .not.FORCE) return C Else access database: call SDSCAN(IPROB,NSDBLK) ISDBLK = 0 if (NSDBLK.eq.0) return write(*,'(''Which block do you want (1 to'',i2, + ''), z to abort? '')',advance='NO') NSDBLK if (.not.GETIR(ISDBLK,1,NSDBLK)) return C Else OK with NSDBLK, ISDBLK both >0 so: C Reset 'SDTRUE's ID data QSDPRB = IPROB C Read the actual data: c print*,'UPSDTR calling SDDAT' call SDDAT(IPROB,NLMTR,LMSHTR,SDTRU) end subroutine UPSDTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPXMUN(FORCE) C Argument FORCE is input. C UPXMUN updates DBMOD's 'XMSHUN'=(NXMUN,XMSHUN). C It gets NXMSHI from user, default 10 if abort, forms uniform mesh of C NXMUN=NXMSHI+2 points in XMSHUN. C .. Scalar arguments .. logical FORCE C .. Local scalars .. integer NXMSHI double precision A,B if (NXMUN.le.0 .or. FORCE) then C extract current endpoints of SLP from module SLPSET call GTABCU(A,B) write(*,9991,advance='NO') MAXMSH-2 9991 format('How many interior points in x-mesh (not counting A,B)',/ + ' in range 10 to',i3,': ') if (.not. GETIR(NXMSHI,10,MAXMSH-2)) then NXMSHI = 10 write(*,'(3x,a)') 'No. of points set to default of 10' end if NXMUN = NXMSHI+2 write(*,'(3x,a,i3,a)') + 'Forming "UNIForm" mesh of ',NXMUN,' points' C Revised x-meshes spec means we always include A,B in UNIF mesh: call MKMESH(NXMUN,A,B,.TRUE.,.TRUE.,XMSHUN) end if end subroutine UPXMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPLMUN(FORCE) C Argument FORCE is input. C UPLMUN updates DBMOD's 'LMSHUN'=(NLMUN,LMSHUN). C It gets NLMUN from user, default 10 if abort, forms uniform mesh of C NLMUN points, over [LLO,LHI], in LMSHUN. If LLO or LHI is infinite, C it is excluded from the mesh but the no. of points stays the same. C .. Scalar arguments .. logical FORCE C .. Local scalars .. double precision LLO,LHI if (NLMUN.le.0 .or. FORCE) then write(*,9999,advance='NO') -XINFTY 9999 format('Give lower endpoint of lambda-mesh',/ + ' (use ',1p,d10.2,'for minus infinity: ') if (.not. GETR(LLO)) then LLO=0d0 write(*,*) ' Lower endpoint set to default of ',LLO end if write(*,9998,advance='NO') XINFTY 9998 format('Give upper endpoint of lambda-mesh',/ + ' (use ',1p,d10.2,'for plus infinity: ') if (.not. GETRR(LHI,LLO,XINFTY)) then LHI=XINFTY write(*,*) ' Upper endpoint set to default of ',LHI end if write(*,9991,advance='NO') MAXMSH 9991 format('How many points in lambda-mesh',/ + ' in range 1 to',i3,': ') if (.not. GETIR(NLMUN,1,MAXMSH)) then NLMUN = 10 write(*,*) 'No. of points set to default of ',NLMUN end if write(*,'(3x,a,i3,a)') + 'Forming "UNIForm" mesh of ',NLMUN,' points' call MKMESH(NLMUN,LLO,LHI,LLO.gt.-XINFTY,LHI.lt.XINFTY,LMSHUN) end if end subroutine UPLMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DIEVTR(IPROB,KLO,KHI) C DIEVTR displays DBMOD's 'EVTRUE'=(EVTRU,QEVTRU,QEVPRB,QEVKLO,QEVKHI). C Also ancillary 'EVTRUE' info C NEVBLK=no. of blocks on data file, 0 if no file C IEVBLK=index of user-selected block, 0 if no block selected C .. Scalar arguments .. integer IPROB,KLO,KHI C .. Local scalars .. integer IK,K if (QEVPRB.eq.-1) then write(*,*)'No "true" eigenvalue data is present' return end if write(*,*)'Stored "true" eigenvalue data is block ',IEVBLK, + ' of ',NEVBLK,' on file' if (QEVPRB.eq.IPROB) then if (QEVKLO.eq.KLO .and. QEVKHI.eq.KHI) then write(*,*) + 'Data matches current problem and k range' elseif (QEVKLO.le.KLO .and. QEVKHI.ge.KHI) then write(*,*) + 'Data matches current problem and ', + 'encloses current k range' else write(*,*) + 'Data matches current problem but ', + 'for different k range' end if else write(*,*) 'Data is not for current problem' end if write(*,*) 'Problem ',QEVPRB,' from k= ',KLO,' to k= ',KHI write(*,fmt="(3x,'K',5x,'Eigenvalue',13x,'Believed error')") do 100 K=KLO,KHI IK = K-KLO+1 if (QEVTRU(IK).eq.PRESNT) write(*, + fmt='(i4,3x,1p,g22.15,3x,d10.2)')K,EVTRU(1,IK),EVTRU(2,IK) 100 continue end subroutine DIEVTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DIEFTR(IPROB,KLO,KHI) C DIEFTR displays DBMOD's 'EFTRUE'= C (EFTR,PDEFTR,QEFTRU,QEFPRB,QEFKLO,QEFKHI). C Also ancillary 'EFTRUE' info C NEFBLK=no. of blocks on data file, 0 if no file C IEFBLK=index of user-selected block, 0 if no block selected C .. Scalar arguments .. integer IPROB,KLO,KHI C .. Local scalars .. integer IK,J,K if (QEFPRB.eq.-1) then write(*,*)'No x-mesh / "true" eigenfunction data is present' return end if write(*,*)'Stored "true" eigenfunction data is block ',IEFBLK, + ' of ',NEFBLK,' on file' if (QEFPRB.eq.IPROB) then if (QEFKLO.eq.KLO .and. QEFKHI.eq.KHI) then write(*,*) + 'Data matches current problem and k range' elseif (QEFKLO.le.KLO .and. QEFKHI.ge.KHI) then write(*,*) + 'Data matches current problem and ', + 'encloses current k range' else write(*,*) + 'Data matches current problem but ', + 'for different k range' end if else write(*,*) 'Data is not for current problem' end if write(*,*) 'Problem ',QEFPRB,' from k= ',KLO,' to k= ',KHI do 100 K=KLO,KHI IK = K-KLO+1 if (QEFTRU(IK).eq.PRESNT) then write(*,fmt=9999) K 9999 format (1x,'Stored Eigenfunction Values for k=',i4,/ + 1x,8x,'x u(x) pu''(x)') do 90 J=1,NXMTR write(*,fmt=9997)XMSHTR(J),EFTR(J,IK),PDEFTR(J,IK) 9997 format (1x,0p,f12.7,1p,2e18.10) 90 continue end if 100 continue end subroutine DIEFTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DISDTR(IPROB) C DISDTR displays DBMOD's 'SDTRUE'=(NLMTR,LMSHTR,SDTRU,QSDPRB). C Also ancillary 'SDTRUE' info C NSDBLK=no. of blocks on data file, 0 if no file C ISDBLK=index. of user-selected block, 0 if no file or user-abort C .. Scalar arguments .. integer IPROB C .. Local scalars .. integer I if (QSDPRB.eq.-1) then write(*,*) + 'No lambda-mesh / "true" spectral density data is present' return end if write(*,*)'Stored "true" spectral density data is block ', + ISDBLK,' of ',NSDBLK,' on file' if (QSDPRB.eq.IPROB) then write(*,*)'Data matches current problem' else write(*,*) 'Data is not for current problem' end if write(*,*) 'Problem ',QSDPRB write(*,fmt="(6x,'lambda',15x,'rho(lambda)',9x,'Believed error')") do 100 I=1,NLMTR write(*,fmt='(i2,3x,1p,2g22.15,3x,d10.2)') + I,LMSHTR(I),SDTRU(1,I),SDTRU(2,I) 100 continue end subroutine DISDTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DIXMUN() C DIXMUN displays DBMOD's 'XMSHUN'=(NXMUN,XMSHUN). C .. Local scalars .. integer I if (NXMUN.eq.-1) then write(*,*)'No "uniform" x-mesh data is present' return end if write(*,fmt=9999) NXMUN,XMSHUN(1),XMSHUN(NXMUN) 9999 format('Stored ''UNIForm'' x-mesh has',i3,' points from x =', + g10.5,' to x =',g10.5,/ + ' i x(i)') do 100 I=1,NXMUN write(*,fmt='(i3,3x,1p,g22.15)') I,XMSHUN(I) 100 continue end subroutine DIXMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DILMUN() C DILMUN displays DBMOD's 'LMSHUN'=(NLMUN,LMSHUN). C .. Local scalars .. integer I if (NLMUN.eq.-1) then write(*,*)'No "uniform" lambda-mesh data is present' return end if write(*,fmt=9999) NLMUN,LMSHUN(1),LMSHUN(NLMUN) 9999 format('Stored ''UNIForm'' lambda-mesh has',i3, + ' points from lambda =',g10.5,' to lambda =',g10.5,/ + ' i lambda(i)') do 100 I=1,NLMUN write(*,fmt='(i3,3x,1p,g22.15)') I,LMSHUN(I) 100 continue end subroutine DILMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTXMTR(NXMESH,XMESH) C GTXMTR tries to copy 'EFTRUE's x-mesh to NXMESH,XMESH. If this mesh C exists (QEFPRB>0), it copies it and returns TRUE, else it leaves C NXMESH,XMESH unchanged and returns FALSE. C .. Scalar arguments .. integer NXMESH C .. Array arguments .. double precision XMESH(1:MAXMSH) C .. Local scalars .. integer I if (QEFPRB.gt.0) then GTXMTR = .TRUE. NXMESH = NXMTR do 102 I=1,NXMESH XMESH(I) = XMSHTR(I) 102 continue return else GTXMTR = .FALSE. end if end function GTXMTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTXMUN(NXMESH,XMESH) C GTXMUN tries to copy 'XMSHUN's x-mesh to NXMESH,XMESH. If this mesh C exists (NXMUN>0), it copies it and returns TRUE, else it leaves C NXMESH,XMESH unchanged and returns FALSE. C .. Scalar arguments .. integer NXMESH C .. Array arguments .. double precision XMESH(1:MAXMSH) C .. Local scalars .. integer I if (NXMUN.gt.0) then GTXMUN = .TRUE. NXMESH = NXMUN do 102 I=1,NXMESH XMESH(I) = XMSHUN(I) 102 continue return else GTXMUN = .FALSE. end if end function GTXMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTLMTR(NLMESH,LMESH) C GTLMTR tries to copy 'SDTRUE's lambda-mesh to NLMESH,LMESH. If this mesh C exists (QSDPRB>0), it copies it and returns TRUE, else it leaves C NLMESH,LMESH unchanged and returns FALSE. C .. Scalar arguments .. integer NLMESH C .. Array arguments .. double precision LMESH(1:MAXMSH) C .. Local scalars .. integer I if (QSDPRB.gt.0) then GTLMTR = .TRUE. NLMESH = NLMTR do 102 I=1,NLMESH LMESH(I) = LMSHTR(I) 102 continue return else GTLMTR = .FALSE. end if end function GTLMTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTLMUN(NLMESH,LMESH) C GTLMUN tries to copy 'LMSHUN's lambda-mesh to NLMESH,LMESH. If this C mesh exists (NLMUN>0), it copies it and returns TRUE, else it leaves C NLMESH,LMESH unchanged and returns FALSE. C .. Scalar arguments .. integer NLMESH C .. Array arguments .. double precision LMESH(1:MAXMSH) C .. Local scalars .. integer I if (NLMUN.gt.0) then GTLMUN = .TRUE. NLMESH = NLMUN do 102 I=1,NLMESH LMESH(I) = LMSHUN(I) 102 continue return else GTLMUN = .FALSE. end if end function GTLMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine EVSCAN(IPROB,NBLOCK) integer IPROB,NBLOCK C EVSCAN scans the file of "true" eigenvalue data for Problem no. C IPROB in the current test set, & displays on-screen the description C line for each data-block in the file, also any Comment lines. C It returns NBLOCK=no. of blocks in file, or 0 if file doesn't C exist or has no data. C C The database for Problem no. nn (01<=nn<=60) is the textfile C EVTRU.nn C in directory "testset\truevals" where "testset" denotes the name of C current test set. It need not exist: if it does not, it is treated C as if it is empty. C C The file comprises a sequence of blocks, and may also have Comment C lines with C in column 1 (these must not occur in the middle of a C sequence of free-format data). C Each block starts with a record having letter B in column 1, the rest C of the line being treated as comment & displayed on screen. C E.g. B Evs with alpha=1, BCs u'(0)=0, u(pi)=0 C The block continues with a sequence of records with V in col. 1 C the rest of the line containing C Index k Eigenvalue eig_k Believed bound on absolute error C in free-format, with the k values >=0 and sorted in increasing order. C E.g. V 1 4.1234567890 2.0d-10 C indicates that we believe ev no. 1 equals 4.1234567890 with error at C most 2 units in the last place. C C Creating and adding to these files is the user's responsibility. C The log-file output from the program, using suitably high C accuracy, can often be trusted to provide the needed data. C C The file is identified by the Problem No. The individual data C blocks carry no identification of the parameter values, range A,B and C boundary conditions used, so if you use various values for these, C identify them by comment lines! The program can't understand the C comments, but displays them when it reads the file. C C Verifying the file is also the user's responsibility. In particular, C make sure the eigenvalue records for each block have C k's in ascending order. If records for a block are for k = 4 5 6 0 1 2 C in that order, and KLO..KHI is 2..5, then the routine will see the data C for k= 4 and 5, and miss that for k = 2. C C Algorithm summary: C Set block-count NBLOCK & record-count ILINE to 0 C Open input file, if it doesn't exist count as end-of-file C loop C Read record-type (=1st character of record) C exit loop on end-of-file C if 'C' (comment), read & display rest of line C elseif not 'X', skip record C else increase NBLOCK & read description line & display it C end if C end loop C close input file & return integer INFIL parameter(INFIL=18) integer IP, IREC, IOERR character FNAME*43, REC_ID*1, LINE*72 NBLOCK = 0 C Set FNAME to 'evtru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'evtru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) if (IOERR.ne.0) then write(*,'("! Database file ",a," not found",t79,"!")') + FNAME(1:IP) else write(*,'("! Reading database file ",a,t79,"!")') FNAME IREC = 0 C Main Loop over blocks, displaying B and V data for each: 150 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.lt.0 .or. REC_ID.eq.'E') goto 199 IREC = IREC+1 c print*, 'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,'(a)') LINE write(*,'("! ",a,t79,"!")') LINE elseif (REC_ID.ne.'B') then C skip rest of line: read(INFIL,*) else read(INFIL,'(a)') LINE NBLOCK = NBLOCK+1 write(*,'("! Block",i2,":",t79,"!",/ + "! ",a,t79,"!")') NBLOCK,LINE end if C end of loop goto 150 199 continue end if close(INFIL) end subroutine EVSCAN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine EVDAT(IPROB,KLO,KHI,EVTRU,QEVTRU) integer IBLOCK,IPROB,KLO,KHI,QEVTRU(KLO:KHI) double precision EVTRU(1:2,KLO:KHI) C EVDAT reads the file of "true" eigenvalue data for Problem no. C IPROB in the current test set, up to the IEVBLK-th block where IEVBLK C is a module variable. C EVDAT returns in EVTRU a list comprising those ev's in the block C whose index k lies in the range KLO..KHI. C C Specifically, if the database file for this problem doesn't exist C nothing is altered. Otherwise, on exit from EVDAT: C - For each ev in database whose k is in KLO..KHI: C EVTRU(1,K) holds eig_k; C EVTRU(2,K) holds a believed bound >=0 for the error in eig_k; C QEVTRU(K) holds the value PRESNT (=1) C - For each other k in KLO..KHI C QEVTRU(K) holds the value ABSENT (=0) C C Algorithm summary: C Open input file C loop C Read to IEVBLK-th 'B'-record as in EVSCAN C end loop C loop C Read record-type ('B' or 'V' expected but could be garbage) C if end-of-file then count it as record-type 'E' C else increase line-count C end if C if type is 'B' or 'E' C exit loop C elsif type 'V' C read V-data & insert in output arrays & display C else C ERROR message: unrecognized record-type C end if C end loop C Close input file integer IP, IREC, IOERR, K double precision EV,EVERR C! character FNAME*43, LINE*72, REC_ID*1 character FNAME*43, REC_ID*1 C Make this a fatal error becuse it should never happen, and if it does, C an array bound exception will soon occur in main program! if (KHI-KLO+1 .gt. MAXEVS) then write(*,'(/,a)') '*** EVDAT: Fatal error, KHI-KLO+1>MAXEVS' stop end if C Set FNAME to 'evtru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'evtru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) C Initialize ev-data status info do 20 K=KLO,KHI QEVTRU(K) = ABSENT 20 continue C C Now count up to IEVBLK-th block: IBLOCK = 0 IREC = 0 250 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID IREC = IREC+1 if (REC_ID.eq.'B') IBLOCK = IBLOCK+1 c print*,'IREC IBLOCK REC_ID: ',IREC,IBLOCK,REC_ID if (IBLOCK.ge.IEVBLK) goto 299 read(INFIL,*) goto 250 C Now we are at 2nd character of desired block, skip rest of line: 299 continue read(INFIL,'(a)') C Read V-data in the block, skipping comment lines but C terminating at any other record-type: write(*,'(t1,"! Block",i2,": K values",t79,"!")') IEVBLK 350 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.ne.0) REC_ID = 'E' IREC = IREC+1 c print*, 'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,*) goto 350 end if if (REC_ID.ne.'V') goto 900 read(INFIL,*,iostat=IOERR) K,EV,EVERR if (IOERR.ne.0) then write(*,*) write(*,*)'***EVDAT: error reading V-data at record',IREC elseif (K.ge.KLO .and. K.le.KHI) then EVTRU(1,K) = EV EVTRU(2,K) = EVERR QEVTRU(K) = PRESNT write(*,fmt='(i5)',advance='NO') K end if goto 350 900 write(*,*) close(INFIL) write(*,*)'... Done' end subroutine EVDAT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine EFSCAN(IPROB,NBLOCK) integer IPROB,NBLOCK C EFSCAN scans the file of "true" eigenfunction data for Problem no. C IPROB in the current test set, & displays on-screen the Mesh C belonging to each data-block in the file, also any Comment lines. C It returns NBLOCK=no. of blocks in file, or 0 if file doesn't C exist or has no data. C C The database for Problem no. nn (01<=nn<=60) is the textfile C EFTRU.nn C in directory "testset\truevals" where "testset" denotes the name of C current test set. It need not exist: if it does not, it is treated C as if it is empty. C C The file comprises a sequence of blocks, and may also have Comment C lines with C in column 1 (these must not occur in the middle of a C sequence of free-format data). C Each block starts with a record having letter X in column 1 C and continuing with the free-format data (which can spill over onto C further lines) C m x(1) ... x(m) C i.e. the value of NMESH and the points x(i) of the mesh. C C Convention: C x(1) may be given as -1.0d35 and x(m) as 1.0d35 (SLTSTPAK's C values for -infinity, +infinity), these will be set by the code C to the current value of a resp. b. C C Restrictions: C If you are setting up meshes to experiment with, you can do what you C like! But if setting up "true" eigenfunction values for general C use, observe these rules to avoid situations which some solvers C can't handle: C 1. a <= x(1) < x(2) < ... < x(m) <= b C where a, b are the endpoints of the problem (the current ones, which C may have been changed from the default ones!) C 2.Equality at either end is forbidden UNLESS that end is regular or C weakly regular (of type 'R' or 'WR' in SLTSTPAK). Of course any C end that has been moved inward from the default end is of type 'R'. C NOTE this excludes, for instance, x=-1, x=1 being included in "true" C data for the Legendre equation (Standard#20) even though all C efns (for the default BCs) are polynomials, and finite at these C points. C The rest of the block is a sequence of records having letter U in C column 1 and continuing with free-format data C k u(1) pu'(1) ... u(m) pu'(m) C i.e. the eigenvalue index k and the values of the k-th eigenfunction C u_k(x) and derivative p(x)u_k'(x) at the points x=x(i) of the mesh. C An example block is (with the X and U's assumed to be in col 1) C C This is a sample block C X 5 1.000 1.500 2.000 2.500 3.000 C U 0 0.12345678 1.3567890 C 0.35673892 0.2121212 C 0.50012098 0 C 0.35673892 -0.2121212 C 0.12345678 -1.3567890 C C Creating and adding to these files is the user's responsibility. C The log-file output from the program, using suitably high C accuracy, can sometimes be trusted to provide the needed data: C but often it can't! Codes' eigenfunction values are still erratic. C C The file is identified by the Problem No. The individual data C blocks carry no identification of the parameter values, range A,B and C boundary conditions used, so if you use various values for these, C identify them by comment lines! The program can't understand the C comments, but displays them when it reads the file. C C Verifying the file is also the user's responsibility. In particular, C make sure the eigenfunction records (U-records) for each block have C k's in ascending order. If U-records for a block are for k = 4 5 6 0 1 2 C in that order, and KLO..KHI is 2..5, then the routine will see the data C for k= 4 and 5, and miss that for k = 2. C C Algorithm summary: C Set block-count NBLOCK & record-count ILINE to 0 C Open input file, if it doesn't exist count as end-of-file C loop C Read record-type (=1st character of record) C exit loop on end-of-file C if 'C' (comment), read & display rest of line C elseif not 'X', skip record C else increase NBLOCK & read mesh & display it C end if C end loop C close input file & return integer IP, IREC, IOERR, J, NMESH double precision XMSHTR(1:MAXMSH) character FNAME*43, REC_ID*1, LINE*72 NBLOCK = 0 C Set FNAME to 'eftru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'eftru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) if (IOERR.ne.0) then write(*,'("! Database file ",a," not found",t79,"!")') + FNAME(1:IP) else write(*,'("! Reading database file ",a,t79,"!")') FNAME IREC = 0 C Main Loop over blocks, displaying X and U data for each: 150 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.lt.0 .or. REC_ID.eq.'E') goto 199 IREC = IREC+1 c write(*,*)'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,'(a)') LINE write(*,'("! ",a,t79,"!")') LINE elseif (REC_ID.ne.'X') then C skip rest of line: read(INFIL,*) else read(INFIL,*,iostat=IOERR) NMESH * ,(XMSHTR(J),J=1,MIN(NMESH,MAXMSH)) if (IOERR.ne.0) then write(*,*)'*** EFSCAN: error reading X-data at record' * ,IREC else NBLOCK = NBLOCK+1 write(*,'("! Block",i2,":",t79,"!")') NBLOCK if (NMESH.gt.MAXMSH) then write(*,*)'Mesh specified with',NMESH,' points,', * ' reduced to maximum allowed:',MAXMSH NMESH = MAXMSH end if write(*,'("! has mesh of",i3," points:",t79,"!")') NMESH write(*,'("!",t79,"!",t4,1p6e12.4)')(XMSHTR(J),J=1,NMESH) end if end if C end of loop goto 150 199 continue end if close(INFIL) end subroutine EFSCAN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine EFDAT(IPROB,KLO,KHI,NXMTR,XMSHTR,EFTR,PDEFTR,QEFTRU) integer IBLOCK,IPROB,KLO,KHI,NXMTR,QEFTRU(KLO:KHI) double precision EFTR(1:MAXMSH,KLO:KHI), * PDEFTR(1:MAXMSH,KLO:KHI),XMSHTR(1:MAXMSH) C EFDAT reads the file of "true" eigenfunction data for Problem no. C IPROB in the current test set, up to the IEFBLK-th block where IEFBLK C is a module variable, and returns in XMSHTR (starting at C XMSHTR(1)) the x-mesh for that block, in EFTR a list of vectors C comprising the values on the x-mesh of those eigenfunctions in the C block for which data exists and whose index k lies in the range C KLO..KHI, in PDEFTR the corresponding derivative values. QEFTRU(K) C says whether data for index K is present. C C Specifically, on exit from EFDAT C NXMTR holds no. of points in x-mesh of user-chosen block C XMSHTR(1:NXMTR) holds their values C while for each such k, as above: C EFTR(k,1:NXMTR) holds values of k-th eigenfunction on mesh C PDEFTR(k,1:NXMTR) holds values of k-th eigenfunction on mesh C QEFTRU(k) holds the value PRESNT (=1) C For each other k in KLO..KHI C QEFTRU(k) holds the value ABSENT (=0) C C Algorithm summary: C Open input file C loop C Read to IEFBLK-th 'X'-record as in EFSCAN C end loop C Read X-mesh & store C loop C Read record-type ('X' or 'U' expected but could be garbage) C if end-of-file then count it as record-type 'E' C else increase line-count C end if C if type is 'X' or 'E' C exit loop C elsif type 'U' C read U-data & insert in output arrays & display C else C ERROR message: unrecognized record-type C end if C end loop C Close input file integer IP, IREC, IOERR, J, K double precision U(1:MAXMSH),PDU(1:MAXMSH) character FNAME*43, REC_ID*1 C Set FNAME to 'eftru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'eftru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) C Make this a fatal error becuse it should never happen if (IOERR.ne.0 .or. IEFBLK.le.0) then write(*,*) + '*** EFDAT: Fatal error, cannot open file or Block no. <= 0' stop end if C Make this a fatal error becuse it should never happen, and if it does, C an array bound exception will soon occur in main program! if (KHI-KLO+1 .gt. MAXEVS) then write(*,*)'*** EFDAT: Fatal error, KHI-KLO+1>MAXEVS' stop end if C Initialize e-fn data status info: do 20 K=KLO,KHI QEFTRU(K) = ABSENT 20 continue C C Now count up to IEFBLK-th block: IBLOCK = 0 IREC = 0 250 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID IREC = IREC+1 if (REC_ID.eq.'X') IBLOCK = IBLOCK+1 c print*,'IREC IBLOCK REC_ID: ',IREC,IBLOCK,REC_ID if (IBLOCK.ge.IEFBLK) goto 299 read(INFIL,*) goto 250 C Now we are at 2nd character of desired block: 299 continue read(INFIL,*,iostat=IOERR) NXMTR * ,(XMSHTR(J),J=1,MIN(NXMTR,MAXMSH)) c print*,'NXMTR: ',NXMTR if (IOERR.ne.0) then write(*,*)'EFDAT: error reading X-data at record',IREC else if (NXMTR.gt.MAXMSH) then NXMTR = MAXMSH end if end if C Read U-data in the block, skipping comment lines but C terminating at any other record-type: write(*,'(t1,"! Block",i2,": K values",t79,"!")') IEFBLK 350 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.ne.0) REC_ID = 'E' IREC = IREC+1 c write(*,*)'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,*) goto 350 end if if (REC_ID.ne.'U') goto 900 read(INFIL,*,iostat=IOERR) K,(U(J),PDU(J),J=1,NXMTR) if (IOERR.ne.0) then write(*,*)'EFDAT: error reading U-data at record',IREC elseif (K.ge.KLO .and. K.le.KHI) then do 400 J=1,NXMTR EFTR(J,K) = U(J) PDEFTR(J,K) = PDU(J) 400 continue QEFTRU(K) = PRESNT write(*,fmt='(i5)',advance='NO') K end if goto 350 900 write(*,*) c print*,'exit EFDAT: NXMTR=',NXMTR close(INFIL) write(*,*)'... Done' end subroutine EFDAT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SDSCAN(IPROB,NBLOCK) integer IPROB,NBLOCK C SDSCAN scans the file of "true" data for Spectral Density Function C (SDF) rho(lambda) of Problem no. IPROB in the current test set, & C displays on-screen the description line for each data-block in the C file, also any Comment lines. It returns NBLOCK=no. of blocks in file, C or 0 if file doesn't exist or has no data. C C The database for Problem no. nn (01<=nn<=60) is the textfile C SDTRU.nn C in directory "testset\truevals" where "testset" denotes the name of C current test set. It need not exist: if it does not, it is treated C as if it is empty. C C The file comprises a sequence of blocks, and may also have Comment C lines with C in column 1 (these must not occur in the middle of a C sequence of free-format data). C Each block starts with a record having letter B in column 1, the rest C of the line being treated as comment & displayed on screen. C E.g. B Problem with lambda-dependent BC coeffs = 1 0 0 1 C The block continues with a sequence of records with R in col. 1 C the rest of the line containing C lambda rho(lambda) Believed bound on absolute error C in free-format, with the lambda values sorted in increasing order. C E.g. R 0.5 0.7324 2d-4 C indicates that we believe rho(0.5) equals 0.7324 with error at C most 2 units in the last place. C C Creating and adding to these files is the user's responsibility. C C The file is identified by the Problem No. The individual data C blocks carry no identification of the parameter values, range A,B and C boundary conditions used, so if you use various values for these, C identify them by comment lines! The program can't understand the C comments, but displays them when it reads the file. C C Verifying the file is also the user's responsibility. In particular, C make sure the SDF records for each block have lambda's in ascending C order. C C Algorithm summary: C Set block-count NBLOCK & record-count ILINE to 0 C Open input file, if it doesn't exist count as end-of-file C loop C Read record-type (=1st character of record) C exit loop on end-of-file C if 'C' (comment), read & display rest of line C elseif not 'B', skip record C else increase NBLOCK & read description line & display it C end if C end loop C close input file & return integer IP, IREC, IOERR character FNAME*43, REC_ID*1, LINE*72 NBLOCK = 0 C Set FNAME to 'sdtru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'sdtru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) if (IOERR.ne.0) then write(*,'("! Database file ",a," not found",t79,"!")') + FNAME(1:IP) else write(*,'("! Reading database file ",a,t79,"!")') FNAME IREC = 0 C Main Loop over blocks, displaying B and R data for each: 150 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.lt.0 .or. REC_ID.eq.'E') goto 199 IREC = IREC+1 c print*, 'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,'(a)') LINE write(*,'("! ",a,t79,"!")') LINE elseif (REC_ID.ne.'B') then C skip rest of line: read(INFIL,*) else read(INFIL,'(a)') LINE NBLOCK = NBLOCK+1 write(*,'("! Block",i2,":",t79,"!",/ + "! ",a,t79,"!")') NBLOCK,LINE end if C end of loop goto 150 199 continue end if close(INFIL) end subroutine SDSCAN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SDDAT(IPROB,NLMTR,LMSHTR,SDTRU) integer IPROB,NLMTR double precision LMSHTR(1:MAXMSH),SDTRU(1:2,1:MAXMSH) C SDDAT reads the file of "true" SDF data for Problem no. IPROB in the C current test set, up to the ISDBLK-th block where ISDBLK is a module C variable. C SDDAT returns in LMSHTR a mesh of lambda values in ascending order, in C SDTRU(1,:) the corresponding SDF values rho(lambda) and in SDTRU(2,:), C believed bounds on the absolute errors in the SDF values. C C If the database file for this problem doesn't exist nothing is C altered. C C Algorithm summary: C Open input file C loop C Read to ISDBLK-th 'B'-record as in SDSCAN C end loop C loop C Read record-type ('B' or 'R' expected but could be garbage) C if end-of-file then count it as record-type 'E' C else increase line-count C end if C if type is 'B' or 'E' C exit loop C elsif type 'R' C read R-data & insert in output arrays & display C else C ERROR message: unrecognized record-type C end if C end loop C Close input file integer IBLOCK, IP, IREC, IOERR double precision LAMBDA, SD,SDERR character FNAME*43, LINE*72, REC_ID*1 logical RECOK C Set FNAME to 'sdtru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'sdtru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) C C Now count up to ISDBLK-th block: IBLOCK = 0 IREC = 0 250 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID IREC = IREC+1 if (REC_ID.eq.'B') IBLOCK = IBLOCK+1 c print*,'IREC IBLOCK REC_ID: ',IREC,IBLOCK,REC_ID if (IBLOCK.ge.ISDBLK) goto 299 read(INFIL,*) goto 250 C Now we are at 2nd character of desired block: 299 continue read(INFIL,'(a)') LINE write(*,'(t1,"! Block",i2,": lambda values",t79,"!")') ISDBLK C Read R-data in the block, skipping comment lines but C terminating at any other record-type: NLMTR = 0 350 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.ne.0) REC_ID = 'E' IREC = IREC+1 c print*, 'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,*) goto 350 end if if (REC_ID.ne.'R') goto 900 RECOK = .TRUE. read(INFIL,*,iostat=IOERR) LAMBDA,SD,SDERR if (IOERR.ne.0) then RECOK = .FALSE. write(*,*)'*** SDDAT: error reading R-data at record',IREC elseif (NLMTR .ge. MAXMSH) then RECOK = .FALSE. write(*,*)'SDDAT: more than ',MAXMSH, + ' values in SDF Data Block, excess ignored' elseif (NLMTR.gt.0) then if (LAMBDA.le.LMSHTR(NLMTR)) then RECOK = .FALSE. write(*,*)'SDDAT: lambda value ',LAMBDA, + ' in SDF Data Block not in asc. order will be ignored' end if end if if (RECOK) then NLMTR = NLMTR+1 LMSHTR(NLMTR) = LAMBDA SDTRU(1,NLMTR) = SD SDTRU(2,NLMTR) = SDERR write(*,fmt='(1pg10.4)',advance='NO') LAMBDA end if goto 350 900 write(*,*) close(INFIL) write(*,*)'... Done' end subroutine SDDAT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DBSUMM use SAFEIO C Crude routine to display ID information for cached data print*,'EVTRUE:' print*,' QEVPRB,QEVKLO,QEVKHI=',QEVPRB,QEVKLO,QEVKHI C double precision EVTRU(1:2,1:MAXEVS) print*,' QEVTRU(1:QEVKHI-QEVKLO+1)=',QEVTRU(1:QEVKHI-QEVKLO+1) print*,' NEVBLK,IEVBLK=',NEVBLK,IEVBLK print*,'EFTRUE:' print*,' QEFPRB,QEFKLO,QEFKHI=',QEFPRB,QEFKLO,QEFKHI print*,' NXMTR=',NXMTR print*,' XMSHTR(1:NXMTR)=',XMSHTR(1:NXMTR) C + ,EFTR(1:MAXMSH,1:MAXEVS),PDEFTR(1:MAXMSH,1:MAXEVS) print*,' QEFTRU(1:QEFKHI-QEFKLO+1)=',QEFTRU(1:QEFKHI-QEFKLO+1) print*,' NEFBLK,IEFBLK=',NEFBLK,IEFBLK print*,'SDTRUE:' print*,' QSDPRB=',QSDPRB print*,' NLMTR=',NLMTR print*,' LMSHTR(1:NLMTR)=',LMSHTR(1:NLMTR) print*,' NSDBLK,ISDBLK=',NSDBLK,ISDBLK print*,'XMSHUN:' print*,' NXMUN=',NXMUN print*,' XMSHUN(1:NXMUN)=',XMSHUN(1:NXMUN) print*,'LMSHUN:' print*,' NLMUN=',NLMUN print*,' LMSHUN(1:NLMUN)=',LMSHUN(1:NLMUN) call SPAUSE end subroutine DBSUMM end module DBMOD SHAR_EOF fi # end of overwriting check if test -f 'errflags.hlp' then echo shar: will not over-write existing file "'errflags.hlp'" else cat << SHAR_EOF > 'errflags.hlp' For information on error exits from the solvers: SLEIGN see source code SL\SLEIGN\SLEIGN.FOR SLEDGE see source code SL\SLEDGE\SLEDGE.FOR SL02F see source code of SL02F in SL\MARCOPAK\MARCOPK1.FOR SLEIGN2 see formats 9010 onward in source text of SL\SLEIGN2\EXTRAS\DRIVE.F Also lines 93 onward (re IFLAG values) in SL\SLEIGN2\SLEIGN2D.FOR though the info there does not seem to be complete. D02KEF see SL\D02KEF\D02KEF.DOC (the NAG online help file) SHAR_EOF fi # end of overwriting check if test -f 'evsimp.f' then echo shar: will not over-write existing file "'evsimp.f'" else cat << SHAR_EOF > 'evsimp.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** C A simple driver to show the use of SLTSTPAK. It uses SL02F as solver. C The problem-set is arbitrary and can be chosen at link-time. program EVSIMP use SLTSTPAK use MARCOMOD implicit none integer IWK,NTEMP parameter (IWK=10000,NTEMP=400) double precision A,A1,A2,B,B1,B2,CURREN,ELAPSE,TOL,XINFTY integer I,IFAIL,IPROB,K,N,NEPRM,NPARM,NPROB,KNOBS(3) logical SYM character ATYPE*4,BTYPE*4,PARNM*72,TITLE*72,TSETNM*8 double precision ELAM(0:1),PARM(0:10),WK(0:IWK,1:4), + WKSMAL(0:NTEMP,1:7) data KNOBS/3*0/ common/SL02CM/ AINFO,BINFO character AINFO*1,BINFO*1 external GETBC C SOLVER-INDEPENDENT STARTUP PHASE C Call the general initialization routine: call TSTINI(TSETNM,NPROB,XINFTY) C Select the Problem write (*,FMT='('' Problem number (1 to'',i3,''): '')') NPROB read (*,FMT=*) IPROB C Call the first section of set-up code: call SETUP0(IPROB,TITLE,NPARM,NEPRM,PARNM) C Write the problem title and ask for parameters if any: write (*,FMT=*) TITLE if (NPARM.gt.0) then write (*,FMT=*) 'Give values of these parameters: ', PARNM read (*,FMT=*) (PARM(I),I=1,NPARM) end if C Call the second section of set-up code: call SETUP1(PARM,A,B,ATYPE,BTYPE,A1,A2,B1,B2,SYM) C Set eigenvalue index & tolerance: write (*,FMT='('' Eigenvalue index: '')') read (*,FMT=*) K write (*,FMT='('' Tolerance: '')') read (*,FMT=*) TOL C SOLVER-SPECIFIC CODE C Give initial guess of ELAM(0) & its error: ELAM(0) = 0d0 ELAM(1) = 1d0 C Convert information about endpoints into form needed by SL02F: call TRANSL(A.ne.-XINFTY,ATYPE,AINFO) call TRANSL(B.ne.XINFTY,BTYPE,BINFO) C Give max no. of meshpoints to be used by SL02F N = 3000 C Select soft failure option: IFAIL = -1 C Set the CPU clock running: call CPU(0,CURREN,ELAPSE) C Solve the problem: call SL02F(ELAM,A,B,K,AINFO,BINFO,SYM,TOL,COEFFN,GETBC,N,WK,IWK, + WKSMAL,NTEMP,KNOBS,IFAIL) C Read the CPU clock: call CPU(1,CURREN,ELAPSE) C Report results: write (*,FMT=*) 'Final estimate of eigenvalue:',ELAM(0) write (*,FMT='('' Error estimate:'',1pd9.2)') ELAM(1) write (*,FMT=*) 'Number of function evaluations:',NEVAL(0) write (*,FMT=*) 'Number of meshpoints used during solution:',N write (*,FMT=*) 'Exit value of IFAIL:',IFAIL write (*,FMT='('' CPU time (sec): '',f10.5)') ELAPSE if (IFAIL.ne.0) write (*,FMT=*) ' WARNING: IFAIL IS NONZERO ' end subroutine TRANSL(XFINIT,XTYPE,XINFO) C Translates SLTSTPAK endpoint-type info into SL02F form. logical XFINIT character XINFO*1,XTYPE*4 if (XTYPE.eq.'R ' .or. XTYPE.eq.'RS ') then XINFO = 'R' else if (XFINIT) then XINFO = 'S' else XINFO = 'I' end if end subroutine GETBC(Y,PDY,EIG,X,IEND,ISING) C GETBC interfaces between SL02F and GETBCS, putting the arguments in a C different order. It also extracts the ISING data via SL02CM. use SLTSTPAK,only:GETBCS implicit none double precision EIG,PDY,X,Y integer IEND logical ISING common/SL02CM/ AINFO,BINFO character AINFO*1,BINFO*1 call GETBCS(IEND,X,EIG,PDY,Y) if (IEND.eq.0) then ISING = AINFO.ne.'R' else ISING = BINFO.ne.'R' end if end SHAR_EOF fi # end of overwriting check if test -f 'initpuff.hlp' then echo shar: will not over-write existing file "'initpuff.hlp'" else cat << SHAR_EOF > 'initpuff.hlp' _|\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/|_ >Now with added Spectral Density!< -|/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\|- Don't forget the playback facility (try BSTANDRD < PLAYBACK.DAT after a run of STANDARD) SHAR_EOF fi # end of overwriting check if test -f 'playback.dat' then echo shar: will not over-write existing file "'playback.dat'" else cat << SHAR_EOF > 'playback.dat' 1 .1 6 0 10 7 1d-8 8 1 2 8 1 3 1 4 0 7 0 4 6 9 10 15 y 1 3 1 2 1 1 y 0 7 2 48 8 0 100 11 z y SHAR_EOF fi # end of overwriting check if test -f 'safeio.f' then echo shar: will not over-write existing file "'safeio.f'" else cat << SHAR_EOF > 'safeio.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** module SAFEIO logical:: PLAYBK=.FALSE. integer, parameter:: IPBK=19 contains C***+****|****+****|**SAFEIO package***|****+****|****+****|****+****|** C Simple 'secure, abortable interactive input' routines C C The following are logical functions which return values through C the argument list and also C either C .TRUE. through the function name meaning 'successful input' C and the input value(s) through its (first) argument C or C .FALSE. through the function name meaning 'aborted by user' C The routines are C GETI(X) - get one Integer value X C GETR(X) - get one Real value X C GETIR(X,XLO,XHI) - get one Integer value X in a Range C GETRR(X,XLO,XHI) - get one Real value X in a Range C GETIS(X,NX) - get NX integer values into array X C GETRS(X,NX) - get NX real values into array X C C The user is to signal 'abort' by typing z or Z (followed by Enter) C C The following is a non-abortable routine requiring a yes/no answer C YESNO() - character*1 function, returns either 'y' or 'n' C The following non-abortable routine waits for ENTER to be pressed C SPAUSE() C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine OPNPBK integer IOERR open(IPBK,file='playback.dat', status='REPLACE', action='WRITE', + iostat=IOERR) if (IOERR.eq.0) then PLAYBK = .TRUE. else write(*,*) 'Unable to open playback-file unit',IPBK, + ', file playback.out, IOSTAT=',IOERR write(*,*) 'It may be in use by another process?' PLAYBK = .FALSE. call SPAUSE end if end subroutine OPNPBK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine CLOPBK close(IPBK) end subroutine CLOPBK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETI(X) implicit none C .. Scalar Arguments .. integer X character*80 LINE C 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETI = .FALSE. else read (LINE,FMT=*,ERR=30) X GETI = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') go to 10 end function GETI C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETR(X) implicit none C .. Scalar Arguments .. double precision X character*80 LINE C .. 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETR = .FALSE. else read (LINE,FMT=*,ERR=30) X GETR = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Real value required, please retype: '')') go to 10 end function GETR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETIR(X,XLO,XHI) implicit none C .. Scalar Arguments .. integer X,XHI,XLO C .. character*80 LINE C .. 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETIR = .FALSE. else read (LINE,FMT=*,ERR=30) X if (X.lt.XLO .or. X.gt.XHI) go to 40 GETIR = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') go to 10 40 write (*,FMT=45) XLO,XHI 45 format(1x,'***Not in range',i9,' :',i9,', please retype: ') go to 10 end function GETIR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETRR(X,XLO,XHI) implicit none C .. Scalar Arguments .. double precision X,XHI,XLO C .. character*80 LINE C .. 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETRR = .FALSE. else read (LINE,FMT=*,ERR=30) X if (X.lt.XLO .or. X.gt.XHI) go to 40 GETRR = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') go to 10 40 write (*,FMT=45) XLO,XHI 45 format(1x,'***Not in range',i9,' :',i9,', please retype: ') go to 10 end function GETRR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETIS(X,NX) implicit none C .. Scalar Arguments .. integer NX C .. C .. Array Arguments .. integer X(NX) C .. C .. Local Scalars .. integer I character*80 LINE C .. I = 1 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETIS = .FALSE. else read (LINE,FMT=*,ERR=30) (X(I),I=I,NX) GETIS = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT=35) I 35 format + ('***Integer values required, please retype from item',i2,': ') go to 10 end function GETIS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETRS(X,NX) implicit none C .. Scalar Arguments .. integer NX C .. C .. Array Arguments .. double precision X(NX) C .. C .. Local Scalars .. integer I character*80 LINE C .. I = 1 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETRS = .FALSE. else read (LINE,FMT=*,ERR=30) (X(I),I=I,NX) GETRS = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT=35) I 35 format + ('***Real values required, please retype from item',i2,': ') go to 10 end function GETRS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** character*1 function YESNO(ASK) implicit none character*(*) ASK C .. Local Scalars .. character YN C .. write(*,'(a)',advance='NO') ASK 10 read (*,FMT='(a)',END=40,ERR=30) YN if (PLAYBK) write(IPBK,'(a)') YN if (YN.eq.'y' .or. YN.eq.'Y') then YESNO = 'y' else if (YN.eq.'n' .or. YN.eq.'N') then YESNO = 'n' else go to 30 end if return 30 write (*,ADVANCE='NO', + FMT='(1x,''***Please type one of y,Y,n,N: '')') go to 10 40 write (*,*) 'Don''t use end-of-file,', + ' it means end of run in most F90 & some F77 systems' write (*,*) 'Sorry!' stop end function YESNO C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SPAUSE write (*,ADVANCE='NO',FMT='(a)') 'Press ENTER to continue' read (*,FMT=*,END=100,ERR=100) 100 return end subroutine SPAUSE C***+****|****+****|****end of SAFEIO package****|****+****|****+****|** end module SAFEIO SHAR_EOF fi # end of overwriting check if test -f 'sample.lst' then echo shar: will not over-write existing file "'sample.lst'" else cat << SHAR_EOF > 'sample.lst' Contents of Test Set sample No. 1:Simple equation -u" = lambda u No parameters No. 2:transformed -u''=lambda u Parms NU, must be >0 No. 3:Branko Curgus2: -y''=lambda x y on [-1,1] No parameters No. 4:-u''=lambda u with a lambda-dependent BC Parms A1', A2' where (A1+lam*A1')u(a)=(A2+lam*A2')pu'(a) No. 5:Branko Curgus4: -(sign(x)y')'=lambda sign(x) y on [-1,1] No parameters No. 6:Klaus 1: -(y'/2)'+(x^2/8(x<0),x^2/2(x>=0)y = lambda y No parameters No. 7:Simple equation -u" = lambda u with u = A1*x+A2 near 0 No parameters No. 8:Another transformed version of Hinz problem No parameters No. 9:Transformed Hinz prob, -(xu')' + x cos(x) u = lambda x u No parameters No.10:Hinz problem -u" + (cos(x) - 1/(4x^2))u = lambda u No parameters SHAR_EOF fi # end of overwriting check if test -f 'samplrun.dat' then echo shar: will not over-write existing file "'samplrun.dat'" else cat << SHAR_EOF > 'samplrun.dat' 1 1 1 .1 6 0 10 7 1d-8 8 1 2 8 1 3 8 1 4 8 0 7 0 4 6 9 10 8 15 y 1 3 8 1 2 8 1 1 8 y 0 7 2 48 8 0 100 11 z y SHAR_EOF fi # end of overwriting check if test -f 'samplrun.out' then echo shar: will not over-write existing file "'samplrun.out'" else cat << SHAR_EOF > 'samplrun.out' ******************************************************************************* * * * SLDRIVER Version 4.1 June 1998 * * John Pryce's Driver for Sturm-Liouville solvers * * * * Running with Problem Set "standard" of 60 problems * * * * and the following 4 Solvers: * * sledge sleign sl02f sleig2 * * * ******************************************************************************* NOTE: Typing z or Z followed by ENTER aborts any data-input operation * ************************Help from file INITPUFF.hlp************************ * * * * _|\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/|_ * * >Now with added Spectral Density!< * * -|/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\|- * * * * Don't forget the playback facility * * (try BSTANDRD < PLAYBACK.DAT after a run of STANDARD) * ******************************************************************************* Press ENTER to continue * ************************Help from file SLHELP0.hlp************************* * * Each problem in a SLTSTPAK collection comes equipped not only with its * * differential equation * * -(p(x)u')' + q(x)u = lambda w(x) u * * but also with a default interval of solution a0, 0.1 gives standard problem in book):.1 Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sledge 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 0 7 Give tolerance 1.00D-04 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 6 Give eigenvalue index range klo,khi (0<=klo<=khi): 0 10 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sledge 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-04 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 7 Give tolerance (>0): 1d-8 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sledge 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 8 Appending to log-file standard\sledge01.m Appending to log-file standard\sledge01.aux *************** CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED *************** Each dot represents 1000 function evaluations: ................... Classification of endpoint A: Regular=T, LC =T, Nonosc all EV=T, Osc all EV=F Classification of endpoint B: Regular=T, LC =T, Nonosc all EV=T, Osc all EV=F Press ENTER to continue ******************************* SOLUTION REPORT ******************************* TESTSET: standard, PROBLEM: 1, SOLVER: sledge, COMPUTE EVs only Parameter values: 0.10000000D+00 Endpoints: A = 0.00000000D+00 B = 3.14159274D+00 Tolerance: 1.00D-08 BCs: A1= 1.00000000D+00 B1= 1.00000000D+00 A2= 0.00000000D+00 B2= 0.00000000D+00 ******************************************************************************* K Eigenvalue IFAIL Absolute error (if error exit) (est.) ("true") 0 1.51986570966322 1.52D-08 1 4.94330954740783 4.94D-08 2 10.2846620699319 1.03D-07 3 17.5599567718135 1.76D-07 4 26.7828616641988 2.68D-07 5 37.9644237349692 3.80D-07 6 51.1133548807423 5.11D-07 7 66.2364439283165 6.62D-07 8 83.3389576011478 8.33D-07 9 102.424982507869 1.02D-06 10 123.497699702064 1.23D-06 CPU secs: 0.2230, No. of function evaluations: 19434 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sledge 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 1 Choose Solver from: 1=sledge 2=sleign 3=sl02f 4=sleig2 2 Solver is now sleign Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleign 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 8 Appending to log-file standard\sleign01.m Appending to log-file standard\sleign01.aux *************** CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED *************** Each dot represents 1000 function evaluations: .................................................. .................................... ******************************* SOLUTION REPORT ******************************* TESTSET: standard, PROBLEM: 1, SOLVER: sleign, COMPUTE EVs only Parameter values: 0.10000000D+00 Endpoints: A = 0.00000000D+00 B = 3.14159274D+00 Tolerance: 1.00D-08 BCs: A1= 1.00000000D+00 B1= 1.00000000D+00 A2= 0.00000000D+00 B2= 0.00000000D+00 ******************************************************************************* K Eigenvalue IFAIL Absolute error (if error exit) (est.) ("true") 0 1.51986573879753 2.59D-09 1 4.94330955395447 3.03D-09 2 10.2846620853148 8.61D-09 3 17.5599567894801 5.53D-08 4 26.7828616919003 2.72D-09 5 37.9644237814058 3.69D-08 6 51.1133549523295 6.13D-08 7 66.2364440606829 3.52D-08 8 83.3389577853615 9.87D-08 9 102.424982748196 1.04D-07 10 123.497699985661 9.62D-08 CPU secs: 1.3830, No. of function evaluations: 86334 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleign 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 1 Choose Solver from: 1=sledge 2=sleign 3=sl02f 4=sleig2 3 Solver is now sl02f Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sl02f 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 8 Appending to log-file standard\sl02f01.m Appending to log-file standard\sl02f01.aux *************** CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED *************** Each dot represents 1000 function evaluations: .. K= 0 , error flag = 0 , no. of mesh intervals used= 924 .. K= 1 , error flag = 0 , no. of mesh intervals used= 924 .. K= 2 , error flag = 0 , no. of mesh intervals used= 902 .. K= 3 , error flag = 0 , no. of mesh intervals used= 888 .. K= 4 , error flag = 0 , no. of mesh intervals used= 862 .. K= 5 , error flag = 0 , no. of mesh intervals used= 836 .. K= 6 , error flag = 0 , no. of mesh intervals used= 806 .. K= 7 , error flag = 0 , no. of mesh intervals used= 776 . K= 8 , error flag = 0 , no. of mesh intervals used= 742 .. K= 9 , error flag = 0 , no. of mesh intervals used= 712 .. K= 10 , error flag = 0 , no. of mesh intervals used= 686 ******************************* SOLUTION REPORT ******************************* TESTSET: standard, PROBLEM: 1, SOLVER: sl02f , COMPUTE EVs only Parameter values: 0.10000000D+00 Endpoints: A = 0.00000000D+00 B = 3.14159274D+00 Tolerance: 1.00D-08 BCs: A1= 1.00000000D+00 B1= 1.00000000D+00 A2= 0.00000000D+00 B2= 0.00000000D+00 ******************************************************************************* K Eigenvalue IFAIL Absolute error (if error exit) (est.) ("true") 0 1.51986573885000 2.81D-07 1 4.94330955386542 4.33D-07 2 10.2846620852457 4.30D-07 3 17.5599567879978 2.29D-07 4 26.7828616929723 -5.05D-08 5 37.9644237809068 -2.99D-07 6 51.1133549508912 -1.34D-07 7 66.2364440605307 -9.95D-08 8 83.3389577857126 1.83D-07 9 102.424982750525 8.64D-07 10 123.497699982258 1.44D-06 CPU secs: 1.4880, No. of function evaluations: 21228 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sl02f 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 1 Choose Solver from: 1=sledge 2=sleign 3=sl02f 4=sleig2 4 Solver is now sleig2 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleig2 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 8 Appending to log-file standard\sleig201.m Appending to log-file standard\sleig201.aux *************** CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED *************** Each dot represents 1000 function evaluations: Each + represents 1000 calls to SLEIGN2's UV routine: alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.2033197E+01 tmid= 0.00000000 z= 0.1255030E+01 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.20331968785880E+01 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.6425517E+00 dthde= 0.1301379E+01 thetal= 0.1635287E+01 thetar= 0.9927356E+00 eigrt= 0.15394501443964E+01 eigup= 0.20331968785880E+01 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.2428426E+00 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.18298771907292E+01 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.3801282E+00 dthde= 0.1273892E+01 thetal= 0.1525592E+01 thetar= 0.1145464E+01 eigrt= 0.15314780078177E+01 eigup= 0.18298771907292E+01 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.1630706E+00 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.14717981712353E+01 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.5556058E-01 dthde= 0.1144730E+01 thetal= 0.1354209E+01 thetar= 0.1409770E+01 eigrt= 0.15314780078177E+01 eigup= 0.18298771907292E+01 eiglt= 0.15203341530355E+01 eiglo= 0.14717981712353E+01 converge= F estim. acc.= 0.3297734E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.15188979132504E+01 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.1129090E-02 dthde= 0.1166417E+01 thetal= 0.1375090E+01 thetar= 0.1376219E+01 eigrt= 0.15314780078177E+01 eigup= 0.18298771907292E+01 eiglt= 0.15198659114654E+01 eiglo= 0.15188979132504E+01 converge= F estim. acc.= 0.6373030E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.15198659114654E+01 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= 0.2100330E-06 dthde= 0.1166851E+01 thetal= 0.1375524E+01 thetar= 0.1375524E+01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.15188979132504E+01 eps= 0.200E-06 tmid= 0.000E+00 dtheta= -0.1129098E-02 dthde= 0.1166417E+01 thetal= 0.1375090E+01 thetar= 0.1376219E+01 eigrt= 0.00000000000000E+00 eigup= 0.10098082799680E+03 eiglt= 0.15198659182649E+01 eiglo= 0.15188979132504E+01 converge= F estim. acc.= 0.6373075E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.15208339232794E+01 eps= 0.200E-06 tmid= 0.000E+00 dtheta= 0.1129938E-02 dthde= 0.1167285E+01 thetal= 0.1375959E+01 thetar= 0.1374829E+01 eigrt= 0.15198659179925E+01 eigup= 0.15208339232794E+01 eiglt= 0.15198659182649E+01 eiglo= 0.15188979132504E+01 converge= F estim. acc.= 0.6364964E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.15198657381424E+01 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.7949219E-10 dthde= 0.1166851E+01 thetal= 0.1375524E+01 thetar= 0.1375524E+01 eigrt= 0.15198659179925E+01 eigup= 0.15208339232794E+01 eiglt= 0.15198657382106E+01 eiglo= 0.15198657381424E+01 converge= T numeig= 0 eig= 0.15198657381424E+01 tol= 0.448E-10 ray= 0.15198657382106E+01 psil= 0.81064723529710E+00 psir= 0.81064723529710E+00 psipl= 0.20123166005619E+00 psipr= 0.20123165997216E+00 sql= 0.38470881947385E+00 sqr= -0.61529118052615E+00 K = 0 done . alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.5786969E+01 tmid= 0.00000000 z= 0.2248531E+01 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.57869693397449E+01 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.5620395E+00 dthde= 0.6029259E+00 thetal= 0.3143767E+01 thetar= -0.5598651E+00 eigrt= 0.48547826409595E+01 eigup= 0.57869693397449E+01 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.1610837E+00 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.52082724057704E+01 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.1895123E+00 dthde= 0.6902855E+00 thetal= 0.2943599E+01 thetar= -0.3875056E+00 eigrt= 0.49337304573152E+01 eigup= 0.52082724057704E+01 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.5271267E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.46874451651934E+01 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.1965301E+00 dthde= 0.7956733E+00 thetal= 0.2735313E+01 thetar= -0.2097491E+00 eigrt= 0.49337304573152E+01 eigup= 0.52082724057704E+01 eiglt= 0.49344436424853E+01 eiglo= 0.46874451651934E+01 converge= F estim. acc.= 0.5269362E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.49435182108952E+01 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.1533905E-03 dthde= 0.7412012E+00 thetal= 0.2841108E+01 thetar= -0.3006383E+00 eigrt= 0.49433112623974E+01 eigup= 0.49435182108952E+01 eiglt= 0.49344436424853E+01 eiglo= 0.46874451651934E+01 converge= F estim. acc.= 0.4186259E-04 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.49433112623974E+01 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= -0.4449691E-08 dthde= 0.7412434E+00 thetal= 0.2841025E+01 thetar= -0.3005677E+00 eigrt= 0.49433112623974E+01 eigup= 0.49435182108952E+01 eiglt= 0.49433112684004E+01 eiglo= 0.49433112623974E+01 converge= T numeig= 1 eig= 0.49433112623974E+01 tol= 0.121E-08 ray= 0.49433112684004E+01 psil= 0.22932618899621E+00 psir= 0.22932618899621E+00 psipl= -0.16636003046755E+01 psipr= -0.16636003308523E+01 sql= 0.54034760420860E+00 sqr= -0.45965239579140E+00 K = 1 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.1142859E+02 tmid= 0.00000000 z= 0.3233214E+01 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.11428587965395E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.5688856E+00 dthde= 0.5036688E+00 thetal= 0.4714058E+01 thetar= -0.2138013E+01 eigrt= 0.10299104549778E+02 eigup= 0.11428587965395E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.9882966E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10285729168856E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.5218749E-03 dthde= 0.4885031E+00 thetal= 0.4441057E+01 thetar= -0.1842650E+01 eigrt= 0.10284660854505E+02 eigup= 0.10285729168856E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.1038637E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10283592540155E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.5218337E-03 dthde= 0.4884647E+00 thetal= 0.4440559E+01 thetar= -0.1842104E+01 eigrt= 0.10284660854505E+02 eigup= 0.10285729168856E+02 eiglt= 0.10284660854134E+02 eiglo= 0.10283592540155E+02 converge= F estim. acc.= 0.1038853E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10284660833252E+02 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= -0.4072009E-10 dthde= 0.4884839E+00 thetal= 0.4440808E+01 thetar= -0.1842377E+01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10285729168856E+02 eps= 0.200E-06 tmid= 0.000E+00 dtheta= 0.5212702E-03 dthde= 0.4885129E+00 thetal= 0.4441059E+01 thetar= -0.1842647E+01 eigrt= 0.10284662113800E+02 eigup= 0.10285729168856E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.1037413E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10283595058744E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.5212293E-03 dthde= 0.4884746E+00 thetal= 0.4440562E+01 thetar= -0.1842102E+01 eigrt= 0.10284662113800E+02 eigup= 0.10285729168856E+02 eiglt= 0.10284662113824E+02 eiglo= 0.10283595058744E+02 converge= F estim. acc.= 0.1037628E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10284662092888E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.2964295E-11 dthde= 0.4884938E+00 thetal= 0.4440811E+01 thetar= -0.1842375E+01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10285729168856E+02 eps= 0.400E-09 tmid= 0.000E+00 . dtheta= 0.5212741E-03 dthde= 0.4885130E+00 thetal= 0.4441059E+01 thetar= -0.1842647E+01 eigrt= 0.10284662105843E+02 eigup= 0.10285729168856E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.1037421E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10283595042831E+02 eps= 0.400E-09 tmid= 0.000E+00 .. dtheta= -0.5212332E-03 dthde= 0.4884746E+00 thetal= 0.4440562E+01 thetar= -0.1842102E+01 eigrt= 0.10284662105843E+02 eigup= 0.10285729168856E+02 eiglt= 0.10284662105846E+02 eiglo= 0.10283595042831E+02 converge= F estim. acc.= 0.1037636E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10284662084926E+02 eps= 0.400E-09 tmid= 0.000E+00 .. dtheta= -0.3195222E-12 dthde= 0.4884938E+00 thetal= 0.4440811E+01 thetar= -0.1842375E+01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10285729168856E+02 eps= 0.800E-12 tmid= 0.000E+00 ..... dtheta= 0.5212741E-03 dthde= 0.4885130E+00 thetal= 0.4441059E+01 thetar= -0.1842647E+01 eigrt= 0.10284662105834E+02 eigup= 0.10285729168856E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.1037421E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10283595042813E+02 eps= 0.800E-12 tmid= 0.000E+00 ..... dtheta= -0.5212332E-03 dthde= 0.4884746E+00 thetal= 0.4440562E+01 thetar= -0.1842102E+01 eigrt= 0.10284662105834E+02 eigup= 0.10285729168856E+02 eiglt= 0.10284662105837E+02 eiglo= 0.10283595042813E+02 converge= F estim. acc.= 0.1037636E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10284662084917E+02 eps= 0.800E-12 tmid= 0.000E+00 ..... dtheta= -0.2970957E-12 dthde= 0.4884938E+00 thetal= 0.4440811E+01 thetar= -0.1842375E+01 eigrt= 0.10284662105834E+02 eigup= 0.10285729168856E+02 eiglt= 0.10284662084917E+02 eiglo= 0.10284662084917E+02 converge= T numeig= 2 eig= 0.10284662084917E+02 tol= 0.591E-13 ...... ray= 0.10284662084917E+02 psil= -0.76654348748369E+00 psir= -0.76654348748369E+00 psipl= -0.69013013874989E+00 psipr= -0.69013013874910E+00 sql= 0.47694471711292E+00 sqr= -0.52305528288708E+00 K = 2 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.1896040E+02 tmid= 0.00000000 z= 0.4202391E+01 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.18960404440584E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.5116058E+00 dthde= 0.3476906E+00 thetal= 0.6282623E+01 thetar= -0.3653761E+01 eigrt= 0.17488964623858E+02 eigup= 0.18960404440584E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.7760593E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.17243879628651E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.1231808E+00 dthde= 0.3945558E+00 thetal= 0.5950349E+01 thetar= -0.3351248E+01 eigrt= 0.17488964623858E+02 eigup= 0.18960404440584E+02 eiglt= 0.17556080771554E+02 eiglo= 0.17243879628651E+02 converge= F estim. acc.= 0.1810504E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.17566526610737E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.2532428E-02 dthde= 0.3846990E+00 thetal= 0.6016277E+01 thetar= -0.3411034E+01 eigrt= 0.17559943727871E+02 eigup= 0.17566526610737E+02 eiglt= 0.17556080771554E+02 eiglo= 0.17243879628651E+02 converge= F estim. acc.= 0.3747402E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.17559943727871E+02 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= -0.5604636E-06 dthde= 0.3848973E+00 thetal= 0.6014947E+01 thetar= -0.3409830E+01 eigrt= 0.17559943727871E+02 eigup= 0.17566526610737E+02 eiglt= 0.17559945184009E+02 eiglo= 0.17559943727871E+02 converge= F estim. acc.= 0.8292384E-07 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.17559945184009E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.2071099E-10 dthde= 0.3848973E+00 thetal= 0.6014948E+01 thetar= -0.3409830E+01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.17559943727871E+02 eps= 0.200E-06 tmid= 0.000E+00 dtheta= -0.5040938E-05 dthde= 0.3848984E+00 thetal= 0.6014943E+01 thetar= -0.3409830E+01 eigrt= 0.00000000000000E+00 eigup= 0.10098082799680E+03 eiglt= 0.17559956824673E+02 eiglo= 0.17559943727871E+02 converge= F estim. acc.= 0.7458339E-06 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.17559969921475E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= 0.5040928E-05 dthde= 0.3848976E+00 thetal= 0.6014948E+01 thetar= -0.3409835E+01 eigrt= 0.17559956824672E+02 eigup= 0.17559969921475E+02 eiglt= 0.17559956824673E+02 eiglo= 0.17559943727871E+02 converge= F estim. acc.= 0.7458329E-06 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.17559956824680E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= 0.4352074E-13 dthde= 0.3848980E+00 thetal= 0.6014946E+01 thetar= -0.3409832E+01 eigrt= 0.17559956824679E+02 eigup= 0.17559956824680E+02 eiglt= 0.17559956824673E+02 eiglo= 0.17559943727871E+02 converge= T numeig= 3 eig= 0.17559956824680E+02 tol= 0.644E-14 . ray= 0.17559956824679E+02 psil= -0.20839206351914E+00 psir= -0.20839206351914E+00 psipl= 0.31861050890239E+01 psipr= 0.31861050890233E+01 sql= 0.52476543728545E+00 sqr= -0.47523456271455E+00 K = 3 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.2837577E+02 tmid= 0.00000000 z= 0.5178581E+01 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.28375771970028E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.4926808E+00 dthde= 0.3118217E+00 thetal= 0.7851555E+01 thetar= -0.5207496E+01 eigrt= 0.26795763834569E+02 eigup= 0.28375771970028E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.5568159E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.26440571584841E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.1045249E+00 dthde= 0.3046071E+00 thetal= 0.7557602E+01 thetar= -0.4904244E+01 eigrt= 0.26795763834569E+02 eigup= 0.28375771970028E+02 eiglt= 0.26783718182413E+02 eiglo= 0.26440571584841E+02 converge= F estim. acc.= 0.1297803E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.26781497432827E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.4214342E-03 dthde= 0.3061262E+00 thetal= 0.7608720E+01 thetar= -0.4957229E+01 eigrt= 0.26795763834569E+02 eigup= 0.28375771970028E+02 eiglt= 0.26782874101187E+02 eiglo= 0.26781497432827E+02 converge= F estim. acc.= 0.5140371E-04 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.26782874101187E+02 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= 0.8197400E-08 dthde= 0.3061323E+00 thetal= 0.7608927E+01 thetar= -0.4957444E+01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.26781497432827E+02 eps= 0.200E-06 tmid= 0.000E+00 dtheta= -0.4176524E-03 dthde= 0.3061229E+00 thetal= 0.7608724E+01 thetar= -0.4957229E+01 eigrt= 0.00000000000000E+00 eigup= 0.10098082799680E+03 eiglt= 0.26782861762335E+02 eiglo= 0.26781497432827E+02 converge= F estim. acc.= 0.5094299E-04 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.26784226091842E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= 0.4176690E-03 dthde= 0.3061349E+00 thetal= 0.7609134E+01 thetar= -0.4957655E+01 eigrt= 0.26782861762223E+02 eigup= 0.26784226091842E+02 eiglt= 0.26782861762335E+02 eiglo= 0.26781497432827E+02 converge= F estim. acc.= 0.5093780E-04 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.26782861748776E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.8524736E-11 dthde= 0.3061289E+00 thetal= 0.7608929E+01 thetar= -0.4957442E+01 eigrt= 0.26782861762223E+02 eigup= 0.26784226091842E+02 eiglt= 0.26782861748804E+02 eiglo= 0.26782861748776E+02 converge= T numeig= 4 eig= 0.26782861748776E+02 tol= 0.104E-11 . ray= 0.26782861748804E+02 psil= 0.77049516788852E+00 psir= 0.77049516788852E+00 psipl= 0.99783271553143E+00 psipr= 0.99783271549529E+00 sql= 0.49091947122265E+00 sqr= -0.50908052877735E+00 K = 4 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.3966355E+02 tmid= 0.00000000 z= 0.6141552E+01 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.39663549754851E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.4261589E+00 dthde= 0.2436139E+00 thetal= 0.9413922E+01 thetar= -0.6720201E+01 eigrt= 0.37914228689634E+02 eigup= 0.39663549754851E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.4410400E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.37622125379864E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.8907200E-01 dthde= 0.2618699E+00 thetal= 0.9148111E+01 thetar= -0.6470781E+01 eigrt= 0.37914228689634E+02 eigup= 0.39663549754851E+02 eiglt= 0.37962263696576E+02 eiglo= 0.37622125379864E+02 converge= F estim. acc.= 0.9040912E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.37968653033205E+02 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= 0.1090139E-02 dthde= 0.2585117E+00 thetal= 0.9194692E+01 thetar= -0.6514361E+01 eigrt= 0.37964436051570E+02 eigup= 0.37968653033205E+02 eiglt= 0.37962263696576E+02 eiglo= 0.37622125379864E+02 converge= F estim. acc.= 0.1110648E-03 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.37964436051570E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.8054332E-07 dthde= 0.2585522E+00 thetal= 0.9194129E+01 thetar= -0.6513834E+01 eigrt= 0.37964436051570E+02 eigup= 0.37968653033205E+02 eiglt= 0.37964436363087E+02 eiglo= 0.37964436051570E+02 converge= T numeig= 5 eig= 0.37964436051570E+02 tol= 0.821E-08 ray= 0.37964436363087E+02 psil= 0.18141840635157E+00 psir= 0.18141840635157E+00 psipl= -0.47447023463369E+01 psipr= -0.47447040634544E+01 sql= 0.51671040514621E+00 sqr= -0.48328959485379E+00 K = 5 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.5285558E+02 tmid= 0.00000000 z= 0.7097782E+01 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.52855580631542E+02 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= 0.3910798E+00 dthde= 0.2256889E+00 thetal= 0.1097480E+02 thetar= -0.8265833E+01 eigrt= 0.51122753635881E+02 eigup= 0.52855580631542E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.3278418E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.50800183178938E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.6977224E-01 dthde= 0.2224778E+00 thetal= 0.1074605E+02 thetar= -0.8033733E+01 eigrt= 0.51122753635881E+02 eigup= 0.52855580631542E+02 eiglt= 0.51113797517175E+02 eiglo= 0.50800183178938E+02 converge= F estim. acc.= 0.6173488E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.51112582238069E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.1805295E-03 dthde= 0.2230451E+00 thetal= 0.1078054E+02 thetar= -0.8068837E+01 eigrt= 0.51122753635881E+02 eigup= 0.52855580631542E+02 eiglt= 0.51113391623473E+02 eiglo= 0.51112582238069E+02 converge= F estim. acc.= 0.1583535E-04 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.51113391623473E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.5451113E-08 dthde= 0.2230466E+00 thetal= 0.1078063E+02 thetar= -0.8068928E+01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.51112582238069E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.1723620E-03 dthde= 0.2230428E+00 thetal= 0.1078055E+02 thetar= -0.8068835E+01 eigrt= 0.00000000000000E+00 eigup= 0.10098082799680E+03 eiglt= 0.51113355013671E+02 eiglo= 0.51112582238069E+02 converge= F estim. acc.= 0.1511909E-04 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.51114127789273E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= 0.1723642E-03 dthde= 0.2230456E+00 thetal= 0.1078072E+02 thetar= -0.8069009E+01 eigrt= 0.51113355013651E+02 eigup= 0.51114127789273E+02 eiglt= 0.51113355013671E+02 eiglo= 0.51112582238069E+02 converge= F estim. acc.= 0.1511863E-04 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.51113355011260E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.1087130E-11 dthde= 0.2230442E+00 thetal= 0.1078063E+02 thetar= -0.8068922E+01 eigrt= 0.51113355013651E+02 eigup= 0.51114127789273E+02 eiglt= 0.51113355011265E+02 eiglo= 0.51113355011260E+02 converge= T numeig= 6 eig= 0.51113355011260E+02 tol= 0.954E-13 . ray= 0.51113355011265E+02 psil= -0.77648467819488E+00 psir= -0.77648467819488E+00 psipl= -0.12031929517936E+01 psipr= -0.12031929517873E+01 sql= 0.49560658560154E+00 sqr= -0.50439341439846E+00 K = 6 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.6791252E+02 tmid= 0.00000000 z= 0.8090250E+01 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.67912517879561E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.3200878E+00 dthde= 0.1877232E+00 thetal= 0.1253079E+02 thetar= -0.9780443E+01 eigrt= 0.66207412670473E+02 eigup= 0.67912517879561E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.2510738E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.65904781071303E+02 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= -0.6470899E-01 dthde= 0.1957923E+00 thetal= 0.1233395E+02 thetar= -0.9592491E+01 eigrt= 0.66207412670473E+02 eigup= 0.67912517879561E+02 eiglt= 0.66235279268673E+02 eiglo= 0.65904781071303E+02 converge= F estim. acc.= 0.5014783E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.66238844740745E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.4636143E-03 dthde= 0.1943789E+00 thetal= 0.1236731E+02 thetar= -0.9624298E+01 eigrt= 0.66236459635078E+02 eigup= 0.66238844740745E+02 eiglt= 0.66235279268673E+02 eiglo= 0.65904781071303E+02 converge= F estim. acc.= 0.3600766E-04 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.66236459635078E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.1785574E-08 dthde= 0.1943890E+00 thetal= 0.1236708E+02 thetar= -0.9624072E+01 eigrt= 0.66236459635078E+02 eigup= 0.66238844740745E+02 eiglt= 0.66236459644263E+02 eiglo= 0.66236459635078E+02 converge= T numeig= 7 eig= 0.66236459635078E+02 tol= 0.139E-09 . ray= 0.66236459644263E+02 psil= -0.15786977708479E+00 psir= -0.15786977708479E+00 psipl= 0.63235754415375E+01 psipr= 0.63235754997220E+01 sql= 0.51192695490666E+00 sqr= -0.48807304509334E+00 K = 7 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.8485584E+02 tmid= 0.00000000 z= 0.9070132E+01 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.84855840073865E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.2654300E+00 dthde= 0.1755944E+00 thetal= 0.1408185E+02 thetar= -0.1131632E+02 eigrt= 0.83344232181804E+02 eigup= 0.84855840073865E+02 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.1781383E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.83072943337187E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.4635543E-01 dthde= 0.1740900E+00 thetal= 0.1392662E+02 thetar= -0.1115977E+02 eigrt= 0.83344232181804E+02 eigup= 0.84855840073865E+02 eiglt= 0.83339216078745E+02 eiglo= 0.83072943337187E+02 converge= F estim. acc.= 0.3205288E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.83338617907483E+02 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= -0.7020759E-04 dthde= 0.1743326E+00 thetal= 0.1394965E+02 thetar= -0.1118303E+02 eigrt= 0.83344232181804E+02 eigup= 0.84855840073865E+02 eiglt= 0.83339020629589E+02 eiglo= 0.83338617907483E+02 converge= F estim. acc.= 0.4832359E-05 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.83339020629589E+02 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.5647269E-08 dthde= 0.1743329E+00 thetal= 0.1394968E+02 thetar= -0.1118306E+02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.83338617907483E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.5926409E-04 dthde= 0.1743393E+00 thetal= 0.1394966E+02 thetar= -0.1118303E+02 eigrt= 0.00000000000000E+00 eigup= 0.10098082799680E+03 eiglt= 0.83338957842726E+02 eiglo= 0.83338617907483E+02 converge= F estim. acc.= 0.4078964E-05 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.83339297777970E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= 0.5926430E-04 dthde= 0.1743400E+00 thetal= 0.1394971E+02 thetar= -0.1118309E+02 eigrt= 0.83338957842695E+02 eigup= 0.83339297777970E+02 eiglt= 0.83338957842726E+02 eiglo= 0.83338617907483E+02 converge= F estim. acc.= 0.4078931E-05 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.83338957842405E+02 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.1362466E-11 dthde= 0.1743397E+00 thetal= 0.1394968E+02 thetar= -0.1118306E+02 eigrt= 0.83338957842695E+02 eigup= 0.83339297777970E+02 eiglt= 0.83338957842413E+02 eiglo= 0.83338957842405E+02 converge= T numeig= 8 eig= 0.83338957842405E+02 tol= 0.938E-13 . ray= 0.83338957842413E+02 psil= 0.78129912912642E+00 psir= 0.78129912912642E+00 psipl= 0.13443772574555E+01 psipr= 0.13443772574455E+01 sql= 0.49761486623259E+00 sqr= -0.50238513376741E+00 K = 8 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.1035578E+03 tmid= 0.00000000 z= 0.1005315E+02 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10355779471644E+03 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= 0.1750327E+00 dthde= 0.1533055E+00 thetal= 0.1562284E+02 thetar= -0.1282653E+02 eigrt= 0.10241607018205E+03 eigup= 0.10355779471644E+03 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.1102500E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10220965418637E+03 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.3358110E-01 dthde= 0.1562105E+00 thetal= 0.1551669E+02 thetar= -0.1272406E+02 eigrt= 0.10241607018205E+03 eigup= 0.10355779471644E+03 eiglt= 0.10242462755023E+03 eiglo= 0.10220965418637E+03 converge= F estim. acc.= 0.2103259E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10242564769673E+03 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.1082043E-03 dthde= 0.1557344E+00 thetal= 0.1553384E+02 thetar= -0.1274060E+02 eigrt= 0.10242495289660E+03 eigup= 0.10242564769673E+03 eiglt= 0.10242462755023E+03 eiglo= 0.10220965418637E+03 converge= F estim. acc.= 0.6783459E-05 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10242495289660E+03 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= 0.7136212E-09 dthde= 0.1557360E+00 thetal= 0.1553378E+02 thetar= -0.1274055E+02 eigrt= 0.10242495289202E+03 eigup= 0.10242495289660E+03 eiglt= 0.10242462755023E+03 eiglo= 0.10220965418637E+03 converge= T numeig= 9 eig= 0.10242495289660E+03 tol= 0.447E-10 ray= 0.10242495289202E+03 psil= 0.13850155543576E+00 psir= 0.13850155543576E+00 psipl= -0.79128886446502E+01 psipr= -0.79128886115657E+01 sql= 0.50890378351191E+00 sqr= -0.49109621648809E+00 K = 9 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.1244331E+03 tmid= 0.00000000 z= 0.1104653E+02 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12443312259113E+03 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.1339584E+00 dthde= 0.1434482E+00 thetal= 0.1718050E+02 thetar= -0.1436939E+02 eigrt= 0.12349927734179E+03 eigup= 0.12443312259113E+03 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.7504796E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12331191651888E+03 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= -0.2656054E-01 dthde= 0.1428847E+00 thetal= 0.1710045E+02 thetar= -0.1428891E+02 eigrt= 0.12349927734179E+03 eigup= 0.12443312259113E+03 eiglt= 0.12349780435382E+03 eiglo= 0.12331191651888E+03 converge= F estim. acc.= 0.1507460E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12349762157398E+03 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.1708341E-04 dthde= 0.1429822E+00 thetal= 0.1711369E+02 thetar= -0.1430222E+02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12331191651888E+03 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.2655522E-01 dthde= 0.1428882E+00 thetal= 0.1710046E+02 thetar= -0.1428892E+02 eigrt= 0.00000000000000E+00 eigup= 0.10098082799680E+03 eiglt= 0.12349776264177E+03 eiglo= 0.12331191651888E+03 converge= F estim. acc.= 0.1507122E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12368360876467E+03 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= 0.2659085E-01 dthde= 0.1430794E+00 thetal= 0.1712695E+02 thetar= -0.1431556E+02 eigrt= 0.12349776192593E+03 eigup= 0.12368360876467E+03 eiglt= 0.12349776264177E+03 eiglo= 0.12331191651888E+03 converge= F estim. acc.= 0.1502599E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12349769997651E+03 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.2632965E-07 dthde= 0.1429841E+00 thetal= 0.1711370E+02 thetar= -0.1430223E+02 eigrt= 0.12349776192593E+03 eigup= 0.12368360876467E+03 eiglt= 0.12349770016065E+03 eiglo= 0.12349769997651E+03 converge= T numeig= 10 eig= 0.12349769997651E+03 tol= 0.149E-08 .. ray= 0.12349770016065E+03 psil= -0.78487346623043E+00 psir= -0.78487346623043E+00 psipl= -0.14442650592767E+01 psipr= -0.14442648246607E+01 sql= 0.49859824010432E+00 sqr= -0.50140175989568E+00 K = 10 done No. of calls to UV routine: 0 ******************************* SOLUTION REPORT ******************************* TESTSET: standard, PROBLEM: 1, SOLVER: sleig2, COMPUTE EVs only Parameter values: 0.10000000D+00 Endpoints: A = 0.00000000D+00 B = 3.14159274D+00 Tolerance: 1.00D-08 BCs: A1= 1.00000000D+00 B1= 1.00000000D+00 A2= 0.00000000D+00 B2= 0.00000000D+00 ******************************************************************************* K Eigenvalue IFAIL Absolute error (if error exit) (est.) ("true") 0 1.51986573814244 6.81D-11 1 4.94331126239740 6.00D-09 2 10.2846620849165 6.08D-13 3 17.5599568246795 1.13D-13 4 26.7828617487758 2.78D-11 5 37.9644360515703 3.12D-07 6 51.1133550112597 4.87D-12 7 66.2364596350776 9.19D-09 8 83.3389578424053 7.82D-12 9 102.424952896602 4.58D-09 10 123.497699976508 1.84D-07 CPU secs: 1.3790, No. of function evaluations: 62058 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EVs only eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleig2 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 0 ***CALCULATION CHOICES SUBMENU*** z Back to previous menu --Radio buttons controlling solver call & reporting-------- --Eigenvalues------------------------------------------ [X]1 Eigenvalues only [ ]2 As (1) & compare with "true" values from database --Eigenvalues + eigenfunctions------------------------- [ ]3 Eigenfunction calc using AUTO x-mesh formed by solver [ ]4 Eigenfunction calc using 'UNIForm' x-mesh (equally spaced in a transformed variable) [ ]5 Eigenfunction calc using USER x-mesh from database [ ]6 As (5) & compare with "true" values from database --Spectral density function (SDF)---------------------- [ ]7 SDF calc using 'UNIForm' lambda-mesh (equally spaced in a transformed variable) [ ]8 SDF calc using USER lambda-mesh from database [ ]9 As (8) & compare with "true" values from database Choose option: 7 Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices SDF, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleig2 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 0 ***CALCULATION CHOICES SUBMENU*** z Back to previous menu --Radio buttons controlling solver call & reporting-------- --Eigenvalues------------------------------------------ [ ]1 Eigenvalues only [ ]2 As (1) & compare with "true" values from database --Eigenvalues + eigenfunctions------------------------- [ ]3 Eigenfunction calc using AUTO x-mesh formed by solver [ ]4 Eigenfunction calc using 'UNIForm' x-mesh (equally spaced in a transformed variable) [ ]5 Eigenfunction calc using USER x-mesh from database [ ]6 As (5) & compare with "true" values from database --Spectral density function (SDF)---------------------- [X]7 SDF calc using 'UNIForm' lambda-mesh (equally spaced in a transformed variable) [ ]8 SDF calc using USER lambda-mesh from database [ ]9 As (8) & compare with "true" values from database Choose option: 4 Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EV+EFn, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleig2 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 0 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 6 Give eigenvalue index range klo,khi (0<=klo<=khi): 9 10 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EV+EFn, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleig2 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 8 Appending to log-file standard\sleig201.m Appending to log-file standard\sleig201.aux How many interior points in x-mesh (not counting A,B) in range 10 to 49: 15 Forming "UNIForm" mesh of 17 points *************** CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED *************** ***Note: this calculation is not recommended for sleig2 at present Results may be suspect, go ahead anyway?y Each dot represents 1000 function evaluations: Each + represents 1000 calls to SLEIGN2's UV routine: alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.1035578E+03 tmid= 0.00000000 z= 0.1005315E+02 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10355779471644E+03 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.1750327E+00 dthde= 0.1533055E+00 thetal= 0.1562284E+02 thetar= -0.1282653E+02 eigrt= 0.10241607018205E+03 eigup= 0.10355779471644E+03 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.1102500E-01 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10220965418637E+03 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.3358110E-01 dthde= 0.1562105E+00 thetal= 0.1551669E+02 thetar= -0.1272406E+02 eigrt= 0.10241607018205E+03 eigup= 0.10355779471644E+03 eiglt= 0.10242462755023E+03 eiglo= 0.10220965418637E+03 converge= F estim. acc.= 0.2103259E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10242564769673E+03 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= 0.1082043E-03 dthde= 0.1557344E+00 thetal= 0.1553384E+02 thetar= -0.1274060E+02 eigrt= 0.10242495289660E+03 eigup= 0.10242564769673E+03 eiglt= 0.10242462755023E+03 eiglo= 0.10220965418637E+03 converge= F estim. acc.= 0.6783459E-05 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.10242495289660E+03 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.7136212E-09 dthde= 0.1557360E+00 thetal= 0.1553378E+02 thetar= -0.1274055E+02 eigrt= 0.10242495289202E+03 eigup= 0.10242495289660E+03 eiglt= 0.10242462755023E+03 eiglo= 0.10220965418637E+03 converge= T numeig= 9 eig= 0.10242495289660E+03 tol= 0.447E-10 ray= 0.10242495289202E+03 psil= 0.13850155543576E+00 psir= 0.13850155543576E+00 psipl= -0.79128886446502E+01 psipr= -0.79128886115657E+01 sql= 0.50890378351191E+00 sqr= -0.49109621648809E+00 . K = 9 done alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 estim= 0.1244331E+03 tmid= 0.00000000 z= 0.1104653E+02 aaa=-1.00000000 aa=-1.00000000 bb= 1.00000000 bbb= 1.00000000 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12443312259113E+03 eps= 0.100E-03 tmid= 0.000E+00 dtheta= 0.1339584E+00 dthde= 0.1434482E+00 thetal= 0.1718050E+02 thetar= -0.1436939E+02 eigrt= 0.12349927734179E+03 eigup= 0.12443312259113E+03 eiglt= 0.00000000000000E+00 eiglo= -0.90483315610463E+00 converge= F estim. acc.= 0.7504796E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12331191651888E+03 eps= 0.100E-03 tmid= 0.000E+00 dtheta= -0.2656054E-01 dthde= 0.1428847E+00 thetal= 0.1710045E+02 thetar= -0.1428891E+02 eigrt= 0.12349927734179E+03 eigup= 0.12443312259113E+03 eiglt= 0.12349780435382E+03 eiglo= 0.12331191651888E+03 converge= F estim. acc.= 0.1507460E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12349762157398E+03 eps= 0.100E-03 tmid= 0.000E+00 . dtheta= -0.1708341E-04 dthde= 0.1429822E+00 thetal= 0.1711369E+02 thetar= -0.1430222E+02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12331191651888E+03 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.2655522E-01 dthde= 0.1428882E+00 thetal= 0.1710046E+02 thetar= -0.1428892E+02 eigrt= 0.00000000000000E+00 eigup= 0.10098082799680E+03 eiglt= 0.12349776264177E+03 eiglo= 0.12331191651888E+03 converge= F estim. acc.= 0.1507122E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12368360876467E+03 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= 0.2659085E-01 dthde= 0.1430794E+00 thetal= 0.1712695E+02 thetar= -0.1431556E+02 eigrt= 0.12349776192593E+03 eigup= 0.12368360876467E+03 eiglt= 0.12349776264177E+03 eiglo= 0.12331191651888E+03 converge= F estim. acc.= 0.1502599E-02 alfa= 0.00000000000000E+00 beta= 0.31415926535898E+01 guess= 0.12349769997651E+03 eps= 0.200E-06 tmid= 0.000E+00 . dtheta= -0.2632965E-07 dthde= 0.1429841E+00 thetal= 0.1711370E+02 thetar= -0.1430223E+02 eigrt= 0.12349776192593E+03 eigup= 0.12368360876467E+03 eiglt= 0.12349770016065E+03 eiglo= 0.12349769997651E+03 converge= T numeig= 10 eig= 0.12349769997651E+03 tol= 0.149E-08 . ray= 0.12349770016065E+03 psil= -0.78487346623043E+00 psir= -0.78487346623043E+00 psipl= -0.14442650592767E+01 psipr= -0.14442648246607E+01 sql= 0.49859824010432E+00 sqr= -0.50140175989568E+00 .. K = 10 done No. of calls to UV routine: 0 ******************************* SOLUTION REPORT ******************************* TESTSET: standard, PROBLEM: 1, SOLVER: sleig2, COMPUTE EV+EFn, UNIF mesh Parameter values: 0.10000000D+00 Endpoints: A = 0.00000000D+00 B = 3.14159274D+00 Tolerance: 1.00D-08 BCs: A1= 1.00000000D+00 B1= 1.00000000D+00 A2= 0.00000000D+00 B2= 0.00000000D+00 ******************************************************************************* ***Results of "deprecated" calculation K Eigenvalue IFAIL Absolute error (if error exit) (est.) ("true") 9 102.424952896602 4.58D-09 Press ENTER to continue Eigenfunction Values for k= 9 x u(x) pu'(x) 0.0000000 1.3850155516E-01 0.0000000000E+00 0.1516770 3.3699976190E-01 0.0000000000E+00 0.3080260 -7.0735480093E-01 0.0000000000E+00 0.4692663 7.9047032088E-01 0.0000000000E+00 0.6356311 -6.5363133427E-01 0.0000000000E+00 0.8073686 4.1698875654E-01 0.0000000000E+00 0.9847434 -1.8040990834E-01 0.0000000000E+00 1.1680375 -9.7945661404E-16 0.0000000000E+00 1.3575525 -9.7945661404E-16 0.0000000000E+00 1.5536104 -9.7945661404E-16 0.0000000000E+00 1.7565561 -9.7945661404E-16 0.0000000000E+00 1.9667589 -9.7945661404E-16 0.0000000000E+00 2.1846153 -9.7945661404E-16 0.0000000000E+00 2.4105509 -9.7945661404E-16 0.0000000000E+00 2.6450238 -9.7945661404E-16 0.0000000000E+00 2.8885271 -9.7945661404E-16 0.0000000000E+00 3.1415927 -9.7945661404E-16 0.0000000000E+00 Press ENTER to continue 10 123.497699976508 1.84D-07 Press ENTER to continue Eigenfunction Values for k= 10 x u(x) pu'(x) 0.0000000 -7.8487346450E-01 0.0000000000E+00 0.1516770 -7.1545731697E-01 0.0000000000E+00 0.3080260 5.1449171227E-01 0.0000000000E+00 0.4692663 -2.9079729144E-01 0.0000000000E+00 0.6356311 1.0703813006E-01 0.0000000000E+00 0.8073686 8.1476447757E-03 0.0000000000E+00 0.9847434 -4.5201862752E-02 0.0000000000E+00 1.1680375 3.9181211082E-15 0.0000000000E+00 1.3575525 3.9181211082E-15 0.0000000000E+00 1.5536104 3.9181211082E-15 0.0000000000E+00 1.7565561 3.9181211082E-15 0.0000000000E+00 1.9667589 3.9181211082E-15 0.0000000000E+00 2.1846153 3.9181211082E-15 0.0000000000E+00 2.4105509 3.9181211082E-15 0.0000000000E+00 2.6450238 3.9181211082E-15 0.0000000000E+00 2.8885271 3.9181211082E-15 0.0000000000E+00 3.1415927 3.9181211082E-15 0.0000000000E+00 Press ENTER to continue CPU secs: 0.1690, No. of function evaluations: 9064 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EV+EFn, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleig2 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 1 Choose Solver from: 1=sledge 2=sleign 3=sl02f 4=sleig2 3 Solver is now sl02f Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EV+EFn, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sl02f 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 8 Appending to log-file standard\sl02f01.m Appending to log-file standard\sl02f01.aux *************** CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED *************** Each dot represents 1000 function evaluations: . K= 9 , error flag = 0 , no. of mesh intervals used= 712 .. K= 10 , error flag = 0 , no. of mesh intervals used= 686 ******************************* SOLUTION REPORT ******************************* TESTSET: standard, PROBLEM: 1, SOLVER: sl02f , COMPUTE EV+EFn, UNIF mesh Parameter values: 0.10000000D+00 Endpoints: A = 0.00000000D+00 B = 3.14159274D+00 Tolerance: 1.00D-08 BCs: A1= 1.00000000D+00 B1= 1.00000000D+00 A2= 0.00000000D+00 B2= 0.00000000D+00 ******************************************************************************* K Eigenvalue IFAIL Absolute error (if error exit) (est.) ("true") 9 102.424982750525 8.64D-07 Press ENTER to continue Eigenfunction Values for k= 9 x u(x) pu'(x) 0.0000000 0.0000000000E+00 6.8775918485E+00 0.1516770 7.9811782998E-01 1.6775866139E+00 0.3080260 2.3789721442E-01 -7.5933516167E+00 0.4692663 -7.7124775509E-01 -2.1201046045E+00 0.6356311 -1.4091224399E-01 7.8829401629E+00 0.8073686 7.9681003324E-01 1.7671227370E-01 0.9847434 -1.5262794994E-01 -7.8766930270E+00 1.1680375 -7.0937762778E-01 3.6426554143E+00 1.3575525 5.7773357038E-01 5.5222015010E+00 1.5536104 2.7172866740E-01 -7.5522855558E+00 1.7565561 -7.8840729580E-01 1.0521514469E+00 1.9667589 5.0311285291E-01 6.2240852353E+00 2.1846153 1.9974928730E-01 -7.7810802956E+00 2.4105509 -7.1239210385E-01 3.5685249776E+00 2.6450238 7.5695157814E-01 2.4555166331E+00 2.8885271 -4.3677006236E-01 -6.7178069925E+00 3.1415927 1.8719689697E-14 8.0407331295E+00 Press ENTER to continue 10 123.497699982258 1.44D-06 Press ENTER to continue Eigenfunction Values for k= 10 x u(x) pu'(x) 0.0000000 0.0000000000E+00 7.7084208694E+00 0.1516770 8.1551569691E-01 5.4104386220E-01 0.3080260 -1.6864427712E-02 -8.7299694134E+00 0.4692663 -7.8197298892E-01 1.8647148952E+00 0.6356311 3.6324836564E-01 7.8340342789E+00 0.8073686 5.5586314856E-01 -6.3188560905E+00 0.9847434 -7.3971311297E-01 -3.2653835009E+00 1.1680375 6.4135641359E-02 8.7952120982E+00 1.3575525 6.5164732208E-01 -5.0670929018E+00 1.5536104 -7.4597298482E-01 -3.0689827538E+00 1.7565561 2.5510252132E-01 8.3634055812E+00 1.9667589 3.6844557504E-01 -7.8265047853E+00 2.1846153 -7.4250355132E-01 3.1653696073E+00 2.4105509 7.6730809682E-01 2.3216978720E+00 2.6450238 -5.5207731355E-01 -6.3572857273E+00 2.8885271 2.5802730193E-01 8.3551142833E+00 3.1415927 -1.9483325489E-14 -8.8333845946E+00 Press ENTER to continue CPU secs: 0.2810, No. of function evaluations: 3396 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EV+EFn, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sl02f 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 1 Choose Solver from: 1=sledge 2=sleign 3=sl02f 4=sleig2 2 Solver is now sleign Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EV+EFn, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleign 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 8 Appending to log-file standard\sleign01.m Appending to log-file standard\sleign01.aux *************** CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED *************** Each dot represents 1000 function evaluations: ............................ ******************************* SOLUTION REPORT ******************************* TESTSET: standard, PROBLEM: 1, SOLVER: sleign, COMPUTE EV+EFn, UNIF mesh Parameter values: 0.10000000D+00 Endpoints: A = 0.00000000D+00 B = 3.14159274D+00 Tolerance: 1.00D-08 BCs: A1= 1.00000000D+00 B1= 1.00000000D+00 A2= 0.00000000D+00 B2= 0.00000000D+00 ******************************************************************************* K Eigenvalue IFAIL Absolute error (if error exit) (est.) ("true") 9 102.424982748196 1.04D-07 Press ENTER to continue Eigenfunction Values for k= 9 x u(x) pu'(x) 0.0000000 0.0000000000E+00 0.0000000000E+00 0.1516770 7.9811737656E-01 0.0000000000E+00 0.3080260 2.3789707343E-01 0.0000000000E+00 0.4692663 -7.7124746545E-01 0.0000000000E+00 0.6356311 -1.4091220160E-01 0.0000000000E+00 0.8073686 7.9681002773E-01 0.0000000000E+00 0.9847434 -1.5262798571E-01 0.0000000000E+00 1.1680375 -7.0937768220E-01 0.0000000000E+00 1.3575525 5.7773364460E-01 0.0000000000E+00 1.5536104 2.7172866933E-01 0.0000000000E+00 1.7565561 -7.8840744235E-01 0.0000000000E+00 1.9667589 5.0311295999E-01 0.0000000000E+00 2.1846153 1.9974931239E-01 0.0000000000E+00 2.4105509 -7.1239226499E-01 0.0000000000E+00 2.6450238 7.5695173999E-01 0.0000000000E+00 2.8885271 -4.3677017517E-01 0.0000000000E+00 3.1415927 -9.8467186256E-16 0.0000000000E+00 Press ENTER to continue 10 123.497699985661 9.62D-08 Press ENTER to continue Eigenfunction Values for k= 10 x u(x) pu'(x) 0.0000000 0.0000000000E+00 0.0000000000E+00 0.1516770 8.1551534345E-01 0.0000000000E+00 0.3080260 -1.6864487207E-02 0.0000000000E+00 0.4692663 -7.8197285789E-01 0.0000000000E+00 0.6356311 3.6324833840E-01 0.0000000000E+00 0.8073686 5.5586309633E-01 0.0000000000E+00 0.9847434 -7.3971311122E-01 0.0000000000E+00 1.1680375 6.4135693497E-02 0.0000000000E+00 1.3575525 6.5164739907E-01 0.0000000000E+00 1.5536104 -7.4597309772E-01 0.0000000000E+00 1.7565561 2.5510258922E-01 0.0000000000E+00 1.9667589 3.6844562897E-01 0.0000000000E+00 2.1846153 -7.4250371424E-01 0.0000000000E+00 2.4105509 7.6730826051E-01 0.0000000000E+00 2.6450238 -5.5207743290E-01 0.0000000000E+00 2.8885271 2.5802737142E-01 0.0000000000E+00 3.1415927 3.9346911335E-15 0.0000000000E+00 Press ENTER to continue CPU secs: 0.5970, No. of function evaluations: 28634 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EV+EFn, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sleign 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 1 Choose Solver from: 1=sledge 2=sleign 3=sl02f 4=sleig2 1 Solver is now sledge Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EV+EFn, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sledge 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 8 Appending to log-file standard\sledge01.m Appending to log-file standard\sledge01.aux *************** CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED *************** ***Note: this calculation is not recommended for sledge at present Results may be suspect, go ahead anyway?y Each dot represents 1000 function evaluations: ........................ Classification of endpoint A: Regular=T, LC =T, Nonosc all EV=T, Osc all EV=F Classification of endpoint B: Regular=T, LC =T, Nonosc all EV=T, Osc all EV=F Press ENTER to continue ******************************* SOLUTION REPORT ******************************* TESTSET: standard, PROBLEM: 1, SOLVER: sledge, COMPUTE EV+EFn, UNIF mesh Parameter values: 0.10000000D+00 Endpoints: A = 0.00000000D+00 B = 3.14159274D+00 Tolerance: 1.00D-08 BCs: A1= 1.00000000D+00 B1= 1.00000000D+00 A2= 0.00000000D+00 B2= 0.00000000D+00 ******************************************************************************* ***Results of "deprecated" calculation K Eigenvalue IFAIL Absolute error (if error exit) (est.) ("true") 9 102.424982743098 1.02D-06 Press ENTER to continue Eigenfunction Values for k= 9 x u(x) pu'(x) 0.0000000 0.0000000000E+00 6.8775743401E+00 0.1516770 7.9811737592E-01 1.6776179316E+00 0.3080260 2.3789707323E-01 -7.5933480817E+00 0.4692663 -7.7124746482E-01 -2.1201106191E+00 0.6356311 -1.4091220154E-01 7.8829387283E+00 0.8073686 7.9681002708E-01 1.7671440910E-01 0.9847434 -1.5262798546E-01 -7.8766925686E+00 1.1680375 -7.0937768171E-01 3.6426569288E+00 1.3575525 5.7773364441E-01 5.5222010832E+00 1.5536104 2.7172866917E-01 -7.5522865735E+00 1.7565561 -7.8840744291E-01 1.0521504040E+00 1.9667589 5.0311296056E-01 6.2240864074E+00 2.1846153 1.9974931236E-01 -7.7810820779E+00 2.4105509 -7.1239226547E-01 3.5685255485E+00 2.6450238 7.5695174059E-01 2.4555180034E+00 2.8885271 -4.3677017555E-01 -6.7178089996E+00 3.1415927 0.0000000000E+00 8.0407352612E+00 Press ENTER to continue 10 123.497699976084 1.23D-06 Press ENTER to continue Eigenfunction Values for k= 10 x u(x) pu'(x) 0.0000000 0.0000000000E+00 7.7084021191E+00 0.1516770 8.1551534377E-01 5.4105292212E-01 0.3080260 -1.6864487198E-02 -8.7299650189E+00 0.4692663 -7.8197285821E-01 1.8647197505E+00 0.6356311 3.6324833842E-01 7.8340332227E+00 0.8073686 5.5586309670E-01 -6.3188585105E+00 0.9847434 -7.3971311142E-01 -3.2653835488E+00 1.1680375 6.4135693202E-02 8.7952127726E+00 1.3575525 6.5164739907E-01 -5.0670935261E+00 1.5536104 -7.4597309759E-01 -3.0689844162E+00 1.7565561 2.5510258956E-01 8.3634069572E+00 1.9667589 3.6844562848E-01 -7.8265064147E+00 2.1846153 -7.4250371383E-01 3.1653714550E+00 2.4105509 7.6730826027E-01 2.3216986379E+00 2.6450238 -5.5207743280E-01 -6.3572869847E+00 2.8885271 2.5802737140E-01 8.3551165415E+00 3.1415927 0.0000000000E+00 -8.8333869078E+00 Press ENTER to continue CPU secs: 0.2230, No. of function evaluations: 24970 Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices EV+EFn, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sledge 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 0 ***CALCULATION CHOICES SUBMENU*** z Back to previous menu --Radio buttons controlling solver call & reporting-------- --Eigenvalues------------------------------------------ [ ]1 Eigenvalues only [ ]2 As (1) & compare with "true" values from database --Eigenvalues + eigenfunctions------------------------- [ ]3 Eigenfunction calc using AUTO x-mesh formed by solver [X]4 Eigenfunction calc using 'UNIForm' x-mesh (equally spaced in a transformed variable) [ ]5 Eigenfunction calc using USER x-mesh from database [ ]6 As (5) & compare with "true" values from database --Spectral density function (SDF)---------------------- [ ]7 SDF calc using 'UNIForm' lambda-mesh (equally spaced in a transformed variable) [ ]8 SDF calc using USER lambda-mesh from database [ ]9 As (8) & compare with "true" values from database Choose option: 7 Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices SDF, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sledge 2 Choose problem 1 (-u" + u/(x+alpha)^2 = lambda u ) 3 Give parameters (if any) for current problem alpha(>0, 0.1 gives standard problem in book) Currently 1.00000000D-01 4 Give endpoints for current problem A = 0.00000000D+00 B = 3.14159274D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( A1*u(a)=A2*pu'(a), B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 3.14159274D+00 Their types R R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 2 Give Problem no. in range 1 to 60: 48 Spectral density fn. example. Ref: Pruess/Fulton 75 Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices SDF, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sledge 2 Choose problem 48 (Spectral density fn. example. Ref: Pruess/Fulton 75 ) 3 Give parameters (if any) for current problem 4 Give endpoints for current problem A = 0.00000000D+00 B = 1.00000000D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( , B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 1.00000000D+00 Their types LPNO R ) To abort any data-input operation type z or Z followed by ENTER Choose option: 8 Appending to log-file standard\sledge48.m Appending to log-file standard\sledge48.aux Give lower endpoint of lambda-mesh (use -1.00D+35for minus infinity: 0 Give upper endpoint of lambda-mesh (use 1.00D+35for plus infinity: 100 How many points in lambda-mesh in range 1 to 51: 11 Forming "UNIForm" mesh of 11 points *************** CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED *************** Each dot represents 1000 function evaluations: .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. .................................................. ................... Classification of endpoint A: Regular=F, LC =F, Nonosc all EV=F, Osc all EV=F Classification of endpoint B: Regular=T, LC =T, Nonosc all EV=T, Osc all EV=F Press ENTER to continue ******************************* SOLUTION REPORT ******************************* TESTSET: standard, PROBLEM: 48, SOLVER: sledge, COMPUTE SDF, UNIF mesh Parameter values: Endpoints: A = 0.00000000D+00 B = 1.00000000D+00 Tolerance: 1.00D-08 BCs: A1= 1.00000000D+00 B1= 1.00000000D+00 A2= 0.00000000D+00 B2= 0.00000000D+00 ******************************************************************************* ***Exit flag has failure value: SDF values are suspect! Spectral Density Values: exit flag= -9 lambda rho(lambda) 1 0.00000000000000 0.00000000000000 2 1.00000000000000 0.00000000000000 3 2.22222222222222 0.00000000000000 4 3.75000000000000 0.385984816104522 5 5.71428571428571 1.36118871761325 6 8.33333333333333 3.17709132837614 7 12.0000000000000 6.45364560612157 8 17.5000000000000 12.6283261586746 9 26.6666666666667 25.5801695659272 10 45.0000000000000 59.2978530602556 11 100.000000000000 205.061878124141 Press ENTER to continue CPU secs: 198.9130, No. of function evaluations: 12869442 * ************************Help from file ERRFLAGS.hlp************************ * * For information on error exits from the solvers: * * SLEIGN see source code SL\SLEIGN\SLEIGN.FOR * * SLEDGE see source code SL\SLEDGE\SLEDGE.FOR * * SL02F see source code of SL02F in SL\MARCOPAK\MARCOPK1.FOR * * SLEIGN2 see formats 9010 onward in source text of * * SL\SLEIGN2\EXTRAS\DRIVE.F * * Also lines 93 onward (re IFLAG values) in * * SL\SLEIGN2\SLEIGN2D.FOR * * though the info there does not seem to be complete. * * D02KEF see SL\D02KEF\D02KEF.DOC (the NAG online help file) * ******************************************************************************* Press ENTER to continue Testset: standard *** MAIN MENU *** Current values z Quit (terminate run) 0 Calculation choices SDF, UNIF mesh eigenvalues; eigenvalues + eigenfunctions; spectral density function 1 Choose solver sledge 2 Choose problem 48 (Spectral density fn. example. Ref: Pruess/Fulton 75 ) 3 Give parameters (if any) for current problem 4 Give endpoints for current problem A = 0.00000000D+00 B = 1.00000000D+00 5 Give one/both BCs for current problem A1= 1.00000000D+00 B1= 1.00000000D+00 ( , B1*u(b)=B2*pu'(b)) A2= 0.00000000D+00 B2= 0.00000000D+00 6 Give eigenvalue index range 9 to 10 7 Give tolerance 1.00D-08 8 Solve problem as currently given 9 Display/change mesh & "true" values from database (Extra information: Original endpoints A = 0.00000000D+00 B = 1.00000000D+00 Their types LPNO R ) To abort any data-input operation type z or Z followed by ENTER Choose option: z Do you want to quit? (y/n) y SHAR_EOF fi # end of overwriting check if test -f 'slbrows.hlp' then echo shar: will not over-write existing file "'slbrows.hlp'" else cat << SHAR_EOF > 'slbrows.hlp' SLDRIVER is about to create the `browse-file' .LST in the current directory, where is the name of the current Problem Set. This contains brief data about all the problems in the set, extracted from the problem set code. The browse-file is not created if there is already a file of that name in the directory. So, if you are in process of updating your Problem Set, you should delete the browse-file from time to time so that it is re-created next time you run the program. NOTE This file is not displayed by the program. Instead, you are expected to view it with your favourite text editor. If you are in a window- environment this is best done by opening a separate window. Or you can print it and keep it by you for reference. SHAR_EOF fi # end of overwriting check if test -f 'slconsts.f' then echo shar: will not over-write existing file "'slconsts.f'" else cat << SHAR_EOF > 'slconsts.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** module SLCONSTS integer,parameter:: MAXMSH=51,MAXEVS=51 + ,ABSENT=0,PRESNT=1 logical,parameter:: NO=.FALSE.,YES=.TRUE. double precision,parameter:: XINFTY=1d35 end module SLCONSTS SHAR_EOF fi # end of overwriting check if test -f 'sld02k.hlp' then echo shar: will not over-write existing file "'sld02k.hlp'" else cat << SHAR_EOF > 'sld02k.hlp' This driver for D02KDF is mostly like the ones for SLEDGE & SL02F, so try using those first! However it copes with the fact that D02KDF is more primitive in some ways no automatic handling of singular endpoints it needs a reasonable initial guess EIG of the eigenvalue and a search-step DEIG and more advanced in that it can handle problems nonlinear in the eigenparameter So, it has been written so that several of the parameters appearing in a problem can be taken as eigenparameter. E.g. in Problem 1 of the standard set, the q(x) function contains parameter 'alpha'. The standard Sturm-Liouville 'lambda' is parameter #0 and 'alpha' is parameter #1. These two are on an equal footing and the program has been written so that invoking the solver (menu choice 7) alters the value of the 'current eigenparameter' keeping the other parameter(s) fixed. E.g. you can set lambda=1.5 in Problem 1 and select alpha as eigen- parameter (menu choice 2 includes this), and look for the alpha value which gives the lowest (k=0) eigenvalue: this will be not far from 0.1. Since q(x) has an infinity in the interval when alpha<0, you need to choose the initial guess near 0.1 & set the search step small (say 0.01) to stop negative alpha values being tried, in this case. For ordinary, but singular, SLPs you have to 'truncate' at each singular endpoint by choosing an endpoint slightly inside the interval and setting regular BCs there: the driver will apply the truncations of the standard BCs inside SLTSTPAK in this case. SHAR_EOF fi # end of overwriting check if test -f 'sldriver.f' then echo shar: will not over-write existing file "'sldriver.f'" else cat << SHAR_EOF > 'sldriver.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** C SLDRIVER Version 4.1 by John D Pryce, June 1998 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C C To go with SLTSTPAK Version 3.2 Jun 98. C Driver Program for SL-Solvers and my design of Test Set implemented C in SLTSTPAK package. Includes facilities for computing both eigen- C values (e-vs) and eigenfunctions (e-fns) and for comparing computed C e-vs and e-fns with "true" values held in a database file. C C Revision history: C Apr 1994: Version 3 C Aug 94: Revised by Steve Pruess C Sep-Dec 94: Improved screen appearance and summary output C Nov-Dec 95: Make compatible with Salford FTN90 compiler C Jan-Apr 96: Major revision involving: C 1.Add the database file facilities. C This involved redefining the state-variables, which describe what C data is/is not present and cause appropriate action to be taken C when various options are invoked from the menus. C 2.Divide the code into C - Driver (this module). C - DBMOD module to read "true" e-v and e-fn data C - The SAFEIO module C - SLTSTPAK C - The current Test Set of problems C (JDPTSET is the standard set of 60 problems) C - SOLVRS, a general interface module for several Solvers. This C contains the names of the solvers and other information as C PARAMETER data, and a general interface routine SOLVIT which C CONTAINS specific interface routines: C - SSLEIG which calls SLEIGN C - SSLED which calls SLEDGE C - etc C Thus adding a new Solver involves adding the data items to SOLVRS C and adding a new specific interface routine inside SOLVIT. Of C course, this interface routine is the key!! It must connect C whatever special facilities the Solver offers, to the information C available from SLTSTPAK routines. C C Mar 1997. In response to comments from TOMS referee. C 1.Add Sp Dens Fn facility offered by SLEDGE. This involved a C revision of the main menu & converting 'e-fn choices' submenu to C 'calculation choices' submenu. C 2.Make database interface simpler & more maintainable (more object C oriented). C 3.Tidy up the routine documentation. C 4.Add more info about the problem being solved, to the REPORT C output C C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C GENERAL DOCUMENTATION C!..yet to be written C***+****|****+****|***MAIN ROUTINES USED BY SLDRIVER*+****|****+****|** module SLMOD use SLTSTPAK use SLCONSTS use SLPSET use SLUTIL use SAFEIO implicit none character*8 TSETNM C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTSLVR(ISOLVR,SOLVER,OKEXIT) use SOLVRS, only: NSOLVR, SLVNAM, OKEXTS C GTSLVR asks the user to choose the SL-Solver to be used by number in C the range 1 to NSOLVR. C It returns TRUE if this is done. If user aborts it returns FALSE and C the in/out arguments are left unchanged. C Global data used from SOLVRS (input): C NSOLVRS, SLVNAM, OKEXTS C In/out arguments: C ISOLVER,SOLVER,OKEXIT Index within list of solver chosen; its C name;its 'success exit' flag value. C .. Scalar Arguments .. integer ISOLVR,OKEXIT character*6 SOLVER C .. Local Scalars .. integer I C write(*,fmt=9999) (I,SLVNAM(I),I=1,NSOLVR) 9999 format('Choose Solver from: ',5(i2,'=',a6,2x), + (/20x,5(i2,'=',a6,2x))) if (.not. GETIR(ISOLVR,1,NSOLVR)) go to 100 C Global data from SOLVRS module: SOLVER = SLVNAM(ISOLVR) OKEXIT = OKEXTS(ISOLVR) GTSLVR = .TRUE. return C Respond to user aborting input: 100 GTSLVR = .FALSE. end function GTSLVR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTPROB(NPROB,IPROB,TITLE,NPARM,NEPRM,PARNM,PARM, + A,B,ATYPE,BTYPE,A1,A2,B1,B2,SYM) C GTPROB asks the user to choose the SL Problem Number IPROB in the C range 1 to NPROB. C It returns TRUE if this is done. If user aborts input of Problem No. or C subsequent input of parameter values it returns FALSE and the in/out C arguments are left unchanged. C It sets the remaining arguments TITLE to SYM by calls to the SLTSTPAK C routine SETUP0 and the SLDRIVER routine GTPARM (which calls the C SLTSTPAK routine SETUP1). C!Still a kluge!! as I haven't mastered the logic of aborting one C state-setting when within another. Will be better when I go more C object-oriented & only keep *one* copy of SLTSTPAK state variables. C .. Scalar Arguments .. double precision A,A1,A2,B,B1,B2 integer IPROB,NEPRM,NPARM,NPROB logical SYM character*4 ATYPE,BTYPE character*72 PARNM,TITLE C .. C .. Array Arguments .. double precision PARM(0:10) C .. Local Scalars .. integer IPRSAV IPRSAV = IPROB write(*,advance='NO',fmt= + '(/''Give Problem no. in range 1 to'',i3,'': '')') NPROB if (.not.GETIR(IPROB,1,NPROB)) go to 100 C Call the version of SETUP0 that doesn't change SLTSTPAK state: call GTDAT0(IPROB,TITLE,NPARM,NEPRM,PARNM) write(*,fmt='(/1x,a)') TITLE if (NPARM.gt.0) then write(*,fmt=9999,advance='NO') PARNM(1:ITRIM(PARNM)) 9999 format(/'Give values of the following parameter(s)',/,1x,a,':') C get entries to PARM starting with PARM(1): if (.not.GETRS(PARM(1),NPARM)) go to 100 end if C else read in OK so: C Update SLTSTPAK state for new IPROB call SETUP0(IPROB,TITLE,NPARM,NEPRM,PARNM) C Update SLTSTPAK state for new PARM call SETUP1(PARM,A,B,ATYPE,BTYPE,A1,A2,B1,B2,SYM) GTPROB = .TRUE. return C Respond to user aborting input: 100 GTPROB = .FALSE. IPROB = IPRSAV call GTDAT0(IPROB,TITLE,NPARM,NEPRM,PARNM) end function GTPROB C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTPARM(NPARM,PARNM,PARM,A,B,ATYPE,BTYPE,A1,A2,B1, + B2,SYM) C GTPARM asks the user to choose the parameter values if any for the C current SL Problem in PARM(1:NPARM). C It returns TRUE if this is done. If user aborts it returns FALSE and C the in/out arguments are left unchanged. C After the user does this it calls the SLTSTPAK routine SETUP1 to C install the PARM values in SLTSTPAK's private memory and thus reset the C values of A,B, ..., SYM inSLTSTPAK's memory. The reset values are returned C through the arguments of GTPARM. C Input arguments: NPARM, PARNM C In/out arguments: the others C .. Scalar Arguments .. double precision A,A1,A2,B,B1,B2 integer NPARM logical SYM character*4 ATYPE,BTYPE character*72 PARNM C .. C .. Array Arguments .. double precision PARM(0:10) C .. if (NPARM.gt.0) then write(*,fmt=9999,advance='NO') PARNM(1:ITRIM(PARNM)) 9999 format(/'Give values of the following parameter(s)',/,1x,a,':') C get entries to PARM starting with PARM(1): if (.not.GETRS(PARM(1),NPARM)) go to 100 end if C else read in OK so: call SETUP1(PARM,A,B,ATYPE,BTYPE,A1,A2,B1,B2,SYM) GTPARM = .TRUE. return C Respond to user aborting input: 100 GTPARM = .FALSE. end function GTPARM C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine GTENDS(A,B,ATYPE,BTYPE,AORIG,BORIG,ATORIG,BTORIG) C (version for drivers that handle singular ends automatically.) C GTENDS asks the user to choose the current endpoints for the C current SL Problem. C It returns TRUE if this is done. If user aborts it returns FALSE and C the in/out arguments are left unchanged. C Input arguments: C AORIG,BORIG = standard endpoints C ATORIG,BTORIG = their type C In/out arguments: C A,B endpoints to be used for a given solver run. GTENDS checks C they are compatible with the standard endpoints: if AORIG is C singular (including of type 'WR'), A must be >= AORIG, if C regular no restriction is imposed. Similarly at BORIG. For C D02KEF which cannot handle singular endpoints automatically, C '>=' is replaced by '>' C ATYPE is set to ATORIG if A=AORIG, to 'R' if A>AORIG C BTYP, is set to BTORIG if B=BORIG, to 'R' if B=0. KHI is >=KLO and <= KLO+MAXEVS-1. C .. Scalar Arguments .. integer KHI,KLO,MAXEVS character*4 ATYPE,BTYPE C .. C .. Local Arrays .. integer KNEW(1:2) C .. 10 continue if (ATYPE.ne.'LCO' .and. BTYPE.ne.'LCO') then write(*,ADVANCE='NO',fmt= + '(''Give eigenvalue index range klo,khi (0<=klo<=khi): '')') if (.not.GETIS(KNEW,2)) go to 100 C Check for validity: if (KNEW(1).lt.0 .or. KNEW(1).gt.KNEW(2)) then write(*,fmt=*) 'Invalid input' go to 10 end if else write(*,ADVANCE='NO',fmt= + '(''Give eigenvalue index range klo,khi '', + ''(klo<=khi, negative values allowed): '')') if (.not.GETIS(KNEW,2)) go to 100 C Check for validity: if (KNEW(1).gt.KNEW(2)) then write(*,fmt=*) 'Invalid input' go to 10 end if end if KLO = KNEW(1) KHI = KNEW(2) if (KHI-KLO+1.gt.MAXEVS) then KHI = KLO+MAXEVS-1 write(*,FMT=*)' More than',MAXEVS, + ' eigenvalues requested, range reduced to ',KLO,':',KHI end if GTINDX = .TRUE. return C Respond to user aborting input: 100 GTINDX = .FALSE. end function GTINDX C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTTOL(TOLER) C GTTOL gets a tolerance value C It returns TRUE if this is done. If user aborts it returns FALSE and C the in/out arguments are left unchanged. C In/out arguments: C TOLER Set by user to value with the restriction: TOLER>0. C .. Scalar Arguments .. double precision TOLER C .. 10 write(*,ADVANCE='NO', +fmt='(/''Give tolerance (>0): '')') if (.not.GETR(TOLER)) go to 100 C Check for validity: if (TOLER.le.0D0) then write(*,fmt=*) 'Invalid input' go to 10 end if GTTOL = .TRUE. return C Respond to user aborting input: 100 GTTOL = .FALSE. end function GTTOL C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine CAMENU(CALSET) C CAMENU handles the 'calculation choices submenu', which looks thus: C----------------------------------------------------------------------- C ***CALCULATION CHOICES SUBMENU*** C z Back to previous menu C --Radio buttons controlling solver call & reporting-------- C --Eigenvalues------------------------------------------ C [X]1 Eigenvalues only C [ ]2 As (1) & compare with "true" values from database C --Eigenvalues + eigenfunctions------------------------- C [ ]3 Eigenfunction calc using AUTO x-mesh formed by solver C [ ]4 Eigenfunction calc using 'UNIForm' x-mesh C (equally spaced in a transformed variable) C [ ]5 Eigenfunction calc using USER x-mesh from database C [ ]6 As (5) & compare with "true" values from database C --Spectral density function (SDF)---------------------- C [ ]7 SDF calc using 'UNIForm' lambda-mesh C (equally spaced in a transformed variable) C [ ]8 SDF calc using USER lambda-mesh from database C [ ]9 As (8) & compare with "true" values from database C Choose option: C----------------------------------------------------------------------- C It sets CALSET = (menu option number). C .. Parameters .. integer NCHOIC parameter (NCHOIC=9) C .. Scalar Arguments .. integer CALSET C .. Local Scalars .. integer I C .. Local Arrays .. character*3 RADIO(1:NCHOIC) C .. C Arguments C --------- C CALSET INOUT integer. Calculation-choice flag. Initial default=1, set in C calling program. May be set by menu choices 1 to 9 in this C routine, or may be left unchanged on exit. C If we want to have a menu loop, restore this & the GO TO below C 100 continue do 105 I=1,NCHOIC RADIO(I) = '[ ]' 105 continue RADIO(CALSET) = '[X]' write(*,fmt=9999) RADIO 9999 format (/17x,'***CALCULATION CHOICES SUBMENU***',/ +' z Back to previous menu',/ +' --Radio buttons controlling solver call & reporting--------',/ +5x,'--Eigenvalues------------------------------------------',/ +1x,a,'1 Eigenvalues only',/ +1x,a,'2 As (1) & compare with "true" values from database',/ +5x,'--Eigenvalues + eigenfunctions-------------------------',/ +1x,a,'3 Eigenfunction calc using AUTO x-mesh formed by solver',/ +1x,a,'4 Eigenfunction calc using ''UNIForm'' x-mesh',/ +' (equally spaced in a transformed variable)',/ +1x,a,'5 Eigenfunction calc using USER x-mesh from database',/ +1x,a,'6 As (5) & compare with "true" values from database',/ +5x,'--Spectral density function (SDF)----------------------',/ +1x,a,'7 SDF calc using ''UNIForm'' lambda-mesh',/ +8x,'(equally spaced in a transformed variable)',/ +1x,a,'8 SDF calc using USER lambda-mesh from database',/ +1x,a,'9 As (8) & compare with "true" values from database') write(*,fmt=9994,advance='NO') 9994 format(1x,'Choose option: ') if (.not.GETIR(CALSET,1,9)) go to 200 C go to 100 C Respond to Quit: 200 return end subroutine CAMENU C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DBUPDT(CALSET,IPROB,KLO,KHI,FORCE) use DBMOD C DBUPDT updates one or more of the database object(s) 'EVTRUE', C 'EFTRUE', 'SDTRUE', 'XMSHUN', 'LMSHUN' according to the calculation C choice CALSET, the 'ID' info in IPROB,KLO,KHI and the flag FORCE, as C in this table: C CALSET value |'ID' info used | Action taken C 1,3 | none | none as no stored data C 2 | IPROB,KLO,KHI | Update 'EVTRUE' C 4 | none | Update 'XMSHUN' C 5,6 | IPROB,KLO,KHI | Update 'EVTRUE','EFTRUE' C 7 | none | Update 'LMSHUN' C 8,9 | IPROB | Update 'SDTRUE' C C If .not.FORCE, nothing is done if the ID matches that of the stored C data. If FORCE, a user dialogue to re-set the data (change a UNIF C mesh or choose a different database block) is forced. C .. Scalar arguments .. integer CALSET,IPROB,KLO,KHI logical FORCE c print*,'Enter DBUPDT: database identification is' c call DBSUMM go to(10,20,30,40,50,60,70,80,90),CALSET C or if out of range: write(*,*)'Panic: SLMOD%DBUPDT illegal CALSET value',CALSET stop C e-vs only: no stored data 10 if (FORCE) write(*,*) + 'No stored data is associated with this calculation choice' go to 200 C e-vs+"true" 20 call UPEVTR(IPROB,KLO,KHI,FORCE) go to 200 C e-vs+e-fns AUTO x-mesh: no stored data 30 if (FORCE) write(*,*) + 'No stored data is associated with this calculation choice' go to 200 C e-vs+e-fns UNIF x-mesh 40 call UPXMUN(FORCE) go to 200 C e-vs+e-fns USER x-mesh C e-vs+e-fns USER x-mesh+"true" 50 continue 60 call UPEVTR(IPROB,KLO,KHI,FORCE) call UPEFTR(IPROB,KLO,KHI,FORCE) go to 200 C SDF UNIF mesh 70 call UPLMUN(FORCE) go to 200 C SDF USER lambda-mesh C SDF USER lambda-mesh+"true" 80 continue 90 call UPSDTR(IPROB,FORCE) go to 200 200 continue c print*,'Exit DBUPDT: database identification is' c call DBSUMM return end subroutine DBUPDT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DBDISP(CALSET,IPROB,KLO,KHI) use DBMOD C DBDISP displays one or more of the database object(s) 'EVTRUE', C 'EFTRUE', 'SDTRUE', 'XMSHUN', 'LMSHUN' according to the calculation C choice CALSET, and the 'ID' info in IPROB,KLO,KHI (only a subset C needed in some cases). C C .. Scalar arguments .. integer CALSET,IPROB,KLO,KHI c print*,'Enter DBDISP: database identification is' c call DBSUMM go to(10,20,30,40,50,60,70,80,90),CALSET C or if out of range: write(*,*)'Panic: SLMOD%DBDISP illegal CALSET value',CALSET stop C e-vs only: no stored data 10 continue go to 200 C e-vs+"true" 20 call DIEVTR(IPROB,KLO,KHI) go to 200 C e-vs+e-fns AUTO x-mesh: no stored data 30 continue go to 200 C e-vs+e-fns UNIF x-mesh 40 call DIXMUN() go to 200 C e-vs+e-fns USER x-mesh C e-vs+e-fns USER x-mesh+"true" 50 continue 60 call DIEVTR(IPROB,KLO,KHI) call SPAUSE call DIEFTR(IPROB,KLO,KHI) go to 200 C SDF UNIF mesh 70 call DILMUN() go to 200 C SDF USER lambda-mesh C SDF USER lambda-mesh+"true" 80 continue 90 call DISDTR(IPROB) go to 200 200 continue c print*,'Exit DBDISP: database identification is' c call DBSUMM return end subroutine DBDISP C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine PRHELP(FNAME) C PRHELP displays the 'help text' held in file FNAME.hlp (i.e. the name C held in FNAME, with .hlp appended). FNAME can be a full or relative C pathname. C .. Scalar Arguments .. character*(*) FNAME C .. C .. Local Scalars .. integer IOFLAG,LFNAME character*75 LINE character*79 STARS C .. STARS = '****************************************' + //'***************************************' LFNAME = ITRIM(FNAME) open(20,STATUS='OLD',FILE=FNAME(1:LFNAME)//'.hlp',ERR=190, + IOSTAT=IOFLAG) write(*,*) LINE=STARS LINE(25:25+18+LFNAME) = 'Help from file '//FNAME(1:LFNAME)//'.hlp' 100 write(*,fmt=110) '* '//LINE//' *' 110 format(a79) read (20,fmt='(a)',END=200) LINE go to 100 190 write(*,fmt='(3a,i3)') 'Couldn''t open file ', + FNAME(1:LFNAME)//'.hlp',', error #',IOFLAG 200 write(*,fmt=110) STARS close (20) end subroutine PRHELP C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine REPORT(QEVREP,QEFREP,QSDREP, * SOLVER,IPROB,KLO,KHI,TOLER,IFAIL, * EV, * NXMESH,XMESH,EF,PDEF, * NLMESH,LMESH,RHO, * ELAPSE,OKEXIT) use DBMOD C REPORT is called immediately after SOLVIT to display the computed C e-vs, e-fns and SDF; and if asked, compare them with "true" values. C It does not check the validity of what is asked to do, e.g. if asked C to print e-fn values when none have been computed it will probably C print garbage. C All needed "true" values must have been read into the database cache C 'EVTRUE', 'EFTRUE' or 'SDTRUE' from the database BEFORE REPORT is C called. C C Output: C Main display is to screen. C Unit 20 is logfile solver//nn//'.m' where solver is 6 character name C of current solver, nn is current Problem no. C Unit 21 is auxiliary logfile solver//nn//'.aux' holding eigenfunctions C in form suitable to include in EFTRU.nn database files. C Unit 21 also receives logging data from SLEIGN2 and SLEDGE, if this C has been switched on (by changing the source code of SOLVIT). C Arguments: C QEVREP,QEFREP,QSDREP C Integer, describe what reporting of evs, e-fns and SDF C (respectively) the user requested: C =0 Don't report C =1 Report C =2 Report and compare with "true" values from database C In case of comparing with "true" values, whether this is C done depends on whether the "true" data is actually C present. So a call to the DBMOD routines EVCHK, EFCHK or C SDCHK is made at the appropriate place, to check this. C SOLVER Name of Solver, 'SLEDGE','SL02F' etc C IPROB Problem number C KLO,KHI Eigenvalue index range last used by SOLVIT C TOLER Tolerance last used by SOLVIT C IFAIL IFAIL(K) holds error flag for calculation of e-v of index K C EV EV(K,1) holds computed e-v of index K C EV(K,2) holds estimated error/error-bound for this (see C info in the various SOLVIT routines) C If IFAIL(K).ne.OKEXIT these will be suspect or absent. C It is assumed SOLVIT has set sensible values in this case! C NXMESH NXMESH=no. of points in x-mesh where e-fn values computed, C including endpoints A & B. C XMESH x-mesh is in XMESH(1:NXMESH) C EF,PDEF (only used when QEFREP is 1 or 2) C Indexed 1:MAXMSH,KLO:KHI. EF(I,K),PDEF(I,K) hold value of C u(x),pu'(x) at x=XMESH(I), for K-th e-fn, for I=1:NXMESH C If IFAIL(K).ne.OKEXIT these will be suspect or absent. C !!NOTE!! It is assumed SOLVIT has set them to all zero if absent. C NLMESH NLMESH=no. of points in lambda-mesh where SDF values C computed, including endpoints A & B. C LMESH x-mesh is in LMESH(1:NLMESH) C RHO (only used when QSDREP is 1 or 2) C RHO(I) holds value rho(lambda) of SDF at lambda=LMESH(I) C ELAPSE Total CPU time for Solver call C OKEXIT Value of Solver's error indicator on SUCCESSFUL exit C C Imported from DBMOD: C EVTRU (only used when QEVREP.eq.2) C Array of "true" eigenvalues in given range KLO..KHI, C is in EVTRU(1,K). Believed bound on error is in EVTRU(2,K) C QEVTRU (only used when QEVREP.eq.2) C Flags to say which "true" evs currently provided. If K-th e-v C is present it is in EVTRU(1,K), and QEVTRU(K) equals PRESNT; C otherwise QEVTRU(K) equals ABSENT. C EFTR,PDEFTR (only when QEFREP.eq.2) C Array of "true" e-functions & derivatives in given range C KLO..KHI on given mesh, if provided. C QEFTRU (only used when QEFREP.eq.2) C Flags to say which "true" e-functions currently provided. C If K-th e-fn u_k(x) is present then C values of u_k(x(i)) are in EFTR(i,K) C values of pu'_k(x(i)) are in PDEFTR(i,K) C (i=0..NUMX+1), and QEFTRU(K) equals PRESNT; C otherwise QEFTRU(K) equals ABSENT. C SDTRU (only when QSDREP is 2) C array of "true" rho(lambda) values on lambda-mesh C NLMESH no. of points in lambda-mesh where SDF computed. C LMESH lambda-mesh is in LMESH(1:NLMESH). C! QERROR is not handled properly! It works as the program stands C! but if both evs/efns and SDF were computed in one 'solve', error C! conditions in evs would be overwritten by success in SDF. C .. C .. Scalar Arguments .. integer IPROB,KLO,KHI,NLMESH,NXMESH,OKEXIT, + QEVREP,QEFREP,QSDREP double precision ELAPSE,TOLER character*(*) SOLVER C .. C .. Array Arguments .. integer IFAIL(KLO:KHI) double precision EV(KLO:KHI,1:2), + XMESH(1:MAXMSH), + EF(1:MAXMSH,KLO:KHI),PDEF(1:MAXMSH,KLO:KHI), + LMESH(1:MAXMSH),RHO(1:MAXMSH) C .. C .. Local Scalars .. integer IK,J,K,NFEVAL,KOFSET double precision EFER,PDEFER,ABSERR logical QERROR character KSTR*12 C .. C C***+****|****+****|****BLOCK 1: EIGENVALUES+****|****+****|****+****|** if (QEVREP.gt.0) then KOFSET = KLO-1 C MATLAB initializing statement for e-v variable in .m file: write(20,*) 'ev=[];' write(*,fmt=300) 300 format(' K',T10,'Eigenvalue',T35,'IFAIL', + T52,'Absolute error', + / T30,'(if error exit)',T50,'(est.) ("true")') C QERROR is set to = any(IFAIL(KLO:KHI).ne.OKEXIT) for PRHELP C message below QERROR = .FALSE. C Loop over eigenvalues: do 310 K = KLO,KHI if (IFAIL(K).eq.OKEXIT) then write(*,advance='NO',fmt='(i4,3x,1p,g22.15,t47,d10.2)') + K,EV(K,1),EV(K,2) else QERROR = .TRUE. write(*,advance='NO', + fmt='(i4,''(?)'',1pg22.15,t35,i4,t47,d10.2)') + K,EV(K,1),IFAIL(K),EV(K,2) end if C Are e-v errors to be displayed? C Note EVTRU(2,K) holds believed bound on abs error in C EVTRU(1,K), which we may use in the future. C Note output on unit 20 puts out a dummy value for ABSERR if no C genuine value present if (QEVREP.ge.2 .and. EVCHK(IPROB,KLO,KHI) .and. + QEVTRU(K-KOFSET).eq.PRESNT) then ABSERR = (EV(K,1)-EVTRU(1,K-KOFSET)) write(*,fmt='(1p,d10.2)') ABSERR else ABSERR = 1.0d20 write(*,*) end if write(20,fmt=305) SOLVER,IPROB,TOLER,K,IFAIL(K),EV(K,1),ABSERR write(21,fmt=305) SOLVER,IPROB,TOLER,K,IFAIL(K),EV(K,1),ABSERR 305 format (1x,'%',a,'/0',i3,1p,d10.2,i5,i4,d24.15,d10.2) write(20,fmt=306) K,EV(K,1),ABSERR 306 format(1x,'ev=[ev;',i5,1p,d24.15,d10.2,'];') write(21,'(a,i3)') 'U ',K C***+****|****+****|****BLOCK 2: EIGENFUNCTIONS (inside block 1)+****|** C Are e-fn values and errors to be displayed? C If error flag raised for K-th e-v (if IFAIL(K).eq.0) user is C told values are suspect but they are always displayed. C "True" e-fns: are available in EFTR,PDEFTR but in general only C for some K in KLO..KHI, namely those for which QEFTRU(K) .eq. C PRESNT. C Errors in computed e-fns are reported for these K if QEFREP=2 if (QEFREP.ge.1) then call SPAUSE if (IFAIL(K).ne.OKEXIT) write(*,*) + ' Eigenfunction values are suspect!' write(*,fmt=9999,advance='NO') K 9999 format (1x,'Eigenfunction Values for k=',i4,/ + 1x,8x,'x u(x) pu''(x)') C Error can be displayed if e-fn values present & mesh=USER if (QEFREP.ge.2 .and. EFCHK(IPROB,KLO,KHI) .and. + QEFTRU(K-KOFSET).eq.PRESNT) then write(*,fmt=9998) 9998 format (11x,'u(x) error pu''(x) error') else write(*,fmt=*) end if C Display e-fn values .. C To logfile, put start of a MATLAB statement that will C form a matrix from the x,u and pu' values: write(20,fmt=*) 'a=[ ...' do 307 J=1,NXMESH write(*,fmt=9997,advance='NO')XMESH(J),EF(J,K),PDEF(J,K) write(20,fmt=9997,advance='NO') + XMESH(J),EF(J,K),PDEF(J,K) 9997 format (1x,0p,f12.7,1p,2e18.10) write(21,fmt=99970) EF(J,K),PDEF(J,K) 99970 format (1x,1p,2e18.10) C .. and e-fn errors if asked for & available if (QEFREP.ge.2 .and. EFCHK(IPROB,KLO,KHI) .and. + QEFTRU(K-KOFSET).eq.PRESNT) then EFER = EF(J,K) - EFTR(J,K-KOFSET) PDEFER = PDEF(J,K) - PDEFTR(J,K-KOFSET) write(*,fmt=9996) EFER,PDEFER write(20,fmt=9996) EFER,PDEFER 9996 format (2x,1p,2e12.2) else write(*,fmt=*) write(20,fmt=*) end if 307 continue C Put out MATLAB statements that extract e-fns and their C derivatives to variables u0,pdu0,u1,pdu1, ... call INT2ST(K,KSTR,IK) write(20,fmt=9995) KSTR(1:IK),KSTR(1:IK) 9995 format(' ];',/, + ' u',a,'=a(:,2);',/, + ' pdu',a,'=a(:,3);') if (K.eq.KLO) write(20,fmt=9994) 9994 format(' x=a(:,1);') call SPAUSE end if 310 continue end if C***+****|****+****|*BLOCK 3: SPECTRAL DENSITY FUNCTION****|****+****|** if (QSDREP.ge.1) then QERROR = IFAIL(KLO).ne.OKEXIT if (QERROR) write(*,*) + '***Exit flag has failure value: SDF values are suspect!' write(*,fmt=9993,advance='NO') IFAIL(KLO) 9993 format (1x,'Spectral Density Values: exit flag=',i3,/ + 9x,'lambda',18x,'rho(lambda)') C Error can be displayed if true SDF present if (QSDREP.ge.2 .and. SDCHK(IPROB)) then write(*,fmt=9992) 9992 format (11x,'rho(lambda) error') else write(*,fmt=*) end if C To logfile, put start of a MATLAB statement that will C form a matrix from the lambda and rho(lambda) values: write(20,fmt=*) 'sdf=[ ...' do 312 J=1,NLMESH write(*,advance='NO',fmt='(i4,1p,2g25.15)') + J,LMESH(J),RHO(J) write(20,advance='NO',fmt='(1p,2g25.15)') + LMESH(J),RHO(J) if (QSDREP.ge.2 .and. SDCHK(IPROB)) then write(*,fmt='(1p,d14.2)') RHO(J)-SDTRU(1,J) write(20,fmt='(1p,d10.2)') RHO(J)-SDTRU(1,J) else write(*,*) write(20,*) end if 312 continue write(20,fmt=9991) 9991 format(' ];',/, + ' lambda=sdf(:,1);',/, + ' rho=sdf(:,2);') call SPAUSE end if C Get no. of function evaluations used in SOLVIT call NFEVAL = NEVAL(0) write(*,fmt= + '(1X,"CPU secs:",f10.4,", No. of function evaluations: ",i10)' + ) ELAPSE,NFEVAL write(20,fmt=315) SOLVER,IPROB,TOLER,KLO,KHI,ELAPSE,NFEVAL write(21,fmt=315) SOLVER,IPROB,TOLER,KLO,KHI,ELAPSE,NFEVAL 315 format (1x,'%',a,'/1',i3,1p,d10.2,2i5,0p,f10.4,i10) if (QERROR) call PRHELP('errflags') end subroutine REPORT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine OPNLOG(TSETNM,IPROB,SOLVER) integer IPROB character TSETNM*8,SOLVER*6 integer IOERR,IS,IFNAM0,IFNAME character STR*10,FNAME0*43,FNAME1*43 C OPNLOG opens logfiles for new Problem. Note 'append' status in C case same Problem is used several times in a run. C Main logfile name, in FNAME, is 'solvernn.m' where C solver = name held in SOLVER variable C nn = decimal representation of IPROB C Log file is intended as an executable MATLAB file, hence the '.m' C Auxiliary logfile is 'solvernn.aux' C This is a f77-ish trick for getting nn with leading zeros write(STR,'(i3)') 100+IPROB call STTRIM(SOLVER,IS) FNAME0 = ADDDIR(TSETNM, SOLVER(1:IS)//STR(2:3)) call STTRIM(FNAME0,IFNAM0) FNAME1 = FNAME0(1:IFNAM0)//'.m' call STTRIM(FNAME1,IFNAME) close(20) open(20,file=FNAME1, status='OLD', action='WRITE', + position='APPEND', iostat=IOERR) if (IOERR.eq.0) then write(*,*) 'Appending to log-file ',FNAME1(1:IFNAME) else open(20,file=FNAME1, status='NEW', action='WRITE', + iostat=IOERR) if (IOERR.eq.0) then write(*,*) 'Opening new log-file ',FNAME1(1:IFNAME) else write(*,*) 'Unable to open log-file unit 20, file ', + FNAME1(1:IFNAME),', IOSTAT=',IOERR stop end if end if C ..and auxiliary logfile intended to report e-fns suitably for C including in database files FNAME1 = FNAME0(1:IFNAM0)//'.aux' call STTRIM(FNAME1,IFNAME) close(21) open(21,file=FNAME1, status='OLD', action='WRITE', + position='APPEND', iostat=IOERR) if (IOERR.eq.0) then write(*,*) 'Appending to log-file ',FNAME1(1:IFNAME) else open(21,file=FNAME1, status='NEW', action='WRITE', + iostat=IOERR) if (IOERR.eq.0) then write(*,*) 'Opening new log-file ',FNAME1(1:IFNAME) else write(*,*) 'Unable to open log-file unit 21, file ', + FNAME1(1:IFNAME),', IOSTAT=',IOERR stop end if end if write(*,*) end subroutine OPNLOG C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** character*80 function ADDDIR(DIR,PATH) character*(*) DIR,PATH C DIR is a directory name, PATH is a relative path name (possibly C just a file name). ADDDIR returns the result of prepending DIR C to PATH following the path-naming conventions of the computer system C described by OPSYS. The allowed values of OPSYS are currently C 'MSDOS', 'UNIX', 'VMS' or MAC'. C C Trailing spaces on DIR are checked for and removed. C Total length of result mustn't exceed 80 chars. C C On first call, the user is asked to specify OPSYS. C! If user aborts this, ADDDIR returns all spaces as result: klugey way C! to abort whole program in this case. IMPROVE!! C C To avoid the OPSYS enquiry, the implementation on a specific platform C can simply initialize OPSYS to the appropriate value instead of UNDEF. integer UNDEF,MSDOS,UNIX,MAC,VMS parameter (UNDEF=0,MSDOS=1,UNIX=2,MAC=3,VMS=4) integer LENDIR character*80 A C Backslash: a literal one is treated as escape char by some compilers character*1,parameter:: BSLASH=ACHAR(92) integer,save:: OPSYS=UNDEF if (OPSYS .eq. UNDEF) then write(*,'(a)',advance='NO') + 'Please describe path-name conventions of your system.', + '1 MSDOS e.g. DIR1'//BSLASH//'DIR2'//BSLASH//'FILE', + '2 Unix e.g. dir1/dir2/file', + '3 Mac e.g. :dir1:dir2:file', + '4 VMS e.g. [DIR1.DIR2]FILE', + 'Choose option: ' if (.not. GETIR(OPSYS,1,4)) OPSYS = UNDEF end if LENDIR = ITRIM(DIR) if (OPSYS.eq.MSDOS) then ADDDIR = DIR(1:LENDIR)//BSLASH//PATH else if (OPSYS.eq.UNIX) then ADDDIR = DIR(1:LENDIR)//'/'//PATH else if (OPSYS.eq.MAC) then ADDDIR = DIR(1:LENDIR)//':'//PATH else if (OPSYS.eq.VMS) then A = PATH if (A(1:1).ne.'[') A='[]'//A ADDDIR = '[.'//DIR(1:LENDIR)//A(2:LEN(A)) else if (OPSYS.eq.UNDEF) then ADDDIR = ' ' else write(*,*) 'ADDDIR: Name of operating system "',OPSYS, + '" unknown - unable to construct filenames' stop end if end function ADDDIR subroutine MBROWS(TSETNM,NPROB) character TSETNM*8,BROWSF*12,PARNM*72,TITLE*72 integer IOERR,IPROB,IT,NEPRM,NPARM,NPROB call STTRIM(TSETNM,IT) BROWSF = TSETNM(1:IT)//'.lst' open(21,file=BROWSF,status='OLD',iostat=IOERR) if (IOERR.ne.0) then open(21,file=BROWSF,status='NEW',iostat=IOERR) if (IOERR.ne.0) then write(*,*) 'Unable to open file ',BROWSF,', IOSTAT=',IOERR else call PRHELP('slbrows') call SPAUSE write(21,*) 'Contents of Test Set ',TSETNM do 50 IPROB=1,NPROB call SETUP0(IPROB,TITLE,NPARM,NEPRM,PARNM) write(21,fmt='(/1x,''No.'',i2,'':'',a)') IPROB,TITLE if (NPARM.le.0) then write(21,fmt='(1x,''No parameters'')') else write(21,fmt='(1x,''Parms '',a)') PARNM end if 50 continue close(21) write(*,*) 'Created Browse-File ',BROWSF write(*,*) 'Now look at it with your favourite editor' end if end if end subroutine MBROWS end module SLMOD C***+****|****+****|****+*THE MAIN PROGRAM**+****|****+****|****+****|** program SLDRIVER use SLMOD !also imports SLCONSTS, SLPSET, SLUTIL, SAFEIO, SLTSTPAK use DBMOD !also imports SLCONSTS, SLPSET, SLUTIL, SAFEIO use SOLVRS, only: DEPREC,FORBID,NSOLVR,SLVNAM,SOLVIT implicit none C C .. Parameters .. character*(*) EOFMSG parameter (EOFMSG='z or Z followed by ENTER') C Used to translate 'calculation-mode' values to SOLVIT & REPORT flags: integer,parameter:: QCALC (1:9)=(/1,1,2,3,3,3,4,4,4/) + ,QEVREP(1:9)=(/1,2,1,1,1,2,0,0,0/) + ,QEFREP(1:9)=(/0,0,1,1,1,2,0,0,0/) + ,QSDREP(1:9)=(/0,0,0,0,0,0,1,1,2/) character*24,parameter::ACMENU(1:9)= + (/' EVs only' + ,' EVs+"true"' + ,' EV+EFn, AUTO mesh' + ,' EV+EFn, UNIF mesh' + ,' EV+EFn, USER mesh' + ,'EV+EFn, USER mesh+"true"' + ,' SDF, UNIF mesh' + ,' SDF, USER mesh' + ,' SDF, USER mesh+"true"'/) C .. C .. Local Scalars .. double precision ELAPSE,TOLER integer CHOICE,FLAG,I,IDUM,IPARM,IPROB,ISOLVR,IT,K,KHI,KLO, + NEPRM,NLMESH,NXMESH,NPARM,NPROB,OKEXIT,CALSET + ,CHOIC9 logical OK,SYM character ATYPE*4,BTYPE*4,ATORIG*4,BTORIG*4,BCSTRA*18,BCSTRB*18, + PARNM*72,TITLE*72,SOLVER*6 C .. C .. Local Arrays .. integer IFAIL(1:MAXEVS) double precision PARM(0:10), + EV(1:2*MAXEVS), + XMESH(1:MAXMSH), + EF(1:MAXMSH,1:MAXEVS),PDEF(1:MAXMSH,1:MAXEVS), + LMESH(1:MAXMSH), + RHO(1:MAXMSH) C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Global Initializations ... C Initialize SLTSTPAK package: call TSTINI(TSETNM,NPROB) C Initialize DBMOD package: call DBINIT C Initialize Playback facility call OPNPBK C Intro & Help message: write(*,fmt=19999) TSETNM,NPROB,NSOLVR,(SLVNAM(I),I=1,NSOLVR) 19999 format(/,79('*'),/, + '*',t79,'*',/, + '*',t24,'SLDRIVER Version 4.1 June 1998',t79,'*',/, + '*',t16,'John Pryce''s Driver for Sturm-Liouville solvers', + t79,'*',/, + '*',t79,'*',/, + '*',t15,'Running with Problem Set "',a8,'" of',i3,' problems', + t79,'*',/, + '*',t79,'*',/, + '*',t24,'and the following',i3,' Solvers:',t79,'*',/, + ('*',t79,'*',t22,5a8)) write(*,fmt=19998) EOFMSG 19998 format('*',t79,'*',/, + 79('*'),//, + ' NOTE: Typing ',a,' aborts any data-input operation') call PRHELP('initpuff') call SPAUSE call PRHELP('slhelp0') call SPAUSE C Check for existence of browse file, create it if not: call MBROWS(TSETNM,NPROB) C Initial setting of eigenvalue & eigenfunction & SDF flags: C Calculation mode is 'eigenvalues only' CALSET = 1 C No points in x-mesh for e-fns or lambda-mesh for SDF NXMESH = 0 NLMESH = 0 C Initial input of Problem: C Quit/no-quit loop for initial input starts here: 10 continue C Initialize TRUEDB ("true" e-v & e-fn database) package. C Input is the (relative) Pathname where database is to be found. C ADDDIR will ask user to specify Op Sys pathname conventions here call STTRIM(TSETNM,IT) C! WARNING! unsafe access of DBMOD variable: DBPATH = ADDDIR('truevals',' ') C! ' ' means abort,see doc of ADDDIR: if (DBPATH.eq.' ') go to 90 DBPATH = ADDDIR(TSETNM, DBPATH) if (.not. GTSLVR(ISOLVR,SOLVER,OKEXIT)) go to 90 if (.not.GTPROB(NPROB,IPROB,TITLE,NPARM,NEPRM,PARNM,PARM, + AORIG,BORIG,ATORIG,BTORIG,A1ORIG,A2ORIG,B1ORIG,B2ORIG,SYM)) + go to 90 C Initialize 'endpoints used' to the defaults for this Problem A = AORIG B = BORIG C Also the 'types of the endpoints used' ATYPE = ATORIG BTYPE = BTORIG C and the BC coefficients A1 = A1ORIG A2 = A2ORIG B1 = B1ORIG B2 = B2ORIG C Set initial e-v index-range and tolerance C if (.not.GTINDX(ATYPE,BTYPE,KLO,KHI,MAXEVS)) go to 90 C if (.not.GTTOL(TOLER)) go to 90 C Set default initial e-v index-range and tolerance KLO = 0 KHI = 0 TOLER = 1d-4 go to 99 C Handle user-aborts: 90 if (YESNO('Do you want to quit? (y/n) ').eq.'n') go to 10 call CLOPBK stop 99 continue C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C *** Main Menu loop *** 100 continue C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** write(*,fmt=9999) TSETNM, ACMENU(CALSET), SOLVER, IPROB, TITLE, + PARNM,(PARM(IPARM),IPARM=1,NPARM) 9999 format (//,'Testset: ',a,t33,'*** MAIN MENU ***', + t66,'Current values',/ + ' z Quit (terminate run)',/ + ' 0 Calculation choices',33x,a24,/ + ' eigenvalues; eigenvalues + eigenfunctions;', + ' spectral density function',/ + ' 1 Choose solver',57x,a6,/ + ' 2 Choose problem',59x,i3,/ + ' (',a72,')',:,/ + ' 3 Give parameters (if any) for current problem',/ + 3x,a72,:,/ + 1p,3x,'Currently',7x,4d15.8,(:,19x,4d15.8)) if (ATYPE.eq.'R' .or. ATYPE.eq.'WR') then BCSTRA = " A1*u(a)=A2*pu'(a)" elseif (ATYPE(1:2).eq.'LC') then BCSTRA = '[u,A1*f+A2*g](a)=0' else BCSTRA = ' ' end if if (BTYPE.eq.'R' .or. BTYPE.eq.'WR') then BCSTRB = " B1*u(b)=B2*pu'(b)" elseif (BTYPE(1:2).eq.'LC') then BCSTRB = '[u,B1*f+B2*g](b)=0' else BCSTRB = ' ' end if write(*,fmt=9998) A,B,A1,B1,BCSTRA,BCSTRB,A2,B2,KLO,KHI,TOLER 9998 format(' 4 Give endpoints for current problem',4x,1p,' A =', + d15.8,' B =',d15.8,/ + ' 5 Give one/both BCs for current problem',' A1=',d15.8, + ' B1=',d15.8,/ + ' (',a18,',',a18,') A2=',d15.8,' B2=',d15.8,/ + ' 6 Give eigenvalue index range',35x,i5,' to',i5,/ + ' 7 Give tolerance',52x,d10.2,/ + ' 8 Solve problem as currently given',/ + ' 9 Display/change mesh & "true" values from database') write(*,fmt=9996,advance='NO') AORIG,BORIG,ATORIG,BTORIG,EOFMSG 9996 format ('(Extra information:',4x,'Original endpoints',1p, + ' A =',d15.8,' B =',d15.8,/30x,'Their types',12x,a4,15x, + a4,' )',//'To abort any data-input operation type ',a, + /'Choose option: ') if (GETIR(CHOICE,0,9)) go to (200,210,220,230,240,250,260, + 270,280,290) CHOICE + 1 C ..else drop through into Quit option.. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C *** Main Menu choices *** C C In each choice, if the flag OK is returned as .false. this signals C user aborted the option, nothing was changed & we return to main menu C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C CHOICE=Z, Quit if (YESNO('Do you want to quit? (y/n) ').eq.'n') go to 1001 C Close the Playback file call CLOPBK stop C CHOICE=0, Calculation choices 200 call CAMENU(CALSET) go to 1001 C CHOICE=1, Input Solver 210 if (.not. GTSLVR(ISOLVR,SOLVER,OKEXIT)) go to 1001 write(*,*) ' Solver is now ',SOLVER go to 1000 C CHOICE=2, Input Problem number 220 if (GTPROB(NPROB,IPROB,TITLE,NPARM,NEPRM,PARNM,PARM,AORIG,BORIG, + ATORIG,BTORIG,A1ORIG,A2ORIG,B1ORIG,B2ORIG,SYM)) then C Initialize 'endpoints used' to the defaults for this Problem A = AORIG B = BORIG C Also the 'types of the endpoints used' ATYPE = ATORIG BTYPE = BTORIG C and the BC coefficients A1 = A1ORIG A2 = A2ORIG B1 = B1ORIG B2 = B2ORIG end if go to 1001 C CHOICE=3, Input Parameters 230 if (GTPARM(NPARM,PARNM,PARM,AORIG,BORIG,ATORIG,BTORIG, + A1ORIG,A2ORIG,B1ORIG,B2ORIG,SYM)) then C This resets the 'ORIG' endpts & BCs to the defaults for this value of C PARMs. If A is now <=AORIG and the latter is not Regular, set it C =AORIG and re-set its properties to the defaults, else set its type C to Regular and leave it and its BCs as is. C Similarly at B. if (A.le.AORIG .and. ATORIG.ne.'R') then A = AORIG ATYPE = ATORIG A1 = A1ORIG A2 = A2ORIG else ATYPE = 'R' end if if (B.ge.BORIG .and. BTORIG.ne.'R') then B = BORIG BTYPE = BTORIG B1 = B1ORIG B2 = B2ORIG else BTYPE = 'R' end if end if go to 1000 C CHOICE=4, new values of one or both endpts 240 call GTENDS(A,B,ATYPE,BTYPE,AORIG,BORIG,ATORIG,BTORIG) C A,B are NOT recorded in SLTSTPAK private memory. go to 1000 C CHOICE=5, new values of one or both BCs C Left BC: 250 write(*,advance='NO',fmt= + '(/1x,''New A1,A2 (z or Z to leave unchanged): '')') OK = GT1BC(A1,A2) C If changed, copy the new values into SLTSTPAK internal memory: if (OK) call SETBCS(0,A1,A2) C Right BC: write(*,advance='NO',fmt= + '(1x,''New B1,B2 (z or Z to leave unchanged): '')') OK = GT1BC(B1,B2) C If changed, copy the new values into SLTSTPAK internal memory: if (OK) call SETBCS(1,B1,B2) go to 1000 C CHOICE=6, new eigenvalue index range 260 OK = GTINDX(ATYPE,BTYPE,KLO,KHI,MAXEVS) go to 1000 C CHOICE=7, new tolerance 270 OK = GTTOL(TOLER) go to 1000 C CHOICE=8, solve problem as currently given 280 continue C Open logfile(s) for current Solver & Problem either 'new' or C 'old,append' call OPNLOG(TSETNM,IPROB,SOLVER) C Update the cached "true" values and mesh from database call DBUPDT(CALSET,IPROB,KLO,KHI,FORCE=NO) C If an x-mesh is required, copy from 'XMSHUN' or 'EFTRUE' if (CALSET.eq.4) then if (.not.GTXMUN(NXMESH,XMESH)) then write(*,fmt=9289) 9289 format('Sorry: UNIForm x-mesh, needed for this ', + 'calculation choice, isn''t set.') go to 288 end if end if if (CALSET.eq.5 .or. CALSET.eq.6) then if (.not.GTXMTR(NXMESH,XMESH)) then write(*,fmt=9288) 9288 format('Sorry: USER x-mesh from file, needed for this ', + 'calculation choice, isn''t set',/ + 6x,'..probably because no data file exists for this problem.') go to 288 end if end if C If a lambda-mesh is required, copy from 'LMSHUN' or 'EFTRUE' if (CALSET.eq.7) then if (.not.GTLMUN(NLMESH,LMESH)) then write(*,fmt=9287) 9287 format('Sorry: UNIForm lambda-mesh, needed for this ', + 'calculation choice, isn''t set.') go to 288 end if end if if (CALSET.eq.8 .or. CALSET.eq.9) then if (.not.GTLMTR(NLMESH,LMESH)) then write(*,fmt=9286) 9286 format('Sorry: USER lambda-mesh from file, needed for ', + 'this calc. choice, isn''t set',/ + 6x,'..probably because no data file exists for this problem.') go to 288 end if end if C Use arrays QCALC etc. to convert different calculation-mode values C CALSET = 1 2|3 4 5 6|7 8 9 C to values needed by SOLVIT: C QCALC = 1 1|2 3 3 3|4 4 4 C and by REPORT: C QEVREP = 1 2|1 1 1 2|0 0 0 C QEFREP = 0 0|1 1 1 2|0 0 0 C QSDREP = 0 0|0 0 0 0|1 1 2 C Clear function evaluation counter IDUM = NEVAL(0) C Ensure that ev-index range is valid in case user switched from C a problem with an LCO end to one without: if (KLO.lt.0 .and. ATYPE.ne.'LCO' .and. BTYPE.ne.'LCO') then write(*, + '(/"LCO-style eigenvalue index range no longer valid...")') OK = GTINDX(ATYPE,BTYPE,KLO,KHI,MAXEVS) end if C Set all evs in range to easily recognized dummy value in case C severe failure leaves them without even an estimate do 282 K=KLO,KHI EV(K-KLO+1) = XINFTY 282 continue write(*,fmt=9284) 9284 format(/,15('*'), +' CALLING SOLVER, SOME DIAGNOSTICS MAY BE PRINTED ',15('*')) call SOLVIT(ISOLVR,QCALC(CALSET),A,B,A1,A2,B1,B2,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE,FLAG) C FLAG=OKCALC means solver at least had a go at requested computation. C FLAG=DEPREC means it wasn't recommended but user made it try anyway. C FLAG=FORBID means it couldn't even try (see comments in SOLVIT): if (FLAG.ne.FORBID) then C Now we know REPORT will be called, output 'About the Problem' C info (which main program knows but REPORT doesn't): write(*,fmt=9283) TSETNM, IPROB, SOLVER, ACMENU(CALSET), + PARM(1:NPARM) 9283 format(31('*'),' SOLUTION REPORT ',31('*'),/ + ,'TESTSET: ',a8,', PROBLEM:',i3,', SOLVER: ',a6, + ', COMPUTE',a24,/ + 'Parameter values: ',4d15.8,(:,19x,4d15.8)) write(*,fmt=9282) A,B,TOLER,A1,B1,A2,B2 9282 format(4x,'Endpoints: A =',1p,d15.8,' B =',d15.8,8x, + 'Tolerance:',d9.2/ + 10x,'BCs: A1=',d15.8,' B1=',d15.8,/ + 15x, 'A2=',d15.8,' B2=',d15.8,/ + 79('*')) if (FLAG.eq.DEPREC) write(*,'(/,15x,a,/)') + ' ***Results of "deprecated" calculation' call REPORT(QEVREP(CALSET),QEFREP(CALSET),QSDREP(CALSET), * SOLVER,IPROB,KLO,KHI,TOLER,IFAIL, * EV, * NXMESH,XMESH,EF,PDEF, * NLMESH,LMESH,RHO, * ELAPSE,OKEXIT) end if C Close the two log-files: close(20) close(21) go to 1000 C Unable to call SOLVIT because needed mesh was absent: 288 write(*,'(6x,a)')'Please set needed data or choose another option' go to 1000 C CHOICE=9, display/change mesh & "true" values 290 write(*,advance='NO',fmt=9299) 9299 format (/17x,'***SUBMENU: DISPLAY/CHANGE MESH or "TRUE" DATA***',/ + ' z Return to previous menu',/ + ' 1 Display current mesh or "true" data from file',/ + ' 2 Change/re-read current mesh or "true" data from file',/ + 'Choose option: ') if(GETIR(CHOIC9,1,2)) go to (291,292),CHOIC9 go to 1001 C Display current cached mesh/"true" data: 291 write(*,*) call DBDISP(CALSET,IPROB,KLO,KHI) go to 290 C Update cached mesh/"true" data from database: 292 write(*,*) call DBUPDT(CALSET,IPROB,KLO,KHI,FORCE=YES) call SPAUSE go to 290 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C *** End of Main Menu loop *** C Use 1000 to give a pause before redisplaying menu, else 1001 1000 call SPAUSE 1001 go to 100 end program SLDRIVER SHAR_EOF fi # end of overwriting check if test -f 'slhelp0.hlp' then echo shar: will not over-write existing file "'slhelp0.hlp'" else cat << SHAR_EOF > 'slhelp0.hlp' Each problem in a SLTSTPAK collection comes equipped not only with its differential equation -(p(x)u')' + q(x)u = lambda w(x) u but also with a default interval of solution a 'slpset.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** module SLPSET C The variables which define the current 'settings' of the SLP being C solved. Put in a module to give more convenient access to the few C routines that need to access these from 'outside'. C Done for v4.0. More to add at next revision which is to be more OO! double precision A,A1,A2,B,B1,B2, + AORIG,A1ORIG,A2ORIG,BORIG,B1ORIG,B2ORIG C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine GTABCU(ACURR,BCURR) C Access routine for current SLP endpoints double precision ACURR,BCURR ACURR = A BCURR = B end subroutine GTABCU end module SLPSET SHAR_EOF fi # end of overwriting check if test -f 'sltstpak.f' then echo shar: will not over-write existing file "'sltstpak.f'" else cat << SHAR_EOF > 'sltstpak.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** C * C SLTSTPAK, SLDRIVER by JDP 1993-1998 * C DOCUMENTATION SECTION * C version 4.1, June 1998 * C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C BUG NOTES etc: C C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C REVISION HISTORY C Spring 96. As part of implementation of SLDRIVER v3.0 C - Problem set (TSTSET routine) put in a separate file C - GETBCS had ISING argument removed. This was 'a concession to SL02F' C and my instinct that it was cack-handed proved correct when it C was part of the reason for a subtle bug that only affected problems C with LC, non-Friedrichs, BCs applied at a truncated endpoint C Spring 97. As part of implementation of SLDRIVER v4.0 C - Converted to a F90 module. C June 98. As part of tidying up for TOMS, documentation corrected to C describe the variables that were formerly in COMMON and are now C module variables of each Problem Set module. C These put in a separate module SLTSTVAR, and changes made so that C XINFTY is a global constant rather than a variable C C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C * C GENERAL DESCRIPTION * C * C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C C This package of 13 routines implements an interface between a Test Set C of Sturm-Liouville Problems, (SLPs), and a Driver program which C applies a particular Sturm-Liouville solver to the Test Set. C C The Test Set is entirely contained within a routine TSTSET which is in C a separate module TESTMOD. If a Problem-writer wishes to alter the C Test Set or replace it completely, only TSTSET needs to be altered. C C My naming convention is that TSTSETs live in files whose name reflects C the contents, e.g the set of 60 problems from my book is in C STANDARD.FOR and a small sample collection is in SAMPLE.FOR. C C Communication between SLTSTPAK & TESTMOD is by global (module) C variables of TESTMOD. I chose to put them in TESTMOD rather than in a C separate module in the hope that this will be more efficient: TSTSET C may be called millions of times during the solution of a difficult C SLP. C The alternative of putting them in SLTSTPAK is not available as it C would lead to recursive USE statements. (I think such a structure is C OK in an OO language like Java where each test set would extend a base C class.) C C The documentation uses a few LaTeX conventions, e.g.: \ starts a C special symbol such as \lambda; underscore _ and caret ^ stand C for subscript and superscript; { } enclose a group of symbols. C C DESIGN CONSIDERATIONS: C Functional considerations. C 1. The class of problem catered for is the classical regular or C singular SLP C -(p(x)u')' + q(x)u = \lambda.w(x)u, aa+0} [u,h](x) (2b) C where [u,h](x) = u(x)ph'(x) - pu'(x)h(x); C and h = A1.f + A2.g with A1,A2 constant; C and f, g are appropriate 'admissible' functions defining C independent BCs at the endpoint, such that, if the C endpoint is non-oscillatory, f specifies the C Friedrichs BC. C C 2. The SLP may involve parameters whose values need to be set by the C user. C C 3. The definition of a 'Problem' in the TSTSET code includes C the DE (1), and 'default' BCs (2a) or (2b) as appropriate, but C NOT C the values of any parameters C eigenvalue index k C tolerance TOL C These are to be supplied by the calling main program. C C 4. Brief titling information should be provided C (a) to identify the selected problem C (b) to number and name parameters (for use in prompt for input) C It should be made convenient for the driver program to obtain the C titles of as many Problems as it wishes, e.g. to display a menu of C Problems. C C 5. The endpoints may depend on parameters. So may their type (limit- C circle, regular etc) and hence the kind of BC required there. C C 6. About Boundary Conditions C 6a. The BCs may involve parameters as well as x and \lambda. C These therefore cannot be determined till the parameters have C been set. C C 6b. A default BC shall be provided at each endpoint that needs one C but this may be overridden. C (We support this by providing default values of the BC C coefficients (A1, A2 at x=a, B1, B2 at x=b) and a routine C to provide new values for them.) C C 6c. The typical automatic solution at a LC endpoint (say x=a) entails C replacing the given BC by a sequence of regular BCs of the form C [u,h](a*)=0 at points a* converging to a. This is to be supported. C C 7. It is very desirable that for a problem with parameters, it be C possible to take a parameter other than \lambda to be the C eigenparameter (provided it doesn't occur in the problem in too C complicated a way, what this means is solver-dependent). C C This has been done for the sort of parameter-dependence which C the NAG code D02KEF can handle, and an interface routine COEFF2 C for D02KEF, though not strictly part of the package, is provided C with it. C C 8. The typical pattern of usage of this test set is C (a) Select the problem, set the values of any parameters and C evaluate 'constants' that may depend on these parameters. C (b) Possibly set up BC information for later use. C (c) Set up information needed by the SL solver. C (d) Invoke the solver, which will usually perform a number of C integrations with trial values of \lambda, each of which C typically (depending on the solver used) evaluates the C coefficient functions and invokes the BC information. C (e) Report results. C C Non-functional considerations. C 9. During the solution process the coefficient functions p,q,w C will be evaluated many times (500 to 50000 is typical). C Evaluation of p,q,w should therefore be reasonably rapid. C C10. Any global storage used by the package is to be invisible to the C calling program. C C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C MODULE VARIABLES & CONSTANTS * C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Usage: C NPROB, XINFTY, PI C hold global constants (no. of problems in set, 'infinity', and C pi=3.14... respectively). C NPROB depends on the particular Problem Set being used, accordingly C it is set inside the particular TSTSET routine. C XINFTY, PI are PARAMETERs. C C IPROB, NPARM, PARM, A, B, ATYPE, BTYPE, SYMC C , A1, A2, B1, B2 C hold the State Information for the current Problem namely: C current Problem no.; C no. and values of Parameters for current Problem; C endpoints and their type-info:'regular', 'limit-circle' etc.; C whether Problem is symmetric (=unchanged when reflected in (a+b)/2); C the boundary condition coefficients (set to defaults in SETUP1 code C of TSTSET but alterable by call of SETBCS). C C NEPRM, IPARM C hold further state information only used by a routine like D02KEF C that can choose other parameters as eigenparameter. C NEPRM indicates params 1 to NEPRM are eligible as eigenparameter C in addition to standard lambda which is parameter 0. C IPARM is index of currently selected eigenparameter. C (So 0<=IPARM<=NEPRM<=NPARMA) C C TITLE, PARNM C hold Problem title and names of its Parameters C PARM(0) (equivalenced to EIGA inside TSTSET), X, P, Q, W, PDU, C U are communication variables between TSTSET and other package C routines. C X transfers input data of COEFFN to corresponding sections of C TSTSET code. C P, Q, W transfer output data from TSTSET back to COEFFN. C PARM(0) aka EIGA, X transfer input data of GETBCS to corresponding C sections of TSTSET code. C PDU, U transfer output data from TSTSET back to GETBCS. C NFEVAL C is a statistics variable. It is reset to 0 by calling NEVAL with C IFLAG=0 and increased by 1 at each call to COEFFN. Its value is C returned by the function NEVAL. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C * C END OF DOCUMENTATION * C START OF CODE * C * C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** module SLTSTPAK use SLTSTVAR use TESTMOD implicit none private public:: TSTINI,SETUP0,GTDAT0,SETUP1,COEFFN,GETBCS,SETBCS,NEVAL, + SETIPM,SETEIG,CPU,COEFF2 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine TSTINI(TSETNMA,NPROBA) C Global initialization routine for Test Set, to be called once per run. C There are no input arguments. C Output arguments: C Title of the test set C The number of Problems in the package, C The value to be taken as 'infinity'. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none C .. Scalar Arguments .. integer NPROBA character*8 TSETNMA C .. Intrinsic Functions .. cc intrinsic ATAN2 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Call TSTSET to set Test-set Title and no. of Problems into global C storage: call TSTSET(-1) C Copy information into output arguments for use by Driver program: TSETNMA = TITLE(1:8) NPROBA = NPROB end subroutine TSTINI C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SETUP0(IPROBA,TITLEA,NPARMA,NEPRMA,PARNMA) C Problem initialization routine stage 0, to be called once per Problem. C Input is IPROBA. The remaining arguments are output and C their meanings are as in the instructions on coding up a Problem. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none C .. Scalar Arguments .. integer IPROBA,NEPRMA,NPARMA character PARNMA*72,TITLEA*72 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Copy problem number into global storage: IPROB = IPROBA C Call the problem-specific set-up code to set title and info about C parameters: call TSTSET(0) C Copy resulting info from global storage into output arguments: TITLEA = TITLE NPARMA = NPARM NEPRMA = NEPRM PARNMA = PARNM end subroutine SETUP0 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine GTDAT0(IPROBA,TITLEA,NPARMA,NEPRMA,PARNMA) C This returns the same information as does SETUP0, but *without* C altering the internal state of SLTSTPAK. C Input is IPROBA. The remaining arguments are output and C their meanings are as in the instructions on coding up a Problem. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none C .. Scalar Arguments .. integer IPROBA,NEPRMA,NPARMA character PARNMA*72,TITLEA*72 C .. Local Scalars .. integer IPRSAV C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Save the value of global variable IPROB IPRSAV = IPROB C Copy problem number into global storage IPROB = IPROBA C Call the problem-specific set-up code to set title and info about C parameters: call TSTSET(0) C Copy resulting info from global variables into output arguments: TITLEA = TITLE NPARMA = NPARM NEPRMA = NEPRM PARNMA = PARNM C Restore IPROB, then restore TITLE,NPARM,NEPRM,PARNM to previous values IPROB = IPRSAV call TSTSET(0) end subroutine GTDAT0 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SETUP1(PARMA,AA,BA,ATYPEA,BTYPEA,A1A,A2A,B1A,B2A,SYMA) C Problem initialization routine stage 1, to be called once per Problem C after setting PARMs if any. C Must not be skipped even if NPARMA is 0. C Input is PARMA. The remaining arguments are output and C their meanings are as in the instructions on coding up a Problem. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none C .. Scalar Arguments .. double precision AA,A1A,A2A,BA,B1A,B2A logical SYMA character ATYPEA*4,BTYPEA*4 C .. Array Arguments .. double precision PARMA(0:10) C .. Local Scalars .. integer I C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Copy PARMA values into global storage do 100 I = 0,NPARM PARM(I) = PARMA(I) 100 continue C Call the 2nd section of set-up code which may depend on PARMA values C It sets endpoints, their type etc., and may set certain constants to C be saved inside TSTSET, used by COEFFN and GETBCS for this problem. call TSTSET(1) C Copy resulting info from global storage into output arguments: AA = A BA = B ATYPEA = ATYPE BTYPEA = BTYPE SYMA = SYM A1A = A1 A2A = A2 B1A = B1 B2A = B2 end subroutine SETUP1 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine COEFFN(XA,PA,QA,WA) C Routine to compute coefficient functions p,q,w C Input is XA, output is PA, QA, WA. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none C .. Scalar Arguments .. double precision PA,QA,WA,XA C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Copy input argument into global storage X = XA call TSTSET(2) C Copy output back from global storage PA = P QA = Q WA = W C Increment function evaluation count NFEVAL = NFEVAL + 1 C Put a dot to screen every 1000 evals if (mod(NFEVAL,1000).eq.0) then write(*,fmt='(".")',advance='NO') if (mod(NFEVAL,50000).eq.0) write(*,*) end if end subroutine COEFFN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine GETBCS(IEND,XA,EIGA,PDUA,UA) C Routine to evaluate boundary conditions C Input is IEND, XA, EIGA. Output is PDUA, UA. C GETBCS takes as input C IEND 0 or 1 for left or right endpoint C XA current x value C EIGA current lambda value, in case BC is lambda-dependent C and produces as output C PDUA,UA defining BC at x for this lambda C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none C .. Scalar Arguments .. double precision PDUA,UA,XA,EIGA integer IEND C .. External Subroutines .. cc external SETEIG,TSTSET C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Copy input arguments into global storage before TSTSET call. C Note SETEIG copies into current eigenparameter, i.e. PARM(IPARM): X = XA call SETEIG(EIGA) C Call TSTSET with switch for left or right B to extract C information in global variables; copy to output. if (IEND.eq.0) then call TSTSET(3) else call TSTSET(4) end if PDUA = PDU UA = U end subroutine GETBCS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SETBCS(IEND,C1,C2) C SETBCS overrides the given stored BC coefficients with new ones C As in GETBCS, IEND=0 for left end, IEND=1 for right end C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none C .. Scalar Arguments .. double precision C1,C2 integer IEND C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** if (IEND.eq.0) then A1 = C1 A2 = C2 else B1 = C1 B2 = C2 end if end subroutine SETBCS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** integer function NEVAL(IFLAG) C NEVAL returns the number of COEFFN calls since it was last reset. C IFLAG is input. If IFLAG=0 then the internal counter is reset to C zero (after returning the current value). If IFLAG is not 0 the C counter is not reset. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none C .. Scalar Arguments .. integer IFLAG NEVAL = NFEVAL if (IFLAG.eq.0) NFEVAL = 0 end function NEVAL C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function TYPEOK(TYPE) C TYPEOK verifies that TYPE is one of the allowed endpoint type codes C 'R ', 'WR ', 'LCN ', 'LCO ', 'LPN ' or 'LPNO'. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none C .. Scalar Arguments .. character TYPE*4 C .. Intrinsic Functions .. intrinsic INDEX TYPEOK = INDEX('$R $WR $LCN $LCO $LPN $LPNO','$'//TYPE) .ne. 0 end function TYPEOK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SETIPM(I) C SETIPM sets the global variable IPARM, which selects the parameter C PARMA(IPARM) to be used as the eigenparameter, for use by the D02Kxx C routines which can handle problems nonlinear in a parameter. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none integer I C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** if (I.ge.0 .and. I.le.NPARM) then IPARM = I else print*,'Serious SETIPM error, IPARM=',I,' out of range' stop end if end subroutine SETIPM C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SETEIG(EIGA) C SETEIG copies its argument to the parameter in the SLTSTPAK global storage C that is currently selected as the eigenparameter. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none double precision EIGA if (IPARM.ge.0 .and. IPARM.le.NPARM) then PARM(IPARM) = EIGA else C This should never happen because (I hope) IPARM is protected C from ever having a value outside the range print*,'Serious SETEIG error, IPARM=',IPARM,' out of range' stop end if end subroutine SETEIG C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** SUBROUTINE CPU(OPTION,CURREN,ELAPSE) C Subroutine to initialise CPU time or return the current and C elapsed CPU times in seconds C A general F90 version is supplied, with a VAX/VMS F77 version in C comments C Input C OPTION - INTEGER - 0 initialises CPU time and sets C elapsed to zero. Any other value returns the C elapsed from the input current time and the C current time. C Input/Output C CURREN - DOUBLE PRECISION - Current CPU time in seconds. On entry the time C from some previous call. On exit the time at the C moment with respect to zero. C Output C ELAPSE - DOUBLE PRECISION - Elapsed CPU time in seconds. The difference C between the current time with respect to zero C and the input current time. C .. Scalar Arguments .. INTEGER OPTION DOUBLE PRECISION CURREN,ELAPSE INTEGER ICURR, IRATE C .. Local Scalars .. C(VAX)C TIMECS - CPU time with respect to zero in centi-seconds C(VAX) INTEGER TIMECS C(VAX) INTEGER CPUTIM C(VAX) C(VAX) IF (OPTION .EQ. 0) THEN C(VAX) CURREN = CPUTIM()/100.0 C(VAX) ELAPSE = 0.0 C(VAX) ELSE C(VAX) TIMECS = CPUTIM() C(VAX) ELAPSE = TIMECS / 100.0 - CURREN C(VAX) CURREN = TIMECS / 100.0 C(VAX) END IF ELAPSE = CURREN call SYSTEM_CLOCK(ICURR,IRATE) CURREN = dble(ICURR)/dble(IRATE) if (OPTION.eq.0) then ELAPSE = 0D0 else ELAPSE = CURREN - ELAPSE end if END SUBROUTINE CPU C(VAX) INTEGER FUNCTION CPUTIM() C(VAX)C .. Parameters .. C(VAX) INTEGER*2 NUMLST,MAXLST C(VAX) PARAMETER (NUMLST=1,MAXLST=NUMLST*6 + 2) C(VAX)C .. Local Scalars .. C(VAX) INTEGER*4 STATUS,FRED C(VAX)C .. Local Arrays .. C(VAX) INTEGER*2 ITMLST(MAXLST) C(VAX)C .. Data Statements .. C(VAX) DATA ITMLST / 4,'407'X,0,0,0,0,0,0 / C(VAX)C .. External Functions .. C(VAX) INTEGER*4 SYS$TRNLNM C(VAX) EXTERNAL SYS$TRNLNM C(VAX) INTEGER SYS$GETJPI C(VAX) INTEGER HARRY C(VAX) EQUIVALENCE (HARRY,ITMLST(3)) C(VAX) SAVE C(VAX)C .. Executable Statements .. C(VAX) HARRY = %LOC(FRED) C(VAX) STATUS = SYS$GETJPI(,,,ITMLST,,,) C(VAX) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) C(VAX) CPUTIM = FRED C(VAX) END C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine COEFF2(PA, QQ, WA, XA, MU, JINT) C COEFF2 is of the form needed by the NAG SL solver D02KEF. It C interfaces to SLTSTPAK in such a way that it can handle problems that C are nonlinear in the eigenparameter, this being a facility of the C D02K routines. The interface is a KLUGE but at least it can be done. C C Explanation of logic: C Either the standard parameter lambda held in EIGA (if IPARM .eq. 0), C or the IPARMth of the NPARMA parameters in PARMA(1:NPARMA) (if IPARM C .gt. 0), has been nominated as eigenparameter. Temporarily NPARMA is C called m, IPARM is called i, and the parameters are called mu(1) .. C mu(m). It is assumed that in the standard definition C -(p u')' + q u = lambda w u C of a SLP, C p depends only on x; C q, w may depend on any of mu(1) .. mu(m) and x. C COEFF2 must return QQ = lambda*w - q, and the partial derivative C WA = d(QQ)/d(mu(i)), through the arguments. C If IPARM, that is i, = 0: C this is no problem since WA is just w. Also the input argument MU C can be ignored as far as COEFFN is concerned as the functions do not C depend on it. C Otherwise if i>0, C the value of mu is copied to the mu(i) in global storage currently C nominated as eigenparameter, by calling SETEIG; the writer of the C Problem Code in TSTSET is responsible for ensuring that the COEFFN C code sets QQ = lambda *w - q and WA = d(QQ)/d(mu(i)). C Argument JINT is to do with D02KEF's 'breakpoint' facility. It is C ignored in this routine tho' could be used for Problem 53 of the C standard test set. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** implicit none double precision XA,MU,PA,QQ,WA integer JINT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** PARM(IPARM) = MU call COEFFN(XA,PA,QQ,WA) if (IPARM .eq. 0) QQ = MU*WA-QQ end subroutine COEFF2 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** end module SLTSTPAK SHAR_EOF fi # end of overwriting check if test -f 'sltstvar.f' then echo shar: will not over-write existing file "'sltstvar.f'" else cat << SHAR_EOF > 'sltstvar.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** module SLTSTVAR double precision,parameter:: + PI=3.14159265358979, + XINFTY=HUGE(1D0) c 'tstcom1.f' double precision A1,A2,A,B1,B2,B,P,PDU,Q,U,W,X integer IPROB,NFEVAL,NPROB logical SYM c 'tstcom2.f' character ATYPE*4,BTYPE*4,PARNM*72,TITLE*72 c 'tstcom3.f' integer IPARM,NEPRM,NPARM double precision PARM(0:10),EIG equivalence(EIG,PARM(0)) end module SLTSTVAR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** SHAR_EOF fi # end of overwriting check if test -f 'slutil.f' then echo shar: will not over-write existing file "'slutil.f'" else cat << SHAR_EOF > 'slutil.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** module SLUTIL implicit none C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine MKMESH(N,A,B,AREG,BREG,X) integer N double precision A,B,X(1:N) logical AREG,BREG C Makes a mesh of N points in interval [A,B]. Points are more widely C spaced for large (negative or positive) X in [A,B], a `natural scale' C of O(10) is assumed so for small |A|,|B| the mesh is nearly equally C spaced. If AREG (resp. BREG) is .FALSE. then A (resp. B) C is `singular' and the mesh is formed by increasing N by 1 or 2 as C needed, forming a mesh that includes A and/or B, and then discarding C the singular points. double precision SCALE,XINFTY parameter (SCALE=10D0, XINFTY=1D35) integer I,IOFSET,NN double precision H,T,TA,TB NN = N-1 IOFSET = 1 if (.not. AREG) then NN = NN+1 IOFSET = 0 end if if (.not.BREG) NN = NN+1 TA = A/(SCALE+abs(A)) TB = B/(SCALE+abs(B)) H = (TB-TA)/NN do 100 I=1,N T = TA + (I-IOFSET)*H if (T.ge.1D0) then X(I) = XINFTY else if (T.le.-1D0) then X(I) = -XINFTY else X(I) = SCALE*T/(1D0-abs(T)) end if 100 continue C Ensure the endpoints if included are *exact* if (AREG) X(1) = A if (BREG) X(N) = B c print*,'exit MKMESH: NMESH(=N),MESH(=X):',N,X end subroutine MKMESH C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SELMSH(NIN,XIN,MAXOUT,NOUT,XOUT) C Selects at most MAXOUT elements from a mesh XIN, spreading the C selection as evenly as possible over the indices of XIN and putting C the selected elements in XOUT and the number of them in NOUT. integer NIN,MAXOUT,NOUT double precision XIN(NIN),XOUT(MAXOUT) integer I double precision C NOUT = min(NIN,MAXOUT) C = DBLE(NIN-1)/DBLE(NOUT-1) do 10 I=1,NOUT XOUT(I) = XIN(NINT(C*(I-1))+1) c write(*,'(i5)',advance='NO') NINT(C*(I-1))+1 10 continue c write(*,*) end subroutine SELMSH C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** integer function LG2INT(Q) C .. Scalar Arguments .. logical Q C .. if (Q) then LG2INT = 1 else LG2INT = 0 end if end function LG2INT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** integer function ITRIM(S) C Returns position of last nonblank character of S C .. Scalar Arguments .. character*(*) S C .. C .. Local Scalars .. integer I C .. C .. Intrinsic Functions .. intrinsic LEN C .. I = LEN(S) 10 if (I.eq.0) go to 20 if (S(I:I).ne.' ') go to 20 I = I - 1 go to 10 20 ITRIM = I end function ITRIM C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine STTRIM(STR,ISTR) character*(*) STR integer ISTR C .. Local scalars .. integer I,J C Does roughly the job of the F90 ITRIM function, in F77 terms. C If I,J are the positions of 1st and last nonblank characters of STR C it moves STR(I:J) to STR(1:) and sets ISTR=J-I+1 C it does NOT remove embedded blanks! J=LEN(STR) if (J.eq.0 .or. STR.eq.' ') then ISTR = 0 else C Now STR is nonblank so: 10 if (STR(J:J).eq.' ') then J = J-1 goto 10 end if I = 1 20 if (STR(I:I).eq.' ') then I = I+1 goto 20 end if STR = STR(I:J) ISTR = J-I+1 end if end subroutine STTRIM C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine INT2ST(K,KSTR,IK) integer K,IK character*12 KSTR C converts K to decimal character representation held in KSTR(1:IK) integer LEN parameter(LEN=12) integer I write(KSTR,'(i12)') K I=LEN 100 I=I-1 if (KSTR(I:I).ne.' ') goto 100 IK=LEN-I KSTR=KSTR(I+1:LEN) end subroutine INT2ST end module SLUTIL SHAR_EOF fi # end of overwriting check if test -f 'solvrs.f' then echo shar: will not over-write existing file "'solvrs.f'" else cat << SHAR_EOF > 'solvrs.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** C This file contains C - main module SOLVRS C - small modules C PQWCOM, SL02CM C which act as COMMONs for inter-routine communication. C - auxiliary routines C used by SLEDGE: COEFF C used by SLEIGN,SLEIGN2: P,Q,W,R C used by SLEIGN2: UV C used by SL02F: SETUP C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** module PQWCOM C PQWCOM acts as a COMMON area. It is used by SSLEIG, SSLEI2 because of C FLIPQ which copes with (q(x) in SLEIGN) being -(q(x) in SLEIGN2 & C elsewhere) double precision XX,PP,QQ,WW logical FLIPQ end module PQWCOM C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C SL02CM is used to communicate ISING data to SL02F's SETUP routine module SL02CM character*1 AINFO,BINFO end module SL02CM C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** module SOLVRS use SLCONSTS use SLTSTPAK,only:GETBCS,COEFFN,CPU use SAFEIO,only:SPAUSE,YESNO implicit none C***+****|****+****|****+*** Global Data ***+****|****+****|****+****|** integer,parameter:: NSOLVR=4 + ,ISLED=1,ISLEIG=2,ISL02=3,ISLEI2=4 + ,OKCALC=0, DEPREC=1, FORBID=2 character*6,parameter:: SLVNAM(NSOLVR)= + (/'sledge','sleign','sl02f ','sleig2'/) integer,parameter:: OKEXTS(NSOLVR)=(/0,1,0,1/) C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SOLVIT(ISOLVR,QCALC,A,B,A1,A2,B1,B2,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE,FLAG) C .. C .. Scalar Arguments .. double precision A,B,A1,A2,B1,B2,TOLER double precision,intent(out)::ELAPSE integer ISOLVR,KHI,KLO,NLMESH,NXMESH,QCALC,FLAG character*4 ATYPE,BTYPE C .. C .. Array Arguments .. integer IFAIL(KLO:KHI) double precision LMESH(1:MAXMSH),XMESH(1:MAXMSH), + EV(KLO:KHI,1:2),EF(1:MAXMSH*MAXEVS),PDEF(1:MAXMSH*MAXEVS), + RHO(1:MAXMSH) C SOLVIT oversees the passing of a given Problem to a given Solver with C the extra defining info: type of calculation (shown by QCALC);e-v C index range, tolerance etc. Inside it are Internal Procedures, one for C each Solver, which set up the call to the solver in question. C C SOLVIT has a 'table of capabilities' by which it weeds out C calculations that are deprecated (e.g. giving a non-AUTO x-mesh to C SLEDGE) or impossible (e.g. asking any code except SLEDGE to do SDF C calculation). C - If an impossible calculation is requested it does not attempt it C and returns with FLAG=FORBID. C - If a deprecated one is requested it asks if user wants to go ahead C anyway. If no it returns with FLAG=FORBID, if yes it attempts it and C returns with FLAG=DEPREC. C - Otherwise it attempts it and returns with FLAG=OKCALC (=0). C In this table blank entries mean impossible, (1,2) are deprecated: C +-evs only C | +-evs, & efns on auto mesh C | | +-evs, & efns on uniform or user mesh C | | | +-spectral density fn on unif/user mesh C QCALC=1 2 3 4 C ------------------------- C sledge Y Y (1) Y C sleign Y Y C sl02f Y Y Y C sleig2 Y (2) C (1) Pruess says *don't* allow QCALC=3) C (2) SLEIGN2 *can* do this but the code is in the SLEIGN2 driver & I C haven't worked out what to extract yet C NOTE:The sort of thing that leads to FLAG>0 is asking SLEIGN to make C an AUTO-mesh. Maybe there is a way to make SLEIGN do this but I C haven't found it. On the other hand it was easy to form an C AUTO-mesh from SL02F's output, while SLEDGE can provide it C explicitly. That is, FLAG>0 may be a comment on the competence of C the person who wrote the interface code as much as on the solver. C .. C .. Array Parameters .. integer, parameter:: HOWOK(1:4,1:NSOLVR)=reshape( + (/OKCALC, OKCALC, DEPREC, OKCALC, + OKCALC, FORBID, OKCALC, FORBID, + OKCALC, OKCALC, OKCALC, FORBID, + OKCALC, FORBID, DEPREC, FORBID/) + ,(/4,NSOLVR/)) C .. C .. Local Scalars .. integer I,NXMSH0 double precision UA,UB,PDUA,PDUB,X C .. C .. Local Arrays .. double precision XMESH0(1:MAXMSH) C Input Arguments: C ISOLVR identifies which solver to use, in range 1..NSOLVR C QCALC =1 compute just evs, no efns C =2 compute evs, and efns on mesh automatically generated C by solver C =3 compute evs, and efns on user-supplied mesh C =4 compute spectral density fn (on user-supplied mesh) C A,B,A1,A2,B1,B2,ATYPE,BTYPE C Endpoint & (regular) bdry cond info. C ATYPE,BTYPE are as returned by SLTSTPAK C KLO,KHI range of eigenvalues to find C TOLER tolerance (both abs & rel) passed to Solver C NXMESH,XMESH (Only when QCALC.eq.3) C NXMESH=no. of points in user-supplied x-mesh. C NB! NXMESH may be as large as NXMESH+2 on output so must C have NXMESH<=MAXMSH-2 on input. C User-provided x-mesh is in XMESH(1:NXMESH) C NLMESH,LMESH (Only when QCALC.eq.4) C NLMESH=no. of points in user-supplied lambda-mesh. C User-provided lambda-mesh is in LMESH(1:NLMESH) C C Output Arguments: C Note IFAIL is indexed KLO:KHI in this routine and in REPORT but C indexed 1:MAXEVS in main program where actually declared. C Similarly EV is indexed KLO:KHI,1:2 here and in REPORT C but indexed 1:2*MAXEVS in main program. C Similarly EF,PDEF are indexed 1:MAXMSH,KLO:KHI in REPORT C but indexed 1:(MAXMSH*MAXEVS) here and in main program. C !!NOTE!! C Since there is the possibility for NXMESH to be set by the Solver, C EF,PDEF can't have NXMESH in their dimension definition (within F77 C rules) convenient tho' this would be. C C IFAIL IFAIL(K) must hold Solver's error flag for calc of ev of C index K. C - There is one exception to this: if the input arguments make C an impossible request so that the Solver cannot even be C called (e.g. asking SLEIGN to produce an AUTO-mesh) then C set IFAIL(KLO:KHI) to 999. In this case please set all C EV(K,1) to 0.d0 and all EV(K,2) to 1.d20, and similar C 'silly' values for other output arguments in case REPORT C has a bug & fails to report this fact. C - Routine SABORT can be used to do this. C EV EV(K,1) must hold computed ev of index K. C EV(K,2) must hold an absolute error estimate of the ev. C Depending on the solver, this may be an estimate of C (computed-true) or of a bound on abs(computed-true). C NXMESH,XMESH C (only when QCALC.eq.2) C XMESH(1:NXMESH) is to hold solver-defined x-mesh. C (only when QCALC.eq.3) C XMESH(1:NXMESH) is to hold mesh after SOLVIT has C 'truncated' it if necessary by removing points outside C current endpoints A,B and possibly re-inserting A,B. C EF,PDEF (only when QCALC.eq. 2 or 3) C Indexed 1:MAXMSH,KLO:KHI then EF(I,K),PDEF(I,K) C Indexed 1:... then EF((K-KLO)*MAXMSH+I), C PDEF((K-KLO)*MAXMSH+I) C must hold value of C u(x),pu'(x) at I-th point of XMESH, for K-th efn C ELAPSE Total CPU time for Solver call C FLAG General error flag. Values on exit: C =OKCALC(=0) The solver was able to attempt the requested calculation C even if it failed to produce eigenvalues for some or C all K in KLO:KHI as shown by IFAIL(K) values. C =DEPREC(=1) The calculation was 'deprecated' but user chose to go C ahead anyway C =FORBID(=2) SOLVIT couldn't even attempt the requested calculation C with the current solver. c print*,'enter SOLVIT: NXMESH,XMESH=',NXMESH,XMESH C Test the requested calculation against the 'capabilities table' and C set FLAG accordingly: FLAG = HOWOK(QCALC,ISOLVR) if (FLAG.eq.FORBID) then write(*,*) ' ***Sorry: ',SLVNAM(ISOLVR), + ' cannot provide the requested calculation' else if (FLAG.eq.DEPREC) then write(*,*)' ***Note: this calculation is not recommended for ', + SLVNAM(ISOLVR),' at present' if (YESNO( + ' Results may be suspect, go ahead anyway?').eq.'n') then FLAG = FORBID end if end if if (FLAG.eq.FORBID) return C ..else continue with normal processing .. C If current endpoints are regular, either originally or by truncation C of singular point C GETBCS will find coefficients (PDUA,UA), (PDUB,UB) which define C the regular BCs to be imposed at current endpoints, in case of C solvers that need this in their argument list. C else C set (PDUA,UA), (PDUB,UB) to the values (A1,A2), (B1,B2) that C appear on the Main Menu C end if C The EIG argument is arbitrarily taken as 0.0. SLEDGE will extract C what lambda-dependence it can support by making a further call to C GETBCS with EIG=1.0. if (ATYPE.eq.'R') then call GETBCS(0,A,0d0,PDUA,UA) else PDUA = A1 UA = A2 end if if (BTYPE.eq.'R') then call GETBCS(1,B,0d0,PDUB,UB) else PDUB = B1 UB = B2 end if C If QCALC=3, convert NXMESH,XMESH by removing points outside (A,B) and C re-inserting A (sim. B) if it is regular or if solver is SLEDGE. C NB! No. of points NXMESH may increase by up to 2 as a result! C When checking whether a point is 'inside (A,B)', we require it to be C actually in ((A+1e-6*|A|), (B-1e-6*|B|)) This avoids including end C values twice if they have been read from the database and are a bit C inaccurate. The factor 1e-6 seems sensible: the user must give >6 sig C figs when he types the x values into the database. NXMSH0 = NXMESH do 90 I=1,NXMESH XMESH0(I) = XMESH(I) 90 continue if (QCALC.eq.3) then NXMESH = 0 if (ATYPE.eq.'R' .or. ISOLVR.eq.ISLED) then NXMESH = NXMESH+1 XMESH(NXMESH) = A end if do 100 I=1,NXMSH0 X = XMESH0(I) if (X.gt.(A+1d-6*abs(A)) .and. X.lt.(B-1d-6*abs(B))) then NXMESH = NXMESH+1 XMESH(NXMESH) = X end if 100 continue if (BTYPE.eq.'R' .or. ISOLVR.eq.ISLED) then NXMESH = NXMESH+1 XMESH(NXMESH) = B end if end if write (*,*) C See at bottom of TSTSET routine where dots are generated: write(*,*) 'Each dot represents 1000 function evaluations:' if (ISOLVR.eq.ISLED) then call SSLED(QCALC,A,B,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE, + UA,PDUA,UB,PDUB) else if (ISOLVR.eq.ISLEIG) then call SSLEIG(QCALC,A,B,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE, + UA,PDUA,UB,PDUB) else if (ISOLVR.eq.ISL02) then call SSL02(QCALC,A,B,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE, + UA,PDUA,UB,PDUB) else if (ISOLVR.eq.ISLEI2) then call SSLEI2(QCALC,A,B,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE, + UA,PDUA,UB,PDUB) else write (*,*) 'Invalid Solver-ID number requested: ',ISOLVR stop end if C To terminate the ...'s in TSTSET counting 1000 fn evals: write(*,*) end subroutine SOLVIT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C---+----|----+----|----+----|----+----|----+----|----+----|----+----|-- subroutine SSLED(QCALC,A,B,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE, + UA,PDUA,UB,PDUB) use SLEDGEMD implicit none C .. C .. Scalar Arguments .. double precision A,B,TOLER, + UA,PDUA,UB,PDUB double precision,intent(out)::ELAPSE integer KHI,KLO,NLMESH,NXMESH,QCALC character*4 ATYPE,BTYPE C .. C .. Array Arguments .. integer IFAIL(KLO:KHI) double precision LMESH(1:MAXMSH),XMESH(1:MAXMSH), + EV(KLO:KHI,1:2),EF(1:MAXMSH*MAXEVS),PDEF(1:MAXMSH*MAXEVS), + RHO(1:MAXMSH) C Interface to SLEDGE whose argument list is C subroutine SLEDGE(JOB,CONS,ENDFIN,INVEC,TOL,TYPE,EV,NUMX,XEF,EF, C + PDEF,T,RHO,IFLAG,STORE) C In the call, actual arguments have the same names as dummy ones C except as in the table: C Dummy Actual C EV EV(:,1) C XEF XMESH C T RHO C IFLAG IFAIL C .. Parameters .. C ISTORE is workspace size, see description of STORE in SLEDGE code integer ISTORE parameter (ISTORE=26*MAXMSH+16) C .. C .. Local Scalars .. double precision PDUA1,UA1,CURREN integer I,IK,K,NUMX C .. C .. Local Arrays .. double precision CONS(1:8),STORE(1:ISTORE),TOL(1:6) integer INVEC(1:3+MAXEVS) logical ENDFIN(1:2),JOB(1:5),TYPE(1:4,1:2) C .. C .. External Subroutines .. cc external SLEDGE C .. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Set up endpoint and regular BC info for SLEDGE: C Note SLEDGE's B1,B2 is my PDUB,-UB CONS(1) = PDUA CONS(3) = UA CONS(5) = PDUB CONS(6) = -UB C At x=a, SLEDGE allows lambda-dependent BC of form C (A1-EIG*A1')u(a) = (A2-EIG*A2')pu'(a) C Extract A1',A2' by a further call to GETBCS with EIG=1.0, and C linearizing. But only if of type 'R', to avoid zerodivide etc in C evaluating BC fns in TSTSET if (ATYPE.eq.'R') then call GETBCS(0,A,1d0,PDUA1,UA1) CONS(2) = PDUA-PDUA1 CONS(4) = UA-UA1 else CONS(2) = 0D0 CONS(4) = 0D0 end if CONS(7) = A CONS(8) = B ENDFIN(1) = A .ne. -XINFTY ENDFIN(2) = B .ne. XINFTY C Set correct pattern of JOB(1:5) settings for allowed QCALC values: C (See SLEDGE documentation for details. Certain SLEDGE options can not C be exercised, e.g. to compute evs & SDF at a single call.) C QCALC \ JOB(I),I= 1 2 3 4 5 C---------------------------------------------------- C 1 evs, no efns | T F F F T C 2 evs + efns AUTO x-mesh | F T F F T C 3 evs + efns USER x-mesh | F T F F F C 4 sp dens fn USER lambda-mesh | F F T F T C JOB(1) = QCALC.eq.1 JOB(2) = QCALC.eq.2 .or. QCALC.eq.3 JOB(3) = QCALC.eq.4 C JOB(4): automatic end-classif'n wanted JOB(4) = .FALSE. C Choose SLEDGE-supplied (JOB(5)= .TRUE.) or user-supplied x-mesh: if (QCALC.ne.3) then JOB(5) = .TRUE. NUMX = 0 else C Supplied mesh MUST contain A,B: I think I've achieved this! JOB(5) = .FALSE. NUMX = NXMESH end if C Set printing level (0 unless debugging): INVEC(1) = 0 C Set no. of lambda-points for SDF calculation: INVEC(2) = NLMESH C Number of eigenvalues to be computed: if (KHI-KLO+1.le.MAXEVS) then INVEC(3) = KHI - KLO + 1 else write (*,FMT=*) + ' Too many eigenvalues requested, reduced to ',MAXEVS INVEC(3) = MAXEVS end if C Indices of eigenvalues sought: C SLEDGE allows them to be non-contiguous but SOLVIT interface doesn't do 300 I = 1,INVEC(3) INVEC(3+I) = KLO + I - 1 300 continue C Set vector of tolerances: TOL(1) = TOLER TOL(2) = TOLER TOL(3) = TOLER TOL(4) = TOL(2) TOL(5) = TOLER TOL(6) = TOL(2) c print*,'before SLEDGE:NXMESH,XMESH(1:NXMESH)=', c + NXMESH,XMESH(1:NXMESH) C Reset the CPU clock call CPU(0,CURREN,ELAPSE) C In this call, note the ev's are put in the 1st column of array EV: call SLEDGE(JOB,CONS,ENDFIN,INVEC,TOL,TYPE,EV,NUMX,XMESH,EF,PDEF, + LMESH,RHO,IFAIL,STORE) C Read the CPU clock call CPU(1,CURREN,ELAPSE) C Update NXMESH since for QCALC.ne.3 NUMX is set by SLEDGE NXMESH = NUMX c print*,'after SLEDGE:NXMESH,XMESH(1:NXMESH)=', c + NXMESH,XMESH(1:NXMESH) C SLEDGE doesn't give error estimates as such so set the error-estimate C entries of EV to indicate estimated mixed rel-abs bound of TOLER, or C dummy value if failure exit. do 380 K=KLO,KHI if (IFAIL(K).eq.0) then EV(K,2) = TOLER*max(abs(EV(K,1)),1D0) else EV(K,2) = 1D20 end if 380 continue C Output SLEDGE's endpoint-classification data (as REPORT doesn't know C about this). It's supposed to be independent of K so I assume checking C IFAIL(KLO) tells me whether SLEDGE has failed to produce it (IFAIL<0) C or believes it is not to be trusted (IFAIL contains the digit 2) write(*,FMT=9999) 'A',(TYPE(I,1),I=1,4), 'B',(TYPE(I,2),I=1,4) 9999 format(/,'Classification of endpoint ',a,': Regular=',L1, + ', LC =',L1,', Nonosc all EV=',L1,', Osc all EV=',L1) write(20,FMT=9998) 'A',(TYPE(I,1),I=1,4), 'B',(TYPE(I,2),I=1,4) 9998 format(' %Classification of endpoints: ',2(1x,a,' =',4L2)) if (HASDIG(IFAIL(KLO),2)) then write(*,*) 'There is doubt about this (IFAIL=2)' write(20,*) ' %There is doubt about this (IFAIL=2)' end if call SPAUSE C If efns were computed (JOB(2) is true) relocate their values from C SLEDGE's storage (consecutive blocks of length NUMX) to REPORT's C storage (EF,PDEF treated as dimensioned (1:MAXMSH,KLO:KHI)). C Work backwards as we are rearranging storage on top of itself. C However if IFAIL(K)<0 (SLEDGE fatal error) set all the values C to 0. if (JOB(2)) then do 410 K=KHI,KLO,-1 IK = K-KLO if (IFAIL(K).ge.0) then do 400 I=NUMX,1,-1 EF(IK*MAXMSH+I) = EF(IK*NUMX+I) PDEF(IK*MAXMSH+I) = PDEF(IK*NUMX+I) 400 continue else do 405 I=NUMX,1,-1 EF(IK*MAXMSH+I) = 0D0 PDEF(IK*MAXMSH+I) = 0D0 405 continue end if 410 continue end if end subroutine SSLED C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function HASDIG(N,D) implicit none integer N,D C To help interpret SLEDGE's positive IFAIL values. C Gives TRUE iff D is one of the decimal digits of N C (1041 has digits 0,1,4; so does -1041; 0 has digit 0) integer NN NN = abs(N) 10 if (mod(NN,10).eq.D) goto 20 NN = NN/10 if (NN.ne.0) go to 10 HASDIG = .FALSE. return 20 HASDIG = .TRUE. end function HASDIG C---+----|----+----|----+----|----+----|----+----|----+----|----+----|-- subroutine SSLEIG(QCALC,A,B,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE, + UA,PDUA,UB,PDUB) use SLEIGNMD use PQWCOM use TESTMOD,only:ABINFO implicit none C .. C .. Scalar Arguments .. double precision A,B,TOLER, + UA,PDUA,UB,PDUB double precision,intent(out)::ELAPSE integer KHI,KLO,NLMESH,NXMESH,QCALC character*4 ATYPE,BTYPE C .. C .. Array Arguments .. integer IFAIL(KLO:KHI) double precision LMESH(1:MAXMSH),XMESH(1:MAXMSH), + EV(KLO:KHI,1:2),EF(1:MAXMSH*MAXEVS),PDEF(1:MAXMSH*MAXEVS), + RHO(1:MAXMSH) C Interface to SLEIGN whose argument list is C SUBROUTINE SLEIGN(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2, C 1 NUMEIG,EIG,TOL,IFLAG,ISLFUN,SLFUN) C In the call, actual arguments have the same names as dummy ones C except as in the table: C Dummy Actual C A1 PDUA C A2 -UA C B1 PDUB C B2 -UB C .. C .. Local Scalars .. integer I,IFLAG,IK,INTAB,ISLFUN,J,K,NUMEIG,AOFSET,BOFSET double precision CURREN double precision DUM,EIG,TOL,P0ATA,QFATA,P0ATB,QFATB C .. C .. Local Arrays .. double precision SLFUN(1:9+MAXMSH) C .. C .. External Functions .. double precision P external P C .. C .. External Subroutines .. cc external SLEIGN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C NOTE: SLEIGN's notation differs from my standard in these ways: C Its NUMEIG is (my K)+1 C Its A1,A2 are my PDUA,-UA & same for B1,B2 C Its q(x) is -(my q(x)) C His coeff functions (my p,-q,w) MUST be called p,q,r C C SLEIGN has no way (that I know) to generate AUTO mesh for efns: if (QCALC.eq.2) then write (*,9999) 9999 format('SLEIGN interface can''t provide AUTO-mesh, please '/ + 'select a different option in EFMENU or another solver') C! call SABORT return end if C Make Q(X) flip the sign of q: FLIPQ = .TRUE. C Set up endpoint info for SLEIGN C Say if finite or infinite endpoints by INTAB=1,2,3 or 4: INTAB = 1 if (B.eq.XINFTY) INTAB = INTAB + 1 if (A.eq.-XINFTY) INTAB = INTAB + 2 C Say if p(x)=0 and q(x)=finite at endpoints. C The ABINFO routine gives the data for *untruncated* endpoints: call ABINFO(P0ATA,QFATA,P0ATB,QFATB) C .. but if end is regular, originally or by *truncation* then the C following apply: if (ATYPE.eq.'R') then P0ATA = -1D0 QFATA = 1D0 end if if (BTYPE.eq.'R') then P0ATB = -1D0 QFATB = 1D0 end if C Dummy evaluation of coefficient function, see code of P,Q,R. C Use the x/(1+|x|) map & its inverse t/(1-|t|) C to safely find an interior point of (A,B) DUM = 0.5D0*(A/(1+abs(A)) + B/(1+abs(B))) DUM = P(DUM/(1-abs(DUM))) C Reset the CPU clock: call CPU(0,CURREN,ELAPSE) C Loop over eigenvalues: do 300 K = KLO,KHI C Make SLEIGN choose own guess of EIG: EIG = 0.0D0 C Make local copy of TOLER (since changed by SLEIGN): TOL = TOLER C Make local copy of K (since may be changed by SLEIGN) C Also SLEIGN indexes evs from 1, not 0 NUMEIG = K+1 C Control eigenfunction calculation. C If ISLFUN>0 then: C SLFUN(9+1:9+ISLFUN) holds x(i) on entry, u(x(i)) on exit if (QCALC.eq.1) then C Evs only ISLFUN = 0 else if (QCALC.eq.2) then C We should have excluded this so: write(*,*) 'ERROR in SSLEIG: QCALC=2 shouldn''t get here!' stop else C Efns computed on USER-mesh C Careful! All my meshes contain A,B. But SLEIGN bombs out if C given a singular endpoint as part of its mesh. So discard C XMESH(1) and/or XMESH(NXMESH) if singular, and insert dummy C e-fn values (zero) in the output array, after the solver call. C NB: moving the end meshpoints inwards a bit is not an option, C as the results would not be comparable with those produced by C other solvers AOFSET = 0 BOFSET = 0 if (ATYPE.ne.'R') AOFSET = 1 if (BTYPE.ne.'R') BOFSET = 1 ISLFUN = NXMESH-AOFSET-BOFSET do 110 I=1,ISLFUN SLFUN(9+I) = XMESH(I+AOFSET) 110 continue end if call SLEIGN(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,PDUA,-UA, + PDUB,-UB,NUMEIG,EIG,TOL,IFLAG,ISLFUN,SLFUN) C Extract SLEIGN's 'out' or 'inout' arguments: IFAIL(K) = IFLAG C Get ev estimate, & estimate of absolute error bound: EV(K,1) = EIG EV(K,2) = max(1D0,abs(EIG))*TOL C Get efn values u(x(i)); note SLEIGN doesn't provide pu' values C Insert dummy u=0 at singular ends, see "Careful!" above if (QCALC.ge.2) then c print*,'SLFUN(1:9+NXMESH)=',SLFUN(1:9+NXMESH) IK = (K-KLO)*MAXMSH do 120 J=1,NXMESH I = J-AOFSET if (I.ge.1 .and. I.le.ISLFUN) then EF(IK+J) = SLFUN(9+I) else EF(IK+J) = 0D0 end if PDEF(IK+J) = 0D0 120 continue end if C Report if SLEIGN altered NUMEIG: if (NUMEIG-1.ne.K) then write (*,*) 'It appears eigenvalue',K,' does not exist' write (*,*) 'Estimated index of last eigenvalue is',NUMEIG-1 end if 300 continue C Read the CPU clock: call CPU(1,CURREN,ELAPSE) end subroutine SSLEIG C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SSLEI2(QCALC,A,B,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE, + UA,PDUA,UB,PDUB) use SLEIG2MD use PQWCOM use TESTMOD,only:ABINFO implicit none C .. C .. Scalar Arguments .. double precision A,B,TOLER, + UA,PDUA,UB,PDUB double precision,intent(out)::ELAPSE integer KHI,KLO,NLMESH,NXMESH,QCALC character*4 ATYPE,BTYPE C .. C .. Array Arguments .. integer IFAIL(KLO:KHI) double precision LMESH(1:MAXMSH),XMESH(1:MAXMSH), + EV(KLO:KHI,1:2),EF(1:MAXMSH*MAXEVS),PDEF(1:MAXMSH*MAXEVS), + RHO(1:MAXMSH) C Interface to SLEIGN2 whose argument list is C subroutine SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2, C + NUMEIG,EIG,TOL,IFLAG,ISLFUN,SLFUN,SINGATA, C + SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) C In the call, actual arguments have the same names as dummy ones C except as in the table: C Dummy Actual C A1 PDUA C A2 -UA C B1 PDUB C B2 -UB C .. C .. Local Scalars .. integer I,IFLAG,IK,INTAB,ISLFUN,J,K,NUMEIG,AOFSET,BOFSET double precision CURREN double precision DUM,EIG,TOL,P0ATA,QFATA,P0ATB, + QFATB,SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB C .. C .. Local Arrays .. double precision SLFUN(1:9+MAXMSH) C .. C .. External Functions .. double precision P external P C .. C .. External Subroutines .. cc external SLEIGN2 C Special COMMON for counting no. of calls to SLEIGN2's UV routine common/SLEI2C/ NUVEVL integer NUVEVL C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C NOTE: SLEIGN2's notation differs from my standard in these ways: C Its A1,A2 are my PDUA,-UA & same for B1,B2 C C Make Q(X) NOT flip the sign of q: FLIPQ = .FALSE. C SLEIGN2 has no way (that I know) to generate AUTO mesh for efns: if (QCALC.eq.2) then write (*,9999) 9999 format('SLEIGN2 interface can''t provide AUTO-mesh, please '/ + 'select a different option in EFMENU or another solver') C! call SABORT return end if C Set up endpoint info for SLEIGN2 C Say if finite or infinite endpoints by INTAB=1,2,3 or 4: INTAB = 1 if (B.eq.XINFTY) INTAB = INTAB + 1 if (A.eq.-XINFTY) INTAB = INTAB + 2 C Say if p(x)=0 and q(x)=finite at endpoints. C The ABINFO routine gives the data for *untruncated* endpoints: call ABINFO(P0ATA,QFATA,P0ATB,QFATB) C .. but if end is regular, originally or by *truncation* then the C following apply: if (ATYPE.eq.'R') then P0ATA = -1D0 QFATA = 1D0 end if if (BTYPE.eq.'R') then P0ATB = -1D0 QFATB = 1D0 end if C Classify type of singularity if any: if (ATYPE.eq.'R' .or. ATYPE.eq.'WR') then SINGATA = -1.0D0 CIRCLA = -1.0D0 OSCILA = -1.0D0 else if (ATYPE.eq.'LCN') then SINGATA = 1.0D0 CIRCLA = 1.0D0 OSCILA = -1.0D0 else if (ATYPE.eq.'LCO') then SINGATA = 1.0D0 CIRCLA = 1.0D0 OSCILA = 1.0D0 else C for LP, LPNO it doesn't matter but: SINGATA = 1.0D0 CIRCLA = -1.0D0 OSCILA = -1.0D0 end if if (BTYPE.eq.'R' .or. BTYPE.eq.'WR') then SINGATB = -1.0D0 CIRCLB = -1.0D0 OSCILB = -1.0D0 else if (BTYPE.eq.'LCN') then SINGATB = 1.0D0 CIRCLB = 1.0D0 OSCILB = -1.0D0 else if (BTYPE.eq.'LCO') then SINGATB = 1.0D0 CIRCLB = 1.0D0 OSCILB = 1.0D0 else C for LP, LPNO it doesn't matter but: SINGATB = 1.0D0 CIRCLB = -1.0D0 OSCILB = -1.0D0 end if C Dummy evaluation of coefficient function, see code of P,Q,R. C Use the x/(1+|x|) map & its inverse t/(1-|t|) C to safely find an interior point of (A,B) DUM = 0.5D0*(A/(1+abs(A)) + B/(1+abs(B))) DUM = P(DUM/(1-abs(DUM))) C Reset the CPU clock: call CPU(0,CURREN,ELAPSE) C Zero the counter of calls to SLEIGN2's UV routine: NUVEVL = 0 C See at bottom of UV routine in problem set, where dots are generated: write(*,*) + 'Each + represents 1000 calls to SLEIGN2''s UV routine:' C Loop over eigenvalues: do 300 K = KLO,KHI C Make SLEIGN2 choose own guess of EIG: EIG = 0.0D0 C Make local copy of TOLER (since changed by SLEIGN2): C Minus sign requests trace-output TOL = -TOLER C Make local copy of K (since may be changed by SLEIGN2) NUMEIG = K C Control eigenfunction calculation. C If ISLFUN>0 then: C SLFUN(9+1:9+ISLFUN) holds x(i) on entry, u(x(i)) on exit if (QCALC.eq.1) then C Evs only ISLFUN = 0 else if (QCALC.eq.2) then C We should have excluded this so: write(*,*) 'ERROR in SSLEI2: QCALC=2 shouldn''t get here!' stop else C Efns computed on USER-mesh C See "Careful!" comments in SLEIGN interface. C Same applies here except we shouldn't be using this way C to compute e-fns, which seems faulty for SLEIGN2 AOFSET = 0 BOFSET = 0 if (ATYPE.ne.'R') AOFSET = 1 if (BTYPE.ne.'R') BOFSET = 1 ISLFUN = NXMESH-AOFSET-BOFSET do 110 I=1,ISLFUN SLFUN(9+I) = XMESH(I+AOFSET) 110 continue end if c Testprints: c print*,'SSLEI2: A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,PDUA,-UA=', c + A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,PDUA,-UA c print*,'SSLEI2: PDUB,-UB,NUMEIG,EIG,TOL,IFLAG,ISLFUN=', c + PDUB,-UB,NUMEIG,EIG,TOL,IFLAG,ISLFUN c print*,'SSLEI2: SINGATA,CIRCLA,OSCILA,SINGATB,CIRCLB,OSCILB=', c + SINGATA,CIRCLA,OSCILA,SINGATB,CIRCLB,OSCILB c call SPAUSE c call SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,PDUA,-UA, + PDUB,-UB,NUMEIG,EIG,TOL,IFLAG,ISLFUN,SLFUN, + SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) C Extract SLEIGN2's 'out' or 'inout' arguments: C It seems a multiple of 100 is added to the 'normal' flag value C to give extra info to SLEIGN2's driver. Remove this: IFAIL(K) = modulo(IFLAG,100) C Get ev estimate, & estimate of absolute error bound: EV(K,1) = EIG EV(K,2) = max(1D0,abs(EIG))*TOL C Get efn values u(x(i)); C Insert dummy u=0 at singular ends C .. see "Careful!" above in this routine & in SLEIGN interface if (QCALC.ge.2) then c print*,'SLFUN(1:9+NXMESH)=',SLFUN(1:9+NXMESH) IK = (K-KLO)*MAXMSH do 120 J=1,NXMESH I = J-AOFSET if (I.ge.1 .and. I.le.ISLFUN) then EF(IK+J) = SLFUN(9+I) else EF(IK+J) = 0D0 end if PDEF(IK+J) = 0D0 120 continue end if C Report if SLEIGN2 altered NUMEIG: if (NUMEIG.ne.K) then write(*,*) write (*,*) 'It appears eigenvalue',K,' does not exist' write (*,*) 'Estimated index of last eigenvalue is',NUMEIG end if write (*,*) 'K = ',K,' done' 300 continue C Read the CPU clock: call CPU(1,CURREN,ELAPSE) write (*,fmt= + '(1X,''No. of calls to UV routine: '',i8)') NUVEVL end subroutine SSLEI2 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SSL02(QCALC,A,B,ATYPE,BTYPE, + KLO,KHI,TOLER, + NXMESH,XMESH,NLMESH,LMESH, + IFAIL,EV,EF,PDEF,RHO, + ELAPSE, + UA,PDUA,UB,PDUB) use MARCOMOD C Needed for SELMSH routine: use SLUTIL use SL02CM implicit none C .. C .. Scalar Arguments .. double precision A,B,TOLER, + UA,PDUA,UB,PDUB double precision,intent(out)::ELAPSE integer KHI,KLO,NLMESH,NXMESH,QCALC character*4 ATYPE,BTYPE C .. C .. Array Arguments .. integer IFAIL(KLO:KHI) double precision LMESH(1:MAXMSH),XMESH(1:MAXMSH), + EV(KLO:KHI,1:2),EF(1:MAXMSH*MAXEVS),PDEF(1:MAXMSH*MAXEVS), + RHO(1:MAXMSH) C Interface to SL02F whose argument list is C subroutine SL02F(ELAM,A,B,K,AINFO,BINFO,SYM,TOL,COEFFN,SETUP,N,WK, C & IWK,WKSMAL,ISMAL,KNOBS,IFAIL) C In the call, actual arguments have the same names as dummy ones C except as in the table: C Dummy Actual C A ALOC C B BLOC C TOL TOLER C IFAIL IFAILA C .. Parameters .. integer IWK,ISMAL parameter (IWK=8000,ISMAL=130) C .. C .. Local Scalars .. double precision ALOC,BLOC,CURREN integer I,IFAILA,IK,K,N logical SYM,HAVEIG C .. C .. Local Arrays .. double precision EIGFNS(0:1,1:3),ELAM(1:2), + WK(0:IWK,1:4),WKSMAL(0:ISMAL,1:7) integer KNOBS(1:2) C .. C .. External Subroutines .. cc external SETUP,SL02F external SETUP C .. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Set up endpoint info for SL02F if (ATYPE.eq.'R') then AINFO = 'R' else if (ATYPE.eq.'LCN' .and. A.gt.-XINFTY) then AINFO = 'S' else if (ATYPE.eq.'LCO') then AINFO = 'S' write (6,FMT=*) + ' ** Endpoint b is of type LCO which SL02F cannot handle', + ' but will have a go' else if (ATYPE(1:2).eq.'LP' .and. A.gt.-XINFTY) then AINFO = 'S' else if (ATYPE.eq.'WR' .and. A.gt.-XINFTY) then AINFO = 'S' else AINFO = 'I' end if if (BTYPE.eq.'R') then BINFO = 'R' else if (BTYPE.eq.'LCN' .and. B.lt.XINFTY) then BINFO = 'S' else if (BTYPE.eq.'LCO') then BINFO = 'S' write (6,FMT=*) + ' ** Endpoint b is of type LCO which SL02F cannot handle', + ' but will have a go' else if (BTYPE(1:2).eq.'LP' .and. B.lt.XINFTY) then BINFO = 'S' else if (BTYPE.eq.'WR' .and. B.lt.XINFTY) then BINFO = 'S' else BINFO = 'I' end if C At present SOLVIT isn't passing symmetry info across so: SYM = .false. C Reset the CPU clock and the function evaluation counter: call CPU(0,CURREN,ELAPSE) C Loop making separate SL02F call for each eigenvalue index: do 200 K = KLO,KHI IK = K-KLO C Set size of storage given to SL02F in WK array C (normally reset to what was used, on exit) N = IWK KNOBS(1) = 0 KNOBS(2) = 0 C Always use 0 as initial guess of ev, and 1 as initial search step: ELAM(1) = 0.D0 ELAM(2) = 1.D0 C Soft fail IFAILA = -1 C Use copies of endpoints as SL02F alters them at singular points: ALOC = A BLOC = B call SL02F(ELAM,ALOC,BLOC,K,AINFO,BINFO,SYM,TOLER,COEFFN, + SETUP,N,WK,IWK,WKSMAL,ISMAL,KNOBS,IFAILA) C Copy output into arrays for output: EV(K,1) = ELAM(1) EV(K,2) = ELAM(2) IFAIL(K) = IFAILA C Report this for general interest: if (IFAILA.eq.0 .or. N.ne.IWK) then write(*,*)'K=',K,', error flag =',IFAILA, + ', no. of mesh intervals used=',N else write(*,*)'K=',K,', error flag =',IFAILA, + ', SL02F was unable to form a satisfactory mesh' end if C If SL02F returned anything other than IFAIL=0 or 12 then no sensible C ev estimate was found so no point attempting eigenfunctions. HAVEIG = (IFAILA.eq.0 .or. IFAILA.eq.12) if (QCALC.eq.2 .and. K.eq.KLO) then if (HAVEIG) then C***Do this once, for K=KLO only*** (irrelevant when SL02FM used) C In case of AUTO-mesh, return, in NXMESH & XMESH, a mesh derived from C that used by SL02F. If the latter has NN *interior* meshpoints and C NN<=MAXMSH, use all of them, else use a selection got by linear C map from indices 1:NXMESH to 1:NN, with A,B added. C Note that the *interior* meshpoints are WK(ia:ib,1) where C ia is 0 if A is singular, 1 if regular C ib is N if B is singular, N-1 if regular call SELMSH(N,WK(0,1),MAXMSH,NXMESH,XMESH) if (AINFO.eq.'R') XMESH(1) = A if (BINFO.eq.'R') XMESH(NXMESH) = B else C If no sensible mesh around, return a trivial mesh: C ???faulty!!! NXMESH = 2 XMESH(1) = A XMESH(2) = B end if end if if (QCALC.ge.2) then C If efns are wanted, then either XMESH held USER-mesh on entry, or C AUTO-mesh has just been created. C Call MARCOPAK routines to evaluate normalized eigenfunction on XMESH. if (HAVEIG) then C ***Informative fail while debugging*** IFAILA = -1 call SL03F(ELAM,K,EIGFNS,WK,IWK,N,SETUP,IFAILA) IFAILA = -1 call SL04F(XMESH,EF(IK*MAXMSH+1),PDEF(IK*MAXMSH+1), + MAXMSH-1,ELAM,EIGFNS,WK,IWK,NXMESH-1,N,IFAILA) else C If no sensible mesh, set all u & pu' values to 0 write (*,*) + 'No eigenfunctions available, so zeros will be displayed' do 180 I=1,NXMESH EF(IK*MAXMSH+I) = 0D0 PDEF(IK*MAXMSH+I) = 0D0 180 continue end if end if 200 continue C Read the CPU clock: call CPU(1,CURREN,ELAPSE) end subroutine SSL02 end module SOLVRS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Auxiliary routines for some of the solvers C These can't be in a module until the solvers themselves are made into C modules since they must be F77 external names to the linker. C for SL02F **+****|****+****|****+****|****+****|****+****|****+****|** subroutine SETUP(Y,PDY,EIG,X,IEND,ISING) C SETUP interfaces between SL02F and GETBCS, putting the arguments in a C different order. It also extracts the ISING data from SSL02 via C SL02CM. use SL02CM use SLTSTPAK,only:GETBCS implicit none C .. Scalar Arguments .. double precision EIG,PDY,X,Y integer IEND logical ISING C .. call GETBCS(IEND,X,EIG,PDY,Y) if (IEND.eq.0) then ISING = AINFO.ne.'R' else ISING = BINFO.ne.'R' end if c write(*,FMT=9999)IEND,X,EIG,PDY,Y,ISING c 9999 format('SETUP iend=',i1,' x=',1pg12.6,' eig=',g12.6,' pdy,y=', c + 2g12.6,' ising=',l1) end subroutine SETUP C for SLEDGE: +****|****+****|****+****|****+****|****+****|****+****|** subroutine COEFF(X,PX,QX,RX) use SLTSTPAK,only:COEFFN implicit none C This just interfaces to COEFFN to give the name required by SLEDGE C .. Scalar Arguments .. double precision PX,QX,RX,X C .. call COEFFN(X,PX,QX,RX) end subroutine COEFF C for SLEIGN, SLEIGN2: *+****|****+****|****+****|****+****|****+****|** C Functions for p(x), q(x), w(x) saving redundant calls to COEFFN: C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** double precision function P(X) use PQWCOM use SLTSTPAK,only:COEFFN implicit none double precision X if (X.ne.XX) then XX = X call COEFFN(XX,PP,QQ,WW) end if P = PP end C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C This is my q(x) in SLEIGN2, but minus (my q(x)) in SLEIGN: double precision function Q(X) use PQWCOM use SLTSTPAK,only:COEFFN implicit none double precision X if (X.ne.XX) then XX = X call COEFFN(XX,PP,QQ,WW) end if Q = QQ if (FLIPQ) Q=-Q end C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** double precision function W(X) use PQWCOM use SLTSTPAK,only:COEFFN implicit none double precision X if (X.ne.XX) then XX = X call COEFFN(XX,PP,QQ,WW) end if W = WW end C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C SLEIGN's name for w(x) is r(x): double precision function R(X) use PQWCOM use SLTSTPAK,only:COEFFN implicit none double precision X if (X.ne.XX) then XX = X call COEFFN(XX,PP,QQ,WW) end if R = WW end C for SLEIGN2: ****|****+****|****+****|****+****|****+****|****+****|** subroutine UV(XA,UA,PUP,VA,PVP,HU,HV) use TESTMOD,only: A1,A2,A,B1,B2,B,EIG,GTHUHV use SLTSTPAK,only:GETBCS implicit none double precision XA,UA,PUP,VA,PVP,HU,HV C UV computes the boundary condition information for SLEIGN2 to use at C a LCN or LCO endpoint. C Input argument C XA Value of independent variable x C Output arguments C UA,PUP Values of u(x), pu'(x) where u is first maximal domain function C defining BCs C VA,PVP Values of v(x), pv'(x) where v is 2nd maximal domain function C defining BCs C HU,HV Values of -(pu')'+qu, -(pv')'+qv at x C If functions used at the left end are different from those at the C right end, this must be explicitly coded by choosing a breakpoint c C and writing code of the form C if (XA.lt.C) then C functions for left end C else C functions for right end C end if C .. Local Variables .. integer IEND double precision A1SAV,A2SAV,B1SAV,B2SAV,C,TA,TB,TC C Special COMMON for counting no. of calls to this routine common/SLEI2C/ NUVEVL integer NUVEVL C .. Executable Statements .. C Form arbitrary 'mid-point' of interval TA = A/(1D0+abs(A)) TB = B/(1D0+abs(B)) TC = 0.5D0*(TA+TB) C = TC/(1D0-abs(TC)) C Save SLTSTPAK state info, mess around with it, then restore it: if (XA.le.C) then IEND = 0 A1SAV = A1 A2SAV = A2 C Set coeffs for 1st BC function: A1 = 1D0 A2 = 0D0 call GETBCS(IEND,XA,EIG,PUP,UA) C Set coeffs for 2nd BC function: A1 = 0D0 A2 = 1D0 call GETBCS(IEND,XA,EIG,PVP,VA) A1 = A1SAV A2 = A2SAV else IEND = 1 B1SAV = B1 B2SAV = B2 C Set coeffs for 1st BC function: B1 = 1D0 B2 = 0D0 call GETBCS(IEND,XA,EIG,PUP,UA) C Set coeffs for 2nd BC function: B1 = 0D0 B2 = 1D0 call GETBCS(IEND,XA,EIG,PVP,VA) B1 = B1SAV B2 = B2SAV end if c print*,'UV: C,IEND,XA,EIG,PUP,UA,PVP,VA=',C,IEND,XA,EIG,PUP,UA,PVP,VA C Now the HU,HV info from Problem Set module. call GTHUHV(IEND,XA,UA,VA,HU,HV) NUVEVL = NUVEVL + 1 if (mod(NUVEVL,1000).eq.0) write(*,fmt='("+")',advance='NO') c print*,'XA,UA,PUP,VA,PVP,HU,HV=', XA,UA,PUP,VA,PVP,HU,HV return end subroutine UV C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C! subroutine SABORT C! implicit none C!C To be called by one of the Solver interface routines in case of an C!C impossible request, see description of IFAIL in SOLVIT C!C Probably superseded at version 3.0 by SOLVIT's 'capabilities table' C!C SABORT calls left in, commented out., as defensive measure. C! integer K C! do 10 K=KLO,KHI C! IFAIL(K) = 999 C! EV(K,1) = 0d0 C! EV(K,2) = 1d20 C! 10 continue C! FLAG = 1 C! end subroutine SABORT SHAR_EOF fi # end of overwriting check if test ! -d 'standard' then mkdir 'standard' fi cd 'standard' if test ! -d 'TRUEVALS' then mkdir 'TRUEVALS' fi cd 'TRUEVALS' if test -f 'eftru.01' then echo shar: will not over-write existing file "'eftru.01'" else cat << SHAR_EOF > 'eftru.01' C Pryce #01, Benchmark problem E1, points are i*pi/8, i=0..8 X 9 0 0.39269908169872 0.78539816339745 1.17809724509617 1.57079632679490 1.96349540849362 2.35619449019234 2.74889357189107 1.0e35 U 0 0.0000000000E+00 3.2493470056E-01 1.8007637530E-01 5.8475808684E-01 4.3085801125E-01 6.5486828472E-01 6.6633625803E-01 5.1161001908E-01 8.1064724685E-01 2.0123166647E-01 8.1277983780E-01 -1.9712188199E-01 6.5719240408E-01 -5.8512601950E-01 3.6726265051E-01 -8.6670479012E-01 0.0000000000E+00 -9.7004378721E-01 U 1 0.0000000000E+00 8.1356034963E-01 4.1639526302E-01 1.1871864368E+00 7.8188400097E-01 5.0692247647E-01 7.3460413577E-01 -7.6855597138E-01 2.2932456191E-01 -1.6635956243E+00 -4.2571194926E-01 -1.4698408595E+00 -7.8886574734E-01 -2.6263712601E-01 -6.0572116897E-01 1.1391640639E+00 0.0000000000E+00 1.7522399855E+00 U 2 0.0000000000E+00 1.4195701404E+00 6.3859556286E-01 1.3937156050E+00 7.4354288516E-01 -1.0453289201E+00 -4.6221214018E-02 -2.4964145393E+00 -7.6654349865E-01 -6.9013016002E-01 -4.5547814569E-01 2.0709949619E+00 4.7305765781E-01 2.0284878553E+00 7.5370219269E-01 -7.9240320774E-01 0.0000000000E+00 -2.5313246261E+00 U 3 0.0000000000E+00 2.1049088803E+00 7.8538548795E-01 9.0171758251E-01 2.7937053376E-01 -3.0681539153E+00 -7.5802306709E-01 -1.0205064090E+00 -2.0839205609E-01 3.1861051754E+00 7.7770128827E-01 6.6594895650E-01 1.0907282713E-01 -3.2777287913E+00 -7.9093801872E-01 -2.2981615170E-01 0.0000000000E+00 3.3122251524E+00 U 4 0.0000000000E+00 2.8436002261E+00 8.1780479751E-01 -3.6856724641E-01 -3.4842298146E-01 -3.6407732682E+00 -5.0800043152E-01 3.1440957282E+00 7.7049516794E-01 9.9783267901E-01 -1.6017075532E-01 -4.0058647653E+00 -6.2803828761E-01 2.5013494055E+00 7.1147229696E-01 1.8077163942E+00 0.0000000000E+00 -4.0956020314E+00 U 5 0.0000000000E+00 3.6178020634E+00 7.2280583111E-01 -2.2452583366E+00 -7.5983824216E-01 -1.4881197019E+00 3.8595959598E-01 4.2522784442E+00 1.8141831122E-01 -4.7447361313E+00 -6.5105777251E-01 2.7920366758E+00 7.8797747121E-01 5.7802189826E-01 -5.2634478468E-01 -3.6513708374E+00 0.0000000000E+00 4.8812994314E+00 U 6 0.0000000000E+00 4.4153240206E+00 5.1275387590E-01 -4.3397621283E+00 -7.0419230920E-01 2.6630710756E+00 7.8869977138E-01 -7.4970439290E-01 -7.7648468268E-01 -1.2031929524E+00 6.7441822205E-01 2.9911533546E+00 -4.9611437380E-01 -4.4240822241E+00 2.6247803184E-01 5.3492444003E+00 0.0000000000E+00 -5.6689821102E+00 U 7 0.0000000000E+00 5.2278867531E+00 2.2116906254E-01 -6.1341321526E+00 -2.1781606631E-01 6.1880139071E+00 1.9156207122E-01 -6.2569170080E+00 -1.5786688972E-01 6.3236746314E+00 1.2067304471E-01 -6.3801392294E+00 -8.1507183604E-02 6.4225535470E+00 4.1130661496E-02 -6.4489737617E+00 0.0000000000E+00 6.4583075564E+00 U 8 0.0000000000E+00 6.0498933671E+00 -1.0435896564E-01 -7.1003239304E+00 4.0029676067E-01 6.2439151890E+00 -6.4754386824E-01 -4.2047144860E+00 7.8129913422E-01 1.3443772937E+00 -7.7006915568E-01 1.7954969076E+00 6.1316617990E-01 -4.6104983607E+00 -3.3918896432E-01 6.5548486102E+00 0.0000000000E+00 -7.2489751412E+00 U 9 0.0000000000E+00 6.8775746703E+00 -4.1087630666E-01 -6.8259859450E+00 7.7357820318E-01 1.9293222170E+00 -6.6914534085E-01 4.3491780770E+00 1.3850130304E-01 -7.9129739036E+00 4.8253098437E-01 6.3884539058E+00 -7.9180067716E-01 -7.2064668075E-01 5.8693481541E-01 -5.4225149644E+00 0.0000000000E+00 8.0407355941E+00 C SLEDGE/1 1 1.00D-10 0 9 9.1140 161546 U 100 0.0000000000E+00 8.0397114912E+01 7.4692124179E-01 -2.8344038799E+01 -5.4596226494E-01 -5.8766803868E+01 -3.2548004827E-01 7.3580050845E+01 7.9763094821E-01 1.8091692686E+00 -2.9271021089E-01 -7.4972074095E+01 -5.7057482277E-01 5.6330742449E+01 7.3532525823E-01 3.1269742219E+01 0.0000000000E+00 -8.0592269356E+01 U 101 0.0000000000E+00 8.1196813794E+01 5.8249052271E-01 -5.5618527928E+01 -7.9745586431E-01 -2.5597715791E+00 5.4857889518E-01 5.9097156927E+01 1.7736281346E-02 -8.1369467462E+01 -5.7359195298E-01 5.6571844705E+01 7.9777799776E-01 9.2322121809E-01 -5.6092228382E-01 -5.7878843946E+01 0.0000000000E+00 8.1390095349E+01 U 102 0.0000000000E+00 8.1996478575E+01 3.2924158518E-01 -7.4857807041E+01 -5.8146588307E-01 5.6275622039E+01 7.4507586689E-01 -2.9391592638E+01 -7.9764060667E-01 -1.8094830720E+00 7.3189434242E-01 3.2716570594E+01 -5.5777798082E-01 -5.8764743272E+01 3.0114660941E-01 7.6108183194E+01 0.0000000000E+00 -8.2187922492E+01 U 103 0.0000000000E+00 8.2796110194E+01 2.5793819417E-02 -8.2934678536E+01 -2.4616148738E-02 8.2943983295E+01 2.1319909888E-02 -8.2955126231E+01 -1.7398213894E-02 8.2965512942E+01 1.3207806720E-02 -8.2974110900E+01 -8.8774032463E-03 8.2980478107E+01 4.4648388096E-03 -8.2984397514E+01 0.0000000000E+00 8.2985750752E+01 U 104 0.0000000000E+00 8.3595709562E+01 -2.8158230415E-01 -7.8385696699E+01 5.4666135685E-01 6.1025200916E+01 -7.2876844927E-01 -3.4099856370E+01 7.9764972537E-01 1.8097795021E+00 -7.4200974817E-01 3.0788860442E+01 5.7033642158E-01 -5.8587271084E+01 -3.0939826951E-01 7.7226962496E+01 0.0000000000E+00 -8.3783580098E+01 C SLEDGE/1 1 1.00D-10 100 104 13.6420 254786 SHAR_EOF fi # end of overwriting check if test -f 'eftru.02' then echo shar: will not over-write existing file "'eftru.02'" else cat << SHAR_EOF > 'eftru.02' C Pryce #02, Benchmark problem E2, points are i*pi/8, i=0..8 C Results for r=+25 X 9 0 0.39269908169872 0.78539816339745 1.17809724509617 1.57079632679490 1.96349540849362 2.35619449019234 2.74889357189107 3.14159265358979 C SLEDGE/0 2 1.00D-10 0 0 -4.025677898470232D+01 1.00D+20 U 0 0.0000000000E+00 1.6311627746E-03 3.3337612636E-03 2.9683082344E-02 7.6696889383E-02 5.2593521020E-01 6.3018591906E-01 2.3471694735E+00 1.3225019562E+00 -6.4225895569E-12 6.3018591906E-01 -2.3471694735E+00 7.6696889383E-02 -5.2593521020E-01 3.3337612636E-03 -2.9683082344E-02 0.0000000000E+00 -1.6311627746E-03 C SLEDGE/0 2 1.00D-10 1 0 -2.131486062225115D+01 1.00D+20 U 1 0.0000000000E+00 1.2811007689E-02 1.9344776802E-02 1.5097275483E-01 2.7382975983E-01 1.4864778038E+00 1.0761873050E+00 1.1894813412E+00 -1.9502919542E-13 -5.6703835820E+00 -1.0761873050E+00 1.1894813412E+00 -2.7382975983E-01 1.4864778038E+00 -1.9344776802E-02 1.5097275483E-01 0.0000000000E+00 1.2811007689E-02 C SLEDGE/0 2 1.00D-10 2 0 -3.520941526621698D+00 1.00D+20 U 2 0.0000000000E+00 6.6579658133E-02 7.3889962550E-02 4.8995009836E-01 6.0851372305E-01 2.2798237529E+00 8.1330537024E-01 -3.4599748608E+00 -8.9075616933E-01 7.8666837640E-13 8.1330537024E-01 3.4599748608E+00 6.0851372305E-01 -2.2798237529E+00 7.3889962550E-02 -4.8995009836E-01 0.0000000000E+00 -6.6579658133E-02 C SLEDGE/0 2 1.00D-10 3 0 1.298648995274326D+01 1.00D+20 U 3 0.0000000000E+00 2.5872806108E-01 2.1015638268E-01 1.1278398709E+00 9.2057338875E-01 1.4547972711E+00 -1.0925536210E-01 -5.8652120138E+00 3.4974201322E-14 6.3389866418E+00 1.0925536210E-01 -5.8652120138E+00 -9.2057338875E-01 1.4547972711E+00 -2.1015638268E-01 1.1278398709E+00 0.0000000000E+00 2.5872806108E-01 C SLEDGE/0 2 1.00D-10 4 0 2.806276589945383D+01 1.00D+20 U 4 0.0000000000E+00 7.6921786262E-01 4.5620324707E-01 1.8202811585E+00 8.9081696646E-01 -1.6679615217E+00 -7.3475576618E-01 -1.1830081576E+00 7.1751231215E-01 -1.2458215873E-12 -7.3475576618E-01 1.1830081576E+00 8.9081696646E-01 1.6679615217E+00 4.5620324707E-01 -1.8202811585E+00 0.0000000000E+00 -7.6921786262E-01 C SLEDGE/0 2 1.00D-10 5 0 4.180107129182122D+01 1.00D+20 U 5 0.0000000000E+00 1.7376321453E+00 7.4832590148E-01 1.8287757117E+00 3.5171698101E-01 -4.9306319028E+00 -3.4885346766E-01 5.3485928911E+00 4.9118169417E-13 -6.3694188432E+00 3.4885346766E-01 5.3485928911E+00 -3.5171698101E-01 -4.9306319028E+00 -7.4832590148E-01 1.8287757117E+00 0.0000000000E+00 1.7376321453E+00 C SLEDGE/0 2 1.00D-10 6 0 5.500295715081144D+01 1.00D+20 U 6 0.0000000000E+00 3.0428321613E+00 9.2329556241E-01 4.7459640651E-01 -3.8751578498E-01 -4.6756525686E+00 4.6836886626E-01 4.4596335451E+00 -6.4426647098E-01 1.7901767771E-11 4.6836886626E-01 -4.4596335451E+00 -3.8751578498E-01 4.6756525686E+00 9.2329556241E-01 -4.7459640651E-01 0.0000000000E+00 -3.0428321613E+00 C SLEDGE/0 2 1.00D-10 7 0 6.905798835128009D+01 1.00D+20 U 7 0.0000000000E+00 4.3911529438E+00 8.5491259086E-01 -2.1098381248E+00 -7.5340480071E-01 7.7950833172E-02 5.9363058588E-01 -3.5076516405E+00 9.1482710660E-13 7.2003479298E+00 -5.9363058588E-01 -3.5076516405E+00 7.5340480071E-01 7.7950833172E-02 -8.5491259086E-01 -2.1098381248E+00 0.0000000000E+00 4.3911529438E+00 C SLEDGE/0 2 1.00D-10 8 0 8.502335650490063D+01 1.00D+20 U 8 0.0000000000E+00 5.5985155926E+00 5.5695213136E-01 -4.9907242249E+00 -4.5273740618E-01 5.8532496797E+00 -1.5920990068E-01 -7.5045549594E+00 6.8343810289E-01 -1.0396650869E-11 -1.5920990067E-01 7.5045549591E+00 -4.5273740617E-01 -5.8532496795E+00 5.5695213135E-01 4.9907242247E+00 0.0000000000E+00 -5.5985155925E+00 C SLEDGE/0 2 1.00D-10 9 0 1.032256800424073D+02 1.00D+20 U 9 0.0000000000E+00 6.6644731093E+00 1.4158814841E-01 -7.0565678798E+00 2.3090796737E-01 7.4976978924E+00 -7.2040965682E-01 -5.3508699060E-01 1.2028618411E-12 -8.7299372959E+00 7.2040965682E-01 -5.3508699060E-01 -2.3090796737E-01 7.4976978924E+00 -1.4158814841E-01 -7.0565678798E+00 0.0000000000E+00 6.6644731093E+00 C SLEDGE/1 2 1.00D-10 0 9 5.0980 85578 C SLEDGE/0 2 1.00D-10 100 0 1.020103063731260D+04 1.00D+20 U 100 0.0000000000E+00 8.0487340614E+01 7.6168557045E-01 -2.4190530960E+01 -4.9021810679E-01 -6.3581030196E+01 -3.6825645932E-01 7.1535300187E+01 7.9690795404E-01 -2.8009202115E-11 -3.6825645932E-01 -7.1535300187E+01 -4.9021810679E-01 6.3581030197E+01 7.6168557044E-01 2.4190530960E+01 0.0000000000E+00 -8.0487340614E+01 C SLEDGE/0 2 1.00D-10 101 0 1.040403003946665D+04 1.00D+20 U 101 0.0000000000E+00 8.1286200635E+01 6.1144352063E-01 -5.2304518234E+01 -7.9189776538E-01 -9.9476575679E+00 5.1282489730E-01 6.2362419243E+01 3.0483654126E-12 -8.1481779659E+01 -5.1282489730E-01 6.2362419243E+01 7.9189776538E-01 -9.9476575679E+00 -6.1144352063E-01 -5.2304518235E+01 0.0000000000E+00 8.1286200636E+01 C SLEDGE/0 2 1.00D-10 102 0 1.060902945894984D+04 1.00D+20 U 102 0.0000000000E+00 8.2085041573E+01 3.6773084719E-01 -7.2889506138E+01 -6.2834597768E-01 5.0649747402E+01 7.5996605295E-01 -2.4850528600E+01 -7.9694547194E-01 2.0208610021E-10 7.5996605301E-01 2.4850528602E+01 -6.2834597773E-01 -5.0649747406E+01 3.6773084722E-01 7.2889506143E+01 0.0000000000E+00 -8.2085041579E+01 C SLEDGE/0 2 1.00D-10 103 0 1.081602889510216D+04 1.00D+20 U 103 0.0000000000E+00 8.2883863991E+01 6.7818945409E-02 -8.2612588366E+01 -9.5677509973E-02 8.2381398189E+01 6.7652955893E-02 -8.2748222384E+01 -3.1089815235E-12 8.3075681156E+01 -6.7652955893E-02 -8.2748222384E+01 9.5677509973E-02 8.2381398189E+01 -6.7818945409E-02 -8.2612588366E+01 0.0000000000E+00 8.2883863992E+01 C SLEDGE/0 2 1.00D-10 104 0 1.102502834728869D+04 1.00D+20 U 104 0.0000000000E+00 8.3682668417E+01 -2.4243911437E-01 -7.9758767487E+01 4.9318171390E-01 6.5855742535E+01 -7.0830718077E-01 -3.8482424746E+01 7.9698086932E-01 3.2961257533E-10 -7.0830718074E-01 3.8482424745E+01 4.9318171388E-01 -6.5855742533E+01 -2.4243911437E-01 7.9758767485E+01 0.0000000000E+00 -8.3682668414E+01 C SLEDGE/1 2 1.00D-10 100 104 9.1210 147506 SHAR_EOF fi # end of overwriting check if test -f 'eftru.07' then echo shar: will not over-write existing file "'eftru.07'" else cat << SHAR_EOF > 'eftru.07' C Pryce #01, Coffey-Evans, points are i*pi/8, i=1..7 X 7 0 0.39269908169872 0.78539816339745 1.17809724509617 1.57079632679490 1.96349540849362 2.35619449019234 2.74889357189107 3.14159265358979 SHAR_EOF fi # end of overwriting check if test -f 'eftru.15' then echo shar: will not over-write existing file "'eftru.15'" else cat << SHAR_EOF > 'eftru.15' C Pryce #15, associated Legendre X 19 -.9 -.8 -.7 -.6 -.5 -.4 -.3 -.2 -.1 0 .1 .2 .3 .4 .5 .6 .7 .8 .9 SHAR_EOF fi # end of overwriting check if test -f 'eftru.20' then echo shar: will not over-write existing file "'eftru.20'" else cat << SHAR_EOF > 'eftru.20' C Pryce #20, Benchmark problem M3 X 11 -0.9 -0.75 -0.6 -0.4 -0.2 0.0 0.2 0.4 0.6 0.75 0.9 C SLEDGE/0 20 1.00D-10 0 52 -2.074616007225466D-12 1.00D+20 U 0 7.0710678119E-01 0.0000000000E+00 7.0710678119E-01 1.4669750471E-13 7.0710678119E-01 3.6674376177E-13 7.0710678119E-01 5.8679001883E-13 7.0710678119E-01 8.8018502824E-13 7.0710678119E-01 1.1735800377E-12 7.0710678119E-01 -1.4669750471E-12 7.0710678119E-01 -1.1735800377E-12 7.0710678119E-01 -8.8018502824E-13 7.0710678119E-01 -5.8679001883E-13 7.0710678119E-01 -3.6674376177E-13 7.0710678119E-01 -1.4669750471E-13 7.0710678119E-01 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 1 52 1.999999999999998D+00 1.00D+20 U 1 1.2247449119E+00 0.0000000000E+00 1.1022703843E+00 -2.3270152556E-01 9.1855865354E-01 -5.3582588123E-01 7.3484692283E-01 -7.8383671769E-01 4.8989794856E-01 -1.0287856920E+00 2.4494897428E-01 -1.1757550765E+00 -1.0552856540E-14 -1.2247448714E+00 -2.4494897428E-01 -1.1757550765E+00 -4.8989794856E-01 -1.0287856920E+00 -7.3484692283E-01 -7.8383671769E-01 -9.1855865354E-01 -5.3582588123E-01 -1.1022703843E+00 -2.3270152556E-01 -1.2247449119E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 2 -2 6.000000000000288D+00 1.00D+20 U 2 1.5811389870E+00 0.0000000000E+00 1.1305142635E+00 -8.1112421983E-01 5.4351647284E-01 -1.5564335359E+00 6.3245553203E-02 -1.8214719323E+00 -4.1109609582E-01 -1.5937879407E+00 -6.9570108524E-01 -9.1073596613E-01 -7.9056941504E-01 -2.6398423354E-14 -6.9570108524E-01 9.1073596613E-01 -4.1109609582E-01 1.5937879407E+00 6.3245553203E-02 1.8214719323E+00 5.4351647284E-01 1.5564335359E+00 1.1305142635E+00 8.1112421983E-01 1.5811389870E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 3 -2 1.200000000000158D+01 1.00D+20 U 3 1.8708290648E+00 0.0000000000E+00 8.8396655763E-01 -1.6262178417E+00 -1.3154264250E-01 -2.2252630357E+00 -6.7349832962E-01 -1.4367964365E+00 -8.2316462509E-01 4.7144883073E-01 -5.2383203415E-01 2.1551946548E+00 -2.1316851446E-14 2.8062430401E+00 5.2383203415E-01 2.1551946548E+00 8.2316462509E-01 4.7144883073E-01 6.7349832962E-01 -1.4367964365E+00 1.3154264250E-01 -2.2252630357E+00 -8.8396655763E-01 -1.6262178417E+00 -1.8708290648E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 4 -2 2.000000000000596D+01 1.00D+20 U 4 2.1213210454E+00 0.0000000000E+00 4.4110204894E-01 -2.4213280731E+00 -7.4266928044E-01 -1.6313864947E+00 -8.6549870017E-01 9.7750441431E-01 -2.3970919882E-01 3.3499890866E+00 4.9214631971E-01 2.7695958406E+00 7.9549512884E-01 1.1029063392E-13 4.9214631971E-01 -2.7695958406E+00 -2.3970919882E-01 -3.3499890866E+00 -8.6549870017E-01 -9.7750441431E-01 -7.4266928044E-01 1.6313864947E+00 4.4110204894E-01 2.4213280731E+00 2.1213210454E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 5 -2 3.000000000001634D+01 1.00D+20 U 5 2.3452090437E+00 0.0000000000E+00 -9.6484783687E-02 -2.8724648443E+00 -9.7650196269E-01 4.4337655078E-01 -3.5797253079E-01 3.7103064827E+00 6.3470706062E-01 2.5944565734E+00 7.2119832723E-01 -1.9992428135E+00 -1.3904607404E-14 -4.3972647748E+00 -7.2119832723E-01 -1.9992428135E+00 -6.3470706062E-01 2.5944565734E+00 3.5797253079E-01 3.7103064827E+00 9.7650196269E-01 4.4337655078E-01 9.6484783687E-02 -2.8724648443E+00 -2.3452090437E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 6 -2 4.200000000003769D+01 1.00D+20 U 6 2.5495115280E+00 0.0000000000E+00 -6.1485076771E-01 -2.6908540360E+00 -7.1584364372E-01 3.1481209229E+00 4.3876043110E-01 3.9144805677E+00 7.4607833719E-01 -2.3494079142E+00 -2.0542929816E-01 -4.9506666003E+00 -7.9672179900E-01 1.2372446735E-13 -2.0542929816E-01 4.9506666003E+00 7.4607833719E-01 2.3494079142E+00 4.3876043110E-01 -3.9144805677E+00 -7.1584364372E-01 -3.1481209229E+00 -6.1485076771E-01 2.6908540360E+00 2.5495115280E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 7 -2 5.600000000007805D+01 1.00D+20 U 7 2.7386153243E+00 0.0000000000E+00 -1.0073302315E+00 -1.7229907674E+00 -9.3615376244E-02 4.8910952227E+00 8.8347210348E-01 4.1145269064E-01 -3.9957456013E-02 -5.7217977187E+00 -8.0382886183E-01 4.1930484120E-01 3.2633735613E-14 5.9907154727E+00 8.0382886183E-01 4.1930484120E-01 3.9957456013E-02 -5.7217977187E+00 -8.8347210348E-01 4.1145269064E-01 9.3615376244E-02 4.8910952227E+00 1.0073302315E+00 -1.7229907674E+00 -2.7386153243E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 8 -2 7.200000000014715D+01 1.00D+20 U 8 2.9154794196E+00 0.0000000000E+00 -1.1944293977E+00 -2.0812286358E-02 5.7612517682E-01 4.2540404886E+00 6.1906983030E-01 -4.5526878216E+00 -7.7843003713E-01 -2.1506724367E+00 -1.1535022277E-01 6.6613690081E+00 7.9720045438E-01 -1.6111013037E-13 -1.1535022277E-01 -6.6613690081E+00 -7.7843003713E-01 2.1506724367E+00 6.1906983030E-01 4.5526878216E+00 5.7612517682E-01 -4.2540404886E+00 -1.1944293977E+00 2.0812286358E-02 2.9154794196E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 9 -2 9.000000000025787D+01 1.00D+20 U 9 3.0822115899E+00 0.0000000000E+00 -1.1389078070E+00 2.1394776053E+00 9.5650700469E-01 9.7476722026E-01 -1.4209911267E-01 -6.6575955289E+00 -5.8180836626E-01 5.3120138881E+00 7.5809075733E-01 2.4620854954E+00 3.9437151387E-14 -7.5851187927E+00 -7.5809075733E-01 2.4620854954E+00 5.8180836626E-01 5.3120138881E+00 1.4209911267E-01 -6.6575955289E+00 -9.5650700469E-01 9.7476722026E-01 1.1389078070E+00 2.1394776053E+00 -3.0822115899E+00 0.0000000000E+00 C SLEDGE/1 20 1.00D-10 0 9 101.5700 1514416 C SLEDGE/0 20 1.00D-10 100 -1 1.010000002408785D+04 1.00D+20 U 100 7.0710678119E-01 0.0000000000E+00 7.0710678119E-01 1.4669750471E-13 7.0710678119E-01 3.6674376177E-13 7.0710678119E-01 5.8679001883E-13 7.0710678119E-01 8.8018502824E-13 7.0710678119E-01 1.1735800377E-12 7.0710678119E-01 -1.4669750471E-12 7.0710678119E-01 -1.1735800377E-12 7.0710678119E-01 -8.8018502824E-13 7.0710678119E-01 -5.8679001883E-13 7.0710678119E-01 -3.6674376177E-13 7.0710678119E-01 -1.4669750471E-13 7.0710678119E-01 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 101 -1 1.030200002529953D+04 1.00D+20 U 101 1.2247449119E+00 0.0000000000E+00 1.1022703843E+00 -2.3270152556E-01 9.1855865354E-01 -5.3582588123E-01 7.3484692283E-01 -7.8383671769E-01 4.8989794856E-01 -1.0287856920E+00 2.4494897428E-01 -1.1757550765E+00 -1.0552856540E-14 -1.2247448714E+00 -2.4494897428E-01 -1.1757550765E+00 -4.8989794856E-01 -1.0287856920E+00 -7.3484692283E-01 -7.8383671769E-01 -9.1855865354E-01 -5.3582588123E-01 -1.1022703843E+00 -2.3270152556E-01 -1.2247449119E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 102 -1 1.050600002655990D+04 1.00D+20 U 102 1.5811389870E+00 0.0000000000E+00 1.1305142635E+00 -8.1112421983E-01 5.4351647284E-01 -1.5564335359E+00 6.3245553203E-02 -1.8214719323E+00 -4.1109609582E-01 -1.5937879407E+00 -6.9570108524E-01 -9.1073596613E-01 -7.9056941504E-01 -2.6398423354E-14 -6.9570108524E-01 9.1073596613E-01 -4.1109609582E-01 1.5937879407E+00 6.3245553203E-02 1.8214719323E+00 5.4351647284E-01 1.5564335359E+00 1.1305142635E+00 8.1112421983E-01 1.5811389870E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 103 -1 1.071200002786976D+04 1.00D+20 U 103 1.8708290648E+00 0.0000000000E+00 8.8396655763E-01 -1.6262178417E+00 -1.3154264250E-01 -2.2252630357E+00 -6.7349832962E-01 -1.4367964365E+00 -8.2316462509E-01 4.7144883073E-01 -5.2383203415E-01 2.1551946548E+00 -2.1316851446E-14 2.8062430401E+00 5.2383203415E-01 2.1551946548E+00 8.2316462509E-01 4.7144883073E-01 6.7349832962E-01 -1.4367964365E+00 1.3154264250E-01 -2.2252630357E+00 -8.8396655763E-01 -1.6262178417E+00 1.2247449119E+00 0.0000000000E+00 C SLEDGE/0 20 1.00D-10 104 -1 1.092000002923001D+04 1.00D+20 U 104 1.1022703843E+00 -2.3270152556E-01 9.1855865354E-01 -5.3582588123E-01 7.3484692283E-01 -7.8383671769E-01 4.8989794856E-01 -1.0287856920E+00 2.4494897428E-01 -1.1757550765E+00 -1.0552856540E-14 -1.2247448714E+00 -2.4494897428E-01 -1.1757550765E+00 -4.8989794856E-01 -1.0287856920E+00 -7.3484692283E-01 -7.8383671769E-01 -9.1855865354E-01 -5.3582588123E-01 -1.1022703843E+00 -2.3270152556E-01 -1.2247449119E+00 0.0000000000E+00 2.1213210454E+00 0.0000000000E+00 C SLEDGE/1 20 1.00D-10 100 104 63.7010 899884 SHAR_EOF fi # end of overwriting check if test -f 'eftru.21' then echo shar: will not over-write existing file "'eftru.21'" else cat << SHAR_EOF > 'eftru.21' C Pryce #21, Benchmark problem M4 X 10 0.0002 0.001 0.002 0.005 0.01 0.02 0.04 0.07 0.1 0.2 C SLEDGE/0 21 1.00D-10 0 -1 -2.986290821092491D+03 1.00D+20 U 0 7.0710678119E-01 0.0000000000E+00 7.0710678119E-01 1.4669750471E-13 7.0710678119E-01 3.6674376177E-13 7.0710678119E-01 5.8679001883E-13 7.0710678119E-01 8.8018502824E-13 7.0710678119E-01 1.1735800377E-12 7.0710678119E-01 -1.4669750471E-12 7.0710678119E-01 -1.1735800377E-12 7.0710678119E-01 -8.8018502824E-13 7.0710678119E-01 -5.8679001883E-13 7.0710678119E-01 -3.6674376177E-13 7.0710678119E-01 -1.4669750471E-13 C SLEDGE/0 21 1.00D-10 1 -1 -1.115557089015093D+02 1.00D+20 U 1 7.0710678119E-01 0.0000000000E+00 1.2247449119E+00 0.0000000000E+00 1.1022703843E+00 -2.3270152556E-01 9.1855865354E-01 -5.3582588123E-01 7.3484692283E-01 -7.8383671769E-01 4.8989794856E-01 -1.0287856920E+00 2.4494897428E-01 -1.1757550765E+00 -1.0552856540E-14 -1.2247448714E+00 -2.4494897428E-01 -1.1757550765E+00 -4.8989794856E-01 -1.0287856920E+00 -7.3484692283E-01 -7.8383671769E-01 -9.1855865354E-01 -5.3582588123E-01 C SLEDGE/0 21 1.00D-10 2 -1 -1.137733981807581D+01 1.00D+20 U 2 -1.1022703843E+00 -2.3270152556E-01 -1.2247449119E+00 0.0000000000E+00 1.5811389870E+00 0.0000000000E+00 1.1305142635E+00 -8.1112421983E-01 5.4351647284E-01 -1.5564335359E+00 6.3245553203E-02 -1.8214719323E+00 -4.1109609582E-01 -1.5937879407E+00 -6.9570108524E-01 -9.1073596613E-01 -7.9056941504E-01 -2.6398423354E-14 -6.9570108524E-01 9.1073596613E-01 -4.1109609582E-01 1.5937879407E+00 6.3245553203E-02 1.8214719323E+00 C SLEDGE/0 21 1.00D-10 3 -1 3.026717665620338D+01 1.00D+20 U 3 5.4351647284E-01 1.5564335359E+00 1.1305142635E+00 8.1112421983E-01 1.5811389870E+00 0.0000000000E+00 1.8708290648E+00 0.0000000000E+00 8.8396655763E-01 -1.6262178417E+00 -1.3154264250E-01 -2.2252630357E+00 -6.7349832962E-01 -1.4367964365E+00 -8.2316462509E-01 4.7144883073E-01 -5.2383203415E-01 2.1551946548E+00 -2.1316851446E-14 2.8062430401E+00 5.2383203415E-01 2.1551946548E+00 8.2316462509E-01 4.7144883073E-01 C SLEDGE/0 21 1.00D-10 4 -1 9.572752229368456D+01 1.00D+20 U 4 6.7349832962E-01 -1.4367964365E+00 1.3154264250E-01 -2.2252630357E+00 -8.8396655763E-01 -1.6262178417E+00 1.2247449119E+00 0.0000000000E+00 1.1022703843E+00 -2.3270152556E-01 9.1855865354E-01 -5.3582588123E-01 7.3484692283E-01 -7.8383671769E-01 4.8989794856E-01 -1.0287856920E+00 2.4494897428E-01 -1.1757550765E+00 -1.0552856540E-14 -1.2247448714E+00 -2.4494897428E-01 -1.1757550765E+00 -4.8989794856E-01 -1.0287856920E+00 C SLEDGE/0 21 1.00D-10 5 -2 1.841172906627578D+02 1.00D+20 U 5 0.0000000000E+00 2.3265270494E+14 4.6452780553E-02 2.0924812895E+02 1.8024556849E-01 1.3739897505E+02 2.9428850800E-01 9.4573805236E+01 4.7080381677E-01 3.2317577542E+01 5.1035268354E-01 -9.9197308396E+00 2.4972193395E-01 -3.5423308391E+01 -4.8034668813E-01 -3.2568398114E+01 -1.0972815600E+00 -8.1805141690E+00 -1.0230769307E+00 1.1694415279E+01 1.0429575166E+00 1.5639266846E+01 0.0000000000E+00 2.0999223522E+01 C SLEDGE/0 21 1.00D-10 6 -2 2.943848036289245D+02 1.00D+20 U 6 0.0000000000E+00 2.5662846908E+14 5.1239856112E-02 2.3081127455E+02 1.9881640223E-01 1.5154688299E+02 3.2458778459E-01 1.0428134859E+02 5.1899919038E-01 3.5482825468E+01 5.6118939934E-01 -1.1346804402E+01 2.6806206116E-01 -3.9725326237E+01 -5.4450708824E-01 -3.5719258556E+01 -1.1741304286E+00 -5.7277791756E+00 -9.5658040675E-01 1.8225577970E+01 1.3360326190E+00 8.0683566611E+00 0.0000000000E+00 -2.5922684075E+01 C SLEDGE/0 21 1.00D-10 7 -2 4.260096649499760D+02 1.00D+20 U 7 0.0000000000E+00 2.7846981815E+14 5.5600726403E-02 2.5045442383E+02 2.1573199627E-01 1.6442982344E+02 3.5217636598E-01 1.1310653079E+02 5.6275256139E-01 3.8288870702E+01 6.0667894767E-01 -1.2835330016E+01 2.8136587080E-01 -4.3936268258E+01 -6.0891300518E-01 -3.8417631877E+01 -1.2241937435E+00 -1.9742551951E+00 -8.2441723094E-01 2.5731853553E+01 1.3738490020E+00 -5.6563497378E+00 0.0000000000E+00 3.0741803435E+01 C SLEDGE/0 21 1.00D-10 8 -2 5.786844733171828D+02 1.00D+20 U 8 0.0000000000E+00 2.9877395345E+14 5.9654669666E-02 2.6871482516E+02 2.3145504581E-01 1.7640029525E+02 3.7780916812E-01 1.2129122608E+02 6.0326488688E-01 4.0814706680E+01 6.4809086787E-01 -1.4419614829E+01 2.9014378588E-01 -4.8152507577E+01 -6.7447012875E-01 -4.0687388717E+01 -1.2476423009E+00 3.0851872702E+00 -6.3349849090E-01 3.3650851846E+01 1.0964816221E+00 -2.2812417630E+01 0.0000000000E+00 -3.5493847079E+01 C SLEDGE/0 21 1.00D-10 9 -1 7.522010575676921D+02 1.00D+20 U 9 -7.9056941504E-01 -2.6398423354E-14 -6.9570108524E-01 9.1073596613E-01 -4.1109609582E-01 1.5937879407E+00 6.3245553203E-02 1.8214719323E+00 5.4351647284E-01 1.5564335359E+00 1.1305142635E+00 8.1112421983E-01 1.5811389870E+00 0.0000000000E+00 -1.1944293977E+00 2.0812286358E-02 2.9154794196E+00 0.0000000000E+00 3.0822115899E+00 0.0000000000E+00 -1.1389078070E+00 2.1394776053E+00 9.5650700469E-01 9.7476722026E-01 C SLEDGE/1 21 1.00D-10 0 9 82.5010 1602618 C SLEDGE/0 21 1.00D-10 100 -2 9.998433109450497D+04 1.00D+20 U 100 0.0000000000E+00 9.7362031955E+14 1.9426313433E-01 8.7369555726E+02 7.4037625274E-01 5.3580319380E+02 1.1369888266E+00 2.6814267275E+02 1.0110967815E+00 -2.9798227767E+02 -1.0309219032E+00 -3.0854528867E+02 1.1402008188E+00 2.6395437235E+02 1.2265014702E+00 2.2221250456E+02 -1.2921305263E+00 -1.8185263597E+02 1.3349353439E+00 1.4809483384E+02 1.4076321462E+00 4.6156527879E+01 0.0000000000E+00 -4.4761754806E+02 C SLEDGE/0 21 1.00D-10 101 -2 1.019847734628133D+05 1.00D+20 U 101 0.0000000000E+00 9.7891934470E+14 1.9531769182E-01 8.7841080854E+02 7.4412660790E-01 5.3793675977E+02 1.1413131117E+00 2.6712959534E+02 1.0001240972E+00 -3.0583785125E+02 -1.0569153244E+00 -3.0167817231E+02 1.1865312649E+00 2.4430796245E+02 1.3019372173E+00 1.7513196644E+02 -1.3848058377E+00 -9.1059239565E+01 1.4139187263E+00 1.2428033469E+01 1.2276340189E+00 -2.2493665038E+02 0.0000000000E+00 4.5206625884E+02 C SLEDGE/0 21 1.00D-10 102 -2 1.040049701622860D+05 1.00D+20 U 102 0.0000000000E+00 9.8421093839E+14 1.9637072213E-01 8.8311862002E+02 7.4786563793E-01 5.4005033194E+02 1.1455918098E+00 2.6606715574E+02 9.8890872182E-01 -3.1373042942E+02 -1.0821174791E+00 -2.9436859120E+02 1.2288010598E+00 2.2335464898E+02 1.3583089214E+00 1.2446500413E+02 -1.4135803348E+00 5.8268056957E+00 1.3585448371E+00 -1.2715702405E+02 5.8495697399E-01 -4.1578922474E+02 0.0000000000E+00 -4.5651487995E+02 C SLEDGE/0 21 1.00D-10 103 -1 1.060449209728433D+05 1.00D+20 U 103 5.4351647284E-01 1.5564335359E+00 1.1305142635E+00 8.1112421983E-01 1.5811389870E+00 0.0000000000E+00 1.8708290648E+00 0.0000000000E+00 8.8396655763E-01 -1.6262178417E+00 -1.3154264250E-01 -2.2252630357E+00 -6.7349832962E-01 -1.4367964365E+00 -8.2316462509E-01 4.7144883073E-01 -5.2383203415E-01 2.1551946548E+00 -2.1316851446E-14 2.8062430401E+00 5.2383203415E-01 2.1551946548E+00 8.2316462509E-01 4.7144883073E-01 C SLEDGE/0 21 1.00D-10 104 -2 1.081046256522211D+05 1.00D+20 U 104 0.0000000000E+00 9.9477243453E+14 1.9847230014E-01 8.9251235217E+02 7.5530994377E-01 5.4421739379E+02 1.1540122975E+00 2.6379367802E+02 9.6575910923E-01 -3.2961597227E+02 -1.1300458910E+00 -2.7842366979E+02 1.3005303697E+00 1.7775243696E+02 1.4107074144E+00 1.5221150217E+01 -1.2768783796E+00 1.9997341878E+02 8.7772512254E-01 -3.6521242131E+02 -1.0366382339E+00 -3.1689118512E+02 0.0000000000E+00 -4.6541186234E+02 C SLEDGE/1 21 1.00D-10 100 104 36.9070 697560 SHAR_EOF fi # end of overwriting check if test -f 'eftru.22' then echo shar: will not over-write existing file "'eftru.22'" else cat << SHAR_EOF > 'eftru.22' C Pryce #22, Benchmark problem H1 X 9 -1.55 -1.3 -1.0 -0.5 0.0 0.5 1.0 1.3 1.55 C SLEDGE/0 22 1.00D-10 0 2 2.500000000017553D-01 1.00D+20 U 0 0.0000000000E+00 3.5354308858E+15 1.0196771009E-01 2.4512263362E+00 3.6571767022E-01 6.5867625986E-01 5.1976066890E-01 4.0473964274E-01 6.6241322522E-01 1.8093899848E-01 7.0710678119E-01 -1.3398374111E-12 6.6241322522E-01 -1.8093899848E-01 5.1976066890E-01 -4.0473964274E-01 3.6571767022E-01 -6.5867625986E-01 1.0196771009E-01 -2.4512263362E+00 0.0000000000E+00 -3.5354308858E+15 C SLEDGE/0 22 1.00D-10 1 2 2.250000000005330D+00 1.00D+20 U 1 0.0000000000E+00 6.1235575863E+15 1.7657506450E-01 4.2410578577E+00 6.1035782522E-01 9.2984083131E-01 7.5753584135E-01 1.0348791949E-01 5.5006091489E-01 -8.5662992769E-01 -2.3010788245E-12 -1.2247448741E+00 -5.5006091489E-01 -8.5662992769E-01 -7.5753584135E-01 1.0348791949E-01 -6.1035782522E-01 9.2984083131E-01 -1.7657506450E-01 4.2410578577E+00 0.0000000000E+00 6.1235575863E+15 C SLEDGE/0 22 1.00D-10 2 2 6.250000000008767D+00 1.00D+20 U 2 0.0000000000E+00 7.9054953121E+15 2.2785883760E-01 5.4633324741E+00 7.2999555410E-01 6.8241739163E-01 6.5329573778E-01 -1.0764818207E+00 -2.2992198693E-01 -1.9323849777E+00 -7.9056941504E-01 6.0163776437E-12 -2.2992198693E-01 1.9323849777E+00 6.5329573778E-01 1.0764818207E+00 7.2999555410E-01 -6.8241739163E-01 2.2785883760E-01 -5.4633324741E+00 0.0000000000E+00 -7.9054953121E+15 C SLEDGE/1 22 1.00D-10 0 2 15.3980 255178 SHAR_EOF fi # end of overwriting check if test -f 'eftru.28' then echo shar: will not over-write existing file "'eftru.28'" else cat << SHAR_EOF > 'eftru.28' C Pryce #28, Benchmark problem I1 X 7 -5.0 -2.5 -1.0 0.0 1.0 2.5 5.0 C SLEDGE/0 28 1.00D-10 0 0 9.999999999999859D-01 1.00D+20 U 0 0.0000000000E+00 0.0000000000E+00 2.7991792943E-06 1.3995929577E-05 3.3002153191E-02 8.2505382975E-02 4.5558067201E-01 4.5558067201E-01 7.5112554458E-01 1.5552450385E-14 4.5558067208E-01 -4.5558067208E-01 3.3002153195E-02 -8.2505382987E-02 2.7991792947E-06 -1.3995929579E-05 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 1 0 2.999999999999981D+00 1.00D+20 U 1 0.0000000000E+00 0.0000000000E+00 1.9793222143E-05 9.5007471226E-05 1.1668023157E-01 2.4502848630E-01 6.4428836511E-01 -2.2085244433E-15 1.1393541878E-15 -1.0622519325E+00 -6.4428836541E-01 1.6136529713E-15 -1.1668023163E-01 2.4502848641E-01 -1.9793222152E-05 9.5007471268E-05 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 2 0 5.000000000000254D+00 1.00D+20 U 2 0.0000000000E+00 0.0000000000E+00 9.6986788931E-05 4.4534751042E-04 2.6836453262E-01 4.3755086840E-01 3.2214418256E-01 -9.6643254769E-01 -5.3112596626E-01 -1.6318650380E-13 3.2214418270E-01 9.6643254811E-01 2.6836453274E-01 -4.3755086859E-01 9.6986788973E-05 -4.4534751061E-04 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 3 0 7.000000000000277D+00 1.00D+20 U 3 0.0000000000E+00 0.0000000000E+00 3.7978581748E-04 1.6613609402E-03 4.5252779817E-01 4.7396332545E-01 -2.6302962362E-01 -1.0521184945E+00 -4.3323009531E-14 1.3009876065E+00 2.6302962374E-01 -1.0521184950E+00 -4.5252779837E-01 4.7396332566E-01 -3.7978581765E-04 1.6613609409E-03 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 4 0 8.999999999999483D+00 1.00D+20 U 4 0.0000000000E+00 0.0000000000E+00 1.2587526104E-03 5.2195665476E-03 5.6755318419E-01 1.3894106141E-01 -4.6497507630E-01 2.7898504578E-01 4.5996857939E-01 -3.4525275571E-13 -4.6497507650E-01 -2.7898504590E-01 5.6755318444E-01 -1.3894106147E-01 1.2587526109E-03 -5.2195665499E-03 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 5 0 1.099999999999932D+01 1.00D+20 U 5 0.0000000000E+00 0.0000000000E+00 3.6408344982E-03 1.4223647235E-02 4.9262721028E-01 -5.6319272959E-01 -5.8815211852E-02 1.4115650844E+00 8.3080414155E-15 -1.4545483630E+00 5.8815211879E-02 1.4115650851E+00 -4.9262721050E-01 -5.6319272985E-01 -3.6408344998E-03 1.4223647241E-02 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 6 0 1.300000000000196D+01 1.00D+20 U 6 0.0000000000E+00 0.0000000000E+00 9.3611052238E-03 3.4193305452E-02 1.9294332856E-01 -1.2241523934E+00 3.9050525154E-01 5.9424712191E-01 -4.1989194446E-01 -2.4166106287E-13 3.9050525172E-01 -5.9424712218E-01 1.9294332865E-01 1.2241523939E+00 9.3611052281E-03 -3.4193305467E-02 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 7 0 1.500000000000212D+01 1.00D+20 U 7 0.0000000000E+00 0.0000000000E+00 2.1647848319E-02 7.3213193087E-02 -1.9825280492E-01 -1.2175598428E+00 2.6318614231E-01 -1.1979507167E+00 7.6802400644E-14 1.5710917956E+00 -2.6318614243E-01 -1.1979507172E+00 1.9825280501E-01 -1.2175598434E+00 -2.1647848328E-02 7.3213193121E-02 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 8 0 1.699999999999353D+01 1.00D+20 U 8 0.0000000000E+00 0.0000000000E+00 4.5363108669E-02 1.4022415008E-01 -4.2829796379E-01 -2.7773368979E-01 -2.3369114360E-01 -1.2864357129E+00 3.9277294890E-01 -2.9863926841E-13 -2.3369114371E-01 1.2864357135E+00 -4.2829796398E-01 2.7773368991E-01 4.5363108689E-02 -1.4022415014E-01 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 9 0 1.900000000000007D+01 1.00D+20 U 9 0.0000000000E+00 0.0000000000E+00 8.6512085399E-02 2.4010105645E-01 -3.1783945395E-01 1.0225157326E+00 -3.5829733616E-01 6.3317021793E-01 1.2884022836E-14 -1.6663944900E+00 3.5829733550E-01 6.3317021676E-01 3.1783945336E-01 1.0225157307E+00 -8.6512085238E-02 2.4010105600E-01 0.0000000000E+00 0.0000000000E+00 C SLEDGE/1 28 1.00D-10 0 9 8.6690 160464 C SLEDGE/0 28 1.00D-10 100 -1 2.010000000178973D+02 1.00D+20 U 100 0.0000000000E+00 0.0000000000E+00 2.7991792943E-06 1.3995929577E-05 3.3002153191E-02 8.2505382975E-02 4.5558067201E-01 4.5558067201E-01 7.5112554458E-01 1.5552450385E-14 4.5558067208E-01 -4.5558067208E-01 3.3002153195E-02 -8.2505382987E-02 2.7991792947E-06 -1.3995929579E-05 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 101 -1 2.030000000201958D+02 1.00D+20 U 101 0.0000000000E+00 0.0000000000E+00 1.9793222143E-05 9.5007471226E-05 1.1668023157E-01 2.4502848630E-01 6.4428836511E-01 -2.2085244433E-15 1.1393541878E-15 -1.0622519325E+00 -6.4428836541E-01 1.6136529713E-15 -1.1668023163E-01 2.4502848641E-01 -1.9793222152E-05 9.5007471268E-05 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 102 -1 2.050000000982520D+02 1.00D+20 U 102 0.0000000000E+00 0.0000000000E+00 9.6986788931E-05 4.4534751042E-04 2.6836453262E-01 4.3755086840E-01 3.2214418256E-01 -9.6643254769E-01 -5.3112596626E-01 -1.6318650380E-13 3.2214418270E-01 9.6643254811E-01 2.6836453274E-01 -4.3755086859E-01 9.6986788973E-05 -4.4534751061E-04 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 103 -1 2.070000000256635D+02 1.00D+20 U 103 0.0000000000E+00 0.0000000000E+00 3.7978581748E-04 1.6613609402E-03 4.5252779817E-01 4.7396332545E-01 -2.6302962362E-01 -1.0521184945E+00 -4.3323009531E-14 1.3009876065E+00 2.6302962374E-01 -1.0521184950E+00 -4.5252779837E-01 4.7396332566E-01 -3.7978581765E-04 1.6613609409E-03 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 28 1.00D-10 104 -1 2.090000000289012D+02 1.00D+20 U 104 0.0000000000E+00 0.0000000000E+00 1.2587526104E-03 5.2195665476E-03 5.6755318419E-01 1.3894106141E-01 -4.6497507630E-01 2.7898504578E-01 4.5996857939E-01 -3.4525275571E-13 -4.6497507650E-01 -2.7898504590E-01 5.6755318444E-01 -1.3894106147E-01 1.2587526109E-03 -5.2195665499E-03 0.0000000000E+00 0.0000000000E+00 C SLEDGE/1 28 1.00D-10 100 104 35.3690 723880 SHAR_EOF fi # end of overwriting check if test -f 'eftru.29' then echo shar: will not over-write existing file "'eftru.29'" else cat << SHAR_EOF > 'eftru.29' C Pryce #29, Benchmark problem I2 X 10 1.0 3.0 5.0 7.0 8.0 9.0 11.0 15.0 25.0 50.0 SHAR_EOF fi # end of overwriting check if test -f 'eftru.35' then echo shar: will not over-write existing file "'eftru.35'" else cat << SHAR_EOF > 'eftru.35' C Pryce #35, Benchmark problem Q1 X 8 -2.0 -1.0 -0.5 0.0 0.5 1.0 2.0 4.0 C SLEDGE/0 35 1.00D-10 0 0 -6.25D+00 1.00D+20 U 0 0.0000000000E+00 0.0000000000E+00 6.3047172953E-07 1.2399617270E-05 6.3009250683E-02 3.5630757676E-01 4.4673394905E-01 1.0927844198E+00 8.9616723062E-01 4.4808361531E-01 8.3592179139E-01 -5.6876789168E-01 4.9004082961E-01 -6.8427423438E-01 8.0811653949E-02 -1.6921913064E-01 7.7350752556E-04 -1.8912669603E-03 0.0000000000E+00 -1.2496596119E-09 C SLEDGE/0 35 1.00D-10 1 0 -2.25D+00 1.00D+20 U 1 0.0000000000E+00 0.0000000000E+00 9.9348417898E-07 1.9440519566E-05 8.2369486821E-02 4.3902098399E-01 4.6089073707E-01 8.1453908234E-01 5.1740239202E-01 -7.7610358808E-01 -1.4355162163E-01 -1.4937369612E+00 -6.8936527211E-01 -5.7553763995E-01 -5.4952702493E-01 4.6120946037E-01 -4.7425650188E-02 6.7192830278E-02 0.0000000000E+00 1.9066387493E-05 C SLEDGE/0 35 1.00D-10 2 0 -2.5D-01 1.00D+20 U 2 0.0000000000E+00 0.0000000000E+00 7.7757932897E-07 1.5176980410E-05 5.8629316040E-02 3.0263028602E-01 2.8874416038E-01 3.9903403233E-01 2.1223079998E-01 -7.4304981029E-01 -2.3250625142E-01 -7.2396117112E-01 -3.3894890378E-01 2.9585690582E-01 3.1145755552E-01 5.8949619723E-01 4.8623621999E-01 -1.5992322086E-01 0.0000000000E+00 -2.8704460653E-02 C SLEDGE/1 35 1.00D-10 0 2 11.3380 196462 SHAR_EOF fi # end of overwriting check if test -f 'eftru.36' then echo shar: will not over-write existing file "'eftru.36'" else cat << SHAR_EOF > 'eftru.36' C Pryce #36, Benchmark problem Q2 X 6 0.5 1.0 1.3 1.6 2.0 2.4 C SLEDGE/0 36 1.00D-10 0 0 -1.923529655114416D+03 1.00D+20 U 0 0.0000000000E+00 1.5292569760E-66 3.0878860270E-18 4.0267283164E-16 2.8495358950E-02 8.7242776280E-01 2.1946178566E+00 1.8917667333E+00 1.5531689477E-01 -2.6411790443E+00 9.0531679920E-06 -2.7390504477E-04 1.1279948745E-11 -4.1702396202E-10 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 36 1.00D-10 1 0 -1.777290818662759D+03 1.00D+20 U 1 0.0000000000E+00 9.6221933149E-66 1.6379040633E-17 2.1267676188E-15 8.4788350392E-02 2.3988968952E+00 5.9167447621E-01 -2.4759880170E+01 -6.5801701010E-01 8.2113948915E+00 -1.3780453296E-04 3.8266305030E-03 -4.1629183847E-10 1.4547593299E-08 0.0000000000E+00 0.0000000000E+00 C SLEDGE/1 36 1.00D-10 0 1 2.1650 28441 C SLEDGE/0 36 1.00D-10 25 -2 -1.767015971893687D+00 1.00D+20 U 25 0.0000000000E+00 1.3667322932E-61 2.4268088488E-13 2.9820936584E-11 -2.9181740696E-02 -6.8900368855E+00 -1.1897774368E-02 -8.0579266835E+00 -8.9617777541E-02 -6.8251810464E+00 -1.1528994000E-01 5.7150934663E+00 -2.2414355822E-01 -2.5870767497E+00 0.0000000000E+00 0.0000000000E+00 C SLEDGE/1 36 1.00D-10 25 25 7.7960 119448 SHAR_EOF fi # end of overwriting check if test -f 'eftru.41' then echo shar: will not over-write existing file "'eftru.41'" else cat << SHAR_EOF > 'eftru.41' C Pryce #41, Benchmark problem Q4 X 7 1.0 1.75 2.0 2.32 2.5 2.75 4.0 C SLEDGE/0 41 1.00D-10 0 -2 -4.895173162418783D+01 1.00D+20 U 0 0.0000000000E+00 -5.1080414798E-12 2.0181742645E-01 3.6019369527E-01 4.9164633816E-01 3.6497160070E-01 5.7591478162E-01 3.0444460900E-01 6.5602754691E-01 1.9033482995E-01 6.8343929892E-01 1.1306108968E-01 6.9739646340E-01 -2.2959379052E-03 3.9419223242E-01 -3.8373862875E-01 0.0000000000E+00 0.0000000000E+00 C SLEDGE/0 41 1.00D-10 1 -2 -4.734169170178745D+01 1.00D+20 U 1 0.0000000000E+00 -8.0669834700E-11 4.0569483262E-01 5.7753537890E-01 6.4077790599E-01 -8.0219560910E-02 5.8079487345E-01 -3.9812463366E-01 3.9483511770E-01 -7.4517926945E-01 2.4805768246E-01 -8.7607955914E-01 1.6782030337E-02 -9.5224838408E-01 -6.3622446428E-01 1.5285832713E-01 0.0000000000E+00 0.0000000000E+00 C SLEDGE/1 41 1.00D-10 0 1 15.0150 233560 C SLEDGE/0 41 1.00D-10 10 -2 -1.581272486715580D+01 1.00D+20 U 10 0.0000000000E+00 3.6463287403E-08 -4.9305006766E-01 -7.5228713521E-01 3.1319971067E-01 -2.3049134769E+00 -3.5647579097E-01 -2.0806222644E+00 -2.4287315734E-01 2.5758427455E+00 2.6191199446E-01 2.5117684807E+00 4.5969340864E-01 -1.2187322698E+00 8.9073834127E-02 -2.8779222383E+00 0.0000000000E+00 0.0000000000E+00 C SLEDGE/1 41 1.00D-10 10 10 7.5410 118608 SHAR_EOF fi # end of overwriting check if test -f 'evtru.01' then echo shar: will not over-write existing file "'evtru.01'" else cat << SHAR_EOF > 'evtru.01' C Benchmark E1; Pryce #1; Pruess-Fulton #104 B With default BCs etc. V 0 1.5198658211D0 1D-10 V 1 4.9433098221D0 1D-10 V 2 10.284662645D0 1D-09 V 3 17.559957746D0 1D-09 V 4 26.782863158D0 1D-09 V 5 37.964425862D0 1D-09 V 6 51.113357757D0 1D-09 V 7 66.236447703D0 1D-09 V 8 83.338962374D0 1D-09 V 9 102.42498840D0 1D-08 V 100 10204.071914D0 1D-06 V 101 10407.072163D0 1D-06 V 102 10612.072405D0 1D-06 V 103 10819.072640D0 1D-06 V 104 11028.072869D0 1D-06 SHAR_EOF fi # end of overwriting check if test -f 'evtru.02' then echo shar: will not over-write existing file "'evtru.02'" else cat << SHAR_EOF > 'evtru.02' C Benchmark E2; Pryce #2; Pruess-Fulton #182 B With r=25 and default BCs etc. V 0 -40.2567789847D0 1D-10 V 1 -21.3148606222D0 1D-10 V 2 -3.5209415266D0 1D-10 V 3 12.9864899527D0 1D-10 V 4 28.0627658995D0 1D-10 V 5 41.801071292D0 1D-09 V 6 55.0029571508D0 1D-09 V 7 69.0579883513D0 1D-09 V 8 85.023356505D0 1D-09 V 9 103.225680042D0 1D-09 V 100 10201.0306373D0 1D-07 V 101 10404.0300395D0 1D-07 V 102 10609.0294589D0 1D-07 V 103 10816.0288951D0 1D-07 V 104 11025.0283473D0 1D-07 SHAR_EOF fi # end of overwriting check if test -f 'evtru.05' then echo shar: will not over-write existing file "'evtru.05'" else cat << SHAR_EOF > 'evtru.05' C Benchmark M2; Pryce #5; Pruess-Fulton #130, c=1 B With default BCs etc. V 0 -0.3768458820D0 1D-10 V 1 -0.37222202189D0 1D-11 V 2 -0.36551769925D0 1D-11 V 3 -0.3581454100D0 1D-10 V 4 -0.35181830795D0 1D-11 V 5 -0.34815308692D0 1D-11 V 6 0.6062607724D0 1D-10 V 7 0.63999506921D0 1D-11 V 8 0.69400929095D0 1D-11 V 9 0.7644879436D0 1D-10 V 100 62.945565575D0 1D-09 V 101 64.19773168D0 1D-08 V 102 65.462235946D0 1D-08 V 103 66.739078340D0 1D-08 V 104 68.02825881D0 1D-08 SHAR_EOF fi # end of overwriting check if test -f 'evtru.07' then echo shar: will not over-write existing file "'evtru.07'" else cat << SHAR_EOF > 'evtru.07' C Benchmark M1; Pryce #7; Pruess-Fulton #108, beta= 30 B With default BCs etc. V 0 0.0 1D-18 V 1 117.946307662D0 1D-09 V 2 231.664929313D0 1D-09 V 3 231.664929313D0 1D-09 V 4 231.664929313D0 1D-09 V 5 340.888299810D0 1D-09 V 6 445.283089582D0 1D-09 V 7 445.283172307D0 1D-09 V 8 445.283255032D0 1D-09 V 9 544.418385149D0 1D-09 V 100 10653.5254359D0 1D-07 V 101 10856.4761532D0 1D-07 V 102 11061.4282995D0 1D-07 V 103 11268.3818201D0 1D-07 V 104 11477.3366628D0 1D-07 SHAR_EOF fi # end of overwriting check if test -f 'evtru.15' then echo shar: will not over-write existing file "'evtru.15'" else cat << SHAR_EOF > 'evtru.15' C Associated Legendre B This is for parameter c=0.25 (Chebyshev), lam_k=(k+1)^2 - 0.25 V 0 0.75 0D0 V 1 3.75 0D0 V 2 8.75 0D0 V 3 15.75 0D0 V 4 24.75 0D0 V 5 35.75 0D0 V 6 48.75 0D0 V 7 63.75 0D0 V 8 80.75 0D0 V 9 99.75 0D0 V 100 10200.75 0D0 V 101 10403.75 0D0 V 102 10608.75 0D0 V 103 10815.75 0D0 V 104 11024.75 0D0 SHAR_EOF fi # end of overwriting check if test -f 'evtru.18' then echo shar: will not over-write existing file "'evtru.18'" else cat << SHAR_EOF > 'evtru.18' C Benchmark E3; Pryce #18; Pruess-Fulton #18 B With default BCs etc. V 0 5.78318596295D0 1D-11 V 1 30.4712623437D0 1D-10 V 2 74.8870067907D0 1D-10 V 3 139.040284426D0 1D-09 V 4 222.932303618D0 1D-09 V 5 326.563352932D0 1D-09 V 6 449.933528518D0 1D-09 V 7 593.042869656D0 1D-09 V 8 755.891394784D0 1D-09 V 9 938.479113476D0 1D-09 V 100 100182.286322D0 1D-06 V 101 102180.881213D0 1D-06 V 102 104199.215313D0 1D-06 V 103 106237.288622D0 1D-06 V 104 108295.101140D0 1D-06 SHAR_EOF fi # end of overwriting check if test -f 'evtru.19' then echo shar: will not over-write existing file "'evtru.19'" else cat << SHAR_EOF > 'evtru.19' C Benchmark E4; Pryce #19; Pruess-Fulton #31 B With default BCs etc. V 0 9.86960440109D0 1D-11 V 1 39.4784176044D0 1D-10 V 2 88.8264396098D0 1D-10 V 3 157.913670417D0 1D-09 V 4 246.740110027D0 1D-09 V 5 355.305758439D0 1D-09 V 6 483.610615653D0 1D-09 V 7 631.654681670D0 1D-09 V 8 799.437956488D0 1D-09 V 9 986.960440109D0 1D-09 V 100 100679.834496D0 1D-06 V 101 102683.364189D0 1D-06 V 102 104706.633091D0 1D-06 V 103 106749.641202D0 1D-06 V 104 108812.388522D0 1D-06 SHAR_EOF fi # end of overwriting check if test -f 'evtru.20' then echo shar: will not over-write existing file "'evtru.20'" else cat << SHAR_EOF > 'evtru.20' C Benchmark M3; Pryce #20; Pruess-Fulton #6 B With default BCs etc. V 0 0.0 0D0 V 1 2.0 0D0 V 2 6.0 0D0 V 3 12.0 0D0 V 4 20.0 0D0 V 5 30.0 0D0 V 6 42.0 0D0 V 7 56.0 0D0 V 8 72.0 0D0 V 9 90.0 0D0 V 100 10100.0 0D0 V 101 10302.0 0D0 V 102 10506.0 0D0 V 103 10712.0 0D0 V 104 10920.0 0D0 SHAR_EOF fi # end of overwriting check if test -f 'evtru.21' then echo shar: will not over-write existing file "'evtru.21'" else cat << SHAR_EOF > 'evtru.21' C Benchmark M4; Pryce #21; Pruess-Fulton #93 B With default BCs etc. V 0 -2986.291097D0 1D-6 V 1 -111.555714615D0 1D-9 V 2 -11.3773405518D0 1D-10 V 3 30.2671755600D0 1D-10 V 4 95.7275207061D0 1D-10 V 5 184.117288624D0 1D-9 V 6 294.384801149D0 1D-9 V 7 426.009662030D0 1D-9 V 8 578.684469956D0 1D-9 V 9 752.201053064D0 1D-9 V 100 99984.3310585D0 1D-7 V 101 101984.773426D0 1D-6 V 102 104004.970125D0 1D-6 V 103 106044.920928D0 1D-6 V 104 108104.625615D0 1D-6 SHAR_EOF fi # end of overwriting check if test -f 'evtru.22' then echo shar: will not over-write existing file "'evtru.22'" else cat << SHAR_EOF > 'evtru.22' C Benchmark H1; Pryce #22; Pruess-Fulton #12 B With default BCs etc. V 0 0.25 0D0 SHAR_EOF fi # end of overwriting check if test -f 'evtru.23' then echo shar: will not over-write existing file "'evtru.23'" else cat << SHAR_EOF > 'evtru.23' C Benchmark H2; Pryce #23; Pruess-Fulton #15 B With default BCs etc. V 0 -0.15351471275D0 1D-11 SHAR_EOF fi # end of overwriting check if test -f 'evtru.28' then echo shar: will not over-write existing file "'evtru.28'" else cat << SHAR_EOF > 'evtru.28' C Benchmark I1; Pryce #18; Pruess-Fulton #1 B With default BCs etc. V 0 1.0 0D0 V 1 3.0 0D0 V 2 5.0 0D0 V 3 7.0 0D0 V 4 9.0 0D0 V 5 11.0 0D0 V 6 13.0 0D0 V 7 15.0 0D0 V 8 17.0 0D0 V 9 19.0 0D0 V 100 201.0 0D0 V 101 203.0 0D0 V 102 205.0 0D0 V 103 207.0 0D0 V 104 209.0 0D0 SHAR_EOF fi # end of overwriting check if test -f 'evtru.29' then echo shar: will not over-write existing file "'evtru.29'" else cat << SHAR_EOF > 'evtru.29' C Benchmark I2; Pryce #29; Pruess-Fulton #2 B With default BCs etc. V 0 -0.0625D0 0D0 V 1 -0.0277777777777778D0 1D-16 V 2 -0.015625D0 1D-16 V 3 -0.01D0 1D-16 V 4 -0.0069444444444444D0 1D-17 V 5 -0.005102040816D0 1D-12 V 6 -0.00390625D0 1D-17 V 7 -0.00308641975D0 1D-11 V 8 -0.0025D0 1D-17 V 9 -0.002066115702D0 1D-12 V -100 2.40292195309D-5 1D-16 V 101 -2.35648977283D-5 1D-16 V 102 -2.31139053254D-5 1D-16 V 103 -2.26757369614D-5 1D-16 V 104 -2.22499110004D-5 1D-16 SHAR_EOF fi # end of overwriting check if test -f 'evtru.30' then echo shar: will not over-write existing file "'evtru.30'" else cat << SHAR_EOF > 'evtru.30' C Benchmark I3; Pryce #30; Pruess-Fulton #13 B With default BCs etc. V 0 -0.25D0 0D0 V 1 -6.25D-2 0D0 V 2 -2.777777777777778D-2 1D-17 V 3 -1.5625D-2 0D0 1D-17 V 4 -1.0D-2 1D-17 V 5 -6.94444444444D-3 1D-18 V 6 -5.10204081632D-3 1D-18 V 7 -3.90625D-3 1D-18 V 8 -3.086419753086D-3 1D-18 V 9 -2.5D-3 1D-18 V 100 2.45074012352D-5 1D-20 V 101 -2.40292195309D-5 1D-20 V 102 -2.35648977283D-5 1D-20 V 103 -2.31139053254D-5 1D-20 V 104 -2.26757369615D-5 1D-20 SHAR_EOF fi # end of overwriting check if test -f 'evtru.32' then echo shar: will not over-write existing file "'evtru.32'" else cat << SHAR_EOF > 'evtru.32' C Benchmark I4; Pryce #32; Pruess-Fulton #161 B With default BCs etc. V 0 4.0 0D0 V 1 8.0 0D0 V 2 12.0 0D0 V 3 16.0 0D0 V 4 20.0 0D0 V 5 24.0 0D0 V 6 28.0 0D0 V 7 32.0 0D0 V 8 36.0 0D0 V 9 40.0 0D0 V 100 404.0 0D0 V 101 408.0 0D0 V 102 412.0 0D0 V 103 416.0 0D0 V 104 420.0 0D0 SHAR_EOF fi # end of overwriting check if test -f 'evtru.34' then echo shar: will not over-write existing file "'evtru.34'" else cat << SHAR_EOF > 'evtru.34' C Benchmark H3; Pryce #34; Pruess-Fulton #54 B With default BCs etc. V 0 5.78318596295D0 1D-11 SHAR_EOF fi # end of overwriting check if test -f 'evtru.35' then echo shar: will not over-write existing file "'evtru.35'" else cat << SHAR_EOF > 'evtru.35' C Benchmark Q1; Pryce #35; Pruess-Fulton #3 B With default BCs etc. V 0 -6.25D0 0D0 V 1 -2.25D0 0D0 V 2 -0.25D0 0D0 SHAR_EOF fi # end of overwriting check if test -f 'evtru.36' then echo shar: will not over-write existing file "'evtru.36'" else cat << SHAR_EOF > 'evtru.36' C Benchmark Q2; Pryce #36; Pruess-Fulton #7 B With default BCs etc. V 0 -1923.529653D0 1D-6 V 1 -1777.2908125D0 1D-7 V 25 -1.7670126867D0 1D-10 SHAR_EOF fi # end of overwriting check if test -f 'evtru.40' then echo shar: will not over-write existing file "'evtru.40'" else cat << SHAR_EOF > 'evtru.40' C Benchmark Q3; Pryce #40; Pruess-Fulton #140 B With default BCs etc. V 0 -48.349481052D0 1D-9 V 1 -46.4616592324D0 1D-9 V 10 -13.522303353D0 1D-9 SHAR_EOF fi # end of overwriting check if test -f 'evtru.41' then echo shar: will not over-write existing file "'evtru.41'" else cat << SHAR_EOF > 'evtru.41' C Benchmark Q4; Pryce #41; Pruess-Fulton #172, l=1.0 B With default BCs etc. V 0 163.2238021D0 1D-7 V 1 401.065122144D0 1D-9 V 2 2221.36634008D0 1D-8 SHAR_EOF fi # end of overwriting check if test -f 'evtru.43' then echo shar: will not over-write existing file "'evtru.43'" else cat << SHAR_EOF > 'evtru.43' C Benchmark H4; Pryce #43; Pruess-Fulton #164, alpha=0 B With default BCs etc. V 1 -25.0D0 0D0 SHAR_EOF fi # end of overwriting check if test -f 'sdtru.56' then echo shar: will not over-write existing file "'sdtru.56'" else cat << SHAR_EOF > 'sdtru.56' B Problem 56, lambda-dependent BC coeffs 1 0 0 1 C Sample lambda-mesh recommended by Fulton & Pruess C SDF values computed by SLEDGE with tolerance 1e-6 R 0.0 0.178037837224755 1e-6 R 0.1 0.247228801423794 1e-6 R 0.2 0.298874042566102 1e-6 R 0.3 0.339439745905772 1e-6 R 0.4 0.372987710880954 1e-6 R 0.5 0.401566008533742 1e-6 R 0.6 0.426395663769014 1e-6 R 0.7 0.448281958445012 1e-6 R 0.8 0.467792452336159 1e-6 R 0.9 0.485343127387624 1e-6 R 1.0 0.501251056353509 1e-6 R 1.1 0.515761608204196 1e-6 R 1.2 0.529072540091809 1e-6 R 1.5 0.563256917671342 1e-6 R 2.0 0.606740944185449 1e-6 R 5.0 0.731126882200227 1e-6 R 10.0 0.804438217323254 1e-6 R 20.0 0.859705846823187 1e-6 R 50.0 0.910492169402615 1e-6 R 100.0 0.936523480007052 1e-6 R 200.0 0.955049824195116 1e-6 R 500.0 0.971546187500839 1e-6 R 1000.0 0.979874230173333 1e-6 R 2000.0 0.985766803865964 1e-6 R 5000.0 0.990997183115877 1e-6 R 10000.0 0.993633735070057 1e-6 R 50000.0 0.997152801814900 1e-6 SHAR_EOF fi # end of overwriting check if test -f 'sdtru.57' then echo shar: will not over-write existing file "'sdtru.57'" else cat << SHAR_EOF > 'sdtru.57' B Problem 57, lambda-dependent BC coeffs 1 0 0 1 C Sample lambda-mesh recommended by Fulton & Pruess, tolerance 1d-6 R 0.0 0.276681559266557 1d-6 R 0.1 0.307961201273323 1d-6 R 0.2 0.336647847001587 1d-6 R 0.3 0.362898957351568 1d-6 R 0.4 0.386919746349256 1d-6 R 0.5 0.408926159200427 1d-6 R 0.6 0.429121140556100 1d-6 R 0.7 0.447694626695562 1d-6 R 0.8 0.464817430736345 1d-6 R 0.9 0.480645155148660 1d-6 R 1.0 0.495309781234082 1d-6 R 1.1 0.508933360842844 1d-6 R 1.2 0.521618379803209 1d-6 R 1.5 0.554929634177825 1d-6 R 2.0 0.598513378036877 1d-6 R 5.0 0.726783359657620 1d-6 R 10.0 0.802473715642727 1d-6 R 20.0 0.858920206450676 1d-6 R 50.0 0.910277764690928 1d-6 R 100.0 0.936445780305491 1d-6 R 200.0 0.955021924876355 1d-6 R 500.0 0.971538954956921 1d-6 R 1000.0 0.979870945984460 1d-6 R 2000.0 0.985767348276968 1d-6 R 5000.0 0.990999423009099 1d-6 R 10000.0 0.993636385606588 1d-6 R 50000.0 0.997155531744216 1d-6 B Problem 57, lambda-dependent BC coeffs 1 0 0 1 C computed by SLEDGE with TOL=1d-4 on UNIForm mesh R 0.00000000000000 0.276721839737367 1d-4 R 0.476190476190476 0.403856612794218 1d-4 R 1.00000000000000 0.495309816679743 1d-4 R 1.57894736842105 0.562685256474484 1d-4 R 2.22222222222222 0.614366653150662 1d-4 R 2.94117647058824 0.655551547126632 1d-4 R 3.75000000000000 0.689454213862939 1d-4 R 4.66666666666667 0.718134033375012 1d-4 R 5.71428571428572 0.742956473512525 1d-4 R 6.92307692307692 0.764865320996004 1d-4 R 8.33333333333333 0.784537375502543 1d-4 R 10.0000000000000 0.802474602636628 1d-4 R 12.0000000000000 0.819062617014565 1d-4 R 14.4444444444444 0.834612883470804 1d-4 R 17.5000000000000 0.849386287477404 1d-4 R 21.4285714285714 0.863616905945061 1d-4 R 26.6666666666667 0.877532820654729 1d-4 R 34.0000000000000 0.891379902216115 1d-4 R 45.0000000000000 0.905461855906129 1d-4 R 63.3333333333333 0.920220492861604 1d-4 R 100.000000000000 0.936445753291453 1d-4 SHAR_EOF fi # end of overwriting check cd .. cd .. if test -f 'standard.lst' then echo shar: will not over-write existing file "'standard.lst'" else cat << SHAR_EOF > 'standard.lst' Contents of Test Set standard No. 1:-u" + u/(x+alpha)^2 = lambda u Parms alpha(>0, 0.1 gives standard problem in book) No. 2:Mathieu equation -u" + 2r cos(2x) u = lambda u Parms r No. 3:Ref: Klotter, Technisch Schwingungslehre, I, p.12 No parameters No. 4:Truncated Hydrogen equation Parms Right-hand endpoint b No. 5:Version of Mathieu equation, -u" + c cos(x) u = lambda u Parms c No. 6:Truncated Gelfand-Levitan. No parameters No. 7:Coffey-Evans eqn -u" + beta[beta sin(2x)^2 - 2cos(2x)]u = lam u Parms beta No. 8:Truncated Lennard-Jones LJ(12,6) Parms endpoint b No. 9:Regular with nasty w(x). Ref Fox, BVPs in DEs, Wisconsin 1960 No parameters No.10:Regular with nasty 1/p(x). Ref: J D Pryce, Num Sol SLPs, 1993 No parameters No.11:Regular with nasty q(x). Ref: Pruess/Fulton 133 No parameters No.12:Bessel`s equation -(xu')' + (nu**2/x) u = lambda x u Parms nu**2(can be <0) No.13:Bessel eqn in normal form. -u" + ((nu**2-1/4)/x**2)u = lam u Parms nu**2(can be <0) No.14:Ref: Bender & Orzsag. -u" - l(l+1)sech**2(x) u = lambda u Parms l No.15:Assoc. Legendre eqn. -((1-x^2)u')' + c u/(1-x^2) = lambda u Parms c(c=0 for usual Legendre, c=1/4 for Chebyshev) No.16:Assoc Legendre tfmed. -u" + [(c-1/4)sec(x)^2 - 1/4] u = lambda u Parms c(c=0 for usual Legendre, c=1/4 reduces to regular case) No.17:Anharmonic oscillator(Marletta PhD) -u" + x^alpha u = lambda u Parms alpha No.18:Bessel, order 0. -(xu')' = lambda x u No parameters No.19:Bessel, order 1/2. -(xu')' + 1/(4x) u = lambda x u No parameters No.20:Legendre eqn. -((1-x^2)u')' = lambda u No parameters No.21:Slightly tricky q(x). -u" -(10/x^1.5) u = lambda u No parameters No.22:Legendre eqn, Liouville form. -u" -(1/4)sec(x)^2 u = lambda u No parameters No.23:Generalized hypergeom., -u"+ (-242ch x + 241)/(4sh(x)^2)u=lam u No parameters No.24:Latzko equation. -((1-x^7)u')' = lambda x^7 u No parameters No.25:Transformed regular -(x^4 u')' - 2x^2 u = lambda x^4 u No parameters No.26:Mysterious exact lam_0=7. -(x^3 u')' + x^3 u = lambda x^2 u No parameters No.27:Airy equation. -u" + x u = lambda u No parameters No.28:Harmonic oscillator. -u" + x^2 u = lambda u No parameters No.29:Hydrogen atom. -u" + (2/x^2 - 1/x) u = lambda u No parameters No.30:Coulomb potential. -u" - u/x = lambda u No parameters No.31:Transformed H-atom. -(x^2 u')' -(l(l+1)-x) u = lambda x^2 u Parms l(integer>=0) No.32:Laguerre eqn. -u" + (x^2 + (alpha-1/4)/x^2) u = lambda u Parms alpha(=1 for standard problem) No.33:Raman Scattering. -u" + (-7x^2 + 0.5x^3 + x^4) u = 0.5 lambda u No parameters No.34:Pruess LCN/LCO border. -u"/2 -(1/(8x^2)+sech(x)^2) u = lambda u No parameters No.35:Morse(1929) potential. -u" + (9e^(-x)-18e^(-2x))u = lambda u No parameters No.36:Morse potential, Secrest et al.(1962) No parameters No.37:Quartic anharmonic oscillator. -u" + (x^4 + x^2) u = lambda u No parameters No.38:Close-evs problem -u" + (x^4-25x^2) u = lambda u No parameters No.39:Morse(Marletta). -u" + 8000[e^(-3x) - 2e^(-3x/2)] u = lambda u No parameters No.40:Wicke and Harris(1976), spike at bottom of well No parameters No.41:Woods-Saxon potential(Vanden Berghe et al. 1989). Parms l(>=0) No.42:Another model potential(Vanden Berghe et al. 1989). Parms l No.43:Bessel, LCN/LCO border. -u" + ((alpha-1/4)/x^2)u = lam u Parms alpha, say in range -0.1 to 0.1 No.44:Border of LPN and LCN. -u" + x^(alpha-2) u = lambda u Parms alpha(near 0) No.45:Border of LCN and LCO. -u" - x^(alpha-2) u = lambda u Parms alpha(near 0) No.46:Bessel normal form, nonFried. BC, ref. Bailey Everitt Zettl 1991 No parameters No.47:NonFriedrichs, Pryce/Marletta. -(xu')'+(b/x)^2 u = lam x^(2b)u Parms b(>0) No.48:Spectral density fn. example. Ref: Pruess/Fulton 75 No parameters No.49:Modified Bessel(Bessel of order nu=i/2). Ref: Pruess/Fulton 33 No parameters No.50:Weierstrass-Mandelbrot. -u" + (c-(omega^2+.25)/x^2) u = lambda u Parms omega >0 & offset c; c>0 vital for SLEIGN2 to find lambda_0 No.51:Titchmarsh problem. -u" - e^x u = lambda u No parameters No.52:Limit-circle osc with cont spectrum. -u" -1/x^3 u = lambda u No parameters No.53:Approximate harmonic oscillator, Pryce 1993 Parms b (reg BCs u(-b)=u(b)=0 are used, b>=10^35 taken as Infinity) No.54:Indefinite weight function, Marletta PhD 1991 No parameters No.55:Indefinite weight fn, Bailey et al. ACM TOMS 1978 No parameters No.56:lambda-dependent BC at x=a, Fulton/Pruess 1992 Parms A1 A2 A1' A2' in SLEDGE-style BCs, 1 0 0 1 for prob. in book No.57:lambda-dependent BC at x=a, Fulton/Pruess private comm. 1992 Parms A1 A2 A1' A2' in SLEDGE-style BCs, 1 0 0 1 for prob. in book No.58:Rossby wave equation, Drazin et al. J Fluid Mech 1982 Parms alpha, c No.59:Ref Gelfand & Levitan, AMS Translations 1955. No parameters No.60:Problem with pseudo-eigenvalue, Pryce 1989, ref Marletta PhD 91 No parameters SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'sledge' then mkdir 'sledge' fi cd 'sledge' if test -f 'sledgemd.f' then echo shar: will not over-write existing file "'sledgemd.f'" else cat << SHAR_EOF > 'sledgemd.f' *********************************************************************** * * * Routines for SLEDGE * * (Sturm-Liouville Estimates Determined by Global Errors) * * * *********************************************************************** C C Release 2.2 12/02/94 C C Steven Pruess, Colorado School of Mines C spruess@mines.colorado.edu C Charles Fulton, Florida Institute of Technology C fulton@zach.fit.edu C *********************************************************************** * These routines estimate eigenvalues, eigenfunctions and/or * * spectral density functions for Sturm-Liouville problems. * * The differential equation has the form: * * * * -(p(x)u')' + q(x)u = EV*r(x)u for x in [A,B] * * * * with boundary conditions (at regular points) * * * * A1*u - A2*(pu') = EV*(A1'*u - A2'*(pu')) at A * * B1*u + B2*(pu') = 0 at B . * * * * The functions p(x) and r(x) are assumed to be positive in * * the open interval (A,B). * *********************************************************************** C C Possible outputs are: C a set of eigenvalues; C a set of eigenvalues and tables of values for their eigen- C functions; C a table of the spectral density function (for cases with C continuous spectrum). C a classification of the problem (regular or singular; if C singular then limit point or limit circle, oscillatory C or nonoscillatory). C C The code can find eigenvalues and eigenfunctions for problems C in spectral category 1 (both endpoints NONOSC), spectral C category 2 (one endpoint NONOSC and the other O-NO), and C those discrete eigenvalues below the essential spectrum in C spectral category 10 (both endpoints O-NO). Here OSC at an C endpoint means the Sturm-Liouville equation is oscillatory for C all real values of EV at that endpoint, NONOSC at an endpoint C means the equation is nonoscillatory for all real values of EV C at that endpoint, and O-NO means there is a `cutoff' value EV' C such that the equation is nonoscillatory for real values of C EV < EV' and oscillatory for real values of EV > EV'. For C problems in other spectral categories an error return will C be generated. The manner in which SLEDGE classifies singular C endpoints of Sturm-Liouville problems as LP/LC (Limit Point/ C Limit Circle), OSC/NONOSC/O-NO, and uses this information to C determine the spectral category is explained in detail in C reference [2]. C C There is one subroutine called SLEDGE of direct interest to the C user; additionally, a secondary routine INTERV is available which C determines the indices of eigenvalues located in a specified C subinterval of the real line. C C The names of other routines in this package are AITKEN, ASYMEV, C ASYMR, BRCKET, CLASS, CLSEND, DENSEF, DSCRIP, EXTRAP, GETEF, C GETRN, MESH, POWER, PQRINT, REGULR, SHOOT, START, STEP, and C ZZERO. C C There are 4 blocks of labeled COMMON with the names SLREAL, C SLINT, SLLOG, and SLCLSS. C C This is the double precision version of the code; all floating C point variables should be declared DOUBLE PRECISION in the C calling program. In these subprograms all such local C variables and constants have been explicitly declared; also, C FORTRAN77 generic intrinsic functions have been used, so C conversion to single precision should be straightforward, if C desired. C C ACKNOWLEDGMENT: This work was partially supported by the C National Science Foundation under grants DMS-8813113 and DMS- C 8905202 to Florida Institute of Technology and DMS-8800839 and C DMS-8905232 to the Colorado School of Mines. C C References C C The following papers are available from the authors on request: C C [1]. Pruess & Fulton, Mathematical software for Sturm-Liouville C problems, ACM Trans. on Math. Software, 19 (1993), 360-376. C C [2]. Fulton, Pruess & Xie, The automatic classification of Sturm- C Liouville problems, submitted, 1992. C C [3]. Pruess, Fulton & Xie, An asymptotic numerical method for a C class of singular Sturm-Liouville problems, to appear in C SIAM J. Numer. Anal. C C [4] Fulton and Pruess, Eigenvalue and eigenfunction asymptotics C for regular Sturm-Liouville problems, Jour. Math. Anal. and C Appls., 188 (1994), 297-340. C C [5] Fulton and Pruess, Numerical Approximation of singular C spectral functions arising from the Fourier-Jacobi problem C on a half line with continuous spectra, Sixth International C Workshop in Analysis and its Applications, June, 1992. C [6]. Pruess, Fulton & Xie, Performance of the Sturm-Liouville C software package SLEDGE, Colo. School of Mines, Dept. of C Math. and Comp. Sci., MCS-91-19, 1991. Revision 12/92. C----------------------------------------------------------------------- C Brief overview of algorithms: C C The code constructs (or takes from input) an initial mesh, C called the level 0 mesh. Subsequent meshes (for level 1,2,...) C are unions of the previous level's mesh with its midpoints. A C sequence of estimates for desired eigenvalues and eigenfunctions C is constructed, one set for each level. These estimates (the C eigenvalue is called EvHat) are exact solutions (up to the C requested tolerance) of a Sturm-Liouville problem which is an C approximation to the original one; this approximation results C from replacing the given coefficient functions with step function C approximations relative to the current level's mesh. The eigen- C functions of the resulting ODE's are piecewise trigonometric C (circular or hyperbolic) functions. C If estimates for the spectral density function are reqested, C these are computed as limits of a sequence of spectral density C functions of approximating regular problems. For these regular C problems the spectral density function is a step function, and C is computed directly from the definition making use of computed C eigenvalues and the norm reciprocals of the corresponding eigen- C functions. If verbose output is rquested by the user, there C will be displayed iterations (corresponding to the sequence of C approximating regular intervals which the code automatically C selects) and within each iteration there will be levels C (corresponding to increasingly finer meshes as described above). C A step spectral density function will be printed at each level C of each iteration. The spectral density function displayed at C the end of each iteration is the result of an h-squared extra- C polation over the regular step functions generated at each level C of this iteration. The condition for stopping at a given iter- C ation is a straightforward comparison of the spectral function C data for the current iteration with the previous iteration. There C is no extrapolation over the sequence of regular approximating C intervals as no extrapolation theory for the approximation of C the singular spectral function by regular step spectral functions C is known. (To achieve closer approximation of the regular step C spectral functions to the singular spectral function, it is C actually the piecewise linear function obtained by joining the C midpoints of successive steps by a straight line which is used as C the `regular' spectral function for the purpose of generating the C actual data used for the h-squared extrapolation.) C The classification is determined by applying standard theory C to an approximating problem, each of whose coefficient functions, C in a small neighborhood of each endpoint, consists of the leading C term in a power-like asymptotic development. For this reason C there are many problems, particularly those with oscillatory C coefficient functions, for which the code's output for the C classification information is labelled `uncertain'. For further C information on the theory used by the code to generate endpoint C classifications and spectral category information see [2] above. C----------------------------------------------------------------------- C Usage (simple explanation) - C The subroutine SLEDGE is called in the following manner: C C SUBROUTINE SLEDGE(JOB,CONS,ENDFIN,INVEC,TOL,TYPE,EV,NUMX,XEF,EF, C PDEF,T,RHO,IFLAG,STORE) C C If k eigenvalues (no eigenvectors) are sought then set C (a) the logical 5-vector JOB to (True, False, False, False, True); C (b) the real 8-vector CONS to the values of A1,A1',A2,A2',B1,B2, C A,B for the boundary condition information. It does not C matter what values are used for infinite endpoints, nor for C the boundary constants at a singular endpoint; the code C automatically selects the Friedrichs' boundary condition at C NONOSC singular endpoints, overriding user input for the C boundary condition constants; for infinite endpoints the code C also automatically selects these constants. C (c) the logical 2-vector ENDFIN to (True, True) if both endpoints C are finite, (True, False) if A is finite but B infinite, etc.; C (d) the integer vector INVEC should have C INVEC(1) = 0 (no internal printing) C INVEC(2) = 0 C INVEC(3) = k, the number of eigenvalues sought C INVEC(3+i) = index of ith eigenvalue sought,i = 1,...,k; C (e) the real 6-vector TOL should have C TOL(1) = absolute error tolerance desired, C TOL(2) = relative error tolerance desired, C the remaining 4 entries of TOL are ignored; C (f) the output estimate for the ith eigenvalue is returned C in EV(i), i = 1,...,k; C (g) the output integer k-vector IFLAG(*) should have all entries C zero; nonzero values indicate warnings or error returns and C are explained in the detailed usage section below; C (h) the auxiliary vector STORE(*) should be dimensioned at least C 155 in the calling program; C (i) the logical 4 by 2 vector TYPE, the real vectors XEF(1), C EF(1), PDEF(1), T(1), and RHO(1) can be ignored except that C they need to be declared in the calling program. The integer C scalar NUMX can also be ignored. C C If k eigenfunctions are also desired, then follow the above C pattern except make JOB(1) False and JOB(2) True. The values of C TOL(3) and TOL(4) control the absolute and relative errors in C each u(x); TOL(5) and TOL(6) control the absolute and relative C errors in each (pu')(x). It is usually appropriate to set TOL(5) C = TOL(3) = TOL(1) and TOL(6) = TOL(4) = TOL(2), but the user has C the option of entering all six tolerance parameters as desired. C The output eigenfunction information is returned in the three C real vectors X(*) for the independent variable x , EF(*) for u(x), C PDEF(*) for (pu')(x). The code automatically chooses the x C values; the number of values is returned in NUMX. If you prefer C another choice of output points, see the detailed explanation C below on usage of the code. The values for the first requested C u(x) are returned in the first NUMX locations of EF(*), those for C the second are in the next NUMX locations, etc. PDEF(*) is part- C itioned similarly; X(*) must be dimensioned at least 31 in the C calling program while EF(*) and PDEF(*) must be dimensioned at C least 31*k. The auxiliary vector STORE(*) should be dimensioned C at least 420. C C For other possibilities, see the detailed description which C follows. C----------------------------------------------------------------------- C Usage (detailed explanation) - C C SUBROUTINE SLEDGE(JOB,CONS,ENDFIN,INVEC,TOL,TYPE,EV,NUMX,XEF,EF,PDEF, C T,RHO,IFLAG,STORE) C C Input parameters; C JOB(*) = logical 5-vector, C JOB(1) = .True. iff a set of eigenvalues are to be C computed but not their eigenfunctions. C JOB(2) = .True. iff a set of eigenvalue and eigenfunc- C tion pairs are to be calculated. C JOB(3) = .True. iff the spectral function is to be C computed over some subinterval of the C essential spectrum. C JOB(4) = .True. iff the normal call to the routines for C classification (regular/singular, etc.) C is OVERRIDDEN. If JOB(4) is True then C TYPE(*,*) discussed below must be C INPUT correctly! Most users will not C want to override the classification C routines, but it would, of course, be C appropriate for users experimenting with C problems for which the coefficient C functions do not have power-like C behavior near the singular endpoints. C Note: the code may perform poorly if C the classification information is C incorrect; since the cost is usually C negligible, it is strongly recommended C that JOB(4) be False. The classifica- C tion is deemed sufficiently important C for spectral density function calcul- C ations that JOB(4) is ignored when C the input JOB(3) is True. C JOB(5) = .True. iff mesh distribution is to be chosen C by SLEDGE. If JOB(5) is True and NUMX C is zero, then the number of mesh C points is also chosen by SLEDGE; if C NUMX > 0 then NUMX mesh points will be C used. If JOB(5) is False, then the C number (NUMX) and distribution C (XEF(*)) must be input by the user. C If JOB(3) is True and JOB(5) False C then the user must set BOTH the number C NUMX and distribution. In this case, C NO global error estimates are made. C CONS(*) = real vector of length 8, values are the boundary C condition constants A1, A1', A2, A2', B1, B2, A, B. C In the case of a NONOSC singular endpoint, the class- C ification routine uses the Friedrichs' boundary C condition constants. The code cannot automatically C choose a non-Friedrichs' boundary condition; however, C interval truncation in the user's calling program can C be used, together with many calls to SLEDGE, to C compute singular eigenvalues associated with a non- C Friedrichs' boundary condition at a NONOSC endpoint C (see remark 12 below). C ENDFIN(*) = logical 2-vector, values are C ENDFIN(1) = .True. iff endpoint A is finite. C ENDFIN(2) = .True. iff endpoint B is finite. C INVEC(*) = integer vector of length 3+(number of eigenvalues C desired). This vector contains a variety of input C information. C INVEC(1) controls the amount of internal printing: values are C from 0 (no printing) to 5 (much printing). C For INVEC(1) > 0 much of the output will be to a file C attached to unit #21 which should be named in the C user's calling program via an OPEN statement. C Output for the various cases is, when INVEC(1) = C 0 no printing. C When JOB(1) or JOB(2) is True C 1 initial mesh (the first 51 or fewer points), C eigenvalue estimate at each level, C 4 the above, C at each level C matching point for eigenfunction shooting, C X(*), EF(*), PDE(*) values, C 5 all the above, C at each level C brackets for the eigenvalue search, C intermediate shooting info for the eigen- C function and eigenfunction norm. C When JOB(3) is True C 1 the actual (a,b) used at each iteration, C the total number of eigenvalues computed, C 2 the above, C switchover points to the asymptotic formulas, C some intermediate Rho(t) approximations, C 3 all the above, C initial meshes for each iteration, C index of the largest EV which may be computed, C various Ev and RsubN values, C 4 all of the above, C RhoHat values at each level, C 5 all of the above, C all Ev and RsubN values below switchover point. C When JOB(4) is False C 2 output a description of the spectrum, C 3 the above plus the constants for the C Friedrichs' boundary condition(s), C 5 all the above plus intermediate details of C classification calculation. C Some of the output may go to the default output device C (screen or printer), but all information requested is C also directed to the file attached to unit #21. C INVEC(2) gives the number (positive) of output values desired C for the array RHO(*) (not referenced if JOB(3) is C False). C INVEC(3) is the total number of eigenvalues to be output in C EV(*). C INVEC(J) for J = 4, 5, ..., 3+INVEC(3) contains the indices for C the eigenvalues sought. If JOB(1) and JOB(2) are C False, this part of INVEC(*) is not referenced. C TOL(*) = real vector of from 2 to 6 tolerances. C If JOB(1) or JOB(2) is True then C TOL(1) is the absolute error tolerance for e-values, C TOL(2) is the relative error tolerance for e-values, C TOL(3) is the abs. error tolerance for e-functions, C TOL(4) is the rel. error tolerance for e-functions, C TOL(5) is the abs. error tolerance for eigenfunction C derivatives, C TOL(6) is the rel. error tolerance for eigenfunction C derivatives. C Eigenfunction tolerances need not be set if JOB(2) C is False. C If JOB(3) is True then C TOL(1) is the absolute error tolerance, C TOL(2) is the relative error tolerance; C the output RHO values are NOT required to satisfy C these tolerances when JOB(5) is False. C All absolute error tolerances must be positive; all C relative error tolerances must be at least 100 times C the unit roundoff. C NUMX = integer whose value is C the number of output points where each eigen- C function is to be evaluated (the number of entries C in XEF(*)) when JOB(2) is True, C or C the number of points in the initial mesh used when C JOB(5) is False and NUMX>0. C If JOB(5) is False, the points in XEF(*) should be C chosen to have a reasonable distribution. Since the C endpoints A and B must be part of any mesh, NUMX C cannot be 1 in this case. If JOB(5) is FALSE and C JOB(3) is True, then NUMX must be positive. C XEF(*) = real vector of points where C eigenfunction estimates are desired (JOB(2) True) C or C where user's initial mesh is entered (JOB(5) False C and NUMX>0). C The values must satisfy C A = XEF(1) < XEF(2) < ... < XEF(NUMX) = B . C When JOB(2) is True the initial mesh corresponds to C the set of points where eigenfunction output is C desired. If JOB(2) is False and NUMX = 0, then this C vector is not referenced. When A and/or B are C infinite (as indicated through ENDFIN(*)), the C entries XEF(1) and/or XEF(NUMX) are ignored; however, C it is required that XEF(2) be negative when ENDFIN(1) C is False, and XEF(NUMX-1) be positive when ENDFIN(2) C is False (otherwise, IFLAG = -39 will result). C T(*) = real vector of INVEC(2) values where the spectral C function RHO(*) is desired (the existence and location C of continuous spectrum can be found by first calling C SLEDGE with JOB(J) False, J=1,...,4 and INVEC(1) = 1). C Vector T(*) is not referenced if JOB(3) is False. Its C entries must be in increasing order. C C Output parameters: C TYPE(*,*) = 4 by 2 logical array; column 1 carries information C about endpoint A while column 2 refers to B. C TYPE(1,*) = True iff the endpoint is regular, C TYPE(2,*) = True iff it is limit circle, C TYPE(3,*) = True iff it is nonoscillatory for all EV, C TYPE(4,*) = True iff it is oscillatory for all EV, C Important note: all of these must be correctly INPUT C if JOB(4) is True! C EV(*) = real vector containing the computed approximations to C the eigenvalues whose indices are specified in C INVEC(*); if JOB(1) and JOB(2) are False, then the C output has no meaning. C NUMX = the number of output points for eigenfunctions when C input NUMX = 0, and JOB(2) or JOB(5) is True. C XEF(*) = input values (if any) are changed only if JOB(2) and C JOB(5) are True; in this case, the output values C are chosen by the code. If JOB(2) is False then this C vector is not referenced; if JOB(2) is True and NUMX>0 C on input then XEF(*) should be dimensioned at least C NUMX+16 in the calling program. If JOB(2) is True and C NUMX=0 on input (so that the code chooses NUMX), then C dimension XEF(*) at least 31 in the calling program. C EF(*) = real vector of eigenfunction values: EF((k-1)*NUMX+i) C is the estimate of u(XEF(i)) corresponding to the C eigenvalue in EV(k). If JOB(2) is False then this C vector is not referenced. Otherwise, if JOB(2) is C True and NUMX>0 on input then EF(*) should be C dimensioned at least NUMX*INVEC(3) in the calling C program. If JOB(2) is True and NUMX=0 on input (so C that the code chooses NUMX), then dimension XEF(*) C at least 31*INVEC(3) in the calling program. C PDEF(*) = real vector of eigenfunction derivative values: C PDEF((k-1)*NUMX+i) is the estimate of (pu')(XEF(i)) C corresponding to the eigenvalue in EV(k). If JOB(2) C is False then this vector is not referenced; otherwise, C it must be dimensioned as is EF(*). C RHO(*) = real vector of values for the spectral density C function rho(t), RHO(I) = rho(T(I)). RHO(*) must be C dimensioned at least INVEC(2); this vector is not C referenced if JOB(3) is False. C IFLAG(*) = integer vector carrying information about the output. C Declared length must be at least max(1,INVEC(3)). For the Kth C requested eigenvalue (when JOB(1) or JOB(2) is true; otherwise, C only IFLAG(1) is used): C IFLAG(K) = 0, normal return, output should be reliable. C < 0, fatal error, calculations ceased: if C = -1, too many levels needed for the eigenvalue C calculation; problem seems too difficult for C this algorithm at this tolerance. Are the C coefficient functions nonsmooth? C = -2, too many levels needed for the eigenfunction C calculation; problem seems too difficult for C this algorithm at this tolerance. Are the C eigenfunctions ill-conditioned? C = -3, too many levels needed for the spectral density C calculation; problem seems too difficult for C this algorithm at this tolerance. C = -4, the user has requested the spectral density C function for a problem which has no continuous C spectrum. C = -5, the user has requested the spectral density C function for a problem with both endpoints C generating essential spectrum, i.e., both C endpoints being either OSC or O-NO. The spectral C density function calculation has not been C implemented for such cases. For spectral C category 10 (both endpoints O-NO) the spectral C multiplicity is generally two, proper normal- C izations for the solutions against which the C spectral functions will be normalized will C depend on how the user wants to express the C eigenfunction expansion. Users having problems C in spectral category 10 are encouraged to supply C them to the authors, and if possible, recommend C normalizations of the two solutions to be used in C writing the associated eigenfunction expansion. C = -6, the user has requested the spectral density C function for a problem in spectral category 2 for C which a proper normalization of solution at the C NONOSC endpoint is not known; for example, C problems with an irregular singular point or C infinite endpoint at one end and continuous C spectrum generated at the other. Users with C problems of this type are encouraged to supply C them to the authors, and if possible, recommend a C normalization of solution at the NONOSC endpoint C which they would like to see implemented. As a C rule it is best to pick a normalization which C ensures that the solution is uniquely fixed and C entire in the eigenvalue parameter EV for all x C in the Sturm-Liouville interval; for further C mathematical information on NONOSC endpoints we C refer to paper [2] above. C = -7, problems encountered in obtaining a bracket. C = -8, too small a step used in the integration; C TOL(*) values may be too small for this problem. C = -9, too small a step used in a spectral density C function calculation for which the continuous C spectrum is generated by a finite endpoint. Try C transforming to Liouville (or some other) form. C = -10, an argument to the circular trig functions is C too large. Try rerunning with a finer initial C mesh, or, on singular problems, use interval C truncation (see remark (12)). C = -15, p(x) and r(x) not positive in (A,B). C = -20, eigenvalues/functions were requested for a C problem with an OSC singular endpoint. C Interval truncation (see remark (12)) must be C used on such problems. C = -3?, illegal input, viz. C -30, NUMX = 1 when JOB(5) is True, C or NUMX = 0 when JOB(3) is True and JOB(5) is C False, C -31, B1 = B2 = 0 (at a regular endpoint), C -32, A1'*A2-A1*A2' .le. 0 when A1' or A2' nonzero, C -33, A1 = A2 = A1'= A2'= 0 (at a regular endpoint), C -34, A .ge. B (when both are finite), C -35, TOL(odd) .le. 0 , C -36, TOL(even) < 100*unit roundoff, C -37, INVEC(k) < 0 for some k>3 when INVEC(3)>0, C -38, INVEC(2) .le. 0 when JOB(3) is True , C -39, XEF(*) entries out of order or not in [A,B]. C or XEF(2), XEF(NUMX-1) have the wrong sign in C infinite interval cases, C or T(*) entries are out of order. C > 0, indicates some kind of warning, in this case the C value may contain ANY of the following digits: C = 1, failure in routine BRCKET probably due to a C cluster of eigenvalues which the code cannot C separate. Calculations have continued as best C as possible, but any eigenfunction results are C suspect. Try rerunning with tighter input C tolerances to separate the cluster. C = 2, there is uncertainty in the classification for C this problem. Because of the limitations of the C floating point arithmetic on the computer used, C and the nature of the finite sampling, the C routine is cannot be decisive about the C classification information at the requested C tolerance. C = 3, there may be some eigenvalues imbedded in the C essential spectrum; using IPRINT greater than C zero will result in additional output giving C the location of the approximating eigenvalues C for the step function problem. These could be C extrapolated to estimate the actual eigenvalue C embedded in the essential spectrum. C = 5, a change of variables was made to avoid poten- C tial slow convergence; however, the global C error estimates may not be as reliable. Some C experimentation using different tolerances is C recommended. C = 6, there were problems with eigenfunction conver- C gence in a spectral density calculation; the C output Rho(t) may not be accurate. C C Auxiliary storage: C STORE(*) = real vector of auxiliary storage, must be dimensioned C at least C max(155,NUMX+16) in general; C 26*(NUMX+16) for any eigenfunction calculation; C 2400+13*INVEC(2) for any spectral density calculation. C----------------------------------------------------------------------- C SUBROUTINE INTERV(FIRST,ALPHA,BETA,CONS,ENDFIN,NFIRST,NTOTAL, C IFLAG,STORE) C C Input parameters: C FIRST = logical; value is True if various internal variables C have not yet been set. If a prior call has been made C to INTERV with FIRST True, then a little time can C be saved by letting FIRST be False. C IMPORTANT NOTE: setting FIRST = True will clobber any C initial mesh the user has input (when NUMX > 0 or C JOB(5) is False); also, INTERV will classify the C problem irregardless of what JOB(4) is set to C for SLEDGE. C ALPHA = real value of left end point of search interval. C BETA = real value of right end point of search interval. C CONS(* ) = real vector of 8 input constants: A1, A1', A2, A2', C B1, B2, A, B. C ENDFIN(*) = logical 2-vector, same meaning as in SLEDGE. C STORE(*) = real vector holding initial mesh. C C Output parameters: C NFIRST = index of first eigenvalue > ALPHA. C NTOTAL = total number of eigenvalues in the interval. C IFLAG = integer status indicator. C IFLAG = 0 , normal return, output should be reliable, C = 11 , there are no eigenvalues in [alpha, beta], C = 12 , low confidence in NFIRST or NTOTAL or both, C = 13 , BETA and/or ALPHA exceed the cutoff for C the continuous spectrum. If only BETA C is too big then NFIRST may be OK, but C NTOTAL is meaningless. C = -11 , ALPHA .ge. BETA, C = -25 , oscillatory endpoint, output meaningless, C = -3? , illegal CONS(*) values (see above comments C on SLEDGE for an explanation). C-------------------------------------------------------------------------- C In addition, a subroutine subprogram must be provided for the C coefficient functions p(x), q(x), and r(x); the form of this C routine is C C SUBROUTINE COEFF(X,PX,QX,RX) C DOUBLE PRECISION X,PX,QX,RX C ... C PX = ... C QX = ... C RX = ... C RETURN C END C C The subroutine name MUST be COEFF, though of course the names of C arguments only need follow the usual FORTRAN77 rules. X is the C independent variable; PX, QX, and RX are the output values of the C respective coefficient functions p(x), q(x), and r(x) at X. C----------------------------------------------------------------------- C This is a simple sample driver for SLEDGE. CC CC Declare all variables: CC C INTEGER IFLAG(1),INVEC(4),NUMX, I,J,K C LOGICAL JOB(5),TYPE(4,2),ENDFIN(2) C DOUBLE PRECISION CONS(8),TOL(6),EV(1),T(3),RHO(3),STORE(2450), C & XEF(5),EF(5),PDEF(5) CC CC Load the boundary condition information into CONS(*). CC This example has a Neumann condition at A = 1, and a CC singular point at B = +infinity. CC C DATA CONS/0.0, 0.0, 1.0, 0.0, 0.0, 0.0, 1.0, 0.0/ C DATA ENDFIN/.TRUE., .FALSE./ CC CC The eigenfunctions will be estimated at 5 points. CC C DATA NUMX,XEF/5, 1.0, 1.5D0, 2.0, 4.0, 100.0/ CC CC Initialize the vector INVEC(*): CC little printing, CC 3 output points for the density function Rho(t), CC estimates for the first (index 0) eigenvalue/function. CC C DATA INVEC/1, 3, 1, 0/ CC CC Set the JOB(*) vector: CC estimate both eigenvalues and eigenvectors, CC estimate the spectral density function, CC classify, CC force the initial mesh to be the output points. CC C DATA JOB/.FALSE.,.TRUE.,.TRUE.,.FALSE.,.FALSE./ CC CC Set the tolerances: CC C DATA TOL/1.D-5,1.D-4, 1.D-5,1.D-4, 1.D-5,1.D-4/ CC CC Initialize the 3 output points for the density function. CC C DATA T/0.0, 0.5, 2.0/ CC CC Open file for output. CC C OPEN(21,FILE = 'sample.out') C CALL SLEDGE(JOB,CONS,ENDFIN,INVEC,TOL,TYPE,EV,NUMX,XEF,EF,PDEF, C & T,RHO,IFLAG,STORE) CC CC Print results: CC C DO 30 I = 1,INVEC(3) C WRITE (*,10) INVEC(3+I),EV(I),IFLAG(I) C WRITE (21,10) INVEC(3+I),EV(I),IFLAG(I) C 10 FORMAT(' Nev =',I6,'; Ev =',D25.15,'; Flag = ',I3) C IF (IFLAG(I) .GT. -10) THEN C WRITE (*,15) C WRITE (21,15) C 15 FORMAT(13X,'x',23X,'u(x)',18X,'(pu`)(x)') C K = NUMX*(I-1) C DO 25 J = 1,NUMX C WRITE (21,20) XEF(J),EF(J+K),PDEF(J+K) C 20 FORMAT(3D25.15) C 25 CONTINUE C ENDIF C 30 CONTINUE C WRITE (*,35) C WRITE (21,35) C 35 FORMAT(/,8X,'t',21X,'Rho(t)') C DO 45 I = 1,INVEC(2) C WRITE (*,40) T(I),RHO(I) C WRITE (21,40) T(I),RHO(I) C 40 FORMAT(F11.3,D32.15) C 45 CONTINUE C CLOSE(21) C STOP C END CC C SUBROUTINE COEFF(X,PX,QX,RX) CC CC Define the coefficient functions; here a Yukawa potential. CC C DOUBLE PRECISION X,PX,QX,RX, T CC CC Be careful with potential over/underflows; here we assume the CC IEEE double precision exponent range. CC C IF (X .LT. 650.0) THEN C T = EXP(-X) C ELSE C T = 0.0 C ENDIF C PX = 1.0 C QX = -T/X C RX = PX C RETURN C END CC CC End of sample driver for SLEDGE. C----------------------------------------------------------------------- C General remarks: C (1) Two machine dependent constants must be set in a DATA C statement in routine START (in part 4 of the package): C URN - an estimate of the unit roundoff; infinite output C values are assigned the value 1/URN. C UFLOW - a number somewhat smaller than -ln(underflow level). C Values of certain variables z for which C ln(abs(z)) < -under C will be set to zero. C (2) A value of IFLAG = -1, -2, or -3 may be the result of a C lack of smoothness in the coefficient functions. In such C cases a user input mesh may perform better (see (4) below). C (3) The heuristics for generating the initial mesh distribution C work reasonably well over a wide range of examples, but C occasionally they are far from optimal. The code's choice C can be over-ridden by setting JOB(5) False, setting NUMX C appropriately and supplying a mesh in XEF(*). C (4) If any of the coefficient functions p,q, or r (or their first C few derivatives) have finite jump discontinuities at points C in the interior of (A,B), then it is advantageous to have C these points in SLEDGE's mesh. Currently, this can only be C accomplished by setting JOB(5) False and supplying an C appropriate mesh using NUMX and XEF(*). C (5) In general, eigenvalue convergence is observed to be more C rapid than eigenfunction convergence; hence, it is C recommended that JOB(2) be False unless eigenfunction C information really is necessary. C (6) When eigenfunction output is sought, unless some knowledge C of the eigenfunction is known in advance, it is recommended C that JOB(5) be True so that the code will attempt to choose C a reasonable distribution for the initial mesh points. C (7) Computing the spectral density function for problems having C continuous spectrum can be very expensive; it is recommended C that initially, relatively crude tolerances (0.001 or so) be C used to get some idea of the effort required. C (8) It is recommended that every problem be classified (JOB(4) C False) by the code before any calculation of spectral C quantities occurs. Only if the user is certain as to what C the classification is (and describes it correctly through C INVEC and TYPE) should the classification option be bypassed. C (9) If the code does the classification of singular problems, it C will automatically choose the Friedrichs' boundary condition C at NONOSC endpoints. If another boundary condition is C desired, the user must use interval truncation in the C calling program (see remark (12)). C (10) While all parts of the code should function on machines C with a fairly narrow exponent range (such as IEEE single C precision), it is better to have a relatively wide exponent C range (IEEE double precision). The classification algorithm, C in particular, is far more reliable if done on a machine with C a fairly wide exponent range. C (11) Care must be taken in writing the subroutine COEFF for the C evaluation of p(x), q(x), and r(x) to avoid arithmetic C exceptions such as overflow and underflow (or trig function C arguments too large). This can be especially delicate on C machines with a small exponent range. C (12) In some cases `interval truncation' is recommended. By this C is meant the user should call SLEDGE several times using a C sequence of regular endpoints (with appropriate boundary C conditions) converging to the singular endpoint. The eigen- C values of the regular problems selected by the user should be C arranged so as to converge to those of the desired singular C problem. For example, if the user wishes to compute eigen- C values associated with a non-Friedrichs' boundary condition C for problems in spectral category 1, the user can experiment C with choosing a sequence of regular approximating intervals, C and vary the boundary conditions appropriately by means of a C `boundary condition function' or known solution of the C equation for a real value of EV on the sequence of regular C intervals until convergence of the regular eigenvalues to C the desired singular one is observed. Similarly, for C problems in spectral category 3 or 5 which involve one or two C endpoints which are LC and OSC, the (necessarily discrete) C spectrum is known to be unbounded below and above. To C implement a given LC boundary condition at a singular LC C endpoint one may choose a `boundary condition function' or C known solution of the equation for a real value of EV and C make use of it on a sequence of regular approximating C intervals to vary the boundary condition on successive calls C to SLEDGE for the sequence of regular intervals until C convergence to the desired singular eigenvalue is observed. C At present these methods are highly experimental and problem- C dependent as good heuristics for the choice of the rate of C convergence of the regular intervals to the singular one C which work well over a wide class of problems are not known. C (The only case in which SLEDGE automatically selects regular C approximating subintervals is for spectral density function C calculations for problems in spectral category 2; but C here the singular endpoint is of LP type, so no singular C boundary condition is required to be implemented.) C (13) Problems of slow convergence can sometimes be avoided by a C judicious change of either dependent or independent variable C (or both). C (14) If the Liouville normal form potential Q(t) has a minimum C far from zero, then the heuristics for generating the initial C mesh may well miss it. In this case, it is advisable to C shift the independent variable. C (15) The determination of the total number of eigenvalues is the C most difficult part of the classification process. When the C theory provides this number, of course, there is no problem; C otherwise, it should be viewed with some skepticism. A more C reliable count of the eigenvalues below the cutoff point of C the essential spectrum can be gained (at some expense) by C trying to compute many eigenvalues near that point. C----------------------------------------------------------------------- C Changes since version 2.1: C (1) bug fix in MESH when a or b infinite 09/12/91 C (2) new mesh heuristics for infinite intervals 09/13/91 C (3) bug fix in CLSEND: undefined CP(*) 09/15/91 C (4) bug fix in AA, BB definition of SLEDGE 09/19/91 C (5) added NUMEV to DENSEF 09/22/91 C (6) fixed NADD initialization in MESH 09/24/91 C (7) fixed uninitialized ASYMEV value 09/27/91 C (8) change eigenvalue count in CLASS 10/01/91 C (9) improved NZERO calculation in STEP 10/07/91 C (10) bug fix on testing input bc 10/10/91 C (11) relaxed error tests on Rho(t) in EXTRAP 10/13/91 C (12) altered printing options in DENSEF,MESH,SLEDGE 10/16/91 C (13) altered KCLASS values 10/16/91 C (14) fixed RLOW, RHIGH bugs in EXTRAP 10/17/91 C (15) add KCLASS print to CLSEND 10/19/91 C (16) finished heuristics for density calculation 10/21/91 C (17) minor change to SYMM part of GETEF 11/06/91 C (18) changed printing format in GETEF 11/06/91 C (19) updated INTERV to conform to earlier changes 11/06/91 C (20) moved initialization of U, UNDER back to START 11/15/91 C (21) wholesale bug fixes in INTERV 11/15/91 C (22) added print of spectral category to DSCRIP 11/21/91 C (23) delete FLAG = 0 in DENSEF 12/02/91 C (24) tightened up oscillatory test in POWER 04/19/92 C (25) altered printouts for oscillatory coeff. case 04/19/92 C (26) increased max NxInit for DENSEF 04/25/92 C (27) pass iteration index to DENSEF 04/25/92 C (28) minor change to POWER 04/30/92 C (29) allow user to input mesh to DENSEF 05/09/92 C (30) renumbered labels in SLEDGE 05/09/92 C (31) minor changes to CLASS, DSCRIP 05/10/92 C (32) tightened switchover test in DENSEF 05/17/92 C (33) altered tests for IRREG in CLSEND 06/24/92 C (34) avoid integer overflow in POWER 06/24/92 C (35) added print option to EXTRAP 06/25/92 C (36) NUMX reset by SLEDGE; change comments 07/21/92 C (37) further tinkering with OSC in POWER, CLSEND 07/22/92 C (38) bug fix in KCLASS = 10 case in CLSEND 08/27/92 C (39) added print options to POWER 11/03/92 C (40) Aitken used instead of Wynn in POWER 11/11/92 C (41) redo eigenfunction pointers in REGULR 12/23/92 C (42) new mesh heuristics for KCLASS = 3 12/31/92 C (43) redo user interface 01/28/93 C (44) don't extrapolate infinity from GETEF 02/13/93 C (45) more changes to user interface 03/14/93 C (46) update format 65 in SLEDGE 04/12/93 C (47) bug fix in END calculation in CLASS 01/24/94 C (48) eliminate undefined FLAG test in DENSEF 12/02/94 C/////////////////////////////////////////////////////////////////////// module SLEDGEMD private public:: SLEDGE,INTERV contains subroutine SLEDGE(JOB,CONS,ENDFIN,INVEC,TOL,TYPE,EV,NUMX,XEF,EF, + PDEF,T,RHO,IFLAG,STORE) C C This is the interface routine between the user and other routines C which carry out most of the actual calculations. C C .. Parameters .. double precision ZERO,HALF,ONE,TWO,TOLMAX parameter (ZERO=0.0,HALF=0.5D0,ONE=1.0,TWO=2.0,TOLMAX=1.D-4) C .. C .. Scalar Arguments .. integer NUMX C .. C .. Array Arguments .. double precision CONS(*),EF(*),EV(*),PDEF(*),RHO(*),STORE(*),T(*), + TOL(*),XEF(*) integer IFLAG(*),INVEC(*) logical ENDFIN(*),JOB(*),TYPE(4,*) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,CUTOFF,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. double precision CP(2),CR(2),D(4,2),EMU(2),EP(2),EQLNF(2),ER(2), + ETA(2,2),PNU(2) integer KCLASS(2) logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision AA,ALPHA,BB,DENS,DENSHI,DENSLO,DENSOP,ENDFAC, + ERROR,FZ,HMIN,RHOTOL,SGN,TOL1,XTOL,ZETA integer I,IBASE,IEV,IPRINT,J,JTOL,K,KCL1,KCL2,LASTEV,MAXITS,MAXT, + MU1,MU2,NEV,NEXTRP,NUMEV,NUMT logical AAFIN,BBFIN,DOMESH,DONE,EDONE,LBASE,LMESH,OSCILL C .. C .. Local Arrays .. double precision CEV(2),ENDI(5),ZETAI(5) logical CSPEC(2),JOBST(3),LPLC(2) C .. C .. External Subroutines .. cc external CLASS,DENSEF,DSCRIP,MESH,REGULR,SHOOT,START C .. C .. Intrinsic Functions .. intrinsic ABS,LOG10,MAX,MIN,MOD,SIGN C .. C .. Common blocks .. common /SLCLSS/CP,CR,CUTOFF,D,EMU,EP,EQLNF,ER,ETA,PNU,KCLASS common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. C .. Data statements .. data DENSLO,DENSOP,DENSHI/4.0,6.0,12.0/ data ENDI/12.0,20.0,85.0,240.0,500.0/ data ZETAI/2.2,2.0,1.5,1.4,1.3/ C .. C C Initialize. C AFIN = ENDFIN(1) BFIN = ENDFIN(2) IPRINT = INVEC(1) NUMT = INVEC(2) NEV = INVEC(3) LNF = .FALSE. DOMESH = .TRUE. LMESH = .FALSE. FLAG = 0 IFLAG(1) = 0 IBASE = 1 LBASE = .FALSE. do 5 I = 1,6 LFLAG(I) = .FALSE. 5 continue TOL1 = MIN(TOL(1)+TOL(2),TOLMAX) JOBST(1) = JOB(2) if ((NUMX.gt.0) .and. (.not.JOB(5))) then JOBST(2) = .TRUE. else JOBST(2) = .FALSE. end if JOBST(3) = JOB(3) if ((.not.JOB(1)) .and. (.not.JOB(2))) NEV = 0 call START(JOBST,CONS,TOL,NEV,INVEC(4),NUMX,XEF,NUMT,T,NEXTRP, + STORE) if (JOB(4)) then ALPHA = A2*A1P - A1*A2P if ((A1P.ne.ZERO) .or. (A2P.ne.ZERO)) then if (ALPHA.le.ZERO) FLAG = -32 else if ((A1.eq.ZERO) .and. (A2.eq.ZERO)) FLAG = -33 end if if ((B1.eq.ZERO) .and. (B2.eq.ZERO)) FLAG = -31 end if if (FLAG.lt.0) go to 120 if (JOB(1) .or. JOB(2)) then do 10 K = 1,NEV EV(K) = ZERO 10 continue end if if (JOB(3)) then do 15 K = 1,NUMT RHO(K) = ZERO 15 continue end if if ((.not.JOB(4)) .or. JOB(3)) then call CLASS(IPRINT,TOL1,JOBST(2),CSPEC,CEV,LASTEV,LPLC,STORE, + JOB(5),HMIN,DOMESH) ALPHA = A2*A1P - A1*A2P if ((A1P.ne.ZERO) .or. (A2P.ne.ZERO)) then if (ALPHA.le.ZERO) FLAG = -32 else if ((A1.eq.ZERO) .and. (A2.eq.ZERO)) FLAG = -33 end if if ((B1.eq.ZERO) .and. (B2.eq.ZERO)) FLAG = -31 if (FLAG.lt.0) go to 120 do 20 K = 1,2 TYPE(1,K) = REG(K) TYPE(2,K) = LC(K) TYPE(3,K) = .not. OSC(K) TYPE(4,K) = OSC(K) if (CSPEC(K)) then TYPE(3,K) = .FALSE. TYPE(4,K) = .FALSE. end if 20 continue if (IPRINT.gt.2) call DSCRIP(LC,LPLC,TYPE,REG,CSPEC,CEV,CUTOFF, + LASTEV,A1,A1P,A2,A2P,B1,B2) else LNF = .FALSE. KCLASS(1) = 0 KCLASS(2) = 0 do 25 K = 1,2 REG(K) = TYPE(1,K) LC(K) = TYPE(2,K) OSC(K) = TYPE(4,K) CSPEC(K) = .not. (TYPE(3,K) .or. TYPE(4,K)) 25 continue if (.not.AFIN) STORE(1) = -99999.0 if (.not.BFIN) STORE(NXINIT) = 99999.0 end if C C Use NSGNF to hold the sign of F when EV is large negative. C SGN = A2P*B2 if (SGN.ne.ZERO) then NSGNF = SIGN(ONE,SGN) else SGN = A1P*B2 + A2P*B1 if (SGN.ne.ZERO) then NSGNF = SIGN(ONE,SGN) else SGN = A1P*B1 + A2*B2 if (SGN.ne.ZERO) then NSGNF = SIGN(ONE,SGN) else SGN = A1*B2 + A2*B1 if (SGN.ne.ZERO) then NSGNF = SIGN(ONE,SGN) else NSGNF = SIGN(ONE,A1*B1) end if end if end if end if OSCILL = ((.not.TYPE(1,1)) .and. TYPE(4,1)) .or. + ((.not.TYPE(1,2)) .and. TYPE(4,2)) TOL1 = TOL(1) + TOL(2) if (JOB(1) .or. JOB(2)) then C C Set up approximating regular problems for eigenvalues. C if (OSCILL) then if (IPRINT.ge.1) then write (*,FMT=30) write (21,FMT=30) 30 format (' This problem is oscillatory, you must use ', + 'interval truncation.') end if FLAG = -20 go to 120 end if if (DOMESH) then C C Calculate the initial mesh. C K = NXINIT + 16 call MESH(JOB(5),-1,STORE,STORE(K),STORE(2*K+1), + STORE(3*K+1),STORE(4*K+1),TOL1,HMIN) if (FLAG.lt.0) go to 120 end if if (((KCLASS(1).eq.3).or. (KCLASS(2).eq.3)) .and. + JOB(5)) LMESH = .TRUE. if ((.not.LMESH) .and. (IPRINT.ge.1)) then write (*,FMT=35) (STORE(I),I=1,NXINIT) write (21,FMT=35) (STORE(I),I=1,NXINIT) 35 format (' Level 0 mesh:',/ (5g15.6)) end if if (JOB(5)) NUMX = NXINIT C C Set MAXLVL, the maximum number of levels (mesh bisections). C C IMPORTANT NOTE: the size of various fixed arrays in this C package depends on the value of MAXLVL in this FORTRAN77 C implementation. If MAXLVL is increased, then more storage C may have to be allocated to these arrays. In particular, C check RATIO(*), R(*,*), and W(*,*) in EXTRAP; EVEXT(*) C in REGULR. C MAXLVL = 10 C do 45 K = 1,NEV EV(K) = ZERO IFLAG(K) = 0 FLAG = 0 call REGULR(JOB(2),LMESH,TOL,INVEC(3+K),EV(K),IPRINT,NEXTRP, + XEF,EF(1+NUMX* (K-1)),PDEF(1+NUMX* (K-1)),HMIN, + STORE) if ((CSPEC(1).or.CSPEC(2)) .and. (IPRINT.ge.1) .and. + (.not.JOB(4)) .and. (FLAG.gt.-5)) then if ((EV(K).ge.CUTOFF) .or. ((LASTEV.ne.-5).and. + (INVEC(3+K).ge.LASTEV))) then write (*,FMT=40) INVEC(3+K) write (21,FMT=40) INVEC(3+K) 40 format (' WARNING: Requested eigenvalue ',i6, + ' may not be below the continuous spectrum.') end if end if if (LFLAG(1)) then IFLAG(K) = IFLAG(K) + IBASE LFLAG(1) = .FALSE. LBASE = .TRUE. end if if (FLAG.lt.0) IFLAG(K) = FLAG 45 continue if (LBASE) then IBASE = 10*IBASE LBASE = .FALSE. end if end if if (JOB(3)) then if (CSPEC(1) .and. CSPEC(2)) then IFLAG(1) = -5 if (IPRINT.gt.0) write (*,FMT=50) 50 format (' This problem has continuous spectrum generated by' + ,' both endpoints. The',/ + ' calculation of the spectral density', + ' function has not yet been implemented',/ + ' for such cases.',/) go to 120 end if if (.not. (CSPEC(1).or.CSPEC(2))) then IFLAG(1) = -4 if (IPRINT.gt.0) write (*,FMT=55) 55 format (' This problem has no continuous spectrum.') go to 120 end if if ((CSPEC(1).and. ((KCLASS(2).eq.5).or. + (KCLASS(2).eq.9))) .or. (CSPEC(2).and. + ((KCLASS(1).eq.5).or. (KCLASS(1).eq.9)))) then IFLAG(1) = -6 if (IPRINT.gt.0) write (*,FMT=60) 60 format ( + ' The normalization of the spectral density function' + ,' is unknown for this problem.') go to 120 end if if ((CSPEC(1).and. (.not.BFIN)) .or. + (CSPEC(2).and. (.not.AFIN))) then IFLAG(1) = -6 if (IPRINT.gt.0) write (*,FMT=60) go to 120 end if if (OSCILL) then FLAG = -25 if (IPRINT.gt.0) then write (*,FMT=30) write (21,FMT=30) end if go to 120 end if XTOL = -LOG10(MAX(TOL(1),TOL(2))) JTOL = XTOL - HALF JTOL = MIN(MAX(JTOL,1),5) DENSOP = 3*JTOL MAXITS = (15-JTOL)/3 C C Set Maxlvl for the density function calculation; see above C "IMPORTANT NOTE" if this is to be increased. C MAXLVL = (7+JTOL)/2 AAFIN = AFIN AA = A KCL1 = KCLASS(1) BBFIN = BFIN BB = B KCL2 = KCLASS(2) if (JOB(5)) then C C Use interval truncation in this oscillatory regime. C OSCILL = .FALSE. if ((.not.JOB(4)) .and. ((KCLASS(1).eq.1).or. + (KCLASS(2).eq.1))) OSCILL = .TRUE. if (.not.OSCILL) then NXINIT = 4*JTOL + 5 ENDFAC = ENDI(JTOL) else NXINIT = 24*JTOL + 36 ENDFAC = 48.0 end if if (CSPEC(1)) then if (AFIN) then KCLASS(1) = 7 ENDFAC = 4.0*ENDFAC if (BFIN) then A = AA + (BB-AA)/ENDFAC else A = AA + ABS(AA)/ENDFAC end if else AFIN = .TRUE. KCLASS(1) = 0 if (BFIN) then A = -ENDFAC - MIN(-B,ZERO) else A = -ENDFAC end if end if else if (BFIN) then KCLASS(2) = 7 ENDFAC = 4.0*ENDFAC if (AFIN) then B = BB - (BB-AA)/ENDFAC else B = BB - ABS(BB)/ENDFAC end if else BFIN = .TRUE. KCLASS(2) = 0 if (AFIN) then B = ENDFAC + MAX(A,ZERO) else B = ENDFAC end if end if end if else if (CSPEC(1)) AFIN = .TRUE. if (CSPEC(2)) BFIN = .TRUE. if (NUMX.eq.0) then IFLAG(1) = -30 return end if end if MAXT = NUMT C C Loop over the choices of intervals. C NUMEV = 0 do 105 K = 1,MAXITS STORE(1) = A STORE(NXINIT) = B LFLAG(3) = .FALSE. FLAG = 0 if (IPRINT.ge.1) then write (*,FMT=65) K write (21,FMT=65) K 65 format (60 ('-'),/' Iteration ',i2) write (21,FMT=70) A,B,NXINIT 70 format (/' For a, b =',2f15.8,/' Nxinit = ',i4,/) end if if (JOB(5)) then I = NXINIT + 16 call MESH(.TRUE.,-1,STORE,STORE(I+1),STORE(2*I+1), + STORE(3*I+1),STORE(4*I+1),TOL1,HMIN) end if if (IPRINT.ge.3) then write (*,FMT=75) (STORE(I),I=1,NXINIT) write (21,FMT=75) (STORE(I),I=1,NXINIT) 75 format (' Level 0 mesh:',/ (5g15.6)) end if call DENSEF(TOL,CSPEC,IPRINT,K,NEXTRP,MAXT,T,RHO,IEV,HMIN, + NUMEV,STORE) if (FLAG.eq.-3) then LFLAG(6) = .FALSE. FLAG = 0 end if if (FLAG.lt.0) go to 120 if (.not.JOB(5)) go to 110 if (K.gt.1) then DONE = .TRUE. J = MAXT do 80 I = 1,J RHOTOL = TWO*ZETA*MAX(TOL(1),TOL(2)*RHO(I)) ERROR = RHO(I) - STORE(2320+ (MAXLVL+2)*NUMT+I) if (ABS(ERROR).le.RHOTOL) then EDONE = .TRUE. else EDONE = .FALSE. MAXT = I end if DONE = DONE .and. EDONE 80 continue if (DONE) go to 110 end if if (IPRINT.ge.2) then write (*,FMT=85) write (21,FMT=85) 85 format (9x,'t',15x,'Truncated Rho(t)') do 95 I = 1,NUMT write (*,FMT=90) T(I),RHO(I) write (21,FMT=90) T(I),RHO(I) 90 format (f12.4,d31.15) 95 continue end if do 100 I = 1,MAXT STORE(2320+ (MAXLVL+2)*NUMT+I) = RHO(I) 100 continue COUNTZ = .TRUE. call SHOOT(CUTOFF,STORE,MU1,FZ) call SHOOT(T(NUMT),STORE,MU2,FZ) COUNTZ = .FALSE. if (T(NUMT).gt.CUTOFF) then DENS = (MU2-MU1)/ (K* (T(NUMT)-CUTOFF)) else DENS = DENSOP end if if (.not.OSCILL) then NXINIT = NXINIT + 10 ZETA = ZETAI(JTOL) else ZETA = 2.0 NXINIT = ZETA*NXINIT end if if (CSPEC(1)) then if (AAFIN) then ENDFAC = 5.0*ZETA if (DENS.lt.DENSLO) ENDFAC = 75.0 if ((DENS.gt.DENSHI) .and. (.not.OSCILL)) ENDFAC = 8.0 A = AA + (A-AA)/ENDFAC if ((AA-A)**2.lt.U) then FLAG = -9 go to 110 end if else if (DENS.lt.DENSLO) ZETA = 2.0 if ((DENS.gt.DENSHI) .and. (.not.OSCILL)) ZETA = 1.4 A = ZETA*A end if end if if (CSPEC(2)) then if (BBFIN) then ENDFAC = 5.0*ZETA if (DENS.lt.DENSLO) ENDFAC = 75.0 if ((DENS.gt.DENSHI) .and. (.not.OSCILL)) ENDFAC = 8.0 B = BB - (BB-B)/ENDFAC if ((B-BB)**2.lt.U) then FLAG = -9 go to 110 end if else if (DENS.lt.DENSLO) ZETA = 2.0 if ((DENS.gt.DENSHI) .and. (.not.OSCILL)) ZETA = 1.4 B = ZETA*B end if end if if (MOD(NXINIT,2).eq.0) NXINIT = NXINIT + 1 NXINIT = MIN(464,NXINIT) 105 continue FLAG = -3 110 if (IPRINT.ge.1) write (21,FMT=115) NUMEV 115 format (' The total number of eigenvalues computed was ',i10) if (CSPEC(1)) then if (AAFIN) then A = AA KCLASS(1) = KCL1 else AFIN = .FALSE. end if end if if (CSPEC(2)) then if (BBFIN) then B = BB KCLASS(2) = KCL2 else BFIN = .FALSE. end if end if end if C C Set fatal output flags. C 120 if (FLAG.lt.-9) then do 125 K = 1,MAX(NEV,1) IFLAG(K) = FLAG 125 continue return else if ((FLAG.lt.0) .and. (.not. (JOB(1).or. + JOB(2)))) IFLAG(1) = FLAG end if C C Set warning flags. C do 135 I = 2,5 do 130 K = 1,MAX(NEV,1) if (LFLAG(I) .and. (IFLAG(K).ge.0)) IFLAG(K) = IFLAG(K) + + I*IBASE 130 continue if (LFLAG(I)) IBASE = 10*IBASE 135 continue return end subroutine SLEDGE C======================================================================= subroutine INTERV(FIRST,ALPHA,BETA,CONS,ENDFIN,NFIRST,NTOTAL, + IFLAG,X) *********************************************************************** * * * INTERV calculates the indices of eigenvalues found in a * * specified interval. * * * *********************************************************************** C Local variables: C C C .. Scalar Arguments .. double precision ALPHA,BETA integer IFLAG,NFIRST,NTOTAL logical FIRST C .. C .. Array Arguments .. double precision CONS(*),X(*) logical ENDFIN(*) C .. C .. Scalars in Common .. integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision CUTOFF,HMIN,V integer I1,I2,I3,J1,J2,J3,K,LASTEV,LEVEL0,MU,NEXTRP,NLAST,NUMX logical DOMESH C .. C .. Local Arrays .. double precision CEV(2),TOL(6) integer IDUMMY(1) logical CSPEC(2),JOBST(3),LPLC(2) C .. C .. External Subroutines .. cc external CLASS,MESH,SHOOT,START C .. C .. Intrinsic Functions .. intrinsic MIN C .. C .. Common blocks .. common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG C common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. C .. Save statement .. save CUTOFF C .. NFIRST = -5 NLAST = -5 IFLAG = 0 if (ALPHA.ge.BETA) then IFLAG = -11 return end if TOL(1) = 0.000001 TOL(2) = 0.000001 if (FIRST) then JOBST(1) = .FALSE. JOBST(2) = .FALSE. JOBST(3) = .FALSE. AFIN = ENDFIN(1) BFIN = ENDFIN(2) MAXLVL = 10 NUMX = 0 call START(JOBST,CONS,TOL,0,IDUMMY,NUMX,X,0,X,NEXTRP,X) call CLASS(0,TOL(1),JOBST(2),CSPEC,CEV,LASTEV,LPLC,X,.TRUE., + HMIN,DOMESH) CUTOFF = MIN(CEV(1),CEV(2)) if (FLAG.lt.0) then IFLAG = FLAG return end if if (OSC(1) .or. OSC(2)) then IFLAG = -25 return end if if (DOMESH) then K = NUMX + 16 call MESH(.TRUE.,-1,X,X(K),X(2*K+1),X(3*K+1),X(4*K+1), + TOL(1),HMIN) end if end if if (FLAG.lt.0) then IFLAG = FLAG return end if LEVEL0 = LEVEL COUNTZ = .TRUE. LEVEL = 3 call SHOOT(ALPHA,X,MU,V) I1 = MU call SHOOT(BETA,X,MU,V) J1 = MU LEVEL = LEVEL + 1 call SHOOT(ALPHA,X,MU,V) I2 = MU call SHOOT(BETA,X,MU,V) J2 = MU 10 LEVEL = LEVEL + 1 if (NFIRST.eq.-5) then call SHOOT(ALPHA,X,MU,V) I3 = MU if ((I1.eq.I2) .and. (I2.eq.I3)) then NFIRST = I1 go to 15 end if I1 = I2 I2 = I3 end if 15 if (NLAST.eq.-5) then call SHOOT(BETA,X,MU,V) J3 = MU if ((J1.eq.J2) .and. (J2.eq.J3)) then NLAST = J1 - 1 if (NFIRST.ne.-5) go to 20 end if J1 = J2 J2 = J3 end if if (LEVEL.lt.MAXLVL) go to 10 20 if (NFIRST.eq.-5) then NFIRST = I3 IFLAG = 12 end if if (NLAST.eq.-5) then NLAST = J3 IFLAG = 12 end if NTOTAL = NLAST + 1 - NFIRST if (NTOTAL.eq.0) IFLAG = 11 if (BETA.gt.CUTOFF) IFLAG = 13 COUNTZ = .FALSE. LEVEL = LEVEL0 return end subroutine INTERV C========================= End of Part 1 =============================== ************************* Start of Part 2 **************************** C/////////////////////////////////////////////////////////////////////// subroutine AITKEN(XLIM,TOL,N,X,ERROR) C C Use Aitken's algorithm to accelerate convergence of the sequence C in X(*). C C C .. Parameters .. double precision ZERO,ONE,TWO parameter (ZERO=0.0,ONE=1.0,TWO=2.0) C .. C .. Scalar Arguments .. double precision ERROR,TOL,XLIM integer N C .. C .. Array Arguments .. double precision X(*) C .. C .. Local Scalars .. double precision DENOM,XOLD integer I C .. C .. Intrinsic Functions .. intrinsic ABS,MAX C .. if (N.le.2) then XLIM = X(N) ERROR = ZERO return end if XOLD = 1.D30 do 10 I = 1,N - 2 DENOM = X(I+2) - TWO*X(I+1) + X(I) if (DENOM.ne.ZERO) then XLIM = X(I) - (X(I+1)-X(I))**2/DENOM ERROR = XLIM - XOLD else ERROR = X(I+2) - X(I+1) XLIM = X(I+2) end if if (ABS(ERROR).lt.MAX(ONE,ABS(XLIM))*TOL) return XOLD = XLIM 10 continue return end subroutine AITKEN C---------------------------------------------------------------------- double precision function ASYMEV(NEV,QINT,RPINT,ALPHA1,ALPHA2, + BETA1,BETA2) C C C Evaluate the asymptotic formula for eigenvalue NEV. C Note: not all cases have been implemented yet. C C .. Parameters .. double precision ZERO,HALF,ONE,TWO,PI parameter (ZERO=0.0,HALF=0.5D0,ONE=1.0,TWO=2.0, + PI=3.14159265358979324D0) C .. C .. Scalar Arguments .. double precision ALPHA1,ALPHA2,BETA1,BETA2,QINT,RPINT integer NEV C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,U,UNDER logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision FNEV C .. C .. Common blocks .. common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. ASYMEV = -999999.0 FNEV = NEV if (REG(1)) then if ((A1P.ne.ZERO) .or. (A2P.ne.ZERO)) then if (A2P.ne.ZERO) then ASYMEV = (TWO*A1P/A2P+QINT)/RPINT if (B2.ne.ZERO) then C Case 1 ASYMEV = ASYMEV + TWO*B1/ (B2*RPINT) + ((FNEV-ONE)*PI/ + RPINT)**2 else C Case 2 ASYMEV = ASYMEV + ((FNEV-HALF)*PI/RPINT)**2 end if else ASYMEV = (TWO*A2/A1P+QINT)/RPINT if (B2.ne.ZERO) then C Case 3 ASYMEV = ASYMEV + TWO*B1/ (B2*RPINT) + + ((FNEV-HALF)*PI/RPINT)**2 else C Case 4 ASYMEV = ASYMEV + (FNEV*PI/RPINT)**2 end if end if else if (A2.ne.ZERO) then if (B2.ne.ZERO) then C Case 1 ASYMEV = (FNEV*PI/RPINT)**2 + + (TWO* (BETA1/BETA2+ALPHA1/ALPHA2)+QINT)/RPINT else C Case 2 (Dirichlet at B) ASYMEV = ((FNEV+HALF)*PI/RPINT)**2 + (TWO*ALPHA1/ + ALPHA2+QINT)/RPINT end if else if (B2.ne.ZERO) then C Case 3 (Dirichlet at A) ASYMEV = ((FNEV+HALF)*PI/RPINT)**2 + (TWO*BETA1/ + BETA2+QINT)/RPINT else C Case 4 (Dirichlet at A and at B) ASYMEV = ((FNEV+ONE)*PI/RPINT)**2 + QINT/RPINT end if end if end if return end if if (REG(2)) then if (B2.ne.ZERO) then if (A2.ne.ZERO) then C Case 1 ASYMEV = (FNEV*PI/RPINT)**2 + + (TWO* (ALPHA1/ALPHA2+BETA1/BETA2)+QINT)/RPINT else C Case 2 (Dirichlet at A) ASYMEV = ((FNEV+HALF)*PI/RPINT)**2 + (TWO*BETA1/ + BETA2+QINT)/RPINT end if else if (B2.ne.ZERO) then C Case 3 (Dirichlet at B) ASYMEV = ((FNEV+HALF)*PI/RPINT)**2 + (TWO*ALPHA1/ + ALPHA2+QINT)/RPINT else C Case 4 (Dirichlet at A and at B) ASYMEV = ((FNEV+ONE)*PI/RPINT)**2 + QINT/RPINT end if end if end if return end function ASYMEV C---------------------------------------------------------------------- double precision function ASYMR(NEV,RPINT,RPATA,RPATB,SCALE) C C C Evaluate the asymptotic formula for RsubNEV. C Note: not all cases have been implemented yet. See the note C above in ASYMEV. C C .. Parameters .. double precision ZERO,HALF,ONE,TWO,PI parameter (ZERO=0.0,HALF=0.5D0,ONE=1.0,TWO=2.0, + PI=3.14159265358979324D0) C .. C .. Scalar Arguments .. double precision RPATA,RPATB,RPINT,SCALE integer NEV C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,U,UNDER logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision FNEV C .. C .. Intrinsic Functions .. intrinsic MAX C .. C .. Common blocks .. common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. ASYMR = ZERO FNEV = MAX(NEV,2) if (REG(1)) then if ((A1P.ne.ZERO) .or. (A2P.ne.ZERO)) then if (A2P.ne.ZERO) then if (B2.ne.ZERO) then ASYMR = TWO*RPINT**3/ (RPATA*A2P**2* + ((FNEV-ONE)*PI)**4) else ASYMR = TWO*RPINT**3/ (RPATA*A2P**2* + ((FNEV-HALF)*PI)**4) end if else if (B2.ne.ZERO) then ASYMR = RPATA*TWO*RPINT/ (A1P* (FNEV-HALF)*PI)**2 else ASYMR = RPATA*TWO*RPINT/ (A1P*FNEV*PI)**2 end if end if else if (A2.ne.ZERO) then ASYMR = TWO/ (RPATA*A2*A2*RPINT) else if (B2.ne.ZERO) then ASYMR = TWO*RPATA* ((FNEV+HALF)*PI/A1)**2/RPINT**3 else ASYMR = TWO*RPATA* ((FNEV+ONE)*PI/A1)**2/RPINT**3 end if end if end if return end if if (REG(2)) then if (A2.ne.ZERO) then ASYMR = TWO/ (RPATB*B2*B2*RPINT) else if (B2.ne.ZERO) then ASYMR = TWO*RPATB* ((FNEV+HALF)*PI/B1)**2/RPINT**3 else ASYMR = TWO*RPATB* ((FNEV+ONE)*PI/B1)**2/RPINT**3 end if end if end if ASYMR = ASYMR*SCALE**2 return end function ASYMR C----------------------------------------------------------------------- subroutine BRCKET(N,EVLOW,EVHIGH,FLOW,FHIGH,ABSERR,RELERR,X) C C Find values for EVLOW and EVHIGH which bracket the Nth eigenvalue; C in particular, C EV(N-1) < EVLOW < EV(N) < EVHIGH < EV(N+1) . C It is assumed that if U(X,LAMBDA) has NZ zeros in (A,B) then C EV(MU-1) < LAMBDA < EV(MU) C where MU is a function of NZ, LAMBDA, and the constants in the C boundary conditions. The value of MU for a given LAMBDA is C returned by a call to subprogram SHOOT. C C C Set COUNTZ so that zeros are counted in SHOOT. C C .. Parameters .. double precision ZERO,TWO parameter (ZERO=0.0,TWO=2.0) C .. C .. Scalar Arguments .. double precision ABSERR,EVHIGH,EVLOW,FHIGH,FLOW,RELERR integer N C .. C .. Array Arguments .. double precision X(*) C .. C .. Scalars in Common .. integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision DIFF,EV,EVSIGN,FEV integer K,MU logical HIGH,LOW C .. C .. External Subroutines .. cc external SHOOT C .. C .. Intrinsic Functions .. intrinsic ABS,MAX,MOD C .. C .. Common blocks .. common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG C common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. COUNTZ = .TRUE. EVSIGN = NSGNF C C SHOOT with Ev = Evlow should return FEV having sign EVSIGN. C if (N.ne.2* (N/2)) EVSIGN = -EVSIGN LOW = .FALSE. HIGH = .FALSE. C C Make EVLOW a lower bound for EV(N). C EV = EVLOW DIFF = ABS(EVHIGH-EVLOW) if (DIFF.eq.ZERO) DIFF = ABSERR + RELERR 10 call SHOOT(EV,X,MU,FEV) if (FLAG.lt.0) then COUNTZ = .FALSE. return end if if (MU.gt.N) then EVHIGH = EV FHIGH = FEV EV = EV - DIFF DIFF = TWO*DIFF if ((MU.eq.N+1) .and. (EVSIGN*FEV.le.ZERO)) HIGH = .TRUE. go to 10 else EVLOW = EV FLOW = FEV if ((MU.eq.N) .and. (EVSIGN*FEV.ge.ZERO)) LOW = .TRUE. end if C C Make EVHIGH an upper bound for EV(N). C if (.not.HIGH) then EV = EVHIGH DIFF = ABS(EVHIGH-EVLOW) 20 call SHOOT(EV,X,MU,FEV) if (FLAG.lt.0) return K = NSGNF* (-1)**MOD(MU,2) if (K*FEV.lt.ZERO) then EV = EV + DIFF DIFF = TWO*DIFF go to 20 else if (MU.le.N) then EVLOW = EV FLOW = FEV EV = EV + DIFF DIFF = TWO*DIFF go to 20 else EVHIGH = EV FHIGH = FEV if (MU.eq.N+1) HIGH = .TRUE. end if end if end if C C Refine the interval [EVLOW,EVHIGH] to include only the Nth C eigenvalue. C 30 if ((.not.LOW) .or. (.not.HIGH)) then DIFF = EVHIGH - EVLOW EV = EVLOW + DIFF/TWO C C Check for a cluster of eigenvalues within user's tolerance. C if (TWO*DIFF.lt.MAX(ABSERR,RELERR* (MAX(ABS(EVLOW), + ABS(EVHIGH))))) then LFLAG(1) = .TRUE. COUNTZ = .FALSE. return end if call SHOOT(EV,X,MU,FEV) if (FLAG.lt.0) then COUNTZ = .FALSE. return end if C C Update EVLOW and EVHIGH. C if (MU.eq.N) then EVLOW = EV LOW = .TRUE. FLOW = FEV else if (MU.eq.N+1) then EVHIGH = EV HIGH = .TRUE. FHIGH = FEV else if (MU.lt.N) then EVLOW = EV FLOW = FEV else EVHIGH = EV FHIGH = FEV end if end if end if go to 30 end if COUNTZ = .FALSE. return end subroutine BRCKET C----------------------------------------------------------------------- subroutine CLASS(IPRINT,TOL,JOB,CSPEC,CEV,LASTEV,LPLC,X,JMESH, + HMIN,DOMESH) C C This routine classifies the Sturm-Liouville problem. Note: C (1) any computational algorithm must be based on a finite C amount of information; hence, there will always be cases that C any algorithm misclassifies. In addition, some problems are C inherently ill-conditioned, in that a small change in the C coefficients can produce a totally different classification. C (2) The maximum number of points sampled for singular problems C is given by the variable KMAX. By increasing this number, the C reliability of the classification may increase; however, the C computing time may also increase. The values we have chosen C seem to be a reasonable balance for most problems. C (3) The algorithms apply standard theorems involving limits of C the Liouville normal form potential. When this is not available, C each coefficient function is approximated by a power function C (c*x^r) and classified according to the properties of the C resulting Liouville approximation. C C C Sample the coefficient functions; determine if the problem as C given is in Liouville normal form. C C .. Parameters .. double precision ZERO,TENTH,ONE,TWO,EIGHT parameter (ZERO=0.0,TENTH=0.1D0,ONE=1.0,TWO=2.0,EIGHT=8.0) C .. C .. Scalar Arguments .. double precision HMIN,TOL integer IPRINT,LASTEV logical DOMESH,JMESH,JOB C .. C .. Array Arguments .. double precision CEV(*),X(*) logical CSPEC(*),LPLC(*) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,CUTOFF,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. double precision CP(2),CR(2),D(4,2),EMU(2),EP(2),EQLNF(2),ER(2), + ETA(2,2),PNU(2) integer KCLASS(2) logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision BASE,END,EV,FEV,OVER,S,SGN integer IFLAG,J,K,KMAX,M C .. C .. Local Arrays .. double precision BC(2),PZ(40,2),QZ(40,2),RZ(40,2),Y(40),Z(40,2) integer KUSED(2),LAST(3) logical ENDFIN(2) C .. C .. External Subroutines .. cc external CLSEND,COEFF,MESH,SHOOT C .. C .. Intrinsic Functions .. intrinsic ABS,INT,LOG,LOG10,MAX,MIN C .. C .. Common blocks .. common /SLCLSS/CP,CR,CUTOFF,D,EMU,EP,EQLNF,ER,ETA,PNU,KCLASS common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. LNF = .TRUE. DOMESH = .TRUE. do 40 J = 1,2 if (J.eq.1) then END = A ENDFIN(1) = AFIN SGN = ONE else END = B ENDFIN(2) = BFIN SGN = -ONE end if K = TENTH - LOG10(TOL) KMAX = MIN(MAX(4*K,10),40) M = 0 BASE = ONE/MIN(MAX(K,4),8) if (ENDFIN(J)) then if (END.ne.ZERO) KMAX = MIN(-INT(LOG10(U))-1,KMAX) else KMAX = MIN(KMAX,20) BASE = EIGHT end if do 10 K = 1,KMAX Z(K,J) = BASE**K 10 continue OVER = UNDER/TWO do 30 K = 1,KMAX if (ENDFIN(J)) then S = END + SGN*Z(K,J) else S = -SGN*Z(K,J) end if call COEFF(S,PZ(K,J),QZ(K,J),RZ(K,J)) NCOEFF = NCOEFF + 1 if ((PZ(K,J).le.ZERO) .or. (RZ(K,J).le.ZERO)) then FLAG = -15 return end if if (LNF .and. (K.gt.1)) then if (PZ(K,J).ne.PZ(K-1,J)) LNF = .FALSE. if (RZ(K,J).ne.RZ(K-1,J)) LNF = .FALSE. end if S = LOG(PZ(K,J)) if (ABS(S).gt.OVER) M = 1 S = LOG(ONE+ABS(QZ(K,J))) if (ABS(S).gt.OVER) M = 1 S = LOG(RZ(K,J)) if (ABS(S).gt.OVER) M = 1 if (M.ne.0) go to 35 30 continue K = KMAX 35 KUSED(J) = K - 1 40 continue do 50 J = 1,2 call CLSEND(Z(1,J),PZ(1,J),QZ(1,J),RZ(1,J),KUSED(J),IPRINT,END, + ENDFIN(J),J,TOL,CEV(J),CSPEC(J),BC,Y,LPLC,IFLAG) if (.not.JOB) then if ((.not.AFIN) .and. (J.eq.1)) X(1) = -END if ((.not.BFIN) .and. (J.eq.2)) X(NXINIT) = END end if if ((CSPEC(J).or. (.not.OSC(J))) .and. (.not.REG(J))) then if (J.eq.1) then A1 = BC(1) A1P = ZERO A2 = BC(2) A2P = ZERO else B1 = BC(1) B2 = BC(2) end if end if if (IFLAG.eq.1) LFLAG(2) = .TRUE. 50 continue CUTOFF = MIN(CEV(1),CEV(2)) C C Find the number of eigenvalues below the start of the C continuous spectrum. C LASTEV = -5 if ((.not.OSC(1)) .and. (.not.LC(2)) .and. OSC(2)) LASTEV = 0 if ((.not.OSC(2)) .and. (.not.LC(1)) .and. OSC(1)) LASTEV = 0 if (OSC(1) .and. (.not.LC(1)) .and. OSC(2) .and. LC(2)) LASTEV = 0 if (OSC(2) .and. (.not.LC(2)) .and. OSC(1) .and. LC(1)) LASTEV = 0 if ((CSPEC(1).and.OSC(2)) .or. (CSPEC(2).and.OSC(1))) LASTEV = 0 if ((CSPEC(1).and. (.not.OSC(2))) .or. + (CSPEC(2).and. (.not.OSC(1))) .or. + (CSPEC(1).and.CSPEC(2))) then K = NXINIT + 16 call MESH(JMESH,-1,X,X(K),X(2*K+1),X(3*K+1),X(4*K+1),TOL,HMIN) DOMESH = .FALSE. COUNTZ = .TRUE. do 75 J = 1,2 LEVEL = 3*J EV = CUTOFF call SHOOT(EV,X,LAST(J),FEV) if (FLAG.lt.0) return if (IPRINT.ge.5) write (21,FMT=70) LEVEL,LAST(J) 70 format (' When level = ',i2,', Ev index at cutoff is ',i12) 75 continue COUNTZ = .FALSE. if (LAST(1).ge.LAST(2)) then LASTEV = LAST(2) if (LAST(1).ne.LAST(2)) then LFLAG(2) = .TRUE. if (IPRINT.ge.3) write (21,FMT=80) 80 format (' The eigenvalue count is uncertain.') if (LAST(1).gt.2*LAST(2)) LASTEV = 0 end if else LASTEV = -5 end if end if return end subroutine CLASS C----------------------------------------------------------------------- subroutine CLSEND(Z,PZ,QZ,RZ,KMAX,IPRINT,END,ENDFIN,IEND,TOL,CEV, + CSPEC,BC,Y,LPLC,IFLAG) C C Iflag = 0 if reasonably certain of the classification; C = 1 if not sure. C C Information about the nature of the problem at singular point C IEND is passed through the variable KCLASS(IEND): C KCLASS(*) = 0 normal; C = 1 oscillatory coefficient function; C = 2 regular, but 1/p, q, or r unbounded; C = 3 infinite endpoint, Eqlnf = -1 ; C = 4 finite singular endpoint, Tau unbounded, C (not 8-10); C = 5 not "hard", irregular; C = 6 "hard" irregular with Eta(1) < 0; C = 7 finite end which generates Cspectrum; C = 8 Q is unbounded (< 1/t^2) near a nonoscill- C atory finite end; C = 9 Q is unbounded (like 1/t^2) near a nonosc- C illatory finite end; C = 10 "hard", irregular, Eta(1) > 0. C Note: "hard" means Tau goes to +infinity at a C finite nonoscillatory endpoint. C REG(*) = .True. iff endpoint is regular. C LC(*) = .True. iff endpoint is limit circle. C OSC(*) = .True. iff endpoint is oscillatory for all Ev. C CSPEC = .True. iff endpoint generates continuous spectrum. C LPLC(*)= .True. iff theory yields Lp/Lc classification. C C C .. Parameters .. double precision ZERO,QUART,HALF,QUART3,ONE,TWO,FOUR parameter (ZERO=0.0,QUART=0.25D0,HALF=0.5D0,QUART3=0.75D0,ONE=1.0, + TWO=2.0,FOUR=4.0) C .. C .. Scalar Arguments .. double precision CEV,END,TOL integer IEND,IFLAG,IPRINT,KMAX logical CSPEC,ENDFIN C .. C .. Array Arguments .. double precision BC(*),PZ(*),QZ(*),RZ(*),Y(*),Z(*) logical LPLC(*) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,CUTOFF,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. double precision CPT(2),CRT(2),D(4,2),EMU(2),EPT(2),EQLNF(2), + ERT(2),ETA(2,2),PNU(2) integer KCLASS(2) logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision C1,C2,C3,CP,CQ,CR,DELTA,EP,EQ,ER,GAMMA,SGN,TOL4, + ZZ integer I,IQLNF,K logical EX,EXACT,IRREG,POSC,QOSC,ROSC C .. C .. External Subroutines .. cc external COEFF,POWER C .. C .. Intrinsic Functions .. intrinsic ABS,MAX,MIN,SIGN,SQRT C .. C .. Common blocks .. common /SLCLSS/CPT,CRT,CUTOFF,D,EMU,EPT,EQLNF,ERT,ETA,PNU,KCLASS common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. IFLAG = 0 if (IPRINT.ge.3) then if (IEND.eq.1) write (21,FMT=5) 5 format (/' For endpoint A') if (IEND.eq.2) write (21,FMT=6) 6 format (/' For endpoint B:') write (21,FMT=7) KMAX 7 format (' Kmax = ',i3) end if CSPEC = .FALSE. IRREG = .FALSE. LPLC(IEND) = .TRUE. KCLASS(IEND) = 0 PNU(IEND) = ZERO CEV = ONE/U EX = .TRUE. C1 = ZERO C2 = ZERO TOL4 = FOUR*TOL C C Seek monomial approximations to each coefficient function. C call POWER(Z,QZ,KMAX,TOL,IPRINT,EQ,CQ,QOSC,EXACT,Y,IFLAG) if (ABS(CQ).le.TOL) CQ = ZERO if (CQ.eq.ZERO) EQ = ZERO if (LNF) then EP = ZERO CP = PZ(1) ER = ZERO CR = RZ(1) POSC = .FALSE. ROSC = .FALSE. else call POWER(Z,PZ,KMAX,TOL,IPRINT,EP,CP,POSC,EXACT,Y,IFLAG) if (ABS(CP).le.TOL) EP = ZERO EX = EX .and. EXACT call POWER(Z,RZ,KMAX,TOL,IPRINT,ER,CR,ROSC,EXACT,Y,IFLAG) if (ABS(CR).le.TOL) ER = ZERO end if if (POSC .or. ROSC) then if (ENDFIN) then REG(IEND) = .TRUE. else IFLAG = 1 if (IPRINT.ge.3) write (21,FMT=10) 10 format ( + ' WARNING: p(x) or r(x) is not well-approximated by' + ,' a power potential.',/ + ' Classification is uncertain.') REG(IEND) = .FALSE. KCLASS(IEND) = 1 end if LC(IEND) = .TRUE. OSC(IEND) = .FALSE. end if if (QOSC) then IFLAG = 1 if (IPRINT.ge.3) write (21,FMT=20) 20 format (' WARNING: q(x) is not well-approximated by a power ', + 'potential.',/' Classification is uncertain.') if (ENDFIN) then REG(IEND) = .TRUE. LC(IEND) = .TRUE. OSC(IEND) = .FALSE. else KCLASS(IEND) = 1 REG(IEND) = .FALSE. LC(IEND) = .FALSE. CSPEC = .TRUE. OSC(IEND) = .FALSE. BC(1) = ONE BC(2) = ZERO CEV = QZ(KMAX-1) K = 40 DELTA = (Z(KMAX)-Z(KMAX-1))/ (K+1) do 30 I = 0,K ZZ = Z(KMAX) - I*DELTA call COEFF(ZZ,CP,CQ,CR) NCOEFF = NCOEFF + 1 CEV = MIN(CEV,CQ) 30 continue if (ABS(CEV).lt.TOL4) CEV = ZERO if (U*ABS(CEV).ge.ONE) CSPEC = .FALSE. end if EQLNF(IEND) = ZERO end if if (IPRINT.ge.3) then write (21,FMT=40) CP,EP,CQ,EQ,CR,ER 40 format (' Cp, Ep; Cq, Eq; Cr, Er =',/3 (2d25.12,/)) end if CPT(IEND) = CP EPT(IEND) = EP C C Analyze this endpoint. C if ((EP.lt.ONE) .and. (EQ.gt.-ONE) .and. (ER.gt.-ONE) .and. + ENDFIN) then REG(IEND) = .TRUE. LC(IEND) = .TRUE. OSC(IEND) = .FALSE. CSPEC = .FALSE. if ((EP.gt.ZERO) .or. (EQ.lt.ZERO) .or. + (ER.lt.ZERO)) KCLASS(IEND) = 2 return end if REG(IEND) = .FALSE. ETA(1,IEND) = HALF* (ER-EP+TWO) if (ABS(ETA(1,IEND)).le.TOL) ETA(1,IEND) = ZERO if (ETA(1,IEND).ne.ZERO) then EQLNF(IEND) = (EQ-ER)/ETA(1,IEND) IQLNF = EQLNF(IEND) + SIGN(HALF,EQLNF(IEND)) if (ABS(IQLNF-EQLNF(IEND)).lt.TOL4) EQLNF(IEND) = IQLNF C1 = (CQ/CR)* (ABS(ETA(1,IEND))*SQRT(CP/CR))**EQLNF(IEND) if (C1.eq.ZERO) EQLNF(IEND) = ZERO C2 = (EP+ER)/ (FOUR*ETA(1,IEND)) C2 = C2* (C2-ONE) if (IPRINT.ge.5) then write (21,FMT=50) C1,C2,EQLNF(IEND),ETA(1,IEND) 50 format (' C1, C2 =',2d20.10,/ + ' Eqlnf, Eta1 =',2d20.10) end if else C3 = (CP/CR)* (QUART* (EP+ER))**2 if (IPRINT.ge.5) then write (21,FMT=60) C3 60 format (' C3 = ',d19.10) end if end if if (.not.ENDFIN) then C C Make an initial estimate for "infinity" (used in MESH). C if ((ER.gt.EQ) .or. (CQ.eq.ZERO)) then if (ER.ne.EP) then GAMMA = ER - EP DELTA = CR/CP else GAMMA = EQ - EP DELTA = ABS(CQ)/CP if (DELTA.eq.ZERO) DELTA = ONE end if else if (EQ.gt.ER) then GAMMA = EQ - EP DELTA = ABS(CQ)/CP else if (ER.gt.EP) then GAMMA = ER - EP DELTA = CR/CP else GAMMA = ZERO if (ER.eq.EP) then DELTA = ABS(CR-CQ)/CP else DELTA = ABS(CQ)/CP end if end if end if end if if (GAMMA.gt.HALF) then if (GAMMA.lt.TWO) then END = 80.0 else END = MIN(MAX(64.0/ ((TWO*GAMMA-3.0)*DELTA** (ONE/ + (GAMMA+TWO))),ONE),80.D0) if (GAMMA.gt.24.0) END = 12.0 end if else if (GAMMA.lt.-HALF) then END = MAX(MIN(600.0*DELTA** (ONE/ + GAMMA)*5.0**GAMMA,120.0D0),TWO) else END = 12.0 end if if ((GAMMA.eq.ZERO) .and. (CQ.ne.ZERO)) END = 40.0 end if end if C C Test for finite irregular singular points. C if (ENDFIN) then SGN = ONE I = ER - EP + SIGN(HALF,ER-EP) K = EQ - EP + SIGN(HALF,EQ-EP) IRREG = .TRUE. if (CQ.eq.ZERO) then if ((I.ge.-2) .and. (ABS(ER-EP-I).le.TOL4)) IRREG = .FALSE. else if ((ER.le.EQ) .and. (I.ge.-2) .and. + (ABS(ER-EP-I).le.TOL4)) IRREG = .FALSE. if ((ER.gt.EQ) .and. (K.ge.-2) .and. + (ABS(EQ-EP-K).le.TOL4)) IRREG = .FALSE. end if EMU(IEND) = HALF* (ONE-EP) if (IRREG) then if (IPRINT.ge.3) write (21,FMT=70) 70 format (' This is an irregular singular point.') KCLASS(IEND) = 5 else C C Compute the principal Frobenius root. C if (ETA(1,IEND).ne.ZERO) then if ((CQ.ne.ZERO) .and. (ER.gt.EQ) .and. (K.eq.-2)) then PNU(IEND) = EMU(IEND)**2 + CQ/CP if (ABS(PNU(IEND)).le.TOL4) PNU(IEND) = ZERO if (PNU(IEND).ge.ZERO) then PNU(IEND) = EMU(IEND) + SQRT(PNU(IEND)) else PNU(IEND) = -EP end if else PNU(IEND) = MAX(ONE-EP,ZERO) end if if (PNU(IEND).gt.-EP) then if (IPRINT.ge.5) write (21,FMT=75) PNU(IEND) 75 format (' The principal Frobenius root is ',e20.8) end if end if end if else SGN = -ONE end if if (SGN*ETA(1,IEND).gt.ZERO) then C C Carry out the Case 1 tests. C K = 0 if (EQLNF(IEND).lt.-TWO) then if (CQ.lt.ZERO) K = 1 if (CQ.gt.ZERO) K = -1 end if if (EQLNF(IEND).eq.-TWO) then if (ABS(C1+C2+QUART).le.TOL4) then if (IPRINT.ge.3) write (21,FMT=80) 80 format (' WARNING: borderline nonoscillatory/oscillato', + 'ry classification.') K = -1 IFLAG = 1 else if (C1+C2.lt.-QUART-TOL4) K = 1 if (C1+C2.gt.-QUART) K = -1 end if end if if (EQLNF(IEND).gt.-TWO) then if (ABS(C2+QUART).le.TOL4) then C2 = -QUART if (IPRINT.ge.3) write (21,FMT=80) IFLAG = 1 end if if (C2.ge.-QUART) K = -1 end if if (K.eq.1) then OSC(IEND) = .TRUE. else if (K.eq.-1) then OSC(IEND) = .FALSE. else if (IPRINT.ge.3) write (21,FMT=85) 85 format (' NO INFORMATION on osc/nonosc class.') end if end if K = 0 if (EQLNF(IEND).lt.-TWO) then if (CQ.gt.ZERO) K = -1 if (CQ.lt.ZERO) K = 1 end if if (EQLNF(IEND).eq.-TWO) then if (ABS(C1+C2-QUART3).le.TOL4) then K = -1 if (IPRINT.ge.3) write (21,FMT=90) 90 format (' WARNING: borderline Lc/Lp classification.') IFLAG = 1 end if if (C1+C2.ge.QUART3) K = -1 if (ABS(C1+C2).lt.QUART3-TOL4) K = 1 if (C1+C2.lt.-TOL4) K = 1 end if if (EQLNF(IEND).gt.-TWO) then if (ABS(C2-QUART3).le.TOL4) then K = -1 if (IPRINT.ge.3) write (21,FMT=90) IFLAG = 1 end if if (C2.ge.QUART3) K = -1 if (ABS(C2).lt.QUART3-TOL4) K = 1 if (C2.lt.-TOL4) K = 1 end if if (K.eq.1) then LC(IEND) = .TRUE. else if (K.eq.-1) then LC(IEND) = .FALSE. else write (21,FMT=95) 95 format (' NO INFORMATION on Lp/Lc class.') end if end if end if if (SGN*ETA(1,IEND).lt.ZERO) then C C Carry out the Case 2 tests. C K = 0 if ((EQLNF(IEND).gt.ZERO) .and. (CQ.lt.ZERO)) K = 1 if ((EQLNF(IEND).gt.ZERO) .and. (CQ.gt.ZERO)) K = -1 if (EQLNF(IEND).eq.ZERO) then K = -1 CEV = CQ/CR CSPEC = .TRUE. if (U*ABS(CEV).ge.ONE) CSPEC = .FALSE. end if if (EQLNF(IEND).lt.ZERO) then K = -1 CEV = ZERO CSPEC = .TRUE. end if if (K.eq.1) then OSC(IEND) = .TRUE. else if (K.eq.-1) then OSC(IEND) = .FALSE. else write (21,FMT=100) 100 format (' NO INFORMATION on Osc/Nonosc class.') end if end if K = 0 if ((EQLNF(IEND).gt.TWO) .and. (CQ.gt.ZERO)) K = -1 if (EQLNF(IEND).le.TWO) K = -1 if ((EQLNF(IEND).gt.TWO) .and. (CQ.lt.ZERO)) K = 1 if (K.eq.1) then LC(IEND) = .TRUE. else if (K.eq.-1) then LC(IEND) = .FALSE. else write (21,FMT=105) 105 format (' NO INFORMATION on Lp/Lc class.') end if end if end if if (ETA(1,IEND).eq.ZERO) then C C Carry out the Case 3 and 4 tests. C if ((SGN* (EQ-ER).lt.ZERO) .and. (CQ.lt.ZERO)) then OSC(IEND) = .TRUE. LC(IEND) = .TRUE. end if if ((SGN* (EQ-ER).lt.ZERO) .and. (CQ.gt.ZERO)) then OSC(IEND) = .FALSE. LC(IEND) = .FALSE. end if if (EQ.eq.ER) then OSC(IEND) = .FALSE. LC(IEND) = .FALSE. CEV = CQ/CR + C3 CSPEC = .TRUE. if (U*ABS(CEV).ge.ONE) CSPEC = .FALSE. end if if ((SGN* (EQ-ER).gt.ZERO) .or. (CQ.eq.ZERO)) then OSC(IEND) = .FALSE. LC(IEND) = .FALSE. CEV = C3 CSPEC = .TRUE. if (U*ABS(CEV).ge.ONE) CSPEC = .FALSE. end if end if if (ABS(CEV).le.TOL4) CEV = ZERO C C Calculate the Friedrichs boundary condition (if appropriate). C if (CSPEC) then BC(1) = ONE BC(2) = ZERO end if if ((.not.CSPEC) .and. (.not.OSC(IEND))) then if ((SGN* (ER+EP).gt.ZERO) .and. (SGN* (EQ+EP).gt.ZERO)) then BC(1) = ZERO BC(2) = ONE else if ((SGN* (ER+EP).gt.ZERO) .and. (EQ+EP.eq.ZERO)) then BC(1) = SQRT(CP*ABS(CQ)) BC(2) = ONE if (BC(1).gt.ONE) then BC(2) = ONE/BC(1) BC(1) = ONE end if else if ((SGN* (ER+EP).lt.ZERO) .or. + (SGN* (EQ+EP).lt.ZERO)) then BC(1) = ONE BC(2) = ZERO end if end if end if end if if (.not.OSC(IEND)) then if ((.not.ENDFIN) .and. (EQLNF(IEND).eq.-ONE)) KCLASS(IEND) = 3 I = ER - EP if (CQ.ne.ZERO) then K = EQ - EP if (CQ.gt.ZERO) then if (K.lt.I) I = 0 else I = MIN(I,K) end if end if if (ENDFIN .and. (I.lt.0)) then if (IRREG) KCLASS(IEND) = 6 if (ETA(1,IEND).gt.ZERO) then C C Transform some nonoscillatory problems for which Tau C is unbounded near a finite singular endpoint. C if (IRREG) KCLASS(IEND) = 10 CPT(IEND) = CP CRT(IEND) = CR EPT(IEND) = EP ERT(IEND) = ER EMU(IEND) = ZERO D(1,IEND) = (ETA(1,IEND)*SQRT(CP/CR))** (ONE/ETA(1,IEND)) D(2,IEND) = ONE/SQRT(SQRT(CP*CR*D(1,IEND)** (EP+ER))) if ((EQLNF(IEND).eq.-TWO) .or. (C1.eq.ZERO)) then if (.not.IRREG) KCLASS(IEND) = 9 EMU(IEND) = ABS(QUART+C1+C2) if (EMU(IEND).lt.TOL4) then EMU(IEND) = HALF else EMU(IEND) = HALF + SQRT(EMU(IEND)) end if else if (.not.IRREG) KCLASS(IEND) = 8 end if ETA(2,IEND) = EMU(IEND) - QUART* (EP+ER)/ETA(1,IEND) if ((KCLASS(IEND).eq.10) .and. (EMU(IEND).eq.ZERO)) then ETA(2,IEND) = HALF* (ONE-EP)/ETA(1,IEND) EMU(IEND) = ETA(2,IEND) + QUART* (EP+ER)/ETA(1,IEND) end if D(3,IEND) = ETA(2,IEND)* (ETA(2,IEND)+ (EP-ONE)/ + ETA(1,IEND)) D(4,IEND) = D(3,IEND) if (EQLNF(IEND).eq.-TWO) D(4,IEND) = D(4,IEND) - C1 if (ABS(D(4,IEND)).le.TOL4) D(4,IEND) = ZERO D(4,IEND) = SQRT(ABS(D(4,IEND))) if (IPRINT.ge.5) then write (21,FMT=110) EMU(IEND),ETA(2,IEND) write (21,FMT=115) D(3,IEND),D(4,IEND) 110 format (' Mu =',d20.6,'; Eta2 =',d20.6) 115 format (' D3 =',d20.6,'; D4 =',d20.6) end if end if if (KCLASS(IEND).ge.9) then if (.not.EX) LFLAG(5) = .TRUE. if (IPRINT.ge.3) then write (21,FMT=120) 120 format (' This problem has unbounded ', + '[Ev*r(x)-q(x)]/p(x).') if ((EMU(IEND).gt.ZERO) .or. + (EP+ER.ne.ZERO)) write (21,FMT=125) 125 format (' A change of variables will be used near', + ' this endpoint.') end if end if end if if (ENDFIN .and. (.not.REG(IEND)) .and. + (KCLASS(IEND).eq.0)) KCLASS(IEND) = 4 end if if ((POSC.or.QOSC.or.ROSC) .and. (.not.ENDFIN)) END = 99.0 if (IPRINT.ge.5) then write (21,FMT=130) KCLASS(IEND) 130 format (' Classification type (KCLASS) is: ',i2) end if return end subroutine CLSEND C----------------------------------------------------------------------- subroutine DENSEF(TOL,CSPEC,IPRINT,ITER,NEXTRP,NUMT,T,RHO,NEV, + HMIN,NUMEV,STORE) *********************************************************************** * * * This routine computes the spectral density function rho(t). * * * *********************************************************************** C C Input parameters: C TOL(*) as in SLEDGE. C CSPEC(*) = logical 2-vector; CSPEC(i) = .true. iff endpoint i C (1 = A, 2 = B) generates continuous spectrum. C IPRINT = integer controlling printing. C ITER = iteration from SLEDGE. C NEXTRP = integer giving maximum no. of extrapolations. C NUMT = integer equalling number of T(*) points. C T(*) = real vector of abcissae for spectral function rho(t). C HMIN = minimum stepsize in Level 0 mesh. C C Output parameters: C RHO(*) = real vector of values for spectral density function C rho(t), RHO(I) = rho(T(I)). C NEV = integer pointer to eigenvalue. On a normal return C (FLAG = 0) this is set to the index of the last C eigenvalue computed; if FLAG is not zero, then NEV C gives the index of the eigenvalue where the problem C occurred. C NUMEV = cumulative number of eigenvalues computed. C C Auxiliary storage: C STORE(*) = real vector of auxiliary storage, must be dimensioned C at least 5*Nxinit+(Maxlvl+2)*NUMT. The value of C Nxinit is either the input NUMX or Maxint. Currently, C Maxlvl = 8 and Maxint = 235. C 1 -> Nxinit vector of mesh points X(*), C Nxinit+1 -> 5*Nxinit intermediate RsubN calculations, C 5*Nxinit+1 -> 5*Nxinit+10*NUMT intermediate RHO values. C----------------------------------------------------------------------- C The definition of a spectral density function assumes a certain C normalization on the eigenfunctions. For the case when x = b C generates the continuous spectrum, the normalization used here C (and in routine GETRN below) is: C (1) when x = a is regular u(a) = (A2-A2P*Ev)/SCALE C (pu')(a) = (A1-A1P*Ev)/SCALE, C with SCALE = sqrt(A1**2+A2**2) when A1' = A2' = 0, and C SCALE = sqrt(ALPHA) otherwise. C (2) When x = a is a regular singular point then u(x) is taken to C be asymptotic to the principal Frobenius solution, i.e., C near x = a u(x) ~ (x-a)**Nu with Nu the larger C root of the indicial equation. C Analogous normalizations hold at x = b when the endpoint x = a C generates the continuous spectrum. C---------------------------------------------------------------------- C Local variables: C C C Initialization: C C .. Parameters .. double precision ZERO,HALF,ONE,TWO,FOUR,SIX,TEN,TOLMIN parameter (ZERO=0.0,HALF=0.5D0,ONE=1.0,TWO=2.0,FOUR=4.0,SIX=6.0, + TEN=10.0,TOLMIN=5.D-3) C .. C .. Scalar Arguments .. double precision HMIN integer IPRINT,ITER,NEV,NEXTRP,NUMEV,NUMT C .. C .. Array Arguments .. double precision RHO(*),STORE(*),T(*),TOL(*) logical CSPEC(2) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,CUTOFF,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. double precision CP(2),CR(2),D(4,2),EMU(2),EP(2),EQLNF(2),ER(2), + ETAT(2,2),PNU(2) integer KCLASS(2) logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision ABSERR,AEV,ALPHA,ALPHA1,ALPHA2,ARN,AVGRHO,BETA1, + BETA2,BIG,DELTA,DENOM,DX,EFNORM,ERROR,ETA,ETAOLD, + EV,EVHAT,EVHIGH,EVLOW,EVSAVE,FHIGH,FLOW,H,HALFH, + PDU,PSRHO,PX,QINT,QLNF,QX,RELERR,RHOSUM,ROLD, + RPATA,RPATB,RPINT,RSUBN,RX,SCALE,SQRTRP,TENU, + TOL1,TOL2,TOLMAX,UX,XLEFT,XTOL,Z,ZABS,ZREL integer I,IASYMP,J,JS,KLVL,KRHO,LPRINT,MAXNEV,NRHO,NSAVE logical DONE,JUMP,RDONE C .. C .. Local Arrays .. double precision EVOLD(200),RSAVE(5) logical EFIN(2,2) C .. C .. External Functions .. cc double precision ASYMEV,ASYMR cc external ASYMEV,ASYMR C .. C .. External Subroutines .. cc external BRCKET,COEFF,EXTRAP,GETEF,GETRN,PQRINT,ZZERO C .. C .. Intrinsic Functions .. intrinsic ABS,MAX,MIN,SQRT C .. C .. Common blocks .. common /SLCLSS/CP,CR,CUTOFF,D,EMU,EP,EQLNF,ER,ETAT,PNU,KCLASS common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. NSAVE = 200 JS = 5*NXINIT TENU = TEN*U BIG = ONE/U AVGRHO = BIG LPRINT = MIN(IPRINT,3) MAXNEV = 0 if (REG(1)) then DX = SQRT(U)*MAX(ONE,ABS(A)) call COEFF(A+DX,PX,QX,RX) if (FLAG.lt.0) return RPATA = RX*PX ALPHA1 = ONE/RX call COEFF(A+TWO*DX,PX,QX,RX) ALPHA1 = ALPHA1* (RPATA-PX*RX)/ (DX*FOUR) RPATA = SQRT(RPATA) ALPHA2 = SQRT(RPATA) ALPHA1 = (A1+A2*ALPHA1)/ALPHA2 ALPHA2 = ALPHA2*A2 NCOEFF = NCOEFF + 2 else ALPHA1 = ZERO ALPHA2 = ONE RPATA = ONE end if if (REG(2)) then DX = SQRT(U)*MAX(ONE,ABS(B)) call COEFF(B-DX,PX,QX,RX) if (FLAG.lt.0) return RPATB = RX*PX BETA1 = ONE/RX call COEFF(B-TWO*DX,PX,QX,RX) BETA1 = BETA1* (RPATB-PX*RX)/ (DX*FOUR) RPATB = SQRT(RPATB) BETA2 = SQRT(RPATB) BETA1 = (B1-B2*BETA1)/BETA2 BETA2 = BETA2*B2 NCOEFF = NCOEFF + 2 else BETA1 = ZERO BETA2 = ONE end if ALPHA = A1P*A2 - A1*A2P if (CSPEC(2)) then if (ALPHA.eq.ZERO) then SCALE = SQRT(A1**2+A2**2) else SCALE = SQRT(ALPHA) end if end if if (CSPEC(1)) SCALE = SQRT(B1**2+B2**2) TOLMAX = MAX(TOL(1),TOL(2)) TOL1 = MIN(TOL(1),TOLMIN) TOL2 = MIN(TOL(2),TOLMIN) ABSERR = TOL1 RELERR = TOL2 KLVL = 1 DELTA = HALF C C Begin the Main loop over LEVEL. C do 120 LEVEL = 0,MAXLVL if (IPRINT.ge.2) then write (*,FMT=10) LEVEL,ITER write (21,FMT=10) LEVEL,ITER 10 format (' Level',i3,' of iteration',i3) end if NRHO = 1 KRHO = 0 PSRHO = ZERO RHOSUM = ZERO ROLD = ZERO IASYMP = 0 EVSAVE = -BIG NEV = 0 JUMP = .FALSE. C C Compute integrals needed in asymptotic formulas. C QINT = ZERO RPINT = ZERO do 20 I = 2,NXINIT XLEFT = STORE(I-1) H = (STORE(I)-XLEFT)/KLVL HALFH = HALF*H do 15 J = 1,KLVL Z = XLEFT + HALFH XLEFT = XLEFT + H call PQRINT(Z,SQRTRP,QLNF) if (FLAG.lt.0) return QINT = QINT + H*QLNF RPINT = RPINT + H*SQRTRP 15 continue 20 continue if (QINT.gt.ONE/U) QINT = ZERO ZABS = MAX(MIN(ABSERR/100.0,RELERR)/10.0,TENU) ZREL = RELERR/10.0 DELTA = MAX(DELTA/SIX,TOL1+TOL2) C C Begin the secondary loop over NEV. C 25 if (IASYMP.ge.2) then AEV = ASYMEV(NEV,QINT,RPINT,ALPHA1,ALPHA2,BETA1,BETA2) EVHAT = AEV if (IASYMP.le.3) go to 35 RSUBN = ASYMR(NEV,RPINT,RPATA,RPATB,SCALE) go to 45 end if if (HMIN/KLVL.le.TENU) FLAG = -8 if (FLAG.lt.0) return if ((LEVEL.gt.0) .and. (NEV.lt.MIN(MAXNEV,NSAVE))) then EV = MAX(HALF*TOL1,DELTA,HALF*TOL2*ABS(EVOLD(NEV+1))) EVLOW = EVOLD(NEV+1) - EV EVHIGH = EVOLD(NEV+1) + EV else if (LEVEL.eq.0) then EV = ZERO else EV = ASYMEV(NEV,QINT,RPINT,ALPHA1,ALPHA2,BETA1,BETA2) end if ETA = MAX(HALF*TOL1,DELTA,HALF*TOL2*ABS(EV)) EVLOW = EV - ETA EVHIGH = EV + ETA end if call BRCKET(NEV,EVLOW,EVHIGH,FLOW,FHIGH,ZABS,ZREL,STORE) if ((LEVEL.eq.0) .and. (NEV.eq.0)) DELTA = EVHIGH - EVLOW if (FLAG.lt.0) return if (ABS(EVHIGH-EVLOW).gt.MAX(ZABS, + ZREL*ABS(EVHIGH))) call ZZERO(EVLOW,EVHIGH,FLOW,FHIGH,ZABS, + ZREL,J,STORE) EVHAT = MIN(EVLOW,EVHIGH) call GETEF(EVHAT,EFNORM,LPRINT,STORE,EFIN) if (FLAG.lt.0) return if (CSPEC(2)) then if (REG(1) .or. (PNU(1).eq.ZERO) .or. + (PNU(1).eq.ONE-EP(1))) then UX = ABS(STORE(NXINIT+1)) PDU = ABS(STORE(2*NXINIT+1)) if (A2-A2P*EVHAT.ne.ZERO) then DENOM = SCALE*UX/ABS(A2-A2P*EVHAT) else DENOM = SCALE*PDU/ABS(A1-A1P*EVHAT) end if else H = STORE(2) - STORE(1) UX = ABS(STORE(NXINIT+2)) PDU = ABS(STORE(2*NXINIT+2)) if (UX.ge.PDU) then DENOM = UX/H**PNU(1) else DENOM = PDU/ (CP(1)*ABS(PNU(1))* + H** (EP(1)+PNU(1)-ONE)) end if end if else if (REG(2) .or. (PNU(2).eq.ZERO) .or. + (PNU(2).eq.ONE-EP(2))) then UX = ABS(STORE(2*NXINIT)) PDU = ABS(STORE(3*NXINIT)) if (B2.ne.ZERO) then DENOM = SCALE*UX/ABS(B2) else DENOM = SCALE*PDU/ABS(B1) end if else H = STORE(NXINIT) - STORE(NXINIT-1) UX = ABS(STORE(2*NXINIT-1)) PDU = ABS(STORE(3*NXINIT-1)) if (UX.ge.PDU) then DENOM = UX/H**PNU(2) else DENOM = PDU/ (CP(2)*ABS(PNU(2))* + H** (EP(2)+PNU(2)-ONE)) end if end if end if if (BIG*DENOM.ge.ONE) then EFNORM = ONE/DENOM**2 else EFNORM = ONE/U**2 end if C C Test for asymptotic EV. C AEV = ASYMEV(NEV,QINT,RPINT,ALPHA1,ALPHA2,BETA1,BETA2) if (TEN*ABS(AEV-EVHAT).gt.MAX(ABSERR,RELERR*ABS(EVHAT))) then IASYMP = 0 else if (IASYMP.lt.1) then IASYMP = 1 else if (IPRINT.ge.2) then write (*,FMT=30) NEV write (21,FMT=30) NEV 30 format (' Switchover to asymptotic eigenvalues at', + ' Nev =',i8) end if IASYMP = 2 end if end if if (EFNORM.lt.BIG) then RSUBN = ONE/ (ALPHA+EFNORM) else RSUBN = ZERO end if C C Test for asymptotic RsubN. C 35 ARN = ASYMR(NEV,RPINT,RPATA,RPATB,SCALE) if (IASYMP.ge.2) then C C Eigenvalues from asymptotic formulas; produce current RsubN. C call GETRN(AEV,ALPHA,CSPEC,SCALE,RSUBN,STORE) if (FLAG.lt.0) return if (ABS(ARN-RSUBN).gt.MAX(ABSERR/100.0,RELERR*ARN)) then IASYMP = 2 else if (IASYMP.lt.3) then IASYMP = 3 else if (IPRINT.ge.2) then write (*,FMT=40) NEV write (21,FMT=40) NEV 40 format (' Switchover to asymptotic RsubN at ', + 'Nev = ',i8) end if IASYMP = 4 end if end if end if 45 if (NEV.lt.NSAVE) EVOLD(NEV+1) = EVHAT if (NEV.gt.0) ETA = HALF* (EVHAT+EVSAVE) if (EVHAT.lt.CUTOFF) PSRHO = PSRHO + RSUBN 50 if (T(NRHO).le.CUTOFF) then C C Use step functions for Rho(t). C if (T(NRHO).le.EVHAT) then RHO(NRHO) = RHOSUM NRHO = NRHO + 1 if (NRHO.le.NUMT) then go to 50 else go to 85 end if end if else if (NEV.eq.0) go to 78 C C Use linear interpolation for Rho(t). C 55 if (T(NRHO).le.ETA) then if (JUMP) then 60 if (T(NRHO).le.EVSAVE) then RHO(NRHO) = RHOSUM - ROLD NRHO = NRHO + 1 if (NRHO.le.NUMT) then go to 60 else JUMP = .FALSE. go to 85 end if else JUMP = .FALSE. 65 if (T(NRHO).le.ETA) then RHO(NRHO) = RHOSUM NRHO = NRHO + 1 if (NRHO.gt.NUMT) go to 85 go to 65 else go to 70 end if end if end if if ((NEV.le.1) .or. (CUTOFF.gt.EVSAVE)) then UX = CUTOFF else UX = ETAOLD end if RHO(NRHO) = RHOSUM - ROLD* (ETA-T(NRHO))/ (ETA-UX) NRHO = NRHO + 1 if (NRHO.le.NUMT) then go to 55 else go to 85 end if end if 70 if ((RSUBN.gt.MAX(SIX*ROLD,TEN*TOLMAX,FOUR*AVGRHO)) .and. + (EVHAT.gt.CUTOFF) .and. (KRHO.gt.4)) then C C Possible eigenvalue in the continuous spectrum. C LFLAG(3) = .TRUE. if (IPRINT.ge.1) then write (*,FMT=75) EVHAT write (21,FMT=75) EVHAT 75 format (' Large jump in the step spectral density', + ' function at',d17.10) write (*,FMT=76) ITER,LEVEL,RSUBN write (21,FMT=76) ITER,LEVEL,RSUBN 76 format (18x,'Iteration =',i2,', level = ',i2, + ', jump = ',d17.10) end if JUMP = .TRUE. end if end if if (NEV.gt.0) ETAOLD = ETA 78 RHOSUM = RHOSUM + RSUBN ROLD = RSUBN EVSAVE = EVHAT C C Output requested information. C if (IPRINT.ge.3) then if ((NEV.le.25) .or. ((IASYMP.le.1).and. + (IPRINT.ge.5))) then write (21,FMT=80) NEV,EVHAT,RSUBN write (*,FMT=80) NEV,EVHAT,RSUBN 80 format (' Nev =',i7,', EvHat =',d15.6,', RHat =',d15.6) else if ((NEV.lt.100) .and. (10* (NEV/10).eq.NEV)) then write (21,FMT=80) NEV,EVHAT,RSUBN write (*,FMT=80) NEV,EVHAT,RSUBN else if ((NEV.lt.1000) .and. (100* (NEV/100).eq.NEV)) then write (21,FMT=80) NEV,EVHAT,RSUBN write (*,FMT=80) NEV,EVHAT,RSUBN else if (1000* (NEV/1000).eq.NEV) then write (21,FMT=80) NEV,EVHAT,RSUBN write (*,FMT=80) NEV,EVHAT,RSUBN end if end if end if end if end if NEV = NEV + 1 if (EVHAT.ge.CUTOFF) then if (KRHO.eq.5) then RSAVE(1) = RSAVE(2) RSAVE(2) = RSAVE(3) RSAVE(3) = RSAVE(4) RSAVE(4) = RSAVE(5) else KRHO = KRHO + 1 end if RSAVE(KRHO) = RSUBN AVGRHO = ZERO do 84 I = 1,KRHO AVGRHO = AVGRHO + RSAVE(I) 84 continue if (KRHO.gt.0) AVGRHO = AVGRHO/KRHO end if go to 25 C C End of Nev loop ------------------ C 85 MAXNEV = NEV NUMEV = NUMEV + MAXNEV if (IPRINT.ge.3) then write (*,FMT=90) MAXNEV write (21,FMT=90) MAXNEV 90 format (' MaxNev = ',i8) end if if (IPRINT.ge.4) then write (*,FMT=95) write (21,FMT=95) 95 format (9x,'t',18x,'RhoHat(t)') do 105 J = 1,NUMT write (*,FMT=100) T(J),RHO(J) write (21,FMT=100) T(J),RHO(J) 100 format (f12.4,e31.15) 105 continue end if C C Extrapolate interpolated approximations. C DONE = .TRUE. do 110 J = 1,NUMT XTOL = MAX(TOL1,ABS(RHO(J))*TOL2) call EXTRAP(RHO(J),XTOL,LEVEL+1,NEXTRP,.TRUE.,.FALSE.,1, + STORE((MAXLVL+1)*J+JS),IPRINT,ERROR,RDONE) if (RHO(J).lt.ZERO) RHO(J) = ZERO if (J.gt.1) RHO(J) = MAX(RHO(J),RHO(J-1)) if (ERROR.le.HALF*XTOL) RDONE = .TRUE. DONE = RDONE .and. DONE 110 continue if (DONE) return ABSERR = MAX(HALF*ABSERR,TENU) RELERR = MAX(HALF*RELERR,TENU) 120 continue FLAG = -3 return end subroutine DENSEF ****************************** End of Part 2 *************************** ******************************* Start of Part 3 ************************ C----------------------------------------------------------------------- subroutine DSCRIP(LC,LPLC,TYPE,REG,CSPEC,CEV,CUTOFF,LASTEV,A1,A1P, + A2,A2P,B1,B2) C C Output (if requested) a description of the spectrum. C C .. Scalar Arguments .. double precision A1,A1P,A2,A2P,B1,B2,CUTOFF integer LASTEV C .. C .. Array Arguments .. double precision CEV(*) logical CSPEC(*),LC(*),LPLC(*),REG(*),TYPE(4,*) C .. write (21,FMT=*) if (TYPE(3,1) .and. TYPE(3,2)) then C C Category 1 C write (21,FMT=123) 1 write (21,FMT=100) write (21,FMT=121) write (21,FMT=102) write (21,FMT=110) if (REG(1)) then write (21,FMT=112) else write (21,FMT=113) write (21,FMT=114) if (LC(1)) then if (LPLC(1)) write (21,FMT=117) else if (LPLC(1)) write (21,FMT=118) end if write (21,FMT=119) A1,A1P,A2,A2P end if write (21,FMT=111) if (REG(2)) then write (21,FMT=112) else write (21,FMT=113) write (21,FMT=114) if (LC(2)) then if (LPLC(2)) write (21,FMT=117) else if (LPLC(2)) write (21,FMT=118) end if write (21,FMT=119) B1,B2 end if end if C if ((TYPE(3,1).and.CSPEC(2)) .or. (TYPE(3,2).and.CSPEC(1))) then C C Category 2 C write (21,FMT=123) 2 write (21,FMT=100) write (21,FMT=103) CUTOFF if (LASTEV.eq.-5) then write (21,FMT=105) write (21,FMT=120) else if (LASTEV.eq.0) then write (21,FMT=107) else if (LASTEV.eq.1) then write (21,FMT=108) else write (21,FMT=109) LASTEV end if end if end if write (21,FMT=110) if (REG(1)) then write (21,FMT=112) else write (21,FMT=113) if (CSPEC(1)) then write (21,FMT=116) CEV(1) else write (21,FMT=114) write (21,FMT=119) A1,A1P,A2,A2P end if if (LC(1)) then if (LPLC(1)) write (21,FMT=117) else if (LPLC(1)) write (21,FMT=118) end if end if write (21,FMT=111) if (REG(2)) then write (21,FMT=112) else write (21,FMT=113) if (CSPEC(2)) then write (21,FMT=116) CEV(2) else write (21,FMT=114) write (21,FMT=119) B1,B2 end if if (LC(2)) then if (LPLC(2)) write (21,FMT=117) else if (LPLC(2)) write (21,FMT=118) end if end if end if C if ((TYPE(3,1).and. (TYPE(4,2).and.LC(2).and. + (.not.CSPEC(2)))) .or. (TYPE(3,2).and. (TYPE(4, + 1).and.LC(1).and. (.not.CSPEC(1))))) then C C Category 3 C write (21,FMT=123) 3 write (21,FMT=100) write (21,FMT=106) write (21,FMT=102) write (21,FMT=110) if (REG(1)) then write (21,FMT=112) else write (21,FMT=113) if (TYPE(4,1)) then write (21,FMT=115) else write (21,FMT=114) write (21,FMT=119) A1,A1P,A2,A2P end if if (LC(1)) then if (LPLC(1)) write (21,FMT=117) else if (LPLC(1)) write (21,FMT=118) end if end if write (21,FMT=111) if (REG(2)) then write (21,FMT=112) else write (21,FMT=113) if (TYPE(4,2)) then write (21,FMT=115) else write (21,FMT=114) write (21,FMT=119) B1,B2 end if if (LC(2)) then if (LPLC(2)) write (21,FMT=117) else if (LPLC(2)) write (21,FMT=118) end if end if end if C if ((TYPE(3,1).and. ((.not.LC(2)).and.TYPE(4, + 2).and. (.not.CSPEC(2)))) .or. + (TYPE(3,2).and. ((.not.LC(1)).and.TYPE(4, + 1).and. (.not.CSPEC(1))))) then C C Category 4 C write (21,FMT=123) 4 write (21,FMT=100) write (21,FMT=104) write (21,FMT=110) if (REG(1)) then write (21,FMT=112) else write (21,FMT=113) if (TYPE(4,1)) then write (21,FMT=115) else write (21,FMT=114) write (21,FMT=119) A1,A1P,A2,A2P end if if (LC(1)) then if (LPLC(1)) write (21,FMT=117) else if (LPLC(1)) write (21,FMT=118) end if end if write (21,FMT=111) if (REG(2)) then write (21,FMT=112) else write (21,FMT=113) if (TYPE(4,2)) then write (21,FMT=115) else write (21,FMT=114) write (21,FMT=119) B1,B2 end if if (LC(2)) then if (LPLC(2)) write (21,FMT=117) else if (LPLC(2)) write (21,FMT=118) end if end if end if C if ((LC(1).and.TYPE(4,1)) .and. (LC(2).and.TYPE(4,2))) then C C Category 5 C write (21,FMT=123) 5 write (21,FMT=100) write (21,FMT=106) write (21,FMT=102) write (21,FMT=110) write (21,FMT=113) write (21,FMT=115) write (21,FMT=117) write (21,FMT=111) write (21,FMT=113) write (21,FMT=115) write (21,FMT=117) end if C if ((TYPE(4,1).and. (.not.LC(1)).and. (.not.CSPEC(1))) .and. + (TYPE(4,2).and. (.not.LC(2)).and. (.not.CSPEC(2)))) then C C Category 6 C write (21,FMT=123) 6 write (21,FMT=122) write (21,FMT=110) write (21,FMT=113) write (21,FMT=115) write (21,FMT=118) write (21,FMT=111) write (21,FMT=113) write (21,FMT=115) write (21,FMT=118) end if C if ((TYPE(4,1).and.TYPE(4,2).and..not. (CSPEC(1).or. + CSPEC(2))) .and. ((LC(1).and. (.not.LC(2))).or. + ((.not.LC(1)).and.LC(2)))) then C C Category 7 C write (21,FMT=123) 7 write (21,FMT=104) write (21,FMT=110) write (21,FMT=113) write (21,FMT=115) if (LC(1)) then if (LPLC(1)) write (21,FMT=117) else if (LPLC(1)) write (21,FMT=118) end if write (21,FMT=111) write (21,FMT=113) write (21,FMT=115) if (LC(2)) then if (LPLC(2)) write (21,FMT=117) else if (LPLC(2)) write (21,FMT=118) end if end if C if ((LC(1).and.TYPE(4,1).and.CSPEC(2)) .or. + (LC(2).and.TYPE(4,2).and.CSPEC(1))) then C C Category 8 C write (21,FMT=123) 8 write (21,FMT=100) write (21,FMT=103) CUTOFF write (21,FMT=110) write (21,FMT=113) if (CSPEC(1)) then write (21,FMT=116) CEV(1) else write (21,FMT=115) end if if (LC(1)) then if (LPLC(1)) write (21,FMT=117) else if (LPLC(1)) write (21,FMT=118) end if write (21,FMT=111) write (21,FMT=113) if (CSPEC(2)) then write (21,FMT=116) CEV(2) else write (21,FMT=115) end if if (LC(2)) then if (LPLC(2)) write (21,FMT=117) else if (LPLC(2)) write (21,FMT=118) end if end if C if ((((.not.LC(1)).and.TYPE(4,1).and. (.not.CSPEC(1))).and. + CSPEC(2)) .or. (((.not.LC(2)).and.TYPE(4, + 2).and. (.not.CSPEC(2))).and.CSPEC(1))) then C C Category 9 C write (21,FMT=123) 9 write (21,FMT=101) write (21,FMT=110) write (21,FMT=113) if (CSPEC(1)) then write (21,FMT=116) CEV(1) else write (21,FMT=115) end if if (LC(1)) then if (LPLC(1)) write (21,FMT=117) else if (LPLC(1)) write (21,FMT=118) end if write (21,FMT=111) write (21,FMT=113) if (CSPEC(2)) then write (21,FMT=116) CEV(2) else write (21,FMT=115) end if if (LC(2)) then if (LPLC(2)) write (21,FMT=117) else if (LPLC(2)) write (21,FMT=118) end if end if C if (CSPEC(1) .and. CSPEC(2)) then C C Category 10 C write (21,FMT=123) 10 write (21,FMT=101) write (21,FMT=103) CUTOFF if (LASTEV.eq.-5) then write (21,FMT=120) else if (LASTEV.eq.0) then write (21,FMT=107) else if (LASTEV.eq.1) then write (21,FMT=108) else write (21,FMT=109) LASTEV end if end if end if write (21,FMT=110) write (21,FMT=113) write (21,FMT=116) CEV(1) if (LC(1)) then if (LPLC(1)) write (21,FMT=117) else if (LPLC(1)) write (21,FMT=118) end if write (21,FMT=111) write (21,FMT=113) write (21,FMT=116) CEV(2) if (LC(2)) then if (LPLC(2)) write (21,FMT=117) else if (LPLC(2)) write (21,FMT=118) end if end if write (21,FMT=*) return 100 format (' This problem has simple spectrum.') 101 format (' This problem may have non-simple spectrum.') 102 format (' There is no continuous spectrum.') 103 format (' There is continuous spectrum in [Ev, infinity) where', + ' Ev =',g15.6) 104 format (' There is continuous spectrum consisting of the entire ', + 'real line.') 105 format (' The set of eigenvalues is bounded below.') 106 format (' There are infinitely many negative and infinitely many', + ' positive',/' eigenvalues (unbounded in either', + ' direction).') 107 format (' There appear to be no eigenvalues below the start of', + ' the continuous spectrum.') 108 format (' There appears to be 1 eigenvalue below the start of the' + ,' continuous spectrum.') 109 format (' There appear to be ',i12,' eigenvalues below the start', + /' of the continuous spectrum.') 110 format (' At endpoint A') 111 format (' At endpoint B') 112 format (' the problem is regular;') 113 format (' the problem is singular;') 114 format (' it is nonoscillatory for all Ev.') 115 format (' it is oscillatory for all Ev.') 116 format (' it is nonoscillatory for Ev <',g15.6, + ' and oscillatory otherwise.') 117 format (' It is limit circle.') 118 format (' It is limit point.') 119 format (' The constants for the Friedrichs boundary conditions' + ,' are',/4e18.8) 120 format (' There appear to be infinitely many eigenvalues below', + ' the start',/' of the continuous spectrum.') 121 format (' There are infinitely many eigenvalues, bounded below.') 122 format (' The nature of the spectrum is unknown; there is likely', + ' to be ',/' continuous spectrum.') 123 format (' The spectral category is',i3,'.') end subroutine DSCRIP C----------------------------------------------------------------------- subroutine EXTRAP(V,TOL,IROW,MAXCOL,FULL,TIGHT,MODE,VSAVE,IPRINT, + ERROR,DONE) C C Use Richardson's h**2 extrapolation (based on doubling) when C suitable, otherwise use Wynn's acceleration scheme. C C Input: C V = real value at current level. C TOL = real tolerance. C IROW = integer giving current row index (1 .le. IROW). C MAXCOL = integer giving maximum number of columns in table. C FULL = logical, True iff entire table is to be computed. C TIGHT = logical, True for conservative convergence tests. C MODE = integer, value is C 0 both Richardson and Wynn algorithms can be used; C 1 only Richardson is used; C 2 only Wynn is used. C IPRINT = integer controlling amount of printing. C Output: C V = real, best output estimate. C VSAVE = real vector, holds previous level values. C DONE = logical, True iff Error is sufficiently small. C C If FULL is True, then the entire acceleration array is produced C (through row IROW); if False, then only the next row is appended. C Hence, the choice of FULL = True requires more work, but it may C save some global storage. The vector VSAVE contains the V values C for levels 0 through max(IROW-1,MAXCOL). C C C The local arrays RATIO(*), R(*,*), and W(*,*) must be declared to C have at least as many rows as the value of MAXLVL initialized in C routine START. C C C .. Parameters .. double precision ZERO,TENTH,ONE,TWO parameter (ZERO=0.0,TENTH=0.1D0,ONE=1.0,TWO=2.0) C .. C .. Scalar Arguments .. double precision ERROR,TOL,V integer IPRINT,IROW,MAXCOL,MODE logical DONE,FULL,TIGHT C .. C .. Array Arguments .. double precision VSAVE(*) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,U,UNDER C .. C .. Local Scalars .. double precision DIFF,EPS,ETEMP,RHIGH,RLOW,RTOL,T,TOL1,TOL2,VTEMP integer I,IMIN,J,MAXJ,NCOL C .. C .. Local Arrays .. double precision R(12,8),RATIO(12),W(40,11) C .. C .. Intrinsic Functions .. intrinsic ABS,LOG,MAX,MIN,MOD C .. C .. Common blocks .. common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. C .. Save statement .. save R,W C .. EPS = 0.2 DONE = .FALSE. ETEMP = ONE/U VTEMP = V VSAVE(IROW) = V TOL1 = TOL TOL2 = TOL/3.0 if (MODE.eq.2) then MAXJ = MAXCOL go to 40 else MAXJ = 11 end if RLOW = MAX(3.0,4.2-0.2* (IROW-1)) RHIGH = MIN(5.0,3.8+0.2* (IROW-1)) RTOL = U C C Analyze the rate of convergence to determine NCOL and tolerances. C NCOL = 2 do 10 I = 1,IROW R(I,1) = VSAVE(I) RATIO(I) = ONE/U if (I.ge.3) then T = R(I,1) - R(I-1,1) if (T.ne.ZERO) then RATIO(I) = (R(I-1,1)-R(I-2,1))/T else V = R(I,1) DONE = .TRUE. return end if if (((RATIO(I).ge.RLOW).and. (RATIO(I).le.RHIGH)) .or. + (.not.TIGHT)) then RTOL = TOL1 NCOL = MIN(MAXCOL,NCOL+1) else RTOL = TOL2 if (RATIO(I).lt.ZERO) RTOL = TENTH*TOL2 if (RATIO(I).lt.TWO) NCOL = 2 end if end if 10 continue if (FULL) then IMIN = 2 else IMIN = IROW end if C C Use Richardson's h^2 extrapolation. The number of columns used C is a function of the amount of data (IROW), the requested order C (MAXCOL), the observed rate of convergence (NCOL), and the amount C of storage allocated to R(*,*). C do 30 I = IMIN,IROW do 20 J = 2,MIN(I,NCOL,8) DIFF = (R(I,J-1)-R(I-1,J-1))/ (4** (J-1)-1) R(I,J) = R(I,J-1) + DIFF if ((.not.FULL) .or. (I.eq.IROW)) then T = ABS(DIFF) if (T.le.ETEMP) then ETEMP = T VTEMP = R(I,J) if (T.le.RTOL) then DONE = .TRUE. V = VTEMP ERROR = ETEMP return end if end if end if 20 continue 30 continue V = VTEMP ERROR = ETEMP if (IROW.lt.4) return C C Test for rate of convergence other than second order. C if (ABS(RATIO(IROW)-RATIO(IROW-1))+ + ABS(RATIO(IROW-1)-RATIO(IROW-2)).gt.EPS) return if ((3.5.lt.RATIO(IROW)) .and. (RATIO(IROW).lt.4.5)) return if (RATIO(IROW).lt.ONE) return if (MODE.ne.0) return C C Use Wynn's algorithm. C 40 if (IPRINT.ge.4) then DIFF = LOG(ABS(RATIO(IROW)))/LOG(TWO) write (21,FMT=50) DIFF 50 format (' In EXTRAP: using Wynn`s acceleration; rate = ',f8.5) end if W(1,1) = VSAVE(1) ETEMP = ONE/U do 60 I = 2,IROW W(I,1) = VSAVE(I) DIFF = W(I,1) - W(I-1,1) if ((I.eq.IROW) .or. (MODE.eq.2)) then T = ABS(DIFF) if (T.le.ETEMP) then ETEMP = T VTEMP = W(I,1) if (T.le.TOL2) then V = VTEMP ERROR = ETEMP DONE = .TRUE. return end if end if end if if (DIFF.ne.ZERO) then W(I,2) = ONE/DIFF else V = W(I,1) ERROR = ZERO DONE = .TRUE. return end if 60 continue do 80 J = 3,MIN(IROW,MAXJ) do 70 I = J,IROW DIFF = W(I,J-1) - W(I-1,J-1) if (DIFF.ne.ZERO) then DIFF = ONE/DIFF else if (MOD(J,2).eq.0) then V = W(I,J-1) ERROR = ZERO DONE = .TRUE. return else DIFF = ONE/U**2 end if end if W(I,J) = W(I-1,J-2) + DIFF if ((MOD(J,2).eq.1) .and. ((I.eq.IROW).or. + (MODE.eq.2))) then T = ABS(DIFF) if (T.le.ETEMP) then ETEMP = T VTEMP = W(I,J) if (T.le.TOL2) then V = VTEMP ERROR = ETEMP DONE = .TRUE. return end if end if end if 70 continue 80 continue V = VTEMP ERROR = ETEMP return end subroutine EXTRAP C----------------------------------------------------------------------- subroutine GETEF(EV,EFNORM,IPRINT,X,EFIN) C C Compute an eigenfunction for one fixed mesh. C C C .. Parameters .. double precision ZERO,C10M4,HALF,ONE,TWO,THREE,FIVE,C15,C21,TINY parameter (ZERO=0.0,C10M4=1.D-4,HALF=0.5D0,ONE=1.0,TWO=2.0, + THREE=3.0,FIVE=5.0,C15=15.0,C21=21.0,TINY=1.D-38) C .. C .. Scalar Arguments .. double precision EFNORM,EV integer IPRINT C .. C .. Array Arguments .. double precision X(*) logical EFIN(2,2) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,CUTOFF,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. double precision CP(2),CR(2),D(4,2),EMU(2),EP(2),EQLNF(2),ER(2), + ETA(2,2),PNU(2) integer KCLASS(2) logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision CHI,DPSI,DV,DW,FNORM,FSCALE,FSUM,H,HALFH,HOM,OM, + OSCALE,PDV,PDW,PN,PROD,PSI,RATIO,RN,RNORM,RSCALE, + RSUM,SCALE,T,TAU,TAUHH,TAUMAX,V,VNEW,W,WNEW, + XLEFT,XRIGHT,Z, + FTERM,RTERM integer I,J,JDU,JLAST,JS,JU,JX,KLVL,MODE logical ALLOK,SYMM C .. C .. Local Arrays .. integer MIDDLE(2) C .. C .. External Subroutines .. cc external STEP C .. C .. Intrinsic Functions .. intrinsic ABS,EXP,LOG,MAX,SIGN C .. C .. Common blocks .. common /SLCLSS/CP,CR,CUTOFF,D,EMU,EP,EQLNF,ER,ETA,PNU,KCLASS common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. KLVL = 2**LEVEL C C For this EV and mesh, calculate FSCALE, RSCALE, and MIDDLE(*). C FSCALE = sum of logs of scale factors 1 through m C RSCALE = sum of logs of scale factors m+1 through N C MIDDLE(1), MIDDLE(2) describe the coordinates of the matching C point M for the shooting; in particular, C M = X(MIDDLE(1)-1) + MIDDLE(2)*H(MIDDLE(1)-1)/2**LEVEL C The matching point is chosen to be roughly (a+b)/2 if either C a = -b and Tau(x) > 0 near 0, or if Tau(x) > 0 for all x; C otherwise, it is chosen to roughly maximize Tau(x). C FSCALE = ZERO RSCALE = ZERO TAUMAX = -ONE/U ALLOK = .TRUE. SYMM = .FALSE. if (A.eq.-B) SYMM = .TRUE. EFIN(1,1) = .TRUE. EFIN(2,1) = .TRUE. EFIN(1,2) = .TRUE. EFIN(2,2) = .TRUE. JX = (NXINIT+1)/2 do 20 I = 2,NXINIT MODE = 0 XLEFT = X(I-1) H = X(I) - XLEFT if (I.eq.2) then if (KCLASS(1).ge.9) MODE = 1 if (.not.AFIN) then MODE = 3 XLEFT = ZERO H = -ONE/X(2) end if end if if (I.eq.NXINIT) then if (KCLASS(2).ge.9) MODE = 2 if (.not.BFIN) then MODE = 4 H = ONE/X(I-1) XLEFT = -H end if end if H = H/KLVL HALFH = HALF*H do 10 J = 1,KLVL Z = XLEFT + HALFH XLEFT = XLEFT + H call STEP(Z,H,EV,PN,RN,TAU,OM,HOM,PSI,DPSI,SCALE,MODE) if (TAU.lt.ZERO) ALLOK = .FALSE. if (TAU.gt.TAUMAX) then TAUMAX = TAU MIDDLE(1) = I MIDDLE(2) = J FSCALE = FSCALE + RSCALE + SCALE OSCALE = SCALE RSCALE = ZERO else RSCALE = RSCALE + SCALE end if 10 continue if ((I.eq.JX) .and. (TAU.lt.ZERO)) SYMM = .FALSE. 20 continue if (ALLOK .or. SYMM) then MIDDLE(1) = JX MIDDLE(2) = MAX(KLVL-1,1) end if if ((.not.AFIN) .or. (.not.BFIN)) then C C Don't split near infinity! C if ((.not.AFIN) .and. (MIDDLE(1).eq.2)) then if (REG(2)) then MIDDLE(1) = NXINIT else MIDDLE(1) = JX end if MIDDLE(2) = MAX(KLVL-1,1) end if if ((.not.BFIN) .and. (MIDDLE(1).eq.NXINIT)) then if (REG(1)) then MIDDLE(1) = 2 else MIDDLE(1) = JX end if MIDDLE(2) = 1 end if end if if ((LEVEL.gt.1) .and. (MIDDLE(2).eq.KLVL)) then MIDDLE(2) = KLVL - 1 FSCALE = FSCALE - OSCALE RSCALE = RSCALE + OSCALE end if if (IPRINT.ge.4) write (21,FMT=21) MIDDLE(1),MIDDLE(2) 21 format (' Coordinates of matching point =',2i6) JU = NXINIT JDU = 2*NXINIT JS = 3*NXINIT C C Shoot from x=A to the middle. C V = A2 - A2P*EV PDV = A1 - A1P*EV FNORM = ZERO if (KCLASS(1).lt.9) then SCALE = MAX(ABS(V),ABS(PDV)) V = V/SCALE PDV = PDV/SCALE MODE = 0 else V = ONE PDV = D(4,1) MODE = 1 end if if (.not.AFIN) MODE = 3 FSUM = -FSCALE if ((IPRINT.ge.5) .and. (MODE.eq.0)) write (21,FMT=35) X(1),V,PDV, + FSUM do 40 I = 2,MIDDLE(1) X(JU+I-1) = V X(JDU+I-1) = PDV X(JS+I-1) = FSUM if (MODE.eq.0) then XLEFT = X(I-1) H = X(I) - XLEFT else XLEFT = ZERO if (MODE.eq.1) then H = ((X(2)-X(1))/D(1,1))**ETA(1,1) else H = -ONE/X(2) end if end if H = H/KLVL HALFH = HALF*H JLAST = KLVL if (I.eq.MIDDLE(1)) JLAST = MIDDLE(2) do 30 J = 1,JLAST Z = XLEFT + HALFH XLEFT = XLEFT + H call STEP(Z,H,EV,PN,RN,TAU,OM,HOM,PSI,DPSI,SCALE,MODE) DV = PDV/PN if (ABS(TAU)*H*H.ge.C10M4) then if (TWO* (FSUM+SCALE).gt.-UNDER) then FNORM = FNORM + RN* (PSI*DPSI* (V*V-DV*DV/TAU)/ + TWO+V*PSI*DV*PSI)*EXP(TWO* (FSUM+SCALE)) if (TWO*FSUM.gt.-UNDER) FNORM = FNORM + + RN*EXP(TWO*FSUM)*H* (V*V+DV*DV/TAU)/TWO end if else if (TWO*FSUM.gt.-UNDER) then TAUHH = TAU*H*H FNORM = FNORM + RN*H*EXP(TWO*FSUM)* + (V*V* (ONE+TAUHH* (TAUHH/FIVE-ONE)/ + THREE)+H*V*DV* (ONE+TAUHH* (TWO*TAUHH/ + C15-ONE)/THREE)+ (H*DV)**2* + (ONE+TAUHH* (TWO*TAUHH/C21-ONE)/FIVE)/THREE) end if end if FSUM = FSUM + SCALE VNEW = DPSI*V + PSI*DV PDV = -PN*TAU*PSI*V + DPSI*PDV V = VNEW 30 continue if (MODE.eq.1) then C C Convert from V(t) to u(x). C if (ETA(2,1).lt.ZERO) then X(JU+1) = ONE/U EFIN(1,1) = .FALSE. else if (ETA(2,1).eq.ZERO) then X(JU+1) = D(2,1) else X(JU+1) = ZERO end if end if Z = ETA(1,1)*ETA(2,1) + EP(1) - ONE if (Z.lt.ZERO) then X(JDU+1) = SIGN(ONE/U,ETA(2,1)) EFIN(2,1) = .FALSE. else if (Z.gt.ZERO) then X(JDU+1) = ZERO else X(JDU+1) = D(2,1)*CP(1)*ETA(1,1)*ETA(2,1)/ + D(1,1)** (ETA(1,1)*ETA(2,1)) end if end if H = X(2) - A PN = CP(1)*H** (EP(1)-ONE) T = (H/D(1,1))**ETA(1,1) CHI = D(2,1)*T**ETA(2,1) V = V*CHI PDV = PN*ETA(1,1)* (ETA(2,1)*V+CHI*PDV*T** (ONE-TWO*EMU(1))) if (IPRINT.ge.5) write (21,FMT=35) X(1),X(JU+1),X(JDU+1) end if MODE = 0 if (IPRINT.ge.5) write (21,FMT=35) XLEFT,V,PDV,FSUM 35 format (g16.6,3d15.6) 40 continue C C Shoot from x=B to the middle. C RNORM = ZERO MODE = 0 if (KCLASS(2).lt.9) then SCALE = MAX(ABS(B1),ABS(B2)) W = -B2/SCALE PDW = B1/SCALE MODE = 0 else W = -ONE PDW = -D(4,2) MODE = 2 end if if (.not.BFIN) MODE = 4 RSUM = -RSCALE if ((IPRINT.ge.5) .and. (MODE.eq.0)) write (21,FMT=35) X(NXINIT), + W,PDW,RSUM do 60 I = NXINIT,MIDDLE(1),-1 X(JU+I) = W X(JDU+I) = PDW X(JS+I) = RSUM if (MODE.eq.0) then XRIGHT = X(I) H = XRIGHT - X(I-1) else XRIGHT = ZERO if (MODE.eq.2) then H = ((X(NXINIT)-X(NXINIT-1))/D(1,2))**ETA(1,2) else H = ONE/X(I-1) end if end if H = H/KLVL HALFH = HALF*H JLAST = KLVL if (I.eq.MIDDLE(1)) JLAST = JLAST - MIDDLE(2) do 50 J = 1,JLAST Z = XRIGHT - HALFH XRIGHT = XRIGHT - H call STEP(Z,H,EV,PN,RN,TAU,OM,HOM,PSI,DPSI,SCALE,MODE) DW = PDW/PN if (ABS(TAU)*H*H.ge.C10M4) then if (TWO* (RSUM+SCALE).gt.-UNDER) then RNORM = RNORM + RN* (PSI*DPSI* (W*W-DW*DW/TAU)/ + TWO-W*PSI*DW*PSI)*EXP(TWO* (RSUM+SCALE)) if (TWO*RSUM.gt.-UNDER) RNORM = RNORM + + RN*EXP(TWO*RSUM)*H* (W*W+DW*DW/TAU)/TWO end if else if (TWO*RSUM.gt.-UNDER) then TAUHH = TAU*H*H RNORM = RNORM + RN*H*EXP(TWO*RSUM)* + (W*W* (ONE+TAUHH* (TAUHH/FIVE-ONE)/ + THREE)-H*W*DW* (ONE+TAUHH* (TWO*TAUHH/ + C15-ONE)/THREE)+ (H*DW)**2* + (ONE+TAUHH* (TWO*TAUHH/C21-ONE)/FIVE)/THREE) end if end if RSUM = RSUM + SCALE WNEW = DPSI*W - PSI*DW PDW = PN*TAU*PSI*W + DPSI*PDW W = WNEW 50 continue if (MODE.eq.2) then C C Convert from V(t) to u(x). C if (ETA(2,2).lt.ZERO) then X(JU+NXINIT) = -ONE/U EFIN(1,2) = .FALSE. else if (ETA(2,2).eq.ZERO) then X(JU+NXINIT) = -D(2,2) else X(JU+NXINIT) = ZERO end if end if Z = ETA(1,2)*ETA(2,2) + EP(2) - ONE if (Z.lt.ZERO) then X(JDU+NXINIT) = SIGN(ONE/U,ETA(2,2)) EFIN(2,2) = .FALSE. else if (Z.gt.ZERO) then X(JDU+NXINIT) = ZERO else X(JDU+NXINIT) = D(2,2)*CP(2)*ETA(1,2)*ETA(2,2)/ + D(1,2)** (ETA(1,2)*ETA(2,2)) end if end if if (IPRINT.ge.5) write (21,FMT=35) X(NXINIT),X(JU+NXINIT), + X(JDU+NXINIT) H = X(NXINIT) - X(NXINIT-1) PN = CP(2)*H** (EP(2)-ONE) T = (H/D(1,2))**ETA(1,2) CHI = D(2,2)*T**ETA(2,2) W = CHI*W PDW = PN*ETA(1,2)* (CHI*PDW*T** (ONE-TWO*EMU(2))-ETA(2,2)*W) end if if (MODE.eq.4) then X(JU+NXINIT) = ZERO X(JDU+NXINIT) = ONE if (IPRINT.ge.5) write (21,FMT=35) X(NXINIT),X(JU+NXINIT), + X(JDU+NXINIT) end if MODE = 0 if ((JLAST.ne.0) .and. (IPRINT.ge.5)) write (21,FMT=35) XRIGHT, + W,PDW,RSUM 60 continue if (ABS(W).ge.ABS(PDW)) then RATIO = V/W if (IPRINT.ge.5) write (21,FMT=61) RATIO*PDW - PDV,RATIO 61 format (' DuHat jump, ratio =',2d24.15) else RATIO = PDV/PDW if (V*W*RATIO.lt.ZERO) RATIO = -RATIO if (IPRINT.ge.5) write (21,FMT=62) RATIO*W - V,RATIO 62 format (' UHat jump, ratio =',2d24.15) end if C C Calculate weighted 2-norm and scale approximate eigenfunction. C CJDP The expression for EFNORM caused overflow unnecessarily so C next 4 lines altered. Note EFNORM, SCALE both used later C but FSCALE, RSCALE are not. C FSCALE = EXP(-FSUM) C RSCALE = EXP(-RSUM) C EFNORM = SQRT(FNORM*FSCALE**2+RNORM* (RATIO*RSCALE)**2) C SCALE = LOG(EFNORM) C Compute the logs of the 2 terms under the square root above, C with precaution against log of zero. FTERM = HALF*LOG(MAX(TINY,FNORM)) - FSUM RTERM = HALF*LOG(MAX(TINY,RNORM*RATIO**2)) - RSUM C SCALE can never cause overflow, and EFNORM will only cause C overflow if it is actually too large to store: if (FTERM.ge.RTERM) then SCALE = FTERM + HALF*LOG(ONE+EXP(TWO*(RTERM-FTERM))) else SCALE = RTERM + HALF*LOG(ONE+EXP(TWO*(FTERM-RTERM))) end if EFNORM = EXP(SCALE) CJDP end of amendment if (IPRINT.ge.5) write (21,FMT=65) EFNORM 65 format (' EFnorm =',d24.15) do 70 I = 1,NXINIT TAU = X(JS+I) - SCALE if (TAU.le.-UNDER) then X(JU+I) = ZERO X(JDU+I) = ZERO else PROD = EXP(TAU) if (I.ge.MIDDLE(1)) PROD = PROD*RATIO X(JU+I) = X(JU+I)*PROD X(JDU+I) = X(JDU+I)*PROD end if 70 continue if (IPRINT.ge.4) then write (21,FMT=75) 75 format (10x,'x',15x,'Uhat(x)',13x,'PUhat`(x)') do 85 I = 1,NXINIT write (21,FMT=80) X(I),X(JU+I),X(JDU+I) 80 format (g16.6,2d20.8) 85 continue end if return end subroutine GETEF C---------------------------------------------------------------------- subroutine GETRN(EV,ALPHA,CSPEC,DENOM,RSUBN,X) C C Compute the RsubN value from the weighted eigenfunction 2-norm C when standard shooting is stable and an accurate eigenvalue is C available (from the asymptotic formulas). C C C .. Parameters .. double precision ZERO,C10M4,HALF,ONE,TWO,THREE,FIVE,C15,C21 parameter (ZERO=0.0,C10M4=1.D-4,HALF=0.5D0,ONE=1.D0,TWO=2.0, + THREE=3.0,FIVE=5.0,C15=15.0,C21=21.0) C .. C .. Scalar Arguments .. double precision ALPHA,DENOM,EV,RSUBN C .. C .. Array Arguments .. double precision X(*) logical CSPEC(*) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,CUTOFF,UNDER,URN integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. double precision CP(2),CR(2),D(4,2),EMU(2),EP(2),EQLNF(2),ER(2), + ETA(2,2),PNU(2) integer KCLASS(2) logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision DPHI,DPSI,DU,DUSAVE,FNORM,H,HALFH,HOM,HSAVE,OM, + PDU,PHI,PN,PSI,RN,SCALE,TAU,TAUHH,U,UNEW,USAVE, + XLEFT,Z integer I,J,KLVL C .. C .. External Subroutines .. cc external STEP C .. C .. Intrinsic Functions .. intrinsic ABS,EXP C .. C .. Common blocks .. common /SLCLSS/CP,CR,CUTOFF,D,EMU,EP,EQLNF,ER,ETA,PNU,KCLASS common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,URN,UNDER C .. U = A2 - A2P*EV PDU = A1 - A1P*EV FNORM = ZERO KLVL = 2**LEVEL C C Shoot from x=A to x=B. C do 20 I = 2,NXINIT XLEFT = X(I-1) H = (X(I)-XLEFT)/KLVL HALFH = HALF*H do 10 J = 1,KLVL Z = XLEFT + HALFH XLEFT = XLEFT + H call STEP(Z,H,EV,PN,RN,TAU,OM,HOM,PSI,DPSI,SCALE,0) SCALE = EXP(SCALE) PHI = PSI*SCALE DPHI = DPSI*SCALE DU = PDU/PN if (ABS(TAU)*H*H.ge.C10M4) then FNORM = FNORM + RN* (PHI*DPHI* (U*U-DU*DU/TAU)/ + TWO+U*PHI*DU*PHI+H* (U*U+DU*DU/TAU)/TWO) else TAUHH = TAU*H*H FNORM = FNORM + RN*H* (U*U* (ONE+TAUHH* (TAUHH/FIVE-ONE)/ + THREE)+H*U*DU* (ONE+TAUHH* (TWO*TAUHH/C15-ONE)/ + THREE)+ (H*DU)**2* (ONE+TAUHH* (TWO*TAUHH/ + C21-ONE)/FIVE)/THREE) end if if ((I.eq.NXINIT) .and. (J.eq.KLVL) .and. CSPEC(1)) then HSAVE = H USAVE = ABS(U) DUSAVE = ABS(PDU) end if UNEW = DPHI*U + PHI*DU PDU = -PN*TAU*PHI*U + DPHI*PDU U = UNEW if ((I.eq.2) .and. (J.eq.1) .and. CSPEC(2)) then HSAVE = H USAVE = ABS(U) DUSAVE = ABS(PDU) end if 10 continue 20 continue if (CSPEC(2)) then if (REG(1) .or. (PNU(1).eq.ZERO) .or. + (PNU(1).eq.ONE-EP(1))) then PHI = DENOM else if (USAVE.ge.DUSAVE) then PHI = USAVE/HSAVE**PNU(1) else PHI = DUSAVE/ (CP(1)*ABS(PNU(1))* + HSAVE** (EP(1)+PNU(1)-ONE)) end if end if else if (REG(2) .or. (PNU(2).eq.ZERO) .or. + (PNU(2).eq.ONE-EP(2))) then PHI = DENOM else if (USAVE.ge.DUSAVE) then PHI = USAVE/HSAVE**PNU(2) else PHI = DUSAVE/ (CP(2)*ABS(PNU(2))* + HSAVE** (EP(2)+PNU(2)-ONE)) end if end if end if RSUBN = ONE/ (ALPHA+FNORM/PHI**2) return end subroutine GETRN ******************************** End of Part 3 ************************* ******************************* Start of Part 4 ************************ C----------------------------------------------------------------------- subroutine MESH(JOB,NEV,X,G,H,QLNF,Z,TOL,HMIN) C C If JOB = True then calculate the initial mesh; redistribute so C that H(*) is approximately equidistributed. If JOB = False C then use the mesh input by the user. C C .. Parameters .. double precision ZERO,TENTH,HALF,ONE,TWO,FOUR parameter (ZERO=0.0,TENTH=0.1D0,HALF=0.5D0,ONE=1.0,TWO=2.0, + FOUR=4.0) C .. C .. Scalar Arguments .. double precision HMIN,TOL integer NEV logical JOB C .. C .. Array Arguments .. double precision G(*),H(*),QLNF(*),X(*),Z(*) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,CUTOFF,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. double precision CP(2),CR(2),D(4,2),EMU(2),EP(2),EQLNF(2),ER(2), + ETA(2,2),PNU(2) integer KCLASS(2) logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision DX,ENDA,ENDB,EPS,EQMAX,EQMIN,EV,GAMMA,P1,P2,P3, + Q1,Q2,Q3,QMAX,QMIN,R1,R2,R3,WEIGHT,Y,Y1,Y2,Y3 integer I,ITS,J,JTOL,K,MAXITS,N,NADD logical DONE C .. C .. External Subroutines .. cc external COEFF C .. C .. Intrinsic Functions .. intrinsic ABS,EXP,LOG10,MAX,MIN,SQRT C .. C .. Common blocks .. common /SLCLSS/CP,CR,CUTOFF,D,EMU,EP,EQLNF,ER,ETA,PNU,KCLASS common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. C .. Save statement .. save ENDA,ENDB C .. C .. Data statements .. data EPS/0.0001/ C .. C if (.not.JOB) then HMIN = B - A do 5 I = 2,NXINIT HMIN = MIN(HMIN,X(I)-X(I-1)) 5 continue return end if N = NXINIT - 1 EV = NEV C C Find an appropriate initial mesh. C if (AFIN) then X(1) = A if (BFIN) then X(NXINIT) = B DX = (B-A)/N do 10 I = 2,N X(I) = X(1) + (I-1)*DX 10 continue else if (NEV.lt.0) then ENDB = X(NXINIT) else X(NXINIT) = (1+4*NEV)*ENDB end if Y1 = X(1)/ (ONE+ABS(X(1))) DX = (X(NXINIT)/ (ONE+X(NXINIT))-Y1)/N do 11 I = 2,N Y = Y1 + (I-1)*DX X(I) = Y/ (ONE-ABS(Y)) 11 continue end if else if (NEV.lt.0) then ENDA = X(1) else X(1) = (1+4*NEV)*ENDA end if if (BFIN) then X(NXINIT) = B Y1 = X(NXINIT)/ (ONE+ABS(X(NXINIT))) DX = (Y1-X(1)/ (ONE-X(1)))/N do 12 I = 2,N Y = Y1 - (I-1)*DX X(NXINIT+1-I) = Y/ (ONE-ABS(Y)) 12 continue else Y1 = X(1)/ (ONE-X(1)) if (NEV.lt.0) then ENDB = X(NXINIT) else X(NXINIT) = (1+4*NEV)*ENDB end if Y2 = X(NXINIT)/ (ONE+X(NXINIT)) DX = (Y2-Y1)/N do 13 I = 2,N Y = Y1 + (I-1)*DX X(I) = Y/ (ONE-ABS(Y)) 13 continue if (ABS(X((NXINIT+1)/2)).lt.TOL) X((NXINIT+1)/2) = ZERO end if end if JTOL = -LOG10(TOL) + HALF if (REG(1) .and. REG(2)) then MAXITS = 6 else MAXITS = 3 end if C C Calculate H(*) and G(*). C ITS = 1 if (.not.AFIN) then if (X(2).ge.ZERO) X(2) = MAX(HALF*X(1),-ONE) end if if (.not.BFIN) then if (X(N).le.ZERO) X(N) = MIN(HALF*X(NXINIT),ONE) end if QMIN = 1.E31 QMAX = -QMIN 20 GAMMA = ZERO C C Equidistribute { [Qmax - Q]^2 * max[abs(p') , abs(q') , abs(r')] }. C EQMAX = ZERO EQMIN = 1.E31 do 25 J = 1,N DX = X(J+1) - X(J) Y2 = X(J) + HALF*DX call COEFF(Y2,P2,Q2,R2) if ((P2.eq.ZERO) .or. (R2.eq.ZERO) .or. (P2*R2.lt.ZERO)) then FLAG = -15 return end if Y1 = MAX(Y2-EPS,X(1)+TWO*U*ABS(X(1))) call COEFF(Y1,P1,Q1,R1) Y3 = MIN(Y2+EPS,X(NXINIT)-TWO*U*ABS(X(NXINIT))) call COEFF(Y3,P3,Q3,R3) if (LNF) then H(J) = ABS(Q3-Q1)/ (Y3-Y1) QLNF(J) = Q2/R2 else H(J) = MAX(ABS(P3-P1),ABS(Q3-Q1),ABS(R3-R1))/ (Y3-Y1) Y1 = SQRT(SQRT(R1*P1)) Y2 = SQRT(SQRT(R2*P2)) Y3 = SQRT(SQRT(R3*P3)) Y = SQRT(P2/R2) QLNF(J) = Q2/R2 + Y* ((Y3-Y1)* (SQRT(P3/R3)-SQRT(P1/R1))/ + FOUR+ (Y3-TWO*Y2+Y1)*Y)/ (Y2*EPS**2) if (ABS(QLNF(J)).le.EPS) QLNF(J) = ZERO end if QMAX = MAX(QMAX,QLNF(J)) QMIN = MIN(QMIN,QLNF(J)) 25 continue Y = MAX(QMAX-QMIN,ONE) EV = 100.0 + MAX(ZERO,QMIN) do 30 J = 1,N DX = X(J+1) - X(J) if (QLNF(J).le.EV) then WEIGHT = 3.0* ((QMAX-QLNF(J))/Y)**2 + ONE H(J) = MAX(H(J)*WEIGHT,U) else Y2 = TWO*DX*SQRT(QLNF(J)-EV) if (Y2.le.UNDER) then WEIGHT = EXP(-Y2) H(J) = MAX(WEIGHT*H(J),U) else H(J) = U end if end if if ((.not.AFIN) .and. (X(J+1).lt.ZERO)) then H(J) = MAX(H(J)*EXP(X(J+1)),U) if ((J.eq.1) .and. (H(1).eq.U)) X(1) = HALF* (X(1)+X(2)) end if if ((.not.BFIN) .and. (X(J).gt.ZERO)) then H(J) = MAX(H(J)*EXP(-X(J)),U) if ((J.eq.N) .and. (H(N).eq.U)) X(NXINIT) = HALF* + (X(N)+X(NXINIT)) end if EQMIN = MIN(EQMIN,H(J)*DX) EQMAX = MAX(EQMAX,H(J)*DX) 30 continue NCOEFF = NCOEFF + 3*N if (EQMAX-EQMIN.le.MAX(TENTH*EQMAX,U/TENTH)) go to 75 C C Use a roughly locally quasi-uniform mesh. C GAMMA = ZERO do 35 I = 1,N GAMMA = GAMMA + H(I) 35 continue GAMMA = ONE/GAMMA do 45 I = 1,N Y = ZERO do 40 J = 1,N Y = MAX(Y,H(J)/ (ONE+GAMMA*ABS(X(I)+X(I+1)-X(J)-X(J+ + 1))*H(J))) 40 continue Z(I) = Y 45 continue do 50 I = 1,N H(I) = Z(I) 50 continue G(1) = ZERO do 55 J = 1,N G(J+1) = G(J) + H(J)* (X(J+1)-X(J)) 55 continue GAMMA = G(N+1)/N C C Redistribution algorithm: C Y = GAMMA I = 1 do 65 J = 1,N 60 if (Y.le.G(J+1)) then I = I + 1 Z(I) = X(J) + (Y-G(J))/H(J) Y = Y + GAMMA go to 60 end if 65 continue Z(1) = X(1) Z(NXINIT) = X(NXINIT) DONE = .TRUE. do 70 J = 2,N if (ABS(Z(J)-X(J)).gt.TENTH* (Z(J+1)-Z(J-1))) DONE = .FALSE. X(J) = Z(J) 70 continue if (.not.DONE) then if (ITS.lt.MAXITS) then ITS = ITS + 1 go to 20 end if end if 75 if (.not.AFIN) then if (X(2).ge.ZERO) X(2) = -ONE end if if (.not.BFIN) then if (X(N).le.ZERO) X(N) = ONE end if do 95 K = 1,2 NADD = 0 if (KCLASS(K).gt.0) then C C Add Nadd extra points near endpoint K. C if (KCLASS(K).eq.1) then NADD = MIN(MAX((JTOL+2)/3,1),4) Y = TENTH end if if (KCLASS(K).eq.2) then NADD = MIN(MAX(JTOL,3),4) Y = MIN(MAX(TENTH** (JTOL/3),1.D-3),1.D-2) end if if (KCLASS(K).eq.3) NADD = MIN(MAX(JTOL/2,2),4) if (KCLASS(K).eq.4) then NADD = MIN(MAX((5+JTOL)/3,2),5) Y = TENTH** (NADD-1) end if if (KCLASS(K).eq.5) then NADD = (2**JTOL)**0.4 NADD = MIN(MAX(NADD,3),6) Y = MIN(MAX((0.1**JTOL)** (0.333),0.001),0.1) end if if (KCLASS(K).eq.6) then NADD = MIN(MAX(JTOL,2),8) Y = 0.005 end if if ((KCLASS(K).eq.7) .or. (KCLASS(K).eq.10)) then NADD = MIN(MAX((2*JTOL+6)/3,3),8) Y = MIN(MAX(SQRT(TENTH*TOL),1.D-6),1.D-2) end if if (KCLASS(K).eq.8) then NADD = (2**JTOL)**0.4 NADD = MIN(MAX(NADD,2),6) Y = MIN(MAX((0.1**JTOL)** (0.333),0.001),0.05) end if if (KCLASS(K).eq.9) then if (LFLAG(5)) then NADD = MIN(MAX((JTOL+4)/3,2),5) Y = TENTH** (NADD-1) else NADD = MIN(MAX(2+JTOL* (JTOL-3)/40,2),4) Y = 0.25 end if end if if (K.eq.1) then do 80 I = NXINIT,2,-1 X(I+NADD) = X(I) 80 continue NXINIT = NXINIT + NADD if (AFIN) DX = X(2) - A do 85 I = 1,NADD if (AFIN) then X(I+1) = A + DX*Y** ((NADD-I+ONE)/NADD) else if (KCLASS(1).ne.1) then X(NADD+2-I) = X(NADD+3-I) - + (X(NADD+4-I)-X(NADD+3-I))*2.4 else X(NADD+2-I) = X(NADD+3-I) - + (X(NADD+4-I)-X(NADD+3-I)) end if end if 85 continue else if (BFIN) DX = B - X(NXINIT-1) N = NXINIT - 1 NXINIT = NXINIT + NADD X(NXINIT) = B do 90 I = 1,NADD if (BFIN) then X(NXINIT-I) = B - DX*Y** ((NADD-I+ONE)/NADD) else if (KCLASS(2).ne.1) then X(N+I) = X(N+I-1) + (X(N+I-1)-X(N+I-2))*2.4 else X(N+I) = X(N+I-1) + (X(N+I-1)-X(N+I-2)) end if end if 90 continue end if end if 95 continue if (.not.AFIN) X(1) = -ONE/U if (.not.BFIN) X(NXINIT) = ONE/U HMIN = X(NXINIT) - X(1) do 100 I = 2,NXINIT HMIN = MIN(HMIN,X(I)-X(I-1)) 100 continue return end subroutine MESH C----------------------------------------------------------------------------- subroutine POWER(X,F,N,TOL,IPRINT,EF,CF,OSC,EXACT,Y,IFLAG) C C Find the power function which "dominates" the tabled C coefficient function. The output is Cf and Ef such that C f(x) is asymptotic to Cf*x^Ef . C The vectors X(*) and F(*) hold the N input points: C F(I) = f(X(I)) I = 1,...,N. C Set IFLAG = 0 for normal return; 1 for uncertainty in Ef; C 2 if uncertain about Cf (oscillatory). C C .. Parameters .. double precision ZERO,HALF,ONE parameter (ZERO=0.0,HALF=0.5D0,ONE=1.0) C .. C .. Scalar Arguments .. double precision CF,EF,TOL integer IFLAG,IPRINT,N logical EXACT,OSC C .. C .. Array Arguments .. double precision F(*),X(*),Y(*) C .. C .. Local Scalars .. double precision ERROR,TOLAIT,TOLMIN integer K,NY C .. C .. External Subroutines .. cc external AITKEN C .. C .. Intrinsic Functions .. intrinsic ABS,LOG,MAX,MIN,SIGN,SQRT C .. C .. Data statements .. data TOLMIN/1.D-6/ C .. C C Estimate the exponent. C OSC = .FALSE. NY = N - 1 ERROR = 1.E30 TOLAIT = MIN(TOLMIN,TOL) do 10 K = 1,NY if ((F(K).ne.ZERO) .and. (F(K+1).ne.ZERO)) then Y(K) = LOG(ABS(F(K+1)/F(K)))/LOG(ABS(X(K+1)/X(K))) else Y(K) = ZERO end if 10 continue EF = Y(NY) if (IPRINT.gt.4) then write (21,FMT=*) ' From POWER; E_k and c_k sequences:' write (21,FMT=15) (Y(K),K=1,NY) 15 format (4d19.10) write (21,FMT=*) end if call AITKEN(EF,TOLAIT,NY,Y,ERROR) K = EF + SIGN(HALF,EF) if (ABS(K-EF).le.SQRT(TOL)) EF = K if (ABS(ERROR).gt.TOL*MAX(ONE,ABS(EF))) then C C There is uncertainty in the exponent. C IFLAG = 1 end if if (ABS(EF).le.TOL) EF = ZERO C C Estimate the coefficient. C do 20 K = 1,N - 1 Y(K) = F(K)/ABS(X(K))**EF 20 continue CF = Y(N-1) if (IPRINT.ge.5) write (21,FMT=15) (Y(K),K=1,N-1) call AITKEN(CF,TOLAIT,N-1,Y,ERROR) if ((EF.gt.20.) .and. (ABS(CF).le.TOL)) then C C Coefficient probably has exponential behavior. C CF = SIGN(ONE,Y(N-1)) else if ((ABS(ERROR).gt.TOL*MAX(ONE,ABS(CF))) .or. + ((ABS(F(N)-CF*X(N)**EF).gt.20.0*TOL*ABS(F(N))).and. + (EF.ne.ZERO))) then C C There is uncertainty in the coefficient; call such C cases oscillatory. C IFLAG = 2 OSC = .TRUE. end if end if if (ABS(CF).gt.1.D7) then EXACT = .FALSE. return end if K = CF + HALF if ((ABS(K-CF).le.SQRT(TOL)) .and. (K.ne.0)) CF = K EXACT = .TRUE. do 30 K = 1,N if (ABS(F(K)-CF*X(K)**EF).gt.TOL*ABS(F(K))) EXACT = .FALSE. 30 continue return end subroutine POWER C---------------------------------------------------------------------- subroutine PQRINT(X,SQRTRP,QLNF) C C Evaluate the integrands needed for the asymptotic formulas. C (1) The Liouville normal form potential Qlnf: C Qlnf(t) = q/r + f"(t)/f with f = (pr)**.25 . C (2) The term in the change of independent variable: C sqrt(r/p) . C C .. Parameters .. double precision ZERO,TWO,FOUR parameter (ZERO=0.0,TWO=2.0,FOUR=4.0) C .. C .. Scalar Arguments .. double precision QLNF,SQRTRP,X C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision EPS,FL,FM,FR,PX,QX,RX,XDOTL,XDOTR,Z C .. C .. External Subroutines .. cc external COEFF C .. C .. Intrinsic Functions .. intrinsic ABS,MIN,SQRT C .. C .. Common blocks .. common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. if (LNF) then call COEFF(X,PX,QX,RX) if ((PX.eq.ZERO) .or. (RX.eq.ZERO) .or. (PX*RX.lt.ZERO)) then FLAG = -15 return end if NCOEFF = NCOEFF + 1 QLNF = QX/RX SQRTRP = SQRT(RX/PX) else EPS = MIN(1.D-4,MIN(ABS(B-X),ABS(X-A))/TWO) Z = X - EPS call COEFF(Z,PX,QX,RX) if ((PX.eq.ZERO) .or. (RX.eq.ZERO) .or. (PX*RX.lt.ZERO)) then FLAG = -15 return end if XDOTL = SQRT(PX/RX) FL = SQRT(SQRT(PX*RX)) Z = X + EPS call COEFF(Z,PX,QX,RX) XDOTR = SQRT(PX/RX) FR = SQRT(SQRT(PX*RX)) call COEFF(X,PX,QX,RX) SQRTRP = SQRT(RX/PX) FM = SQRT(SQRT(PX*RX)) NCOEFF = NCOEFF + 3 QLNF = QX/RX + ((FR-FM)* (XDOTR-XDOTL)/FOUR+ (FR-TWO*FM+FL)/ + SQRTRP)/ (EPS*EPS*FM*SQRTRP) if (ABS(QLNF).le.EPS) QLNF = ZERO end if return end subroutine PQRINT C----------------------------------------------------------------------- subroutine REGULR(JOB,JOBMSH,TOL,NEV,EV,IPRINT,NEXTRP,XEF,EF,PDEF, + HMIN,STORE) *********************************************************************** * * * REGULR calculates Sturm-Liouville eigenvalue and (optionally) * * eigenfunction estimates for the problem described initially. * * * *********************************************************************** C C Input parameters: C JOB = logical variable describing tasks to be carried out. C JOB = .True. iff an eigenfunction is to be calculated. C JOBMSH = logical variable, JOBMSH = .True. iff initial mesh C is a function of the eigenvalue index. C TOL(*) = real vector of 6 tolerances. C TOL(1) is the absolute error tolerance for e-values, C TOL(2) is the relative error tolerance for e-values, C TOL(3) is the abs. error tolerance for e-functions, C TOL(4) is the rel. error tolerance for e-functions, C TOL(5) is the abs. error tolerance for e-function C derivatives, C TOL(6) is the rel. error tolerance for e-function C derivatives. C Eigenfunction tolerances need not be set if JOB is C False. All absolute error tolerances must be C positive; all relative must be at least 100 times C the unit roundoff. C NEV = integer index for the eigenvalue sought; NEV .GE. 0 . C EV = real initial guess for eigenvalue NEV; accuracy is C not at all critical, but if a good estimate is C available some time may be saved. C IPRINT = integer controlling amount of internal printing done. C C Output parameters: C EV = real computed approximation to NEVth eigenvalue. C XEF(*) = real vector of points for eigenfunction output. C EF(*) = real vector of eigenfunction values: EF(i) is the C estimate of u(XEF(i)). If JOB is False then this C vector is not referenced. C PDEF(*) = real vector of eigenfunction derivative values: C PDEF(i) is the estimate of (pu')(XEF(i)). If JOB is C False then this vector is not referenced. C C Auxiliary storage: C STORE(*) = real vector of auxiliary storage, must be dimensioned C at least max[100,26N]. (N the number of mesh points) C C Storage allocation in auxiliary vector (currently Maxlvl = 10): C STORE(*) C 1 -> N vector of mesh points X(*), C N+1 -> 2N best current eigenfunction values, C 2N+1 -> 3N best current derivative values, C 3N+1 -> 4N scale factors in GETEF, C 4N+1 -> (6+2*Maxlvl)N intermediate eigenfunction values. C----------------------------------------------------------------------- C Local variables: C C C .. Parameters .. double precision ZERO,HALF,ONE,THREE,FIVE,TEN,TOLMIN parameter (ZERO=0.0,HALF=0.5D0,ONE=1.0,THREE=3.0,FIVE=5.0, + TEN=10.0,TOLMIN=1.D-3) C .. C .. Scalar Arguments .. double precision EV,HMIN integer IPRINT,NEV,NEXTRP logical JOB,JOBMSH C .. C .. Array Arguments .. double precision EF(*),PDEF(*),STORE(*),TOL(*),XEF(*) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision ABSERR,ALPHA1,ALPHA2,BETA1,BETA2,DELTA,EFNORM, + ERROR,EVHAT,EVHIGH,EVLOW,FHIGH,FLOW,H,PDUMAX, + QINT,QLNF,RELERR,RPINT,SQRTRP,TOL1,TOL2,TOL3, + TOL4,TOL5,TOL6,TOLEXT,TOLPDU,TOLSUM,UMAX,Z integer I,II,J,JDU,JU,KDU,KK,KU logical DONE,EFDONE,EVDONE,EXFULL C .. C .. Local Arrays .. double precision EVEXT(20) logical EFIN(2,2) C .. C .. External Functions .. cc double precision ASYMEV cc external ASYMEV C .. C .. External Subroutines .. cc external BRCKET,EXTRAP,GETEF,MESH,PQRINT,ZZERO C .. C .. Intrinsic Functions .. intrinsic ABS,MAX,MIN C .. C .. Common blocks .. common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. ALPHA1 = ZERO ALPHA2 = ONE BETA1 = ZERO BETA2 = ONE if (NEV.lt.0) then FLAG = -37 return end if EVDONE = .FALSE. TOL1 = MIN(TOL(1),TOLMIN) TOL2 = MIN(TOL(2),TOLMIN) if (.not. (REG(1).and.REG(2))) then TOL1 = TOL1/THREE TOL2 = TOL2/THREE end if if (JOB) then TOL3 = MIN(TOL(3),TOLMIN) TOL4 = MIN(TOL(4),TOLMIN) TOL5 = MIN(TOL(5),TOLMIN) TOL6 = MIN(TOL(6),TOLMIN) ABSERR = TOL1/FIVE RELERR = TOL2/FIVE EXFULL = .TRUE. else EFDONE = .TRUE. ABSERR = TOL1/TEN RELERR = TOL2/TEN EXFULL = .FALSE. end if TOLSUM = TOL1 + TOL2 if (JOBMSH) then if (NEV.ge.0) then II = NXINIT + 16 call MESH(.TRUE.,NEV,STORE,STORE(II),STORE(2*II+1), + STORE(3*II+1),STORE(4*II+1),TOLSUM,HMIN) end if if (IPRINT.ge.1) then write (*,FMT=15) (STORE(I),I=1,NXINIT) write (21,FMT=15) (STORE(I),I=1,NXINIT) 15 format (' Level 0 mesh:',/ (5g15.6)) end if end if C C Compute estimates for integrals in asymptotic formulas (accuracy C is not all that critical). C QINT = ZERO RPINT = ZERO do 20 I = 2,NXINIT H = STORE(I) - STORE(I-1) Z = STORE(I-1) + HALF*H if ((.not.AFIN) .and. (I.eq.2)) then H = STORE(3) - STORE(2) Z = STORE(2) end if if ((.not.BFIN) .and. (I.eq.NXINIT)) then H = STORE(NXINIT-1) - STORE(NXINIT-2) Z = STORE(NXINIT-1) end if call PQRINT(Z,SQRTRP,QLNF) if (FLAG.lt.0) return QINT = QINT + H*QLNF RPINT = RPINT + H*SQRTRP 20 continue if (QINT.gt.ONE/U) QINT = ZERO if (RPINT.gt.ONE/U) RPINT = ZERO C C Loop over the levels. C do 60 LEVEL = 0,MAXLVL if (HMIN/2**LEVEL.le.TEN*U) then FLAG = -8 go to 70 end if C C Find a bracket for the Nevth eigenvalue. C if (LEVEL.eq.0) then EV = ASYMEV(NEV,QINT,RPINT,ALPHA1,ALPHA2,BETA1,BETA2) EV = MAX(EV,ZERO) DELTA = HALF else DELTA = MAX(TOLSUM*ABS(EVHAT),HALF*HALF*DELTA) if (LEVEL.gt.1) then ERROR = (EVEXT(LEVEL)-EVEXT(LEVEL-1))/THREE if (ABS(ERROR).le.100.) then EV = EVHAT + ERROR else DELTA = ONE EV = EVHAT end if else EV = EVHAT end if end if EVLOW = EV - DELTA EVHIGH = EV + DELTA if (IPRINT.ge.4) write (21,FMT=25) EVLOW,EVHIGH 25 format (' In bracket:',2d24.15) call BRCKET(NEV,EVLOW,EVHIGH,FLOW,FHIGH,ABSERR,RELERR,STORE) if (IPRINT.ge.4) write (21,FMT=30) EVLOW,EVHIGH 30 format (' Out bracket:',2d24.15) DELTA = HALF* (EVHIGH-EVLOW) if (FLAG.lt.0) return if (ABS(EVHIGH-EVLOW).gt.MAX(ABSERR,RELERR*ABS(EVHIGH))) then call ZZERO(EVLOW,EVHIGH,FLOW,FHIGH,ABSERR,RELERR,J,STORE) if (J.ne.0) then FLAG = -7 return end if end if EVHAT = MIN(EVLOW,EVHIGH) if (IPRINT.ge.1) then write (*,FMT=40) LEVEL,EVHAT write (21,FMT=40) LEVEL,EVHAT 40 format (' Level ',i3,' ; EvHat = ',d24.15) end if EV = EVHAT TOLEXT = MAX(TOL1,ABS(EV)*TOL2) call EXTRAP(EV,TOLEXT,LEVEL+1,NEXTRP,EXFULL,.TRUE.,0,EVEXT, + IPRINT,ERROR,EVDONE) if (JOB) then call GETEF(EVHAT,EFNORM,IPRINT,STORE,EFIN) if (LEVEL.eq.0) then UMAX = ONE PDUMAX = ONE C C Set pointers to STORE(*). C JU = NXINIT JDU = 2*NXINIT KU = 4*NXINIT KDU = (MAXLVL+5)*NXINIT KK = MAXLVL + 1 end if C C Extrapolate eigenfunction values. C TOLEXT = MAX(TOL3,UMAX*TOL4) TOLPDU = MAX(TOL5,PDUMAX*TOL6) EFDONE = .TRUE. if (AFIN) then UMAX = ABS(STORE(JU+1)) PDUMAX = ABS(STORE(JDU+1)) else UMAX = ZERO PDUMAX = ZERO end if if (EFIN(1,1)) then call EXTRAP(STORE(JU+1),TOLEXT,LEVEL+1,NEXTRP,EXFULL, + .TRUE.,0,STORE(KU+1),0,ERROR,DONE) EFDONE = EFDONE .and. DONE end if if (EFIN(2,1)) then call EXTRAP(STORE(JDU+1),TOLPDU,LEVEL+1,NEXTRP,EXFULL, + .TRUE.,0,STORE(KDU+1),0,ERROR,DONE) EFDONE = EFDONE .and. DONE end if do 50 I = 2,NXINIT - 1 II = KK* (I-1) + 1 call EXTRAP(STORE(JU+I),TOLEXT,LEVEL+1,NEXTRP,EXFULL, + .TRUE.,0,STORE(KU+II),0,ERROR,DONE) EFDONE = EFDONE .and. DONE call EXTRAP(STORE(JDU+I),TOLPDU,LEVEL+1,NEXTRP,EXFULL, + .TRUE.,0,STORE(KDU+II),0,ERROR,DONE) EFDONE = EFDONE .and. DONE UMAX = MAX(UMAX,ABS(STORE(JU+I))) PDUMAX = MAX(PDUMAX,ABS(STORE(JDU+I))) 50 continue II = KK* (NXINIT-1) + 1 if (EFIN(1,2)) then call EXTRAP(STORE(JU+NXINIT),TOLEXT,LEVEL+1,NEXTRP, + EXFULL,.TRUE.,0,STORE(KU+II),0,ERROR,DONE) EFDONE = EFDONE .and. DONE end if if (EFIN(2,2)) then call EXTRAP(STORE(JDU+NXINIT),TOLPDU,LEVEL+1,NEXTRP, + EXFULL,.TRUE.,0,STORE(KDU+II),0,ERROR,DONE) EFDONE = EFDONE .and. DONE end if if (BFIN) then UMAX = MAX(UMAX,ABS(STORE(JU+NXINIT))) PDUMAX = MAX(PDUMAX,ABS(STORE(JDU+NXINIT))) end if ABSERR = MAX(HALF*ABSERR,TEN*U) RELERR = MAX(HALF*RELERR,TEN*U) end if if (EVDONE .and. (LEVEL.ge.2) .and. EFDONE) go to 70 60 continue if (.not.EVDONE) then FLAG = -1 return end if C C Unload eigenfunction values. C 70 if (JOB) then do 80 I = 1,NXINIT XEF(I) = STORE(I) EF(I) = STORE(JU+I) PDEF(I) = STORE(JDU+I) 80 continue if ((FLAG.ge.0) .and. (.not.EFDONE)) FLAG = -2 end if return end subroutine REGULR C--------------------------------------------------------------------- subroutine SHOOT(EV,X,MU,FEV) C C .. Parameters .. double precision ZERO,HALF,ONE,TWO,PI parameter (ZERO=0.0,HALF=0.5D0,ONE=1.0,TWO=2.0, + PI=3.141592653589793D0) C .. C .. Scalar Arguments .. double precision EV,FEV integer MU C .. C .. Array Arguments .. double precision X(*) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,CUTOFF,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. double precision CP(2),CR(2),D(4,2),EMU(2),EP(2),EQLNF(2),ER(2), + ETA(2,2),PNU(2) integer KCLASS(2) logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision CHI,DPSI,DV,H,HALFH,HOMEGA,OMEGA,PDV,PHASE,PN, + PSI,RN,SA1,SA2,SB1,SB2,SCALE,SGN,T,TAU,V,VNEW,X2, + XLEFT,Z integer I,IMAX,J,K1,K2,KLVL,MODE,NSAVE,NZERO C .. C .. External Subroutines .. cc external STEP C .. C .. Intrinsic Functions .. intrinsic ABS,ATAN,INT,MAX,MIN,MOD,SIGN C .. C .. Common blocks .. common /SLCLSS/CP,CR,CUTOFF,D,EMU,EP,EQLNF,ER,ETA,PNU,KCLASS common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. C .. Data statements .. data IMAX/1000000/ C .. C C Make one shot across (A,B) for the current mesh using the scaled C variable v(x). Count zeros if COUNTZ is True. C C Shoot from x=A to x=B. C V = A2 - A2P*EV PDV = A1 - A1P*EV NZERO = 0 NSAVE = NSGNF SA1 = A1 SA2 = A2 SB1 = B1 SB2 = B2 KLVL = 2**LEVEL MODE = 0 C C Modify base sign count if necessary. C if (((KCLASS(1).gt.8).or. (KCLASS(2).gt.8)) .and. + (EV.lt.CUTOFF)) then if (KCLASS(1).gt.8) then SA1 = D(4,1) SA2 = ONE V = SA2 PDV = SA1 MODE = 1 end if if (KCLASS(2).gt.8) then SB1 = D(4,2) SB2 = ONE end if SGN = A2*B2 if (SGN.eq.ZERO) then SGN = SA1*SB2 + SA2*SB1 if (SGN.eq.ZERO) SGN = A1*B1 end if NSGNF = SIGN(ONE,SGN) end if if (.not.AFIN) MODE = 3 SCALE = MAX(ABS(V),ABS(PDV)) V = V/SCALE PDV = PDV/SCALE do 20 I = 2,NXINIT XLEFT = X(I-1) H = X(I) - XLEFT if (MODE.eq.1) then H = (H/D(1,1))**ETA(1,1) XLEFT = ZERO end if if (MODE.eq.3) then XLEFT = ZERO H = -ONE/X(2) end if if ((KCLASS(2).gt.8) .and. (I.eq.NXINIT) .and. + (EV.lt.CUTOFF)) then C C Convert from u(x) to V(t) near x=b. C MODE = 2 T = (H/D(1,2))**ETA(1,2) CHI = D(2,2)*T**ETA(2,2) V = V/CHI PN = CP(2)*H** (EP(2)-ONE) PDV = (PDV/ (PN*CHI*ETA(1,2))+ETA(2,2)*V)* + T** (TWO*EMU(2)-ONE) H = T XLEFT = -H end if if ((.not.BFIN) .and. (I.eq.NXINIT)) then MODE = 4 H = ONE/X(I-1) XLEFT = -H end if H = H/KLVL HALFH = HALF*H do 10 J = 1,KLVL Z = XLEFT + HALFH call STEP(Z,H,EV,PN,RN,TAU,OMEGA,HOMEGA,PSI,DPSI,SCALE,MODE) if (FLAG.lt.0) then FEV = ZERO return end if DV = PDV/PN VNEW = DPSI*V + PSI*DV XLEFT = XLEFT + H if (COUNTZ) then C C Count zeros of v(x). C if (TAU.le.ZERO) then if (VNEW*V.lt.ZERO) NZERO = NZERO + 1 else if (DV.eq.ZERO) then NZERO = NZERO + INT(HALF+HOMEGA/PI) else PHASE = ATAN(V*OMEGA/DV) K1 = PHASE/PI X2 = (PHASE+HOMEGA)/PI if (X2.lt.IMAX) then K2 = X2 NZERO = NZERO + K2 - K1 else NZERO = IMAX end if if (PHASE* (PHASE+HOMEGA).lt.ZERO) NZERO = NZERO + + 1 end if NZERO = MIN(IMAX,NZERO) end if end if PDV = -PN*TAU*PSI*V + DPSI*PDV V = VNEW 10 continue if (MODE.eq.1) then C C Convert from V(t) back to u(x) near x=a. C PN = CP(1)* (X(2)-A)** (EP(1)-ONE) T = ((X(2)-A)/D(1,1))**ETA(1,1) CHI = D(2,1)*T**ETA(2,1) PDV = PN*ETA(1,1)*CHI* (ETA(2,1)*V+PDV*T** (ONE-TWO*EMU(1))) V = CHI*V end if MODE = 0 20 continue FEV = SB1*V + SB2*PDV if (COUNTZ) then C C Adjust zero count. C MU = NZERO if (A2P.ne.ZERO) then if (EV.ge.SA2/A2P) MU = NZERO + 1 end if if (SB2.ne.ZERO) then SGN = SIGN(ONE,NSGNF*FEV) if (MOD(MU,2).eq.1) SGN = -SGN if (SGN.lt.ZERO) MU = MU + 1 end if end if NSGNF = NSAVE return end subroutine SHOOT C----------------------------------------------------------------------- subroutine START(JOB,CONS,TOL,NEV,INDXEV,N,XEF,NUMT,T,NEXTRP,X) C C This routine tests the input data, initializes the labeled C common blocks, and generates the first mesh. Check C eigenfunction tolerances iff JOB(1) is True , C XEF(*) iff JOB(2) is True, C NUMT, T(*) iff JOB(3) is True , C C .. Parameters .. double precision ZERO,HUNDRD parameter (ZERO=0.0,HUNDRD=100.0) C .. C .. Scalar Arguments .. integer N,NEV,NEXTRP,NUMT C .. C .. Array Arguments .. double precision CONS(*),T(*),TOL(*),X(*),XEF(*) integer INDXEV(*) logical JOB(*) C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision UFLOW,URN integer I,K C .. C .. Intrinsic Functions .. intrinsic LOG10,MAX,MIN C .. C .. Common blocks .. common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. C .. Data statements .. ************************************************************************ * In the following DATA statement, initialize URN to an estimate for * * the unit roundoff and UFLOW to a value somewhat less than * * -ln(underflow). E.g., * * for IEEE double precision use URN = 2.D-16, UFLOW = 650; * * for VAXen double precision use URN = 1.D-17, UFLOW = 85; * * for Crays (single precision) use URN = 7.D-15, UFLOW = 5000. * * Exact values are not at all critical. * * Here, we assume IEEE double precision: * * * data URN/2.D-16/,UFLOW/650.0/ C .. C*********************************************************************** U = URN UNDER = UFLOW C C Initialize. C A1 = CONS(1) A1P = CONS(2) A2 = CONS(3) A2P = CONS(4) A = CONS(7) B1 = CONS(5) B2 = CONS(6) B = CONS(8) NCOEFF = 0 FLAG = 0 C C Test input. C if (AFIN .and. BFIN .and. (A.ge.B)) FLAG = -34 if (TOL(1).le.ZERO) FLAG = -35 if (TOL(2).lt.HUNDRD*U) FLAG = -36 if (JOB(1)) then if (TOL(3).le.ZERO) FLAG = -35 if (TOL(4).lt.HUNDRD*U) FLAG = -36 if (TOL(5).le.ZERO) FLAG = -35 if (TOL(6).lt.HUNDRD*U) FLAG = -36 end if if (JOB(2)) then if (N.eq.1) then FLAG = -30 else if (AFIN .and. (XEF(2).le.A)) FLAG = -39 do 10 I = 3,N - 1 if (XEF(I-1).ge.XEF(I)) FLAG = -39 10 continue if (BFIN .and. (XEF(N-1).gt.B)) FLAG = -39 end if if ((.not.AFIN) .and. (XEF(2).ge.ZERO)) FLAG = -39 if ((.not.BFIN) .and. (XEF(N-1).le.ZERO)) FLAG = -39 end if if ((JOB(2).or.JOB(3)) .and. (NEV.gt.0)) then do 20 I = 1,NEV if (INDXEV(I).lt.0) FLAG = -37 20 continue end if if (JOB(3)) then if (NUMT.le.0) FLAG = -38 do 30 I = 2,NUMT if (T(I).le.T(I-1)) FLAG = -39 30 continue end if if (FLAG.lt.0) return C C Set MAXEXT, the maximum number of extrapolations allowed, and C MAXINT, the maximum number of intervals in X(*) allowed when C mesh is chosen by START. C C IMPORTANT NOTE: the size of various fixed arrays in this package C depends on the value of MAXEXT in this FORTRAN77 implementation. C If MAXEXT is increased, then more storage may have to be allocated C to the columns of R(*,*) in EXTRAP. C MAXEXT = 6 MAXINT = 31 C C Calculate maximum number of columns in extrapolation table C and the maximum number of levels allowed. C K = -LOG10(TOL(2)) I = MAX(K+3,0) NEXTRP = MIN(MAX(3,I/2),MAXEXT) C C Calculate the initial mesh. C if (N.gt.0) then NXINIT = N else NXINIT = MIN(2*NEXTRP+3,MAXINT) if (JOB(1)) N = NXINIT end if if (JOB(2)) then A = XEF(1) B = XEF(NXINIT) do 40 I = 1,NXINIT X(I) = XEF(I) 40 continue end if return end subroutine START C----------------------------------------------------------------------- subroutine STEP(X,H,EV,PX,RX,TAU,OMEGA,HOMEGA,PSI,DPSI,SCLOG,MODE) C C Evaluate the coefficient functions, the scaled basis function PSI, C its derivative DPSI, and the log of the scale factor SCLOG. C C C .. Parameters .. double precision ZERO,HNDRTH,HALF,ONE,TWO,SIX,TWELVE,TWENTY parameter (ZERO=0.0,HNDRTH=.01,HALF=0.5D0,ONE=1.0,TWO=2.0,SIX=6.0, + TWELVE=12.0,TWENTY=20.0) C .. C .. Scalar Arguments .. double precision DPSI,EV,H,HOMEGA,OMEGA,PSI,PX,RX,SCLOG,TAU,X integer MODE C .. C .. Scalars in Common .. double precision A,A1,A1P,A2,A2P,B,B1,B2,CUTOFF,U,UNDER integer FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT C logical AFIN,BFIN,COUNTZ,LNF C .. C .. Arrays in Common .. double precision CP(2),CR(2),D(4,2),EMU(2),EP(2),EQLNF(2),ER(2), + ETA(2,2),PNU(2) integer KCLASS(2) C logical LC(2),LFLAG(6),OSC(2),REG(2) C .. C .. Local Scalars .. double precision DX,FP,FR,OVER,QX,T,TMU,Z C .. C .. External Subroutines .. cc external COEFF C .. C .. Intrinsic Functions .. intrinsic ABS,COS,LOG,MAX,MIN,SIN,SQRT,TANH C .. C .. Common blocks .. common /SLCLSS/CP,CR,CUTOFF,D,EMU,EP,EQLNF,ER,ETA,PNU,KCLASS common /SLINT/FLAG,LEVEL,MAXEXT,MAXINT,MAXLVL,NCOEFF,NSGNF,NXINIT C common /SLLOG/AFIN,BFIN,COUNTZ,LFLAG,LNF,LC,OSC,REG common /SLREAL/A1,A1P,A2,A2P,B1,B2,A,B,U,UNDER C .. C .. Data statements .. data OVER/1.D8/ C .. C C Evaluate the coefficient functions at X and calculate TAU. The C error flag FLAG is zero for a successful calculation; if p(x) C or r(x) are zero, then FLAG is set to -15. If the argument for C a trig function exceeds OVER then FLAG is set to -10. C Proceed normally when Mode = 0; when Mode = 1 or 2 use the C change of variable for "hard" problems; when Mode = 3 or 4 use C the change of variable t = -1/x near infinity. C if (MODE.eq.0) then call COEFF(X,PX,QX,RX) else if (MODE.gt.2) then T = X X = -ONE/T call COEFF(X,PX,QX,RX) T = T*T PX = T*PX QX = QX/T RX = RX/T else T = X if (ETA(1,MODE).eq.ONE) then DX = D(1,MODE)*ABS(T) else DX = D(1,MODE)* (ABS(T))** (ONE/ETA(1,MODE)) end if if (MODE.eq.1) then Z = A + DX else Z = B - DX end if call COEFF(Z,PX,QX,RX) end if end if NCOEFF = NCOEFF + 1 if ((PX.eq.ZERO) .or. (RX.eq.ZERO)) then FLAG = -15 return end if if ((MODE.eq.1) .or. (MODE.eq.2)) then if (EMU(MODE).eq.HALF) then TMU = ABS(T) else TMU = (T*T)**EMU(MODE) end if FP = CP(MODE) if (EP(MODE).ne.ZERO) FP = FP*DX**EP(MODE) FR = CR(MODE) if (ER(MODE).ne.ZERO) FR = FR*DX**ER(MODE) PX = PX*TMU/FP QX = (QX/FR-D(3,MODE)/T**2)*TMU RX = RX*TMU/FR end if TAU = (EV*RX-QX)/PX OMEGA = SQRT(ABS(TAU)) HOMEGA = H*OMEGA SCLOG = ZERO C C Evaluate the scaled basis functions. C if (HOMEGA.gt.HNDRTH) then if (TAU.gt.ZERO) then if (HOMEGA.gt.OVER) then FLAG = -10 return end if DPSI = COS(HOMEGA) PSI = SIN(HOMEGA)/OMEGA else SCLOG = HOMEGA if (HOMEGA.lt.UNDER) then T = TANH(HOMEGA) DPSI = ONE/ (ONE+T) PSI = T*DPSI/OMEGA else SCLOG = MIN(SCLOG,TWO*UNDER) DPSI = HALF PSI = DPSI/OMEGA end if end if else T = TAU*H*H DPSI = ONE + T* (T/TWELVE-ONE)/TWO PSI = H* (ONE+T* (T/TWENTY-ONE)/SIX) if (T.lt.ZERO) then T = MAX(ABS(PSI),ABS(DPSI)) SCLOG = LOG(T) PSI = PSI/T DPSI = DPSI/T end if end if return end subroutine STEP C----------------------------------------------------------------------- subroutine ZZERO(B,C,FB,FC,ABSERR,RELERR,IFLAG,X) C C C ZZERO computes a root of F. The method used is a combination of C bisection and the secant rule. This code is adapted from one in C the text "Foundations of Numerical Computing" written by Allen, C Pruess, and Shampine. C C Input parameters: C B,C = values of X such that F(B)*F(C) .LE. 0. C FB,FC = values of F at input B and C, resp. C ABSERR,RELERR = absolute and relative error tolerances. The C stopping criterion is: C ABS(B-C) .LE. 2.0*MAX(ABSERR,ABS(B)*RELERR). C Output parameters: C B,C = see IFLAG returns. C FB = value of final residual F(B). C IFLAG = 0 for normal return; F(B)*F(C) .LT. 0 and the C stopping criterion is met (or F(B)=0). B always C satisfies ABS(F(B)) .LE. ABS(F(C)). C = 1 if too many function evaluations were made; in this version C 200 are allowed. C =-2 if F(B)*F(C) is positive on input. C C Local variables: C C Internal constants C C C Initialization. C C .. Parameters .. double precision ZERO,ONE,TWO,EIGHT integer MAXF parameter (ZERO=0.0,ONE=1.0,TWO=2.0,EIGHT=8.0,MAXF=200) C .. C .. Scalar Arguments .. double precision ABSERR,B,C,FB,FC,RELERR integer IFLAG C .. C .. Array Arguments .. double precision X(*) C .. C .. Local Scalars .. double precision A,ACMB,CMB,FA,P,Q,TOL,WIDTH integer KOUNT,MU,NF C .. C .. External Subroutines .. cc external SHOOT C .. C .. Intrinsic Functions .. intrinsic ABS,MAX,SIGN C .. KOUNT = 0 WIDTH = ABS(B-C) A = C FA = FC if (SIGN(ONE,FA).eq.SIGN(ONE,FB)) then IFLAG = -2 return end if FC = FA NF = 2 20 if (ABS(FC).lt.ABS(FB)) then C C Interchange B and C so that ABS(F(B)) .LE. ABS(F(C)). C A = B FA = FB B = C FB = FC C = A FC = FA end if CMB = (C-B)/TWO ACMB = ABS(CMB) TOL = MAX(ABSERR,ABS(B)*RELERR) C C Test stopping criterion and function count. C if (ACMB.le.TOL) then IFLAG = 0 return end if if (NF.ge.MAXF) then IFLAG = 1 return end if C C Calculate new iterate implicitly as B+P/Q where we arrange C P .GE. 0. The implicit form is used to prevent overflow. C P = (B-A)*FB Q = FA - FB if (P.lt.ZERO) then P = -P Q = -Q end if C C Update A; check if reduction in the size of bracketing interval is C satisfactory. If not, bisect until it is. C A = B FA = FB KOUNT = KOUNT + 1 if (KOUNT.ge.4) then if (EIGHT*ACMB.ge.WIDTH) then B = B + CMB go to 30 end if KOUNT = 0 WIDTH = ACMB end if C C Test for too small a change. C if (P.le.ABS(Q)*TOL) then C C Increment by tolerance. C B = B + SIGN(TOL,CMB) else C C Root ought to be between B and (C+B)/2. C if (P.lt.CMB*Q) then C C Use secant rule. C B = B + P/Q else C C Use bisection. C B = B + CMB end if end if C C Have completed computation for new iterate B. C 30 call SHOOT(B,X,MU,FB) NF = NF + 1 if (ABS(FB).eq.ZERO) then IFLAG = 0 C = B FC = FB return end if if (SIGN(ONE,FB).eq.SIGN(ONE,FC)) then C = A FC = FA end if go to 20 end subroutine ZZERO end module SLEDGEMD SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'sleign' then mkdir 'sleign' fi cd 'sleign' if test -f 'sleignmd.f' then echo shar: will not over-write existing file "'sleignmd.f'" else cat << SHAR_EOF > 'sleignmd.f' module sleignmd private public:: SLEIGN contains SUBROUTINE SLEIGN(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2, 1 NUMEIG,EIG,TOL,IFLAG,ISLFUN,SLFUN) INTEGER INTAB,NUMEIG,IFLAG,ISLFUN DOUBLE PRECISION A,B,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2,EIG,TOL DOUBLE PRECISION SLFUN(*) C ********** C C This subroutine is designed for the calculation of a specified C eigenvalue, EIG, of a Sturm-Liouville problem in the form C C (p(x)*y'(x))' + (q(x) + eig*r(x))*y(x) = 0 on (a,b) C C for user-supplied coefficient functions P, Q, and R. C The problem may be either regular or singular. In the C regular case, boundary conditions of the form C C a1*y(a) + a2*p(a)*y'(a) = 0 C b1*y(b) + b2*p(b)*y'(b) = 0 C C are prescribed by specifying the numbers A1, A2, B1, and B2. C The index of the desired eigenvalue is specified in NUMEIG C and its requested accuracy in TOL. Initial data for the C associated eigenfunction are also computed along with values C at selected points, if desired, in array SLFUN. C C The SUBROUTINE statement is C C SUBROUTINE sleign(a,b,intab,p0ata,qfata,p0atb,qfatb,a1,a2,b1,b2, C numeig,eig,tol,iflag,islfun,slfun) C C where C C A and B are input variables defining the interval. If the C interval is finite, A must be less than B. (See INTAB below.) C C INTAB is an integer input variable specifying the nature of the C interval. It can have four values. C C INTAB = 1 - A and B are finite. C INTAB = 2 - A is finite and B is infinite (+). C INTAB = 3 - A is infinite (-) and B is finite. C INTAB = 4 - A is infinite (-) and B is infinite (+). C C If either A or B is infinite, it is classified singular and C its value is ignored. C C P0ATA, QFATA, P0ATB, and QFATB are input variables set to C 1.0 or -1.0 as the following properties of P, Q, and R at C the interval endpoints are true or false, respectively. C C P0ATA - p(a) is zero. (If true, A is singular.) C QFATA - q(a) and r(a) are finite. (If false, A is singular.) C P0ATB - p(b) is zero. (If true, B is singular.) C QFATB - q(b) and r(b) are finite. (If false, B is singular.) C C A1 and A2 are input variables set to prescribe the boundary C condition at A. Their values are ignored if A is singular. C C B1 and B2 are input variables set to prescribe the boundary C condition at B. Their values are ignored if B is singular. C C NUMEIG is an integer variable. On input, it should be set to C the index of the desired eigenvalue (increasing sequence). C On output, it is unchanged unless the problem (apparently) C lacks NUMEIG eigenvalues, in which case it is reset to the C index of the largest eigenvalue. C C EIG is a variable set on input to 0.0 or to an initial guess of C the eigenvalue. If EIG is set to 0.0, SLEIGN will generate C the initial guess. On output, EIG holds the calculated C eigenvalue if IFLAG (see below) signals success. C C TOL is a variable set on input to the desired accuracy of the C eigenvalue. On output, TOL is reset to the accuracy estimated C to have been achieved if IFLAG (see below) signals success. C This accuracy estimate is absolute if EIG is less than one C in magnitude, and relative otherwise. In addition, prefixing C TOL with a negative sign, removed after interrogation, serves C as a flag to request trace output from the calculation. C C IFLAG is an integer output variable set as follows. C C IFLAG = 1 - successful problem solution. C IFLAG = 2 - improper input parameters. C IFLAG = 3 - NUMEIG exceeds actual number of eigenvalues. C IFLAG = 4 - some uncertainty about accuracy estimate TOL. C IFLAG = 5 - convergence too slow, best results returned. C IFLAG = 6 - failure, integrator could not complete. C C ISLFUN is an integer input variable set to the number of C selected eigenfunction values desired. If no values are C desired, set ISLFUN zero or negative. C C SLFUN is an array of length at least 9. On output, the first 9 C locations contain the integration interval and initial data C that completely determine the eigenfunction. C C SLFUN(1) - point where two pieces of eigenfunction Y match. C SLFUN(2) - left endpoint XAA of the (truncated) interval. C SLFUN(3) - value of THETA at XAA. (Y = RHO*sin(THETA)) C SLFUN(4) - value of F at XAA. (RHO = exp(F)) C SLFUN(5) - right endpoint XBB of the (truncated) interval. C SLFUN(6) - value of THETA at XBB. C SLFUN(7) - value of F at XBB. C SLFUN(8) - final value of integration accuracy parameter EPS. C SLFUN(9) - the constant Z in the polar form transformation. C C F(XAA) and F(XBB) are chosen so that the eigenfunction is C continuous in the interval (XAA,XBB) and has weighted (by R) C L2-norm of 1.0 on the interval. If ISLFUN is positive, then C on input the further ISLFUN locations of SLFUN specify the C points, in ascending order, where the eigenfunction values C are desired and on output contain the values themselves. C C Subprograms called C C user-supplied ..... p,q,r C C sleign-supplied ... alfbet,dxdt,epslon,esteig,estpac,f,gerk C C This version dated 5/18/89. C Paul B. Bailey, Sandia Laboratories, Albuquerque C Burton S. Garbow, Argonne National Laboratory C C ********** C .. Scalars in Common .. INTEGER INTSAV LOGICAL EIGF DOUBLE PRECISION ASAV,BSAV,C1,C2,EIGSAV,Z C .. C .. Local Scalars .. INTEGER I,IA,IB,IMAX,IMIN,IOUT,IP,J,JFLAG,KFLAG,LFLAG,MF,ML, 1 NEIG,NMID LOGICAL AOK,BOK,BRACKT,CHNGAB,CHNGM,CONVRG,FYNYT,FYNYT1, 1 LIMIT,LOGIC,NEWTON,ONEDIG,PRIN,THEGT0,THELT0 DOUBLE PRECISION AA,AAA,ALFA,ASL,ASR,BB,BBB,BETA, 1 C,CHNG,CL,CR,DAV,DE,DEDW,DEN,DERIVL,DERIVR,DIST, 2 DPSIL,DPSIPL,DPSIPR,DPSIR,DT,DTHDA,DTHDAA,DTHDB, 3 DTHDBB,DTHDE,DTHDEA,DTHDEB,DTHETA,DTHOLD,E,EEE, 4 EIGLO,EIGLT,EIGRT,EIGUP,EL,ELIM,EMAX,EMIN,EOLD,EPS,EPSMIN, 5 ER1,ER2,ESTERR,FLO,FMAX,FUP,GMAX,GUESS,H,ONE,PI,PIN, 6 PSIL,PSIPL,PSIPR,PSIR,PX,QAV,QX,RATIO,RAV,RAY,RX, 7 SL,SQL,SQR,SR,T,T1,T2,T3,TAU,TEMP,THRESH,TMAX,TMID,TMP, 8 U,UL,UR,V,WL,X,X50,XAA,XBB,XBC,XMID,XSAV,ZAV C .. C .. Local Arrays .. INTEGER IWORK(5) DOUBLE PRECISION DS(98),ERL(3),ERR(3),PS(99),QS(99),RS(99), 1 WORK(27),YL(3),YR(3) C .. C .. External Functions .. DOUBLE PRECISION P,Q,R EXTERNAL P,Q,R C .. C .. External Subroutines .. cc EXTERNAL ALFBET,DXDT,ESTEIG,ESTPAC,F,GERK C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,COS,EXP,INT,LOG,MAX,MIN,SIGN,SIN,TAN C .. C .. Common blocks .. COMMON /DATADT/ASAV,BSAV,C1,C2,INTSAV COMMON /DATAF/EIGSAV,EIGF COMMON /ZEE/Z C .. C Set constants EPSMIN, the computer unit roundoff error, and PI. C (Variable ONE set to 1.0 eases precision conversion.) C ONE = 1.0 EPSMIN = EPSLON(ONE) PI = 4.0*ATAN(ONE) C C Set output device number. C IOUT = 8 C C Check input parameters for errors. If errors, return IFLAG=2. C LOGIC = TOL.NE.0.0 .AND. 1.LE.INTAB .AND. INTAB.LE.4 .AND. 1 P0ATA*QFATA*P0ATB*QFATB*NUMEIG.NE.0.0 IF (INTAB.EQ.1) LOGIC = LOGIC .AND. A.LT.B IF (.NOT.LOGIC) THEN IFLAG = 2 RETURN END IF C C Set PRIN = .true. to trigger trace printout of successive steps. C PRIN = .FALSE. IF (TOL.LT.0.0) PRIN = .TRUE. C C Set EPS to the (initial) integration accuracy. C EPS = 0.001 C C AOK (BOK) signals, if true, that endpoint A (B) is not singular. C AOK = INTAB.LT.3 .AND. P0ATA.LT.0.0 .AND. QFATA.GT.0.0 BOK = (INTAB.EQ.1 .OR. INTAB.EQ.3) .AND. 1 P0ATB.LT.0.0 .AND. QFATB.GT.0.0 NEIG = ABS(NUMEIG) - 1 C C Initial C1 and C2, used in the mapping between X and T intervals. C C1 = 1.0 C2 = 0.0 C DO (SAVE-INPUT-DATA) ASAV = A BSAV = B INTSAV = INTAB TAU = ABS(TOL) C END (SAVE-INPUT-DATA) C C Evaluate P, Q, R to obtain preliminary information about the C differential equation. C C DO (SAMPLE-COEFFICIENTS) THRESH = 1.0E+17 10 CONTINUE CALL DXDT(EPSMIN,TEMP,X50) PX = P(X50) QX = Q(X50) RX = R(X50) PS(50) = PX QS(50) = QX/PX RS(50) = RX/PX C C DAV,QAV,RAV are used in special case estimation when NUMEIG = 1,2. C EMIN = min(-Q/R), achieved at X for index value IMIN. C EMAX = max(-Q/R), achieved at X for index value IMAX. C MF and ML are the least and greatest index values, respectively. C DAV = 0.0 QAV = 0.0 RAV = 0.0 XSAV = X50 EMIN = THRESH EMAX = -THRESH IF (RX.NE.0.0) THEN EMIN = -QX/RX EMAX = EMIN IMIN = 50 IMAX = 50 END IF H = 0.9/40.0 DO 20 I=49,1,-1 IF (I.GE.10) T = H*(I-50) IF (I.LT.10) T = T - 0.75*(1.0+T) CALL DXDT(T,TEMP,X) PX = P(X) QX = Q(X) RX = R(X) PS(I) = PX QS(I) = QX/PX RS(I) = RX/PX DS(I) = XSAV - X DAV = DAV + DS(I) QAV = QAV + DS(I)*(0.5*(QS(I)+QS(I+1))-QAV)/DAV RAV = RAV + DS(I)*(0.5*(RS(I)+RS(I+1))-RAV)/DAV XSAV = X C C Try to avoid overflow by stopping when functions are large near A. C FYNYT = (ABS(RX)+ABS(QX)+1.0/PX).LE.THRESH IF (RX.NE.0.0) THEN IF (-QX/RX.LT.EMIN) THEN EMIN = -QX/RX IMIN = I END IF IF (-QX/RX.GT.EMAX) THEN EMAX = -QX/RX IMAX = I END IF END IF MF = I IF (.NOT.FYNYT) GO TO 30 20 CONTINUE 30 CONTINUE AAA = T IF (AOK) AAA = -1.0 XSAV = X50 DO 40 I=51,99 IF (I.LE.90) T = H*(I-50) IF (I.GT.90) T = T + 0.75*(1.0-T) CALL DXDT(T,TEMP,X) PX = P(X) QX = Q(X) RX = R(X) PS(I) = PX QS(I) = QX/PX RS(I) = RX/PX DS(I-1) = X - XSAV DAV = DAV + DS(I-1) QAV = QAV + DS(I-1)*(0.5*(QS(I-1)+QS(I))-QAV)/DAV RAV = RAV + DS(I-1)*(0.5*(RS(I-1)+RS(I))-RAV)/DAV XSAV = X C C Try to avoid overflow by stopping when functions are large near B. C FYNYT1 = (ABS(QX)+ABS(RX)+1.0/PX).LE.THRESH IF (RX.NE.0.0) THEN IF (-QX/RX.LT.EMIN) THEN EMIN = -QX/RX IMIN = I END IF IF (-QX/RX.GT.EMAX) THEN EMAX = -QX/RX IMAX = I END IF END IF ML = I - 1 IF (.NOT.FYNYT1) GO TO 50 40 CONTINUE 50 CONTINUE BBB = T IF (BOK) BBB = 1.0 LOGIC = C1.EQ.1.0 .AND. (.NOT.FYNYT .OR. .NOT.FYNYT1) C C Modify (T,X) transformation corresponding to truncated interval. C IF (LOGIC) THEN C1 = 0.5*(BBB-AAA) C2 = 0.5*(AAA+BBB) GO TO 10 END IF C C Estimate upper bound ELIM for EIG such that boundary conditions C can be satisfied. C ELIM = EMAX + 1.0 IF (INTAB.EQ.3 .OR. (P0ATA.GT.0.0 .AND. QFATA.LT.0.0)) THEN IF (-QS(MF)/RS(MF).LE.ELIM) THEN ELIM = -QS(MF)/RS(MF) IMAX = MF END IF END IF IF (INTAB.EQ.2 .OR. (P0ATB.GT.0.0 .AND. QFATB.LT.0.0)) THEN IF (-QS(ML)/RS(ML).LE.ELIM) THEN ELIM = -QS(ML)/RS(ML) IMAX = ML END IF END IF IF (INTAB.EQ.4) THEN ELIM = MIN(ELIM,-QS(MF)/RS(MF),-QS(ML)/RS(ML)) IF (-QS(MF)/RS(MF).EQ.ELIM) IMAX = MF IF (-QS(ML)/RS(ML).EQ.ELIM) IMAX = ML END IF ELIM = ELIM - EPSMIN IF (ELIM.EQ.0.0) ELIM = -EPSMIN LIMIT = ELIM.LE.EMAX C END (SAMPLE-COEFFICIENTS) PIN = (NEIG+1)*PI IF (EIG.EQ.0.0) THEN C DO (ESTIMATE-EIG) CALL ESTEIG(MF,ML,LIMIT,ELIM,EMAX,EMIN,PIN,QS,RS,DS,PS, 1 IMAX,IMIN,EEE,EIG,IA,IB,EL,WL,DEDW) C END (ESTIMATE-EIG) END IF GUESS = EIG C DO (SET-INITIAL-INTERVAL-AND-MATCHPOINT) IF (GUESS.NE.0.0) THEN C C Reduce overly large guess for EIG to upper bound if necessary. C IF (LIMIT .AND. EIG.GT.ELIM) EIG = ELIM EEE = EIG C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(MF,ML,EEE,PIN,QS,RS,DS,PS, 1 IA,IB,IP,TEMP,U,TMP) C END (ESTIMATE-PHASE-ANGLE-CHANGE) END IF C C Choose initial interval as large as possible that avoids overflow. C IA and IB are boundary indices for nonnegativity of EIG*R+Q. C AA = -1.0 IF (.NOT.AOK) THEN AA = H*(IA-50) IF (IA.LT.10) AA = -1.0 + 0.1/4.0**(10-IA) END IF BB = 1.0 IF (.NOT.BOK) THEN BB = H*(IB-50) IF (IB.GT.90) BB = 1.0 - 0.1/4.0**(IB-90) END IF AA = AA + 0.6*(AAA-AA) BB = BB + 0.6*(BBB-BB) C C Determine boundary values ALFA and BETA for theta at A and B. C Z = 1.0 CALL ALFBET(A,INTAB,AA,A1,A2,EEE,P0ATA,QFATA,AOK, 1 ALFA,KFLAG,DERIVL) CALL ALFBET(B,INTAB,BB,B1,B2,EEE,P0ATB,QFATB,BOK, 1 BETA,JFLAG,DERIVR) IF (.NOT.BOK) BETA = PI - BETA C C Take boundary conditions into account in estimation of EIG. C PIN = PIN + BETA - ALFA - PI IF (GUESS.EQ.0.0) EEE = EL + DEDW*(PIN-WL) C C Subroutine ESTPAC must be called again because PIN has changed. C C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(MF,ML,EEE,PIN,QS,RS,DS,PS,IA,IB,IP,TEMP,U,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) C C Choose the constant Z. C IF (U.GT.0.0) Z = ZAV/U C C Reset boundary values ALFA and BETA. C CALL ALFBET(A,INTAB,AA,A1,A2,EEE,P0ATA,QFATA,AOK, 1 ALFA,KFLAG,DERIVL) CALL ALFBET(B,INTAB,BB,B1,B2,EEE,P0ATB,QFATB,BOK, 1 BETA,JFLAG,DERIVR) IF (.NOT.BOK) BETA = PI - BETA IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' alfa=',ALFA,' beta=',BETA C C Special case formula for estimation of EIG when NUMEIG = 1,2. C IF (U.EQ.0.0 .AND. NEIG.LE.1 .AND. (BETA+NEIG*PI).LT.ALFA) THEN XBC = MAX(-1.0/TAN(ALFA),1.0/TAN(BETA)) EEE = -(XBC*XBC-QAV)/RAV DEDW = XBC*(1.0+XBC*XBC)/RAV END IF C C Choose initial matching point TMID. C TMID = H*(IP-50) IF (TMID.LT.-0.8) TMID = -0.4 IF (TMID.GT.0.8) TMID = 0.4 IF (PRIN) WRITE(IOUT,'(A,E15.7,A,F11.8,A,E15.7)') 1 ' estim=',EEE,' tmid=',TMID,' z=',Z IF (PRIN) WRITE(IOUT,'(A,F11.8,A,F11.8,A,F11.8,A,F11.8)') 1 ' aaa=',AAA,' aa=',AA,' bb=',BB,' bbb=',BBB C END (SET-INITIAL-INTERVAL-AND-MATCHPOINT) C C End preliminary work, begin main task of computing EIG. C C Logical variables have the following meanings if true. C AOK - endpoint A is not singular. C BOK - endpoint B is not singular. C CHNGM - matching point TMID should be changed. C CHNGAB - one or both endpoints should be moved farther out. C BRACKT - EIG has been bracketed. C CONVRG - convergence test for EIG has been successfully passed. C NEWTON - Newton iteration may be employed. C THELT0 - lower bound for EIG has been found. C THEGT0 - upper bound for EIG has been found. C LIMIT - upper bound exists with boundary conditions satisfied. C ONEDIG - most significant digit can be expected to be correct. C EIGF - derivative argument is in original coordinate system. C EIG = EEE EIGF = .FALSE. CHNGM = .FALSE. CHNGAB = .TRUE. 60 CONTINUE IF (CHNGAB) THEN C DO (INITIAL-IZE) CHNGAB = .FALSE. BRACKT = .FALSE. CONVRG = .FALSE. THELT0 = .FALSE. THEGT0 = .FALSE. EIGLO = 0.0 EIGLT = 0.0 EIGRT = 0.0 EIGUP = 0.0 DTHOLD = 0.0 C END (INITIAL-IZE) END IF C C Recompute boundary conditions at singular endpoint(s). C C DO (RESET-BOUNDARY-CONDITIONS) DERIVL = 0.0 IF (.NOT.AOK) CALL ALFBET(A,INTAB,AA,A1,A2,EIG, 1 P0ATA,QFATA,.FALSE.,ALFA,KFLAG,DERIVL) DERIVR = 0.0 IF (.NOT.BOK) THEN CALL ALFBET(B,INTAB,BB,B1,B2,EIG,P0ATB,QFATB,.FALSE., 1 BETA,JFLAG,DERIVR) BETA = PI - BETA END IF IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' alfa=',ALFA,' beta=',BETA C END (RESET-BOUNDARY-CONDITIONS) 70 CONTINUE IF (EIG.NE.GUESS .AND. .NOT.BRACKT) THEN C C If initial guess was supplied, check that boundary conditions C can be satisfied at singular endpoints. If not, try for C slightly lower EIG consistent with boundary conditions. C 80 CONTINUE IF (.NOT.AOK) CALL ALFBET(A,INTAB,AA,A1,A2,EIG, 1 P0ATA,QFATA,.FALSE.,TMP,KFLAG,TEMP) IF (.NOT.BOK) CALL ALFBET(B,INTAB,BB,B1,B2,EIG, 1 P0ATB,QFATB,.FALSE.,TMP,JFLAG,TEMP) IF (KFLAG*JFLAG.NE.1) THEN IF (THEGT0) EIG = 0.6*EIG + 0.4*EIGUP IF (THELT0) EIG = 0.6*EIG + 0.4*EIGLO IF (THELT0 .AND. EIGLO.LT.ELIM) EIGUP = ELIM GO TO 80 END IF END IF C DO (OBTAIN-DTHETA-WITH-ONE-CORRECT-DIGIT) 90 CONTINUE IF (PRIN) WRITE(IOUT,'(/A,E22.14,A,E10.3,A,E10.3)') 1 ' guess=',EIG,' eps=',EPS,' tmid=',TMID C DO (INTEGRATE-FOR-DTHETA) C DO (SET-INITIAL-CONDITIONS) DTHDEA = DERIVL DTHDAA = 0.0 IF (.NOT.AOK) THEN CALL DXDT(AA,DT,X) PX = P(X)/Z QX = Q(X)/Z RX = R(X)/Z C = EIG*RX + QX DTHDAA = -(COS(ALFA)**2/PX + 1 C*SIN(ALFA)**2)*DT C C Two special cases for DTHDAA. C IF (C.GE.0.0 .AND. P0ATA.LT.0.0 .AND. 1 QFATA.LT.0.0) DTHDAA = DTHDAA + 1 ALFA*DT/(X-A) IF (C.GE.0.0 .AND. P0ATA.GT.0.0 .AND. 1 QFATA.GT.0.0) DTHDAA = DTHDAA + 2 (ALFA-0.5*PI)*DT/(X-A) END IF DTHDEB = -DERIVR DTHDBB = 0.0 IF (.NOT.BOK) THEN CALL DXDT(BB,DT,X) PX = P(X)/Z QX = Q(X)/Z RX = R(X)/Z C = EIG*RX + QX DTHDBB = -(COS(BETA)**2/PX + 1 C*SIN(BETA)**2)*DT C C Two special cases for DTHDBB. C IF (C.GE.0.0 .AND. P0ATB.LT.0.0 .AND. 1 QFATB.LT.0.0) DTHDBB = DTHDBB + 2 (PI-BETA)*DT/(B-X) IF (C.GE.0.0 .AND. P0ATB.GT.0.0 .AND. 1 QFATB.GT.0.0) DTHDBB = DTHDBB + 2 (0.5*PI-BETA)*DT/(B-X) END IF TMAX = TMID GMAX = ABS(DTHDEA) EIGSAV = EIG C END (SET-INITIAL-CONDITIONS) C T C YL = (theta,d(theta)/d(eig),d(theta)/da) C T = AA YL(1) = ALFA YL(2) = DTHDEA YL(3) = 0.0 C C Use integrator in one-step mode towards change to different TMID. C LFLAG = 1 IF (CHNGM) LFLAG = -1 100 CONTINUE CALL GERK(F,3,YL,T,TMID,EPS,EPS,LFLAG,ERL, 1 WORK,IWORK) IF (LFLAG.EQ.-2 .AND. T.GT.-0.8 .AND. 1 ABS(YL(2)).GT.GMAX) THEN TMAX = T GMAX = ABS(YL(2)) END IF IF (LFLAG.EQ.3) PRINT*, 1 'After 9000 function evaluations GERK reached T=',T IF (LFLAG.EQ.3 .OR. LFLAG.EQ.-2) GO TO 100 IF (LFLAG.GT.3) THEN IFLAG = 6 RETURN END IF DTHDA = DTHDAA*EXP(-2.0*YL(3)) C T C YR = (theta,d(theta)/d(eig),d(theta)/db) C T = BB YR(1) = BETA + PI*NEIG YR(2) = DTHDEB YR(3) = 0.0 C C Use integrator in one-step mode towards change to different TMID. C LFLAG = 1 IF (CHNGM) LFLAG = -1 110 CONTINUE CALL GERK(F,3,YR,T,TMID,EPS,EPS,LFLAG,ERR, 1 WORK,IWORK) IF (LFLAG.EQ.-2 .AND. T.LT.0.8 .AND. 1 ABS(YR(2)).GT.GMAX) THEN TMAX = T GMAX = ABS(YR(2)) END IF IF (LFLAG.EQ.3) PRINT*, 1 'After 9000 function evaluations GERK reached T=',T IF (LFLAG.EQ.3 .OR. LFLAG.EQ.-2) GO TO 110 IF (LFLAG.GT.3) THEN IFLAG = 6 RETURN END IF DTHDB = DTHDBB*EXP(-2.0*YR(3)) C C DTHETA measures theta difference from left and right integrations. C DTHETA = YL(1) - YR(1) DTHDE = YL(2) - YR(2) ER1 = ERL(1) - ERR(1) ER2 = ERL(2) - ERR(2) TMID = TMAX C END (INTEGRATE-FOR-DTHETA) C C Define ONEDIG to try to be sure of one correct digit in DTHETA. C Redo integrations with tighter tolerance until ONEDIG is true. C ONEDIG = ABS(ER1).LE.0.1*ABS(DTHETA) .AND. 1 ABS(ER2).LE.0.1*ABS(DTHDE) NEWTON = ABS(DTHETA).LT.0.06 IF (NEWTON) THEN C DO (COMPUTE-CONVRG) C C Measure convergence after adding separate contributions to error. C T1 = ABS(DTHETA)+50.0*ABS(ER1) T2 = (1.0+AA)*ABS(DTHDA) T3 = (1.0-BB)*ABS(DTHDB) ESTERR = (T1+T2+T3)/ABS(DTHDE)/MAX(ONE,ABS(EIG)) CONVRG = ESTERR.LE.TAU IF (PRIN) WRITE(IOUT,'(A,L2)') 1 ' converge=',CONVRG IF (PRIN .AND. .NOT.CONVRG) 1 WRITE(IOUT,'(A,E15.7)') 2 ' estim. acc.=',ESTERR C END (COMPUTE-CONVRG) END IF IF (.NOT.ONEDIG .OR. 1 ABS(ER1).GT.0.01*ABS(DTHETA)) THEN C C Reduce local error criterion, but return IFLAG=5 if too small. C EPS = 0.05*EPS IF (EPS.LE.EPSMIN) THEN IFLAG = 5 RETURN END IF END IF IF (.NOT.(ONEDIG .OR. CONVRG)) GO TO 90 IF (ABS(DTHETA).LT.0.1) CHNGM = .FALSE. IF (PRIN) WRITE(IOUT,'(A,E15.7,A,E15.7)') 1 ' dtheta=',DTHETA,' dthde=',DTHDE IF (PRIN) WRITE(IOUT,'(/A,E15.7,A,E15.7)') 1 ' thetal=',YL(1),' thetar=',YR(1) C END (OBTAIN-DTHETA-WITH-ONE-CORRECT-DIGIT) C DO (SET-BRACKET-AND-FORM-NEWTON-ITERATES) C C EIG is bracketed when both THEGT0=.true. and THELT0=.true. C IF (DTHETA*DTHDE.GT.0.0) THEN IF (.NOT.THEGT0 .OR. EIG.LE.EIGUP) THEN THEGT0 = .TRUE. EIGUP = EIG FUP = DTHETA EIGRT = EIG - DTHETA/DTHDE END IF ELSE IF (.NOT.THELT0 .OR. EIG.GE.EIGLO) THEN THELT0 = .TRUE. EIGLO = EIG FLO = DTHETA EIGLT = EIG - DTHETA/DTHDE END IF END IF BRACKT = THELT0 .AND. THEGT0 IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' eigrt=',EIGRT,' eigup=',EIGUP IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' eiglt=',EIGLT,' eiglo=',EIGLO C END (SET-BRACKET-AND-FORM-NEWTON-ITERATES) IF (NEWTON) THEN CHNGM = .TRUE. IF (CONVRG) THEN CHNG = DTHDA*(-1.0-AA) - DTHDB*(1.0-BB) TEMP = (DTHETA+CHNG)/DTHDE EIG = EIG - TEMP TOL = ABS(TEMP)/MAX(ONE,ABS(EIG)) ELSE CHNGAB = T1.LT.0.5*(T2+T3) C C Move endpoint(s) out or take Newton step, according to CHNGAB. C IF (CHNGAB) THEN C DO (MOVE-ENDPOINTS) IF (T2.GT.T1 .AND. AA.GT.AAA) 1 AA = AA + 0.8*(-1.0-AA) IF (T3.GE.T1 .AND. BB.LT.BBB) 1 BB = BB + 0.8*(1.0-BB) AA = MAX(AA,AAA) BB = MIN(BB,BBB) IF ((AAA-AA).EQ.(BBB-BB)) THEN C C Cannot move endpoint(s) again. Store estimates and return IFLAG=5. C CHNG = (DTHDA-DTHDB)*(AAA-AA) TEMP = (DTHETA+CHNG)/DTHDE EIG = EIG - TEMP TOL = ABS(TEMP)/MAX(ONE,ABS(EIG)) IFLAG = 5 RETURN END IF EEE = EIG IF (PRIN) WRITE(IOUT,'(A,2E15.8)') 1 ' new endpoints ',AA,BB C END (MOVE-ENDPOINTS) ELSE EIG = EIG - DTHETA/DTHDE END IF END IF ELSE IF (BRACKT) THEN C C Obtain next estimate of EIG by bisection or linear interpolation. C FMAX = MAX(-FLO,FUP) EOLD = EIG RATIO = DTHETA/DTHOLD EIG = 0.5*(EIGLO+EIGUP) IF (FMAX.LE.1.5) THEN U = -FLO/(FUP-FLO) DIST = EIGUP - EIGLO EIG = EIGLO + U*DIST V = MIN(EIGLT,EIGRT) IF (EIG.LE.V) EIG = 0.5*(EIG+V) V = MAX(EIGLT,EIGRT) IF (EIG.GE.V) EIG = 0.5*(EIG+V) DE = EIG - EOLD CHNGAB = RATIO.GE.0.4 .AND. .NOT.(AOK.AND.BOK) IF (ABS(DE).LT.EPSMIN) THEN TOL = ABS(DE)/MAX(ONE,ABS(EIG)) IFLAG = 5 RETURN END IF END IF CHNGM = .NOT.CHNGM .AND. RATIO.GE.0.4 ELSE C DO (TRY-FOR-BRACKET) C C Take twice the Newton step in trying for a bracket. C IF (EIG.EQ.EEE) THEN IF (GUESS.NE.0.0) DEDW = 1.0/DTHDE CHNG = -(DEDW+1.0/DTHDE)*DTHETA IF (ABS(CHNG).GT.0.1*ABS(EIG)) 1 CHNG = -0.1*SIGN(EIG,DTHETA) ELSE CHNG = -2.0*DTHETA/DTHDE END IF LOGIC = EIG.NE.EEE .AND. DTHOLD.LT.0.0 .AND. 1 LIMIT .AND. CHNG.GT.(ELIM-EIG) IF (LOGIC) THEN CHNG = 0.99*(ELIM-EIG+EPSMIN) IF (CHNG.LT.EPSMIN) THEN C C If change is too small, EIG is presumed not to exist (IFLAG=3). C NUMEIG = NEIG - INT(-DTHETA/PI) IFLAG = 3 RETURN END IF C C Limit change in EIG to a factor of 10. C ELSE IF (ABS(CHNG).GT.(1.0+10.0*ABS(EIG))) THEN CHNG = SIGN(1.0+10.0*ABS(EIG),CHNG) ELSE IF (ABS(EIG).GE.1.0 .AND. 1 ABS(CHNG).LT.0.1*ABS(EIG)) THEN CHNG = 0.1*SIGN(EIG,CHNG) END IF EOLD = EIG EIG = EIG + CHNG C END (TRY-FOR-BRACKET) END IF END IF DTHOLD = DTHETA IF (.NOT.(CONVRG .OR. CHNGAB .OR. NEWTON)) GO TO 70 IF (.NOT.CONVRG) GO TO 60 IFLAG = 1 IF (PRIN) WRITE(IOUT,'(A,I7,A,E22.14,A,E10.3)') 1 ' numeig=',NUMEIG,' eig=',EIG,' tol=',TOL C DO (COMPUTE-EIGENFUNCTION-DATA) C C Convert from T to X values, fill 7 of first 9 locations of SLFUN. C CALL DXDT(TMID,TEMP,XMID) CALL DXDT(AA,TEMP,XAA) CALL DXDT(BB,TEMP,XBB) SLFUN(1) = XMID SLFUN(2) = XAA SLFUN(3) = ALFA SLFUN(5) = XBB SLFUN(6) = BETA + PI*NEIG SLFUN(8) = EPS SLFUN(9) = Z C C Compute SLFUN(4), SLFUN(7) towards normalizing the eigenfunction. C EIGSAV = EIG Z = -Z T = AA YL(1) = ALFA YL(2) = DTHDEA YL(3) = 0.0 LFLAG = 1 120 CONTINUE CALL GERK(F,3,YL,T,TMID,EPS,EPS,LFLAG,ERL,WORK,IWORK) IF (LFLAG.EQ.3) PRINT*, 1 'After 9000 function evaluations GERK reached T=',T IF (LFLAG.EQ.3) GO TO 120 T = BB YR(1) = BETA + PI*NEIG YR(2) = DTHDEB YR(3) = 0.0 LFLAG = 1 130 CONTINUE CALL GERK(F,3,YR,T,TMID,EPS,EPS,LFLAG,ERR,WORK,IWORK) IF (LFLAG.EQ.3) PRINT*, 1 'After 9000 function evaluations GERK reached T=',T IF (LFLAG.EQ.3) GO TO 130 Z = -Z SL = SIN(YL(1)) SR = SIN(YR(1)) CL = COS(YL(1)) CR = COS(YR(1)) UL = (YL(2)-DTHDEA*EXP(-2.0*YL(3)))*Z UR = (YR(2)-DTHDEB*EXP(-2.0*YR(3)))*Z ASL = ABS(SL) ASR = ABS(SR) DEN = 0.5*LOG(UL*ASR*ASR-UR*ASL*ASL) SLFUN(4) = LOG(ASR) - YL(3) - DEN SLFUN(7) = LOG(ASL) - YR(3) - DEN C END (COMPUTE-EIGENFUNCTION-DATA) C DO (CHECK-MATCHING-VALUES-OF-EIGENFUNCTION) C C Perform final check on EIG. Return IFLAG=4 if not accurate enough. C E = ASR*EXP(-DEN) PSIL = E*SL PSIPL = E*CL SQL = E*E*UL DPSIL = PSIL*ERL(3) + PSIPL*ERL(1) DPSIPL = PSIL*ERL(1) + PSIPL*ERL(3) PSIPL = PSIPL*Z E = ASL*EXP(-DEN) PSIR = E*SR PSIPR = E*CR SQR = E*E*UR DPSIR = PSIR*ERR(3) + PSIPR*ERR(1) DPSIPR = PSIR*ERR(1) + PSIPR*ERR(3) PSIPR = PSIPR*Z RAY = EIG + (PSIL*PSIPL-PSIR*PSIPR)/(SQL-SQR) IF (PRIN) THEN WRITE(IOUT,'(A,E22.14)') ' ray=',RAY WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' psil=',PSIL,' psir=',PSIR WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' psipl=',PSIPL,' psipr=',PSIPR WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' sql=',SQL,' sqr=',SQR WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' dpsil=',DPSIL,' dpsir=',DPSIR WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' dpsipl=',DPSIPL,' dpsipr=',DPSIPR END IF C END (CHECK-MATCHING-VALUES-OF-EIGENFUNCTION) IF (ABS(RAY-EIG).GT.TAU*MAX(ONE,ABS(EIG))) IFLAG = 4 IF (ISLFUN.GT.0) THEN C C Calculate selected eigenfunction values by integration. C C DO (GENERATE-EIGENFUNCTION-VALUES) EIGF = .TRUE. NMID = 0 DO 140 I=1,ISLFUN IF (SLFUN(9+I).LE.SLFUN(1)) NMID = I 140 CONTINUE IF (NMID.GT.0) THEN X = SLFUN(2) YL(1) = SLFUN(3) YL(2) = 0.0 YL(3) = SLFUN(4) LFLAG = 1 DO 160 J=1,NMID C Move any eigenfunction output points to lie within the range XAA..XBB CJDP (an attempt to stop errors at singular endpoints) SLFUN(J+9)=min(max(SLFUN(J+9),SLFUN(2)),SLFUN(5)) 150 CONTINUE IF (X.NE.SLFUN(J+9)) 1 CALL GERK(F,3,YL,X,SLFUN(J+9),SLFUN(8),SLFUN(8), 1 LFLAG,ERL,WORK,IWORK) IF (LFLAG.EQ.3) PRINT*, 1 'After 9000 function evaluations GERK reached X=',X IF (LFLAG.EQ.3) GO TO 150 IF (LFLAG.EQ.6) LFLAG = 2 SLFUN(J+9) = EXP(YL(3))*SIN(YL(1)) 160 CONTINUE END IF IF (NMID.LT.ISLFUN) THEN X = SLFUN(5) YR(1) = SLFUN(6) YR(2) = 0.0 YR(3) = SLFUN(7) LFLAG = 1 DO 180 J=ISLFUN,NMID+1,-1 C Move any eigenfunction output points to lie within the range XAA..XBB CJDP (see above) SLFUN(J+9)=min(max(SLFUN(J+9),SLFUN(2)),SLFUN(5)) 170 CONTINUE IF (X.NE.SLFUN(J+9)) 1 CALL GERK(F,3,YR,X,SLFUN(J+9),SLFUN(8),SLFUN(8), 1 LFLAG,ERR,WORK,IWORK) IF (LFLAG.EQ.3) PRINT*, 1 'After 9000 function evaluations GERK reached X=',X IF (LFLAG.EQ.3) GO TO 170 IF (LFLAG.EQ.6) LFLAG = 2 SLFUN(J+9) = EXP(YR(3))*SIN(YR(1)) 180 CONTINUE END IF C END (GENERATE-EIGENFUNCTION-VALUES) END IF RETURN END SUBROUTINE SLEIGN C ---------------------------------------------------------------------- SUBROUTINE ALFBET(XEND,INTAB,TT,COEF1,COEF2,EIG,P0,QF,OK, 1 VALUE,IFLAG,DERIV) INTEGER INTAB,IFLAG LOGICAL OK DOUBLE PRECISION XEND,TT,COEF1,COEF2,EIG,P0,QF,VALUE,DERIV C ********** C C This subroutine computes a boundary value for a specified endpoint C of the interval for a Sturm-Liouville problem in the form C C (p(x)*y'(x))' + (q(x) + eig*r(x))*y(x) = 0 on (a,b) C C for user-supplied coefficient functions P, Q, and R. It is called C from SLEIGN. Both regular and singular endpoints are treated. C C Subprograms called C C user-supplied ..... p,q,r C C sleign-supplied ... dxdt,extrap C C ********** C .. Scalars in Common .. DOUBLE PRECISION Z C .. C .. Local Scalars .. LOGICAL LOGIC DOUBLE PRECISION C,CD,D,HH,ONE,PI,PX,QX,RX,T,TEMP,X C .. C .. External Functions .. DOUBLE PRECISION P,Q,R EXTERNAL P,Q,R C .. C .. External Subroutines .. cc EXTERNAL DXDT,EXTRAP C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,SIGN,SQRT C .. C .. Common blocks .. COMMON /ZEE/Z C .. C Set machine dependent constant. C C PI (variable ONE set to 1.0 eases precision conversion). ONE = 1.0 PI = 4.0*ATAN(ONE) C IFLAG = 1 DERIV = 0.0 IF (OK) THEN VALUE = 0.5*PI IF (COEF1.NE.0.0) VALUE = ATAN(-Z*COEF2/COEF1) LOGIC = (TT.LT.0.0 .AND. VALUE.LT.0.0) .OR. 1 (TT.GT.0.0 .AND. VALUE.LE.0.0) IF (LOGIC) VALUE = VALUE + PI ELSE LOGIC = (INTAB.EQ.2 .AND. TT.GT.0.0) .OR. 1 (INTAB.EQ.3 .AND. TT.LT.0.0) .OR. 2 INTAB.EQ.4 .OR. (P0.GT.0.0 .AND. QF.LT.0.0) IF (LOGIC) THEN T = SIGN(ONE,TT) CALL EXTRAP(T,TT,EIG,VALUE,DERIV,IFLAG) ELSE CALL DXDT(TT,TEMP,X) PX = P(X)/Z QX = Q(X)/Z RX = R(X)/Z C = 2.0*(EIG*RX+QX) IF (C.LT.0.0) THEN VALUE = 0.0 IF (P0.GT.0.0) VALUE = 0.5*PI ELSE HH = ABS(XEND-X) D = 2.0*HH/PX CD = C*D*HH IF (P0.GT.0.0) THEN VALUE = C*HH IF (CD.LT.1.0) VALUE = VALUE/(1.0+SQRT(1.0-CD)) VALUE = VALUE + 0.5*PI ELSE VALUE = D IF (CD.LT.1.0) VALUE = VALUE/(1.0+SQRT(1.0-CD)) END IF END IF END IF END IF RETURN END SUBROUTINE ALFBET C ---------------------------------------------------------------------- SUBROUTINE DXDT(T,DT,X) DOUBLE PRECISION T,DT,X C ********** C C This subroutine transforms coordinates from T on (-1,1) to C X on (A,B) in the solution of a Sturm-Liouville problem. C It is called from subroutines SLEIGN, ALFBET, F, and EXTRAP. C C ********** C .. Scalars in Common .. INTEGER INTAB DOUBLE PRECISION A,B,C1,C2 C .. C .. Local Scalars .. DOUBLE PRECISION U C .. C .. Intrinsic Functions .. INTRINSIC ABS C .. C .. Common blocks .. COMMON /DATADT/A,B,C1,C2,INTAB C .. U = C1*T + C2 GO TO (10,20,30,40), INTAB 10 CONTINUE DT = C1*0.5*(B-A) X = 0.5*((B+A)+(B-A)*U) RETURN 20 CONTINUE DT = C1*2.0/(1.0-U)**2 X = A + (1.0+U)/(1.0-U) RETURN 30 CONTINUE DT = C1*2.0/(1.0+U)**2 X = B - (1.0-U)/(1.0+U) RETURN 40 CONTINUE DT = C1/(1.0-ABS(U))**2 X = U/(1.0-ABS(U)) RETURN END SUBROUTINE DXDT C ---------------------------------------------------------------------- SUBROUTINE ESTEIG(MF,ML,LIMIT,ELIM,EMAX,EMIN,PIN,QS,RS,DS,PS, 1 IMAX,IMIN,EEE,EIG,IA,IB,EL,WL,DEDW) INTEGER MF,ML,IMAX,IMIN,IA,IB LOGICAL LIMIT DOUBLE PRECISION ELIM,EMAX,EMIN,PIN,EEE,EIG,EL,WL,DEDW DOUBLE PRECISION QS(ML),RS(ML),DS(ML),PS(ML) C ********** C C This subroutine generates an initial guess for a specified C eigenvalue of a Sturm-Liouville problem in the form C C (p(x)*y'(x))' + (q(x) + eig*r(x))*y(x) = 0 on (a,b) C C for user-supplied coefficient functions P, Q, and R. It is C called from SLEIGN when no initial guess is provided by the user. C C The method used is to approximately solve the equation for EIG C C Integral (sqrt((eig*r+q)/p)) = numeig*pi C C where the integral is taken over those X in (A,B) for which C C (eig*r+q)/p .gt. 0 C C and NUMEIG is the index of the desired eigenvalue (PIN=NUMEIG*pi). C C Subprograms called C C sleign-supplied ... estpac C C ********** C .. Scalars in Common .. INTEGER INTAB DOUBLE PRECISION A,B,C1,C2 C .. C .. Local Scalars .. INTEGER IE,IP LOGICAL LOGIC DOUBLE PRECISION BALLPK,EU,FNEW,FOLD,SUM,TEMP,U,WU C .. C .. External Subroutines .. cc EXTERNAL ESTPAC C .. C .. Intrinsic Functions .. INTRINSIC ABS,MIN C .. C .. Common blocks .. COMMON /DATADT/A,B,C1,C2,INTAB C .. EEE = MIN(ELIM,EMAX) C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(MF,ML,EEE,PIN,QS,RS,DS,PS,IA,IB,IP,SUM,U,TEMP) C END (ESTIMATE-PHASE-ANGLE-CHANGE) C C Choose bounds for EIG and associate function (integral) values. C EL = EMIN WL = 0.0 EU = EEE WU = SUM IF (LIMIT .AND. WU.LT.PIN) THEN EIG = ELIM ELSE IF (U.EQ.0.0) THEN EL = EMAX EEE = EMAX + 1.0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(MF,ML,EEE,PIN,QS,RS,DS,PS, 1 IA,IB,IP,SUM,U,TEMP) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EU = EEE WU = SUM END IF 10 CONTINUE IF (WU.LE.PIN) THEN C C Increase trial value if integral is still too small. C EL = EU WL = WU EEE = EU + ((PIN-WU+3.0)/U)**2 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(MF,ML,EEE,PIN,QS,RS,DS,PS, 1 IA,IB,IP,SUM,U,TEMP) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EU = EEE WU = SUM GO TO 10 END IF C C EIG is bracketed. Now try to reduce the size of the bracket C by searching among the saved values of -QS()/RS(). C 20 CONTINUE IF (ABS(IMAX-IMIN).GE.2 .AND. EU.LE.EMAX) THEN IE = (IMAX+IMIN)/2 IF (RS(IE).NE.0.0) THEN EEE = -QS(IE)/RS(IE) C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(MF,ML,EEE,PIN,QS,RS,DS,PS, 1 IA,IB,IP,SUM,U,TEMP) C END (ESTIMATE-PHASE-ANGLE-CHANGE) IF (SUM.GT.PIN) THEN IMAX = IE WU = SUM EU = EEE ELSE IMIN = IE WL = SUM EL = EEE END IF GO TO 20 END IF END IF C C Improve approximation for EIG using bisection or secant method. C Substitute 'ballpark' estimate if approximation grows too large. C DEDW = (EU-EL)/(WU-WL) FOLD = 0.0 IF (INTAB.EQ.1) BALLPK = (PIN/(A-B))**2 LOGIC = .TRUE. 30 CONTINUE IF (LOGIC) THEN LOGIC = (WL.LT.(PIN-1.0) .OR. WU.GT.(PIN+1.0)) EEE = EL + DEDW*(PIN-WL) FNEW = MIN(PIN-WL,WU-PIN) IF (FNEW.GT.0.4*FOLD .OR. FNEW.LE.1.0) 1 EEE = 0.5*(EL+EU) IF (INTAB.EQ.1 .AND. ABS(EEE).GT.1.0E+3*BALLPK) THEN EIG = BALLPK RETURN ELSE IF (INTAB.NE.1 .AND. ABS(EEE).GT.1.0E+6) THEN EIG = 1.0 RETURN ELSE FOLD = FNEW C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(MF,ML,EEE,PIN,QS,RS,DS,PS, 1 IA,IB,IP,SUM,U,TEMP) C END (ESTIMATE-PHASE-ANGLE-CHANGE) IF (SUM.LT.PIN) THEN EL = EEE WL = SUM ELSE EU = EEE WU = SUM END IF DEDW = (EU-EL)/(WU-WL) GO TO 30 END IF END IF END IF RETURN END SUBROUTINE ESTEIG C ---------------------------------------------------------------------- SUBROUTINE ESTPAC(MF,ML,EEE,PIN,QS,RS,DS,PS,IA,IB,IP,SUM,U,ZAV) INTEGER MF,ML,IA,IB,IP DOUBLE PRECISION EEE,PIN,SUM,U,ZAV DOUBLE PRECISION QS(ML),RS(ML),DS(ML),PS(ML) C ********** C C This subroutine estimates the change in 'phase angle' in the C eigenvalue determination of a Sturm-Liouville problem in the form C C (p(x)*y'(x))' + (q(x) + eig*r(x))*y(x) = 0 on (a,b) C C for user-supplied coefficient functions P, Q, and R. It is C called from SLEIGN, and also from ESTEIG when no initial guess C is provided by the user. C C The subroutine approximates the (trapezoidal rule) integral of C C sqrt((eig*r+q)/p) C C where the integral is taken over those X in (A,B) for which C C (eig*r+q)/p .gt. 0 C C ********** C .. Local Scalars .. INTEGER J DOUBLE PRECISION PSUM,RT,RTSAV,V,W,WSAV C .. C .. Intrinsic Functions .. INTRINSIC ABS,SIGN,SQRT C .. IA = MF IB = 80 IP = MF C C SUM accumulates the integral approximation. U measures the total C length of subintervals where (EIG*R+Q)/P .gt. 0.0. ZAV is the C average value of sqrt((EIG*R+Q)*P) over those subintervals. C SUM = 0.0 U = 0.0 ZAV = 0.0 WSAV = EEE*RS(MF) + QS(MF) IF (WSAV.GT.0.0) THEN RTSAV = SQRT(WSAV) ELSE RTSAV = 0.0 END IF DO 10 J=MF+1,ML W = EEE*RS(J) + QS(J) IF (W.GT.0.0) THEN IF (J.GE.80) IB = J U = U + DS(J-1) RT = SQRT(W) ELSE RT = 0.0 IF (U.EQ.0.0 .AND. RTSAV.EQ.0.0 .AND. IA.LE.19) IA = IA + 1 END IF IF (W.EQ.0.0 .OR. WSAV.EQ.0.0 .OR. W.EQ.SIGN(W,WSAV)) THEN V = RT + RTSAV ELSE V = (W*RT+WSAV*RTSAV)/ABS(W-WSAV) END IF WSAV = W RTSAV = RT PSUM = DS(J-1)*V IF (PSUM.LT.(PIN-SUM)) IP = J SUM = SUM + PSUM IF (U.GT.0.0) ZAV = ZAV + PSUM*(PS(J)+PS(J-1)) 10 CONTINUE SUM = 0.5*SUM ZAV = 0.25*ZAV RETURN END SUBROUTINE ESTPAC C ---------------------------------------------------------------------- SUBROUTINE EXTRAP(T,TT,EIG,VALUE,DERIV,IFLAG) INTEGER IFLAG DOUBLE PRECISION T,TT,EIG,VALUE,DERIV C ********** C C This subroutine is called from ALFBET in determining boundary C values at a singular endpoint of the interval for a C Sturm-Liouville problem in the form C C (p(x)*y'(x))' + (q(x) + eig*r(x))*y(x) = 0 on (a,b) C C for user-supplied coefficient functions P, Q, and R. C C EXTRAP, which in turn calls INTPOL, extrapolates the function C C arctan(1.0/sqrt(-p*(eig*r+q))) C C from its values for T within (-1,1) to an endpoint. C C Subprograms called C C user-supplied ..... p,q,r C C sleign-supplied ... dxdt,intpol C C ********** C .. Scalars in Common .. DOUBLE PRECISION Z C .. C .. Local Scalars .. INTEGER KGOOD DOUBLE PRECISION ANS,CTN,ERROR,PROD,PX,QX,RX,T1,TEMP,X C .. C .. Local Arrays .. DOUBLE PRECISION FN1(5),XN(5) C .. C .. External Functions .. DOUBLE PRECISION P,Q,R EXTERNAL P,Q,R C .. C .. External Subroutines .. cc EXTERNAL DXDT,INTPOL C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,SQRT,TAN C .. C .. Common blocks .. COMMON /ZEE/Z C .. IFLAG = 1 KGOOD = 0 T1 = TT 10 CONTINUE CALL DXDT(T1,TEMP,X) PX = P(X)/Z QX = Q(X)/Z RX = R(X)/Z PROD = -PX*(EIG*RX+QX) IF (PROD.LE.0.0) THEN T1 = 0.5*(T1+T) IF ((1.0+(T1-T)**2).GT.1.0) GO TO 10 IFLAG = 5 RETURN ELSE KGOOD = KGOOD + 1 XN(KGOOD) = T1 FN1(KGOOD) = ATAN(1.0/SQRT(PROD)) T1 = 0.5*(T+T1) IF (KGOOD.LT.5) GO TO 10 END IF T1 = 0.01 CALL INTPOL(5,XN,FN1,T,T1,3,ANS,ERROR) VALUE = ABS(ANS) CTN = 1.0/TAN(VALUE) DERIV = 0.5*PX*RX/CTN/(1.0+CTN**2) TT = XN(1) RETURN END SUBROUTINE EXTRAP C ---------------------------------------------------------------------- SUBROUTINE F(T,Y,YP) DOUBLE PRECISION T DOUBLE PRECISION Y(2),YP(3) C ********** C C This subroutine evaluates the derivative functions for use with C integrator GERK in solving a Sturm-Liouville problem in the form C C (p(x)*y'(x))' + (q(x) + eig*r(x))*y(x) = 0 on (a,b) C C for user-supplied coefficient functions P, Q, and R. C C Subprograms called C C user-supplied ..... p,q,r C C sleign-supplied ... dxdt C C ********** C .. Scalars in Common .. LOGICAL EIGF DOUBLE PRECISION EIG,Z C .. C .. Local Scalars .. DOUBLE PRECISION C,C2,DT,QX,RX,S,S2,V,W,X,XP,ZP C .. C .. External Functions .. DOUBLE PRECISION P,Q,R EXTERNAL P,Q,R C .. C .. External Subroutines .. cc EXTERNAL DXDT C .. C .. Intrinsic Functions .. INTRINSIC ABS,COS,SIN C .. C .. Common blocks .. COMMON /DATAF/EIG,EIGF COMMON /ZEE/Z C .. DT = 1.0 X = T IF (.NOT.EIGF) CALL DXDT(T,DT,X) ZP = ABS(Z) XP = ZP/P(X) QX = Q(X)/ZP RX = R(X)/ZP V = EIG*RX + QX S = SIN(Y(1)) C = COS(Y(1)) S2 = S*S C2 = C*C YP(1) = DT*(XP*C2+V*S2) W = (XP-V)*S*C IF (Z.LT.0.0) RX = ABS(RX) YP(2) = DT*(-2.0*W*Y(2)+RX*S2) YP(3) = DT*W RETURN END SUBROUTINE F C ---------------------------------------------------------------------- SUBROUTINE GS(X,Y,YP) DOUBLE PRECISION X DOUBLE PRECISION Y(1),YP(1) C ********** C C This subroutine evaluates the derivative function for use with C integrator GERK in solving a differential equation in the form C C (p(x)*y'(x))' + q(x)*y(x) = 0 on (a,b) C C for user-supplied coefficient functions P and Q. C C Subprograms called C C user-supplied ..... p,q C C ********** C .. Scalars in Common .. DOUBLE PRECISION Z C .. C .. Local Scalars .. DOUBLE PRECISION C,C2,QX,S,S2,XP C .. C .. External Functions .. DOUBLE PRECISION P,Q EXTERNAL P,Q C .. C .. Intrinsic Functions .. INTRINSIC COS,SIN C .. C .. Common blocks .. COMMON /ZEE/Z C .. XP = Z/P(X) QX = Q(X)/Z S = SIN(Y(1)) C = COS(Y(1)) S2 = S*S C2 = C*C YP(1) = XP*C2+QX*S2 RETURN END SUBROUTINE GS C ---------------------------------------------------------------------- SUBROUTINE INTPOL(N,XN,FN,X,ABSERR,MAXDEG,ANS,ERROR) INTEGER N,MAXDEG DOUBLE PRECISION X,ABSERR,ANS,ERROR DOUBLE PRECISION XN(N),FN(N) C ********** C C This subroutine forms an interpolating polynomial for data pairs. C It is called from EXTRAP in solving a Sturm-Liouville problem. C C ********** C .. Local Scalars .. INTEGER I,I1,II,IJ,IK,IKM1,J,K,L,LIMIT DOUBLE PRECISION PROD C .. C .. Local Arrays .. INTEGER INDEX(10) DOUBLE PRECISION V(10,10) C .. C .. Intrinsic Functions .. INTRINSIC ABS,MIN C .. L = MIN(MAXDEG,N-2) + 2 LIMIT = MIN(L,N-1) DO 10 I = 1,N V(I,1) = ABS(XN(I)-X) INDEX(I) = I 10 CONTINUE DO 30 I=1,LIMIT DO 20 J=I+1,N II = INDEX(I) IJ = INDEX(J) IF (V(II,1).GT.V(IJ,1)) THEN INDEX(I) = IJ INDEX(J) = II END IF 20 CONTINUE 30 CONTINUE PROD = 1.0 I1 = INDEX(1) ANS = FN(I1) V(1,1) = FN(I1) DO 50 K=2,L IK = INDEX(K) V(K,1) = FN(IK) DO 40 I=1,K-1 II = INDEX(I) V(K,I+1) = (V(I,I)-V(K,I))/(XN(II)-XN(IK)) 40 CONTINUE IKM1 = INDEX(K-1) PROD = (X-XN(IKM1))*PROD ERROR = PROD*V(K,K) IF(ABS(ERROR).LE.ABSERR) RETURN ANS = ANS + ERROR 50 CONTINUE ANS = ANS - ERROR RETURN END SUBROUTINE INTPOL C ---------------------------------------------------------------------- SUBROUTINE ZCOUNT(A,B,A1,A2,B1,B2,JPAIRS,PAIRS,JSUM) INTEGER JPAIRS,JSUM DOUBLE PRECISION A,B,A1,A2,B1,B2 DOUBLE PRECISION PAIRS(2*JPAIRS) C ********** C C This subroutine counts the zeros, over specified subintervals, of C the solutions of a second order differential equation in the form C C (p(x)*y'(x))' + q(x)*y(x) = 0 on (a,b) C C for user-supplied coefficient functions P and Q. This count in C turn corresponds to the number of zeros, in the interior of (A,B), C of the first eigenfunction of the related Sturm-Liouville problem C whose (semidefinite) weight function vanishes identically in the C subintervals. The problem is restricted to be regular. C C The applicable initial condition depends upon three cases. C C Case 1 -- On a subinterval with left endpoint A, C A1*Y(A) + A2*Y'(A)*P(A) = 0. C C Case 2 -- On a subinterval with right endpoint B, C B1*Y(B) + B2*Y'(B)*P(B) = 0. C C Case 3 -- On a subinterval with neither A nor B as endpoint, C Y(XAA) = 0, where XAA is the left endpoint. C C The SUBROUTINE statement is C C SUBROUTINE zcount(a,b,a1,a2,b1,b2,jpairs,pairs,jsum) C C where C C A and B are input variables defining the full interval. C A must be less than B. C C A1 and A2 are input variables set to prescribe the initial C condition at A (Case 1). C C B1 and B2 are input variables set to prescribe the initial C condition at B (Case 2). C C JPAIRS is an integer input variable set to the number of C specified subintervals of (A,B). C C PAIRS is an input array of length 2*JPAIRS whose successive C ordered element pairs specify the subintervals. C C JSUM is an integer output variable set to the total zero count. C C Subprograms called C C sleign-supplied ... epslon,g,gerk C C user-supplied ..... p,q C C This version dated 5/18/89. C Burton S. Garbow, Argonne National Laboratory C C ********** C .. Scalars in Common .. DOUBLE PRECISION Z C .. C .. Local Scalars .. INTEGER I,J,LFLAG,MF,ML DOUBLE PRECISION EPS,EPSMIN,H,ONE,PI,PSUM,PX,QX,RT,RTSAV, 1 T,U,V,W,WSAV,X,X50,XAA,XBB,XSAV,ZAV C .. C .. Local Arrays .. INTEGER IWORK(5) DOUBLE PRECISION DS(98),GERROR(1),PS(99),QS(99),WORK(11),Y(1) C .. C .. External Functions .. DOUBLE PRECISION P,Q EXTERNAL P,Q C .. C .. External Subroutines .. cc EXTERNAL GS,GERK C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,INT,SIGN,SQRT C .. C .. Common blocks .. COMMON /ZEE/Z C .. C Set constants EPSMIN, the computer unit roundoff error, and PI. C (Variable ONE set to 1.0 eases precision conversion.) C ONE = 1.0 EPSMIN = EPSLON(ONE) PI = 4.0*ATAN(ONE) C C Set relative and absolute error tolerances for GERK. C EPS = SQRT(EPSMIN) C JSUM = 0 DO 70 J = 1,JPAIRS XAA = PAIRS(2*J-1) XBB = PAIRS(2*J) C DO (CALCULATE-MODIFIED-PRUFER-TRANSFORMATION-CONSTANT) C C Evaluate P, Q to obtain preliminary information about the C differential equation. C C DO (SAMPLE-COEFFICIENTS) X50 = 0.5*((XBB+XAA)+(XBB-XAA)*EPSMIN) PX = P(X50) QX = Q(X50) PS(50) = PX QS(50) = QX/PX C C MF and ML are the least and greatest index values, respectively. C XSAV = X50 H = 0.9/40.0 DO 10 I=49,1,-1 IF (I.GE.10) T = H*(I-50) IF (I.LT.10) T = T - 0.75*(1.0+T) X = 0.5*((XBB+XAA)+(XBB-XAA)*T) PX = P(X) QX = Q(X) PS(I) = PX QS(I) = QX/PX DS(I) = XSAV - X XSAV = X MF = I 10 CONTINUE XSAV = X50 DO 20 I=51,99 IF (I.LE.90) T = H*(I-50) IF (I.GT.90) T = T + 0.75*(1.0-T) X = 0.5*((XBB+XAA)+(XBB-XAA)*T) PX = P(X) QX = Q(X) PS(I) = PX QS(I) = QX/PX DS(I-1) = X - XSAV XSAV = X ML = I - 1 20 CONTINUE C END (SAMPLE-COEFFICIENTS) C DO (ESTIMATE-PHASE-ANGLE-CHANGE) C C U measures the total length of subintervals where Q/P .gt. 0.0. C ZAV is the average value of sqrt(Q*P) over those subintervals. C U = 0.0 ZAV = 0.0 WSAV = QS(MF) IF (WSAV.GT.0.0) THEN RTSAV = SQRT(WSAV) ELSE RTSAV = 0.0 END IF DO 30 I=MF+1,ML W = QS(I) IF (W.GT.0.0) THEN U = U + DS(I-1) RT = SQRT(W) ELSE RT = 0.0 END IF IF (W.EQ.0.0 .OR. WSAV.EQ.0.0 .OR. 1 W.EQ.SIGN(W,WSAV)) THEN V = RT + RTSAV ELSE V = (W*RT+WSAV*RTSAV)/ABS(W-WSAV) END IF WSAV = W RTSAV = RT PSUM = DS(I-1)*V IF (U.GT.0.0) ZAV = ZAV + PSUM*(PS(I)+PS(I-1)) 30 CONTINUE ZAV = 0.25*ZAV C END (ESTIMATE-PHASE-ANGLE-CHANGE) Z = 1.0 IF (U.GT.0.0) Z = ZAV/U C END (CALCULATE-MODIFIED-PRUFER-TRANSFORMATION-CONSTANT) LFLAG = 1 IF (XAA.EQ.A) THEN C C Case 1 ---------- C Y(1) = PI/2.0 IF (A1.NE.0.0) Y(1) = ATAN(-Z*A2/A1) IF (Y(1).LT.0.0) Y(1) = Y(1) + PI 40 CONTINUE CALL GERK(GS,1,Y,XAA,XBB,EPS,EPS,LFLAG,GERROR,WORK,IWORK) IF (LFLAG.EQ.3) GO TO 40 JSUM = JSUM + INT((Y(1)+ABS(EPS))/PI) ELSE IF (XBB.EQ.B) THEN C C Case 2 ---------- C Y(1) = PI/2.0 IF (B1.NE.0.0) Y(1) = ATAN(-Z*B2/B1) IF (Y(1).GT.0.0) Y(1) = Y(1) - PI 50 CONTINUE CALL GERK(GS,1,Y,XBB,XAA,EPS,EPS,LFLAG,GERROR,WORK,IWORK) IF (LFLAG.EQ.3) GO TO 50 JSUM = JSUM - INT((Y(1)-ABS(EPS))/PI) ELSE C C Case 3 ---------- C Y(1) = 0.0 60 CONTINUE CALL GERK(GS,1,Y,XAA,XBB,EPS,EPS,LFLAG,GERROR,WORK,IWORK) IF (LFLAG.EQ.3) GO TO 60 JSUM = JSUM + INT((Y(1)+ABS(EPS))/PI) END IF 70 CONTINUE RETURN END SUBROUTINE ZCOUNT SUBROUTINE GERK(F, NEQN, Y, T, TOUT, RELERR, ABSERR, IFLAG, * GERROR, WORK, IWORK) C C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C C WRITTEN BY H.A.WATTS AND L.F.SHAMPINE C SANDIA LABORATORIES C C GERK IS DESIGNED TO SOLVE SYSTEMS OF DIFFERENTIAL EQUATIONS C WHEN IT IS IMPORTANT TO HAVE A READILY AVAILABLE GLOBAL ERROR C ESTIMATE. PARALLEL INTEGRATION IS PERFORMED TO YIELD TWO C SOLUTIONS ON DIFFERENT MESH SPACINGS AND GLOBAL EXTRAPOLATION C IS APPLIED TO PROVIDE AN ESTIMATE OF THE GLOBAL ERROR IN THE C MORE ACCURATE SOLUTION. C C FOR IBM SYSTEM 360 AND 370 AND OTHER MACHINES OF SIMILAR C ARITHMETIC CHARACTERISTICS, THIS CODE SHOULD BE CONVERTED TO C DOUBLE PRECISION. C C******************************************************************* C ABSTRACT C******************************************************************* C C SUBROUTINE GERK INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN)) C WHERE THE Y(I) ARE GIVEN AT T . C TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TOUT C BUT IT CAN BE USED AS A ONE-STEP INTEGRATOR TO ADVANCE THE C SOLUTION A SINGLE STEP IN THE DIRECTION OF TOUT. ON RETURN, AN C ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T IS PROVIDED C AND THE PARAMETERS IN THE CALL LIST ARE SET FOR CONTINUING THE C INTEGRATION. THE USER HAS ONLY TO CALL GERK AGAIN (AND PERHAPS C DEFINE A NEW VALUE FOR TOUT). ACTUALLY, GERK IS MERELY AN C INTERFACING ROUTINE WHICH ALLOCATES VIRTUAL STORAGE IN THE C ARRAYS WORK, IWORK AND CALLS SUBROUTINE GERKS FOR THE SOLUTION. C GERKS IN TURN CALLS SUBROUTINE FEHL WHICH COMPUTES AN APPROX- C IMATE SOLUTION OVER ONE STEP. C C GERK USES THE RUNGE-KUTTA-FEHLBERG (4,5) METHOD DESCRIBED C IN THE REFERENCE C E.FEHLBERG , LOW-ORDER CLASSICAL RUNGE-KUTTA FORMULAS WITH C STEPSIZE CONTROL , NASA TR R-315 C C C THE PARAMETERS REPRESENT- C F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES C YP(I)=DY(I)/DT C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT T C T -- INDEPENDENT VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED C RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR C LOCAL ERROR TEST. AT EACH STEP THE CODE REQUIRES THAT C ABS(LOCAL ERROR) .LE. RELERR*ABS(Y) + ABSERR C FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION C VECTORS. C IFLAG -- INDICATOR FOR STATUS OF INTEGRATION C GERROR(*) -- VECTOR WHICH ESTIMATES THE GLOBAL ERROR AT T. C THAT IS, GERROR(I) APPROXIMATES Y(I)-TRUE C SOLUTION(I). C WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO GERK WHICH C IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED C AT LEAST 3+8*NEQN C IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL C TO GERK WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST C BE DIMENSIONED AT LEAST 5 C C C******************************************************************* C FIRST CALL TO GERK C******************************************************************* C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE C ARRAYS IN THE CALL LIST - Y(NEQN), WORK(3+8*NEQN), IWORK(5), C DECLARE F IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE F(T,Y,YP) C AND INITIALIZE THE FOLLOWING PARAMETERS- C C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED. (NEQN .GE. 1) C Y(*) -- VECTOR OF INITIAL CONDITIONS C T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED. C T=TOUT IS ALLOWED ON THE FIRST CALL ONLY,IN WHICH CASE C GERK RETURNS WITH IFLAG=2 IF CONTINUATION IS POSSIBLE. C RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES C WHICH MUST BE NON-NEGATIVE BUT MAY BE CONSTANTS. WE CAN C USUALLY EXPECT THE GLOBAL ERRORS TO BE SOMEWHAT SMALLER C THAN THE REQUESTED LOCAL ERROR TOLERANCES. TO AVOID C LIMITING PRECISION DIFFICULTIES THE CODE ALWAYS USES C THE LARGER OF RELERR AND AN INTERNAL RELATIVE ERROR C PARAMETER WHICH IS MACHINE DEPENDENT. C IFLAG -- +1,-1 INDICATOR TO INITIALIZE THE CODE FOR EACH NEW C PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG= C -1 ONLY WHEN ONE-STEP INTEGRATOR CONTROL IS ESSENTIAL. C IN THIS CASE, GERK ATTEMPTS TO ADVANCE THE SOLUTION A C SINGLE STEP IN THE DIRECTION OF TOUT EACH TIME IT IS C CALLED. SINCE THIS MODE OF OPERATION RESULTS IN EXTRA C COMPUTING OVERHEAD, IT SHOULD BE AVOIDED UNLESS NEEDED. C C C******************************************************************* C OUTPUT FROM GERK C******************************************************************* C C Y(*) -- SOLUTION AT T C T -- LAST POINT REACHED IN INTEGRATION. C IFLAG = 2 -- INTEGRATION REACHED TOUT. INDICATES SUCCESSFUL C RETURN AND IS THE NORMAL MODE FOR CONTINUING C INTEGRATION. C =-2 -- A SINGLE SUCCESSFUL STEP IN THE DIRECTION OF C TOUT HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING C INTEGRATION ONE STEP AT A TIME. C = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN C 9000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS C IS APPROXIMATELY 500 STEPS. C = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION C VANISHED MAKING A PURE RELATIVE ERROR TEST C IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE. C USING THE ONE-STEP INTEGRATION MODE FOR ONE STEP C IS A GOOD WAY TO PROCEED. C = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED C ACCURACY COULD NOT BE ACHIEVED USING SMALLEST C ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR C TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE C ATTEMPTED. C = 6 -- GERK IS BEING USED INEFFICIENTLY IN SOLVING C THIS PROBLEM. TOO MUCH OUTPUT IS RESTRICTING THE C NATURAL STEPSIZE CHOICE. USE THE ONE-STEP C INTEGRATOR MODE. C = 7 -- INVALID INPUT PARAMETERS C THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS C SATISFIED - NEQN .LE. 0 C T=TOUT AND IFLAG .NE. +1 OR -1 C RELERR OR ABSERR .LT. 0. C IFLAG .EQ. 0 OR .LT. -2 OR .GT. 7 C GERROR(*) -- ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T C WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO C INTEREST TO THE USER BUT NECESSARY FOR SUBSEQUENT C CALLS. WORK(1),...,WORK(NEQN) CONTAIN THE FIRST C DERIVATIVES OF THE SOLUTION VECTOR Y AT T. C WORK(NEQN+1) CONTAINS THE STEPSIZE H TO BE C ATTEMPTED ON THE NEXT STEP. IWORK(1) CONTAINS C THE DERIVATIVE EVALUATION COUNTER. C C C******************************************************************* C SUBSEQUENT CALLS TO GERK C******************************************************************* C C SUBROUTINE GERK RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE C THE INTEGRATION. IF THE INTEGRATION REACHED TOUT, THE USER NEED C ONLY DEFINE A NEW TOUT AND CALL GERK AGAIN. IN THE ONE-STEP C INTEGRATOR MODE (IFLAG=-2) THE USER MUST KEEP IN MIND THAT EACH C STEP TAKEN IS IN THE DIRECTION OF THE CURRENT TOUT. UPON C REACHING TOUT (INDICATED BY CHANGING IFLAG TO 2), THE USER MUST C THEN DEFINE A NEW TOUT AND RESET IFLAG TO -2 TO CONTINUE IN THE C ONE-STEP INTEGRATOR MODE. C C IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS C TO CONTINUE (IFLAG=3 CASE), HE JUST CALLS GERK AGAIN. THE C FUNCTION COUNTER IS THEN RESET TO 0 AND ANOTHER 9000 FUNCTION C EVALUATIONS ARE ALLOWED. C C HOWEVER, IN THE CASE IFLAG=4, THE USER MUST FIRST ALTER THE C ERROR CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE C INTEGRATION CAN PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED. C C ALSO, IN THE CASE IFLAG=5, IT IS NECESSARY FOR THE USER TO C RESET IFLAG TO 2 (OR -2 WHEN THE ONE-STEP INTEGRATION MODE IS C BEING USED) AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH C BEFORE THE INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, C EXECUTION WILL BE TERMINATED. THE OCCURRENCE OF IFLAG=5 C INDICATES A TROUBLE SPOT (SOLUTION IS CHANGING RAPIDLY, C SINGULARITY MAY BE PRESENT) AND IT OFTEN IS INADVISABLE TO C CONTINUE. C C IF IFLAG=6 IS ENCOUNTERED, THE USER SHOULD USE THE ONE-STEP C INTEGRATION MODE WITH THE STEPSIZE DETERMINED BY THE CODE. IF C THE USER INSISTS UPON CONTINUING THE INTEGRATION WITH GERK IN C THE INTERVAL MODE, HE MUST RESET IFLAG TO 2 BEFORE CALLING GERK C AGAIN. OTHERWISE,EXECUTION WILL BE TERMINATED. C C IF IFLAG=7 IS OBTAINED, INTEGRATION CAN NOT BE CONTINUED UNLESS C THE INVALID INPUT PARAMETERS ARE CORRECTED. C C IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN C INFORMATION REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, C WORK AND IWORK SHOULD NOT BE ALTERED. C C******************************************************************* C C .. SCALAR ARGUMENTS .. INTEGER IFLAG,NEQN DOUBLE PRECISION ABSERR,RELERR,T,TOUT C .. C .. ARRAY ARGUMENTS .. INTEGER IWORK(5) DOUBLE PRECISION GERROR(NEQN),WORK(3+8*NEQN),Y(NEQN) C .. C .. SUBROUTINE ARGUMENTS .. EXTERNAL F C .. C .. LOCAL SCALARS .. INTEGER K1,K1M,K2,K3,K4,K5,K6,K7,K8 C .. C .. EXTERNAL SUBROUTINES .. cc EXTERNAL GERKS C .. C COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY K1M = NEQN + 1 K1 = K1M + 1 K2 = K1 + NEQN K3 = K2 + NEQN K4 = K3 + NEQN K5 = K4 + NEQN K6 = K5 + NEQN K7 = K6 + NEQN K8 = K7 + NEQN C ******************************************************************* C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, C HE MUST USE GERKS DIRECTLY. C ******************************************************************* CALL GERKS(F, NEQN, Y, T, TOUT, RELERR, ABSERR, IFLAG, * GERROR, WORK(1), WORK(K1M), WORK(K1), WORK(K2), WORK(K3), * WORK(K4), WORK(K5), WORK(K6), WORK(K7), WORK(K8), * WORK(K8+1), IWORK(1), IWORK(2), IWORK(3), IWORK(4), IWORK(5)) RETURN END SUBROUTINE GERK SUBROUTINE GERKS(F, NEQN, Y, T, TOUT, RELERR, ABSERR, IFLAG, * GERROR, YP, H, F1, F2, F3, F4, F5, YG, YGP, SAVRE, SAVAE, * NFE, KOP, INIT, JFLAG, KFLAG) C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C ******************************************************************* C GERKS INTEGRATES A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL C EQUATIONS AS DESCRIBED IN THE COMMENTS FOR GERK. THE ARRAYS C YP,F1,F2,F3,F4,F5,YG AND YGP (OF DIMENSION AT LEAST NEQN) AND C THE VARIABLES H,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,AND KFLAG ARE C USED INTERNALLY BY THE CODE AND APPEAR IN THE CALL LIST TO C ELIMINATE LOCAL RETENTION OF VARIABLES BETWEEN CALLS. C ACCORDINGLY, THEY SHOULD NOT BE ALTERED. ITEMS OF POSSIBLE C INTEREST ARE C YP - DERIVATIVE OF SOLUTION VECTOR AT T C H - AN APPROPRIATE STEPSIZE TO BE USED FOR THE NEXT STEP C NFE- COUNTER ON THE NUMBER OF DERIVATIVE FUNCTION C EVALUATIONS. C ******************************************************************* C .. SCALAR ARGUMENTS .. INTEGER IFLAG,INIT,JFLAG,KFLAG,KOP,NEQN,NFE DOUBLE PRECISION ABSERR,H,RELERR,SAVAE,SAVRE,T,TOUT C .. C .. ARRAY ARGUMENTS .. DOUBLE PRECISION F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN), 1 GERROR(NEQN),Y(NEQN),YG(NEQN),YGP(NEQN),YP(NEQN) C .. C .. SUBROUTINE ARGUMENTS .. EXTERNAL F C .. C .. LOCAL SCALARS .. INTEGER K,MAXNFE,MFLAG LOGICAL HFAILD,OUTPUT DOUBLE PRECISION A,AE,DT,EE,EEOET,ESTTOL,ET,HH,HMIN,ONE,REMIN,RER, 1 S,SCALE,TOL,TOLN,TS,U,U26,YPK C .. C .. EXTERNAL FUNCTIONS .. cc DOUBLE PRECISION EPSLON cc EXTERNAL EPSLON C .. C .. EXTERNAL SUBROUTINES .. cc EXTERNAL FEHL C .. C .. INTRINSIC FUNCTIONS .. INTRINSIC ABS,MAX,MIN,SIGN C .. C ******************************************************************* C REMIN IS A TOLERANCE THRESHOLD WHICH IS ALSO DETERMINED BY THE C INTEGRATION METHOD. IN PARTICULAR, A FIFTH ORDER METHOD WILL C GENERALLY NOT BE CAPABLE OF DELIVERING ACCURACIES NEAR LIMITING C PRECISION ON COMPUTERS WITH LONG WORDLENGTHS. DATA REMIN /3.E-11/ C ******************************************************************* C THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER C OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE. C AS SET,THIS CORRESPONDS TO ABOUT 500 STEPS. DATA MAXNFE /9000/ C ******************************************************************* C U - THE COMPUTER UNIT ROUNDOFF ERROR U IS THE SMALLEST POSITIVE C VALUE REPRESENTABLE IN THE MACHINE SUCH THAT 1.+ U .GT. 1. C (VARIABLE ONE SET TO 1.0 EASES PRECISION CONVERSION.) C ONE = 1.0 U = EPSLON(ONE) C ******************************************************************* C CHECK INPUT PARAMETERS IF (NEQN.LT.1) GO TO 10 IF ((RELERR.LT.0.) .OR. (ABSERR.LT.0.)) GO TO 10 MFLAG = ABS(IFLAG) IF ((MFLAG.GE.1) .AND. (MFLAG.LE.7)) GO TO 20 C INVALID INPUT 10 IFLAG = 7 RETURN C IS THIS THE FIRST CALL 20 IF (MFLAG.EQ.1) GO TO 70 C CHECK CONTINUATION POSSIBILITIES IF (T.EQ.TOUT) GO TO 10 IF (MFLAG.NE.2) GO TO 30 C IFLAG = +2 OR -2 IF (INIT.EQ.0) GO TO 60 IF (KFLAG.EQ.3) GO TO 50 IF ((KFLAG.EQ.4) .AND. (ABSERR.EQ.0.)) GO TO 40 IF ((KFLAG.EQ.5) .AND. (RELERR.LE.SAVRE) .AND. * (ABSERR.LE.SAVAE)) GO TO 40 GO TO 70 C IFLAG = 3,4,5,6, OR 7 30 IF (IFLAG.EQ.3) GO TO 50 IF ((IFLAG.EQ.4) .AND. (ABSERR.GT.0.)) GO TO 60 C INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO C THE INSTRUCTIONS PERTAINING TO IFLAG=4,5,6 OR 7 40 STOP C ******************************************************************* C RESET FUNCTION EVALUATION COUNTER 50 NFE = 0 IF (MFLAG.EQ.2) GO TO 70 C RESET FLAG VALUE FROM PREVIOUS CALL 60 IFLAG = JFLAG C SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT C INPUT CHECKING 70 JFLAG = IFLAG KFLAG = 0 C SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS SAVRE = RELERR SAVAE = ABSERR C RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS C 32U+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING C FROM IMPOSSIBLE ACCURACY REQUESTS RER = MAX(RELERR,32.*U+REMIN) U26 = 26.*U DT = TOUT - T IF (MFLAG.EQ.1) GO TO 80 IF (INIT.EQ.0) GO TO 90 GO TO 110 C ******************************************************************* C INITIALIZATION -- C SET INITIALIZATION COMPLETION INDICATOR,INIT C SET INDICATOR FOR TOO MANY OUTPUT POINTS,KOP C EVALUATE INITIAL DERIVATIVES C COPY INITIAL VALUES AND DERIVATIVES FOR THE C PARALLEL SOLUTION C SET COUNTER FOR FUNCTION EVALUATIONS,NFE C ESTIMATE STARTING STEPSIZE 80 INIT = 0 KOP = 0 A = T CALL F(A, Y, YP) NFE = 1 IF (T.NE.TOUT) GO TO 90 IFLAG = 2 RETURN 90 INIT = 1 H = ABS(DT) TOLN = 0. DO 100 K=1,NEQN YG(K) = Y(K) YGP(K) = YP(K) TOL = RER*ABS(Y(K)) + ABSERR IF (TOL.LE.0.) GO TO 100 TOLN = TOL YPK = ABS(YP(K)) IF (YPK*H**5.GT.TOL) H = (TOL/YPK)**0.2 100 CONTINUE IF (TOLN.LE.0.) H = 0. H = MAX(H,U26*MAX(ABS(T),ABS(DT))) C ******************************************************************* C SET STEPSIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT 110 H = SIGN(H,DT) C TEST TO SEE IF GERK IS BEING SEVERELY IMPACTED BY TOO MANY C OUTPUT POINTS IF (ABS(H).GT.2.*ABS(DT)) KOP = KOP + 1 IF (KOP.NE.100) GO TO 120 KOP = 0 IFLAG = 6 RETURN 120 IF (ABS(DT).GT.U26*ABS(T)) GO TO 140 C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN DO 130 K=1,NEQN YG(K) = YG(K) + DT*YGP(K) Y(K) = Y(K) + DT*YP(K) 130 CONTINUE A = TOUT CALL F(A, YG, YGP) CALL F(A, Y, YP) NFE = NFE + 2 GO TO 230 C INITIALIZE OUTPUT POINT INDICATOR 140 OUTPUT = .FALSE. C TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION, C SCALE THE ERROR TOLERANCES SCALE = 2./RER AE = SCALE*ABSERR C ******************************************************************* C ******************************************************************* C STEP BY STEP INTEGRATION 150 HFAILD = .FALSE. C SET SMALLEST ALLOWABLE STEPSIZE HMIN = U26*ABS(T) C ADJUST STEPSIZE IF NECESSARY TO HIT THE OUTPUT POINT. C LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEPSIZE C AND THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE. DT = TOUT - T IF (ABS(DT).GE.2.*ABS(H)) GO TO 170 IF (ABS(DT).GT.ABS(H)) GO TO 160 C THE NEXT SUCCESSFUL STEP WILL COMPLETE THE INTEGRATION TO THE C OUTPUT POINT OUTPUT = .TRUE. H = DT GO TO 170 160 H = 0.5*DT C ******************************************************************* C CORE INTEGRATOR FOR TAKING A SINGLE STEP C ******************************************************************* C THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW C IN COMPUTING THE ERROR TOLERANCE FUNCTION ET. C TO AVOID PROBLEMS WITH ZERO CROSSINGS, RELATIVE ERROR IS C MEASURED USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION C AT THE BEGINNING AND END OF A STEP. C THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF C SIGNIFICANCE. C TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED C TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T. C PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO C SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE C CHATTERING ON PROBLEMS HAVING DISCONTINUITIES. C TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE C STEPSIZE IT ESTIMATES WILL SUCCEED. C AFTER A STEP FAILURE, THE STEPSIZE IS NOT ALLOWED TO INCREASE C FOR THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE C EFFICIENT ON PROBLEMS HAVING DISCONTINUITIES AND MORE C EFFECTIVE IN GENERAL SINCE LOCAL EXTRAPOLATION IS BEING USED C AND THE ERROR ESTIMATE MAY BE UNRELIABLE OR UNACCEPTABLE WHEN C A STEP FAILS. C ******************************************************************* C TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS. C IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H 170 IF (NFE.LE.MAXNFE) GO TO 180 C TOO MUCH WORK IFLAG = 3 KFLAG = 3 RETURN C ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H 180 CALL FEHL(F, NEQN, YG, T, H, YGP, F1, F2, F3, F4, F5, F1) NFE = NFE + 5 C COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR C ESTIMATES AND REMOVE SCALING OF TOLERANCES. NOTE THAT RELATIVE C ERROR IS MEASURED WITH RESPECT TO THE AVERAGE MAGNITUDES OF THE C OF THE SOLUTION AT THE BEGINNING AND END OF THE STEP. EEOET = 0. DO 200 K=1,NEQN ET = ABS(YG(K)) + ABS(F1(K)) + AE IF (ET.GT.0.) GO TO 190 C INAPPROPRIATE ERROR TOLERANCE IFLAG = 4 KFLAG = 4 RETURN 190 EE = ABS((-2090.*YGP(K)+(21970.*F3(K)-15048.*F4(K))) * +(22528.*F2(K)-27360.*F5(K))) EEOET = MAX(EEOET,EE/ET) 200 CONTINUE ESTTOL = ABS(H)*EEOET*SCALE/752400. IF (ESTTOL.LE.1.) GO TO 210 C UNSUCCESSFUL STEP C REDUCE THE STEPSIZE , TRY AGAIN C THE DECREASE IS LIMITED TO A FACTOR OF 1/10 HFAILD = .TRUE. OUTPUT = .FALSE. S = 0.1 IF (ESTTOL.LT.59049.) S = 0.9/ESTTOL**0.2 H = S*H IF (ABS(H).GT.HMIN) GO TO 170 C REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE IFLAG = 5 KFLAG = 5 RETURN C SUCCESSFUL STEP C STORE ONE-STEP SOLUTION YG AT T+H C AND EVALUATE DERIVATIVES THERE 210 TS = T T = T + H DO 220 K=1,NEQN YG(K) = F1(K) 220 CONTINUE A = T CALL F(A, YG, YGP) NFE = NFE + 1 C NOW ADVANCE THE Y SOLUTION OVER TWO STEPS OF C LENGTH H/2 AND EVALUATE DERIVATIVES THERE HH = 0.5*H CALL FEHL(F, NEQN, Y, TS, HH, YP, F1, F2, F3, F4, F5, Y) TS = TS + HH A = TS CALL F(A, Y, YP) CALL FEHL(F, NEQN, Y, TS, HH, YP, F1, F2, F3, F4, F5, Y) A = T CALL F(A, Y, YP) NFE = NFE + 12 C CHOOSE NEXT STEPSIZE C THE INCREASE IS LIMITED TO A FACTOR OF 5 C IF STEP FAILURE HAS JUST OCCURRED, NEXT C STEPSIZE IS NOT ALLOWED TO INCREASE S = 5. IF (ESTTOL.GT.1.889568E-4) S = 0.9/ESTTOL**0.2 IF (HFAILD) S = MIN(S,ONE) H = SIGN(MAX(S*ABS(H),HMIN),H) C ******************************************************************* C END OF CORE INTEGRATOR C ******************************************************************* C SHOULD WE TAKE ANOTHER STEP IF (OUTPUT) GO TO 230 IF (IFLAG.GT.0) GO TO 150 C ******************************************************************* C ******************************************************************* C INTEGRATION SUCCESSFULLY COMPLETED C ONE-STEP MODE IFLAG = -2 GO TO 240 C INTERVAL MODE 230 T = TOUT IFLAG = 2 240 DO 250 K=1,NEQN GERROR(K) = (YG(K)-Y(K))/31. 250 CONTINUE RETURN END SUBROUTINE GERKS SUBROUTINE FEHL(F, NEQN, Y, T, H, YP, F1, F2, F3, F4, F5, S) C FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD C ******************************************************************* C FEHL INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT=F(T,Y(1),---,Y(NEQN)) C WHERE THE INITIAL VALUES Y(I) AND THE INITIAL DERIVATIVES C YP(I) ARE SPECIFIED AT THE STARTING POINT T. FEHL ADVANCES C THE SOLUTION OVER THE FIXED STEP H AND RETURNS C THE FIFTH ORDER (SIXTH ORDER ACCURATE LOCALLY) SOLUTION C APPROXIMATION AT T+H IN ARRAY S(I). C F1,---,F5 ARE ARRAYS OF DIMENSION NEQN WHICH ARE NEEDED C FOR INTERNAL STORAGE. C THE FORMULAS HAVE BEEN GROUPED TO CONTROL LOSS OF SIGNIFICANCE. C FEHL SHOULD BE CALLED WITH AN H NOT SMALLER THAN 13 UNITS OF C ROUNDOFF IN T SO THAT THE VARIOUS INDEPENDENT ARGUMENTS CAN BE C DISTINGUISHED. C ******************************************************************* C .. SCALAR ARGUMENTS .. INTEGER NEQN DOUBLE PRECISION H,T C .. C .. ARRAY ARGUMENTS .. DOUBLE PRECISION F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN), 1 S(NEQN),Y(NEQN),YP(NEQN) C .. C .. SUBROUTINE ARGUMENTS .. EXTERNAL F C .. C .. LOCAL SCALARS .. INTEGER K DOUBLE PRECISION CH C .. CH = 0.25*H DO 10 K=1,NEQN F5(K) = Y(K) + CH*YP(K) 10 CONTINUE CALL F(T+0.25*H, F5, F1) CH = 0.09375*H DO 20 K=1,NEQN F5(K) = Y(K) + CH*(YP(K)+3.*F1(K)) 20 CONTINUE CALL F(T+0.375*H, F5, F2) CH = H/2197. DO 30 K=1,NEQN F5(K) = Y(K) + CH*(1932.*YP(K)+(7296.*F2(K)-7200.*F1(K))) 30 CONTINUE CALL F(T+12./13.*H, F5, F3) CH = H/4104. DO 40 K=1,NEQN F5(K) = Y(K) + CH*((8341.*YP(K)-845.*F3(K))+(29440.*F2(K) * -32832.*F1(K))) 40 CONTINUE CALL F(T+H, F5, F4) CH = H/20520. DO 50 K=1,NEQN F1(K) = Y(K) + CH*((-6080.*YP(K)+(9295.*F3(K)-5643.*F4(K))) * +(41040.*F1(K)-28352.*F2(K))) 50 CONTINUE CALL F(T+0.5*H, F1, F5) C COMPUTE APPROXIMATE SOLUTION AT T+H CH = H/7618050. DO 60 K=1,NEQN S(K) = Y(K) + CH*((902880.*YP(K)+(3855735.*F3(K)-1371249.* * F4(K)))+(3953664.*F2(K)+277020.*F5(K))) 60 CONTINUE RETURN END SUBROUTINE FEHL DOUBLE PRECISION FUNCTION EPSLON (X) DOUBLE PRECISION X C C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. C DOUBLE PRECISION A,B,C,EPS,FOUR,THREE C C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS C SATISFYING THE FOLLOWING TWO ASSUMPTIONS, C 1. THE BASE USED IN REPRESENTING FLOATING POINT C NUMBERS IS NOT A POWER OF THREE. C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO C THE ACCURACY USED IN FLOATING POINT VARIABLES C THAT ARE STORED IN MEMORY. C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING C ASSUMPTION 2. C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, C B HAS A ZERO FOR ITS LAST BIT OR DIGIT, C C IS NOT EXACTLY EQUAL TO ONE, C EPS MEASURES THE SEPARATION OF 1.0 FROM C THE NEXT LARGER FLOATING POINT NUMBER. C FOUR = 4.0 THREE = 3.0 A = FOUR/THREE 10 B = A - 1.0 C = B + B + B EPS = ABS(C-1.0) IF (EPS .EQ. 0.0) GO TO 10 EPSLON = EPS*ABS(X) RETURN END FUNCTION EPSLON end module sleignmd SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'sleign2' then mkdir 'sleign2' fi cd 'sleign2' if test -f 'sleig2md.f' then echo shar: will not over-write existing file "'sleig2md.f'" else cat << SHAR_EOF > 'sleig2md.f' C Revision of sleig2md.f1 4/9/98 C Removes some EXTERNAL statements that refer to module procedures C Marked with cc? at start of line module sleig2md private public::sleign2 contains C THIS VERSION OF SLEIGN2 IS DATED SEPT. 8, 1994. C DOUBLE PRECISION version (created using NAG F77 Tools) C C This program is for an equation of the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) C subroutine SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2, + NUMEIG,EIG,TOL,IFLAG,ISLFUN,SLFUN,SINGATA, + SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) C ********** C C This subroutine is designed for the calculation of a specified C eigenvalue, EIG, of a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions p, q, and w. C The problem may be either nonsingular or singular. In the C nonsingular case, boundary conditions of the form C C A1*y(a) + A2*p(a)*y'(a) = 0 C B1*y(b) + B2*p(b)*y'(b) = 0 C C are prescribed by specifying the numbers A1, A2, B1, and B2. C The index of the desired eigenvalue is specified in NUMEIG C and its requested accuracy in TOL. Initial data for the C associated eigenfunction are also computed along with values C at selected points, if desired, in array SLFUN. C C In addition to the coefficient functions p, q, and w, the user C must supply subroutine UV to describe the boundary condition C when the problem is limit circle. UV can be a dummy subroutine C if the problem is not limit circle. C C The SUBROUTINE statement is C C SUBROUTINE sleign2(a,b,intab,p0ata,qfata,p0atb,qfatb,a1,a2,b1,b2, C numeig,eig,tol,iflag,islfun,slfun, C singata,singatb,circla,circlb,oscila,oscilb) C C where C C A and B are input variables defining the interval. If the C interval is finite, A must be less than B. (See INTAB below.) C C INTAB is an integer input variable specifying the nature of the C interval. It can have four values. C C INTAB = 1 - A and B are finite. C INTAB = 2 - A is finite and B is infinite (+). C INTAB = 3 - A is infinite (-) and B is finite. C INTAB = 4 - A is infinite (-) and B is infinite (+). C C If either A or B is infinite, it is classified singular and C its value is ignored. C C P0ATA, QFATA, P0ATB, and QFATB are input variables set to C 1.0 or -1.0 as the following properties of p, q, and w at C the interval endpoints are true or false, respectively. C C P0ATA - p(a) is zero. (If true, A is singular.) C QFATA - q(a) and w(a) are finite. (If false, A is singular.) C P0ATB - p(b) is zero. (If true, B is singular.) C QFATB - q(b) and w(b) are finite. (If false, B is singular.) C C A1 and A2 are input variables set to prescribe the boundary C condition at A. Their values are ignored if A is singular. C C B1 and B2 are input variables set to prescribe the boundary C condition at B. Their values are ignored if B is singular. C C NUMEIG is an integer variable. On input, it should be set to C the index of the desired eigenvalue (increasing sequence where C index 0 corresponds to the smallest nonnegative eigenvalue). C On output, it is unchanged unless the problem (apparently) C lacks eigenvalue NUMEIG, in which case it is reset to the C index of the largest eigenvalue. C C EIG is a variable set on input to 0.0 or to an initial guess of C the eigenvalue. If EIG is set to 0.0, SLEIGN2 will generate C the initial guess. On output, EIG holds the calculated C eigenvalue if IFLAG (see below) signals success. C C TOL is a variable set on input to the desired accuracy of the C eigenvalue. On output, TOL is reset to the accuracy estimated C to have been achieved if IFLAG (see below) signals success. C This accuracy estimate is absolute if EIG is less than one C in magnitude, and relative otherwise. In addition, prefixing C TOL with a negative sign, removed after interrogation, serves C as a flag to request trace output from the calculation. C C IFLAG is an integer output variable set as follows. C C IFLAG = 1 - successful problem solution. C IFLAG = 2 - integrator tolerance cannot be reduced. C IFLAG = 3 - no more improvement. C IFLAG = 4 - RAY and EIG fail to agree after 5 tries. C IFLAG = 6 - in SECANT-METHOD, ABS(DE) .LT. EPSMIN . C IFLAG = 7 - iterations are stuck in a loop. C IFLAG = 8 - number of iterations has reached the set limit. C IFLAG = 9 - residual truncation error dominates. C IFLAG = 10 - improper input parameters. C IFLAG = 11 - NUMEIG exceeds actual highest eigenvalue index. C IFLAG = 12 - failed to get a bracket. C IFLAG = 13 - AA cannot be moved in any further. C IFLAG = 14 - BB cannot be moved in any further. C IFLAG = 51 - integration failure after 1st call to INTEG. C IFLAG = 52 - integration failure after 2nd call to INTEG. C IFLAG = 53 - integration failure after 3rd call to INTEG. C IFLAG = 54 - integration failure after 4th call to INTEG. C C ISLFUN is an integer input variable set to the number of C selected eigenfunction values desired. If no values are C desired, set ISLFUN zero or negative. C C SLFUN is an array of length at least 9. On output, the first 9 C locations contain the integration interval and initial data C that completely determine the eigenfunction. C C SLFUN(1) - point where two pieces of eigenfunction Y match. C SLFUN(2) - left endpoint XAA of the (truncated) interval. C SLFUN(3) - value of THETA at XAA. (Y = RHO*sin(THETA)) C SLFUN(4) - value of F at XAA. (RHO = exp(F)) C SLFUN(5) - right endpoint XBB of the (truncated) interval. C SLFUN(6) - value of THETA at XBB. C SLFUN(7) - value of F at XBB. C SLFUN(8) - final value of integration accuracy parameter EPS. C SLFUN(9) - the constant Z in the polar form transformation. C C F(XAA) and F(XBB) are chosen so that the eigenfunction is C continuous in the interval (XAA,XBB) and has weighted (by W) C L2-norm of 1.0 on the interval. If ISLFUN is positive, then C on input the further ISLFUN locations of SLFUN specify the C points, in ascending order, where the eigenfunction values C are desired and on output contain the values themselves. C C SINGATA is an input variable set positive if endpoint A C is singular, and negative or zero if A is nonsingular. C C SINGATB is an input variable set positive if endpoint B C is singular, and negative or zero if B is nonsingular. C C CIRCLA is an input variable set positive if endpoint A has C a limit-circle singularity, and negative or zero if not. C C CIRCLB is an input variable set positive if endpoint B has C a limit-circle singularity, and negative or zero if not. C C OSCILA is an input variable set positive if the limit-circle C singularity at A is oscillatory, and negative or zero if not. C C OSCILB is an input variable set positive if the limit-circle C singularity at B is oscillatory, and negative or zero if not. C C Subprograms called C C user-supplied ..... p,q,w,uv C C sleign2-supplied .. aabb,alfbet,dxdt,eigenf,epslon,estpac,integ, C setmid,tfromi,thum C C This version dated 6/21/94. C Paul B. Bailey, Albuquerque, New Mexico C Burton S. Garbow, Park Forest, Illinois C C ********** C .. Scalars in Common .. double precision AA,ASAV,BB,BSAV,C1,C2,DTHDAA,DTHDBB,EIGSAV, + EPSMIN,HPI,PI,TMID,TSAVEL,TSAVER,TWOPI,Z integer IND,INTSAV,MDTHZ logical ADDD C .. C .. Arrays in Common .. double precision TEE(100),ZEE(100) integer JAY(100) C .. C .. Local Scalars .. double precision AAA,AAAA,AAS,ALFA,BALLPK,BBB,BBBB,BBS,BESTEIG, + BESTEST,BETA,C,CHNG,CHNGLIM,CL,CR,DAV,DE,DEDW, + DEN,DERIVL,DERIVR,DIST,DT,DTHDA,DTHDAAX,DTHDB, + DTHDBBX,DTHDE,DTHDEA,DTHDEB,DTHETA,DTHOLD, + DTHOLDY,DTHZ,DUM,E,EEE,EIGLO,EIGLT,EIGPI,EIGRT, + EIGUP,EL,ELIMA,ELIMB,ELIMUP,EMAX,EMIN,EOLD,EPS, + EPSM,ER1,ER2,ESTERR,EU,FLO,FMAX,FNEW,FOLD,FUP, + GUESS,HU,HV,OLDEST,OLDRAY,ONE,PIN,PSIL,PSIPL, + PSIPR,PSIR,PUP,PVP,PX,QAV,QX,RATL1,RATL2,RATL3, + RATR1,RATR2,RATR3,RAY,REMZ,RLX,SL,SL1,SL2,SL3, + SQL,SQR,SR,SR1,SR2,SR3,SUM,SUM0,T,T1,T2,T3,TAU, + THA,THB,THRESH,TMP,TS,U,UL,UR,UT,V,WAV,WL,WU,WX, + X,X50,XAA,XBB,XMID,XSAV,XT,ZAV integer I,IA,IB,IE,IMAX,IMID,IMIN,IOUT,JFLAG,JJL,JJR,K,KFLAG, + LOOP2,LOOP3,MF,ML,MP,NEIG,NITER,NRAY logical AOK,BOK,BRACKT,CHNGEPS,CONVRG,ENDA,ENDB,EXIT,FIRSTT,FYNYT, + FYNYT1,LCIRCA,LCIRCB,LIMA,LIMB,LIMUP,LOGIC,NEWTON,NEWTONF, + OLDNEWT,ONEDIG,OSCA,OSCB,PRIN,SINGA,SINGB,THEGT0,THELT0 C .. C .. Local Arrays .. double precision DELT(99),DS(99),ERL(3),ERR(3),PS(99),PSS(99), + QS(99),WS(99),XS(99),YL(3),YR(3),YZL(3),YZR(3) C .. C .. External Functions .. double precision P,Q,W external P,Q,W C .. C .. External Subroutines .. cc external AABB,ALFBET,DXDT,EIGFCN,ESTPAC,INTEG,SETMID,THUM,UV C .. C .. Intrinsic Functions .. intrinsic ABS,ATAN,COS,EXP,INT,LOG,MAX,MIN,SIGN,SIN,SQRT C .. C .. Common blocks .. common /DATADT/ASAV,BSAV,C1,C2,INTSAV common /DATAF/EIGSAV,IND common /PIE/PI,TWOPI,HPI common /RNDOFF/EPSMIN common /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ common /TEEZ/TEE common /TSAVE/TSAVEL,TSAVER common /ZEE/Z common /ZEEZ/JAY,ZEE C .. C .. Scalar Arguments .. double precision A,A1,A2,B,B1,B2,CIRCLA,CIRCLB,EIG,OSCILA,OSCILB, + P0ATA,P0ATB,QFATA,QFATB,SINGATA,SINGATB,TOL integer IFLAG,INTAB,ISLFUN,NUMEIG C .. C .. Array Arguments .. double precision SLFUN(9) C .. C Set constants EPSMIN, the computer unit roundoff error, and PI. C (Variable ONE set to 1.0 eases precision conversion.) C Initialize PSS (John Pryce) C ONE = 1.0D0 EPSMIN = EPSLON(ONE) PI = 4.0D0*ATAN(ONE) TWOPI = 2.0D0*PI HPI = 0.5D0*PI do 3 I=1,99 PSS(I) = 0.0D0 3 continue C C Set output device number. C IOUT = 6 C C Check input parameters for errors. If errors, return IFLAG=2. C LOGIC = 1 .le. INTAB .and. INTAB .le. 4 .and. + P0ATA*QFATA*P0ATB*QFATB .ne. 0.0D0 if (INTAB.eq.1) LOGIC = LOGIC .and. A .lt. B if (.not.LOGIC) then IFLAG = 10 go to 150 end if C C Set PRIN = .true. to trigger trace printout of successive steps. C PRIN = .FALSE. if (TOL.lt.0.0D0) PRIN = .TRUE. C C Set EPS to the (initial) integration accuracy. C EPS = 0.0001D0 C C Set logical variables. C AOK = INTAB .lt. 3 .and. P0ATA .lt. 0.0D0 .and. QFATA .gt. 0.0D0 BOK = (INTAB.eq.1 .or. INTAB.eq.3) .and. P0ATB .lt. 0.0D0 .and. + QFATB .gt. 0.0D0 SINGA = SINGATA .gt. 0.0D0 SINGB = SINGATB .gt. 0.0D0 LCIRCA = CIRCLA .gt. 0.0D0 LCIRCB = CIRCLB .gt. 0.0D0 OSCA = OSCILA .gt. 0.0D0 OSCB = OSCILB .gt. 0.0D0 EIGPI = NUMEIG*PI NEIG = NUMEIG - 1 C C Initial C1 and C2, used in the mapping between X and T intervals. C C1 = 1.0D0 C2 = 0.0D0 C DO (SAVE-INPUT-DATA) ASAV = A BSAV = B INTSAV = INTAB TAU = ABS(TOL) C END (SAVE-INPUT-DATA) C C Initialize the arrays JAY and ZEE if either end is oscillatory. C if (OSCA .or. OSCB) then do 5 K = 1,100 JAY(K) = 0 ZEE(K) = 1.0D0 5 continue end if C C Evaluate P, Q, W to obtain preliminary information about the C differential equation. C C DO (SAMPLE-COEFFICIENTS) THRESH = 1.0D+17 10 continue call DXDT(EPSMIN,TMP,X50) XS(50) = X50 TS = EPSMIN PX = P(X50) QX = Q(X50) WX = W(X50) PS(50) = PX QS(50) = QX/PX WS(50) = WX/PX C C DAV,QAV,WAV are used in special case estimation when NUMEIG = 0,1. C EMIN = min(Q/W), achieved at X for index value IMIN. C EMAX = max(Q/W), achieved at X for index value IMAX. C MF and ML are the least and greatest index values, respectively. C DAV = 0.0D0 QAV = 0.0D0 WAV = 0.0D0 XSAV = X50 EMIN = 0.0D0 if (QX.ne.0.0D0) EMIN = QX/WX EMAX = EMIN IMIN = 50 IMAX = 50 do 20 I = 49,1,-1 T = TFROMI(I) call DXDT(T,TMP,X) XS(I) = X PX = P(X) QX = Q(X) WX = W(X) PS(I) = PX QS(I) = QX/PX WS(I) = WX/PX DS(I) = XSAV - X DELT(I) = 0.5D0* (TS-T) DAV = DAV + DS(I) QAV = QAV + DS(I)* (0.5D0* (QS(I)+QS(I+1))-QAV)/DAV WAV = WAV + DS(I)* (0.5D0* (WS(I)+WS(I+1))-WAV)/DAV XSAV = X TS = T C C Try to avoid overflow by stopping when functions are large near A. C FYNYT = (ABS(WX)+ABS(QX)+1.0D0/ABS(PX)) .le. THRESH if (QX.ne.0.0D0 .and. QX/WX.lt.EMIN) then EMIN = QX/WX IMIN = I end if if (QX.ne.0.0D0 .and. QX/WX.gt.EMAX) then EMAX = QX/WX IMAX = I end if MF = I if (.not.FYNYT) go to 30 20 continue 30 continue AAA = T if (.not.SINGA) AAA = -1.0D0 XSAV = X50 do 40 I = 51,99 T = TFROMI(I) call DXDT(T,TMP,X) XS(I) = X PX = P(X) QX = Q(X) WX = W(X) PS(I) = PX QS(I) = QX/PX WS(I) = WX/PX DS(I-1) = X - XSAV DELT(I-1) = 0.5D0* (T-TS) DAV = DAV + DS(I-1) QAV = QAV + DS(I-1)* (0.5D0* (QS(I-1)+QS(I))-QAV)/DAV WAV = WAV + DS(I-1)* (0.5D0* (WS(I-1)+WS(I))-WAV)/DAV XSAV = X TS = T C C Try to avoid overflow by stopping when functions are large near B. C FYNYT1 = (ABS(QX)+ABS(WX)+1.0D0/ABS(PX)) .le. THRESH if (QX.ne.0.0D0 .and. QX/WX.lt.EMIN) then EMIN = QX/WX IMIN = I end if if (QX.ne.0.0D0 .and. QX/WX.gt.EMAX) then EMAX = QX/WX IMAX = I end if ML = I - 1 if (.not.FYNYT1) go to 50 40 continue 50 continue BBB = T if (.not.SINGB) BBB = 1.0D0 LOGIC = C1 .eq. 1.0D0 .and. (.not.FYNYT .or. .not.FYNYT1) C C Modify (T,X) transformation corresponding to truncated interval. C if (LOGIC) then C1 = 0.5D0* (BBB-AAA) C2 = 0.5D0* (AAA+BBB) go to 10 end if if (OSCA .or. OSCB) call THUM(MF,ML,XS) C C Here we try to determine 'sigma0'. Initially, we will be C satisfied to determine eliml and elimr, the limiting values C of q/w, if they exist. C LIMA = .FALSE. if (SINGA .and. .not.LCIRCA) then RATL1 = QS(MF)/WS(MF) RATL2 = QS(MF+1)/WS(MF+1) RATL3 = QS(MF+2)/WS(MF+2) SL1 = RATL1/ (XS(MF+1)-XS(MF)) SL2 = RATL2/ (XS(MF+2)-XS(MF+1)) SL3 = RATL3/ (XS(MF+3)-XS(MF+2)) if (ABS(SL2).ge.ABS(SL1) .and. ABS(SL2).le.ABS(SL3)) then ELIMA = RATL1 LIMA = PS(MF) .eq. PS(MF+1) WRITE (021,FMT=*) ' There is a limit at a = ',ELIMA write (21,FMT=*) ' There is a limit at a = ',ELIMA end if end if LIMB = .FALSE. if (SINGB .and. .not.LCIRCB) then RATR1 = QS(ML)/WS(ML) RATR2 = QS(ML-1)/WS(ML-1) RATR3 = QS(ML-2)/WS(ML-2) SR1 = RATR1/ (XS(ML)-XS(ML-1)) SR2 = RATR2/ (XS(ML-1)-XS(ML-2)) SR3 = RATR3/ (XS(ML-2)-XS(ML-3)) if (ABS(SR2).ge.ABS(SR1) .and. ABS(SR2).le.ABS(SR3)) then ELIMB = RATR1 LIMB = PS(ML) .eq. PS(ML-1) WRITE (021,FMT=*) ' There is a limit at b = ',ELIMB write (21,FMT=*) ' There is a limit at b = ',ELIMB end if end if LIMUP = .FALSE. ELIMUP = EMAX if (LIMA .or. LIMB) then LIMUP = .TRUE. if (.not.LIMB) then ELIMUP = ELIMA else if (.not.LIMA) then ELIMUP = ELIMB else ELIMUP = MIN(ELIMA,ELIMB) end if write (21,FMT=*) ' The continuous spectrum has a lower ' write (21,FMT=*) ' bound, sigma0 = ',ELIMUP end if C END (SAMPLE-COEFFICIENTS) PIN = EIGPI + PI if (EIG.eq.0.0D0) then C DO (ESTIMATE-EIG) SUM0 = 0.0D0 if (OSCA .or. OSCB) then EEE = 0.0D0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS,TAU, + IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) SUM0 = SUM end if EEE = MIN(ELIMUP,EMAX) C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS,TAU,IA, + IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) 17 continue if (.not.LIMUP .and. ABS(SUM).ge. + 10.D0*MAX(1.0D0,ABS(PIN))) then if (SUM.ge.10.D0*PIN) then if (EEE.ge.1.0D0) then EEE = EEE/10.D0 else if (EEE.lt.-1.0D0) then EEE = 10.D0*EEE else EEE = EEE - 1.0D0 end if else if (SUM.le.10.D0*PIN) then if (EEE.le.-1.0D0) then EEE = EEE/10.D0 else if (EEE.gt.1.0D0) then EEE = 10.D0*EEE else EEE = EEE + 1.0D0 end if else go to 27 end if C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS,TAU, + IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) go to 17 end if 27 continue C EU = EEE WU = SUM if (SUM.ge.PIN) then EL = EU WL = WU 60 continue if (WL.ge.PIN) then EU = EL WU = WL EEE = EL - ((WL-PIN+3.0D0)/U)**2 - 1.0D0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS, + TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EL = EEE WL = SUM go to 60 end if else EL = EEE WL = SUM end if if (LIMUP .and. WU.lt.PIN) then EEE = ELIMUP else if (U.eq.0.0D0) then EEE = EMAX + 1.0D0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS, + TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EU = EEE WU = SUM end if 70 continue if (WU.le.PIN) then EL = EU WL = WU EEE = EU + ((PIN-WU+3.0D0)/U)**2 + 1.0D0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS, + TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EU = EEE WU = SUM go to 70 end if 80 continue if (ABS(IMAX-IMIN).ge.2 .and. EU.le.EMAX) then IE = (IMAX+IMIN)/2 EEE = QS(IE)/WS(IE) C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS, + TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) if (SUM.gt.PIN) then IMAX = IE WU = SUM EU = EEE else IMIN = IE WL = SUM EL = EEE end if go to 80 end if C C Improve approximation for EIG using bisection or secant method. C Substitute 'ballpark' estimate if approximation grows too large. C DEDW = (EU-EL)/ (WU-WL) FOLD = 0.0D0 if (INTAB.eq.1) BALLPK = (PIN/ (A-B))**2 if (INTAB.eq.1) write (21,FMT=*) ' BALLPK = ',BALLPK LOGIC = .TRUE. 90 continue if (LOGIC) then LOGIC = (WL.lt.PIN-1.0D0 .or. WU.gt.PIN+1.0D0) EEE = EL + DEDW* (PIN-WL) FNEW = MIN(PIN-WL,WU-PIN) if (FNEW.gt.0.4D0*FOLD .or. FNEW.le.1.0D0) EEE = 0.5D0* + (EL+EU) if (INTAB.eq.1 .and. ABS(EEE).gt.1.0D3*BALLPK) then EEE = BALLPK go to 100 else if (INTAB.ne.1 .and. ABS(EEE).gt.1.0D6) then EEE = 1.0D0 go to 100 else FOLD = FNEW C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS, + PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) if (SUM.lt.PIN) then EL = EEE WL = SUM else EU = EEE WU = SUM end if DEDW = (EU-EL)/ (WU-WL) go to 90 end if end if end if C END (ESTIMATE-EIG) end if 100 continue GUESS = EIG if (LIMUP .and. EEE.ge.ELIMUP) EEE = ELIMUP - 0.01D0 C DO (SET-INITIAL-INTERVAL-AND-MATCHPOINT) if (GUESS.ne.0.0D0) then EEE = EIG C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS,TAU,IA, + IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) end if C C Choose initial interval as large as possible that avoids overflow. C JJL and JJR are boundary indices for nonnegativity of EIG*W-Q. C AA = -1.0D0 if (SINGA) AA = TFROMI(JJL) BB = 1.0D0 if (SINGB) BB = TFROMI(JJR) AA = MIN(-0.01D0,AA) BB = MAX(0.01D0,BB) AA = MIN(AA,-0.9D0) BB = MAX(BB,0.9D0) if (OSCA) AA = -0.9999D0 if (OSCB) BB = 0.9999D0 C C Determine boundary values ALFA and BETA for theta at A and B. C Z = 1.0D0 call ALFBET(A,INTAB,AA,A1,A2,EEE,P0ATA,QFATA,SINGA,LCIRCA,ALFA, + KFLAG,DERIVL) call ALFBET(B,INTAB,BB,B1,B2,EEE,P0ATB,QFATB,SINGB,LCIRCB,BETA, + JFLAG,DERIVR) if (SINGB) BETA = PI - BETA C C Take boundary conditions into account in estimation of EIG. C PIN = EIGPI + BETA - ALFA if (OSCA) PIN = PIN + ALFA if (OSCB) PIN = PIN + PI - BETA if (GUESS.eq.0.0D0) then EEE = EL + DEDW* (PIN-WL) if (.not. (OSCA.or.OSCB) .and. + ABS(EEE).gt.1000.0D0) EEE = SIGN(1000.0D0,EEE) if (INTAB.eq.1 .and. ABS(EEE).gt.1.0D3*BALLPK) EEE = BALLPK end if C DO (ESTIMATE-PHASE-ANGLE-CHANGE) call ESTPAC(OSCA .or. OSCB,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS, + TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) C C Choose the constant Z . C if (U.gt.0.0D0) Z = ZAV/UT C C Reset boundary values ALFA and BETA . C call ALFBET(A,INTAB,AA,A1,A2,EEE,P0ATA,QFATA,SINGA,LCIRCA,ALFA, + KFLAG,DERIVL) call ALFBET(B,INTAB,BB,B1,B2,EEE,P0ATB,QFATB,SINGB,LCIRCB,BETA, + JFLAG,DERIVR) if (SINGB) BETA = PI - BETA if (PRIN) write (IOUT,FMT='(A,E22.14,A,E22.14)') ' alfa=',ALFA, + ' beta=',BETA write (21,FMT='(A,E22.14,A,E22.14)') ' alfa=',ALFA,' beta=',BETA C C Special case formula for estimation of EIG when NUMEIG = 0,1. C if (U.eq.0.0D0 .and. NUMEIG.le.0 .and. (BETA+EIGPI).lt.ALFA) then C XBC = MAX(-1.0/TAN(ALFA),1.0/TAN(BETA)) C EEE = -(XBC*XBC-QAV)/WAV C DEDW = XBC*(1.0+XBC*XBC)/WAV end if C C Choose initial matching point TMID . C IMID = 50 TMID = 0.5D0* (AA+BB) if (PRIN) write (IOUT,FMT='(A,E15.7,A,F11.8,A,E15.7)') ' estim=', + EEE,' tmid=',TMID,' z=',Z if (PRIN) write (IOUT,FMT='(A,F11.8,A,F11.8,A,F11.8,A,F11.8)') + ' aaa=',AAA,' aa=',AA,' bb=',BB,' bbb=',BBB write (21,FMT='(A,E15.7,A,F11.8,A,E15.7)') ' estim=',EEE, + ' tmid=',TMID,' z=',Z write (21,FMT='(A,F11.8,A,F11.8,A,F11.8,A,F11.8)') ' aaa=',AAA, + ' aa=',AA,' bb=',BB,' bbb=',BBB C END (SET-INITIAL-INTERVAL-AND-MATCHPOINT) if (EIG.eq.0.0D0 .and. LIMUP .and. EEE.ge.ELIMUP) EEE = ELIMUP - + 0.01D0 C DO (RESET-TMID) call SETMID(MF,ML,EEE,QS,WS,IMID,TMID) C END (RESET-TMID) if (OSCA .or. OSCB) then Z = 1.0D0 C DO (PREP-ZEEZ) do 85 I = 1,100 TEE(I) = 1.0D0 if (JAY(I).ne.0) TEE(I) = TFROMI(JAY(I)) 85 continue C END (PREP-ZEEZ) end if if (IFLAG.eq.-1) then SLFUN(1) = TMID SLFUN(2) = AA SLFUN(3) = ALFA SLFUN(5) = BB SLFUN(6) = BETA + EIGPI SLFUN(9) = Z ADDD = .FALSE. MDTHZ = 0 IFLAG = 1 return end if C C End preliminary work, begin main task of computing EIG. C C Logical variables have the following meanings if true. C AOK - endpoint A is not singular. C BOK - endpoint B is not singular. C BRACKT - EIG has been bracketed. C CONVRG - convergence test for EIG has been successfully passed. C NEWTON - Newton iteration may be employed. C THELT0 - lower bound for EIG has been found. C THEGT0 - upper bound for EIG has been found. C LIMIT - upper bound exists with boundary conditions satisfied. C ONEDIG - most significant digit can be expected to be correct. C EIG = EEE NRAY = 1 EXIT = .FALSE. FIRSTT = .TRUE. LOOP2 = 0 LOOP3 = 0 MP = 0 BESTEIG = EIG BESTEST = 1.D+9 OLDEST = BESTEST NEWTONF = .FALSE. CHNGEPS = .FALSE. EPSM = EPSMIN AAAA = AAA BBBB = BBB ENDA = .FALSE. ENDB = .FALSE. TSAVEL = -1.0D0 TSAVER = 1.0D0 110 continue C DO (INITIAL-IZE) BRACKT = .FALSE. CONVRG = .FALSE. THELT0 = .FALSE. THEGT0 = .FALSE. EIGLO = EMIN - 1.0D0 EIGLT = 0.0D0 EIGRT = 0.0D0 EIGUP = EMAX + 1.0D0 if (LIMUP) EIGUP = MIN(EMAX,ELIMUP) DTHOLD = 1.0D0 IFLAG = 1 C END (INITIAL-IZE) write (21,FMT=*) write (21,FMT=*) '---------------------------------------------' write (21,FMT=*) ' INITIAL GUESS FOR EIG = ',EIG write (21,FMT=*) ' aa,bb = ',AA,BB C DO UNTIL(CONVRG .OR. EXIT) do 120 NITER = 1,40 WRITE (021,FMT=*) WRITE (021,FMT=*) ' ******************** ' C DO (SET-TMID-AND-BOUNDARY-CONDITIONS) WRITE (021,FMT=*) ' set tmid and boundary conditions ' V = EIG*WS(IMID) - QS(IMID) C IF (V.LE.0.0) DO (RESET-TMID) if (V.le.0.0D0) call SETMID(MF,ML,EIG,QS,WS,IMID,TMID) C END (RESET-TMID) C DO (RESET-BOUNDARY-CONDITIONS) DERIVL = 0.0D0 if (SINGA) call ALFBET(A,INTAB,AA,A1,A2,EIG,P0ATA,QFATA,.TRUE., + LCIRCA,ALFA,KFLAG,DERIVL) DERIVR = 0.0D0 if (SINGB) then call ALFBET(B,INTAB,BB,B1,B2,EIG,P0ATB,QFATB,.TRUE.,LCIRCB, + BETA,JFLAG,DERIVR) BETA = PI - BETA end if if (PRIN) write (IOUT,FMT='(A,E22.14,A,E22.14)') ' alfa=',ALFA, + ' beta=',BETA C END (RESET-BOUNDARY-CONDITIONS) C C Check that boundary conditions can be satisfied at singular C endpoints. If not, try for slightly altered EIG consistent C with boundary conditions. C if (LIMUP .and. EIG.ne.GUESS .and. .not.BRACKT) then 115 continue KFLAG = 1 if (SINGA .and. .not.LCIRCA) call ALFBET(A,INTAB,AA,A1,A2, + EIG,P0ATA,QFATA,.TRUE.,.FALSE.,TMP,KFLAG,TMP) JFLAG = 1 if (SINGB .and. .not.LCIRCB) call ALFBET(B,INTAB,BB,B1,B2, + EIG,P0ATB,QFATB,.TRUE.,.FALSE.,TMP,JFLAG,TMP) if ((KFLAG.ne.1.or.JFLAG.ne.1) .and. + (THELT0.and.EIGLO.lt.ELIMUP)) then EIGUP = ELIMUP EIG = ELIMUP - EPSMIN go to 115 end if end if C END (SET-TMID-AND-BOUNDARY-CONDITIONS) C DO (OBTAIN-DTHETA-WITH-ONE-CORRECT-DIGIT) if (PRIN) write (IOUT,FMT='(/A,E22.14,A,E10.3,A,E10.3)') + ' guess=',EIG,' eps=',EPS,' tmid=',TMID C DO (INTEGRATE-FOR-DTHETA) C DO (SET-INITIAL-CONDITIONS) THA = ALFA DTHDEA = DERIVL DTHDAA = 0.0D0 if (SINGA .and. .not.LCIRCA) then call DXDT(AA,DT,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z C = EIG*WX - QX DTHDAA = - (COS(ALFA)**2/PX+C*SIN(ALFA)**2)*DT C C Two special cases for DTHDAA . C if (C.ge.0.0D0 .and. P0ATA.lt.0.0D0 .and. + QFATA.lt.0.0D0) DTHDAA = DTHDAA + ALFA*DT/ (X-A) if (C.ge.0.0D0 .and. P0ATA.gt.0.0D0 .and. + QFATA.gt.0.0D0) DTHDAA = DTHDAA + (ALFA-0.5D0*PI)*DT/ + (X-A) end if THB = BETA DTHDEB = -DERIVR DTHDBB = 0.0D0 if (SINGB .and. .not.LCIRCB) then call DXDT(BB,DT,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z C = EIG*WX - QX DTHDBB = - (COS(BETA)**2/PX+C*SIN(BETA)**2)*DT C C Two special cases for DTHDBB . C if (C.ge.0.0D0 .and. P0ATB.lt.0.0D0 .and. + QFATB.lt.0.0D0) DTHDBB = DTHDBB + (PI-BETA)*DT/ (B-X) if (C.ge.0.0D0 .and. P0ATB.gt.0.0D0 .and. + QFATB.gt.0.0D0) DTHDBB = DTHDBB + (0.5D0*PI-BETA)*DT/ + (B-X) end if C END (SET-INITIAL-CONDITIONS) EIGSAV = EIG C T C YL = (theta,d(theta)/d(eig),d(theta)/da) C YL(1) = ALFA YL(2) = DTHDEA YL(3) = 0.0D0 C call INTEG(AA,THA,DTHDAA,DTHDEA,TMID,A1,A2,EPS,YL,ERL,LCIRCA, + AOK,SINGA,OSCA,IFLAG) if (IFLAG.eq.5) then IFLAG = 51 WRITE (021,FMT=*) ' IFLAG = 51 ' EXIT = .TRUE. go to 130 end if DTHDA = DTHDAA*EXP(-2.0D0*YL(3)) C T C YR = (theta,d(theta)/d(eig),d(theta)/db) C YR(1) = BETA + EIGPI - PI YR(2) = DTHDEB YR(3) = 0.0D0 C call INTEG(BB,THB,DTHDBB,DTHDEB,TMID,B1,B2,EPS,YR,ERR,LCIRCB, + BOK,SINGB,OSCB,IFLAG) if (IFLAG.eq.5) then IFLAG = 52 WRITE (021,FMT=*) ' IFLAG = 52 ' EXIT = .TRUE. go to 130 end if DTHDB = DTHDBB*EXP(-2.0D0*YR(3)) C ER1 = ERL(1) - ERR(1) ER2 = ERL(2) - ERR(2) C if (OSCA .or. OSCB) then Z = 1.0D0 call DXDT(TMID,TMP,XT) call UV(XT,U,PUP,V,PVP,HU,HV) EIGSAV = 0.0D0 call INTEG(AA,THA,DTHDAA,DTHDEA,TMID,A1,A2,EPS,YZL,ERL, + LCIRCA,AOK,SINGA,OSCA,IFLAG) if (IFLAG.eq.5) then IFLAG = 53 WRITE (021,FMT=*) ' IFLAG = 53 ' EXIT = .TRUE. go to 130 end if call INTEG(BB,THB,DTHDBB,DTHDEB,TMID,B1,B2,EPS,YZR,ERR, + LCIRCB,BOK,SINGB,OSCB,IFLAG) if (IFLAG.eq.5) then IFLAG = 54 WRITE (021,FMT=*) ' IFLAG = 54 ' EXIT = .TRUE. go to 130 end if EIGSAV = EIG DTHZ = YZR(1) - YZL(1) MDTHZ = DTHZ/PI REMZ = DTHZ - MDTHZ*PI if (DTHZ.lt.0.0D0 .and. REMZ.lt.0.0D0) then MDTHZ = MDTHZ - 1 REMZ = REMZ + PI end if if (REMZ.gt.3.14D0) MDTHZ = MDTHZ + 1 end if C C DTHETA measures theta difference from left and right integrations. C C DO (FORM-DTHETA) DTHETA = YL(1) - YR(1) - EIGPI if (OSCA .or. OSCB) DTHETA = DTHETA + MDTHZ*PI DTHDE = YL(2) - YR(2) C END (FORM-DTHETA) ONEDIG = ABS(ER1) .le. 0.5D0*ABS(DTHETA) .and. + ABS(ER2) .le. 0.5D0*ABS(DTHDE) write (21,FMT=*) write (21,FMT=*) ' EIG,DTHETA,ONEDIG = ',EIG,DTHETA,ONEDIG FIRSTT = .FALSE. C END (INTEGRATE-FOR-DTHETA) CHNGEPS = .FALSE. CONVRG = .FALSE. OLDNEWT = NEWTON NEWTON = ABS(DTHETA) .lt. 0.06D0 .and. BRACKT if (NEWTON) then ONEDIG = ONEDIG .or. ABS(DTHETA+ER1) .lt. 0.5D0*DTHOLD if (.not.ONEDIG .and. EPS.gt.EPSM) then EPS = MAX(0.01D0*EPS,EPSM) CHNGEPS = .TRUE. end if end if if (PRIN) write (IOUT,FMT='(A,E15.7,A,E15.7)') ' dtheta=', + DTHETA,' dthde=',DTHDE if (PRIN) write (IOUT,FMT='(/A,E15.7,A,E15.7)') ' thetal=', + YL(1),' thetar=',YR(1) C END (OBTAIN-DTHETA-WITH-ONE-CORRECT-DIGIT) if (.not.ONEDIG) then EXIT = .TRUE. write (21,FMT=*) ' NOT ONEDIG ' go to 130 end if C DO (SET-BRACKET-DATA) WRITE (021,FMT=*) ' set-bracket ' if (DTHETA*DTHDE.gt.0.0D0) then if (.not.THEGT0 .or. EIG.le.EIGUP) then THEGT0 = .TRUE. EIGUP = EIG FUP = DTHETA EIGRT = EIG - DTHETA/DTHDE end if else if (.not.THELT0 .or. EIG.ge.EIGLO) then THELT0 = .TRUE. EIGLO = EIG FLO = DTHETA EIGLT = EIG - DTHETA/DTHDE end if end if C C EIG is bracketed when both THEGT0=.true. and THELT0=.true. C BRACKT = THELT0 .and. THEGT0 if (PRIN) write (IOUT,FMT='(A,E22.14,A,E22.14)') ' eigrt=', + EIGRT,' eigup=',EIGUP if (PRIN) write (IOUT,FMT='(A,E22.14,A,E22.14)') ' eiglt=', + EIGLT,' eiglo=',EIGLO C END (SET-BRACKET-DATA) if (BRACKT) LOOP2 = 0 C DO (TEST-FOR-CONVERGENCE) C C Measure convergence after adding separate contributions to error. C T1 = ABS(DTHETA)/ABS(DTHDE) T2 = (1.0D0+AA)*ABS(DTHDA)/ABS(DTHDE) T3 = (1.0D0-BB)*ABS(DTHDB)/ABS(DTHDE) if (.not. (AOK.or.SINGA) .or. (LCIRCA.and. + .not.OSCA)) T2 = 0.0D0 if (.not. (BOK.or.SINGB) .or. (LCIRCB.and. + .not.OSCB)) T3 = 0.0D0 ESTERR = T1 + T2 + T3 ESTERR = ESTERR/MAX(ONE,ABS(EIG)) CONVRG = ESTERR .le. TAU .and. NEWTON write (21,FMT=*) ' T1,T2,T3 = ',T1,T2,T3 write (21,FMT=*) ' EPS,ESTERR = ',EPS,ESTERR write (21,FMT=*) ' ONEDIG,BRACKT,NEWTON,CONVRG = ',ONEDIG, + BRACKT,NEWTON,CONVRG if (ESTERR.lt.BESTEST) then BESTEIG = EIG BESTEST = ESTERR write (21,FMT=*) ' BESTEIG,BESTEST = ',BESTEIG,BESTEST end if if (THEGT0) write (21,FMT=*) ' EIGUP = ',EIGUP if (THELT0) write (21,FMT=*) ' EIGLO = ',EIGLO if (PRIN) write (IOUT,FMT='(A,L2)') ' converge=',CONVRG if (PRIN .and. .not.CONVRG) write (IOUT, + FMT='(A,E15.7)') ' estim. acc.=',ESTERR C END (TEST-FOR-CONVERGENCE) if (CONVRG) then WRITE (021,FMT=*) ' number of iterations was ',NITER WRITE (021,FMT=*) + '-----------------------------------------------' go to 130 else if (NEWTON) then if (OLDNEWT .and. ABS(DTHETA).ge.0.5D0*ABS(DTHOLD)) then write (21,FMT=*) ' NEWTON DID NOT IMPROVE EIG ' NEWTONF = .TRUE. LOOP3 = LOOP3 + 1 else ENDA = T2 .gt. T1 .and. AA .gt. AAAA ENDB = T3 .gt. T1 .and. BB .lt. BBBB if (ENDA .or. ENDB) then NEWTON = .FALSE. else if ((T2+T3).gt.T1 .and. + (AA.le.AAAA.and.BB.ge.BBBB)) then WRITE (021,FMT=*) + ' RESIDUAL TRUNCATION ERROR DOMINATES ' EXIT = .TRUE. IFLAG = 9 go to 130 end if end if if (NEWTONF .or. ENDA .or. ENDB) then EXIT = .TRUE. go to 130 end if C DO (NEWTON'S-METHOD) WRITE (021,FMT=*) ' Newton''s method ' RLX = 1.2D0 if (BRACKT) RLX = 1.0D0 EIG = EIG - RLX*DTHETA/DTHDE C END (NEWTON'S-METHOD) else if (BRACKT) then WRITE (021,FMT=*) ' bracket ' C DO (SECANT-METHOD) WRITE (021,FMT=*) ' do secant method ' FMAX = MAX(-FLO,FUP) EOLD = EIG EIG = 0.5D0* (EIGLO+EIGUP) if (FMAX.le.1.5D0) then U = -FLO/ (FUP-FLO) DIST = EIGUP - EIGLO EIG = EIGLO + U*DIST V = MIN(EIGLT,EIGRT) if (EIG.le.V) EIG = 0.5D0* (EIG+V) V = MAX(EIGLT,EIGRT) if (EIG.ge.V) EIG = 0.5D0* (EIG+V) DE = EIG - EOLD if (ABS(DE).lt.EPSMIN) then TOL = ABS(DE)/MAX(ONE,ABS(EIG)) IFLAG = 6 EXIT = .TRUE. go to 130 end if end if C END (SECANT-METHOD) else C DO (TRY-FOR-BRACKET) LOOP2 = LOOP2 + 1 if (LOOP2.le.9 .and. DTHETA.lt.0.0D0) then MP = MIN(MP,INT(-DTHETA/PI)) write (21,FMT=*) ' MP = ',MP end if if (LOOP2.gt.9) then IFLAG = 12 EXIT = .TRUE. go to 130 end if if (EIG.eq.EEE) then if (GUESS.ne.0.0D0) DEDW = 1.0D0/DTHDE CHNG = -0.6D0* (DEDW+1.0D0/DTHDE)*DTHETA if (EIG.ne.0.0D0 .and. ABS(CHNG).gt. + 0.1D0*ABS(EIG)) CHNG = -0.1D0*SIGN(EIG,DTHETA) else CHNG = -1.2D0*DTHETA/DTHDE C C Limit change in EIG to a factor of 10. C if (ABS(CHNG).gt. (1.0D0+10.0D0*ABS(EIG))) then CHNG = SIGN(1.0D0+10.0D0*ABS(EIG),CHNG) else if (ABS(EIG).ge.1.0D0 .and. + ABS(CHNG).lt.0.1D0*ABS(EIG)) then CHNG = 0.1D0*SIGN(EIG,CHNG) end if if (DTHOLD.lt.0.0D0 .and. LIMUP .and. + CHNG.gt. (ELIMUP-EIG)) then CHNG = 0.95D0* (ELIMUP-EIG) if (CHNG.lt.EPSMIN) then WRITE (021,FMT=*) ' elimup,eig = ',ELIMUP,EIG write (21,FMT=*) ' IN BRACKET, CHNG.LT.EPSMIN ' NUMEIG = NEIG - INT(-DTHETA/PI) WRITE (021,FMT=*) ' new numeig = ',NUMEIG write (21,FMT=*) ' new numeig = ',NUMEIG IFLAG = 11 EXIT = .TRUE. end if end if end if EOLD = EIG CHNGLIM = 2.0D0*ESTERR*MAX(ONE,ABS(EIG)) if (ABS(DTHETA).lt.0.06D0 .and. + ABS(CHNG).gt.CHNGLIM) CHNG = SIGN(CHNGLIM,CHNG) EIG = EIG + CHNG C END (TRY-FOR-BRACKET) end if end if if (IFLAG.eq.11) go to 130 if (NITER.ge.3 .and. DTHOLDY.eq.DTHETA) then IFLAG = 7 EXIT = .TRUE. go to 130 end if DTHOLDY = DTHOLD DTHOLD = DTHETA WRITE (021,FMT=*) ' number of iterations was ',NITER WRITE (021,FMT=*) + '-----------------------------------------------' 120 continue IFLAG = 8 EXIT = .TRUE. 130 continue TOL = BESTEST EIG = BESTEIG if (EXIT) then write (21,FMT=*) ' EXIT ' if (FIRSTT) then if (IFLAG.eq.51 .or. IFLAG.eq.53) then if (AA.lt.-0.1D0) then WRITE (021,FMT=*)' FIRST COMPLETE INTEGRATION FAILED.' write (21,FMT=*) + ' FIRST COMPLETE INTEGRATION FAILED. ' if (AA.eq.-1.0D0) go to 150 AAS = AA call AABB(AA,-ONE) write (21,FMT=*) ' aa MOVED FROM ',AAS,' IN TO ',AA EXIT = .FALSE. go to 110 else write (21,FMT=*) ' aa.ge.-0.1 ' IFLAG = 13 go to 150 end if else if (IFLAG.eq.52 .or. IFLAG.eq.54) then if (BB.gt.0.1D0) then WRITE (021,FMT=*)' FIRST COMPLETE INTEGRATION FAILED.' write (21,FMT=*) + ' FIRST COMPLETE INTEGRATION FAILED. ' if (BB.eq.1.0D0) go to 150 BBS = BB call AABB(BB,-ONE) write (21,FMT=*) ' bb MOVED FROM ',BBS,' IN TO ',BB EXIT = .FALSE. go to 110 else write (21,FMT=*) ' bb.le.0.1 ' IFLAG = 14 go to 150 end if end if else if (IFLAG.eq.51 .or. IFLAG.eq.53) then WRITE (021,FMT=*) ' A COMPLETE INTEGRATION FAILED. ' write (21,FMT=*) ' A COMPLETE INTEGRATION FAILED. ' if (CHNGEPS .and. EPS.lt.0.002D0) then EPS = 5.0D0*EPS EPSM = EPS write (21,FMT=*) ' EPS INCREASED TO ',EPS else AAS = AA call AABB(AA,-ONE) AAAA = AA write (21,FMT=*) ' aa MOVED FROM ',AAS,' IN TO ',AA end if EXIT = .FALSE. go to 110 else if (IFLAG.eq.52 .or. IFLAG.eq.54) then WRITE (021,FMT=*) ' A COMPLETE INTEGRATION FAILED. ' write (21,FMT=*) ' A COMPLETE INTEGRATION FAILED. ' if (CHNGEPS .and. EPS.lt.0.002D0) then EPS = 5.0D0*EPS EPSM = EPS write (21,FMT=*) ' EPS INCREASED TO ',EPS else BBS = BB call AABB(BB,-ONE) BBBB = BB write (21,FMT=*) ' bb MOVED FROM ',BBS,' IN TO ',BB end if EXIT = .FALSE. go to 110 else if (IFLAG.eq.6) then WRITE (021,FMT=*) ' IN SECANT, CHNG.LT.EPSMIN ' write (21,FMT=*) ' IN SECANT, CHNG.LT.EPSMIN ' go to 140 else if (IFLAG.eq.7) then WRITE (021,FMT=*) ' DTHETA IS REPEATING ' write (21,FMT=*) ' DTHETA IS REPEATING ' go to 140 else if (IFLAG.eq.8) then WRITE (021,FMT=*) ' NUMBER OF ITERATIONS REACHED SET LIMIT ' write (21,FMT=*) ' NUMBER OF ITERATIONS REACHED SET LIMIT ' go to 140 else if (IFLAG.eq.9) then write (21,FMT=*) ' RESIDUAL TRUNCATION ERROR DOMINATES ' go to 140 else if (IFLAG.eq.11) then WRITE (021,FMT=*) ' IN TRY FOR BRACKET, CHNG.LT.EPSMIN ' write (21,FMT=*) ' IN TRY FOR BRACKET, CHNG.LT.EPSMIN ' go to 150 else if (IFLAG.eq.12) then WRITE (021,FMT=*) ' FAILED TO GET A BRACKET. ' write (21,FMT=*) ' FAILED TO GET A BRACKET. ' go to 140 else if (NEWTONF .or. .not.ONEDIG) then if (LOOP3.ge.3) then write (21,FMT=*) ' NEWTON IS NOT GETTING ANYWHERE ' NEWTONF = .FALSE. IFLAG = 3 go to 140 end if if (EPS.gt.EPSM .and. BESTEST.lt.OLDEST) then CHNGEPS = .TRUE. EPS = 0.2D0*EPS WRITE (021,FMT=*) ' EPS REDUCED TO ',EPS write (21,FMT=*) ' EPS REDUCED TO ',EPS EXIT = .FALSE. NEWTON = .FALSE. OLDEST = BESTEST go to 110 else if (EPS.le.EPSM) then WRITE (021,FMT=*) ' EPS CANNOT BE REDUCED FURTHER. ' write (21,FMT=*) ' EPS CANNOT BE REDUCED FURTHER. ' IFLAG = 2 go to 140 else WRITE (021,FMT=*) ' no more improvement ' write (21,FMT=*) ' NO MORE IMPROVEMENT ' IFLAG = 3 go to 140 end if end if else if (ENDA) then AAS = AA call AABB(AA,ONE) AA = MAX(AA,AAA) WRITE (021,FMT=*) ' aa MOVED OUT TO ',AA write (21,FMT=*) ' aa MOVED FROM ',AAS,' OUT TO ',AA ENDA = .FALSE. EXIT = .FALSE. go to 110 else if (ENDB) then BBS = BB call AABB(BB,ONE) BB = MIN(BB,BBB) WRITE (021,FMT=*) ' bb MOVED OUT TO ',BB write (21,FMT=*) ' bb MOVED FROM ',BBS,' OUT TO ',BB ENDB = .FALSE. EXIT = .FALSE. go to 110 end if end if 140 continue C C If CONVRG is false, check that any truncation error might possibly C be reduced or that the integrations might be done more accurately. C if (.not.CONVRG) then if (EPS.gt.EPSM) then CHNGEPS = .TRUE. EPS = 0.2D0*EPS WRITE (021,FMT=*) ' EPS REDUCED TO ',EPS write (21,FMT=*) ' EPS REDUCED TO ',EPS EXIT = .FALSE. NEWTON = .FALSE. OLDEST = BESTEST go to 110 else if (AA.gt.AAAA .and. T2.gt.0.0D0 .and. T2.ge.T3) then AAS = AA call AABB(AA,ONE) AA = MAX(AA,AAA) WRITE (021,FMT=*) ' aa MOVED OUT TO ',AA write (21,FMT=*) ' aa MOVED FROM ',AAS,' OUT TO ',AA EXIT = .FALSE. go to 110 else if (BB.lt.BBBB .and. T3.gt.0.0D0 .and. T3.ge.T2) then BBS = BB call AABB(BB,ONE) BB = MIN(BB,BBB) WRITE (021,FMT=*) ' bb MOVED OUT TO ',BB write (21,FMT=*) ' bb MOVED FROM ',BBS,' OUT TO ',BB EXIT = .FALSE. go to 110 end if end if if (PRIN) write (IOUT,FMT='(A,I7,A,E22.14,A,E10.3)') ' numeig=', + NUMEIG,' eig=',EIG,' tol=',TOL C DO (COMPUTE-EIGENFUNCTION-DATA) C C Convert from T to X values, fill 7 of first 9 locations of SLFUN. C call DXDT(TMID,TMP,XMID) call DXDT(AA,TMP,XAA) call DXDT(BB,TMP,XBB) SLFUN(1) = XMID SLFUN(2) = XAA SLFUN(3) = ALFA SLFUN(5) = XBB SLFUN(6) = BETA + EIGPI SLFUN(8) = EPS SLFUN(9) = Z C C Compute SLFUN(4), SLFUN(7) towards normalizing the eigenfunction. C EIGSAV = EIG THA = ALFA DTHDAAX = 0.0D0 YL(1) = 0.0D0 YL(2) = 0.0D0 YL(3) = 0.0D0 call INTEG(AA,THA,DTHDAAX,DTHDEA,TMID,A1,A2,EPS,YL,ERL,LCIRCA,AOK, + SINGA,OSCA,JFLAG) THB = BETA DTHDBBX = 0.0D0 call INTEG(BB,THB,DTHDBBX,DTHDEB,TMID,B1,B2,EPS,YR,ERR,LCIRCB,BOK, + SINGB,OSCB,JFLAG) YR(1) = YR(1) + EIGPI SL = SIN(YL(1)) SR = SIN(YR(1)) CL = COS(YL(1)) CR = COS(YR(1)) UL = (YL(2)-DTHDEA*EXP(-2.0D0*YL(3)))*Z UR = (YR(2)-DTHDEB*EXP(-2.0D0*YR(3)))*Z DUM = 0.5D0*LOG(UL-UR) SLFUN(4) = -YL(3) - DUM SLFUN(7) = -YR(3) - DUM C END (COMPUTE-EIGENFUNCTION-DATA) C DO (CHECK-MATCHING-VALUES-OF-EIGENFUNCTION) C C Perform final check on EIG. Return IFLAG = 400+ C if not accurate enough. C DEN = UL*SR*SR - UR*SL*SL E = ABS(SR)/SQRT(DEN) PSIL = E*SL PSIPL = E*CL*Z SQL = E*E*UL E = ABS(SL)/SQRT(DEN) PSIR = E*SR PSIPR = E*CR*Z SQR = E*E*UR ADDD = PSIL*PSIR .lt. 0.0D0 .and. PSIPL*PSIPR .lt. 0.0D0 RAY = EIG + (PSIL*PSIPL-PSIR*PSIPR)/ (SQL-SQR) if (PRIN) then write (IOUT,FMT='(A,E22.14)') ' ray=',RAY write (IOUT,FMT='(A,E22.14,A,E22.14)') ' psil=',PSIL,' psir=', + PSIR write (IOUT,FMT='(A,E22.14,A,E22.14)') ' psipl=',PSIPL, + ' psipr=',PSIPR write (IOUT,FMT='(A,E22.14,A,E22.14)') ' sql=',SQL,' sqr=',SQR end if C END (CHECK-MATCHING-VALUES-OF-EIGENFUNCTION) C C If next condition is .true., then something is apparently wrong C with the accuracy of EIG. Bisect and go through the loop again. C if (ABS(RAY-EIG).gt.2.0D0*TOL*MAX(ONE,ABS(EIG))) then NRAY = NRAY + 1 write (21,FMT=*) ' NRAY, RAY = ',NRAY,RAY if (RAY.eq.OLDRAY .or. NRAY.gt.5) then IFLAG = 400 + IFLAG go to 150 end if EIG = 0.5D0* (EIG+RAY) OLDRAY = RAY go to 110 end if if (NRAY.le.5) IFLAG = IFLAG + 100 C DO (GENERATE-EIGENFUNCTION-VALUES) call EIGFCN(EIGPI,A1,A2,B1,B2,AOK,SINGA,LCIRCA,OSCA,BOK,SINGB, + LCIRCB,OSCB,SLFUN,ISLFUN) C END (GENERATE-EIGENFUNCTION-VALUES) 150 continue write (21,FMT=*) ' IFLAG = ',IFLAG return end subroutine SLEIGN2 subroutine AABB(TEND,OUT) C ********** C C This subroutine moves aa or bb further out or closer in. C TEND is either aa or bb. If OUT is positive, TEND is moved C further out, and if OUT is negative, TEND is moved closer in. C C ********** C .. Local Scalars .. double precision D,TST,TSTS integer I C .. C .. Intrinsic Functions .. intrinsic ABS,SIGN C .. C .. Scalar Arguments .. double precision OUT,TEND C .. if (OUT.lt.0.0D0 .and. ABS(TEND).le.0.9D0) then TST = 0.5D0*ABS(TEND) else D = 0.1D0 TSTS = 0.9D0 do 10 I = 1,20 TST = 1.0D0 - D if (TST.gt.ABS(TEND) .or. (TST.eq.ABS(TEND).and. + OUT.lt.0.0D0)) go to 20 D = 0.1D0*D TSTS = TST 10 continue 20 continue if (OUT.lt.0.0D0) TST = TSTS end if TEND = SIGN(TST,TEND) return end subroutine AABB subroutine ALFBET(XEND,INTAB,TT,COEF1,COEF2,EIG,P0,QF,SING,LCIRC, + VALUE,IFLAG,DERIV) C ********** C C This subroutine computes a boundary value for a specified endpoint C of the interval for a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. It is called C from SLEIGN. Both regular and singular endpoints are treated. C C Subprograms called C C user-supplied ..... p,q,w C C sleign-supplied ... dxdt,extrap C C ********** C .. Scalars in Common .. double precision Z C .. C .. Local Scalars .. double precision C,CD,D,HH,ONE,PI,PUP,PVP,PX,QX,T,TEMP,TTS,U,V,WX, + X,XDENOM,XNUM logical LOGIC C .. C .. External Functions .. double precision P,Q,W external P,Q,W C .. C .. External Subroutines .. cc external DXDT,EXTRAP,UV C .. C .. Intrinsic Functions .. intrinsic ABS,ATAN,ATAN2,SIGN,SQRT C .. C .. Common blocks .. common /ZEE/Z C .. C Set machine dependent constant. C C PI (variable ONE set to 1.0 eases precision conversion). C .. Scalar Arguments .. double precision COEF1,COEF2,DERIV,EIG,P0,QF,TT,VALUE,XEND integer IFLAG,INTAB logical LCIRC,SING C .. ONE = 1.0D0 PI = 4.0D0*ATAN(ONE) C IFLAG = 1 DERIV = 0.0D0 if (.not.SING) then VALUE = 0.5D0*PI if (COEF1.ne.0.0D0) VALUE = ATAN(-Z*COEF2/COEF1) LOGIC = (TT.lt.0.0D0 .and. VALUE.lt.0.0D0) .or. + (TT.gt.0.0D0 .and. VALUE.le.0.0D0) if (LOGIC) VALUE = VALUE + PI else if (LCIRC) then call DXDT(TT,TEMP,X) call UV(X,U,PUP,V,PVP,TEMP,TEMP) XNUM = COEF1*U + COEF2*V XDENOM = (COEF1*PUP+COEF2*PVP)/Z VALUE = ATAN2(XNUM,XDENOM) if (XNUM.lt.0.0D0) VALUE = VALUE + 2.0D0*PI else LOGIC = (INTAB.eq.2 .and. TT.gt.0.0D0) .or. + (INTAB.eq.3 .and. TT.lt.0.0D0) .or. INTAB .eq. 4 .or. + (P0.gt.0.0D0 .and. QF.lt.0.0D0) if (LOGIC) then T = SIGN(ONE,TT) TTS = TT call EXTRAP(T,TTS,EIG,VALUE,DERIV,IFLAG) else call DXDT(TT,TEMP,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z C = 2.0D0* (EIG*WX-QX) if (C.lt.0.0D0) then VALUE = 0.0D0 if (P0.gt.0.0D0) VALUE = 0.5D0*PI else HH = ABS(XEND-X) D = 2.0D0*HH/PX CD = C*D*HH if (P0.gt.0.0D0) then VALUE = C*HH if (CD.lt.1.0D0) VALUE = VALUE/ (1.0D0+SQRT(1.0D0-CD)) VALUE = VALUE + 0.5D0*PI else VALUE = D if (CD.lt.1.0D0) VALUE = VALUE/ (1.0D0+SQRT(1.0D0-CD)) end if end if end if end if return end subroutine ALFBET subroutine DXDT(T,DT,X) C ********** C C This subroutine transforms coordinates from T on (-1,1) to C X on (A,B) in the solution of a Sturm-Liouville problem. C It is called from subroutines SLEIGN, ALFBET, F, and EXTRAP. C C ********** C .. Scalars in Common .. double precision A,B,C1,C2 integer INTAB C .. C .. Local Scalars .. double precision U C .. C .. Intrinsic Functions .. intrinsic ABS C .. C .. Common blocks .. common /DATADT/A,B,C1,C2,INTAB C .. C .. Scalar Arguments .. double precision DT,T,X C .. U = C1*T + C2 go to (10,20,30,40) INTAB 10 continue DT = C1*0.5D0* (B-A) X = 0.5D0* ((B+A)+ (B-A)*U) return 20 continue DT = C1*2.0D0/ (1.0D0-U)**2 X = A + (1.0D0+U)/ (1.0D0-U) return 30 continue DT = C1*2.0D0/ (1.0D0+U)**2 X = B - (1.0D0-U)/ (1.0D0+U) return 40 continue DT = C1/ (1.0D0-ABS(U))**2 X = U/ (1.0D0-ABS(U)) return end subroutine DXDT subroutine EIGFCN(EIGPI,A1,A2,B1,B2,AOK,SINGA,LCIRCA,OSCA,BOK, + SINGB,LCIRCB,OSCB,SLFUN,ISLFUN) C ********** C ********** C .. Scalars in Common .. double precision AA,BB,DTHDAA,DTHDBB,TMID integer MDTHZ logical ADDD C .. C .. Local Scalars .. double precision DTHDAT,DTHDBT,DTHDET,EFF,T,THT,TM integer I,IFLAG,J,NMID logical LCIRC,OK,SING C .. C .. Local Arrays .. double precision ERL(3),ERR(3),YL(3),YR(3) C .. C .. External Subroutines .. cc external INTEG C .. C .. Intrinsic Functions .. intrinsic EXP,SIN C .. C .. Common blocks .. common /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ C .. C C WARNING: In this program it is assumed that the points T C in SLFUN all lie within the interval (AA,BB). C C Calculate selected eigenfunction values by integration (over T). C C .. Scalar Arguments .. double precision A1,A2,B1,B2,EIGPI integer ISLFUN logical AOK,BOK,LCIRCA,LCIRCB,OSCA,OSCB,SINGA,SINGB C .. C .. Array Arguments .. double precision SLFUN(ISLFUN+9) C .. NMID = 0 do 10 I = 1,ISLFUN if (SLFUN(9+I).le.TMID) NMID = I 10 continue if (NMID.gt.0) then T = AA YL(1) = SLFUN(3) YL(2) = 0.0D0 YL(3) = 0.0D0 LCIRC = LCIRCA OK = AOK SING = SINGA EFF = 0.0D0 do 20 J = 1,NMID TM = SLFUN(J+9) if (TM.lt.AA .or. TM.gt.BB) then C WRITE (021,FMT=*) ' t.lt.aa .or. t.gt.bb ' C stop SLFUN(J+9) = 0D0 end if THT = YL(1) DTHDAT = DTHDAA*EXP(-2.0D0*EFF) DTHDET = YL(2) if (TM.gt.AA) then call INTEG(T,THT,DTHDAT,DTHDET,TM,A1,A2,SLFUN(8),YL,ERL, + LCIRC,OK,SING,OSCA,IFLAG) if (OSCA) then EFF = YL(3) else LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YL(3) end if end if SLFUN(J+9) = SIN(YL(1))*EXP(EFF+SLFUN(4)) T = TM if (T.gt.-1.0D0) OK = .TRUE. if (T.lt.-0.9D0 .and. OSCA) then OK = .FALSE. T = AA YL(1) = SLFUN(3) YL(2) = 0.0D0 YL(3) = 0.0D0 end if 20 continue end if if (NMID.lt.ISLFUN) then T = BB YR(1) = SLFUN(6) - EIGPI YR(2) = 0.0D0 YR(3) = 0.0D0 LCIRC = LCIRCB OK = BOK SING = SINGB EFF = 0.0D0 do 30 J = ISLFUN,NMID + 1,-1 TM = SLFUN(J+9) if (TM.lt.AA .or. TM.gt.BB) then C WRITE (021,FMT=*) ' t.lt.aa .or. t.gt.bb ' C stop SLFUN(J+9) = 0D0 end if THT = YR(1) DTHDBT = DTHDBB*EXP(-2.0D0*EFF) DTHDET = YR(2) if (TM.lt.BB) then call INTEG(T,THT,DTHDBT,DTHDET,TM,B1,B2,SLFUN(8),YR,ERR, + LCIRC,OK,SING,OSCB,IFLAG) if (OSCB) then EFF = YR(3) else LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YR(3) end if end if SLFUN(J+9) = SIN(YR(1)+EIGPI)*EXP(EFF+SLFUN(7)) if (ADDD) SLFUN(J+9) = -SLFUN(J+9) T = TM if (T.lt.1.0D0) OK = .TRUE. if (T.gt.0.9D0 .and. OSCB) then OK = .FALSE. T = BB YR(1) = SLFUN(6) - EIGPI YR(2) = 0.0D0 YR(3) = 0.0D0 end if 30 continue end if return end subroutine EIGFCN subroutine ESTPAC(IOSC,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS,TAU,IA, + IB,JJL,JJR,SUM,U,UT,ZAV) C ********** C C This subroutine estimates the change in 'phase angle' in the C eigenvalue determination of a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. C C The subroutine approximates the (trapezoidal rule) integral of C C sqrt((eig*w-q)/p) C C where the integral is taken over those X in (A,B) for which C C (eig*w-q)/p .gt. 0 C C ********** C .. Local Scalars .. double precision DPSUM,DPSUMT,PSUM,RT,RTSAV,V,WSAV,WW,ZAVJ,ZAVSAV integer J,JJ,JSAV,MF1 C .. C .. Arrays in Common .. double precision ZEE(100) integer JAY(100) C .. C .. Intrinsic Functions .. intrinsic ABS,MAX,MIN,SIGN,SQRT C .. C .. Common blocks .. common /ZEEZ/JAY,ZEE C .. C .. Scalar Arguments .. double precision EEE,SUM,SUM0,TAU,U,UT,ZAV integer IA,IB,JJL,JJR,MF,ML logical IOSC C .. C .. Array Arguments .. double precision DELT(ML),DS(ML),PS(ML),PSS(ML),QS(ML),WS(ML) C .. IA = MF IB = 80 C C SUM accumulates the integral approximation. U measures the total C length of subintervals where (EIG*W-Q)/P .gt. 0.0. ZAV is the C average value of sqrt((EIG*W-Q)*P) over those subintervals. C if (.not.IOSC) then JJL = 99 JJR = 1 SUM = 0.0D0 U = 0.0D0 UT = 0.0D0 ZAV = 0.0D0 WSAV = EEE*WS(MF) - QS(MF) if (WSAV.gt.0.0D0) then RTSAV = SIGN(SQRT(WSAV),PS(MF)) else RTSAV = 0.0D0 end if do 10 J = MF + 1,ML WW = EEE*WS(J) - QS(J) if (WW.gt.0.0D0) then if (J.gt.80) IB = J U = U + DS(J-1) UT = UT + DELT(J-1) RT = SIGN(SQRT(WW),PS(J)) else RT = 0.0D0 if (U.eq.0.0D0 .and. RTSAV.eq.0.0D0 .and. + IA.le.19) IA = IA + 1 end if if (WW.eq.0.0D0 .or. WSAV.eq.0.0D0 .or. + WW.eq.SIGN(WW,WSAV)) then V = RT + RTSAV else V = (WW*RT+WSAV*RTSAV)/ABS(WW-WSAV) end if WSAV = WW RTSAV = RT PSUM = DS(J-1)*V if (EEE.eq.0.0D0) then PSS(J) = PSUM else DPSUM = PSUM - PSS(J) DPSUMT = DPSUM*DELT(J-1)/DS(J-1) if (DPSUMT.gt.0.001D0*TAU) then JJL = MIN(JJL,J) JJR = MAX(JJR,J) end if end if SUM = SUM + PSUM if (U.gt.0.0D0) ZAV = ZAV + DELT(J-1)*V*ABS(PS(J)+PS(J-1)) 10 continue SUM = 0.5D0*SUM - SUM0 ZAV = 0.25D0*ZAV else JJ = 1 JAY(1) = MF 20 continue SUM = 0.0D0 U = 0.0D0 UT = 0.0D0 ZAV = 0.0D0 ZAVJ = 0.0D0 MF1 = JAY(JJ) WSAV = EEE*WS(MF1) - QS(MF1) if (WSAV.gt.0.0D0) then RTSAV = SIGN(SQRT(WSAV),PS(MF1)) else RTSAV = 0.0D0 end if do 30 J = MF1 + 1,ML WW = EEE*WS(J) - QS(J) if (WW.gt.0.0D0) then if (J.gt.80) IB = J U = U + DS(J-1) UT = UT + DELT(J-1) RT = SIGN(SQRT(WW),PS(J)) else RT = 0.0D0 if (U.eq.0.0D0 .and. RTSAV.eq.0.0D0 .and. + IA.le.19) IA = IA + 1 end if if (WW.eq.0.0D0 .or. WSAV.eq.0.0D0 .or. + WW.eq.SIGN(WW,WSAV)) then V = RT + RTSAV else V = (WW*RT+WSAV*RTSAV)/ABS(WW-WSAV) end if WSAV = WW RTSAV = RT PSUM = DS(J-1)*V SUM = SUM + PSUM if (U.gt.0.0D0) ZAV = ZAV + DELT(J-1)*V*ABS(PS(J)+PS(J-1)) if (U.ne.0.0D0) then if (ZAVJ.eq.0.0D0) JSAV = J ZAVJ = 0.25D0*ZAV/UT if (J.eq.JSAV) ZAVSAV = ZAVJ if (2.0D0*ZAVJ.lt.ZAVSAV .or. ZAVJ.gt.2.0D0*ZAVSAV) then JJ = JJ + 1 JAY(JJ) = J ZEE(JJ) = 0.5D0* (ZAVJ+ZAVSAV) go to 40 end if end if 30 continue 40 continue if (J.gt.ML) then JJ = JJ + 1 JAY(JJ) = ML ZEE(JJ) = 0.5D0* (ZAVJ+ZAVSAV) end if if (J.lt.ML) go to 20 SUM = 0.5D0*SUM ZAV = 0.25D0*ZAV end if IB = IB + 1 return end subroutine ESTPAC subroutine EXTRAP(T,TT,EIG,VALUE,DERIV,IFLAG) C ********** C C This subroutine is called from ALFBET in determining boundary C values at a singular endpoint of the interval for a C Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. C C EXTRAP, which in turn calls INTPOL, extrapolates the function C C arctan(1.0/sqrt(-p*(eig*w-q))) C C from its values for T within (-1,1) to an endpoint. C C Subprograms called C C user-supplied ..... p,q,w C C sleign-supplied ... dxdt,intpol C C ********** C .. Scalars in Common .. double precision Z C .. C .. Local Scalars .. double precision ANS,CTN,ERROR,PROD,PX,QX,T1,TEMP,WX,X integer KGOOD C .. C .. Local Arrays .. double precision FN1(5),XN(5) C .. C .. External Functions .. double precision P,Q,W external P,Q,W C .. C .. External Subroutines .. cc external DXDT,INTPOL C .. C .. Intrinsic Functions .. intrinsic ABS,ATAN,SQRT,TAN C .. C .. Common blocks .. common /ZEE/Z C .. C .. Scalar Arguments .. double precision DERIV,EIG,T,TT,VALUE integer IFLAG C .. IFLAG = 1 KGOOD = 0 T1 = TT 10 continue call DXDT(T1,TEMP,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z PROD = -PX* (EIG*WX-QX) if (PROD.le.0.0D0) then T1 = 0.5D0* (T1+T) if ((1.0D0+ (T1-T)**2).gt.1.0D0) go to 10 IFLAG = 5 return else KGOOD = KGOOD + 1 XN(KGOOD) = T1 FN1(KGOOD) = ATAN(1.0D0/SQRT(PROD)) T1 = 0.5D0* (T+T1) if (KGOOD.lt.5) go to 10 end if T1 = 0.01D0 call INTPOL(5,XN,FN1,T,T1,3,ANS,ERROR) VALUE = ABS(ANS) CTN = 1.0D0/TAN(VALUE) DERIV = 0.5D0*PX*WX/CTN/ (1.0D0+CTN**2) TT = XN(1) return end subroutine EXTRAP subroutine F(U,Y,YP) C ********** C C This subroutine evaluates the derivative functions for use with C integrator GERK in solving a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. C C Subprograms called C C user-supplied ..... p,q,w C C sleign-supplied ... dxdt C C ********** C .. Scalars in Common .. double precision EIG,Z integer IND C .. C .. Local Scalars .. double precision C,C2,DT,QX,S,S2,T,TH,V,WW,WX,X,XP C .. C .. External Functions .. double precision P,Q,W external P,Q,W C .. C .. External Subroutines .. cc external DXDT C .. C .. Intrinsic Functions .. intrinsic COS,MOD,SIN C .. C .. Common blocks .. common /DATAF/EIG,IND common /ZEE/Z C .. C .. Scalar Arguments .. double precision U C .. C .. Array Arguments .. double precision Y(2),YP(3) C .. if (MOD(IND,2).eq.1) then T = U TH = Y(1) else T = Y(1) TH = U end if call DXDT(T,DT,X) XP = Z/P(X) QX = Q(X)/Z WX = W(X)/Z V = EIG*WX - QX S = SIN(TH) C = COS(TH) S2 = S*S C2 = C*C YP(1) = DT* (XP*C2+V*S2) if (IND.eq.1) then WW = (XP-V)*S*C YP(2) = DT* (-2.0D0*WW*Y(2)+WX*S2) YP(3) = DT*WW else if (IND.eq.2) then YP(2) = YP(2)/YP(1) YP(3) = YP(3)/YP(1) YP(1) = 1.0D0/YP(1) else if (IND.eq.3) then else YP(1) = 1.0D0/YP(1) end if return end subroutine F double precision function FF(ALFLAM) C ********** C ********** C .. Scalars in Common .. double precision CC,EIGSAV,HPI,PI,THETU,THETV,TWOPI,UB,UL,UR,VB, + VL,VR,Z integer IND,INDD C .. C .. Local Scalars .. double precision AA,BB,DTHDAA,DTHDBB,DTHDEA,DTHDEB,DUM,EPS,LAMBDA, + PVPB,PVPL,PVPR,RHOB,RHOL,RHOR,THA,THB,THL,THR, + TMID integer LFLAG logical AOK,BOK,LCIRCA,LCIRCB,OSCA,OSCB,SINGA,SINGB C .. C .. Local Arrays .. double precision ERR(3),Y(3) C .. C .. External Subroutines .. cc external INTEG C .. C .. Intrinsic Functions .. intrinsic COS,EXP,SIN C .. C .. Common blocks .. common /DATAF/EIGSAV,INDD common /EPP2/CC,UL,UR,VL,VR,UB,VB,IND common /PIE/PI,TWOPI,HPI common /THET/THETU,THETV common /ZEE/Z C .. C C (THIS ROUTINE IS BEING MODIFIED FOR PERIODIC PROBLEMS WHICH C ARE NOT NECESSARILY REGULAR, BUT IS NOT YET COMPLETE.) C C .. Scalar Arguments .. double precision ALFLAM C .. AOK = .TRUE. LCIRCA = .FALSE. SINGA = .FALSE. OSCA = .FALSE. BOK = .TRUE. LCIRCB = .FALSE. SINGB = .FALSE. OSCB = .FALSE. C AA = -1.0D0 BB = 1.0D0 C C SET TMID SO THAT IT IS NOT IN THE EXACT MIDDLE. C TMID = 0.1D0*PI C INDD = 1 LAMBDA = ALFLAM EIGSAV = LAMBDA EPS = 1.D-7 C if (IND.ge.2) go to 10 C 50 continue C C FOR U: C THA = HPI Y(1) = THA Y(2) = 1.0D0 Y(3) = 0.0D0 DTHDAA = 0.0D0 DTHDEA = 1.0D0 LFLAG = 1 call INTEG(AA,THA,DTHDAA,DTHDEA,TMID,DUM,DUM,EPS,Y,ERR,LCIRCA,AOK, + SINGA,OSCA,LFLAG) if (LFLAG.eq.5) then EPS = 10.0D0*EPS go to 50 end if RHOL = EXP(Y(3)) THL = Y(1) UL = RHOL*SIN(THL) C THB = HPI Y(1) = THB Y(2) = 1.0D0 Y(3) = 0.0D0 DTHDBB = 0.0D0 DTHDEB = 1.0D0 LFLAG = 1 call INTEG(BB,THB,DTHDBB,DTHDEB,TMID,DUM,DUM,EPS,Y,ERR,LCIRCB,BOK, + SINGB,OSCB,LFLAG) if (LFLAG.eq.5) then EPS = 10.0D0*EPS go to 50 end if RHOR = EXP(Y(3)) THR = Y(1) UR = RHOR*SIN(THR) C C FOR V: C THA = 0.0D0 Y(1) = THA Y(2) = 1.0D0 Y(3) = 0.0D0 DTHDAA = 0.0D0 DTHDEA = 1.0D0 LFLAG = 1 call INTEG(AA,THA,DTHDAA,DTHDEA,TMID,DUM,DUM,EPS,Y,ERR,LCIRCA,AOK, + SINGA,OSCA,LFLAG) if (LFLAG.eq.5) then EPS = 10.0D0*EPS go to 50 end if RHOL = EXP(Y(3)) THL = Y(1) VL = RHOL*SIN(THL) PVPL = Z*RHOL*COS(THL) C THB = 0.0D0 Y(1) = THB Y(2) = 1.0D0 Y(3) = 0.0D0 DTHDBB = 0.0D0 DTHDEB = 1.0D0 LFLAG = 1 call INTEG(BB,THB,DTHDBB,DTHDEB,TMID,DUM,DUM,EPS,Y,ERR,LCIRCB,BOK, + SINGB,OSCB,LFLAG) if (LFLAG.eq.5) then EPS = 10.0D0*EPS go to 50 end if RHOR = EXP(Y(3)) THR = Y(1) VR = RHOR*SIN(THR) PVPR = Z*RHOR*COS(THR) FF = (VR* (UL*PVPL-1.0D0)-CC*VL* (UR*PVPR-1.0D0))* (VL-VR/ + CC) - VL*VR* (UL-CC*UR)* (PVPL-PVPR/CC) return C 10 continue C C FOR U: C THA = HPI Y(1) = THA Y(2) = 1.0D0 Y(3) = 0.0D0 DTHDAA = 0.0D0 DTHDEA = 1.0D0 LFLAG = 1 call INTEG(AA,THA,DTHDAA,DTHDEA,BB,DUM,DUM,EPS,Y,ERR,LCIRCA,AOK, + SINGA,OSCA,LFLAG) if (LFLAG.eq.5) then EPS = 10.0D0*EPS go to 10 end if RHOB = EXP(Y(3)) THB = Y(1) THETU = THB UB = RHOB*SIN(THB) C C FOR V: C THA = 0.0D0 Y(1) = THA Y(2) = 1.0D0 Y(3) = 0.0D0 DTHDAA = 0.0D0 DTHDEA = 1.0D0 LFLAG = 1 call INTEG(AA,THA,DTHDAA,DTHDEA,BB,DUM,DUM,EPS,Y,ERR,LCIRCA,AOK, + SINGA,OSCA,LFLAG) if (LFLAG.eq.5) then EPS = 10.0D0*EPS go to 10 end if RHOB = EXP(Y(3)) THB = Y(1) THETV = THB VB = RHOB*SIN(THB) PVPB = Z*RHOB*COS(THB) FF = CC*PVPB + UB/CC - 2.0D0 return end function FF subroutine FIT(TH1,TH,TH2) C ********** C C This program converts TH into an 'equivalent' angle between C TH1 and TH2. We assume TH1.LT.TH2 and PI.LE.(TH2-TH1). C C ********** C .. Scalars in Common .. double precision HPI,PI,TWOPI C .. C .. Intrinsic Functions .. intrinsic AINT C .. C .. Common blocks .. common /PIE/PI,TWOPI,HPI C .. C .. Scalar Arguments .. double precision TH,TH1,TH2 C .. if (TH.lt.TH1) TH = TH + AINT((TH1-TH+PI)/PI)*PI if (TH.gt.TH2) TH = TH - AINT((TH-TH2+PI)/PI)*PI return end subroutine FIT subroutine FZ(UU,Y,YP) C ********** C C This subroutine evaluates the derivative of the function PHI C in the regularization at a singular endpoint. C C Here, HU means -(PUP)' + QU. C C ********** C .. Scalars in Common .. double precision EIG integer IND C .. C .. Local Scalars .. double precision A1122,A12,A21,AU,AV,B1122,B12,B21,C,C2,D,DT,HU, + HV,PHI,PUP,PVP,S,S2,SC,T,U,V,WW,WX,X C .. C .. External Functions .. double precision W external W C .. C .. External Subroutines .. cc external DXDT,UV C .. C .. Intrinsic Functions .. intrinsic COS,MOD,SIN C .. C .. Common blocks .. common /DATAF/EIG,IND C .. C .. Scalar Arguments .. double precision UU C .. C .. Array Arguments .. double precision Y(2),YP(3) C .. if (MOD(IND,2).eq.1) then T = UU PHI = Y(1) else T = Y(1) PHI = UU end if call DXDT(T,DT,X) call UV(X,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP WX = W(X) S = SIN(PHI) C = COS(PHI) S2 = S*S C2 = C*C SC = S*C B1122 = WX*U*V B12 = WX*V*V B21 = -WX*U*U AU = EIG*WX*U - HU AV = EIG*WX*V - HV A1122 = U*AV + V*AU A12 = V*AV A21 = -U*AU YP(1) = -DT* (A1122*SC+A12*S2-A21*C2)/D if (IND.eq.1) then WW = 2.0D0* (A12+A21)*SC + A1122* (C2-S2) YP(2) = -DT* (WW*Y(2)+2.0D0*B1122*SC+B12*S2-B21*C2)/D YP(3) = 0.5D0*DT*WW/D else if (IND.eq.2) then YP(2) = YP(2)/YP(1) YP(3) = YP(3)/YP(1) YP(1) = 1.0D0/YP(1) else if (IND.eq.3) then else YP(1) = 1.0D0/YP(1) end if return end subroutine FZ subroutine GERKZ(F,NEQ,Y,TIN,TOUT,REPS,AEPS,LFLAG,ER,WORK,IWORK) C ********** C ********** C .. Scalars in Common .. double precision EPSMIN,Z C .. C .. Local Scalars .. double precision T,TOUTS integer I,J,K,L,LLFLAG C .. C .. Arrays in Common .. double precision TEE(100),ZEE(100) integer JAY(100) C .. C .. Local Arrays .. double precision U(3) C .. C .. External Subroutines .. cc external GERK,THTOTHZ,THZTOTH C .. C .. Intrinsic Functions C .. Common blocks .. common /RNDOFF/EPSMIN common /TEEZ/TEE common /ZEE/Z common /ZEEZ/JAY,ZEE C .. C .. Scalar Arguments .. double precision AEPS,REPS,TIN,TOUT integer LFLAG,NEQ C .. C .. Array Arguments .. double precision ER(3),WORK(27),Y(3) integer IWORK(5) C .. C .. Subroutine Arguments .. external F C .. C .. Intrinsic Functions .. intrinsic MAX,MIN C .. T = TIN if (TIN.lt.TOUT) then do 10 I = 1,19 if (TEE(I)-EPSMIN.le.TIN .and. TIN.lt.TEE(I+1)+EPSMIN) J = I if (TEE(I)-EPSMIN.lt.TOUT .and. + TOUT.le.TEE(I+1)+EPSMIN) L = I 10 continue do 30 K = J,L TOUTS = MIN(TOUT,TEE(K+1)) Z = ZEE(K+1) if (Z.eq.0.0D0) Z = 1.0D0 call THTOTHZ(Y,Z,U) LLFLAG = 1 20 continue call GERK(F,NEQ,U,T,TOUTS,REPS,AEPS,LLFLAG,ER,WORK,IWORK) if (LLFLAG.gt.3) then WRITE (021,FMT=*) ' llflag = ',LLFLAG LFLAG = 5 return end if if (LLFLAG.eq.3 .or. LLFLAG.eq.-2) go to 20 call THZTOTH(U,Z,Y) 30 continue else do 40 I = 20,2,-1 if (TEE(I-1)-EPSMIN.lt.TIN .and. TIN.le.TEE(I)+EPSMIN) J = I if (TEE(I-1)-EPSMIN.le.TOUT .and. + TOUT.lt.TEE(I)+EPSMIN) L = I 40 continue do 60 K = J,L,-1 TOUTS = MAX(TOUT,TEE(K-1)) Z = ZEE(K) if (Z.eq.0.0D0) Z = 1.0D0 call THTOTHZ(Y,Z,U) LLFLAG = 1 50 continue call GERK(F,NEQ,U,T,TOUTS,REPS,AEPS,LLFLAG,ER,WORK,IWORK) if (LLFLAG.gt.3) then WRITE (021,FMT=*) ' llflag = ',LLFLAG LFLAG = 5 return end if if (LLFLAG.eq.3 .or. LLFLAG.eq.-2) go to 50 call THZTOTH(U,Z,Y) 60 continue end if TIN = T LFLAG = LLFLAG return end subroutine GERKZ subroutine INTEG(TEND,THEND,DTHDAA,DTHDE,TMID,COEF1,COEF2,EPS,Y, + ER,LCIRC,OK,SING,OSC,IFLAG) C ********** C ********** C .. Scalars in Common .. double precision EIG,HPI,PI,TSAVEL,TSAVER,TWOPI,Z integer IND C .. C .. Arrays in Common .. double precision TT(7,2),YY(7,3,2) integer NT(2) C .. C .. Local Scalars .. double precision C,D,DDD,DPHIDAA,DPHIDE,DTHIN,DUM,EFF,FAC2,HU,HV, + P1,PHI,PHI0,PUP,PVP,PYPZ,PYPZ0,Q1,RHOSQ,S,T,TH, + TH0,THBAR,THETA,THIN,THU,THU0,THV,THV0,TIN, + TINTHZ,TMP,TOUT,TSTAR,U,V,W1,XSTAR,XT,XT0,YSTAR, + YZ,YZ0,ZSAV integer I,J,K2PI,KFLAG,LFLAG,M logical LOGIC C .. C .. Local Arrays .. double precision ERZ(3),WORK(27),YP(3),YU(3) integer IWORK(5) C .. C .. External Subroutines .. cc external DXDT,F,FZ,GERK,GERKZ,INTEGT,SETTHU,UV,UVPHI,WR cc? external F,FZ C .. C .. External Functions .. double precision P,Q,W external P,Q,W C .. C .. Intrinsic Functions .. intrinsic ABS,ATAN2,COS,EXP,LOG,MIN,SIGN,SIN C .. C .. Common blocks .. common /DATAF/EIG,IND common /PIE/PI,TWOPI,HPI common /TEMP/TT,YY,NT common /TSAVE/TSAVEL,TSAVER common /ZEE/Z C .. C C Note: The input values of THEND and DTHDAA are overwritten C when integrating from a limit circle endpoint. C C .. Scalar Arguments .. double precision COEF1,COEF2,DTHDAA,DTHDE,EPS,TEND,THEND,TMID integer IFLAG logical LCIRC,OK,OSC,SING C .. C .. Array Arguments .. double precision ER(3),Y(3) C .. IFLAG = 1 IND = 1 if (OSC) then if (.not.OK) then LOGIC = .FALSE. else if (TEND.le.TMID) then LOGIC = TEND .ge. TSAVEL else LOGIC = TEND .le. TSAVER end if C if (LOGIC) then TINTHZ = TEND TH = THEND DTHIN = DTHDE Y(1) = TH Y(2) = DTHIN EFF = Y(3) else C DO (INTEGRATE-FOR-PHI-OSC) ZSAV = Z Z = 1.0D0 T = TEND PHI0 = ATAN2(COEF2,COEF1) if (TMID.gt.TEND) then J = 1 else J = 2 end if C C We want -PI/2 .lt. PHI0 .le. PI/2. C if (COEF1.lt.0.0D0) PHI0 = PHI0 - SIGN(PI,COEF2) Y(1) = PHI0 Y(2) = 0.0D0 Y(3) = 0.0D0 call DXDT(T,TMP,XT0) call FZ(T,Y,YP) DPHIDAA = -YP(1) call UV(XT0,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP C C Set THU0 and THV0. C THU0 = ATAN2(U,PUP) if (U.lt.0.0D0) THU0 = THU0 + TWOPI call SETTHU(XT0,THU0) THV0 = ATAN2(V,PVP) if (V.lt.0.0D0) THV0 = THV0 + TWOPI 10 continue if (THV0.lt.THU0) then THV0 = THV0 + TWOPI go to 10 end if C C Set TH0 and copy into THEND, overwriting its input value. C Also, redefine DTHDAA, overwriting its input value. C call UVPHI(U,PUP,V,PVP,THU0,THV0,PHI0,TH0) THEND = TH0 C = COS(PHI0) S = SIN(PHI0) YZ0 = U*C + V*S PYPZ0 = PUP*C + PVP*S DUM = ABS(COS(TH0)) if (DUM.ge.0.5D0) then FAC2 = -D* (DUM/PYPZ0)**2 else FAC2 = -D* (SIN(TH0)/YZ0)**2 end if DTHDAA = DPHIDAA*FAC2 TOUT = TMID I = 2 TT(I,J) = T YY(I,1,J) = Y(1) YY(I,2,J) = Y(2) YY(I,3,J) = Y(3) KFLAG = -1 C C TSAVEL, TSAVER presumed set by an earlier call with EIG .ne. 0. C if (EIG.eq.0.0D0) then if (T.le.TSAVEL) TOUT = TSAVEL if (T.gt.TSAVER) TOUT = TSAVER KFLAG = 1 end if 20 continue call GERK(FZ,3,Y,T,TOUT,EPS,EPS,KFLAG,ER,WORK,IWORK) if (KFLAG.gt.3) then WRITE (021,FMT=*) ' KFLAG1 = 5 ' IFLAG = 5 return end if if (KFLAG.eq.3) go to 20 if (Y(3).lt.-15.0D0) Y(3) = -15.0D0 PHI = Y(1) C C Store up to seven values of (T,PHI) for later reference. C I = I + 1 if (I.le.7) then TT(I,J) = T YY(I,1,J) = PHI YY(I,2,J) = Y(2) YY(I,3,J) = Y(3) end if if (10.0D0*ABS(PHI-PHI0).ge.PI) go to 30 if (KFLAG.eq.-2) go to 20 30 continue if (T.le.TOUT) then TSAVEL = T else TSAVER = T end if NT(J) = I DPHIDE = Y(2) TINTHZ = T call DXDT(T,TMP,XT) call UV(XT,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP C C Set THU and THV. C THU = ATAN2(U,PUP) if (U.lt.0.0D0) THU = THU + TWOPI call SETTHU(XT,THU) THV = ATAN2(V,PVP) if (V.lt.0.0D0) THV = THV + TWOPI 40 continue if (THV.lt.THU) then THV = THV + TWOPI go to 40 end if C C Now define TH in terms of PHI, THU, and THV. C call UVPHI(U,PUP,V,PVP,THU,THV,PHI,TH) YZ = U*COS(PHI) + V*SIN(PHI) PYPZ = PUP*COS(PHI) + PVP*SIN(PHI) Y(1) = TH S = SIN(TH) C = COS(TH) DUM = ABS(C) if (DUM.ge.0.5D0) then FAC2 = -D* (DUM/PYPZ)**2 else FAC2 = -D* (S/YZ)**2 end if DTHIN = FAC2*DPHIDE Y(2) = DTHIN Z = ZSAV RHOSQ = EXP(2.0D0*Y(3))* (YZ**2+PYPZ**2) EFF = 0.5D0*LOG(RHOSQ* (S**2+ (C/Z)**2)) Y(3) = EFF C END (INTEGRATE-FOR-PHI-OSC) end if if (TINTHZ.ne.TMID) then TIN = TINTHZ TOUT = TMID THIN = TH C DO (INTEGRATE-FOR-THETAZ) C C The following block of code replaces what was used for C non-limit-circle problems, with a few changes. C T = TIN Y(1) = THIN Y(2) = DTHIN Y(3) = 0.0D0 50 continue call GERKZ(F,3,Y,T,TOUT,EPS,EPS,LFLAG,ERZ,WORK,IWORK) if (LFLAG.gt.3) then WRITE (021,FMT=*) ' LFLAGZ = ',LFLAG IFLAG = 5 return end if if (LFLAG.eq.3 .or. LFLAG.eq.-2) go to 50 C END (INTEGRATE-FOR-THETAZ) Y(3) = Y(3) + EFF Z = 1.0D0 end if else if (LCIRC) then C DO (INTEGRATE-FOR-PHI-NONOSC) T = TEND PHI0 = ATAN2(COEF2,COEF1) C C We want -PI/2 .lt. PHI0 .le. PI/2. C if (COEF1.lt.0.0D0) PHI0 = PHI0 - SIGN(PI,COEF2) Y(1) = PHI0 Y(2) = 0.0D0 Y(3) = 0.0D0 call DXDT(T,TMP,XT) call FZ(T,Y,YP) DPHIDAA = -YP(1) call UV(XT,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP YZ0 = U*COEF1 + V*COEF2 PYPZ0 = (PUP*COEF1+PVP*COEF2)/Z C C Set TH0 and copy into THEND, overwriting its input value. C Also, redefine DTHDAA, overwriting its input value. C TH0 = ATAN2(YZ0,PYPZ0) if (YZ0.lt.0.0D0) TH0 = TH0 + TWOPI THEND = TH0 DUM = ABS(COS(TH0)) if (DUM.ge.0.5D0) then FAC2 = (-D/Z)* (DUM/PYPZ0)**2 else FAC2 = (-D/Z)* (SIN(TH0)/YZ0)**2 end if DTHDAA = FAC2*DPHIDAA C C In the next piece, we assume TH0 .ge. 0. C M = 0 if (TH0.eq.0.0D0) M = -1 if (TH0.gt.PI .or. (TH0.eq.PI.and.T.lt.TMID)) M = 1 PHI = PHI0 K2PI = 0 YZ0 = U*COS(PHI0) + V*SIN(PHI0) if (TMID.gt.TEND) then J = 1 TSTAR = -0.9999D0 else J = 2 TSTAR = 0.9999D0 end if DPHIDE = 0.0D0 call WR(FZ,EPS,TSTAR,PHI0,PHI0,DPHIDE,TOUT,Y,TT(1,J),YY(1,1,J), + ERZ,WORK,IWORK) T = TOUT DDD = MIN(0.01D0,ABS(TMID-TOUT)) TOUT = TOUT + DDD* (TMID-TOUT)/ABS(TMID-TOUT) KFLAG = 1 call GERK(FZ,3,Y,T,TOUT,EPS,EPS,KFLAG,ER,WORK,IWORK) TT(7,J) = T YY(7,1,J) = Y(1) YY(7,2,J) = Y(2) YY(7,3,J) = Y(3) 60 continue T = TOUT call DXDT(T,TMP,XT) call UV(XT,U,PUP,V,PVP,HU,HV) PHI = Y(1) S = SIN(PHI) C = COS(PHI) YZ = U*C + V*S if (YZ*YZ0.lt.0.0D0) K2PI = K2PI + 1 YZ0 = YZ if (KFLAG.gt.3) then WRITE (021,FMT=*) ' KFLAG2 = ',KFLAG IFLAG = 5 return end if if (KFLAG.eq.3 .or. KFLAG.eq.-2) go to 60 C C Convert from PHI to THETA. C DPHIDE = Y(2) D = U*PVP - V*PUP PYPZ = (PUP*C+PVP*S)/Z THBAR = ATAN2(YZ,PYPZ) if (TMID.gt.TEND .and. THBAR.lt.TH0 .and. + PHI.lt.PHI0) THBAR = THBAR + TWOPI if (TMID.lt.TEND .and. THBAR.gt.TH0 .and. + PHI.gt.PHI0) THBAR = THBAR - TWOPI TH = THBAR - M*PI if (TH.lt.-PI) TH = TH + TWOPI if (TH.gt.TWOPI) TH = TH - TWOPI if (TMID.lt.TEND .and. K2PI.gt.1) TH = TH - (K2PI-1)*TWOPI if (TMID.gt.TEND .and. K2PI.gt.1) TH = TH + (K2PI-1)*TWOPI if (TMID.gt.TEND .and. TH*TH0.lt.0.0D0) TH = TH + TWOPI C C We now have YZ, PYPZ, PHI and TH. C DUM = ABS(COS(TH)) if (DUM.ge.0.5D0) then FAC2 = - (D/Z)* (DUM/PYPZ)**2 else FAC2 = - (D/Z)* (SIN(TH)/YZ)**2 end if DTHIN = FAC2*DPHIDE THETA = ATAN2(YZ,Z*PYPZ) S = SIN(THETA) C = COS(THETA) RHOSQ = EXP(2.0D0*Y(3))* (YZ**2+ (Z*PYPZ)**2) EFF = 0.5D0*LOG(RHOSQ* (S**2+ (C/Z)**2)) C END (INTEGRATE-FOR-PHI-NONOSC) TIN = TOUT TOUT = TMID THIN = TH C DO (INTEGRATE-FOR-THETA) call INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C END (INTEGRATE-FOR-THETA) Y(3) = Y(3) + EFF else if (.not.OK .and. .not.SING) then C C This is the 'weakly regular' case. C if (TMID.gt.TEND) then J = 1 TSTAR = -0.9999D0 else J = 2 TSTAR = 0.9999D0 end if call DXDT(TSTAR,TMP,XSTAR) P1 = 1.0D0/P(XSTAR) Q1 = Q(XSTAR) W1 = W(XSTAR) YSTAR = THEND + 0.5D0* (TSTAR-TEND)* + (P1*COS(THEND)**2+ (EIG*W1-Q1)*SIN(THEND)**2) call WR(F,EPS,TSTAR,YSTAR,THEND,DTHDE,TOUT,YU,TT(1,J), + YY(1,1,J),ERZ,WORK,IWORK) T = TOUT DDD = MIN(0.01D0,ABS(TMID-TOUT)) TOUT = TOUT + DDD* (TMID-TOUT)/ABS(TMID-TOUT) KFLAG = 1 call GERK(F,3,YU,T,TOUT,EPS,EPS,KFLAG,ER,WORK,IWORK) TT(7,J) = T YY(7,1,J) = YU(1) YY(7,2,J) = YU(2) YY(7,3,J) = YU(3) TIN = TOUT TOUT = TMID THIN = YU(1) DTHIN = YU(2) C DO (INTEGRATE-FOR-THETA) call INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C END (INTEGRATE-FOR-THETA) else C C This is the regular (not weakly regular) or limit point case. C TIN = TEND TOUT = TMID THIN = THEND DTHIN = DTHDE C DO (INTEGRATE-FOR-THETA) call INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C END (INTEGRATE-FOR-THETA) end if return end subroutine INTEG subroutine INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C ********** C C Integrate for theta. C C ********** C .. Local Scalars .. double precision T integer LFLAG C .. C .. External Subroutines .. cc external F,GERK C .. C DO (INTEGRATE-FOR-TH) C .. Scalar Arguments .. double precision DTHIN,EPS,THIN,TIN,TOUT integer IFLAG C .. C .. Array Arguments .. double precision ER(3),WORK(27),Y(3) integer IWORK(5) C .. T = TIN Y(1) = THIN Y(2) = DTHIN Y(3) = 0.0D0 LFLAG = 1 10 continue call GERK(F,3,Y,T,TOUT,EPS,EPS,LFLAG,ER,WORK,IWORK) if (LFLAG.eq.3) go to 10 if (LFLAG.gt.3) then WRITE (021,FMT=*) ' LFLAG = ',LFLAG IFLAG = 5 return end if THIN = Y(1) DTHIN = Y(2) C END (INTEGRATE-FOR-TH) return end subroutine INTEGT subroutine INTPOL(N,XN,FN,X,ABSERR,MAXDEG,ANS,ERROR) C ********** C C This subroutine forms an interpolating polynomial for data pairs. C It is called from EXTRAP in solving a Sturm-Liouville problem. C C ********** C .. Local Scalars .. double precision PROD integer I,I1,II,IJ,IK,IKM1,J,K,L,LIMIT C .. C .. Local Arrays .. double precision V(10,10) integer INDEX(10) C .. C .. Intrinsic Functions .. intrinsic ABS,MIN C .. C .. Scalar Arguments .. double precision ABSERR,ANS,ERROR,X integer MAXDEG,N C .. C .. Array Arguments .. double precision FN(N),XN(N) C .. L = MIN(MAXDEG,N-2) + 2 LIMIT = MIN(L,N-1) do 10 I = 1,N V(I,1) = ABS(XN(I)-X) INDEX(I) = I 10 continue do 30 I = 1,LIMIT do 20 J = I + 1,N II = INDEX(I) IJ = INDEX(J) if (V(II,1).gt.V(IJ,1)) then INDEX(I) = IJ INDEX(J) = II end if 20 continue 30 continue PROD = 1.0D0 I1 = INDEX(1) ANS = FN(I1) V(1,1) = FN(I1) do 50 K = 2,L IK = INDEX(K) V(K,1) = FN(IK) do 40 I = 1,K - 1 II = INDEX(I) V(K,I+1) = (V(I,I)-V(K,I))/ (XN(II)-XN(IK)) 40 continue IKM1 = INDEX(K-1) PROD = (X-XN(IKM1))*PROD ERROR = PROD*V(K,K) if (ABS(ERROR).le.ABSERR) return ANS = ANS + ERROR 50 continue ANS = ANS - ERROR return end subroutine INTPOL subroutine LPOL(KEIGS,XN,FN,X,F) C ********** C ********** C .. Local variables .. C .. Scalar Arguments .. double precision F,X integer KEIGS C .. C .. Array Arguments .. double precision FN(KEIGS),XN(KEIGS) C .. C .. Local Scalars .. double precision X12,X13,X14,X15,X21,X23,X24,X25,X31,X32,X34,X35, + X41,X42,X43,X45,X51,X52,X53,X54,XX1,XX2,XX3,XX4, + XX5 C .. X12 = XN(1) - XN(2) X13 = XN(1) - XN(3) X23 = XN(2) - XN(3) X21 = -X12 X31 = -X13 X32 = -X23 XX1 = X - XN(1) XX2 = X - XN(2) XX3 = X - XN(3) if (KEIGS.ge.4) then X14 = XN(1) - XN(4) X24 = XN(2) - XN(4) X34 = XN(3) - XN(4) X41 = -X14 X42 = -X24 X43 = -X34 XX4 = X - XN(4) end if if (KEIGS.eq.5) then X15 = XN(1) - XN(5) X25 = XN(2) - XN(5) X35 = XN(3) - XN(5) X45 = XN(4) - XN(5) X51 = -X15 X52 = -X25 X53 = -X35 X54 = -X45 XX5 = X - XN(5) end if if (KEIGS.eq.3) then F = XX2*XX3*FN(1)/ (X12*X13) + XX1*XX3*FN(2)/ + (X21*X23) + XX1*XX2*FN(3)/ (X31*X32) else if (KEIGS.eq.4) then F = XX2*XX3*XX4*FN(1)/ (X12*X13*X14) + XX1*XX3*XX4*FN(2)/ + (X21*X23*X24) + XX1*XX2*XX4*FN(3)/ + (X31*X32*X34) + XX1*XX2*XX3*FN(4)/ (X41*X42*X43) else F = XX2*XX3*XX4*XX5*FN(1)/ (X12*X13*X14*X15) + + XX1*XX3*XX4*XX5*FN(2)/ (X21*X23*X24*X25) + + XX1*XX2*XX4*XX5*FN(3)/ (X31*X32*X34*X35) + + XX1*XX2*XX3*XX5*FN(4)/ (X41*X42*X43*X45) + + XX1*XX2*XX3*XX4*FN(5)/ (X51*X52*X53*X54) end if return end subroutine LPOL C C subroutine PERIO(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2, + NUMEIG,EIG,TOL,IFLAG,SLFN,SINGATA,SINGATB,CIRCLA, + CIRCLB,OSCILA,OSCILB) C ********** C ********** C .. Scalars in Common .. double precision CC,UB,UL,UR,VB,VL,VR,Z C double precision EPSMIN integer IND C .. C .. Local Scalars .. double precision A1D,A1N,A2D,A2N,AE,B1D,B1N,B2D,B2N,EIGLO,EIGUP, + LAMBDA,LAMUP,RE,TOLL,TOLS integer JFLAG C .. C .. External Subroutines .. cc external FZERO,SLEIGN2 C .. C .. External Functions .. cc? external FF cc? double precision FF C .. C .. Intrinsic Functions .. intrinsic ABS,MAX C .. C .. Common blocks .. common /EPP2/CC,UL,UR,VL,VR,UB,VB,IND C common /RNDOFF/EPSMIN common /ZEE/Z C .. C C Get upper and lower bounds as accurately as possible. C C .. Scalar Arguments .. double precision A,A1,A2,B,B1,B2,CIRCLA,CIRCLB,EIG,OSCILA,OSCILB, + P0ATA,P0ATB,QFATA,QFATB,SINGATA,SINGATB,TOL integer IFLAG,INTAB,NUMEIG C .. C .. Array Arguments .. double precision SLFN(9) C .. TOLL = 0.0D0 TOLS = TOL C A1N = 0.0D0 A2N = 1.0D0 B1N = 0.0D0 B2N = 1.0D0 TOL = TOLL EIG = 0.0D0 IFLAG = 0 call SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1N,A2N,B1N,B2N, + NUMEIG,EIG,TOL,IFLAG,0,SLFN,SINGATA,SINGATB,CIRCLA, + CIRCLB,OSCILA,OSCILB) WRITE (021,FMT=*) ' eiglo,iflag = ',EIG,IFLAG EIGLO = EIG - 0.1D0 C A1D = 1.0D0 A2D = 0.0D0 B1D = 1.0D0 B2D = 0.0D0 TOL = TOLL EIG = 0.0D0 IFLAG = 0 call SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1D,A2D,B1D,B2D, + NUMEIG,EIG,TOL,IFLAG,0,SLFN,SINGATA,SINGATB,CIRCLA, + CIRCLB,OSCILA,OSCILB) WRITE (021,FMT=*) ' eigup,iflag = ',EIG,IFLAG EIGUP = EIG + 0.1D0 LAMBDA = 0.5D0* (EIGLO+EIGUP) C C The following call to SLEIGN2 sets the stage for INTEG. C TOL = .001D0 IFLAG = -1 call SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2,NUMEIG, + LAMBDA,TOL,IFLAG,0,SLFN,SINGATA,SINGATB,CIRCLA, + CIRCLB,OSCILA,OSCILB) Z = 1.0D0 C EIG = EIGLO LAMUP = EIGUP RE = TOLS AE = RE C C IND = 2 selects the classical function d(LAMBDA) in function FF. C IND = 2 call FZERO(FF,EIG,LAMUP,LAMBDA,RE,AE,JFLAG) if (JFLAG.ne.1) WRITE (021,FMT=*) ' jflag = ',JFLAG IFLAG = JFLAG TOL = ABS(EIG-LAMUP)/MAX(1.0D0,ABS(EIG)) WRITE (021,FMT=*) ' EIGLO,EIGUP = ',EIGLO,EIGUP C return end subroutine PERIO subroutine SETMID(MF,ML,EIG,QS,WS,IMID,TMID) C ********** C C This procedures tests the interval sample points in the order C 50,51,49,52,48,...,etc. for the first one where the expression C (lambda*w-q) is positive. This point is designated TMID. C C ********** C .. Local Scalars .. double precision S integer I,J C .. C .. External Functions .. cc double precision TFROMI cc external TFROMI C .. C .. Scalar Arguments .. double precision EIG,TMID integer IMID,MF,ML C .. C .. Array Arguments .. double precision QS(*),WS(*) C .. S = -1.0D0 do 10 J = 1,100 I = 50 + S* (J/2) S = -S if (I.lt.MF .or. I.gt.ML) go to 20 if (EIG*WS(I)-QS(I).gt.0.0D0) then IMID = I TMID = TFROMI(IMID) go to 20 end if 10 continue 20 continue WRITE (021,FMT=*) ' new tmid = ',TMID return end subroutine SETMID subroutine SETTHU(X,THU) C ********** c c This subroutine establishes a definite value for THU, c the phase angle for the function U, including an c appropriate integer multiple of pi c It needs the numbers MMW(*) found in THUM c C ********** C .. Scalars in Common .. double precision HPI,PI,TWOPI integer MMWD C .. C .. Arrays in Common .. double precision YS(197) integer MMW(98) C .. C .. Local Scalars .. integer I C .. C .. Common blocks .. common /PASS/YS,MMW,MMWD common /PIE/PI,TWOPI,HPI C .. C .. Scalar Arguments .. double precision THU,X C .. do 10 I = 1,MMWD if (X.ge.YS(MMW(I)) .and. X.le.YS(MMW(I)+1)) then if (THU.gt.PI) then THU = THU + (I-1)*TWOPI return else THU = THU + I*TWOPI return end if end if 10 continue do 20 I = 1,MMWD if (X.ge.YS(MMW(I))) THU = THU + TWOPI 20 continue return end subroutine SETTHU double precision function TFROMI(I) C ********** C C This function associates the value of an interval sample point C with its index. C C ********** C .. Scalar Arguments .. integer I C .. if (I.lt.8) then TFROMI = -1.0D0 + 0.1D0/4.0D0** (8-I) else if (I.gt.92) then TFROMI = 1.0D0 - 0.1D0/4.0D0** (I-92) else TFROMI = 0.0227D0* (I-50) end if return end function TFROMI subroutine THTOTHZ(Y,Z,U) C ********** C THIS PROGRAM CONVERTS FROM TH TO THZ WHERE C TAN(TH)=PSI/(P*PSI') C AND C TAN(THZ)=Z*PSI/(P*PSI'), C OR C TAN(THZ)=Z*TAN(TH) . C SO WE HAVE C DTHZ=Z*(COS(THZ)/COS(TH))**2 * DTH , C OR C DTH=(1/Z)*(COS(TH)/COS(THZ))**2 * DTHZ . C ********** C .. Scalars in Common .. double precision HPI,PI,TWOPI C .. C .. Local Scalars .. double precision DTH,DTHZ,DUM,FAC,PIK,REMTH,TH,THZ integer K C .. C .. Intrinsic Functions .. intrinsic ABS,ATAN,COS,LOG,SIN,TAN C .. C .. Common blocks .. common /PIE/PI,TWOPI,HPI C .. C .. Scalar Arguments .. double precision Z C .. C .. Array Arguments .. double precision U(3),Y(3) C .. TH = Y(1) DTH = Y(2) K = TH/PI if (TH.lt.0.0D0) K = K - 1 PIK = K*PI REMTH = TH - PIK if (4.0D0*REMTH.le.PI) then THZ = ATAN(Z*TAN(REMTH)) + PIK else if (4.0D0*REMTH.ge.3.0D0*PI) then THZ = ATAN(Z*TAN(REMTH)) + PIK + PI else THZ = ATAN(TAN(REMTH-HPI)/Z) + PIK + HPI end if DUM = ABS(COS(THZ)) if (DUM.ge.0.5D0) then FAC = Z* (DUM/COS(TH))**2 else FAC = (SIN(THZ)/SIN(TH))**2/Z end if DTHZ = FAC*DTH U(1) = THZ U(2) = DTHZ U(3) = Y(3) - 0.5D0*LOG(Z*FAC) return end subroutine THTOTHZ subroutine THUM(MF,ML,XS) C ********** C C YS IS LIKE XS, BUT HAS TWICE AS MANY POINTS. C MMW(N) IS THE VALUE OF THE INDEX I OF U(I), MF .LE. I .LE. 2*ML-2, C WHERE U FOR THE Nth TIME CHANGES SIGN FROM - TO + C AND WHERE P*U' IS POSITIVE. C MMWD IS THE NUMBER OF SUCH POINTS OF U. C C ********** C .. Scalars in Common .. integer MMWD C .. C .. Arrays in Common .. double precision YS(197) integer MMW(98) C .. C .. Local Scalars .. double precision PUP,PUP1,TMP,U,U1 integer I,N C .. C .. Common blocks .. common /PASS/YS,MMW,MMWD C .. C .. Scalar Arguments .. integer MF,ML C .. C .. Array Arguments .. double precision XS(*) C .. C .. External Subroutines .. cc external UV C .. do 10 I = 1,98 YS(2*I-1) = XS(I) YS(2*I) = 0.5D0* (XS(I)+XS(I+1)) 10 continue YS(197) = XS(99) N = 0 U1 = 0.0D0 PUP1 = 0.0D0 do 20 I = 2*MF - 1,2*ML - 1 call UV(YS(I),U,PUP,TMP,TMP,TMP,TMP) if (U1.lt.0.0D0 .and. U.gt.0.0D0 .and. PUP1.gt.0.0D0) then N = N + 1 MMW(N) = I - 1 end if U1 = U PUP1 = PUP 20 continue MMWD = N return end subroutine THUM subroutine THZTOTH(U,Z,Y) C ********** C THIS PROGRAM CONVERTS FROM THZ TO TH WHERE C TAN(TH)=PSI/(P*PSI') C AND C TAN(THZ)=Z*PSI/(P*PSI'), C OR C TAN(THZ)=Z*TAN(TH) . C SO WE HAVE C DTHZ=Z*(COS(THZ)/COS(TH))**2 * DTH , C OR C DTH=(1/Z)*(COS(TH)/COS(THZ))**2 * DTHZ . C ********** C .. Scalars in Common .. double precision HPI,PI,TWOPI C .. C .. Local Scalars .. double precision DTH,DTHZ,DUM,FAC,PIK,REMTHZ,TH,THZ integer K C .. C .. Intrinsic Functions .. intrinsic ABS,ATAN,COS,LOG,SIN,TAN C .. C .. Common blocks .. common /PIE/PI,TWOPI,HPI C .. C .. Scalar Arguments .. double precision Z C .. C .. Array Arguments .. double precision U(3),Y(3) C .. THZ = U(1) DTHZ = U(2) K = THZ/PI if (THZ.lt.0.0D0) K = K - 1 PIK = K*PI REMTHZ = THZ - PIK if (4.0D0*REMTHZ.le.PI) then TH = ATAN(TAN(REMTHZ)/Z) + PIK else if (4.0D0*REMTHZ.ge.3.0D0*PI) then TH = ATAN(TAN(REMTHZ)/Z) + PIK + PI else TH = ATAN(Z*TAN(REMTHZ-HPI)) + PIK + HPI end if DUM = ABS(COS(TH)) if (DUM.ge.0.5D0) then FAC = (DUM/COS(THZ))**2/Z else FAC = Z* (SIN(TH)/SIN(THZ))**2 end if DTH = FAC*DTHZ Y(1) = TH Y(2) = DTH Y(3) = U(3) + 0.5D0*LOG(Z/FAC) return end subroutine THZTOTH subroutine UVPHI(U,PUP,V,PVP,THU,THV,PHI,TH) C ********** C C This program finds TH appropriate to THU, THV, and PHI, where C THU is the phase angle for U, and THV is the phase angle for V. C C ********** C .. Scalars in Common .. double precision HPI,PI,TWOPI C .. C .. Local Scalars .. double precision C,D,PYP,S,Y C .. C .. External Subroutines .. cc external FIT C .. C .. Intrinsic Functions .. intrinsic ATAN2,COS,SIN C .. C .. Common blocks .. common /PIE/PI,TWOPI,HPI C .. C .. Scalar Arguments .. double precision PHI,PUP,PVP,TH,THU,THV,U,V C .. TH = THU if (PHI.eq.0.0D0) return if (THV-THU.lt.PI) then TH = THV if (PHI.eq.-HPI) return TH = THV - PI if (PHI.eq.HPI) return else TH = THV - PI if (PHI.eq.-HPI) return TH = THV - TWOPI if (PHI.eq.HPI) return end if C = COS(PHI) S = SIN(PHI) Y = U*C + V*S PYP = PUP*C + PVP*S TH = ATAN2(Y,PYP) if (Y.lt.0.0D0) TH = TH + TWOPI D = U*PVP - V*PUP if (D*PHI.gt.0.0D0) then call FIT(THU-PI,TH,THU) else call FIT(THU,TH,THU+PI) end if return end subroutine UVPHI subroutine WR(FG,EPS,TSTAR,YSTAR,THEND,DTHDE,TOUT,Y,TT,YY,ERR, + WORK,IWORK) C ********** C C This subroutine integrates Y' = F(T,Y) from t = +/-1.0 to THEND C even when F cannot be evaluated at t. (T*,Y*) is chosen as a C nearby point, and the equation is integrated from there and C checked for consistency with having integrated from t. If not, C a different (T*,Y*) is chosen until consistency is achieved. C C ********** C .. Scalars in Common .. double precision EIG,EPSMIN integer IND C .. C .. Local Scalars .. double precision CHNG,D2F,D2G,D3F,D3G,D4F,D4G,HT,HU,OLDSS2,OLDYY2, + ONE,SLO,SOUT,SUMM,SUP,T,TEN5,TIN,U,UOUT,USTAR, + YLO,YOUT,YUP integer I,K,KFLAG C .. C .. Local Arrays .. double precision DF(4),DG(4),FF(6),GG(5),S(3),SS(6,3),UU(6) C .. C .. External Subroutines .. cc external GERK,LPOL C .. C .. Intrinsic Functions .. intrinsic ABS,SIGN C .. C .. Common blocks C .. Scalar Arguments .. double precision DTHDE,EPS,THEND,TOUT,TSTAR,YSTAR C .. C .. Array Arguments .. double precision ERR(3),TT(7),WORK(27),Y(3),YY(7,3) integer IWORK(5) C .. C .. Subroutine Arguments .. external FG C .. C .. Common blocks .. common /DATAF/EIG,IND common /RNDOFF/EPSMIN C .. ONE = 1.0D0 TEN5 = 100000.0D0 C C Integrate Y' = F(T,Y,YP). C TIN = SIGN(ONE,TSTAR) HT = TSTAR - TIN TT(1) = TIN YY(1,1) = THEND YY(1,2) = DTHDE YY(1,3) = 0.0D0 TT(2) = TSTAR YY(2,1) = YSTAR YY(2,2) = DTHDE YY(2,3) = 0.0D0 YLO = -TEN5 YUP = TEN5 C C Normally IND = 1 or 3; IND is set to 2 or 4 when Y is to be used C as the independent variable in FG(T,Y,YP), instead of the usual T. C Before leaving this subroutine, IND is reset to 1. C 10 continue T = TSTAR Y(1) = YY(2,1) Y(2) = YY(2,2) Y(3) = YY(2,3) KFLAG = 1 IND = 1 do 30 K = 3,6 TOUT = T + HT 20 continue call GERK(FG,3,Y,T,TOUT,EPS,EPS,KFLAG,ERR,WORK,IWORK) if (KFLAG.gt.3) then WRITE (021,FMT=*) ' KFLAG3 = 5 ' end if if (KFLAG.eq.3) go to 20 YOUT = Y(1) TT(K) = T YY(K,1) = YOUT YY(K,2) = Y(2) YY(K,3) = Y(3) 30 continue IND = 3 do 40 I = 2,6 call FG(TT(I),YY(I,1),FF(I)) 40 continue call LPOL(5,TT(2),FF(2),TT(1),FF(1)) if (ABS(FF(1)).le.500.0D0) then C C Now we want to apply some criterion to see if these results are C consistent with having integrated from (TT(1),YY(1,1). C do 50 I = 1,4 DF(I) = FF(I+1) - FF(I) 50 continue D2F = DF(4) - DF(3) D3F = DF(4) - 2.0D0*DF(3) + DF(2) D4F = DF(4) - 3.0D0*DF(3) + 3.0D0*DF(2) - DF(1) SUMM = HT* (FF(5)-3.5D0*DF(4)+53.0D0*D2F/12.0D0-55.0D0*D3F/ + 24.0D0+251.0D0*D4F/720.0D0) C C Presumably, YY(2,1) should be YY(1,1) + SUMM. C OLDYY2 = YY(2,1) YY(2,1) = YY(1,1) + SUMM C C Also improve the value of Y(2) at TSTAR. C YY(2,2) = 0.5D0* (YY(1,2)+YY(3,2)) YY(2,3) = 0.5D0* (YY(1,3)+YY(3,3)) CHNG = YY(2,1) - OLDYY2 if (CHNG.ge.0.0D0 .and. OLDYY2.gt.YLO) YLO = OLDYY2 if (CHNG.le.0.0D0 .and. OLDYY2.lt.YUP) YUP = OLDYY2 if ((YY(2,1).ge.YUP.and.YLO.gt.-TEN5) .or. + (YY(2,1).le.YLO.and.YUP.lt.TEN5)) YY(2,1) = 0.5D0* + (YLO+YUP) if (ABS(YY(2,1)-OLDYY2).gt.EPSMIN) go to 10 else C C Here, Y' is assumed infinite at T = TIN. In this case, C it cannot be expected to approximate Y with a polynomial, C so the independent and dependent variables are interchanged. C The points are assumed equally spaced. C HU = (YY(6,1)-YY(1,1))/5.0D0 UU(1) = YY(1,1) SS(1,1) = TT(1) SS(1,2) = DTHDE SS(1,3) = 0.0D0 UU(2) = UU(1) + HU SS(2,1) = TSTAR SS(2,2) = DTHDE SS(2,3) = 0.0D0 USTAR = UU(2) SLO = -TEN5 SUP = TEN5 60 continue U = USTAR S(1) = SS(2,1) S(2) = SS(2,2) S(3) = SS(2,3) KFLAG = 1 IND = 2 do 80 K = 3,6 UOUT = U + HU 70 continue call GERK(FG,3,S,U,UOUT,EPS,EPS,KFLAG,ERR,WORK,IWORK) if (KFLAG.gt.3) then WRITE (021,FMT=*) ' KFLAG4 = 5 ' end if if (KFLAG.eq.3) go to 70 SOUT = S(1) UU(K) = U SS(K,1) = SOUT SS(K,2) = S(2) SS(K,3) = S(3) 80 continue IND = 4 do 90 I = 2,5 call FG(UU(I),SS(I,1),GG(I)) 90 continue GG(1) = 0.0D0 do 100 I = 1,4 DG(I) = GG(I+1) - GG(I) 100 continue D2G = DG(4) - DG(3) D3G = DG(4) - 2.0D0*DG(3) + DG(2) D4G = DG(4) - 3.0D0*DG(3) + 3.0D0*DG(2) - DG(1) SUMM = HU* (GG(5)-3.5D0*DG(4)+53.0D0*D2G/12.0D0-55.0D0*D3G/ + 24.0D0+251.0D0*D4G/720.0D0) C C Presumably, SS(2,1) should be SS(1,1) + SUMM. C OLDSS2 = SS(2,1) SS(2,1) = SS(1,1) + SUMM if (SS(2,1).le.-1.0D0) SS(2,1) = -1.0D0 + EPSMIN if (SS(2,1).ge.1.0D0) SS(2,1) = 1.0D0 - EPSMIN C C Also improve the value of Y(2) at TSTAR. C SS(2,2) = 0.5D0* (SS(1,2)+SS(3,2)) SS(2,3) = 0.5D0* (SS(1,3)+SS(3,3)) CHNG = SS(2,1) - OLDSS2 if (CHNG.ge.0.0D0 .and. OLDSS2.gt.SLO) SLO = OLDSS2 if (CHNG.le.0.0D0 .and. OLDSS2.lt.SUP) SUP = OLDSS2 if ((SS(2,1).ge.SUP.and.SLO.gt.-TEN5) .or. + (SS(2,1).le.SLO.and.SUP.lt.TEN5)) SS(2,1) = 0.5D0* + (SLO+SUP) if (ABS(SS(2,1)-OLDSS2).gt.EPSMIN) go to 60 end if if (IND.eq.4) then do 110 I = 1,6 TT(I) = SS(I,1) YY(I,1) = UU(I) YY(I,2) = SS(I,2) YY(I,3) = SS(I,3) 110 continue end if TOUT = TT(6) IND = 1 return end subroutine WR subroutine GERK(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,GERROR,WORK, + IWORK) C C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C C WRITTEN BY H.A.WATTS AND L.F.SHAMPINE C SANDIA LABORATORIES C C GERK IS DESIGNED TO SOLVE SYSTEMS OF DIFFERENTIAL EQUATIONS C WHEN IT IS IMPORTANT TO HAVE A READILY AVAILABLE GLOBAL ERROR C ESTIMATE. PARALLEL INTEGRATION IS PERFORMED TO YIELD TWO C SOLUTIONS ON DIFFERENT MESH SPACINGS AND GLOBAL EXTRAPOLATION C IS APPLIED TO PROVIDE AN ESTIMATE OF THE GLOBAL ERROR IN THE C MORE ACCURATE SOLUTION. C C FOR IBM SYSTEM 360 AND 370 AND OTHER MACHINES OF SIMILAR C ARITHMETIC CHARACTERISTICS, THIS CODE SHOULD BE CONVERTED TO C REAL. C C******************************************************************* C ABSTRACT C******************************************************************* C C SUBROUTINE GERK INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN)) C WHERE THE Y(I) ARE GIVEN AT T . C TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TOUT C BUT IT CAN BE USED AS A ONE-STEP INTEGRATOR TO ADVANCE THE C SOLUTION A SINGLE STEP IN THE DIRECTION OF TOUT. ON RETURN, AN C ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T IS PROVIDED C AND THE PARAMETERS IN THE CALL LIST ARE SET FOR CONTINUING THE C INTEGRATION. THE USER HAS ONLY TO CALL GERK AGAIN (AND PERHAPS C DEFINE A NEW VALUE FOR TOUT). ACTUALLY, GERK IS MERELY AN C INTERFACING ROUTINE WHICH ALLOCATES VIRTUAL STORAGE IN THE C ARRAYS WORK, IWORK AND CALLS SUBROUTINE GERKS FOR THE SOLUTION. C GERKS IN TURN CALLS SUBROUTINE FEHL WHICH COMPUTES AN APPROX- C IMATE SOLUTION OVER ONE STEP. C C GERK USES THE RUNGE-KUTTA-FEHLBERG (4,5) METHOD DESCRIBED C IN THE REFERENCE C E.FEHLBERG , LOW-ORDER CLASSICAL RUNGE-KUTTA FORMULAS WITH C STEPSIZE CONTROL , NASA TR R-315 C C C THE PARAMETERS REPRESENT- C F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES C YP(I)=DY(I)/DT C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT T C T -- INDEPENDENT VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED C RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR C LOCAL ERROR TEST. AT EACH STEP THE CODE REQUIRES THAT C ABS(LOCAL ERROR) .LE. RELERR*ABS(Y) + ABSERR C FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION C VECTORS. C IFLAG -- INDICATOR FOR STATUS OF INTEGRATION C GERROR(*) -- VECTOR WHICH ESTIMATES THE GLOBAL ERROR AT T. C THAT IS, GERROR(I) APPROXIMATES Y(I)-TRUE C SOLUTION(I). C WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO GERK WHICH C IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED C AT LEAST 3+8*NEQN C IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL C TO GERK WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST C BE DIMENSIONED AT LEAST 5 C C C******************************************************************* C FIRST CALL TO GERK C******************************************************************* C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE C ARRAYS IN THE CALL LIST - Y(NEQN), WORK(3+8*NEQN), IWORK(5), C DECLARE F IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE F(T,Y,YP) C AND INITIALIZE THE FOLLOWING PARAMETERS- C C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED. (NEQN .GE. 1) C Y(*) -- VECTOR OF INITIAL CONDITIONS C T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED. C T=TOUT IS ALLOWED ON THE FIRST CALL ONLY,IN WHICH CASE C GERK RETURNS WITH IFLAG=2 IF CONTINUATION IS POSSIBLE. C RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES C WHICH MUST BE NON-NEGATIVE BUT MAY BE CONSTANTS. WE CAN C USUALLY EXPECT THE GLOBAL ERRORS TO BE SOMEWHAT SMALLER C THAN THE REQUESTED LOCAL ERROR TOLERANCES. TO AVOID C LIMITING PRECISION DIFFICULTIES THE CODE ALWAYS USES C THE LARGER OF RELERR AND AN INTERNAL RELATIVE ERROR C PARAMETER WHICH IS MACHINE DEPENDENT. C IFLAG -- +1,-1 INDICATOR TO INITIALIZE THE CODE FOR EACH NEW C PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG= C -1 ONLY WHEN ONE-STEP INTEGRATOR CONTROL IS ESSENTIAL. C IN THIS CASE, GERK ATTEMPTS TO ADVANCE THE SOLUTION A C SINGLE STEP IN THE DIRECTION OF TOUT EACH TIME IT IS C CALLED. SINCE THIS MODE OF OPERATION RESULTS IN EXTRA C COMPUTING OVERHEAD, IT SHOULD BE AVOIDED UNLESS NEEDED. C C C******************************************************************* C OUTPUT FROM GERK C******************************************************************* C C Y(*) -- SOLUTION AT T C T -- LAST POINT REACHED IN INTEGRATION. C IFLAG = 2 -- INTEGRATION REACHED TOUT. INDICATES SUCCESSFUL C RETURN AND IS THE NORMAL MODE FOR CONTINUING C INTEGRATION. C =-2 -- A SINGLE SUCCESSFUL STEP IN THE DIRECTION OF C TOUT HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING C INTEGRATION ONE STEP AT A TIME. C = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN C 9000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS C IS APPROXIMATELY 500 STEPS. C = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION C VANISHED MAKING A PURE RELATIVE ERROR TEST C IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE. C USING THE ONE-STEP INTEGRATION MODE FOR ONE STEP C IS A GOOD WAY TO PROCEED. C = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED C ACCURACY COULD NOT BE ACHIEVED USING SMALLEST C ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR C TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE C ATTEMPTED. C = 6 -- GERK IS BEING USED INEFFICIENTLY IN SOLVING C THIS PROBLEM. TOO MUCH OUTPUT IS RESTRICTING THE C NATURAL STEPSIZE CHOICE. USE THE ONE-STEP C INTEGRATOR MODE. C = 7 -- INVALID INPUT PARAMETERS C THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS C SATISFIED - NEQN .LE. 0 C T=TOUT AND IFLAG .NE. +1 OR -1 C RELERR OR ABSERR .LT. 0. C IFLAG .EQ. 0 OR .LT. -2 OR .GT. 7 C GERROR(*) -- ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T C WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO C INTEREST TO THE USER BUT NECESSARY FOR SUBSEQUENT C CALLS. WORK(1),...,WORK(NEQN) CONTAIN THE FIRST C DERIVATIVES OF THE SOLUTION VECTOR Y AT T. C WORK(NEQN+1) CONTAINS THE STEPSIZE H TO BE C ATTEMPTED ON THE NEXT STEP. IWORK(1) CONTAINS C THE DERIVATIVE EVALUATION COUNTER. C C C******************************************************************* C SUBSEQUENT CALLS TO GERK C******************************************************************* C C SUBROUTINE GERK RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE C THE INTEGRATION. IF THE INTEGRATION REACHED TOUT, THE USER NEED C ONLY DEFINE A NEW TOUT AND CALL GERK AGAIN. IN THE ONE-STEP C INTEGRATOR MODE (IFLAG=-2) THE USER MUST KEEP IN MIND THAT EACH C STEP TAKEN IS IN THE DIRECTION OF THE CURRENT TOUT. UPON C REACHING TOUT (INDICATED BY CHANGING IFLAG TO 2), THE USER MUST C THEN DEFINE A NEW TOUT AND RESET IFLAG TO -2 TO CONTINUE IN THE C ONE-STEP INTEGRATOR MODE. C C IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS C TO CONTINUE (IFLAG=3 CASE), HE JUST CALLS GERK AGAIN. THE C FUNCTION COUNTER IS THEN RESET TO 0 AND ANOTHER 9000 FUNCTION C EVALUATIONS ARE ALLOWED. C C HOWEVER, IN THE CASE IFLAG=4, THE USER MUST FIRST ALTER THE C ERROR CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE C INTEGRATION CAN PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED. C C ALSO, IN THE CASE IFLAG=5, IT IS NECESSARY FOR THE USER TO C RESET IFLAG TO 2 (OR -2 WHEN THE ONE-STEP INTEGRATION MODE IS C BEING USED) AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH C BEFORE THE INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, C EXECUTION WILL BE TERMINATED. THE OCCURRENCE OF IFLAG=5 C INDICATES A TROUBLE SPOT (SOLUTION IS CHANGING RAPIDLY, C SINGULARITY MAY BE PRESENT) AND IT OFTEN IS INADVISABLE TO C CONTINUE. C C IF IFLAG=6 IS ENCOUNTERED, THE USER SHOULD USE THE ONE-STEP C INTEGRATION MODE WITH THE STEPSIZE DETERMINED BY THE CODE. IF C THE USER INSISTS UPON CONTINUING THE INTEGRATION WITH GERK IN C THE INTERVAL MODE, HE MUST RESET IFLAG TO 2 BEFORE CALLING GERK C AGAIN. OTHERWISE,EXECUTION WILL BE TERMINATED. C C IF IFLAG=7 IS OBTAINED, INTEGRATION CAN NOT BE CONTINUED UNLESS C THE INVALID INPUT PARAMETERS ARE CORRECTED. C C IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN C INFORMATION REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, C WORK AND IWORK SHOULD NOT BE ALTERED. C C******************************************************************* C C .. Scalar Arguments .. double precision ABSERR,RELERR,T,TOUT integer IFLAG,NEQN C .. C .. Array Arguments .. double precision GERROR(NEQN),WORK(3+8*NEQN),Y(NEQN) integer IWORK(5) C .. C .. Subroutine Arguments .. external F C .. C .. Local Scalars .. integer K1,K1M,K2,K3,K4,K5,K6,K7,K8 C .. C .. External Subroutines .. cc external GERKS C .. C COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY K1M = NEQN + 1 K1 = K1M + 1 K2 = K1 + NEQN K3 = K2 + NEQN K4 = K3 + NEQN K5 = K4 + NEQN K6 = K5 + NEQN K7 = K6 + NEQN K8 = K7 + NEQN C ******************************************************************* C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, C HE MUST USE GERKS DIRECTLY. C ******************************************************************* call GERKS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,GERROR,WORK(1), + WORK(K1M),WORK(K1),WORK(K2),WORK(K3),WORK(K4),WORK(K5), + WORK(K6),WORK(K7),WORK(K8),WORK(K8+1),IWORK(1), + IWORK(2),IWORK(3),IWORK(4),IWORK(5)) return end subroutine GERK subroutine GERKS(F,NEQN,Y,T,TOUT,RELERR,ABSERR,IFLAG,GERROR,YP,H, + F1,F2,F3,F4,F5,YG,YGP,SAVRE,SAVAE,NFE,KOP,INIT, + JFLAG,KFLAG) C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C ******************************************************************* C GERKS INTEGRATES A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL C EQUATIONS AS DESCRIBED IN THE COMMENTS FOR GERK. THE ARRAYS C YP,F1,F2,F3,F4,F5,YG AND YGP (OF DIMENSION AT LEAST NEQN) AND C THE VARIABLES H,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,AND KFLAG ARE C USED INTERNALLY BY THE CODE AND APPEAR IN THE CALL LIST TO C ELIMINATE LOCAL RETENTION OF VARIABLES BETWEEN CALLS. C ACCORDINGLY, THEY SHOULD NOT BE ALTERED. ITEMS OF POSSIBLE C INTEREST ARE C YP - DERIVATIVE OF SOLUTION VECTOR AT T C H - AN APPROPRIATE STEPSIZE TO BE USED FOR THE NEXT STEP C NFE- COUNTER ON THE NUMBER OF DERIVATIVE FUNCTION C EVALUATIONS. C ******************************************************************* C .. Scalar Arguments .. double precision ABSERR,H,RELERR,SAVAE,SAVRE,T,TOUT integer IFLAG,INIT,JFLAG,KFLAG,KOP,NEQN,NFE C .. C .. Array Arguments .. double precision F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN), + GERROR(NEQN),Y(NEQN),YG(NEQN),YGP(NEQN),YP(NEQN) C .. C .. Subroutine Arguments .. external F C .. C .. Local Scalars .. double precision A,AE,DT,EE,EEOET,ESTTOL,ET,HH,HMIN,ONE,REMIN,RER, + S,SCALE,TOL,TOLN,TS,U,U26,YPK integer K,MAXNFE,MFLAG logical HFAILD,OUTPUT C .. C .. External Functions .. cc double precision EPSLON cc external EPSLON C .. C .. External Subroutines .. cc external FEHL C .. C .. Intrinsic Functions .. intrinsic ABS,MAX,MIN,SIGN C .. C ******************************************************************* C REMIN IS A TOLERANCE THRESHOLD WHICH IS ALSO DETERMINED BY THE C INTEGRATION METHOD. IN PARTICULAR, A FIFTH ORDER METHOD WILL C GENERALLY NOT BE CAPABLE OF DELIVERING ACCURACIES NEAR LIMITING C PRECISION ON COMPUTERS WITH LONG WORDLENGTHS. C ******************************************************************* C THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER C OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE. C AS SET,THIS CORRESPONDS TO ABOUT 500 STEPS. C ******************************************************************* C U - THE COMPUTER UNIT ROUNDOFF ERROR U IS THE SMALLEST POSITIVE C VALUE REPRESENTABLE IN THE MACHINE SUCH THAT 1.+ U .GT. 1. C (VARIABLE ONE SET TO 1.0 EASES PRECISION CONVERSION.) C C .. Data statements .. data REMIN/3.D-11/ data MAXNFE/9000/ C .. ONE = 1.0D0 U = EPSLON(ONE) C ******************************************************************* C CHECK INPUT PARAMETERS if (NEQN.lt.1) go to 10 if ((RELERR.lt.0.D0) .or. (ABSERR.lt.0.D0)) go to 10 MFLAG = ABS(IFLAG) if ((MFLAG.ge.1) .and. (MFLAG.le.7)) go to 20 C INVALID INPUT 10 IFLAG = 7 return C IS THIS THE FIRST CALL 20 if (MFLAG.eq.1) go to 70 C CHECK CONTINUATION POSSIBILITIES if (T.eq.TOUT) go to 10 if (MFLAG.ne.2) go to 30 C IFLAG = +2 OR -2 if (INIT.eq.0) go to 60 if (KFLAG.eq.3) go to 50 if ((KFLAG.eq.4) .and. (ABSERR.eq.0.D0)) go to 40 if ((KFLAG.eq.5) .and. (RELERR.le.SAVRE) .and. + (ABSERR.le.SAVAE)) go to 40 go to 70 C IFLAG = 3,4,5,6, OR 7 30 if (IFLAG.eq.3) go to 50 if ((IFLAG.eq.4) .and. (ABSERR.gt.0.D0)) go to 60 C INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO C THE INSTRUCTIONS PERTAINING TO IFLAG=4,5,6 OR 7 40 stop C ******************************************************************* C RESET FUNCTION EVALUATION COUNTER 50 NFE = 0 if (MFLAG.eq.2) go to 70 C RESET FLAG VALUE FROM PREVIOUS CALL 60 IFLAG = JFLAG C SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT C INPUT CHECKING 70 JFLAG = IFLAG KFLAG = 0 C SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS SAVRE = RELERR SAVAE = ABSERR C RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS C 32U+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING C FROM IMPOSSIBLE ACCURACY REQUESTS RER = MAX(RELERR,32.D0*U+REMIN) U26 = 26.D0*U DT = TOUT - T if (MFLAG.eq.1) go to 80 if (INIT.eq.0) go to 90 go to 110 C ******************************************************************* C INITIALIZATION -- C SET INITIALIZATION COMPLETION INDICATOR,INIT C SET INDICATOR FOR TOO MANY OUTPUT POINTS,KOP C EVALUATE INITIAL DERIVATIVES C COPY INITIAL VALUES AND DERIVATIVES FOR THE C PARALLEL SOLUTION C SET COUNTER FOR FUNCTION EVALUATIONS,NFE C ESTIMATE STARTING STEPSIZE 80 INIT = 0 KOP = 0 A = T call F(A,Y,YP) NFE = 1 if (T.ne.TOUT) go to 90 IFLAG = 2 return 90 INIT = 1 H = ABS(DT) TOLN = 0.D0 do 100 K = 1,NEQN YG(K) = Y(K) YGP(K) = YP(K) TOL = RER*ABS(Y(K)) + ABSERR if (TOL.le.0.D0) go to 100 TOLN = TOL YPK = ABS(YP(K)) if (YPK*H**5.gt.TOL) H = (TOL/YPK)**0.2D0 100 continue if (TOLN.le.0.D0) H = 0.D0 H = MAX(H,U26*MAX(ABS(T),ABS(DT))) C ******************************************************************* C SET STEPSIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT 110 H = SIGN(H,DT) C TEST TO SEE IF GERK IS BEING SEVERELY IMPACTED BY TOO MANY C OUTPUT POINTS if (ABS(H).gt.2.D0*ABS(DT)) KOP = KOP + 1 if (KOP.ne.100) go to 120 KOP = 0 IFLAG = 6 return 120 if (ABS(DT).gt.U26*ABS(T)) go to 140 C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN do 130 K = 1,NEQN YG(K) = YG(K) + DT*YGP(K) Y(K) = Y(K) + DT*YP(K) 130 continue A = TOUT call F(A,YG,YGP) call F(A,Y,YP) NFE = NFE + 2 go to 230 C INITIALIZE OUTPUT POINT INDICATOR 140 OUTPUT = .FALSE. C TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION, C SCALE THE ERROR TOLERANCES SCALE = 2.D0/RER AE = SCALE*ABSERR C ******************************************************************* C ******************************************************************* C STEP BY STEP INTEGRATION 150 HFAILD = .FALSE. C SET SMALLEST ALLOWABLE STEPSIZE HMIN = U26*ABS(T) C ADJUST STEPSIZE IF NECESSARY TO HIT THE OUTPUT POINT. C LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEPSIZE C AND THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE. DT = TOUT - T if (ABS(DT).ge.2.D0*ABS(H)) go to 170 if (ABS(DT).gt.ABS(H)) go to 160 C THE NEXT SUCCESSFUL STEP WILL COMPLETE THE INTEGRATION TO THE C OUTPUT POINT OUTPUT = .TRUE. H = DT go to 170 160 H = 0.5D0*DT C ******************************************************************* C CORE INTEGRATOR FOR TAKING A SINGLE STEP C ******************************************************************* C THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW C IN COMPUTING THE ERROR TOLERANCE FUNCTION ET. C TO AVOID PROBLEMS WITH ZERO CROSSINGS, RELATIVE ERROR IS C MEASURED USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION C AT THE BEGINNING AND END OF A STEP. C THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF C SIGNIFICANCE. C TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED C TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T. C PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO C SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE C CHATTERING ON PROBLEMS HAVING DISCONTINUITIES. C TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE C STEPSIZE IT ESTIMATES WILL SUCCEED. C AFTER A STEP FAILURE, THE STEPSIZE IS NOT ALLOWED TO INCREASE C FOR THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE C EFFICIENT ON PROBLEMS HAVING DISCONTINUITIES AND MORE C EFFECTIVE IN GENERAL SINCE LOCAL EXTRAPOLATION IS BEING USED C AND THE ERROR ESTIMATE MAY BE UNRELIABLE OR UNACCEPTABLE WHEN C A STEP FAILS. C ******************************************************************* C TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS. C IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H 170 if (NFE.le.MAXNFE) go to 180 C TOO MUCH WORK IFLAG = 3 KFLAG = 3 return C ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H 180 call FEHL(F,NEQN,YG,T,H,YGP,F1,F2,F3,F4,F5,F1) NFE = NFE + 5 C COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR C ESTIMATES AND REMOVE SCALING OF TOLERANCES. NOTE THAT RELATIVE C ERROR IS MEASURED WITH RESPECT TO THE AVERAGE MAGNITUDES OF THE C OF THE SOLUTION AT THE BEGINNING AND END OF THE STEP. EEOET = 0.D0 do 200 K = 1,NEQN ET = ABS(YG(K)) + ABS(F1(K)) + AE if (ET.gt.0.D0) go to 190 C INAPPROPRIATE ERROR TOLERANCE IFLAG = 4 KFLAG = 4 return 190 EE = ABS((-2090.D0*YGP(K)+ (21970.D0*F3(K)-15048.D0*F4(K)))+ + (22528.D0*F2(K)-27360.D0*F5(K))) EEOET = MAX(EEOET,EE/ET) 200 continue ESTTOL = ABS(H)*EEOET*SCALE/752400.D0 if (ESTTOL.le.1.D0) go to 210 C UNSUCCESSFUL STEP C REDUCE THE STEPSIZE , TRY AGAIN C THE DECREASE IS LIMITED TO A FACTOR OF 1/10 HFAILD = .TRUE. OUTPUT = .FALSE. S = 0.1D0 if (ESTTOL.lt.59049.D0) S = 0.9D0/ESTTOL**0.2D0 H = S*H if (ABS(H).gt.HMIN) go to 170 C REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE IFLAG = 5 KFLAG = 5 return C SUCCESSFUL STEP C STORE ONE-STEP SOLUTION YG AT T+H C AND EVALUATE DERIVATIVES THERE 210 TS = T T = T + H do 220 K = 1,NEQN YG(K) = F1(K) 220 continue A = T call F(A,YG,YGP) NFE = NFE + 1 C NOW ADVANCE THE Y SOLUTION OVER TWO STEPS OF C LENGTH H/2 AND EVALUATE DERIVATIVES THERE HH = 0.5D0*H call FEHL(F,NEQN,Y,TS,HH,YP,F1,F2,F3,F4,F5,Y) TS = TS + HH A = TS call F(A,Y,YP) call FEHL(F,NEQN,Y,TS,HH,YP,F1,F2,F3,F4,F5,Y) A = T call F(A,Y,YP) NFE = NFE + 12 C CHOOSE NEXT STEPSIZE C THE INCREASE IS LIMITED TO A FACTOR OF 5 C IF STEP FAILURE HAS JUST OCCURRED, NEXT C STEPSIZE IS NOT ALLOWED TO INCREASE S = 5.D0 if (ESTTOL.gt.1.889568D-4) S = 0.9D0/ESTTOL**0.2D0 if (HFAILD) S = MIN(S,ONE) H = SIGN(MAX(S*ABS(H),HMIN),H) C ******************************************************************* C END OF CORE INTEGRATOR C ******************************************************************* C SHOULD WE TAKE ANOTHER STEP if (OUTPUT) go to 230 if (IFLAG.gt.0) go to 150 C ******************************************************************* C ******************************************************************* C INTEGRATION SUCCESSFULLY COMPLETED C ONE-STEP MODE IFLAG = -2 go to 240 C INTERVAL MODE 230 T = TOUT IFLAG = 2 240 do 250 K = 1,NEQN GERROR(K) = (YG(K)-Y(K))/31.D0 250 continue return end subroutine GERKS subroutine FEHL(F,NEQN,Y,T,H,YP,F1,F2,F3,F4,F5,S) C FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD C ******************************************************************* C FEHL INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT=F(T,Y(1),---,Y(NEQN)) C WHERE THE INITIAL VALUES Y(I) AND THE INITIAL DERIVATIVES C YP(I) ARE SPECIFIED AT THE STARTING POINT T. FEHL ADVANCES C THE SOLUTION OVER THE FIXED STEP H AND RETURNS C THE FIFTH ORDER (SIXTH ORDER ACCURATE LOCALLY) SOLUTION C APPROXIMATION AT T+H IN ARRAY S(I). C F1,---,F5 ARE ARRAYS OF DIMENSION NEQN WHICH ARE NEEDED C FOR INTERNAL STORAGE. C THE FORMULAS HAVE BEEN GROUPED TO CONTROL LOSS OF SIGNIFICANCE. C FEHL SHOULD BE CALLED WITH AN H NOT SMALLER THAN 13 UNITS OF C ROUNDOFF IN T SO THAT THE VARIOUS INDEPENDENT ARGUMENTS CAN BE C DISTINGUISHED. C ******************************************************************* C .. Scalar Arguments .. double precision H,T integer NEQN C .. C .. Array Arguments .. double precision F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN), + S(NEQN),Y(NEQN),YP(NEQN) C .. C .. Subroutine Arguments .. external F C .. C .. Local Scalars .. double precision CH integer K C .. CH = 0.25D0*H do 10 K = 1,NEQN F5(K) = Y(K) + CH*YP(K) 10 continue call F(T+0.25D0*H,F5,F1) CH = 0.09375D0*H do 20 K = 1,NEQN F5(K) = Y(K) + CH* (YP(K)+3.D0*F1(K)) 20 continue call F(T+0.375D0*H,F5,F2) CH = H/2197.D0 do 30 K = 1,NEQN F5(K) = Y(K) + CH* (1932.D0*YP(K)+ + (7296.D0*F2(K)-7200.D0*F1(K))) 30 continue call F(T+12.D0/13.D0*H,F5,F3) CH = H/4104.D0 do 40 K = 1,NEQN F5(K) = Y(K) + CH* ((8341.D0*YP(K)-845.D0*F3(K))+ + (29440.D0*F2(K)-32832.D0*F1(K))) 40 continue call F(T+H,F5,F4) CH = H/20520.D0 do 50 K = 1,NEQN F1(K) = Y(K) + CH* ((-6080.D0*YP(K)+ (9295.D0*F3(K)- + 5643.D0*F4(K)))+ (41040.D0*F1(K)-28352.D0*F2(K))) 50 continue call F(T+0.5D0*H,F1,F5) C COMPUTE APPROXIMATE SOLUTION AT T+H CH = H/7618050.D0 do 60 K = 1,NEQN S(K) = Y(K) + CH* ((902880.D0*YP(K)+ (3855735.D0*F3(K)- + 1371249.D0*F4(K)))+ (3953664.D0*F2(K)+277020.D0*F5(K))) 60 continue return end subroutine FEHL double precision function EPSLON(X) C C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. C C C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS C SATISFYING THE FOLLOWING TWO ASSUMPTIONS, C 1. THE BASE USED IN REPRESENTING FLOATING POINT C NUMBERS IS NOT A POWER OF THREE. C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO C THE ACCURACY USED IN FLOATING POINT VARIABLES C THAT ARE STORED IN MEMORY. C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING C ASSUMPTION 2. C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, C B HAS A ZERO FOR ITS LAST BIT OR DIGIT, C C IS NOT EXACTLY EQUAL TO ONE, C EPS MEASURES THE SEPARATION OF 1.0 FROM C THE NEXT LARGER FLOATING POINT NUMBER. C C .. Scalar Arguments .. double precision X C .. C .. Local Scalars .. double precision A,B,C,EPS,FOUR,THREE C .. C .. Intrinsic Functions .. intrinsic ABS C .. FOUR = 4.0D0 THREE = 3.0D0 A = FOUR/THREE 10 B = A - 1.0D0 C = B + B + B EPS = ABS(C-1.0D0) if (EPS.eq.0.0D0) go to 10 EPSLON = EPS*ABS(X) return end function EPSLON subroutine FZERO(F,B,C,R,RE,AE,IFLAG) C ********** C ********** C .. Local Scalars .. double precision A,ACBS,ACMB,AW,CMB,DIF,DIFS,FA,FB,FC,FX,FZ,P,Q, + RW,TOL,Z integer IC,KOUNT C .. C .. Intrinsic Functions .. intrinsic ABS,MAX,MIN,SIGN C .. C .. Scalar Arguments .. double precision AE,B,C,R,RE integer IFLAG C .. C .. Function Arguments .. double precision F external F C .. DIF = 1000.0D0 Z = R if (R.le.MIN(B,C) .or. R.ge.MAX(B,C)) Z = C RW = MAX(RE,0.0D0) AW = MAX(AE,0.0D0) IC = 0 FZ = F(Z) FB = F(B) KOUNT = 2 if (FZ*FB.lt.0.0D0) then C = Z FC = FZ else if (Z.ne.C) then FC = F(C) KOUNT = 3 if (FZ*FC.lt.0.0D0) then B = Z FB = FZ end if end if A = C FA = FC ACBS = ABS(B-C) FX = MAX(ABS(FB),ABS(FC)) C 10 continue if (ABS(FC).lt.ABS(FB)) then A = B FA = FB B = C FB = FC C = A FC = FA end if CMB = 0.5D0* (C-B) ACMB = ABS(CMB) TOL = RW*ABS(B) + AW IFLAG = 1 if (ACMB.le.TOL) then if (FB*FC.ge.0.0D0) IFLAG = 4 if (ABS(FB).gt.FX) IFLAG = 3 return end if IFLAG = 2 if (FB.eq.0.0D0) return IFLAG = 5 if (KOUNT.ge.500) return C P = (B-A)*FB Q = FA - FB if (P.lt.0.0D0) then P = -P Q = -Q end if A = B FA = FB IC = IC + 1 if (IC.ge.4) then if (8.0D0*ACMB.ge.ACBS) B = 0.5D0* (C+B) else IC = 0 ACBS = ACMB if (P.le.ABS(Q)*TOL) then B = B + SIGN(TOL,CMB) else if (P.ge.CMB*Q) then B = 0.5D0* (C+B) else B = B + P/Q end if end if FB = F(B) DIFS = DIF DIF = FB - FC if (DIF.eq.DIFS) then IFLAG = 6 return end if KOUNT = KOUNT + 1 if (FB*FC.ge.0.0D0) then C = A FC = FA end if go to 10 end subroutine FZERO end module sleig2md SHAR_EOF fi # end of overwriting check cd .. cd .. cd .. cd .. # End of shell archive exit 0