C**** VECCPSIJ.FOR 2004/10/27 C**** VECtor Color PostScript files of three components of IxJ DataFiles C**** C**** Compile into Executable module: FCE VECCPSIJ.FOR C**** C**** Compilation notes: C**** The input file directory (IFDIR) should contain the files: C**** VECCPSIJ.I , COLORS , CPIJCBDT/* , and Z files. C**** IFDIR should be defined as an environment varialble or defined C**** near the beginning of this Fortran source listing. C**** The executable module a.out should be renamed to VECCPSIJ . C**** REAL*4 FOCEAN(720*360), U(720*360),V(720*360),W(720*360) CHARACTER*80 IFDIR,ARGMNT,ZFILE,TITLE PARAMETER (IBACKC = 0, ! index of background color * IFOREC = 1, ! index of foreground color * DATMIS = -999999) ! value for missing data CHARACTER JLAND,JWHIT LOGICAL*4 QEXIST C**** CALL GETENV ('IFDIR',IFDIR) NARGS = IARGC() IF(NARGS.le.0) GO TO 800 C**** C**** Determine resolution C**** FOCEAN(1) = -1. IARG = 1 CALL GETARG (IARG,ARGMNT) IF(ARGMNT(1:1).lt.'0' .or. ARGMNT(1:1).gt.'9') GO TO 50 LOCAX = SCAN(ARGMNT,'Xx') IF(LOCAX.le.1) GO TO 50 READ (ARGMNT(1:LOCAX-1) ,*,IOSTAT=IOSQ) IM IF(IOSQ.ne.0) GO TO 50 READ (ARGMNT(LOCAX+1:80),*,IOSTAT=IOSQ) JM IF(IOSQ.ne.0) GO TO 50 IARG = 2 GO TO 100 C**** Resolution not specified on command line, derive it from file 50 CALL RESOLU (ARGMNT, IM,JM,ZFILE, *810) IF(ZFILE(1:4).eq.'None') GO TO 100 C**** C**** Read ocean fraction file C**** INQUIRE (FILE=ZFILE,EXIST=QEXIST) IF(.not.QEXIST) ZFILE = TRIM(IFDIR) // '/' // ZFILE OPEN (11,FILE=ZFILE,FORM='UNFORMATTED',STATUS='OLD',ERR=809) READ (11) TITLE,(FOCEAN(I),I=1,IM*JM) CLOSE (11) WRITE (6,*) TRIM(ZFILE) // ' read in: ' // TRIM(TITLE) C**** C**** Open and read input files C**** C**** Read in COLORS 100 CALL COLOR (IFDIR) C**** Open input DataFile CALL GETARG (IARG,ARGMNT) OPEN (1,FILE=ARGMNT,FORM='UNFORMATTED',STATUS='OLD',ERR=810) C**** Skip over unused records in input DataFile NREC = 1 IF(NARGS > IARG) then CALL GETARG (IARG+1,ARGMNT) READ (ARGMNT,*,ERR=811) NREC IF(NREC<=0) GO TO 811 ; endif DO 120 N=1,NREC-1 120 READ (1,ERR=812) C**** Read components U, V and W from input DataFile READ (1,ERR=812) TITLE,(U(I),I=1,IM*JM) ; N = N+1 WRITE (6,*) 'Read from unit 1: ',TITLE READ (1,ERR=812) TITLE,(V(I),I=1,IM*JM) ; N = N+1 WRITE (6,*) 'Read from unit 1: ',TITLE READ (1,ERR=812) TITLE,(W(I),I=1,IM*JM) WRITE (6,*) 'Read from unit 1: ',TITLE CLOSE (1) C**** C**** Determine presentation parameters C**** TITLE = title describing each record C**** CSCLJ = center value of color scale C**** DSCLJ = scale difference between scale markers C**** JROTA = color plot is rotated JROTA boxes to the left C**** JLAND = color plot boxes show: A = All, L = land, O = ocean C**** JWHIT = continental outline or unused areas: W = white, B = black C**** CALL MATCHI (IM*JM, TITLE,U,V,W, DATMIS, IFDIR, * CSCLJ,DSCLJ, JROTA, JLAND,JWHIT) IF(TITLE(1:9).eq.'VERTICAL ') TITLE(1:64) = TITLE(10:64) IF(FOCEAN(1).eq.-1) JLAND = 'A' C**** C**** P: Print 1 or 2 records on color printer C**** 650 OPEN (9,FILE='VECCPSIJ.PS') WRITE (9,965) C WRITE (9,966) ! for two plots on same page CALL WRITPS (IM,JM, FOCEAN, TITLE,U,V,W, DATMIS, * CSCLJ,DSCLJ, JROTA, JLAND,JWHIT) C WRITE (9,967) ! for two plots on same page C CALL WRITPS (IM,JM, FOCEAN, TITLE2,U2,V2,W2, DATMIS, C * CSCLJ2,DSCLJ2, JROTA2, JLAND2,JWHIT2) WRITE (9,968) CLOSE (9) WRITE (6,*) 'PostScript file written: VECCPSIJ.PS' GO TO 999 C**** 800 WRITE (6,*) *'Usage: VECCPSIJ [IMxJM] DataFile [nrec] 2004/10/27' WRITE (6,*) *' VECtor Color PostScript file of 3 DataFile components.' WRITE (6,*) *' Records 1, 2 and 3 [or nrec, nrec+1 and nrec+2] are used.' GO TO 999 809 WRITE (0,*) 'Error opening ocean fraction file: ',ZFILE STOP 809 810 WRITE (0,*) 'Error opening DataFile: ',ARGMNT STOP 810 811 WRITE (0,*) 'Argument NREC should be a positive integer, not: ', * ARGMNT STOP 811 812 WRITE (0,*) 'Error reading N-th record of input DataFile. N =',N STOP 812 C**** 965 FORMAT ('%!PS-Adobe-3.0 PostScript file CPSIJ.PS 2004/10/27'/ * '%%Orientation: Landscape' / * 'gsave 90 rotate 108 -306 translate') 966 FORMAT ('%!PS-Adobe-3.0 PostScript file CPSIJ.PS 2004/10/27'/ * '%%Orientation: Portrait' / * 'gsave .75 .75 scale 120 774 translate') 967 FORMAT (/'%%% Second record printed on bottom half of page' / * ' 0 -496 translate') 968 FORMAT (/ 'grestore' / 'showpage') 999 END SUBROUTINE COLOR (IFDIR) C**** C**** COLOR reads the file COLORS containing the RGB color values C**** that are used for the PostScript output file. C**** PARAMETER (MAXC=63) CHARACTER IFDIR*80,FILEIN*80 LOGICAL*4 QEXIST COMMON /COLORS/ REDP(0:MAXC),GRNP(0:MAXC),BLUP(0:MAXC),NMCOLR C**** Open the file COLORS FILEIN = 'COLORS' INQUIRE (FILE=FILEIN,EXIST=QEXIST) IF(.not.QEXIST) FILEIN = TRIM(IFDIR) // '/COLORS' OPEN (4,FILE=FILEIN,STATUS='OLD',ERR=801) C**** Read in RGB color values 20 DO 30 N=1,5 30 READ (4,904) DO 40 N=0,MAXC READ (4,904,IOSTAT=IOSQ) REDS,GRNS,BLUS, REDP(N),GRNP(N),BLUP(N) 40 IF(IOSQ.ne.0) GO TO 50 50 NMCOLR = N-1 WRITE (6,906) NMCOLR,FILEIN RETURN C**** 801 WRITE (0,*) 'Error opening file: ',FILEIN STOP 801 C**** 904 FORMAT (3X,3F7.3,1X,3F7.3) 906 FORMAT (' Last line of RGB color values is:',I3, * '. Read from: ',A) END SUBROUTINE MATCHI (IMxJM, TITLE,U,V,W, DATMIS, IFDIR, * CSCLJ,DSCLJ, JROTA, JLAND,JWHIT) C**** C**** MATCHI matches the DataFile record TITLE with TITLEIs in the file C**** VECCPSIJ.I to get presentation parameters for the plot. C**** If the DataFile record TITLE does not match any TITLEI in the C**** file VECCPSIJ.I, then the presentation parameters are estimated. C**** C**** Input: C**** IMxJM = resolution of DataFile C**** TITLE = record TITLE of DataFile C**** U,V,W = three components of IxJ data C**** DATMIS= value for missing data C**** IFDIR = directory in which VECCPSIJ.I should reside C**** Output: C**** CSCLJ = center value of color scale C**** DSCLJ = scale difference between scale markers C**** JROTA = plot is rotated IROTA boxes to the left C**** JLAND = grid cells show: A = All, L = land, O = ocean C**** JWHIT = continental outline or unused areas: W = white, B = black C**** Internal: C**** TITLEI= first 32 bytes of a record in the file VECCPSIJ.I C**** JCBFN = file name of color bar distribution table C**** REAL*4 U(IMxJM),V(IMxJM),W(IMxJM) CHARACTER TITLE*80, IFDIR*80, JLAND,JWHIT, FILEIN*80, * TITLEI*32,JCBFN*8 LOGICAL*4 QEXIST C**** C**** Determine presentation parameters form the file VECCPSIJ.I C**** C**** Open VECCPSIJ.I FILEIN = 'VECCPSIJ.I' INQUIRE (FILE=FILEIN,EXIST=QEXIST) IF(.not.QEXIST) FILEIN = TRIM(IFDIR) // '/VECCPSIJ.I' OPEN (4,FILE=FILEIN,STATUS='OLD',ERR=200) DO 110 N=1,4 110 READ (4,912,ERR=811) C**** Match TITLE with TITLEI in a record in VECCPSIJ.I 120 READ (4,912,END=200) TITLEI,CSCLJ,DSCLJ,JROTA,JLAND,JWHIT,JCBFN DO 130 K=1,32 130 IF(TITLEI(K:K).ne.TITLE(K:K) .and. TITLEI(K:K).ne.'.') GO TO 120 CLOSE (4) WRITE (6,913) TITLEI,CSCLJ,DSCLJ,JROTA,JLAND,JWHIT,JCBFN C**** TITLEI matches TITLE CALL LOADCB (JCBFN,IFDIR) RETURN C**** C**** TITLE does not match any record in the file VECCPSIJ.I C**** Estimate presentation parmeters C**** 200 CLOSE (4) JROTA = 0 JLAND = 'A' JWHIT = 'B' C**** Calculate mean and standard deviation IJW = 0 SW = 0. SWQ = 0. DO 210 IJ=1,IMxJM IF(W(IJ).le.DATMIS) GO TO 210 IJW = IJW + 1 SW = SW + W(IJ) SWQ = SWQ + W(IJ)**2 210 continue CSCLJ = SW/IJW STDV = SQRT(SWQ/IJW - CSCLJ**2) DSCLJ = ROUND (STDV/2.5) CSCLJ = NINT(4*CSCLJ/DSCLJ)*DSCLJ/4. C**** Load equally distributed Color Block Definition Table JCBFN = 'SCT0' CALL LOADCB (JCBFN,IFDIR) RETURN C**** 811 WRITE (0,*) 'Error reading record N of file VECCPSIJ.I . N =',N STOP 811 C**** 912 FORMAT (A32,2F8.0,I4,2(2X,A1),2X,A8) 913 FORMAT (' TITLE matches TITLEI in record if VECCPSIJ.I:', / * 1X,A32,2F10.3,I4,2(2X,A1),2X,A8) END SUBROUTINE LOADCB (CBDTFN,IFDIR) C**** C**** LOADCB loads the desired color bar distribution table into the C**** common block CBDTCB. C**** C**** CBDTFN = file name of requested color bar distribution table C**** IFDIR = input file directory C**** PARAMETER (MAXBLK=64) ! maximum number of blocks in any CBDT CHARACTER CBDTFN*8, IFDIR*80, FILEIN*80 LOGICAL*4 QEXIST COMMON /CBDTCB/ KCBDT(MAXBLK), ! color index for each block * NBLKS ! number of blocks C**** C**** Read in color bar distribution table from disk C**** C**** Open color bar distribution table FILEIN = 'CPIJCBDT/' // CBDTFN INQUIRE (FILE=FILEIN,EXIST=QEXIST) IF(.not.QEXIST) FILEIN = TRIM(IFDIR) // '/CPIJCBDT/' // CBDTFN OPEN (4,FILE=FILEIN,STATUS='OLD',ERR=801) C**** Skip first three lines of color bar distribution table DO 20 K=1,3 20 READ (4,*,ERR=802) C**** Contents of file is in reverse order DO 40 K=1,MAXBLK 40 KCBDT(K) = -1 READ (4,*,END=50,ERR=50) (KCBDT(K),K=MAXBLK,1,-1) 50 CLOSE (4) C**** Move loaded data in memory: KCBDT(1) to KCBDT(NBLKS) KOFF = 0 DO 60 K=1,MAXBLK IF(KCBDT(K).ge.0) then ; KCBDT(K-KOFF) = KCBDT(K) else ; KOFF = KOFF+1 ; endif 60 continue NBLKS = MAXBLK-KOFF WRITE (6,*) 'Number of blocks in Color Block Distribution Table ' * // TRIM(CBDTFN) // ' is:',NBLKS RETURN C**** C**** 801 WRITE (0,*) 'Error opening file: ',FILEIN STOP 801 802 WRITE (0,*) 'Error reading one of first three lines of CBDT file.' STOP 802 END SUBROUTINE WRITPS (IM,JM, FOCEAN, TITLE,U,V,W, DATMIS, * CSCLJ,DSCLJ,JROTA,JLAND,JWHIT) C**** C**** Write Vector Color PostScript file C**** C**** IM,JM = horizontal resolution C**** FOCEAN= ocean fration array C**** TITLE = title at top of plot C**** U,V,W = three components of grid point data to be plotted C**** DATMIS= upper boundary for missing data C**** CSCLJ = center value of color scale C**** DSCLJ = scale difference between scale markers C**** JROTA = color plot is rotated JROTA boxes to the left C**** JLAND = color plot boxes show: A = all, L = land, O = ocean C**** JWHIT = continental outline or unused areas: W = white, B = black C**** STARR = value of large standard arrow C**** LABEL = label of arrow in lower left corner of plot C**** PARAMETER (MAXC=63, MAXBLK=64, IBACKC=0, IFOREC=1) REAL*4 FOCEAN(IM,JM), U(IM,JM),V(IM,JM),W(IM,JM) INTEGER*4 KCOLOR(720),IEDGE(720), IAMP(720),IANG(720) CHARACTER TITLE*80, JLAND,JWHIT, CBAR*8 COMMON /COLORS/ REDP(0:MAXC),GRNP(0:MAXC),BLUP(0:MAXC),NMCOLR COMMON /CBDTCB/ KCBDT(MAXBLK),NBLKS C**** C**** Write RGB color values to PostScript file C**** WRITE (9,900) WRITE (9,901) '/RED [',(REDP(N),N=0,NMCOLR) WRITE (9,*) ' ] def' WRITE (9,901) '/GREEN [',(GRNP(N),N=0,NMCOLR) WRITE (9,*) ' ] def' WRITE (9,901) '/BLUE [',(BLUP(N),N=0,NMCOLR) WRITE (9,*) ' ] def' C**** C**** Write title to PostScript file C**** LEN = LEN_TRIM(TITLE) NLP = 0 NRP = 0 DO 110 N=1,LEN IF(TITLE(N:N).eq.'(') NLP = NLP + 1 110 IF(TITLE(N:N).eq.')') NRP = NRP + 1 IF(NLP.le.NRP) GO TO 130 C**** Too many Left Parentheses: replace some with blanks DO 120 N=LEN,1,-1 IF(TITLE(N:N).ne.'(') GO TO 120 TITLE(N:N) = ' ' NLP = NLP - 1 IF(NLP.eq.NRP) GO TO 150 120 continue STOP 120 130 IF(NRP.le.NLP) GO TO 150 C**** Too many Right Parentheses: replace some with blanks DO 140 N=LEN,1,-1 IF(TITLE(N:N).ne.')') GO TO 140 TITLE(N:N) = ' ' NRP = NRP - 1 IF(NRP.eq.NLP) GO TO 150 140 continue STOP 140 150 WRITE (9,915) TITLE(1:LEN) C**** C**** Scale plot to have 1 unit per grid cell C**** SCALEX = 72*9./IM SCALEY = 72*6./JM WRITE (9,919) IM,JM, SCALEX,SCALEY C**** C**** Write longitude by latitude color plot to PostScript file C**** WRITE (9,920) BCEN = NBLKS/2. DO 220 J=1,JM WRITE (9,921) J-JM/2.,J DO 210 IR=1,IM I = IR+JROTA IF(I.gt.IM) I = I-IM KCOLOR(IR) = 1 IF( JWHIT.eq.'B') KCOLOR(IR) = 0 IF((JLAND.eq.'O' .and. FOCEAN(I,J).le..5) .or. * (JLAND.eq.'L' .and. FOCEAN(I,J).gt..5)) GO TO 210 IF(W(I,J).le.DATMIS) KCOLOR(IR) = 1-KCOLOR(IR) IF(W(I,J).le.DATMIS) GO TO 210 K = CEILING (4*(W(I,J)-CSCLJ)/DSCLJ + BCEN) IF(K.le.0 ) K = 1 IF(K.gt.NBLKS) K = NBLKS KCOLOR(IR) = KCBDT(K) 210 continue WRITE (9,922) (KCOLOR(IR),IR=1,IM) 220 WRITE (9,923) C**** C**** Write longitude by latitude vector plot to PostScript file C**** STARR = 4*ABS(DSCLJ) ! value of standard arrow WRITE (9,930) -JM/2-.5 DO 320 J=1,JM DO 310 IR=1,IM I = IR+JROTA IF(I.gt.IM) I = I-IM AMP = SQRT(U(I,J)**2 + V(I,J)**2) / STARR ANG = 0 IF(AMP.gt.0) ANG = ATAN2(V(I,J),U(I,J)) IAMP(IR) = NINT(100*SQRT(AMP)) IF(IAMP(IR).gt.999) IAMP(IR) = 999 IANG(IR) = NINT(ANG*360/6.2831853) 310 IF(IANG(IR).lt.0) IANG(IR) = IANG(IR) + 360 WRITE (9,931) J, (IANG(IR),IAMP(IR),IR=1,IM) 320 WRITE (9,932) WRITE (9,933) C**** C**** Write continental outline to PostScript file C**** IF(FOCEAN(1,1).lt.0. .or. JLAND.ne.'A') GO TO 500 KPEDGE = 0 IF(JWHIT.eq.'W') KPEDGE = 1 WRITE (9,940) KPEDGE C**** Draw horizontal edges between north-south grid boxes DO 430 J=1,JM-1 WRITE (9,941) J-JM/2.,J NEDGES = 0 DO 420 IR=1,IM I = IR+JROTA IF(I.gt.IM) I = I-IM IF(FOCEAN(I,J).gt..5 .xor. FOCEAN(I,J+1).le..5) GO TO 420 NEDGES = NEDGES + 1 IEDGE(NEDGES) = IR 420 continue IF(NEDGES.le.0) GO TO 430 WRITE (9,942) (IEDGE(N),N=1,NEDGES) WRITE (9,943) NEDGES 430 continue C**** Draw vertical edges between east-west grid boxes DO 450 J=2,JM-1 WRITE (9,944) J-JM/2.,J NEDGES = 0 I = 1+JROTA DO 440 IR=1,IM-1 IP1 = IR+1+JROTA IF(IP1.gt.IM) IP1 = IP1-IM IF(FOCEAN(I,J).gt..5 .xor. FOCEAN(IP1,J).le..5) GO TO 440 NEDGES = NEDGES + 1 IEDGE(NEDGES) = IR 440 I = IP1 IF(NEDGES.le.0) GO TO 450 WRITE (9,942) (IEDGE(N),N=1,NEDGES) WRITE (9,945) NEDGES 450 continue WRITE (9,*) ' grestore' C**** C**** Write colorbar to PostScript file C**** 500 WRITE (9,950) 72*6./NBLKS WRITE (9,922) (KCBDT(K),K=1,NBLKS) WRITE (9,951) NBLKS C**** Write colorbar labels WRITE (9,952) N = NINT (4.*CSCLJ/DSCLJ) N4 = MODULO (N,4) B1 = BCEN - N4 - 4.*INT((BCEN-N4-.5)/4.) DO 560 B=B1,NBLKS-.5,4. YBAR = B*72*6./NBLKS - 72*3. - 4 VALU = CSCLJ + (B-BCEN)*DSCLJ/4 WRITE (CBAR,953) NINT(VALU) IF(NINT(DSCLJ* 10).ne.NINT(DSCLJ )*10) WRITE (CBAR,954) VALU IF(NINT(DSCLJ* 100).ne.NINT(DSCLJ* 10)*10) WRITE (CBAR,955) VALU IF(NINT(DSCLJ*1000).ne.NINT(DSCLJ*100)*10) WRITE (CBAR,956) VALU 560 WRITE (9,957) YBAR,CBAR C**** C**** Write surrounding rectangle to PostScript file C**** WRITE (9,960) C**** C**** Write NASA/GISS logo to PostScript file C**** WRITE (9,961) C**** C**** Display large standard arrow and label in lower left corner C**** IAMPS = NINT(100*SQRT(1.)) WRITE (9,962) SCALEX,SCALEY, -JM/2.-1.5, IAMPS WRITE (CBAR,963) NINT(STARR) IF(NINT(STARR* 10).ne.NINT(STARR )*10) WRITE (CBAR,964) STARR IF(NINT(STARR* 100).ne.NINT(STARR* 10)*10) WRITE (CBAR,965) STARR IF(NINT(STARR*1000).ne.NINT(STARR*100)*10) WRITE (CBAR,966) STARR WRITE (9,967) CBAR RETURN C**** 900 FORMAT (/'%%% Load Color Table') 901 FORMAT (4X,A8,10F5.2 / (12X,10F5.2)) 915 FORMAT (/'%%% Produce TITLE' / *' /Helvetica-Bold findfont 20 scalefont setfont' / *' gsave 0 226 moveto' / '(',A,')' / *' dup stringwidth pop 648 exch div 1 scale show', *' grestore') 919 FORMAT (/'/IM',I4,' def /JM',I4,' def %%% Resolution' / *'gsave ',2F8.4,' scale %%% scale is now 1 unit per cell') 920 FORMAT (/'%%% Fill Each Grid Cell with Color' / *' /COLORBOX { newpath Y moveto' / *' -1 0 rlineto 0 -1 rlineto 1 0 rlineto closepath' / *' dup RED exch get exch' / *' dup GREEN exch get exch' / *' BLUE exch get setrgbcolor fill } def') 921 FORMAT (/'/Y',F6.1,' def %%% Data for J =',I4) 922 FORMAT (24I3) 923 FORMAT (' IM -1 1 {COLORBOX} for') 930 FORMAT (/' /ARROW {newpath 0 -.375 moveto .375 0 lineto' / *' 0 .375 lineto 0 .125 lineto -.375 .125 lineto' / *' -.375 -.125 lineto 0 -.125 lineto closepath', * ' fill} def' / *' /AI {gsave .01 mul dup scale rotate ARROW ' / *' grestore -1 0 translate} def' // *'%%% Draw Arrows in Each Grid Cell' / *' gsave -.5',F6.1,' translate 0 setgray') 931 FORMAT (/'/J',I4,' def IM 1 translate' / (18I4)) 932 FORMAT (' IM {AI} repeat') 933 FORMAT (' grestore') 940 FORMAT (/'%%% Draw Continental Outline' / *' /IEDGE { pop newpath Y moveto -1 0 rlineto stroke } def' / *' /JEDGE { pop newpath Y moveto 0 -1 rlineto stroke } def' / *I5,' setgray 1 setlinecap .25 setlinewidth') 941 FORMAT (/'/Y',F6.1,' def %%% East-west edges for J =',I4) 942 FORMAT (18I4) 943 FORMAT (' 1 1',I4,' {IEDGE} for') 944 FORMAT (/'/Y',F6.1,' def %%% North-south edges for J =',I4) 945 FORMAT (' 1 1',I4,' {JEDGE} for') 950 FORMAT (/'%%% Draw Colorbar to left of data' / * '%%% COLORBAR procedure for each color table value' / *' /COLORBAR { newpath 0 exch moveto' / *' -1 0 rlineto 0 -1 rlineto 1 0 rlineto closepath' / *' dup RED exch get exch' / *' dup GREEN exch get exch' / *' BLUE exch get setrgbcolor fill } def' / *'gsave -10 -216 translate 8',F9.4,' scale') 951 FORMAT (I3,' -1 1 {COLORBAR} for grestore') 952 FORMAT ('%%% Label the Colorbar' / *' /Helvetica-Bold findfont 16 scalefont setfont 0 setgray') 953 FORMAT (I7 ,'-') 954 FORMAT (F7.1,'-') 955 FORMAT (F7.2,'-') 956 FORMAT (F7.3,'-') 957 FORMAT (' -112',F8.2,' moveto (',A8,') dup stringwidth pop' / * ' 92 exch sub 0 rmoveto show') 960 FORMAT (/'%%% Draw surrounding rectangle' / *' 2 setlinewidth newpath -1 -217 moveto' / *' 650 0 rlineto 0 434 rlineto -650 0 rlineto', *' closepath stroke') 961 FORMAT (/'%%% Draw NASA/GISS logo' / *' /Helvetica-Bold findfont 12 scalefont setfont' / *' newpath 582 -232 moveto (NASA/GISS) show') 962 FORMAT (/'%%% Draw label for standard arrow in lower left corner'/ *' gsave ',2F8.4,' scale .5',F6.1,' translate 0',I4,' AI' / *' grestore') 963 FORMAT ('=',I4) 964 FORMAT ('=',F4.1) 965 FORMAT ('=',F4.2) 966 FORMAT ('=',F5.3) 967 FORMAT ( ' /Helvetica-Bold findfont 12 scalefont setfont' / * ' 15 -232 moveto (',A,') show') END FUNCTION ROUND (X) C**** C**** ROUND returns a rounded value of the positive number X C**** IF(X.lt.9000.) GO TO 10 ROUND = 80000. IF(X.ge.65000.) RETURN ROUND = NINT(X*.0001)*10000 RETURN C**** 10 IF(X.lt.900.) GO TO 20 ROUND = 8000. IF(X.ge.6500.) RETURN ROUND = NINT(X*.001)*1000 RETURN C**** 20 IF(X.lt.90.) GO TO 30 ROUND = 800. IF(X.ge.650.) RETURN ROUND = NINT(X*.01)*100 RETURN C**** 30 IF(X.lt.9.) GO TO 40 ROUND = 80. IF(X.ge.65.) RETURN ROUND = NINT(X*.1)*10 RETURN C**** 40 IF(X.lt..9) GO TO 50 ROUND = 8. IF(X.ge.6.5) RETURN ROUND = NINT(X) RETURN C**** 50 IF(X.lt..09) GO TO 60 ROUND = .8 IF(X.ge..65) RETURN ROUND = NINT(X*10.)*.1 RETURN C**** 60 IF(X.lt..015) GO TO 70 ROUND = .08 IF(X.ge..065) RETURN ROUND = NINT(X*100.)*.01 RETURN C**** 70 ROUND = .01 RETURN END SUBROUTINE RESOLU (FILEIN, IM,JM,ZFILE, *) C**** C**** RESOLU reads in the first four byte integer of a datafile and C**** from this information it determines the horizontal resolution. C**** C**** Input: FILEIN = character file name of a DATAFILE C**** Output: IM,JM = horizontal resolution C**** ZFILE = character file name of the ocean fraction file C**** * = use RETURN 1 if resolution is not determined C**** CHARACTER FILEIN*(*), ZFILE*(*) C**** OPEN (1,FILE=FILEIN,ACCESS='DIRECT',RECL=4,STATUS='OLD',ERR=801) READ (1,REC=1) IJT CLOSE (1) IJRES = (IJT-80)/4 C**** IF(IJRES.eq.46*9) then IM = 46 JM = 9 ZFILE = 'None' RETURN endif C**** IF(IJRES.eq.46*12) then IM = 46 JM = 12 ZFILE = 'None' RETURN endif C**** IF(IJRES.eq.72*46) then IM = 72 JM = 46 ZFILE = 'Z5X4N' RETURN endif C**** IF(IJRES.eq.72*46*2) then IM = 72 JM = 46 ZFILE = 'Z5X4N' RETURN endif C**** IF(IJRES.eq.90*60) then IM = 90 JM = 60 ZFILE = 'Z4X3N' RETURN endif C**** IF(IJRES.eq.144*72) then IM = 144 JM = 72 ZFILE = 'Z144X72' RETURN endif C**** IF(IJRES.eq.144*73) then IM = 144 JM = 73 ZFILE = 'None' RETURN endif C**** IF(IJRES.eq.120*90) then IM = 120 JM = 90 ZFILE = 'Z3X2N' RETURN endif C**** IF(IJRES.eq.144*90) then IM = 144 JM = 90 ZFILE = 'Z144X90N' RETURN endif C**** IF(IJRES.eq.360*180) then IM = 360 JM = 180 ZFILE = 'Z360X180' RETURN endif C**** IF(IJRES.eq.720*360) then IM = 720 JM = 360 ZFILE = 'Z720X360' RETURN endif C**** Unable to derive resolution from record length IM = IJRES JM = 1 ZFILE = 'None' RETURN C**** Unable to open datafile 801 RETURN 1 END