      PROGRAM ZXPSI                                                                                                                 
C     PROGRAM ZXPSI (ZXIN,       ZXOUT,       INPUT,       OUTPUT,      )       F2                                                  
C    1         TAPE1=ZXIN, TAPE2=ZXOUT, TAPE5=INPUT, TAPE6=OUTPUT)                                                                  
C     ------------------------------------------------------------              F2                                                  
C                                                                               F2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)       F2                                                  
C     APR 16/97 - F.MAJAESS(REVISE TO PROCESS ALL SETS NOT JUST THE FIRST SET)                                                      
C     JAN 15/93 - E. CHAN  (DECODE LEVELS IN 8-WORD LABEL)                                                                          
C     JUL 13/92 - E. CHAN  (DIMENSION SELECTED VARIABLES AS REAL*8)                                                                 
C     JAN 29/92 - E. CHAN  (CONVERT HOLLERITH LITERALS TO ASCII)                                                                    
C     MAY 14/83 - R.LAPRISE.                                                                                                        
C     NOV 06/80 - J.D.HENDERSON                                                                                                     
C                                                                               F2                                                  
CZXPSI   - COMPUTES MERIDIONAL STREAM-FUNCTION FROM A CROSS-SECTION     1  1   GF1                                                  
C                                                                               F3                                                  
CAUTHOR  - J.D.HENDERSON                                                        F3                                                  
C                                                                               F3                                                  
CPURPOSE - COMPUTES CROSS-SECTION OF MERIDIONAL STREAM FUNCTION FROM A          F3                                                  
C          CROSS-SECTION OF V WIND COMPONENT OR A FIELD OF VERTICAL MOTION.     F3                                                  
C          NOTE - MAXIMUM LATITUDES IS $BJ$ AND MAXIMUM LEVELS IS $L$.          F3                                                  
C                                                                               F3                                                  
CINPUT FILE...                                                                  F3                                                  
C                                                                               F3                                                  
C      ZXIN  = CONTAINS CROSS-SECTION DATA                                      F3                                                  
C                                                                               F3                                                  
COUTPUT FILE...                                                                 F3                                                  
C                                                                               F3                                                  
C      ZXOUT = THE MERIDIONAL STREAM FUNCTION CROSS-SECTION                     F3                                                  
C-------------------------------------------------------------------------------                                                    
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMMON/BLANCK/XA(181,100), F(181),G(181,100)                                                                                  
C                                                                                                                                   
      LOGICAL OK                                                                                                                    
      LOGICAL W                                                                                                                     
      REAL PR(100)                                                                                                                  
      REAL*8 SL(181),CL(181),WL(181),WOSSL(181),RAD(181)                                                                            
      INTEGER LEV(100)                                                                                                              
C                                                                                                                                   
      COMMON/ICOM/IBUF(8),IDAT(181)                                                                                                 
      DATA MAXX/181/, MAXL/100/, MAXJ/181/                                                                                          
C---------------------------------------------------------------------                                                              
      NFF=3                                                                                                                         
      CALL JCLPNT(NFF,1,2,6)                                                                                                        
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
      NSET=0                                                                                                                        
C                                                                                                                                   
C     * GET THE CROSS-SECTION. STOP IF THE FILE IS EMPTY.                                                                           
C     * LEV WILL CONTAIN THE PRESSURE LEVEL VALUES IN MILLIBARS.                                                                    
C                                                                                                                                   
  100 CALL GETZX2(1,XA,MAXJ,LEV,NLEV,IBUF,MAXX,OK)                                                                                  
      IF(.NOT.OK) GO TO 510                                                                                                         
      IF(NLEV.LT.1 .OR. NLEV.GT.MAXL) CALL         XIT('ZXPSI',-2)                                                                  
      NAME=IBUF(3)                                                                                                                  
      W=(NAME.EQ.NC4TO8("   W"))                                                                                                    
      IF (NSET.EQ.0) THEN                                                                                                           
       IF(W) WRITE(6,6040)                                                                                                          
       WRITE(6,6025) IBUF                                                                                                           
      ENDIF                                                                                                                         
      NLAT=IBUF(5)                                                                                                                  
      CALL LVDCODE(PR,LEV,NLEV)                                                                                                     
