      PROGRAM COFAPS                                                                                                                
C     PROGRAM COFAPS (SPEC,       PSGRID,       INPUT,       OUTPUT,    )       E2                                                  
C    1          TAPE1=SPEC, TAPE2=PSGRID, TAPE5=INPUT, TAPE6=OUTPUT)                                                                
C     --------------------------------------------------------------            E2                                                  
C                                                                               E2                                                  
C     FEB 20/08 - F.MAJAESS (ADDED "PLTINFO" FILE CREATION)                     E2                                                  
C     JUL 03/03 - A.IRWIN,F.MAJAESS (REVISED FOR F90 AND LINUX PLATFORMS)                                                           
C     NOV 06/95 - F.MAJAESS (REVISE DEFAULT PACKING DENSITY VALUE)                                                                  
C     FEB 15/94 - F.MAJAESS (REVISE FOR TRUNCATIONS > 99)                                                                           
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 06/83 - R.LAPRISE.                                                                                                        
C     NOV 28/80 - J.D.HENDERSON                                                                                                     
C                                                                               E2                                                  
CCOFAPS  - CONVERTS SPECTRAL FILE TO POLAR STEREOGRAPHIC GRIDS          1  1 C GE1                                                  
C                                                                               E3                                                  
CAUTHOR  - J.D.HENDERSON                                                        E3                                                  
C                                                                               E3                                                  
CPURPOSE - CONVERTS A FILE OF GLOBAL SPECTRAL HARMONIC FIELDS (SPEC)            E3                                                  
C          TO HEMISPHERIC POLAR STEREOGRAPHIC GRIDS (PSFILE).                   E3                                                  
C          NOTE - IN ADDITION TO PSGRID AND THE OUTPUT FILE, COFAPS ALSO        E3                                                  
C                 WRITES CO-ORDINATE INFORMATION TO "PLTINFO" FILE              E3                                                  
C                 (UNIT 45) TO BE SUBSEQUENTLY USED BY GGPLOT.                  E3                                                  
C            ***  THE USER SHOULD CALL GGPLOT IMMEDIATELY AFTER COFAPS,(IF      E3                                                  
C                 PRODUCING A PLOT SO DESIRED), AND BEFORE CALLING              E3                                                  
C                 COFAPS/GGAPS/SUBAREA AGAIN, (EXCEPT WHEN PLOTTING MULTIPLE    E3                                                  
C                 FIELDS WITH A SINGLE CALL TO GGPLOT).                         E3                                                  
C                                                                               E3                                                  
CINPUT FILE...                                                                  E3                                                  
C                                                                               E3                                                  
C      SPEC = INPUT FILE OF GLOBAL SPECTRAL FIELDS                              E3                                                  
C                                                                               E3                                                  
COUTPUT FILE...                                                                 E3                                                  
C                                                                               E3                                                  
C      PSGRID = OUTPUT FILE OF POLAR STEREOGRAPHIC GRIDS                        E3                                                  
C               (EITHER NORTH OR SOUTH HEMISPHERE)                              E3                                                  
C                                                                                                                                   
CINPUT PARAMETERS...                                                                                                                
C                                                                               E5                                                  
C      LX,LY = POLAR STEREOGRAPHIC GRID DIMENSIONS.                             E5                                                  
C              LX=0; THE FIRST SIX VALUES ON THE CARD WILL ASSUME               E5                                                  
C                    THEIR DEFAULT VALUES:                                      E5                                                  
C                                                                               E5                                                  
C                      LX=51, LY=55, IP=26, JP=28, D60=3.81E5, DGRW=-10.E0      E5                                                  
C                                                                               E5                                                  
C                    WHICH WILL LEAD TO PRODUCING THE STANDARD POLAR            E5                                                  
C                    STEREOGRAPHIC PROJECTION OVER N OR S POLE BASED            E5                                                  
C                    ON CHOICE FOR NHEM WITH THE ASSOCIATED                     E5                                                  
C                     (DLAT1,DLON1)/(DLAT2/DLON2)                               E5                                                  
C                    CARTESIAN COORDINATE IN DEGREES OF                         E5                                                  
C                        LOWER_LEFT/UPPER_RIGHT                                 E5                                                  
C                    CORNER OF THE GRID BEING, RESPECTIVELY:                    E5                                                  
C                       DLAT1=-9.4., DLON1=-122.8.,                             E5                                                  
C                       DLAT2=-9.4., DLON2=57.2,                                E5                                                  
C                    IF NHEM=1 (NH), AND                                        E5                                                  
C                       DLAT1=9.4., DLON1=122.8.,                               E5                                                  
C                       DLAT2=9.4., DLON2=-57.2,                                E5                                                  
C                    IF NHEM=2 (SH).                                            E5                                                  
C      IP,JP = COORDINATES OF POLE IN THE P.S. GRID                             E5                                                  
C      D60   = GRID LENGTH AT 60 DEGREES LATITUDE (METERS)                      E5                                                  
C      DGRW  = ORIENTATION OF GREENWICH LONGITUDE IN THE P.S. GRID (DEG)        E5                                                  
C      NHEM  = 1 FOR N.HEM., 2 FOR S. HEM.                                      E5                                                  
C              DEFAULT VALUE IS 1.                                              E5                                                  
C                                                                               E5                                                  
CEXAMPLE OF INPUT CARD...                                                       E5                                                  
C                                                                               E5                                                  
C*COFAPS     51   55   26   28    3.81E5      -10.    1                         E5                                                  
C                                                                               E5                                                  
C     (THIS CARD WILL PRODUCE A 51,55 GRID WITH POLE AT 26,28.                  E5                                                  
C      GRID SIZE AT 60 DEG IS 381 KM AND ORIENTATION OF THE                     E5                                                  
C      GREENWICH MERIDIAN IS -10 DEGREES. IT IS A N.HEM. GRID.                  E5                                                  
C      THIS IS ACTUALLY THE STANDARD CMC GRID).                                 E5                                                  
C--------------------------------------------------------------------                                                               
C                                                                                                                                   
      IMPLICIT REAL (A-H,O-Z),                                                                                                      
     +INTEGER (I-N)                                                                                                                 
      COMPLEX SP                                                                                                                    
      COMMON/BLANCK/SP(9264),PS(18528)                                                                                              
