! 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),CURRENTX,CURRENTY INTEGER ITYPBC(1000),IREF(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,ITYPIN,NELC) 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,JPTSB,ITYPBC) ENDIF ! SORT OUT A NEW ORDER IREF=1 CURRENTX=ALXX(1) CURRENTY=ALYY(1) KS=2 KSP=1 DO J=2,JPTS 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 320 CONTINUE ENDDO IREF(KS)=JPTS IF(IFIN .GT. 0) THEN 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)) WRITE(155,*) K,IREF(K),ALXX(K),ALYY(K) ELSE ALXX(K)=ALXX(IREF(K)) ALYY(K)=ALYY(IREF(K)) ALWD(K)=BLWD(IREF(K)) WRITE(155,*) K,IREF(K),ALXX(K),ALYY(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 ICTYP=40 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(MOD(K,2) .EQ. 0) THEN ITYPB=ITYPIN ELSE ITYPB=ICTYP ICTYP=ICTYP+1 ENDIF IF(ITYPB .GT. 39) THEN ICTT=(ITYPB-39)*2 ICTT=ITYPBC(ICTT) ELSE ICTT=0 ENDIF JEND=K XLENGTHP=XLENGTH ! GO AND FORM A LINE CALL FORMLINEL(I1D,I2D,ALXX,ALYY,ALWD,JST,JEND,JKP,XLENGTHP,ITYPB,ICTT) JST=JEND ENDIF ENDDO ENDIF IF(I2D .EQ. 1) CALL FORM999(1,1,NELC) ! 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,ITYPIN,NELC) 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 real :: XLENGTH character*3 :: sub DATA ITIME/0/ IF(ITIME .EQ. 0) THEN XLENGTH=100. ITIME=1 I1D=0 I2D=1 IFIN=1 ITYPIN=1 NELC=2 ENDIF call wdialogload(IDD_FORMLINE) ierr=infoerror(1) call wdialogputRadioButton(idf_radio1) 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 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) 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(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 BACKSPACE(IINALN) GOTO 200 ENDIF ENDDO 200 CONTINUE READ(IINALN,'(A8)') ID IF(ID(1:7) .EQ. 'ENDFILE') RETURN CALL GETBRIDCUL(IINALN,ALXX,ALYY,BLXX,BLYY,BLWD,NPTSB,ITYPBC) K=(NPTSB-2)/2+2 ALXX(K)=ALXX(2) ALYY(K)=ALYY(2) NPTS=K DO K=2,NPTSB-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=NPTSB ! NPTSB=NPTS ! NPTS=NTEMP RETURN END SUBROUTINE GETBRIDCUL(IINALN,ALXX,ALYY,BLXX,BLYY,BLWD,NPTSB,ITYPBC) CHARACTER(LEN=140) :: DLINLARGE CHARACTER(LEN=8) :: ID REAL*8 TEMP(8) REAL*8 ALXX(*),ALYY(*),BLXX(*),BLYY(*),BLWD(*) INTEGER ITYPBC(*) PI=3.14159 KK=1 DO K=1,1000 CALL GINPT1(IINALN,DLINLARGE) IF(DLINLARGE(1:7) .EQ. 'CULVERT') THEN READ(DLINLARGE(8:140),*) IDN,(TEMP(J),J=1,8) ITYPBC(KK)=1 ITYPBC(KK+1)=1 XCEN=(TEMP(2)+TEMP(4))/2. YCEN=(TEMP(3)+TEMP(5))/2. CW=TEMP(7)*TEMP(8)/2. IF(KK .EQ. 1) THEN DNORM=ATAN2(TEMP(3)-ALYY(1),TEMP(2)-ALXX(1)) ELSE DNORM=ATAN2(TEMP(3)-BLYY(KK-1),TEMP(2)-BLXX(KK-1)) ENDIF WRITE(155,*) KK,DNORM IF(DNORM .LT. 0.) DNORM=DNORM+PI IF(DNORM .GT. PI) DNORM=DNORM-PI WRITE(155,*) KK,DNORM BLXX(KK)=XCEN-CW*COS(DNORM) BLYY(KK)=YCEN-CW*SIN(DNORM) BLWD(KK)=TEMP(6) KK=KK+1 BLXX(KK)=XCEN+CW*COS(DNORM) BLYY(KK)=YCEN+CW*SIN(DNORM) BLWD(KK)=TEMP(6) 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(2) BLYY(KK)=TEMP(3) BLWD(KK)=TEMP(4) KK=KK+1 BLXX(KK)=TEMP(5) BLYY(KK)=TEMP(6) BLWD(KK)=TEMP(7) KK=KK+1 READ(DLINLARGE(8:140),*) ID,(TEMP(J),J=1,6) ELSEIF(DLINLARGE(1:7) .EQ. 'ENDFILE') THEN NPTSB=KK-1 GO TO 200 ENDIF ENDDO 200 CONTINUE DO K=1,NPTSB WRITE(156,*) K,BLXX(K),BLYY(K),BLWD(K) ENDDO RETURN END