      SUBROUTINE GRAB(S,I4OR8,IBASE,NWORDS)                             MAN   20
      REAL*8 S
      DIMENSION S(1)                                                    MAN   30
C                                                                       MAN   40
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - MAN   50
C                                                                       MAN   60
C      THIS ROUTINE WILL OBTAIN ALL CORE REQUESTED ON THE JOB CARD      MAN   70
C   FOR USE IN A ONE-DIMENSIONAL ARRAY  'S'.... S(IBASE) IS THE FIRST   MAN   80
C   WORD OF THE ALLOCATED CORE.                                         MAN   90
C                                                                       MAN  100
C  ::;  DESCRIPTION OF PARAMETERS                                       MAN  110
C    S    -   THE ARRAY RELATIVE TO WHICH 'GRABBED' CORE IS ADDRESSED   MAN  120
C  I4OR8  -   AN I*4 VARIABLE WHOSE VALUE IS THE NUMBER OF BYTES PER    MAN  130
C             WORD IN THE ARRAY 'S'.  1,2,4,8,16 AND 32 ARE VALID       MAN  140
C  IBASE  -   THE INDEX OF THE FIRST WORD OF THE 'GRABBED' CORE         MAN  150
C  NWORDS -   THE NUMBER OF I4OR8-BYTE WORDS ALLOCATED                  MAN  160
C     ON INPUT IT IS THE NUMBER OF BYTES TO ALLOCATE, OR IF NEGATIVE,   MAN  170
C     IT IS THE NUMBER OF BYTES TO LEAVE FREE.                          MAN  180
CDCC                                                                    MAN  190
CDCC     I4OR8 = 1 IS REQUIRED                                          MAN  200
CDCC     NWORDS - ON INPUT IS THE NUMBER OF WORDS TO ALLOCATE.  IF      MAN  210
CDCC              NEGATIVE, 10000 IS USED.                              MAN  220
CDCC                                                                    MAN  230
C                                                                       MAN  240
C     IF FEWER THAN 16K WORDS ARE AVAILABLE, THE ROUTINE STOPS          MAN  250
C                                                                       MAN  260
C  THIS ROUTINE USES STEVE PIEPER'S ROUTINE KORUSE...                   MAN  270
C        IGOT=KORUSE(IASK,ITSAT)                                        MAN  280
C  FOUND IN B21541.GENLIB.LOAD.  SOURCE IS IN B21541.GENLIB.FORT ON     MAN  290
C  CELLBC.   KORUSE TRIES TO ALLOCATE IASK BYTES OF CORE. IT RETURNS    MAN  300
C  IGOT BYTES OF CORE. THIS IS SMALLER THAN IASK IF IASK CONTIGUOUS     MAN  310
C  BYTES NOT AVAILABLE                                                  MAN  320
C  ITSAT IS THE ABSOLUTE LOCATION IN CORE OF THE FIRST BTYE             MAN  330
C  THIS ROUTINE ALSO USES STEVE PIEPER'S  ROUTINE KORFRE                MAN  340
C  WHICH HAS A DUMMY ARGUMENT AND RETURNS THE AVAILABLE CORE            MAN  350
C  IN BYTES                                                             MAN  360
C                                                                       MAN  510
C  IF SIZE GIVEN IN INPUT WILL ASK FOR THE AMOUNT SPECIFIED             MAN  520
C  ALSO WILL CHECK IF AVAILABLE                                         MAN  530
C                                                                       MAN 1940
C     FOLLOWING IS FOR UNIX(ULTRIX) (VIRTUAL MEMORY)   
C                                                                       MAN 1960
      IASK = NWORDS
      IF ( IASK .LT. 0 ) IASK = 5 000 000                               MAN 1980
      CALL GET_MEMORY(IASK,ITSAT,IERR)
      if(itsat.eq.0)then
          write(*,*)'FATAL ERROR: cannot fill memory request'
          call exit(1)
      endif
CVAX  IRET = LIB$GET_VM ( IASK, ITSAT )                                 MAN 1990
CVAX  IF ( IRET .NE. 1 ) CALL LIB$STOP (%VAL(IRET) )                    MAN 2000
      PRINT 1003, IASK                                                  MAN 2010
 1003 FORMAT ( ' ALLOCATED ', I10, ' BYTES OF VIRTUAL MEMORY' / )       MAN 2020
      NWORDS = IASK/I4OR8 - 1                                           MAN 2030
