      PROGRAM XSAVE                                                                                                                 
C     PROGRAM XSAVE (OLD,        ADD1,        ADD2, ...,      ADD80,            B2                                                  
C    1               NEW,       INPUT,      OUTPUT,                     )       B2                                                  
C    2         TAPE1=OLD, TAPE11=ADD1, TAPE12=ADD2,...,TAPE90=ADD80,            B2                                                  
C    3        TAPE91=NEW, TAPE5=INPUT,TAPE6=OUTPUT)                             B2                                                  
C     -----------------------------------------------------------------         B2                                                  
C                                                                               B2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       B2                                                  
C     APR 08/00 - S.KHARIN  (ADD AN OPTION FOR ADDING UP TO 80 SETS.            B2                                                  
C                            ALWAYS CONVERT THE FIELD NAME TO UPPER CASE.)      B2                                                  
C     JAN 29/98 - D.LIU     (OPTIONALLY MAKE SUPERLABEL AND THE FIELD                                                               
C                            NAME UPPER/LOWER CASE)                                                                                 
C     JUL 08/97 - D.LIU     (READ AN OPTIONAL INPUT CARD AS NEW FIELD                                                               
C                            NAME)                                                                                                  
C     FEB 21/92 - E.CHAN    (TREAT SUPERLABELS AS ASCII INSTEAD OF AS                                                               
C                            HOLLERITHS)                                                                                            
C     JAN 29/92 - E.CHAN    (CONVERT HOLLERITH LITERALS TO ASCII AND                                                                
C                            REPLACE BUFFERED I/O)                                                                                  
C     MAR 06/89 - F.MAJAESS (READ THE SUPERLABEL FROM COLUMNS 15-74)                                                                
C     DEC 06/83 - B.DUGAS.                                                                                                          
C     OCT 07/80 - J.D.HENDERSON                                                                                                     
C                                                                               B2                                                  
CXSAVE   - ADDS UP TO 80 OR DELETES 1 SET TO/FROM A SUPERLABELED FILE. 81  1 C  B1                                                  
C                                                                               B3                                                  
CAUTHOR  - J.D.HENDERSON                                                        B3                                                  
C                                                                               B3                                                  
CPURPOSE - ADDS UP TO 80 OR DELETES 1 SET TO/FROM A SUPERLABELED FILE.          B3                                                  
C          NOTE - IF THE SUPERLABEL TO BE ADDED ALREADY EXISTS IN THE OLD       B3                                                  
C                 FILE, THAT SET IS DELETED BEFORE THE NEW ONE IS ADDED.        B3                                                  
C                                                                               B3                                                  
CINPUT FILES...                                                                 B3                                                  
C                                                                               B3                                                  
C      OLD     = FILE OF SUPERLABELED SETS (CAN BE EMPTY).                      B3                                                  
C      ADD1,...= FILES CONTAINING NEW SETS TO BE ADDED OR REPLACED.             B3                                                  
C                                                                               B3                                                  
COUTPUT FILE...                                                                 B3                                                  
C                                                                               B3                                                  
C      NEW     = COPY OF OLD WITH NEW SETS ADDED OR REPLACED.                   B3                                                  
C                                                                                                                                   
CINPUT PARAMETER...                                                                                                                 
C                                                                               B5                                                  
C      SPRLBL = 60 CHARACTER SUPERLABEL FOR NEW SET TO BE ADDED/DELETED.        B5                                                  
C               TO DELETE A SET: "..DELETE" MUST FIRST BE SPECIFIED IN COLUMNS  B5                                                  
C                                11 TO 18 FOLLOWED BY THE SUPERLABEL, (SUBJECT  B5                                                  
C                                TO THE RESTICTIONS SPECIFIED BELOW), ON A      B5                                                  
C                                SECOND CARD.                                   B5                                                  
C               TO  ADD   A SET: THE SUPERLABEL MUST BE READ FROM COLUMNS 15    B5                                                  
C                                TO 74 AND IT MUST BE PRECEEDED BY BLANK        B5                                                  
C                                CHARACTERS AT COLUMNS 11, 13 AND 14. THE       B5                                                  
C                                THE CHARACTER AT COLUMN 12 MAY BE USED TO      B5                                                  
C                                REQUEST THAT THE SUPERLABEL BE CONVERTED INTO  B5                                                  
C                                UPPER OR LOWER CASE ('U', 'u', 'L', 'l' ARE    B5                                                  
C                                LEGITIMATE VALUES FOR THIS COLUMN AND ALL      B5                                                  
C                                OTHERS WILL BE IGNORED). ALSO THE SUPERLABEL   B5                                                  
C                                MUST CONTAIN AT LEAST A NON-BLANK CHARACTER    B5                                                  
C                                NOT INCLUDING THE ONE AT COLUMN 12.            B5                                                  
C        NAME = (OPTIONAL SECOND CARD WHEN ADDING ONE SET,                      B5                                                  
C                REQUIRED CARD WHEN ADDING MORE THAN ONE SET)                   B5                                                  
C               NEW NAME OF THE FIELD TO BE ADDED.                              B5                                                  
C               IT MAY BE EMPTY IN WHICH CASE THE FIELD NAME IN THE ADDED       B5                                                  
C               SET IS NOT CHANGED.                                             B5                                                  
C                                                                               B5                                                  
C  **NOTE: WHEN ADDING MORE THAT ONE SET, THE NUMBER OF INPUT CARDS MUST BE     B5                                                  
C          EXACTLY TWICE THE NUMBER OF SETS TO BE ADDED. OTHERWISE, THE PROGRAM B5                                                  
C          WILL ABORT.                                                          B5                                                  
C                                                                               B5                                                  
CEXAMPLE OF INPUT CARD...                                                       B5                                                  
C                                                                               B5                                                  
C*XSAVE       OBSERVED TEMPERATURE CROSS-SECTION (JAN)                          B5                                                  
C                                                                               B5                                                  
C*XSAVE    u  observed temperature cross-section (jan)                          B5                                                  
C*         TEMP                                                                 B5                                                  
C----------------------------------------------------------------------------                                                       
C                                                                                                                                   
C     * SPRLBL = TABLE OF SUPERLABES READ FROM THE INPUT CARD                                                                       
C     * SNAME  = TABLE OF FIELD NAMES READ FROM THE INPUT CARD                                                                      
C     * NFU    = UNIT NUMBER TABLE                                                                                                  
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      CHARACTER*64 SPRLBL(80)                                                                                                       
      CHARACTER*4 SNAME(80)                                                                                                         
      INTEGER IBL(28)                                                                                                               
      CHARACTER SLABL*80,RLABL*64,NAME*4                                                                                            
      COMMON/ICOM/ IBUF(8),LABEL(65341)                                                                                             
      EQUIVALENCE (RLABL,LABEL),(IBL(9),SLABL),(NAME,IBUF(3))                                                                       
