      CHARACTER*8 FUNCTION DATE ( DUM )
      INTEGER*4 JMO,JDAY,JYEAR
      CHARACTER*10 KMO(12)
      DATA KMO/'January','February','March','April',
     & 'May','June','July','August',
     & 'September','October','November','December'/
C                                                                       
C     RETURNS DATE IN FORM MM/DD/YY. 
C                                                                       
      CALL IDATE ( JMO, JDAY, JYEAR )                               
C      WRITE (6,103) JDAY,KMO(JMO),JYEAR                          
C 103  FORMAT (/,' Today is: ',I2,2X,A10,',  19',I2,/ ) 
      RETURN                                                            
      END
      
      CHARACTER*24 FUNCTION FILMAK ( SUBDIR, FIL )                      
C                                                                       
C      BUILDS A COMPLETE VAX/VMS FILENAME.                              
C                                                                       
C      SUBDIR = CHARACTER*8 SUBDIRECTORY (UNDER USER'S DEFAULT          
C         DIRECTORY).                                                   
C     FIL = CHARACTER*8 FILENAME (NOT INCLUDING TYPE .SPK).             
C                                                                       
      CHARACTER*8 SUBDIR, FIL                                           
C                                                                       
      FILMAK = ' '                                                      
      IF ( SUBDIR .NE. ' ' ) FILMAK = SUBDIR             
      FILMAK = FILMAK(1:11) // FIL // '.SPK'                            
C                                                                       
C     SQUEEZE OUT BLANKS.                                               
C                                                                       
      N = 0                                                             
      DO 19 I = 1, 24                                                   
      IF ( FILMAK(I:I) .EQ. ' ' ) GO TO 19                              
      N = N + 1                                                         
      FILMAK(N:N) = FILMAK(I:I)                                         
 19   CONTINUE                                                          
      FILMAK(N+1:24) = ' '                                              
      RETURN                                                            
      END
      
      SUBROUTINE KEEP (ARRAY,KIND,KLAS,NROW,NCOL,MEMBER,DDNAME,IER)