C                                                                       MAN 2060
C   HERE WE HAVE IGOT BYTES STARTING IN LOCATION ITSAT                  MAN 2070
C                                                                       MAN 2080
C   <-------------- ITSAT BYTES ---------> <---- IGOT BYTES ----->      MAN 2090
C                                                                       MAN 2100
C  0                S(1)                S(IBASE)        S(IBASE+NWORDS) MAN 2110
C   <-LOCF(S) BYTES->                                                   MAN 2120
C                                                                       MAN 2130
C -- THE LOCF FUNCTION RETURNS THE ADDRESS (IN BYTES REL TO LOC'N 0)    MAN 2140
C   OF THE VARIABLE S                                                   MAN 2150
C                                                                       MAN 2160
  60  LOCS = %LOC(S)                                                    MAN 2170
      IBASE = (ITSAT-LOCS)/I4OR8 + 1                                    MAN 2180
      nelem=iask/i4or8
      do i=1,nelem
         s(ibase+i)=0.
      enddo
COMC                                                                    MAN 2240
COMC      FOR FIXED-SIZE COMMON MEMORY                                  MAN 2250
COMC                                                                    MAN 2260
COM      IBASE = 10                                                     MAN 2270
COM      NWORDS = MAXWRD - IBASE                                        MAN 2280
COM      PRINT 23, NWORDS                                               MAN 2290
COM  23  FORMAT ( '0FIXED COMMON BLOCK VERSION OF PTOLEMY, ',           MAN 2300
COM     1  ' ALLOCATOR SIZE =', I6, ' WORDS.' / )                       MAN 2310
      RETURN                                                            MAN 2320
      END
      
      SUBROUTINE GETLNK ( AKEY, IRET )                                  MAN   20
C                                                                       MAN   30
C     PROCESSES LINKULE KEYWORDS AND LOADS LINKULE                      MAN   40
C                                                                       MAN   50
C     THIS ROUTINE DETERMINES WHAT ( REAL POTENTIAL, IMAG POTENTIAL,    MAN   60
C     WAVE FUNCTIONS) IS TO BE SET BY THE LINKULE AND ALSO THE          MAN   70
C     LINKULE NAME.                                                     MAN   80
C     IT THEN LOADS THE LINKULE AND SAVES ITS ADDRESS.                  MAN   90
C                                                                       MAN  100
C     IRET - 0 = AN ERROR; 1 = O.K.                                     MAN  110
C                                                                       MAN  120
C     11/24/77 - FIRST VERSION - S.P.                                   MAN  130
C     7/6/78 - CDC VERSION ADDED                                        MAN  140
C     12/7/78 - TENSOR POTENTIALS ADDED, AND USE NUMLNK - RPG           MAN  150
C     12/27/79 - CHANGE CDC PREFIXES TO CNI, ADD MORE NAMES - RPG       MAN  160
C     1/16/80 - MORE CHARACTER*8'S, REMOVE EXTRA / - RPG                MAN  170
C      1/21/80 - %M, CIB%F AROUND LOCF CALLS - RPG                      MAN  180
C     2/25/80 - REMOVE 1ST INDEX FROM LNKNAM - RPG                      MAN  190
C     3/14/80 - REMOVE BOTH ABOVE CHANGES - S.P.                        MAN  200
C     7/28/81 - PRINT LOCATION OF LOAD - S.P.                           MAN  210
C                                                                       MAN  220
      IMPLICIT REAL*8 ( A-H, O-Z )                                      MAN  230
      COMMON /LNKBLK/ NUMLNK, IUNIQU, LNKADR(6,12)                      MAN  240
      CHARACTER*8 LNKNAM(3,12)
      EQUIVALENCE ( LNKNAM(1,1), LNKADR(1,1) )                          MAN  240
C                                                                       MAN  250
      CHARACTER*8 AKEY                                                  MAN  260
      CHARACTER*8 WORD
      CHARACTER*8 AKEYS(12)                                             MAN  270
      DATA AKEYS/'REALPOTE', 'IMAGPOTE', 'REALSOPO', 'IMAGSOPO', 'COULOMMAN  270
     *BP', 'WAVEFUNC', 'REALTRPO', 'IMAGTRPO', 'REALTLPO', 'IMAGTLPO', 'MAN  270
     *REALTPRP', 'IMAGTPRP'/                                            MAN  270
C                                                                       MAN  300
C     FOR NON-IBM WE NEED A LIST OF SUBROUTINE (=LINKUL) NAMES          MAN  310
C                                                                       MAN  320
      DATA NUMNAM /15/                                                  MAN  330
      CHARACTER*8 NAMES(15)
      DATA NAMES/'BKGPTELP', 'FIXEDWOO', 'GAUSSIAN', 'LAGRANGE', 'LTSTELMAN  340
     *P ', 'OHTA    ', 'PARITWOO', 'RAWITSCH', 'REID    ', 'SHAPE   ',  MAN  340
     * 'SPLINE ','TWOSHAPE','DEFORM','JDEPEN','JDEPE1'/
      EXTERNAL BKGPTE, FIXEDW, GAUSSI, LAGRAN, LTSTEL, OHTA , PARITW, RAMAN  370
     *WITS, REID , SHAPE , SPLINE, twosha,deform,jdepen,jdepe1                               
C                                                                       MAN  400
      CHARACTER*8 INTERN
      DATA INTERN / 'INTERNAL' /                                        MAN  420
C                                                                       MAN  470
C     FIND THE KEY                                                      MAN  480
C                                                                       MAN  490
      DO 19 IKEY = 1, NUMLNK                                            MAN  500
      IF ( AKEY .EQ. AKEYS(IKEY) ) GO TO 50                             MAN  510
 19   CONTINUE                                                          MAN  520
C                                                                       MAN  530
C     GET THE LINKULE NAME                                              MAN  540
C                                                                       MAN  550
 50   CALL NXWORD ( WORD, &900, &900, &900 )                            MAN  560
      LNKNAM(1,IKEY) = WORD                                             MAN  570
      ILOC = 0                                                          MAN  580
      IF ( WORD .EQ. INTERN ) GO TO 200                                 MAN  590
C                                                                       MAN  600
C     LOAD IT                                                           MAN  620
C     IN THE NON-IBM VERSIONS THE LINKULES ARE IN THE OVERLAY           MAN  790
C                                                                       MAN  800
      DO 109 I = 1, NUMNAM                                              MAN  810
      IF ( WORD .EQ. NAMES(I) ) GO TO 140                               MAN  820
 109  CONTINUE                                                          MAN  830
      PRINT 113, WORD                                                   MAN  840
 113  FORMAT ( '0*** ', A8, ' IS NOT IN THIS VERSION OF PTOLEMY.' )     MAN  850
      GO TO 950                                                         MAN  860
C                                                                       MAN  870
 140  GO TO ( 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152MAN  880
	2,153,154,155),I
 141  ILOC = %LOC(BKGPTE)                                               MAN  910
      GO TO 200                                                         MAN  920
 142  ILOC = %LOC(FIXEDW)                                               MAN  930
      GO TO 200                                                         MAN  940
 143  ILOC = %LOC(GAUSSI)                                               MAN  950
      GO TO 200                                                         MAN  960
 144  ILOC = %LOC(LAGRAN)                                               MAN  970
      GO TO 200                                                         MAN  980
 145  ILOC = %LOC(LTSTEL)                                               MAN  990
      GO TO 200                                                         MAN 1000
 146  ILOC = %LOC(OHTA)                                                 MAN 1010
      GO TO 200                                                         MAN 1020
 147  ILOC = %LOC(PARITW)                                               MAN 1030
      GO TO 200                                                         MAN 1040
 148  ILOC = %LOC(RAWITS)                                               MAN 1050
      GO TO 200                                                         MAN 1060
 149  ILOC = %LOC(REID)                                                 MAN 1070
      GO TO 200                                                         MAN 1080
 150  ILOC = %LOC(SHAPE)                                                MAN 1090
      GO TO 200                                                         MAN 1100
 151  ILOC = %LOC(SPLINE)                                               MAN 1110
      GO TO 200                                                         MAN 1120
 152  ILOC = %LOC(TWOSHA)                                               MAN 1130
           GO TO 200
 153      ILOC=%LOC(DEFORM)
	GO TO 200
 154       ILOC=%LOC(JDEPEN)
           GO TO 200
 155       ILOC=%LOC(JDEPE1)
C                                                                       MAN 1160
 200  LNKADR(3,IKEY) = ILOC                                             MAN 1170
      PRINT 203, WORD, ILOC                                             MAN 1180
 203  FORMAT ( ' LINKULE ', A8, ' LOADED AT LOCATION ', Z8 )            MAN 1190
CDC     1  O12 )                                                        MAN 1210
      IRET = 1                                                          MAN 1220
      RETURN                                                            MAN 1230
C                                                                       MAN 1240
 900  PRINT 903, AKEY                                                   MAN 1250
 903  FORMAT ( '0**** A LINKULE NAME MUST FOLLOW THE ', A8, ' KEYWORD.' MAN 1260
     *)                                                                 MAN 1260
 950  IRET = 0                                                          MAN 1280
      RETURN                                                            MAN 1290
      END
      
      SUBROUTINE SAVEHS ( IRET )                                        MAN   20