C                                                                                                                                   
      LOGICAL COPY,DELETE,RENAME                                                                                                    
      COMMON/MACHTYP/ MACHINE,INTSIZE                                                                                               
C                                                                                                                                   
      DATA LA/65341/                                                                                                                
C     DATA (IBL(I),I=1,8)/4HLABL,0,4HLABL,0,10,1,0,1/                                                                               
C--------------------------------------------------------------------                                                               
C     CALL SETLAB(IBL,NC4TO8("LABL"),0,NC4TO8("LABL"),0,10,1,0,1)                                                                   
      NF=84                                                                                                                         
      CALL JCLPNT(NF,1,                                                                                                             
     1         11,12,13,14,15,16,17,18,19,20,                                                                                       
     2         21,22,23,24,25,26,27,28,29,30,                                                                                       
     3         31,32,33,34,35,36,37,38,39,40,                                                                                       
     4         41,42,43,44,45,46,47,48,49,50,                                                                                       
     5         51,52,53,54,55,56,57,58,59,60,                                                                                       
     6         61,62,63,64,65,66,67,68,69,70,                                                                                       
     7         71,72,73,74,75,76,77,78,79,80,                                                                                       
     8         81,82,83,84,85,86,87,88,89,90,91,5,6)                                                                                
      MAXLEN=LA+8                                                                                                                   