C                                                                                                                                   
      LOGICAL OK, EX, STAT                                                                                                          
      INTEGER LSR(2,66)                                                                                                             
      REAL*8 ALP(2275),EPSI(2275)                                                                                                   
      REAL WRKL(132)                                                                                                                
      COMMON/ICOM/IBUF(8),IDAT(18528)                                                                                               
      DATA MAXX/18528/                                                                                                              
C---------------------------------------------------------------------                                                              
      NFF=4                                                                                                                         
      CALL JCLPNT(NFF,1,2,5,6)                                                                                                      
      REWIND 1                                                                                                                      
      REWIND 2                                                                                                                      
C                                                                                                                                   
C     * READ THE GRID SIZE FROM A CARD.                                                                                             
C     * GRID IS (LX,LY) WITH POLE AT (IP,JP).                                                                                       
C     * GRID SIZE IS D60(M) AND ORIENTATION IS DGRW (DEG).                                                                          
C     * NHEM = 1,2 FOR N,S HEMISPHERE.                                                                                              
C     * BLANK CARD DEFAULTS TO STANDARD CMC GRID.                                                                                   
C                                                                                                                                   
      READ(5,5010,END=902) LX,LY,IP,JP,D60,DGRW,NHEM                            E4                                                  
      IF(NHEM.EQ.0 .OR. NHEM.EQ.3) NHEM=1                                                                                           
      IF(LX.GT.0) THEN                                                                                                              
          NDFLT=0                                                                                                                   
          X=FLOAT(1-IP)                                                                                                             
          Y=FLOAT(1-JP)                                                                                                             
          CALL LLFXY(DLAT1,DLON1,X,Y,D60,DGRW,NHEM)                                                                                 
          X=FLOAT(LX-IP)                                                                                                            
          Y=FLOAT(LY-JP)                                                                                                            
          CALL LLFXY(DLAT2,DLON2,X,Y,D60,DGRW,NHEM)                                                                                 
          WRITE(6,6010)LX,LY,IP,JP,D60                                                                                              
          WRITE(6,6023)DLAT1,DLON1,DLAT2,DLON2,DGRW,NHEM                                                                            
          CALL PSCAL(LY,IP,JP,D60,LX,DGRW,DLAT1,DLON1,DLAT2,DLON2,                                                                  
     1               NHEM,NDFLT,NBADPS)                                                                                             
          IF (NBADPS.NE.0) THEN                                                                                                     
            WRITE(6,6026) NBADPS                                                                                                    
            CALL                                   XIT('COFAPS',-1)                                                                 
          ENDIF                                                                                                                     
          WRITE(6,6020)LX,LY,IP,JP,D60                                                                                              
          WRITE(6,6022)DLAT1,DLON1,DLAT2,DLON2,DGRW,NHEM                                                                            
      ELSE                                                                                                                          
       LX=51                                                                                                                        
       LY=55                                                                                                                        
       IP=26                                                                                                                        
       JP=28                                                                                                                        
       D60=3.81E5                                                                                                                   
       DGRW=-10.E0                                                                                                                  
       IF (NHEM.EQ.1) THEN                                                                                                          
         DLAT1=-9.4E0                                                                                                               
         DLON1=-122.8E0                                                                                                             
         DLAT2=-9.4E0                                                                                                               
         DLON2=57.2E0                                                                                                               
       ELSE                                                                                                                         
         DLAT1=9.4E0                                                                                                                
         DLON1=122.8E0                                                                                                              
         DLAT2=9.4E0                                                                                                                
         DLON2=-57.2E0                                                                                                              
       ENDIF                                                                                                                        
       NDFLT=0                                                                                                                      
       WRITE(6,6010)LX,LY,IP,JP,D60                                                                                                 
       WRITE(6,6023)DLAT1,DLON1,DLAT2,DLON2,DGRW,NHEM                                                                               
      ENDIF                                                                                                                         