C                                                                       MAN   50
C     INITIALIZE THE SAVING AND RESTORING OF THE H'S.                   MAN   60
C                                                                       MAN   70
C                                                                       MAN   80
C     THE SAVEHS FILE IS A SEQUENTIAL DATA SET WRITTEN WITHOUT FORMAT   MAN   90
C     CONTROL.  IT CONTAINS THE FOLLOWING LOGICAL RECORDS.              MAN  100
C                                                                       MAN  110
C     1)  SAVEHS HEADER; DATE; REACTION; HEADER                         MAN  120
C     2)  COMMONS FOR FIRST BOUNDSTATE.                                 MAN  130
C     3)  COMMONS FOR SECOND BOUNDSTATE.                                MAN  140
C     4)  COMMONS AT START OF GRID SETUP.                               MAN  150
C       ITEMS 2, 3, AND 4 HAVE THE SAME FORMAT AND ARE PRODUCED         MAN  160
C       BY THE ENTRY 'SAVECM' BELOW.                                    MAN  170
C     5)  GRDSET VARIABLES STARTING WITH  NPSUM, NPDIF, ...             MAN  180
C     6) A)  DIF-RANGE POLYS                                            MAN  190
C        B)  SUM POINTS FOR FINDING H'S                                 MAN  200
C        C)  1/(EXPONENTIAL TAILS) THAT ARE MULTIPLIED INTO             MAN  210
C            THE COMPUTED H'S.                                          MAN  220
C        D)  RI POINTS FOR FINDING H'S                                  MAN  230
C        E)  RO POINTS FOR FINDING H'S                                  MAN  240
C     7)  NUMLIS  -  A SINGLE INTEGER.                                  MAN  250
C     8)  LIS - THE ARRAY OF LI'S ATWHICH STUFF WAS COMPUTED.           MAN  260
C     9)  H-RECORDS.  THERE IS ONE FOR EACH VALUE OF (LI, AND DIF).     MAN  270
C         EACH RECORD CONSISTS OF AN IDENTIFIER,                        MAN  280
C         AND THE HS FOR EACH VALUE OF (SUM, LX, LO-LI).                MAN  290
C             THE H'S HAVE BEEN MULTIPLIED BY THE EXP FACTORS IN 6.C    MAN  300
C         A DUMMY H-RECORD WITH A VERY LARGE IDENTIFIER IS WRITTEN      MAN  310
C         AT THE END OF THE H'S.                                        MAN  320
C                                                                       MAN  330
C           FOR MULTIPASS RUNS, RECORD TYPES 2-9 REPEAT FOR EACH PASS,  MAN  340
C     EXCEPT THAT RECORD 2 OR 3 MAY BE OMITTED IF NO CHANGE.            MAN  350
C     THE SEQUENCE TERMINATES GRACEFULLY AT AN END-OF-FILE.             MAN  360
C                                                                       MAN  370
C                                                                       MAN  380
C     6/10/75 - FIRST VERSION                                           MAN  390
C     7/29/75 - DON'T OVERRIDE THE HEADER                               MAN  400
C     9/17/75 - SAVE/RESTORE R0MASS.                                    MAN  410
C     2/29/76 - ADVANCE TO TYPE 2 - INCOMPATABLE WITH EARLIER PTOLEMY   MAN  420
C      5/21/76 - TYPE 3                                                 MAN  430
C     10/3/76 - CONVERT OLD UNDEF TO NEW UNDEF                          MAN  440
C     4/25/78 - TYPE 4 FOR REVERSAL OF LIN, LOUT - S.P.                 MAN  450
C     5/13/79 - TYPE 5 FOR PARITIES, RATMAS.  RECONSTRUCT TYPE 4 - S.P. MAN  460
C     10/26/79 - STANDARDIZE, TERMINATE GRACEFULLY AT EOF IN MULTIPASS  MAN  470
C        USEHS RUNS - RPG                                               MAN  480
C     2/5/80 - CHAR*8 DATE, THISDT; CVA OPEN SAVEHS FILE;               MAN  490
C        INTGER TO INTGR; CVA COMMON /INTGER/ - RPG                     MAN  500
C                                                                       MAN  510
C     THE  SAVEHS  KEYWORD WAS USED.  CHECK VALIDITY AND INITIALIZE     MAN  520
C                                                                       MAN  530
      IMPLICIT REAL*8 ( A-H, O-Z )                                      MAN  540
      INTEGER PARITS, PARIPT, PARITY                                    MAN  550
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,MAN  550
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINTMAN  550
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, IMAN  550
     *REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), MAN  550
     *PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, NBLKSZ,MAN  550
     * MAPPHI, NFIROF, LEBACK                                           MAN  550
      LOGICAL*1 WASSET                                                  MAN  560
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), IDMAN  560
     *ONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, R0MASS, WMAN  560
     *ASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), NODEPT(2),ICD3MAN  560
     *I                                                                 MAN  560
C JRB 5/92 add float common, since amt used here but not defined ???
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, AMAN  560
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, TMAN  560
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, MAN  560
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPAMAN  560
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, MAN  560
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0MAN  560
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, MAN  560
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, MAN  560
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDAMAN  560
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PAMAN  560
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, RMAN  560
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, AMAN  560
     *MXGPT(2), PHIMID, GAMPHI                                          MAN  560
C JRB 5/92 add float common, since amt used here but not defined ???
      CHARACTER*1 REACT, HEADER                                         MAN  570
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             MAN  570
C                                                                       MAN  580
      DIMENSION FLOATK(NUMFLT)                                          MAN  590
      INTEGER INTGR(NUMINT), JBLOCK(NUMJ), SWITCH(NUMSW)                MAN  600
C                                                                       MAN  610
      CHARACTER*1 THEDAT(18), HEADR2(65), BLNK1                         MAN  630
      DATA BLNK1/' '/                                                   MAN  630
C                                                                       MAN  640
      CHARACTER*8 HED(4), HED2(4)                                       MAN  650
CDC      INTEGER HED(2), HED2(2)                                        MAN  660
      DATA HED / 'PTOLEMY ', 'SAVEHS F', 'ILE     ', '        ' /       MAN  670
CDC      DATA HED / 'PTOLEMY SAVEHS FILE' /                             MAN  680
      CHARACTER*8 DATE, THISDT                                          MAN  690
      INTEGER TYPE,TYPE2                                                MAN  700
      DATA TYPE / 5 /                                                   MAN  700
C                                                                       MAN  710
      IRET = 0                                                          MAN  800
