C ALGORITHM 746, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 21, NO. 3, September, 1995, P. 233-266. C C This file contains 15 files separated by lines of the form C C*** filename C C The filenames in this file are: C C Makefile eg_code.f eg_evaluate.f C eg_parser.f evaluate.out pcomp.for C pcomp.fun pcomp.sym pcomp_er.f C pcomp_ev.f pcomp_ex.f pcomp_g.f C pcomp_p1.f pcomp_p2.f pcomp_s.f C C C*** Makefile FC=f77 FFLAGS=-g parser: eg_parser.o pcomp_p1.o pcomp_p2.o pcomp_ev.o pcomp_ex.o pcomp_er.o $(FC) $(FFLAGS) eg_parser.o pcomp_p1.o pcomp_p2.o pcomp_ev.o pcomp_ex.o pcomp_er.o -o parser evaluate: eg_evaluate.o pcomp_s.o pcomp_ev.o pcomp_ex.o pcomp_er.o $(FC) $(FFLAGS) eg_evaluate.o pcomp_s.o pcomp_ev.o pcomp_ex.o pcomp_er.o -o evaluate code: eg_code.o pcomp_g.o pcomp_er.o $(FC) $(FFLAGS) eg_code.o pcomp_g.o pcomp_er.o -o code clean: rm -f core *.o parser evaluate code C*** eg_code.f program code parameter (lrsym=15000, lisym=15000) double precision rsym(lrsym) integer isym(lisym), larsym,laisym,ierr open(3, file='pcomp.sym', status='UNKNOWN') open(4, file='pcomp.for', status='UNKNOWN') call symprp(3,rsym,lrsym,isym,lisym,larsym,laisym,ierr) if(ierr.gt.0)goto 900 call symfor(4,rsym,lrsym,isym,lisym,ierr) if(ierr.gt.0)goto 900 goto 9999 900 call symerr(ierr,0) 9999 continue close(3) close(4) end C*** eg_evaluate.f program fungra implicit double precision (a-h,o-z) parameter (nmax=100, mmax=50,lrsym=30000,lisym=10000) dimension x(nmax), f(mmax), df(mmax,nmax),rsym(lrsym), + isym(lisym) logical act(mmax) open(3,file='pcomp.sym', status='UNKNOWN') n=20 m=1 do 10 i=1,n/2 x(2*i-1)=-1.2 x(2*i)=1.0 10 continue act(1)=.true. call symprp(3,rsym,lrsym,isym,lisym,larsym,laisym,ierr) if(ierr.gt.0)goto 900 call symfun(x,n,f,m,act,rsym,lrsym,isym,lisym,ierr) if(ierr.gt.0)goto 900 call symgra(x,n,f,m,df,mmax,act,rsym,lrsym,isym,lisym, + ierr) if(ierr.gt.0)goto 900 write(*,*)f(1) write(*,*)(df(1,i),i=1,n) goto 9999 900 call symerr(ierr,lrow) 9999 continue close(3) end C*** eg_parser.f program parser parameter (lrsym=15000, lisym=15000) double precision rsym(lrsym) integer isym(lisym), larsym,laisym,ierr,lrow open(2, file='pcomp.fun', status='UNKNOWN') open(3, file='pcomp.sym', status='UNKNOWN') call syminp(2,3,rsym,lrsym,isym,lisym,larsym, + laisym,ierr,lrow) if(ierr.gt.0)then call symerr(ierr,lrow) else close(2) close(3) endif end C*** evaluate.out 4598.0000000000 -215.60000000000 792.00000000000 -655.60000000000 792.00000000000 -655.60000000000 792.00000000000 -655.60000000000 792.00000000000 -655.60000000000 792.00000000000 -655.60000000000 792.00000000000 -655.60000000000 792.00000000000 -655.60000000000 792.00000000000 -655.60000000000 792.00000000000 -655.60000000000 -88.000000000000 C*** pcomp.for C********************************* C C P C O M P (Version 3.1) C C********************************* C SUBROUTINE XFUN (X,N,F,M,ACTIVE,IERR) INTEGER N,M DOUBLE PRECISION X(N),F(M) LOGICAL ACTIVE(M) INTEGER IERR C DOUBLE PRECISION XAUX(21:211) INTEGER I0,IX0 INTEGER I,OFS C INTEGER VINDEX(39) INTEGER VICONS(5) DOUBLE PRECISION VRCONS(1) DATA (VINDEX(I), I=1,39) 1 /1,2,3,4,5, 2 6,7,8,9,10, 3 11,12,13,14,15, 4 16,17,18,19,20, 5 1,2,3,4,5, 6 6,7,8,9,10, 7 11,12,13,14,15, 8 16,17,18,19/ DATA (VICONS(I), I=1,5) 1 /1,20,19,100,2/ DATA (VRCONS(I), I=1,1) 1 /0.00000000000000000D+00/ C IF (N .NE. 20) THEN IERR=43 RETURN ENDIF IF (M .NE. 1) THEN IERR=44 RETURN ENDIF OFS=0 IF (ACTIVE(1)) THEN XAUX(21)=0.0D0 DO 14 I0=0,18 IX0=VINDEX(21+I0) XAUX(22+OFS)=DBLE(100) XAUX(23+OFS)=X(IX0)**(2) XAUX(24+OFS)=X(1+IX0)-XAUX(23+OFS) XAUX(25+OFS)=XAUX(24+OFS)**(2) XAUX(26+OFS)=XAUX(22+OFS)*XAUX(25+OFS) XAUX(27+OFS)=DBLE(1) XAUX(28+OFS)=XAUX(27+OFS)-X(IX0) XAUX(29+OFS)=XAUX(28+OFS)**(2) XAUX(30+OFS)=XAUX(26+OFS)+XAUX(29+OFS) XAUX(31+OFS)=XAUX(21+OFS)+XAUX(30+OFS) OFS=OFS+10 14 CONTINUE OFS=OFS-190 F(1)=XAUX(211) ENDIF RETURN END C C C SUBROUTINE XGRA (X,N,F,M,DF,MMAX,ACTIVE,IERR) INTEGER N,M,MMAX DOUBLE PRECISION X(N),F(M),DF(MMAX,N) LOGICAL ACTIVE(M) INTEGER IERR C DOUBLE PRECISION XAUX(21:211),YAUX(21:211) INTEGER I0,IX0 INTEGER I,OFS C INTEGER VINDEX(39) INTEGER VICONS(5) DOUBLE PRECISION VRCONS(1) DATA (VINDEX(I), I=1,39) 1 /1,2,3,4,5, 2 6,7,8,9,10, 3 11,12,13,14,15, 4 16,17,18,19,20, 5 1,2,3,4,5, 6 6,7,8,9,10, 7 11,12,13,14,15, 8 16,17,18,19/ DATA (VICONS(I), I=1,5) 1 /1,20,19,100,2/ DATA (VRCONS(I), I=1,1) 1 /0.00000000000000000D+00/ C IF (N .NE. 20) THEN IERR=43 RETURN ENDIF IF (M .NE. 1) THEN IERR=44 RETURN ENDIF OFS=0 IF (ACTIVE(1)) THEN XAUX(21)=0.0D0 DO 14 I0=0,18 IX0=VINDEX(21+I0) XAUX(22+OFS)=DBLE(100) XAUX(23+OFS)=X(IX0)**(2) XAUX(24+OFS)=X(1+IX0)-XAUX(23+OFS) XAUX(25+OFS)=XAUX(24+OFS)**(2) XAUX(26+OFS)=XAUX(22+OFS)*XAUX(25+OFS) XAUX(27+OFS)=DBLE(1) XAUX(28+OFS)=XAUX(27+OFS)-X(IX0) XAUX(29+OFS)=XAUX(28+OFS)**(2) XAUX(30+OFS)=XAUX(26+OFS)+XAUX(29+OFS) XAUX(31+OFS)=XAUX(21+OFS)+XAUX(30+OFS) OFS=OFS+10 14 CONTINUE OFS=OFS-190 F(1)=XAUX(211) DO 15 I=1,20 DF(1,I)=0.0D0 15 CONTINUE DO 16 I=21,210 YAUX(I)=0.0D0 16 CONTINUE YAUX(211)=1.0D0 OFS=OFS+190 DO 3 I0=18,0,-1 IX0=VINDEX(21+I0) OFS=OFS-10 YAUX(21+OFS)=YAUX(21+OFS)+YAUX(31+OFS) YAUX(30+OFS)=YAUX(30+OFS)+YAUX(31+OFS) YAUX(26+OFS)=YAUX(26+OFS)+YAUX(30+OFS) YAUX(29+OFS)=YAUX(29+OFS)+YAUX(30+OFS) YAUX(28+OFS)=YAUX(28+OFS)+2*XAUX(28+OFS)**1*YAUX(29+OFS) YAUX(27+OFS)=YAUX(27+OFS)+YAUX(28+OFS) DF(1,IX0)=DF(1,IX0)-YAUX(28+OFS) YAUX(22+OFS)=YAUX(22+OFS)+XAUX(25+OFS)*YAUX(26+OFS) YAUX(25+OFS)=YAUX(25+OFS)+XAUX(22+OFS)*YAUX(26+OFS) YAUX(24+OFS)=YAUX(24+OFS)+2*XAUX(24+OFS)**1*YAUX(25+OFS) DF(1,1+IX0)=DF(1,1+IX0)+YAUX(24+OFS) YAUX(23+OFS)=YAUX(23+OFS)-YAUX(24+OFS) DF(1,IX0)=DF(1,IX0)+2*X(IX0)**1*YAUX(23+OFS) 3 CONTINUE ENDIF RETURN END C*** pcomp.fun c TP295 (n=20) * SET OF INDICES indn=1..20 indnm1=1..19 * VARIABLE x(i),i in indn * FUNCTION f f = sum(100*(x(i+1)-x(i)**2)**2+(1-x(i))**2, i in indnm1) * END C*** pcomp.sym 2 39 1 5 1 1 1 20 1 1 1 1 36 1 1 1 20 19 1 1 20 19 1 21 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 0 0 0 0 1 20 19 100 2 0 0 0 0 1 20 1 0 0 0 1 1 1 265 1 2 262 4 414 1 390 1 171 279 1 414 1 279 1 222 2 45 222 2 42 262 1 414 1 279 1 45 222 2 43 287 61 1 -1 0.00000000000000000D+00 C*** pcomp_er.f SUBROUTINE SYMERR (LNUM,N) INTEGER LNUM,N C C********************************************************************** C C S Y M E R R - INDICATE ERROR MESSAGE AND THE LINE NUMBER IN THE C SOURCE CODE, THE ERROR OCCURED. C C PARAMETERS: C LNUM - LINE NUMBER OF ERROR. C N - ERROR CODE. C C********************************************************************** C GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20, 1 21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37, 2 38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54, 3 55,56,57,58) N 1 WRITE(*,'(1X,A)') 'file not found - no compilation.' RETURN 2 WRITE(*,'(1X,A)') 'file too long - no compilation.' RETURN 3 WRITE(*,100) LNUM,'identifier expected.' RETURN 4 WRITE(*,100) LNUM,'identifier redefined.' RETURN 5 WRITE(*,100) LNUM,''','' expected.' RETURN 6 WRITE(*,100) LNUM,'''('' expected.' RETURN 7 WRITE(*,100) LNUM,'identifier not declared.' RETURN 8 WRITE(*,100) LNUM,'type mismatch.' RETURN 9 WRITE(*,100) LNUM,'division by zero.' RETURN 10 WRITE(*,100) LNUM,'constant expected.' RETURN 11 WRITE(*,100) LNUM,'operator expected.' RETURN 12 WRITE(*,100) LNUM,'unexpected end of source file.' RETURN 13 WRITE(*,100) LNUM,'''..'' expected.' RETURN 14 WRITE(*,100) LNUM,''')'' expected.' RETURN 15 WRITE(*,100) LNUM,'THEN expected.' RETURN 16 WRITE(*,100) LNUM,'ELSE expected.' RETURN 17 WRITE(*,100) LNUM,'ENDIF expected.' RETURN 18 WRITE(*,100) LNUM,'THEN without IF.' RETURN 19 WRITE(*,100) LNUM,'ELSE without IF.' RETURN 20 WRITE(*,100) LNUM,'ENDIF without IF.' RETURN 21 WRITE(*,100) LNUM,'''='' expected.' RETURN 22 WRITE(*,100) LNUM,'bad integer constant.' RETURN 23 WRITE(*,100) LNUM,'bad real constant.' RETURN 24 WRITE(*,100) LNUM,'formula too complex.' RETURN 25 WRITE(*,100) LNUM,'error in expression.' RETURN 26 WRITE(*,100) LNUM,'compiler error.' RETURN 27 WRITE(*,100) LNUM,'identifier not valid.' RETURN 28 WRITE(*,100) LNUM,'unknown type identifier.' RETURN 29 WRITE(*,100) LNUM,'unknown character.' RETURN 30 WRITE(*,100) LNUM,'yacc stack overflow.' RETURN 31 WRITE(*,100) LNUM,'syntax error.' RETURN 32 WRITE(*,100) LNUM,'out of memory.' RETURN 33 WRITE(*,100) LNUM,'bad index.' RETURN 34 WRITE(*,100) LNUM,'internal error of dynamical parser.' RETURN 35 WRITE(*,100) LNUM,'wrong number of subscripts.' RETURN 36 WRITE(*,100) LNUM,'wrong number of arguments.' RETURN 37 WRITE(*,100) LNUM,'too many index sets.' RETURN 38 WRITE(*,100) LNUM,'too many integer constants.' RETURN 39 WRITE(*,100) LNUM,'too many real constants.' RETURN 40 WRITE(*,100) LNUM,'too many variables.' RETURN 41 WRITE(*,100) LNUM,'too many functions.' RETURN 42 WRITE(*,100) LNUM,'too many index variables.' RETURN 43 WRITE(*,100) LNUM,'number of variables not consistent.' RETURN 44 WRITE(*,100) LNUM,'number of functions not consistent.' RETURN 45 WRITE(*,100) LNUM,'false end symbol.' RETURN 46 WRITE(*,100) LNUM,'FORTRAN code exceeds line.' RETURN 47 WRITE(*,100) LNUM,'feature not yet supported.' RETURN 48 WRITE(*,100) LNUM,'bad input format.' RETURN 49 WRITE(*,100) LNUM,'length of working array IWA too small.' RETURN 50 WRITE(*,100) LNUM,'length of working array WA too small.' RETURN 51 WRITE(*,100) LNUM,'ATANH: domain error.' RETURN 52 WRITE(*,100) LNUM,'LOG: domain error.' RETURN 53 WRITE(*,100) LNUM,'SQRT: domain error.' RETURN 54 WRITE(*,100) LNUM,'ASIN: domain error.' RETURN 55 WRITE(*,100) LNUM,'ACOS: domain error.' RETURN 56 WRITE(*,100) LNUM,'ACOSH: domain error.' RETURN 57 WRITE(*,'(1X,A6,I4,A)') 'LABEL ',LNUM,' defined more than once.' RETURN 58 WRITE(*,'(1X,A6,I4,A11)') 'LABEL ',LNUM,' not found.' RETURN 100 FORMAT(1X,5Hline ,I3,2H: ,A) END C*** pcomp_ev.f SUBROUTINE EVAL (START,IVAL,FVAL,MODE,PVVA, 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IINDEX,VINDEX,IICONS,VICONS,IRCONS,VRCONS,IVARI, 4 VVARI,IFUNC,VFUNC,VGRAD,VPFX,VINDVA,GSTACK,IERR) INTEGER START,IVAL DOUBLE PRECISION FVAL INTEGER MODE INTEGER PVVA INTEGER MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA,MPIFN INTEGER MPVFN,MPVPF,MPIV INTEGER IINDEX(MPIIS,5),VINDEX(MPVIS),IICONS(MPIIC,4) INTEGER VICONS(MPVIC),IRCONS(MPIRC,4),IVARI(MPIVA,3) INTEGER IFUNC(MPIFN,6),VPFX(MPVPF),VINDVA(MPIV) DOUBLE PRECISION VRCONS(MPVRC),VVARI(MPVVA),VFUNC(MPVFN) DOUBLE PRECISION VGRAD(MPVFN,MPVVA) DOUBLE PRECISION GSTACK(MPVVA,10) INTEGER IERR C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C INTEGER MAXEXT PARAMETER (MAXEXT=1) C INTEGER EXTTYP(MAXEXT) INTEGER EXT INTEGER EXTPAR(2) C INTEGER ISMDEP,FSMDEP,GSMDEP,RSMDEP PARAMETER (ISMDEP=10,FSMDEP=10,GSMDEP=10,RSMDEP=40) INTEGER ISTACK(ISMDEP),RSTACK(RSMDEP) DOUBLE PRECISION FSTACK(FSMDEP) INTEGER ITOS,FTOS,GTOS,RTOS C INTEGER PC,X,DIM,I DOUBLE PRECISION Z,Z1,Z2 C INTEGER NOGRAD,GRAD PARAMETER (NOGRAD=0,GRAD=1) C DATA EXTTYP /1/ C PC=START ITOS=0 FTOS=0 GTOS=0 RTOS=0 1 X=VPFX(PC) 10 IF (X .EQ. -1) THEN IF (ITOS .GT. 0) IVAL=ISTACK(ITOS) IF (FTOS .GT. 0) FVAL=FSTACK(FTOS) RETURN ENDIF 20 IF (X .EQ. ADD+128) THEN ISTACK(ITOS-1)=ISTACK(ITOS-1)+ISTACK(ITOS) ITOS=ITOS-1 PC=PC+1 GO TO 1 ENDIF 30 IF (X .EQ. SUB+128) THEN ISTACK(ITOS-1)=ISTACK(ITOS-1)-ISTACK(ITOS) ITOS=ITOS-1 PC=PC+1 GO TO 1 ENDIF 40 IF (X .EQ. MULT+128) THEN ISTACK(ITOS-1)=ISTACK(ITOS-1)*ISTACK(ITOS) ITOS=ITOS-1 PC=PC+1 GO TO 1 ENDIF 50 IF (X .EQ. DIV+128) THEN IF (ISTACK(ITOS) .EQ. 0) THEN IERR=9 RETURN ENDIF ISTACK(ITOS-1)=ISTACK(ITOS-1)/ISTACK(ITOS) ITOS=ITOS-1 PC=PC+1 GO TO 1 ENDIF 60 IF (X .EQ. UMINUS+128) THEN ISTACK(ITOS)=-ISTACK(ITOS) PC=PC+1 GO TO 1 ENDIF 70 IF (X .EQ. INUM+128) THEN ITOS=ITOS+1 IF (ITOS .GT. ISMDEP) THEN IERR=24 RETURN ENDIF ISTACK(ITOS)=VICONS(VPFX(PC+1)) PC=PC+2 GO TO 1 ENDIF 80 IF (X .EQ. INDVAR+128) THEN ITOS=ITOS+1 IF (ITOS .GT. ISMDEP) THEN IERR=24 RETURN ENDIF ISTACK(ITOS)=VINDVA(VPFX(PC+1)) PC=PC+2 GO TO 1 ENDIF 90 IF (X .EQ. ADD) THEN IF (MODE .EQ. GRAD) THEN DO 91 I=1,PVVA GSTACK(I,GTOS-1)=GSTACK(I,GTOS-1)+GSTACK(I,GTOS) 91 CONTINUE GTOS=GTOS-1 ENDIF FSTACK(FTOS-1)=FSTACK(FTOS-1)+FSTACK(FTOS) FTOS=FTOS-1 PC=PC+1 GO TO 1 ENDIF 100 IF (X .EQ. SUB) THEN IF (MODE .EQ. GRAD) THEN DO 101 I=1,PVVA GSTACK(I,GTOS-1)=GSTACK(I,GTOS-1)-GSTACK(I,GTOS) 101 CONTINUE GTOS=GTOS-1 ENDIF FSTACK(FTOS-1)=FSTACK(FTOS-1)-FSTACK(FTOS) FTOS=FTOS-1 PC=PC+1 GO TO 1 ENDIF 110 IF (X .EQ. MULT) THEN IF (MODE .EQ. GRAD) THEN DO 111 I=1,PVVA GSTACK(I,GTOS-1)=FSTACK(FTOS)*GSTACK(I,GTOS-1)+ 1 FSTACK(FTOS-1)*GSTACK(I,GTOS) 111 CONTINUE GTOS=GTOS-1 ENDIF FSTACK(FTOS-1)=FSTACK(FTOS-1)*FSTACK(FTOS) FTOS=FTOS-1 PC=PC+1 GO TO 1 ENDIF 120 IF (X .EQ. DIV) THEN IF (FSTACK(FTOS) .EQ. 0.0D0) THEN IERR=9 RETURN ENDIF IF (MODE .EQ. GRAD) THEN Z=FSTACK(FTOS)**2 DO 121 I=1,PVVA GSTACK(I,GTOS-1)=GSTACK(I,GTOS-1)/FSTACK(FTOS)- 1 FSTACK(FTOS-1)/Z*GSTACK(I,GTOS) 121 CONTINUE GTOS=GTOS-1 ENDIF FSTACK(FTOS-1)=FSTACK(FTOS-1)/FSTACK(FTOS) FTOS=FTOS-1 PC=PC+1 GO TO 1 ENDIF 130 IF (X .EQ. POWER) THEN IF (FSTACK(FTOS-1) .LE. 0.0D0) THEN IERR=9 RETURN ENDIF IF (MODE .EQ. GRAD) THEN Z1=FSTACK(FTOS)*FSTACK(FTOS-1)**(FSTACK(FTOS)-1.0D0) Z2=FSTACK(FTOS-1)**FSTACK(FTOS)*DLOG(FSTACK(FTOS-1)) DO 132 I=1,PVVA GSTACK(I,GTOS-1)=Z1*GSTACK(I,GTOS-1)+Z2*GSTACK(I,GTOS) 132 CONTINUE GTOS=GTOS-1 ENDIF FSTACK(FTOS-1)=FSTACK(FTOS-1)**FSTACK(FTOS) FTOS=FTOS-1 PC=PC+1 GO TO 1 ENDIF 135 IF (X .EQ. POWER+128) THEN IF (MODE .EQ. GRAD) THEN IF ((VPFX(PC+1) .LT. 1) .AND. (FSTACK(FTOS) .EQ. 0.0D0)) THEN IERR=9 RETURN ENDIF Z=VPFX(PC+1)*FSTACK(FTOS)**(VPFX(PC+1)-1) DO 137 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 137 CONTINUE ENDIF IF ((VPFX(PC+1) .LT. 0) .AND. (FSTACK(FTOS) .EQ. 0.0D0)) THEN IERR=9 RETURN ENDIF FSTACK(FTOS)=FSTACK(FTOS)**VPFX(PC+1) PC=PC+2 GO TO 1 ENDIF 140 IF (X .EQ. UMINUS) THEN IF (MODE .EQ. GRAD) THEN DO 141 I=1,PVVA GSTACK(I,GTOS)=-GSTACK(I,GTOS) 141 CONTINUE ENDIF FSTACK(FTOS)=-FSTACK(FTOS) PC=PC+1 GO TO 1 ENDIF 150 IF (X .EQ. RNUM) THEN IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF DO 151 I=1,PVVA GSTACK(I,GTOS)=0.0D0 151 CONTINUE ENDIF FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF FSTACK(FTOS)=VRCONS(VPFX(PC+1)) PC=PC+2 GO TO 1 ENDIF 160 IF (X .EQ. INUM) THEN IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF DO 161 I=1,PVVA GSTACK(I,GTOS)=0.0D0 161 CONTINUE ENDIF FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF FSTACK(FTOS)=DBLE(VICONS(VPFX(PC+1))) PC=PC+2 GO TO 1 ENDIF 170 IF (X .EQ. INDVAR) THEN IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF DO 171 I=1,PVVA GSTACK(I,GTOS)=0.0D0 171 CONTINUE ENDIF FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF FSTACK(FTOS)=DBLE(VINDVA(VPFX(PC+1))) PC=PC+2 GO TO 1 ENDIF 180 IF (X .EQ. REAL) THEN IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF DO 181 I=1,PVVA GSTACK(I,GTOS)=0.0D0 181 CONTINUE ENDIF DIM=IRCONS(VPFX(PC+1),1) IF (DIM .EQ. 0) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF FSTACK(FTOS)=VRCONS(IRCONS(VPFX(PC+1),4)) PC=PC+2 GO TO 1 ELSE IF (DIM .EQ. 1) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF IF ((ISTACK(ITOS) .LT. 0) .OR. (ISTACK(ITOS) .GT. 1 IRCONS(VPFX(PC+1),2))) THEN IERR=33 RETURN ENDIF FSTACK(FTOS)=VRCONS(IRCONS(VPFX(PC+1),4)+ISTACK(ITOS)-1) ITOS=ITOS-1 PC=PC+2 GO TO 1 ELSE IF (DIM .EQ. 2) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF IF ((ISTACK(ITOS-1) .LE. 0) .OR. (ISTACK(ITOS) .LT. 0) .OR. 1 (ISTACK(ITOS-1) .GT. IRCONS(VPFX(PC+1),2)) .OR. 2 (ISTACK(ITOS) .GT. IRCONS(VPFX(PC+1),3))) THEN IERR=33 RETURN ENDIF FSTACK(FTOS)=VRCONS(IRCONS(VPFX(PC+1),4)+(ISTACK(ITOS-1)-1)* 1 IRCONS(VPFX(PC+1),3)+ISTACK(ITOS)-1) ITOS=ITOS-2 PC=PC+2 GO TO 1 ENDIF ENDIF 190 IF (X .EQ. INT) THEN IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF DO 191 I=1,PVVA GSTACK(I,GTOS)=0.0D0 191 CONTINUE ENDIF DIM=IICONS(VPFX(PC+1),1) IF (DIM .EQ. 0) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF FSTACK(FTOS)=DBLE(VICONS(IICONS(VPFX(PC+1),4))) PC=PC+2 GO TO 1 ELSE IF (DIM .EQ. 1) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF IF ((ISTACK(ITOS) .LT. 0) .OR. (ISTACK(ITOS) .GT. 1 IICONS(VPFX(PC+1),2))) THEN IERR=33 RETURN ENDIF FSTACK(FTOS)=DBLE(VICONS(IICONS(VPFX(PC+1),4)+ISTACK(ITOS)-1)) ITOS=ITOS-1 PC=PC+2 GO TO 1 ELSE IF (DIM .EQ. 2) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF IF ((ISTACK(ITOS-1) .LE. 0) .OR. (ISTACK(ITOS) .LT. 0) .OR. 1 (ISTACK(ITOS-1) .GT. IICONS(VPFX(PC+1),2)) .OR. 2 (ISTACK(ITOS) .GT. IICONS(VPFX(PC+1),3))) THEN IERR=33 RETURN ENDIF FSTACK(FTOS)=DBLE(VICONS(IICONS(VPFX(PC+1),4)+(ISTACK(ITOS-1) 1 -1)*IICONS(VPFX(PC+1),3)+ISTACK(ITOS)-1)) ITOS=ITOS-2 PC=PC+2 GO TO 1 ENDIF ENDIF 200 IF (X .EQ. VAR) THEN IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF DO 201 I=1,PVVA GSTACK(I,GTOS)=0.0D0 201 CONTINUE ENDIF DIM=IVARI(VPFX(PC+1),1) IF (DIM .EQ. 0) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF FSTACK(FTOS)=VVARI(IVARI(VPFX(PC+1),3)) IF (MODE .EQ. GRAD) GSTACK(IVARI(VPFX(PC+1),3),GTOS)=1.0D0 PC=PC+2 GO TO 1 ELSE IF (DIM .EQ. 1) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF IF ((ISTACK(ITOS) .LT. 0) .OR. (ISTACK(ITOS) .GT. 1 IVARI(VPFX(PC+1),2))) THEN IERR=33 RETURN ENDIF FSTACK(FTOS)=VVARI(IVARI(VPFX(PC+1),3)+ISTACK(ITOS)-1) IF (MODE .EQ. GRAD) GSTACK(IVARI(VPFX(PC+1),3) 1 +ISTACK(ITOS)-1,GTOS)=1.0D0 ITOS=ITOS-1 PC=PC+2 GO TO 1 ENDIF ENDIF 210 IF (X .EQ. FUNC) THEN IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF ENDIF DIM=IFUNC(VPFX(PC+1),1) IF (DIM .LE. 0) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF IF (MODE .EQ. GRAD) THEN DO 211 I=1,PVVA GSTACK(I,GTOS)=VGRAD(IFUNC(VPFX(PC+1),5),I) 211 CONTINUE ENDIF FSTACK(FTOS)=VFUNC(IFUNC(VPFX(PC+1),4)) PC=PC+2 GO TO 1 ELSE IF (DIM .EQ. 1) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF IF ((ISTACK(ITOS) .LT. 0) .OR. (ISTACK(ITOS) .GT. 1 IFUNC(VPFX(PC+1),3))) THEN IERR=33 RETURN ENDIF IF (MODE .EQ. GRAD) THEN DO 212 I=1,PVVA GSTACK(I,GTOS)=VGRAD(IFUNC(VPFX(PC+1),5)+ISTACK(ITOS)-1,I) 212 CONTINUE ENDIF FSTACK(FTOS)=VFUNC(IFUNC(VPFX(PC+1),4)+ISTACK(ITOS)-1) ITOS=ITOS-1 PC=PC+2 GO TO 1 ENDIF ENDIF 220 IF (X .EQ. STDRD) THEN IF (VPFX(PC+1) .EQ. 1) THEN IF (MODE .EQ. GRAD) THEN Z=DSIGN(1.0D0,FSTACK(FTOS)) DO 2201 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2201 CONTINUE ENDIF FSTACK(FTOS)=DABS(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 2) THEN IF (FSTACK(FTOS) .LT. 0.0D0) THEN IERR=53 RETURN ENDIF IF (MODE .EQ. GRAD) THEN IF (FSTACK(FTOS) .EQ. 0.0D0) THEN IERR=9 RETURN ENDIF Z=0.5D0/DSQRT(FSTACK(FTOS)) DO 2202 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2202 CONTINUE ENDIF FSTACK(FTOS)=DSQRT(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 3) THEN IF (MODE .EQ. GRAD) THEN Z=DEXP(FSTACK(FTOS)) DO 2203 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2203 CONTINUE ENDIF FSTACK(FTOS)=DEXP(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 4) THEN IF (FSTACK(FTOS) .LE. 0.0D0) THEN IERR=52 RETURN ENDIF IF (MODE .EQ. GRAD) THEN Z=1.0D0/FSTACK(FTOS) DO 2204 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2204 CONTINUE ENDIF FSTACK(FTOS)=DLOG(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 5) THEN IF (FSTACK(FTOS) .LE. 0.0D0) THEN IERR=52 RETURN ENDIF IF (MODE .EQ. GRAD) THEN Z=1.0D0/(FSTACK(FTOS)*DLOG(10.0D0)) DO 2205 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2205 CONTINUE ENDIF FSTACK(FTOS)=DLOG10(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 6) THEN IF (MODE .EQ. GRAD) THEN Z=DCOS(FSTACK(FTOS)) DO 2206 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2206 CONTINUE ENDIF FSTACK(FTOS)=DSIN(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 7) THEN IF (MODE .EQ. GRAD) THEN Z=-DSIN(FSTACK(FTOS)) DO 2207 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2207 CONTINUE ENDIF FSTACK(FTOS)=DCOS(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 8) THEN IF (MODE .EQ. GRAD) THEN Z=1.0D0/DCOS(FSTACK(FTOS))**2 DO 2208 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2208 CONTINUE ENDIF FSTACK(FTOS)=DTAN(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 9) THEN IF (MODE .EQ. GRAD) THEN IF (DABS(FSTACK(FTOS)) .GE. 1.0D0) THEN IERR = 54 RETURN ENDIF Z=1.0D0/DSQRT(1.0D0-FSTACK(FTOS)**2) DO 2209 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2209 CONTINUE ENDIF IF (DABS(FSTACK(FTOS)) .GT. 1.0D0) THEN IERR = 54 RETURN ENDIF FSTACK(FTOS)=DASIN(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 10) THEN IF (MODE .EQ. GRAD) THEN IF (DABS(FSTACK(FTOS)) .GE. 1.0D0) THEN IERR = 55 RETURN ENDIF Z=-1.0D0/DSQRT(1.0D0-FSTACK(FTOS)**2) DO 2210 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2210 CONTINUE ENDIF IF (DABS(FSTACK(FTOS)) .GT. 1.0D0) THEN IERR = 55 RETURN ENDIF FSTACK(FTOS)=DACOS(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 11) THEN IF (MODE .EQ. GRAD) THEN Z=1.0D0/(1.0D0+FSTACK(FTOS)**2) DO 2211 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2211 CONTINUE ENDIF FSTACK(FTOS)=DATAN(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 12) THEN IF (MODE .EQ. GRAD) THEN Z=DCOSH(FSTACK(FTOS)) DO 2212 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2212 CONTINUE ENDIF FSTACK(FTOS)=DSINH(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 13) THEN IF (MODE .EQ. GRAD) THEN Z=DSINH(FSTACK(FTOS)) DO 2213 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2213 CONTINUE ENDIF FSTACK(FTOS)=DCOSH(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 14) THEN IF (MODE .EQ. GRAD) THEN Z=1.0D0/DCOSH(FSTACK(FTOS))**2 DO 2214 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2214 CONTINUE ENDIF FSTACK(FTOS)=DTANH(FSTACK(FTOS)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 15) THEN IF (MODE .EQ. GRAD) THEN Z=1.0D0/DSQRT(1.0D0+FSTACK(FTOS)**2) DO 2215 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2215 CONTINUE ENDIF FSTACK(FTOS)=DLOG(FSTACK(FTOS)+DSQRT(1.0D0+FSTACK(FTOS)**2)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 16) THEN IF (MODE .EQ. GRAD) THEN IF (FSTACK(FTOS) .LE. 1.0D0) THEN IERR = 56 RETURN ENDIF Z=1.0D0/DSQRT(FSTACK(FTOS)**2-1.0D0) DO 2216 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2216 CONTINUE ENDIF IF (FSTACK(FTOS) .LT. 1.0D0) THEN IERR = 56 RETURN ENDIF FSTACK(FTOS)=DLOG(FSTACK(FTOS)+DSQRT(FSTACK(FTOS)**2-1.0D0)) PC=PC+2 GOTO 1 C ELSE IF (VPFX(PC+1) .EQ. 17) THEN IF (DABS(FSTACK(FTOS)) .GE. 1.0D0) THEN IERR = 51 RETURN ENDIF IF (MODE .EQ. GRAD) THEN Z=1.0D0/(1.0D0-FSTACK(FTOS)**2) DO 2217 I=1,PVVA GSTACK(I,GTOS)=Z*GSTACK(I,GTOS) 2217 CONTINUE ENDIF FSTACK(FTOS)=0.5D0*DLOG((1.0D0+FSTACK(FTOS))/ 1 (1.0D0-FSTACK(FTOS))) PC=PC+2 GOTO 1 ENDIF ENDIF 230 IF (X .EQ. EXTERN) THEN EXT=VPFX(PC+1) IF (EXTTYP(EXT) .EQ. 1) THEN EXTPAR(1)=ISTACK(ITOS) ITOS=ITOS-1 ELSE IF (EXTTYP(EXT) .EQ. 2) THEN EXTPAR(1)=ISTACK(ITOS-1) EXTPAR(2)=ISTACK(ITOS) ITOS=ITOS-2 ENDIF FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF CALL EXTFUN(EXT,VVARI,PVVA,FSTACK(FTOS),EXTPAR) IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF CALL EXTGRA(EXT,VVARI,PVVA,GSTACK(1,GTOS),EXTPAR) ENDIF PC=PC+2 GO TO 1 ENDIF 240 IF (X .EQ. SUM) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF RTOS=RTOS+4 IF (RTOS .GT. RSMDEP) THEN IERR=24 RETURN ENDIF IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF DO 241 I=1,PVVA GSTACK(I,GTOS)=0.0D0 241 CONTINUE ENDIF FSTACK(FTOS)=0.0D0 RSTACK(RTOS)=IINDEX(VPFX(PC+2),2) RSTACK(RTOS-1)=IINDEX(VPFX(PC+2),5) RSTACK(RTOS-2)=VPFX(PC+1) RSTACK(RTOS-3)=PC+3 VINDVA(VPFX(PC+1))=VINDEX(RSTACK(RTOS-1)) PC=PC+3 GO TO 1 ENDIF 250 IF (X .EQ. ENDSUM) THEN IF (MODE .EQ. GRAD) THEN DO 251 I=1,PVVA GSTACK(I,GTOS-1)=GSTACK(I,GTOS-1)+GSTACK(I,GTOS) 251 CONTINUE GTOS=GTOS-1 ENDIF FSTACK(FTOS-1)=FSTACK(FTOS-1)+FSTACK(FTOS) FTOS=FTOS-1 RSTACK(RTOS)=RSTACK(RTOS)-1 IF (RSTACK(RTOS) .GT. 0) THEN RSTACK(RTOS-1)=RSTACK(RTOS-1)+1 VINDVA(RSTACK(RTOS-2))=VINDEX(RSTACK(RTOS-1)) PC=RSTACK(RTOS-3) ELSE RTOS=RTOS-4 PC=PC+1 ENDIF GO TO 1 ENDIF 260 IF (X .EQ. PROD) THEN FTOS=FTOS+1 IF (FTOS .GT. FSMDEP) THEN IERR=24 RETURN ENDIF RTOS=RTOS+4 IF (RTOS .GT. RSMDEP) THEN IERR=24 RETURN ENDIF IF (MODE .EQ. GRAD) THEN GTOS=GTOS+1 IF (GTOS .GT. GSMDEP) THEN IERR=24 RETURN ENDIF DO 261 I=1,PVVA GSTACK(I,GTOS)=0.0D0 261 CONTINUE ENDIF FSTACK(FTOS)=1.0D0 RSTACK(RTOS)=IINDEX(VPFX(PC+2),2) RSTACK(RTOS-1)=IINDEX(VPFX(PC+2),5) RSTACK(RTOS-2)=VPFX(PC+1) RSTACK(RTOS-3)=PC+3 VINDVA(VPFX(PC+1))=VINDEX(RSTACK(RTOS-1)) PC=PC+3 GO TO 1 ENDIF 270 IF (X .EQ. ENDPRD) THEN IF (MODE .EQ. GRAD) THEN DO 271 I=1,PVVA GSTACK(I,GTOS-1)=FSTACK(FTOS)*GSTACK(I,GTOS-1)+ 1 FSTACK(FTOS-1)*GSTACK(I,GTOS) 271 CONTINUE GTOS=GTOS-1 ENDIF FSTACK(FTOS-1)=FSTACK(FTOS-1)*FSTACK(FTOS) FTOS=FTOS-1 RSTACK(RTOS)=RSTACK(RTOS)-1 IF (RSTACK(RTOS) .GT. 0) THEN RSTACK(RTOS-1)=RSTACK(RTOS-1)+1 VINDVA(RSTACK(RTOS-2))=VINDEX(RSTACK(RTOS-1)) PC=RSTACK(RTOS-3) ELSE RTOS=RTOS-4 PC=PC+1 ENDIF GO TO 1 ENDIF 275 IF ((X .EQ. IF+128) .OR. (X .EQ. ENDIF+128)) THEN PC=PC+1 GO TO 1 ENDIF 280 IF (X .EQ. RELOP) THEN ITOS=ITOS+1 IF (ITOS .GT. ISMDEP) THEN IERR=24 RETURN ENDIF IF (VPFX(PC+1) .EQ. 1) THEN IF (FSTACK(FTOS-1) .EQ. FSTACK(FTOS)) THEN ISTACK(ITOS)=1 ELSE ISTACK(ITOS)=0 ENDIF ELSE IF (VPFX(PC+1) .EQ. 2) THEN IF (FSTACK(FTOS-1) .NE. FSTACK(FTOS)) THEN ISTACK(ITOS)=1 ELSE ISTACK(ITOS)=0 ENDIF ELSE IF (VPFX(PC+1) .EQ. 3) THEN IF (FSTACK(FTOS-1) .LT. FSTACK(FTOS)) THEN ISTACK(ITOS)=1 ELSE ISTACK(ITOS)=0 ENDIF ELSE IF (VPFX(PC+1) .EQ. 4) THEN IF (FSTACK(FTOS-1) .LE. FSTACK(FTOS)) THEN ISTACK(ITOS)=1 ELSE ISTACK(ITOS)=0 ENDIF ELSE IF (VPFX(PC+1) .EQ. 5) THEN IF (FSTACK(FTOS-1) .GT. FSTACK(FTOS)) THEN ISTACK(ITOS)=1 ELSE ISTACK(ITOS)=0 ENDIF ELSE IF (VPFX(PC+1) .EQ. 6) THEN IF (FSTACK(FTOS-1) .GE. FSTACK(FTOS)) THEN ISTACK(ITOS)=1 ELSE ISTACK(ITOS)=0 ENDIF ENDIF IF (MODE .EQ. GRAD) GTOS=GTOS-2 FTOS=FTOS-2 PC=PC+2 GO TO 1 ENDIF 290 IF (X .EQ. AND) THEN IF (ISTACK(ITOS-1)+ISTACK(ITOS) .EQ. 2) THEN ISTACK(ITOS-1)=1 ELSE ISTACK(ITOS-1)=0 ENDIF ITOS=ITOS-1 PC=PC+1 GO TO 1 ENDIF 300 IF (X .EQ. OR) THEN IF (ISTACK(ITOS-1)+ISTACK(ITOS) .GT. 0) THEN ISTACK(ITOS-1)=1 ELSE ISTACK(ITOS-1)=0 ENDIF ITOS=ITOS-1 PC=PC+1 GO TO 1 ENDIF 310 IF (X .EQ. NOT) THEN ISTACK(ITOS)=1-ISTACK(ITOS) PC=PC+1 GO TO 1 ENDIF 320 IF (X .EQ. BEQ) THEN IF (ISTACK(ITOS) .EQ. 0) THEN ITOS=ITOS-1 PC=VPFX(PC+1) ELSE ITOS=ITOS-1 PC=PC+2 ENDIF GO TO 1 ENDIF 330 IF (X .EQ. BRA) THEN PC=VPFX(PC+1) GO TO 1 ENDIF 340 IF (X .EQ. GOTO) THEN PC=VPFX(PC+2) GO TO 1 ENDIF 350 IF (X .EQ. CONTIN) THEN PC=PC+2 GO TO 1 ENDIF 360 IF (X .EQ. ASSIGN) THEN IF (IFUNC(VPFX(PC+1),1) .LE. 0) THEN IF (MODE .EQ. GRAD) THEN DO 361 I=1,PVVA VGRAD(IFUNC(VPFX(PC+1),5),I)=GSTACK(I,GTOS) 361 CONTINUE GTOS=GTOS-1 ENDIF VFUNC(IFUNC(VPFX(PC+1),4))=FSTACK(FTOS) ELSE IF (MODE .EQ. GRAD) THEN DO 362 I=1,PVVA VGRAD(IFUNC(VPFX(PC+1),5)+VINDVA(IFUNC(VPFX(PC+1),2))- 1 1,I)=GSTACK(I,GTOS) 362 CONTINUE GTOS=GTOS-1 ENDIF VFUNC(IFUNC(VPFX(PC+1),4)+VINDVA(IFUNC(VPFX(PC+1),2))-1)= 1 FSTACK(FTOS) ENDIF FTOS=FTOS-1 PC=PC+2 GO TO 1 ENDIF 370 IF ((X .EQ. -ASSIGN) .OR. (X .EQ. -FUNC)) THEN IERR=27 RETURN ENDIF C IERR=26 WRITE(*,*) 'EVAL (3901) : unknown opcode ',X RETURN END C*** pcomp_ex.f SUBROUTINE EXTFUN (EXT,X,N,F,EXTPAR) INTEGER EXT,N,EXTPAR(2) DOUBLE PRECISION X(N),F GOTO (1) EXT 1 CALL EXF001(X,N,F) RETURN END C C C SUBROUTINE EXTGRA (EXT,X,N,DF,EXTPAR) INTEGER EXT,N,EXTPAR(2) DOUBLE PRECISION X(N),DF(N) GOTO (1) EXT 1 CALL EXG001(X,N,DF) RETURN END C C*************************************** C C EXAMPLE FORMAT FOR EXTERNAL FUNCTIONS C C*************************************** C SUBROUTINE EXF001 (X,N,F) INTEGER N DOUBLE PRECISION X(N),F F=0.0D0*X(N) RETURN END C C C SUBROUTINE EXG001 (X,N,DF) INTEGER N DOUBLE PRECISION X(N),DF(N) INTEGER I DO 10 I=1,N DF(I)=0.0D0*X(I) 10 CONTINUE RETURN END C*** pcomp_g.f C********************************************* C * C PROGRAM : PCOMP * C MODULE : G (FORTRAN CODE GENERATOR) * C ABSTRACT : FORTRAN PRECOMPILER * C KEY WORD : AUTOMATIC DIFFERENTIATION * C SOURCE : PCOMP 2.3 by M.LIEPELT * C COPYRIGHT : M.DOBMANN, K.SCHITTKOWSKI * C MATHEMATISCHES INSTITUT, * C UNIVERSITAET BAYREUTH, * C D-8580 BAYREUTH, GERMANY * C DATE : SEPTEMBER 1, 1993 * C VERSION : 3.1 * C * C********************************************* C C C SUBROUTINE SYMPRP (SYMFIL,WA,LWA,IWA,LIWA,UWA,UIWA,IERR) INTEGER SYMFIL INTEGER LWA,LIWA DOUBLE PRECISION WA(LWA) INTEGER IWA(LIWA) INTEGER UWA,UIWA INTEGER IERR C C********************************************************************** C C S Y M P R P - LOAD INTERMEDIATE CODE GENERATED BY SYMINP FROM C SYMFIL INTO WORKING ARRAYS. C C PARAMETERS: C SYMFIL - INPUT DEVICE; THE INTERMEDIATE CODE GENERATED BY C SYMINP WAS WRITTEN TO THIS FILE AND IS NOW LOADED. C WA(LWA) - REAL WORKING ARRAY, REQUIRED BY SYMPRP. ON RETURN, C WA() CONTAINS THE INTERMEDIATE CODE. C IWA(LIWA) - INTEGER WORKING ARRAY, CF. WA(). C UWA,UIWA - INDICATE THE ACTUAL SPACE OF WA() AND IWA() THAT C HAS BEEN USED BY THE SUBROUTINE. C IERR - THE PARAMETER SHOWS THE REASON FOR TERMINATING THE C SUBROUTINE. ON RETURN IERR COULD CONTAIN THE FOLLOW- C ING VALUES: C IERR = 0 : SUCCESSFUL TERMINATION. C IERR > 0 : AN ERROR HAS BEEN DETECTED. FOR FURTHER C INFORMATION CF. SUBROUTINE SYMERR. C C********************************************************************** C INTEGER I,PWA,PIWA,PX,PIX C INTEGER GSMDEP PARAMETER (GSMDEP=10) C DO 10 I=1,14 READ(SYMFIL,'(I6)',ERR=100) IWA(I) 10 CONTINUE PIWA=IWA(1)*5+IWA(2)+IWA(3)*4+IWA(4)+IWA(5)*4+IWA(7)*3+ 1 IWA(9)*6+IWA(13)+14 PWA=IWA(6) PX=IWA(8)+IWA(11)+IWA(12)*IWA(8)+GSMDEP*IWA(8) PIX=IWA(14) IF ((PWA+PX .GT. LWA) .OR. (PIWA+PIX .GT. LIWA)) THEN IERR=32 RETURN ENDIF DO 20 I=15,PIWA READ(SYMFIL,'(I6)',ERR=100) IWA(I) 20 CONTINUE DO 30 I=1,PWA READ(SYMFIL,'(D24.17)',ERR=100) WA(I) 30 CONTINUE IERR=0 UWA=PWA+PX UIWA=PIWA+PIX RETURN 100 IERR=26 RETURN END C C C SUBROUTINE SYMFOR (XFIL,WA,LWA,IWA,LIWA,IERR) INTEGER XFIL INTEGER LWA,LIWA DOUBLE PRECISION WA(LWA) INTEGER IWA(LIWA) INTEGER IERR C C********************************************************************** C C S Y M F O R - GENERATE EXECUTABLE FORTRAN CODE FOR EVALUATION C OF FUNCTIONS AND GRADIENTS. C C PARAMETERS: C XFIL - OUTPUT DEVICE; THE EXECUTABLE FORTRAN CODE GENERATED C BY SYMFOR IS WRITTEN TO THIS FILE. C WA(LWA) - REAL WORKING ARRAY, CONTAINS THE INTERMEDIATE CODE C GENERATED BY SYMINP. C IWA(LIWA) - INTEGER WORKING ARRAY, CF. WA(LWA). C IERR - THE PARAMETER SHOWS THE REASON FOR TERMINATING THE C SUBROUTINE. ON RETURN IERR COULD CONTAIN THE FOLLOW- C ING VALUES: C IERR = 0 : SUCCESSFUL TERMINATION. C IERR > 0 : AN ERROR HAS BEEN DETECTED. FOR FURTHER C INFORMATION CF. SUBROUTINE SYMERR. C C********************************************************************** C INTEGER PIIS,PVIS,PIIC,PVIC,PIRC,PVRC,PIVA,PVVA,PIFN,PXFN,PVFN INTEGER PVGR,PVPF,PIV,LIIS,LVIS,LIIC,LVIC,LIRC,LVRC,LIVA,LVVA INTEGER LIFN,LVFN,LVGR,LVPF,LIV INTEGER PVP,PVQD,LVP,LIST,LVQD C INTEGER MAXVP,MAXVQD PARAMETER (MAXVP=100) C INTEGER MAXXC,MAXLC LOGICAL EXCALL C INTEGER ISMDEP PARAMETER (ISMDEP=10) C PIIS=IWA(1) PVIS=IWA(2) PIIC=IWA(3) PVIC=IWA(4) PIRC=IWA(5) PVRC=IWA(6) PIVA=IWA(7) PVVA=IWA(8) PIFN=IWA(9) PXFN=IWA(10) PVFN=IWA(11) PVGR=IWA(12) PVPF=IWA(13) PIV=IWA(14) LIIS=15 LVIS=LIIS+PIIS*5 LIIC=LVIS+PVIS LVIC=LIIC+PIIC*4 LIRC=LVIC+PVIC LVRC=1 LIVA=LIRC+PIRC*4 LVVA=LVRC+PVRC LIFN=LIVA+PIVA*3 LVFN=LVVA+PVVA LVGR=LVFN+PVFN LVPF=LIFN+PIFN*6 LIV=LVPF+PVPF LVP=LIV+PIV LIST=LVP+(PIV+1)*MAXVP LVQD=LIST+(PIV+1)*ISMDEP MAXVQD=(LIWA-LVQD+1)/5 PVP=0 CALL REVCDE(PIIS,PIIC,PVIC,PIRC,PIVA,PVVA,PIFN,PXFN, 1 PVPF,PIV,IWA(LIIS),IWA(LIIC), 2 IWA(LVIC),IWA(LIRC),IWA(LIVA), 3 IWA(LIFN),IWA(LVPF), 4 MAXVP,IWA(LVP),PVP,IWA(LIST),MAXVQD,IWA(LVQD),PVQD, 5 MAXXC,MAXLC,EXCALL,IERR) IF (IERR .NE. 0) THEN RETURN ENDIF CALL FORCDE(XFIL,PVIS,PVIC,PVRC,PVVA,PIFN,PXFN,PVFN,PIV,IWA(LVIS), 1 IWA(LVIC),WA(LVRC),MAXVP,IWA(LVP),PVP,MAXVQD, 2 IWA(LVQD),MAXXC,MAXLC,EXCALL,IERR) RETURN END C C C SUBROUTINE REVCDE (PIIS,PIIC,PVIC,PIRC,PIVA,PVVA,PIFN, 1 PXFN,PVPF,PIV,IINDEX,IICONS, 2 VICONS,IRCONS,IVARI,IFUNC, 3 VPFX,MAXVP,VPOLY,PVP,ISTACK, 4 MAXVQD,VQD,PVQD,MAXXC,MAXLC,EXCALL,IERR) INTEGER PIIS,PIIC,PVIC,PIRC,PIVA,PVVA,PIFN,PXFN INTEGER PVPF,PIV INTEGER IINDEX(PIIS,5),IICONS(PIIC,4),VICONS(PVIC) INTEGER IRCONS(PIRC,4),IVARI(PIVA,3),IFUNC(PIFN,6),VPFX(PVPF) INTEGER MAXVP,MAXVQD INTEGER VPOLY(PIV+1,MAXVP),VQD(MAXVQD,5) INTEGER PVP,PVQD INTEGER MAXXC,MAXLC LOGICAL EXCALL INTEGER IERR C INTEGER ISMDEP PARAMETER (ISMDEP=10) INTEGER ISTACK(PIV+1,ISMDEP) C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C INTEGER MAXSTD,MAXEXT PARAMETER (MAXSTD=17,MAXEXT=1) INTEGER STDTYP(MAXSTD),EXTTYP(MAXEXT) C INTEGER LSMDEP,RSMDEP,XSMDEP PARAMETER (LSMDEP=10,RSMDEP=40,XSMDEP=10) INTEGER LSTACK(LSMDEP),RSTACK(RSMDEP) INTEGER XSTACK(XSMDEP) INTEGER ITOS,LTOS,RTOS,XTOS INTEGER DIM,FC,I,K,LC,PC,QC,QC1,QC2,X,XC C------------------------------------------- INTEGER PINSRT C INTEGER OFS LOGICAL NUMBER C------------------------------------------- DATA STDTYP /1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1/ DATA EXTTYP /0/ C QC=0 FC=1 MAXXC=0 MAXLC=0 EXCALL=.FALSE. C 1 LC=0 XC=PVVA ITOS=0 LTOS=0 RTOS=0 XTOS=0 PC=IFUNC(FC,6) C------------------------------------------------------------ IF (IFUNC(FC,1) .EQ. 1) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF VQD(QC,1)=VECTOR VQD(QC,2)=IFUNC(FC,2) VQD(QC,3)=IFUNC(FC,3) VQD(QC,4)=0 VQD(QC,5)=0 DO 7 K=1,PIIS IF ((IINDEX(K,1) .EQ. 1) .AND. 1 (IINDEX(K,3) .EQ. 1) .AND. 2 (IINDEX(K,4) .EQ. IFUNC(FC,3))) THEN VQD(QC,4)=IINDEX(K,5) ENDIF 7 CONTINUE RTOS=RTOS+1 IF (RTOS .GT. RSMDEP) THEN IERR=24 RETURN ENDIF RSTACK(RTOS)=QC ENDIF C------------------------------------------------------------ QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF C IF (IFUNC(FC,1) .LE. 0) THEN VQD(QC,1)=ACTIVE VQD(QC,2)=IFUNC(FC,4) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=0 ELSE ITOS=ITOS+1 IF (ITOS .GT. ISMDEP) THEN IERR=24 RETURN ENDIF DO 9 I=2,PIV+1 ISTACK(I,ITOS)=0 9 CONTINUE ISTACK(1,ITOS)=IFUNC(FC,4)-1 ISTACK(IFUNC(FC,2)+1,ITOS)=1 VQD(QC,1)=ACTIVE VQD(QC,2)=-PINSRT(ISTACK(1,ITOS),PIV,MAXVP,VPOLY,PVP,IERR) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=0 ITOS=ITOS-1 ENDIF C------------------------------------------------------------ 2 X=VPFX(PC) 10 IF (X .EQ. -1) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF VQD(QC,1)=-1 VQD(QC,2)=0 VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=0 C------------------------------------------------------------ IF (IFUNC(FC,1) .EQ. 1) THEN VQD(QC,2)=QC VQD(RSTACK(RTOS),5)=QC RTOS=RTOS-1 ENDIF C------------------------------------------------------------ FC=FC+1 IF (FC .GT. PXFN) THEN C IF (FC .GT. PIFN) THEN PVQD=QC IF (PVP .EQ. 0) THEN PVP=1 DO 19 I=1,PIV+1 VPOLY(I,1)=0 19 CONTINUE ENDIF RETURN ELSE GO TO 1 ENDIF ENDIF 20 IF (X .EQ. ADD+128) THEN DO 21 I=1,PIV+1 ISTACK(I,ITOS-1)=ISTACK(I,ITOS-1)+ISTACK(I,ITOS) 21 CONTINUE ITOS=ITOS-1 PC=PC+1 GO TO 2 ENDIF 30 IF (X .EQ. SUB+128) THEN DO 31 I=1,PIV+1 ISTACK(I,ITOS-1)=ISTACK(I,ITOS-1)-ISTACK(I,ITOS) 31 CONTINUE ITOS=ITOS-1 PC=PC+1 GO TO 2 ENDIF 40 IF (X .EQ. MULT+128) THEN IF (NUMBER(ISTACK(1,ITOS-1),PIV+1)) THEN DO 41 I=PIV+1,1,-1 ISTACK(I,ITOS-1)=ISTACK(1,ITOS-1)*ISTACK(I,ITOS) 41 CONTINUE ELSE IF (NUMBER(ISTACK(1,ITOS),PIV+1)) THEN DO 42 I=PIV+1,1,-1 ISTACK(I,ITOS-1)=ISTACK(I,ITOS-1)*ISTACK(1,ITOS) 42 CONTINUE ELSE IERR=24 RETURN ENDIF ITOS=ITOS-1 PC=PC+1 GO TO 2 ENDIF 50 IF (X .EQ. DIV+128) THEN IF (.NOT. NUMBER(ISTACK(1,ITOS),PIV+1)) THEN IERR=24 RETURN ELSE IF (ISTACK(1,ITOS) .EQ. 0) THEN IERR=9 RETURN ENDIF DO 51 I=1,PIV+1 ISTACK(I,ITOS-1)=ISTACK(I,ITOS-1)/ISTACK(1,ITOS) 51 CONTINUE ITOS=ITOS-1 PC=PC+1 GO TO 2 ENDIF 60 IF (X .EQ. UMINUS+128) THEN DO 61 I=1,PIV+1 ISTACK(I,ITOS)=-ISTACK(I,ITOS) 61 CONTINUE PC=PC+1 GO TO 2 ENDIF 70 IF (X .EQ. INUM+128) THEN ITOS=ITOS+1 IF (ITOS .GT. ISMDEP) THEN IERR=24 RETURN ENDIF ISTACK(1,ITOS)=VICONS(VPFX(PC+1)) DO 71 I=2,PIV+1 ISTACK(I,ITOS)=0 71 CONTINUE PC=PC+2 GO TO 2 ENDIF 80 IF (X .EQ. INDVAR+128) THEN ITOS=ITOS+1 IF (ITOS .GT. ISMDEP) THEN IERR=24 RETURN ENDIF DO 81 I=1,PIV+1 ISTACK(I,ITOS)=0 81 CONTINUE ISTACK(VPFX(PC+1)+1,ITOS)=1 PC=PC+2 GO TO 2 ENDIF 90 IF (X .EQ. ADD) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=ADD VQD(QC,2)=0 VQD(QC,3)=XSTACK(XTOS-1) VQD(QC,4)=XSTACK(XTOS) VQD(QC,5)=XC XSTACK(XTOS-1)=XC XTOS=XTOS-1 PC=PC+1 GO TO 2 ENDIF 100 IF (X .EQ. SUB) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=SUB VQD(QC,2)=0 VQD(QC,3)=XSTACK(XTOS-1) VQD(QC,4)=XSTACK(XTOS) VQD(QC,5)=XC XSTACK(XTOS-1)=XC XTOS=XTOS-1 PC=PC+1 GO TO 2 ENDIF 110 IF (X .EQ. MULT) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=MULT VQD(QC,2)=0 VQD(QC,3)=XSTACK(XTOS-1) VQD(QC,4)=XSTACK(XTOS) VQD(QC,5)=XC XSTACK(XTOS-1)=XC XTOS=XTOS-1 PC=PC+1 GO TO 2 ENDIF 120 IF (X .EQ. DIV) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=DIV VQD(QC,2)=0 VQD(QC,3)=XSTACK(XTOS-1) VQD(QC,4)=XSTACK(XTOS) VQD(QC,5)=XC XSTACK(XTOS-1)=XC XTOS=XTOS-1 PC=PC+1 GO TO 2 ENDIF 130 IF (X .EQ. POWER) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=POWER VQD(QC,2)=0 VQD(QC,3)=XSTACK(XTOS-1) VQD(QC,4)=XSTACK(XTOS) VQD(QC,5)=XC XSTACK(XTOS-1)=XC XTOS=XTOS-1 PC=PC+1 GO TO 2 ENDIF 135 IF (X .EQ. POWER+128) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=POWER+128 VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=XSTACK(XTOS) VQD(QC,4)=0 VQD(QC,5)=XC XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ENDIF 140 IF (X .EQ. UMINUS) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=UMINUS VQD(QC,2)=0 VQD(QC,3)=XSTACK(XTOS) VQD(QC,4)=0 VQD(QC,5)=XC XSTACK(XTOS)=XC PC=PC+1 GO TO 2 ENDIF 150 IF (X .EQ. RNUM) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=RNUM VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ENDIF 160 IF (X .EQ. INUM) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=INUM VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ENDIF 170 IF (X .EQ. INDVAR) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=INDVAR VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ENDIF C ---------------------------- 180 IF (X .EQ. REAL) THEN DIM=IRCONS(VPFX(PC+1),1) IF (DIM .EQ. 0) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=REAL VQD(QC,2)=IRCONS(VPFX(PC+1),4) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 1) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=REAL ISTACK(1,ITOS)=ISTACK(1,ITOS)+IRCONS(VPFX(PC+1),4)-1 IF (NUMBER(ISTACK(1,ITOS),PIV+1)) THEN VQD(QC,2)=ISTACK(1,ITOS) ELSE VQD(QC,2)=-PINSRT(ISTACK(1,ITOS),PIV, 1 MAXVP,VPOLY,PVP,IERR) ENDIF VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC ITOS=ITOS-1 PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 2) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=REAL ISTACK(1,ITOS-1)=IRCONS(VPFX(PC+1),4)+ 1 (ISTACK(1,ITOS-1)-1)*IRCONS(VPFX(PC+1),3)+ 2 ISTACK(1,ITOS)-1 DO 182 I=2,PIV+1 ISTACK(I,ITOS-1)=ISTACK(I,ITOS-1)* 1 IRCONS(VPFX(PC+1),3)+ISTACK(I,ITOS) 182 CONTINUE IF (NUMBER(ISTACK(1,ITOS-1),PIV+1)) THEN VQD(QC,2)=ISTACK(1,ITOS-1) ELSE VQD(QC,2)=-PINSRT(ISTACK(1,ITOS-1),PIV,MAXVP, 1 VPOLY,PVP,IERR) ENDIF VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC ITOS=ITOS-2 PC=PC+2 GO TO 2 ENDIF ENDIF 190 IF (X .EQ. INT) THEN DIM=IICONS(VPFX(PC+1),1) IF (DIM .EQ. 0) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=INT VQD(QC,2)=IICONS(VPFX(PC+1),4) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 1) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=INT ISTACK(1,ITOS)=ISTACK(1,ITOS)+IICONS(VPFX(PC+1),4)-1 IF (NUMBER(ISTACK(1,ITOS),PIV+1)) THEN VQD(QC,2)=ISTACK(1,ITOS) ELSE VQD(QC,2)=-PINSRT(ISTACK(1,ITOS),PIV,MAXVP, 1 VPOLY,PVP,IERR) ENDIF VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC ITOS=ITOS-1 PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 2) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=INT ISTACK(1,ITOS-1)=IICONS(VPFX(PC+1),4)+ 1 (ISTACK(1,ITOS-1)-1)*IICONS(VPFX(PC+1),3)+ 2 ISTACK(1,ITOS)-1 DO 192 I=2,PIV+1 ISTACK(I,ITOS-1)=ISTACK(I,ITOS-1)*IICONS(VPFX(PC+1),3) 1 +ISTACK(I,ITOS) 192 CONTINUE IF (NUMBER(ISTACK(1,ITOS-1),PIV+1)) THEN VQD(QC,2)=ISTACK(1,ITOS-1) ELSE VQD(QC,2)=-PINSRT(ISTACK(1,ITOS-1),PIV,MAXVP, 1 VPOLY,PVP,IERR) ENDIF VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC ITOS=ITOS-2 PC=PC+2 GO TO 2 ENDIF ENDIF 200 IF (X .EQ. VAR) THEN DIM=IVARI(VPFX(PC+1),1) IF (DIM .EQ. 0) THEN XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=IVARI(VPFX(PC+1),3) PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 1) THEN XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF ISTACK(1,ITOS)=ISTACK(1,ITOS)+IVARI(VPFX(PC+1),3)-1 IF (NUMBER(ISTACK(1,ITOS),PIV+1)) THEN XSTACK(XTOS)=ISTACK(1,ITOS) ELSE XSTACK(XTOS)=-PINSRT(ISTACK(1,ITOS),PIV,MAXVP, 1 VPOLY,PVP,IERR) ENDIF ITOS=ITOS-1 PC=PC+2 GO TO 2 ENDIF ENDIF 210 IF (X .EQ. FUNC) THEN DIM=IFUNC(VPFX(PC+1),1) IF (DIM .LE. 0) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=FUNC VQD(QC,2)=IFUNC(VPFX(PC+1),4) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 1) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC,1)=FUNC ISTACK(1,ITOS)=ISTACK(1,ITOS)+IFUNC(VPFX(PC+1),4)-1 IF (NUMBER(ISTACK(1,ITOS),PIV+1)) THEN VQD(QC,2)=ISTACK(1,ITOS) ELSE VQD(QC,2)=-PINSRT(ISTACK(1,ITOS),PIV,MAXVP, 1 VPOLY,PVP,IERR) ENDIF VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC ITOS=ITOS-1 PC=PC+2 GO TO 2 ENDIF ENDIF 220 IF (X .EQ. STDRD) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 DIM=STDTYP(VPFX(PC+1)) IF (DIM .EQ. 0) THEN VQD(QC,1)=STDRD VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 1) THEN VQD(QC,1)=STDRD VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=XSTACK(XTOS) VQD(QC,4)=0 VQD(QC,5)=XC XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 2) THEN VQD(QC,1)=STDRD VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=XSTACK(XTOS-1) VQD(QC,4)=XSTACK(XTOS) VQD(QC,5)=XC XTOS=XTOS-1 XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ENDIF ENDIF 230 IF (X .EQ. EXTERN) THEN EXCALL=.TRUE. QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 DIM=EXTTYP(VPFX(PC+1)) IF (DIM .EQ. 0) THEN VQD(QC,1)=EXTERN VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 1) THEN VQD(QC,1)=EXTERN VQD(QC,2)=VPFX(PC+1) IF (NUMBER(ISTACK(1,ITOS),PIV+1)) THEN VQD(QC,3)=ISTACK(1,ITOS) ELSE VQD(QC,3)=-PINSRT(ISTACK(1,ITOS),PIV,MAXVP, 1 VPOLY,PVP,IERR) ENDIF VQD(QC,4)=0 VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC ITOS=ITOS-1 PC=PC+2 GO TO 2 ELSE IF (DIM .EQ. 2) THEN VQD(QC,1)=EXTERN VQD(QC,2)=VPFX(PC+1) IF (NUMBER(ISTACK(1,ITOS-1),PIV+1)) THEN VQD(QC,3)=ISTACK(1,ITOS-1) ELSE VQD(QC,3)=-PINSRT(ISTACK(1,ITOS-1),PIV,MAXVP, 1 VPOLY,PVP,IERR) ENDIF IF (NUMBER(ISTACK(1,ITOS),PIV+1)) THEN VQD(QC,4)=ISTACK(1,ITOS) ELSE VQD(QC,4)=-PINSRT(ISTACK(1,ITOS),PIV,MAXVP, 1 VPOLY,PVP,IERR) ENDIF VQD(QC,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC ITOS=ITOS-2 PC=PC+2 GO TO 2 ENDIF ENDIF 240 IF (X .EQ. SUM) THEN QC=QC+2 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC-1,1)=SUM+128 VQD(QC-1,2)=0 VQD(QC-1,3)=0 VQD(QC-1,4)=0 VQD(QC-1,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC VQD(QC,1)=SUM VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=IINDEX(VPFX(PC+2),2) VQD(QC,4)=IINDEX(VPFX(PC+2),5) RTOS=RTOS+1 IF (RTOS .GT. RSMDEP) THEN IERR=24 RETURN ENDIF RSTACK(RTOS)=QC PC=PC+3 GO TO 2 ENDIF 250 IF (X .EQ. ENDSUM) THEN QC=QC+2 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC-1,1)=ADD VQD(QC-1,2)=0 VQD(QC-1,3)=XSTACK(XTOS-1) VQD(QC-1,4)=XSTACK(XTOS) VQD(QC-1,5)=XC VQD(QC,1)=ENDSUM VQD(QC,2)=XC-XSTACK(XTOS-1) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=RSTACK(RTOS) VQD(RSTACK(RTOS),5)=QC XC=XC+VQD(QC,2)*(VQD(RSTACK(RTOS),3)-1) XTOS=XTOS-1 XSTACK(XTOS)=XC RTOS=RTOS-1 PC=PC+1 GO TO 2 ENDIF 260 IF (X .EQ. PROD) THEN QC=QC+2 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC-1,1)=PROD+128 VQD(QC-1,2)=0 VQD(QC-1,3)=0 VQD(QC-1,4)=0 VQD(QC-1,5)=XC XTOS=XTOS+1 IF (XTOS .GT. XSMDEP) THEN IERR=24 RETURN ENDIF XSTACK(XTOS)=XC VQD(QC,1)=PROD VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=IINDEX(VPFX(PC+2),2) VQD(QC,4)=IINDEX(VPFX(PC+2),5) RTOS=RTOS+1 IF (RTOS .GT. RSMDEP) THEN IERR=24 RETURN ENDIF RSTACK(RTOS)=QC PC=PC+3 GO TO 2 ENDIF 270 IF (X .EQ. ENDPRD) THEN QC=QC+2 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF XC=XC+1 VQD(QC-1,1)=MULT VQD(QC-1,2)=0 VQD(QC-1,3)=XSTACK(XTOS-1) VQD(QC-1,4)=XSTACK(XTOS) VQD(QC-1,5)=XC VQD(QC,1)=ENDPRD VQD(QC,2)=XC-XSTACK(XTOS-1) VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=RSTACK(RTOS) VQD(RSTACK(RTOS),5)=QC XC=XC+VQD(QC,2)*(VQD(RSTACK(RTOS),3)-1) XTOS=XTOS-1 XSTACK(XTOS)=XC RTOS=RTOS-1 PC=PC+1 GO TO 2 ENDIF 280 IF (X .EQ. RELOP) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF LC=LC+1 VQD(QC,1)=RELOP VQD(QC,2)=VPFX(PC+1) VQD(QC,3)=XSTACK(XTOS-1) VQD(QC,4)=XSTACK(XTOS) VQD(QC,5)=LC LTOS=LTOS+1 IF (LTOS .GT. LSMDEP) THEN IERR=24 RETURN ENDIF LSTACK(LTOS)=LC XTOS=XTOS-2 IF (XC .GT. MAXXC) MAXXC=XC XC=PVVA PC=PC+2 GO TO 2 ENDIF 290 IF (X .EQ. AND) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF LC=LC+1 VQD(QC,1)=AND VQD(QC,2)=0 VQD(QC,3)=LSTACK(LTOS-1) VQD(QC,4)=LSTACK(LTOS) VQD(QC,5)=LC LTOS=LTOS-1 LSTACK(LTOS)=LC PC=PC+1 GO TO 2 ENDIF 300 IF (X .EQ. OR) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF LC=LC+1 VQD(QC,1)=OR VQD(QC,2)=0 VQD(QC,3)=LSTACK(LTOS-1) VQD(QC,4)=LSTACK(LTOS) VQD(QC,5)=LC LTOS=LTOS-1 LSTACK(LTOS)=LC PC=PC+1 GO TO 2 ENDIF 310 IF (X .EQ. NOT) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF LC=LC+1 VQD(QC,1)=NOT VQD(QC,2)=0 VQD(QC,3)=LSTACK(LTOS) VQD(QC,4)=0 VQD(QC,5)=LC LSTACK(LTOS)=LC PC=PC+1 GO TO 2 ENDIF 320 IF (X .EQ. BEQ) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF VQD(QC,1)=BEQ VQD(QC,2)=0 VQD(QC,3)=LSTACK(LTOS) VQD(QC,4)=0 VQD(QC,5)=0 LTOS=LTOS-1 IF (LC .GT. MAXLC) MAXLC=LC LC=0 PC=PC+2 GO TO 2 ENDIF 330 IF (X .EQ. BRA) THEN QC=QC+2 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF VQD(QC-1,1)=BRA VQD(QC-1,2)=0 VQD(QC-1,3)=0 VQD(QC-1,4)=0 VQD(QC-1,5)=0 VQD(QC,1)=LABEL VQD(QC,2)=QC VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=0 PC=PC+2 GO TO 2 ENDIF 340 IF (X .EQ. CONTIN) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF VQD(QC,1)=CONTIN VQD(QC,2)=0 VQD(QC,3)=VPFX(PC+1) VQD(QC,4)=0 VQD(QC,5)=0 PC=PC+2 GO TO 2 ENDIF 350 IF (X .EQ. GOTO) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF VQD(QC,1)=GOTO VQD(QC,2)=0 VQD(QC,3)=VPFX(PC+1) VQD(QC,4)=0 VQD(QC,5)=0 PC=PC+3 GO TO 2 ENDIF 360 IF (X .EQ. ASSIGN) THEN IF (IFUNC(VPFX(PC+1),1) .LE. 0) THEN QC=QC+2 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF VQD(QC-1,1)=ASSIGN VQD(QC-1,2)=IFUNC(VPFX(PC+1),4) VQD(QC-1,3)=XSTACK(XTOS) VQD(QC-1,4)=0 VQD(QC-1,5)=0 XTOS=XTOS-1 IF (XC .GT. MAXXC) MAXXC=XC XC=PVVA VQD(QC,1)=LABEL VQD(QC,2)=QC VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=0 PC=PC+2 GO TO 2 ELSE QC=QC+2 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF VQD(QC-1,1)=ASSIGN ITOS=ITOS+1 IF (ITOS .GT. ISMDEP) THEN IERR=24 RETURN ENDIF DO 361 I=2,PIV+1 ISTACK(I,ITOS)=0 361 CONTINUE ISTACK(1,ITOS)=IFUNC(VPFX(PC+1),4)-1 ISTACK(IFUNC(VPFX(PC+1),2)+1,ITOS)=1 VQD(QC-1,2)=-PINSRT(ISTACK(1,ITOS),PIV,MAXVP,VPOLY,PVP,IERR) ITOS=ITOS-1 VQD(QC-1,3)=XSTACK(XTOS) VQD(QC-1,4)=0 VQD(QC-1,5)=0 XTOS=XTOS-1 IF (XC .GT. MAXXC) MAXXC=XC XC=PVVA VQD(QC,1)=LABEL VQD(QC,2)=QC VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=0 PC=PC+2 GO TO 2 ENDIF ENDIF 365 IF (X .EQ. -ASSIGN) THEN IERR=27 RETURN ENDIF 370 IF (X .EQ. IF+128) THEN RTOS=RTOS+1 IF (RTOS .GT. RSMDEP) THEN IERR=24 RETURN ENDIF RSTACK(RTOS)=QC+1 PC=PC+1 GO TO 2 ENDIF 380 IF (X .EQ. ENDIF+128) THEN QC=QC+1 IF (QC .GT. MAXVQD) THEN IERR=32 RETURN ENDIF VQD(QC,1)=LABEL VQD(QC,2)=QC VQD(QC,3)=0 VQD(QC,4)=0 VQD(QC,5)=0 QC1=RSTACK(RTOS) RTOS=RTOS-1 381 IF ((VQD(QC1,1) .NE. BEQ) .AND. (QC1 .LT. QC)) THEN QC1=QC1+1 GO TO 381 ENDIF QC2=QC1+1 382 IF ((VQD(QC2,1) .NE. BRA) .AND. (QC2 .LT. QC)) THEN QC2=QC2+1 GO TO 382 ENDIF IF (QC2 .LT. QC) THEN VQD(QC1,2)=QC2+1 VQD(QC2,2)=QC QC1=QC1+1 GO TO 381 ELSE IF (VQD(QC1,1) .EQ. BEQ) VQD(QC1,2)=QC PC=PC+1 GO TO 2 ENDIF ENDIF C IERR=26 WRITE(*,*) 'REVCDE (4866) : unknown token ',X RETURN END C C C SUBROUTINE FORCDE (XFIL,PVIS,PVIC,PVRC,PVVA,PIFN,PXFN,PVFN,PIV, 1 VINDEX,VICONS,VRCONS,MAXVP,VPOLY,PVP,MAXVQD, 2 VQD,MAXXC,MAXLC,EXCALL,IERR) INTEGER XFIL INTEGER PVIS,PVIC,PVRC,PVVA,PIFN,PXFN,PVFN,PIV INTEGER VINDEX(PVIS),VICONS(PVIC) DOUBLE PRECISION VRCONS(PVRC) INTEGER MAXVP,MAXVQD INTEGER VPOLY(PIV+1,MAXVP),VQD(MAXVQD,5) INTEGER PVP INTEGER MAXXC,MAXLC LOGICAL EXCALL INTEGER IERR C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C INTEGER MAXSTD,MAXEXT PARAMETER (MAXSTD=17,MAXEXT=1) C CHARACTER*6 STDNAM(MAXSTD) INTEGER STDTYP(MAXSTD),EXTTYP(MAXEXT) INTEGER STDLEN(MAXSTD) CHARACTER*4 RELNAM(6) C INTEGER FUNMOD,GRAMOD PARAMETER (FUNMOD=0,GRAMOD=1) C INTEGER I,K,MODE INTEGER AQC,FC,QC,X INTEGER DIM,EXT C INTEGER OFS C CHARACTER*30 S1,S2,S3,S4,S5 INTEGER SLEN1,SLEN2,SLEN3,SLEN4,SLEN5 C DATA STDNAM /'DABS','DSQRT','DEXP','DLOG','DLOG10', 1 'DSIN','DCOS','DTAN','DASIN','DACOS','DATAN', 2 'DSINH','DCOSH','DTANH','DASINH','DACOSH','DATANH'/ DATA STDTYP /1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1/ DATA STDLEN /4,5,4,4,6,4,4,4,5,5,5,5,5,5,6,6,6/ DATA EXTTYP /0/ DATA RELNAM /'.EQ.','.NE.','.LT.','.LE.','.GT.','.GE.'/ C OFS=0 MODE=FUNMOD 2 IF (MODE .EQ. FUNMOD) THEN WRITE(XFIL,'(A)') 'C*********************************' WRITE(XFIL,'(A)') 'C' WRITE(XFIL,'(A)') 'C P C O M P (Version 3.1)' WRITE(XFIL,'(A)') 'C' WRITE(XFIL,'(A)') 'C*********************************' WRITE(XFIL,'(A)') 'C' WRITE(XFIL,'(6X,A)') 'SUBROUTINE XFUN (X,N,F,M,ACTIVE,IERR)' WRITE(XFIL,'(6X,A)') 'INTEGER N,M' WRITE(XFIL,'(6X,A)') 'DOUBLE PRECISION X(N),F(M)' WRITE(XFIL,'(6X,A)') 'LOGICAL ACTIVE(M)' WRITE(XFIL,'(6X,A)') 'INTEGER IERR' WRITE(XFIL,'(A)') 'C' C IF (MAXXC .GT. PVVA) THEN CALL ITOA(PVVA+1,S1,SLEN1) CALL ITOA(MAXXC,S2,SLEN2) WRITE(XFIL,'(6X,A)') 'DOUBLE PRECISION XAUX('//S1(1:SLEN1)// 1 ':'//S2(1:SLEN2)//')' ENDIF C IF (PXFN .LT. PIFN) THEN CALL ITOA(PVFN-(PIFN-PXFN)+1,S1,SLEN1) CALL ITOA(PVFN,S2,SLEN2) WRITE(XFIL,'(6X,A)') 'DOUBLE PRECISION VFUNC('//S1(1:SLEN1)// 1 ':'//S2(1:SLEN2)//')' ENDIF ELSE WRITE(XFIL,'(A)') 'C' WRITE(XFIL,'(A)') 'C' WRITE(XFIL,'(A)') 'C' WRITE(XFIL,'(6X,A)') 1 'SUBROUTINE XGRA (X,N,F,M,DF,MMAX,ACTIVE,IERR)' WRITE(XFIL,'(6X,A)') 'INTEGER N,M,MMAX' WRITE(XFIL,'(6X,A)') 'DOUBLE PRECISION X(N),F(M),DF(MMAX,N)' WRITE(XFIL,'(6X,A)') 'LOGICAL ACTIVE(M)' WRITE(XFIL,'(6X,A)') 'INTEGER IERR' WRITE(XFIL,'(A)') 'C' C IF (MAXXC .GT. PVVA) THEN CALL ITOA(PVVA+1,S1,SLEN1) CALL ITOA(MAXXC,S2,SLEN2) WRITE(XFIL,'(6X,A)') 'DOUBLE PRECISION XAUX('//S1(1:SLEN1)// 1 ':'//S2(1:SLEN2)//'),YAUX('//S1(1:SLEN1)// 2 ':'//S2(1:SLEN2)//')' ENDIF IF (EXCALL) THEN CALL ITOA(PVVA,S1,SLEN1) WRITE(XFIL,'(6X,A)') 'DOUBLE PRECISION Z(1:'//S1(1:SLEN1)//')' ENDIF C IF (PXFN .LT. PIFN) THEN CALL ITOA(PVFN-(PIFN-PXFN)+1,S1,SLEN1) CALL ITOA(PVFN,S2,SLEN2) CALL ITOA(PVVA,S3,SLEN3) WRITE(XFIL,'(6X,A)') 'DOUBLE PRECISION VFUNC('//S1(1:SLEN1)// 1 ':'//S2(1:SLEN2)//'),VGRAD('//S1(1:SLEN1)// 2 ':'//S2(1:SLEN2)//','//S3(1:SLEN3)//')' ENDIF ENDIF C IF (MAXLC .GT. 0) THEN CALL ITOA(MAXLC,S1,SLEN1) WRITE(XFIL,'(6X,A)') 'LOGICAL LAUX(1:'//S1(1:SLEN1)//')' ENDIF IF (EXCALL) WRITE(XFIL,'(6X,A)') 'INTEGER EXTPAR(2)' C--------------------------------------------------------------- DO 10 I=0,PIV-1 CALL ITOA(I,S1,SLEN1) WRITE(XFIL,'(6X,A)') 'INTEGER I'//S1(1:SLEN1)//',IX'// 1 S1(1:SLEN1) 10 CONTINUE C IF (MODE .EQ. GRAMOD) WRITE(XFIL,'(6X,A)') 'INTEGER I' C--------------------------------------------------------------- WRITE(XFIL,'(6X,A)') 'INTEGER I,OFS' WRITE(XFIL,'(A)') 'C' C CALL ITOA(PVRC,S3,SLEN3) IF (PVIS .GT. 0) THEN CALL ITOA(PVIS,S1,SLEN1) WRITE(XFIL,'(6X,A)') 'INTEGER VINDEX('//S1(1:SLEN1)//')' ENDIF IF (PVIC .GT. 0) THEN CALL ITOA(PVIC,S1,SLEN1) WRITE(XFIL,'(6X,A)') 'INTEGER VICONS('//S1(1:SLEN1)//')' ENDIF IF (PVRC .GT. 0) THEN CALL ITOA(PVRC,S1,SLEN1) WRITE(XFIL,'(6X,A)') 'DOUBLE PRECISION VRCONS('// 1 S1(1:SLEN1)//')' ENDIF IF (PVIS .GT. 0) CALL IDATA(XFIL,VINDEX,PVIS,'VINDEX') IF (PVIC .GT. 0) CALL IDATA(XFIL,VICONS,PVIC,'VICONS') IF (PVRC .GT. 0) CALL FDATA(XFIL,VRCONS,PVRC,'VRCONS') WRITE(XFIL,'(A)') 'C' C CALL ITOA(PVVA,S1,SLEN1) CALL ITOA(PVFN-(PIFN-PXFN),S2,SLEN2) WRITE(XFIL,'(6X,A)') 'IF (N .NE. '//S1(1:SLEN1)//') THEN' WRITE(XFIL,'(6X,A)') 'IERR=43' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') 'IF (M .NE. '//S2(1:SLEN2)//') THEN' WRITE(XFIL,'(6X,A)') 'IERR=44' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') 'OFS=0' C---------------------------------------------------------------- K=1 QC=1 C---------------------------------------------------------------- 100 X=VQD(QC,1) C IF (X .EQ. ACTIVE) THEN IF (VQD(QC,2) .GE. 0) THEN CALL ITOA(VQD(QC,2),S1,SLEN1) ELSE CALL MAKEP(VPOLY(1,-VQD(QC,2)),PIV+1,S1,SLEN1) ENDIF WRITE(XFIL,'(6X,A)') 'IF (ACTIVE('//S1(1:SLEN1)//')) THEN' QC=QC+1 GO TO 100 C ELSE IF (X .EQ. -1) THEN WRITE(XFIL,'(6X,A)') 'ENDIF' C---------------------------------------------------------------- IF (VQD(QC,2) .GT. 0) THEN WRITE(XFIL,'(I5,1X,A)') VQD(QC,2),'CONTINUE' ENDIF C---------------------------------------------------------------- K=K+1 IF (K .LE. PXFN) THEN QC=QC+1 GO TO 100 ELSE WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'END' IF (MODE .EQ. FUNMOD) THEN MODE=GRAMOD GO TO 2 ELSE RETURN ENDIF ENDIF C ELSE IF (X .EQ. ADD) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'+'//S3(1:SLEN3) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. SUB) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'-'//S3(1:SLEN3) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. MULT) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'*'//S3(1:SLEN3) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. DIV) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF ('//S3(1:SLEN3)//' .EQ. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=9' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'/'//S3(1:SLEN3) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. POWER) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF ('//S2(1:SLEN2)//' .LE. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=9' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'**'//S3(1:SLEN3) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. POWER+128) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL ITOA(VQD(QC,2),S3,SLEN3) IF (VQD(QC,2) .LT. 0) THEN WRITE(XFIL,'(6X,A)') 'IF ('//S2(1:SLEN2) 1 //' .EQ. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=9' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' ENDIF WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'**'//'('//S3(1:SLEN3)//')' QC=QC+1 GO TO 100 C ELSE IF (X .EQ. UMINUS) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 '-'//S2(1:SLEN2) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. RNUM) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL FTOA(VRCONS(VQD(QC,2)),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. REAL) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) IF (VQD(QC,2) .GE. 0) THEN CALL ITOA(VQD(QC,2),S2,SLEN2) ELSE CALL MAKEP(VPOLY(1,-VQD(QC,2)),PIV+1,S2,SLEN2) ENDIF WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=VRCONS('// 1 S2(1:SLEN2)//')' QC=QC+1 GO TO 100 C ELSE IF (X .EQ. INUM) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL ITOA(VICONS(VQD(QC,2)),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=DBLE('// 1 S2(1:SLEN2)//')' QC=QC+1 GO TO 100 C ELSE IF (X .EQ. INT) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) IF (VQD(QC,2) .GE. 0) THEN CALL ITOA(VQD(QC,2),S2,SLEN2) ELSE CALL MAKEP(VPOLY(1,-VQD(QC,2)),PIV+1,S2,SLEN2) ENDIF WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=DBLE(VICONS('// 1 S2(1:SLEN2)//'))' QC=QC+1 GO TO 100 C ELSE IF (X .EQ. INDVAR) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL ITOA(VQD(QC,2)-1,S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=DBLE(IX'// 1 S2(1:SLEN2)//')' QC=QC+1 GO TO 100 C ELSE IF (X .EQ. FUNC) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) CALL MAKEF(PIFN,PXFN,PVFN,PIV,PVP,VPOLY,VQD(QC,2),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. STDRD) THEN DIM=STDTYP(VQD(QC,2)) C IF (DIM .EQ. 0) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) S2=STDNAM(VQD(QC,2)) SLEN2=STDLEN(VQD(QC,2)) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2) C ELSE IF (DIM .EQ. 1) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) S2=STDNAM(VQD(QC,2)) SLEN2=STDLEN(VQD(QC,2)) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S3,SLEN3) C---------------------------------------------------------------------- IF (VQD(QC,2) .EQ. 2) THEN WRITE(XFIL,'(6X,A)') 'IF ('//S3(1:SLEN3) 1 //' .LT. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=53' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' C ELSE IF ((VQD(QC,2) .EQ. 4) .OR. (VQD(QC,2) .EQ. 5)) THEN WRITE(XFIL,'(6X,A)') 'IF ('//S3(1:SLEN3) 1 //' .LE. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=52' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' C ELSE IF (VQD(QC,2) .EQ. 9) THEN WRITE(XFIL,'(6X,A)') 'IF (DABS('//S3(1:SLEN3)// 1 ') .GT. 1.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR = 54' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' C ELSE IF(VQD(QC,2) .EQ. 10) THEN WRITE(XFIL,'(6X,A)') 'IF (DABS('//S3(1:SLEN3)// 1 ') .GT. 1.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR = 55' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' C ELSE IF(VQD(QC,2) .EQ. 16) THEN WRITE(XFIL,'(6X,A)') 'IF ('//S3(1:SLEN3)// 1 ' .LT. 1.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR = 56' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' C ELSE IF(VQD(QC,2) .EQ. 17) THEN WRITE(XFIL,'(6X,A)') 'IF (DABS('//S3(1:SLEN3)// 1 ') .GE. 1.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR = 51' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' ENDIF C---------------------------------------------------------------------- WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'('//S3(1:SLEN3)//')' C ELSE IF (DIM .EQ. 2) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) S2=STDNAM(VQD(QC,2)) SLEN2=STDLEN(VQD(QC,2)) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S3,SLEN3) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S4,SLEN4) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'('//S3(1:SLEN3)// 2 ','//S4(1:SLEN4)//')' C ELSE IERR=26 WRITE(*,*) ' FORCDE (5149) : illegal dimension ',DIM RETURN ENDIF QC=QC+1 GO TO 100 C ELSE IF (X .EQ. EXTERN) THEN EXT=VQD(QC,2) IF (EXTTYP(EXT) .EQ. 1) THEN IF (VQD(QC,3) .GE. 0) THEN CALL ITOA(VQD(QC,3),S1,SLEN1) ELSE CALL MAKEP(VPOLY(1,-VQD(QC,3)),PIV+1,S1,SLEN1) ENDIF WRITE(XFIL,'(6X,A)') 'EXTPAR(1)='//S1(1:SLEN1) ELSE IF (EXTTYP(EXT) .EQ. 2) THEN IF (VQD(QC,3) .GE. 0) THEN CALL ITOA(VQD(QC,3),S1,SLEN1) ELSE CALL MAKEP(VPOLY(1,-VQD(QC,3)),PIV+1,S1,SLEN1) ENDIF IF (VQD(QC,4) .GE. 0) THEN CALL ITOA(VQD(QC,4),S2,SLEN2) ELSE CALL MAKEP(VPOLY(1,-VQD(QC,4)),PIV+1,S2,SLEN2) ENDIF WRITE(XFIL,'(6X,A)') 'EXTPAR(1)='//S1(1:SLEN1) WRITE(XFIL,'(6X,A)') 'EXTPAR(2)='//S2(1:SLEN2) ENDIF CALL ITOA(EXT,S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S2,SLEN2) WRITE(XFIL,'(6X,A)') 'CALL EXTFUN('//S1(1:SLEN1)//',X,N,' 1 //S2(1:SLEN2)//',EXTPAR)' QC=QC+1 GO TO 100 C ELSE IF (X .EQ. SUM+128) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=0.0D0' QC=QC+1 GO TO 100 C ELSE IF (X .EQ. PROD+128) THEN CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,5),S1,SLEN1) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=1.0D0' QC=QC+1 GO TO 100 C ELSE IF ((X .EQ. SUM) .OR. (X.EQ. PROD) .OR. (X .EQ. VECTOR)) THEN CALL ITOA(VQD(QC,2)-1,S2,SLEN2) CALL ITOA(VQD(QC,3)-1,S3,SLEN3) CALL ITOA(VQD(QC,4),S4,SLEN4) CALL ITOA(VQD(QC,5),S5,SLEN5) C----------------------------------------------------- IF (X .NE. VECTOR) OFS=OFS+1 C----------------------------------------------------- C WRITE(XFIL,'(6X,A)') 'OFS'//S2(1:SLEN2)//'=0' WRITE(XFIL,'(6X,A)') 'DO '//S5(1:SLEN5)//' I'//S2(1:SLEN2)// 1 '=0,'//S3(1:SLEN3) WRITE(XFIL,'(6X,A)') 'IX'//S2(1:SLEN2)//'=VINDEX('// 1 S4(1:SLEN4)//'+I'//S2(1:SLEN2)//')' QC=QC+1 GO TO 100 C ELSE IF ((X .EQ. ENDSUM) .OR. (X .EQ. ENDPRD)) THEN CALL ITOA(VQD(QC,2),S1,SLEN1) CALL ITOA(VQD(QC,2)*VQD(VQD(QC,5),3),S2,SLEN2) C----------------------------------------------------- OFS=OFS-1 C----------------------------------------------------- WRITE(XFIL,'(6X,A)') 'OFS=OFS+'//S1(1:SLEN1) WRITE(XFIL,'(I5,1X,A)') QC,'CONTINUE' WRITE(XFIL,'(6X,A)') 'OFS=OFS-'//S2(1:SLEN2) QC=QC+1 GO TO 100 C---------------------------------------------------------------------- ELSE IF (X .EQ. RELOP) THEN CALL MAKEL(VQD(QC,5),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//RELNAM(VQD(QC,2))//S3(1:SLEN3) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. AND) THEN CALL MAKEL(VQD(QC,5),S1,SLEN1) CALL MAKEL(VQD(QC,3),S2,SLEN2) CALL MAKEL(VQD(QC,4),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'.AND.'//S3(1:SLEN3) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. OR) THEN CALL MAKEL(VQD(QC,5),S1,SLEN1) CALL MAKEL(VQD(QC,3),S2,SLEN2) CALL MAKEL(VQD(QC,4),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 S2(1:SLEN2)//'.OR.'//S3(1:SLEN3) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. NOT) THEN CALL MAKEL(VQD(QC,5),S1,SLEN1) CALL MAKEL(VQD(QC,3),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='// 1 '.NOT.'//S2(1:SLEN2) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. BEQ) THEN CALL MAKEL(VQD(QC,3),S1,SLEN1) CALL ITOA(VQD(QC,2),S2,SLEN2) WRITE(XFIL,'(6X,A)') 'IF (.NOT.'//S1(1:SLEN1)//')'// 1 ' GO TO '//S2(1:SLEN2) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. BRA) THEN CALL ITOA(VQD(QC,2),S1,SLEN1) WRITE(XFIL,'(6X,A)') 'GO TO '//S1(1:SLEN1) QC=QC+1 GO TO 100 C ELSE IF ((X .EQ. IF+128) .OR. (X .EQ. ENDIF+128)) THEN QC=QC+1 GO TO 100 C ELSE IF (X .EQ. CONTIN) THEN WRITE(XFIL,'(1X,I4,1X,A)') VQD(QC,3),'CONTINUE' QC=QC+1 GO TO 100 C ELSE IF (X .EQ. GOTO) THEN CALL ITOA(VQD(QC,3),S1,SLEN1) WRITE(XFIL,'(6X,A)') 'GO TO '//S1(1:SLEN1) QC=QC+1 GO TO 100 C ELSE IF (X .EQ. ASSIGN) THEN CALL MAKEF(PIFN,PXFN,PVFN,PIV,PVP,VPOLY,VQD(QC,2),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S2(1:SLEN2) IF (MODE .EQ. GRAMOD) THEN C CALL ITOA(QC,S1,SLEN1) CALL ITOA(PVVA,S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 VQD(QC,2),1,S3,SLEN3) S3=S3(1:SLEN3-3)//',I)' CALL ITOA(PVVA+1,S4,SLEN4) CALL ITOA(VQD(QC,3)-1,S5,SLEN5) WRITE(XFIL,'(6X,A)') 'DO '//S1(1:SLEN1)//' I=1,'//S2(1:SLEN2) WRITE(XFIL,'(6X,A)') S3(1:SLEN3)//'=0.0D0' WRITE(XFIL,'(I5,1X,A)') QC,'CONTINUE' C IF (PVVA+1 .LT. VQD(QC,3)) THEN CALL ITOA(VQD(QC+1,2),S1,SLEN1) WRITE(XFIL,'(6X,A)') 'DO '//S1(1:SLEN1)//' I=' 1 //S4(1:SLEN4)//','//S5(1:SLEN5) WRITE(XFIL,'(6X,A)') 'YAUX(I)=0.0D0' WRITE(XFIL,'(I5,1X,A)') VQD(QC+1,2),'CONTINUE' ENDIF C CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 VQD(QC,2),VQD(QC,3),S1,SLEN1) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=1.0D0' C AQC=QC FC=VQD(QC,2) QC=QC-1 200 IF (QC .GT. 0) THEN IF (VQD(QC,5) .GT. 0) THEN CALL FORDF (XFIL,PVVA,PIFN,PXFN,PVFN,PIV, 1 MAXVP,VPOLY,PVP,MAXVQD,VQD,QC,FC,OFS,IERR) IF (IERR .NE. 0) RETURN QC=QC-1 GO TO 200 ENDIF ENDIF QC=AQC+1 C ------------------------- ELSE C ------------------------- C no CONTINUE in XFUN C ------------------------- QC=QC+1 C ------------------------- ENDIF QC=QC+1 GO TO 100 C ELSE IF (X .EQ. LABEL) THEN WRITE(XFIL,'(I5,1X,A)') VQD(QC,2),'CONTINUE' QC=QC+1 GO TO 100 C ELSE IERR=26 WRITE(*,*) ' FORCDE (5296) : unknown opcode ',X ENDIF END C C C SUBROUTINE FORDF (XFIL,PVVA,PIFN,PXFN,PVFN,PIV, 1 MAXVP,VPOLY,PVP,MAXVQD,VQD,QC,FC,OFS,IERR) INTEGER XFIL INTEGER PVVA,PIFN,PXFN,PVFN,PIV,PVP INTEGER MAXVP,MAXVQD INTEGER VPOLY(PIV+1,MAXVP),VQD(MAXVQD,5) INTEGER QC,FC,OFS INTEGER IERR C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C INTEGER MAXSTD,MAXEXT PARAMETER (MAXSTD=17,MAXEXT=1) C INTEGER EXTTYP(MAXEXT) C CHARACTER*30 S1,S2,S3,S4,S5,S6 INTEGER SLEN1,SLEN2,SLEN3,SLEN4,SLEN5,SLEN6 C INTEGER EXT,X,Y C DATA EXTTYP /0/ C X=VQD(QC,1) IF (X .EQ. ADD) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=' 1 //S1(1:SLEN1)//'+'//S2(1:SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,4),S1,SLEN1) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=' 1 //S1(1:SLEN1)//'+'//S2(1:SLEN2) RETURN C ELSE IF (X .EQ. SUB) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=' 1 //S1(1:SLEN1)//'+'//S2(1:SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,4),S1,SLEN1) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'=' 1 //S1(1:SLEN1)//'-'//S2(1:SLEN2) RETURN C ELSE IF (X .EQ. MULT) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S2(1:SLEN2)//'*'//S3(1:SLEN3) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,4),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S2(1:SLEN2)//'*'//S3(1:SLEN3) RETURN C ELSE IF (X .EQ. DIV) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S2,SLEN2) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF ('//S3(1:SLEN3)//' .EQ. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=9' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S2(1:SLEN2)//'/'//S3(1:SLEN3) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,4),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S3,SLEN3) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S4,SLEN4) CALL FOLD(XFIL,S1(1:SLEN1)//'='//S1(1:SLEN1)//'-' 1 //S2(1:SLEN2)//'*'//S3(1:SLEN3) 2 //'/'//S4(1:SLEN4)//'**2', 3 2*SLEN1+SLEN2+SLEN3+SLEN4+7,IERR) RETURN C ELSE IF (X .EQ. POWER) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,4),S3,SLEN3) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S4,SLEN4) WRITE(XFIL,'(6X,A)') 'IF ('//S2(1:SLEN2) 1 //' .LE. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=9' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' CALL FOLD(XFIL,S1(1:SLEN1)//'='//S1(1:SLEN1)//'+'//S3(1:SLEN3) 1 //'*'//S2(1:SLEN2)//'**('//S3(1:SLEN3)//'-1.0D0)*' 2 //S4(1:SLEN4),2*SLEN1+SLEN2+2*SLEN3+SLEN4+14,IERR) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,4),S1,SLEN1) CALL FOLD(XFIL,S1(1:SLEN1)//'='//S1(1:SLEN1)//'+'//S2(1:SLEN2) 1 //'**'//S3(1:SLEN3)//'*'//'DLOG('//S2(1:SLEN2) 2 //')*'//S4(1:SLEN4),2*SLEN1+2*SLEN2+SLEN3+SLEN4+12,IERR) RETURN C ELSE IF (X .EQ. POWER+128) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL ITOA(VQD(QC,2),S2,SLEN2) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S3,SLEN3) CALL ITOA(VQD(QC,2)-1,S4,SLEN4) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S5,SLEN5) IF (VQD(QC,2) .GT. 1) THEN WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S2(1:SLEN2)//'*'//S3(1:SLEN3)//'**' 2 //S4(1:SLEN4)//'*'//S5(1:SLEN5) ELSE IF (VQD(QC,2) .EQ. 1) THEN WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S2(1:SLEN2)//'*'//S5(1:SLEN5) ELSE WRITE(XFIL,'(6X,A)') 'IF ('//S3(1:SLEN3) 1 //' .EQ. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=9' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //'('//S2(1:SLEN2)//')'//'*'//S3(1:SLEN3)//'**' 2 //'('//S4(1:SLEN4)//')'//'*'//S5(1:SLEN5) ENDIF RETURN C ELSE IF (X .EQ. UMINUS) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S2,SLEN2) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'-' 1 //S2(1:SLEN2) RETURN C ELSE IF ((X .EQ. RNUM) .OR. (X .EQ. REAL)) THEN RETURN C ELSE IF ((X .EQ. INUM) .OR. (X .EQ. INT)) THEN RETURN C ELSE IF (X .EQ. INDVAR) THEN RETURN C ELSE IF (X .EQ. FUNC) THEN CALL ITOA(QC,S1,SLEN1) CALL ITOA(PVVA,S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,1,S3,SLEN3) S3=S3(1:SLEN3-3)//',I)' CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 VQD(QC,2),1,S4,SLEN4) S4=S4(1:SLEN4-3)//',I)' CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S5,SLEN5) C--------------------------------------------------- IF (S3 .EQ. S4) THEN C IERR=49 RETURN C ENDIF C--------------------------------------------------- ELSE WRITE(XFIL,'(6X,A)') 'DO '//S1(1:SLEN1)//' I=1,'//S2(1:SLEN2) WRITE(XFIL,'(6X,A)') S3(1:SLEN3)//'='//S3(1:SLEN3)//'+' 1 //S4(1:SLEN4)//'*'//S5(1:SLEN5) WRITE(XFIL,'(I5,1X,A)') QC,'CONTINUE' RETURN ENDIF C----------------------------------------------------------------- ELSE IF ((X .EQ. SUM+128) .OR. (X .EQ. PROD+128)) THEN RETURN C ELSE IF ((X .EQ. SUM) .OR. (X .EQ. PROD)) THEN OFS=OFS-1 C CALL ITOA(VQD(VQD(QC,5),2),S2,SLEN2) C WRITE(XFIL,'(6X,A)') 'OFS=OFS-'//S2(1:SLEN2) WRITE(XFIL,'(I5,1X,A)') QC,'CONTINUE' RETURN C ELSE IF ((X .EQ. ENDSUM) .OR. (X .EQ. ENDPRD)) THEN OFS=OFS+1 CALL ITOA(VQD(QC,2)*VQD(VQD(QC,5),3),S1,SLEN1) CALL ITOA(VQD(VQD(QC,5),2)-1,S2,SLEN2) CALL ITOA(VQD(VQD(QC,5),3)-1,S3,SLEN3) CALL ITOA(VQD(VQD(QC,5),4),S4,SLEN4) CALL ITOA(VQD(QC,5),S5,SLEN5) CALL ITOA(VQD(QC,2),S6,SLEN6) WRITE(XFIL,'(6X,A)') 'OFS=OFS+'//S1(1:SLEN1) WRITE(XFIL,'(6X,A)') 'DO '//S5(1:SLEN5)//' I'//S2(1:SLEN2)// 1 '='//S3(1:SLEN3)//',0,-1' WRITE(XFIL,'(6X,A)') 'IX'//S2(1:SLEN2)//'=VINDEX('// 1 S4(1:SLEN4)//'+I'//S2(1:SLEN2)//')' WRITE(XFIL,'(6X,A)') 'OFS=OFS-'//S6(1:SLEN6) RETURN C----------------------------------------------------------------- ELSE IF (X .EQ. STDRD) THEN Y=VQD(QC,2) IF (Y .EQ. 1) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //'DSIGN(1.0D0,'//S2(1:SLEN2)//')*'//S3(1:SLEN3) RETURN ELSE IF (Y .EQ. 2) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF ('//S2(1:SLEN2) 1 //' .LT. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=53' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ELSE IF ('//S2(1:SLEN2) 1 //' .EQ. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=9' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //'0.5D0/DSQRT('//S2(1:SLEN2)//')*'//S3(1:SLEN3) RETURN ELSE IF (Y .EQ. 3) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //'DEXP('//S2(1:SLEN2)//')*'//S3(1:SLEN3) RETURN ELSE IF (Y .EQ. 4) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF ('//S2(1:SLEN2) 1 //' .LE. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=52' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S3(1:SLEN3)//'/'//S2(1:SLEN2) RETURN ELSE IF (Y .EQ. 5) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF ('//S2(1:SLEN2) 1 //' .LE. 0.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR=52' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' CALL FOLD(XFIL,S1(1:SLEN1)//'='//S1(1:SLEN1)//'+'//S3(1:SLEN3) 1 //'/('//S2(1:SLEN2)//'*DLOG(10.0D0))',2*SLEN1+SLEN2 2 +SLEN3+18,IERR) RETURN ELSE IF (Y .EQ. 6) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //'DCOS('//S2(1:SLEN2)//')*'//S3(1:SLEN3) RETURN ELSE IF (Y .EQ. 7) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'-' 1 //'DSIN('//S2(1:SLEN2)//')*'//S3(1:SLEN3) RETURN ELSE IF (Y .EQ. 8) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S3(1:SLEN3)//'/DCOS('//S2(1:SLEN2)//')**2' RETURN ELSE IF (Y .EQ. 9) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF (DABS('//S2(1:SLEN2)// 1 ') .GE. 1.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR = 54' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S3(1:SLEN3)//'/DSQRT(1.0D0-'//S2(1:SLEN2)//'**2)' RETURN ELSE IF (Y .EQ. 10) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF (DABS('//S2(1:SLEN2)// 1 ') .GE. 1.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR = 55' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'-' 1 //S3(1:SLEN3)//'/DSQRT(1.0D0-'//S2(1:SLEN2)//'**2)' RETURN ELSE IF (Y .EQ. 11) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S3(1:SLEN3)//'/(1.0D0+'//S2(1:SLEN2)//'**2)' RETURN ELSE IF (Y .EQ. 12) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //'DCOSH('//S2(1:SLEN2)//')*'//S3(1:SLEN3) RETURN ELSE IF (Y .EQ. 13) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //'DSINH('//S2(1:SLEN2)//')*'//S3(1:SLEN3) RETURN ELSE IF (Y .EQ. 14) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S3(1:SLEN3)//'/DCOSH('//S2(1:SLEN2)//')**2' RETURN ELSE IF (Y .EQ. 15) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S3(1:SLEN3)//'/DSQRT(1.0D0+'//S2(1:SLEN2)//'**2)' RETURN ELSE IF (Y .EQ. 16) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF ('//S2(1:SLEN2)// 1 ' .LE. 1.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR = 56' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S3(1:SLEN3)//'/DSQRT('//S2(1:SLEN2)//'**2-1.0D0)' RETURN ELSE IF (Y .EQ. 17) THEN CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,3),S1,SLEN1) CALL MAKEX(PVVA,PIV,PVP,VPOLY,OFS,VQD(QC,3),S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S3,SLEN3) WRITE(XFIL,'(6X,A)') 'IF (DABS('//S2(1:SLEN2)// 1 ') .GE. 1.0D0) THEN' WRITE(XFIL,'(6X,A)') 'IERR = 51' WRITE(XFIL,'(6X,A)') 'RETURN' WRITE(XFIL,'(6X,A)') 'ENDIF' WRITE(XFIL,'(6X,A)') S1(1:SLEN1)//'='//S1(1:SLEN1)//'+' 1 //S3(1:SLEN3)//'/(1.0D0-'//S2(1:SLEN2)//'**2)' RETURN ELSE IERR=26 WRITE(*,*) ' FORDF (5504) : unknown standard function ',Y RETURN ENDIF C ELSE IF (X .EQ. EXTERN) THEN EXT=VQD(QC,2) IF (EXTTYP(EXT) .EQ. 1) THEN IF (VQD(QC,3) .GE. 0) THEN CALL ITOA(VQD(QC,3),S1,SLEN1) ELSE CALL MAKEP(VPOLY(1,-VQD(QC,3)),PIV+1,S1,SLEN1) ENDIF WRITE(XFIL,'(6X,A)') 'EXTPAR(1)='//S1(1:SLEN1) ELSE IF (EXTTYP(EXT) .EQ. 2) THEN IF (VQD(QC,3) .GE. 0) THEN CALL ITOA(VQD(QC,3),S1,SLEN1) ELSE CALL MAKEP(VPOLY(1,-VQD(QC,3)),PIV+1,S1,SLEN1) ENDIF IF (VQD(QC,4) .GE. 0) THEN CALL ITOA(VQD(QC,4),S2,SLEN2) ELSE CALL MAKEP(VPOLY(1,-VQD(QC,4)),PIV+1,S2,SLEN2) ENDIF WRITE(XFIL,'(6X,A)') 'EXTPAR(1)='//S1(1:SLEN1) WRITE(XFIL,'(6X,A)') 'EXTPAR(2)='//S2(1:SLEN2) ENDIF CALL ITOA(EXT,S1,SLEN1) WRITE(XFIL,'(6X,A)') 'CALL EXTGRA('//S1(1:SLEN1)//', 1 X,N,Z,EXTPAR)' C CALL ITOA(QC,S1,SLEN1) CALL ITOA(PVVA,S2,SLEN2) CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,1,S3,SLEN3) S3=S3(1:SLEN3-3)//',I)' CALL MAKEY(PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 FC,VQD(QC,5),S4,SLEN4) WRITE(XFIL,'(6X,A)') 'DO '//S1(1:SLEN1)//' I=1,'//S2(1:SLEN2) WRITE(XFIL,'(6X,A)') S3(1:SLEN3)//'='//S3(1:SLEN3)//'+Z(I)*' 1 //S4(1:SLEN4) WRITE(XFIL,'(I5,1X,A)') QC,'CONTINUE' RETURN C ELSE IF ((X .EQ. VECTOR) .OR. (X .EQ. ACTIVE)) THEN RETURN C ENDIF IERR=26 WRITE(*,*) ' FORDF (5535) : unknown opcode ',X RETURN END C C C SUBROUTINE MAKEF (PIFN,PXFN,PVFN,PIV,PVP,VPOLY,I,STRING,STRLEN) INTEGER PIFN,PXFN,PVFN,PIV,PVP,I INTEGER VPOLY(PIV+1,PVP) CHARACTER*(*) STRING INTEGER STRLEN C CHARACTER*10 S INTEGER SLEN C IF (I .GE. 0) THEN CALL ITOA(I,S,SLEN) ELSE CALL MAKEP(VPOLY(1,-I),PIV+1,S,SLEN) ENDIF IF (I .LE. PVFN-(PIFN-PXFN)) THEN STRING='F('//S(1:SLEN)//')' STRLEN=2+SLEN+1 ELSE STRING='VFUNC('//S(1:SLEN)//')' STRLEN=6+SLEN+1 ENDIF RETURN END C C C SUBROUTINE MAKEL (I,STRING,STRLEN) INTEGER I CHARACTER*(*) STRING INTEGER STRLEN C CHARACTER*10 S INTEGER SLEN C CALL ITOA(I,S,SLEN) STRING='LAUX('//S(1:SLEN)//')' STRLEN=5+SLEN+1 RETURN END C C C SUBROUTINE MAKEX (PVVA,PIV,PVP,VPOLY,OFS,I,STRING,STRLEN) INTEGER PVVA,PIV,PVP,I,OFS INTEGER VPOLY(PIV+1,PVP) CHARACTER*(*) STRING INTEGER STRLEN C CHARACTER*20 S INTEGER SLEN C IF (I .GE. 0) THEN CALL ITOA(I,S,SLEN) ELSE CALL MAKEP(VPOLY(1,-I),PIV+1,S,SLEN) ENDIF IF (I .LE. PVVA) THEN STRING='X('//S(1:SLEN)//')' STRLEN=2+SLEN+1 ELSE IF (OFS .GT. 0) THEN S=S(1:SLEN)//'+OFS' SLEN=SLEN+4 ENDIF STRING='XAUX('//S(1:SLEN)//')' STRLEN=5+SLEN+1 ENDIF RETURN END C C C SUBROUTINE MAKEY (PIFN,PXFN,PVFN,PVVA,PIV,PVP,VPOLY,OFS, 1 I,J,STRING,STRLEN) INTEGER PIFN,PXFN,PVFN,PVVA,PIV,PVP,OFS,I,J INTEGER VPOLY(PIV+1,PVP) CHARACTER*(*) STRING INTEGER STRLEN C CHARACTER*20 S1,S2 INTEGER SLEN1,SLEN2 C IF (I .GE. 0) THEN CALL ITOA(I,S1,SLEN1) ELSE CALL MAKEP(VPOLY(1,-I),PIV+1,S1,SLEN1) ENDIF IF (J .GE. 0) THEN CALL ITOA(J,S2,SLEN2) ELSE CALL MAKEP(VPOLY(1,-J),PIV+1,S2,SLEN2) ENDIF IF (J .GT. PVVA) THEN IF (OFS .GT. 0) THEN S2=S2(1:SLEN2)//'+OFS' SLEN2=SLEN2+4 ENDIF STRING='YAUX('//S2(1:SLEN2)//')' STRLEN=5+SLEN2+1 ELSE IF (I .LE. PVFN-(PIFN-PXFN)) THEN STRING='DF('//S1(1:SLEN1)//','//S2(1:SLEN2)//')' STRLEN=3+SLEN1+1+SLEN2+1 ELSE STRING='VGRAD('//S1(1:SLEN1)//','//S2(1:SLEN2)//')' STRLEN=6+SLEN1+1+SLEN2+1 ENDIF RETURN END C C C SUBROUTINE FTOA (X,S,SLEN) DOUBLE PRECISION X CHARACTER*24 S INTEGER SLEN C INTEGER I C WRITE(S,'(D24.17)',ERR=11) X DO 10 I=1,24 IF (S(I:I) .NE. ' ') THEN S=S(I:24) SLEN=24-I+1 RETURN ENDIF 10 CONTINUE 11 CONTINUE SLEN=24 RETURN END C C C SUBROUTINE ITOA (N,S,SLEN) INTEGER N CHARACTER*10 S INTEGER SLEN C INTEGER I C WRITE(S,'(I10)',ERR=11) N DO 10 I=1,10 IF (S(I:I) .NE. ' ') THEN S=S(I:10) SLEN=10-I+1 RETURN ENDIF 10 CONTINUE 11 CONTINUE SLEN=10 RETURN END C C C SUBROUTINE MAKEP (P,N,STRING,STRLEN) INTEGER N INTEGER P(N) CHARACTER*(*) STRING INTEGER STRLEN C CHARACTER*10 S INTEGER SLEN INTEGER I C STRING=' ' STRLEN=0 IF (P(1) .NE. 0) CALL ITOA(P(1),STRING,STRLEN) DO 100 I=2,N IF (P(I) .NE. 0) THEN IF (P(I) .GT. 0) THEN IF (STRLEN .GT. 0) CALL STRCT(STRING,STRLEN,'+',1) ELSE CALL STRCT(STRING,STRLEN,'-',1) ENDIF IF (IABS(P(I)) .NE. 1) THEN CALL ITOA(IABS(P(I)),S,SLEN) CALL STRCT(STRING,STRLEN,S(1:SLEN)//'*',SLEN+1) ENDIF CALL ITOA(I-2,S,SLEN) CALL STRCT(STRING,STRLEN,'IX'//S(1:SLEN),2+SLEN) ENDIF 100 CONTINUE RETURN END C C C SUBROUTINE STRCT (S1,SLEN1,S2,SLEN2) CHARACTER*(*) S1,S2 INTEGER SLEN1,SLEN2 C IF (SLEN1 .EQ. 0) THEN S1=S2(1:SLEN2) SLEN1=SLEN2 ELSE S1=S1(1:SLEN1)//S2(1:SLEN2) SLEN1=SLEN1+SLEN2 ENDIF RETURN END C C C INTEGER FUNCTION PINSRT (P,MAXIV,MAXVP,VPOLY,PVP,IERR) INTEGER MAXIV,MAXVP INTEGER P(MAXIV+1),VPOLY(MAXIV+1,MAXVP) INTEGER PVP,IERR C INTEGER I,J C IF (PVP .GT. 0) THEN DO 20 I=1,PVP DO 10 J=1,MAXIV+1 IF (P(J) .NE. VPOLY(J,I)) GO TO 20 10 CONTINUE PINSRT=I RETURN 20 CONTINUE ENDIF PVP=PVP+1 IF (PVP .GT. MAXVP) THEN IERR=32 RETURN ENDIF DO 30 J=1,MAXIV+1 VPOLY(J,PVP)=P(J) 30 CONTINUE PINSRT=PVP RETURN END C C C LOGICAL FUNCTION NUMBER (P,N) INTEGER N INTEGER P(N) C INTEGER I C NUMBER=.TRUE. DO 10 I=2,N IF (P(I) .NE. 0) NUMBER=.FALSE. 10 CONTINUE RETURN END C C C SUBROUTINE IDATA (XFIL,V,N,ID) INTEGER XFIL,N INTEGER V(N) CHARACTER*6 ID C INTEGER FIRST,LAST,COUNT,ROW,COL CHARACTER*80 STRING,S1,S2 INTEGER STRLEN,SLEN1,SLEN2 C CHARACTER CONT(10) DATA CONT /'1','2','3','4','5','6','7','8','9','O'/ C FIRST=1 10 IF (N .LT. FIRST+49) THEN LAST=N ELSE LAST=FIRST+49 ENDIF CALL ITOA(FIRST,S1,SLEN1) CALL ITOA(LAST,S2,SLEN2) WRITE(XFIL,'(6X,A)') 'DATA ('//ID//'(I), I='//S1(1:SLEN1)// 1 ','//S2(1:SLEN2)//')' COUNT=FIRST ROW=1 COL=1 STRING='/' STRLEN=1 20 CALL ITOA(V(COUNT),S1,SLEN1) CALL STRCT(STRING,STRLEN,S1,SLEN1) IF (COUNT .EQ. LAST) THEN CALL STRCT(STRING,STRLEN,'/',1) ELSE CALL STRCT(STRING,STRLEN,',',1) ENDIF IF ((COUNT .EQ. LAST) .OR. (COL .EQ. 5)) THEN WRITE(XFIL,'(5X,A,5X,A)') CONT(ROW),STRING(1:STRLEN) STRING=' ' STRLEN=1 ROW=ROW+1 COL=1 ELSE COL=COL+1 ENDIF COUNT=COUNT+1 IF (COUNT .LE. LAST) GO TO 20 IF (LAST .LT. N) THEN FIRST=LAST+1 GO TO 10 ENDIF RETURN END C C C SUBROUTINE FDATA (XFIL,V,N,ID) INTEGER XFIL,N DOUBLE PRECISION V(N) CHARACTER*6 ID C INTEGER FIRST,LAST,COUNT,ROW,COL CHARACTER*80 STRING,S1,S2 INTEGER STRLEN,SLEN1,SLEN2 C CHARACTER CONT(10) DATA CONT /'1','2','3','4','5','6','7','8','9','O'/ C FIRST=1 10 IF (N .LT. FIRST+19) THEN LAST=N ELSE LAST=FIRST+19 ENDIF CALL ITOA(FIRST,S1,SLEN1) CALL ITOA(LAST,S2,SLEN2) WRITE(XFIL,'(6X,A)') 'DATA ('//ID//'(I), I='//S1(1:SLEN1)// 1 ','//S2(1:SLEN2)//')' COUNT=FIRST ROW=1 COL=1 STRING='/' STRLEN=1 20 CALL FTOA(V(COUNT),S1,SLEN1) CALL STRCT(STRING,STRLEN,S1,SLEN1) IF (COUNT .EQ. LAST) THEN CALL STRCT(STRING,STRLEN,'/',1) ELSE CALL STRCT(STRING,STRLEN,',',1) ENDIF IF ((COUNT .EQ. LAST) .OR. (COL .EQ. 2)) THEN WRITE(XFIL,'(5X,A,5X,A)') CONT(ROW),STRING(1:STRLEN) STRING=' ' STRLEN=1 ROW=ROW+1 COL=1 ELSE COL=COL+1 ENDIF COUNT=COUNT+1 IF (COUNT .LE. LAST) GO TO 20 IF (LAST .LT. N) THEN FIRST=LAST+1 GO TO 10 ENDIF RETURN END C C C SUBROUTINE FOLD (XFIL,STRING,STRLEN,IERR) CHARACTER*(*) STRING INTEGER XFIL,STRLEN,IERR C INTEGER BRACE,BREAK,CLEN,WIDTH CHARACTER CONT*4,X,STR*80 LOGICAL SEP INTEGER I C SEP(X)=((X .EQ. '+') .OR. (X .EQ. '-') .OR. (X .EQ. '*') .OR. 1 (X .EQ. '/') .OR. (X .EQ. '=')) C WIDTH=56 CONT=' ' CLEN=1 1 IF (STRLEN .LE. WIDTH) THEN STR(1:STRLEN)=STRING(1:STRLEN) WRITE(XFIL,'(5X,A)') CONT(1:CLEN)//STR(1:STRLEN) ELSE BRACE=0 BREAK=0 DO 10 I=1,WIDTH IF (STRING(I:I) .EQ. '(') BRACE=BRACE+1 IF (STRING(I:I) .EQ. ')') BRACE=BRACE-1 IF (SEP(STRING(I:I)) .AND. (BRACE .EQ. 0)) BREAK=I 10 CONTINUE IF (BREAK .EQ. 0) THEN IERR=46 RETURN ENDIF STR(1:BREAK)=STRING(1:BREAK) WRITE(XFIL,'(5X,A)') CONT(1:CLEN)//STR(1:BREAK) WIDTH=53 CONT='/ ' CLEN=4 STRING=STRING(BREAK+1:STRLEN) STRLEN=STRLEN-BREAK IF (STRLEN .GT. 0) GO TO 1 ENDIF RETURN END C*** pcomp_p1.f C********************************************* C * C PROGRAM : PCOMP * C MODULE : PL (LARGE COMPILER) * C ABSTRACT : FORTRAN PRECOMPILER * C KEY WORD : AUTOMATIC DIFFERENTIATION * C SOURCE : PCOMP 2.3 by M.LIEPELT * C COPYRIGHT : M.DOBMANN, K.SCHITTKOWSKI * C MATHEMATISCHES INSTITUT, * C UNIVERSITAET BAYREUTH, * C D-8580 BAYREUTH, GERMANY * C DATE : SEPTEMBER 1, 1993 * C VERSION : 3.1 * C * C********************************************* C C C SUBROUTINE YYPAR (INPUT,WA,LWA,IWA,LIWA,PLWA,PLIWA,IERR,LNUM) C INTEGER INPUT INTEGER LWA,LIWA,PLWA,PLIWA,IERR,LNUM INTEGER IWA(LIWA) DOUBLE PRECISION WA(LWA) C INTEGER INFOLI(14) INTEGER VEK3(3),VEK4(4),VEK5(5),VEK6(6) INTEGER IHELP1,IHELP2,IHELP3,IHELP4,IHELP5 INTEGER MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA,MPIFN INTEGER MPVFN,MPVPF,MPIV C C IN DIESER AUFTEILUNG UNNOETIG C INTEGER IHELP6,IHELP7,IHELP8,IHELP9,S16 C C DOUBLE PRECISION HELP4,HELP6 INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) INTEGER YYEXCA(0:17),YYACT(0:468),YYPACT(0:331),YYPGO(0:44) INTEGER YYR1(0:113),YYR2(0:113),YYCHK(0:331),YYDEF(0:331) C INTEGER YYMDEP,YYERRC,YYNPRO,YYLAST,YYFLAG,YYACPT INTEGER YYABRT PARAMETER (YYMDEP=150,YYERRC=256,YYNPRO=114) PARAMETER (YYLAST=469,YYFLAG=-3000,YYACPT=0,YYABRT=31) C INTEGER YYV(0:YYMDEP-1),YYS(0:YYMDEP-1) INTEGER YYPV,YYPS,YYSTAT,YYTMP,YYNERR,YYERRF,YYCHAR INTEGER YYPVT,YYXPV,YYXPS,YYXSTA,YYXN,YYVAL,YYXI,YYXLEN C INTEGER S1,S2,S3,S4,S5,S6,S7,S8,S9,S10 INTEGER S12,S14 INTEGER PC,PC1,PC2 C INTEGER IVAL DOUBLE PRECISION FVAL INTEGER I,J,YYLEX C CHARACTER STAR*5,CONT*1,LINE*66 INTEGER LPOS,SPOS LOGICAL EOF C INTEGER MAXSYM PARAMETER (MAXSYM=100) INTEGER YYLVAL CHARACTER*6 SYMNAM(MAXSYM) INTEGER SYMTYP(MAXSYM),SYMREF(MAXSYM),SYMEND C INTEGER MAXSTD,MAXEXT PARAMETER (MAXSTD=17,MAXEXT=1) INTEGER STDTYP(MAXSTD),EXTTYP(MAXEXT) C INTEGER NOGRAD PARAMETER (NOGRAD=0) C INTEGER MAXMAR PARAMETER (MAXMAR=100) INTEGER MARKST(MAXMAR,2),GOTOST(MAXMAR,2) INTEGER MC,GC C INTEGER GETIWA DOUBLE PRECISION GETWA C DATA STDTYP /1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1/ DATA EXTTYP /1/ C DATA (YYEXCA(I),I=0,17) O /-1,1,0,-1,-2,0,-1,75,257,23, 1 -2,32,-1,77,257,22,-2,33/ DATA (YYACT(I),I=0,99) O /27,155,13,14,15,16,17,18,19,5, 1 48,69,157,310,49,306,329,82,312,250, 2 321,320,307,300,298,81,280,277,51,50, 3 82,276,275,271,248,232,230,164,62,163, 4 78,98,324,97,78,79,95,323,94,79, 5 315,314,313,304,303,302,292,291,290,289, 6 288,287,285,268,265,262,258,257,253,252, 7 251,177,129,127,223,128,203,130,201,188, 8 184,158,166,160,152,107,103,102,72,71, 9 46,42,40,38,36,34,32,150,129,127/ DATA (YYACT(I),I=100,199) O /100,128,325,130,273,190,186,165,73,70, 1 44,195,256,115,228,74,194,211,129,127, 2 212,128,131,130,131,129,127,281,128,247, 3 130,245,243,241,282,129,127,278,128,80, 4 130,96,206,279,129,127,244,128,106,130, 5 131,260,129,127,296,128,249,130,197,199, 6 67,60,58,132,133,193,129,127,246,128, 7 131,130,189,187,129,129,127,131,128,130, 8 130,66,59,57,185,309,183,131,129,127, 9 56,128,55,130,120,254,131,226,227,121/ DATA (YYACT(I),I=200,299) O /129,127,295,128,131,130,308,104,294,172, 1 173,174,175,176,231,192,161,76,131,181, 2 129,127,240,128,159,130,131,131,116,255, 3 222,162,220,156,90,89,91,87,88,198, 4 131,105,218,216,92,93,242,90,89,91, 5 87,88,131,202,154,63,61,92,93,151, 6 207,208,123,113,124,215,75,217,77,219, 7 284,221,131,330,146,224,311,147,129,127, 8 317,128,229,130,120,118,117,119,200,121, 9 129,127,236,128,238,130,122,125,129,127/ DATA (YYACT(I),I=300,399) O /235,128,179,130,178,101,177,129,127,138, 1 128,153,130,318,200,144,137,53,145,322, 2 195,196,234,263,136,264,108,266,143,267, 3 131,331,195,196,195,196,167,168,169,170, 4 64,126,131,129,127,52,128,54,130,327, 5 131,326,129,127,180,128,182,130,319,131, 6 129,127,316,128,141,130,139,142,111,140, 7 299,112,274,129,127,297,128,286,130,213, 8 120,118,214,119,283,121,209,120,118,210, 9 119,272,121,270,269,131,261,120,118,204/ DATA (YYACT(I),I=400,468) O /119,191,121,149,131,259,120,118,148,119, 1 114,121,131,171,120,118,110,119,109,121, 2 99,33,31,30,29,131,28,20,237,135, 3 134,86,239,85,84,83,328,305,301,293, 4 225,68,47,65,45,43,41,39,233,205, 5 37,35,12,26,11,25,10,24,9,23, 6 8,22,7,21,6,4,3,2,1/ DATA (YYPACT(I),I=0,99) O /-3000,-3000,-272,-3000,-3000,417,-3000,-3000,-3000, O -3000, 1 -3000,-3000,-3000,416,414,413,412,-168,411,-169, 2 -3000,-170,-171,-172,-173,-152,-174,-254,-3000,-3000, 3 -3000,-3000,305,-3000,307,-3000,131,-3000,129,-3000, 4 122,-3000,121,-3000,-7,-3000,300,-3000,120,-3000, 5 -273,-153,-175,-3000,-176,-154,4,-15,-216,-15, 6 -221,410,-163,42,-178,197,-15,-179,286,408, 7 406,327,222,400,-144,184,242,-3000,0,0, 8 331,-15,-15,-3000,-3000,-3000,-3000,-3000,-3000,-3000, 9 -3000,284,276,269,325,323,318,274,233,-3000/ DATA (YYPACT(I),I=100,199) O /398,393,-166,218,-3000,-180,301,213,-28,-3000, 1 -3000,180,-181,172,-3000,-225,-155,-182,0,0, 2 0,0,372,-3000,-3000,-3000,-3000,-15,-15,-15, 3 -15,-15,265,28,264,262,0,-15,0,125, 4 -184,123,-156,-3000,112,-185,111,-157,-3000,-3000, 5 391,171,-3000,-3000,104,75,-28,-28,56,-186, 6 212,-188,389,-3000,-3000,-3000,81,152,152,-3000, 7 -3000,-3000,132,132,28,28,28,-3000,-15,-15, 8 345,76,338,-15,202,-15,201,-15,191,-15, 9 189,-3000,-190,-15,-3000,-28,-28,-3000,30,73/ DATA (YYPACT(I),I=200,299) O /-15,-231,170,-232,-3000,-3000,-225,256,248,-3000, 1 0,-3000,-15,-3000,0,178,72,236,71,102, 2 70,158,68,-233,146,-250,-3000,-148,-3000,310, 3 -194,-195,-196,185,-145,-197,-198,364,110,355, 4 -199,-15,-3000,-15,-200,-15,-3000,-15,-201,-3000, 5 384,383,-234,381,-3000,-158,-225,-235,-236,-3000, 6 -3000,-3000,-240,93,133,-241,83,124,374,-3000, 7 -3000,-202,-3000,-3000,367,-203,-204,-205,-206,-3000, 8 -207,-208,-3000,-3000,-254,164,-3000,161,113,365, 9 -243,360,-244,-3000,-209,-3000,-3000,-3000,-210,-3000/ DATA (YYPACT(I),I=300,331) O /-211,-255,-245,162,141,-258,8,-212,-213,-214, 1 352,240,-3000,348,-246,-247,-3000,-28,-254,-3000, 2 -217,-222,61,341,339,-3000,-3000,-3000,-253,263, 3 -3000,-254/ DATA (YYPGO(I),I=0,44) O /0,468,467,466,465,464,463,462,461,460, 1 459,458,457,456,455,454,453,452,0,451, 2 450,115,449,448,217,447,81,446,445,444, 3 443,442,441,1,440,439,438,437,436,435, 4 434,433,431,430,429/ DATA (YYR1(I),I=0,99) O /0,1,2,2,4,4,4,4,4,4, 1 4,5,6,6,19,7,8,8,20,22, 2 20,20,21,21,23,23,24,24,24,24, 3 24,24,24,24,9,10,10,25,25,25, 4 25,25,11,12,12,27,27,27,27,27, 5 13,13,14,14,28,28,28,28,15,16, 6 16,29,29,30,30,17,17,18,18,31, 7 31,32,34,35,31,31,31,38,36,36, 8 37,37,26,26,26,26,26,26,26,26, 9 26,26,26,43,26,44,26,33,33,33/ DATA (YYR1(I),I=100,113) O /33,33,39,39,40,40,40,41,41,41, 1 42,42,42,3/ DATA (YYR2(I),I=0,99) O /0,5,4,0,4,4,4,4,4,4, 1 5,4,4,0,9,4,4,0,13,1, 2 16,21,3,2,7,0,7,7,7,7, 3 6,5,3,3,4,4,0,9,23,15, 4 35,19,4,4,0,9,23,15,35,19, 5 21,33,4,0,7,9,9,11,4,4, 6 0,19,7,7,1,7,21,4,0,9, 7 15,1,1,1,29,7,7,1,21,0, 8 6,1,7,7,7,7,7,6,5,2, 9 2,2,2,1,19,1,19,7,7,5/ DATA (YYR2(I),I=100,113) O /6,7,3,3,3,9,13,3,9,13, 1 3,9,13,4/ DATA (YYCHK(I),I=0,99) O /-3000,-1,-2,-3,-4,281,-5,-7,-9,-11, 1 -13,-15,-17,274,275,276,277,278,279,280, 2 10,-6,-8,-10,-12,-14,-16,-18,10,10, 3 10,10,264,10,264,-19,264,-20,264,-25, 4 264,-27,264,-28,262,-29,264,-31,264,268, 5 283,282,40,10,40,61,61,61,40,61, 6 40,263,45,262,40,-30,61,40,-32,284, 7 262,264,264,262,-21,262,-24,264,40,45, 8 -26,40,45,-39,-40,-41,-42,265,266,263, 9 262,264,272,273,264,262,-26,264,262,10/ DATA (YYCHK(I),I=100,199) O /263,263,45,264,10,44,-26,264,40,10, 1 10,41,44,41,10,257,44,44,43,45, 2 42,47,-24,262,264,-24,10,43,45,42, 3 47,94,-26,-26,-43,-44,40,40,40,41, 4 44,41,44,10,41,44,41,44,10,10, 5 263,41,264,10,41,-33,261,40,-26,44, 6 264,44,-21,264,262,262,264,-24,-24,-24, 7 -24,41,-26,-26,-26,-26,-26,41,40,40, 8 -24,-26,-24,61,264,61,262,61,264,61, 9 262,10,44,61,41,259,260,-33,-26,-33/ DATA (YYCHK(I),I=200,299) O /258,264,41,264,10,-22,61,-26,-26,41, 1 44,41,44,41,44,-26,41,-26,41,-26, 2 41,-26,41,264,-26,-34,-33,-33,41,-26, 3 267,44,267,-23,-21,44,44,-24,-26,-24, 4 44,61,10,61,44,61,10,61,267,10, 5 269,264,264,264,10,44,257,264,264,41, 6 41,41,264,-26,-26,264,-26,-26,264,10, 7 10,267,10,262,-21,267,267,267,44,10, 8 267,44,10,10,-18,264,10,264,264,264, 9 264,264,264,-35,44,41,41,10,267,10/ DATA (YYCHK(I),I=300,331) O /267,-36,264,264,264,-37,270,267,44,44, 1 271,268,10,264,264,264,10,40,-18,10, 2 267,267,-33,264,264,41,10,10,-38,269, 3 10,-18/ DATA (YYDEF(I),I=0,99) O /3,-2,0,1,2,0,13,17,36,44, 1 53,60,68,0,0,0,0,0,0,0, 2 113,4,5,6,7,8,9,10,11,15, 3 34,42,0,58,0,12,0,16,0,35, 4 0,43,0,52,0,59,64,67,0,71, 5 0,0,0,65,0,0,0,0,0,0, 6 0,0,0,0,0,0,0,0,0,0, 7 0,0,0,0,0,-2,0,-2,0,0, 8 0,0,0,89,90,91,92,93,95,102, 9 103,104,107,110,0,0,0,0,0,54/ DATA (YYDEF(I),I=100,199) O /0,0,0,0,62,0,0,0,0,75, 1 76,0,0,0,14,0,0,0,0,0, 2 0,0,0,32,33,31,37,0,0,0, 3 0,0,0,88,0,0,0,0,0,0, 4 0,0,0,45,0,0,0,0,55,56, 5 0,0,63,69,0,0,0,0,0,0, 6 0,0,0,22,23,19,0,26,27,28, 7 29,30,82,83,84,85,86,87,0,0, 8 0,0,0,0,0,0,0,0,0,0, 9 0,57,0,0,72,0,0,99,0,0/ DATA (YYDEF(I),I=200,299) O /0,0,0,0,18,25,0,0,0,105, 1 0,108,0,111,0,0,0,0,0,0, 2 0,0,0,0,0,0,97,98,100,101, 3 0,0,0,0,0,0,0,0,0,0, 4 0,0,39,0,0,0,47,0,0,70, 5 0,0,0,0,20,0,0,0,0,106, 6 109,112,0,0,0,0,0,0,0,68, 7 50,0,66,24,0,0,0,0,0,41, 8 0,0,49,61,73,0,21,0,0,0, 9 0,0,0,79,0,94,96,38,0,46/ DATA (YYDEF(I),I=300,331) O /0,81,0,0,0,0,0,0,0,0, 1 0,0,68,0,0,0,74,0,80,51, 2 0,0,0,0,0,77,40,48,0,0, 3 68,78/ C DATA YYV /YYMDEP*0/ DATA YYS /YYMDEP*0/ C LNUM=0 LPOS=67 SPOS=2 EOF=.FALSE. IERR=0 PC=0 MC=0 GC=0 SYMEND=0 C DO 5 I=1,MAXMAR GOTOST(I,1)=0 MARKST(I,1)=0 GOTOST(I,2)=0 MARKST(I,2)=0 5 CONTINUE C DO 6 I=1,14 INFOLI(I)=14 6 CONTINUE INFOLI(6)=0 INFOLI(8)=0 INFOLI(10)=0 INFOLI(11)=0 INFOLI(12)=0 C C ignore leading '\n'! C YYCHAR=YYLEX(INPUT,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF,YYLVAL, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,MAXSYM,SYMNAM, 2 SYMTYP,SYMREF,SYMEND,IERR) C C Initialize externals - yyparse may be called more than once C YYPV=-1 YYPS=-1 YYSTAT=0 YYTMP=0 YYVAL=0 YYNERR=0 YYERRF=0 YYCHAR=-1 C C yystack: C 10 YYXPV=YYPV YYXPS=YYPS YYXSTA=YYSTAT C C top of for(;;) loop while no reductions done C C yy_stack: put a state and value onto the stacks C 20 YYXPS=YYXPS+1 IF (YYXPS .GE. YYMDEP) THEN IERR=30 GO TO 9999 ENDIF YYS(YYXPS)=YYXSTA YYXPV=YYXPV+1 YYV(YYXPV)=YYVAL C C yy_newstate: we have a new state - find out what to do C 30 YYXN=YYPACT(YYXSTA) IF (YYXN .LE. YYFLAG) GO TO 40 IF (YYCHAR .LT. 0) THEN YYCHAR=YYLEX(INPUT,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF,YYLVAL, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,MAXSYM,SYMNAM, 2 SYMTYP,SYMREF,SYMEND,IERR) IF (YYCHAR .LT. 0) YYCHAR=0 ENDIF YYXN=YYXN+YYCHAR IF ((YYXN .LT. 0) .OR. (YYXN .GE. YYLAST)) GO TO 40 YYXN=YYACT(YYXN) IF (YYCHK(YYXN) .EQ. YYCHAR) THEN YYCHAR=-1 YYVAL=YYLVAL YYXSTA=YYXN IF (YYERRF .GT. 0) YYERRF=YYERRF-1 GO TO 20 ENDIF C C yydefault: C 40 YYXN=YYDEF(YYXSTA) IF (YYXN .EQ. -2) THEN IF (YYCHAR .LT. 0) THEN YYCHAR=YYLEX(INPUT,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF,YYLVAL, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,MAXSYM,SYMNAM, 2 SYMTYP,SYMREF,SYMEND,IERR) IF (YYCHAR .LT. 0) YYCHAR=0 ENDIF C C look through exception table C YYXI=0 41 IF ((YYEXCA(YYXI) .NE. -1) .OR. (YYEXCA(YYXI+1) .NE. 1 YYXSTA)) THEN YYXI=YYXI+2 GO TO 41 ENDIF 42 YYXI=YYXI+2 IF ((YYEXCA(YYXI) .GE. 0) .AND. (YYEXCA(YYXI) .NE. 1 YYCHAR)) GO TO 42 YYXN=YYEXCA(YYXI+1) IF (YYXN .LT. 0) THEN IERR=YYACPT GO TO 9999 ENDIF ENDIF C C check for syntax error C IF (YYXN .EQ. 0) THEN C C have an error, switch( yyerrflag ) C GO TO (50,51,52,53) YYERRF+1 C C case 0: new error C 50 YYNERR=YYNERR+1 IF (IERR .EQ. 0) IERR=YYABRT GO TO 51 C C yyerrlab: get globals into registers. C we have a user generated syntax type error C C 501 YYXPV=YYPV C YYXPS=YYPS C YYXSTA=YYSTAT C YYNERR=YYNERR+1 C C skip_init: C case 1: C case 2: incompletely recovered error. try again... C 51 CONTINUE 52 YYERRF=3 C C find state where "error" is a legal shift action C 521 IF (YYXPS .GE. 0) THEN YYXN=YYPACT(YYS(YYXPS))+YYERRC IF ((YYXN .GE. 0) .AND. (YYXN .LT. YYLAST)) THEN IF (YYCHK(YYACT(YYXN)) .EQ. YYERRC) THEN C C simulate shift of "error" C YYXSTA=YYACT(YYXN) GO TO 20 ENDIF ENDIF C C current state has no shift on "error", pop stack C YYXPS=YYXPS-1 YYXPV=YYXPV-1 GO TO 521 ENDIF C C there is no state on stack with "error" C as a valid shift, give up. C IF (IERR .EQ. 0) IERR=YYABRT GO TO 9999 C C case 3: no shift yet; eat a token C 53 IF (YYCHAR .EQ. 0) THEN IF (IERR .EQ. 0) IERR=YYABRT GO TO 9999 ENDIF YYCHAR=-1 GO TO 30 C C /* end if( yy_n == 0 ) */ C ENDIF C C reduction by production yy_n C put stack tops, etc. so things right after switch. C YYTMP=YYXN YYPVT=YYXPV C C Look in goto table for next state. C If yyr2[ yy_n ] doesn't have the low order bit C set, then there is no action to be done for C this reduction. So, no saving & unsaving of C registers done. The only difference between the C code just after the if and the body of the if is C the goto yy_stack in the body. This way the test C can be made before the choice of what to do is needed. C C length of production doubled with extra bit. C YYXLEN=YYR2(YYXN) IF (MOD(YYXLEN,2) .EQ. 0) THEN YYXLEN=YYXLEN/2 YYXPV=YYXPV-YYXLEN YYVAL=YYV(YYXPV+1) YYXN=YYR1(YYXN) YYXPS=YYXPS-YYXLEN YYXSTA=YYPGO(YYXN)+YYS(YYXPS)+1 IF (YYXSTA .GE. YYLAST) THEN YYXSTA=YYACT(YYPGO(YYXN)) ELSE YYXSTA=YYACT(YYXSTA) IF (YYCHK(YYXSTA) .NE. -YYXN) YYXSTA=YYACT(YYPGO(YYXN)) ENDIF GO TO 20 ENDIF YYXLEN=YYXLEN/2 YYXPV=YYXPV-YYXLEN YYVAL=YYV(YYXPV+1) YYXN=YYR1(YYXN) YYXPS=YYXPS-YYXLEN YYXSTA=YYPGO(YYXN)+YYS(YYXPS)+1 IF (YYXSTA .GE. YYLAST) THEN YYXSTA=YYACT(YYPGO(YYXN)) ELSE YYXSTA=YYACT(YYXSTA) IF (YYCHK(YYXSTA) .NE. -YYXN) YYXSTA=YYACT(YYPGO(YYXN)) ENDIF C C save until reenter driver code C YYSTAT=YYXSTA YYPS=YYXPS YYPV=YYXPV C C code supplied by user is placed in this switch C C module : declaration_blocks endmodule {} C IF (YYTMP .EQ. 1) THEN C----------------------------------------------- IF (GC .NE. 0) THEN IF (MC .EQ.0) THEN IERR=58 LNUM=GOTOST(1,1) GO TO 9999 ENDIF DO 1010 I=1,GC IERR=58 DO 1000 J=1,MC IF (GOTOST(I,1) .EQ. MARKST(J,1)) THEN IERR=0 CALL PUT1(MARKST(J,2),0.0D0,VPF,GOTOST(I,2)+2,LIWA, 1 PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) ENDIF 1000 CONTINUE IF (IERR .NE. 0) THEN LNUM=GOTOST(I,1) GO TO 9999 ENDIF 1010 CONTINUE DO 1020 I=1,GC GOTOST(I,1)=0 GOTOST(I,2)=0 1020 CONTINUE DO 1030 I=1,MC MARKST(I,1)=0 MARKST(I,2)=0 1030 CONTINUE MC=0 GC=0 ENDIF C----------------------------------------------- DO 1040 I=1,IWA(13) IF (GETIWA(VPF,I,0,IWA,LIWA,INFOLI) .EQ. -ASSIGN) THEN CALL PUT1(ASSIGN,0.0D0,VPF,I,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) IHELP1=GETIWA(VPF,I+1,0,IWA,LIWA,INFOLI)+IWA(10) CALL PUT1(IHELP1,0.0D0, 1 VPF,I+1,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) ELSE IF (GETIWA(VPF,I,0,IWA,LIWA,INFOLI) .EQ. -FUNC) THEN CALL PUT1(FUNC,0.0D0,VPF,I,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) IHELP1=GETIWA(VPF,I+1,0,IWA,LIWA,INFOLI)+IWA(10) CALL PUT1(IHELP1,0.0D0, 1 VPF,I+1,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) ENDIF 1040 CONTINUE GO TO 9999 C C declaration_block : function_head stmts {} C ELSE IF (YYTMP .EQ. 10) THEN CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) GO TO 9999 PC=IWA(13) C C param_declaration : ID '=' INUM '\n' {} C ELSE IF (YYTMP .EQ. 14) THEN S1=YYV(YYPVT-3) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=INT VEK4(1)=0 VEK4(2)=0 VEK4(3)=0 VEK4(4)=IWA(4) CALL PUT4(VEK4,IIC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S1)=IWA(3) C C index_declaration : ID '=' index_delimiter RANGE index_delimiter '\n' {} C ELSE IF (YYTMP .EQ. 18) THEN S1=YYV(YYPVT-5) S3=YYV(YYPVT-3) S5=YYV(YYPVT-1) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=INDEX IHELP1=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S5,0,IWA,LIWA,INFOLI) IF (IHELP1 .LT. IHELP2) THEN VEK5(1)=1 VEK5(2)=IHELP2-IHELP1+1 VEK5(3)=IHELP1 VEK5(4)=IHELP2 VEK5(5)=IWA(2)+1 CALL PUT5(VEK5,IIS,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF DO 1100 I=IHELP1,IHELP2 CALL PUT1(I,0.0D0,VIS,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) 1100 CONTINUE IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF ELSE VEK5(1)=1 VEK5(2)=IHELP1-IHELP2+1 VEK5(3)=IHELP2 VEK5(4)=IHELP1 VEK5(5)=IWA(2)+1 CALL PUT5(VEK5,IIS,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF DO 1110 I=IHELP1,IHELP2,-1 CALL PUT1(I,0.0D0,VIS,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) 1110 CONTINUE IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF ENDIF SYMREF(S1)=IWA(1) C C index_declaration : ID '=' INUM ',' INUM {} opt_inum '\n' C ELSE IF (YYTMP .EQ. 19) THEN S1=YYV(YYPVT-4) S3=YYV(YYPVT-2) S5=YYV(YYPVT) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 GO TO 9999 ENDIF SYMTYP(S1)=INDEX IHELP1=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S5,0,IWA,LIWA,INFOLI) VEK5(1)=2 VEK5(2)=2 VEK5(3)=MIN(IHELP1,IHELP2) VEK5(4)=MAX0(IHELP1,IHELP2) VEK5(5)=IWA(2)+1 CALL PUT5(VEK5,IIS,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 SYMREF(S1)=IWA(1) CALL PUT1(IHELP1,0.0D0,VIS,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) CALL PUT1(IHELP2,0.0D0,VIS,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) GO TO 9999 C C index_declaration : ID '=' ind_expr ',' C ID '=' index_delimiter RANGE index_delimiter '\n' {} C C ELSE IF (YYTMP .EQ. 21) THEN S1=YYV(YYPVT-9) S5=YYV(YYPVT-5) S7=YYV(YYPVT-3) S9=YYV(YYPVT-1) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=INDEX VEK5(1)=3 VEK5(5)=IWA(2)+1 IF (SYMTYP(S5) .EQ. 0) THEN SYMTYP(S5)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S5)=IWA(14) ELSE IF (SYMTYP(S5) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(VIC,S7,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S9,0,IWA,LIWA,INFOLI) IF (IHELP1 .LT. IHELP2) THEN DO 1200 I=IHELP1,IHELP2 CALL PUT1(I,0.0D0,IV,SYMREF(S5),LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(IVAL,0.0D0,VIS,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IF (I .EQ. IHELP1) THEN VEK5(2)=1 VEK5(3)=IVAL VEK5(4)=IVAL ELSE VEK5(2)=VEK5(2)+1 VEK5(3)=MIN(IVAL,VEK5(3)) VEK5(4)=MAX0(IVAL,VEK5(4)) ENDIF 1200 CONTINUE CALL PUT5(VEK5,IIS,0,LIWA,PLIWA,IWA,INFOLI,IERR) ELSE DO 1210 I=IHELP1,IHELP2,-1 CALL PUT1(I,0.0D0,IV,SYMREF(S5),LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(IVAL,0.0D0,VIS,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IF (I .EQ. IHELP1) THEN VEK5(2)=1 VEK5(3)=IVAL VEK5(4)=IVAL ELSE VEK5(2)=VEK5(2)+1 VEK5(3)=MIN(IVAL,VEK5(3)) VEK5(4)=MAX0(IVAL,VEK5(4)) ENDIF 1210 CONTINUE CALL PUT5(VEK5,IIS,0,LIWA,PLIWA,IWA,INFOLI,IERR) ENDIF SYMREF(S1)=IWA(1) CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C C index_delimiter : ID {} C ELSE IF (YYTMP .EQ. 22) THEN S1 = YYV(YYPVT) IF (SYMTYP(S1) .NE. INT) THEN IERR=8 GO TO 9999 ENDIF YYVAL =GETIWA(IIC,SYMREF(S1),4,IWA,LIWA,INFOLI) C C opt_inum : opt_inum ',' INUM {} C ELSE IF (YYTMP .EQ. 24) THEN S3=YYV(YYPVT) IHELP1=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) CALL PUT1(IHELP1,0.0D0,VIS,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) GO TO 9999 VEK5(1)=GETIWA(IIS,IWA(1),1,IWA,LIWA,INFOLI) VEK5(5)=GETIWA(IIS,IWA(1),5,IWA,LIWA,INFOLI) VEK5(2)=GETIWA(IIS,IWA(1),2,IWA,LIWA,INFOLI)+1 IHELP2=GETIWA(IIS,IWA(1),3,IWA,LIWA,INFOLI) IHELP3=GETIWA(IIS,IWA(1),4,IWA,LIWA,INFOLI) VEK5(3)=MIN(IHELP1,IHELP2) VEK5(4)=MAX0(IHELP1,IHELP3) CALL PUT5(VEK5,IIS,IWA(1),LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C ind_expr : ind_expr '+' ind_expr {} C ELSE IF (YYTMP .EQ. 26) THEN CALL PUT1(ADD+128,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) GO TO 9999 C C ind_expr : ind_expr '-' ind_expr {} C ELSE IF (YYTMP .EQ. 27) THEN CALL PUT1(SUB+128,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) GO TO 9999 C C ind_expr : ind_expr '*' ind_expr {} C ELSE IF (YYTMP .EQ. 28) THEN CALL PUT1(MULT+128,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C ind_expr : ind_expr '/' ind_expr {} C ELSE IF (YYTMP .EQ. 29) THEN CALL PUT1(DIV+128,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) GO TO 9999 C C ind_expr : '-' ind_expr %prec UMINUS {} C ELSE IF (YYTMP .EQ. 31) THEN CALL PUT1(UMINUS+128,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C ind_expr : INUM {} C ELSE IF (YYTMP .EQ. 32) THEN CALL PUT1(INUM+128,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(YYV(YYPVT),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C ind_expr : ID {} C ELSE IF (YYTMP .EQ. 33) THEN S1=YYV(YYPVT) IF (SYMTYP(S1) .EQ. 0) THEN SYMTYP(S1)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 SYMREF(S1)=IWA(14) ELSE IF (SYMTYP(S1) .NE. INDVAR) THEN IERR=8 GO TO 9999 ENDIF CALL PUT1(INDVAR+128,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C real_declaration : ID '=' expr '\n' {} C ELSE IF (YYTMP .EQ. 37) THEN S1=YYV(YYPVT-3) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=REAL CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(0,FVAL,VRC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) VEK4(1)=0 VEK4(2)=0 VEK4(3)=0 VEK4(4)=IWA(6) CALL PUT4(VEK4,IRC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S1)=IWA(5) C C real_declaration : ID '(' ID ')' '=' expr ',' ID IN ID '\n' {} C ELSE IF (YYTMP .EQ. 38) THEN CALL CASE38(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) IF (IERR .NE. 0) GO TO 9999 C C real_declaration : ID '(' INUM ')' '=' expr '\n' {} C ELSE IF (YYTMP .EQ. 39) THEN CALL CASE39(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) IF (IERR .NE. 0) GO TO 9999 C C real_declaration : ID '(' ID ',' ID ')' '=' expr ',' C ID IN ID ',' ID IN ID '\n' {} C ELSE IF (YYTMP .EQ. 40) THEN CALL CASE40(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) IF (IERR .NE. 0) GO TO 9999 C C real_declaration : ID '(' INUM ',' INUM ')' '=' expr '\n' {} C ELSE IF (YYTMP .EQ. 41) THEN CALL CASE41(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) IF (IERR .NE. 0) GO TO 9999 C C integer_declaration : ID '=' expr '\n' {} C ELSE IF (YYTMP .EQ. 45) THEN S1=YYV(YYPVT-3) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=INT CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(IDNINT(FVAL),0.0D0,VIC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) VEK4(1)=0 VEK4(2)=0 VEK4(3)=0 VEK4(4)=IWA(4) CALL PUT4(VEK4,IIC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S1)=IWA(3) C C integer_declaration : ID '(' ID ')' '=' expr ',' ID IN ID '\n' {} C ELSE IF (YYTMP .EQ. 46) THEN CALL CASE46(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) IF (IERR .NE. 0) GO TO 9999 C C integer_declaration : ID '(' INUM ')' '=' expr '\n' {} C ELSE IF (YYTMP .EQ. 47) THEN CALL CASE47(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) IF (IERR .NE. 0) GO TO 9999 C C integer_declaration : ID '(' ID ',' ID ')' '=' expr ',' C ID IN ID ',' ID IN ID '\n' {} C ELSE IF (YYTMP .EQ. 48) THEN CALL CASE48(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) IF (IERR .NE. 0) GO TO 9999 C C integer_declaration : ID '(' INUM ',' INUM ')' '=' expr '\n' {} C ELSE IF (YYTMP .EQ. 49) THEN S1=YYV(YYPVT-8) S3=YYV(YYPVT-6) S5=YYV(YYPVT-4) IF (SYMTYP(S1) .NE. INT) THEN IERR=7 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S5,0,IWA,LIWA,INFOLI) IHELP3=GETIWA(IIC,SYMREF(S1),2,IWA,LIWA,INFOLI) IHELP4=GETIWA(IIC,SYMREF(S1),3,IWA,LIWA,INFOLI) IF ((IHELP1 .LT. 1) .OR. (IHELP1 .GT. IHELP3) .OR. 1 (IHELP2 .LT. 1) .OR. (IHELP2 .GT. IHELP4)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIC,SYMREF(S1),4,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) IHELP3=GETIWA(IIC,SYMREF(S1),3,IWA,LIWA,INFOLI) IHELP4=GETIWA(VIC,S5,0,IWA,LIWA,INFOLI) CALL PUT1(IDNINT(FVAL),0.0D0,VIC, 1 IHELP1+(IHELP2-1)*IHELP3+IHELP4-1, 2 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C C table_head : TABLE ID '(' ID ')' ',' ID IN ID '\n' {} C ELSE IF (YYTMP .EQ. 50) THEN S2=YYV(YYPVT-8) S4=YYV(YYPVT-6) S7=YYV(YYPVT-3) S9=YYV(YYPVT-1) IF (SYMTYP(S2) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S2)=REAL SYMREF(S2)=IWA(5)+1 IF (SYMTYP(S4) .EQ. 0) THEN SYMTYP(S4)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S4)=IWA(14) ELSE IF (SYMTYP(S4) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF (SYMTYP(S9) .NE. INDEX) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S9),3,IWA,LIWA,INFOLI) IF ((S4 .NE. S7) .OR. (IHELP1 .LE. 0)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF VEK4(1)=1 VEK4(2)=GETIWA(IIS,SYMREF(S9),4,IWA,LIWA,INFOLI) VEK4(3)=0 VEK4(4)=IWA(6)+1 CALL PUT4(VEK4,IRC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IRC,IWA(5),2,IWA,LIWA,INFOLI) DO 1700 I=1,IHELP1 CALL PUT1(0,0.0D0,VRC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) 1700 CONTINUE IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF C C table_head : TABLE ID '(' ID ',' ID ')' ',' ID IN ID ',' ID IN ID '\n' {} C ELSE IF (YYTMP .EQ. 51) THEN S1=YYV(YYPVT-14) S3=YYV(YYPVT-12) S5=YYV(YYPVT-10) S8=YYV(YYPVT-7) S10=YYV(YYPVT-5) S12=YYV(YYPVT-3) S14=YYV(YYPVT-1) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=REAL SYMREF(S1)=IWA(5)+1 IF (SYMTYP(S3) .EQ. 0) THEN SYMTYP(S3)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S3)=IWA(14) ELSE IF (SYMTYP(S3) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF (SYMTYP(S5) .EQ. 0) THEN SYMTYP(S5)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S5)=IWA(14) ELSE IF (SYMTYP(S5) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF ((SYMTYP(S10) .NE. INDEX) .OR. 1 (SYMTYP(S14) .NE. INDEX)) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S10),3,IWA,LIWA,INFOLI) IHELP2=GETIWA(IIS,SYMREF(S14),3,IWA,LIWA,INFOLI) IF ((S3 .NE. S8) .OR. (S5 .NE. S12) .OR. 1 (IHELP1 .LE. 0) .OR. (IHELP2 .LE. 0)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF VEK4(1)=2 VEK4(2)=GETIWA(IIS,SYMREF(S10),4,IWA,LIWA,INFOLI) VEK4(3)=GETIWA(IIS,SYMREF(S14),4,IWA,LIWA,INFOLI) VEK4(4)=IWA(6)+1 CALL PUT4(VEK4,IRC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IRC,IWA(5),2,IWA,LIWA,INFOLI) IHELP2=GETIWA(IRC,IWA(5),3,IWA,LIWA,INFOLI) DO 1800 I=1,IHELP1*IHELP2 CALL PUT1(0,0.0D0,VRC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) 1800 CONTINUE IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF C C table_declaration : INUM RNUM '\n' {} C ELSE IF (YYTMP .EQ. 54) THEN S1=YYV(YYPVT-2) S2=YYV(YYPVT-1) IHELP1=GETIWA(VIC,S1,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(IIS,SYMREF(S9),4,IWA,LIWA,INFOLI) IF ((IHELP1 .LT. 1) .OR. 1 (IHELP1 .GT. IHELP2)) THEN IERR = 33 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP3=GETIWA(IRC,IWA(5),4,IWA,LIWA,INFOLI) HELP4=GETWA(VRC,S2,WA,LWA,INFOLI) CALL PUT1(0,HELP4,VRC,IHELP3+IHELP1-1,LIWA,PLIWA,IWA,LWA,PLWA, 1 WA,INFOLI,IERR) C C table_declaration : INUM '-' RNUM '\n' {} C ELSE IF (YYTMP .EQ. 55) THEN S1=YYV(YYPVT-3) S3=YYV(YYPVT-1) IHELP1=GETIWA(VIC,S1,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(IIS,SYMREF(S9),4,IWA,LIWA,INFOLI) IF ((IHELP1 .LT. 1) .OR. 1 (IHELP1 .GT. IHELP2)) THEN IERR = 33 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP3=GETIWA(IRC,IWA(5),4,IWA,LIWA,INFOLI) HELP4=GETWA(VRC,S3,WA,LWA,INFOLI) CALL PUT1(0,-HELP4,VRC,IHELP3+IHELP1-1,LIWA,PLIWA,IWA,LWA,PLWA, 1 WA,INFOLI,IERR) C C table_declaration : INUM INUM RNUM '\n' {} C ELSE IF (YYTMP .EQ. 56) THEN S1=YYV(YYPVT-3) S2=YYV(YYPVT-2) S3=YYV(YYPVT-1) IHELP1=GETIWA(VIC,S1,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S2,0,IWA,LIWA,INFOLI) IHELP3=GETIWA(IIS,SYMREF(S10),4,IWA,LIWA,INFOLI) IHELP4=GETIWA(IIS,SYMREF(S14),4,IWA,LIWA,INFOLI) IF ((IHELP1 .LT. 1) .OR. (IHELP1 .GT. IHELP3) .OR. 1 (IHELP2 .LT. 1) .OR. (IHELP2 .GT. IHELP4)) THEN IERR = 33 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP5=GETIWA(IRC,IWA(5),4,IWA,LIWA,INFOLI) HELP6=GETWA(VRC,S3,WA,LWA,INFOLI) CALL PUT1(0,HELP6,VRC,IHELP5+(IHELP1-1)*IHELP4+IHELP2-1,LIWA, 1 PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) C C table_declaration : INUM INUM '-' RNUM '\n' {} C ELSE IF (YYTMP .EQ. 57) THEN S1=YYV(YYPVT-4) S2=YYV(YYPVT-3) S4=YYV(YYPVT-1) IHELP1=GETIWA(VIC,S1,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S2,0,IWA,LIWA,INFOLI) IHELP3=GETIWA(IIS,SYMREF(S10),4,IWA,LIWA,INFOLI) IHELP4=GETIWA(IIS,SYMREF(S14),4,IWA,LIWA,INFOLI) IF ((IHELP1 .LT. 1) .OR. (IHELP1 .GT. IHELP3) .OR. 1 (IHELP2 .LT. 1) .OR. (IHELP2 .GT. IHELP4)) THEN IERR = 33 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP5=GETIWA(IRC,IWA(5),4,IWA,LIWA,INFOLI) HELP6=GETWA(VRC,S4,WA,LWA,INFOLI) CALL PUT1(0,-HELP6,VRC,IHELP5+(IHELP1-1)*IHELP4+IHELP2-1,LIWA, 1 PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) C C variable_declaration : ID '(' ID ')' ',' ID IN ID '\n' {} C ELSE IF (YYTMP .EQ. 61) THEN S1=YYV(YYPVT-8) S3=YYV(YYPVT-6) S6=YYV(YYPVT-3) S8=YYV(YYPVT-1) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=VAR SYMREF(S1)=IWA(7)+1 IF (SYMTYP(S3) .EQ. 0) THEN SYMTYP(S3)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S3)=IWA(14) ELSE IF (SYMTYP(S3) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF (SYMTYP(S8) .NE. INDEX) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S8),1,IWA,LIWA,INFOLI) IF ((S3 .NE. S6) .OR. (IHELP1 .NE. 1)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF VEK3(1)=1 VEK3(2)=GETIWA(IIS,SYMREF(S8),2,IWA,LIWA,INFOLI) VEK3(3)=IWA(8)+1 CALL PUT3(VEK3,IVA,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IVA,IWA(7),2,IWA,LIWA,INFOLI) DO 2100 I=1,IHELP1 CALL PUT1(0,0.0D0,VVA,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) 2100 CONTINUE IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF C C variable_declaration : ID opt_id '\n' {} C ELSE IF (YYTMP .EQ. 62) THEN S1=YYV(YYPVT-2) S2=YYV(YYPVT-1) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=VAR SYMREF(S1)=S2 VEK3(1)=0 VEK3(2)=0 VEK3(3)=IWA(8)+S2-IWA(7) CALL PUT3(VEK3,IVA,S2,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IVA,S2,3,IWA,LIWA,INFOLI) CALL PUT1(0,0.0D0,VVA,IHELP1,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF C C opt_id : opt_id ',' ID {} C ELSE IF (YYTMP .EQ. 63) THEN S1=YYV(YYPVT-2) S3=YYV(YYPVT) IF (SYMTYP(S3) .NE. 0) THEN IERR=4 GO TO 9999 ENDIF CALL PUT1(0,0.0D0,VVA,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) GO TO 9999 VEK3(1)=0 VEK3(2)=0 VEK3(3)=IWA(8) CALL PUT3(VEK3,IVA,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 SYMTYP(S3)=VAR SYMREF(S3)=IWA(7) YYVAL=S1 C C opt_id : /* empty */ {} C ELSE IF (YYTMP .EQ. 64) THEN VEK3(1)=0 VEK3(2)=0 VEK3(3)=0 CALL PUT3(VEK3,IVA,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(0,0.0D0,VVA,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF YYVAL=IWA(7) C C function_head : FUNC ID '\n' {} C ELSE IF (YYTMP .EQ. 65) THEN C----------------------------------------------------------------------- IF (GC .NE. 0) THEN IF (MC .EQ.0) THEN IERR=58 LNUM=GOTOST(1,1) GO TO 9999 ENDIF DO 2210 I=1,GC IERR=58 DO 2200 J=1,MC IF (GOTOST(I,1) .EQ. MARKST(J,1)) THEN IERR=0 CALL PUT1(MARKST(J,2),0.0D0,VPF,GOTOST(I,2)+2,LIWA, 1 PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) ENDIF 2200 CONTINUE IF (IERR .NE. 0) THEN LNUM=GOTOST(I,1) GO TO 9999 ENDIF 2210 CONTINUE DO 2220 I=1,GC GOTOST(I,1)=0 GOTOST(I,2)=0 2220 CONTINUE DO 2230 I=1,MC MARKST(I,1)=0 MARKST(I,2)=0 2230 CONTINUE MC=0 GC=0 ENDIF C----------------------------------------------------------------------- S2=YYV(YYPVT-1) IF (SYMTYP(S2) .NE. 0) THEN IERR=4 GO TO 9999 ENDIF DO 2240 I=1,SYMEND IF ((SYMTYP(I) .EQ. FUNC) .AND. (SYMREF(I) .GT. IWA(10))) THEN SYMREF(I)=SYMREF(I)+1 ENDIF 2240 CONTINUE SYMTYP(S2)=FUNC VEK6(1)=0 VEK6(2)=0 VEK6(3)=0 VEK6(4)=0 VEK6(5)=0 VEK6(6)=0 CALL PUT6(VEK6,IFN,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 IWA(10)=IWA(10)+1 SYMREF(S2)=IWA(10) DO 2250 I=IWA(9)-1,IWA(10),-1 VEK6(1)=GETIWA(IFN,I,1,IWA,LIWA,INFOLI) VEK6(2)=GETIWA(IFN,I,2,IWA,LIWA,INFOLI) VEK6(3)=GETIWA(IFN,I,3,IWA,LIWA,INFOLI) VEK6(4)=GETIWA(IFN,I,4,IWA,LIWA,INFOLI)+1 VEK6(5)=GETIWA(IFN,I,5,IWA,LIWA,INFOLI)+1 VEK6(6)=GETIWA(IFN,I,6,IWA,LIWA,INFOLI) CALL PUT6(VEK6,IFN,I+1,LIWA,PLIWA,IWA,INFOLI,IERR) 2250 CONTINUE VEK6(1)=0 VEK6(2)=0 VEK6(3)=0 VEK6(4)=IWA(11)-(IWA(9)-IWA(10))+1 VEK6(5)=IWA(12)-(IWA(9)-IWA(10))+1 VEK6(6)=PC+1 CALL PUT6(VEK6,IFN,IWA(10),LIWA,PLIWA,IWA,INFOLI,IERR) IWA(11)=IWA(11)+1 IWA(12)=IWA(12)+1 IF (IWA(6)+IWA(8)+IWA(11)+IWA(12)*IWA(8) .GT. LWA) THEN IERR=32 GO TO 9999 ENDIF C C function_head : FUNC ID '(' ID ')' ',' ID IN ID '\n' {} C ELSE IF (YYTMP .EQ. 66) THEN C----------------------------------------------- IF (GC .NE. 0) THEN IF (MC .EQ.0) THEN IERR=58 LNUM=GOTOST(1,1) GO TO 9999 ENDIF DO 2310 I=1,GC IERR=58 DO 2300 J=1,MC IF (GOTOST(I,1) .EQ. MARKST(J,1)) THEN IERR=0 CALL PUT1(MARKST(J,2),0.0D0,VPF,GOTOST(I,2)+2,LIWA, 1 PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) ENDIF 2300 CONTINUE IF (IERR .NE. 0) THEN LNUM=GOTOST(I,1) GO TO 9999 ENDIF 2310 CONTINUE DO 2320 I=1,GC GOTOST(I,1)=0 GOTOST(I,2)=0 2320 CONTINUE DO 2330 I=1,MC MARKST(I,1)=0 MARKST(I,2)=0 2330 CONTINUE MC=0 GC=0 ENDIF C----------------------------------------------- S2=YYV(YYPVT-8) S4=YYV(YYPVT-6) S7=YYV(YYPVT-3) S9=YYV(YYPVT-1) IF (SYMTYP(S2) .NE. 0) THEN IERR=4 GO TO 9999 ENDIF DO 2340 I=1,SYMEND IF ((SYMTYP(I) .EQ. FUNC) .AND. (SYMREF(I) .GT. IWA(10))) THEN SYMREF(I)=SYMREF(I)+1 ENDIF 2340 CONTINUE IF (SYMTYP(S4) .EQ. 0) THEN SYMTYP(S4)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 SYMREF(S4)=IWA(14) ELSE IF (SYMTYP(S4) .NE. INDVAR) THEN IERR=8 GO TO 9999 ENDIF IF (SYMTYP(S9) .NE. INDEX) THEN IERR=8 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S9),1,IWA,LIWA,INFOLI) IHELP2=GETIWA(IIS,SYMREF(S9),3,IWA,LIWA,INFOLI) IF ((S4 .NE. S7) .OR. (IHELP1 .NE. 1) .OR. (IHELP2 .NE. 1)) THEN IERR=33 GO TO 9999 ENDIF SYMTYP(S2)=FUNC VEK6(1)=0 VEK6(2)=0 VEK6(3)=0 VEK6(4)=0 VEK6(5)=0 VEK6(6)=0 CALL PUT6(VEK6,IFN,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 IWA(10)=IWA(10)+1 SYMREF(S2)=IWA(10) DO 2350 I=IWA(9)-1,IWA(10),-1 VEK6(1)=GETIWA(IFN,I,1,IWA,LIWA,INFOLI) VEK6(2)=GETIWA(IFN,I,2,IWA,LIWA,INFOLI) VEK6(3)=GETIWA(IFN,I,3,IWA,LIWA,INFOLI) VEK6(4)=GETIWA(IFN,I,4,IWA,LIWA,INFOLI)+ 1 GETIWA(IIS,SYMREF(S9),2,IWA,LIWA,INFOLI) VEK6(5)=GETIWA(IFN,I,5,IWA,LIWA,INFOLI)+ 1 GETIWA(IIS,SYMREF(S9),2,IWA,LIWA,INFOLI) VEK6(6)=GETIWA(IFN,I,6,IWA,LIWA,INFOLI) CALL PUT6(VEK6,IFN,I+1,LIWA,PLIWA,IWA,INFOLI,IERR) 2350 CONTINUE VEK6(1)=1 VEK6(2)=SYMREF(S4) VEK6(3)=GETIWA(IIS,SYMREF(S9),2,IWA,LIWA,INFOLI) VEK6(4)=IWA(11)-(IWA(9)-IWA(10))+1 VEK6(5)=IWA(12)-(IWA(9)-IWA(10))+1 VEK6(6)=PC+1 CALL PUT6(VEK6,IFN,IWA(10),LIWA,PLIWA,IWA,INFOLI,IERR) IWA(11)=IWA(11)+GETIWA(IFN,IWA(10),3,IWA,LIWA,INFOLI) IWA(12)=IWA(12)+GETIWA(IFN,IWA(10),3,IWA,LIWA,INFOLI) IF (IWA(6)+IWA(8)+IWA(11)+IWA(12)*IWA(8) .GT. LWA) THEN IERR=32 GO TO 9999 ENDIF C C stmt : ID '=' expr '\n' {} C ELSE IF (YYTMP .EQ. 69) THEN S1=YYV(YYPVT-3) IF (SYMTYP(S1) .EQ. 0) THEN SYMTYP(S1)=FUNC VEK6(1)=-1 VEK6(2)=0 VEK6(3)=0 VEK6(4)=IWA(11)+1 VEK6(5)=IWA(12)+1 VEK6(6)=0 CALL PUT6(VEK6,IFN,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 SYMREF(S1)=IWA(9) IWA(11)=IWA(11)+1 IWA(12)=IWA(12)+1 IF (IWA(6)+IWA(8)+IWA(11)+IWA(12)*IWA(8) .GT. LWA) THEN IERR=32 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. FUNC) THEN IF (GETIWA(IFN,SYMREF(S1),1,IWA,LIWA,INFOLI).GT. 0) THEN IERR=35 GO TO 9999 ENDIF ELSE IERR=8 GO TO 9999 ENDIF IF (GETIWA(IFN,SYMREF(S1),1,IWA,LIWA,INFOLI) .EQ. -1) THEN CALL PUT1(-ASSIGN,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1)-IWA(10),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE CALL PUT1(ASSIGN,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ENDIF PC=IWA(13) C C stmt : ID '(' ID ')' '=' expr '\n' {} C ELSE IF (YYTMP .EQ. 70) THEN S1=YYV(YYPVT-6) S3=YYV(YYPVT-4) IF (SYMTYP(S1) .EQ. FUNC) THEN IF (GETIWA(IFN,SYMREF(S1),1,IWA,LIWA,INFOLI) .NE. 1) THEN IERR=35 GO TO 9999 ENDIF ELSE IERR=8 GO TO 9999 ENDIF IF (SYMTYP(S3) .NE. INDVAR) THEN IERR=8 GO TO 9999 ELSE IF (GETIWA(IFN,SYMREF(S1),2,IWA,LIWA,INFOLI) .NE. 1 SYMREF(S3)) THEN IERR=33 GO TO 9999 ENDIF CALL PUT1(ASSIGN,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 PC=IWA(13) C C stmt : IF {} '(' logic_expr ')' THEN '\n' stmts opt_else_if C opt_else ENDIF '\n' C ELSE IF (YYTMP .EQ. 71) THEN CALL PUT1(IF+128,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C stmt : IF '(' logic_expr ')' {} THEN '\n' stmts opt_else_if C opt_else ENDIF '\n' C ELSE IF (YYTMP .EQ. 72) THEN S1=YYV(YYPVT-3) CALL PUT1(BEQ,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(-100,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 YYV(YYPVT-3)=IWA(13) C C stmt : IF '(' logic_expr ')' THEN '\n' stmts {} opt_else_if C opt_else ENDIF '\n' C ELSE IF (YYTMP .EQ. 73) THEN CALL PUT1(BRA,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(-200,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C stmt : IF '(' logic_expr ')' THEN '\n' stmts opt_else_if C opt_else ENDIF '\n' {} C ELSE IF (YYTMP .EQ. 74) THEN CALL PUT1(ENDIF+128,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 S1=YYV(YYPVT-12) PC1=S1 2400 IF ((GETIWA(VPF,PC1,0,IWA,LIWA,INFOLI) .NE. -100) .AND. 1 (PC1 .LT. IWA(13))) THEN PC1=PC1+1 GO TO 2400 ENDIF PC2=PC1+1 2410 IF ((GETIWA(VPF,PC2,0,IWA,LIWA,INFOLI).NE. -200) .AND. 1 (PC2 .LT. IWA(13))) THEN PC2=PC2+1 GO TO 2410 ENDIF IF (PC2 .LT. IWA(13)) THEN CALL PUT1(PC2+1,0.0D0,VPF,PC1,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(IWA(13)+1,0.0D0,VPF,PC2,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 PC1=PC1+1 GO TO 2400 ELSE IF (GETIWA(VPF,PC1-1,0,IWA,LIWA,INFOLI) .EQ. BEQ) THEN CALL PUT1(IWA(13)+1,0.0D0,VPF,PC1,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ENDIF C C stmt : MARKE CONTINUE '\n' {} C ELSE IF (YYTMP .EQ. 75) THEN S1=YYV(YYPVT-2) IF (MC .GT. 0) THEN IHELP1=GETIWA(VIC,S1,0,IWA,LIWA,INFOLI) DO 2500 I=1,MC IF (MARKST(I,1) .EQ. IHELP1) THEN IERR=57 LNUM=IHELP1 ENDIF 2500 CONTINUE IF (IERR .NE. 0) GO TO 9999 ENDIF MC=MC+1 IF (MC .GT. MAXMAR) THEN IERR=32 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(VIC,S1,0,IWA,LIWA,INFOLI) MARKST(MC,1)=IHELP1 MARKST(MC,2)=IWA(13)+1 CALL PUT1(CONTIN,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) CALL PUT1(IHELP1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF C C stmt : GOTO INUM '\n' {} C ELSE IF (YYTMP .EQ. 76) THEN S2=YYV(YYPVT-1) GC=GC+1 IF (GC .GT. MAXMAR) THEN IERR=32 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(VIC,S2,0,IWA,LIWA,INFOLI) GOTOST(GC,1)=IHELP1 GOTOST(GC,2)=IWA(13)+1 CALL PUT1(GOTO,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) CALL PUT1(IHELP1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) CALL PUT1(0,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF C C opt_else_if : opt_else_if ELSE IF '(' logic_expr ')' {} C THEN stmts '\n' C ELSE IF (YYTMP .EQ. 77) THEN CALL PUT1(BEQ,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(-100,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C opt_else_if : opt_else_if ELSE IF '(' logic_expr ')' C THEN stmts '\n' {} C ELSE IF (YYTMP .EQ. 78) THEN CALL PUT1(BRA,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(-200,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C opt_else : /* empty */ {} C ELSE IF (YYTMP .EQ. 81) THEN CALL UNVPF(IWA(13)-2,LIWA,PLIWA,IWA,INFOLI) C C expr : expr '+' expr {} C ELSE IF (YYTMP .EQ. 82) THEN CALL PUT1(ADD,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C expr : expr '-' expr {} C ELSE IF (YYTMP .EQ. 83) THEN CALL PUT1(SUB,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C expr : expr '*' expr {} C ELSE IF (YYTMP .EQ. 84) THEN CALL PUT1(MULT,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C expr : expr '/' expr {} C ELSE IF (YYTMP .EQ. 85) THEN CALL PUT1(DIV,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C expr : expr '^' expr {} C ELSE IF (YYTMP .EQ. 86) THEN IHELP1=GETIWA(VPF,IWA(13),0,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. UMINUS) THEN IHELP1=GETIWA(VPF,IWA(13)-2,0,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. INUM) THEN CALL PUT1(POWER+128,0.0D0,VPF,IWA(13)-2,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) IHELP2=GETIWA(VPF,IWA(13)-1,0,IWA,LIWA,INFOLI) IHELP3=-GETIWA(VIC,IHELP2,0,IWA,LIWA,INFOLI) CALL PUT1(IHELP3,0.0D0,VPF,IWA(13)-1,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) CALL UNVPF(IWA(13)-1,LIWA,PLIWA,IWA,INFOLI) ELSE CALL PUT1(POWER,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ENDIF ELSE IHELP1=GETIWA(VPF,IWA(13)-1,0,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. INUM) THEN CALL PUT1(POWER+128,0.0D0,VPF,IWA(13)-1,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) IHELP2=GETIWA(VPF,IWA(13),0,IWA,LIWA,INFOLI) IHELP3=GETIWA(VIC,IHELP2,0,IWA,LIWA,INFOLI) CALL PUT1(IHELP3,0.0D0,VPF,IWA(13),LIWA,PLIWA,IWA,LWA,PLWA, 1 WA,INFOLI,IERR) ELSE CALL PUT1(POWER,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ENDIF ENDIF C C expr : '-' expr %prec UMINUS {} C ELSE IF (YYTMP .EQ. 88) THEN CALL PUT1(UMINUS,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C expr : SUM {} '(' expr ',' ID IN ID ')' C ELSE IF (YYTMP .EQ. 93) THEN CALL PUT1(SUM,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(0,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(0,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 YYV(YYPVT)=IWA(13)-2 C C expr : SUM '(' expr ',' ID IN ID ')' {} C ELSE IF (YYTMP .EQ. 94) THEN S1=YYV(YYPVT-8) S6=YYV(YYPVT-3) S8=YYV(YYPVT-1) IF (SYMTYP(S6) .EQ. 0) THEN SYMTYP(S6)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 SYMREF(S6)=IWA(14) ELSE IF (SYMTYP(S6) .NE. INDVAR) THEN IERR=8 GO TO 9999 ENDIF IF (SYMTYP(S8) .NE. INDEX) THEN IERR=8 GO TO 9999 ENDIF CALL PUT1(SYMREF(S6),0.0D0,VPF,S1+1,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S8),0.0D0,VPF,S1+2,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(ENDSUM,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C expr : PROD {} '(' expr ',' ID IN ID ')' C ELSE IF (YYTMP .EQ. 95) THEN CALL PUT1(PROD,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(0,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(0,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 YYV(YYPVT)=IWA(13)-2 C C expr : PROD '(' expr ',' ID IN ID ')' {} C ELSE IF (YYTMP .EQ. 96) THEN S1=YYV(YYPVT-8) S6=YYV(YYPVT-3) S8=YYV(YYPVT-1) IF (SYMTYP(S6) .EQ. 0) THEN SYMTYP(S6)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 SYMREF(S6)=IWA(14) ELSE IF (SYMTYP(S6) .NE. INDVAR) THEN IERR=8 GO TO 9999 ENDIF IF (SYMTYP(S8) .NE. INDEX) THEN IERR=8 GO TO 9999 ENDIF CALL PUT1(SYMREF(S6),0.0D0,VPF,S1+1,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S8),0.0D0,VPF,S1+2,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(ENDPRD,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C logic_expr : logic_expr AND logic_expr {} C ELSE IF (YYTMP .EQ. 97) THEN CALL PUT1(AND,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C logic_expr : logic_expr OR logic_expr {} C ELSE IF (YYTMP .EQ. 98) THEN CALL PUT1(OR,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C logic_expr : NOT logic_expr {} C ELSE IF (YYTMP .EQ. 99) THEN CALL PUT1(NOT,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C logic_expr : expr RELOP expr {} C ELSE IF (YYTMP .EQ. 101) THEN CALL PUT1(RELOP,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(YYV(YYPVT-1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C number : RNUM {} C ELSE IF (YYTMP .EQ. 102) THEN CALL PUT1(RNUM,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(YYV(YYPVT),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C number : INUM {} C ELSE IF (YYTMP .EQ. 103) THEN CALL PUT1(INUM,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(YYV(YYPVT),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 C C identifier : ID {} C ELSE IF (YYTMP .EQ. 104) THEN S1=YYV(YYPVT) IF (SYMTYP(S1) .EQ. 0) THEN SYMTYP(S1)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 SYMREF(S1)=IWA(14) ENDIF IF (SYMTYP(S1) .EQ. INDVAR) THEN CALL PUT1(INDVAR,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IF (SYMTYP(S1) .EQ. REAL) THEN IHELP1=GETIWA(IRC,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. 0) THEN CALL PUT1(REAL,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. INT) THEN IHELP1=GETIWA(IIC,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. 0) THEN CALL PUT1(INT,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. VAR) THEN IHELP1=GETIWA(IVA,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. 0) THEN CALL PUT1(VAR,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. FUNC) THEN IHELP1=GETIWA(IFN,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. -1) THEN CALL PUT1(-FUNC,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1)-IWA(10),0.0D0,VPF,0,LIWA,PLIWA,IWA, 1 LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IF (IHELP1 .EQ. 0) THEN CALL PUT1(FUNC,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA, 1 LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IERR=8 GO TO 9999 ENDIF C C identifier : ID '(' ind_expr ')' {} C ELSE IF (YYTMP .EQ. 105) THEN S1=YYV(YYPVT-3) IF (SYMTYP(S1) .EQ. REAL) THEN IHELP1=GETIWA(IRC,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. 1) THEN CALL PUT1(REAL,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. INT) THEN IHELP1=GETIWA(IIC,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. 1) THEN CALL PUT1(INT,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. VAR) THEN IHELP1=GETIWA(IVA,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. 1) THEN CALL PUT1(VAR,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. FUNC) THEN IHELP1=GETIWA(IFN,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. 1) THEN CALL PUT1(FUNC,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. 0) THEN IERR=7 GO TO 9999 ELSE IERR=8 GO TO 9999 ENDIF C C identifier : ID '(' ind_expr ',' ind_expr ')' {} C ELSE IF (YYTMP .EQ. 106) THEN S1=YYV(YYPVT-5) IF (SYMTYP(S1) .EQ. REAL) THEN IHELP1=GETIWA(IRC,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. 2) THEN CALL PUT1(REAL,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. INT) THEN IHELP1=GETIWA(IIC,SYMREF(S1),1,IWA,LIWA,INFOLI) IF (IHELP1 .EQ. 2) THEN CALL PUT1(INT,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(SYMREF(S1),0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=35 GO TO 9999 ENDIF ELSE IF (SYMTYP(S1) .EQ. 0) THEN IERR=7 GO TO 9999 ELSE IERR=8 GO TO 9999 ENDIF C C standard_function : STDRD {} C ELSE IF (YYTMP .EQ. 107) THEN S1=YYV(YYPVT) IF (STDTYP(S1) .EQ. 0) THEN CALL PUT1(STDRD,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(S1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=36 GO TO 9999 ENDIF C C standard_function : STDRD '(' expr ')' {} C ELSE IF (YYTMP .EQ. 108) THEN S1=YYV(YYPVT-3) IF (STDTYP(S1) .EQ. 1) THEN CALL PUT1(STDRD,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(S1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=36 GO TO 9999 ENDIF C C standard_function : STDRD '(' expr ',' expr ')' {} C ELSE IF (YYTMP .EQ. 109) THEN S1=YYV(YYPVT-5) IF (STDTYP(S1) .EQ. 2) THEN CALL PUT1(STDRD,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(S1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=36 GO TO 9999 ENDIF C C extern_function : EXTERN {} C ELSE IF (YYTMP .EQ. 110) THEN S1=YYV(YYPVT) IF (EXTTYP(S1) .EQ. 0) THEN CALL PUT1(EXTERN,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(S1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=36 GO TO 9999 ENDIF C C extern_function : EXTERN '(' ind_expr ')' {} C ELSE IF (YYTMP .EQ. 111) THEN S1=YYV(YYPVT-3) IF (EXTTYP(S1) .EQ. 1) THEN CALL PUT1(EXTERN,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(S1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=36 GO TO 9999 ENDIF C C extern_function : EXTERN '(' ind_expr ',' ind_expr ')' {} C ELSE IF (YYTMP .EQ. 112) THEN S1=YYV(YYPVT-5) IF (EXTTYP(S1) .EQ. 2) THEN CALL PUT1(EXTERN,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) CALL PUT1(S1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) GO TO 9999 ELSE IERR=36 GO TO 9999 ENDIF C C C ELSE IERR=26 WRITE(*,*) 'YYPAR (2833) : unknown state ',YYTMP GO TO 9999 ENDIF C C reset registers in driver code C GO TO 10 9999 CONTINUE RETURN END C C C C*** pcomp_p2.f SUBROUTINE CASE38(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) C INTEGER YYPVT,YYV(0:149) INTEGER SYMTYP(100),SYMREF(100) INTEGER LWA,LIWA,PLWA,PLIWA,IERR,LNUM INTEGER IWA(LIWA) DOUBLE PRECISION WA(LWA) INTEGER INFOLI(14) INTEGER PC C INTEGER VEK4(4) INTEGER IHELP1,IHELP2,IHELP3,IHELP4,GETIWA INTEGER MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA,MPIFN INTEGER MPVFN,MPVPF,MPIV INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) C DOUBLE PRECISION FVAL INTEGER S1,S3,S8,S10 INTEGER IVAL C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C S1=YYV(YYPVT-10) S3=YYV(YYPVT-8) S8=YYV(YYPVT-3) S10=YYV(YYPVT-1) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=REAL SYMREF(S1)=IWA(5)+1 IF (SYMTYP(S3) .EQ. 0) THEN SYMTYP(S3)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S3)=IWA(14) ELSE IF (SYMTYP(S3) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF (SYMTYP(S10) .NE. INDEX) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S10),3,IWA,LIWA,INFOLI) IF ((S3 .NE. S8) .OR. (IHELP1 .LE. 0)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF VEK4(1)=1 VEK4(2)=GETIWA(IIS,SYMREF(S10),4,IWA,LIWA,INFOLI) VEK4(3)=0 VEK4(4)=IWA(6)+1 CALL PUT4(VEK4,IRC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IRC,IWA(5),2,IWA,LIWA,INFOLI) DO 1300 I=1,IHELP1 CALL PUT1(0,0.0D0,VRC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) 1300 CONTINUE IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S10),2,IWA,LIWA,INFOLI) DO 1310 I=1,IHELP1 IHELP2=GETIWA(IIS,SYMREF(S10),5,IWA,LIWA,INFOLI) IHELP3=GETIWA(VIS,IHELP2+I-1,0,IWA,LIWA,INFOLI) CALL PUT1(IHELP3,0.0D0,IV,SYMREF(S3),LIWA,PLIWA,IWA,LWA,PLWA, 1 WA,INFOLI,IERR) MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IRC,IWA(5),2,IWA,LIWA,INFOLI) IHELP4=GETIWA(IV,SYMREF(S3),0,IWA,LIWA,INFOLI) CALL PUT1(0,FVAL,VRC,IWA(6)-IHELP1+IHELP4,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) 1310 CONTINUE CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C 9999 CONTINUE RETURN END C C C SUBROUTINE CASE39(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) C INTEGER YYPVT,YYV(0:149) INTEGER SYMTYP(100),SYMREF(100) INTEGER LWA,LIWA,PLWA,PLIWA,IERR,LNUM INTEGER IWA(LIWA) DOUBLE PRECISION WA(LWA) INTEGER INFOLI(14) INTEGER PC C INTEGER IHELP1,IHELP2,GETIWA INTEGER MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA,MPIFN INTEGER MPVFN,MPVPF,MPIV INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) C DOUBLE PRECISION FVAL INTEGER S1,S3 INTEGER IVAL C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C S1=YYV(YYPVT-6) S3=YYV(YYPVT-4) IF (SYMTYP(S1) .NE. REAL) THEN IERR=7 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(IRC,SYMREF(S1),2,IWA,LIWA,INFOLI) IF ((IHELP1 .LT. 1) .OR. 1 (IHELP1 .GT. IHELP2)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IRC,SYMREF(S1),4,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) CALL PUT1(0,FVAL,VRC,IHELP1+IHELP2-1,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C 9999 CONTINUE RETURN END C C C SUBROUTINE CASE40(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) C INTEGER YYPVT,YYV(0:149) INTEGER SYMTYP(100),SYMREF(100) INTEGER LWA,LIWA,PLWA,PLIWA,IERR,LNUM INTEGER IWA(LIWA) DOUBLE PRECISION WA(LWA) INTEGER INFOLI(14) INTEGER PC C INTEGER VEK4(4) INTEGER IHELP1,IHELP2,IHELP3,IHELP4,IHELP5,IHELP6,IHELP7 INTEGER IHELP8,IHELP9,GETIWA INTEGER MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA,MPIFN INTEGER MPVFN,MPVPF,MPIV INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) C DOUBLE PRECISION FVAL INTEGER S1,S3,S5,S10,S12,S14,S16 INTEGER IVAL C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C S1=YYV(YYPVT-16) S3=YYV(YYPVT-14) S5=YYV(YYPVT-12) S10=YYV(YYPVT-7) S12=YYV(YYPVT-5) S14=YYV(YYPVT-3) S16=YYV(YYPVT-1) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=REAL SYMREF(S1)=IWA(5)+1 IF (SYMTYP(S3) .EQ. 0) THEN SYMTYP(S3)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S3)=IWA(14) ELSE IF (SYMTYP(S3) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF (SYMTYP(S5) .EQ. 0) THEN SYMTYP(S5)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S5)=IWA(14) ELSE IF (SYMTYP(S5) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF ((SYMTYP(S12) .NE. INDEX) .OR. 1 (SYMTYP(S16) .NE. INDEX)) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S12),3,IWA,LIWA,INFOLI) IHELP2=GETIWA(IIS,SYMREF(S16),3,IWA,LIWA,INFOLI) IF ((S3 .NE. S10) .OR. (S5 .NE. S14) .OR. 1 (IHELP1 .LE. 0) .OR. (IHELP2 .LE. 0)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF VEK4(1)=2 VEK4(2)=GETIWA(IIS,SYMREF(S12),4,IWA,LIWA,INFOLI) VEK4(3)=GETIWA(IIS,SYMREF(S16),4,IWA,LIWA,INFOLI) VEK4(4)=IWA(6)+1 CALL PUT4(VEK4,IRC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IRC,IWA(5),2,IWA,LIWA,INFOLI) IHELP2=GETIWA(IRC,IWA(5),3,IWA,LIWA,INFOLI) DO 1400 I=1,IHELP1*IHELP2 CALL PUT1(0,0.0D0,VRC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) 1400 CONTINUE IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S12),2,IWA,LIWA,INFOLI) DO 1420 I=1,IHELP1 IHELP2=GETIWA(IIS,SYMREF(S12),5,IWA,LIWA,INFOLI) IHELP3=GETIWA(VIS,IHELP2+I-1,0,IWA,LIWA,INFOLI) CALL PUT1(IHELP3,0.0D0,IV,SYMREF(S3),LIWA,PLIWA,IWA,LWA,PLWA, 1 WA,INFOLI,IERR) IHELP4=GETIWA(IIS,SYMREF(S16),2,IWA,LIWA,INFOLI) DO 1410 J=1,IHELP4 IHELP5=GETIWA(IIS,SYMREF(S16),5,IWA,LIWA,INFOLI) IHELP6=GETIWA(VIS,IHELP5+J-1,0,IWA,LIWA,INFOLI) CALL PUT1(IHELP6,0.0D0,IV,SYMREF(S5),LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IRC,IWA(5),2,IWA,LIWA,INFOLI) IHELP2=GETIWA(IRC,IWA(5),3,IWA,LIWA,INFOLI) IHELP7=GETIWA(IV,SYMREF(S3),0,IWA,LIWA,INFOLI) IHELP8=GETIWA(IRC,IWA(5),3,IWA,LIWA,INFOLI) IHELP9=GETIWA(IV,SYMREF(S5),0,IWA,LIWA,INFOLI) CALL PUT1(0,FVAL,VRC, 1 IWA(6)-(IHELP1*IHELP2)+(IHELP7-1)*IHELP8+IHELP9, 2 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) 1410 CONTINUE 1420 CONTINUE CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C 9999 CONTINUE RETURN END C C C SUBROUTINE CASE41(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) C INTEGER YYPVT,YYV(0:149) INTEGER SYMTYP(100),SYMREF(100) INTEGER LWA,LIWA,PLWA,PLIWA,IERR,LNUM INTEGER IWA(LIWA) DOUBLE PRECISION WA(LWA) INTEGER INFOLI(14) INTEGER PC C INTEGER IHELP1,IHELP2,IHELP3,IHELP4,GETIWA INTEGER MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA,MPIFN INTEGER MPVFN,MPVPF,MPIV INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) C DOUBLE PRECISION FVAL INTEGER S1,S3,S5 INTEGER IVAL C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C S1=YYV(YYPVT-8) S3=YYV(YYPVT-6) S5=YYV(YYPVT-4) IF (SYMTYP(S1) .NE. REAL) THEN IERR=7 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S5,0,IWA,LIWA,INFOLI) IHELP3=GETIWA(IRC,SYMREF(S1),2,IWA,LIWA,INFOLI) IHELP4=GETIWA(IRC,SYMREF(S1),3,IWA,LIWA,INFOLI) IF ((IHELP1 .LT. 1) .OR. (IHELP1 .GT. IHELP3) .OR. 1 (IHELP2 .LT. 1) .OR. (IHELP2 .GT. IHELP4)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IRC,SYMREF(S1),4,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) IHELP3=GETIWA(IRC,SYMREF(S1),3,IWA,LIWA,INFOLI) IHELP4=GETIWA(VIC,S5,0,IWA,LIWA,INFOLI) CALL PUT1(0,FVAL,VRC,IHELP1+(IHELP2-1)*IHELP3+IHELP4-1, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C 9999 CONTINUE RETURN END C C C SUBROUTINE CASE46(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) C INTEGER YYPVT,YYV(0:149) INTEGER SYMTYP(100),SYMREF(100) INTEGER LWA,LIWA,PLWA,PLIWA,IERR,LNUM INTEGER IWA(LIWA) DOUBLE PRECISION WA(LWA) INTEGER INFOLI(14) INTEGER PC C INTEGER VEK4(4) INTEGER IHELP1,IHELP2,IHELP3,IHELP4,GETIWA INTEGER MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA,MPIFN INTEGER MPVFN,MPVPF,MPIV INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) C DOUBLE PRECISION FVAL INTEGER S1,S3,S8,S10 INTEGER IVAL C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C C S1=YYV(YYPVT-10) S3=YYV(YYPVT-8) S8=YYV(YYPVT-3) S10=YYV(YYPVT-1) IF (SYMTYP(S1) .NE. 0) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=INT SYMREF(S1)=IWA(3)+1 IF (SYMTYP(S3) .EQ. 0) THEN SYMTYP(S3)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S3)=IWA(14) ELSE IF (SYMTYP(S3) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF (SYMTYP(S10) .NE. INDEX) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S10),3,IWA,LIWA,INFOLI) IF ((S3 .NE. S8) .OR. (IHELP1 .LE. 0)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF VEK4(1)=1 VEK4(2)=GETIWA(IIS,SYMREF(S10),4,IWA,LIWA,INFOLI) VEK4(3)=0 VEK4(4)=IWA(4)+1 CALL PUT4(VEK4,IIC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIC,IWA(3),2,IWA,LIWA,INFOLI) DO 1500 I=1,IHELP1 CALL PUT1(0,0.0D0,VIC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) 1500 CONTINUE IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S10),2,IWA,LIWA,INFOLI) DO 1510 I=1,IHELP1 IHELP2=GETIWA(IIS,SYMREF(S10),5,IWA,LIWA,INFOLI) IHELP3=GETIWA(VIS,IHELP2+I-1,0,IWA,LIWA,INFOLI) CALL PUT1(IHELP3,0.0D0,IV,SYMREF(S3),LIWA,PLIWA,IWA,LWA,PLWA, 1 WA,INFOLI,IERR) MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIC,IWA(3),2,IWA,LIWA,INFOLI) IHELP4=GETIWA(IV,SYMREF(S3),0,IWA,LIWA,INFOLI) CALL PUT1(IDNINT(FVAL),0.0D0,VIC,IWA(4)-IHELP1+IHELP4,LIWA, 1 PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) 1510 CONTINUE CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C C 9999 CONTINUE RETURN END C C C SUBROUTINE CASE47(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) C INTEGER YYPVT,YYV(0:149) INTEGER SYMTYP(100),SYMREF(100) INTEGER LWA,LIWA,PLWA,PLIWA,IERR,LNUM INTEGER IWA(LIWA) DOUBLE PRECISION WA(LWA) INTEGER INFOLI(14) INTEGER PC C INTEGER IHELP1,IHELP2,GETIWA INTEGER MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA,MPIFN INTEGER MPVFN,MPVPF,MPIV INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) C DOUBLE PRECISION FVAL INTEGER S1,S3 INTEGER IVAL C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C C S1=YYV(YYPVT-6) S3=YYV(YYPVT-4) IF (SYMTYP(S1) .NE. INT) THEN IERR=7 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) IHELP2=GETIWA(IIC,SYMREF(S1),2,IWA,LIWA,INFOLI) IF ((IHELP1 .LT. 0) .OR. (IHELP1 .GT. IHELP2)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIC,SYMREF(S1),4,IWA,LIWA,INFOLI) IHELP2=GETIWA(VIC,S3,0,IWA,LIWA,INFOLI) CALL PUT1(IDNINT(FVAL),0.0D0,VIC,IHELP1+IHELP2-1,LIWA,PLIWA, 1 IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C 9999 CONTINUE RETURN END C C C SUBROUTINE CASE48(YYV,YYPVT,SYMTYP,SYMREF,IERR,LNUM, 1 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,PC) C INTEGER YYPVT,YYV(0:149) INTEGER SYMTYP(100),SYMREF(100) INTEGER LWA,LIWA,PLWA,PLIWA,IERR,LNUM INTEGER IWA(LIWA) DOUBLE PRECISION WA(LWA) INTEGER INFOLI(14) INTEGER PC C INTEGER VEK4(4) INTEGER IHELP1,IHELP2,IHELP3,IHELP4,IHELP5,IHELP6,IHELP7 INTEGER IHELP8,IHELP9,GETIWA INTEGER MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA,MPIFN INTEGER MPVFN,MPVPF,MPIV INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) C DOUBLE PRECISION FVAL INTEGER S1,S3,S5,S10,S12,S14,S16 INTEGER IVAL C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C S1=YYV(YYPVT-16) S3=YYV(YYPVT-14) S5=YYV(YYPVT-12) S10=YYV(YYPVT-7) S12=YYV(YYPVT-5) S14=YYV(YYPVT-3) S16=YYV(YYPVT-1) IF (SYMTYP(S1) .NE. 0) THEN IERR=4 LNUM=LNUM-1 GO TO 9999 ENDIF SYMTYP(S1)=INT SYMREF(S1)=IWA(3)+1 IF (SYMTYP(S3) .EQ. 0) THEN SYMTYP(S3)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S3)=IWA(14) ELSE IF (SYMTYP(S3) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF (SYMTYP(S5) .EQ. 0) THEN SYMTYP(S5)=INDVAR CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF SYMREF(S5)=IWA(14) ELSE IF (SYMTYP(S5) .NE. INDVAR) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IF ((SYMTYP(S12) .NE. INDEX) .OR. 1 (SYMTYP(S16) .NE. INDEX)) THEN IERR=8 LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S12),3,IWA,LIWA,INFOLI) IHELP2=GETIWA(IIS,SYMREF(S16),3,IWA,LIWA,INFOLI) IF ((S3 .NE. S10) .OR. (S5 .NE. S14) .OR. 1 (IHELP1 .LE. 0) .OR. (IHELP2 .LE. 0)) THEN IERR=33 LNUM=LNUM-1 GO TO 9999 ENDIF VEK4(1)=2 VEK4(2)=GETIWA(IIS,SYMREF(S12),4,IWA,LIWA,INFOLI) VEK4(3)=GETIWA(IIS,SYMREF(S16),4,IWA,LIWA,INFOLI) VEK4(4)=IWA(4)+1 CALL PUT4(VEK4,IIC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIC,IWA(3),2,IWA,LIWA,INFOLI) IHELP2=GETIWA(IIC,IWA(3),3,IWA,LIWA,INFOLI) DO 1600 I=1,IHELP1*IHELP2 CALL PUT1(0,0.0D0,VIC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 1 IERR) 1600 CONTINUE IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF CALL PUT1(-1,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIS,SYMREF(S12),2,IWA,LIWA,INFOLI) DO 1620 I=1,IHELP1 IHELP2=GETIWA(IIS,SYMREF(S12),5,IWA,LIWA,INFOLI) IHELP3=GETIWA(VIS,IHELP2+I-1,0,IWA,LIWA,INFOLI) CALL PUT1(IHELP3,0.0D0,IV,SYMREF(S3),LIWA,PLIWA,IWA,LWA,PLWA, 1 WA,INFOLI,IERR) IHELP4=GETIWA(IIS,SYMREF(S16),2,IWA,LIWA,INFOLI) DO 1610 J=1,IHELP4 IHELP5=GETIWA(IIS,SYMREF(S16),5,IWA,LIWA,INFOLI) IHELP6=GETIWA(VIS,IHELP5+J-1,0,IWA,LIWA,INFOLI) CALL PUT1(IHELP6,0.0D0,IV,SYMREF(S5),LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,IERR) MPIIS=MAX0(1,IWA(1)) MPVIS=MAX0(1,IWA(2)) MPIIC=MAX0(1,IWA(3)) MPVIC=MAX0(1,IWA(4)) MPIRC=MAX0(1,IWA(5)) MPVRC=MAX0(1,IWA(6)) MPIVA=MAX0(1,IWA(7)) MPVVA=MAX0(1,IWA(8)) MPIFN=MAX0(1,IWA(9)) MPVFN=MAX0(1,IWA(11)) MPVPF=MAX0(1,IWA(13)) MPIV =MAX0(1,IWA(14)) CALL EVAL(PC+1,IVAL,FVAL,NOGRAD,IWA(8), 1 MPIIS,MPVIS,MPIIC,MPVIC,MPIRC,MPVRC,MPIVA,MPVVA, 2 MPIFN,MPVFN,MPVPF,MPIV, 3 IWA(INFOLI(1)+1),IWA(INFOLI(2)+1), 4 IWA(INFOLI(3)+1),IWA(INFOLI(4)+1),IWA(INFOLI(5)+1), 5 WA(INFOLI(6)+1),IWA(INFOLI(7)+1),WA(INFOLI(8)+1), 6 IWA(INFOLI(9)+1),WA(INFOLI(11)+1),WA(INFOLI(12)+1), 7 IWA(INFOLI(13)+1),IWA(INFOLI(14)+1), 8 WA(IWA(12)+1),IERR) IF (IERR .NE. 0) THEN LNUM=LNUM-1 GO TO 9999 ENDIF IHELP1=GETIWA(IIC,IWA(3),2,IWA,LIWA,INFOLI) IHELP2=GETIWA(IIC,IWA(3),3,IWA,LIWA,INFOLI) IHELP7=GETIWA(IV,SYMREF(S3),0,IWA,LIWA,INFOLI) IHELP8=GETIWA(IIC,IWA(3),3,IWA,LIWA,INFOLI) IHELP9=GETIWA(IV,SYMREF(S5),0,IWA,LIWA,INFOLI) CALL PUT1(IDNINT(FVAL),0.0D0,VIC, 1 IWA(4)-(IHELP1*IHELP2)+(IHELP7-1)*IHELP8+IHELP9, 2 LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) 1610 CONTINUE 1620 CONTINUE CALL UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C 9999 CONTINUE RETURN END C C C SUBROUTINE SYMINP (INPUT,SYMFIL,WA,LWA,IWA,LIWA,PLWA,PLIWA, 1 IERR,LNUM) INTEGER INPUT,SYMFIL INTEGER LWA,LIWA DOUBLE PRECISION WA(LWA) INTEGER IWA(LIWA) INTEGER PLWA,PLIWA INTEGER IERR,LNUM C INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) INTEGER INFOLI(14),VEK3(3),VEK4(4),VEK5(5),VEK6(6) INTEGER I C INTEGER GSMDEP PARAMETER (GSMDEP=10) C PLIWA=14 PLWA=0 DO 1 I=1,3 VEK3(I)=0 1 CONTINUE DO 2 I=1,4 VEK4(I)=0 2 CONTINUE DO 3 I=1,5 VEK5(I)=0 3 CONTINUE DO 4 I=1,6 VEK6(I)=0 4 CONTINUE DO 8 I=1,LWA WA(I)=0.0D0 8 CONTINUE DO 9 I=1,LIWA IWA(I)=0 9 CONTINUE C CALL YYPAR (INPUT,WA,LWA,IWA,LIWA,PLWA,PLIWA,IERR,LNUM) IF (IERR .NE. 0) RETURN C INFOLI(1)=14 INFOLI(2)=IWA(1)*5+INFOLI(1) INFOLI(3)=IWA(2)+INFOLI(2) INFOLI(4)=IWA(3)*4+INFOLI(3) INFOLI(5)=IWA(4)+INFOLI(4) INFOLI(7)=IWA(5)*4+INFOLI(5) INFOLI(9)=IWA(7)*3+INFOLI(7) INFOLI(13)=IWA(9)*6+INFOLI(9) INFOLI(14)=IWA(13)+INFOLI(13) C INFOLI(6)=0 INFOLI(8)=IWA(6)+INFOLI(6) INFOLI(11)=IWA(8)+INFOLI(8) INFOLI(12)=IWA(11)+INFOLI(11) C IF (IWA(1) .EQ. 0) 1 CALL PUT5(VEK5,IIS,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IWA(2) .EQ. 0) 1 CALL PUT1(0,0.0D0,VIS,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IWA(3) .EQ. 0) 1 CALL PUT4(VEK4,IIC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IWA(4) .EQ. 0) 1 CALL PUT1(0,0.0D0,VIC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IWA(5) .EQ. 0) 1 CALL PUT4(VEK4,IRC,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IWA(6) .EQ. 0) 1 CALL PUT1(0,0.0D0,VRC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IWA(7) .EQ. 0) 1 CALL PUT3(VEK3,IVA,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IWA(8) .EQ. 0) 1 CALL PUT1(0,0.0D0,VVA,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IWA(9) .EQ. 0) 1 CALL PUT6(VEK6,IFN,0,LIWA,PLIWA,IWA,INFOLI,IERR) IF (IWA(11) .EQ. 0) 1 CALL PUT1(0,0.0D0,VFN,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IWA(12) .EQ. 0) 1 CALL PUT1(0,0.0D0,VGR,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IWA(13) .EQ. 0) 1 CALL PUT1(0,0.0D0,VPF,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IWA(14) .EQ. 0) 1 CALL PUT1(0,0.0D0,IV,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) C DO 90 I=1,PLIWA-IWA(14) WRITE(SYMFIL,'(I6)',ERR=100) IWA(I) 90 CONTINUE DO 91 I=1,IWA(6) WRITE(SYMFIL,'(D24.17)',ERR=100) WA(I) 91 CONTINUE PLWA=IWA(6)+IWA(8)+IWA(11)+IWA(11)*IWA(8)+GSMDEP*IWA(8) IF (PLWA .GT. LWA) THEN IERR=32 RETURN ENDIF RETURN 100 IERR=26 RETURN END C C C SUBROUTINE KLEIN (D,BUCHST) CHARACTER D LOGICAL BUCHST C CHARACTER DAK,DAG,DZK DAK='a' DAG='A' DZK='z' BUCHST = ((ICHAR(DAK) .LE. ICHAR(D)) .AND. 1 (ICHAR(D) .LE. ICHAR(DZK))) RETURN END C C C SUBROUTINE UPCASE (D) CHARACTER D C CHARACTER DAK,DAG,DZK DAK='a' DAG='A' DZK='z' D = CHAR(ICHAR(D)+ICHAR(DAG)-ICHAR(DAK)) RETURN END C C C CHARACTER FUNCTION GETCHR (FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) INTEGER FD,LNUM,LPOS,SPOS CHARACTER STAR*5,CONT*1,LINE*66 LOGICAL EOF C CHARACTER D LOGICAL BUCHST C IF (LPOS .EQ. 67) THEN 5 LNUM=LNUM+1 READ(FD,'(A5,A1,A66)',END=10) STAR,CONT,LINE IF ((STAR(1:1) .EQ. 'C') .OR. (STAR(1:1) .EQ. 'c') .OR. 1 (LINE .EQ. ' ')) GO TO 5 IF (CONT .EQ. ' ' .OR. CONT .EQ. '0') THEN GETCHR='#' LPOS=1 SPOS=2 RETURN ELSE LPOS=1 SPOS=2 ENDIF ENDIF IF (STAR(1:1) .EQ. '*') THEN GETCHR='\\' STAR(1:1)=' ' RETURN ENDIF IF (SPOS .LE. 5) THEN D=STAR(SPOS:SPOS) CALL KLEIN(D,BUCHST) IF (BUCHST) CALL UPCASE(D) GETCHR=D SPOS=SPOS+1 RETURN ENDIF D=LINE(LPOS:LPOS) LPOS=LPOS+1 CALL KLEIN(D,BUCHST) IF (BUCHST) CALL UPCASE(D) GETCHR=D RETURN 10 GETCHR='#' EOF=.TRUE. RETURN END C C C SUBROUTINE UNGTC (LPOS,IERR) C INTEGER LPOS INTEGER IERR C IF (LPOS .GT. 1) THEN LPOS=LPOS-1 ELSE IERR=48 ENDIF RETURN END C C C INTEGER FUNCTION KEYWD (STRING,YYLVAL,IERR) CHARACTER*(*) STRING INTEGER YYLVAL,IERR C INTEGER RELOP,AND,OR,NOT,ID,SUM,PROD,IN,IF,THEN,ELSE INTEGER ENDIF,STDRD,EXTERN,GOTO,CONTIN PARAMETER (RELOP=258,AND=259,OR=260,NOT=261,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269) PARAMETER (ELSE=270,ENDIF=271,STDRD=272,EXTERN=273) PARAMETER (GOTO=282,CONTIN=284) C INTEGER MAXSTD,MAXEXT PARAMETER (MAXSTD=17,MAXEXT=1) C CHARACTER*6 STDNAM(MAXSTD),ALTNAM(MAXSTD),EXTNAM(MAXEXT) CHARACTER*4 RELNAM(6) C INTEGER I C DATA STDNAM /'DABS','DSQRT','DEXP','DLOG','DLOG10', 1 'DSIN','DCOS','DTAN','DASIN','DACOS','DATAN', 2 'DSINH','DCOSH','DTANH','DASINH','DACOSH','DATANH'/ DATA ALTNAM /'ABS','SQRT','EXP','LOG','LOG10', 1 'SIN','COS','TAN','ASIN','ACOS','ATAN', 2 'SINH','COSH','TANH','ASINH','ACOSH','ATANH'/ DATA EXTNAM /'XXXXXX'/ DATA RELNAM /'.EQ.','.NE.','.LT.','.LE.','.GT.','.GE.'/ C IF (STRING(1:1) .NE. '.') THEN IF (STRING .EQ. 'SUM') THEN KEYWD=SUM YYLVAL=0 RETURN ENDIF IF (STRING .EQ. 'PROD') THEN KEYWD=PROD YYLVAL=0 RETURN ENDIF IF (STRING .EQ. 'IN') THEN KEYWD=IN YYLVAL=0 RETURN ENDIF IF (STRING .EQ. 'IF') THEN KEYWD=IF YYLVAL=0 RETURN ENDIF IF (STRING .EQ. 'THEN') THEN KEYWD=THEN YYLVAL=0 RETURN ENDIF IF (STRING .EQ. 'ELSE') THEN KEYWD=ELSE YYLVAL=0 RETURN ENDIF IF (STRING .EQ. 'ENDIF') THEN KEYWD=ENDIF YYLVAL=0 RETURN ENDIF IF (STRING .EQ. 'GOTO') THEN KEYWD=GOTO YYLVAL=0 RETURN ENDIF IF (STRING .EQ. 'CONTINUE') THEN KEYWD=CONTIN YYLVAL=0 RETURN ENDIF DO 10 I=1,MAXSTD IF ((STRING .EQ. STDNAM(I)) .OR. (STRING .EQ. ALTNAM(I))) THEN KEYWD=STDRD YYLVAL=I RETURN ENDIF 10 CONTINUE DO 20 I=1,MAXEXT IF (STRING .EQ. EXTNAM(I)) THEN KEYWD=EXTERN YYLVAL=I RETURN ENDIF 20 CONTINUE KEYWD=ID YYLVAL=0 RETURN ELSE DO 30 I=1,6 IF (STRING .EQ. RELNAM(I)) THEN KEYWD=RELOP YYLVAL=I RETURN ENDIF 30 CONTINUE IF (STRING .EQ. '.AND.') THEN KEYWD=AND YYLVAL=0 RETURN ENDIF IF (STRING .EQ. '.OR.') THEN KEYWD=OR YYLVAL=0 RETURN ENDIF IF (STRING .EQ. '.NOT.') THEN KEYWD=NOT YYLVAL=0 RETURN ENDIF IERR=11 RETURN ENDIF END C C C INTEGER FUNCTION INSERT (STRING,STRLEN,TYPE,LIWA,PLIWA,IWA,LWA, 1 PLWA,WA,INFOLI,MAXSYM,SYMNAM,SYMTYP, 2 SYMREF,SYMEND,IERR) CHARACTER*(*) STRING INTEGER STRLEN,TYPE INTEGER LIWA,PLIWA,LWA,PLWA INTEGER IWA(LIWA),INFOLI(14) DOUBLE PRECISION WA(LWA) INTEGER MAXSYM CHARACTER*6 SYMNAM(MAXSYM) INTEGER SYMTYP(MAXSYM),SYMREF(MAXSYM),SYMEND INTEGER IERR C INTEGER INUM,RNUM,ID,GETIWA PARAMETER (INUM=262,RNUM=263,ID=264) C INTEGER IIS,VIS,IIC,VIC,IRC,VRC,IVA,VVA,IFN,XFN,VFN,VGR,VPF,IV PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,VRC=6,IVA=7,VVA=8) PARAMETER (IFN=9,XFN=10,VFN=11,VGR=12,VPF=13,IV=14) C INTEGER I,X INTEGER IHELP DOUBLE PRECISION Y,GETWA CHARACTER*40 COPY C INSERT=0 IF ((TYPE .EQ. INUM) .OR. (TYPE .EQ. RNUM)) THEN COPY=' ' COPY(40-STRLEN+1:40)=STRING(1:STRLEN) ENDIF IF (TYPE .EQ. INUM) THEN READ(COPY,'(I40)',ERR=11) X DO 10 I=1,IWA(4) IHELP=GETIWA(VIC,I,0,IWA,LIWA,INFOLI) IF (X .EQ. IHELP) THEN INSERT=I RETURN ENDIF 10 CONTINUE CALL PUT1(X,0.0D0,VIC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) RETURN INSERT=IWA(4) RETURN 11 IERR=22 RETURN C ELSE IF (TYPE .EQ. RNUM) THEN READ(COPY,'(D40.17)',ERR=21) Y DO 20 I=1,IWA(6) RHELP=GETWA(VRC,I,WA,LWA,INFOLI) IF (Y .EQ. RHELP) THEN INSERT=I RETURN ENDIF 20 CONTINUE CALL PUT1(0,Y,VRC,0,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI,IERR) IF (IERR .NE. 0) RETURN INSERT=IWA(6) RETURN 21 IERR=23 RETURN C ELSE IF (TYPE .EQ. ID) THEN DO 30 I=1,SYMEND IF (STRING(1:STRLEN) .EQ. SYMNAM(I)) THEN INSERT=I RETURN ENDIF 30 CONTINUE IF (SYMEND .GE. MAXSYM) THEN IERR=32 RETURN ENDIF SYMEND=SYMEND+1 SYMNAM(SYMEND)=STRING(1:STRLEN) SYMTYP(SYMEND)=0 SYMREF(SYMEND)=0 INSERT=SYMEND RETURN C ELSE IERR=26 WRITE(*,*) ' INSERT (5787) : unknown type ',TYPE ENDIF END C C INTEGER FUNCTION YYLEX (FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF, 1 YYLVAL,LIWA,PLIWA,IWA,LWA,PLWA,WA,INFOLI, 2 MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) INTEGER FD,LNUM,LPOS,SPOS CHARACTER STAR*5,CONT*1,LINE*66 LOGICAL EOF INTEGER YYLVAL INTEGER LIWA,PLIWA,LWA,PLWA INTEGER IWA(LIWA),INFOLI(14) DOUBLE PRECISION WA(LWA) INTEGER MAXSYM CHARACTER*6 SYMNAM(MAXSYM) INTEGER SYMTYP(MAXSYM),SYMREF(MAXSYM),SYMEND INTEGER IERR C INTEGER ADD,SUB,MULT,DIV,POWER,LEFT,RIGHT,COMMA,ASSIGN,NLINE INTEGER RANGE,RELOP,AND,OR,NOT,INUM,RNUM,ID,SUM,PROD,IN,IF,THEN INTEGER ELSE,ENDIF,STDRD,EXTERN,PARAM,INDEX,REAL,INT,TABLE,VAR INTEGER FUNC,END,GOTO,MARKE,CONTIN,UMINUS,INDVAR,ENDSUM,ENDPRD INTEGER BEQ,BRA,LABEL,VECTOR,ACTIVE PARAMETER (ADD=43,SUB=45,MULT=42,DIV=47,POWER=94,LEFT=40,RIGHT=41) PARAMETER (COMMA=44,ASSIGN=61,NLINE=10,RANGE=257,RELOP=258) PARAMETER (AND=259,OR=260,NOT=261,INUM=262,RNUM=263,ID=264) PARAMETER (SUM=265,PROD=266,IN=267,IF=268,THEN=269,ELSE=270) PARAMETER (ENDIF=271,STDRD=272,EXTERN=273,PARAM=274,INDEX=275) PARAMETER (REAL=276,INT=277,TABLE=278,VAR=279,FUNC=280,END=281) PARAMETER (GOTO=282,MARKE=283,CONTIN=284,UMINUS=285,INDVAR=286) PARAMETER (ENDSUM=287,ENDPRD=288,BEQ=289,BRA=290,LABEL=291) PARAMETER (VECTOR=292,ACTIVE=293) C INTEGER TYPNUM PARAMETER (TYPNUM=8) CHARACTER*24 TYPNAM(TYPNUM) INTEGER TYPLEN(TYPNUM) C INTEGER I,INSERT,J,KEYWD,STRLEN LOGICAL BUCHST,ZIFFER CHARACTER C,GETCHR,STRING*40 C DATA TYPNAM /'PARAMETER','SETOFINDICES','REALCONSTANT', 1 'INTEGERCONSTANT','TABLE','VARIABLE','FUNCTION', 2 'END'/ DATA TYPLEN /9,12,12,15,5,8,8,3/ C BUCHST(C) = (('A' .LE. C) .AND. (C .LE. 'Z')) ZIFFER(C) = (('0' .LE. C) .AND. (C .LE. '9')) C IF ((EOF) .OR. (IERR .NE. 0)) THEN YYLEX=-1 YYLVAL=0 RETURN ENDIF 10 C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (C .EQ. ' ') GO TO 10 20 IF (C .EQ. '(') THEN YYLEX=LEFT YYLVAL=0 RETURN ENDIF 30 IF (C .EQ. ')') THEN YYLEX=RIGHT YYLVAL=0 RETURN ENDIF 40 IF (C .EQ. '+') THEN YYLEX=ADD YYLVAL=0 RETURN ENDIF 50 IF (C .EQ. '-') THEN YYLEX=SUB YYLVAL=0 RETURN ENDIF 60 IF (C .EQ. '*') THEN C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (C .EQ. '*') THEN YYLEX=POWER YYLVAL=0 RETURN ELSE YYLEX=MULT YYLVAL=0 CALL UNGTC(LPOS,IERR) RETURN ENDIF ENDIF 70 IF (C .EQ. '/') THEN YYLEX=DIV YYLVAL=0 RETURN ENDIF 80 IF (C .EQ. '=') THEN YYLEX=ASSIGN YYLVAL=0 RETURN ENDIF 90 IF (C .EQ. ',') THEN YYLEX=COMMA YYLVAL=0 RETURN ENDIF 100 IF (C .NE. '.') GO TO 110 C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (C .EQ. '.') THEN YYLEX=RANGE YYLVAL=0 RETURN ELSE IF (ZIFFER(C)) THEN STRING='.' STRLEN=1 GO TO 113 ELSE IF (.NOT. BUCHST(C)) THEN YYLEX=-1 IERR=13 RETURN ENDIF STRING='.'//C STRLEN=2 101 C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (BUCHST(C)) THEN STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)=C GO TO 101 ELSE IF (C .EQ. '.') THEN STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)=C ENDIF YYLEX=KEYWD(STRING,YYLVAL,IERR) IF (IERR .NE. 0) THEN YYLEX=-1 YYLVAL=0 ENDIF RETURN 110 IF (.NOT. ZIFFER(C)) GO TO 120 STRING=C STRLEN=1 IF (LPOS .EQ. 1) THEN 111 C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF ((ZIFFER(C)) .AND. (SPOS .LE. 6)) THEN STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)=C GO TO 111 ELSE YYLEX=MARKE YYLVAL=INSERT(STRING,STRLEN,INUM,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) IF (SPOS .EQ. 6) THEN CALL UNGTC(LPOS,IERR) ELSE CALL UNGTC(SPOS,IERR) ENDIF RETURN ENDIF ELSE 112 C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (ZIFFER(C)) THEN STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)=C GO TO 112 ELSE IF (C .EQ. 'D' .OR. C .EQ. 'E') THEN GO TO 114 ELSE IF (C .NE. '.') THEN YYLEX=INUM YYLVAL=INSERT(STRING,STRLEN,INUM,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) CALL UNGTC(LPOS,IERR) RETURN ENDIF ENDIF STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)='.' C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (ZIFFER(C)) THEN GO TO 113 ELSE IF (BUCHST(C)) THEN IF (C .EQ. 'D' .OR. C .EQ. 'E') THEN GO TO 114 ELSE STRING(STRLEN:STRLEN)=' ' STRLEN=STRLEN-1 YYLEX=INUM YYLVAL=INSERT(STRING,STRLEN,INUM,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) CALL UNGTC(LPOS,IERR) CALL UNGTC(LPOS,IERR) RETURN ENDIF ELSE IF (C .EQ. '.') THEN YYLEX=INUM STRING(STRLEN:STRLEN)=' ' STRLEN=STRLEN-1 YYLVAL=INSERT(STRING,STRLEN,INUM,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) CALL UNGTC(LPOS,IERR) CALL UNGTC(LPOS,IERR) RETURN ELSE YYLEX=RNUM YYLVAL=INSERT(STRING,STRLEN,RNUM,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) CALL UNGTC(LPOS,IERR) RETURN ENDIF 113 IF (ZIFFER(C)) THEN STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)=C C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) GO TO 113 ELSE IF (C .NE. 'D' .AND. C .NE. 'E') THEN STRLEN=STRLEN+2 STRING(STRLEN-1:STRLEN)='D0' YYLEX=RNUM YYLVAL=INSERT(STRING,STRLEN,RNUM,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) CALL UNGTC(LPOS,IERR) RETURN ENDIF 114 STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)='D' C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (BUCHST(C)) THEN CALL UNGTC(LPOS,IERR) CALL UNGTC(LPOS,IERR) STRING(STRLEN:STRLEN)=' ' STRLEN=STRLEN-1 YYLEX=RNUM YYLVAL=INSERT(STRING,STRLEN,RNUM,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) RETURN ELSE IF (ZIFFER(C)) THEN GO TO 115 ELSE IF (C .NE. '+' .AND. C .NE. '-') THEN YYLEX=-1 IERR=23 RETURN ENDIF STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)=C C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) 115 IF (ZIFFER(C)) THEN STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)=C C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) GO TO 115 ENDIF YYLEX=RNUM YYLVAL=INSERT(STRING,STRLEN,RNUM,LIWA,PLIWA,IWA,LWA,PLWA,WA, 1 INFOLI,MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) CALL UNGTC(LPOS,IERR) RETURN 120 IF (BUCHST(C)) THEN STRING=C STRLEN=1 121 C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (BUCHST(C) .OR. ZIFFER(C)) THEN STRLEN=STRLEN+1 STRING(STRLEN:STRLEN)=C GO TO 121 ENDIF CALL UNGTC(LPOS,IERR) YYLEX=KEYWD(STRING,YYLVAL,IERR) IF ((STRLEN .GT. 6) .AND. (YYLEX .NE. CONTIN)) THEN YYLEX=-1 IERR=27 RETURN ENDIF IF (YYLEX .EQ. ID) 1 YYLVAL=INSERT(STRING,STRLEN,ID,LIWA,PLIWA,IWA,LWA,PLWA,WA, 2 INFOLI,MAXSYM,SYMNAM,SYMTYP,SYMREF,SYMEND,IERR) RETURN ENDIF 130 IF (C .EQ. '\\') THEN 131 C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (C .EQ. ' ') GO TO 131 J=0 DO 132 I=1,TYPNUM IF (C .EQ. TYPNAM(I)(1:1)) J=I 132 CONTINUE STRING=C DO 134 I=2,TYPLEN(J) 133 C=GETCHR(FD,LNUM,STAR,CONT,LINE,LPOS,SPOS,EOF) IF (C .EQ. ' ') GO TO 133 STRING(I:I)=C 134 CONTINUE IF (STRING .EQ. TYPNAM(J)) THEN YYLEX=PARAM+(J-1) YYLVAL=0 RETURN ELSE YYLEX=-1 YYLVAL=0 IERR=28 RETURN ENDIF ENDIF 140 IF (C .EQ. '#') THEN YYLEX=NLINE YYLVAL=0 RETURN ENDIF 150 YYLEX=-1 IERR=29 RETURN END C C C SUBROUTINE PUT1(IVEK,RVEK,ART,OFFSET,LIWA,PLIWA,IWA,LWA,PLWA, 1 WA,INFOLI,IERR) C INTEGER ART,LIWA,PLIWA,LWA,PLWA,OFFSET INTEGER IVEK,IWA(LIWA),INFOLI(14) DOUBLE PRECISION RVEK,WA(LWA) C INTEGER VIS,VIC,VRC,VVA,VFN,VGR,VPF,IV INTEGER LVIS,LIIC,LVIC,LIRC,LVRC,LVVA,LVFN,LVGR,LVPF,LIV PARAMETER (VIS=2,VIC=4,VRC=6,VVA=8,VFN=11,VGR=12,VPF=13,IV=14) C INTEGER I C LVIS=INFOLI(2) LIIC=INFOLI(3) LVIC=INFOLI(4) LIRC=INFOLI(5) LVPF=INFOLI(13) LIV =INFOLI(14) C LVRC=INFOLI(6) LVVA=INFOLI(8) LVFN=INFOLI(11) LVGR=INFOLI(12) C IF (ART .EQ. VIS) THEN IF (OFFSET .EQ. 0) THEN IWA(2)=IWA(2)+1 PLIWA=PLIWA+1 IF (PLIWA .GT. LIWA) GO TO 9999 IF (PLIWA-1 .GT. LIIC) THEN DO 100 I=PLIWA,LIIC+1+1,-1 IWA(I)=IWA(I-1) 100 CONTINUE ENDIF IWA(IWA(2)+LVIS)=IVEK ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(2))) THEN IWA(LVIS+OFFSET)=IVEK ELSE IERR=34 RETURN ENDIF C C ELSE IF (ART .EQ. VIC) THEN IF (OFFSET .EQ. 0) THEN IWA(4)=IWA(4)+1 PLIWA=PLIWA+1 IF (PLIWA .GT. LIWA) GO TO 9999 IF (PLIWA-1 .GT. LIRC) THEN DO 300 I=PLIWA,LIRC+1+1,-1 IWA(I)=IWA(I-1) 300 CONTINUE ENDIF IWA(IWA(4)+LVIC)=IVEK ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(4))) THEN IWA(LVIC+OFFSET)=IVEK ELSE IERR=34 RETURN ENDIF C C ELSE IF (ART .EQ. VRC) THEN IF (OFFSET .EQ. 0) THEN IWA(6)=IWA(6)+1 PLWA=PLWA+1 IF (PLWA .GT. LWA) GO TO 9999 IF (PLWA-1 .GT. LVVA) THEN DO 500 I=PLWA,LVVA+1+1,-1 WA(I)=WA(I-1) 500 CONTINUE ENDIF WA(IWA(6)+LVRC)=RVEK ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(6))) THEN WA(LVRC+OFFSET)=RVEK ELSE IERR=34 RETURN ENDIF C C ELSE IF (ART .EQ. VVA) THEN IF (OFFSET .EQ. 0) THEN IWA(8)=IWA(8)+1 PLWA=PLWA+1 IF (PLWA .GT. LWA) GO TO 9999 IF (PLWA-1 .GT. LVFN) THEN DO 700 I=PLWA,LVFN+1+1,-1 WA(I)=WA(I-1) 700 CONTINUE ENDIF WA(IWA(8)+LVVA)=RVEK ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(8))) THEN WA(LVVA+OFFSET)=RVEK ELSE IERR=34 RETURN ENDIF C C ELSE IF (ART .EQ. VFN) THEN IF (OFFSET .EQ. 0) THEN IWA(11)=IWA(11)+1 PLWA=PLWA+1 IF (PLWA .GT. LWA) GO TO 9999 IF (PLWA-1 .GT. LVGR) THEN DO 900 I=PLWA,LVGR+1+1,-1 WA(I)=WA(I-1) 900 CONTINUE ENDIF WA(IWA(11)+LVFN)=RVEK ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(11))) THEN WA(LVFN+OFFSET)=RVEK ELSE IERR=34 RETURN ENDIF C C ELSE IF (ART .EQ. VGR) THEN IF (OFFSET .EQ. 0) THEN IWA(12)=IWA(12)+1 PLWA=PLWA+1 IF (PLWA .GT. LWA) GO TO 9999 IF (PLWA-1 .GT. IWA(12)-1+LVGR) THEN DO 1000 I=PLWA,IWA(12)-1+LVGR+1+1,-1 WA(I)=WA(I-1) 1000 CONTINUE ENDIF WA(IWA(12)+LVGR)=RVEK ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(12))) THEN WA(LVGR+OFFSET)=RVEK ELSE IERR=34 RETURN ENDIF C C ELSE IF (ART .EQ. VPF) THEN IF (OFFSET .EQ. 0) THEN IWA(13)=IWA(13)+1 PLIWA=PLIWA+1 IF (PLIWA .GT. LIWA) GO TO 9999 IF (PLIWA-1 .GT. LIV) THEN DO 1100 I=PLIWA,LIV+1+1,-1 IWA(I)=IWA(I-1) 1100 CONTINUE ENDIF IWA(LVPF+IWA(13))=IVEK ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(13))) THEN IWA(LVPF+OFFSET)=IVEK ELSE IERR=34 RETURN ENDIF C C ELSE IF (ART .EQ. IV) THEN IF (OFFSET .EQ. 0) THEN IWA(14)=IWA(14)+1 PLIWA=PLIWA+1 IF (PLIWA .GT. LIWA) GO TO 9999 IF (PLIWA-1 .GT. IWA(14)-1+LIV) THEN DO 1200 I=PLIWA,IWA(14)-1+LIV+1+1,-1 IWA(I)=IWA(I-1) 1200 CONTINUE ENDIF IWA(LIV+IWA(14))=IVEK ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(14))) THEN IWA(LIV+OFFSET)=IVEK ELSE IERR=34 RETURN ENDIF C C ELSE IERR=34 RETURN C C ENDIF C INFOLI(1)=14 INFOLI(2)=IWA(1)*5+INFOLI(1) INFOLI(3)=IWA(2)+INFOLI(2) INFOLI(4)=IWA(3)*4+INFOLI(3) INFOLI(5)=IWA(4)+INFOLI(4) INFOLI(7)=IWA(5)*4+INFOLI(5) INFOLI(9)=IWA(7)*3+INFOLI(7) INFOLI(13)=IWA(9)*6+INFOLI(9) INFOLI(14)=IWA(13)+INFOLI(13) C INFOLI(6)=0 INFOLI(8)=IWA(6)+INFOLI(6) INFOLI(11)=IWA(8)+INFOLI(8) INFOLI(12)=IWA(11)+INFOLI(11) C RETURN C 9999 CONTINUE WRITE(*,*) 'OUT OF MEMORY' IERR=32 RETURN END C C C SUBROUTINE PUT3(IVEK,ART,OFFSET,LIWA,PLIWA,IWA,INFOLI,IERR) C INTEGER ART,LIWA,PLIWA,OFFSET INTEGER IVEK(3),IWA(LIWA),INFOLI(14) C INTEGER IVA INTEGER LIVA,LIFN PARAMETER (IVA=7) C INTEGER I,J C LIVA=INFOLI(7) LIFN=INFOLI(9) C IF (ART .EQ. IVA) THEN C IF (OFFSET .EQ. 0) THEN IWA(7)=IWA(7)+1 PLIWA=PLIWA+3 IF (PLIWA .GT. LIWA) GO TO 9999 IF (PLIWA-3 .GT. LIFN) THEN DO 100 I=PLIWA,LIFN+3+1,-1 IWA(I)=IWA(I-3) 100 CONTINUE ENDIF IF (IWA(7) .GT. 1) THEN DO 120 I=3,1,-1 IWA(LIVA+IWA(7)*I)=IVEK(I) DO 110 J=1,IWA(7)-1 IWA(LIVA+IWA(7)*I-J)=IWA(LIVA+IWA(7)*I-J-(I-1)) 110 CONTINUE 120 CONTINUE ELSE DO 130 I=1,3 IWA(LIVA+I) = IVEK(I) 130 CONTINUE ENDIF C ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(7))) THEN DO 140 I=1,3 IWA(LIVA+IWA(7)*(I-1)+OFFSET)=IVEK(I) 140 CONTINUE ELSE IERR=34 RETURN ENDIF C C ELSE IERR=34 RETURN C C ENDIF C INFOLI(1)=14 INFOLI(2)=IWA(1)*5+INFOLI(1) INFOLI(3)=IWA(2)+INFOLI(2) INFOLI(4)=IWA(3)*4+INFOLI(3) INFOLI(5)=IWA(4)+INFOLI(4) INFOLI(7)=IWA(5)*4+INFOLI(5) INFOLI(9)=IWA(7)*3+INFOLI(7) INFOLI(13)=IWA(9)*6+INFOLI(9) INFOLI(14)=IWA(13)+INFOLI(13) C INFOLI(6)=0 INFOLI(8)=IWA(6)+INFOLI(6) INFOLI(11)=IWA(8)+INFOLI(8) INFOLI(12)=IWA(11)+INFOLI(11) C RETURN C 9999 CONTINUE WRITE(*,*) 'OUT OF MEMORY' IERR=32 RETURN END C C C SUBROUTINE PUT4(IVEK,ART,OFFSET,LIWA,PLIWA,IWA,INFOLI,IERR) C INTEGER ART,LIWA,PLIWA,OFFSET INTEGER IVEK(4),IWA(LIWA),INFOLI(14) C INTEGER IIC,IRC INTEGER LIIC,LVIC,LIRC,LIVA PARAMETER (IIC=3,IRC=5) C INTEGER I,J C LIIC=INFOLI(3) LVIC=INFOLI(4) LIRC=INFOLI(5) LIVA=INFOLI(7) C IF (ART .EQ. IIC) THEN C IF (OFFSET .EQ. 0) THEN IWA(3)=IWA(3)+1 PLIWA=PLIWA+4 IF (PLIWA .GT. LIWA) GO TO 9999 IF (PLIWA-4 .GT. LVIC) THEN DO 100 I=PLIWA,LVIC+1+4,-1 IWA(I)=IWA(I-4) 100 CONTINUE ENDIF IF (IWA(3) .GT. 1) THEN DO 120 I=4,1,-1 IWA(LIIC+IWA(3)*I)=IVEK(I) DO 110 J=1,IWA(3)-1 IWA(LIIC+IWA(3)*I-J)=IWA(LIIC+IWA(3)*I-J-(I-1)) 110 CONTINUE 120 CONTINUE ELSE DO 130 I=1,4 IWA(LIIC+I) = IVEK(I) 130 CONTINUE ENDIF C ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(3))) THEN DO 140 I=1,4 IWA(LIIC+IWA(3)*(I-1)+OFFSET)=IVEK(I) 140 CONTINUE ELSE IERR=34 RETURN ENDIF C C ELSE IF (ART .EQ. IRC) THEN C IF (OFFSET .EQ. 0) THEN IWA(5)=IWA(5)+1 PLIWA=PLIWA+4 IF (PLIWA .GT. LIWA) GO TO 9999 IF (PLIWA-4 .GT. LIVA) THEN DO 200 I=PLIWA,LIVA+4+1,-1 IWA(I)=IWA(I-4) 200 CONTINUE ENDIF IF (IWA(5) .GT. 1) THEN DO 220 I=4,1,-1 IWA(LIRC+IWA(5)*I)=IVEK(I) DO 210 J=1,IWA(5)-1 IWA(LIRC+IWA(5)*I-J)=IWA(LIRC+IWA(5)*I-J-(I-1)) 210 CONTINUE 220 CONTINUE ELSE DO 230 I=1,4 IWA(LIRC+I) = IVEK(I) 230 CONTINUE ENDIF C ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(5))) THEN DO 240 I=1,4 IWA(LIRC+IWA(5)*(I-1)+OFFSET)=IVEK(I) 240 CONTINUE ELSE IERR=34 RETURN ENDIF C C ELSE IERR=34 RETURN C C ENDIF C INFOLI(1)=14 INFOLI(2)=IWA(1)*5+INFOLI(1) INFOLI(3)=IWA(2)+INFOLI(2) INFOLI(4)=IWA(3)*4+INFOLI(3) INFOLI(5)=IWA(4)+INFOLI(4) INFOLI(7)=IWA(5)*4+INFOLI(5) INFOLI(9)=IWA(7)*3+INFOLI(7) INFOLI(13)=IWA(9)*6+INFOLI(9) INFOLI(14)=IWA(13)+INFOLI(13) C INFOLI(6)=0 INFOLI(8)=IWA(6)+INFOLI(6) INFOLI(11)=IWA(8)+INFOLI(8) INFOLI(12)=IWA(11)+INFOLI(11) C RETURN C 9999 CONTINUE WRITE(*,*) 'OUT OF MEMORY' IERR=32 RETURN END C C C SUBROUTINE PUT5(IVEK,ART,OFFSET,LIWA,PLIWA,IWA,INFOLI,IERR) C INTEGER ART,LIWA,PLIWA,OFFSET INTEGER IVEK(5),IWA(LIWA),INFOLI(14) C INTEGER IIS INTEGER LIIS,LVIS PARAMETER (IIS=1) C INTEGER I,J C LIIS=INFOLI(1) LVIS=INFOLI(2) C IF (ART .EQ. IIS) THEN C IF (OFFSET .EQ. 0) THEN IWA(1)=IWA(1)+1 PLIWA=PLIWA+5 IF (PLIWA .GT. LIWA) GO TO 9999 IF (PLIWA-5 .GT. LVIS) THEN DO 10 I=PLIWA,LVIS+5+1,-1 IWA(I)=IWA(I-5) 10 CONTINUE ENDIF IF (IWA(1) .GT. 1) THEN DO 30 I=5,1,-1 IWA(LIIS+IWA(1)*I)=IVEK(I) DO 20 J=1,IWA(1)-1 IWA(LIIS+IWA(1)*I-J)=IWA(LIIS+IWA(1)*I-J-(I-1)) 20 CONTINUE 30 CONTINUE ELSE DO 40 I=1,5 IWA(LIIS+I) = IVEK(I) 40 CONTINUE ENDIF C ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(1))) THEN DO 140 I=1,5 IWA(LIIS+IWA(1)*(I-1)+OFFSET)=IVEK(I) 140 CONTINUE ELSE IERR=34 RETURN ENDIF C C ELSE IERR=34 RETURN C C ENDIF C INFOLI(1)=14 INFOLI(2)=IWA(1)*5+INFOLI(1) INFOLI(3)=IWA(2)+INFOLI(2) INFOLI(4)=IWA(3)*4+INFOLI(3) INFOLI(5)=IWA(4)+INFOLI(4) INFOLI(7)=IWA(5)*4+INFOLI(5) INFOLI(9)=IWA(7)*3+INFOLI(7) INFOLI(13)=IWA(9)*6+INFOLI(9) INFOLI(14)=IWA(13)+INFOLI(13) C INFOLI(6)=0 INFOLI(8)=IWA(6)+INFOLI(6) INFOLI(11)=IWA(8)+INFOLI(8) INFOLI(12)=IWA(11)+INFOLI(11) C RETURN C 9999 CONTINUE WRITE(*,*) 'OUT OF MEMORY' IERR=32 RETURN END C C C SUBROUTINE PUT6(IVEK,ART,OFFSET,LIWA,PLIWA,IWA,INFOLI,IERR) C INTEGER ART,LIWA,PLIWA,OFFSET INTEGER IVEK(6),IWA(LIWA),INFOLI(14) C INTEGER IFN INTEGER LIFN,LVPF PARAMETER (IFN=9) C INTEGER I,J C LIFN=INFOLI(9) LVPF=INFOLI(13) C IF (ART .EQ. IFN) THEN C IF (OFFSET .EQ. 0) THEN IWA(9)=IWA(9)+1 PLIWA=PLIWA+6 IF (PLIWA .GT. LIWA) GO TO 9999 IF (PLIWA-6 .GT. LVPF) THEN DO 100 I=PLIWA,LVPF+6+1,-1 IWA(I)=IWA(I-6) 100 CONTINUE ENDIF IF (IWA(9) .GT. 1) THEN DO 120 I=6,1,-1 IWA(LIFN+IWA(9)*I)=IVEK(I) DO 110 J=1,IWA(9)-1 IWA(LIFN+IWA(9)*I-J)=IWA(LIFN+IWA(9)*I-J-(I-1)) 110 CONTINUE 120 CONTINUE ELSE DO 130 I=1,6 IWA(LIFN+I) = IVEK(I) 130 CONTINUE ENDIF C ELSE IF ((OFFSET .GE. 1) .AND. (OFFSET .LE. IWA(9))) THEN DO 140 I=1,6 IWA(LIFN+IWA(9)*(I-1)+OFFSET)=IVEK(I) 140 CONTINUE ELSE IERR=34 RETURN ENDIF C C ELSE IERR=34 RETURN C C ENDIF C INFOLI(1)=14 INFOLI(2)=IWA(1)*5+INFOLI(1) INFOLI(3)=IWA(2)+INFOLI(2) INFOLI(4)=IWA(3)*4+INFOLI(3) INFOLI(5)=IWA(4)+INFOLI(4) INFOLI(7)=IWA(5)*4+INFOLI(5) INFOLI(9)=IWA(7)*3+INFOLI(7) INFOLI(13)=IWA(9)*6+INFOLI(9) INFOLI(14)=IWA(13)+INFOLI(13) C INFOLI(6)=0 INFOLI(8)=IWA(6)+INFOLI(6) INFOLI(11)=IWA(8)+INFOLI(8) INFOLI(12)=IWA(11)+INFOLI(11) C RETURN C 9999 CONTINUE WRITE(*,*) 'OUT OF MEMORY' IERR=32 RETURN END C C C INTEGER FUNCTION GETIWA(FELD,DIM1,DIM2,IWA,LIWA,INFOLI) C INTEGER FELD,DIM1,DIM2,LIWA INTEGER IWA(LIWA),INFOLI(14) C INTEGER IIS,VIS,IIC,VIC,IRC,IVA,IFN,VPF,IV INTEGER LIIS,LVIS,LIIC,LVIC,LIRC,LIVA,LIFN,LVPF,LIV C PARAMETER (IIS=1,VIS=2,IIC=3,VIC=4,IRC=5,IVA=7,IFN=9,VPF=13,IV=14) C LIIS=INFOLI(1) LVIS=INFOLI(2) LIIC=INFOLI(3) LVIC=INFOLI(4) LIRC=INFOLI(5) LIVA=INFOLI(7) LIFN=INFOLI(9) LVPF=INFOLI(13) LIV =INFOLI(14) C C IF (FELD .EQ. IIS) THEN IF (IWA(1) .GT. 1) THEN GETIWA=IWA(LIIS+IWA(1)*(DIM2-1)+DIM1) ELSE GETIWA=IWA(LIIS+DIM2) ENDIF C ELSE IF (FELD .EQ. VIS) THEN GETIWA=IWA(INFOLI(2)+DIM1) C ELSE IF (FELD .EQ. IIC) THEN IF (IWA(3) .GT. 1) THEN GETIWA=IWA(LIIC+IWA(3)*(DIM2-1)+DIM1) ELSE GETIWA=IWA(LIIC+DIM2) ENDIF C ELSE IF (FELD .EQ. VIC) THEN GETIWA=IWA(INFOLI(4)+DIM1) C ELSE IF (FELD .EQ. IRC) THEN IF (IWA(5) .GT. 1) THEN GETIWA=IWA(LIRC+IWA(5)*(DIM2-1)+DIM1) ELSE GETIWA=IWA(LIRC+DIM2) ENDIF C ELSE IF (FELD .EQ. IVA) THEN IF (IWA(7) .GT. 1) THEN GETIWA=IWA(LIVA+IWA(7)*(DIM2-1)+DIM1) ELSE GETIWA=IWA(LIVA+DIM2) ENDIF C ELSE IF (FELD .EQ. IFN) THEN IF (IWA(9) .GT. 1) THEN GETIWA=IWA(LIFN+IWA(9)*(DIM2-1)+DIM1) ELSE GETIWA=IWA(LIFN+DIM2) ENDIF C ELSE IF (FELD .EQ. VPF) THEN GETIWA=IWA(INFOLI(13)+DIM1) C ELSE IF (FELD .EQ. IV) THEN GETIWA=IWA(INFOLI(14)+DIM1) C ENDIF RETURN END C C C DOUBLE PRECISION FUNCTION GETWA(FELD,DIM,WA,LWA,INFOLI) C INTEGER FELD,DIM INTEGER INFOLI(14),LWA DOUBLE PRECISION WA(LWA) C INTEGER VRC,VVA,VFN,VGR INTEGER LVRC,LVVA,LVFN,LVGR C PARAMETER (VRC=6,VVA=8,VFN=11,VGR=12) C LVRC=INFOLI(6) LVVA=INFOLI(8) LVFN=INFOLI(11) LVGR=INFOLI(12) C IF (FELD .EQ. VRC) THEN GETWA=WA(LVRC+DIM) C ELSE IF (FELD .EQ. VVA) THEN GETWA=WA(LVVA+DIM) C ELSE IF (FELD .EQ. VFN) THEN GETWA=WA(LVFN+DIM) C ELSE IF (FELD .EQ. VGR) THEN GETWA=WA(LVGR+DIM) C ENDIF RETURN END C C C SUBROUTINE UNVPF(PC,LIWA,PLIWA,IWA,INFOLI) C INTEGER PC,LIWA,PLIWA,IWA(LIWA),INFOLI(14) C INTEGER I C DO 100 I=1,IWA(14) IWA(INFOLI(13)+PC+I)=IWA(INFOLI(14)+I) IWA(INFOLI(14)+I)=0 100 CONTINUE INFOLI(14)=INFOLI(13)+PC IWA(13)=PC PLIWA=INFOLI(14)+IWA(14) RETURN END C C*** pcomp_s.f C********************************************* C * C PROGRAM : PCOMP * C MODULE : S (RUNTIME EXECUTIVE) * C ABSTRACT : FORTRAN PRECOMPILER * C KEY WORD : AUTOMATIC DIFFERENTIATION * C SOURCE : PCOMP 2.3 by M.LIEPELT * C COPYRIGHT : M.DOBMANN, K.SCHITTKOWSKI * C MATHEMATISCHES INSTITUT, * C UNIVERSITAET BAYREUTH, * C D-8580 BAYREUTH, GERMANY * C DATE : SEPTEMBER 1, 1993 * C VERSION : 3.1 * C * C********************************************* C C C SUBROUTINE SYMPRP (SYMFIL,WA,LWA,IWA,LIWA,UWA,UIWA,IERR) INTEGER SYMFIL INTEGER LWA,LIWA DOUBLE PRECISION WA(LWA) INTEGER IWA(LIWA) INTEGER UWA,UIWA INTEGER IERR C C********************************************************************** C C S Y M P R P - LOAD INTERMEDIATE CODE GENERATED BY SYMINP FROM C SYMFIL INTO WORKING ARRAYS. C C PARAMETERS: C SYMFIL - INPUT DEVICE; THE INTERMEDIATE CODE GENERATED BY C SYMINP WAS WRITTEN TO THIS FILE AND IS NOW LOADED. C WA(LWA) - REAL WORKING ARRAY, REQUIRED BY SYMPRP. ON RETURN, C WA() CONTAINS THE INTERMEDIATE CODE. C IWA(LIWA) - INTEGER WORKING ARRAY, CF. WA(). C UWA,UIWA - INDICATE THE ACTUAL SPACE OF WA() AND IWA() THAT C HAS BEEN USED BY THE SUBROUTINE. C IERR - THE PARAMETER SHOWS THE REASON FOR TERMINATING THE C SUBROUTINE. ON RETURN IERR COULD CONTAIN THE FOLLOW- C ING VALUES: C IERR = 0 : SUCCESSFUL TERMINATION. C IERR > 0 : AN ERROR HAS BEEN DETECTED. FOR FURTHER C INFORMATION CF. SUBROUTINE SYMERR. C C********************************************************************** C INTEGER I,PWA,PIWA,PX,PIX C INTEGER GSMDEP PARAMETER (GSMDEP=10) C DO 10 I=1,14 READ(SYMFIL,'(I6)',ERR=100) IWA(I) 10 CONTINUE PIWA=IWA(1)*5+IWA(2)+IWA(3)*4+IWA(4)+IWA(5)*4+IWA(7)*3+ 1 IWA(9)*6+IWA(13)+14 PWA=IWA(6) PX=IWA(8)+IWA(11)+IWA(12)*IWA(8)+GSMDEP*IWA(8) PIX=IWA(14) IF ((PWA+PX .GT. LWA) .OR. (PIWA+PIX .GT. LIWA)) THEN IERR=32 RETURN ENDIF DO 20 I=15,PIWA READ(SYMFIL,'(I6)',ERR=100) IWA(I) 20 CONTINUE DO 30 I=1,PWA READ(SYMFIL,'(D24.17)',ERR=100) WA(I) 30 CONTINUE IERR=0 UWA=PWA+PX UIWA=PIWA+PIX RETURN 100 IERR=26 RETURN END C C C SUBROUTINE SYMFUN (X,N,F,M,ACTIVE,WA,LWA,IWA,LIWA,IERR) INTEGER N,M DOUBLE PRECISION X(N),F(M) LOGICAL ACTIVE(M) INTEGER LWA,LIWA DOUBLE PRECISION WA(LWA) INTEGER IWA(LIWA) INTEGER IERR C C********************************************************************** C C S Y M F U N - EVALUATE SYMBOLICALLY DEFINED FUNCTIONS. C C PARAMETERS: C X(N) - ON INPUT, THE ONE-DIMENSIONAL ARRAY X HAS TO CONTAIN C THE ARGUMENT THE FUNCTIONS ARE TO BE COMPUTED AT. C F(M) - ON RETURN, F CONTAINS THE VALUES OF THE ACTIVE C FUNCTIONS AT ARGUMENT X. C ACTIVE(M) - THE LOGICAL ARRAY SPECIFIES WHICH OF THE M FUNCTIONS C ARE TO BE COMPUTED ( ACTIVE(K) = .TRUE. ). C WA(LWA) - REAL WORKING ARRAY, CONTAINS THE INTERMEDIATE CODE C GENERATED BY SYMINP. C IWA(LIWA) - INTEGER WORKING ARRAY, CF. WA(LWA). C IERR - THE PARAMETER SHOWS THE REASON FOR TERMINATING THE C SUBROUTINE. ON RETURN IERR COULD CONTAIN THE FOLLOW- C ING VALUES: C IERR = 0 : SUCCESSFUL TERMINATION. C IERR > 0 : AN ERROR HAS BEEN DETECTED. FOR FURTHER C INFORMATION CF. SUBROUTINE SYMERR. C C********************************************************************** C INTEGER PIIS,PVIS,PIIC,PVIC,PIRC,PVRC,PIVA,PVVA,PIFN,PXFN,PVFN INTEGER PVGR,PVPF,PIV,LIIS,LVIS,LIIC,LVIC,LIRC,LVRC,LIVA,LVVA INTEGER LIFN,LVFN,LVGR,LVPF,LIV,LGST C INTEGER IVAL DOUBLE PRECISION FVAL INTEGER I,J,K,PC C INTEGER NOGRAD PARAMETER (NOGRAD=0) C PIIS=IWA(1) PVIS=IWA(2) PIIC=IWA(3) PVIC=IWA(4) PIRC=IWA(5) PVRC=IWA(6) PIVA=IWA(7) PVVA=IWA(8) PIFN=IWA(9) PXFN=IWA(10) PVFN=IWA(11) PVGR=IWA(12) PVPF=IWA(13) PIV=IWA(14) LIIS=15 LVIS=LIIS+PIIS*5 LIIC=LVIS+PVIS LVIC=LIIC+PIIC*4 LIRC=LVIC+PVIC LVRC=1 LIVA=LIRC+PIRC*4 LVVA=LVRC+PVRC LIFN=LIVA+PIVA*3 LVFN=LVVA+PVVA LVGR=LVFN+PVFN LVPF=LIFN+PIFN*6 LIV=LVPF+PVPF LGST=LVGR+PVGR*PVVA IF (N .NE. PVVA) THEN IERR=43 RETURN ENDIF IF (M .NE. PVFN-(PIFN-PXFN)) THEN IERR=44 RETURN ENDIF DO 10 I=1,N WA(LVVA+I-1)=X(I) 10 CONTINUE K=0 DO 20 I=1,PXFN IF (IWA(LIFN+(I-1)+(1-1)*PIFN) .EQ. 0) THEN K=K+1 IF (ACTIVE(K)) THEN PC=IWA(LIFN+(I-1)+(6-1)*PIFN) CALL EVAL(PC,IVAL,FVAL,NOGRAD,PVVA, 1 PIIS,PVIS,PIIC,PVIC,PIRC,PVRC, 2 PIVA,PVVA,PIFN,PVFN,PVPF,PIV, 3 IWA(LIIS),IWA(LVIS), 4 IWA(LIIC),IWA(LVIC),IWA(LIRC),WA(LVRC),IWA(LIVA), 5 WA(LVVA),IWA(LIFN),WA(LVFN),WA(LVGR),IWA(LVPF),IWA(LIV), 6 WA(LGST),IERR) F(K)=WA(LVFN+IWA(LIFN+(I-1)+(4-1)*PIFN)-1) ENDIF ELSE IF (IWA(LIFN+(I-1)+(1-1)*PIFN) .EQ. 1) THEN DO 15 J=1,IWA(LIFN+(I-1)+(3-1)*PIFN) K=K+1 IF (ACTIVE(K)) THEN PC=IWA(LIFN+(I-1)+(6-1)*PIFN) IWA(LIV+IWA(LIFN+(I-1)+(2-1)*PIFN)-1)=J CALL EVAL(PC,IVAL,FVAL,NOGRAD,PVVA, 1 PIIS,PVIS,PIIC, 2 PVIC,PIRC,PVRC,PIVA,PVVA,PIFN,PVFN,PVPF,PIV, 3 IWA(LIIS), 4 IWA(LVIS),IWA(LIIC),IWA(LVIC),IWA(LIRC),WA(LVRC), 5 IWA(LIVA),WA(LVVA),IWA(LIFN),WA(LVFN),WA(LVGR), 6 IWA(LVPF),IWA(LIV),WA(LGST),IERR) F(K)=WA(LVFN+IWA(LIFN+(I-1)+(4-1)*PIFN)-1+(J-1)) ENDIF 15 CONTINUE ENDIF 20 CONTINUE RETURN END C C C SUBROUTINE SYMGRA (X,N,F,M,DF,MMAX,ACTIVE,WA,LWA,IWA,LIWA,IERR) INTEGER N,M,MMAX DOUBLE PRECISION X(N),F(M),DF(MMAX,N) LOGICAL ACTIVE(M) INTEGER LWA,LIWA DOUBLE PRECISION WA(LWA) INTEGER IWA(LIWA) INTEGER IERR C C*********************************************************************** C C S Y M G R A - EVALUATE SYMBOLICALLY DEFINED FUNCTIONS AND C CORRESPONDING GRADIENTS. C C PARAMETERS: C X(N) - ON INPUT, THE ONE-DIMENSIONAL ARRAY X HAS TO CONTAIN C THE ARGUMENT THE FUNCTIONS ARE TO BE COMPUTED AT. C F(M) - ON RETURN, F CONTAINS THE VALUES OF THE ACTIVE C FUNCTIONS AT ARGUMENT X. C DF(MMAX,N) - ON RETURN, DF CONTAINS THE GRADIENTS OF THE ACTIVE C FUNCTIONS AT ARGUMENT X. IN THE DRIVING PROGRAM, THE C ROW DIMENSION OF DF HAS TO BE EQUAL TO MMAX. C ACTIVE(M) - THE LOGICAL ARRAY SPECIFIES WHICH OF THE M FUNCTIONS C ARE TO BE COMPUTED ( ACTIVE(K) = .TRUE. ). C WA(LWA) - REAL WORKING ARRAY, CONTAINS THE INTERMEDIATE CODE C GENERATED BY SYMINP. C IWA(LIWA) - INTEGER WORKING ARRAY, CF. WA(LWA). C IERR - THE PARAMETER SHOWS THE REASON FOR TERMINATING THE C SUBROUTINE. ON RETURN IERR COULD CONTAIN THE FOLLOW- C ING VALUES: C IERR = 0 : SUCCESSFUL TERMINATION. C IERR > 0 : AN ERROR HAS BEEN DETECTED. FOR FURTHER C INFORMATION CF. SUBROUTINE SYMERR. C C*********************************************************************** C INTEGER PIIS,PVIS,PIIC,PVIC,PIRC,PVRC,PIVA,PVVA,PIFN,PXFN,PVFN INTEGER PVGR,PVPF,PIV,LIIS,LVIS,LIIC,LVIC,LIRC,LVRC,LIVA,LVVA INTEGER LIFN,LVFN,LVGR,LVPF,LIV,LGST C INTEGER IVAL DOUBLE PRECISION FVAL INTEGER I,J,K,L,PC C INTEGER GRAD PARAMETER (GRAD=1) C PIIS=IWA(1) PVIS=IWA(2) PIIC=IWA(3) PVIC=IWA(4) PIRC=IWA(5) PVRC=IWA(6) PIVA=IWA(7) PVVA=IWA(8) PIFN=IWA(9) PXFN=IWA(10) PVFN=IWA(11) PVGR=IWA(12) PVPF=IWA(13) PIV=IWA(14) LIIS=15 LVIS=LIIS+PIIS*5 LIIC=LVIS+PVIS LVIC=LIIC+PIIC*4 LIRC=LVIC+PVIC LVRC=1 LIVA=LIRC+PIRC*4 LVVA=LVRC+PVRC LIFN=LIVA+PIVA*3 LVFN=LVVA+PVVA LVGR=LVFN+PVFN LVPF=LIFN+PIFN*6 LIV=LVPF+PVPF LGST=LVGR+PVGR*PVVA IF (N .NE. PVVA) THEN IERR=43 RETURN ENDIF IF (M .NE. PVFN-(PIFN-PXFN)) THEN IERR=44 RETURN ENDIF DO 10 I=1,N WA(LVVA+I-1)=X(I) 10 CONTINUE K=0 DO 20 I=1,PXFN IF (IWA(LIFN+(I-1)+(1-1)*PIFN) .EQ. 0) THEN K=K+1 IF (ACTIVE(K)) THEN PC=IWA(LIFN+(I-1)+(6-1)*PIFN) CALL EVAL(PC,IVAL,FVAL,GRAD,PVVA, 1 PIIS,PVIS,PIIC,PVIC,PIRC,PVRC, 2 PIVA,PVVA,PIFN,PVFN,PVPF,PIV, 3 IWA(LIIS),IWA(LVIS), 4 IWA(LIIC),IWA(LVIC),IWA(LIRC),WA(LVRC),IWA(LIVA), 5 WA(LVVA),IWA(LIFN),WA(LVFN),WA(LVGR),IWA(LVPF),IWA(LIV), 6 WA(LGST),IERR) F(K)=WA(LVFN+IWA(LIFN+(I-1)+(4-1)*PIFN)-1) DO 11 L=1,PVVA DF(K,L)=WA(LVGR+(IWA(LIFN+(I-1)+(5-1)*PIFN)-1)+(L-1)*PVGR) 11 CONTINUE ENDIF ELSE IF (IWA(LIFN+(I-1)+(1-1)*PIFN) .EQ. 1) THEN DO 15 J=1,IWA(LIFN+(I-1)+(3-1)*PIFN) K=K+1 IF (ACTIVE(K)) THEN PC=IWA(LIFN+(I-1)+(6-1)*PIFN) IWA(LIV+IWA(LIFN+(I-1)+(2-1)*PIFN)-1)=J CALL EVAL(PC,IVAL,FVAL,GRAD,PVVA, 1 PIIS,PVIS,PIIC,PVIC,PIRC,PVRC, 2 PIVA,PVVA,PIFN,PVFN,PVPF,PIV, 3 IWA(LIIS),IWA(LVIS), 4 IWA(LIIC),IWA(LVIC),IWA(LIRC),WA(LVRC),IWA(LIVA), 5 WA(LVVA),IWA(LIFN),WA(LVFN),WA(LVGR),IWA(LVPF), 6 IWA(LIV),WA(LGST),IERR) F(K)=WA(LVFN+IWA(LIFN+(I-1)+(4-1)*PIFN)+(J-1)-1) DO 12 L=1,PVVA DF(K,L)=WA(LVGR+(IWA(LIFN+(I-1)+(5-1)*PIFN)-1+(J-1))+ 1 (L-1)*PVGR) 12 CONTINUE ENDIF 15 CONTINUE ENDIF 20 CONTINUE RETURN END