! Last change: IPK 12 Jan 98 1:44 pm ! SUBROUTINE GNODE ! ! 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,ALXX(1000),ALYY(1000),ALWD(1000) REAL*8 BLXX(1000),BLYY(1000),BLWD(1000) INTEGER ITYPBC(1000) ! CHARACTER*1 IFLAG data itime/0/ if(itime .eq. 0) then nh=1 itime=1 endif 4 CONTINUE CALL FORMLINEMENU(ITYP,I1D,I2D,IFIN,XLENGTH) IF(I1D .EQ. -999) RETURN IF(ITYP .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 IF(IFIN .EQ. 0) THEN NHTP = 0 NMESS = 6 NBRR = 3 CALL HEDR ! ! Get screen coordinates of each end of line ! DO J=1,1000 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(ALXX,ALYY,ALWD,JPTS,BLXX,BLYY,BLWD,NPTSB,ITYPBC) DO J=1,JPTS ALXX(J)=(ALXX(J)+XS)/TXSCAL ALYY(J)=(ALYY(J)+YS)/TXSCAL ENDDO ENDIF ! COMPUTE OVERALL LENGTH TOTLEN=0. DO J=1,JPTS-1 TOTLEN=TOTLEN+SQRT((ALXX(J+1)-ALXX(J))**2+(ALYY(J+1)-ALYY(J))**2) ENDDO ! ESTIMATE NUMBER OF ELEMENTS NELTS=TOTLEN*TXSCAL/XLENGTH+1 XLENGTH=TOTLEN*TXSCAL/NELTS ! GET NEW NODE LOCATIONS AND CREAT ELEMENT CALL GETNOD(J) JKP=J ! ! Store GRIDX and GRIDY into it ! CORD(J,1) = ALXX(1) CORD(J,2) = ALYY(1) IF(ALWD(1).GT. 0.) THEN WIDTH(J)=ALWD(1) ENDIF INEW(J) = 1 INSKP(J) = 0 ! XUSR(J) = ALXX(1)*TXSCAL - XS YUSR(J) = ALYY(1)*TXSCAL - YS ! ! Display point ! CALL PLTNOD(J,1) JPTC=2 XLENGTHR=XLENGTH/TXSCAL XCUR=ALXX(1) YCUR=ALYY(1) DO N=1,NELTS 500 ANGLEL=ATAN2(ALYY(JPTC)-ALYY(JPTC-1),ALXX(JPTC)-ALXX(JPTC-1)) XNEXT=XCUR+XLENGTHR*COS(ANGLEL) YNEXT=YCUR+XLENGTHR*SIN(ANGLEL) IF(ALXX(JPTC)-ALXX(JPTC-1) .NE. 0.) THEN FRAC=(XNEXT-ALXX(JPTC-1))/(ALXX(JPTC)-ALXX(JPTC-1)) ELSE FRAC=(YNEXT-ALYY(JPTC-1))/(ALYY(JPTC)-ALYY(JPTC-1)) ENDIF IF(FRAC .GT. 1. .AND. JPTC .LT. JPTS) THEN XLENGTHR=XLENGTHR-SQRT((ALXX(JPTC)-XCUR)**2+(ALYY(JPTC)-YCUR)**2) XCUR=ALXX(JPTC) YCUR=ALYY(JPTC) JPTC=JPTC+1 GO TO 500 ENDIF ! GET NEW LOCATION CALL GETNOD(J) IF(ALWD(1).GT. 0.) THEN WIDTH(J)=ALWD(JPTC-1)+FRAC*(ALWD(JPTC)-ALWD(JPTC-1)) ENDIF ! ! Store GRIDX and GRIDY into it ! CORD(J,1) = XNEXT CORD(J,2) = YNEXT INEW(J) = 1 INSKP(J) = 0 ! XUSR(J) = XNEXT*TXSCAL - XS YUSR(J) = YNEXT*TXSCAL - YS ! ! Display point ! CALL PLTNOD(J,1) XCUR=XNEXT YCUR=YNEXT XLENGTHR=XLENGTH/TXSCAL IF(I1D .EQ. 1 .OR. I2D .EQ. 1) THEN IF(N .EQ. 1) THEN J1=JKP IF(ALWD(1) .NE. 0.) GO TO 600 call nodedisp(jKP) ENDIF IF(ALWD(1) .NE. 0.) GO TO 600 WIDTH(J)=WIDTH(J1) WD(J)=WD(J1) SS1(J)=SS1(J1) SS2(J)=SS2(J1) WIDS(J)=WIDS(J1) WIDBS(J)=WIDBS(J1) SSO(J)=SSO(J1) BS1(J)=BS1(J1) 600 call getelm(k) NOP(K,1)=J1 NOP(K,2)=0 NOP(K,3)=J NCORN(K)=3 IMAT(K)=1 IESKP(K) = 0 NE = MAX(K,NE) IERC=0 CALL PLTELM(K,IERC) J1=J ENDIF ENDDO ENDIF IF(I2D .EQ. 1) CALL FORM999(1,1) ! 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 '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 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) 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 real :: XLENGTH character*3 :: sub DATA ITIME/0/ IF(ITIME .EQ. 0) THEN XLENGTH=100. ITIME=1 I1D=0 I2D=1 IFIN=1 ENDIF call wdialogload(IDD_FORMLINE) ierr=infoerror(1) call wdialogputRadioButton(idf_radio1) call wdialogputcheckbox(IDF_CHECK1,I1D) call wdialogputcheckbox(IDF_CHECK2,I2D) call wdialogputcheckbox(IDF_CHECK3,IFIN) CALL WDialogPutREAL(idf_REAL1,XLENGTH) 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 wdialogGetCheckBox(idf_check1,I1D) call wdialogGetCheckBox(idf_check2,I2D) call wdialogGetCheckBox(idf_check3,IFIN) CALL WDialogGetREAL(idf_REAL1,XLENGTH) RETURN ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN I1D=-999 RETURN ENDIF ENDDO RETURN END SUBROUTINE FILEDAT(ALXX,ALYY,ALWD,NPTS,BLXX,BLYY,BLWD,NPTSB,ITYPBC) USE WINTERACTER USE DFLIB ! ! ! Define some parameters to match those in the resource file ! include 'd.inc' REAL*8 ALXX(*),ALYY(*),ALWD(*),BLXX(*),BLYY(*),BLWD(*) INTEGER ITYPBC(*) 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,1000 CALL GINPT(IINALN,ID,DLIN) IF(ID(1:3) .EQ. 'XYW') THEN READ(DLIN,*) ALXX(K),ALYY(K),ALWD(K) ELSEIF(ID(1:3) .EQ. 'XY ') THEN READ(DLIN,*) ALXX(K),ALYY(K) ALWD(K)=0. ELSE NPTS=K-1 GOTO 200 ENDIF ENDDO 200 CONTINUE READ(IINALN,'(A8)') ID IF(ID(1:7) .EQ. 'ENDFILE') RETURN CALL GETBRIDCUL(BLXX,BLYY,BLWD,NPTSB,ITYPBC) 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=NPTSB NPTSB=NPTS NPTS=NTEMP RETURN END SUBROUTINE GETBRIDCUL(BLXX,BLYY,BLWD,NPTSB,ITYPBC) CHARACTER(LEN=140) :: DLINLARGE DIMENSION TEMP(7) REAL*8 BLXX(*),BLYY(*),BLWD(*) INTEGER ITYPBC(*) KK=1 DO K=1,1000 CALL GINPT1(IINALN,DLINLARGE) READ(DLINLARGE(7:140),*) ID,(TEMP(J),J=1,6) IF(DLINLARGE(1:6) .EQ. 'CULVERT') THEN ITYPBC(KK)=1 ELSEIF(DLINLARGE(1:6) .EQ. 'BRIDGE ') THEN ITYPBC(KK)=2 ELSEIF(DLINLARGE(1:6) .EQ. 'ENDFIL') THEN NPTSB=KK ENDIF 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) ENDDO RETURN END