1*----------------------------------------------------------------------- 2* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. 3*----------------------------------------------------------------------- 4 SUBROUTINE UETONB(Z,MX,NX,NY) 5 6 REAL Z(MX,*) 7 8 INTEGER NP(2),NI(2) 9 REAL XC(4),YC(4),ZC(4),AX(10),AY(10),TLM(2) 10 LOGICAL LMISS 11 12 COMMON /UEBLK1/ TL1,TL2,IPT,NT,LASCND 13 PARAMETER (MAXNT=100) 14 LOGICAL LASCND 15 INTEGER IPT(MAXNT) 16 REAL TL1(MAXNT),TL2(MAXNT) 17 18 EXTERNAL RUWGX,RUWGY 19 20 21* / GET INTERNAL PARAMETERS / 22 23 CALL GLLGET('LMISS ',LMISS ) 24 CALL GLRGET('RMISS ',RMISS ) 25 CALL SGIGET('ITR ',ITR) 26 27* / SET GRID ATTRIBUTE IF IT HAS NOT BEEN SET YET / 28 29 CALL UWDFLT(NX,NY) 30 31* / CHECK Z VALUES AND TONE LEVEL / 32 33 CALL UEZCHK(Z,MX,NX,NY,'UETONB',ISTAT) 34 IF (ISTAT.NE.0) RETURN 35 36* / SET TONE MODE (IRMODE) / 37 38 CALL UWQGXB(UXMIN,UXMAX,NXZ) 39 CALL UWQGYB(UYMIN,UYMAX,NYZ) 40 41 IF (ITR.LT.4) THEN 42 CALL STFTRF(UXMIN,UYMIN,VXMIN,VYMIN) 43 CALL STFTRF(UXMAX,UYMAX,VXMAX,VYMAX) 44 DX=VXMAX-VXMIN 45 DY=VYMAX-VYMIN 46 ELSE 47 DX=UXMAX-UXMIN 48 DY=UYMAX-UYMIN 49 END IF 50 51 IRMODE=0 52 IF (DX.LT.0) IRMODE=MOD(IRMODE+1,2) 53 IF (DY.LT.0) IRMODE=MOD(IRMODE+1,2) 54 55 CALL SGISET('IRMODE', IRMODE) 56 57* / INITIALIZE / 58 59 CALL UEAINT 60 61* / LOOP FOR EACH TONE PATTERN / 62 63 DO 30 IT=1,NT 64 65 CALL SZTNOP(IPT(IT)) 66 67* / LOOP FOR EACH SECTION / 68 69 DO 20 I=1,NX-1 70 71 I0=I-1 72 I1=I+1 73 74 IF (I.EQ.1) THEN 75 XC(1)=RUWGX(I) 76 ELSE 77 XC(1)=(RUWGX(I0)+RUWGX(I))/2.0 78 END IF 79 IF (I.EQ.NX-1) THEN 80 XC(2)=RUWGX(I1) 81 ELSE 82 XC(2)=(RUWGX(I)+RUWGX(I1))/2.0 83 END IF 84 XC(3)=XC(2) 85 XC(4)=XC(1) 86 87 DO 10 J=1,NY-1 88 89 J0=J-1 90 J1=J+1 91 92 IF (Z(I,J).LT.TL1(IT)) GO TO 10 93 IF (Z(I,J).GT.TL2(IT)) GO TO 10 94 95 ZC(1)=Z(I,J) 96 ZC(2)=Z(I,J) 97 ZC(3)=Z(I,J) 98 ZC(4)=Z(I,J) 99 100 IF (LMISS .AND. NINDXR(ZC,4,1,RMISS).NE.0) GO TO 10 101 102 IF (J.EQ.1) THEN 103 YC(1)=RUWGY(J) 104 ELSE 105 YC(1)=(RUWGY(J0)+RUWGY(J))/2.0 106 END IF 107 YC(2)=YC(1) 108 IF (J.EQ.NY-1) THEN 109 YC(3)=RUWGY(J1) 110 ELSE 111 YC(3)=(RUWGY(J)+RUWGY(J1))/2.0 112 END IF 113 YC(4)=YC(3) 114 115 TLM(1)=TL1(IT) 116 TLM(2)=TL2(IT) 117 CALL UEAREA(XC,YC,ZC,TLM,AX,AY,NP,NI,NG) 118 119 DO 40 N=1,NG 120 CALL SZTNZU(NP(N),AX(NI(N)),AY(NI(N))) 121 40 CONTINUE 122 123 10 CONTINUE 124 20 CONTINUE 125 126 CALL SZTNCL 127 128 30 CONTINUE 129 130 END 131