c--------( PLMAPCL : Plot color-contour map with Line loc. )-------- parameter (MAXSZ=3001*3001) c dimension g(MAXSZ) character*80 wdr, flog, fnin, fnln, fnam character area*8, s4*4, yn*1, spl*3/' '/ character out*72, buf*80, sdtm*20 external cviken c call premsg('PLMAPCL : plot color-contour map with Line loc.') call opnpin() ldr = lwkdir(50,wdr) + 1 flog = wdr fnin = wdr fnln = wdr fnam = wdr call gparma('Enter LOG filename ==> ', 81-ldr, flog(ldr:80)) call gparma('Enter Input data filename ==> ', * 81-ldr, fnin(ldr:80)) open(10,file=fnin,status='old') call gparma('Enter StdLIN filename ==> ', * 81-ldr, fnln(ldr:80)) open(11,file=fnln,status='old') call gparma('Enter Output PS filename ==> ', * 81-ldr, fnam(ldr:80)) if (fnam(ldr:ldr).eq.' ') fnam(1:1) = char(0) if (fnam(80:80).ne.' ') then call abendm('too long filename') endif open(9,status='scratch') c 1 read(10,'(a)',end=8) buf if(buf(1:1).eq.'#') goto 1 2 read(buf,'(a8,i4,4x,4i8)') area, ncc, iorg, korg, ispa, ispb if(ncc.ge.200) then mc = 1 nc = ncc - 200 else mc = 0 nc = ncc endif if(nc.ge.1.and.nc.le.62) then iorg = 0 ispa = 0 ispb = 0 korg = (nc-30)*360 - 180 if(nc.gt.60) korg = 0 if(nc.eq.61) iorg = +5400 if(nc.eq.62) iorg = -5400 endif read(10,*) ixs, iys, mszx, mszy, nmx, nmy, vnul xs = float(ixs)/1000. ys = float(iys)/1000. call premsg(' ') write(out,'(a,a8,a,i4,4x,4i8)') * '--- Area : ', area, ' Coord.', ncc, iorg,korg, ispa,ispb call premsg(out) write(out,'(14x,2a10,2x,2a8,2a6)') * 'xs', 'ys', 'msz-x', 'msz-y', 'mx', 'my' call premsg(out) write(out,'(16x,2f10.2,2i8,2i6)') xs, ys, mszx, mszy, nmx, nmy call premsg(out) if((nmx*nmy).gt.MAXSZ) then call abendm('too many grids') endif read(10,*) ((g(i+j),i=0,(nmx-1)*nmy,nmy),j=1,nmy) do 4 i=1,nmx*nmy if(g(i).ne.vnul) goto 5 4 continue call abendm('no valid data') 5 n = 1 gsum = g(i) gmin = g(i) gmax = g(i) do 6 j=i+1,nmx*nmy if(g(j).eq.vnul) goto 6 n = n + 1 gsum = gsum + g(j) if(g(j).lt.gmin) gmin = g(j) if(g(j).gt.gmax) gmax = g(j) 6 continue gsum = gsum / float(n) n = 0 gdev = 0. do 7 i=1,nmx*nmy if (g(i).eq.vnul) goto 7 dg = g(i) - gsum n = n + 1 gdev = gdev + dg*dg 7 continue gdev = sqrt(gdev / float(n)) write(out,'(4x,3(a,f7.1),a,f6.1)') 'Data Range : [', gmin, * ' ,', gmax, ' ] Mean :', gsum, ' St.Dev.:', gdev call premsg(out) call premsg('') c if(spl.eq.' ') then call gparmi(' Select 1(portrait) or 2(landscape) ==> ', kpl) if(kpl.eq.1) spl = 'A4P' if(kpl.eq.2) spl = 'A4L' if(spl.eq.' ') call abendm('invalid value') call psopn(fnam, spl) endif call premsg(' Specify contour interval ' * // '(1/2 of color-grading interval)') call gparmi(' ( enter 0 to skip contouring ) ==> ', istep) if(istep.eq.0) goto 3 istp = iabs(istep) call gparmi(' Median value of color-grading ? ==> ', mval) mval = mval/(istp*2)*(istp*2) vlo = float(mval - istp*20) vhi = float(mval + istp*20) if(kpl.eq.1) then call gparmf(' Width of Drawing (in cm) ? ==> ', wide) fscl = float((nmy-1)*mszy) / wide high = float((nmx-1)*mszx) / fscl else call gparmf(' Height of Drawing (in cm) ? ==> ', high) fscl = float((nmx-1)*mszx) / high wide = float((nmy-1)*mszy) / fscl endif fscl = fscl * 100. ccm = fscl/100000. kscl = 0 sclr = 0. sclu = 0. klll = 0 kshl = 0 c if(fscl.lt.3333334..and.fscl.ge.20000.) then km = nint(fscl)/25000 if(km.eq.0) km = 1 if(km.gt.50) km = 50 if(km.gt.2.and.km.lt.5) km = 2 if(km.gt.5.and.km.lt.10) km = 5 if(km.gt.10.and.km.lt.20) km = 10 if(km.gt.20.and.km.lt.50) km = 20 iinc = km kinc = km + km/2 if(km.eq.50) iinc = 60 if(km.eq.1.or.km.eq.5.or.km.eq.50) kinc = iinc dscl = float(km)/ccm 11 call prompt(' Draw Scale Bar ? ') call gparma(' "y" (Yes) or "n" (No) ==> ', 1, yn) if(yn.ne.'y'.and.yn.ne.'n') goto 11 if(yn.eq.'y') then kscl = 1 write(out,'(a,f4.1,a)') * ' size :', dscl, 'cm Wide, 0.8cm High' call premsg(out) call prompt(' Lower-Left Pos. ? (right and up)') call gparmf2(' in cm ==> ', sclr, sclu) endif 12 call prompt(' Draw Lat.Lon.Lines ?') call gparma(' "y" (Yes) or "n" (No) ==> ', 1, yn) if(yn.ne.'y'.and.yn.ne.'n') goto 12 if(yn.eq.'y') klll = 1 c endif 13 call prompt(' Draw Coastlines ? ') call gparma(' "y" (Yes) or "n" (No) ==> ', 1, yn) if(yn.ne.'y'.and.yn.ne.'n') goto 13 if(yn.eq.'y') then kshl = 2 14 call prompt(' Rivers ? ') call gparma(' "y" (Yes) or "n" (No) ==> ', 1, yn) if(yn.ne.'y'.and.yn.ne.'n') goto 14 if(yn.eq.'y') kshl = 12 15 call prompt(' Pref.Boundary ?') call gparma(' "y" (Yes) or "n" (No) ==> ', 1, yn) if(yn.ne.'y'.and.yn.ne.'n') goto 15 if(yn.eq.'y') then kshl = kshl + 200 if(kshl.eq.202) kshl = 102 endif endif write(9,'(a8,i4,4x,4i8)') area, ncc, iorg, korg, ispa, ispb write(9,*) xs, ys, mszx, mszy, nmx, nmy write(9,*) istp, mval, fscl, high, wide write(9,*) kscl, sclr, sclu, klll, kshl write(6,'(a)') '----------------------------------------' write(6,'(a)') * 'PLMAPCL : plot color-contour map with Line location' write(6,'(a,a)') ' Input data filename : ', fnin(1:lrtrim(fnin)) write(6,'(a,a)') ' Output PS filename : ', fnam(1:lrtrim(fnam)) write(6,'(a,a8,a,i4,4x,4i8)') * 'Areaname : ', area, ' Coord.', ncc, iorg,korg, ispa,ispb write(6,'(14x,2a10,2x,2a8,2a6)') * 'xs', 'ys', 'msz-x', 'msz-y', 'mx', 'my' write(6,'(16x,2f10.2,2i8,2i6)') xs, ys, mszx, mszy, nmx, nmy write(6,'(6x,a,i4,4x,a,i4)') 'step=', istp, 'mval=', mval write(6,'(6x,a,f8.0,4x,a3,f8.1,a1,f8.1,a1)') * 'scale 1 /', fscl, spl, high, 'H', wide, 'W' if(kscl.ne.0.or.klll.ne.0.or.kshl.ne.0) then write(6,'(a,$)') ' with ' if(kshl.ne.0) write(6,'(a,$)') ' Coast' if(mod(kshl,100)/10.ne.0) write(6,'(a,$)') '+River' if(kshl/100.ne.0) write(6,'(a,$)') '+PrefB' if(klll.ne.0) write(6,'(a,$)') ' LatLonLines' if(kscl.ne.0) then write(6,'(a,f5.1,$)') ' ScaleBar [', sclr write(6,'(a,f5.1,a,$)') ',', sclu, ' ]' endif write(6,'(a)') endif c call plots(1.5, 1.5) call dfrgbt(0) call dframe(0., 0., wide, high, nmy, nmx) call paintm(g, vlo, vhi, vnul) call wrect(0., 0., wide, high) call conts(0., 0., wide, high, nmy, nmx, 0.) call contx(g, vnul, istp, 2, -99999, 99999, 0) if(kscl.ne.0) then call plot(sclr, sclu+0.1, 3) call plot(sclr+dscl, sclu+0.1, 2) call newpen(2) call plot(sclr+dscl, sclu+0.3, 3) call plot(sclr+dscl, sclu, 2) call plot(sclr, sclu, 2) call plot(sclr, sclu+0.3, 2) write(s4,'(i2,a2)') km, 'km' call lstyle('T', 0.5, 0., 0, -255) call ptext(s4, 4, sclr+dscl/2., sclu+0.5, 2) call newpen(1) endif call scisor(0., 0., wide, high) call cvinit(ncc,float(iorg),float(korg),float(ispa),float(ispb)) if(klll.ne.0.or.kshl.ne.0) then xt = xs + float((nmx-1)*mszx)/1000. yt = ys + float((nmy-1)*mszy)/1000. call cvenik(ys, xs, fi1, fk1) call cvenik(yt, xs, fi2, fk2) call cvenik(ys, xt, fi3, fk3) call cvenik(yt, xt, fi4, fk4) isf = nint(amin1(fi1,fi2) - 0.5) itf = nint(amax1(fi3,fi4) + 0.5) ksf = nint(amin1(fk1,fk3) - 0.5) ktf = nint(amax1(fk2,fk4) + 0.5) endif if(klll.ne.0) then do 200 i=isf/iinc,itf/iinc idf = i * iinc if(idf.lt.isf.or.idf.gt.itf) goto 200 call cviken(float(idf), float(ksf), y, x) call plot((y-ys)/ccm, (x-xs)/ccm, 3) do 100 kdf=ksf+1,ktf call cviken(float(idf), float(kdf), y, x) call plot((y-ys)/ccm, (x-xs)/ccm, 2) 100 continue 200 continue do 400 k=ksf/kinc,ktf/kinc kdf = k * kinc if(kdf.lt.ksf.or.kdf.gt.ktf) goto 400 call cviken(float(isf), float(kdf), y, x) call plot((y-ys)/ccm, (x-xs)/ccm, 3) do 300 idf=isf+1,itf call cviken(float(idf), float(kdf), y, x) call plot((y-ys)/ccm, (x-xs)/ccm, 2) 300 continue 400 continue endif if(kshl.ne.0) then call rshore(mc, isf/60, (itf+59)/60, ksf/60, (ktf+59)/60) call pshore(-ys/ccm, -xs/ccm, kshl, ccm, cviken) endif c call newpen(6) 50 kpen = 0 read(11,'(a)',end=52) buf if ((buf(1:1).eq.'&') .or. (buf(1:1).eq.'%') * .or. (buf(1:1).eq.'#')) goto 50 read(buf,'(f10.4,1x,f11.4)') alat, alon call cviken(alat, alon, y, x) call plot((y-ys)/ccm, (x-xs)/ccm, 3) 51 read(11,'(a)',end=52) buf if ((buf(1:1).eq.'&') .or. (buf(1:1).eq.'%') * .or. (buf(1:1).eq.'#')) goto 50 read(buf,'(f10.4,1x,f11.4)') alat, alon call cviken(alat, alon, y, x) call plot((y-ys)/ccm, (x-xs)/ccm, 2) goto 51 52 rewind(11) call newpen(1) c call scisor(0., 0., 0., 0.) call lstyle('T', 0.4, 0., 0, -255) call ptext(area, 8, -1., -1., 0) call ptext(fnin, 50, 2., -1., 0) call plote() 3 read(10,'(a)',end=8) buf if(buf(1:1).eq.'#') goto 3 20 call prompt(' Process Next set ?') call gparma(' "y" (Yes) or "n" (No) ==> ', 1, yn) if(yn.ne.'y'.and.yn.ne.'n') goto 20 if(yn.eq.'y') goto 2 c 8 close(10) endfile(9) rewind(9) call pscls() call clspin() c if(flog(ldr:ldr).ne.' ') then open(99,file=flog,access='append') write(99,'(//a,$)') 'PLMAPCL :' write(99,'(a)') ' plot color-contour map with Line location' write(99,'(a,a)') * ' Input data filename : ', fnin(1:lrtrim(fnin)) write(99,'(a,a)') * ' StdLIN filename : ', fnln(1:lrtrim(fnln)) write(99,'(a,a)') * ' Output PS filename : ', fnam(1:lrtrim(fnam)) 92 read(9,'(a8,i4,4x,4i8)',end=93) * area, ncc, iorg, korg, ispa, ispb read(9,*) xs, ys, mszx, mszy, nmx, nmy read(9,*) istp, mval, fscl, high, wide read(9,*) kscl, sclr, sclu, klll, kshl write(99,'(a,a8,a,i4,4x,4i8)') * 'Areaname : ', area, ' Coord.', ncc, iorg,korg,ispa,ispb write(99,'(14x,2a10,2x,2a8,2a6)') * 'xs', 'ys', 'msz-x', 'msz-y', 'mx', 'my' write(99,'(16x,2f10.2,2i8,2i6)') xs, ys, mszx, mszy, nmx, nmy write(99,'(6x,a,i4,4x,a,i4)') 'step=', istp, 'mval=', mval write(99,'(6x,a,f8.0,4x,a3,f8.1,a1,f8.1,a1)') * 'scale 1 /', fscl, spl, high, 'H', wide, 'W' if(kscl.ne.0.or.klll.ne.0.or.kshl.ne.0) then write(99,'(a,$)') ' with ' if(kshl.ne.0) write(99,'(a,$)') ' Coast' if(mod(kshl,100)/10.ne.0) write(99,'(a,$)') '+River' if(kshl/100.ne.0) write(99,'(a,$)') '+PrefB' if(klll.ne.0) write(99,'(a,$)') ' LatLonLines' if(kscl.ne.0) then write(99,'(a,f5.1,$)') ' ScaleBar [', sclr write(99,'(a,f5.1,a,$)') ',', sclu, ' ]' endif write(99,'(a)') endif goto 92 93 call strdtm(sdtm) write(99,'(a,a,a)') '=============== ', sdtm, '===============' close(99) endif close(9) stop end