C*********************************************************************** C C SINGLE PRECISION RUN-TIME SUPPORT PACKAGE. C C*********************************************************************** SUBROUTINE EMIT0(DEPVAR,RFS,IFS,LFS) INTEGER DEPVAR,LFS INTEGER IFS(LFS) REAL RFS(LFS) INTEGER FSP,NFS CHARACTER*40 ERRM COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ERRM /' OVERFLOW OF BUFFER'/ IF (FSP .GT. LFS) CALL SERRM(ERRM) FSP = FSP + 1 IFS(FSP) = FSP - 1 RFS(FSP) = DEPVAR RETURN C C LAST CARD OF SUBROUTINE EMIT0. C END C********************************************************************** SUBROUTINE EMIT1(IND1,DER1,DEPVAR,RFS,IFS,LFS) INTEGER IND1,DEPVAR,LFS INTEGER IFS(LFS) REAL DER1 REAL RFS(LFS) INTEGER FSP,NEWFSP,NFS CHARACTER*40 ERRM COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ERRM /' OVERFLOW OF BUFFER'/ NEWFSP = FSP + 2 IF (NEWFSP .GT. LFS) CALL SERRM(ERRM) IFS(FSP+1) = IND1 RFS(FSP+1) = DER1 IFS(NEWFSP) = FSP RFS(NEWFSP) = DEPVAR FSP = NEWFSP RETURN C C LAST CARD OF SUBROUTINE EMIT1. C END C********************************************************************** SUBROUTINE EMIT2(IND1,DER1,IND2,DER2,DEPVAR,RFS,IFS,LFS) INTEGER IND1,IND2,DEPVAR,LFS INTEGER IFS(LFS) CHARACTER*40 ERRM REAL DER1,DER2 REAL RFS(LFS) INTEGER FSP,NEWFSP,NFS COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ERRM /' OVERFLOW OF BUFFER'/ NEWFSP = FSP + 3 IF (NEWFSP .GT. LFS) CALL SERRM(ERRM) IFS(FSP+1) = IND1 RFS(FSP+1) = DER1 IFS(FSP+2) = IND2 RFS(FSP+2) = DER2 IFS(NEWFSP) = FSP RFS(NEWFSP) = DEPVAR FSP = NEWFSP RETURN C C LAST CARD OF SUBROUTINE EMIT2. C END C********************************************************************** SUBROUTINE SPCOPY(GRAD,IGRAD,STRIDE,BUFFER,N) INTEGER IGRAD,STRIDE,N REAL GRAD(STRIDE,N),BUFFER(N) INTEGER I DO 10 I = 1, N GRAD(IGRAD,I) = BUFFER(I) 10 CONTINUE IGRAD = IGRAD + N*N RETURN C C LAST CARD OF SUBROUTINE SPCOPY. C END C*********************************************************************** SUBROUTINE SPGRAD(YGRAD,LYGRAD,ID,RGRAD,IGRAD,RFS,IFS,LFS) INTEGER LYGRAD,ID,RGRAD,IGRAD,LFS INTEGER IFS(LFS) REAL YGRAD(LYGRAD),RFS(LFS) CHARACTER*40 ERRM INTEGER DEPVAR,FSP,FSPEND,I,IND,OLDFSP,NFS REAL ONE,T,ZERO COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ZERO,ONE /0.0E0,1.0E0/ DATA ERRM /' NOTHING TO BE READ. THIS IS AN ERROR'/ DO 10 I = 1, LYGRAD YGRAD(I) = ZERO 10 CONTINUE YGRAD(ID) = ONE RGRAD = RGRAD + 1 IGRAD = RGRAD FSPEND = FSP 20 CONTINUE IF (FSPEND .EQ. 0) THEN IF (NFS .EQ. 0) GO TO 40 CALL SERRM(ERRM) END IF DEPVAR = RFS(FSPEND) OLDFSP = FSPEND - 1 FSPEND = IFS(FSPEND) T = YGRAD(DEPVAR) IF (T .EQ. ZERO) GO TO 20 YGRAD(DEPVAR) = ZERO 30 CONTINUE IF (OLDFSP .LE. FSPEND) GO TO 20 IND = IFS(OLDFSP) YGRAD(IND) = YGRAD(IND) + T*RFS(OLDFSP) OLDFSP = OLDFSP - 1 GO TO 30 40 CONTINUE RETURN C C LAST CARD OF SUBROUTINE SPGRAD. C END C*********************************************************************** SUBROUTINE SPINIT(NEED,HAVE) INTEGER NEED,HAVE INTEGER FSP,NFS CHARACTER*40 ERRM COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ERRM /' VECTOR YGRAD OR YJACOB IS TOO SMALL'/ FSP = 0 NFS = 0 IF (NEED .GT. HAVE) CALL SERRM(ERRM) RETURN C C LAST CARD OF SUBROUTINE SPINIT. C END C******************************************************************* SUBROUTINE SERRM(STR) C C THIS ROUTINE WRITES AN ERROR MESSAGE AND ABORTS. C CHARACTER*40 STR INTEGER NWRITE DATA NWRITE /6/ WRITE (NWRITE,'(" FATAL ERROR IN SPJAKELIB")') WRITE (NWRITE,'(A40)') STR STOP C C LAST CARD OF SUBROUTINE SERRM. C END C********************************************************************** C C DOUBLE PRECISION RUN-TIME SUPPORT PACKAGE. C C********************************************************************** SUBROUTINE DMIT0(DEPVAR,RFS,IFS,LFS) INTEGER DEPVAR,LFS INTEGER IFS(LFS) DOUBLE PRECISION RFS(LFS) INTEGER FSP,NFS CHARACTER*40 ERRM COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ERRM /' OVERFLOW OF BUFFER'/ IF (FSP .GT. LFS) CALL DERRM(ERRM) FSP = FSP + 1 IFS(FSP) = FSP - 1 RFS(FSP) = DEPVAR RETURN C C LAST CARD OF SUBROUTINE DMIT0. C END C********************************************************************** SUBROUTINE DMIT1(IND1,DER1,DEPVAR,RFS,IFS,LFS) INTEGER IND1,DEPVAR,LFS DOUBLE PRECISION DER1 INTEGER IFS(LFS) DOUBLE PRECISION RFS(LFS) INTEGER FSP,NEWFSP,NFS CHARACTER*40 ERRM COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ERRM /' OVERFLOW OF BUFFER'/ NEWFSP = FSP + 2 IF (NEWFSP .GT. LFS) CALL DERRM(ERRM) IFS(FSP+1) = IND1 RFS(FSP+1) = DER1 IFS(NEWFSP) = FSP RFS(NEWFSP) = DEPVAR FSP = NEWFSP RETURN C C LAST CARD OF SUBROUTINE DMIT1. C END C********************************************************************** SUBROUTINE DMIT2(IND1,DER1,IND2,DER2,DEPVAR,RFS,IFS,LFS) INTEGER IND1,IND2,DEPVAR,LFS DOUBLE PRECISION DER1,DER2 INTEGER IFS(LFS) DOUBLE PRECISION RFS(LFS) INTEGER FSP,NEWFSP,NFS CHARACTER*40 ERRM COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ERRM /' OVERFLOW OF BUFFER'/ NEWFSP = FSP + 3 IF (NEWFSP .GT. LFS) CALL DERRM(ERRM) IFS(FSP+1) = IND1 RFS(FSP+1) = DER1 IFS(FSP+2) = IND2 RFS(FSP+2) = DER2 IFS(NEWFSP) = FSP RFS(NEWFSP) = DEPVAR FSP = NEWFSP RETURN C C LAST CARD OF SUBROUTINE DMIT2. C END C********************************************************************** SUBROUTINE DPCOPY(GRAD,IGRAD,STRIDE,BUFFER,N) INTEGER IGRAD,STRIDE,N DOUBLE PRECISION GRAD(STRIDE,N),BUFFER(N) INTEGER I DO 10 I = 1, N GRAD(IGRAD,I) = BUFFER(I) 10 CONTINUE IGRAD = IGRAD + N*N RETURN C C LAST CARD OF SUBROUTINE DPCOPY. C END C*********************************************************************** SUBROUTINE DPGRAD(YGRAD,LYGRAD,ID,RGRAD,IGRAD,RFS,IFS,LFS) INTEGER LYGRAD,ID,RGRAD,IGRAD,LFS INTEGER IFS(LFS) DOUBLE PRECISION YGRAD(LYGRAD),RFS(LFS) INTEGER DEPVAR,FSP,FSPEND,I,IND,OLDFSP,NFS CHARACTER*40 ERRM DOUBLE PRECISION ONE,T,ZERO COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ZERO,ONE /0.0D0,1.0D0/ DATA ERRM /' NOTHING TO BE READ. THIS IS AN ERROR'/ DO 10 I = 1, LYGRAD YGRAD(I) = ZERO 10 CONTINUE YGRAD(ID) = ONE RGRAD = RGRAD + 1 IGRAD = RGRAD FSPEND = FSP 20 CONTINUE IF (FSPEND .EQ. 0) THEN IF (NFS .EQ. 0) GO TO 40 CALL DERRM(ERRM) END IF DEPVAR = RFS(FSPEND) OLDFSP = FSPEND - 1 FSPEND = IFS(FSPEND) T = YGRAD(DEPVAR) IF (T .EQ. ZERO) GO TO 20 YGRAD(DEPVAR) = ZERO 30 CONTINUE IF (OLDFSP .LE. FSPEND) GO TO 20 IND = IFS(OLDFSP) YGRAD(IND) = YGRAD(IND) + T*RFS(OLDFSP) OLDFSP = OLDFSP - 1 GO TO 30 40 CONTINUE RETURN C C LAST CARD OF SUBROUTINE DPGRAD. C END C*********************************************************************** SUBROUTINE DPINIT(NEED,HAVE) INTEGER NEED,HAVE INTEGER FSP,NFS CHARACTER*40 ERRM COMMON /FACTOR/ FSP,NFS SAVE /FACTOR/ DATA ERRM /' VECTOR YGRAD OR YJACOB IS TOO SMALL'/ FSP = 0 NFS = 0 IF (NEED .GT. HAVE) CALL DERRM(ERRM) RETURN C C LAST CARD OF SUBROUTINE DPINIT. C END C******************************************************************* SUBROUTINE DERRM(STR) C C THIS ROUTINE WRITES AN ERROR MESSAGE AND ABORTS. C CHARACTER*40 STR INTEGER NWRITE DATA NWRITE /6/ WRITE (NWRITE,'(" FATAL ERROR IN DPJAKELIB")') WRITE (NWRITE,'(A40)') STR STOP C C LAST CARD OF SUBROUTINE DERRM. C END C********************************************************************* C Sample main programming calling JAKED1 C********************************************************************* PROGRAM SAMPLE INTEGER IWA(29600) CHARACTER*1 CWA(244500) INTEGER LCWA,LIWA LIWA = 29600 LCWA = 244500 CALL JAKED1(IWA,LIWA,CWA,LCWA) STOP END C********************************************************** C Test functions Watson and chebyquad C*********************************************************** C THE WATSON OBJECTIVE FUNCTION C SUBROUTINE SWATS(N,X,F) INTEGER N REAL X(N) REAL F INTEGER I,J REAL FLOAT,D1,D2,GRAD,S1,S2,T,T1 REAL ZERO,ONE,C29 DATA ZERO,ONE,C29 /0.0E0,1.0E0,2.9E1/ CONSTRUCT D(F)/D(X) IN GRAD(N) F = ZERO DO 30 I = 1, 29 D1 = FLOAT(I)/C29 S1 = ZERO D2 = ONE DO 10 J = 2, N S1 = S1 + FLOAT(J-1)*D2*X(J) D2 = D1*D2 10 CONTINUE S2 = ZERO D2 = ONE DO 20 J = 1, N S2 = S2 + D2*X(J) D2 = D1*D2 20 CONTINUE T = S1 - S2**2 - ONE F = F + T**2 30 CONTINUE T1 = X(2) - X(1)**2 - ONE F = F + X(1)**2 + T1**2 RETURN END C********************************************************************* C Result of precompilation with JAKEF should be: C C SUBROUTINE SWATSJ(N,X,F,GRAD,YGRAD,LYGRAD,RFS,IFS,LFS) C INTEGER LFS,IFS(LFS) C REAL RFS(LFS),TGRA(543) C INTEGER N,I,J,LQ00,LQ01,LQ02,LQ03,LQ04,LQ05,LYGRAD,IGRAD,RGRAD,IX C REAL X(N),F,FLOAT,D1,D2,GRAD(N),S1,S2,T,T1,ZERO,ONE,C29,YGRAD(LYGR C *AD) C DATA ZERO,ONE,C29/0.0E0,1.0E0,2.9E1/ C IX = 548 C CALL SPINIT(IX+N,LYGRAD) C CALL EMIT0(1,RFS,IFS,LFS) C F = ZERO C LQ00 = 1 C LQ01 = 29 C DO 90001 I = LQ00,LQ01 C D1 = (FLOAT(I))/C29 C CALL EMIT0(2,RFS,IFS,LFS) C S1 = ZERO C D2 = ONE C LQ02 = 2 C LQ03 = N C DO 90002 J = LQ02,LQ03 C TGRA(2) = (FLOAT(J-1))*D2 C CALL EMIT1(IX+J,TGRA(2),6,RFS,IFS,LFS) C TGRA(1) = TGRA(2)*X(J) C CALL EMIT2(2,1.,6,1.,2,RFS,IFS,LFS) C S1 = S1+TGRA(1) C D2 = D1*D2 C90002 CONTINUE C CALL EMIT0(3,RFS,IFS,LFS) C S2 = ZERO C D2 = ONE C LQ04 = 1 C LQ05 = N C DO 90003 J = LQ04,LQ05 C CALL EMIT1(IX+J,D2,6,RFS,IFS,LFS) C TGRA(1) = D2*X(J) C CALL EMIT2(3,1.,6,1.,3,RFS,IFS,LFS) C S2 = S2+TGRA(1) C D2 = D1*D2 C90003 CONTINUE C CALL EMIT1(3,S2+S2,7,RFS,IFS,LFS) C TGRA(2) = S2**2 C CALL EMIT2(2,1.,7,-(1.),6,RFS,IFS,LFS) C TGRA(1) = S1-TGRA(2) C CALL EMIT1(6,1.,4,RFS,IFS,LFS) C T = TGRA(1)-ONE C CALL EMIT1(4,T+T,6,RFS,IFS,LFS) C TGRA(1) = T**2 C CALL EMIT2(1,1.,6,1.,1,RFS,IFS,LFS) C F = F+TGRA(1) C90001 CONTINUE C CALL EMIT1(IX+1,X(1)+X(1),7,RFS,IFS,LFS) C TGRA(2) = X(1)**2 C CALL EMIT2(IX+2,1.,7,-(1.),6,RFS,IFS,LFS) C TGRA(1) = X(2)-TGRA(2) C CALL EMIT1(6,1.,5,RFS,IFS,LFS) C T1 = TGRA(1)-ONE C CALL EMIT1(IX+1,X(1)+X(1),8,RFS,IFS,LFS) C TGRA(3) = X(1)**2 C CALL EMIT2(1,1.,8,1.,6,RFS,IFS,LFS) C TGRA(1) = F+TGRA(3) C CALL EMIT1(5,T1+T1,7,RFS,IFS,LFS) C TGRA(2) = T1**2 C CALL EMIT2(6,1.,7,1.,1,RFS,IFS,LFS) C F = TGRA(1)+TGRA(2) C90000 CONTINUE C RGRAD = 0 C CALL SPGRAD(YGRAD,LYGRAD,1,RGRAD,IGRAD,RFS,IFS,LFS) C CALL SPCOPY(GRAD,IGRAD,1,YGRAD(IX+1),N) C RETURN C END C********************************************************************** C********************************************************************** C THE CHEBYQUAD VECTOR FUNCTION C SUBROUTINE DCHEB(N,X,F) INTEGER N DOUBLE PRECISION X(N),F(N) INTEGER I,IEV,J,K DOUBLE PRECISION DFLOAT,JACOB,TEMP,TEMP1,TEMP2,TI,TK DOUBLE PRECISION ZERO,ONE,TWO DATA ZERO,ONE,TWO /0.0D0,1.0D0,2.0D0/ CONSTRUCT D(F)/D(X) IN JACOB(N,N) DO 10 K = 1, N F(K) = ZERO 10 CONTINUE DO 30 J = 1, N TEMP1 = ONE TEMP2 = TWO*X(J) - ONE TEMP = TWO*TEMP2 DO 20 I = 1, N F(I) = F(I) + TEMP2 TI = TEMP*TEMP2 - TEMP1 TEMP1 = TEMP2 TEMP2 = TI 20 CONTINUE 30 CONTINUE TK = ONE/DFLOAT(N) IEV = -1 DO 40 K = 1, N F(K) = TK*F(K) IF (IEV .GT. 0) F(K) = F(K) + ONE/(DFLOAT(K)**2 - ONE) IEV = -IEV 40 CONTINUE RETURN END C********************************************************************* C Result of precompilation with JAKEF C C SUBROUTINE CHEBJ(N,X,F,JACOB,LJAC,YJACOB,LYJACO,RFS,IFS,LFS) C INTEGER LJAC C INTEGER LFS,IFS(LFS) C DOUBLE PRECISION RFS(LFS),TJACO(543) C INTEGER N,I,IEV,J,K,LQ00,LQ01,LQ02,LQ03,LQ04,LQ05,LQ06,LQ07,LYJACO C *,IJACOB,RJACOB,LJACOB,JJACOB,IF,IX C DOUBLE PRECISION X(N),F(N),DFLOAT,JACOB(LJAC,N),TEMP,TEMP1,TEMP2,T C *I,TK,ZERO,ONE,TWO,YJACOB(LYJACO) C DATA ZERO,ONE,TWO/0.0D0,1.0D0,2.0D0/ C IF = 547 C IX = IF+N C CALL DPINIT(IX+N,LYJACO) C LQ00 = 1 C LQ01 = N C DO 90001 K = LQ00,LQ01 C CALL DMIT0(IF+K,RFS,IFS,LFS) C F(K) = ZERO C90001 CONTINUE C LQ02 = 1 C LQ03 = N C DO 90002 J = LQ02,LQ03 C CALL DMIT0(2,RFS,IFS,LFS) C TEMP1 = ONE C CALL DMIT1(IX+J,TWO,5,RFS,IFS,LFS) C TJACO(1) = TWO*X(J) C CALL DMIT1(5,1.D0,3,RFS,IFS,LFS) C TEMP2 = TJACO(1)-ONE C CALL DMIT1(3,TWO,1,RFS,IFS,LFS) C TEMP = TWO*TEMP2 C LQ04 = 1 C LQ05 = N C DO 90003 I = LQ04,LQ05 C CALL DMIT2(IF+I,1.D0,3,1.D0,IF+I,RFS,IFS,LFS) C F(I) = F(I)+TEMP2 C CALL DMIT2(1,TEMP2,3,TEMP,5,RFS,IFS,LFS) C TJACO(1) = TEMP*TEMP2 C CALL DMIT2(5,1.D0,2,-(1.D0),4,RFS,IFS,LFS) C TI = TJACO(1)-TEMP1 C CALL DMIT1(3,1.D0,2,RFS,IFS,LFS) C TEMP1 = TEMP2 C CALL DMIT1(4,1.D0,3,RFS,IFS,LFS) C TEMP2 = TI C90003 CONTINUE C90002 CONTINUE C TK = ONE/(DFLOAT(N)) C IEV = -(1) C LQ06 = 1 C LQ07 = N C DO 90004 K = LQ06,LQ07 C CALL DMIT1(IF+K,TK,IF+K,RFS,IFS,LFS) C F(K) = TK*F(K) C IF (IEV.LE.0)GO TO 90005 C TJACO(1) = ONE/(((DFLOAT(K))**2)-ONE) C CALL DMIT1(IF+K,1.D0,IF+K,RFS,IFS,LFS) C F(K) = F(K)+TJACO(1) C90005 CONTINUE C IEV = -(IEV) C90004 CONTINUE C90000 CONTINUE C RJACOB = 0 C LJACOB = N C DO 90006 JJACOB = 1,LJACOB C CALL DPGRAD(YJACOB,LYJACO,IF+JJACOB,RJACOB,IJACOB,RFS,IFS,LFS) C CALL DPCOPY(JACOB,IJACOB,LJAC,YJACOB(IX+1),N) C90006 CONTINUE C RETURN C END C********************************************************************* C