C                                                                       
C      KEEPS A "SPEAKEASY" OBJECT.  VAX/VMS VERSION.                    
C                                                                       
C     ARGUMENTS:                                                        
C                                                                       
C     ARRAY = ARRAY TO BE WRITTEN (ANY TYPE OR LENGTH).                 
C     KIND = VARIABLE TYPE:                                             
C         1 = INTEGER                                                   
C         2 OR 3 = REAL*8                                               
C         4 = COMPLEX*16 ( 2 REAL*8 NUMBERS)                            
C         5 = REAL*4                                                    
C         6 = CHARACTER*8                                               
C         7 = INTEGER*2                                                 
C         8 = INTEGER*1 OR LOGICAL*1                                    
C         9 = CHARACTER*1                                               
C         ANYTHING ELSE = REAL*8                                        
C     KLAS = AN INTEGER, WRITTEN BUT IGNORED.                           
C     NROW = ROW LENGTH (SECOND OR ONLY DIMENSION).                     
C     NCOL = COLUMN LENGTH (FIRST, MOST RAPDLY VARYING DIMENSION).      
C     MEMBER = CHARACTER*8 FILE NAME (TYPE IS .SPK).                    
C     DDNAME = SUBDIRECTORY NAME (UNDER USER'S DEFAULT DIRECTORY).      
C     IER = RETURNED ERROR FLAG:  0 = OK, OTHERWISE IT IS THE FORTRAN   
C         ERROR NUMBER, LISTED IN TABLE B-4 OF THE "VAX-11 FORTRAN      
C         IV-PLUS USER'S GUIDE".                                        
C                                                                       
C          THE OUTPUT FILE CONTAINS TWO RECORDS.  THE FIRST BLOCK HAS   
C     THE MEMBER NAME (REDUNDANT), KIND, CLAS, NROW, NCOL, THE NUMBER OF
C     BYTES WRITTEN, AND THE DATE AND TIME.  THE SECOND RECORD CONTAINS 
C     THE OBJECT ITSELF.  THE FILE IS WRITTEN USING STANDARD UNFORMATTED
C     WRITE STATEMENTS ON LOGICAL UNIT 4.                               
C                                                                       
      LOGICAL*1 ARRAY(1)                                                
      CHARACTER*8 MEMBER, DDNAME                                        
C                                                                       
      INTEGER BYTES(9)                                                  
      DATA BYTES / 4, 8, 8, 16, 4, 8, 2, 1, 1 /                         
      CHARACTER*8 DAT, TIM, DATE                                        
      CHARACTER*24 FILNAM, FILMAK                                       
C                                                                       
      IER = 0                                                           
C                                                                       
C     COMPUTE THE LENGTH OF THE ARRAY IN BYTES.                         
C                                                                       
      IF ( KIND .GT. 0 .AND. KIND .LT. 10 ) THEN                        
      NBYTES = BYTES(KIND)                                              
      ELSE                                                              
      NBYTES = 8                                                        
      END IF                                                            
      NBYTES = NBYTES*MAX0(NROW,1)*MAX0(NCOL,1)                         
C                                                                       
C     CONSTRUCT THE FILENAME, WITH BLANKS SQUEEZED OUT.                 
C                                                                       
      FILNAM = FILMAK( DDNAME, MEMBER )                                 
C                                                                       
C     OPEN THE FILE.                                                    
C                                                                       
      OPEN (UNIT=4,NAME=FILNAM,TYPE='NEW',FORM='UNFORMATTED',ERR=900)
C                                                                       
C     WRITE THE ID RECORD.                                              
C                                                                       
      DAT = DATE( DAT )                                                 
      CALL TIMODA( TIM )                                                
      WRITE (4,ERR=900) MEMBER,KIND,KLAS,NROW,NCOL,NBYTES,DAT,TIM                                                              
C                                                                       
C     WRITE THE ARRAY.  CHARACTER TYPES REQUIRE A DIFFERENT             
C     SUBROUTINE BECAUSE THE ARGUMENT IS PASSED BY DESCRIPTOR.          
C                                                                       
      IF ( KIND .EQ. 6 .OR. KIND .EQ. 9 ) THEN                          
      CALL KEEPCH ( ARRAY, NBYTES, &900 )                               
      ELSE                                                              
      CALL KEEPNM ( ARRAY, NBYTES, &900 )                               
      ENDIF                                                             
C                                                                       
C     CLOSE THE FILE.                                                   
C                                                                       
      CLOSE ( UNIT=4, DISP='SAVE', ERR=900 )                            
      RETURN                                                            
C                                                                       
C     ERROR.  RETURN THE ERROR NUMBER IN IER, AND PRINT THE ERROR MESSAG
C     SEE PAGE 6-27 OF THE "VAX-11 COMMON RUN-TIME PROCEDURE LIBRARY    
C     REFERENCE MANUAL".                                                
C                                                                       
C 900  CALL ERRSNS ( IER, IRMSTS, IRMSTV, ICOND )                        
  900 RETURN                                                            
      END                                                               
C                                                                       
C     THESE SIMPLE SUBROUTINES SPEED UP I/O PROCESSING.                 
C                                                                       
      SUBROUTINE KEEPCH ( ARRAY, N, * )                                 
      CHARACTER*1 ARRAY(N)                                              
      WRITE ( 4, ERR=910 ) ARRAY                                        
      RETURN                                                            
 910  RETURN 1                                                          
      END                                                               
C                                                                       
      SUBROUTINE KEEPNM ( ARRAY, N, * )                                 
      LOGICAL*1 ARRAY(N)                                                
      WRITE ( 4, ERR=920 ) ARRAY                                        
      RETURN                                                            
 920  RETURN 1                                                          
      END                                                               
      SUBROUTINE KEPT ( ARRAY, KIND, KLAS, NROW, NCOL, MEMBER,  DDNAME, 
     *IER, IFLG )                                                       
C                                                                       
C     RETRIEVES A KEPT "SPEAKEASY" OBJECT.  VAX/VMS VERSION.            
C                                                                       
C     THE ARGUMENTS ARE THE SAME AS SUBROUTINE KEEP EXCEPT:             
C                                                                       
C     IFLG = FLAG (INPUT):                                              
C        = 0 TO READ ONLY THE ID RECORD.                                
C        = 1 TO READ THE WHOLE FILE.                                    
C                                                                       
C     ALTERNATE ENTRY POINTS:                                           
C                                                                       
C     CALL KEPTCN ( ARRAY, IER, LEN )                                   
C                                                                       
C        TO CONTINUE READING THE SAME KEPT OBJECT.                      
C        A KEPTCN CALL NORMALLY FOLLOWS A KEPT CALL WITH                
C        IFLG=0.  LEN IS THE NUMBER OF BYTES IN THE RECEIVING ARRAY.    
C                                                                       
C     CALL KEPTCL                                                       
C                                                                       
C        TO CLOSE THE MOST RECENTLY OPENED KEEP FILE.                   
C        KEPTCL SHOULD BE CALLED IF YOU CALL KEPT WITH IFLG=0           
C        AND THEN DECIDE NOT TO CALL KEPTCN.                            
C                                                                       
C          NOTE:  THE RETURN STATUS IER IS ALWAYS THE VAX/VMS FORTRAN   
C     ERROR NUMBER.  THESE ARE NOT THE SAME AS THE IBM ERROR NUMBERS    
C     EXPECTED BY THE PTOLEMY SUBROUTINE GETIT.  HOWEVER, THIS DOESN'T  
C     MATTER BECAUSE THE APPROPRIATE ERROR MESSAGE IS ALWAYS PRINTED    
C     ANYWAY.                                                           
C                                                                       
      LOGICAL*1 ARRAY(1)                                                
      CHARACTER*8 MEMBER, DDNAME, OLDMEM                                
C                                                                       
      CHARACTER*8 DAT, TIM                                              
      CHARACTER*24 FILNAM, FILMAK                                       
C                                                                       
      IER = 0                                                           
C                                                                       
C     CONSTRUCT THE FILENAME, AND OPEN THE FILE.                        
C                                                                       
      FILNAM = FILMAK( DDNAME, MEMBER )                                 
      OPEN (UNIT=4,NAME=FILNAM,TYPE='OLD',FORM='UNFORMATTED',READONLY, 
     * ERR=900 )                                                    
C                                                                       
C     READ THE ID RECORD, AND PRINT INFO.                               
C                                                                       
      READ ( 4, ERR=900 ) OLDMEM,KIND,KLAS,NROW,NCOL,NBYTES,DAT,TIM                                                               
      WRITE(6,1000) OLDMEM, DAT, TIM                                      
 1000 FORMAT ( ' ORIGINAL MEMBERNAME = ', A8, '   WRITTTEN ON ',  A8, ' 
     *AT ', A8 )                                                        
C                                                                       
C     QUIT IF REQUESTED.                                                
C                                                                       
      IF ( IFLG .EQ. 0 ) RETURN                                         
      GO TO 100                                                         
C                                                                       
C     CONTINUE READING                                                  
C                                                                       
      ENTRY KEPTCN ( ARRAY, IER, LEN )                                  
      NBYTES = MIN0 ( LEN, NBYTES )                                     
C                                                                       
 100  IF ( KIND .EQ. 6 .OR. KIND .EQ. 9 ) THEN                          
      CALL KEPTCH ( ARRAY, NBYTES, &900 )                               
      ELSE                                                              
      CALL KEPTNM ( ARRAY, NBYTES, &900 )                               
      END IF                                                            
C                                                                       
C     CLOSE THE FILE.                                                   
C                                                                       
      ENTRY KEPTCL                                                      
C                                                                       
      CLOSE ( UNIT=4 )                                                  
      RETURN                                                            
C                                                                       
C     ERROR.  SIGNAL AND RETURN ERROR NUMBER.                           
C                                                                       
C 900  CALL ERRSNS ( IER, IRMSTS, IRMSTV, ICOND )                        
 900  RETURN                                                            
      END                                                               
C                                                                       
C     THESE SIMPLE SUBROUTINES SPEED UP I/O PROCESSING.                 
C                                                                       
      SUBROUTINE KEPTCH ( ARRAY, N, * )                                 
      CHARACTER*1 ARRAY(N)                                              
      WRITE ( 4, ERR=910 ) ARRAY                                        
      RETURN                                                            
 910  RETURN 1                                                          
      END                                                               
C                                                                       
      SUBROUTINE KEPTNM ( ARRAY, N, * )                                 
      LOGICAL*1 ARRAY(N)                                                
      WRITE ( 4, ERR=920 ) ARRAY                                        
      RETURN                                                            
 920  RETURN 1                                                          
      END
      
      FUNCTION LENHF ( IDUM )                                           
C                                                                       
C     RETURNS THE ESTIMATED LENGTH OF THE SAVEHS FILE (IN BYTES)        
C                                                                       
C     FOR BEST RESULTS, THE FOLLOWING KEYWORDS SHOULD BE SPECIFIED      
C     BEFORE SAVEHS:  VPOLYORD, NPDIF, NPSUM, LMAX, LMIN, LSTEP,        
C     REACTION, AND MULTIPASS.                                          
C                                                                       
      IMPLICIT REAL*8 ( A-H, O-Z )                                      
      COMMON /CNSTNT/ PI, RT4PI, PIINV, RADIAN, DEGREE, HBARC, AMUMEV, 
     & AFINE, BIGEST, SMLEST, BIGNUM, SMLNUM, BIGLOG                      
      INTEGER PARITS, PARIPT, PARITY                                    
      COMMON /INTGER/ L, LMAX, LMIN, LOOKST, LX, MAPSUM, MAPDIF, MAXITR,
     * NAITKN, NBACK, NCOSIN, NODES, NPDIF, NPHIAD, NPPHI, NPSUM, IPRINT
     *, ISIZE, IZS(5), IZP, IZT, LSTEP, LBACK, MAXLEX, LMAXAD, MAXFUN, I
     * REINI, MODEFT, NUMRAN, NVPOLY, NPCOUL, MXCOUL, LMINSB, PARITS(5), 
     * PARIPT(2), PARITY, IPARM1, IPARM2, IPARM3, IPARM4, IPARM5, 
     & NBLKSZ, MAPPHI, NFIROF, LEBACK                                           
      COMMON /JBLOCK/ J, JS(5), JP, JSP, JST, JPARM1, JPARM2, JPARM3    
      INTEGER PROBLM, R0TYPE, CONVRG                                    
      COMMON /SWITCH/ IASYMP, ICHECK, IECHO, IELAST, IFIT, IVRTEX, IRLWA
     *V, ITSO, LINEAR, NUCONL, NEXT, IFITER, IEPOW, ISAVMX, ISAVB, LABAN
     *G, PROBLM, MASTYP, R0TYPE, IBSPAS, ISW1, ISW2, ISW3, ISCRFL, NOBFA
     *C, CONVRG, IEXTYP, IBRNSB, MEORD, KFRMTP, IWRTWV, LORNTZ, IRELPT, 
     * ISAVSM                                                            
      LOGICAL*1 WASSET                                                  
      COMMON /INTRNL/ UNDEF, NOTDEF, ICHANB, ICHANW, ICNTT, EBNDS(2), 
     & IDONE, ISTRIP, IHSAVE, NEXTSV, IPOT, IWFN, LIMOST, IEXCIT, 
     & R0MASS, WASSET(40), RATMAS, LSPECS(4), NODESP(4), LSPCPT(2), 
     & NODEPT(2),ICD3I
C     NBYTE8 AND NBYTE4 ARE THE NUMBER OF BYTES IN REAL*8 NUMBERS AND   
C     INTEGERS RESPECTIVELY.                                            
C                                                                       
      DATA NBYTE8, NBYTE4 / 8, 4 /                                      
C                                                                       
C     THESE ARE THE LENGTHS OF THE DATA-ENTERING COMMONS.  THEY         
C     SHOULD AGREE WITH THE CORRESPONDING VALUES IN  CONTRL,            
C     BUT IT DOESN'T MATTER MUCH IF THEY GET A LITTLE BEHIND.           
C                                                                       
      DATA NUMFLT/151/, NUMINT/51/, NUMJ/12/, NUMSW/23/                 
C                                                                       
C                                                                       
C     RECORD 1 HAS THE HEADER ETC.                                      
C                                                                       
      LENHF = 152 + NBYTE4                                              
C                                                                       
C     EACH OF RECORDS 2-4 HAS THE DATA-ENTERING COMMONS AND SOME        
C     OTHER STUFF.                                                      
C                                                                       
      LENHF = LENHF + NBYTE8*(NUMFLT+7) + NBYTE4*( NUMINT + NUMJ + NUMS
     *W + 6 )                                                           
C                                                                       
C     RECORDS 5 AND 6 ARE WRITTEN BY  GRDSET,  JUST AFTER STATEMENT 950.
C                                                                       
      LENHF = LENHF + NBYTE4*8 + NBYTE8*14                              
      LENHF = LENHF + NBYTE8*( 3*NVPOLY+3 + NPSUM + 3*NPDIF*NPSUM )     
C                                                                       
C     RECORDS 7 AND 8 ARE WRITTEN IN  ANGSET  JUST ATER STATEMENT 1309. 
C     IF LMAX OR LMIN IS UNDEFINED (AS USUAL), WE MUST GUESS THE NUMBER 
C     OF L'S TO BE CALCULATED.  WE USE EXAMPLE 3.                       
C                                                                       
      NL = 10                                                           
      IF ( LMAX .NE. NOTDEF .AND. LMIN .NE. NOTDEF) NL=(LMAX-LMIN+
     & LSTEP)/LSTEP                                                      
      LENHF = LENHF + NBYTE4 + NBYTE4*NL                                
C                                                                       
C     THE REST OF THE RECORDS ARE WRITTEN IN  INELDC  AFTER STATEMENT   
C     549.  THERE IS ONE RECORD FOR EACH (LI,DIF), PLUS ONE.            
C     EACH RECORD CONTAINS AN INTEGER IDENTIFIER, PLUS ONE REAL*8       
C     NUMBER FOR EACH (SUM,LX,LO-LI).  TO CALCULATE THE NUMBER OF LX'S, 
C     THE LOWEST POSSIBLE VALUES OF TRANSFERRED J'S ARE ASSUMED.        
C     IF ANY PARITIES ARE UNKNOWN, NO PARITY CHANGE IS ASSUMED.         
C                                                                       
      JPT = IABS( JS(2) - JS(3) )                                       
      JTT = IABS( JS(1) - JS(4) )                                       
      IPA = ( 1 - PARITS(1)*PARITS(2)*PARITS(3)*PARITS(4) )/2           
      LXF = IABS( JPT - JTT )/2                                         
      LXL = ( JPT + JTT )/2                                             
      N = ( (LXL+LXF+1)*(LXL-LXF+1) + MOD( LXF+IPA+1, 2 ) )/2           
      LENHF = LENHF + ( NL*NPDIF + 1 )*(NBYTE4 + NBYTE8*N*NPSUM )       
C                                                                       
C     IF "MULTIPASS" HAS BEEN SPECIFIED, THE ALLOCATION IS DOUBLED.     
C                                                                       
      IF ( IBSPAS .NE. 0 ) LENHF = 2*LENHF                              
C                                                                       
      RETURN                                                            
      END
      
      SUBROUTINE TIMODA ( THETIM )                                      
C                                                                       
C     RETURNS TIME IN FORM HH:MM:SS.  VAX/VMS VERSION.                  
C                                                                       
C     1/21/80 - RPG                                                     
C                                                                       
      CHARACTER*8 THETIM                                                
      CALL TIME(THETIM)                                     
      RETURN                                                            
      END
      
      SUBROUTINE TOCHAR ( BYTES, CHARS, N )                             
C                                                                       
C     TOCHAR PUTS N BYTES IN CHARACTER STRING, FROMCH DOES OPPOSITE.    
C                                                                       
C     2/25/80 - RPG                                                     
C                                                                       
      LOGICAL*1 BYTES(N)                                                
      CHARACTER*1 CHARS(N)                                              
C                                                                       
      DO 9 I = 1, N                                                     
      CHARS(I) = CHAR(BYTES(I))                                         
 9    CONTINUE                                                          
      RETURN                                                            
C                                                                       
      ENTRY FROMCH ( BYTES, CHARS, N )                                  
C                                                                       
      DO 19 I = 1, N                                                    
      BYTES(I) = ICHAR(CHARS(I))                                        
 19   CONTINUE                                                          
      RETURN                                                            
      END
      
      SUBROUTINE WRITHS ( N, LI, A, * )                                 
C                                                                       
C     WRITHS, READHS:  WRITE & READ H'S AS WHOLE ARRAYS FOR FAST I/O    
C                                                                       
C     2/29/80 - RPG                                                     
C                                                                       
      REAL*8 A(N)                                                       
CDC      ALLOCLEVEL A                                                   
C                                                                       
      WRITE ( 1, ERR=100 ) LI, A                                        
      RETURN                                                            
C                                                                       
      ENTRY READHS ( N, LI, A, * )                                      
C                                                                       
      READ ( 1, ERR=100, END=100 ) LI, A                                
      RETURN                                                            
C                                                                       
 100  RETURN 1                                                          
      END
      
      SUBROUTINE WRITSC ( N, A, B, C, D, * )                            
C                                                                       
C     WRITES AND READS SCRATCH FILE USING WHOLE ARRAYS FOR FAST I/O     
C                                                                       
C     2/29/80 - RPG                                                     
C                                                                       
      REAL*4 A(N), B(N), C(N), D(N)                                     
CDC      ALLOCLEVEL  A, B, C, D                                         
C                                                                       
      WRITE ( 2, ERR=100 ) A, B, C, D                                   
      RETURN                                                            
C                                                                       
      ENTRY READSC ( N, A, B, C, D, * )                                 
C                                                                       
      READ ( 2, ERR=100, END=100 ) A, B, C, D                           
      RETURN                                                            
C                                                                       
 100  RETURN                                                            
      END                                                               
