1*----------------------------------------------------------------------- 2* UDCNTZ 3*----------------------------------------------------------------------- 4* Copyright (C) 2000-2004 GFD Dennou Club. All rights reserved. 5*----------------------------------------------------------------------- 6 SUBROUTINE UDCNTZ(Z,MX,NX,NY,IBR,NBR2) 7 8 INTEGER IBR(NBR2) 9 REAL Z(MX,*) 10 11 INTEGER NS(2),NP(2),NQ(2) 12 LOGICAL LUDCHK,LOPEN,LMISS,LMADA,LOK,LSET,LMSG, 13 + LEPSL,LCHAR,LMAP,LCLIP,LPRINT,LEXIT,LCENT 14 CHARACTER CMSG*80 15 16 COMMON /UDBLK1/ NB,LX,LY,NBR 17 COMMON /UDBLK2/ NL,CZL,IDX,ITY,HLV 18 COMMON /UDBLK3/ CLAB 19 PARAMETER (NLX=50) 20 INTEGER IDX(NLX),ITY(NLX) 21 REAL CZL(NLX),HLV(NLX) 22 CHARACTER CLAB(NLX)*8 23 24 EXTERNAL RVMIN,RVMAX,RUDLEV,LUDCHK 25 26 SAVE 27 28 29* / GET INTERNAL PARAMETERS / 30 31 CALL UDRGET('RSIZET ',RSIZE ) 32 CALL UDRGET('XTTL ',XTTL ) 33 CALL UDLGET('LMSG ',LMSG ) 34 CALL UDLGET('LCENT ',LCENT ) 35 CALL UDIGET('NLEV ',NLEV ) 36 CALL UDIGET('INDXMJ ',INDEX ) 37 38 CALL GLLGET('LMISS',LMISS) 39 CALL GLRGET('RMISS',RMISS) 40 CALL GLIGET('NBITSPW',NB) 41 CALL GLLGET('LEPSL',LEPSL) 42 CALL SGLGET('LCHAR',LCHAR) 43 44 CALL STQTRF(LMAP) 45 46* / SET INTERNAL PARAMETER / 47 48 CALL GLLSET('LEPSL',.TRUE.) 49 CALL SGLSET('LCHAR',.TRUE.) 50 51* / CHECK WORKING ARRAY SIZE / 52 53 NBR=NBR2/2 54 LX=NX+2 55 LY=NY+2 56 NWRD=LX*LY*2/NB+1 57 IF (NWRD.GT.NBR) THEN 58 CALL MSGDMP('M','UDCNTR','WORKING AREA IS NOT ENOUGH.') 59 CMSG='NBR2/2 SHOULD BE LARGER THAN (NX+2)*(NY+2)/##+1.' 60 WRITE(CMSG(44:45),'(I2)') NB/2 61 CALL MSGDMP('E','-CNT.-',CMSG) 62 END IF 63 64* / SET GRID ATTRIBUTE IF IT HAS NOT BEEN SET YET / 65 66 CALL UWDFLT(NX,NY) 67 68* / CHECK MIN & MAX / 69 70 NS(1)=MX 71 NS(2)=NY 72 NP(1)=1 73 NP(2)=1 74 NQ(1)=NX 75 NQ(2)=NY 76 RMINZ=RVMIN(Z,NS,NP,NQ,2) 77 RMAXZ=RVMAX(Z,NS,NP,NQ,2) 78 79 LMADA=LMISS .AND. RMINZ.EQ.RMISS .AND. RMAXZ.EQ.RMISS 80 81 IF (LMADA .OR. RMINZ.EQ.RMAXZ) THEN 82 83* / MESSAGE FOR MISSING OR CONSTANT FIELD / 84 85 IF (LMADA) THEN 86 CMSG='MISSING FIELD.' 87 ELSE 88 CMSG='CONSTANT (##########) FIELD.' 89 WRITE(CMSG(11:20),'(1P,E10.3)') RMINZ 90 END IF 91 CALL MSGDMP('W','UDCNTR',CMSG) 92 93 LPRINT=LMSG 94 LEXIT=.TRUE. 95 96 ELSE 97 98* / GENERATE CONTOUR LEVELS IF THEY HAVE NOT BEEN GENERATED YET / 99 100 CALL UDQCLZ(LSET) 101 IF (.NOT.LSET) THEN 102 CALL UDGCLB(Z,MX,NX,NY,-REAL(NLEV)) 103 CALL UDSCLZ(.FALSE.) 104 END IF 105 106* / CHECK INAPPROPRIATE DATA / 107 108 DO 10 K=1,NY 109 DO 15 J=1,NX 110 111 LOK=.NOT.(LMISS .AND. Z(J,K).EQ.RMISS) 112 113 DO 20 I=1,NL 114 IF (LOK .AND. Z(J,K).EQ.CZL(I)) THEN 115 XXX=RUDVAL(Z(J,K),CZL(I)) 116 CMSG='INAPPROPRIATE DATA WILL BE MODIFIED INTERNALLY.' 117 CALL MSGDMP('M','UDCNTR',CMSG) 118 WRITE(CMSG(1:80),500) J,K,Z(J,K),XXX 119 500 FORMAT('Z(',I3,',',I3,')=',G16.9,' ===> ',G16.9) 120 CALL MSGDMP('M','-CNT.-',CMSG) 121 END IF 122 20 CONTINUE 123 124 15 CONTINUE 125 10 CONTINUE 126 127* / CONTOUR INTERVAL / 128 129 DZ=RUDLEV(1) 130 CMSG='CONTOUR INTERVAL =##########' 131 WRITE(CMSG(19:28),'(1P,E10.3)') DZ 132 133 LPRINT=NL.GE.2 .AND. LMSG 134 LEXIT=.FALSE. 135 136 END IF 137 138* / PRINT MESSAGE / 139 140 IF (LPRINT) THEN 141 CALL SGLGET('LCLIP', LCLIP) 142 CALL SGLSET('LCLIP',.FALSE.) 143 CALL SGQVPT(VXMN,VXMX,VYMN,VYMX) 144 XPT=(VXMN+VXMX)/2 145 IF (LMAP.AND.LCENT) THEN 146 YPT=VYMN/2 147 ELSE 148 CALL UZRGET('ROFFXB',ROFFX) 149 CALL UZRGET('PAD1',PAD) 150 YPT=VYMN+ROFFX-RSIZE*(PAD*2+1.5) 151 ROFFX=ROFFX-RSIZE*(PAD+1.0)*2 152 CALL UZRSET('ROFFXB',ROFFX) 153 END IF 154 CALL CUPPER(CMSG) 155 CALL SGTXZV(XPT,YPT,CMSG,RSIZE,0,0,INDEX) 156 CALL SGLSET('LCLIP',LCLIP) 157 IF (LEXIT) GO TO 100 158 END IF 159 160* / CHECK BOUND / 161 162 CALL UDICLR(IBR,NBR*2) 163 164 DO 25 K=0,1 165 K1=1-K 166 DO 30 IY=1,NY-K 167 IY1=IY+K 168 DO 35 IX=1,NX-K1 169 IX1=IX+K1 170 IF (.NOT.(LMISS .AND. 171 + (Z(IX1,IY).EQ.RMISS .OR. Z(IX,IY1).EQ.RMISS))) THEN 172 CALL UDBSET(IX,IY,K,1,IBR) 173 END IF 174 35 CONTINUE 175 30 CONTINUE 176 25 CONTINUE 177 178 DO 40 K=0,1 179 K1=1-K 180 DO 45 IY=1,NY-K 181 IY1=IY+K1 182 IY2=IY-K1 183 DO 50 IX=1,NX-K1 184 IX1=IX+K 185 IX2=IX-K 186 IF (.NOT.LUDCHK(IX1,IY1,K,1,IBR) 187 + .AND. .NOT.LUDCHK(IX2,IY2,K,1,IBR)) THEN 188 CALL UDBCLR(IX,IY,K,1,IBR) 189 END IF 190 50 CONTINUE 191 45 CONTINUE 192 40 CONTINUE 193 194* / DRAW CONTOURS / 195 196 DO 55 LC=1,NL 197 198* / INITIALIZE / 199 200 CX=CZL(LC) 201 IF (.NOT.(RMINZ.LT.CX .AND. CX.LT.RMAXZ)) GO TO 55 202 203 IF (HLV(LC).LE.0) THEN 204 CALL SZCRST 205 ELSE 206 NLAB=LENC(CLAB(LC)) 207 CALL SZSCHZ(CLAB(LC)(1:NLAB),HLV(LC)) 208 END IF 209 CALL SZSLTI(ITY(LC),IDX(LC)) 210 211 CALL UDICLR(IBR,NBR) 212 213* / CHECK BRANCH / 214 215 NN=0 216 DO 60 K=0,1 217 K1=1-K 218 DO 65 IY=1,NY-K 219 IY1=IY+K 220 DO 70 IX=1,NX-K1 221 IX1=IX+K1 222 IF (Z(IX1,IY).EQ.CX) THEN 223 ZZ1=RUDVAL(Z(IX1,IY),CX) 224 ELSE 225 ZZ1=Z(IX1,IY) 226 END IF 227 IF (Z(IX,IY1).EQ.CX) THEN 228 ZZ2=RUDVAL(Z(IX,IY1),CX) 229 ELSE 230 ZZ2=Z(IX,IY1) 231 END IF 232 IF (LUDCHK(IX,IY,K,1,IBR)) then 233 if ((ZZ1-CX)*(ZZ2-CX).LT.0) THEN 234 CALL UDBSET(IX,IY,K,0,IBR) 235 NN=NN+1 236 end if 237 END IF 238 70 CONTINUE 239 65 CONTINUE 240 60 CONTINUE 241 242 IF (NN.NE.0) THEN 243 244* / BOUND TO BOUND CONTOURS / 245 246 DO 75 K=0,1 247 K1=1-K 248 DO 80 IY=1,NY-K 249 DO 85 IX=1,NX-K1 250 IF (LUDCHK(IX,IY,K,0,IBR)) THEN 251 IX1=IX+K 252 IX2=IX-K 253 IY1=IY+K1 254 IY2=IY-K1 255 LOPEN=.NOT.(LUDCHK(IX1,IY1,K,1,IBR) 256 + .AND. LUDCHK(IX2,IY2,K,1,IBR)) 257 IF (LOPEN) THEN 258 CALL UDLINE(Z,MX,IX,IY,K,CX,LOPEN,IBR) 259 END IF 260 END IF 261 85 CONTINUE 262 80 CONTINUE 263 75 CONTINUE 264 265* / CLOSED CONTOURS / 266 267 K=0 268 K1=1-K 269 DO 90 IY=1,NY-K 270 DO 95 IX=1,NX-K1 271 IF (LUDCHK(IX,IY,K,0,IBR)) THEN 272 IX1=IX+K 273 IX2=IX-K 274 IY1=IY+K1 275 IY2=IY-K1 276 LOPEN=.NOT.(LUDCHK(IX1,IY1,K,1,IBR) 277 + .AND. LUDCHK(IX2,IY2,K,1,IBR)) 278 IF (.NOT.LOPEN) THEN 279 CALL UDLINE(Z,MX,IX,IY,K,CX,LOPEN,IBR) 280 END IF 281 END IF 282 95 CONTINUE 283 90 CONTINUE 284 285 END IF 286 287 55 CONTINUE 288 289* / RESET INTERNAL PARAMETER / 290 291 100 CALL GLLSET('LEPSL',LEPSL) 292 CALL SGLSET('LCHAR',LCHAR) 293 294 END 295