C                                                                                                                                   
C     * NFADD = THE NUMBER OF SETS TO ADD                                                                                           
C     * (MAY BE ZERO IF DELETING A SET)                                                                                             
C                                                                                                                                   
      NFADD=NF-4                                                                                                                    
      WRITE(6,6005) NFADD                                                                                                           
      IF (NFADD.LT.0) CALL                         XIT('XSAVE',-1)                                                                  
C                                                                                                                                   
C     * NFOUT = THE OUTPUT FILE NUMBER                                                                                              
C                                                                                                                                   
      NFOUT=NFADD+1                                                                                                                 
      REWIND 1                                                                                                                      
      DO I=1,NFOUT                                                                                                                  
         REWIND 10+I                                                                                                                
      ENDDO                                                                                                                         
      DO I=1,28                                                                                                                     
       IBL(I)=0                                                                                                                     
      ENDDO                                                                                                                         
      CALL SETLAB(IBL,NC4TO8("LABL"),0,NC4TO8("LABL"),0,10,1,0,1)                                                                   
C                                                                                                                                   
C     * READ 1ST INPUT CARD                                                                                                         
C                                                                                                                                   
      READ(5,5010,END=901) SPRLBL(1)                                                                                                
                                                                                                                                    
      IF( SPRLBL(1)(1:8) .EQ. '..DELETE' ) THEN                                                                                     
C                                                                                                                                   
C     * IF THE FIRST CARD IS '..DELETE', WE WANT TO DELETE A SET                                                                    
C     * WITH THE SUPERLABEL FROM THE SECOND CARD                                                                                    
C                                                                                                                                   
         IF (NFADD.GT.1) CALL                      XIT('XSAVE',-2)                                                                  
         NFADD=1                                                                                                                    
         DELETE=.TRUE.                                                                                                              
         READ(5,5010,END=902) SPRLBL(1)                                         B4                                                  
         IF( SPRLBL(1)(1:4) .NE. '    ' ) THEN                                                                                      
            WRITE(6,6040) SPRLBL(1)                                                                                                 
            CALL                                   XIT('XSAVE',-3)                                                                  
         ENDIF                                                                                                                      
      ELSE                                                                                                                          
C                                                                                                                                   
C     * OTHERWISE TRY TO READ A NEW FIELD NAME                                                                                      
C                                                                                                                                   
         IF (NFADD.LT.1) CALL                      XIT('XSAVE',-4)                                                                  
         DELETE=.FALSE.                                                                                                             
         SNAME(1)='    '                                                                                                            
         READ(5,5020,END=115) SNAME(1)                                          B4                                                  
         GOTO 120                                                                                                                   
 115     IF (NFADD.GT.1) CALL                      XIT('XSAVE',-5)                                                                  
 120     CONTINUE                                                                                                                   
C                                                                                                                                   
C     * READ ALL SUPERLABELS AND FIELD NAMES                                                                                        
C                                                                                                                                   
         IF (NFADD.GT.1) THEN                                                                                                       
            DO N=2,NFADD                                                                                                            
               READ(5,5010,END=903) SPRLBL(N)                                   B4                                                  
               READ(5,5020,END=904) SNAME(N)                                    B4                                                  
            ENDDO                                                                                                                   
C                                                                                                                                   
C     * ABORT IF THERE ARE MORE SUPERLABELS THAN SETS TO BE ADDED                                                                   
C                                                                                                                                   
            READ(5,5010,END=125) RLABL                                                                                              
            WRITE(6,6060)                                                                                                           
            CALL                                   XIT('XSAVE',-6)                                                                  
 125        CONTINUE                                                                                                                
         ENDIF                                                                                                                      