C                                                                                                                                   
C     * GAUSSG COMPUTES THE VALUE OF THE GAUSSIAN LATITUDES AND THEIR                                                               
C     * SINES AND COSINES. TRIGL MAKES THEM GLOBAL (S TO N).                                                                        
C                                                                                                                                   
      ILATH=NLAT/2                                                                                                                  
      CALL GAUSSG(ILATH,SL,WL,CL,RAD,WOSSL)                                                                                         
      CALL  TRIGL(ILATH,SL,WL,CL,RAD,WOSSL)                                                                                         
      IF(W) GO TO 500                                                                                                               
C                                                                                                                                   
C    * MERIDIONAL WIND CASE.                                                                                                        
C                                                                                                                                   
C     * INTEGRATE EACH LATITUDE IN PRESSURE FROM THE TOP DOWN.                                                                      
C     * CONVERT MB TO N/M**2 BY A FACTOR OF 100.                                                                                    
C                                                                                                                                   
      TPAG=2.E0*3.14159E0*6.371E6/9.80616E0                                                                                         
      TPAG=TPAG*100.E0                                                                                                              
      DO 405 J=1,NLAT                                                                                                               
  405 F(J)=0.5E0*XA(J,1)*PR(1)*TPAG* CL(J)                                                                                          
C                                                                                                                                   
      DO 420 L=1,NLEV                                                                                                               
      IF(L.EQ.1) GO TO 415                                                                                                          
      DO 410 J=1,NLAT                                                                                                               
      TPAGC=TPAG* CL(J)                                                                                                             
  410 F(J)=F(J)+0.5E0*(XA(J,L)+XA(J,L-1))*(PR(L)-PR(L-1))*TPAGC                                                                     
C                                                                                                                                   
  415 IBUF(3)=NC4TO8(" PSI")                                                                                                        
      IBUF(4)=LEV(L)                                                                                                                
      CALL PUTFLD2(2,F,IBUF,MAXX)                                                                                                   
      IF (NSET.EQ.0) WRITE(6,6025) IBUF                                                                                             
  420 CONTINUE                                                                                                                      
      NSET=NSET+1                                                                                                                   
      GO TO 100                                                                                                                     
C                                                                                                                                   
  500 CONTINUE                                                                                                                      
C                                                                                                                                   
C    * VERTICAL MOTION CASE                                                                                                         
C                                                                                                                                   
C    * INTEGRATE EACH PRESSURE LEVEL FROM NORTH TO SOUTH.                                                                           
C    * SET THE NORTHERN MOST LATITUDE EQUALS TO ZERO.                                                                               
C                                                                                                                                   
      TPAG=2.E0*3.1459E0*6.371E6*6.371E6/9.80616E0                                                                                  
      DO 505 J=1,NLEV                                                                                                               
  505 G(NLAT,J)=0.E0                                                                                                                
      DO 520 L=2,NLAT                                                                                                               
      DO 520 J=1,NLEV                                                                                                               
      M=NLAT-L+1                                                                                                                    
      G(M,J)=0.5E0*(XA(M+1,J)*CL(M+1)+XA(M,J)*CL(M))*                                                                               
     & (RAD(M+1)-RAD(M))*TPAG                                                                                                       
  520 CONTINUE                                                                                                                      
      DO 530 J=1,NLEV                                                                                                               
      S=0.E0                                                                                                                        
      DO 535 L=1,NLAT                                                                                                               
      M=NLAT-L+1                                                                                                                    
      S=S+G(M,J)                                                                                                                    
  535 F(M)=S                                                                                                                        
      IBUF(3)=NC4TO8(" PSI")                                                                                                        
      IBUF(4)=LEV(J)                                                                                                                
      CALL PUTFLD2(2,F,IBUF,MAXX)                                                                                                   
      IF (NSET.EQ.0) WRITE(6,6025) IBUF                                                                                             
  530 CONTINUE                                                                                                                      
      NSET=NSET+1                                                                                                                   
      GO TO 100                                                                                                                     
  510 IF(NSET.GT.0) THEN                                                                                                            
        WRITE(6,6050) NSET                                                                                                          
        CALL                                       XIT('ZXPSI',0)                                                                   
      ELSE                                                                                                                          
        CALL                                       XIT('ZXPSI',-1)                                                                  
      ENDIF                                                                                                                         
C---------------------------------------------------------------------                                                              
 6025 FORMAT(' ',A4,I10,1X,A4,I10,4I6)                                                                                              
 6040 FORMAT(10X,"CALCULATES MASS STREAMFUNCTION FROM OMEGA")                                                                       
 6050 FORMAT('0 PROCESSED ',I5,' SETS.')                                                                                            
      END                                                                                                                           
