You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
376 lines
11 KiB
Fortran
376 lines
11 KiB
Fortran
5 years ago
|
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
|
||
|
|
|