*DECK RKFAB SUBROUTINE RKFAB (NCOMP, XPTS, NXPTS, NFC, IFLAG, Z, MXNON, P, + NTP, IP, YHP, NIV, U, V, W, S, STOWA, G, WORK, IWORK, NFCC) C***BEGIN PROLOGUE RKFAB C***SUBSIDIARY C***PURPOSE Subsidiary to BVSUP C***LIBRARY SLATEC C***TYPE SINGLE PRECISION (RKFAB-S, DRKFAB-D) C***AUTHOR Watts, H. A., (SNLA) C***DESCRIPTION C C ********************************************************************** C C Subroutine RKFAB integrates the initial value equations using C the variable-step RUNGE-KUTTA-FEHLBERG integration scheme or C the variable-order ADAMS method and orthonormalization C determined by a linear dependence test. C C ********************************************************************** C C***SEE ALSO BVSUP C***ROUTINES CALLED BVDER, DEABM, DERKF, REORT, STOR1 C***COMMON BLOCKS ML15TO, ML17BW, ML18JR, ML8SZ C***REVISION HISTORY (YYMMDD) C 750601 DATE WRITTEN C 890831 Modified array declarations. (WRB) C 890921 Realigned order of variables in certain COMMON blocks. C (WRB) C 891214 Prologue converted to Version 4.0 format. (BAB) C 900328 Added TYPE section. (WRB) C 910722 Updated AUTHOR section. (ALS) C***END PROLOGUE RKFAB C DIMENSION P(NTP,*),IP(NFCC,*),U(NCOMP,NFC,*), 1 V(NCOMP,*),W(NFCC,*),Z(*),YHP(NCOMP,*), 2 XPTS(*),S(*),STOWA(*),WORK(*),IWORK(*), 3 G(*) C C ********************************************************************** C COMMON /ML8SZ/ C,XSAV,IGOFX,INHOMO,IVP,NCOMPD,NFCD COMMON /ML15TO/ PX,PWCND,TND,X,XBEG,XEND,XOT,XOP,INFO(15),ISTKOP, 1 KNSWOT,KOP,LOTJP,MNSWOT,NSWOT COMMON /ML18JR/ AE,RE,TOL,NXPTSD,NIC,NOPG,MXNOND,NDISK,NTAPE,NEQ, 1 INDPVT,INTEG,NPS,NTPD,NEQIVP,NUMORT,NFCCD, 2 ICOCO COMMON /ML17BW/ KKKZPW,NEEDW,NEEDIW,K1,K2,K3,K4,K5,K6,K7,K8,K9, 1 K10,K11,L1,L2,KKKINT,LLLINT C EXTERNAL BVDER C C ********************************************************************** C INITIALIZATION OF COUNTERS AND VARIABLES. C C***FIRST EXECUTABLE STATEMENT RKFAB KOD = 1 NON = 1 X = XBEG JON = 1 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 1 WORK(1) = XEND IF (NOPG .EQ. 0) GO TO 1 INFO(3) = 0 IF (X .EQ. Z(1)) JON = 2 1 NFCP1 = NFC + 1 C C ********************************************************************** C *****BEGINNING OF INTEGRATION LOOP AT OUTPUT POINTS.****************** C ********************************************************************** C DO 110 KOPP = 2,NXPTS KOP=KOPP C 5 XOP = XPTS(KOP) IF (NDISK .EQ. 0) KOD = KOP C C STEP BY STEP INTEGRATION LOOP BETWEEN OUTPUT POINTS. C 10 XXOP = XOP IF (NOPG .EQ. 0) GO TO 15 IF (XEND.GT.XBEG.AND.XOP.GT.Z(JON)) XXOP=Z(JON) IF (XEND.LT.XBEG.AND.XOP.LT.Z(JON)) XXOP=Z(JON) C C ********************************************************************** 15 GO TO (20,25),INTEG C DERKF INTEGRATOR C 20 CALL DERKF(BVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,IDID,WORK,KKKINT, 1 IWORK,LLLINT,G,IPAR) GO TO 28 C DEABM INTEGRATOR C 25 CALL DEABM(BVDER,NEQ,X,YHP,XXOP,INFO,RE,AE,IDID,WORK,KKKINT, 1 IWORK,LLLINT,G,IPAR) 28 IF(IDID .GE. 1) GO TO 30 INFO(1) = 1 IF(IDID .EQ. -1) GO TO 15 IFLAG = 20 - IDID RETURN C C ********************************************************************** C GRAM-SCHMIDT ORTHOGONALIZATION TEST FOR ORTHONORMALIZATION C (TEMPORARILY USING U AND V IN THE TEST) C 30 IF (NOPG .EQ. 0) GO TO 35 IF (XXOP .NE. Z(JON)) GO TO 100 JFLAG=2 GO TO 40 35 JFLAG=1 IF (INHOMO .EQ. 3 .AND. X .EQ. XEND) JFLAG=3 C 40 IF (NDISK .EQ. 0) NON=NUMORT+1 CALL REORT(NCOMP,U(1,1,KOD),V(1,KOD),YHP,NIV, 1 W(1,NON),S,P(1,NON),IP(1,NON),STOWA,JFLAG) C IF (JFLAG .NE. 30) GO TO 45 IFLAG=30 RETURN C 45 IF (JFLAG .EQ. 10) GO TO 5 C IF (JFLAG .NE. 0) GO TO 100 C C ********************************************************************** C STORE ORTHONORMALIZED VECTORS INTO SOLUTION VECTORS. C IF (NUMORT .LT. MXNON) GO TO 65 IF (X .EQ. XEND) GO TO 65 IFLAG = 13 RETURN C 65 NUMORT = NUMORT + 1 CALL STOR1(YHP,U(1,1,KOD),YHP(1,NFCP1),V(1,KOD),1, 1 NDISK,NTAPE) C C ********************************************************************** C STORE ORTHONORMALIZATION INFORMATION, INITIALIZE C INTEGRATION FLAG, AND CONTINUE INTEGRATION TO THE NEXT C ORTHONORMALIZATION POINT OR OUTPUT POINT. C Z(NUMORT) = X IF (INHOMO .EQ. 1 .AND. NPS .EQ. 0) C = S(NFCP1) * C IF (NDISK .EQ. 0) GO TO 90 IF (INHOMO .EQ. 1) WRITE (NTAPE) (W(J,1), J = 1,NFCC) WRITE(NTAPE) (IP(J,1), J = 1,NFCC),(P(J,1), J = 1,NTP) 90 INFO(1) = 0 JON = JON + 1 IF (NOPG .EQ. 1 .AND. X .NE. XOP) GO TO 10 C C ********************************************************************** C CONTINUE INTEGRATION IF WE ARE NOT AT AN OUTPUT POINT. C 100 IF (IDID .EQ. 1) GO TO 15 C C STORAGE OF HOMOGENEOUS SOLUTIONS IN U AND THE PARTICULAR C SOLUTION IN V AT THE OUTPUT POINTS. C CALL STOR1(U(1,1,KOD),YHP,V(1,KOD),YHP(1,NFCP1),0,NDISK,NTAPE) 110 CONTINUE C ********************************************************************** C ********************************************************************** C IFLAG = 0 RETURN END