C                                                                                                                                   
C                                                                                                                                   
C     * CHECK AND WRITE CO-ORDINATE INFORMATION OUT FOR GGPLOT                                                                      
C                                                                                                                                   
      NOUTYP=1                                                                                                                      
      INQUIRE(FILE='pltinfo',EXIST=EX)                                                                                              
      INQUIRE(45,OPENED=STAT)                                                                                                       
      IF (STAT) THEN                                                                                                                
       CLOSE(45)                                                                                                                    
      ENDIF                                                                                                                         
      OPEN(45,FILE='pltinfo',FORM='UNFORMATTED')                                                                                    
      REWIND 45                                                                                                                     
      IF (EX) THEN                                                                                                                  
        CALL READPLTINFO(45,DLAT1P,DLON1P,DLAT2P,DLON2P,DGRWP,                                                                      
     1                   NHEMP,NOUTYPP,IOST)                                                                                        
        IF(IOST.LT.0) GOTO 120                                                                                                      
                                                                                                                                    
        OK = (DLAT1P.EQ.DLAT1) .AND. (DLON1P  .EQ.DLON1  ) .AND.                                                                    
     1       (DLAT2P.EQ.DLAT2) .AND. (DLON2P  .EQ.DLON2  ) .AND.                                                                    
     2       (DGRWP .EQ.DGRW ) .AND. (NHEMP   .EQ.NHEM   ) .AND.                                                                    
     3                               (NOUTYPP .EQ.NOUTYP)                                                                           
        PRINT *,' P=',DLAT1P,DLON1P,DLAT2P,DLON2P,DGRWP,NHEMP                                                                       
        PRINT *,' O=',DLAT1,DLON1,DLAT2,DLON2,DGRW,NHEM                                                                             
        IF (OK) THEN                                                                                                                
          GO TO 140                                                                                                                 
        ELSE                                                                                                                        
          WRITE(6,6040) DLAT1,DLON1,DLAT2,DLON2,DGRW,NHEM,NOUTYP                                                                    
          GO TO 130                                                                                                                 
        ENDIF                                                                                                                       
  120   WRITE(6,6035)                                                                                                               
  130   CONTINUE                                                                                                                    
        CLOSE(45)                                                                                                                   
        CALL SYSTEM('\rm -f pltinfo')                                                                                               
        OPEN(45,FILE='pltinfo',FORM='UNFORMATTED')                                                                                  
        REWIND 45                                                                                                                   
      ENDIF                                                                                                                         
C                                                                                                                                   
      CALL WRITEPLTINFO(45,DLAT1,DLON1,DLAT2,                                                                                       
     1     DLON2,DGRW,NHEM,NOUTYP,IOST)                                                                                             
