PROGRAM sanmenzu * 1995-07-03, 1998-02-13, 2000-04-25 masuda/k. * m = month (tuki) * p = precipitation (koosui-ryoo) * t = temperature (kion) IMPLICIT NONE INCLUDE 'datapath.fi' CHARACTER*50 fname INTEGER imon, istn, kframe, kstn, n, nstn REAL rmonth(12) INTEGER lstn(500) * REAL vxmin1,vxmax1,vymin1,vymax1 REAL vxmin2,vxmax2,vymin2,vymax2 REAL wpmin,wpmax,wtmin,wtmax,wmmin,wmmax REAL wptk0,wptki,wttk0,wttki,wmtk0,wmtki REAL wplb0,wplbi,wtlb0,wtlbi,wmlb0,wmlbi REAL dvxbtk,dvybtk,dvxltk,dvyltk REAL chsizw INTEGER labip,labfrp,labit,labfrt,labim,labfrm INTEGER ltypew,lcolw REAL dvxlby,dvylbx * INTEGER iokion, ioame INTEGER iswitch, iseq, iyearb, iyeare, irtnt, irtnp REAL rlat, rlon, rheit REAL tmonv(12), tannv, tannv2 REAL pmonv(12), pannv, pannv2 CHARACTER*25 hstat, hcntr, hwork * DATA iokion / 11 /, ioame / 12 / DATA wpmin/ -50.0/,wpmax/ 500.0/,wtmin/ -30.0 /,wtmax/ 50.0 / DATA wmmin/ 0.2/,wmmax/ 12.8/ DATA vxmin1/0.15 /,vxmax1/0.50 /,vymin1/0.15 /,vymax1/0.50/ DATA vxmin2/0.625/,vxmax2/0.975/,vymin2/0.625/,vymax2/0.975/ DATA wptk0/ 0.0 /,wptki/ 50.0/,wttk0/ -30.0 /,wttki/ 10.0 / DATA wmtk0/ 1.0 /,wmtki/ 1.0/ DATA wplb0/ 0.0 /,wplbi/ 100.0/,wtlb0/ -20.0 /,wtlbi/ 20.0 / DATA wmlb0/ 1.0 /,wmlbi/ 1.0/ DATA dvxbtk/0.015 /,dvybtk/0.015/,dvxltk/0.010 /,dvyltk/0.010/ DATA chsizw/0.015 / DATA labip/ 3 /,labfrp/ 0 /,labit / 3 /,labfrt/ 0 / DATA labim/ 2 /,labfrm/ 0 / DATA ltypew/ 1 /,lcolw / 1 / DATA dvxlby/-0.08 /,dvylbx/-0.06/ * BEGIN DO imon = 1, 12 rmonth(imon) = imon END DO * kstn = 0 900 CONTINUE READ(*,*,END=990) istn kstn = kstn+1 lstn(kstn) = istn GO TO 900 990 CONTINUE nstn = kstn * fname = dapath//'climate/rikanenp/kion' OPEN(unit=iokion, file=fname, & status='OLD',access='SEQUENTIAL',form='FORMATTED') READ(iokion,'(1X)') * fname = dapath//'climate/rikanenp/ame' OPEN(unit=ioame, file=fname, & status='OLD',access='SEQUENTIAL',form='FORMATTED') READ(ioame, '(1X)') * * Sakuzu hazime CALL opngks * kframe = 0 kstn = 1 9000 CONTINUE IF (kstn .GT. nstn) GO TO 9900 * * "data" o yomu * iswitch = 1 CALL readrika (iokion, iswitch, iseq, hstat, hcntr, & rlat, rlon, rheit, & tmonv, tannv, tannv2, iyearb, iyeare, irtnt) IF (irtnt .LT. 0) GO TO 9900 * iswitch = 2 CALL readrika (ioame, iswitch, iseq, hstat, hcntr, & rlat, rlon, rheit, & pmonv, pannv, pannv2, iyearb, iyeare, irtnp) IF (irtnp .LT. 0) GO TO 9900 * IF (iseq .EQ. lstn(kstn)) THEN * * zu 1 (migi-sita). koosuiryoo (tate) to tuki (yoko) * CALL GSWN (1, wmmin, wmmax, wpmin, wpmax ) CALL GSVP (1, vxmin2, vxmax2, vymin1, vymax1 ) * CALL GSLN (ltypew) CALL GSPLCI(lcolw) CALL GSTXCI(lcolw) CALL waku2 (wmmin, wmmax, wpmin, wpmax, & wmtk0, wmtki, wptk0, wptki, & dvxbtk,dvybtk,dvxltk,dvyltk, & wmlb0, wmlbi, wplb0, wplbi, chsizw, & labim, labfrm,labip, labfrp) * IF (irtnp .EQ. 0) THEN CALL GSELNT(1) n = 12 CALL GSLN ( 1 ) CALL GSPLCI( 3 ) DO imon = 1, n CALL senbun(rmonth(imon), 0.0, rmonth(imon), pmonv(imon)) END DO * CALL GSMK ( 2 ) CALL GSMKSC( 0.5 ) CALL GSPMCI( 5 ) CALL GPM (n, rmonth, pmonv) ELSE CALL GSELNT(0) CALL GSTXCI(2) CALL GSTXAL(2,3) CALL GSCHUP( 0.0, 1.0) CALL GTX( 0.5*(vxmin2+vxmax2), 0.5*(vymin1+vymax1), & '"data" ga nai.') END IF * CALL GSELNT(1) CALL GSLN ( 2 ) CALL GSPLCI( 2 ) CALL senbun( wmmin, 0.0, wmmax, 0.0 ) CALL GSLN ( 1 ) * CALL GSELNT(0) CALL GSTXCI(1) CALL GSTXAL(2,3) CALL GSCHUP( 0.0, 1.0) CALL GTX( 0.5*(vxmin2+vxmax2), vymin1+dvylbx, & 'tuki' ) CALL GSCHUP(-1.0, 0.0) CALL GTX( vxmin2+dvxlby, 0.5*(vymin1+vymax1), & 'koosui-ryoo (mm)') CALL GSCHUP( 0.0, 1.0) * * zu 2 (migi-ue). kion (tate) to tuki (yoko) * CALL GSWN (1, wmmin, wmmax, wtmin, wtmax ) CALL GSVP (1, vxmin2, vxmax2, vymin2, vymax2 ) * CALL GSLN (ltypew) CALL GSPLCI(lcolw) CALL GSTXCI(lcolw) CALL waku2 (wmmin, wmmax, wtmin, wtmax, & wmtk0, wmtki, wttk0, wttki, & dvxbtk,dvybtk,dvxltk,dvyltk, & wmlb0, wmlbi, wtlb0, wtlbi, chsizw, & labim, labfrm,labit, labfrt) * IF (irtnt .EQ. 0) THEN CALL GSELNT(1) CALL GSLN ( 1 ) CALL GSPLCI( 3 ) CALL GPL ( n, rmonth, tmonv ) * CALL GSMK ( 2 ) CALL GSMKSC( 0.5 ) CALL GSPMCI( 5 ) CALL GPM (n, rmonth, tmonv) ELSE CALL GSELNT(0) CALL GSTXCI(2) CALL GSTXAL(2,3) CALL GSCHUP( 0.0, 1.0) CALL GTX( 0.5*(vxmin2+vxmax2), 0.5*(vymin2+vymax2), & '"data" ga nai.') END IF * CALL GSELNT(1) CALL GSLN ( 2 ) CALL GSPLCI( 2 ) CALL senbun( wmmin, 0.0, wmmax, 0.0 ) CALL GSLN ( 1 ) * CALL GSELNT(0) CALL GSTXCI(1) CALL GSTXAL(2,3) CALL GSCHUP( 0.0, 1.0) CALL GTX( 0.5*(vxmin2+vxmax2), vymin2+dvylbx, & 'tuki' ) CALL GSCHUP(-1.0, 0.0) CALL GTX( vxmin2+dvxlby, 0.5*(vymin2+vymax2), & 'kion (do C)') CALL GSCHUP( 0.0, 1.0) * * zu 3 (hidari-ue). koosuiryoo (tate) to kion (yoko) * CALL GSWN (1, wpmin, wpmax, wtmin, wtmax ) CALL GSVP (1, vxmin1, vxmax1, vymin2, vymax2 ) * CALL GSLN (ltypew) CALL GSPLCI(lcolw) CALL GSTXCI(lcolw) CALL waku2 (wpmin, wpmax, wtmin, wtmax, & wptk0, wptki, wttk0, wttki, & dvxbtk,dvybtk,dvxltk,dvyltk, & wplb0, wplbi, wtlb0, wtlbi, chsizw, & labip, labfrp,labit, labfrt) * IF (irtnt .EQ. 0 .AND. irtnp .EQ. 0) THEN CALL GSELNT(1) CALL GSLN ( 1 ) CALL GSPLCI( 3 ) CALL GPL ( n, pmonv, tmonv ) * CALL GSMK ( 2 ) CALL GSMKSC( 0.5 ) CALL GSPMCI( 5 ) CALL GPM (n, pmonv, tmonv) ELSE CALL GSELNT(0) CALL GSTXCI(2) CALL GSTXAL(2,3) CALL GSCHUP( 0.0, 1.0) CALL GTX( 0.5*(vxmin1+vxmax1), 0.5*(vymin2+vymax2), & '"data" ga nai.') END IF * CALL GSELNT(1) CALL GSLN ( 2 ) CALL GSPLCI( 2 ) CALL senbun( wpmin, 0.0, wpmax, 0.0 ) CALL senbun( 0.0, wtmin, 0.0, wtmax) CALL GSLN ( 1 ) * CALL GSELNT(0) CALL GSTXCI(1) CALL GSTXAL(2,3) CALL GSCHUP( 0.0, 1.0) CALL GTX( 0.5*(vxmin1+vxmax1), vymin2+dvylbx, & 'koosui-ryoo (mm)' ) CALL GSCHUP(-1.0, 0.0) CALL GTX( vxmin1+dvxlby, 0.5*(vymin2+vymax2), & 'kion (do C)') CALL GSCHUP( 0.0, 1.0) * * daimei (timei) * CALL GSELNT(0) CALL GSTXCI(1) CALL GSTXAL(1,3) CALL GSCHH (0.02) hwork = '(???) ' WRITE (hwork(2:4), '(I3)') iseq CALL GTX (0.125, 0.48, hwork) CALL GTX (0.125, 0.43, hstat) CALL GTX (0.125, 0.38, hcntr) WRITE (hwork(1:10), '(F10.3)') abs(rlat) IF (rlat .GE. 0.0) THEN hwork(11:12) = ' N' ELSE hwork(11:12) = ' S' END IF CALL GTX (0.125, 0.33, hwork) WRITE (hwork(1:10), '(F10.3)') abs(rlon) IF (rlon .GE. 0.0) THEN hwork(11:12) = ' E' ELSE hwork(11:12) = ' W' END IF CALL GTX (0.125, 0.28, hwork) WRITE (hwork(1:10), '(I10)') nint(rheit) hwork(11:12) = ' m' CALL GTX (0.125, 0.23, hwork) WRITE (hwork(1:12), '(I5,'' -'',I5)' ) iyearb, iyeare CALL GTX (0.125, 0.18, hwork) * CALL frame kframe = kframe+1 WRITE (*,*) 'gamen bangoo ',kframe,' titen bangoo ',iseq kstn = kstn+1 END IF GO TO 9000 9900 CONTINUE CLOSE(unit=iokion) CLOSE(unit=ioame) * owari CALL clsgks END INCLUDE 'waku2.f' INCLUDE 'wc2ndc.f' INCLUDE 'senbun.f' INCLUDE 'readrika.f'