SUBROUTINE crgrid USE BLK1MOD USE BLKMAP REAL*8 GRIDX,GRIDY,GRIDXL,GRIDYL,XL,YL,ANGD,GETANG1,A,B,C,D INTEGER*2 IGSKP dimension XL(1500,3),YL(1500,3),mappt(2),XL1(500),XL2(500) INCLUDE 'TXFRM.COM' COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) ! ! define line numbers in map file ! ITEST=1 CALL PANELGENBLK(NY,XSZ,KL1,KL2,ISW1,ISW2,ITEST) JS=1 ! K=0 KL=1 CALL RCyan DO 20 J=1,MAXPTS MLEN=J-JS IF(XMAP(J) .LE. VDX .or. j .eq. maxpts) THEN IF(J .EQ. MAXPTS .AND. XMAP(J) .GT. VDX) MLEN=MLEN+1 ! ! K=K+1 IF(K .EQ. KL2) THEN DO KK=1,MLEN XL(KK,1)=XMAP(KK+JS-1) YL(KK,1)=YMAP(KK+JS-1) ENDDO IF(ISW2 .EQ. 1) THEN DO KK=MLEN,1,-1 XL(KK,3)=XL(MLEN-KK+1,1) YL(KK,3)=YL(MLEN-KK+1,1) ENDDO DO KK=1,MLEN XL(KK,1)=XL(KK,3) YL(KK,1)=YL(KK,3) ENDDO ENDIF MAPPT(1)=MLEN ENDIF IF(K .EQ. KL1) THEN DO KK=1,MLEN XL(KK,2)=XMAP(KK+JS-1) YL(KK,2)=YMAP(KK+JS-1) ENDDO IF(ISW1 .EQ. 1) THEN DO KK=MLEN,1,-1 XL(KK,3)=XL(MLEN-KK+1,2) YL(KK,3)=YL(MLEN-KK+1,2) ENDDO DO KK=1,MLEN XL(KK,2)=XL(KK,3) YL(KK,2)=YL(KK,3) ENDDO ENDIF MAPPT(2)=MLEN ENDIF JS=J+1 KL=2 ENDIF 20 CONTINUE K1=1 K2=2 ! ! compute line length ! XL1=0. nlpts1=mappt(k1) do n=2,nlpts1 XL1(n)=XL1(n-1)+SQRT((XL(N,1)-XL(n-1,1))**2+(YL(n,1)-YL(n-1,1))**2) enddo XL2=0. nlpts2=mappt(k2) do n=2,nlpts2 XL2(n)=XL2(n-1)+SQRT((XL(N,2)-XL(n-1,2))**2+(YL(n,2)-YL(n-1,2))**2) enddo xmean=(XL1(nlpts1)+XL2(nlpts2))/2. ! ! get size spacing ! along=xmean/xsz NX=(along+0.99) NXP=NX+1 NYP=NY+1 NRL=NX*NYP+1 NRT=NXP*NYP 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 N=1,NRT GRIDX(N)=0. ! GRIDY(N)=0. IGSKP(N)=0 END DO ! ! calculate lengths ! xalong1=XL1(nlpts1)/NX xalong2=XL2(nlpts2)/NX ! ! compute cords along the edges ! XALONG=0. XXALONG=0. GRIDX(1)=XL(1,1) GRIDY(1)=YL(1,1) GRIDX(NYP)=XL(1,2) GRIDY(NYP)=YL(1,2) NRT=NXP*NYP NX1=2 NX2=2 NCR=1 DO N=NY+2,NRT,NYP NCR=NCR+1 XALONG=XALONG+XALONG1 DO M=NX1,NLPTS1 IF(XALONG .LT. XL1(M)) THEN M1=M GO TO 200 ENDIF ENDDO 200 CONTINUE FRAC1=(XALONG-XL1(M1-1))/(XL1(M1)-XL1(M1-1)) GRIDX(N)=XL(m1-1,1)+FRAC1*(XL(m1,1)-XL(m1-1,1)) GRIDY(N)=YL(m1-1,1)+FRAC1*(YL(m1,1)-YL(m1-1,1)) NX1=M1 XXALONG=XXALONG+XALONG2 DO M=NX2,NLPTS2 IF(XXALONG .LT. XL2(M)) THEN M2=M GO TO 250 ENDIF ENDDO 250 CONTINUE FRAC1=(XXALONG-XL2(M2-1))/(XL2(M2)-XL2(M2-1)) GRIDX(N+NY)=XL(m2-1,2)+FRAC1*(XL(m2,2)-XL(m2-1,2)) GRIDY(N+NY)=YL(m2-1,2)+FRAC1*(YL(m2,2)-YL(m2-1,2)) NX2=M2 ANGD1=GETANG1(GRIDX(N-NY-1),GRIDY(N-NY-1),GRIDX(N),GRIDY(N),GRIDX(N+NY),GRIDY(N+NY)) ANGD2=GETANG1(GRIDX(N),GRIDY(N),GRIDX(N+NY),GRIDY(N+NY),GRIDX(N-1),GRIDY(N-1)) ANGM1=(ANGD1+180-ANGD2)/2. ! WRITE(151,*) N,ANGD1,ANGD2,ANGM1 IF(ITEST .EQ. 1) THEN XALONGKP=XALONG XXALONGKP=XXALONG ! write(151,*) 'b',xalong,xxalong IF(ANGM1 .GT. 100. .OR. ANGM1 .LT. 80.) THEN IF(ANGM1 .GT. 100) THEN XALONG=XALONG+XALONG1/2. XXALONG=XXALONG-XALONG2/2. ELSE XALONG=XALONG-XALONG1/2. XXALONG=XXALONG+XALONG2/2. ENDIF ! WRITE(151,*) 'a',XALONG,XXALONG itag=0 275 CONTINUE DO M=1,NLPTS1 IF(XALONG .LT. XL1(M)) THEN M1=M GO TO 300 ENDIF ENDDO 300 CONTINUE FRAC1=(XALONG-XL1(M1-1))/(XL1(M1)-XL1(M1-1)) GRIDX(N)=XL(m1-1,1)+FRAC1*(XL(m1,1)-XL(m1-1,1)) GRIDY(N)=YL(m1-1,1)+FRAC1*(YL(m1,1)-YL(m1-1,1)) NX1=M1 DO M=1,NLPTS2 IF(XXALONG .LT. XL2(M)) THEN M2=M GO TO 350 ENDIF ENDDO 350 CONTINUE FRAC1=(XXALONG-XL2(M2-1))/(XL2(M2)-XL2(M2-1)) GRIDX(N+NY)=XL(m2-1,2)+FRAC1*(XL(m2,2)-XL(m2-1,2)) GRIDY(N+NY)=YL(m2-1,2)+FRAC1*(YL(m2,2)-YL(m2-1,2)) NX2=M2 ANGD3=GETANG1(GRIDX(N-NY-1),GRIDY(N-NY-1),GRIDX(N),GRIDY(N),GRIDX(N+NY),GRIDY(N+NY)) ANGD4=GETANG1(GRIDX(N),GRIDY(N),GRIDX(N+NY),GRIDY(N+NY),GRIDX(N-1),GRIDY(N-1)) ANGM2=(ANGD3+180-ANGD4)/2. ! WRITE(151,*) N,ANGD3,ANGD4,ANGM2 if(itag .eq. itest) go to 375 IF(ANGM1 .LT. 80. .AND. ANGM2 .GT. 100.) THEN FRAC=(ANGM2-90)/(ANGM2-ANGM1) XALONG=XALONG+XALONG1/2.*FRAC XXALONG=XXALONG-XALONG2/2.*FRAC itag=1 ! WRITE(151,*) XALONG,XXALONG GO TO 275 ELSEIF(ANGM1 .GT. 100. .AND. ANGM2 .LT. 80.) THEN FRAC=(90-ANGM2)/(ANGM1-ANGM2) XALONG=XALONG-XALONG1/2.*FRAC XXALONG=XXALONG+XALONG2/2.*FRAC itag=1 ! WRITE(151,*) XALONG,XXALONG GO TO 275 ! WRITE(151,*) XALONG,XXALONG ENDIF XALONG1=(XL1(nlpts1)-XALONG)/(NXP-NCR) XALONG2=(XL2(nlpts2)-XXALONG)/(NXP-NCR) 375 continue ENDIF ENDIF ENDDO ! ! ! check if points ok allow for move ! ! ! form elements and other coordinates ! ! ! Interpolate interior points ! DO M=1,NRT,NYP NFS=NRL+M-1 CALL INTERP(GRIDX,GRIDY,M,M+NY,1,GRIDX(M),GRIDY(M),GRIDX(M+NY) & & ,GRIDY(M+NY),NY,0) DO N=M,M+NY GRIDXL(N)=GRIDX(N) GRIDYL(N)=GRIDY(N) GRIDX(N) =(GRIDXL(N)+XS)/TXSCAL GRIDY(N) =(GRIDYL(N)+YS)/TXSCAL XTEMP=GRIDX(N) YTEMP=GRIDY(N) SIZ=0.1 CALL RRed call drawcr(xtemp,ytemp,siz) CALL RBlue ENDDO END DO ! ! query for depths ! ! ! query for happY DO 500 N=1,NRT ! ! Find next blank node in CORD ! 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 WD(J)=-9999. ! 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) NOP(K,1)=IGRIDE((I-1)*NYP+J) NOP(K,2)=0 NOP(K,3)=IGRIDE(I*NYP+J) NOP(K,4)=0 NOP(K,5)=IGRIDE(I*NYP+J+1) NOP(K,6)=0 NOP(K,7)=IGRIDE((I-1)*NYP+J+1) 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 WRTOUT(0) RETURN end REAL*8 FUNCTION GETANG1(X1,Y1,X2,Y2,X3,Y3) REAL*8 X1,Y1,X2,Y2,X3,Y3,CAN C=SQRT((X2-X1)**2+(Y2-Y1)**2) B=SQRT((X3-X2)**2+(Y3-Y2)**2) A=SQRT((X1-X3)**2+(Y1-Y3)**2) CAN=(B**2+C**2-A**2)/(2.*B*C) GETANG1=DACOSD(CAN) RETURN END SUBROUTINE PANELgenblk(N1,XL,N2,N3,ISW1,ISW2,ITEST) use winteracter implicit none include 'D.inc' ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE integer :: N1,N2,N3,IERR,IFIRST,ISW1,ISW2,ITEST real :: XL character*3 :: sub DATA IFIRST/0/ IF(IFIRST .EQ. 0) THEN IFIRST=1 N1=1 N2=1 N3=2 XL=5. isw1=0 isw2=0 ENDIF call wdialogload(IDD_GENBLK) ierr=infoerror(1) CALL WDialogPutInteger(idf_integer1,n1) CALL WDialogPutInteger(idf_integer2,n2) CALL WDialogPutInteger(idf_integer3,n3) CALL WDialogPutInteger(idf_integer5,ITEST) CALL WDialogPutReal(idf_real1,xl) CALL WDialogPutCheckBox(idf_check1,isw1) CALL WDialogPutCheckBox(idf_check2,isw2) CALL WDialogSelect(IDD_GENBLK) ierr=infoerror(1) CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN CALL WDialogGetInteger(idf_integer1,n1) CALL WDialogGetInteger(idf_integer2,n2) CALL WDialogGetInteger(idf_integer3,n3) CALL WDialogGetReal(idf_real1,xl) CALL WDialogGetInteger(idf_integer5,ITEST) CALL WDialogGetCheckBox(idf_check1,isw1) CALL WDialogGetCheckBox(idf_check2,isw2) ENDIF RETURN END