! Last change: IPK 12 Jan 98 1:44 pm ! SUBROUTINE GNODE(ITYPC) ! ! Routine to create a series of nodes along a line ! USE BLK1MOD ! INCLUDE 'BLK1.COM' INCLUDE 'TXFRM.COM' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL REAL*8 GRIDX(150),GRIDY(150),ALX,ALY,ATX,ATY,CURRENTX,CURRENTY,X11,Y11 INTEGER IREF(2000),JREF(2000) ! CHARACTER*1 IFLAG data itime/0/ if(itime .eq. 0) then ALLOCATE(ALXX(2000),ALYY(2000),ALWD(2000),BLXX(2000),BLYY(2000),BLWD(2000)& ,CNX(2000,4),CNY(2000,4),ITYPBC(2000),XBRLEN(2000),HLEFT(2000),HMID(2000),HRIGHT(2000)& ,HSET(MAXP,3),IRTYP(2000),WIDTHD(2000)) nh=1 itime=1 endif 4 CONTINUE IF(ITYPC .EQ. 1) THEN NHTP = 0 NMESS = 6 NBRR = 3 CALL HEDR ! ! Get screen coordinates of each end of line ! 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) ALX=XTEMP ALY=YTEMP IF(IRMAIN .EQ. 1) RETURN ! IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN CALL WRTOUT(0) RETURN ENDIF ! ! Exit input ! 9 CONTINUE CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) CALL HEDR ! CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) ATX=XTEMP ATY=YTEMP IF(IRMAIN .EQ. 1) RETURN ! CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) ! ! Define number of nodes in a line ! NBRR = 0 NMESS=45 CALL HEDR NMESS = 7 call getint(nh) ! READ(*,*) NH NINT=NH-1 ! ! zero GRIDX and GRIDY to hold generated coordinates ! DO N=1,NH GRIDX(N)=0. GRIDY(N)=0. END DO ! ! Interpolate points onto line ! CALL INTERP(GRIDX,GRIDY,1,NH,1,ALX,ALY,ATX,ATY,NINT,0) ! ! Copy points into the coordinate array ! DO N=1,NH ! ! Find next blank node in CORD ! CALL GETNOD(J) ! ! Store GRIDX and GRIDY into it ! CORD(J,1) = GRIDX(N) CORD(J,2) = GRIDY(N) INEW(J) = 1 INSKP(J) = 0 ! XUSR(J) = GRIDX(N)*TXSCAL - XS YUSR(J) = GRIDY(N)*TXSCAL - YS ! ! Display point ! CALL PLTNOD(J,1) ! END DO ELSE KID=0 ITYP=2 CALL FORMLINEMENU(ITYP,I1D,I2D,IFIN,XLENGTH,ITYPIN,NELC,NBRID) IF(I1D .EQ. -999) RETURN IF(IFIN .EQ. 0) THEN NHTP = 0 NMESS = 6 NBRR = 3 CALL HEDR ! ! Get screen coordinates of each end of line ! DO J=1,2000 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) IF(IFLAG .EQ. 'q' .or. ibox .eq. 10) go to 300 ALXX(J)=XTEMP ALYY(J)=YTEMP JPTS=J ENDDO 300 CONTINUE ELSE CALL FILEDAT(JPTS,NBRID) ENDIF ! SORT OUT A NEW ORDER IREF=1 CURRENTX=ALXX(1) CURRENTY=ALYY(1) KS=2 KSP=1 DO J=2,JPTS IF(JPTSB .GT. 0) THEN IF(KSP .LE. JPTSB) THEN DO K=KSP,JPTSB TOTLEN=SQRT((ALXX(J)-CURRENTX)**2+(ALYY(J)-CURRENTY)**2) TOTLENB=SQRT((BLXX(K)-CURRENTX)**2+(BLYY(K)-CURRENTY)**2) IF(ABS(TOTLENB - TOTLEN) .LT. 1.0) THEN ! THIS IS A BREAKPOINT IREF(KS)=-K KS=KS+1 KSP=KSP+1 CURRENTX=BLXX(K) CURRENTY=BLYY(K) GO TO 320 ENDIF IF(TOTLENB .LT. TOTLEN) THEN ! THIS IS A BREAKPOINT IREF(KS)=-K KS=KS+1 KSP=KSP+1 CURRENTX=BLXX(K) CURRENTY=BLYY(K) GO TO 310 ELSE IREF(KS)=J KS=KS+1 CURRENTX=ALXX(J) CURRENTY=ALYY(J) GO TO 320 ENDIF 310 CONTINUE ENDDO ELSE 315 CONTINUE IREF(KS)=J KS=KS+1 CURRENTX=ALXX(J) CURRENTY=ALYY(J) ENDIF 320 CONTINUE ELSE IREF(KS)=J IF(KS .LT. JPTS)KS=KS+1 CURRENTX=ALXX(J) CURRENTY=ALYY(J) ENDIF ENDDO ! IREF(KS)=JPTS IF(IFIN .GT. 0) THEN IREF(KS)=JPTS DO K=KS,1,-1 IF(IREF(K) .LT. 0) THEN ALXX(K)=BLXX(-IREF(K)) ALYY(K)=BLYY(-IREF(K)) ALWD(K)=BLWD(-IREF(K)) HMID(K)=BLWD(-IREF(K)) HLEFT(K)=HMID(K) HRIGHT(K)=HMID(K) ELSE ALXX(K)=ALXX(IREF(K)) ALYY(K)=ALYY(IREF(K)) ALWD(K)=ALWD(IREF(K)) HMID(K)=HMID(IREF(K)) HLEFT(K)=HLEFT(IREF(K)) HRIGHT(K)=HRIGHT(IREF(K)) ENDIF ENDDO DO J=1,KS ALXX(J)=(ALXX(J)+XS)/TXSCAL ALYY(J)=(ALYY(J)+YS)/TXSCAL ENDDO DO J=1,KS BLXX(J)=(BLXX(J)+XS)/TXSCAL BLYY(J)=(BLYY(J)+YS)/TXSCAL ENDDO ! KS=KS-1 ENDIF JST=1 JKP=0 K=2 321 IF(IREF(K) .LT. 0) THEN 323 IF(IREF(K+1) .GT. 0) THEN IREF(K+1)=0 K=K+1 GO TO 323 ELSE K=K+2 IF(K .GE. KS) GO TO 325 GO TO 321 ENDIF ELSE K=K+1 IF(K .GE. KS) GO TO 325 GO TO 321 ENDIF 325 CONTINUE KC=0 DO K=1,KS IF(IREF(K) .EQ. 0) CYCLE KC=KC+1 JREF(KC)=IREF(K) ALXX(KC)=ALXX(K) ALYY(KC)=ALYY(K) ALWD(KC)=ALWD(K) HLEFT(KC)=HLEFT(K) HMID(KC)=HMID(K) HRIGHT(KC)=HRIGHT(K) ENDDO IREF=JREF KS=KC ICTYP=NBRID KFS=1 DO K=1,KS III=K X11=ALXX(III)*TXSCAL - XS Y11=ALYY(III)*TXSCAL - XS ENDDO DO K=2,KS IF(IREF(K) .LT. 0 .OR. K .EQ. KS) THEN ! IF(K .LT. KS) THEN ! IF(IREF(K) .LT. 0 .AND. IREF(K+1) .GT. 0) THEN ! ITYPB=ICTYP+1 ! ICTYP=ICTYP+1 ! ELSE ! ITYPB=ITYPIN ! ENDIF ! ELSE ! ITYPB=ITYPIN ! ENDIF IF(KFS .EQ. 2 .OR. JPTSB .EQ. 0) THEN ITYPB=ICTYP ICTYP=ICTYP+1 KFS=1 ELSE KFS=KFS+1 ITYPB=ITYPIN ENDIF IF(ITYPB .GT. NBRID-1) THEN ICTT=(ITYPB-NBRID+1)*2 ICTT=ITYPBC(ICTT) IRTYP(ITYPB)=ICTT ELSE ICTT=0 IRTYP(ITYPB)=0 ENDIF JEND=K XLENGTHP=XLENGTH ! GO AND FORM A LINE ! IF(ICTT .EQ. 2) XLENGTHP=XBRLEN((ITYPB-39)*2) CALL FORMLINEL(I1D,I2D,JST,JEND,JKP,XLENGTHP,ITYPB,ICTT) JST=JEND ENDIF ENDDO IF(I2D .EQ. 1) CALL FORM999(1,1,NELC) ENDIF ! GO TO 4 ! END SUBROUTINE INTERP(GRIDX,GRIDY,NL,NH,INT,ALX,ALY,ATX,ATY,NINT,ISWT) ! ! Routine to fill GRIDX and GRIDY by interpolation ! NL = START OF GENERATED ! NH = END OF GENERATED ! INT = INTERVAL ! ALX, ALY = START LOC ! ATX, ATY = END LOC ! NINT = NUMBER OF POINTS ! ISWT = 0 BASELINE = 1 APPLY CHANGES !IPK MAY02 REAL*8 GRIDX(NH),GRIDY(NH),ALX,ALY,ATX,ATY ! ! Compute intervals ! XINT=(ATX-ALX)/FLOAT(NINT) YINT=(ATY-ALY)/FLOAT(NINT) ! ! Generate points ! IF(ISWT .EQ. 0) THEN KP=0 DO 200 K=NL,NH,INT IF(KP .EQ. 0) THEN GRIDX(K)=ALX GRIDY(K)=ALY ELSE GRIDX(K)=GRIDX(KP)+XINT GRIDY(K)=GRIDY(KP)+YINT ENDIF KP=K 200 CONTINUE ELSE XAD=ALX YAD=ALY KP=0 DO 220 K=NL,NH,INT IF(KP .EQ. 0) THEN GRIDX(K)=GRIDX(K)+XAD GRIDY(K)=GRIDY(K)+YAD ELSE XAD=XAD+XINT YAD=YAD+YINT GRIDX(K)=GRIDX(K)+XAD GRIDY(K)=GRIDY(K)+YAD ENDIF KP=K 220 CONTINUE ENDIF RETURN END SUBROUTINE GEL ! ! Routine to create a block of elements ! USE WINTERACTER USE BLK1MOD INCLUDE 'BFILES.I90' ! INCLUDE 'BLK1.COM' include 'd.inc' INCLUDE 'TXFRM.COM' !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL REAL*8 GRIDX,GRIDY,ALX,ALY,BLX,BLY,ARX,ARY,BRX,BRY,GRIDXL,GRIDYL INTEGER*2 IGSKP COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) ! CHARACTER*1 IFLAG data itime/0/ if(itime .eq. 0) then nx=0 ny=0 itime=1 endif CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to use'//& CHAR(13)//'existing nodes?' ,& 'ELEMENT CREATION OPTION') ! ! If answer 'No', point to location ! IF (WInfoDialog(4) .EQ. 2) then noptcr=0 GO TO 4 else noptcr=1 go to 1100 END IF 4 CONTINUE NHTP=0 NMESS=8 NBRR = 3 CALL HEDR ! ! Get screen coordinates of each end of line ! 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) ALX=XTEMP ALY=YTEMP IF(IRMAIN .EQ. 1) RETURN ! IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN CALL WRTOUT(0) RETURN elseif(iflag .eq. 'n') then call getfpna(XTEMP) call getfpna(YTEMP) ENDIF ! ! Exit input ! 9 CONTINUE ! CALL PLOTT(XTEMP,YTEMP,3) ! CALL PLOTT(XTEMP,YTEMP,2) siz=0.1 call drawcr(xtemp,ytemp,siz) NBRR=0 CALL HEDR CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) ARX=XTEMP ARY=YTEMP if(iflag .eq. 'n') then call getfpna(XTEMP) call getfpna(YTEMP) endif IF(IRMAIN .EQ. 1) RETURN ! 12 CONTINUE ! CALL PLOTT(XTEMP,YTEMP,3) ! CALL PLOTT(XTEMP,YTEMP,2) call drawcr(xtemp,ytemp,siz) CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) BRX=XTEMP BRY=YTEMP if(iflag .eq. 'n') then call getfpna(XTEMP) call getfpna(YTEMP) endif IF(IRMAIN .EQ. 1) RETURN ! 16 CONTINUE ! CALL PLOTT(XTEMP,YTEMP,3) ! CALL PLOTT(XTEMP,YTEMP,2) call drawcr(xtemp,ytemp,siz) CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) BLX=XTEMP BLY=YTEMP if(iflag .eq. 'n') then call getfpna(XTEMP) call getfpna(YTEMP) endif IF(IRMAIN .EQ. 1) RETURN ! 20 CONTINUE ! CALL PLOTT(XTEMP,YTEMP,3) ! CALL PLOTT(XTEMP,YTEMP,2) call drawcr(xtemp,ytemp,siz) go to 25 1100 continue CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE1,IFLAG,INSKP,IBOX) ALX=CORD(INODE1,1) ALY=CORD(INODE1,2) CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE2,IFLAG,INSKP,IBOX) ARX=CORD(INODE2,1) ARY=CORD(INODE2,2) CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE3,IFLAG,INSKP,IBOX) BRX=CORD(INODE3,1) BRY=CORD(INODE3,2) CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE4,IFLAG,INSKP,IBOX) BLX=CORD(INODE4,1) BLY=CORD(INODE4,2) ! ! Define number of elements along x and y sides ! 25 CONTINUE NMESS=45 CALL HEDR NMESS = 9 call getint(nx) ! READ(*,*) NX NMESS=45 CALL HEDR NMESS = 10 call getint(ny) ! READ(*,*) NY NXP=NX+1 NYP=NY+1 NRL=NX*NYP+1 NRT=NXP*NYP ! ipk jul01 test for limit exceeded if(nrt .gt. maxpgen) then call panelegn go to 25 endif DO N=1,NE DO M=1,8 NOPSV(N,M)=NOP(N,M) ENDDO IMATSV(N)=IMAT(N) ENDDO NESAV=NE NEFSAV=NENTRY NPUNDO=NRT ! ! Initialize GRIDX and GRIDY ! DO 100 N=1,NRT GRIDX(N)=0. GRIDY(N)=0. IGSKP(N)=0 100 END DO ! ! Interpolate left and right side ! CALL INTERP(GRIDX,GRIDY,1,NYP,1,ALX,ALY,BLX,BLY,NY,0) CALL INTERP(GRIDX,GRIDY,NRL,NRT,1,ARX,ARY,BRX,BRY,NY,0) ! ! plot points ! DO 200 N=1,NYP !IPK MAY02 XTEMP=GRIDX(N) YTEMP=GRIDY(N) GRIDXL(N) = GRIDX(N)*TXSCAL - XS GRIDYL(N) = GRIDY(N)*TXSCAL - YS CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) FPN = N CALL RRed ! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) siz=0.1 call drawcr(xtemp,ytemp,siz) CALL RBlue 200 END DO DO 220 N=NRL,NRT !IPK MAY02 XTEMP=GRIDX(N) YTEMP=GRIDY(N) GRIDXL(N) = GRIDX(N)*TXSCAL - XS GRIDYL(N) = GRIDY(N)*TXSCAL - YS CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) FPN = N CALL RRed ! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) call drawcr(xtemp,ytemp,siz) CALL RBlue 220 END DO ! ! Interpolate bottom and top sides ! CALL INTERP(GRIDX,GRIDY,1,NRL,NYP,ALX,ALY,ARX,ARY,NX,0) CALL INTERP(GRIDX,GRIDY,NYP,NRT,NYP,BLX,BLY,BRX,BRY,NX,0) ! ! plot points ! DO 240 N=1,NRL,NYP !IPK MAY02 XTEMP=GRIDX(N) YTEMP=GRIDY(N) GRIDXL(N) = GRIDX(N)*TXSCAL - XS GRIDYL(N) = GRIDY(N)*TXSCAL - YS CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) FPN = N CALL RRed ! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) call drawcr(xtemp,ytemp,siz) CALL RBlue 240 END DO DO 260 N=NYP,NRT,NYP !IPK MAY02 XTEMP=GRIDX(N) YTEMP=GRIDY(N) GRIDXL(N) = GRIDX(N)*TXSCAL - XS GRIDYL(N) = GRIDY(N)*TXSCAL - YS CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) FPN = N CALL RRed ! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) call drawcr(xtemp,ytemp,siz) CALL RBlue 260 END DO ! ! Interpolate interior points ! DO 300 M=2,NYP NFS=NRL+M-1 CALL INTERP(GRIDX,GRIDY,M,NFS,NYP,GRIDX(M),GRIDY(M),GRIDX(NFS) & & ,GRIDY(NFS),NX,0) DO N=M,NFS XTEMP=GRIDX(N) YTEMP=GRIDY(N) GRIDXL(N) = GRIDX(N)*TXSCAL - XS GRIDYL(N) = GRIDY(N)*TXSCAL - YS CALL RRed call drawcr(xtemp,ytemp,siz) CALL RBlue ENDDO 300 END DO 305 CONTINUE NMESS=11 NBRR=10 CALL HEDR 310 IBOX=1 ip=0 CALL PROX(GRIDX(1),GRIDY(1),NRT,XX,YY,IP,IFLAG,IGSKP,IBOX) IF(IBOX .NE. 6 .and. (ip .gt. 0 .and. ip .le. nrt)) THEN XKP=GRIDX(IP) YKP=GRIDY(IP) IPK=IP ENDIF IF(IRMAIN .EQ. 1 .OR. IBOX .EQ. 7) RETURN IF(IFLAG .EQ. 'q') THEN GO TO 400 ENDIF DO N=1,NRT GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL ENDDO IF(IBOX .EQ. 6) THEN XX=XKP YY=YKP IP=IPK GO TO 315 ENDIF write(90,*) 'back prox irdisp',IRDISP IF(IRDISP .EQ. 1) THEN CALL PLTPT ENDIF ! ! Get screen coordinate of new node location ! CALL XYLOC(XX,YY,IFLAG,IBOX) write(90,*) 'back xyloc irdisp',IRDISP IF(IRMAIN .EQ. 1 .OR. IBOX .EQ. 7) RETURN 315 IF(IRDISP .EQ. 1) THEN DO N=1,NRT GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL ENDDO CALL PLTPT ENDIF ! ! Establish difference from movement ! ALX=XX-GRIDX(IP) ALY=YY-GRIDY(IP) CALL PLOTT(XX,YY,3) CALL PLOTT(XX,YY,2) FPN = IP ! CALL RRed ! CALL NUMBR(XX,YY,0.20,FPN,0.0,-1) ! CALL RBlue ! ! Find location on boundary ! IF(IP .LE. NYP) THEN ! Left boundary NLW=IP NUP=NRL+IP-1 NSTP=NYP BLX=0. BLY=0. NS=NX ELSEIF(IP .GE. NRL) THEN ! Right boundary NLW=IP-NX*NYP NUP=IP NSTP=NYP BLX=ALX BLY=ALY ALX=0. ALY=0. NS=NX ELSE LINENO=(IP-1)/NYP IF(IP-LINENO*NYP .EQ. 1) THEN ! Lower boundary NLW=IP NUP=IP+NY NSTP=1 BLX=0. BLY=0. NS=NY ELSEIF(IP-LINENO*NYP .EQ. NYP) THEN ! Upper boundary NLW=IP-NY NUP=IP NSTP=1 BLX=ALX BLY=ALY ALX=0. ALY=0. NS=NY ELSE GO TO 305 ENDIF ENDIF ! ! Interpolate change along x line ! 14935011 IF(IRGB .EQ. 14935011) THEN call rgrey ELSE CALL RWHITEB ENDIF do n=1,nrt XTEMP=gridx(n) YTEMP=gridy(n) call drawcr(xtemp,ytemp,siz) enddo CALL RRed CALL INTERP(GRIDX,GRIDY,NLW,NUP,NSTP,ALX,ALY,BLX,BLY,NS,1) do n=1,nrt XTEMP=gridx(n) YTEMP=gridy(n) call drawcr(xtemp,ytemp,siz) GRIDXL(N) = GRIDX(N)*TXSCAL - XS GRIDYL(N) = GRIDY(N)*TXSCAL - YS enddo call Rblue GO TO 310 ! ! Copy points into cord array ! 400 CONTINUE DO 500 N=1,NRT ! ! Find next blank node in CORD ! IF(NOPTCR .EQ. 1) THEN IF(N .EQ. 1) THEN NODDEL(N)=0 GO TO 500 ELSEIF(N .EQ. NYP) THEN NODDEL(N)=0 GO TO 500 ELSEIF(N .EQ. 1+NYP*NX) THEN NODDEL(N)=0 GO TO 500 ELSEIF(N .EQ. NRT) THEN NODDEL(N)=0 GO TO 500 ENDIF ENDIF CALL GETNOD(J) NODDEL(N)=J ! ! Store GRIDX and GRIDY into it ! CORD(J,1) = GRIDX(N) CORD(J,2) = GRIDY(N) IGRIDE(N) = J INEW(J) = 1 INSKP(J) = 0 ! XUSR(J) = GRIDX(N)*TXSCAL - XS YUSR(J) = GRIDY(N)*TXSCAL - YS ! ! Display point ! CALL PLTNOD(J,1) ! 500 END DO ! ! Generate elements ! CALL GETELM(K) IECHG=0 ! DO 600 I=1,NX DO 590 J=1,NY CALL GETELM(K) IF(I .EQ. 1 .AND. J .EQ. 1 .AND. NOPTCR .EQ. 1) THEN NOP(K,1)=INODE1 ELSE NOP(K,1)=IGRIDE((I-1)*NYP+J) ENDIF NOP(K,2)=0 IF(I .EQ. NX .AND. J .EQ. 1 .AND. NOPTCR .EQ. 1) THEN NOP(K,3)=INODE2 ELSE NOP(K,3)=IGRIDE(I*NYP+J) ENDIF NOP(K,4)=0 IF(I .EQ. NX .AND. J .EQ. NY .AND. NOPTCR .EQ. 1) THEN NOP(K,5)=INODE3 ELSE NOP(K,5)=IGRIDE(I*NYP+J+1) ENDIF NOP(K,6)=0 IF(I .EQ. 1 .AND. J .EQ. NY .AND. NOPTCR .EQ. 1) THEN NOP(K,7)=INODE4 ELSE NOP(K,7)=IGRIDE((I-1)*NYP+J+1) ENDIF NOP(K,8)=0 IMAT(K)=1 ! IF(K .GT. NE) NE=K NCORN(K)=8 IESKP(K)=0 !IPK JAN98 IERC=0 IRDONE=0 CALL PLTELM(K,IERC) 590 CONTINUE 600 END DO ! CALL UNDO(IYES) ! IF(IYES .EQ. 1) THEN ! DO N=1,NEUNDO ! J=IELDEL(N) ! CALL DELTEL(J) ! ENDDO ! DO N=1,NPUNDO ! J=NODDEL(N) ! CALL DELETN(J) ! ENDDO ! ENDIF CALL WRTOUT(0) RETURN END SUBROUTINE PLTPT USE BLK1MOD INCLUDE 'TXFRM.COM' ! INCLUDE 'BLK1.COM' !IPK MAY02 REAL*8 GRIDX,GRIDY,GRIDXL,GRIDYL INTEGER*2 IGSKP COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) DO N=1,NRT GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL ENDDO ! ! plot points ! DO N=1,NYP !IPK MAY02 XTEMP=GRIDX(N) YTEMP=GRIDY(N) CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) FPN = N CALL RRed ! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) siz=0.1 call drawcr(xtemp,ytemp,siz) CALL RBlue END DO DO N=NRL,NRT !IP MAY02 XTEMP=GRIDX(N) YTEMP=GRIDY(N) CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) FPN = N CALL RRed ! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) call drawcr(xtemp,ytemp,siz) CALL RBlue END DO ! ! plot points ! DO N=1,NRL,NYP !IPK MAY02 XTEMP=GRIDX(N) YTEMP=GRIDY(N) CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) FPN = N CALL RRed ! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) call drawcr(xtemp,ytemp,siz) CALL RBlue END DO DO N=NYP,NRT,NYP !IPK MAY02 XTEMP=GRIDX(N) YTEMP=GRIDY(N) CALL PLOTT(XTEMP,YTEMP,3) CALL PLOTT(XTEMP,YTEMP,2) FPN = N CALL RRed ! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) call drawcr(xtemp,ytemp,siz) CALL RBlue END DO RETURN END subroutine panelegn USE WINTERACTER CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'You have requested '//& ' more than the allowable number of nodes.'//CHAR(13)//'The model will return '// & 'to allow new numbers to be input','Limit error') ! ! If answer 'Yes', execute ! IF (WInfoDialog(4) .EQ. 1) then return ENDIF return end SUBROUTINE FORMLINEMENU(ITYP,I1D,I2D,IFIN,XLENGTH,ITYPIN,NELC,NBRID) use winteracter implicit none SAVE include 'D.inc' INCLUDE 'BFILES.I90' DATA ITIME/0/ ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE integer :: ITYP,I1D,IERR,ITIME,I2D,IFIN,ITYPIN,NELC,NBRID real :: XLENGTH ! character*3 :: sub ! DATA ITIME/0/ ! IF(ITIME .EQ. 0) THEN XLENGTH=250. ITIME=1 I1D=0 I2D=1 IFIN=1 ITYPIN=30 NELC=2 NBRID=40 ! idf_radio1=2 ! ENDIF call wdialogload(IDD_FORMLINE) ierr=infoerror(1) call wdialogputRadioButton(idf_radio2) call wdialogputRadioButton(idf_radio3) CALL WDialogPutREAL(idf_REAL1,XLENGTH) CALL WDialogPutInteger(idf_INTEGER1,ITYPIN) call wdialogPutCheckBox(idf_check3,IFIN) CALL WDialogPutInteger(idf_INTEGER2,NELC) CALL WDialogPutInteger(idf_INTEGER3,NBRID) CALL WDialogSelect(IDD_FORMLINE) ierr=infoerror(1) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) DO IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN call wdialogGetRadioButton(idf_radio1,ITYP) call wdialogGetRadioButton(idf_radio3,I1D) call wdialogGetCheckBox(idf_check3,IFIN) CALL WDialogGetREAL(idf_REAL1,XLENGTH) CALL WDialogGetInteger(idf_INTEGER1,ITYPIN) CALL WDialogGetInteger(idf_INTEGER2,NELC) CALL WDialogGetInteger(idf_INTEGER3,NBRID) if(I1D .eq. 1) then I1D=0 I2D=0 ELSEIF(I1D .EQ. 2) THEN I1D=1 I2D=0 ELSEIF(I1D .EQ. 3) THEN I1D=0 I2D=1 ENDIF RETURN ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN I1D=-999 RETURN ENDIF ENDDO RETURN END SUBROUTINE FILEDAT(JPTS,NBRID) USE WINTERACTER USE DFLIB USE BLK1MOD ! ! ! Define some parameters to match those in the resource file ! include 'd.inc' REAL*8 ATMPAR CHARACTER(LEN=255) :: FNAME,FILTER CHARACTER(LEN=3) :: SUB CHARACTER ID*8,DLIN*72 IINALN=45 Filter='ALIGNMENT file -- *.dat|' CALL WSelectFile(Filter,PromptOn,FNAME,'Open Alignment File') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN CALL IlowerCase(FNAME) CALL GETSUB(FNAME,SUB) OPEN(IINALN,FILE=FNAME,STATUS='OLD',action='read') ELSE RETURN ENDIF DO K=1,2000 CALL GINPT(IINALN,ID,DLIN) IF(ID(1:3) .EQ. 'XYW') THEN READ(DLIN,*) ALXX(K),ALYY(K),ALWD(K),HLEFT(K),HMID(K),HRIGHT(K) ELSEIF(ID(1:3) .EQ. 'XY ') THEN READ(DLIN,*) ALXX(K),ALYY(K) ALWD(K)=0. ELSE JPTS=K-1 BACKSPACE(IINALN) GOTO 200 ENDIF ENDDO 200 CONTINUE READ(IINALN,'(A8)') ID IF(ID(1:7) .EQ. 'ENDFILE') RETURN CALL GETBRIDCUL(IINALN,NBRID) ! K=(JPTSB-2)/2+2 ! ALXX(K)=ALXX(2) ! ALYY(K)=ALYY(2) ! JPTS=K ! DO K=2,JPTSB-2,2 ! ALXX(K+1)=(BLXX(K)+BLXX(K+1))/2. ! ALYY(K+1)=(BLYY(K)+BLYY(K+1))/2. ! ALWD(K+1)=(BLWD(K)+BLWD(K+1))/2. ! ENDDO ! DO K=1,1000 ! ATMPAR=BLXX(K) ! BLXX(K)=ALXX(K) ! ALXX(K)=ATMPAR ! ATMPAR=BLYY(K) ! BLYY(K)=ALYY(K) ! ALYY(K)=ATMPAR ! ENDDO ! NTEMP=JPTSB ! JPTSB=JPTS ! NPTS=NTEMP RETURN END SUBROUTINE GETBRIDCUL(IINALN,NBRID) USE BLK1MOD INCLUDE 'TXFRM.COM' CHARACTER(LEN=140) :: DLINLARGE CHARACTER(LEN=8) :: IDN,ID REAL*8 TEMP(9),CPX,CPY,XCEN,YCEN,CW KID=0 PI=3.14159 KK=1 DO K=1,2000 CALL GINPT1(IINALN,DLINLARGE) IF(DLINLARGE(1:7) .EQ. 'CULVERT') THEN READ(DLINLARGE(9:140),*) idn,(TEMP(J),J=2,9) ITYPBC(KK)=1 ITYPBC(KK+1)=1 XCEN=(TEMP(2)+TEMP(4))/2. YCEN=(TEMP(3)+TEMP(5))/2. CW=TEMP(9)*TEMP(8)/2. IF(KK .EQ. 1) THEN CPX=ALXX(1) CPY=ALYY(1) ELSE CPX=BLXX(KK-1) CPY=BLYY(KK-1) ENDIF DNORM=ATAN2(YCEN-CPY,XCEN-CPX) IF(DNORM .LT. 0.) DNORM=DNORM+PI IF(DNORM .GT. PI) DNORM=DNORM-PI BLXX(KK)=XCEN-CW*COS(DNORM) BLYY(KK)=YCEN-CW*SIN(DNORM) BLWD(KK)=TEMP(7) CNX(KK,1)=BLXX(KK)-TEMP(6)/2.*COS(DNORM-PI/2.) CNX(KK,2)=BLXX(KK)+TEMP(6)/2.*COS(DNORM-PI/2.) CNY(KK,1)=BLYY(KK)-TEMP(6)/2.*SIN(DNORM-PI/2.) CNY(KK,2)=BLYY(KK)+TEMP(6)/2.*SIN(DNORM-PI/2.) KPT=NBRID+KK/2 KID(KPT,1)=KK DO KLM=1,2 CALL GETNOD(J) KID(KPT,KLM+1)=J INEW(J) = 1 INSKP(J) =0 XUSR(J)=CNX(KK,KLM) YUSR(J)=CNY(KK,KLM) CORD(J,1)=(XUSR(J)+XS)/TXSCAL CORD(J,2)=(YUSR(J)+YS)/TXSCAL ENDDO KK=KK+1 BLXX(KK)=XCEN+CW*COS(DNORM) BLYY(KK)=YCEN+CW*SIN(DNORM) BLWD(KK)=TEMP(7) CNX(KK-1,3)=BLXX(KK)-TEMP(6)/2.*COS(DNORM-PI/2.) CNX(KK-1,4)=BLXX(KK)+TEMP(6)/2.*COS(DNORM-PI/2.) CNY(KK-1,3)=BLYY(KK)-TEMP(6)/2.*SIN(DNORM-PI/2.) CNY(KK-1,4)=BLYY(KK)+TEMP(6)/2.*SIN(DNORM-PI/2.) DO KLM=3,4 CALL GETNOD(J) KID(KPT,KLM+1)=J INEW(J) = 1 INSKP(J) =0 XUSR(J)=CNX(KK-1,KLM) YUSR(J)=CNY(KK-1,KLM) CORD(J,1)=(XUSR(J)+XS)/TXSCAL CORD(J,2)=(YUSR(J)+YS)/TXSCAL ENDDO KK=KK+1 ELSEIF(DLINLARGE(1:6) .EQ. 'BRIDGE') THEN READ(DLINLARGE(7:140),*) IDN,(TEMP(J),J=1,7) ITYPBC(KK)=2 ITYPBC(KK+1)=2 BLXX(KK)=TEMP(1) BLYY(KK)=TEMP(2) BLWD(KK)=TEMP(3) KK=KK+1 BLXX(KK)=TEMP(4) BLYY(KK)=TEMP(5) BLWD(KK)=TEMP(6) XBRLEN(KK)=SQRT((BLXX(KK)-BLXX(KK-1))**2+(BLYY(KK)-BLYY(KK-1))**2) KK=KK+1 ! READ(DLINLARGE(8:140),*) ID,(TEMP(J),J=1,6) ELSEIF(DLINLARGE(1:7) .EQ. 'ENDFILE') THEN JPTSB=KK-1 GO TO 200 ENDIF ENDDO 200 CONTINUE RETURN END