C                                                                                                                                   
C     * GET THE NEXT SPECTRAL FIELD.                                                                                                
C                                                                                                                                   
  140 NR=0                                                                                                                          
  150 CALL GETFLD2(1,SP,NC4TO8("SPEC"),-1,-1,-1,IBUF,MAXX,OK)                                                                       
      IF(.NOT.OK.AND.NR.EQ.0) CALL                 XIT('COFAPS',-2)                                                                 
      IF(.NOT.OK)THEN                                                                                                               
        WRITE(6,6015) NR                                                                                                            
        CALL                                       XIT('COFAPS',0)                                                                  
      ENDIF                                                                                                                         
      IF(NR.EQ.0) THEN                                                                                                              
        CALL PRTLAB (IBUF)                                                                                                          
        NPACK=MIN(2,IBUF(8))                                                                                                        
      ENDIF                                                                                                                         
      LRLMT=IBUF(7)                                                                                                                 
      IF(LRLMT.LT.100) CALL FXLRLMT (LRLMT,IBUF(5),IBUF(6),0)                                                                       
      CALL DIMGT(LSR,LA,LR,LM,KTR,LRLMT)                                                                                            
      CALL EPSCAL(EPSI,LSR,LM)                                                                                                      
C                                                                                                                                   
C     * CONVERT SPECTRAL COEFF TO P.S. GRID FIELD.                                                                                  
C                                                                                                                                   
      CALL STAPS2(PS,LX,LY,IP,JP,D60,DGRW,NHEM,SP,LSR,LM,ALP,EPSI,WRKL)                                                             
C                                                                                                                                   
C     * SAVE THE GRIDS.                                                                                                             
C                                                                                                                                   
      CALL SETLAB(IBUF,NC4TO8("GRID"),-1,-1,-1,LX,LY,NHEM,NPACK)                                                                    
      CALL PUTFLD2(2,PS,IBUF,MAXX)                                                                                                  
      IF(NR.EQ.0) CALL PRTLAB (IBUF)                                                                                                
      NR=NR+1                                                                                                                       
      GO TO 150                                                                                                                     
C                                                                                                                                   
C     * E.O.F. ON INPUT.                                                                                                            
C                                                                                                                                   
  902 CALL                                         XIT('COFAPS',-3)                                                                 
C---------------------------------------------------------------------                                                              
 5010 FORMAT(10X,4I5,2E10.0,I5)                                                 E4                                                  
 6010 FORMAT('0LX,LY,IP,JP,D60 =',4I6,E12.4)                                                                                        
 6015 FORMAT(' ',I6,' RECORDS READ')                                                                                                
 6020 FORMAT('0RESULTING LX,LY,IP,JP,D60 =',4I5,E12.4)                                                                              
 6022 FORMAT('0ADJUSTED DLAT1,DLON1,DLAT2,DLON2,DGRW,NHEM = ',5E12.4,I5)                                                            
 6023 FORMAT('0CHOSEN DLAT1,DLON1,DLAT2,DLON2,DGRW,NHEM = ',5E12.4,I5)                                                              
 6026 FORMAT(1X,'COFAPS-ERROR : SUB-AREA CO-ORDINATES INVALID CODE ',I5)                                                            
 6035 FORMAT(/' ** PLTINFO "FT45" FILE EXISTS AND EMPTY !'/)                                                                        
 6040 FORMAT(/,                                                                                                                     
     1       ' **  WARNING   ** SUB-AREA COORDINATES CHANGED IN',                                                                   
     2       ' PLTINFO "FT45" FILE FOR GGPLOT.'/                                                                                    
     3       ' **  REMINDER  ** NORMAL PROCEDURE IS TO PLOT',                                                                       
     4       ' PREVIOUSLY "SUBAREA/GGAPS/COFAPS" GENERATED FIELDS BY',                                                              
     5       ' GGPLOT BEFORE '/                                                                                                     
     6       '                  PROCEEDING WITH ANOTHER SET OF',                                                                    
     7       ' FIELDS HAVING DIFFERENT SUB-AREA COORDINATES.'//                                                                     
     8       ' ** NEW VALUES ** DLAT1,DLON1,DLAT2,DLON2,DGRW,NHEM,',                                                                
     9       'NOUTYP=',5E12.4,2I5/)                                                                                                 
      END                                                                                                                           