C                                                                                                                                   
C     * CHECK AND MODIFY THE SUPERLABELS, IF NEEDED                                                                                 
C                                                                                                                                   
         DO N=1,NFADD                                                                                                               
C                                                                                                                                   
C     * ABORT IF THE SUPERLABEL IS BLANK                                                                                            
C                                                                                                                                   
            IF(SPRLBL(N)(5:64).EQ.                                                                                                  
     1 '                                                            ')                                                              
     2           CALL                              XIT('XSAVE',-7)                                                                  
C                                                                                                                                   
C     * CHECK FOR BLANKS IN POSITIONS 1, 3 AND 4                                                                                    
C                                                                                                                                   
            IF (SPRLBL(N)(1:1).NE.' '.AND.SPRLBL(N)(3:4).NE.'  ')                                                                   
     1           CALL                              XIT('XSAVE',-8)                                                                  
C                                                                                                                                   
C     * IF SPRLBL(2:2) IS EITHER 'U'/'L', THE SUPERLABEL                                                                            
C     * WILL BE CONVERTED TO UPPER/LOWER CASE.                                                                                      
C     * THE FIELD NAME ALWAYS CONVERTED TO UPPER CASE.                                                                              
C                                                                                                                                   
            IF (SPRLBL(N)(2:2).EQ.'U'.OR.SPRLBL(N)(2:2).EQ.'u') THEN                                                                
               CALL LWRTUPR(SPRLBL(N),64)                                                                                           
            ELSEIF (SPRLBL(N)(2:2).EQ.'L'.OR.SPRLBL(N)(2:2).EQ.'l') THEN                                                            
               CALL UPRTLWR(SPRLBL(N),64)                                                                                           
            ENDIF                                                                                                                   
            CALL LWRTUPR(SNAME(N),4)                                                                                                
C                                                                                                                                   
C     * SET/RESET SPRLBL(2:2) TO A BLANK                                                                                            
C                                                                                                                                   
            SPRLBL(N)(2:2)=' '                                                                                                      
         ENDDO                                                                                                                      
      ENDIF                                                                                                                         
                                                                                                                                    
C                                                                                                                                   
C     * READ THE NEXT RECORD FROM FILE OLD.                                                                                         
C                                                                                                                                   
      COPY=.TRUE.                                                                                                                   
 130  CALL FBUFFIN(1,IBUF,MAXLEN,K,LEN)                                                                                             
      IF (K.EQ.0) THEN                                                                                                              
C                                                                                                                                   
C     * FILE OLD HAS NOW BEEN COPIED.                                                                                               
C                                                                                                                                   
         IF (DELETE) THEN                                                                                                           
C                                                                                                                                   
C       * EXIT HERE IF WE ARE JUST DELETING A SET.                                                                                  
C                                                                                                                                   
            WRITE(6,6030)                                                                                                           
            CALL                                   XIT('XSAVE',1)                                                                   
         ENDIF                                                                                                                      
C                                                                                                                                   
C       * GO AND ADD NEW SETS ALONG WITH ITS SUPERLABELS.                                                                           
C                                                                                                                                   
         GO TO 140                                                                                                                  
      ENDIF                                                                                                                         
      IF(IBUF(1).EQ.NC4TO8("LABL")) THEN                                                                                            
C                                                                                                                                   
C     * CHECK THE SUPERLABEL JUST READ.                                                                                             
C     * IF IT IS ONE OF THE SPRLBL(N) DO NOT COPY IT.                                                                               
C                                                                                                                                   
         COPY=.TRUE.                                                                                                                
         DO N=1,NFADD                                                                                                               
            IF( RLABL.EQ.SPRLBL(N)) THEN                                                                                            
               COPY=.FALSE.                                                                                                         
               WRITE(6,6035) RLABL                                                                                                  
               GOTO 135                                                                                                             
            ENDIF                                                                                                                   
         ENDDO                                                                                                                      
 135     CONTINUE                                                                                                                   
      ENDIF                                                                                                                         
      IF (COPY) THEN                                                                                                                
