      PROGRAM PSMLT                                                                                                                 
C     PROGRAM PSMLT (IN1,       IN2,       OUT,       OUTPUT,           )       C2                                                  
C    1         TAPE1=IN1, TAPE2=IN2, TAPE3=OUT, TAPE6=OUTPUT)                                                                       
C     -------------------------------------------------------                   C2                                                  
C                                                                               C2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       C2                                                  
C     SEP 21/95 - F.MAJAESS(INCREASE ARRAY DIMENSIONS)                          C2                                                  
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     MAY 13/83 - R.LAPRISE.                                                                                                        
C     JUL 21/81 - J.D.HENDERSON                                                                                                     
C     JUL 21/78 - TED SHEPHERD                                                                                                      
C                                                                               C2                                                  
CPSMLT   - MULTIPLIES A FILE OF REAL SETS BY A ONE-LEVEL REAL FILE      2  1    C1                                                  
C                                                                               C3                                                  
CAUTHOR  - J.D.HENDERSON                                                        C3                                                  
C                                                                               C3                                                  
CPURPOSE - MULTIPLIES A FILE OF REAL MULTI-LEVEL SETS (IN2) BY A FILE OF        C3                                                  
C          REAL ONE LEVEL FIELDS (IN1). EACH ONE LEVEL FIELD MULTIPLIES         C3                                                  
C          AN ENTIRE SET FROM THE MULTI-LEVEL FILE.                             C3                                                  
C          NOTE - BOTH INPUT FILES IN1 AND IN2 MUST BE REAL AND THERE           C3                                                  
C                 MUST BE ONE SET IN IN2 FOR EACH FIELD IN IN1.                 C3                                                  
C                                                                               C3                                                  
CINPUT FILES...                                                                 C3                                                  
C                                                                               C3                                                  
C      IN1 = FILE OF ONE LEVEL REAL FIELDS.                                     C3                                                  
C      IN2 = FILE OF MULTI-LEVEL REAL SETS.                                     C3                                                  
C                                                                               C3                                                  
COUTPUT FILE...                                                                 C3                                                  
C                                                                               C3                                                  
C      OUT = THE PRODUCT.                                                       C3                                                  
C-------------------------------------------------------------------------                                                          
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/BLANCK/F(65341),G(65341)                                                                                               
C                                                                                                                                   
      LOGICAL OK,SPEC                                                                                                               
      INTEGER LEV(100),JBUF(8)                                                                                                      
      COMMON/ICOM/IBUF(8),IDAT(65341)                                                                                               
      DATA MAXX/65341/, MAXL/100/                                                                                                   
C-----------------------------------------------------------------------                                                            
      NFF=4                                                                                                                         
      CALL JCLPNT(NFF,1,2,3,6)                                                                                                      
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
      REWIND 3                                                                                                                      
      NRECS=0                                                                                                                       
C                                                                                                                                   
C     * GET THE NUMBER OF LEVELS IN THE MULTI-LEVEL FILE.                                                                           
C                                                                                                                                   
      CALL FILEV(LEV,NLEV,IBUF,2)                                                                                                   
      IF((NLEV.LT.1).OR.(NLEV.GT.MAXL)) CALL       XIT('PSMLT',-1)                                                                  
      NPTS=IBUF(5)*IBUF(6)                                                                                                          
      REWIND 2                                                                                                                      
C                                                                                                                                   
C     * GET THE NEXT FIELD FROM FILE 1.                                                                                             
C                                                                                                                                   
  100 CALL GETFLD2(1,G,-1,-1,-1,-1,IBUF,MAXX,OK)                                                                                    
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6010) NRECS,NLEV                                                                                                    
        CALL                                       XIT('PSMLT',0)                                                                   
      ENDIF                                                                                                                         
      IF(NRECS.EQ.0) WRITE(6,6025) IBUF                                                                                             
C                                                                                                                                   
C     * STOP IF THIS FIELD IS COMPLEX.                                                                                              
C                                                                                                                                   
      KIND=IBUF(1)                                                                                                                  
      SPEC=(KIND.EQ.NC4TO8("SPEC").OR.KIND.EQ.NC4TO8("FOUR"))                                                                       
      IF(SPEC)THEN                                                                                                                  
        WRITE(6,6025) IBUF                                                                                                          
        CALL                                       XIT('PSMLT',-2)                                                                  
      ENDIF                                                                                                                         
      DO 110 I=1,8                                                                                                                  
  110 JBUF(I)=IBUF(I)                                                                                                               
C                                                                                                                                   
C     * READ NEXT SET ONE LEVEL AT A TIME. STOP IF WRONG KIND OR SIZE.                                                              
C                                                                                                                                   
      DO 300 I=1,NLEV                                                                                                               
      CALL GETFLD2(2,F,KIND,-1,-1,-1,IBUF,MAXX,OK)                                                                                  
      IF(.NOT.OK) CALL                             XIT('PSMLT',-3)                                                                  
      CALL CMPLBL(0,IBUF,0,JBUF,OK)                                                                                                 
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6025) IBUF                                                                                                          
        CALL                                       XIT('PSMLT',-4)                                                                  
      ENDIF                                                                                                                         
      IF(NRECS.EQ.0) WRITE(6,6025) IBUF                                                                                             
C                                                                                                                                   
C     * MULTIPLY THIS LEVEL OF THE SET BY THE ONE LEVEL FIELD.                                                                      
C     * SAVE THE RESULT ON FILE 3.                                                                                                  
C                                                                                                                                   
      DO 250 J=1,NPTS                                                                                                               
  250 F(J)=F(J)*G(J)                                                                                                                
  300 CALL PUTFLD2(3,F,IBUF,MAXX)                                                                                                   
C                                                                                                                                   
      NRECS=NRECS+1                                                                                                                 
      GO TO 100                                                                                                                     
C-----------------------------------------------------------------------                                                            
 6010 FORMAT('0PSMLT MULTIPLIED',I6,' SETS TO',I3,' LEVELS')                                                                        
 6025 FORMAT(' ',A4,I10,1X,A4,I10,4I6)                                                                                              
      END                                                                                                                           
