C**** BWIJ2.S Black & White PostScript program for IxJ 1999/02/26 C**** C**** Compile: FCE90 BWIJ2.S C**** C**** Compilation notes: The directory /u/cmrun/ should contain the C**** files: BWIJ.I , BWIJCBDT/* , and Z files. C**** /u/cmrun/ can be changed in this Fortran source listing. C**** The executable module a.out should be renamed to BWIJ2 . C**** The PP command sends the PostScript file to a network C**** printer. The printer's correct address should be part of the C**** argument to the CALL SYSTEM Fortran statment. C**** PARAMETER (MAXREC=1800, MAXIJR=72*46*MAXREC) C**** C**** MAXREC = dimension of TITLE array C**** MAXIJR = dimension of XYZD array C**** LOGICAL*4 QOPEN,QFOPEN,QPOPEN COMMON /PARMCB/ IM,JM,NRECM(4),QOPEN(3) DATA QFOPEN/.FALSE./, QPOPEN/.FALSE./ C**** C**** IM,JM = longitude and latitude horizontal resolution C**** NRECM = number of records read from data file so far C**** NRECM(4) = number of difference records calculated so far C**** QOPEN = whether data file is currently open C**** QFOPEN = whether BWIJ2.O and BWIJ2.IF have been opened C**** CHARACTER TITLE*80, JGRID*1,JLAND*1,JWHIT*1, JCBFN*8 COMMON /DATACB/ XYZD(MAXIJR,4) COMMON /TITLCB/ TITLE(MAXREC,4),DSCLJ(MAXREC,4), * JCBDT(MAXREC,4),JROTA(MAXREC,4),JBLK0(MAXREC,4),JDBLK(MAXREC,4), * JCBFN(MAXREC,4),JGRID(MAXREC,4),JLAND(MAXREC,4),JWHIT(MAXREC,4) C**** C**** XYZD = longitude by latitude data read from files C**** TITLE = title describing each record C**** JGRID = color plot displays specified grid: A, B, U or V C**** JROTA = color plot is rotated JROTA boxes to the left C**** JBLK0 = number of color blocks from bottom of scale to 0 C**** JDBLK = number of color blocks between scale markers C**** DSCLJ = scale difference between scale markers C**** JLAND = color plot boxes show: A = All, L = land, O = ocean C**** JWHIT = continental outline or unused areas: W = white, B = black C**** JCBFN = file name of color bar distribution table C**** JCBDT = index pointing to color bar distribution table C**** INTEGER*4 NREC(4), KMIN(3),KMAX(3) CHARACTER FILEIN*80, ARG*80, ERRARG*80, CPIJCB*8, * UNNN*4,UNN2*4,UNN3*4, CDSCL*6 COMMON /FIXDCB/ FOCEAN(144,90) EQUIVALENCE (NRX,NREC(1)),(NRY,NREC(2)),(NRZ,NREC(3)) DATA NREC/4*1/ C**** C**** FOCEAN = ocean fraction for each horizontal grid box C**** NREC = most recently displayed record of file C**** IARGS = IARGC() IF(IARGS.le.0) GO TO 800 C**** Read in BWIJ.I and BWIJCBDT/ST12 CALL MATCH0 CALL LOADCB ('ST12 ',ICB,*750) C**** C**** Process command line arguments C**** IARG = 1 CALL GETARG (IARG,ARG) C**** Determine resolution LOCAX = SCAN(ARG,'Xx') IF(LOCAX.le.0) GO TO 120 READ (ARG(1:LOCAX-1) ,*,IOSTAT=IOSQ) IM IF(IOSQ.ne.0) GO TO 120 READ (ARG(LOCAX+1:80),*,IOSTAT=IOSQ) JM IF(IOSQ.ne.0) GO TO 110 IARG = 2 GO TO 120 110 IM = 72 C**** Open X file 120 CALL GETARG (IARG,ARG) OPEN (1,FILE=ARG,FORM='UNFORMATTED',STATUS='OLD',ERR=810) QOPEN(1) = .TRUE. NRX = 1 CALL READIN (1,NRX,*999) IMJMNR = 1 + IM*JM*(NRX-1) CALL MATCHI (IM*JM,XYZD(IMJMNR,1),TITLE(NRX,1),JGRID(NRX,1), * JROTA(NRX,1),JBLK0(NRX,1),JDBLK(NRX,1),DSCLJ(NRX,1), * JLAND(NRX,1),JWHIT(NRX,1),JCBFN(NRX,1),JCBDT(NRX,1)) IARG = IARG + 1 IF(IARG.gt.IARGS) GO TO 200 C**** Open Y file CALL GETARG (IARG,ARG) OPEN (2,FILE=ARG,FORM='UNFORMATTED',STATUS='OLD',ERR=810) QOPEN(2) = .TRUE. NRY = 1 CALL READIN (2,NRY,*999) IMJMNR = 1 + IM*JM*(NRY-1) CALL MATCHI (IM*JM,XYZD(IMJMNR,2),TITLE(NRY,2),JGRID(NRY,2), * JROTA(NRY,2),JBLK0(NRY,2),JDBLK(NRY,2),DSCLJ(NRY,2), * JLAND(NRY,2),JWHIT(NRY,2),JCBFN(NRY,2),JCBDT(NRY,2)) IARG = IARG + 1 IF(IARG.gt.IARGS) GO TO 200 C**** Open Z file CALL GETARG (IARG,ARG) OPEN (3,FILE=ARG,FORM='UNFORMATTED',STATUS='OLD',ERR=810) QOPEN(3) = .TRUE. NRZ = 1 CALL READIN (3,NRZ,*999) IMJMNR = 1 + IM*JM*(NRZ-1) CALL MATCHI (IM*JM,XYZD(IMJMNR,3),TITLE(NRZ,3),JGRID(NRZ,3), * JROTA(NRZ,3),JBLK0(NRZ,3),JDBLK(NRZ,3),DSCLJ(NRZ,3), * JLAND(NRZ,3),JWHIT(NRZ,3),JCBFN(NRZ,3),JCBDT(NRZ,3)) C**** C**** Read ocean fraction file C**** 200 FOCEAN(1,1) = -1. IF(IM.ne.72 .or. JM.ne.46) GO TO 210 ARG = '/u/cmrun/Z72X46N' GO TO 240 210 IF(IM.ne.90 .or. JM.ne.60) GO TO 220 ARG = '/u/cmrun/Z90X60N' GO TO 240 220 IF(IM.ne.120 .or. JM.ne.90) GO TO 230 ARG = '/u/cmrun/Z120X90N' GO TO 240 230 IF(IM.ne.144 .or. JM.ne.90) GO TO 250 ARG = '/u/cmrun/Z144X90N' 240 OPEN (26,FILE=ARG,FORM='UNFORMATTED',STATUS='OLD',ERR=830) READ (26) ARG,(FOCEAN(I,1),I=1,IM*JM) CLOSE (26) C**** 250 NR = NRX IU = 1 WRITE (UNNN,923) 'X',NR C**** C**** Display color plot C**** 300 IMJMNR = 1 + IM*JM*(NR-1) CALL CPIJ (IM,JM,FOCEAN,XYZD(IMJMNR,IU),TITLE(NR,IU), * JGRID(NR,IU), JBLK0(NR,IU),JDBLK(NR,IU), * DSCLJ(NR,IU),JLAND(NR,IU), JCBDT(NR,IU),UNNN) C**** C**** Receive keyboard input C**** 400 READ (5,940,END=750) ARG IF(ARG(1:1).eq.'Q' .or. ARG(1:1).eq.'q') GO TO 750 IF(ARG(1:1).eq.'A' .or. ARG(1:1).eq.'a') GO TO 410 IF(ARG(1:1).eq.'L' .or. ARG(1:1).eq.'l') GO TO 420 IF(ARG(1:1).eq.'O' .or. ARG(1:1).eq.'o') GO TO 430 IF(ARG(1:1).eq.'W' .or. ARG(1:1).eq.'w') GO TO 440 IF(ARG(1:1).eq.'B' .or. ARG(1:1).eq.'b') GO TO 450 IF(ARG(1:1).eq.'G' .or. ARG(1:1).eq.'g') GO TO 460 IF(ARG(1:1).eq.'R' .or. ARG(1:1).eq.'r') GO TO 470 IF(ARG(1:1).eq.'C' .or. ARG(1:1).eq.'c') GO TO 480 IF(ARG(1:1).eq.'S' .or. ARG(1:1).eq.'s') GO TO 490 IF(ARG(1:1).eq.'X' .or. ARG(1:1).eq.'x') GO TO 510 IF(ARG(1:1).eq.'Y' .or. ARG(1:1).eq.'y') GO TO 510 IF(ARG(1:1).eq.'Z' .or. ARG(1:1).eq.'z') GO TO 510 IF(ARG(1:1).eq.'D' .or. ARG(1:1).eq.'d') GO TO 550 IF(ARG(1:1).eq.'T' .or. ARG(1:1).eq.'t') GO TO 590 IF(ARG(1:1).eq.'N' .or. ARG(1:1).eq.'n') GO TO 600 IF(ARG(1:1).eq.'F' .or. ARG(1:1).eq.'f') GO TO 640 IF(ARG(1:1).eq.'P' .or. ARG(1:1).eq.'p') GO TO 650 GO TO 400 C**** A: display All grid boxes 410 JLAND(NR,IU) = 'A' GO TO 300 C**** L: display only Land grid boxes 420 JLAND(NR,IU) = 'L' GO TO 300 C**** O: display only Ocean grid boxes 430 JLAND(NR,IU) = 'O' GO TO 300 C**** W: display continental outline or unused boxes in White 440 JWHIT(NR,IU) = 'W' GO TO 400 C**** B: display continental outline or unused boxes in Black 450 JWHIT(NR,IU) = 'B' GO TO 400 C**** G: display data on different Grid 460 IF(ARG(2:2).eq.'A' .or. ARG(2:2).eq.'a') JGRID(NR,IU) = 'A' IF(ARG(2:2).eq.'B' .or. ARG(2:2).eq.'b') JGRID(NR,IU) = 'B' IF(ARG(2:2).eq.'U' .or. ARG(2:2).eq.'u') JGRID(NR,IU) = 'U' IF(ARG(2:2).eq.'V' .or. ARG(2:2).eq.'v') JGRID(NR,IU) = 'V' GO TO 300 C**** R: Rotate color plot I grid boxes to the left 470 READ (ARG(2:10),*,IOSTAT=IOSQ) I IF(IOSQ.eq.0) JROTA(NR,IU) = MOD(I+JROTA(NR,IU)+1000*IM,IM) GO TO 300 C**** C**** C: use new Color bar distribution table C**** 480 CALL PARSE (ARG(2:80),79,1,KMIN,KMAX) IF(KMAX(1).le.0) GO TO 400 IF(KMAX(1).gt.KMIN(1)+7) KMAX(1) = KMIN(1)+7 CPIJCB = ARG(1+KMIN(1):1+KMAX(1)) CALL LOADCB (CPIJCB,ICBDT,*400) JCBFN(NR,IU) = CPIJCB JCBDT(NR,IU) = ICBDT GO TO 400 C**** C**** S: use new scaling parameters C**** 490 DSCLK = 0. SCL0K = 0. READ (ARG(2:80),*,IOSTAT=IOSQ) KDBLK,DSCLK,KBLK0,SCL0K IF(DSCLK.eq.0. .or. (IOSQ.ne.0..and.IOSQ.ne.-2)) GO TO 491 JBLK0(NR,IU) = KBLK0 - NINT(KDBLK*SCL0K/DSCLK) JDBLK(NR,IU) = KDBLK DSCLJ(NR,IU) = DSCLK GO TO 300 491 WRITE (6,949) JDBLK(NR,IU),DSCLJ(NR,IU),JBLK0(NR,IU) GO TO 400 C**** C**** Display another record C**** 510 CALL NEWREC (ARG,6, NREC, IU,NR,UNNN, *400) NREC(IU) = NR GO TO 300 C**** C**** D: display a difference record C**** 550 IF(SCAN(ARG,'=').le.0) GO TO 510 C**** Calculate different record 551 ND = NRECM(4) + 1 IF(IM*JM*ND.gt.MAXIJR) GO TO 552 CALL DIFFER (ARG,IM*JM,NREC,ND,XYZD(1,4), *400) NR = ND IU = 4 NRECM(4) = NR NREC(4) = NR IMJMNR = 1 + IM*JM*(NR-1) CALL SPPEST (IM*JM, XYZD(IMJMNR,4),DSCLJ(NR,4), * JCBDT(NR,4),JROTA(NR,4),JBLK0(NR,4),JDBLK(NR,4), * JCBFN(NR,4),JGRID(NR,4),JLAND(NR,4),JWHIT(NR,4)) WRITE (UNNN,923) 'D',NR WRITE (6,930) UNNN // ARG(2:69) GO TO 300 C**** New D record exceeds internal dimension set by MAXIJR 552 WRITE (6,930) *'New D record exceeds internal dimension set by MAXIJR' GO TO 400 C**** C**** T: edit current title C**** 590 READ (5,940,END=750) ARG DO 591 K=1,80 591 IF(ARG(K:K).ne.'"') TITLE(NR,IU)(K:K) = ARG(K:K) GO TO 300 C**** C**** N: load New data file C**** 600 KU = 0 IF(ARG(2:2).eq.'X' .or. ARG(2:2).eq.'x') KU = 1 IF(ARG(2:2).eq.'Y' .or. ARG(2:2).eq.'y') KU = 2 IF(ARG(2:2).eq.'Z' .or. ARG(2:2).eq.'z') KU = 3 IF(KU.le.0) GO TO 400 IF(QOPEN(KU)) CLOSE (KU) QOPEN(KU) = .FALSE. CALL PARSE (ARG(3:80),78,2,KMIN,KMAX) CALL FILEEX (ARG(2+KMIN(1):2+KMAX(1)),KMAX(1)-KMIN(1)+1,FILEIN) OPEN (KU,FILE=FILEIN,FORM='UNFORMATTED',STATUS='OLD',ERR=603) QOPEN(KU) = .TRUE. DO 601 N=1,NRECM(KU) 601 JCBDT(N,KU) = 0 NRECM(KU) = 0 KN = 1 IF(KMAX(2).gt.0) READ (ARG(2+KMIN(2):2+KMAX(2)),*,IOSTAT=IOSQ) KN 602 CALL READIN (KU,KN,*400) IMJMKN = 1 + IM*JM*(KN-1) CALL MATCHI (IM*JM,XYZD(IMJMKN,KU),TITLE(KN,KU),JGRID(KN,KU), * JROTA(KN,KU),JBLK0(KN,KU),JDBLK(KN,KU),DSCLJ(KN,KU), * JLAND(KN,KU),JWHIT(KN,KU),JCBFN(KN,KU),JCBDT(KN,KU)) IU = KU NR = KN NREC(IU) = NR WRITE (UNNN,923) CHAR(Z'57'+IU),NR GO TO 300 603 WRITE (6,930) 'Unable to open file: ' // FILEIN(1:56) GO TO 400 C**** C**** F: write Files BWIJ2.O and BWIJ2.IF of title, data and parameters C**** 640 IF(QFOPEN) GO TO 641 OPEN (7,FILE='BWIJ2.O',FORM='UNFORMATTED') OPEN (8,FILE='BWIJ2.IF',FORM='FORMATTED') 641 WRITE (7) TITLE(NR,IU),(XYZD(I,IU),I=1+IM*JM*(NR-1),IM*JM*NR) WRITE (CDSCL,961) DSCLJ(NR,IU) IF(NINT(DSCLJ(NR,IU)*100.).eq.NINT(DSCLJ(NR,IU)*10.)*10) *WRITE (CDSCL,962) DSCLJ(NR,IU) IF(NINT(DSCLJ(NR,IU)*100.).eq.NINT(DSCLJ(NR,IU))*100) *WRITE (CDSCL,963) NINT(DSCLJ(NR,IU)) WRITE (8,964) TITLE(NR,IU)(1:32),JGRID(NR,IU),JROTA(NR,IU), * JDBLK(NR,IU),CDSCL,JBLK0(NR,IU),JLAND(NR,IU), * JWHIT(NR,IU),JCBFN(NR,IU) WRITE (6,930) * 'Files BWIJ2.O and BWIJ2.IF written for record: ' // UNNN GO TO 400 C**** C**** P: Print 1 or 2 records on color printer C**** 650 CALL PARSE (ARG(3:80),78,2,KMIN,KMAX) CALL NEWREC (ARG(2+KMIN(1):80),6, NREC, KU,KN,UNN2, *400) IF(.not.QPOPEN) OPEN (9,FILE='BWIJ2.PS') QPOPEN = .TRUE. IF(KMIN(2).le.0) WRITE (9,965) IF(KMIN(2).gt.0) WRITE (9,966) IMJMKN = 1 + IM*JM*(KN-1) CALL WRITPS (IM,JM,FOCEAN,XYZD(IMJMKN,KU),TITLE(KN,KU), * JGRID(KN,KU),JROTA(KN,KU),JBLK0(KN,KU),JDBLK(KN,KU), * DSCLJ(KN,KU),JLAND(KN,KU),JWHIT(KN,KU),JCBDT(KN,KU)) UNN3 = ' ' IF(KMIN(2).le.0) GO TO 651 CALL NEWREC (ARG(2+KMIN(2):80),6, NREC, KU,KN,UNN3, *653) WRITE (9,967) IMJMKN = 1 + IM*JM*(KN-1) CALL WRITPS (IM,JM,FOCEAN,XYZD(IMJMKN,KU),TITLE(KN,KU), * JGRID(KN,KU),JROTA(KN,KU),JBLK0(KN,KU),JDBLK(KN,KU), * DSCLJ(KN,KU),JLAND(KN,KU),JWHIT(KN,KU),JCBDT(KN,KU)) 651 WRITE (9,968) IF(ARG(2:2).eq.'P' .or. ARG(2:2).eq.'p') GO TO 652 WRITE (6,930) 'PostScript file BWIJ2.PS written containing: ' * // UNN2 // ' ' // UNN3 GO TO 400 652 CLOSE (9) QPOPEN = .FALSE. CALL SYSTEM ('lp -d pub6 BWIJ2.PS') WRITE (6,930) 'PostScript file BWIJ2.PS written and printed ' // * 'containing: ' // UNN2 // ' ' // UNN3 GO TO 400 653 WRITE (9,967) GO TO 400 C**** C**** Q: Quit BWIJ2 program C**** 750 IF(.not.QFOPEN) GO TO 751 CLOSE (7) CLOSE (8) 751 GO TO 999 C**** 800 WRITE (0,*) 'Usage: BWIJ2 [144x90] filex [filey filez] 99/02/26' GO TO 999 810 WRITE (0,*) ' Unable to open file: ',ARG(1:56) STOP 810 830 WRITE (0,*) ' File not found: ',ARG(1:16) STOP 830 C**** 923 FORMAT (A1,I3.3) 930 FORMAT (3X,A) 940 FORMAT (A) 949 FORMAT (' Current values:',I4,' = DBLK',F9.2,' = DSCL',I6, * ' = BLK0') 961 FORMAT (F6.2) 962 FORMAT (F6.1) 963 FORMAT (I6 ) 964 FORMAT (A32,A3,2I4,A6,I6,2A3,A10) 965 FORMAT ( *'%!PS BWIJ2.PS PostScript output file from BWIJ2 1999/02/26'/ *' .32 .32 scale 90 rotate 464 -940 translate') 966 FORMAT ( *'%!PS BWIJ2.PS PostScript output file from BWIJ2 1999/02/26'/ *' .24 .24 scale 456 2388 translate') 967 FORMAT (/'%%% Second record printed on bottom half of page' / * ' 0 -1436 translate') 968 FORMAT (/'showpage'/) 999 END SUBROUTINE READIN (IU,NR,*) C**** C**** READIN reads data from unit IU up to record NR C**** C**** NRECM = number of records read from file so far C**** PARAMETER (MAXREC=1800, MAXIJR=72*46*MAXREC) LOGICAL*4 QOPEN CHARACTER TITLE*80 COMMON /PARMCB/ IM,JM,NRECM(4),QOPEN(3) COMMON /DATACB/ XYZD(MAXIJR,4) COMMON /TITLCB/ TITLE(MAXREC,4) C**** IF(NR.le.NRECM(IU)) RETURN IF(.not.QOPEN(IU)) GO TO 800 IF(NR.gt.MAXREC) GO TO 810 IF(IM*JM*NR.gt.MAXIJR) GO TO 820 DO 10 N=NRECM(IU)+1,NR IMIN = IM*JM*(N-1) + 1 IMAX = IM*JM*N READ (IU,IOSTAT=IOSQ) TITLE(N,IU),(XYZD(I,IU),I=IMIN,IMAX) 10 IF(IOSQ.ne.0) GO TO 830 NRECM(IU) = NR RETURN C**** 800 WRITE (6,980) CHAR(Z'57'+IU),NRECM(IU) RETURN 1 810 WRITE (6,981) 'Requested record exceeds internal dimens' // * 'ion of the parameter MAXREC = 1800.' RETURN 1 820 WRITE (6,981) 'Requested record exceeds internal dimens' // * 'ion of the parameter MAXIJR.' RETURN 1 830 WRITE (6,983) N,CHAR(Z'57'+IU) CLOSE(IU) NRECM(IU) = N-1 QOPEN(IU) = .FALSE. RETURN 1 C**** 980 FORMAT (' File',A2,' was closed.',I6,' records were read in.') 981 FORMAT (3X,A) 983 FORMAT (' Error encountered reading record',I4,' of file',A2, * '. File is closed.') END SUBROUTINE MATCH0 C**** C**** MATCH0 loads data from the file BWIJ.I into CPIJoI common block C**** PARAMETER (MAXoI=1024) REAL*4 XYZD(*) CHARACTER TITLE*80, JGRID*1,JLAND*1,JWHIT*1, JCBFN*8, * TITLEI*32, IGRID*1,ILAND*1,IWHIT*1, ICBFN*8 COMMON /CPIJoI/ TITLEI(MAXoI),IGRID(MAXoI),IROTA(MAXoI), * IBLK0(MAXoI),IDBLK(MAXoI),DSCLI(MAXoI), * ILAND(MAXoI),IWHIT(MAXoI),ICBFN(MAXoI) C**** C**** TITLEI= matches first 32 characters of data record TITLE C**** IGRID = color plot displays specified grid: A, B, U or V C**** IROTA = color plot is rotated IROTA boxes to the left C**** IBLK0 = number of color blocks from 0 to bottom of color bar C**** IDBLK = number of color blocks between scale markers C**** DSCLI = scale difference between IDBLK color blocks C**** ILAND = color plot boxes show: A = All, L = land, O = ocean C**** IWHIT = continental outline or unused areas: W = white, B = black C**** ICBFN = file name of color bar distribution title C**** DATA IIMAX /0/ C**** C**** IIMAX = number of lines read from the file BWIJ.I C**** C**** Read in BWIJ.I C**** OPEN (4,FILE='BWIJ.I',STATUS='OLD',ERR=10) WRITE (0,*) 'File BWIJ.I read in.' GO TO 20 10 OPEN (4,FILE='/u/cmrun/BWIJ.I',STATUS='OLD',ERR=60) WRITE (0,*) 'File /u/cmrun/BWIJ.I read in.' 20 DO 30 I=1,4 30 READ (4,904) DO 40 I=1,MAXoI READ (4,904,IOSTAT=IOSQ) TITLEI(I),IGRID(I),IROTA(I),IDBLK(I), * DSCLI(I),IBLK0(I),ILAND(I),IWHIT(I),ICBFN(I) 40 IF(IOSQ.ne.0) GO TO 50 50 IIMAX = I-1 CLOSE (4) WRITE (0,*) 'File BWIJ.I contains',IIMAX,' lines of data.' IF(IIMAX.le.0) STOP 2043 RETURN 60 WRITE (0,*) 'Neither BWIJ.I nor /u/cmrun/BWIJ.I was found.' RETURN C**** C**** ENTRY MATCHI (IMxJM,XYZD,TITLE,JGRID,JROTA,JBLK0,JDBLK,DSCLJ, * JLAND,JWHIT,JCBFN,JCBDT) C**** C**** MATCHI matches the data record TITLE with TITLEIs in the file C**** BWIJ.I to get initial parameters for the color plot. C**** If the data record TITLE does not match any BWIJ.I TITLEI, C**** then the initial parameters are estimated. C**** IF(JCBDT.gt.0) RETURN DO 130 L=1,IIMAX DO 110 K=1,32 110 IF(TITLEI(L)(K:K).ne.TITLE(K:K) .and. TITLEI(L)(K:K).ne.'.') * GO TO 130 IF(ICBFN(L).eq.' ') GO TO 200 C**** TITLEI(L) matches TITLE JGRID = IGRID(L) JROTA = IROTA(L) JBLK0 = IBLK0(L) JDBLK = IDBLK(L) DSCLJ = DSCLI(L) JLAND = ILAND(L) JWHIT = IWHIT(L) JCBFN = ICBFN(L) CALL LOADCB (JCBFN,JCBDT,*120) RETURN C**** Desired color bar distribution table not found 120 JCBFN = 'ST12 ' JCBDT = 1 RETURN 130 continue GO TO 200 C**** C**** ENTRY SPPEST (IMxJM,XYZD,DSCLJ,JCBDT,JROTA,JBLK0,JDBLK, * JCBFN,JGRID,JLAND,JWHIT,*) C**** C**** SPPEST estimates the screen presentation parmeters C**** C**** C**** Estimate color plot parameters C**** 200 SMIN = 1.E20 SMAX = -1.E20 DO 210 IJ=1,IMxJM IF(XYZD(IJ).le.-999999.) GO TO 210 IF(XYZD(IJ).lt.SMIN) SMIN = XYZD(IJ) IF(XYZD(IJ).gt.SMAX) SMAX = XYZD(IJ) 210 continue JGRID = 'A' JROTA = 0 JBLK0 = 3 - 4*NINT(10.*SMIN/(SMAX-SMIN)) JDBLK = 4 DSCLJ = ROUND ((SMAX-SMIN)/11.) JLAND = 'A' JWHIT = 'B' JCBFN = 'ST12 ' JCBDT = 1 RETURN C**** 904 FORMAT (A32,A3,2I4,F6.0,I6,2A3,A10) END SUBROUTINE LOADCB (CPIJCB,ICBDT,*) C**** C**** LOADCB determines whether the current color bar distribution table C**** has been loaded. If it has not, then LOADCB reads the color bar C**** distribution table and loads its contents into the next unused row C**** of KCBDT. In all cases, LOADCB returns the index ICBDT which C**** points to the current color bar distribution table. C**** C**** CPIJCB = requested color bar distribution table C**** ICBDT = index pointing to color bar distribution table C**** PARAMETER (MAXBLK=64, MAXCB=64) C**** C**** MAXBLK = maximum number of color blocks in any color bar table C**** MAXCB = maximum number of color bar distribution tables C**** CHARACTER CPIJCB*8, CBDTFN*8, FILEIN*80 COMMON /CBDTCB/ KCBDT(MAXBLK,MAXCB),NBLKS(MAXCB),CBDTFN(MAXCB) DATA MCBDT /0/ C**** C**** KCBDT = contents of color bar distribution tables C**** NBLKS = number of blocks in each color bar distribution table C**** CBDTFN = file names of color bar distribution tables C**** MCBDT = number of color bar distribution tables loaded so far C**** DO 10 J=1,MCBDT ICBDT = J 10 IF(CPIJCB.eq.CBDTFN(J)) RETURN C**** C**** Read in new color bar distribution table from disk C**** IF(MCBDT.ge.MAXCB) GO TO 800 MCBDT = MCBDT + 1 FILEIN = 'BWIJCBDT/' // CPIJCB OPEN (4,FILE=FILEIN,STATUS='OLD',ERR=110) GO TO 120 110 FILEIN = '/u/cmrun/BWIJCBDT/' // CPIJCB OPEN (4,FILE=FILEIN,STATUS='OLD',ERR=810) 120 DO 130 K=1,3 130 READ (4,*,ERR=820) C**** Contents of file is in reverse order DO 140 K=1,MAXBLK 140 KCBDT(K,MCBDT) = -1 READ (4,*,END=150,ERR=150) (KCBDT(K,MCBDT),K=MAXBLK,1,-1) 150 CLOSE (4) C**** Move loaded data into memory KCBDT(1,MCBDT) to KCBDT(NBLKS,MCBDT) KOFF = 0 DO 160 K=1,MAXBLK IF(KCBDT(K,MCBDT).ge.0) THEN KCBDT(K-KOFF,MCBDT) = KCBDT(K,MCBDT) ELSE KOFF = KOFF + 1 ENDIF 160 continue NBLKS(MCBDT) = MAXBLK-KOFF CBDTFN(MCBDT) = CPIJCB ICBDT = MCBDT RETURN C**** 800 WRITE (6,980) 'Number of color bar distribution tables ' // * 'exceeds internal dimension MAXCB.' RETURN 1 810 WRITE (6,980) 'Neither ' // FILEIN(10:25) // ' nor ' // * FILEIN(1:25) // ' was found.' RETURN 1 820 WRITE (6,980) 'Color bar distribution table is empty: ' // * FILEIN(1:25) RETURN 1 980 FORMAT (3X,A) END SUBROUTINE CPIJ (IM,JM,FOCEAN,XYZD,TITLE,JGRID, * JBLK0,JDBLK,DSCLJ,JLAND, JCBDT,UNNN) C**** C**** CPIJ write data minimum and maximum and scale values to unit 6 C**** C**** IM,JM = horizontal resolution C**** FOCEAN= ocean fraction array C**** XYZD = grid point data to be plotted C**** TITLE = title at top of plot C**** JGRID = type of grid, all data is assumed to be on A grid C**** JBLK0 = number of color blocks from bottom of scale to 0 C**** JDBLK = number of color blocks between scale markers C**** DSCLJ = scale difference between scale markers C**** JLAND = color plot boxes show: A = all, L = land, O = ocean C**** JCBDT = index pointing to color bar distribution table C**** UNNN = character describing data file and record number C**** PARAMETER (MAXBLK=64, MAXCB=64) REAL*4 FOCEAN(IM,JM),XYZD(IM,JM) CHARACTER TITLE*80, JGRID*1,JLAND*1, UNNN*4 COMMON /CBDTCB/ KCBDT(MAXBLK,MAXCB),NBLKS(MAXCB) C**** Calculate data minimum and maximum XYZMIN = 1.E30 XYZMAX = -1.E30 DO 110 I=1,IM*JM IF((JLAND.eq.'O' .and. FOCEAN(I,1).le..5) .or. * (JLAND.eq.'L' .and. FOCEAN(I,1).gt..5)) GO TO 110 IF(XYZD(I,1).lt.XYZMIN) XYZMIN = XYZD(I,1) IF(XYZD(I,1).gt.XYZMAX) XYZMAX = XYZD(I,1) 110 continue C**** Calculate scale minimum and maximum MBLK = NBLKS(JCBDT) JB1 = 1 + MOD(JBLK0+100000*JDBLK-1,JDBLK) JBM = JB1 + JDBLK*((MBLK-1-JB1)/JDBLK) VALMIN = (JB1-JBLK0)*DSCLJ/JDBLK VALMAX = (JBM-JBLK0)*DSCLJ/JDBLK C**** Display TITLE above the data WRITE (6,931) TITLE(1:79) WRITE (6,932) XYZMIN,XYZMAX,VALMIN,VALMAX,UNNN RETURN C**** 931 FORMAT (A) 932 FORMAT (' Data:',F8.2,' to',F8.2, * ' Scale:',F8.2,' to',F8.2,6X,A4) END SUBROUTINE WRITPS (IM,JM,FOCEAN,XYZD,TITLE,JGRID,JROTA, * JBLK0,JDBLK,DSCLJ,JLAND,JWHIT,JCBDT) C**** C**** Write PostScript file for record KN from unit KU. C**** C**** IM,JM = horizontal resolution C**** FOCEAN= ocean fration array C**** XYZD = grid point data to be plotted C**** TITLE = title at top of plot C**** JGRID = type of grid, all data is assumed to be on A grid C**** JROTA = color plot is rotated JROTA boxes to the left C**** JBLK0 = number of color blocks from bottom of scale to 0 C**** JDBLK = number of color blocks between scale markers C**** DSCLJ = scale difference between scale markers C**** JLAND = color plot boxes show: A = all, L = land, O = ocean C**** JWHIT = continental outline or unused areas: W = white, B = black C**** JCBDT = index pointing to color bar distribution table C**** UNNN = character describing data file and record number C**** PARAMETER (MAXBLK=64, MAXCB=64) REAL*4 FOCEAN(IM,JM),XYZD(IM,JM) INTEGER*4 KCOLOR(360),IEDGE(360) CHARACTER TITLE*80, JGRID*1,JLAND*1,JWHIT*1, CBAR*8, PATHS*60 COMMON /PATHCB/ PATHS(157) COMMON /CBDTCB/ KCBDT(MAXBLK,MAXCB),NBLKS(MAXCB) C**** C**** Define spatial parameters C**** DX = 1728./IM DY = 1104./JM JEQ = JM/2 WRITE (9,900) IM,JM,DX,DY C**** C**** Write PATHS array to PostScript file C**** WRITE (9,915) PATHS C**** C**** Write title to PostScript file C**** YTITLE = DY*JEQ + 24. LEN = LEN_TRIM(TITLE) WRITE (9,920) YTITLE,TITLE(1:LEN) C**** C**** Write longitude by latitude plot to PostScript file C**** WRITE (9,930) Y = -DY*JEQ DO 320 J=1,JM WRITE (9,931) J IRDIF=JROTA DO 310 IR=1,IM IF(IR+JROTA.eq.IM+1) IRDIF=JROTA-IM KCOLOR(IR) = 0 IF( JWHIT.eq.'B') KCOLOR(IR) = 32 IF((JLAND.eq.'O' .and. FOCEAN(IR+IRDIF,J).le..5) .or. * (JLAND.eq.'L' .and. FOCEAN(IR+IRDIF,J).gt..5)) GO TO 310 KBLK = INT(XYZD(IR+IRDIF,J)*JDBLK/DSCLJ + JBLK0-MAXBLK) + MAXBLK IF(KBLK.le.0 ) KBLK = 1 IF(KBLK.gt.NBLKS(JCBDT)) KBLK = NBLKS(JCBDT) KCOLOR(IR) = KCBDT(KBLK,JCBDT)*2 - MOD(IR+IRDIF+J,2) IF(KCOLOR(IR).lt.0) KCOLOR(IR) = 0 310 continue WRITE (9,932) (KCOLOR(IR),IR=1,IM) WRITE (9,933) Y 320 Y = Y + DY 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) DX,DY C**** East-west continental edges WRITE (9,941) KPEDGE,.2 DO 430 J=1,JM-1 NEDGES = 0 IRDIF=JROTA DO 420 IR=1,IM IF(IR.eq.IM+1) IRDIF=JROTA-IM IF(FOCEAN(IR+IRDIF,J ).gt..5 .xor. * FOCEAN(IR+IRDIF,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) J-JEQ,J, (IEDGE(N),N=1,NEDGES) WRITE (9,943) NEDGES 430 continue C**** North-south continental edges WRITE (9,941) KPEDGE,.2 DO 450 J=2,JM-1 NEDGES = 0 I=1+JROTA DO 440 IR=1,IM-1 IP1=I+1 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,944) J-JEQ,J, (IEDGE(N),N=1,NEDGES) WRITE (9,945) NEDGES 450 continue WRITE (9,*) ' grestore' C**** C**** Write shadebar to PostScript file C**** 500 JBAR0 = -(NBLKS(JCBDT)/2)*24 WRITE (9,950) JBAR0 DO 510 N=1,NBLKS(JCBDT) KCOLOR(N) = KCBDT(N,JCBDT)*2 - MOD(N,2) 510 IF(KCOLOR(N).lt.0.) KCOLOR(N) = 0 WRITE (9,932) (KCOLOR(N),N=1,NBLKS(JCBDT)) WRITE (9,951) NBLKS(JCBDT) C**** Write shadebar labels WRITE (9,952) JB1 = 1 + MOD(JBLK0+100000*JDBLK-1,JDBLK) DO 560 JB=JB1,NBLKS(JCBDT)-1,JDBLK JBAR = JB*24 + JBAR0 VALU = (JB-JBLK0)*DSCLJ/JDBLK WRITE (CBAR,953) VALU IF(NINT(DSCLJ*100.).eq.NINT(DSCLJ*10.)*10) WRITE (CBAR,954) VALU IF(NINT(DSCLJ*100.).eq.NINT(DSCLJ)*100)WRITE (CBAR,955) NINT(VALU) 560 WRITE (9,956) JBAR-12,CBAR C**** C**** Write surrounding rectangle to PostScript file C**** Y = -DY*JEQ - 2. DYJM = -2.*Y WRITE (9,960) Y,DYJM C**** C**** Write NASA/GISS logo to PostScript file C**** Y = -DY*JEQ - 4. WRITE (9,970) Y-1.,Y RETURN C**** 900 FORMAT (/'%%% Parameters:' / ' /IM',I4,' def /JM',I4,' def', * ' /DX',F7.2,' def /DY',F7.2,' def') 915 FORMAT (/'%%% Load the graphic PATHS array' / (4X,A60)) 920 FORMAT (/'%%% Produce TITLE' / * ' /Helvetica-Bold findfont 64 scalefont setfont' / * ' 0',F7.2,' moveto' / '(',A,')' / ' gsave ', * 'dup stringwidth pop 1728 exch div 1 scale show grestore') 930 FORMAT (/'%%% GRIDBOX procedure for each grid box' / * ' /GRIDBOX { gsave 1 sub DX mul Y translate DX DY scale' / * ' PATHS exch get exec fill grestore } def') 931 FORMAT ('%%% Data for J =',I4) 932 FORMAT (24I3) 933 FORMAT (' /Y',F8.2,' def IM -1 1 {GRIDBOX} for') 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' / * ' 1 setlinecap gsave ',2F7.2,' scale') 941 FORMAT (/I5,' setgray',F7.3,' setlinewidth' /) 942 FORMAT ('/Y',I4,' def %%% East-west edges for J =',I4 / (18I4)) 943 FORMAT (' 1 1',I4,' {IEDGE} for') 944 FORMAT ('/Y',I4,' def %%% North-south edges for J =',I4 /(18I4)) 945 FORMAT (' 1 1',I4,' {JEDGE} for') 950 FORMAT (/'%%% SHADEBAR procedure for each shade table value' / * ' /SHADEBAR { gsave 1 sub 0 exch translate' / * ' PATHS exch get exec fill grestore } def' / * /'%%% Draw Shadebar to left of data' / * ' gsave -56',I5,' translate 24 24 scale') 951 FORMAT (I6,' -1 1 {SHADEBAR} for grestore') 952 FORMAT ('%%% Label the Shadebar' / * ' /Helvetica-Bold findfont 48 scalefont setfont 0 setgray') 953 FORMAT (F7.2,'-') 954 FORMAT (F7.1,'-') 955 FORMAT (I7 ,'-') 956 FORMAT (' -348',I5,' moveto (',A8,') dup stringwidth pop' / * ' 288 exch sub 0 rmoveto show') 960 FORMAT (/'%%% Draw surrounding rectangle' / * ' 4 setlinewidth newpath -2',F8.2,' moveto' / * ' 1732 0 rlineto 0',F8.2,' rlineto -1732 0 rlineto' / * ' closepath stroke') 970 FORMAT (/'%%% Draw NASA/GISS logo' / * ' /Helvetica-Bold findfont 32 scalefont setfont' / * ' newpath 1548',F8.2,' moveto' / * ' 184 0 rlineto 0 31 rlineto -184 0 rlineto closepath' / * ' 1 setgray fill' / * ' 1556',F8.2,' moveto 0 setgray (NASA/GISS) show') 981 FORMAT (3X,A) END BLOCK DATA C**** C**** PATHCB contains the PostScript closed paths that surround the C**** different thickness line segments that fit into a unit square C**** CHARACTER*60 PATH02(13),PATH04(8),PATH06(12),PATH08(8), * PATH10(12),PATH12(8),PATH14(12),PATH16(8), * PATH18(12),PATH20(8),PATH22(12),PATH24(8), * PATH26(12),PATH28(8),PATH30(12),PATH32(4) COMMON /PATHCB/ PATH02,PATH04,PATH06,PATH08, * PATH10,PATH12,PATH14,PATH16, * PATH18,PATH20,PATH22,PATH24, * PATH26,PATH28,PATH30,PATH32 C**** Paths 0, 1 and 2 DATA PATH02 / *'/PATHS [ { newpath closepath } % 0', *'{ newpath .31250 0 moveto .35417 0 lineto % 1', *' 1 .64583 lineto 1 .68750 lineto closepath ', *' .68750 1 moveto .64583 1 lineto ', *' 0 .35417 lineto 0 .31250 lineto closepath ', *'1 0 moveto 1 .02083 lineto .97917 0 lineto closepath ', *'0 1 moveto 0 .97917 lineto .02083 1 lineto closepath }', *'{ newpath .64583 0 moveto .68750 0 lineto % 2', *' 1 .31250 lineto 1 .35417 lineto closepath ', *' .35417 1 moveto .31250 1 lineto ', *' 0 .68750 lineto 0 .64583 lineto closepath ', *'0 0 moveto 0 .02083 lineto .97917 1 lineto ', *'1 1 lineto 1 .97917 lineto .02083 0 lineto closepath }'/ C**** Paths 3 and 4 DATA PATH04 / *'{ newpath .21875 0 moveto .28125 0 lineto % 3', *' .28125 1 lineto .21875 1 lineto closepath ', *' .71875 0 moveto .78125 0 lineto ', *' .78125 1 lineto .71875 1 lineto closepath }', *'{ newpath .21875 0 moveto .28125 0 lineto % 4', *' .28125 1 lineto .21875 1 lineto closepath ', *' .71875 0 moveto .78125 0 lineto ', *' .78125 1 lineto .71875 1 lineto closepath }'/ C**** Paths 5 and 6 DATA PATH06 / *'{ newpath .60417 0 moveto .72917 0 lineto % 5', *' 0 .72917 lineto 0 .60417 lineto closepath ', *' .39583 1 moveto .27083 1 lineto ', *' 1 .27083 lineto 1 .39583 lineto closepath ', *'0 0 moveto .06250 0 lineto 0 .06250 lineto closepath ', *'1 1 moveto .93750 1 lineto 1 .93750 lineto closepath }', *'{ newpath .27083 0 moveto .39583 0 lineto % 6', *' 0 .39583 lineto 0 .27083 lineto closepath ', *' .72917 1 moveto .60417 1 lineto ', *' 1 .60417 lineto 1 .72917 lineto closepath ', *'1 0 moveto 1 .06250 lineto .06250 1 lineto ', *'0 1 lineto 0 .93750 lineto .93750 0 lineto closepath }'/ C**** Paths 7 and 8 DATA PATH08 / *'{ newpath 0 .81250 moveto 0 .68750 lineto % 7', *' 1 .68750 lineto 1 .81250 lineto closepath ', *' 0 .31250 moveto 0 .18750 lineto ', *' 1 .18750 lineto 1 .31250 lineto closepath }', *'{ newpath 0 .81250 moveto 0 .68750 lineto % 8', *' 1 .68750 lineto 1 .81250 lineto closepath ', *' 0 .31250 moveto 0 .18750 lineto ', *' 1 .18750 lineto 1 .31250 lineto closepath }'/ C**** Paths 9 and 10 DATA PATH10 / *'{ newpath .22917 0 moveto .43750 0 lineto % 9', *' 1 .56250 lineto 1 .77083 lineto closepath ', *' .77083 1 moveto .56250 1 lineto ', *' 0 .43750 lineto 0 .22917 lineto closepath ', *'1 0 moveto 1 .10417 lineto .89583 0 lineto closepath ', *'0 1 moveto 0 .89583 lineto .10417 1 lineto closepath }', *'{ newpath .56250 0 moveto .77083 0 lineto %10', *' 1 .22917 lineto 1 .43750 lineto closepath ', *' .43750 1 moveto .22917 1 lineto ', *' 0 .77083 lineto 0 .56250 lineto closepath ', *'0 0 moveto 0 .10417 lineto .89583 1 lineto ', *'1 1 lineto 1 .89583 lineto .10417 0 lineto closepath }'/ C**** Paths 11 and 12 DATA PATH12 / *'{ newpath .15625 0 moveto .35417 0 lineto %11', *' .35417 1 lineto .15625 1 lineto closepath ', *' .64583 0 moveto .84375 0 lineto ', *' .84375 1 lineto .64583 1 lineto closepath }', *'{ newpath .15625 0 moveto .35417 0 lineto %12', *' .35417 1 lineto .15625 1 lineto closepath ', *' .64583 0 moveto .84375 0 lineto ', *' .84375 1 lineto .64583 1 lineto closepath }'/ C**** Paths 13 and 14 DATA PATH14 / *'{ newpath .52083 0 moveto .81250 0 lineto %13', *' 0 .81250 lineto 0 .52083 lineto closepath ', *' .47917 1 moveto .18750 1 lineto ', *' 1 .18750 lineto 1 .47917 lineto closepath ', *'0 0 moveto .14583 0 lineto 0 .14583 lineto closepath ', *'1 1 moveto .85417 1 lineto 1 .85417 lineto closepath }', *'{ newpath .18750 0 moveto .47917 0 lineto %14', *' 0 .47917 lineto 0 .18750 lineto closepath ', *' .81250 1 moveto .52083 1 lineto ', *' 1 .52083 lineto 1 .81250 lineto closepath ', *'1 0 moveto 1 .14583 lineto .14583 1 lineto ', *'0 1 lineto 0 .85417 lineto .85417 0 lineto closepath }'/ C**** Paths 15 and 16 DATA PATH16 / *'{ newpath 0 .87500 moveto 0 .62500 lineto %15', *' 1 .62500 lineto 1 .87500 lineto closepath ', *' 0 .37500 moveto 0 .12500 lineto ', *' 1 .12500 lineto 1 .37500 lineto closepath }', *'{ newpath 0 .87500 moveto 0 .62500 lineto %16', *' 1 .62500 lineto 1 .87500 lineto closepath ', *' 0 .37500 moveto 0 .12500 lineto ', *' 1 .12500 lineto 1 .37500 lineto closepath }'/ C**** Paths 17 and 18 DATA PATH18 / *'{ newpath .14583 0 moveto .52083 0 lineto %17', *' 1 .47917 lineto 1 .85417 lineto closepath ', *' .85417 1 moveto .47917 1 lineto ', *' 0 .52083 lineto 0 .14583 lineto closepath ', *'1 0 moveto 1 .18750 lineto .81250 0 lineto closepath ', *'0 1 moveto 0 .81250 lineto .18750 1 lineto closepath }', *'{ newpath .47917 0 moveto .85417 0 lineto %18', *' 1 .14583 lineto 1 .52083 lineto closepath ', *' .52083 1 moveto .14583 1 lineto ', *' 0 .85417 lineto 0 .47917 lineto closepath ', *'0 0 moveto 0 .18750 lineto .81250 1 lineto ', *'1 1 lineto 1 .81250 lineto .18750 0 lineto closepath }'/ C**** Paths 19 and 20 DATA PATH20 / *'{ newpath .09375 0 moveto .40625 0 lineto %19', *' .40625 1 lineto .09375 1 lineto closepath ', *' .59375 0 moveto .90625 0 lineto ', *' .90625 1 lineto .59375 1 lineto closepath }', *'{ newpath .09375 0 moveto .40625 0 lineto %20', *' .40625 1 lineto .09375 1 lineto closepath ', *' .59375 0 moveto .90625 0 lineto ', *' .90625 1 lineto .59375 1 lineto closepath }'/ C**** Paths 21 and 22 DATA PATH22 / *'{ newpath .43750 0 moveto .89583 0 lineto %21', *' 0 .89583 lineto 0 .43750 lineto closepath ', *' .56250 1 moveto .10417 1 lineto ', *' 1 .10417 lineto 1 .56250 lineto closepath ', *'0 0 moveto .22917 0 lineto 0 .22917 lineto closepath ', *'1 1 moveto .77083 1 lineto 1 .77083 lineto closepath }', *'{ newpath .10417 0 moveto .56250 0 lineto %22', *' 0 .56250 lineto 0 .10417 lineto closepath ', *' .89583 1 moveto .43750 1 lineto ', *' 1 .43750 lineto 1 .89583 lineto closepath ', *'1 0 moveto 1 .22917 lineto .22917 1 lineto ', *'0 1 lineto 0 .77083 lineto .77083 0 lineto closepath }'/ C**** Paths 23 and 24 DATA PATH24 / *'{ newpath 0 .94375 moveto 0 .55625 lineto %23', *' 1 .55625 lineto 1 .94375 lineto closepath ', *' 0 .44375 moveto 0 .05625 lineto ', *' 1 .05625 lineto 1 .44375 lineto closepath }', *'{ newpath 0 .94375 moveto 0 .55625 lineto %24', *' 1 .55625 lineto 1 .94375 lineto closepath ', *' 0 .44375 moveto 0 .05625 lineto ', *' 1 .05625 lineto 1 .44375 lineto closepath }'/ C**** Paths 25 and 26 DATA PATH26 / *'{ newpath .06250 0 moveto .60417 0 lineto %25', *' 1 .39583 lineto 1 .93750 lineto closepath ', *' .93750 1 moveto .39583 1 lineto ', *' 0 .60417 lineto 0 .06250 lineto closepath ', *'1 0 moveto 1 .27083 lineto .72917 0 lineto closepath ', *'0 1 moveto 0 .72917 lineto .27083 1 lineto closepath }', *'{ newpath .39583 0 moveto .93750 0 lineto %26', *' 1 .06250 lineto 1 .60417 lineto closepath ', *' .60417 1 moveto .06250 1 lineto ', *' 0 .93750 lineto 0 .39583 lineto closepath ', *'0 0 moveto 0 .27083 lineto .72917 1 lineto ', *'1 1 lineto 1 .72917 lineto .27083 0 lineto closepath }'/ C**** Paths 27 and 28 DATA PATH28 / *'{ newpath .03125 0 moveto .46875 0 lineto %27', *' .46875 1 lineto .03125 1 lineto closepath ', *' .53125 0 moveto .96875 0 lineto ', *' .96875 1 lineto .53125 1 lineto closepath }', *'{ newpath .03125 0 moveto .46875 0 lineto %28', *' .46875 1 lineto .03125 1 lineto closepath ', *' .53125 0 moveto .96875 0 lineto ', *' .96875 1 lineto .53125 1 lineto closepath }'/ C**** Paths 29 and 30 DATA PATH30 / *'{ newpath .35417 0 moveto .97917 0 lineto %29', *' 0 .97917 lineto 0 .35417 lineto closepath ', *' .64583 1 moveto .02083 1 lineto ', *' 1 .02083 lineto 1 .64583 lineto closepath ', *'0 0 moveto .31250 0 lineto 0 .31250 lineto closepath ', *'1 1 moveto .68750 1 lineto 1 .68750 lineto closepath }', *'{ newpath .02083 0 moveto .64583 0 lineto %30', *' 0 .64583 lineto 0 .02083 lineto closepath ', *' .97917 1 moveto .35417 1 lineto ', *' 1 .35417 lineto 1 .97917 lineto closepath ', *'1 0 moveto 1 .31250 lineto .31250 1 lineto ', *'0 1 lineto 0 .68750 lineto .68750 0 lineto closepath }'/ C**** Paths 31 and 32 DATA PATH32 / *'{ newpath 0 0 moveto 1 0 lineto %31', *' 1 1 lineto 0 1 lineto closepath } ', *'{ newpath 0 0 moveto 1 0 lineto %32', *' 1 1 lineto 0 1 lineto closepath } ] def '/ END SUBROUTINE PARSE (S,LENS,NTOK,KMIN,KMAX) C**** C**** PARSE parses a character string S of length LENS into its first C**** NTOK tokens. KMIN(n) and KMAX(n) are the first and last C**** characters of S for the n-th token. C**** INTEGER*4 KMIN(*),KMAX(*) CHARACTER S*(*) N = 0 K = 0 10 IF(N.ge.NTOK) RETURN N = N + 1 C**** Skip over blank characters between tokens 20 IF(K.ge.LENS) GO TO 50 K = K + 1 IF(S(K:K).eq.' ') GO TO 20 KMIN(N) = K C**** Contiguous nonblank characters are part of the token 30 IF(K.ge.LENS) GO TO 40 K = K + 1 IF(S(K:K).ne.' ') GO TO 30 KMAX(N) = K-1 GO TO 10 40 KMAX(N) = K N = N + 1 C**** Remaining tokens were not included in the string 50 DO 60 N0=N,NTOK KMIN(N0) = 0 60 KMAX(N0) = 0 RETURN END SUBROUTINE NEWREC (S,LENS, NREC, IU,NR,UNNN, *) C**** C**** NEWREC decodes the token S into a file and a record number, C**** and checks that the record is available C**** C**** Input: S = string containing X,Y,Z,D and/or record number C**** LENS = # of characters in string S C**** NREC = most recently dispaled records of files X, Y or Z C**** Output: IU = unit number 1,2,3,4 corresponding to X,Y,Z,D C**** NR = record numbr of unit IU determined from S and/or NREC C**** UNNN = 4 byte character string showing file and record numbr C**** PARAMETER (MAXREC=1800, MAXIJR=72*46*MAXREC) INTEGER*4 NREC(4) CHARACTER S*(LENS), UNNN*4 CHARACTER TITLE*80, JGRID*1,JLAND*1,JWHIT*1, JCBFN*8 COMMON /PARMCB/ IM,JM,NRECM(4),QOPEN(3) COMMON /DATACB/ XYZD(MAXIJR,4) COMMON /TITLCB/ TITLE(MAXREC,4),DSCLJ(MAXREC,4), * JCBDT(MAXREC,4),JROTA(MAXREC,4),JBLK0(MAXREC,4),JDBLK(MAXREC,4), * JCBFN(MAXREC,4),JGRID(MAXREC,4),JLAND(MAXREC,4),JWHIT(MAXREC,4) C**** IF(S(1:1).eq.'D' .or. S(1:1).eq.'d') GO TO 10 C**** File is X, Y or Z KU = 0 IF(S(1:1).eq.'X' .or. S(1:1).eq.'x') KU = 1 IF(S(1:1).eq.'Y' .or. S(1:1).eq.'y') KU = 2 IF(S(1:1).eq.'Z' .or. S(1:1).eq.'z') KU = 3 IF(KU.eq.0) GO TO 810 IF(NRECM(KU).le.0) GO TO 820 KN = NREC(KU) IOSQ = 0 IF(S(2:2).ne.' ') READ (S(2:LENS),*,IOSTAT=IOSQ) KN IF(IOSQ.ne.0) GO TO 830 CALL READIN (KU,KN,*800) IMJMKN = 1 + IM*JM*(KN-1) CALL MATCHI (IM*JM,XYZD(IMJMKN,KU),TITLE(KN,KU),JGRID(KN,KU), * JROTA(KN,KU),JBLK0(KN,KU),JDBLK(KN,KU),DSCLJ(KN,KU), * JLAND(KN,KU),JWHIT(KN,KU),JCBFN(KN,KU),JCBDT(KN,KU)) IU = KU NR = KN WRITE (UNNN,900) CHAR(Z'57'+IU),MOD(NR,1000) IF(NR.gt.999) UNNN(2:2) = CHAR(Z'37'+NR/100) RETURN C**** File is D 10 KN = NREC(4) IOSQ = 0 IF(S(2:2).ne.' ') READ (S(2:LENS),*,IOSTAT=IOSQ) KN IF(IOSQ.ne.0) GO TO 830 IF(KN.gt.NRECM(4)) GO TO 840 IU = 4 NR = KN WRITE (UNNN,900) 'D',MOD(NR,1000) IF(NR.gt.999) UNNN(2:2) = CHAR(Z'37'+NR/100) RETURN C**** 800 RETURN 1 810 WRITE (6,981) 'File should be X, Y, Z or D. Not: ' // S RETURN 1 820 WRITE (6,981) S(1:1) // ' file was never opened.' RETURN 1 830 WRITE (6,981) 'Integer record number should follow file: ' // S RETURN 1 840 WRITE (6,981) 'Requested difference record is not defined: '// S RETURN 1 C**** 900 FORMAT (A1,I3.3) 981 FORMAT (3X,A) END SUBROUTINE FILEEX (FIN,LENF,FEX) C**** C**** FILEEX expands a filename FIN by environment variables defined C**** in the user's .profile file. C**** CHARACTER FIN*80, FEX*80 IF(FIN(1:1).eq.'$') GO TO 10 FEX = FIN(1:LENF) RETURN C**** Leading $ was found, determine / or . 10 DO 20 K=3,LENF 20 IF(FIN(K:K).eq.'/' .or. FIN(K:K).eq.'.') GO TO 30 FEX = FIN(1:LENF) RETURN C**** Internal / or . was found 30 KSLASH = K CALL GETENV (FIN(2:KSLASH-1),FEX) IF(FEX(1:1).gt.' ') GO TO 40 FEX = FIN(1:LENF) RETURN C**** Insert the rest of FIN into the output filename FEX 40 LENE = LEN_TRIM(FEX) FEX(LENE+1:80) = FIN(KSLASH:LENF) RETURN 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 DIFFER (ARG,IMxJM,NREC,ND,DDDD, *) C**** C**** D =: calculate a Different record C**** PARAMETER (MAXREC=1800, MAXIJR=72*46*MAXREC) INTEGER*4 NREC(4) CHARACTER ARG*80, UQQQ*4, * TITLE*80, JCBFN*8, JGRID,JLAND,JWHIT, TEXT*80 REAL*4 DDDD(IMxJM,*) COMMON /DATACB/ XYZD(MAXIJR,4) COMMON /TITLCB/ TITLE(MAXREC,4),DSCLJ(MAXREC,4), * JCBDT(MAXREC,4),JROTA(MAXREC,4),JBLK0(MAXREC,4),JDBLK(MAXREC,4), * JCBFN(MAXREC,4),JGRID(MAXREC,4),JLAND(MAXREC,4),JWHIT(MAXREC,4) C**** DO 10 I=1,IMxJM 10 DDDD(I,ND) = 0. NQ = 0 C**** KEQU = SCAN(ARG,'=') KMAX = LEN_TRIM(ARG) 20 KMAX = LEN_TRIM(ARG(1:KMAX)) IF(KEQU.ge.KMAX) GO TO 80 KR = SCAN(ARG(KEQU+1:KMAX),'XYZDxyzd',.TRUE.) KS = SCAN(ARG(KEQU+1:KMAX),'+-',.TRUE.) KT = SCAN(ARG(KEQU+1:KMAX),'*',.TRUE.) IF(KT.gt.KS) GO TO 60 IF(KR.gt.KS) GO TO 40 C**** Current term is a signed constant READ (ARG(KEQU+KS+1:KMAX),*,ERR=90) FAC IF(ARG(KEQU+KS:KEQU+KS).eq.'-') FAC = -FAC DO 30 I=1,IMxJM 30 DDDD(I,ND) = DDDD(I,ND) + FAC KMAX = KEQU + KS - 1 GO TO 20 C**** Current term is a signed data record 40 LENS = KMAX-KEQU-KR+1 CALL NEWREC (ARG(KEQU+KR:KMAX),LENS, NREC, IQ,NQ,UQQQ, *91) FAC = 1. IF(ARG(KEQU+KS:KEQU+KS).eq.'-') FAC = -1. DO 50 I=1,IMxJM 50 DDDD(I,ND) = DDDD(I,ND) + FAC*XYZD(I+IMxJM*(NQ-1),IQ) KMAX = KEQU + KS - 1 GO TO 20 C**** Current term is a signed number times a data record 60 LENS = KMAX-KEQU-KR+1 CALL NEWREC (ARG(KEQU+KR:KMAX),LENS, NREC, IQ,NQ,UQQQ, *91) READ (ARG(KEQU+KS+1:KEQU+KT-1),*,ERR=90) FAC IF(ARG(KEQU+KS:KEQU+KS).eq.'-') FAC = -FAC DO 70 I=1,IMxJM 70 DDDD(I,ND) = DDDD(I,ND) + FAC*XYZD(I+IMxJM*(NQ-1),IQ) KMAX = KEQU + KS - 1 GO TO 20 C**** 80 IF(NQ.gt.0.) TITLE(ND,4) = TITLE(NQ,IQ) TITLE(ND,4)(47:50) = 'DIFF' RETURN C**** Invalid format 90 WRITE (6,*) ' Invalid format for Different record.' 91 RETURN 1 END BLOCK DATA C**** C**** Default values for PARMCB C**** LOGICAL*4 QOPEN COMMON /PARMCB/ IM,JM,NRECM(4),QOPEN(3) C**** C**** IM,JM = longitude and latitude horizontal resolution C**** NRECM = number of records read from data file so far C**** NRECM(4) = number of difference records calculated so far C**** QOPEN = whether data file is currently open C**** C**** DATA IM,JM/72,46/, NRECM/4*0/, QOPEN/3*.FALSE./ END