C                                                                       MAN  810
C     CAN ONLY HAVE SAVEHS OR USEHS; NOT BOTH                           MAN  820
C                                                                       MAN  830
      IF ( IHSAVE .EQ. 0 ) GO TO 40                                     MAN  840
 32   PRINT 33                                                          MAN  850
 33   FORMAT ( '0**** SAVEHS AND USEHS ARE EXCLUSIVE; OR ',  ' SAVEHS ORMAN  860
     * USEHS HAS ALREADY BEEN ENTERED.' )                               MAN  860
      RETURN                                                            MAN  880
C                                                                       MAN  890
 40   IF ( IDONE .EQ. 0 ) GO TO 50                                      MAN  900
 42   PRINT 43                                                          MAN  910
 43   FORMAT ( '0**** IT IS TOO LATE TO INITIALIZE FOR SAVEHS',  ' OR USMAN  920
     *EHS.' )                                                           MAN  920
      RETURN                                                            MAN  940
C                                                                       MAN  950
 50   CONTINUE                                                          MAN 1070
C                                                                       MAN 1080
C     OPEN THE OUTPUT FILE                                              MAN 1090
C                                                                       MAN 1100
      NBLKSZ = MAX0( (NBLKSZ+511)/512, 1 )*512                          MAN 1110
      NBLKS = LENHF( IDUM )/NBLKSZ + 1                                  MAN 1120
      PRINT 53, NBLKSZ, NBLKS                                           MAN 1130
 53   FORMAT ( '0BLOCK SIZE OF H"S FILE =', I6,  ' BYTES, INITIAL SIZE =MAN 1140
     *', I6, ' BLOCKS.' )                                               MAN 1140
      OPEN ( UNIT=1, TYPE='NEW', DISP='SAVE', BLOCKSIZE=NBLKSZ,  FORM='UMAN 1160
     *NFORMATTED', INITIALSIZE=NBLKS, ERR=90 )                          MAN 1160
CNV      REWIND 1                                                       MAN 1180
      THISDT = DATE(THISDT)                                             MAN 1190
      CALL EDTDAT ( THEDAT, N, THISDT )                                 MAN 1200
      WRITE ( 1, ERR=90 ) HED, TYPE, THEDAT, REACT, HEADER              MAN 1210
C                                                                       MAN 1220
      IHSAVE = 1                                                        MAN 1230
      IRET = 1                                                          MAN 1240
      RETURN                                                            MAN 1250
C                                                                       MAN 1260
 90   PRINT 93                                                          MAN 1270
 93   FORMAT ( '0**** ERROR IN INITIALIZING H  S FILE.' )               MAN 1280
      RETURN                                                            MAN 1290
C                                                                       MAN 1310
C     WRITE THE COMMON BLOCKS AFTER EACH BOUND STATE AND BEFORE         MAN 1320
C     GRDSET.                                                           MAN 1330
C                                                                       MAN 1340
      ENTRY SAVECM ( NUMFLT, FLOATK, NUMINT, INTGR, NUMJ, JBLOCK, NUMSW,MAN 1350
     * SWITCH, IRET )                                                   MAN 1350
C                                                                       MAN 1370
      TEMP = 0                                                          MAN 1380
      WRITE ( 1, ERR=190 ) ICHANB, ISTRIP, NUMFLT, NUMINT,  NUMJ, NUMSW,MAN 1390
     * FLOATK, INTGR, JBLOCK, SWITCH, R0MASS,  RATMAS, TEMP, TEMP, TEMP,MAN 1390
     * TEMP, TEMP                                                       MAN 1390
      IRET = 1                                                          MAN 1430
      RETURN                                                            MAN 1440
C                                                                       MAN 1450
 190  PRINT 193                                                         MAN 1460
 193  FORMAT ( '0**** ERROR IN WRITING ON H  S FILE.' )                 MAN 1470
      IRET = 0                                                          MAN 1480
      RETURN                                                            MAN 1490
C                                                                       MAN 1510
C     USEHS KEYWORD READ - INITIALIZE H'S INPUT                         MAN 1520
C                                                                       MAN 1530
      ENTRY USEHS ( NUMFLT, FLOATK, NUMINT, INTGR, NUMJ, JBLOCK, NUMSW, MAN 1540
     *SWITCH, IRET )                                                    MAN 1540
C                                                                       MAN 1560
      GO TO ( 200, 300, 300 ), IRET                                     MAN 1570
C                                                                       MAN 1580
 200  IRET = 0                                                          MAN 1590
      IF ( IHSAVE .NE. 0 ) GO TO 32                                     MAN 1600
      IF ( IDONE .NE. 0 ) GO TO 42                                      MAN 1610
C                                                                       MAN 1670
C     OPEN THE INPUT FILE                                               MAN 1680
C                                                                       MAN 1690
      REWIND 1                                                          MAN 1700
      READ ( 1, ERR=90, END=90 ) HED2, TYPE2, THEDAT, REACT, HEADR2     MAN 1710
      DO 239 I = 1, 2                                                   MAN 1720
      IF ( HED2(I) .EQ. HED(I) ) GO TO 239                              MAN 1730
      PRINT 233                                                         MAN 1740
CIB 233     FORMAT ('0**** FT01F001 DOES NOT POINT TO A SAVEHS FILE.')  MAN 1750
 233  FORMAT ('0**** TAPE1 DOES NOT POINT TO A SAVEHS FILE.')           MAN 1760
      RETURN                                                            MAN 1770
 239  CONTINUE                                                          MAN 1780
C                                                                       MAN 1790
      PRINT 253, THEDAT, REACT, HEADR2                                  MAN 1800
 253  FORMAT ( '  ON ', 18A1, ' ARE BEING REUSED.' /  '0 ', 45A1, 5X, 65MAN 1810
     *A1 / )                                                            MAN 1810
      DO 265 I = 1, 65                                                  MAN 1830
      IF ( HEADER(I) .NE. BLNK1 ) GO TO 280                             MAN 1840
 265  CONTINUE                                                          MAN 1850
      DO 269 I = 1, 65                                                  MAN 1860
      HEADER(I) = HEADR2(I)                                             MAN 1870
 269  CONTINUE                                                          MAN 1880
C                                                                       MAN 1890
 280  IF ( TYPE .EQ. TYPE2 ) GO TO 300                                  MAN 1900
      IF ( TYPE2 .EQ. 4 ) GO TO 300                                     MAN 1910
      PRINT 283, TYPE, TYPE2                                            MAN 1920
 283  FORMAT ( '0THE H  S FILE IS INCOMPATABLE WITH THE PRESENT',  ' VERMAN 1930
     *SION OF PTOLEMY:', 2I10 )                                         MAN 1930
      RETURN                                                            MAN 1950
C                                                                       MAN 1960
C     READ BOUNDSTATE AND GRDSET COMMONS                                MAN 1970
C                                                                       MAN 1980
 300  READ ( 1, ERR=390, END=380 ) ICHANB, ISTRIP,  NF, NI, NJ, NS,     MAN 1990
     * (FLOATK(I), I=1,NF), (INTGR(I), I = 1,NI), (JBLOCK(I), I = 1,    MAN 1990
     * NJ ), ( SWITCH(I), I = 1, NS ), R0MASS,  RATMAS                  MAN 1990
      IHSAVE = 2                                                        MAN 2040
      IRET = 1                                                          MAN 2050
C                                                                       MAN 2120
C     TYPE 4 SAVEHS HAVE RATMAS = 0.  WE SET RATMAS = AMP/AMT AND       MAN 2130
C     INDICATE ALL PARITES ARE UNKNOWN.                                 MAN 2140
C                                                                       MAN 2150
      IF ( RATMAS .NE. 0 ) RETURN                                       MAN 2160
      RATMAS = AMP/AMT                                                  MAN 2170
      DO 339 I = 33, 40                                                 MAN 2180
      INTGR(I) = 0                                                      MAN 2190
 339  CONTINUE                                                          MAN 2200
      RETURN                                                            MAN 2210
C                                                                       MAN 2220
C                                                                       MAN 2230
C     IN A MULTIPASS RUN, AN END OF FILE MAY BE OK.                     MAN 2240
C                                                                       MAN 2250
 380  IF ( IRET .NE. 3 ) GO TO 390                                      MAN 2260
      PRINT 383                                                         MAN 2270
 383  FORMAT ( '0', 10X, '**** END OF H  S FILE ****' )                 MAN 2280
      IRET = -1                                                         MAN 2290
      IHSAVE = 0                                                        MAN 2300
      RETURN                                                            MAN 2310
 390  PRINT 393                                                         MAN 2320
 393  FORMAT ( '0**** ERROR OR UNEXPECTED END-OF-FILE WHEN',  ' READING MAN 2330
     *H  S FILE' )                                                      MAN 2330
      IRET = 0                                                          MAN 2350
      RETURN                                                            MAN 2360
      END
      
      SUBROUTINE LINKUL ( LOC,ALIAS,MYINTS,IPOTYP,IREQUE,IRETUR,L,      MAN   20
     * J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, ID )                  MAN   20
C                                                                       MAN   40
C     LINKULE CALLER FOR PTOLEMY                                        MAN   50
C                                                                       MAN   60
C     THIS ROUTINE ADDS THE FIXED PART OF A LINKULE ARGUMENT LIST       MAN   70
C     TO THE ABOVE ARGUMENTS AND THEN CALLS THE LINKULE.                MAN   80
C     THE LINKULE MUST ALREADY BE LOADED IN CORE AND LOC MUST BE ITS    MAN   90
C     ENTRY POINT ADDRESS.                                              MAN  100
C     UPON RETURN, THE STUFF WRITTEN IN IUNIT WILL BE COPIED TO THE     MAN  110
C     PRINTER.                                                          MAN  120
C                                                                       MAN  130
C     11/25/77 - FIRST VERSION - S.P.                                   MAN  140
C     7/6/78 - CDC VERSION                                              MAN  150
C     5/6/79 - PASS IPARAM ARRAY SEPARATELY - S.P.                      MAN  160
C     12/28/79 - STANDARD MORTRAN - RPG                                 MAN  170
C     7/30/80 - IUNIT IS 6 FOR CDC - S.P.                               MAN  180
C                                                                       MAN  190
      IMPLICIT REAL*8 ( A-H, O-Z )                                      MAN  200
C                                                                       MAN  210
      DIMENSION MYINTS(2), ARRAY1(1), ARRAY2(1)                         MAN  220
      INTEGER*4 Z                                                       MAN  240
      COMMON /LOCKT/ Z(100)                                             MAN  240
      INTEGER FACFR4, FACFR2, FACFR1                                    MAN  240
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            MAN  240
      DIMENSION ALLOC(1)                                                MAN  240
      LOGICAL*1 MLLOC(1)                                                MAN  240
      REAL*4 ALLOC4(1)                                                  MAN  240
      INTEGER ILLOC(1)                                                  MAN  240
      INTEGER*2 ILLOC2(1)                                               MAN  240
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), MLMAN  240
     *LOC(1) )                                                          MAN  240
      COMMON / LENGTH / LENG(1)                                         MAN  250
      COMMON / FLOAT / F(153)                                           MAN  270
      COMMON / INTGER/ I(46)                                            MAN  280
      COMMON / JBLOCK / JB(1)                                           MAN  290
      COMMON / SWITCH / IS(1)                                           MAN  300
      COMMON / CNSTNT / C(1)                                            MAN  310
      COMMON / TEMPVS / T(1)                                            MAN  320
      COMMON / WAVCOM / WAV(1)                                          MAN  330
      COMMON / KANDM / KM(1)                                            MAN  340
      COMMON / INTRNL / IN(1)                                           MAN  350
C                                                                       MAN  360
      EXTERNAL NALLOC, NAMLOC                                           MAN  370
      DATA IUNIT /10/                                                   MAN  390
CDC      DATA IUNIT /6/                                                 MAN  400
C                                                                       MAN  410
      CHARACTER*1 LINE(133)                                             MAN  420
C     NOTE:                                                             MAN  470
C     F(112) IS BEGINING OF PARAM'S                                     MAN  490
C     I(46) IS BEGINNING OF IPARAM'S                                    MAN  500
C      write(6,1996) alias
C1996  format(/,' I am now in LINKUL: ',A8/) 
      IF(ALIAS.EQ.'SHAPE') THEN
      CALL SHAPE(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'SPLINE') THEN
      CALL SPLINE(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'BKGPTELP') THEN
      CALL BKGPTE(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC, I(46))
      ELSE IF(ALIAS.EQ.'DEFORM') THEN
      CALL DEFORM(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC, I(46) )
      ELSE IF(ALIAS.EQ.'OHTA') THEN
      CALL OHTA(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'PARITWOO') THEN
      CALL PARITW(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'FIXEDWOO') THEN
      CALL FIXEDW(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'GAUSSIAN') THEN
      CALL GAUSSI(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'JDEPE1') THEN
      CALL JDEPE1(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'JDEPEN') THEN
      CALL JDEPEN(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'LAGRANGE') THEN
      CALL LAGRAN(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'LTSTELP') THEN
      CALL LTSTEL(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC, I(46))
      ELSE IF(ALIAS.EQ.'RAWITSCH') THEN
      CALL RAWITS(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      ELSE IF(ALIAS.EQ.'REID') THEN
      CALL REID(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC, I(46))
      ELSE IF(ALIAS.EQ.'TWOSHAPE') THEN
      CALL TWOSHA(ALIAS, MYINTS, IPOTYP, IREQUE, IRETUR, IUNIT, NUMOUT,                                                  MAN  530
     &  L, J, RSTART, STEPSZ, NUMPTS, ARRAY1, ARRAY2, F, T, F(112), I, 
     & JB, IS, IN, IN, C, WAV, KM, ID, ALLOC, ILLOC, FACFR4, Z, LENG, 
     & NALLOC, NAMLOC )
      END IF
C      write(6,1996) alias 
C                                                                       MAN  580
      IF ( NUMOUT .EQ. 0 )  RETURN                                      MAN  590
C                                                                       MAN  600
 150  READ ( IUNIT, 153, END=200 )  LINE                                MAN  610
 153  FORMAT ( 133A1 )                                                  MAN  620
      PRINT 153, LINE                                                   MAN  630
      GO TO 150                                                         MAN  640
 200  REWIND IUNIT                                                      MAN  650
      RETURN                                                            MAN  660
      END
C            
      SUBROUTINE KEEPIT                                                 MAN   20
C                                                                       MAN   30
C     PERFORMS SPEAKEASY KEEP OPERATION FOR PTOLEMY                     MAN   40
C                                                                       MAN   50
C     PTOLEMY INPUT IS                                                  MAN   60
C                                                                       MAN   70
C     KEEP  OBJECTNAME  MEMBERNAME                                      MAN   80
C                                                                       MAN   90
C     OBJECTNAME MAY BE EITHER THE NAME OF AN OBJECT IN THE ALLOCATOR   MAN  100
C     OR ONE OF THE FOLLOWING SPECIAL NAMES                             MAN  110
C       ANGLEGRID - KEEPS ANGLESTEP, ANGLEMIN, ANGLEMAX                 MAN  120
C       HEADER - KEEPS THE HEADER WITHOUT LEADING BLANKS                MAN  130
C       REACTION - KEEPS THE REACTION WITHOUT TRAILING BLANKS           MAN  140
C       ELAB                                                            MAN  150
C                                                                       MAN  160
C     THE PDS IS REFERED TO BY THE DDNAME MYKEEP.                       MAN  170
C                                                                       MAN  180
C     11/7/76 - FIRST VERSION                                           MAN  190
C     4/9/78 - CHIGNVEC ADDED TO LIST - S.P.                            MAN  200
C     4/25/78 - LI AND LO INTERCHANGED - S.P.                           MAN  210
C     4/27/78 - I AND ISUM ADDED TO SPECIAL NAMES - S.P.                MAN  220
C     3/6/79 - S MATRICES - S.P.                                        MAN  230
C     12/28/79 - STANDARD MORTRAN - RPG                                 MAN  240
C     1/16/80 - CHARACTER*8 OBNAME, MOVE CIB%F DOWN - RPG               MAN  250
C     12/14/18 - CROSSSECTIONS, F, ETC BY ANGLE GRID - S.P.             MAN  260
C                                                                       MAN  270
      IMPLICIT REAL*8 ( A-H, O-Z )                                      MAN  280
C                                                                       MAN  290
      INTEGER*4 Z                                                       MAN  300
      COMMON /LOCKT/ Z(100)                                             MAN  300
      INTEGER FACFR4, FACFR2, FACFR1                                    MAN  300
      COMMON /ALLOCS/ FACFR4, FACFR2, FACFR1                            MAN  300
      DIMENSION ALLOC(1)                                                MAN  300
      LOGICAL*1 MLLOC(1)                                                MAN  300
      REAL*4 ALLOC4(1)                                                  MAN  300
      INTEGER ILLOC(1)                                                  MAN  300
      INTEGER*2 ILLOC2(1)                                               MAN  300
      EQUIVALENCE ( FACFR4, ALLOC(1), ILLOC(1), ILLOC2(1), ALLOC4(1), MLMAN  300
     *LOC(1) )                                                          MAN  300
      COMMON /LENGTH/ LENG(1)                                           MAN  310
C                                                                       MAN  320
      COMMON /FLOAT/ A, ACCURA, AI, ANGSTP, ANGMIN, ANGMAX, ASO, ASOI, AMAN  330
     *SYMPT, DELTVK, DWCUT, E, ECM, ELAB, EXS(5), GAMDIF, GAMSUM, TAU, TMAN  330
     *AUI, AM, AMA, AMB, AMBIGA, AMBIGB, AMX, AMXCS(5), AMXCGS(5), AMP, MAN  330
     *AMT, Q, R, R0, RC, RC0, RI, RI0, RSO, RSO0, RSOI, RSOI0, SPAM, SPAMAN  330
     *MP, SPAMT, STEPSZ, STEP1R, STEP1I, SUMMAX, SUMMID, SUMMIN, V, VI, MAN  330
     *VSO, VSOI, FITMUL, WRITES, ASI, RSI, RSI0, VSI, AMDMLT, STPSPR, R0MAN  330
     *E, RI0E, AE, AIE, VE, VIE, FITACC, ALMNMT, SPFACP, SPFACT, R0ESQ, MAN  330
     *RI0ESQ, AESQ, AIESQ, VESQ, VIESQ, DERIVS, FITRAT, RCP, RCT, RC0P, MAN  330
     *RC0T, SUMPTS, ACCINE, COULML, ALMXMT, EXSPT(2), POWRL, POWIM, BNDAMAN  330
     *SY, SCTASY, VTR,VTRI,VTL,VTLI,VTP,VTPI, PARAM1, PARAM2, PARAM3, PAMAN  330
     *RAM4, PARAM5, PAR620(15), RTR, RTRI, RTL, RTLI, RTP, RTPI, RTR0, RMAN  330
     *TRI0, RTL0, RTLI0, RTP0, RTPI0, ATR, ATRI, ATL, ATLI, ATP, ATPI, AMAN  330
     *MXGPT(2), PHIMID, GAMPHI                                          MAN  330
      DIMENSION PARAMS(20)                                              MAN  330
      EQUIVALENCE ( PARAMS(1), PARAM1 )                                 MAN  330
      DIMENSION AMS(5)                                                  MAN  330
      EQUIVALENCE ( AMS(1), AMA )                                       MAN  330
      DIMENSION VTEN(6), RTEN(6), RTEN0(6), ATEN(6)                     MAN  330
      EQUIVALENCE ( VTEN(1), VTR ), (RTEN(1), RTR ), (RTEN0(1), RTR0 ), MAN  330
     *(ATEN(1), ATR )                                                   MAN  330
      CHARACTER*1 REACT, HEADER                                         MAN  340
      COMMON /HEDCOM/ REACT(45), HEADER(65)                             MAN  340
      LOGICAL ONELSW, IDENSW                                            MAN  350
      COMMON /INELCM/ JBPF, JBTF, LXMIN, LXMAX, ILILOR, ILILOI, MSTOP, IMAN  350
     *A12M, NMLOLX, ONELSW, NUMLX, IRDINT, IELCUP, LILOSZ, NUMLIS, ILIS,MAN  350
     * IBETAS(3), ICL2FF, LXSTEP, IDENSW, LSKIP, JPMIN, JPMAX, JPBASE, NMAN  350
     *JP, JTMIN, JTMAX, JTBASE, NJT, IINDXS, ISMATR, ISMATI, NSMAT, NLX,MAN  350
     * NSPLI, ITOCS, NASPLI, IUNITR, LIFIT, ILIFIT, NOLFIT, IDELSR, IDELMAN  350
     *SI                                                                MAN  350
      INTEGER INDXJS(4,2)                                               MAN  350
      EQUIVALENCE ( INDXJS(1,1), JPMIN )                                MAN  350
C                                                                       MAN  360
C                                                                       MAN  370
      CHARACTER*1 BLANK                                                 MAN  380
      DATA BLANK / ' ' /                                                MAN  380
      CHARACTER*8 OBNAME, MEMBER, MYKEEP, AS                            MAN  390
      DATA AS/'AS'/                                                     MAN  390
      DATA MYKEEP/'MYKEEP'/                                             MAN  390
C                                                                       MAN  400
      DATA NSPECL / 16 /                                                MAN  410
      CHARACTER*8 SPECIL(16)                                            MAN  420
      DATA SPECIL/'SMAG', 'SPHASE', 'LXCROSSS', 'MXCROSSS', 'SIN', 'SOUTMAN  420
     *', 'F', 'HEADER', 'REACTION', 'ELAB', 'ANGLEGRI', 'CHIGNVEC', 'S',MAN  420
     * 'ISUM', 'SEL', 'CROSSSEC'/                                       MAN  420
      INTEGER KINDS(16)                                                 MAN  450
      DATA KINDS/2, 2, 2, 2, 4, 4, 4, 9, 9, 2, 2, 2, 4, 4, 4, 2/        MAN  450
      INTEGER KLASSS(16)                                                MAN  470
      DATA KLASSS/6, 6, 6, 6, 5, 5, 6, 5, 5, 0, 5, 2, 6, 6, 5, 6/       MAN  470
      INTEGER ISIZES(16)                                                MAN  490
      DATA ISIZES/8, 8, 8, 8,16,16,16, 1, 1, 8, 8, 8,16,16, 16, 8/      MAN  490
      INTEGER IGOTOS(16)                                                MAN  510
      DATA IGOTOS/2, 2, 3, 3, 1, 1, 3, 4, 5, 6, 7, 8, 2, 2, 1, 3/       MAN  510
C                                                                       MAN  540
      CALL NXWORD ( OBNAME, &900, &900, &900 )                          MAN  550
 50   CALL NXWORD ( MEMBER, &900, &900, &900 )                          MAN  560
      IF ( MEMBER .EQ. AS ) GO TO 50                                    MAN  570
C                                                                       MAN  580
C     IS IT IN THE ALLOCATOR                                            MAN  590
C                                                                       MAN  600
      IOB = NAMLOC(OBNAME)                                              MAN  610
      LOCOB = Z(IOB)                                                    MAN  620
      LENOB = LENG(IOB)                                                 MAN  630
C                                                                       MAN  640
C     SET UP KIND, ETC                                                  MAN  650
C                                                                       MAN  660
      KIND = 2                                                          MAN  670
      KLASS = 5                                                         MAN  680
      ISIZE = 8                                                         MAN  690
      NCOLS = 1                                                         MAN  700
      NROWS = 0                                                         MAN  710
C                                                                       MAN  720
C     SEE IF WE KNOW SOMETHING SPECIAL ABOUT IT                         MAN  730
C                                                                       MAN  740
      DO 189 I = 1, NSPECL                                              MAN  750
      IF ( SPECIL(I) .EQ. OBNAME ) GO TO 200                            MAN  760
 189  CONTINUE                                                          MAN  770
      GO TO 500                                                         MAN  780
C                                                                       MAN  790
C     PROCESS SPECIAL STUFF                                             MAN  800
C                                                                       MAN  810
 200  KIND = KINDS(I)                                                   MAN  820
      KLASS = KLASSS(I)                                                 MAN  830
      ISIZE = ISIZES(I)                                                 MAN  840
      IGOTO = IGOTOS(I)                                                 MAN  850
      GO TO ( 500, 220, 230, 240, 250, 260, 270, 280 ), IGOTO           MAN  860
C                                                                       MAN  870
C                                                                       MAN  880
 220  NCOLS = NMLOLX                                                    MAN  890
      GO TO 500                                                         MAN  900
C                                                                       MAN  910
C     SOMETHING ON THE ANGLE GRID                                       MAN  920
C                                                                       MAN  930
 230  NCOLS = (ANGMAX-ANGMIN)/ANGSTP + 1.5                              MAN  940
      IF ( 8*LENOB/ISIZE .EQ. NROWS ) KLASS = 5                         MAN  950
      GO TO 500                                                         MAN  960
C                                                                       MAN  970
C     HEADER                                                            MAN  980
C                                                                       MAN  990
 240  DO 244 I = 1, 65                                                  MAN 1000
      IF ( HEADER(I) .NE. BLANK ) GO TO 245                             MAN 1010
 244  CONTINUE                                                          MAN 1020
      I = 65                                                            MAN 1030
 245  CALL KEEP ( HEADER(I), 9, 5, 66-I, 1, MEMBER, MYKEEP, IER )       MAN 1040
      NROWS = 66-I                                                      MAN 1050
      GO TO 265                                                         MAN 1060
C                                                                       MAN 1070
C     REACTION                                                          MAN 1080
C                                                                       MAN 1090
 250  DO 254 I = 1, 45                                                  MAN 1100
      IF ( REACT(46-I) .NE. BLANK ) GO TO 255                           MAN 1110
 254  CONTINUE                                                          MAN 1120
      I = 45                                                            MAN 1130
 255  CALL KEEP ( REACT, 9, 5, 46-I, 1, MEMBER, MYKEEP, IER )           MAN 1140
      NROWS = 46-I                                                      MAN 1150
      GO TO 265                                                         MAN 1160
C                                                                       MAN 1170
C     ELAB                                                              MAN 1180
C                                                                       MAN 1190
 260  CALL KEEP ( ELAB, 2, 0, 1, 1, MEMBER, MYKEEP, IER )               MAN 1200
      NROWS = 1                                                         MAN 1210
 265  NCOLS = 1                                                         MAN 1220
      GO TO 800                                                         MAN 1230
C                                                                       MAN 1240
C     ANGLEGRID                                                         MAN 1250
C                                                                       MAN 1260
 270  CALL KEEP ( ANGSTP, 2, 5, 3, 1, MEMBER, MYKEEP, IER )             MAN 1270
      NROWS = 3                                                         MAN 1280
      GO TO 265                                                         MAN 1290
C                                                                       MAN 1300
C     OBJECT IS A SQUARE MATRIX OR ARRAY                                MAN 1310
C                                                                       MAN 1320
 280  NCOLS = DSQRT( (8.*LENOB)/ISIZE + .010D0 )                        MAN 1330
      GO TO 500                                                         MAN 1340
C                                                                       MAN 1350
C     OUTPUT AN OBJECT IN THE ALLOCATOR                                 MAN 1360
C                                                                       MAN 1370
 500  IF ( IOB .EQ. 0 ) GO TO 910                                       MAN 1380
      LENOB = (8*LENOB)/ISIZE                                           MAN 1390
      IF ( NROWS .NE. 0 ) NCOLS = LENOB/NROWS                           MAN 1400
      IF ( NCOLS .NE. 0 ) NROWS = LENOB/NCOLS                           MAN 1410
      LENOB2 = NROWS*NCOLS                                              MAN 1420
      IF ( LENOB .EQ. LENOB2 ) GO TO 600                                MAN 1430
      PRINT 513, OBNAME, LENOB, NROWS,  NCOLS, LENOB2, KIND, KLASS      MAN 1440
 513  FORMAT ( '0**** WARNING: ', A8, ' HAS', I6,  ' ELEMENTS BUT NROWS,MAN 1460
     * NCOLS & OUTPUT LENGHT =', 3I6,  ' KIND, CLASS =', 2I3 )          MAN 1460
      NROWS = LENOB                                                     MAN 1490
      NCOLS = 1                                                         MAN 1500
      KLASS = 5                                                         MAN 1510
C                                                                       MAN 1520
 600  CALL KEEP ( ALLOC(LOCOB), KIND, KLASS, NROWS, NCOLS, MEMBER,  MYKEMAN 1530
     *EP, IER )                                                         MAN 1530
C                                                                       MAN 1550
 800  IF ( IER .NE. 0 ) GO TO 920                                       MAN 1560
      PRINT 803, OBNAME, MEMBER, KIND, KLASS, NROWS, NCOLS              MAN 1570
 803  FORMAT ( 1X, A8, ' HAS BEEN KEPT AS MEMBER ', A8,  5X, 'KIND =', IMAN 1580
     *2, 3X, 'KLASS =', I2,  3X, 'NROWS =', I6, 3X, 'NCOLS =', I6 )     MAN 1580
      RETURN                                                            MAN 1610
C                                                                       MAN 1620
C     ERROR MESSAGES                                                    MAN 1630
C                                                                       MAN 1640
 900  PRINT 903                                                         MAN 1650
 903  FORMAT ( '0**** KEEP MUST BE FOLLOWED BY TWO NAMES.' )            MAN 1660
      GO TO 980                                                         MAN 1670
C                                                                       MAN 1680
 910  PRINT 913, OBNAME                                                 MAN 1690
 913  FORMAT ( '0**** ', A8, ' IS NOT A DEFINED OBJECT.' )              MAN 1700
      RETURN                                                            MAN 1710
 920  PRINT 923, IER, OBNAME, MEMBER                                    MAN 1720
 923  FORMAT ( '0**** ERROR NUMBER ', Z8,  ' ENCOUNTERED WHILE KEEPING 'MAN 1730
     *, A8, ' AS ', A8 )                                                MAN 1730
      RETURN                                                            MAN 1750
C                                                                       MAN 1760
 980  PRINT 983                                                         MAN 1770
 983  FORMAT ( ' **** CONTINUING WITH NEXT INPUT CARD.' )               MAN 1780
      CALL NEWCD                                                        MAN 1790
      RETURN                                                            MAN 1800
C                                                                       MAN 1810
      END  
      
      SUBROUTINE IXSORT(IX,X,N)
	IMPLICIT REAL*8 (A-H,O-Z)
	INTEGER*4 LV(16),UV(16),N,P,LP,UP,IY
	DIMENSION X(1),IX(1)
	DO 5 I=1,N
	IX(I)=I
 5      CONTINUE
	LV(1)=1
	UV(1)=N
	P=1
10      IF(P.LT.1)RETURN
20      IF((UV(P)-LV(P)).GE.1)GO TO 30
	P=P-1
	GO TO 10
30      LP=LV(P)-1
	UP=UV(P)
	Y=X(UP)
	IY=IX(UP)
40      IF((UP-LP).LT.2)GO TO 70
	LP=LP+1
	IF(X(LP).LE.Y)GO TO 40
	X(UP)=X(LP)
	IX(UP)=IX(LP)
50       IF((UP-LP).LT.2)GO TO 60
	UP=UP-1
	IF(X(UP).GE.Y)GO TO 50
	X(LP)=X(UP)
	IX(LP)=IX(UP)
	GO TO 40
60      UP=UP-1
70      X(UP)=Y
	IX(UP)=IY
	IF((UP-LV(P)).GE.(UV(P)-UP))GO TO 80
	LV(P+1)=LV(P)
	UV(P+1)=UP-1
	LV(P)=UP+1
	GO TO 90
80      LV(P+1)=UP+1
	UV(P+1)=UV(P)
	UV(P)=UP-1
90      P=P+1
	GO TO 20
	END
  	
      SUBROUTINE AITKEN(NDEGRE,DELTA,EPSLON,NIN,XIN,FIN,NOUT,
     1 XOUT,FOUT,NFAIL,WORST,WORK)
	IMPLICIT REAL*8 (A-H,O-Z)
	DIMENSION XIN(NIN),FIN(NIN),XOUT(NOUT),FOUT(NOUT),WORK(2,1)
	LOGICAL DELTSW,UPSW
	DELTSW=DELTA.GT.0
	NI=1
	NFAIL=0
	WORST=0
	XMID=XIN((NIN+1)/2)
	NDEGR=MIN0(NDEGRE,NIN-1)
	DO 799 NO=1,NOUT
	X=XOUT(NO)
	UPSW=.FALSE.
	D=DABS(X-XIN(NI))
120     IF(NI.EQ.NIN)GO TO 150
	D2=DABS(X-XIN(NI+1))
	IF(D2.GE.D)GO TO 150
	UPSW=.TRUE.
	NI=NI+1
	D=D2
	GO TO 120
150     IF(UPSW)GO TO 200
160     IF(NI.EQ.1)GO TO 200
	D2=DABS(X-XIN(NI-1))
	IF(D2.GE.D)GO TO 200
	NI=NI-1
	D=D2
	GO TO 160
200     NL=NI-1
	NU=NI+1
	F=FIN(NI)
	WORK(1,1)=X-XIN(NI)
	UPSW=WORK(1,1).LT.0
	WORK(2,1)=F
	ERROR=0
	IF(NDEGR.LE.0)GO TO 700
	DO 599 ND=1,NDEGR
	FLAST=F
	IF(ND.EQ.2)UPSW=X.LT.XMID
	IF(UPSW)GO TO 350
320      I=NU
	NU=NU+1
	UPSW=.TRUE.
	IF(I.LE.NIN)GO TO 400
350     I=NL
	NL=NL-1
	UPSW=.FALSE.
	IF(I.LT.1)GO TO 320
400     DEL=X-XIN(I)
	F=FIN(I)
	DO 489 J=1,ND
	 F=(WORK(1,J)*F-DEL*WORK(2,J))/(WORK(1,J)-DEL)
489     CONTINUE
	IF(.NOT.DELTSW)GO TO 550
	ERROR=DABS(F)
	IF(ERROR.LE.EPSLON)GO TO 700
	ERROR=DABS((F-FLAST)/F)
	IF(ERROR.LE.DELTA)GO TO 700
550     WORK(1,ND+1)=DEL
	WORK(2,ND+1)=F
599     CONTINUE
	IF(DELTSW)NFAIL=NFAIL+1
700     FOUT(NO)=F
	WORST=DMAX1(WORST,ERROR)
799     CONTINUE
	RETURN
	END