C                                                                                                                                   
C     * COPY THIS RECORD ONTO FILE NEW IF REQUESTED.                                                                                
C                                                                                                                                   
         CALL FBUFOUT(10+NFOUT,IBUF,LEN,K)                                                                                          
      ENDIF                                                                                                                         
      GO TO 130                                                                                                                     
C                                                                                                                                   
C     * NOW ADD THE SUPERLABEL AND THE NEW SET FROM FILES ADD1,...                                                                  
C     * STOP IF ANY OF THE FILES ADD1,..., IS EMPTY.                                                                                
C                                                                                                                                   
 140  CONTINUE                                                                                                                      
      SLABL(65:80)='                '                                                                                               
      DO N=1,NFADD                                                                                                                  
         WRITE(6,6040) SPRLBL(N)                                                                                                    
         IF (SNAME(N).NE.'    ') WRITE(6,6050) SNAME(N)                                                                             
         SLABL(1:64)=SPRLBL(N)                                                                                                      
         NREC=0                                                                                                                     
 145     CALL FBUFFIN(10+N,IBUF(1),MAXLEN,K,LEN)                                                                                    
         IF(K.EQ.0) THEN                                                                                                            
            IF(NREC.EQ.0) CALL                     XIT('XSAVE',-9)                                                                  
            WRITE(6,6040) SPRLBL(N)                                                                                                 
            IF (N.EQ.NFADD) THEN                                                                                                    
               CALL                                XIT('XSAVE',0)                                                                   
            ELSE                                                                                                                    
               GOTO 150                                                                                                             
            ENDIF                                                                                                                   
         ENDIF                                                                                                                      
         IF(NREC.EQ.0) CALL FBUFOUT(10+NFOUT,IBL,10*MACHINE+8,K)                                                                    
         IF (SNAME(N).NE.'    ') THEN                                                                                               
            NAME=SNAME(N)                                                                                                           
         ENDIF                                                                                                                      
         CALL FBUFOUT(10+NFOUT,IBUF,LEN,K)                                                                                          
         WRITE(6,6025) IBUF                                                                                                         
         NREC=NREC+1                                                                                                                
         GO TO 145                                                                                                                  
 150     CONTINUE                                                                                                                   
      ENDDO                                                                                                                         
C                                                                                                                                   
C     * E.O.F. ON INPUT.                                                                                                            
C                                                                                                                                   
 901  CALL                                         XIT('XSAVE',-10)                                                                 
 902  CALL                                         XIT('XSAVE',-11)                                                                 
                                                                                                                                    
 903  WRITE(6,6060)                                                                                                                 
      CALL                                         XIT('XSAVE',-12)                                                                 
 904  WRITE(6,6060)                                                                                                                 
      CALL                                         XIT('XSAVE',-13)                                                                 
C--------------------------------------------------------------------                                                               
 5010 FORMAT(10X,A64)                                                           B4                                                  
 5020 FORMAT(10X,1X,A4)                                                         B4                                                  
 6005 FORMAT('0 FOUND ',I5,' SET(S) ON THE COMMAND LINE TO ADD.')                                                                   
 6025 FORMAT(' ',A4,I10,1X,A4,I10,4I6)                                                                                              
 6030 FORMAT('0 SET DELETED')                                                                                                       
 6035 FORMAT('0  SKIP SET ',A64)                                                                                                    
 6040 FORMAT('0  XSAVE ON-',A64)                                                                                                    
 6050 FORMAT('0  FIELD NAME CHANGED TO ',A4)                                                                                        
 6060 FORMAT('0...THERE MUST BE EXACTLY 2 CARDS PER SET,',                                                                          
     1     ' WHEN ADDING MORE THAN 1 SET.')                                                                                         
      END                                                                                                                           
