VERSION84 WITH NEW GRID PLOTTING AND 1D EXPANSION
Ian P King
5 years ago
parent
4a4eef2a0b
commit
8f3dbc8e9c
@ -0,0 +1,311 @@
|
||||
SUBROUTINE BuildModel(NP,NE)
|
||||
|
||||
!
|
||||
!
|
||||
USE WINTERACTER
|
||||
USE BLK3D
|
||||
! USE BLK1MOD
|
||||
INCLUDE 'd.inc'
|
||||
|
||||
REAL, DIMENSION(4,4) :: A
|
||||
REAL, DIMENSION(700) :: XLIN,YLIN,BLVL
|
||||
REAL :: ViewAngle = 0.0
|
||||
INTEGER :: ITYPIMAGE = 4
|
||||
INTEGER , DIMENSION(6) :: WIDSTAT
|
||||
REAL, PARAMETER :: DEFDIST = 5.0
|
||||
REAL :: ROTH=0.0
|
||||
REAL :: ROTV=0.0
|
||||
REAL :: ROT=0.0
|
||||
REAL :: SHIFT=0.0
|
||||
REAL :: SHIFTV=0.0
|
||||
|
||||
INTEGER K,J,NCN,KK,mat,JHAND1
|
||||
CHARACTER(LEN=260) :: FILENAME = 'objects.w3d'
|
||||
CHARACTER(LEN=65) :: STBAR1
|
||||
|
||||
DATA ITIME/0/
|
||||
!
|
||||
IF(ITIME .EQ. 0) THEN
|
||||
IROTSV=0
|
||||
ROTSV=0.0
|
||||
ROTHSV=0.
|
||||
ROTVSV=0.
|
||||
DISTSV=0.
|
||||
VSCALESV=1.0
|
||||
ITIME=1
|
||||
ENDIF
|
||||
|
||||
! CALL WindowOpenChild(JHAND1,HIDEWINDOW,WIDTH=1000,HEIGHT=600)
|
||||
CALL WindowOpenChild(JHAND1,FLAGS =SysMenuOn+MinButton+MaxButton+StatusBar, &
|
||||
MENUID=IDM_MENU1,TOOLID=(/0,IDT_TOOLBAR1,0,0/),&
|
||||
TITLE ='View RMA 3D model files' )
|
||||
CALL WINDOWSELECT(JHAND1)
|
||||
!
|
||||
! Create a bitmap of same size as window and draw initial frame
|
||||
!
|
||||
WIDSTAT(1) = 1000
|
||||
WIDSTAT(2) = 2000
|
||||
WIDSTAT(3) = 1000
|
||||
WIDSTAT(4) = 1000
|
||||
WIDSTAT(5) = 1000
|
||||
WIDSTAT(6) = 2000
|
||||
CALL WindowStatusBarParts(6, WIDSTAT)
|
||||
CALL WindowOutStatusBar(1, ' Rotations, Translations ')
|
||||
CALL WindowOutStatusBar(3, ' Eye Distance')
|
||||
CALL WindowOutStatusBar(5, ' Adjusted Eye Location')
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
CALL WBitmapCreate(JHAND1,WInfoWindow(WindowWidth), &
|
||||
WInfoWindow(WindowHeight))
|
||||
|
||||
!
|
||||
! Start a new model
|
||||
!
|
||||
! Estimate vertices and facets
|
||||
MAXVERT=NP
|
||||
MAXFACET=2*NE
|
||||
CALL W3dNew(MAXVERT,MAXFACET,20)
|
||||
!
|
||||
CALL W3dGetMatrix(A)
|
||||
!
|
||||
CALL W3dMatrix(A)
|
||||
CALL W3dTranslate(0.0,0.0,0.0)
|
||||
CALL W3dScale(1.0,-VSCALESV,1.0)
|
||||
|
||||
CALL TRPLAT(IQUAL)
|
||||
!
|
||||
! Define materials
|
||||
!
|
||||
DO K=1,9
|
||||
CALL W3dMaterial(K,WRGB(255,128,64))
|
||||
ENDDO
|
||||
|
||||
!!
|
||||
!
|
||||
! Determine model extent
|
||||
!
|
||||
XMIN = WInfo3dReal(M3dXmin)
|
||||
XMAX = WInfo3dReal(M3dXmax)
|
||||
YMIN = WInfo3dReal(M3dYmin)
|
||||
YMAX = WInfo3dReal(M3dYmax)
|
||||
ZMIN = WInfo3dReal(M3dZmin)
|
||||
ZMAX = WInfo3dReal(M3dZmax)
|
||||
! CALL W3dGetMatrix(MODEL)
|
||||
|
||||
!
|
||||
XLEN = XMAX - XMIN
|
||||
YLEN = YMAX - YMIN
|
||||
ZLEN = ZMAX - ZMIN
|
||||
DIST = DEFDIST*MAX(XLEN,YLEN,ZLEN)
|
||||
WRITE(STBAR1,'(F13.3)') DIST
|
||||
CALL WindowOutStatusBar(4,STBAR1)
|
||||
DISTSTEP = DIST / 50.
|
||||
|
||||
CALL W3dMatrix()
|
||||
IF(IROTSV .EQ. 1) THEN
|
||||
CALL W3dRotate(-45.+ROTVSV,1)
|
||||
CALL W3dRotate(ROTHSV,2)
|
||||
CALL W3dRotate(ROTSV,3)
|
||||
ROTV=ROTVSV
|
||||
ROTH=ROTHSV
|
||||
ROT=ROTSV
|
||||
DIST=DISTSV
|
||||
ELSE
|
||||
CALL W3dRotate(-45.,1)
|
||||
CALL W3dRotate(0.,2)
|
||||
CALL W3dRotate(0.,3)
|
||||
ENDIF
|
||||
CALL W3dGetMatrix(EYE)
|
||||
EYE(1,4) = XMIN + XLEN/2.0
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0
|
||||
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
! CALL WMessageBox(YesNo,QuestionIcon,CommonYes, &
|
||||
! 'Do you wish to continue (YES) or quit (NO) this view ?', 'CONTINUE?')
|
||||
! IF(WInfoDialog(4) .eq. 1) then
|
||||
! GO TO 300
|
||||
! ELSE
|
||||
! CALL WindowCloseChild(JHAND1)
|
||||
! return
|
||||
! ENDIF
|
||||
300 continue
|
||||
CALL CHVIEW(JHAND1,ITYPIMAGE)
|
||||
CALL WindowCloseChild(JHAND1)
|
||||
CALL WBitmapDestroy(JHAND1)
|
||||
I3DPLT=0
|
||||
|
||||
|
||||
RETURN
|
||||
END SUBROUTINE BuildModel
|
||||
|
||||
SUBROUTINE TRPLAT(IQUAL)
|
||||
use winteracter
|
||||
USE BLK1MOD
|
||||
|
||||
!
|
||||
! Build a surface
|
||||
!
|
||||
!
|
||||
REAL :: WM
|
||||
REAL XSING,YSING,BLVL
|
||||
allocatable XSING(:),YSING(:),BLVL(:)
|
||||
INTEGER :: IVERT,IFACET,NCNS,K,KK,MAXNP
|
||||
INTEGER :: IVERTICES(4)
|
||||
INTEGER :: IFCORNER(3,1) = RESHAPE((/1,3,5/),(/3,1/))
|
||||
! INTEGER :: IFCORNER(3,4) = RESHAPE((/1,2,6,2,3,5,2,4,6,4,5,6/),(/3,4/))
|
||||
! INTEGER :: IFCORNERR(3,8) = RESHAPE((/1,2,9,1,9,8,2,3,4,2,4,9,8,9,6,8,6,7,9,4,5,9,5,6/),(/3,8/))
|
||||
INTEGER :: IFCORNERR(3,2) = RESHAPE((/1,3,5,1,5,7/),(/3,2/))
|
||||
IVERT = WInfo3dInteger(M3dVertices)
|
||||
wdmax=-1.e10
|
||||
wdmin=1.e10
|
||||
MAXNP=NP
|
||||
ALLOCATE (XSING(MAXNP),YSING(MAXNP),BLVL(MAXNP))
|
||||
XSING=5.
|
||||
YSING=-5.
|
||||
BLVL=-.5
|
||||
DO K=1,NP
|
||||
IF(INSKP(K) .EQ. 1) CYCLE
|
||||
IF(CORD(K,1) .LT. 0. .OR. CORD(K,1) .GT. HSIZE) CYCLE
|
||||
IF(CORD(K,2) .LT. 0. .OR. CORD(K,2) .GT. 7.5) CYCLE
|
||||
wdmax=max(WD(K),wdmax)
|
||||
wdmin=min(WD(K),wdmin)
|
||||
XSING(K)=CORD(K,1)
|
||||
YSING(K)=-CORD(K,2)
|
||||
ENDDO
|
||||
wdmins=wdmin/((wdmax-wdmin)*2.)
|
||||
DO K=1,NP
|
||||
IF(INSKP(K) .EQ. 1) CYCLE
|
||||
IF(CORD(K,1) .LT. 0. .OR. CORD(K,1) .GT. HSIZE) CYCLE
|
||||
IF(CORD(K,2) .LT. 0. .OR. CORD(K,2) .GT. 7.5) CYCLE
|
||||
blvl(k)=-(WD(K)-wdmin)/(wdmax-wdmin)
|
||||
ENDDO
|
||||
!! read(155,'(2i6,24f12.3)') j,ncn,(xlin(k),ylin(k),blvl(k),k=1,ncn)
|
||||
!! blvl(k)=(blvl(k))*0.1
|
||||
CALL W3dVertices(xsing,blvl,ysing,MAXNP)
|
||||
DO IFACET = 1,ne
|
||||
! IF(IMAT(IFACET) .EQ. 999) CYCLE
|
||||
if(ncorn(ifacet) .lt. 6 .or. (imat(ifacet) .eq. 0)) cycle
|
||||
IF(IESKP(IFACET) .NE. 0) CYCLE
|
||||
IF(CORD(nop(ifacet,1),1) .LT. 0. .OR. CORD(nop(ifacet,1),1) .GT. HSIZE) CYCLE
|
||||
IF(CORD(nop(ifacet,3),1) .LT. 0. .OR. CORD(nop(ifacet,3),1) .GT. HSIZE) CYCLE
|
||||
IF(CORD(nop(ifacet,5),1) .LT. 0. .OR. CORD(nop(ifacet,5),1) .GT. HSIZE) CYCLE
|
||||
IF(CORD(nop(ifacet,1),2) .LT. 0. .OR. CORD(nop(ifacet,1),2) .GT. 7.5) CYCLE
|
||||
IF(CORD(nop(ifacet,3),2) .LT. 0. .OR. CORD(nop(ifacet,3),2) .GT. 7.5) CYCLE
|
||||
IF(CORD(nop(ifacet,5),2) .LT. 0. .OR. CORD(nop(ifacet,5),2) .GT. 7.5) CYCLE
|
||||
if(ncorn(ifacet) .eq. 6) then
|
||||
K=1
|
||||
i1=nop(ifacet,ifcorner(1,k))
|
||||
i2=nop(ifacet,ifcorner(2,k))
|
||||
i3=nop(ifacet,ifcorner(3,k))
|
||||
wm=(blvl(i1)+blvl(i2)+blvl(i3))/3.
|
||||
mat=-wm*8.+1.
|
||||
|
||||
CALL W3dMaterialN(MAT)
|
||||
|
||||
IVERTICES(1) = i1
|
||||
IVERTICES(2) = i2
|
||||
IVERTICES(3) = i3
|
||||
ncns=3
|
||||
CALL W3dFacet(IVERTICES,ncns)
|
||||
! WRITE(156,*) IFACET,I1,I2,I3,MAT
|
||||
! enddo
|
||||
else
|
||||
IF(CORD(nop(ifacet,7),1) .LT. 0. .OR. CORD(nop(ifacet,7),1) .GT. HSIZE) CYCLE
|
||||
IF(CORD(nop(ifacet,7),2) .LT. 0. .OR. CORD(nop(ifacet,7),2) .GT. 7.5) CYCLE
|
||||
do k=1,2
|
||||
i1=nop(ifacet,ifcornerr(1,k))
|
||||
i2=nop(ifacet,ifcornerr(2,k))
|
||||
i3=nop(ifacet,ifcornerr(3,k))
|
||||
wm=(blvl(i1)+blvl(i2)+blvl(i3))/3.
|
||||
mat=-wm*8.+1.
|
||||
|
||||
CALL W3dMaterialN(MAT)
|
||||
|
||||
IVERTICES(1) = i1
|
||||
IVERTICES(2) = i2
|
||||
IVERTICES(3) = i3
|
||||
ncns=3
|
||||
CALL W3dFacet(IVERTICES,ncns)
|
||||
! WRITE(156,*) IFACET,I1,I2,I3,MAT
|
||||
enddo
|
||||
endif
|
||||
END DO
|
||||
DEALLOCATE (XSING,YSING,BLVL)
|
||||
RETURN
|
||||
END SUBROUTINE TRPLAT
|
||||
|
||||
!
|
||||
SUBROUTINE ViewPos(Angle)
|
||||
|
||||
USE BLK3D
|
||||
!
|
||||
! Set viewing position
|
||||
!
|
||||
IMPLICIT NONE
|
||||
!
|
||||
REAL, INTENT(IN) :: Angle
|
||||
CHARACTER(LEN=50) :: STBAR1
|
||||
|
||||
!
|
||||
! REAL, PARAMETER :: DIST = 20. ! Controls viewing distance
|
||||
real xtmp,ytmp,ztmp,xpos,ypos,zpos,xup,yup,zup
|
||||
!
|
||||
!
|
||||
! Calculate viewing position using EYE matrix calculated by 3D modelling routines.
|
||||
!
|
||||
XTMP = 0.0
|
||||
YTMP = 0.0
|
||||
ZTMP = DIST
|
||||
XPOS = EYE(1,1)*XTMP + EYE(1,2)*YTMP + EYE(1,3)*ZTMP + EYE(1,4)
|
||||
YPOS = EYE(2,1)*XTMP + EYE(2,2)*YTMP + EYE(2,3)*ZTMP + EYE(2,4)
|
||||
ZPOS = EYE(3,1)*XTMP + EYE(3,2)*YTMP + EYE(3,3)*ZTMP + EYE(3,4)
|
||||
WRITE(STBAR1,'(3F13.3)') XPOS,YPOS,ZPOS
|
||||
CALL WindowOutStatusBar(6,STBAR1)
|
||||
!
|
||||
! Calculate up vector using EYE matrix calculated by 3D modelling routines.
|
||||
!
|
||||
XTMP = 0.0
|
||||
YTMP = 1.0
|
||||
ZTMP = 0.0
|
||||
XUP = EYE(1,1)*XTMP + EYE(1,2)*YTMP + EYE(1,3)*ZTMP
|
||||
YUP = EYE(2,1)*XTMP + EYE(2,2)*YTMP + EYE(2,3)*ZTMP
|
||||
ZUP = EYE(3,1)*XTMP + EYE(3,2)*YTMP + EYE(3,3)*ZTMP
|
||||
!
|
||||
! Set eye position
|
||||
!
|
||||
CALL W3dEye(XPOS,YPOS,ZPOS, &
|
||||
EYE(1,4),EYE(2,4),EYE(3,4), &
|
||||
XUP,YUP,ZUP)
|
||||
|
||||
RETURN
|
||||
END SUBROUTINE ViewPos
|
||||
!
|
||||
SUBROUTINE ShowModel(JHAND1,ITYPIMAGE)
|
||||
!
|
||||
! Display the model
|
||||
!
|
||||
USE WINTERACTER
|
||||
|
||||
IMPLICIT NONE
|
||||
!
|
||||
INTEGER, INTENT(IN) :: JHAND1,ITYPIMAGE ! Memory bitmap handle
|
||||
!
|
||||
! Select the bitmap as the target drawable and draw the model
|
||||
!
|
||||
!CALL IGrSelect(DrawBitmap,JHAND1)
|
||||
!CALL IGrAreaClear()
|
||||
!CALL W3dShow(View3Flat)
|
||||
CALL WglSelect(DrawBitmap,JHAND1)
|
||||
! CALL IGrAreaClear()
|
||||
CALL WglShow(ITYPIMAGE)
|
||||
!
|
||||
! Now select window as target drawable and copy bitmap to window
|
||||
!
|
||||
! CALL IGrSelect(DrawWin)
|
||||
CALL WglSelect(DrawWin)
|
||||
CALL WBitmapPut(JHAND1,0,0)
|
||||
RETURN
|
||||
END SUBROUTINE ShowModel
|
||||
!
|
||||
@ -0,0 +1,587 @@
|
||||
SUBROUTINE ADD999(ISWT9,NELC)
|
||||
|
||||
! add type 999 elements to all 1-d elements
|
||||
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
COMMON ISEQ(4000,10),LIST1(2000),LIST2(2000),J1OLD(20),J2OLD(20)
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
IF(.NOT. ALLOCATED(IUSEDM)) THEN
|
||||
ALLOCATE (IUSEDM(MAXE))
|
||||
IUSEDM=0
|
||||
ENDIF
|
||||
IF(.NOT. ALLOCATED(HSET)) THEN
|
||||
ISWTH=0
|
||||
ELSE
|
||||
ISWTH=1
|
||||
ENDIF
|
||||
! loop on elements looking for 1-d
|
||||
PI2=3.14159/2.
|
||||
|
||||
NTEMPLC=0
|
||||
NCM=MAXECON
|
||||
NCMi=MAXECON
|
||||
IUSEDM=0
|
||||
DO N=1,NE
|
||||
IF(IMAT(N) .NE. 999) CYCLE
|
||||
CALL KCON(0)
|
||||
GO TO 75
|
||||
ENDDO
|
||||
GO TO 90
|
||||
75 CONTINUE
|
||||
DO N=1,NE
|
||||
IF(IMAT(N) .EQ. 999) THEN
|
||||
DO J=1,NCMi
|
||||
IF(NCORN(ICON(N,J)) .EQ. 3) THEN
|
||||
M=ICON(N,J)
|
||||
IF(NOP(M,1) .EQ. NOP(N,1) .AND. NOP(M,3) .EQ. NOP(N,3) .OR.&
|
||||
NOP(M,1) .EQ. NOP(N,3) .AND. NOP(M,3) .EQ. NOP(N,1)) THEN
|
||||
IUSEDM(ICON(N,J))=1
|
||||
GO TO 80
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
80 CONTINUE
|
||||
ENDDO
|
||||
90 n=1
|
||||
ICL=0
|
||||
do k=1,10
|
||||
iseqp=2000
|
||||
iseqm=2000
|
||||
do ns=n,ne
|
||||
if(imat(ns) .eq. 0 .or. (imat(ns) .ge. 900 .and. imat(ns) .lt. 2000)) cycle
|
||||
if(ncorn(ns) .gt. 3) cycle
|
||||
if(IUSEDM(ns) .eq. 1) cycle
|
||||
! renumber elements to put them in order
|
||||
N=NS
|
||||
N1=NOP(NS,1)
|
||||
N3=NOP(NS,3)
|
||||
iseq(iseqp,k)=ns
|
||||
IUSEDM(n)=1
|
||||
go to 100
|
||||
enddo
|
||||
go to 200
|
||||
100 continue
|
||||
! search for element connected to n1 or n3
|
||||
do m=1,ne
|
||||
if(imat(ns) .eq. 0 .or. (imat(ns) .ge. 900 .and. imat(ns) .lt. 2000)) cycle
|
||||
! if(imat(m) .gt. 0 .and. imat(m) .lt. 900) then
|
||||
if(ncorn(m) .lt. 4) then
|
||||
if(IUSEDM(m) .eq. 1) cycle
|
||||
if(nop(m,1) .eq. n3) then
|
||||
IUSEDM(m)=1
|
||||
iseqp=iseqp+1
|
||||
iseq(iseqp,k)=m
|
||||
! n1=nop(m,1)
|
||||
n3=nop(m,3)
|
||||
n=m
|
||||
go to 100
|
||||
elseif(nop(m,1) .eq. n1) then
|
||||
nop(m,1)=nop(m,3)
|
||||
nop(m,3)=n1
|
||||
IUSEDM(m)=1
|
||||
iseqm=iseqm-1
|
||||
iseq(iseqm,k)=m
|
||||
n1=nop(m,1)
|
||||
! n3=nop(m,3)
|
||||
n=m
|
||||
go to 100
|
||||
elseif(nop(m,3) .eq. n1) then
|
||||
IUSEDM(m)=1
|
||||
iseqm=iseqm-1
|
||||
iseq(iseqm,k)=m
|
||||
n1=nop(m,1)
|
||||
! n3=nop(m,3)
|
||||
n=m
|
||||
go to 100
|
||||
elseif(nop(m,3) .eq. n3) then
|
||||
nop(m,3)=nop(m,1)
|
||||
nop(m,1)=n3
|
||||
IUSEDM(m)=1
|
||||
iseqp=iseqp+1
|
||||
iseq(iseqp,k)=m
|
||||
! n1=nop(m,1)
|
||||
n3=nop(m,3)
|
||||
n=m
|
||||
go to 100
|
||||
endif
|
||||
endif
|
||||
! endif
|
||||
enddo
|
||||
enddo
|
||||
200 continue
|
||||
! do n=990,1005
|
||||
! write(150,*) n,(iseq(n,m),m=1,5)
|
||||
! enddo
|
||||
NETEMP=NE
|
||||
|
||||
do k=1,10
|
||||
nss=0
|
||||
do ns=1,4000
|
||||
if(iseq(ns,k) .eq. 0) cycle
|
||||
n=iseq(ns,k)
|
||||
N1=NOP(N,1)
|
||||
N2=NOP(N,2)
|
||||
N3=NOP(N,3)
|
||||
|
||||
if(nss .eq. 0) then
|
||||
ELDIR=ATAN2(YUSR(N3)-YUSR(N1),XUSR(N3)-XUSR(N1))
|
||||
CALL GETNOD(J1)
|
||||
INEW(J1) = 1
|
||||
INSKP(J1) =0
|
||||
IF(ISWTH .EQ. 1) THEN
|
||||
WD(J1)=HSET(N1,3)
|
||||
ELSE
|
||||
WD(J1)=-9999.
|
||||
ENDIF
|
||||
CALL GETNOD(J2)
|
||||
INEW(J2) = 1
|
||||
INSKP(J2) =0
|
||||
IF(ISWTH .EQ. 1) THEN
|
||||
WD(J2)=HSET(N1,1)
|
||||
ELSE
|
||||
WD(J2)=-9999.
|
||||
ENDIF
|
||||
|
||||
! XUSR(J1)=+WIDTHD(N1)/2.*COS(ELDIR-PI2)+XUSR(N1)
|
||||
! YUSR(J1)=+WIDTHD(N1)/2.*SIN(ELDIR-PI2)+YUSR(N1)
|
||||
XUSR(J1)=+WIDTH(N1)/2.*COS(ELDIR-PI2)+XUSR(N1)
|
||||
YUSR(J1)=+WIDTH(N1)/2.*SIN(ELDIR-PI2)+YUSR(N1)
|
||||
CORD(J1,1)=(XUSR(J1)+XS)/TXSCAL
|
||||
CORD(J1,2)=(YUSR(J1)+YS)/TXSCAL
|
||||
IF(ISWT9 .EQ. 2) THEN
|
||||
WD(J1)=WD(N1)
|
||||
ENDIF
|
||||
nnn=iseq(ns+1,k)
|
||||
if(nnn .eq. 0) then
|
||||
ELDIR=ATAN2(YUSR(N3)-YUSR(N1),XUSR(N3)-XUSR(N1))
|
||||
else
|
||||
n4=nop(nnn,3)
|
||||
ELDIR=ATAN2(YUSR(N4)-YUSR(N1),XUSR(N4)-XUSR(N1))
|
||||
endif
|
||||
! XUSR(J2)=+WIDTHD(N1)/2.*COS(ELDIR+PI2)+XUSR(N1)
|
||||
! YUSR(J2)=+WIDTHD(N1)/2.*SIN(ELDIR+PI2)+YUSR(N1)
|
||||
XUSR(J2)=+WIDTH(N1)/2.*COS(ELDIR+PI2)+XUSR(N1)
|
||||
YUSR(J2)=+WIDTH(N1)/2.*SIN(ELDIR+PI2)+YUSR(N1)
|
||||
CORD(J2,1)=(XUSR(J2)+XS)/TXSCAL
|
||||
CORD(J2,2)=(YUSR(J2)+YS)/TXSCAL
|
||||
IF(ISWT9 .EQ. 2) THEN
|
||||
WD(J2)=WD(N1)
|
||||
ENDIF
|
||||
nss=1
|
||||
else
|
||||
nnn=iseq(ns+1,k)
|
||||
if(nnn .eq. 0) then
|
||||
ELDIR=ATAN2(YUSR(N3)-YUSR(N1),XUSR(N3)-XUSR(N1))
|
||||
else
|
||||
n4=nop(nnn,3)
|
||||
ELDIR=ATAN2(YUSR(N4)-YUSR(N1),XUSR(N4)-XUSR(N1))
|
||||
endif
|
||||
endif
|
||||
N0=N1
|
||||
! get two node numbers and store in ntempc
|
||||
CALL GETNOD(J3)
|
||||
INEW(J3) = 1
|
||||
INSKP(J3) =0
|
||||
IF(ISWTH .EQ. 1) THEN
|
||||
WD(J3)=HSET(N3,3)
|
||||
ELSE
|
||||
WD(J3)=-9999.
|
||||
ENDIF
|
||||
CALL GETNOD(J4)
|
||||
INEW(J4) = 1
|
||||
INSKP(J4) =0
|
||||
IF(ISWTH .EQ. 1) THEN
|
||||
WD(J4)=HSET(N3,1)
|
||||
ELSE
|
||||
WD(J4)=-9999.
|
||||
ENDIF
|
||||
IF(J4 .GT. NP) NP=J4
|
||||
nn= imat(n)
|
||||
if(nn .gt. 1999) then
|
||||
! XUSR(J3)=+WIDTHD(N3)/2.*COS(ELDIR-PI2)+XUSR(N3)
|
||||
! YUSR(J3)=+WIDTHD(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3)
|
||||
! XUSR(J4)=+WIDTHD(N3)/2.*COS(ELDIR+PI2)+XUSR(N3)
|
||||
! YUSR(J4)=+WIDTHD(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3)
|
||||
XUSR(J3)=+WIDTH(N3)/2.*COS(ELDIR-PI2)+XUSR(N3)
|
||||
YUSR(J3)=+WIDTH(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3)
|
||||
XUSR(J4)=+WIDTH(N3)/2.*COS(ELDIR+PI2)+XUSR(N3)
|
||||
YUSR(J4)=+WIDTH(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3)
|
||||
ELSEIF(KID(nn,1) .NE. 0) THEN
|
||||
JR2=KID(IMAT(N),2)
|
||||
JR1=KID(IMAT(N),3)
|
||||
JR4=KID(IMAT(N),4)
|
||||
JR3=KID(IMAT(N),5)
|
||||
XUSR(J1)=XUSR(JR1)
|
||||
YUSR(J1)=YUSR(JR1)
|
||||
XUSR(J2)=XUSR(JR2)
|
||||
YUSR(J2)=YUSR(JR2)
|
||||
XUSR(J3)=XUSR(JR3)
|
||||
YUSR(J3)=YUSR(JR3)
|
||||
XUSR(J4)=XUSR(JR4)
|
||||
YUSR(J4)=YUSR(JR4)
|
||||
! nop(n-1,7)=jr3
|
||||
ELSE
|
||||
! XUSR(J3)=+WIDTHD(N3)/2.*COS(ELDIR-PI2)+XUSR(N3)
|
||||
! YUSR(J3)=+WIDTHD(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3)
|
||||
! XUSR(J4)=+WIDTHD(N3)/2.*COS(ELDIR+PI2)+XUSR(N3)
|
||||
! YUSR(J4)=+WIDTHD(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3)
|
||||
XUSR(J3)=+WIDTH(N3)/2.*COS(ELDIR-PI2)+XUSR(N3)
|
||||
YUSR(J3)=+WIDTH(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3)
|
||||
XUSR(J4)=+WIDTH(N3)/2.*COS(ELDIR+PI2)+XUSR(N3)
|
||||
YUSR(J4)=+WIDTH(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3)
|
||||
ENDIF
|
||||
|
||||
CORD(J3,1)=(XUSR(J3)+XS)/TXSCAL
|
||||
CORD(J3,2)=(YUSR(J3)+YS)/TXSCAL
|
||||
CORD(J4,1)=(XUSR(J4)+XS)/TXSCAL
|
||||
CORD(J4,2)=(YUSR(J4)+YS)/TXSCAL
|
||||
IF(ISWT9 .EQ. 2) THEN
|
||||
WD(J3)=WD(N3)
|
||||
WD(J4)=WD(N3)
|
||||
ENDIF
|
||||
350 CONTINUE
|
||||
CALL GETELM(I3)
|
||||
! RECORD IN LIST FOR FUTURE
|
||||
ICL=ICL+1
|
||||
LIST1(ICL)=I3
|
||||
LIST2(I3)=icl
|
||||
NCORN(I3) = 8
|
||||
IESKP(I3) = 0
|
||||
NOP(I3,1)=J1
|
||||
NOP(I3,3)=J3
|
||||
NOP(I3,5)=N3
|
||||
NOP(I3,6)=N2
|
||||
NOP(I3,7)=N1
|
||||
IF(ISWT9 .EQ. 0) THEN
|
||||
IMAT(I3)=999
|
||||
ELSE
|
||||
IMAT(I3)=IMAT(N)
|
||||
ENDIF
|
||||
CALL GETELM(I4)
|
||||
! RECORD IN LIST FOR FUTURE
|
||||
ICL=ICL+1
|
||||
LIST1(ICL)=I4
|
||||
LIST2(I4)=-icl
|
||||
NCORN(I4) = 8
|
||||
IESKP(I4) = 0
|
||||
IF(I4 .GT. NETEMP) NETEMP=I4
|
||||
IMAT(I4)=999
|
||||
NOP(I4,1)=J4
|
||||
NOP(I4,2)= 0
|
||||
NOP(I4,3)=J2
|
||||
NOP(I4,5)=N1
|
||||
NOP(I4,6)=N2
|
||||
NOP(I4,7)=N3
|
||||
IF(ISWT9 .EQ. 0) THEN
|
||||
IMAT(I4)=999
|
||||
ELSE
|
||||
IMAT(I4)=IMAT(N)
|
||||
CALL DELTEL(N)
|
||||
ENDIF
|
||||
J2=J4
|
||||
J1=J3
|
||||
ENDDO
|
||||
enddo
|
||||
NE=NETEMP
|
||||
ICLM=ICL
|
||||
NELCT=2
|
||||
400 CONTINUE
|
||||
CALL FILM(1)
|
||||
call KCON(0)
|
||||
|
||||
do n=1,ne
|
||||
|
||||
if(imat(n) .eq. 2000) then
|
||||
nm=nop(n,4)
|
||||
if(necon(nm,1) .eq. n) then
|
||||
nat=necon(nm,2)
|
||||
else
|
||||
nat=necon(nm,1)
|
||||
endif
|
||||
if(list2(n) .gt. 0) then
|
||||
nm=nop(n,4)
|
||||
if(necon(nm,1) .eq. n) then
|
||||
nat=necon(nm,2)
|
||||
else
|
||||
nat=necon(nm,1)
|
||||
endif
|
||||
n1=nop(nat,7)
|
||||
n2=nop(nat,1)
|
||||
j1=nop(n,5)
|
||||
j2=nop(n,7)
|
||||
j3=nop(n,1)
|
||||
j4=nop(n,3)
|
||||
else
|
||||
nm=nop(n,8)
|
||||
if(necon(nm,1) .eq. n) then
|
||||
nat=necon(nm,2)
|
||||
else
|
||||
nat=necon(nm,1)
|
||||
endif
|
||||
n1=nop(nat,3)
|
||||
n2=nop(nat,5)
|
||||
j1=nop(n,1)
|
||||
j2=nop(n,3)
|
||||
j3=nop(n,5)
|
||||
j4=nop(n,7)
|
||||
endif
|
||||
xusr(j1)=xusr(n1)
|
||||
yusr(j1)=yusr(n1)
|
||||
cord(j1,1)=cord(n1,1)
|
||||
cord(j1,2)=cord(n1,2)
|
||||
xusr(j2)=xusr(n1)
|
||||
yusr(j2)=yusr(n1)
|
||||
cord(j2,1)=cord(n1,1)
|
||||
cord(j2,2)=cord(n1,2)
|
||||
xusr(j3)=xusr(n2)
|
||||
yusr(j3)=yusr(n2)
|
||||
cord(j3,1)=cord(n2,1)
|
||||
cord(j3,2)=cord(n2,2)
|
||||
xusr(j4)=xusr(n2)
|
||||
yusr(j4)=yusr(n2)
|
||||
cord(j4,1)=cord(n2,1)
|
||||
cord(j4,2)=cord(n2,2)
|
||||
elseif(imat(n) .eq. 2001) then
|
||||
if(list2(n) .gt. 0) then
|
||||
nm=nop(n,8)
|
||||
if(necon(nm,1) .eq. n) then
|
||||
nat=necon(nm,2)
|
||||
else
|
||||
nat=necon(nm,1)
|
||||
endif
|
||||
n1=nop(nat,5)
|
||||
n2=nop(nat,3)
|
||||
j1=nop(n,5)
|
||||
j2=nop(n,7)
|
||||
j3=nop(n,1)
|
||||
j4=nop(n,3)
|
||||
else
|
||||
nm=nop(n,4)
|
||||
if(necon(nm,1) .eq. n) then
|
||||
nat=necon(nm,2)
|
||||
else
|
||||
nat=necon(nm,1)
|
||||
endif
|
||||
n1=nop(nat,1)
|
||||
n2=nop(nat,7)
|
||||
j1=nop(n,1)
|
||||
j2=nop(n,3)
|
||||
j3=nop(n,5)
|
||||
j4=nop(n,7)
|
||||
endif
|
||||
xusr(j1)=xusr(n1)
|
||||
yusr(j1)=yusr(n1)
|
||||
cord(j1,1)=cord(n1,1)
|
||||
cord(j1,2)=cord(n1,2)
|
||||
xusr(j2)=xusr(n1)
|
||||
yusr(j2)=yusr(n1)
|
||||
cord(j2,1)=cord(n1,1)
|
||||
cord(j2,2)=cord(n1,2)
|
||||
xusr(j3)=xusr(n2)
|
||||
yusr(j3)=yusr(n2)
|
||||
cord(j3,1)=cord(n2,1)
|
||||
cord(j3,2)=cord(n2,2)
|
||||
xusr(j4)=xusr(n2)
|
||||
yusr(j4)=yusr(n2)
|
||||
cord(j4,1)=cord(n2,1)
|
||||
cord(j4,2)=cord(n2,2)
|
||||
endif
|
||||
enddo
|
||||
450 CALL DELETM(0)
|
||||
IF(NELC .LE. NELCT) THEN
|
||||
NMESS=47
|
||||
CALL GETINT(NNEL)
|
||||
IF(NNEL .EQ. 2) GO TO 470
|
||||
! Loop on newly created elements only
|
||||
DO K=1,ICL,2
|
||||
! work in pairs
|
||||
N1=LIST1(K)
|
||||
N2=LIST1(K+1)
|
||||
NMT=IMAT(N1)
|
||||
! temporarily get corner limits I1,I2,I3,I4
|
||||
I1=NOP(N1,1)
|
||||
I2=NOP(N2,3)
|
||||
I3=NOP(N1,3)
|
||||
I4=NOP(N2,1)
|
||||
! Delete nodes in middle
|
||||
JJ=NOP(N1,7)
|
||||
JK=NOP(N1,5)
|
||||
CALL DELETN(JJ)
|
||||
IF(K .EQ. ICL-1) THEN
|
||||
CALL DELETN(JK)
|
||||
ENDIF
|
||||
! CALL DELTEL(N1)
|
||||
! CALL DELTEL(N2)
|
||||
! Get x and y increments
|
||||
DX1=(XUSR(I2)-XUSR(I1))/NNEL
|
||||
DY1=(YUSR(I2)-YUSR(I1))/NNEL
|
||||
DX2=(XUSR(I4)-XUSR(I3))/NNEL
|
||||
DY2=(YUSR(I4)-YUSR(I3))/NNEL
|
||||
|
||||
! loop on new elements across section
|
||||
J1OLD(1)=I1
|
||||
J2OLD(1)=I3
|
||||
IF(K .GT. 1) THEN
|
||||
DO L=1,NNEL+1
|
||||
J1OLD(L+1)=J2OLD(L+1)
|
||||
ENDDO
|
||||
ENDIF
|
||||
! loop to creat nodes across section
|
||||
DO L=1,NNEL
|
||||
! Create new nodes for first in sequence
|
||||
IF(K .EQ. 1) THEN
|
||||
IF(L .LT. NNEL) THEN
|
||||
CALL GETNOD(JNEW)
|
||||
J1OLD(L+1)=JNEW
|
||||
NP=MAX(NP,J1OLD(L+1))
|
||||
XUSR(J1OLD(L+1))=XUSR(J1OLD(L))+DX1
|
||||
YUSR(J1OLD(L+1))=YUSR(J1OLD(L))+DY1
|
||||
CORD(J1OLD(L+1),1)=(XUSR(J1OLD(L+1))+XS)/TXSCAL
|
||||
CORD(J1OLD(L+1),2)=(YUSR(J1OLD(L+1))+YS)/TXSCAL
|
||||
INEW(J1OLD(L+1))=1
|
||||
INSKP(J1OLD(L+1)) = 0
|
||||
WD(J1OLD(L+1))=-9999.
|
||||
WIDTH(J1OLD(L+1))=0.
|
||||
SS1(J1OLD(L+1))=0.
|
||||
SS2(J1OLD(L+1))=0.
|
||||
WIDS(J1OLD(L+1))=0.
|
||||
WIDBS(J1OLD(L+1))=0.
|
||||
SSO(J1OLD(L+1))=0.
|
||||
ELSE
|
||||
J1OLD(L+1)=I2
|
||||
ENDIF
|
||||
ENDIF
|
||||
! save forward nodes as list
|
||||
IF(L .LT. NNEL) THEN
|
||||
CALL GETNOD(JNEW)
|
||||
J2OLD(L+1)=JNEW
|
||||
NP=MAX(NP,J2OLD(L+1))
|
||||
XUSR(J2OLD(l+1))=XUSR(J2OLD(L))+DX2
|
||||
YUSR(J2OLD(L+1))=YUSR(J2OLD(L))+DY2
|
||||
CORD(J2OLD(L+1),1)=(XUSR(J2OLD(L+1))+XS)/TXSCAL
|
||||
CORD(J2OLD(L+1),2)=(YUSR(J2OLD(L+1))+YS)/TXSCAL
|
||||
INEW(J2OLD(L+1))=1
|
||||
INSKP(J2OLD(L+1)) = 0
|
||||
WD(J2OLD(L+1))=-9999.
|
||||
WIDTH(J2OLD(L+1))=0.
|
||||
SS1(J2OLD(L+1))=0.
|
||||
SS2(J2OLD(L+1))=0.
|
||||
WIDS(J2OLD(L+1))=0.
|
||||
WIDBS(J2OLD(L+1))=0.
|
||||
SSO(J2OLD(L+1))=0.
|
||||
ELSE
|
||||
J2OLD(L+1)=I4
|
||||
ENDIF
|
||||
! Connect elements from list
|
||||
CALL GETELM(NEA)
|
||||
NE=MAX(NE,NEA)
|
||||
NOP(NEA,1)=J1OLD(L)
|
||||
NOP(NEA,3)=J2OLD(L)
|
||||
NOP(NEA,5)=J2OLD(L+1)
|
||||
NOP(NEA,7)=J1OLD(L+1)
|
||||
NOP(NEA,2)=0
|
||||
NOP(NEA,4)=0
|
||||
NOP(NEA,6)=0
|
||||
NOP(NEA,8)=0
|
||||
IMAT(NEA)=NMT
|
||||
NCORN(NEA) = 8
|
||||
IESKP(NEA) = 0
|
||||
ENDDO
|
||||
ENDDO
|
||||
470 CONTINUE
|
||||
do n=1,ne
|
||||
if(imat(n) .gt. 1000) then
|
||||
CALL DELTEL(n)
|
||||
endif
|
||||
enddo
|
||||
RETURN
|
||||
ENDIF
|
||||
DO I=1,ICLM,2
|
||||
NEL=LIST1(I)
|
||||
IF(IMAT(NEL) .EQ. 0) CYCLE
|
||||
IF(I .GT. 1) THEN
|
||||
J3=J4
|
||||
ELSE
|
||||
CALL GETNOD(J3)
|
||||
XUSR(J3)=(XUSR(NOP(NEL,7))+XUSR(NOP(NEL,1)))/2.
|
||||
YUSR(J3)=(YUSR(NOP(NEL,7))+YUSR(NOP(NEL,1)))/2.
|
||||
CORD(J3,1)=(XUSR(J3)+XS)/TXSCAL
|
||||
CORD(J3,2)=(YUSR(J3)+YS)/TXSCAL
|
||||
WD(J3)=(WD(NOP(NEL,1))+WD(NOP(NEL,7)))/2.
|
||||
INEW(J3) = 1
|
||||
INSKP(J3) =0
|
||||
IF(J3 .GT. NP) NP=J3
|
||||
ENDIF
|
||||
|
||||
CALL GETNOD(J4)
|
||||
XUSR(J4)=(XUSR(NOP(NEL,3))+XUSR(NOP(NEL,5)))/2.
|
||||
YUSR(J4)=(YUSR(NOP(NEL,3))+YUSR(NOP(NEL,5)))/2.
|
||||
CORD(J4,1)=(XUSR(J4)+XS)/TXSCAL
|
||||
CORD(J4,2)=(YUSR(J4)+YS)/TXSCAL
|
||||
WD(J4)=(WD(NOP(NEL,3))+WD(NOP(NEL,5)))/2.
|
||||
INEW(J4) = 1
|
||||
INSKP(J4) =0
|
||||
IF(J4 .GT. NP) NP=J4
|
||||
CALL GETELM(I3)
|
||||
! RECORD IN LIST FOR FUTURE
|
||||
ICL=ICL+1
|
||||
LIST1(ICL)=I3
|
||||
NCORN(I3) = 8
|
||||
IESKP(I3) = 0
|
||||
IF(I3 .GT. NETEMP) NETEMP=I3
|
||||
NOP(I3,5)=J4
|
||||
NOP(I3,7)=J3
|
||||
NOP(I3,1)=NOP(NEL,1)
|
||||
NOP(I3,3)=NOP(NEL,3)
|
||||
NOP(NEL,1)=J3
|
||||
NOP(NEL,3)=J4
|
||||
IMAT(I3)=IMAT(NEL)
|
||||
|
||||
NEL=LIST1(I+1)
|
||||
IF(IMAT(NEL) .EQ. 0) CYCLE
|
||||
IF(I .GT. 1) THEN
|
||||
J3A=J4A
|
||||
ELSE
|
||||
CALL GETNOD(J3A)
|
||||
XUSR(J3A)=(XUSR(NOP(NEL,3))+XUSR(NOP(NEL,5)))/2.
|
||||
YUSR(J3A)=(YUSR(NOP(NEL,3))+YUSR(NOP(NEL,5)))/2.
|
||||
CORD(J3A,1)=(XUSR(J3A)+XS)/TXSCAL
|
||||
CORD(J3A,2)=(YUSR(J3A)+YS)/TXSCAL
|
||||
WD(J3A)=(WD(NOP(NEL,3))+WD(NOP(NEL,5)))/2.
|
||||
INEW(J3A) = 1
|
||||
INSKP(J3A) =0
|
||||
IF(J3A .GT. NP) NP=J3A
|
||||
ENDIF
|
||||
CALL GETNOD(J4A)
|
||||
XUSR(J4A)=(XUSR(NOP(NEL,1))+XUSR(NOP(NEL,7)))/2.
|
||||
YUSR(J4A)=(YUSR(NOP(NEL,1))+YUSR(NOP(NEL,7)))/2.
|
||||
CORD(J4A,1)=(XUSR(J4A)+XS)/TXSCAL
|
||||
CORD(J4A,2)=(YUSR(J4A)+YS)/TXSCAL
|
||||
WD(J4A)=(WD(NOP(NEL,1))+WD(NOP(NEL,7)))/2.
|
||||
INEW(J4A) = 1
|
||||
INSKP(J4A) =0
|
||||
IF(J4A .GT. NP) NP=J4A
|
||||
CALL GETELM(I3)
|
||||
! RECORD IN LIST FOR FUTURE
|
||||
ICL=ICL+1
|
||||
LIST1(ICL)=I3
|
||||
NCORN(I3) = 8
|
||||
IESKP(I3) = 0
|
||||
IF(I3 .GT. NETEMP) NETEMP=I3
|
||||
NOP(I3,1)=J4A
|
||||
NOP(I3,3)=J3A
|
||||
NOP(I3,5)=NOP(NEL,5)
|
||||
NOP(I3,7)=NOP(NEL,7)
|
||||
NOP(NEL,5)=J3A
|
||||
NOP(NEL,7)=J4A
|
||||
IMAT(I3)=IMAT(NEL)
|
||||
|
||||
ENDDO
|
||||
NELCT=NELCT*2
|
||||
GO TO 450
|
||||
! RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,18 @@
|
||||
SUBROUTINE ADDBEDLV
|
||||
|
||||
USE BLK1MOD
|
||||
|
||||
! process node with weighting values
|
||||
DO N=1,NP
|
||||
! IF(ICN(N) .EQ. 2) THEN
|
||||
IF(NRIVCR1(N) .GT. 0) THEN
|
||||
NC1=NRIVCR1(N)
|
||||
NC2=NRIVCR2(N)
|
||||
WT1=WTRIVCR1(N)
|
||||
WT2=WTRIVCR2(N)
|
||||
WD(N)=CRSDAT(NC1,1,1)*WT1+CRSDAT(NC2,1,1)*WT2
|
||||
ENDIF
|
||||
! ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,136 @@
|
||||
SUBROUTINE ADDSLOT
|
||||
|
||||
! ADD SLOT TO 1-D
|
||||
|
||||
USE BLK1MOD
|
||||
|
||||
! GET SLOT PARAMETERS
|
||||
|
||||
CALL GETSLOTPARAM(ISLTYP,SLDEP,SLRNG,SLPOR)
|
||||
IF(ISLTYP .EQ. -1) RETURN
|
||||
|
||||
! SEARCH FOR CROSS-SECTION REACH/TYPE
|
||||
IF(ISLTYP .EQ. 0) THEN
|
||||
DO N=1,MCRS
|
||||
IF(IVMIL(N) .LT. 1) EXIT
|
||||
MM=NRIVL(IVMIL(N))
|
||||
IF(MM .GT. 0) THEN
|
||||
CALL ADDSLOTDATA(IVMIL(N),MM,SLDEP,SLRNG,SLPOR)
|
||||
ENDIF
|
||||
NRIVL(IVMIL(N))=MM
|
||||
ENDDO
|
||||
ELSE
|
||||
! SEARCH FOR CROSS-SECTION REACH/TYPE
|
||||
!
|
||||
! IVMIL = CROSS-SECTION NUMBER
|
||||
! NRIVL = NUMBER OF POINTS IN SECTION
|
||||
! NOREACH = REACH/TYPE NUMBER
|
||||
! CRSDAT 1 = ELEVATION
|
||||
! CRSDAT 2 = AREA
|
||||
! CRSDAT 3 = WIDTH
|
||||
|
||||
DO N=1,MCRS
|
||||
IF(ISLTYP .EQ. NOREACH(N)) THEN
|
||||
MM=NRIVL(IVMIL(N))
|
||||
CALL ADDSLOTDATA(IVMIL(N),MM,SLDEP,SLRNG,SLPOR)
|
||||
NRIVL(IVMIL(N))=MM
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
! APPLY CHANGE
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE GETSLOTPARAM(ISLTYP,SLDEP,SLRNG,SLPOR)
|
||||
use winteracter
|
||||
USE BLK1MOD
|
||||
|
||||
!-
|
||||
|
||||
include 'd.inc'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
INTEGER :: IERR,ISET,IBOX
|
||||
REAL :: ASET
|
||||
CHARACTER*1 :: IFLAG
|
||||
|
||||
call wdialogload(IDD_ADDSLOT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_ADDSLOT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
ISLTYP=0
|
||||
SLDEP=4.
|
||||
SLRNG=0.5
|
||||
SLPOR=0.1
|
||||
100 continue
|
||||
|
||||
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER1,ISLTYP)
|
||||
CALL WDialogPutReal(idf_real1,SLDEP)
|
||||
CALL WDialogPutReal(idf_real2,SLRNG)
|
||||
CALL WDialogPutReal(idf_real3,SLPOR)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
DO
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER1,ISLTYP)
|
||||
CALL WDialogGetReal(idf_real1,SLDEP)
|
||||
CALL WDialogGetReal(idf_real2,SLRNG)
|
||||
CALL WDialogGetReal(idf_real3,SLPOR)
|
||||
GO TO 200
|
||||
else
|
||||
ISLTYP=-1
|
||||
RETURN
|
||||
endif
|
||||
ENDDO
|
||||
200 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE ADDSLOTDATA(N,M,SLDEP,SLRNG,SLPOR)
|
||||
USE BLK1MOD
|
||||
BLEVL=CRSDAT(N,1,1)
|
||||
BWIDT=CRSDAT(N,1,3)
|
||||
IF(BWIDT .LT. 1) THEN
|
||||
CRSDAT(N,1,3)=1.0
|
||||
CRSDAT(N,0,1)=BLEVL-SLRNG
|
||||
CRSDAT(N,0,3)=SLPOR
|
||||
CRSDAT(N,-1,1)=CRSDAT(N,0,1)-SLDEP
|
||||
CRSDAT(N,-1,3)=SLPOR
|
||||
MLT=-1
|
||||
ELSE
|
||||
CRSDAT(N,0,1)=BLEVL-SLRNG
|
||||
CRSDAT(N,0,3)=1.0
|
||||
CRSDAT(N,-1,1)=BLEVL-2.*SLRNG
|
||||
CRSDAT(N,-1,3)=SLPOR
|
||||
CRSDAT(N,-2,1)=CRSDAT(N,0,1)-SLDEP
|
||||
CRSDAT(N,-2,3)=SLPOR
|
||||
MLT=-2
|
||||
ENDIF
|
||||
DO I=M,MLT,-1
|
||||
DO J=1,3
|
||||
CRSDAT(N,I+1-MLT,J)=CRSDAT(N,I,J)
|
||||
ENDDO
|
||||
ENDDO
|
||||
M=M+1-MLT
|
||||
DO I=2,M
|
||||
if(i .gt. 1) then
|
||||
CRSDAT(N,I,2)=CRSDAT(N,I-1,2)+&
|
||||
(CRSDAT(N,I,1)-CRSDAT(N,I-1,1))*&
|
||||
(CRSDAT(N,I,3)+CRSDAT(N,I-1,3))/2.
|
||||
endif
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,343 @@
|
||||
! Last change: IPK 12 Jan 98 11:21 am
|
||||
!
|
||||
!****************************************************************
|
||||
!
|
||||
SUBROUTINE ADDLAY
|
||||
!
|
||||
! Add nodal layer data and write to file
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
CHARACTER*1 IFLAG,ANSW(10)
|
||||
REAL RLAY(9)
|
||||
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
!
|
||||
4 CONTINUE
|
||||
|
||||
call openlay
|
||||
|
||||
NHTP=0
|
||||
NBRR=0
|
||||
NMESS=45
|
||||
CALL HEDR
|
||||
NMESS=4
|
||||
xprt=3.2
|
||||
!
|
||||
IPOS=ILAYTP
|
||||
call GETLAYDAT(NLAY,ipos,RLAY)
|
||||
ILAYTP=IPOS
|
||||
! call getint(nlay)
|
||||
! READ(*,*) NLAY
|
||||
!
|
||||
! Write out current layers
|
||||
!
|
||||
7 CONTINUE
|
||||
NHTP=0
|
||||
NMESS=0
|
||||
NBRR=4
|
||||
CALL HEDR
|
||||
CALL RCYAN
|
||||
DO 10 K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .GT. 5) THEN
|
||||
DO 9 N=1,NCORN(K),2
|
||||
J=NOP(K,N)
|
||||
FPN = LAY(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) - .11
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.0) THEN
|
||||
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||||
ENDIF
|
||||
9 CONTINUE
|
||||
ENDIF
|
||||
ENDIF
|
||||
10 END DO
|
||||
CALL RBLUE
|
||||
!
|
||||
! Input new layers
|
||||
!
|
||||
5 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
|
||||
IF(IRMAIN .EQ. 1) THEN
|
||||
REWIND 102
|
||||
DO J=1,NP
|
||||
IF(LAY(J) .GT. -9998) THEN
|
||||
if(ILAYTP .eq. 1) then
|
||||
write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||||
6000 format('LD2 ',2i8,9F8.2)
|
||||
else
|
||||
write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||||
6001 format('LD3 ',2i8,9F8.2)
|
||||
endif
|
||||
ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
ENDIF
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'n') THEN
|
||||
GO TO 4
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
NLAYD=1
|
||||
REWIND 102
|
||||
DO J=1,NP
|
||||
IF(LAY(J) .GT. -9998) THEN
|
||||
if(ILAYTP .eq. 1) then
|
||||
write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||||
else
|
||||
write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||||
endif
|
||||
ENDIF
|
||||
ENDDO
|
||||
CALL WRTOUT(0)
|
||||
RETURN
|
||||
ENDIF
|
||||
!
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. HSIZE) XPRT=0.
|
||||
FPN= INODE
|
||||
CALL NUMBR(XPRT,7.20,0.2,FPN,0.0,-1)
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
LAY(INODE) = NLAY
|
||||
DO J=1,7
|
||||
WTLAY(INODE,J)=RLAY(J)
|
||||
ENDDO
|
||||
FPN = NLAY
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) + .11
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 'a') THEN
|
||||
DO 100 K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .GT. 5) THEN
|
||||
DO 90 N=1,NCORN(K),2
|
||||
J=NOP(K,N)
|
||||
DO I=1,7
|
||||
WTLAY(J,I)=RLAY(I)
|
||||
ENDDO
|
||||
LAY(J)=NLAY
|
||||
FPN=NLAY
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) + .11
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.0) THEN
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
ENDIF
|
||||
90 CONTINUE
|
||||
ENDIF
|
||||
ENDIF
|
||||
100 CONTINUE
|
||||
NLAYD=1
|
||||
CALL WRTOUT(0)
|
||||
ELSEIF(IFLAG .EQ. 'f') THEN
|
||||
DO 120 K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .GT. 5) THEN
|
||||
DO 110 N=1,NCORN(K),2
|
||||
J=NOP(K,N)
|
||||
IF(LAY(J) .EQ. -9999.) THEN
|
||||
LAY(J)=NLAY
|
||||
DO I=1,7
|
||||
WTLAY(J,I)=RLAY(I)
|
||||
ENDDO
|
||||
FPN=NLAY
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) + .11
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.0) THEN
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
ENDIF
|
||||
ENDIF
|
||||
110 CONTINUE
|
||||
ENDIF
|
||||
ENDIF
|
||||
120 CONTINUE
|
||||
NLAYD=1
|
||||
CALL WRTOUT(0)
|
||||
!
|
||||
ELSE
|
||||
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||||
ENDIF
|
||||
!
|
||||
GOTO 5
|
||||
!
|
||||
END
|
||||
subroutine openlay
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'd.inc'
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=3) :: SUB
|
||||
LOGICAL :: OPENED
|
||||
INTEGER :: IERR
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
INQUIRE(102, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
CALL WSelectFile(ID_STRING9,SaveDialog+PromptOn,FNAME,'Save layer file')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='lay'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
open(102,file=fname, form='formatted', status='unknown')
|
||||
ENDIF
|
||||
endif
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE RDLAYER
|
||||
!
|
||||
! Read nodal layer data
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*8 ID
|
||||
CHARACTER*72 DLIN
|
||||
DIMENSION WTTEMP(7)
|
||||
|
||||
!
|
||||
100 CONTINUE
|
||||
READ(103,7000,END=400) ID,DLIN
|
||||
7000 FORMAT(A8,A72)
|
||||
IF(ID(1:2) .EQ. 'LD') THEN
|
||||
READ(DLIN,5000) NODNUM,NLAYD,(WTTEMP(I),I=1,7)
|
||||
5000 FORMAT(2I8,7F8.0)
|
||||
IF(NODNUM .EQ. 0) THEN
|
||||
DO N=0,NP
|
||||
LAY(N)=NLAYD
|
||||
IF(NLAYD .GT. 0) THEN
|
||||
DO I=0,NLAYD
|
||||
WTLAY(N,I)=WTTEMP(I)
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
ELSEIF(NODNUM .GT. 0) THEN
|
||||
LAY(NODNUM)=NLAYD
|
||||
IF(NLAYD .GT. 0) THEN
|
||||
DO I=1,NLAYD
|
||||
WTLAY(NODNUM,I)=WTTEMP(I)
|
||||
ENDDO
|
||||
ENDIF
|
||||
|
||||
ENDIF
|
||||
ENDIF
|
||||
IF(ID(3:3) .EQ. '2') THEN
|
||||
ILAYTP=1
|
||||
ELSE
|
||||
ILAYTP=0
|
||||
ENDIF
|
||||
GO TO 100
|
||||
400 CONTINUE
|
||||
DO K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
NCN=NCORN(K)
|
||||
IF(NCN .EQ. 5) NCN=3
|
||||
DO N=1,NCORN(K),2
|
||||
J=NOP(K,N)
|
||||
FPN=LAY(N)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) + .11
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.0) THEN
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE WRTLAYER
|
||||
use winteracter
|
||||
|
||||
!
|
||||
! Read nodal layer data
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*8 ID
|
||||
CHARACTER*72 DLIN
|
||||
DIMENSION WTTEMP(7)
|
||||
LOGICAL :: OPENED
|
||||
include 'd.inc'
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=3) :: SUB
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
INQUIRE(102, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
CALL WSelectFile(ID_STRING9,SaveDialog+PromptOn,FNAME,'Save layer file')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='lay'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
open(102,file=fname, form='formatted', status='unknown')
|
||||
ENDIF
|
||||
else
|
||||
rewind 102
|
||||
endif
|
||||
|
||||
DO J=0,NP
|
||||
IF(LAY(J) .GT. -9998) THEN
|
||||
if(j .gt. 0) then
|
||||
if(lay(j) .ne. lay(0)) then
|
||||
go to 300
|
||||
else
|
||||
do i=1,lay(j)
|
||||
if(wtlay(j,i) .ne. wtlay(0,i)) then
|
||||
go to 300
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
go to 500
|
||||
300 continue
|
||||
if(ILAYTP .eq. 1) then
|
||||
write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||||
6000 format('LD2 ',2i8,9F8.2)
|
||||
else
|
||||
write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||||
6001 format('LD3 ',2i8,9F8.2)
|
||||
endif
|
||||
else
|
||||
if(ILAYTP .eq. 1) then
|
||||
write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||||
else
|
||||
write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||||
endif
|
||||
endif
|
||||
ENDIF
|
||||
500 CONTINUE
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,192 @@
|
||||
SUBROUTINE ADDQUAD
|
||||
|
||||
! Subroutine to add a quadrilateral block
|
||||
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
CHARACTER*1 IFLAG
|
||||
|
||||
DATA N1,N2,N3,N4/1,1,1,1/
|
||||
|
||||
! Initiliaze list etc
|
||||
|
||||
NHTPSV=NHTP
|
||||
NMESSSV=NMESS
|
||||
NBRRSV=NBRR
|
||||
|
||||
DO N=1,NP
|
||||
LIST(N)=0
|
||||
ENDDO
|
||||
! Get the points that form the triangle
|
||||
|
||||
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 CALL PLOTT(XTEMP,YTEMP,3)
|
||||
! CALL PLOTT(XTEMP,YTEMP,2)
|
||||
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
|
||||
!
|
||||
CALL PLOTT(ALX,ALY,3)
|
||||
CALL PLOTT(XTEMP,YTEMP,2)
|
||||
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 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 PLOTT(ALX,ALY,2)
|
||||
|
||||
! Get the number of element information
|
||||
|
||||
CALL PANELQUAD(N1,N2,N3,N4)
|
||||
|
||||
! Get number For 1 and 3 and 2 and 4
|
||||
|
||||
NMID1=(N1+N3)/2
|
||||
NMID2=(N2+N4)/2
|
||||
|
||||
! Form the new nodes
|
||||
|
||||
CALL DEFNOD(ALX,ALY)
|
||||
CALL DEFNOD(ARX,ARY)
|
||||
CALL DEFNOD(BRX,BRY)
|
||||
CALL DEFNOD(BLX,BLY)
|
||||
|
||||
! Now work on sides
|
||||
|
||||
DO N=1,N1-1
|
||||
RATIO=FLOAT(N)/FLOAT(N1)
|
||||
X1=ALX+RATIO*(ARX-ALX)
|
||||
Y1=ALY+RATIO*(ARY-ALY)
|
||||
CALL DEFNOD(X1,Y1)
|
||||
ENDDO
|
||||
DO N=1,N2-1
|
||||
RATIO=FLOAT(N)/FLOAT(N2)
|
||||
X1=ARX+RATIO*(BRX-ARX)
|
||||
Y1=ARY+RATIO*(BRY-ARY)
|
||||
CALL DEFNOD(X1,Y1)
|
||||
ENDDO
|
||||
DO N=1,N3-1
|
||||
RATIO=FLOAT(N)/FLOAT(N3)
|
||||
X1=BRX+RATIO*(BLX-BRX)
|
||||
Y1=BRY+RATIO*(BLY-BRY)
|
||||
CALL DEFNOD(X1,Y1)
|
||||
ENDDO
|
||||
DO N=1,N4-1
|
||||
RATIO=FLOAT(N)/FLOAT(N4)
|
||||
X1=BLX+RATIO*(ALX-BLX)
|
||||
Y1=BLY+RATIO*(ALY-BLY)
|
||||
CALL DEFNOD(X1,Y1)
|
||||
ENDDO
|
||||
CALL FRMNODQ(ALX,ALY,ARX,ARY,BRX,BRY,BLX,BLY,NMID1,NMID2)
|
||||
|
||||
! Form triangles for the added nodes
|
||||
|
||||
CALL DELN2(NP,1)
|
||||
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE PANELQUAD(N1,N2,N3,N4)
|
||||
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'D.inc'
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: N1,N2,N3,N4,IERR
|
||||
! real ::
|
||||
character*3 :: sub
|
||||
|
||||
call wdialogload(IDD_QUAD)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(idf_integer1,n1)
|
||||
CALL WDialogPutInteger(idf_integer2,n2)
|
||||
CALL WDialogPutInteger(idf_integer3,n3)
|
||||
CALL WDialogPutInteger(idf_integer4,n4)
|
||||
|
||||
|
||||
CALL WDialogSelect(IDD_QUAD)
|
||||
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 WDialogGetInteger(idf_integer4,n4)
|
||||
|
||||
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,191 @@
|
||||
SUBROUTINE ADDTRIANG
|
||||
|
||||
! Subroutine to add a triangular block
|
||||
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
CHARACTER*1 IFLAG
|
||||
|
||||
DATA N1,N2,N3/1,1,1/
|
||||
|
||||
! Initiliaze list etc
|
||||
|
||||
NHTPSV=NHTP
|
||||
NMESSSV=NMESS
|
||||
NBRRSV=NBRR
|
||||
|
||||
DO N=1,NP
|
||||
LIST(N)=0
|
||||
ENDDO
|
||||
! Get the points that form the triangle
|
||||
|
||||
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 CALL PLOTT(ALX,ALY,3)
|
||||
! CALL PLOTT(ALX,ALY,2)
|
||||
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 CALL PLOTT(XTEMP,YTEMP,3)
|
||||
CALL PLOTT(ALX,ALY,3)
|
||||
CALL PLOTT(XTEMP,YTEMP,2)
|
||||
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 PLOTT(ALX,ALY,2)
|
||||
|
||||
! Get the number of element information
|
||||
|
||||
CALL PANELTRG(N1,N2,N3)
|
||||
|
||||
! Get middle number
|
||||
|
||||
IF(N1 .GT. N2) THEN
|
||||
IF(N1 .GT. N3) THEN
|
||||
IF(N2 .GT. N3) THEN
|
||||
NMID=N2
|
||||
ELSE
|
||||
NMID=N1
|
||||
ENDIF
|
||||
ELSE
|
||||
NMID=N1
|
||||
ENDIF
|
||||
ELSE
|
||||
IF(N2 .GT. N3) THEN
|
||||
IF(N1 .GT. N3) THEN
|
||||
NMID=N1
|
||||
ELSE
|
||||
NMID=N3
|
||||
ENDIF
|
||||
ELSE
|
||||
NMID=N2
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
! Form the new nodes
|
||||
|
||||
CALL DEFNOD(ALX,ALY)
|
||||
CALL DEFNOD(ARX,ARY)
|
||||
CALL DEFNOD(BRX,BRY)
|
||||
|
||||
! Now work on sides
|
||||
|
||||
DO N=1,N1-1
|
||||
RATIO=FLOAT(N)/FLOAT(N1)
|
||||
X1=ALX+RATIO*(ARX-ALX)
|
||||
Y1=ALY+RATIO*(ARY-ALY)
|
||||
CALL DEFNOD(X1,Y1)
|
||||
ENDDO
|
||||
DO N=1,N2-1
|
||||
RATIO=FLOAT(N)/FLOAT(N2)
|
||||
X1=ARX+RATIO*(BRX-ARX)
|
||||
Y1=ARY+RATIO*(BRY-ARY)
|
||||
CALL DEFNOD(X1,Y1)
|
||||
ENDDO
|
||||
DO N=1,N3-1
|
||||
RATIO=FLOAT(N)/FLOAT(N3)
|
||||
X1=BRX+RATIO*(ALX-BRX)
|
||||
Y1=BRY+RATIO*(ALY-BRY)
|
||||
CALL DEFNOD(X1,Y1)
|
||||
ENDDO
|
||||
CALL FRMNODT(ALX,ALY,ARX,ARY,BRX,BRY,NMID)
|
||||
|
||||
! For triangles for the added nodes
|
||||
|
||||
CALL DELN2(NP,1)
|
||||
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE PANELTRG(N1,N2,N3)
|
||||
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'D.inc'
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: N1,N2,N3,IERR
|
||||
! real ::
|
||||
character*3 :: sub
|
||||
|
||||
call wdialogload(IDD_TRIANG)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(idf_integer1,n1)
|
||||
CALL WDialogPutInteger(idf_integer2,n2)
|
||||
CALL WDialogPutInteger(idf_integer3,n3)
|
||||
|
||||
|
||||
CALL WDialogSelect(IDD_TRIANG)
|
||||
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)
|
||||
|
||||
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,464 @@
|
||||
!IPK LAST UPDATE JULY 18 1998 MAJOR CHANGES
|
||||
! Last change: IPK 12 Jan 98 11:22 am
|
||||
!ipk jan98 delete old call to char(7)
|
||||
!****************************************************************
|
||||
!
|
||||
SUBROUTINE ADDWID
|
||||
!
|
||||
! Add nodal width data
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
CHARACTER*1 IFLAG,ANSW(10),ANSW1(10)
|
||||
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
DATA ANSW1/ 'w','1','2','d','e','s','b','z','r','q'/
|
||||
!
|
||||
4 CONTINUE
|
||||
NHTP=13
|
||||
NMESS=0
|
||||
NBRR=0
|
||||
!ipk apr95 add call to flushwn
|
||||
call flushwn
|
||||
CALL HEDR
|
||||
102 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW1(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'w') THEN
|
||||
!
|
||||
! get width
|
||||
!
|
||||
104 continue
|
||||
call plotot(1)
|
||||
CALL RCYAN
|
||||
DO K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .LT. 6) THEN
|
||||
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||||
DO N=1,3,2
|
||||
J=NOP(K,N)
|
||||
FPN = WIDTH(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) - .11
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
enddo
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
enddo
|
||||
CALL RBLUE
|
||||
nmess=45
|
||||
nhtp=0
|
||||
nbrr=4
|
||||
call flushwn
|
||||
CALL HEDR
|
||||
nmess=5
|
||||
xprt=3.2
|
||||
call getfpn(cwid)
|
||||
!
|
||||
! Input new widths
|
||||
!
|
||||
105 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'n') THEN
|
||||
GO TO 104
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
CALL WRTOUT(0)
|
||||
go to 4
|
||||
ENDIF
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. HSIZE) XPRT=0.
|
||||
FPN= INODE
|
||||
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
WIDTH(INODE) = CWID
|
||||
FPN = WIDTH(INODE)
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) + .11
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
endif
|
||||
go to 105
|
||||
elseif(iflag .eq. '1') then
|
||||
!
|
||||
! get ss1
|
||||
!
|
||||
204 continue
|
||||
call plotot(1)
|
||||
CALL RCYAN
|
||||
DO K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .LT. 6) THEN
|
||||
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||||
DO N=1,3,2
|
||||
J=NOP(K,N)
|
||||
FPN = ss1(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) - .11
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
enddo
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
enddo
|
||||
CALL RBLUE
|
||||
nmess=45
|
||||
nhtp=0
|
||||
nbrr=4
|
||||
call flushwn
|
||||
CALL HEDR
|
||||
nmess=22
|
||||
xprt=3.2
|
||||
call getfpn(ss1tp)
|
||||
!
|
||||
! Input new ss1
|
||||
!
|
||||
205 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'n') THEN
|
||||
GO TO 204
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
CALL WRTOUT(0)
|
||||
go to 4
|
||||
ENDIF
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. HSIZE) XPRT=0.
|
||||
FPN= INODE
|
||||
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
SS1(INODE) = SS1TP
|
||||
FPN = SS1TP
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) + .11
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
endif
|
||||
go to 205
|
||||
elseif(iflag .eq. '2') then
|
||||
!
|
||||
! get ss2
|
||||
!
|
||||
304 continue
|
||||
call plotot(1)
|
||||
CALL RCYAN
|
||||
DO K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .LT. 6) THEN
|
||||
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||||
DO N=1,3,2
|
||||
J=NOP(K,N)
|
||||
FPN = ss2(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) - .11
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
enddo
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
enddo
|
||||
CALL RBLUE
|
||||
nmess=45
|
||||
nhtp=0
|
||||
nbrr=4
|
||||
call flushwn
|
||||
CALL HEDR
|
||||
nmess=23
|
||||
xprt=3.2
|
||||
call getfpn(ss2tp)
|
||||
!
|
||||
! Input new ss2
|
||||
!
|
||||
305 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'n') THEN
|
||||
GO TO 304
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
CALL WRTOUT(0)
|
||||
go to 4
|
||||
ENDIF
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. HSIZE) XPRT=0.
|
||||
FPN= INODE
|
||||
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
SS2(INODE) = SS2TP
|
||||
FPN = SS2TP
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) + .11
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
endif
|
||||
go to 305
|
||||
elseif(iflag .eq. 'd') then
|
||||
!
|
||||
! get storage width
|
||||
!
|
||||
404 continue
|
||||
call plotot(1)
|
||||
CALL RCYAN
|
||||
DO K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .LT. 6) THEN
|
||||
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||||
DO N=1,3,2
|
||||
J=NOP(K,N)
|
||||
FPN = wids(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) - .11
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
enddo
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
enddo
|
||||
CALL RBLUE
|
||||
nmess=45
|
||||
nhtp=0
|
||||
nbrr=4
|
||||
call flushwn
|
||||
CALL HEDR
|
||||
nmess=24
|
||||
xprt=3.2
|
||||
call getfpn(wids1tp)
|
||||
!
|
||||
! Input new storgae width
|
||||
!
|
||||
405 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'n') THEN
|
||||
GO TO 404
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
CALL WRTOUT(0)
|
||||
go to 4
|
||||
ENDIF
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. HSIZE) XPRT=0.
|
||||
FPN= INODE
|
||||
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
WIDS(INODE) = wids1TP
|
||||
FPN = wids1TP
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) + .11
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
endif
|
||||
go to 405
|
||||
elseif(iflag .eq. 'e') then
|
||||
!
|
||||
! get storage elevation
|
||||
!
|
||||
504 continue
|
||||
call plotot(1)
|
||||
CALL RCYAN
|
||||
DO K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .LT. 6) THEN
|
||||
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||||
DO N=1,3,2
|
||||
J=NOP(K,N)
|
||||
FPN = widbs(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) - .11
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
enddo
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
enddo
|
||||
CALL RBLUE
|
||||
nmess=45
|
||||
nhtp=0
|
||||
nbrr=4
|
||||
call flushwn
|
||||
CALL HEDR
|
||||
nmess=39
|
||||
xprt=3.2
|
||||
call getfpn(widbs1tp)
|
||||
!
|
||||
! Input new storage elevations
|
||||
!
|
||||
505 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'n') THEN
|
||||
GO TO 504
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
CALL WRTOUT(0)
|
||||
go to 4
|
||||
ENDIF
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. HSIZE) XPRT=0.
|
||||
FPN= INODE
|
||||
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
WIDBS(INODE) = widbs1TP
|
||||
FPN = widbs1tp
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) + .11
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
endif
|
||||
go to 505
|
||||
elseif(iflag .eq. 's') then
|
||||
!
|
||||
! get storage slopes
|
||||
!
|
||||
604 continue
|
||||
call plotot(1)
|
||||
CALL RCYAN
|
||||
DO K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .LT. 6) THEN
|
||||
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||||
DO N=1,3,2
|
||||
J=NOP(K,N)
|
||||
FPN = sso(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) - .11
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
enddo
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
enddo
|
||||
CALL RBLUE
|
||||
nmess=45
|
||||
nhtp=0
|
||||
nbrr=4
|
||||
call flushwn
|
||||
CALL HEDR
|
||||
nmess=40
|
||||
xprt=3.2
|
||||
call getfpn(widslp)
|
||||
!
|
||||
! Input new storage slopes
|
||||
!
|
||||
605 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'n') THEN
|
||||
GO TO 604
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
CALL WRTOUT(0)
|
||||
go to 4
|
||||
ENDIF
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. HSIZE) XPRT=0.
|
||||
FPN= INODE
|
||||
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
SSO(INODE) = widslp
|
||||
FPN = widslp
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) + .11
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
endif
|
||||
go to 605
|
||||
!ipk mar02
|
||||
!
|
||||
! get bed slopes
|
||||
!
|
||||
elseif(iflag .eq. 'b') then
|
||||
704 continue
|
||||
call plotot(1)
|
||||
CALL RCYAN
|
||||
DO K=1,NE
|
||||
IF(IMAT(K) .GT. 0) THEN
|
||||
IF(NCORN(K) .LT. 6) THEN
|
||||
IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN
|
||||
DO N=1,3,2
|
||||
J=NOP(K,N)
|
||||
FPN = BS1(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) - .11
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
enddo
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
enddo
|
||||
CALL RBLUE
|
||||
nmess=45
|
||||
nhtp=0
|
||||
nbrr=4
|
||||
call flushwn
|
||||
CALL HEDR
|
||||
nmess=44
|
||||
xprt=3.2
|
||||
call getfpn(bedslp)
|
||||
!
|
||||
! Input new bed slopes
|
||||
!
|
||||
705 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'n') THEN
|
||||
GO TO 704
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
CALL WRTOUT(0)
|
||||
go to 4
|
||||
ENDIF
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. HSIZE) XPRT=0.
|
||||
FPN= INODE
|
||||
CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1)
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
BS1(INODE) = bedslp
|
||||
FPN = bedslp
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) + .11
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.20,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
endif
|
||||
go to 705
|
||||
|
||||
elseif(iflag .eq. 'q') then
|
||||
return
|
||||
endif
|
||||
go to 4
|
||||
END
|
||||
@ -0,0 +1,463 @@
|
||||
!IPK LAST UPDATE JULY 7 2016 ADD TEST FOR ZERO WIDTH
|
||||
SUBROUTINE CHKAREA
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
include 'd.inc'
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||||
|
||||
dimension itran(0:16)
|
||||
data itran/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/
|
||||
|
||||
DATA I1,I2,I3,I4/1,0,0,0/,EMAX/-1./
|
||||
|
||||
WRITE(90,*) 'GOING TO CHKOPT'
|
||||
CALL GETCHOPT(I1,I2,I3,I4,EREF,WIDEL)
|
||||
WRITE(90,*) I1
|
||||
IF(I1 .LT. 0) THEN
|
||||
I1=1
|
||||
I2=0
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(I1 .EQ. 1) THEN
|
||||
! and see if all corner nodes exist
|
||||
!
|
||||
! Test for areas of each element
|
||||
!
|
||||
INEG = 0
|
||||
!IPK JUL16
|
||||
IERW=0
|
||||
DO 250 N=1,NE
|
||||
IF(IMAT(N) .GT. 0 .AND. NCORN(N) .GT. 5) THEN
|
||||
J1=NOP(N,1)
|
||||
J2=NOP(N,3)
|
||||
J3=NOP(N,5)
|
||||
if(cord(j1,1) .lt. -1.e9 .or. cord(j2,1) .lt. -1.e9 .or. cord(j3,1) .lt. -1.e9) then
|
||||
WRITE(90,*) ' NODE UNDEFINED FOR ELEMENT NUMBER',N
|
||||
CALL DELTEL(N)
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Element removed','ELEMENT REMOVED')
|
||||
GO TO 250
|
||||
ENDIF
|
||||
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
|
||||
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
|
||||
IF(AREA .LT. 0.) THEN
|
||||
WRITE(90,*) ' NEGATIVE AREA FOR ELEMENT NUMBER',N
|
||||
INEG = 1
|
||||
GO TO 250
|
||||
ENDIF
|
||||
IF(NCORN(N) .EQ. 8) THEN
|
||||
J1=NOP(N,3)
|
||||
J2=NOP(N,5)
|
||||
J3=NOP(N,7)
|
||||
if(cord(j1,1) .lt. -1.e9 .or. cord(j2,1) .lt. -1.e9 .or. cord(j3,1) .lt. -1.e9) then
|
||||
WRITE(90,*) ' NODE UNDEFINED FOR ELEMENT NUMBER',N
|
||||
CALL DELTEL(N)
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Element removed','ELEMENT REMOVED')
|
||||
GO TO 250
|
||||
ENDIF
|
||||
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
|
||||
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
|
||||
IF(AREA .LT. 0.) THEN
|
||||
WRITE(90,*) ' NEGATIVE AREA FOR ELEMENT NUMBER',N
|
||||
INEG = 1
|
||||
ENDIF
|
||||
ENDIF
|
||||
!IPK JUL16 ADD TEST FOR MISSING WIDTH
|
||||
ELSEIF(IMAT(N) .GT. 0) THEN
|
||||
IF(WIDTH(NOP(N,1)) .EQ. 0. .OR. WIDTH(NOP(N,3)) .EQ. 0) THEN
|
||||
IF(IERW .EQ. 0) THEN
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Nodal width missing in 1-D element'//Char(13)//&
|
||||
'See file MESSGEN.OUT for details' ,'WARNING 1-D WIDTH MISSING')
|
||||
write(90,6000)
|
||||
write(90,6001) n,nop(n,1),width(nop(n,1)),nop(n,3),width(nop(n,3))
|
||||
6000 FORMAT(' NODAL WIDTH MISSING FOR 1-D ELEMENT'/' ELEMENT NODE1 WIDTH1 NODE2 WIDTH2')
|
||||
6001 FORMAT(I8,2(I10,F10.2))
|
||||
IERW=1
|
||||
ELSE
|
||||
write(90,6001) n,nop(n,1),width(nop(n,1)),nop(n,3),width(nop(n,3))
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
250 END DO
|
||||
|
||||
IF(INEG .EQ. 1) THEN
|
||||
!cipk aug00
|
||||
|
||||
Call WMessageBox(3,2,1,'Negative Areas have been found'//Char(13)//&
|
||||
'See file MESSGEN.OUT for details'//'Press YES to set positive',&
|
||||
'ERROR IN NETWORK AREAS!!')
|
||||
|
||||
IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then
|
||||
!
|
||||
! Test for areas of each element
|
||||
!
|
||||
INEG=0
|
||||
DO 300 N=1,NE
|
||||
IF(IMAT(N) .GT. 0 .AND. NCORN(N) .GT. 5) THEN
|
||||
J1=NOP(N,1)
|
||||
J2=NOP(N,3)
|
||||
J3=NOP(N,5)
|
||||
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
|
||||
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
|
||||
IF(AREA .LT. 0.) THEN
|
||||
if(NCORN(N) .EQ. 6) THEN
|
||||
JM12=NOP(N,2)
|
||||
JM23=NOP(N,4)
|
||||
JM31=NOP(N,6)
|
||||
NOP(N,2)=JM31
|
||||
NOP(N,3)=J3
|
||||
NOP(N,4)=JM23
|
||||
NOP(N,5)=J2
|
||||
NOP(N,6)=JM12
|
||||
GO TO 300
|
||||
ELSEIF(NCORN(N) .EQ. 8) THEN
|
||||
INEG=1
|
||||
ENDIF
|
||||
ENDIF
|
||||
IF(NCORN(N) .EQ. 8) THEN
|
||||
J1=NOP(N,3)
|
||||
J2=NOP(N,5)
|
||||
J3=NOP(N,7)
|
||||
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
|
||||
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
|
||||
IF(AREA .LT. 0.) THEN
|
||||
IF(INEG .EQ. 1) THEN
|
||||
J0=NOP(N,1)
|
||||
JM01=NOP(N,2)
|
||||
JM12=NOP(N,4)
|
||||
JM23=NOP(N,6)
|
||||
JM30=NOP(N,8)
|
||||
NOP(N,2)=JM30
|
||||
NOP(N,3)=J3
|
||||
NOP(N,4)=JM23
|
||||
NOP(N,5)=J2
|
||||
NOP(N,6)=JM12
|
||||
NOP(N,7)=J1
|
||||
NOP(N,8)=JM01
|
||||
ELSE
|
||||
WRITE(90,*) ' CROSS OVER NEGATIVE AREA FOR ELEMENT NUMBER',N
|
||||
Call WMessageBox(3,2,1,'cross-over element diagonals have been found'//Char(13)//&
|
||||
'See file MESSGEN.OUT for details'//'Press YES to set delete',&
|
||||
'ERROR IN NETWORK AREAS!!')
|
||||
IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then
|
||||
CALL DELTEL(N)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
300 END DO
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
! CARRY OUT TEST FOR ELEMENT ELEVATION DIFFERENCES
|
||||
IF(I2 .EQ. 1) THEN
|
||||
EMAX=0.
|
||||
DO N=1,NE
|
||||
EDIF(N)=0
|
||||
IF(IMAT(N) .LE. 0) GO TO 400
|
||||
IF(NCORN(N) .GT. 5) THEN
|
||||
DO M=1,NCORN(N)-1,2
|
||||
DO MM=M,NCORN(N)-1,2
|
||||
EDIF(N)=MAX(ABS(WD(NOP(N,M))-WD(NOP(N,MM))),EDIF(N))
|
||||
ENDDO
|
||||
ENDDO
|
||||
ELSE
|
||||
IF(I4 .EQ. 0) THEN
|
||||
EDIF(N)=ABS(WD(NOP(N,3))-WD(NOP(N,1)))
|
||||
ELSE
|
||||
if(icrin .eq. 0) then
|
||||
CALL WMessageBox(0, 4, 1,'Cross-section data not loaded '//CHAR(13)// &
|
||||
'Click OK start again','ERROR GETTING NO SECTION DATA')
|
||||
RETURN
|
||||
endif
|
||||
N1=NOP(N,1)
|
||||
N2=NOP(N,3)
|
||||
BT1= &
|
||||
CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ &
|
||||
CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1)
|
||||
BT2= &
|
||||
CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ &
|
||||
CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2)
|
||||
H1=WIDEL-BT1
|
||||
H2=WIDEL-BT2
|
||||
IF(H1 .LT. 0. .OR. H2 .LT. 0.) THEN
|
||||
CALL WMessageBox(1, 4, 1,'Depth negative '//CHAR(13)// &
|
||||
'Click OK to continue with depth=1.'//CHAR(13)//'Click Cancel to start again','ERROR GETTING SECTION DATA')
|
||||
if(WInfoDialog(4) .eq. 0) then
|
||||
RETURN
|
||||
else
|
||||
IF(H1 .LT. 0.) H1=1.0
|
||||
IF(H2 .LT. 0.) H2=1.0
|
||||
endif
|
||||
ENDIF
|
||||
CALL INTERPWLV(N1,H1,AR1,WR1,DWR1)
|
||||
CALL INTERPWLV(N2,H2,AR2,WR2,DWR2)
|
||||
IF(I4 .EQ. 1) THEN
|
||||
EDIF(N)=ABS(WR1-WR2)
|
||||
ELSE
|
||||
EDIF(N)=ABS(AR1-AR2)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
IF(EDIF(N) .GT. EMAX) EMAX=EDIF(N)
|
||||
400 CONTINUE
|
||||
ENDDO
|
||||
NUMV=13
|
||||
CONTUR(1)=-0.5
|
||||
DO K=2,13
|
||||
CONTUR(K)=(EMAX+0.5)/12.+CONTUR(K-1)
|
||||
ENDDO
|
||||
|
||||
DO N=1,NE
|
||||
! IF(N .EQ. 46451) WRITE(155,*) N,EMAX,EDIF(N)
|
||||
IF(IMAT(N) .GT. 0) THEN
|
||||
IF(EDIF(N) .LT. 0.001) THEN
|
||||
ICOL=1
|
||||
ELSE
|
||||
ICOL=EDIF(N)*12./EMAX+.999
|
||||
ENDIF
|
||||
icll=itran(icol)
|
||||
! IF(N .EQ. 46451) WRITE(155,*) N,ICOL,EMAX,EDIF(N)
|
||||
CALL FILLEMC(N,ICLL)
|
||||
ENDIF
|
||||
ENDDO
|
||||
XLEG=8.8
|
||||
YLEG=7.4
|
||||
|
||||
CALL LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL)
|
||||
|
||||
ENDIF
|
||||
EDIF(0)=EMAX
|
||||
CALL WMenuSetState(ID_SECGRP,ItemEnabled,1)
|
||||
IF(I2 .EQ. 1) RETURN
|
||||
! CARRY OUT TEST FOR ELEMENT NORMAILZED DEPTH DIFFERENCES
|
||||
IF(I3 .EQ. 1) THEN
|
||||
EMAX=0.
|
||||
DO N=1,NE
|
||||
EDIF(N)=0
|
||||
IF(IMAT(N) .LE. 0) GO TO 500
|
||||
IF(NCORN(N) .GT. 5) THEN
|
||||
DO M=1,NCORN(N)-1,2
|
||||
DO MM=M,NCORN(N)-1,2
|
||||
D1=EREF-WD(NOP(N,M))
|
||||
D2=EREF-WD(NOP(N,MM))
|
||||
if(d1 .lt. 0.0) d1=0.0
|
||||
if(d2 .lt. 0.0) d2=0.0
|
||||
DMEAN=(D1+D2)/2.
|
||||
if(DMEAN .LE. 1.) DMEAN=1.0
|
||||
EDIF(N)=MAX(ABS(D1-D2)/DMEAN,EDIF(N))
|
||||
ENDDO
|
||||
ENDDO
|
||||
ELSE
|
||||
IF(I4 .EQ. 0) THEN
|
||||
D1=EREF-WD(NOP(N,1))
|
||||
D2=EREF-WD(NOP(N,3))
|
||||
IF(D1 .LT. 0. .OR. D2 .LT. 0.) THEN
|
||||
CALL WMessageBox(1, 4, 1,'Depth negative '//CHAR(13)// &
|
||||
'Click OK to continue with depth=1.'//CHAR(13)//'Click Cancel to start again','ERROR GETTING SECTION DATA')
|
||||
if(WInfoDialog(4) .eq. 0) then
|
||||
RETURN
|
||||
else
|
||||
IF(D1 .LT. 0.) D1=1.0
|
||||
IF(D2 .LT. 0.) D2=1.0
|
||||
endif
|
||||
ENDIF
|
||||
|
||||
DMEAN=(D1+D2)/2.
|
||||
if(DMEAN .LE. 1.) DMEAN=1.0
|
||||
EDIF(N)=ABS(D1-D2)/DMEAN
|
||||
ELSE
|
||||
if(icrin .eq. 0) then
|
||||
CALL WMessageBox(0, 4, 1,'Cross-section data not loaded '//CHAR(13)// &
|
||||
'Click OK start again','ERROR GETTING NO SECTION DATA')
|
||||
RETURN
|
||||
endif
|
||||
N1=NOP(N,1)
|
||||
N2=NOP(N,3)
|
||||
BT1= &
|
||||
CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ &
|
||||
CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1)
|
||||
BT2= &
|
||||
CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ &
|
||||
CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2)
|
||||
H1=WIDEL-BT1
|
||||
H2=WIDEL-BT2
|
||||
IF(H1 .LT. 0. .OR. H2 .LT. 0.) THEN
|
||||
CALL WMessageBox(1, 4, 1,'Depth negative '//CHAR(13)// &
|
||||
'Click OK to continue with depth=1.'//CHAR(13)//'Click Cancel to start again','ERROR GETTING SECTION DATA')
|
||||
if(WInfoDialog(4) .eq. 0) then
|
||||
RETURN
|
||||
else
|
||||
IF(H1 .LT. 0.) H1=1.0
|
||||
IF(H2 .LT. 0.) H2=1.0
|
||||
endif
|
||||
ENDIF
|
||||
CALL INTERPWLV(N1,H1,AR1,WR1,DWR1)
|
||||
CALL INTERPWLV(N2,H2,AR2,WR2,DWR2)
|
||||
IF(I4 .EQ. 1) THEN
|
||||
EDIF(N)=ABS(WR1-WR2)*2./(WR1+WR2)
|
||||
ELSE
|
||||
EDIF(N)=ABS(AR1-AR2)*2./(AR1+AR2)
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
ENDIF
|
||||
IF(EDIF(N) .GT. EMAX) EMAX=EDIF(N)
|
||||
500 CONTINUE
|
||||
ENDDO
|
||||
NUMV=11
|
||||
CONTUR(1)=0.
|
||||
DO K=2,11
|
||||
CONTUR(K)=EMAX/10.+CONTUR(K-1)
|
||||
ENDDO
|
||||
|
||||
DO N=1,NE
|
||||
IF(IMAT(N) .GT. 0) THEN
|
||||
ICOL=EDIF(N)*10./EMAX+.999
|
||||
icll=itran(icol)
|
||||
CALL FILLEMC(N,ICLL)
|
||||
ENDIF
|
||||
ENDDO
|
||||
XLEG=8.8
|
||||
YLEG=7.4
|
||||
|
||||
CALL LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL)
|
||||
|
||||
ENDIF
|
||||
EDIF(0)=EMAX
|
||||
CALL WMenuSetState(ID_SECGRP,ItemEnabled,1)
|
||||
FLUSH(90)
|
||||
IF(I3 .EQ. 1) RETURN
|
||||
|
||||
CALL PLOTOT(0)
|
||||
CALL HEDR
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE GETCHOPT(I1,I2,I3,I4,EREF,WIDEL)
|
||||
!
|
||||
! Generate continuity lines
|
||||
!
|
||||
|
||||
USE WINTERACTER
|
||||
include 'd.inc'
|
||||
SAVE
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: I1,I2,I3,I4,I4A,ITIME,IPOS
|
||||
|
||||
REAL :: WIDEL
|
||||
|
||||
REAL :: EREF
|
||||
|
||||
data itime/0/
|
||||
|
||||
IF(ITIME .EQ. 0) THEN
|
||||
EREF=0.
|
||||
WIDEL=0.
|
||||
itime=1.
|
||||
I4=0
|
||||
ENDIF
|
||||
|
||||
call wdialogload(IDD_CHKOPT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_CHKOPT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
I4A=I4
|
||||
IF(I4 .GT. 0) I4A=1
|
||||
call wdialogputCheckBox(idf_check1,I1)
|
||||
call wdialogputCheckBox(idf_check2,I4A)
|
||||
if(i2 .eq. 1) then
|
||||
CALL WDialogPutRadioButton(IDF_RADIO1)
|
||||
elseif(i3 .eq. 1) then
|
||||
CALL WDialogPutRadioButton(IDF_RADIO2)
|
||||
endif
|
||||
CALL WDialogPutReal(IDF_REAL1,EREF)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
call wdialogGetCheckBox(idf_check1,I1)
|
||||
call wdialogGetCheckBox(idf_check2,I4A)
|
||||
call wdialogGetRadioButton(idf_radio1,IPOS)
|
||||
IF(IPOS .EQ. 1) THEN
|
||||
I2=1
|
||||
I3=0
|
||||
ELSEIF(IPOS .EQ. 2) THEN
|
||||
I2=0
|
||||
I3=1
|
||||
ELSE
|
||||
I2=0
|
||||
I3=0
|
||||
ENDIF
|
||||
CALL WDialoggetReal(IDF_REAL1,EREF)
|
||||
GO TO 100
|
||||
|
||||
ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
I1=-1
|
||||
I2=0
|
||||
I3=0
|
||||
WRITE(90,*) 'CANCEL',I1,I2,I3,I4A
|
||||
return
|
||||
ENDIF
|
||||
|
||||
enddo
|
||||
100 CONTINUE
|
||||
WRITE(90,*) 'IN CHKOPT',I1,I2,I3,I4A
|
||||
|
||||
IF(I4A .NE. 0) THEN
|
||||
call wdialogload(IDD_CHK1DOPT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_CHK1DOPT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
if(i4 .le. 1) then
|
||||
CALL WDialogPutRadioButton(IDF_RADIO1)
|
||||
elseif(i4 .eq. 2) then
|
||||
CALL WDialogPutRadioButton(IDF_RADIO2)
|
||||
endif
|
||||
CALL WDialogPutReal(IDF_REAL1,WIDEL)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
|
||||
do
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
call wdialogGetRadioButton(idf_radio1,I4)
|
||||
CALL WDialogGetReal(IDF_REAL1,WIDEL)
|
||||
|
||||
WRITE(90,*) 'OUT OF CHKOPT',I1,I2,I3,I4A
|
||||
return
|
||||
|
||||
ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
|
||||
I4=0
|
||||
I4A=0
|
||||
|
||||
ENDIF
|
||||
|
||||
enddo
|
||||
|
||||
ENDIF
|
||||
WRITE(90,*) 'OUT OF CHKOPT',I1,I2,I3,I4A
|
||||
return
|
||||
end
|
||||
|
||||
@ -0,0 +1,33 @@
|
||||
SUBROUTINE ASSIGNEQ
|
||||
|
||||
USE BLK1MOD
|
||||
USE BLKELTLD
|
||||
COMMON XCEN(5000),YCEN(5000)
|
||||
DIST(I,J)=(XYCEL(I,1)-XCEN(J))**2+(XYCEL(I,2)-YCEN(J))**2
|
||||
VOID=1.E20
|
||||
|
||||
! get centroids of mesh
|
||||
XCEN=VOID
|
||||
YCEN=VOID
|
||||
DO J=1,NE
|
||||
CALL GETXCL(J,XCJ,YCJ)
|
||||
XCEN(J)=XCJ
|
||||
YCEN(J)=YCJ
|
||||
ENDDO
|
||||
|
||||
! test for nearest centroid
|
||||
DO I=1,NQHYD
|
||||
NCLINE(I)=0
|
||||
DISTM=VOID
|
||||
DO J=1,NE
|
||||
IF(XCEN(J) .GE. VOID) CYCLE
|
||||
IF(DIST(I,J) .LT. DISTM) THEN
|
||||
DISTM=DIST(I,J)
|
||||
NCLINE(I)=J
|
||||
ENDIF
|
||||
ENDDO
|
||||
WRITE(103,6001) NCLINE(I),ILAYRE(1,NQHYD),HAE(1,I),(HDE(1,I,K),K=1,3)
|
||||
6001 FORMAT('EFE',5X,2I8,7X,'1',F8.3,3F8.2,7X,'1')
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,9 @@
|
||||
INTEGER :: NBKFL,ISWBKFL,IACTVFIL,ITOTFIL,I3DVIEW,IRDONE
|
||||
REAL :: BFMINMAX
|
||||
CHARACTER(LEN=255) :: BFNAME,BFNAMR,FNAMKEP,DIRECT
|
||||
CHARACTER(LEN=48) :: FNAMEDISP
|
||||
COMMON /BFLSI/ NBKFL,ISWBKFL(10),I3DVIEW,IRDONE
|
||||
COMMON /BFLSR/ BFMINMAX(10,4)
|
||||
COMMON /BFLSC/ BFNAME(10),BFNAMR(10),FNAMKEP,DIRECT,FNAMEDISP
|
||||
CHARACTER(LEN=255) :: FNAMEOUT
|
||||
COMMON /RSTOR/ IACTVFIL,ITOTFIL,FNAMEOUT(10)
|
||||
@ -0,0 +1,117 @@
|
||||
MODULE BLK1MOD
|
||||
|
||||
INCLUDE 'PARAM.COM'
|
||||
! BLK1
|
||||
!-
|
||||
REAL HSIZE
|
||||
COMMON /SSIZE/ HSIZE
|
||||
|
||||
INTEGER MAXP,MAXE,MAXLIN,MAXSTO,MAXECON,MAXLN,MAELN
|
||||
|
||||
|
||||
INTEGER*2 INSKP,IESKP,INEW,NCORN,IJUN,ISWTAGN,iswtintp
|
||||
!IPK MAY02 INTEGER*2 NOP,IMAT,IEM,NEF,NEFLAG,LINTYP,LAY
|
||||
INTEGER*2 IMAT,LINTYP,LAY
|
||||
INTEGER*4 NOP,IEM,NEF,NEFLAG
|
||||
! REAL*8 CORD,XUSR,YUSR,XC,YC,CMAP,XMAP,YMAP,pscale,xref,yref
|
||||
REAL*8 CORD,XUSR,YUSR,XC,YC,pscale,xref,yref
|
||||
|
||||
INTEGER*2 MSN
|
||||
ALLOCATABLE MSN(:)
|
||||
|
||||
|
||||
ALLOCATABLE CORD(:,:),XUSR(:),YUSR(:),XC(:),YC(:)&
|
||||
,NOP(:,:),IMAT(:),THTA(:),IMATL(:),CORDSN(:,:)&
|
||||
,WD(:) ,WD1(:),INSKP(:), IESKP(:),NCORN(:)&
|
||||
,WIDTH(:), SS1(:), SS2(:), WIDS(:)&
|
||||
,IJUN(:),INEW(:),IEM(:),LINTYP(:),NEFLAG(:),NEF(:,:),LAY(:),WTLAY(:,:)&
|
||||
,WIDBS(:),SSO(:),NODDEL(:),IELDEL(:)&
|
||||
,NOPSV(:,:),nefsv(:,:),IMATSV(:),LOCK(:),BS1(:),NKEY1(:),EDIF(:),ANGOP(:)&
|
||||
,IGRPNUM(:,:),MAXENT(:),IGRPSER(:),IUSEDM(:)
|
||||
ALLOCATABLE NRF(:),AREF(:),LEVREM(:),TRANSEL(:),WLEN(:),WHGT(:)
|
||||
INTEGER*8 MAXPTS
|
||||
COMMON /BLK/ MAXPTS,PSCALE,xref,yref&
|
||||
, IPNN, IPEN, XMIN, YMIN, XMAX, YMAX, NLAYD,ILAYTP&
|
||||
,VOID, VDX, XSCALE, YSCALE,AMAP,IRESTT&
|
||||
,NXPMIN, NYPMIN, NXPMAX, NYPMAX, IPP&
|
||||
,XPMIN, YPMIN, XPMAX, YPMAX, WDSCAL,IESW&
|
||||
,NPLAST,NELAST,NEFL,NENTRY,IECHG,ICHG&
|
||||
,IIN, IBAK, LUNIT,IGIN,IS11,IMP,IGFG,ISWAP,ITRIAN&
|
||||
,klint,jlint,lmpnam,IDELV,nmapf,NSIGF,NPUNDO,NEUNDO,nefsav,nesav&
|
||||
,xadded,yadded,icolsw,rad,colint,ielvsw,ISWTAGN,iswtintp,eref,igrp,igrpout,MAXIGRP
|
||||
!IPK MAR02 ADD BS1
|
||||
!IPK FEB02 ADD LOCK
|
||||
!IPK MAY01 ADD NODDEL AND IELDEL
|
||||
!IPK JUL98 WIDBS AND SSO ADDED
|
||||
!IPK JAN98 IDELV ADDED
|
||||
!ipk feb94 line above added, two lines changed may 94 to add xref,yref
|
||||
! 9 ,LINTYP(MAXLIN),NEFLAG(150),NEF(600,3),LAY(MAXP)
|
||||
!
|
||||
!IPK MAR04 INTEGER*2 ILIST,LLIST
|
||||
INTEGER*4 ILIST,LLIST
|
||||
|
||||
ALLOCATABLE ILIST(:,:),LLIST(:)
|
||||
COMMON /BLK1/ NLST, ICCLN(140,350),NCLM
|
||||
!
|
||||
CHARACTER*80 TITLE
|
||||
CHARACTER*24 HLABL
|
||||
!ipk feb94 add
|
||||
character*40 mpnam
|
||||
!ipk dec97 line above modified
|
||||
|
||||
CHARACTER*1 ALABL(10)
|
||||
COMMON /BLKA1/ TITLE,HLABL,ALABL,MPNAM
|
||||
!ipk dec97 line above modified
|
||||
!
|
||||
!IPK JAN01 INCREASE IPSW TO 10
|
||||
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||||
!ycw mar97 add
|
||||
COMMON /CROSS/ ICRS,XPCS(2),YPCS(2),NCSNOD,XCND(50),YCND(50),&
|
||||
NCSPTS,XELVP(50),YELVP(50),ZELVP(50),SELVP(50),&
|
||||
ZREF,DFACTOR,ZMIN,IXNOD,LCROSS&
|
||||
,IVMIL(MCRS),NRIVL(MCRS),NOREACH(MCRS)&
|
||||
,CRSDAT(MCRS,MPTS,3),NCRSEC,XCRS(MCRS),YCRS(MCRS)
|
||||
|
||||
ALLOCATABLE NRIVCR1(:),WTRIVCR1(:),NRIVCR2(:),WTRIVCR2(:)
|
||||
|
||||
!NRIVCR1(MAXP),WTRIVCR1(MAXP)&
|
||||
! ,NRIVCR2(MAXP),WTRIVCR2(MAXP),
|
||||
|
||||
LOGICAL LCROSS
|
||||
|
||||
COMMON /UNITS/IOT,IOT1
|
||||
|
||||
COMMON /INTERPL/ IGRID(MAXGRD,MAXGRD),NX,NY,XGRID,YGRID
|
||||
|
||||
real*8 xusrsto,yusrsto
|
||||
INTEGER*2 IMATSTO
|
||||
|
||||
ALLOCATABLE xusrsto(:,:),yusrsto(:,:),wdsto(:,:),&
|
||||
WIDTHsto(:,:), SS1sto(:,:), SS2sto(:,:), WIDSsto(:,:)&
|
||||
,WIDBSsto(:,:),SSOsto(:,:),bs1sto(:,:)&
|
||||
,nopsto(:,:,:),imatsto(:,:),thtasto(:,:)
|
||||
|
||||
! loaded/ xusrsto(maxp,maxsto),yusrsto(maxp,maxsto),wdsto(maxp,maxsto),&
|
||||
! WIDTHsto(MAXP,maxsto), SS1sto(MAXP,maxsto), SS2sto(MAXP,maxsto), WIDSsto(MAXP,maxsto)&
|
||||
! ,WIDBSsto(MAXP,maxsto),SSOsto(MAXP,maxsto),bs1sto(maxp,maxsto)&
|
||||
! ,nopsto(maxe,8,maxsto),imatsto(maxe,maxsto),thtasto(maxe,maxsto)
|
||||
|
||||
ALLOCATABLE ICCLNSTO(:,:,:)&
|
||||
,NPSTO(:),NESTO(:),NLSTSTO(:),NCLMSTO(:)
|
||||
|
||||
|
||||
INTEGER*4 ILISTSTO,LLISTSTO
|
||||
ALLOCATABLE ILISTSTO(:,:,:),LLISTSTO(:,:)
|
||||
|
||||
COMMON /TMPLIST/ ilisttmp(100),INREORD
|
||||
|
||||
ALLOCATABLE ICN(:)
|
||||
|
||||
ALLOCATABLE ICONNCT(:,:)
|
||||
|
||||
ALLOCATABLE IOUTLST(:,:),NOUTLST(:),XOUT(:,:),YOUT(:,:)
|
||||
|
||||
COMMON /VIEWS/ HANG,VANG,VRTSCAL,HANGOLD,VANGOLD,VRTORIG,IASPCT
|
||||
|
||||
|
||||
END MODULE
|
||||
@ -0,0 +1,131 @@
|
||||
MODULE BLK1MOD
|
||||
|
||||
INCLUDE 'PARAM.COM'
|
||||
! BLK1
|
||||
!-
|
||||
REAL HSIZE
|
||||
COMMON /SSIZE/ HSIZE
|
||||
|
||||
INTEGER MAXP,MAXE,MAXLIN,MAXSTO,MAXECON,MAXLN,MAELN
|
||||
|
||||
|
||||
INTEGER*2 INSKP,IESKP,INEW,NCORN,IJUN,ISWTAGN,iswtintp
|
||||
!IPK MAY02 INTEGER*2 NOP,IMAT,IEM,NEF,NEFLAG,LINTYP,LAY
|
||||
INTEGER*2 IMAT,LINTYP,LAY,IRTYP
|
||||
INTEGER*4 NOP,IEM,NEF,NEFLAG,ILINEL
|
||||
! REAL*8 CORD,XUSR,YUSR,XC,YC,CMAP,XMAP,YMAP,pscale,xref,yref
|
||||
REAL*8 CORD,XUSR,YUSR,XC,YC,pscale,xref,yref
|
||||
REAL*8 ALXX,ALYY,ALWD,BLXX,BLYY,BLWD,XBRLEN,CNX,CNY,WIDTHD,HLEFT,HMID,HRIGHT,HSET
|
||||
|
||||
INTEGER*2 MSN
|
||||
ALLOCATABLE MSN(:)
|
||||
|
||||
|
||||
ALLOCATABLE CORD(:,:),XUSR(:),YUSR(:),XC(:),YC(:),IRTYP(:)&
|
||||
,NOP(:,:),IMAT(:),THTA(:),IMATL(:),CORDSN(:,:)&
|
||||
,WD(:) ,WD1(:),INSKP(:), IESKP(:),NCORN(:)&
|
||||
,WIDTH(:), SS1(:), SS2(:), WIDS(:)&
|
||||
,IJUN(:),INEW(:),IEM(:),LINTYP(:),NEFLAG(:),NEF(:,:),LAY(:),WTLAY(:,:)&
|
||||
,WIDBS(:),SSO(:),NODDEL(:),IELDEL(:)&
|
||||
,NOPSV(:,:),nefsv(:,:),IMATSV(:),LOCK(:),BS1(:),NKEY1(:),EDIF(:),ANGOP(:)&
|
||||
,IGRPNUM(:,:),MAXENT(:),IGRPSER(:),IUSEDM(:),IOD(:)&
|
||||
,ALXX(:),ALYY(:),BLXX(:),BLYY(:),ALWD(:),BLWD(:),ITYPBC(:),CNX(:,:),CNY(:,:),XBRLEN(:)&
|
||||
,HLEFT(:),HMID(:),HRIGHT(:),HSET(:,:),WIDTHD(:)
|
||||
ALLOCATABLE NRF(:),AREF(:),LEVREM(:),TRANSEL(:),WLEN(:),WHGT(:)
|
||||
INTEGER*8 MAXPTS
|
||||
COMMON /BLK/ MAXPTS,PSCALE,xref,yref&
|
||||
, IPNN, IPEN, XMIN, YMIN, XMAX, YMAX, NLAYD,ILAYTP&
|
||||
,VOID, VDX, XSCALE, YSCALE,AMAP,IRESTT&
|
||||
,NXPMIN, NYPMIN, NXPMAX, NYPMAX, IPP&
|
||||
,XPMIN, YPMIN, XPMAX, YPMAX, WDSCAL,IESW&
|
||||
,NPLAST,NELAST,NEFL,NENTRY,IECHG,ICHG&
|
||||
,IIN, IBAK, LUNIT,IGIN,IS11,IMP,IGFG,ISWAP,ITRIAN&
|
||||
,klint,jlint,lmpnam,IDELV,nmapf,NSIGF,NPUNDO,NEUNDO,nefsav,nesav&
|
||||
,xadded,yadded,icolsw,rad,colint,ielvsw,ISWTAGN,iswtintp,eref,igrp,igrpout,MAXIGRP&
|
||||
,JPTSB,ILINEL
|
||||
!IPK MAR02 ADD BS1
|
||||
!IPK FEB02 ADD LOCK
|
||||
!IPK MAY01 ADD NODDEL AND IELDEL
|
||||
!IPK JUL98 WIDBS AND SSO ADDED
|
||||
!IPK JAN98 IDELV ADDED
|
||||
!ipk feb94 line above added, two lines changed may 94 to add xref,yref
|
||||
! 9 ,LINTYP(MAXLIN),NEFLAG(150),NEF(600,3),LAY(MAXP)
|
||||
!
|
||||
!IPK MAR04 INTEGER*2 ILIST,LLIST
|
||||
INTEGER*4 ILIST,LLIST
|
||||
|
||||
ALLOCATABLE ILIST(:,:),LLIST(:)
|
||||
COMMON /BLK1/ NLST, ICCLN(140,350),NCLM
|
||||
!
|
||||
CHARACTER*80 TITLE
|
||||
CHARACTER*24 HLABL
|
||||
!ipk feb94 add
|
||||
character*40 mpnam
|
||||
!ipk dec97 line above modified
|
||||
|
||||
CHARACTER*1 ALABL(10)
|
||||
COMMON /BLKA1/ TITLE,HLABL,ALABL,MPNAM
|
||||
!ipk dec97 line above modified
|
||||
!
|
||||
!IPK JAN01 INCREASE IPSW TO 10
|
||||
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||||
!ycw mar97 add
|
||||
COMMON /CROSS/ ICRS,XPCS(2),YPCS(2),NCSNOD,XCND(50),YCND(50),&
|
||||
NCSPTS,XELVP(50),YELVP(50),ZELVP(50),SELVP(50),&
|
||||
ZREF,DFACTOR,ZMIN,IXNOD,LCROSS
|
||||
! ,IVMIL(MCRS),NRIVL(MCRS),NOREACH(MCRS)&
|
||||
! ,CRSDAT(MCRS,-4:MPTS,3),NCRSEC,XCRS(MCRS),YCRS(MCRS)
|
||||
|
||||
INTEGER IVMIL,NRIVL,NOREACH,NCRSEC,MCRS,MPTS
|
||||
REAL CRSDAT,XCRS,YCRS
|
||||
ALLOCATABLE IVMIL(:),NRIVL(:),NOREACH(:),CRSDAT(:,:,:),XCRS(:),YCRS(:)
|
||||
|
||||
ALLOCATABLE NRIVCR1(:),WTRIVCR1(:),NRIVCR2(:),WTRIVCR2(:)
|
||||
|
||||
!NRIVCR1(MAXP),WTRIVCR1(MAXP)&
|
||||
! ,NRIVCR2(MAXP),WTRIVCR2(MAXP),
|
||||
|
||||
LOGICAL LCROSS
|
||||
|
||||
COMMON /UNITS/IOT,IOT1
|
||||
|
||||
COMMON /INTERPL/ IGRID(MAXGRD,MAXGRD),NX,NY,XGRID,YGRID
|
||||
|
||||
real*8 xusrsto,yusrsto
|
||||
INTEGER*2 IMATSTO
|
||||
|
||||
ALLOCATABLE xusrsto(:,:),yusrsto(:,:),wdsto(:,:),&
|
||||
WIDTHsto(:,:), SS1sto(:,:), SS2sto(:,:), WIDSsto(:,:)&
|
||||
,WIDBSsto(:,:),SSOsto(:,:),bs1sto(:,:)&
|
||||
,nopsto(:,:,:),imatsto(:,:),thtasto(:,:)
|
||||
|
||||
! loaded/ xusrsto(maxp,maxsto),yusrsto(maxp,maxsto),wdsto(maxp,maxsto),&
|
||||
! WIDTHsto(MAXP,maxsto), SS1sto(MAXP,maxsto), SS2sto(MAXP,maxsto), WIDSsto(MAXP,maxsto)&
|
||||
! ,WIDBSsto(MAXP,maxsto),SSOsto(MAXP,maxsto),bs1sto(maxp,maxsto)&
|
||||
! ,nopsto(maxe,8,maxsto),imatsto(maxe,maxsto),thtasto(maxe,maxsto)
|
||||
|
||||
ALLOCATABLE ICCLNSTO(:,:,:)&
|
||||
,NPSTO(:),NESTO(:),NLSTSTO(:),NCLMSTO(:)
|
||||
|
||||
|
||||
INTEGER*4 ILISTSTO,LLISTSTO
|
||||
ALLOCATABLE ILISTSTO(:,:,:),LLISTSTO(:,:)
|
||||
|
||||
COMMON /TMPLIST/ ilisttmp(100),INREORD
|
||||
|
||||
ALLOCATABLE ICN(:)
|
||||
|
||||
ALLOCATABLE ICONNCT(:,:),NKEP(:)
|
||||
|
||||
ALLOCATABLE IOUTLST(:,:),NOUTLST(:),XOUT(:,:),YOUT(:,:)
|
||||
|
||||
COMMON /VIEWS/ HANG,VANG,VRTSCAL,HANGOLD,VANGOLD,VRTORIG,IASPCT
|
||||
|
||||
INTEGER KID(900,5)
|
||||
|
||||
INTEGER IGUNIT,NROWS1,NCOLS1
|
||||
REAL XXORG,YYORG,CELLSIZX,CELLSIZY
|
||||
REAL VALLIN,XCOL,YCOL
|
||||
ALLOCATABLE VALLIN(:),XCOL(:),YCOL(:)
|
||||
|
||||
END MODULE
|
||||
@ -0,0 +1,85 @@
|
||||
|
||||
|
||||
INCLUDE 'PARAM.COM'
|
||||
! BLK1
|
||||
!-
|
||||
REAL HSIZE
|
||||
COMMON /SSIZE/ HSIZE
|
||||
|
||||
|
||||
INTEGER*2 INSKP,IESKP,INEW,NCORN,IJUN,ISWTAGN,iswtintp
|
||||
!IPK MAY02 INTEGER*2 NOP,IMAT,IEM,NEF,NEFLAG,LINTYP,LAY
|
||||
INTEGER*2 IMAT,LINTYP,LAY
|
||||
INTEGER*4 NOP,IEM,NEF,NEFLAG
|
||||
! REAL*8 CORD,XUSR,YUSR,XC,YC,CMAP,XMAP,YMAP,pscale,xref,yref
|
||||
REAL*8 CORD,XUSR,YUSR,XC,YC,pscale,xref,yref
|
||||
!
|
||||
COMMON /BLK/ CORD(MAXP,2),XUSR(MAXP),YUSR(MAXP),XC(MAXP),YC(MAXP)&
|
||||
,PSCALE,xref,yref&
|
||||
, IPNN, IPEN, XMIN, YMIN, XMAX, YMAX, NLAYD,ILAYTP&
|
||||
,VOID, VDX, XSCALE, YSCALE,AMAP,IRESTT&
|
||||
,NXPMIN, NYPMIN, NXPMAX, NYPMAX, IPP&
|
||||
,XPMIN, YPMIN, XPMAX, YPMAX, WDSCAL,IESW&
|
||||
,MAXPTS,NPLAST,NELAST,NEFL,NENTRY,IECHG,ICHG&
|
||||
,NOP(MAXE,8),IMAT(MAXE),THTA(MAXE),IMATL(MAXE),CORDSN(MAXP,2)&
|
||||
,WD(MAXP) ,WD1(MAXP) ,INSKP(MAXP), IESKP(MAXE)&
|
||||
,NCORN(MAXP),IIN, IBAK, LUNIT,IGIN,IS11,IMP,IGFG,ISWAP,ITRIAN&
|
||||
,WIDTH(MAXP), SS1(MAXP), SS2(MAXP), WIDS(MAXP)&
|
||||
,IJUN(MAXP),INEW(MAXP),IEM(MAXE)&
|
||||
,LINTYP(MAXLIN),NEFLAG(MAXP),NEF(MAXP,3),LAY(0:MAXP+1),WTLAY(0:MAXP,9)&
|
||||
,klint,jlint,lmpnam,IDELV&
|
||||
,WIDBS(MAXP),SSO(MAXP),nmapf,NSIGF,NODDEL(MAXP),IELDEL(MAXE)&
|
||||
,NPUNDO,NEUNDO,NOPSV(MAXE,8),nesav,nefsv(maxp,3),nefsav,IMATSV(MAXE)&
|
||||
,LOCK(MAXP),xadded,yadded,BS1(MAXP),icolsw,rad,colint,ielvsw,ISWTAGN,iswtintp
|
||||
!IPK MAR02 ADD BS1
|
||||
!IPK FEB02 ADD LOCK
|
||||
!IPK MAY01 ADD NODDEL AND IELDEL
|
||||
!IPK JUL98 WIDBS AND SSO ADDED
|
||||
!IPK JAN98 IDELV ADDED
|
||||
!ipk feb94 line above added, two lines changed may 94 to add xref,yref
|
||||
! 9 ,LINTYP(MAXLIN),NEFLAG(150),NEF(600,3),LAY(MAXP)
|
||||
!
|
||||
!IPK MAR04 INTEGER*2 ILIST,LLIST
|
||||
INTEGER*4 ILIST,LLIST
|
||||
COMMON /BLK1/ ILIST(MAXLN,MAELN),LLIST(MAXLN),NLST&
|
||||
, ICCLN(50,350),NCLM
|
||||
!
|
||||
CHARACTER*80 TITLE
|
||||
CHARACTER*24 HLABL
|
||||
!ipk feb94 add
|
||||
character*40 mpnam
|
||||
!ipk dec97 line above modified
|
||||
|
||||
CHARACTER*1 ALABL(10)
|
||||
COMMON /BLKA1/ TITLE,HLABL,ALABL,MPNAM
|
||||
!ipk dec97 line above modified
|
||||
!
|
||||
!IPK JAN01 INCREASE IPSW TO 10
|
||||
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||||
!ycw mar97 add
|
||||
COMMON /CROSS/ ICRS,XPCS(2),YPCS(2),NCSNOD,XCND(50),YCND(50),&
|
||||
NCSPTS,XELVP(50),YELVP(50),ZELVP(50),SELVP(50),&
|
||||
ZREF,DFACTOR,ZMIN,IXNOD,LCROSS&
|
||||
,IVMIL(MCRS),NRIVL(MCRS),NOREACH(MCRS)&
|
||||
,CRSDAT(MCRS,MPTS,3),NRIVCR1(MAXP),WTRIVCR1(MAXP)&
|
||||
,NRIVCR2(MAXP),WTRIVCR2(MAXP),NCRSEC,XCRS(MCRS),YCRS(MCRS)
|
||||
LOGICAL LCROSS
|
||||
|
||||
COMMON /UNITS/IOT,IOT1
|
||||
|
||||
COMMON /INTERPL/ IGRID(MAXGRD,MAXGRD),NX,NY,XGRID,YGRID
|
||||
|
||||
real*8 xusrsto,yusrsto
|
||||
INTEGER*2 IMATSTO
|
||||
common /loaded/ xusrsto(maxp,maxsto),yusrsto(maxp,maxsto),wdsto(maxp,maxsto),&
|
||||
WIDTHsto(MAXP,maxsto), SS1sto(MAXP,maxsto), SS2sto(MAXP,maxsto), WIDSsto(MAXP,maxsto)&
|
||||
,WIDBSsto(MAXP,maxsto),SSOsto(MAXP,maxsto),bs1sto(maxp,maxsto)&
|
||||
,nopsto(maxe,8,maxsto),imatsto(maxe,maxsto),thtasto(maxe,maxsto)&
|
||||
,ICCLNSTO(50,350,MAXSTO)&
|
||||
,NPSTO(MAXSTO),NESTO(MAXSTO),NLSTSTO(MAXSTO),NCLMSTO(MAXSTO)
|
||||
|
||||
|
||||
INTEGER*4 ILISTSTO,LLISTSTO
|
||||
COMMON /LOADED2/ ILISTSTO(MAXLN,MAELN,MAXSTO),LLISTSTO(MAXLN,MAXSTO)
|
||||
|
||||
COMMON /TMPLIST/ ilisttmp(100),INREORD
|
||||
@ -0,0 +1,23 @@
|
||||
!IPK LAST UPDATED OCT 18 1996
|
||||
!
|
||||
! BLK2
|
||||
!
|
||||
INTEGER*8 MTSUM,MRSUM,MTSUMSV,MSUM
|
||||
COMMON /BLKKB4/MTSUM,MRSUM,MTSUMSV(0:100),MSUM
|
||||
INTEGER ENXT,NCM,NCMI,KNT,NDP,NNEW,MP,NAD,NAE,MLIST,NDELM &
|
||||
,LIST,NINC,LNEW,NDROP,NELIM,NITST,NFWSAV,MTSUM1,NSEQ,NFWSV
|
||||
COMMON /BLKB/ NCM,NCMI,KNT,NDP,NNEW,MP,NAD,NAE &
|
||||
,MLIST(MAXE),ENXT(MAXE),NDELM(MAXP),LIST(MAXP) &
|
||||
,NINC(MAXP),LNEW(8),NDROP(8),NELIM(MAXE),NITST &
|
||||
,NFWS,NFWSAV,mtsum1,NSEQ,NFWSV(0:100)
|
||||
!IPK MAY94 LINE ABOVE ADDED
|
||||
!
|
||||
INTEGER ICON
|
||||
COMMON /BLKB1/ ICON(MAXE,MAXECON)
|
||||
!
|
||||
INTEGER NECON
|
||||
COMMON /BLKB2/ NECON(MAXP,MAXECON)
|
||||
!
|
||||
INTEGER ITRAC,NTRAC
|
||||
COMMON /BLKB3/ ITRAC(350),NTRAC,JTRAC(350),KTRAC(350)
|
||||
!
|
||||
@ -0,0 +1,30 @@
|
||||
MODULE BLK2MOD
|
||||
|
||||
!IPK LAST UPDATED OCT 18 1996
|
||||
!
|
||||
! BLK2
|
||||
!
|
||||
INTEGER*8 MTSUM,MRSUM,MTSUMSV,MSUM,MTSUM1
|
||||
COMMON /BLKKB4/MTSUM,MRSUM,MTSUMSV(0:100),MSUM
|
||||
INTEGER ENXT,NCM,NCMI,KNT,NDP,NNEW,MP,NAD,NAE,MLIST,NDELM &
|
||||
,LIST,NINC,LNEW,NDROP,NELIM,NITST,NFWSAV,NSEQ,NFWSV
|
||||
COMMON /BLKB/ mtsum1,NCM,NCMI,KNT,NDP,NNEW,MP,NAD,NAE &
|
||||
,LNEW(8),NDROP(8),NITST &
|
||||
,NFWS,NFWSAV,NSEQ,NFWSV(0:100)
|
||||
!IPK MAY94 LINE ABOVE ADDED
|
||||
|
||||
ALLOCATABLE MLIST(:),ENXT(:),NDELM(:),LIST(:) &
|
||||
,NINC(:),NELIM(:)
|
||||
|
||||
!
|
||||
INTEGER ICON
|
||||
ALLOCATABLE ICON(:,:)
|
||||
!
|
||||
INTEGER NECON
|
||||
ALLOCATABLE NECON(:,:)
|
||||
!
|
||||
INTEGER ITRAC,NTRAC,NTRACT,NNEL
|
||||
COMMON /BLKB3/ ITRAC(1000),NTRAC,JTRAC(1000,20),KTRAC(1000,20)
|
||||
!
|
||||
END MODULE
|
||||
|
||||
@ -0,0 +1,7 @@
|
||||
MODULE BLK3D
|
||||
|
||||
REAL XMAX,YMAX,ZMAX,XMIN,YMIN,ZMIN,XLEN,YLEN,ZLEN,DIST,DISTSTEP
|
||||
REAL :: EYE(4,4)
|
||||
REAL :: ROTSV,ROTHSV,ROTVSV,DISTSV,VSCALESV
|
||||
INTEGER IROTSV
|
||||
END MODULE
|
||||
@ -0,0 +1,6 @@
|
||||
MODULE BLKELTLD
|
||||
REAL DYE,TAE,HAE,XYCEL
|
||||
INTEGER NCLINE,NEST,IYDATE,NHYE,IQUENIT,IBINEL,NQHYD,NQP,IRMATYP
|
||||
ALLOCATABLE DYE(:,:),TAE(:,:),HAE(:,:),NCLINE(:),NEST(:),IYDATE(:),NHYE(:),ILAYRE(:,:),HDE(:,:,:),XYCEL(:,:)
|
||||
|
||||
END
|
||||
@ -0,0 +1,14 @@
|
||||
|
||||
PARAMETER (MAXPL=500000,MAXELMP=50000)
|
||||
|
||||
REAL*8 XCEN,YCEN,RADS,MAP,XMAP,YMAP,CMAP
|
||||
|
||||
COMMON /MAPBLK/ NOPEL(MAXELMP,3),XCEN(MAXELMP),YCEN(MAXELMP)&
|
||||
,RADS(MAXELMP) ,NKEY(MAXELMP),IEDGE(500,2),IGAP(500),CMAP(MAXPL,2)&
|
||||
,XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL),NELFM(500)
|
||||
|
||||
|
||||
COMMON /MAPINFO/ NELTS
|
||||
|
||||
common /mapc/imap(maxpl),NCRS(MAXPL)
|
||||
|
||||
@ -0,0 +1,4 @@
|
||||
MODULE BLKMAT
|
||||
INTEGER, ALLOCATABLE :: IMATN(:),IRGB(:)
|
||||
REAL, ALLOCATABLE :: SHINE(:),GLOSS(:)
|
||||
END MODULE
|
||||
@ -0,0 +1,856 @@
|
||||
!ipk lsdt update nov 10 1995
|
||||
SUBROUTINE BRKDWN(NCN,NELNO)
|
||||
! SUBROUTINE BRKDWN(X,Y,VL,NCN)
|
||||
SAVE
|
||||
DOUBLE PRECISION XN,XLN,YLN,XLP,YLP
|
||||
PARAMETER (NTB=100)
|
||||
!
|
||||
! Routine to subdivide quadrilaterals and triangles for plotting
|
||||
!
|
||||
!ipkoct93 COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ
|
||||
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||||
COMMON /PLTC/IPSAV,IFLG,XLL,YLL
|
||||
LOGICAL SWITCH
|
||||
!
|
||||
! DIMENSION X(10),Y(10),VL(10)
|
||||
COMMON /BRK/ X(10),Y(10),VL(10),DL(10),VLM(10)
|
||||
DIMENSION IQ(3,8),RIX(3,8),RIY(3,8)
|
||||
DIMENSION IT(3,4),ZIX(3,4),ZIY(3,4)
|
||||
DIMENSION IST(3,3)
|
||||
DIMENSION CX(3,NTB),CY(3,NTB),VAL(3,NTB),XLC(3,NTB),YLC(3,NTB)
|
||||
DIMENSION ISPLT(3),XP(6),YP(6),VP(6),XLP(6),YLP(6)
|
||||
DATA IQ / 1, 2, 9, 2, 3, 4, 2, 4, 9, 4, 5, 9,&
|
||||
1, 9, 8, 8, 9, 6, 8, 6, 7, 9, 5, 6/
|
||||
DATA RIX/ -1.,0.,0., 0.,1.,1., 0.,1.,0., 1.,1.,0.,&
|
||||
-1.,0.,-1., -1.,0.,0., -1.,0.,-1., 0.,1.,0./
|
||||
DATA RIY/ -1.,-1.,0., -1.,-1.,0., -1.,0.,0., 0.,1.,0.,&
|
||||
-1.,0.,0., 0.,0.,1., 0.,1.,1., 0.,1.,1./
|
||||
DATA IT / 1, 2, 6, 3, 4, 2, 5, 6, 4, 2, 4, 6/
|
||||
DATA ZIX/0.,.5,0., 1.,.5,.5, 0.,0.,.5, .5,.5,0./
|
||||
DATA ZIY/0.,0.,.5, 0.,.5,0., 1.,.5,.5, 0.,.5,.5/
|
||||
DATA IST/ 1,4,5, 4,2,5, 1,5,3/
|
||||
! DATA XCSQ/1.0/
|
||||
!
|
||||
! Distance function squared
|
||||
!
|
||||
DISTSQ(AX,AY,BX,BY)=(AX-BX)**2+(AY-BY)**2
|
||||
|
||||
! do n=1,ncn
|
||||
! write(90,*) n,x(n),y(n),vl(n)
|
||||
! enddo
|
||||
IF(NCN .LT. 6) THEN
|
||||
CALL EXPND(NCN,NELNO)
|
||||
ENDIF
|
||||
|
||||
XCSQ=0.25
|
||||
!
|
||||
! If NCN = 3 then copy over values
|
||||
!
|
||||
IF(NCN .EQ. 3) THEN
|
||||
ITT=-1
|
||||
DO 180 L=1,3
|
||||
CX(L,1)=X(L)
|
||||
CY(L,1)=Y(L)
|
||||
VAL(L,1)=VL(L)
|
||||
180 CONTINUE
|
||||
XLC(1,1)=0.
|
||||
XLC(2,1)=1.
|
||||
XLC(3,1)=0.
|
||||
YLC(1,1)=0.
|
||||
YLC(2,1)=0.
|
||||
YLC(3,1)=0.
|
||||
NTAB=1
|
||||
!
|
||||
! Subdivide quadrilateral to 2 triangles and develop list
|
||||
!
|
||||
ELSEIF(NCN .EQ. 4) THEN
|
||||
ITT=0
|
||||
DO 190 I=1,3
|
||||
X(I+4)=X(I)
|
||||
Y(I+4)=Y(I)
|
||||
VL(I+4)=VL(I)
|
||||
190 CONTINUE
|
||||
!
|
||||
! Pick long side for diagonal
|
||||
!
|
||||
IF (DISTSQ(X(1),Y(1),X(3),Y(3)) .GT. DISTSQ(X(2),Y(2),X(4),Y(4))) THEN
|
||||
!
|
||||
! Rotate if its longer
|
||||
!
|
||||
DO 200 I=1,5
|
||||
X(I)=X(I+1)
|
||||
Y(I)=Y(I+1)
|
||||
VL(I)=VL(I+1)
|
||||
200 CONTINUE
|
||||
ENDIF
|
||||
!
|
||||
! Now process it
|
||||
!
|
||||
DO 210 L=1,3
|
||||
CX(L,1)=X(L)
|
||||
CY(L,1)=Y(L)
|
||||
VAL(L,1)=VL(L)
|
||||
210 CONTINUE
|
||||
XLC(1,1)=-1.
|
||||
XLC(2,1)=1.
|
||||
XLC(3,1)=1.
|
||||
YLC(1,1)=-1.
|
||||
YLC(2,1)=-1.
|
||||
YLC(3,1)=1.
|
||||
DO 220 L=1,3
|
||||
CX(L,2)=X(L+2)
|
||||
CY(L,2)=Y(L+2)
|
||||
VAL(L,2)=VL(L+2)
|
||||
220 CONTINUE
|
||||
XLC(1,2)=1.
|
||||
XLC(2,2)=-1.
|
||||
XLC(3,2)=-1.
|
||||
YLC(1,2)=1.
|
||||
YLC(2,2)=1.
|
||||
YLC(3,2)=-1.
|
||||
NTAB=2
|
||||
!
|
||||
! Subdivide 6 node triangle to 4 triangles and develop list
|
||||
!
|
||||
ELSEIF(NCN .EQ. 6) THEN
|
||||
ITT=2
|
||||
! write(90,*) (x(i),i=1,8)
|
||||
DO 300 K=1,4
|
||||
DO 280 L=1,3
|
||||
CX(L,K)=X(IT(L,K))
|
||||
CY(L,K)=Y(IT(L,K))
|
||||
VAL(L,K)=VL(IT(L,K))
|
||||
XLC(L,K)=ZIX(L,K)
|
||||
YLC(L,K)=ZIY(L,K)
|
||||
280 CONTINUE
|
||||
300 CONTINUE
|
||||
NTAB=4
|
||||
!
|
||||
! Subdivide 8 node quadrilateral to 8 triangles and develop list
|
||||
!
|
||||
ELSEIF(NCN .GE. 8) THEN
|
||||
IF(NCN .EQ. 8) THEN
|
||||
ITT=1
|
||||
ELSE
|
||||
ITT=0
|
||||
X9=X(9)
|
||||
Y9=Y(9)
|
||||
VL9=VL(9)
|
||||
ENDIF
|
||||
DO 310 I=1,2
|
||||
X(I+8)=X(I)
|
||||
Y(I+8)=Y(I)
|
||||
VL(I+8)=VL(I)
|
||||
310 CONTINUE
|
||||
!
|
||||
! Pick long side for diagonal
|
||||
!
|
||||
IF (DISTSQ(X(1),Y(1),X(5),Y(5)) .GT. &
|
||||
DISTSQ(X(3),Y(3),X(7),Y(7))) THEN
|
||||
!
|
||||
! Rotate if its longer
|
||||
!
|
||||
DO 320 I=1,8
|
||||
X(I)=X(I+2)
|
||||
Y(I)=Y(I+2)
|
||||
VL(I)=VL(I+2)
|
||||
320 CONTINUE
|
||||
ENDIF
|
||||
!
|
||||
! Define center point
|
||||
!
|
||||
IF(NCN .LT. 9) THEN
|
||||
X(9)=0.
|
||||
Y(9)=0.
|
||||
VL(9)=0.
|
||||
DO 360 I=1,8
|
||||
SH=XN(ITT,I,0.d0,0.d0)
|
||||
X(9)=X(9)+SH*X(I)
|
||||
Y(9)=Y(9)+SH*Y(I)
|
||||
VL(9)=VL(9)+SH*VL(I)
|
||||
360 CONTINUE
|
||||
ELSE
|
||||
X(9)=X9
|
||||
Y(9)=Y9
|
||||
VL(9)=VL9
|
||||
ENDIF
|
||||
DO 400 K=1,8
|
||||
DO 380 L=1,3
|
||||
CX(L,K)=X(IQ(L,K))
|
||||
CY(L,K)=Y(IQ(L,K))
|
||||
VAL(L,K)=VL(IQ(L,K))
|
||||
XLC(L,K)=RIX(L,K)
|
||||
YLC(L,K)=RIY(L,K)
|
||||
380 CONTINUE
|
||||
400 CONTINUE
|
||||
NTAB=8
|
||||
ENDIF
|
||||
!
|
||||
! Start at bottom of list
|
||||
!
|
||||
420 CONTINUE
|
||||
N=NTAB
|
||||
!
|
||||
! Check lengths of sides and nore values
|
||||
!
|
||||
ISTART=0
|
||||
ICNT=0
|
||||
IF(DISTSQ(CX(1,N),CY(1,N),CX(2,N),CY(2,N)) .GT. XCSQ) THEN
|
||||
ICNT=1
|
||||
ISPLT(1)=1
|
||||
ISTART=1
|
||||
ELSE
|
||||
ISPLT(1)=0
|
||||
ENDIF
|
||||
IF(DISTSQ(CX(2,N),CY(2,N),CX(3,N),CY(3,N)) .GT. XCSQ) THEN
|
||||
ICNT=ICNT+1
|
||||
ISPLT(2)=1
|
||||
ISTART=2
|
||||
ELSE
|
||||
ISPLT(2)=0
|
||||
ENDIF
|
||||
IF(DISTSQ(CX(3,N),CY(3,N),CX(1,N),CY(1,N)) .GT. XCSQ) THEN
|
||||
ICNT=ICNT+1
|
||||
ISPLT(3)=1
|
||||
ISTART=3
|
||||
ELSE
|
||||
ISPLT(3)=0
|
||||
ENDIF
|
||||
IF(ICNT .EQ. 0) THEN
|
||||
!
|
||||
! Call to plot contours for each triangle
|
||||
!
|
||||
IF(IPSAV .EQ. 0) THEN
|
||||
CALL CBLOK(CX(1,N),CY(1,N),VAL(1,N))
|
||||
ELSE
|
||||
CALL CONTRD(CX(1,N),CY(1,N),VAL(1,N))
|
||||
ENDIF
|
||||
NTAB=N-1
|
||||
IF(NTAB .EQ. 0) THEN
|
||||
RETURN
|
||||
ELSE
|
||||
GO TO 420
|
||||
ENDIF
|
||||
ELSEIF(ICNT .EQ. 1) THEN
|
||||
!
|
||||
! We must split the triangle into 2. Rotate first into temporary array.
|
||||
!
|
||||
IF(NTAB .GT. NTB-1) THEN
|
||||
WRITE(*,*) 'ELEMENT TABLE SIZE EXCEEDED PLOT CURTAILED'
|
||||
RETURN
|
||||
ENDIF
|
||||
DO 440 I=1,3
|
||||
J=MOD(ISTART+I-2,3)+1
|
||||
XP(I)=CX(J,N)
|
||||
YP(I)=CY(J,N)
|
||||
VP(I)=VAL(J,N)
|
||||
XLP(I)=XLC(J,N)
|
||||
YLP(I)=YLC(J,N)
|
||||
440 CONTINUE
|
||||
XLN=(XLP(1)+XLP(2))/2.
|
||||
YLN=(YLP(1)+YLP(2))/2.
|
||||
XNEW=0.
|
||||
YNEW=0.
|
||||
VNEW=0.
|
||||
DO 460 I=1,NCN
|
||||
SH=XN(ITT,I,XLN,YLN)
|
||||
XNEW=XNEW+SH*X(I)
|
||||
YNEW=YNEW+SH*Y(I)
|
||||
VNEW=VNEW+SH*VL(I)
|
||||
460 CONTINUE
|
||||
CX(1,N)=XP(1)
|
||||
CX(2,N)=XNEW
|
||||
CX(3,N)=XP(3)
|
||||
CY(1,N)=YP(1)
|
||||
CY(2,N)=YNEW
|
||||
CY(3,N)=YP(3)
|
||||
VAL(1,N)=VP(1)
|
||||
VAL(2,N)=VNEW
|
||||
VAL(3,N)=VP(3)
|
||||
XLC(1,N)=XLP(1)
|
||||
XLC(2,N)=XLN
|
||||
XLC(3,N)=XLP(3)
|
||||
YLC(1,N)=YLP(1)
|
||||
YLC(2,N)=YLN
|
||||
YLC(3,N)=YLP(3)
|
||||
|
||||
CX(1,N+1)=XP(2)
|
||||
CX(2,N+1)=XP(3)
|
||||
CX(3,N+1)=XNEW
|
||||
CY(1,N+1)=YP(2)
|
||||
CY(2,N+1)=YP(3)
|
||||
CY(3,N+1)=YNEW
|
||||
VAL(1,N+1)=VP(2)
|
||||
VAL(2,N+1)=VP(3)
|
||||
VAL(3,N+1)=VNEW
|
||||
XLC(1,N+1)=XLP(2)
|
||||
XLC(2,N+1)=XLP(3)
|
||||
XLC(3,N+1)=XLN
|
||||
YLC(1,N+1)=YLP(2)
|
||||
YLC(2,N+1)=YLP(3)
|
||||
YLC(3,N+1)=YLN
|
||||
NTAB=N+1
|
||||
ELSEIF(ICNT .EQ. 2) THEN
|
||||
IF(NTAB .GT. NTB-2) THEN
|
||||
WRITE(*,*) 'ELEMENT TABLE SIZE EXCEEDED PLOT CURTAILED'
|
||||
RETURN
|
||||
ENDIF
|
||||
!
|
||||
! We must split the triangle into 3. Rotate first into temporary array.
|
||||
!
|
||||
IF(ISTART .EQ. 3) THEN
|
||||
IF(ISPLT(1) .EQ. 1) ISTART=3
|
||||
IF(ISPLT(2) .EQ. 1) ISTART=2
|
||||
ELSE
|
||||
ISTART=1
|
||||
ENDIF
|
||||
DO 540 I=1,3
|
||||
J=MOD(ISTART+I-2,3)+1
|
||||
XP(I)=CX(J,N)
|
||||
YP(I)=CY(J,N)
|
||||
VP(I)=VAL(J,N)
|
||||
XLP(I)=XLC(J,N)
|
||||
YLP(I)=YLC(J,N)
|
||||
540 CONTINUE
|
||||
XLP(4)=(XLP(1)+XLP(2))/2.
|
||||
YLP(4)=(YLP(1)+YLP(2))/2.
|
||||
XLP(5)=(XLP(2)+XLP(3))/2.
|
||||
YLP(5)=(YLP(2)+YLP(3))/2.
|
||||
XP(4)=0.
|
||||
YP(4)=0.
|
||||
VP(4)=0.
|
||||
XP(5)=0.
|
||||
YP(5)=0.
|
||||
VP(5)=0.
|
||||
DO 560 I=1,NCN
|
||||
SH=XN(ITT,I,XLP(4),YLP(4))
|
||||
XP(4)=XP(4)+SH*X(I)
|
||||
YP(4)=YP(4)+SH*Y(I)
|
||||
VP(4)=VP(4)+SH*VL(I)
|
||||
SH=XN(ITT,I,XLP(5),YLP(5))
|
||||
XP(5)=XP(5)+SH*X(I)
|
||||
YP(5)=YP(5)+SH*Y(I)
|
||||
VP(5)=VP(5)+SH*VL(I)
|
||||
560 CONTINUE
|
||||
N=NTAB-1
|
||||
DO 600 K=1,3
|
||||
N=N+1
|
||||
DO 580 L=1,3
|
||||
CX(L,N)=XP(IST(L,K))
|
||||
CY(L,N)=YP(IST(L,K))
|
||||
VAL(L,N)=VP(IST(L,K))
|
||||
XLC(L,N)=XLP(IST(L,K))
|
||||
YLC(L,N)=YLP(IST(L,K))
|
||||
580 CONTINUE
|
||||
600 CONTINUE
|
||||
NTAB=N
|
||||
ELSEIF(ICNT .EQ. 3) THEN
|
||||
IF(NTAB .GT. NTB-3) THEN
|
||||
WRITE(*,*) 'ELEMENT TABLE SIZE EXCEEDED PLOT CURTAILED'
|
||||
RETURN
|
||||
ENDIF
|
||||
!
|
||||
! We must split the triangle into 4. Fill midsides
|
||||
!
|
||||
DO 640 I=1,3
|
||||
XP(2*I-1)=CX(I,N)
|
||||
YP(2*I-1)=CY(I,N)
|
||||
VP(2*I-1)=VAL(I,N)
|
||||
XLP(2*I-1)=XLC(I,N)
|
||||
YLP(2*I-1)=YLC(I,N)
|
||||
640 CONTINUE
|
||||
XLP(2)=(XLP(1)+XLP(3))/2.
|
||||
YLP(2)=(YLP(1)+YLP(3))/2.
|
||||
XLP(4)=(XLP(3)+XLP(5))/2.
|
||||
YLP(4)=(YLP(3)+YLP(5))/2.
|
||||
XLP(6)=(XLP(5)+XLP(1))/2.
|
||||
YLP(6)=(YLP(5)+YLP(1))/2.
|
||||
XP(2)=0.
|
||||
YP(2)=0.
|
||||
VP(2)=0.
|
||||
XP(4)=0.
|
||||
YP(4)=0.
|
||||
VP(4)=0.
|
||||
XP(6)=0.
|
||||
YP(6)=0.
|
||||
VP(6)=0.
|
||||
DO 660 I=1,NCN
|
||||
SH=XN(ITT,I,XLP(2),YLP(2))
|
||||
XP(2)=XP(2)+SH*X(I)
|
||||
YP(2)=YP(2)+SH*Y(I)
|
||||
VP(2)=VP(2)+SH*VL(I)
|
||||
SH=XN(ITT,I,XLP(4),YLP(4))
|
||||
XP(4)=XP(4)+SH*X(I)
|
||||
YP(4)=YP(4)+SH*Y(I)
|
||||
VP(4)=VP(4)+SH*VL(I)
|
||||
SH=XN(ITT,I,XLP(6),YLP(6))
|
||||
XP(6)=XP(6)+SH*X(I)
|
||||
YP(6)=YP(6)+SH*Y(I)
|
||||
VP(6)=VP(6)+SH*VL(I)
|
||||
660 CONTINUE
|
||||
N=NTAB-1
|
||||
DO 700 K=1,4
|
||||
N=N+1
|
||||
DO 680 L=1,3
|
||||
CX(L,N)=XP(IT(L,K))
|
||||
CY(L,N)=YP(IT(L,K))
|
||||
VAL(L,N)=VP(IT(L,K))
|
||||
XLC(L,N)=XLP(IT(L,K))
|
||||
YLC(L,N)=YLP(IT(L,K))
|
||||
680 CONTINUE
|
||||
700 CONTINUE
|
||||
NTAB=N
|
||||
ENDIF
|
||||
GO TO 420
|
||||
!
|
||||
END
|
||||
SUBROUTINE CONTRD(X,Y,V)
|
||||
SAVE
|
||||
!
|
||||
! Routine to draw contours across triangle
|
||||
!
|
||||
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||||
LOGICAL SWITCH
|
||||
DIMENSION X(3),Y(3),V(3),XX(2),YY(2)
|
||||
!
|
||||
! Get VMIN and VMAX
|
||||
!
|
||||
VMIN=MIN(V(1),V(2),V(3))
|
||||
VMAX=MAX(V(1),V(2),V(3))
|
||||
!
|
||||
! Process each contour value
|
||||
!
|
||||
DO 500 N=1,NUMV
|
||||
!
|
||||
! Test if contour lies in range
|
||||
!
|
||||
IF(CONTUR(N) .LT. VMIN) GO TO 500
|
||||
IF(CONTUR(N) .GT. VMAX) GO TO 500
|
||||
!
|
||||
! Its active
|
||||
!
|
||||
I=0
|
||||
!
|
||||
! Look for an intercept V(1) AND V(2)
|
||||
!
|
||||
IF(CONTUR(N) .GE. MIN(V(1),V(2)) &
|
||||
.AND. CONTUR(N) .LE. MAX(V(1),V(2))) THEN
|
||||
!
|
||||
! We have an intercept
|
||||
!
|
||||
I=I+1
|
||||
if(v(2) .ne. v(1)) then
|
||||
FACT=(CONTUR(N)-V(1))/(V(2)-V(1))
|
||||
else
|
||||
fact=0.5
|
||||
endif
|
||||
!
|
||||
! Locate point
|
||||
!
|
||||
XX(I)=X(1)+FACT*(X(2)-X(1))
|
||||
YY(I)=Y(1)+FACT*(Y(2)-Y(1))
|
||||
ENDIF
|
||||
!
|
||||
! Look for an intercept V(2) AND V(3)
|
||||
!
|
||||
IF(CONTUR(N) .GE. MIN(V(2),V(3)) &
|
||||
.AND. CONTUR(N) .LE. MAX(V(2),V(3))) THEN
|
||||
!
|
||||
! We have an intercept
|
||||
!
|
||||
I=I+1
|
||||
if(v(3) .ne. v(2)) then
|
||||
FACT=(CONTUR(N)-V(2))/(V(3)-V(2))
|
||||
else
|
||||
fact=0.5
|
||||
endif
|
||||
!
|
||||
! Locate point
|
||||
!
|
||||
XX(I)=X(2)+FACT*(X(3)-X(2))
|
||||
YY(I)=Y(2)+FACT*(Y(3)-Y(2))
|
||||
IF(I .EQ. 2) GO TO 450
|
||||
ENDIF
|
||||
!
|
||||
! Look for an intercept V(3) AND V(1)
|
||||
!
|
||||
IF(CONTUR(N) .GE. MIN(V(3),V(1)) &
|
||||
.AND. CONTUR(N) .LE. MAX(V(3),V(1))) THEN
|
||||
!
|
||||
! We have an intercept
|
||||
!
|
||||
I=I+1
|
||||
if(v(1) .ne. v(3)) then
|
||||
FACT=(CONTUR(N)-V(3))/(V(1)-V(3))
|
||||
else
|
||||
fact=0.5
|
||||
endif
|
||||
!
|
||||
! Locate point
|
||||
!
|
||||
XX(I)=X(3)+FACT*(X(1)-X(3))
|
||||
YY(I)=Y(3)+FACT*(Y(1)-Y(3))
|
||||
ENDIF
|
||||
!
|
||||
! Test for no intercept *ERROR*
|
||||
!
|
||||
IF(I .LT. 2) THEN
|
||||
WRITE(*,*) 'ERROR NO INTERCEPT NOTED, PLOT CURTAILED'
|
||||
WRITE(90,*) ' NON INTERCEPT VALUES ARE'
|
||||
WRITE(90,*) v(1),v(2),v(3),contur(n)
|
||||
RETURN
|
||||
ENDIF
|
||||
!
|
||||
! Now draw line
|
||||
!
|
||||
450 CONTINUE
|
||||
CALL PLOTT(XX(1),YY(1),3)
|
||||
CALL PLOTT(XX(2),YY(2),2)
|
||||
!
|
||||
! Go back for next contour
|
||||
!
|
||||
500 CONTINUE
|
||||
!
|
||||
! We are done
|
||||
!
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE CBLOK(X,Y,V)
|
||||
!
|
||||
! Given a triangle (X,Y) with values V Draw polygons of the
|
||||
! contours in CONTUR that cross the triangle
|
||||
!
|
||||
DIMENSION X(3),Y(3),V(3),AX(10),AY(10)
|
||||
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||||
LOGICAL SWITCH
|
||||
!
|
||||
! Sort out order for values of V
|
||||
!
|
||||
200 IF(V(1) .LE. V(2)) THEN
|
||||
IF(V(3) .LT. V(2)) THEN
|
||||
VT=V(2)
|
||||
V(2)=V(3)
|
||||
V(3)=VT
|
||||
XT=X(2)
|
||||
X(2)=X(3)
|
||||
X(3)=XT
|
||||
YT=Y(2)
|
||||
Y(2)=Y(3)
|
||||
Y(3)=YT
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ELSE
|
||||
VT=V(1)
|
||||
V(1)=V(2)
|
||||
V(2)=VT
|
||||
XT=X(1)
|
||||
X(1)=X(2)
|
||||
X(2)=XT
|
||||
YT=Y(1)
|
||||
Y(1)=Y(2)
|
||||
Y(2)=YT
|
||||
GO TO 200
|
||||
ENDIF
|
||||
!
|
||||
! INITIALIZE
|
||||
!
|
||||
IPAN12=0
|
||||
IPAN23=0
|
||||
!
|
||||
! Loop on contours
|
||||
!
|
||||
cjfact=1.001
|
||||
DO 900 N=1,NUMV
|
||||
nn=float(n)*cjfact
|
||||
if(numv .le. 10) nn=nn+2
|
||||
!
|
||||
! Check for passing lowest contour
|
||||
!
|
||||
IF(CONTUR(N) .GE. V(1)) THEN
|
||||
!
|
||||
! Possible active contour
|
||||
!
|
||||
IF(CONTUR(N) .LE. V(3)) THEN
|
||||
!
|
||||
! Definitely active. Get intercept on 1-3
|
||||
!
|
||||
if(v(3) .ne. v(1)) then
|
||||
FACT=(CONTUR(N)-V(1))/(V(3)-V(1))
|
||||
else
|
||||
fact=0.5
|
||||
endif
|
||||
!
|
||||
! Locate point
|
||||
!
|
||||
XX1=X(1)+FACT*(X(3)-X(1))
|
||||
YY1=Y(1)+FACT*(Y(3)-Y(1))
|
||||
IF(CONTUR(N) .LE. V(2)) THEN
|
||||
!
|
||||
! Second intercept is on 1-2
|
||||
!
|
||||
IPAN12=IPAN12+1
|
||||
if(v(2) .ne. v(1)) then
|
||||
FACT=(CONTUR(N)-V(1))/(V(2)-V(1))
|
||||
else
|
||||
fact=0.5
|
||||
endif
|
||||
!
|
||||
! Locate point
|
||||
!
|
||||
XX2=X(1)+FACT*(X(2)-X(1))
|
||||
YY2=Y(1)+FACT*(Y(2)-Y(1))
|
||||
IF(IPAN12 .EQ. 1) THEN
|
||||
!
|
||||
! This is the first contour across 1-2
|
||||
!
|
||||
AX(1)=X(1)
|
||||
AX(2)=XX1
|
||||
AX(3)=XX2
|
||||
AY(1)=Y(1)
|
||||
AY(2)=YY1
|
||||
AY(3)=YY2
|
||||
XX1F=XX1
|
||||
XX2F=XX2
|
||||
YY1F=YY1
|
||||
YY2F=YY2
|
||||
CALL POLYG(AX,AY,3,NN)
|
||||
ELSE
|
||||
!
|
||||
! This is a second contour line
|
||||
!
|
||||
AX(1)=XX1
|
||||
AX(2)=XX2
|
||||
AX(3)=XX2F
|
||||
AX(4)=XX1F
|
||||
AY(1)=YY1
|
||||
AY(2)=YY2
|
||||
AY(3)=YY2F
|
||||
AY(4)=YY1F
|
||||
XX1F=XX1
|
||||
XX2F=XX2
|
||||
YY1F=YY1
|
||||
YY2F=YY2
|
||||
CALL POLYG(AX,AY,4,NN)
|
||||
ENDIF
|
||||
ELSE
|
||||
!
|
||||
! Second intercept is on 2-3
|
||||
!
|
||||
IPAN23=IPAN23+1
|
||||
if(v(3) .ne. v(2)) then
|
||||
FACT=(CONTUR(N)-V(2))/(V(3)-V(2))
|
||||
else
|
||||
fact=0.5
|
||||
endif
|
||||
!
|
||||
! Locate point
|
||||
!
|
||||
XX2=X(2)+FACT*(X(3)-X(2))
|
||||
YY2=Y(2)+FACT*(Y(3)-Y(2))
|
||||
IF(IPAN23 .EQ. 1) THEN
|
||||
!
|
||||
! This is the first contour on 2-3
|
||||
!
|
||||
IF(IPAN12 .EQ. 0) THEN
|
||||
!
|
||||
! There is no previous contour across this element
|
||||
!
|
||||
AX(1)=X(1)
|
||||
AX(2)=XX1
|
||||
AX(3)=XX2
|
||||
AX(4)=X(2)
|
||||
AY(1)=Y(1)
|
||||
AY(2)=YY1
|
||||
AY(3)=YY2
|
||||
AY(4)=Y(2)
|
||||
XX1F=XX1
|
||||
XX2F=XX2
|
||||
YY1F=YY1
|
||||
YY2F=YY2
|
||||
CALL POLYG(AX,AY,4,NN)
|
||||
ELSE
|
||||
!
|
||||
! There is a previous contour across 1-2
|
||||
!
|
||||
AX(1)=XX1
|
||||
AX(2)=XX2
|
||||
AX(3)=X(2)
|
||||
AX(4)=XX2F
|
||||
AX(5)=XX1F
|
||||
AY(1)=YY1
|
||||
AY(2)=YY2
|
||||
AY(3)=Y(2)
|
||||
AY(4)=YY2F
|
||||
AY(5)=YY1F
|
||||
XX1F=XX1
|
||||
XX2F=XX2
|
||||
YY1F=YY1
|
||||
YY2F=YY2
|
||||
CALL POLYG(AX,AY,5,NN)
|
||||
ENDIF
|
||||
ELSE
|
||||
!
|
||||
! This is a second contour line on 2-3
|
||||
!
|
||||
AX(1)=XX1
|
||||
AX(2)=XX2
|
||||
AX(3)=XX2F
|
||||
AX(4)=XX1F
|
||||
AY(1)=YY1
|
||||
AY(2)=YY2
|
||||
AY(3)=YY2F
|
||||
AY(4)=YY1F
|
||||
XX1F=XX1
|
||||
XX2F=XX2
|
||||
YY1F=YY1
|
||||
YY2F=YY2
|
||||
CALL POLYG(AX,AY,4,NN)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ELSE
|
||||
!
|
||||
! Complete drawing of contour checking to see where previous
|
||||
! contour was
|
||||
!
|
||||
IF(IPAN23 .GT. 0) THEN
|
||||
!
|
||||
! It was on 2-3
|
||||
!
|
||||
AX(1)=X(3)
|
||||
AX(2)=XX2F
|
||||
AX(3)=XX1F
|
||||
AY(1)=Y(3)
|
||||
AY(2)=YY2F
|
||||
AY(3)=YY1F
|
||||
CALL POLYG(AX,AY,3,NN)
|
||||
ELSEIF(IPAN12 .GT. 0) THEN
|
||||
!
|
||||
! It was on 1-2
|
||||
!
|
||||
AX(1)=X(3)
|
||||
AX(2)=X(2)
|
||||
AX(3)=XX2F
|
||||
AX(4)=XX1F
|
||||
AY(1)=Y(3)
|
||||
AY(2)=Y(2)
|
||||
AY(3)=YY2F
|
||||
AY(4)=YY1F
|
||||
CALL POLYG(AX,AY,4,NN)
|
||||
ELSE
|
||||
AX(1)=X(3)
|
||||
AX(2)=X(2)
|
||||
AX(3)=X(1)
|
||||
AY(1)=Y(3)
|
||||
AY(2)=Y(2)
|
||||
AY(3)=Y(1)
|
||||
CALL POLYG(AX,AY,3,NN)
|
||||
ENDIF
|
||||
GO TO 905
|
||||
ENDIF
|
||||
ENDIF
|
||||
900 CONTINUE
|
||||
905 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE EXPND(NCN,N)
|
||||
|
||||
USE BLK1MOD
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
! INCLUDE 'PARAM.COM'
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLKBRK.COM'
|
||||
! INCLUDE 'BFILES.I90'
|
||||
! WRITE(90,*) 'BEFORE',N,X(1),X(2),X(3),Y(1),Y(2),Y(3)
|
||||
COMMON /BRK/ X(10),Y(10),VL(10),DL(10),VLM(10)
|
||||
! expand
|
||||
DSTRTN1=1.0
|
||||
N1=NOP(N,1)
|
||||
N2=NOP(N,2)
|
||||
N3=NOP(N,3)
|
||||
x1= cord(n1,1)
|
||||
x2= cord(n3,1)
|
||||
y1= cord(n1,2)
|
||||
y2= cord(n3,2)
|
||||
eldir=atan2(y2-y1,x2-x1)
|
||||
ALFAN1=eldir-1.5708
|
||||
ALFAN2=ALFAN1
|
||||
ALFAN3=ALFAN1
|
||||
NCN=8
|
||||
width(n2)=(width(n1)+width(n3))/2.
|
||||
TX2=X(2)
|
||||
TY2=Y(2)
|
||||
TX3=X(3)
|
||||
TY3=Y(3)
|
||||
VL2=VL(2)
|
||||
VL3=VL(3)
|
||||
X(6)=X(3)
|
||||
Y(6)=Y(3)
|
||||
VL(6)=VL(3)
|
||||
X(2)=X(1)
|
||||
Y(2)=Y(1)
|
||||
VL(2)=VL(1)
|
||||
VL(3)=VL(1)
|
||||
X(1)=X(2)-WIDTH(N1)*COS(ALFAN1)/(2.*TXSCAL)*DSTRTN1
|
||||
X(3)=X(2)+WIDTH(N1)*COS(ALFAN1)/(2.*TXSCAL)*DSTRTN1
|
||||
Y(1)=Y(2)-WIDTH(N1)*SIN(ALFAN1)/(2.*TXSCAL)*DSTRTN1
|
||||
Y(3)=Y(2)+WIDTH(N1)*SIN(ALFAN1)/(2.*TXSCAL)*DSTRTN1
|
||||
VL(4)=VL2
|
||||
VL(8)=VL2
|
||||
X(4)=TX2+WIDTH(N2)*COS(ALFAN2)/(2.*TXSCAL)*DSTRTN1
|
||||
X(8)=TX2-WIDTH(N2)*COS(ALFAN2)/(2.*TXSCAL)*DSTRTN1
|
||||
Y(4)=TY2+WIDTH(N2)*SIN(ALFAN2)/(2.*TXSCAL)*DSTRTN1
|
||||
Y(8)=TY2-WIDTH(N2)*SIN(ALFAN2)/(2.*TXSCAL)*DSTRTN1
|
||||
VL(5)=VL3
|
||||
VL(7)=VL3
|
||||
X(5)=TX3+WIDTH(N3)*COS(ALFAN3)/(2.*TXSCAL)*DSTRTN1
|
||||
X(7)=TX3-WIDTH(N3)*COS(ALFAN3)/(2.*TXSCAL)*DSTRTN1
|
||||
Y(5)=TY3+WIDTH(N3)*SIN(ALFAN3)/(2.*TXSCAL)*DSTRTN1
|
||||
Y(7)=TY3-WIDTH(N3)*SIN(ALFAN3)/(2.*TXSCAL)*DSTRTN1
|
||||
! check areas
|
||||
|
||||
aj=x(3)-x(1)
|
||||
bj=y(3)-y(1)
|
||||
ak=x(5)-x(1)
|
||||
bk=y(5)-y(1)
|
||||
a1=aj*bk-ak*bj
|
||||
if(a1 .lt. 0.) then
|
||||
tx1=x(1)
|
||||
ty1=y(1)
|
||||
x(1)=x(3)
|
||||
y(1)=y(3)
|
||||
x(3)=tx1
|
||||
y(3)=ty1
|
||||
|
||||
endif
|
||||
aj=x(5)-x(1)
|
||||
bj=y(5)-y(1)
|
||||
ak=x(7)-x(1)
|
||||
bk=y(7)-y(1)
|
||||
a2=aj*bk-ak*bj
|
||||
if(a2 .lt. 0) then
|
||||
tx1=x(5)
|
||||
ty1=y(5)
|
||||
x(5)=x(7)
|
||||
y(5)=y(7)
|
||||
x(7)=tx1
|
||||
y(7)=ty1
|
||||
endif
|
||||
|
||||
aj=x(4)-x(1)
|
||||
bj=y(4)-y(1)
|
||||
ak=x(8)-x(1)
|
||||
bk=y(8)-y(1)
|
||||
a1=aj*bk-ak*bj
|
||||
if(a1 .lt. 0.) then
|
||||
tx1=x(4)
|
||||
ty1=y(4)
|
||||
x(4)=x(8)
|
||||
y(4)=y(8)
|
||||
x(8)=tx1
|
||||
y(8)=ty1
|
||||
endif
|
||||
RETURN
|
||||
END
|
||||
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 1.4 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 1.4 KiB |
@ -0,0 +1,496 @@
|
||||
! Last change: IPK 2 Mar 1999 12:58 pm
|
||||
!IPK NEW ROUTINE OCT 23 1996
|
||||
SUBROUTINE CCLINE(ISW)
|
||||
!
|
||||
! Generate continuity lines
|
||||
!
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
CHARACTER*1 IFLAG
|
||||
DIMENSION XLIN(350),YLIN(350),INODE1(350)
|
||||
! DIMENSION ICN(MAXP)
|
||||
LOGICAL :: OPENED
|
||||
DO J=1,MAXP
|
||||
ICN(J)=0
|
||||
ENDDO
|
||||
|
||||
IF(ISW .EQ. 1) THEN
|
||||
call opencln(ipos)
|
||||
if(ipos .eq. 0) return
|
||||
ELSE
|
||||
ipos=2
|
||||
ENDIF
|
||||
!
|
||||
! First sort out the potential midsides
|
||||
! Note that transition elements caues a problem
|
||||
! Find these first
|
||||
DO N=1,NE
|
||||
IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN
|
||||
!
|
||||
! We have a transition mark node number as if it were corner
|
||||
!
|
||||
ICN(NOP(N,3))=1
|
||||
ICN(NOP(N,1))=2
|
||||
ICN(NOP(N,4))=2
|
||||
ICN(NOP(N,5))=2
|
||||
ELSE
|
||||
!
|
||||
! Store ICN = 2 for corner nodes
|
||||
!
|
||||
NCN=NCORN(N)
|
||||
!IPKOCT93 IF(IMAT(N) .GT. 900) THEN
|
||||
IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN
|
||||
MST=1
|
||||
ELSE
|
||||
MST=2
|
||||
ENDIF
|
||||
DO M=1,NCN,MST
|
||||
ICN(NOP(N,M))=2
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
!
|
||||
! Get connections
|
||||
!
|
||||
CALL NTONCON(ipos)
|
||||
100 CONTINUE
|
||||
NHTP=0
|
||||
NMESS=26
|
||||
NBRR=8
|
||||
NTRACT=0
|
||||
|
||||
CALL HEDR
|
||||
NCLL=0
|
||||
!
|
||||
! Get first point
|
||||
!
|
||||
110 CONTINUE
|
||||
K=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE1(1),IFLAG,INSKP,IBOX)
|
||||
if(inode1(1) .eq. 0) go to 110
|
||||
IF(IRMAIN .EQ. 1) THEN
|
||||
NTRACT=0
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
NTRACT=0
|
||||
GO TO 500
|
||||
ENDIF
|
||||
!IPK JAN01
|
||||
IF(IBOX .EQ. 7 .OR. IFLAG .EQ. 'n' .or. &
|
||||
IBOX .EQ. 5 .OR. IFLAG .EQ. 'd') THEN
|
||||
ipos=ncll+1
|
||||
CALL GETCLN(ipos)
|
||||
!IPK JAN02
|
||||
IF(ISW .EQ. 1) THEN
|
||||
IF(IPOS .EQ. 0) THEN
|
||||
DO NCLL=1,140
|
||||
DO KK=1,350
|
||||
ICCLN(NCLL,KK)=0
|
||||
ENDDO
|
||||
ENDDO
|
||||
NCLM=0
|
||||
ELSE
|
||||
ncll=ipos
|
||||
DO KK=1,350
|
||||
ICCLN(NCLL,KK)=0
|
||||
ENDDO
|
||||
IF(NCLM .EQ. NCLL) NCLM=NCLM-1
|
||||
ENDIF
|
||||
GO TO 100
|
||||
ENDIF
|
||||
ENDIF
|
||||
IF(ICN(INODE1(1)) .NE. 2) THEN
|
||||
NMESS=28
|
||||
CALL HEDR
|
||||
GO TO 110
|
||||
ENDIF
|
||||
|
||||
NBRR=5
|
||||
NMESS=27
|
||||
CALL HEDR
|
||||
fpn=inode1(1)
|
||||
CALL NUMBR(0.5,7.2,0.2,FPN,0.0,-1)
|
||||
call pltnod(inode1(1),0)
|
||||
!
|
||||
! Get second point
|
||||
!
|
||||
150 CONTINUE
|
||||
K=K+1
|
||||
160 CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE1(K),IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) THEN
|
||||
NTRACT=0
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
NTRACT=0
|
||||
GO TO 500
|
||||
ENDIF
|
||||
NMESS=26
|
||||
CALL HEDR
|
||||
IF(IBOX .EQ. 6 .OR. IFLAG .EQ. 'b' ) THEN
|
||||
K=K-2
|
||||
GO TO 150
|
||||
ELSEIF(IBOX .EQ. 7 .OR. IFLAG .EQ. 'n') THEN
|
||||
KL=K-2
|
||||
|
||||
IF(ISW .EQ. 1) THEN
|
||||
|
||||
!IPK Get continuity line number
|
||||
ipos=ncll+1
|
||||
CALL GETCLN(ipos)
|
||||
ncll=ipos
|
||||
IF(NCLL .EQ. 0) GO TO 500
|
||||
ENDIF
|
||||
!
|
||||
! Trace along line
|
||||
!
|
||||
NTRACT=1
|
||||
IF(KL .GT. 0) THEN
|
||||
DO LS=1,KL
|
||||
CALL TRACE(INODE1(LS),INODE1(LS+1))
|
||||
ENDDO
|
||||
ELSE
|
||||
NTRACT=1
|
||||
ITRAC(1)=INODE1(1)
|
||||
ENDIF
|
||||
!
|
||||
! Output line to file
|
||||
!
|
||||
! WRITE(90,6000) (ITRAC(KK),KK=1,NTRAC)
|
||||
!ipk jan01
|
||||
INQUIRE(98, OPENED=OPENED)
|
||||
if(opened) then
|
||||
IF(IPOS .EQ. 1) THEN
|
||||
DO KK=1,NTRACT
|
||||
WRITE(98,6001) ITRAC(KK),XUSR(ITRAC(KK)),YUSR(ITRAC(KK))
|
||||
6001 FORMAT('NODE',I7,2F15.3)
|
||||
ENDDO
|
||||
ELSE
|
||||
WRITE(98,6000) NCLL,(ITRAC(KK),KK=1,NTRACT)
|
||||
ENDIF
|
||||
endif
|
||||
!IPK JAN01
|
||||
6000 FORMAT('CC1',I5,9I8/('CC2',5X,9I8))
|
||||
DO KK=1,NTRACT
|
||||
XLIN(KK)=CORD(ITRAC(KK),1)
|
||||
YLIN(KK)=CORD(ITRAC(KK),2)
|
||||
ENDDO
|
||||
|
||||
!ipk jan01
|
||||
! Save to an array by line number
|
||||
!
|
||||
IF(ISW .EQ. 1) THEN
|
||||
DO KK=1,NTRACT
|
||||
ICCLN(NCLL,KK)=ITRAC(KK)
|
||||
ENDDO
|
||||
IF(NCLL .GT. NCLM) NCLM=NCLL
|
||||
ENDIF
|
||||
|
||||
CALL RRED
|
||||
!ipk jan01
|
||||
CALL THICKL
|
||||
CALL DASHLN(XLIN,YLIN,NTRACT,0)
|
||||
!ipk jan01
|
||||
|
||||
CALL THINL
|
||||
!
|
||||
! Go to get another line
|
||||
!
|
||||
IF(ISW .EQ. 2) RETURN
|
||||
GO TO 100
|
||||
ELSE
|
||||
IF(ICN(INODE1(K)) .NE. 2) THEN
|
||||
NMESS=27
|
||||
CALL HEDR
|
||||
GO TO 160
|
||||
ENDIF
|
||||
KL=K-1
|
||||
!
|
||||
! Trace along line
|
||||
!
|
||||
call pltnod(inode1(1),0)
|
||||
NTRACT=1
|
||||
DO LS=1,KL
|
||||
CALL TRACE(INODE1(LS),INODE1(LS+1))
|
||||
call pltnod(inode1(ls+1),0)
|
||||
ENDDO
|
||||
if(ntracT .gt. 0) then
|
||||
DO KK=1,NTRACT
|
||||
if(itrac(kk) .eq. 0) go to 300
|
||||
XLIN(KK)=CORD(ITRAC(KK),1)
|
||||
YLIN(KK)=CORD(ITRAC(KK),2)
|
||||
ENDDO
|
||||
CALL RRED
|
||||
!ipk jan01
|
||||
CALL THICKL
|
||||
CALL DASHLN(XLIN,YLIN,NTRACT,0)
|
||||
!ipk jan01
|
||||
CALL THINL
|
||||
endif
|
||||
300 CONTINUE
|
||||
fpn=inode1(KL+1)
|
||||
CALL NUMBR(0.5+KL*0.5,7.2,0.2,FPN,0.0,-1)
|
||||
!
|
||||
! Get another point
|
||||
!
|
||||
GO TO 150
|
||||
ENDIF
|
||||
!
|
||||
! Exit
|
||||
!
|
||||
500 CONTINUE
|
||||
END
|
||||
SUBROUTINE NTONCON(ipos)
|
||||
!
|
||||
! Generate Connections
|
||||
!
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
!
|
||||
! Initialize to zero
|
||||
!
|
||||
NCM=MAXECON
|
||||
DO N=1,NP
|
||||
DO L=1,NCM
|
||||
NECON(N,L)=0
|
||||
ENDDO
|
||||
ENDDO
|
||||
!
|
||||
! Loop on elements
|
||||
!
|
||||
DO N=1,NE
|
||||
!
|
||||
! Check to see that this element is active
|
||||
!
|
||||
IF(IMAT(N) .NE. 0) THEN
|
||||
NCN=NCORN(N)
|
||||
!
|
||||
! Search to see if connection M and K made
|
||||
!
|
||||
|
||||
! DO M=1,NCN,2
|
||||
DO M=1,NCN,ipos
|
||||
|
||||
|
||||
! IF(M .GT. NCN-1) GO TO 200
|
||||
! K=M+2
|
||||
K=M+ipos
|
||||
IF(K .GT. NCN) K=1
|
||||
DO L=1,NCM
|
||||
IF(NECON(NOP(N,M),L) .EQ. 0) THEN
|
||||
!
|
||||
! This is new connection
|
||||
!
|
||||
NECON(NOP(N,M),L)=NOP(N,K)
|
||||
GO TO 150
|
||||
ELSEIF(NECON(NOP(N,M),L) .EQ. NOP(N,K)) THEN
|
||||
!
|
||||
! This is an old connection
|
||||
!
|
||||
GO TO 150
|
||||
ENDIF
|
||||
ENDDO
|
||||
150 CONTINUE
|
||||
!
|
||||
! Now look in the revers direction
|
||||
!
|
||||
DO L=1,NCM
|
||||
IF(NECON(NOP(N,K),L) .EQ. 0) THEN
|
||||
NECON(NOP(N,K),L)=NOP(N,M)
|
||||
!
|
||||
! This is new connection
|
||||
!
|
||||
GO TO 175
|
||||
ELSEIF(NECON(NOP(N,K),L) .EQ. NOP(N,M)) THEN
|
||||
!
|
||||
! This is an old connection
|
||||
!
|
||||
GO TO 175
|
||||
ENDIF
|
||||
ENDDO
|
||||
175 CONTINUE
|
||||
ENDDO
|
||||
ENDIF
|
||||
200 CONTINUE
|
||||
ENDDO
|
||||
|
||||
!
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE TRACE(INODE1,INODE2)
|
||||
!
|
||||
! Generate continuity lines
|
||||
!
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
DIST(N,M)=(cord(n,1)-cord(m,1))**2+(cord(n,2)-cord(m,2))**2
|
||||
!
|
||||
! Start at INODE1
|
||||
!
|
||||
ITRAC(NTRACT)=INODE1
|
||||
LAT=INODE1
|
||||
100 CONTINUE
|
||||
!
|
||||
! Look for new nearer node to INODE2
|
||||
!
|
||||
CURR=1.E30
|
||||
LAT1=0
|
||||
DO K=1,NCM
|
||||
LATTMP=NECON(LAT,K)
|
||||
IF(LATTMP .NE. 0) THEN
|
||||
IF(DIST(INODE2,LATTMP) .LT. CURR) THEN
|
||||
LAT1=LATTMP
|
||||
CURR=DIST(INODE2,LATTMP)
|
||||
ENDIF
|
||||
ELSE
|
||||
GO TO 150
|
||||
ENDIF
|
||||
ENDDO
|
||||
150 CONTINUE
|
||||
IF(LAT1 .EQ. 0) RETURN
|
||||
NTRACT=NTRACT+1
|
||||
ITRAC(NTRACT)=LAT1
|
||||
IF(LAT1 .EQ. INODE2) RETURN
|
||||
IF(NTRACT .GT. 350) RETURN
|
||||
LAT=LAT1
|
||||
GO TO 100
|
||||
END
|
||||
|
||||
subroutine opencln(ipos)
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'd.inc'
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=3) :: SUB
|
||||
LOGICAL :: OPENED
|
||||
INTEGER :: IPOS,IERR
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
INQUIRE(98, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
CALL WSelectFile(ID_STRING8,SaveDialog+PromptOn,FNAME,'Save continuity line')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='cln'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
open(98,file=fname, form='formatted', status='unknown')
|
||||
ENDIF
|
||||
endif
|
||||
|
||||
call wdialogload(IDD_DIALOG08)
|
||||
ierr=infoerror(1)
|
||||
|
||||
|
||||
call wdialogputRadioButton(idf_radio1)
|
||||
|
||||
|
||||
CALL WDialogSelect(IDD_DIALOG08)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
call wdialoggetradiobutton(idf_radio1,ipos)
|
||||
ipos=3-ipos
|
||||
return
|
||||
endif
|
||||
ipos= 0
|
||||
RETURN
|
||||
enddo
|
||||
ipos= 2
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
!ipk jan01
|
||||
subroutine getcln(ipos)
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'd.inc'
|
||||
|
||||
INTEGER :: IPOS,IERR
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
|
||||
call wdialogload(IDD_DIALOG010)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_DIALOG010)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER1,IPOS)
|
||||
|
||||
write(90,*) 'iposin',ipos
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER1,IPOS)
|
||||
write(90,*) 'iposout',ipos
|
||||
|
||||
return
|
||||
endif
|
||||
return
|
||||
enddo
|
||||
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE CHKLIN
|
||||
!
|
||||
! Generate continuity lines
|
||||
!
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
|
||||
IPOS=2
|
||||
CALL NTONCON(ipos)
|
||||
|
||||
DO I=1,NCLM
|
||||
NTRACT=1
|
||||
ITRAC(1)=ICCLN(I,1)
|
||||
DO J=1,350
|
||||
INODE1=ICCLN(I,J)
|
||||
INODE2=ICCLN(I,J+1)
|
||||
IF(INODE2 .EQ. 0) GO TO 300
|
||||
CALL TRACE(INODE1,INODE2)
|
||||
ENDDO
|
||||
300 DO J=1,NTRACT
|
||||
ICCLN(I,J)=ITRAC(J)
|
||||
ENDDO
|
||||
ENDDO
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,588 @@
|
||||
SUBROUTINE CHVIEW(JHAND1,ITYPIMAGE)
|
||||
|
||||
!
|
||||
USE WINTERACTER
|
||||
|
||||
USE BLK3D
|
||||
SAVE
|
||||
|
||||
INCLUDE 'd.inc'
|
||||
! IMPLICIT NONE
|
||||
!
|
||||
REAL , PARAMETER :: PI = 3.1415926
|
||||
! REAL , PARAMETER :: AngleStep = PI/30.
|
||||
REAL, PARAMETER :: DEFDIST = 5.0
|
||||
!
|
||||
REAL :: ViewAngle = 0.0
|
||||
REAL :: SHIFT=0.0
|
||||
REAL :: SHIFTV=0.0
|
||||
REAL :: ROTH=0.0
|
||||
REAL :: ROTV=0.0
|
||||
REAL :: ROT=0.0
|
||||
REAL :: VSCALE=1.0
|
||||
INTEGER :: ITYPE,K,JRGB
|
||||
INTEGER :: JHAND1,ITYPIMAGE,ITIME
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
LOGICAL :: CHANGED,ONEC
|
||||
CHARACTER(LEN=65) :: STBAR1
|
||||
CHARACTER(LEN=260) :: FILENAME = 'objects.w3d'
|
||||
! Main Message loop, keep asking for and processing
|
||||
! messages until the user selects the Exit option.
|
||||
!
|
||||
ONEC=.TRUE.
|
||||
DO
|
||||
CALL WMessage(ITYPE,MESSAGE)
|
||||
SELECT CASE (ITYPE)
|
||||
CASE (KeyDown)
|
||||
IF (MESSAGE%VALUE1==KeyEscape) EXIT
|
||||
!
|
||||
! Window exposed - re-paint window from bitmap
|
||||
!
|
||||
CASE (Expose)
|
||||
CALL WBitmapDestroy(JHAND1)
|
||||
CALL WBitmapCreate(JHAND1,WInfoWindow(WindowWidth), &
|
||||
WInfoWindow(WindowHeight))
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (Resize) ! Window resized
|
||||
CALL WBitmapDestroy(JHAND1)
|
||||
CALL WBitmapCreate(JHAND1,WInfoWindow(WindowWidth), &
|
||||
WInfoWindow(WindowHeight))
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
!
|
||||
! Close window request - exit program
|
||||
!
|
||||
CASE (MenuSelect) ! Menu item selected
|
||||
SELECT CASE (MESSAGE%VALUE1)
|
||||
CASE (ID_SAV3D)
|
||||
!
|
||||
! Save data
|
||||
!
|
||||
CALL WSelectFile(FILTERSTR='Winteracter 3D model files|*.w3d|', &
|
||||
IFLAGS =SaveDialog+PromptOn+AppendExt, &
|
||||
FILEDIR =FILENAME, &
|
||||
TITLE ='Save 3D model file')
|
||||
IF (WInfoDialog(ExitButtonCommon)==CommonOK) THEN
|
||||
CALL W3dSave(FILENAME)
|
||||
ENDIF
|
||||
!
|
||||
CASE (ID_CLOSE)
|
||||
RETURN
|
||||
CASE (ID_OPENNEW)
|
||||
ITYPIMAGE=-1
|
||||
RETURN
|
||||
CASE (ID_SAVEVIEW)
|
||||
ROTSV=ROT
|
||||
ROTHSV=ROTH
|
||||
ROTVSV=ROTV
|
||||
DISTSV=DIST
|
||||
VSCALESV=VSCALE
|
||||
IROTSV=1
|
||||
CASE (ID_WIRE)
|
||||
ITYPIMAGE=0
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_HIDDEN)
|
||||
ITYPIMAGE=1
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_UNLIT)
|
||||
ITYPIMAGE=2
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_FLAT)
|
||||
ITYPIMAGE=3
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_GOURAUD)
|
||||
ITYPIMAGE=4
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_MULTCOL)
|
||||
IF(ONEC) THEN
|
||||
CALL W3dMaterial(9,WRGB(254,254,255))
|
||||
CALL W3dMaterial(8,WRGB(230,254,255))
|
||||
CALL W3dMaterial(7,WRGB(180,254,255))
|
||||
CALL W3dMaterial(6,WRGB(130,254,255))
|
||||
CALL W3dMaterial(5,WRGB(080,254,255))
|
||||
CALL W3dMaterial(4,WRGB(030,254,255))
|
||||
CALL W3dMaterial(3,WRGB(001,220,220))
|
||||
CALL W3dMaterial(2,WRGB(001,180,180))
|
||||
CALL W3dMaterial(1,WRGB(001,120,120))
|
||||
CALL V3Materials(JHAND1,ITYPIMAGE,VIEWANGLE)
|
||||
CALL WindowSelect(JHAND1)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
ENDIF
|
||||
ONEC=.FALSE.
|
||||
CASE (ID_ONECOL)
|
||||
DO K=1,9
|
||||
CALL W3dMaterial(K,WRGB(255,255,100))
|
||||
ENDDO
|
||||
CALL WSelectColour(JRGB,'Colour ')
|
||||
IF (WInfoDialog(ExitButtonCommon)==CommonOK) THEN
|
||||
DO K=1,9
|
||||
CALL W3dMaterial(K,JRGB)
|
||||
ENDDO
|
||||
CHANGED = .TRUE.
|
||||
ENDIF
|
||||
IF(CHANGED) CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
ONEC=.TRUE.
|
||||
CASE (ID_ZOOMIN)
|
||||
DIST=DIST-DISTSTEP
|
||||
WRITE(STBAR1,'(F13.3)') DIST
|
||||
CALL WindowOutStatusBar(4,STBAR1)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
!
|
||||
CASE (ID_ZOOMOUT)
|
||||
DIST=DIST+DISTSTEP
|
||||
WRITE(STBAR1,'(F13.3)') DIST
|
||||
CALL WindowOutStatusBar(4,STBAR1)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_FZOOM)
|
||||
DIST=DIST-DISTSTEP*5.
|
||||
WRITE(STBAR1,'(F13.3)') DIST
|
||||
CALL WindowOutStatusBar(4,STBAR1)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
!
|
||||
CASE (ID_PLEFT)
|
||||
SHIFT=SHIFT+0.5
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_PRIGHT)
|
||||
SHIFT=SHIFT-0.5
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_UPAR)
|
||||
SHIFTV=SHIFTV+0.5
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_DWNAR)
|
||||
SHIFTV=SHIFTV-0.5
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_ROTATAC)
|
||||
ROT=ROT-5.
|
||||
CALL W3dRotate(0.,1)
|
||||
CALL W3dRotate(0.,2)
|
||||
CALL W3dRotate(-5.,3)
|
||||
!ROT=ROT+0.087266
|
||||
!EYE(1,4) = (XMIN + XLEN/2.0+SHIFT)*COS(ROT)+(YMIN + YLEN/2.0)*SIN(ROT)
|
||||
!EYE(3,4) = ZMIN + ZLEN/2.0
|
||||
!EYE(2,4) =-(XMIN + XLEN/2.0+SHIFT)*SIN(ROT)+(YMIN + YLEN/2.0)*COS(ROT)
|
||||
!CALL ViewPos(ViewAngle)
|
||||
!CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
|
||||
CALL W3dGetMatrix(EYE)
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (ID_ROTATC)
|
||||
ROT=ROT+5.
|
||||
CALL W3dRotate(0.,1)
|
||||
CALL W3dRotate(0.,2)
|
||||
CALL W3dRotate(5.,3)
|
||||
!ROT=ROT+0.087266
|
||||
!EYE(1,4) = (XMIN + XLEN/2.0+SHIFT)*COS(ROT)+(YMIN + YLEN/2.0)*SIN(ROT)
|
||||
!EYE(3,4) = ZMIN + ZLEN/2.0
|
||||
!EYE(2,4) =-(XMIN + XLEN/2.0+SHIFT)*SIN(ROT)+(YMIN + YLEN/2.0)*COS(ROT)
|
||||
!CALL ViewPos(ViewAngle)
|
||||
!CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
|
||||
CALL W3dGetMatrix(EYE)
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
!! CASE (ID_VSCALEV)
|
||||
! CALL GETVSCAL(VSCALESV)
|
||||
!! CALL W3dScale(1.0,VSCALESV,1.0)
|
||||
! CALL W3dGetMatrix(EYE)
|
||||
! EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
! EYE(2,4) = YMIN + YLEN/2.0
|
||||
! EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
! CALL ViewPos(ViewAngle)
|
||||
! CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
|
||||
CASE (ID_RSET)
|
||||
DIST = DEFDIST*MAX(XLEN,YLEN,ZLEN)
|
||||
WRITE(STBAR1,'(F13.3)') DIST
|
||||
CALL WindowOutStatusBar(4,STBAR1)
|
||||
SHIFT=0.
|
||||
SHIFTV=0.
|
||||
VIEWANGLE=0.
|
||||
CALL W3dRotate(-ROTV,1)
|
||||
CALL W3dRotate(-ROTH,2)
|
||||
CALL W3dRotate(-ROT,3)
|
||||
CALL W3dGetMatrix(EYE)
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
ROTH=0.
|
||||
ROTV=0.
|
||||
ROT=0.
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
CASE(ID_TOP)
|
||||
CALL W3dRotate(-ROTV-45.,1)
|
||||
CALL W3dGetMatrix(EYE)
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
ROTV=-45.
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
CASE(ID_SIDE)
|
||||
CALL W3dRotate(-ROTV+45.,1)
|
||||
CALL W3dGetMatrix(EYE)
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
ROTV= 45.
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
END SELECT
|
||||
CASE (CloseRequest)
|
||||
RETURN
|
||||
!
|
||||
! Mouse button pressed. Action depends on button:
|
||||
!
|
||||
CASE (MouseButDown)
|
||||
SELECT CASE (MESSAGE%VALUE1)
|
||||
! Left button. Start rotation.
|
||||
!
|
||||
CASE (LeftButton)
|
||||
ROTH=ROTH+5.
|
||||
CALL W3dRotate(0.,1)
|
||||
CALL W3dRotate(5.,2)
|
||||
CALL W3dRotate(0.,3)
|
||||
CALL W3dGetMatrix(EYE)
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
! right button. Start rotation.
|
||||
!
|
||||
CASE (RightButton)
|
||||
ROTH=ROTH-5.
|
||||
CALL W3dRotate(0.,1)
|
||||
CALL W3dRotate(-5.,2)
|
||||
CALL W3dRotate(0.,3)
|
||||
CALL W3dGetMatrix(EYE)
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
CASE (UpWheel)
|
||||
ROTV=ROTV+5.
|
||||
CALL W3dRotate(5.,1)
|
||||
CALL W3dRotate(0.,2)
|
||||
CALL W3dRotate(0.,3)
|
||||
CALL W3dGetMatrix(EYE)
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
|
||||
CASE (DownWheel)
|
||||
ROTV=ROTV-5.
|
||||
CALL W3dRotate(-5.,1)
|
||||
CALL W3dRotate(0.,2)
|
||||
CALL W3dRotate(0.,3)
|
||||
CALL W3dGetMatrix(EYE)
|
||||
WRITE(STBAR1,'(5F13.3)') ROTH,ROTV,ROT,SHIFT,SHIFTV
|
||||
CALL WindowOutStatusBar(2,STBAR1)
|
||||
EYE(1,4) = XMIN + XLEN/2.0+SHIFT
|
||||
EYE(2,4) = YMIN + YLEN/2.0
|
||||
EYE(3,4) = ZMIN + ZLEN/2.0+SHIFTV
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
ENDSELECT
|
||||
END SELECT
|
||||
END DO
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE V3Materials(JHAND1,ITYPIMAGE,VIEWANGLE)
|
||||
!
|
||||
! Edit materials
|
||||
!
|
||||
USE WINTERACTER
|
||||
USE BLKMAT
|
||||
INCLUDE 'd.inc'
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
CHARACTER(LEN=10) :: CMATNUM
|
||||
!
|
||||
! INTEGER, INTENT(IN) :: JHAND1,ITYPIMAGE ! Memory bitmap handle
|
||||
! REAL, INTENT(IN) :: VIEWANGLE
|
||||
INTEGER JHAND1,ITYPIMAGE ! Memory bitmap handle
|
||||
REAL VIEWANGLE
|
||||
INTEGER NMAT,MAXMAT,JMAT,IMAT,JRGB,I1,I2,IG,IR,IB,J2,JC1,JR1,ISHINE,IGLOSS,IC2,IR2,IR1,IC1
|
||||
LOGICAL CHANGED
|
||||
!
|
||||
CALL WMessageEnable(FieldChanged,Enabled)
|
||||
|
||||
CALL WDialogLoad(IDD_MATERIALS)
|
||||
!
|
||||
! Operate on a copy of the material list,
|
||||
! so model remains intact if user cancels
|
||||
!
|
||||
NMAT = WInfo3dInteger(M3dMaterials)
|
||||
ALLOCATE(IMATN(NMAT))
|
||||
ALLOCATE(IRGB(NMAT))
|
||||
ALLOCATE(SHINE(NMAT))
|
||||
ALLOCATE(GLOSS(NMAT))
|
||||
MAXMAT = WInfo3dInteger(M3dMaxMaterials)
|
||||
CALL WGridRows(IDF_GRID1,NMAT)
|
||||
!
|
||||
! Retrieve material list and set background colours of "Material" column to match
|
||||
!
|
||||
JMAT = 0
|
||||
DO IMAT = 1,MAXMAT
|
||||
CALL W3dMaterialN(IMAT)
|
||||
JRGB = WInfo3dInteger(M3dRGB)
|
||||
IF (JRGB/=-1) THEN
|
||||
JMAT = JMAT + 1
|
||||
IMATN(JMAT) = IMAT
|
||||
IRGB(JMAT) = JRGB
|
||||
SHINE(JMAT) = WInfo3dReal(M3dShine)
|
||||
GLOSS(JMAT) = WInfo3dReal(M3dGloss)
|
||||
CALL WGridColourCell(IDF_GRID1,1,JMAT,RGBBACK=JRGB)
|
||||
END IF
|
||||
END DO
|
||||
!
|
||||
! IMAT = Current material
|
||||
!
|
||||
IMAT = 1
|
||||
!
|
||||
! Update "Current Material" group box
|
||||
!
|
||||
CALL V3ShowMaterial(IMAT)
|
||||
!
|
||||
CALL V3DialogShow()
|
||||
!
|
||||
! Move focus to "Modify" checkbox column
|
||||
! (Note: Must do this AFTER displaying dialog.
|
||||
! Linux version crashes if set before dialog is visible.)
|
||||
!
|
||||
CALL WGridSetCell(IDF_GRID1,2,IMAT)
|
||||
!
|
||||
DO
|
||||
CALL WMessage(ITYPE,MESSAGE)
|
||||
SELECT CASE (ITYPE)
|
||||
!
|
||||
! Button press
|
||||
!
|
||||
CASE (PushButton)
|
||||
SELECT CASE (MESSAGE%VALUE1)
|
||||
CASE (IDOK)
|
||||
CALL WDialogHide()
|
||||
DO JMAT = 1,NMAT
|
||||
CALL W3dMaterial(IMATN(JMAT),IRGB(JMAT),SHINE(JMAT),GLOSS(JMAT))
|
||||
END DO
|
||||
! CALL V3Display(.TRUE.)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
EXIT
|
||||
CASE (IDCANCEL)
|
||||
EXIT
|
||||
CASE (IDF_APPLY)
|
||||
DO JMAT = 1,NMAT
|
||||
CALL W3dMaterial(IMATN(JMAT),IRGB(JMAT),SHINE(JMAT),GLOSS(JMAT))
|
||||
END DO
|
||||
! CALL V3Display(.TRUE.)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
|
||||
CHANGED = .TRUE.
|
||||
CALL WDialogFieldState(IDF_APPLY,Disabled)
|
||||
CASE (IDF_COLOUR)
|
||||
JRGB = IRGB(IMAT)
|
||||
WRITE(CMATNUM,'(I10)') IMAT
|
||||
CALL ILocateString(CMATNUM,I1,I2)
|
||||
CALL WSelectColour(JRGB,'Material '//CMATNUM(I1:I2))
|
||||
IF (WInfoDialog(ExitButtonCommon)==CommonOK) THEN
|
||||
IRGB(IMAT) = JRGB
|
||||
CALL V3ShowMaterial(IMAT)
|
||||
CHANGED = .TRUE.
|
||||
CALL WDialogFieldState(IDF_APPLY,Enabled)
|
||||
END IF
|
||||
! CASE (IDHELP)
|
||||
! CALL V3Help(5)
|
||||
END SELECT
|
||||
!
|
||||
! Change material ?
|
||||
!
|
||||
CASE (FieldChanged)
|
||||
IF (MESSAGE%VALUE2==IDF_GRID1) THEN
|
||||
CALL WGridPos(MESSAGE%Y,IC2,IR2)
|
||||
IF (IC2==1) THEN
|
||||
CALL WGridSetCell(IDF_GRID1,2,IR2)
|
||||
IF (IMAT==IR2) THEN
|
||||
CALL WGridPutCellCheckbox(IDF_GRID1,2,IMAT,Enabled)
|
||||
ELSE
|
||||
CALL WGridPutCellCheckbox(IDF_GRID1,2,IMAT,Disabled)
|
||||
IMAT = IR2
|
||||
CALL WGridPutCellCheckbox(IDF_GRID1,2,IMAT,Enabled)
|
||||
CALL V3ShowMaterial(IMAT)
|
||||
END IF
|
||||
ELSE IF (MESSAGE%VALUE1==IDF_GRID1) THEN
|
||||
CALL WGridPos(MESSAGE%X,IC1,IR1)
|
||||
IF (IC1==2.AND.IC2==2.AND.IR1==IR2) THEN
|
||||
IF (IMAT==IR2) THEN
|
||||
CALL WGridPutCellCheckbox(IDF_GRID1,2,IMAT,Enabled)
|
||||
ELSE
|
||||
CALL WGridPutCellCheckbox(IDF_GRID1,2,IMAT,Disabled)
|
||||
IMAT = IR2
|
||||
CALL V3ShowMaterial(IMAT)
|
||||
END IF
|
||||
END IF
|
||||
END IF
|
||||
ELSE IF (MESSAGE%VALUE1==IDF_SHINE.AND. &
|
||||
MESSAGE%VALUE2==IDF_SHINE) THEN
|
||||
CALL WDialogGetTrackbar(IDF_SHINE,ISHINE)
|
||||
SHINE(IMAT) = ISHINE/100.
|
||||
CALL WDialogPutReal(IDF_SHINE2,SHINE(IMAT),'(F4.2)')
|
||||
CHANGED = .TRUE.
|
||||
CALL WDialogFieldState(IDF_APPLY,Enabled)
|
||||
ELSE IF (MESSAGE%VALUE1==IDF_GLOSS.AND. &
|
||||
MESSAGE%VALUE2==IDF_GLOSS) THEN
|
||||
CALL WDialogGetTrackbar(IDF_GLOSS,IGLOSS)
|
||||
GLOSS(IMAT) = IGLOSS/100.
|
||||
CALL WDialogPutReal(IDF_GLOSS2,GLOSS(IMAT),'(F4.2)')
|
||||
CHANGED = .TRUE.
|
||||
CALL WDialogFieldState(IDF_APPLY,Enabled)
|
||||
END IF
|
||||
!
|
||||
! Maintain display
|
||||
!
|
||||
CASE (Expose)
|
||||
CALL ViewPos(ViewAngle)
|
||||
CALL ShowModel(JHAND1,ITYPIMAGE)
|
||||
! CALL V3Display(.TRUE.)
|
||||
END SELECT
|
||||
END DO
|
||||
!
|
||||
CALL WDialogUnload()
|
||||
DEALLOCATE(IMATN)
|
||||
DEALLOCATE(IRGB)
|
||||
DEALLOCATE(SHINE)
|
||||
DEALLOCATE(GLOSS)
|
||||
RETURN
|
||||
END SUBROUTINE V3Materials
|
||||
|
||||
!
|
||||
!******************************************************************************
|
||||
!
|
||||
SUBROUTINE V3ShowMaterial(IMAT)
|
||||
|
||||
USE WINTERACTER
|
||||
! USE RESID
|
||||
USE BLKMAT
|
||||
INCLUDE 'd.inc'
|
||||
!
|
||||
INTEGER, INTENT(IN) :: IMAT
|
||||
INTEGER ISHINE,IGLOSS,IR,IG,IB
|
||||
!
|
||||
CALL WGridPutCellCheckbox(IDF_GRID1,2,IMAT,Enabled)
|
||||
CALL WGridColourCell(IDF_GRID1,1,IMAT,RGBBACK=IRGB(IMAT))
|
||||
CALL WRGBsplit(IRGB(IMAT),IR,IG,IB)
|
||||
CALL WDialogPutInteger(IDF_RED ,IR)
|
||||
CALL WDialogPutInteger(IDF_GREEN,IG)
|
||||
CALL WDialogPutInteger(IDF_BLUE ,IB)
|
||||
CALL WDialogPutReal(IDF_SHINE2,SHINE(IMAT),'(F4.2)')
|
||||
CALL WDialogPutReal(IDF_GLOSS2,GLOSS(IMAT),'(F4.2)')
|
||||
ISHINE = INT(SHINE(IMAT)*100.)
|
||||
CALL WDialogPutTrackbar(IDF_SHINE,ISHINE)
|
||||
IGLOSS = INT(GLOSS(IMAT)*100.)
|
||||
CALL WDialogPutTrackbar(IDF_GLOSS,IGLOSS)
|
||||
RETURN
|
||||
END SUBROUTINE V3ShowMaterial
|
||||
|
||||
!
|
||||
!******************************************************************************
|
||||
!
|
||||
SUBROUTINE V3DialogShow()
|
||||
!
|
||||
! Display current dialog at top left corner of model view window
|
||||
!
|
||||
USE WINTERACTER
|
||||
INCLUDE 'd.inc'
|
||||
INTEGER IXWIN,IYWIN
|
||||
! CALL WindowSelect(IHVIEWWIN)
|
||||
IXWIN = WInfoWindow(ClientXPos)
|
||||
IYWIN = WInfoWindow(ClientYPos)
|
||||
! CALL WindowSelect(0)
|
||||
CALL WDialogShow(IXWIN,IYWIN,ITYPE=SemiModeless)
|
||||
RETURN
|
||||
END SUBROUTINE V3DialogShow
|
||||
|
||||
SUBROUTINE GETVSCAL(VSCALESV)
|
||||
USE WINTERACTER
|
||||
INCLUDE 'd.inc'
|
||||
call wdialogload(IDD_VSCAL)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_VSCAL)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutReal(IDF_REAL1,VSCALESV)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
do
|
||||
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
call wdialogGetReal(IDF_REAL1,VSCALESV)
|
||||
RETURN
|
||||
else
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,120 @@
|
||||
!IPK LAST UPDATE jAN 25 2001 CORRECT REFERENCE TO INEW
|
||||
SUBROUTINE COMPACT(ISW)
|
||||
!
|
||||
! Compact nodes or element numbers
|
||||
! ISW = 3 compact nodes
|
||||
! ISW = 4 compact elements
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
DIMENSION ICREFN(MAXP),ICREFE(MAXE)
|
||||
!
|
||||
!
|
||||
IF(ISW .EQ. 3) THEN
|
||||
!
|
||||
! First compact node list and create cross reference
|
||||
!
|
||||
JJ=1
|
||||
DO J=1,NP
|
||||
!IPK JAN01 FIX TEST
|
||||
IF(INEW(J) .NE. 0) THEN
|
||||
INEW(JJ)= INEW(J)
|
||||
CORD(JJ,1)=CORD(J,1)
|
||||
CORD(JJ,2)=CORD(J,2)
|
||||
XUSR(JJ)=XUSR(J)
|
||||
YUSR(JJ)=YUSR(J)
|
||||
WD(JJ)=WD(J)
|
||||
LAY(JJ)=LAY(J)
|
||||
WIDTH(JJ)=WIDTH(J)
|
||||
SS1(JJ)=SS1(J)
|
||||
SS2(JJ)=SS2(J)
|
||||
WIDS(JJ)=WIDS(J)
|
||||
WIDBS(JJ)=WIDBS(J)
|
||||
SSO(JJ)=SSO(J)
|
||||
INSKP(JJ)=INSKP(J)
|
||||
LOCK(JJ)=LOCK(J)
|
||||
ICREFN(J)=JJ
|
||||
JJ=JJ+1
|
||||
ENDIF
|
||||
ENDDO
|
||||
DO J=JJ,NP
|
||||
CORD(J,1)=-1.D20
|
||||
CORD(J,2)=-1.D20
|
||||
XUSR(J)=-1.D20
|
||||
YUSR(J)=-1.D20
|
||||
WD(J)=-9999.
|
||||
LAY(J)=-9999
|
||||
WIDTH(J)=0.
|
||||
SS1(J)=0
|
||||
SS2(J)=0.
|
||||
WIDS(J)=0.
|
||||
WIDBS(J)=0.
|
||||
SSO(J)=0.
|
||||
INSKP(J)=1
|
||||
!IPK JAN01 ADD INEW
|
||||
INEW(J)=0
|
||||
LOCK(J)=0
|
||||
ENDDO
|
||||
NP=JJ-1
|
||||
!
|
||||
! Next renumber element connections
|
||||
!
|
||||
DO N=1,NE
|
||||
DO M=1,8
|
||||
IF(NOP(N,M) .NE. 0) THEN
|
||||
NOP(N,M)=ICREFN(NOP(N,M))
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDDO
|
||||
|
||||
! Renumber continuity lines
|
||||
|
||||
DO I=1,NCLM
|
||||
DO J=1,350
|
||||
IF(ICCLN(I,J) .GT. 0) THEN
|
||||
ICCLN(I,J)=ICREFN(ICCLN(I,J))
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDDO
|
||||
|
||||
ELSEIF(ISW .EQ. 4) THEN
|
||||
!
|
||||
! Compact elements
|
||||
!
|
||||
JJ=1
|
||||
DO J=1,NE
|
||||
IF(NOP(J,1) .NE. 0) THEN
|
||||
DO M=1,8
|
||||
NOP(JJ,M)=NOP(J,M)
|
||||
ENDDO
|
||||
ICREFE(J)=JJ
|
||||
XC(JJ)=XC(J)
|
||||
YC(JJ)=YC(J)
|
||||
IMAT(JJ)=IMAT(J)
|
||||
THTA(JJ)=THTA(J)
|
||||
IEM(JJ)=0
|
||||
NCORN(JJ)=NCORN(J)
|
||||
IESKP(JJ)=IESKP(J)
|
||||
JJ=JJ+1
|
||||
ENDIF
|
||||
ENDDO
|
||||
DO J=JJ,NE
|
||||
DO M=1,8
|
||||
NOP(J,M)=0
|
||||
ENDDO
|
||||
IMAT(J)=0
|
||||
THTA(J)=0
|
||||
IEM(J)=0
|
||||
NCORN(J)=0
|
||||
IESKP(JJ)=-1
|
||||
ENDDO
|
||||
NE=JJ-1
|
||||
DO J=1,NLST
|
||||
DO I=1,LLIST(J)
|
||||
ILIST(J,I)=ICREFE(ILIST(J,I))
|
||||
ENDDO
|
||||
ENDDO
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,149 @@
|
||||
SUBROUTINE COMPWGT
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! COMMON/ICN1/ ICN(MAXP)
|
||||
|
||||
DIST(X1,X2,Y1,Y2)=SQRT((X1-X2)**2+(Y1-Y2)**2)
|
||||
|
||||
DO J=1,MAXP
|
||||
ICN(J)=0
|
||||
END DO
|
||||
! First sort out the potential midsides
|
||||
! Note that transition elements caues a problem
|
||||
! Find these first
|
||||
DO 200 N=1,NE
|
||||
if(NCORN(N) .GT. 5) GO TO 200
|
||||
IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN
|
||||
!
|
||||
! We have a transition mark node number as if it were corner
|
||||
!
|
||||
ICN(NOP(N,3))=-1
|
||||
ICN(NOP(N,1))=IMAT(N)
|
||||
ICN(NOP(N,4))=IMAT(N)
|
||||
ICN(NOP(N,5))=IMAT(N)
|
||||
ELSE
|
||||
!
|
||||
! Store ICN = 2 for corner nodes
|
||||
!
|
||||
NCN=NCORN(N)
|
||||
!IPKOCT93 IF(IMAT(N) .GT. 900) THEN
|
||||
IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN
|
||||
GO TO 185
|
||||
ELSE
|
||||
MST=2
|
||||
ENDIF
|
||||
|
||||
DO 180 M=1,NCN,MST
|
||||
ICN(NOP(N,M))=IMAT(N)
|
||||
180 CONTINUE
|
||||
185 CONTINUE
|
||||
ENDIF
|
||||
200 END DO
|
||||
|
||||
DO N=1,NP
|
||||
IF(ICN(N) .GT. 0) THEN
|
||||
ADIST=1.E20
|
||||
DO J=1,NCRSEC
|
||||
IF(IVMIL(J) .EQ. 0) CYCLE
|
||||
IF(ICN(N) .EQ. NOREACH(IVMIL(J))) THEN
|
||||
A1=DIST(XUSR(N),XCRS(IVMIL(J)),YUSR(N),YCRS(IVMIL(J)))
|
||||
IF(A1 .LT. ADIST) THEN
|
||||
ADIST=A1
|
||||
NSEC1=IVMIL(J)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
!IPK JUN04
|
||||
IF(ADIST .EQ. 1.E20) THEN
|
||||
NRIVCR1(N)=0
|
||||
NRIVCR2(N)=0
|
||||
WTRIVCR1(N)=0
|
||||
WTRIVCR2(N)=0
|
||||
ELSE
|
||||
BDIST=1.E20
|
||||
DO J=1,NCRSEC
|
||||
IF(IVMIL(J) .EQ. 0) CYCLE
|
||||
IF(ICN(N) .EQ. NOREACH(IVMIL(J))) THEN
|
||||
IF(IVMIL(J) .NE. NSEC1) THEN
|
||||
A1=DIST(XUSR(N),XCRS(IVMIL(J)),YUSR(N),YCRS(IVMIL(J)))
|
||||
A2=DIST(XCRS(NSEC1),XCRS(IVMIL(J)),YCRS(NSEC1),YCRS(IVMIL(J)))
|
||||
|
||||
! A1 IS DISTANCE TO NODE
|
||||
! A2 IS DISTANCE TO RECORDED POINT
|
||||
|
||||
IF(A2 .GE. A1) THEN
|
||||
IF(A1 .LT. BDIST) THEN
|
||||
BDIST=A1
|
||||
NSEC2=IVMIL(J)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
IF(BDIST .EQ. 1.E20) NSEC2=NSEC1
|
||||
NRIVCR1(N)=NSEC1
|
||||
NRIVCR2(N)=NSEC2
|
||||
WTRIVCR1(N)=BDIST/(ADIST+BDIST)
|
||||
WTRIVCR2(N)=ADIST/(ADIST+BDIST)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE GETCSLOC
|
||||
use winteracter
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!-
|
||||
|
||||
include 'd.inc'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
INTEGER :: IERR,ISET,IBOX
|
||||
REAL :: ASET
|
||||
CHARACTER*1 :: IFLAG
|
||||
|
||||
call wdialogload(IDD_CSLOC)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_CSLOC)
|
||||
ierr=infoerror(1)
|
||||
|
||||
ISET=1
|
||||
100 continue
|
||||
|
||||
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER1,ISET)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
DO
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER1,ISET)
|
||||
GO TO 200
|
||||
else
|
||||
RETURN
|
||||
endif
|
||||
ENDDO
|
||||
200 CONTINUE
|
||||
|
||||
CALL XYLOC(XX,YY,IFLAG,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
XCRS(ISET) = XX*TXSCAL - XS
|
||||
YCRS(ISET) = YY*TXSCAL - YS
|
||||
GO TO 100
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,300 @@
|
||||
SUBROUTINE CONOUT(MENUS)
|
||||
!
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
SAVE
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||||
!
|
||||
DIMENSION VALUS(MAXP)
|
||||
|
||||
CHARACTER*60 STRELS
|
||||
|
||||
DATA STRELS/' You have tried to reorder before executing "FILL"'/
|
||||
!
|
||||
!
|
||||
! Test to make sure fill has been executed.
|
||||
!
|
||||
IF(MENUUS .EQ. 13) ifilltmp=0
|
||||
DO N=1,NE
|
||||
IF(IMAT(N) .GT. 0) THEN
|
||||
DO M=2,NCORN(N),2
|
||||
!ipkoct93
|
||||
if(imat(n) .LT. 900) THEN
|
||||
IF(NOP(N,M) .EQ. 0) THEN
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'You have tried to plot contours before filling'//char(13)//&
|
||||
'Do you wish to temporarily fill and proceed?'//&
|
||||
CHAR(13)//' ','PLOTTING CONTOURS WITHOUT A FILLED NETWORK?')
|
||||
!
|
||||
! If answer 'No', return
|
||||
!
|
||||
IF (WInfoDialog(4).EQ.2) THEN
|
||||
RETURN
|
||||
ENDIF
|
||||
CALL FILM(1)
|
||||
ifilltmp=1
|
||||
call hedr
|
||||
GO TO 300
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
!
|
||||
300 CONTINUE
|
||||
DO N=1,NP
|
||||
VALUS(N)=WD(N)
|
||||
ENDDO
|
||||
!
|
||||
CALL TOLMAX(VALUS,TTMIN,TTMAX)
|
||||
|
||||
ISZ=0
|
||||
IF(MENUS .EQ. 13) THEN
|
||||
ISZ=1
|
||||
CALL CSET(TTMIN,TTMAX,isz)
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
PSCL=1.0
|
||||
CALL ELCONT(VALUS,PSCL)
|
||||
|
||||
if(ifilltmp .eq. 1) CALL DELETM(0)
|
||||
|
||||
RETURN
|
||||
END
|
||||
SUBROUTINE ELCONT(VALUS,PSCL)
|
||||
!
|
||||
! Routine to draw element contours
|
||||
!
|
||||
USE BLK1MOD
|
||||
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
INCLUDE 'BFILES.I90'
|
||||
COMMON /BRK/ X(10),Y(10),VL(10),DL(10),VLM(10)
|
||||
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||||
LOGICAL SWITCH
|
||||
! DIMENSION X(10),Y(10),VL(10),VALUS(*)
|
||||
DIMENSION VALUS(*)
|
||||
DATA PSCL1/1.0/ITIME/0/
|
||||
|
||||
IF(PSCL .eq. 0.) then
|
||||
PSCL=PSCL1
|
||||
ELSE
|
||||
PSCL1=PSCL
|
||||
ENDIF
|
||||
CALL RRed
|
||||
|
||||
CALL GETXC
|
||||
|
||||
IF(.NOT. ALLOCATED(NKEY1)) THEN
|
||||
ALLOCATE (NKEY1(MAXE))
|
||||
ENDIF
|
||||
CALL SORTDB(YC,NKEY1,NE)
|
||||
|
||||
DO 500 NN=NE,1,-1
|
||||
N=NKEY1(NN)
|
||||
IF(IESKP(N) .EQ. 1) GO TO 500
|
||||
NCN=NCORN(N)
|
||||
IF(NCN .EQ. 9) NCN=8
|
||||
DO M=1,NCN,2
|
||||
if(nop(n,m) .eq. 0) go to 500
|
||||
IF(VALUS(NOP(N,M)) .LT. -9998.) GO TO 500
|
||||
ENDDO
|
||||
!
|
||||
! Copy values into work array
|
||||
!
|
||||
NCN=NCORN(N)
|
||||
! if(ncn .lt. 6) go to 500
|
||||
IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) GO TO 500
|
||||
IOK=0
|
||||
DO 300 M=1,NCN
|
||||
IF(NOP(N,M) .EQ. 0) GO TO 500
|
||||
X(M)=CORD(NOP(N,M),1)
|
||||
Y(M)=CORD(NOP(N,M),2)
|
||||
IF(I3DVIEW .EQ. 1) THEN
|
||||
IF(VRTSCAL .GT. 0.) THEN
|
||||
Y(M)=Y(M)+(WD(NOP(N,M))-VRTORIG)*COS(VANG/57.29578)/VRTSCAL
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
IF(X(M) .GT. 0. .AND. X(M) .LT. HSIZE) THEN
|
||||
IF(Y(M) .GT. 0. .AND. Y(M) .LT. 7.) THEN
|
||||
IOK=1
|
||||
ENDIF
|
||||
ENDIF
|
||||
VL(M)=VALUS(NOP(N,M))*PSCL
|
||||
300 CONTINUE
|
||||
IF(IOK .EQ. 0) GO TO 500
|
||||
! CALL BRKDWN(X,Y,VL,NCN)
|
||||
NELNO=N
|
||||
CALL BRKDWN(NCN,NELNO)
|
||||
|
||||
!ipkoct93
|
||||
if(ipsw(4) .eq. 1) then
|
||||
NLINP=NCN+1
|
||||
X(NLINP)=X(1)
|
||||
Y(NLINP)=Y(1)
|
||||
CALL DASHLN(X,Y,NLINP,0)
|
||||
endif
|
||||
|
||||
500 CONTINUE
|
||||
!
|
||||
! Print title
|
||||
!
|
||||
ncharr=lenstr(title)
|
||||
call rblue
|
||||
IF(NCHARR .GT. 1) CALL SYMBL(0.5,7.25,0.20,TITLE,0.0,ncharr)
|
||||
|
||||
XLEG=8.8
|
||||
YLEG=7.4
|
||||
|
||||
CALL LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL)
|
||||
CALL RBlue
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL)
|
||||
SAVE
|
||||
DIMENSION CONTUR(99),X(10),Y(10)
|
||||
DATA LDIGO/2/
|
||||
XLOC=XLEG+0.5
|
||||
YLOC=YLEG
|
||||
csfact=1.0001
|
||||
DO 80 N=1,NUMV
|
||||
IF(N .LT. NUMV) THEN
|
||||
!
|
||||
! Define polygon
|
||||
!
|
||||
X(1)=XLEG
|
||||
X(2)=XLEG
|
||||
X(3)=XLEG+0.4
|
||||
X(4)=XLEG+0.4
|
||||
Y(1)=YLOC
|
||||
Y(2)=YLOC-0.3
|
||||
Y(3)=YLOC-0.3
|
||||
Y(4)=YLOC
|
||||
nn=(n+1)*csfact
|
||||
if(numv .le. 10) nn=nn+2
|
||||
CALL POLYG(X,Y,4,nn)
|
||||
ENDIF
|
||||
!
|
||||
! Plot the value on the screen
|
||||
!
|
||||
if(contur(n) .ne. 0.) then
|
||||
DIG = ALOG10(ABS(CONTUR(N)))
|
||||
else
|
||||
dig = -2.
|
||||
endif
|
||||
IF(DIG .GT. 2.999) THEN
|
||||
LDIG=-DIG - 1
|
||||
ELSEIF (DIG .GT. 1.999) THEN
|
||||
LDIG = 0
|
||||
ELSEIF (DIG .GT. 0.999) THEN
|
||||
LDIG = 1
|
||||
ELSEIF (DIG .GT. 0) THEN
|
||||
LDIG = 2
|
||||
ELSE
|
||||
LDIG = DIG - 2. + .01
|
||||
LDIG = -LDIG
|
||||
ENDIF
|
||||
IF(LDIG .LT. 0) GO TO 70
|
||||
DO 60 KK=1,3
|
||||
ANUM=10.**(-LDIG)
|
||||
IF(N .EQ. 1) THEN
|
||||
IF(ABS(CONTUR(2)-CONTUR(1)) .LT. ANUM) THEN
|
||||
LDIG = LDIG + 1
|
||||
ELSE
|
||||
GO TO 70
|
||||
ENDIF
|
||||
ELSE
|
||||
IF(ABS(CONTUR(N)-CONTUR(N-1)) .LT. ANUM) THEN
|
||||
LDIG = LDIG + 1
|
||||
ELSE
|
||||
GO TO 70
|
||||
ENDIF
|
||||
ENDIF
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
call rblue
|
||||
CTMP=CONTUR(N)
|
||||
IF(ABS(CTMP) .LT. 1.E-7) THEN
|
||||
CTMP=0.
|
||||
LDIG=LDIGO
|
||||
ENDIF
|
||||
|
||||
CALL rblack
|
||||
CALL NUMBR(XLOC,YLOC-0.09,0.2,CTMP,0.0,LDIG)
|
||||
LDIGO=LDIG
|
||||
CALL rblack
|
||||
!
|
||||
CALL PLOTT(X(1),Y(1),3)
|
||||
CALL PLOTT(X(2),Y(2),2)
|
||||
CALL PLOTT(X(3),Y(3),2)
|
||||
CALL PLOTT(X(4),Y(4),2)
|
||||
CALL PLOTT(X(1),Y(1),2)
|
||||
!
|
||||
YLOC=YLOC-0.30
|
||||
80 CONTINUE
|
||||
CALL RBlue
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE TOLMAX(VALUS,TTMIN,TTMAX)
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
DIMENSION VALUS(*)
|
||||
!
|
||||
TMAX = -1.E+20
|
||||
TMIN = 1.E+20
|
||||
DO 218 J=1,NP
|
||||
IF (VALUS(J) .GT. TMAX) THEN
|
||||
TMAX = VALUS(J)
|
||||
ITMAX = J
|
||||
ENDIF
|
||||
IF (VALUS(J) .LT. TMIN) THEN
|
||||
TMIN = VALUS(J)
|
||||
ITMIN = J
|
||||
ENDIF
|
||||
218 CONTINUE
|
||||
WRITE(90,*) ' '
|
||||
WRITE(90,*) ' Max, Min for entire network '
|
||||
WRITE(90,*) ' MAX value = ', TMAX, ' at node ', ITMAX
|
||||
WRITE(90,*) ' MIN value = ', TMIN, ' at node ', ITMIN
|
||||
WRITE(90,*) ' '
|
||||
!
|
||||
! Check for max and min values of elements in the plotting area
|
||||
!
|
||||
TTMAX = -1.E+20
|
||||
TTMIN = 1.E+20
|
||||
DO 228 N=1,NE
|
||||
IF(IESKP(N) .EQ. 0) THEN
|
||||
DO 220 M=1,NCORN(N)
|
||||
J=NOP(N,M)
|
||||
!ipk sep99
|
||||
if(j .eq. 0) go to 220
|
||||
IF (VALUS(J) .GT. TTMAX) THEN
|
||||
TTMAX = VALUS(J)
|
||||
ITTMAX = J
|
||||
ENDIF
|
||||
IF (VALUS(J) .LT. TTMIN) THEN
|
||||
TTMIN = VALUS(J)
|
||||
ITTMIN = J
|
||||
ENDIF
|
||||
220 CONTINUE
|
||||
ENDIF
|
||||
228 CONTINUE
|
||||
!
|
||||
WRITE(90,*) ' '
|
||||
WRITE(90,*) ' Max, Min for plot area '
|
||||
WRITE(90,*) ' MAX value = ', TTMAX, ' at node ', ITTMAX
|
||||
WRITE(90,*) ' MIN value = ', TTMIN, ' at node ', ITTMIN
|
||||
!
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
@ -0,0 +1,193 @@
|
||||
PROGRAM creatgrid
|
||||
dimension XL(100,2),YL(100,2),mappt(2),XL1(100),XL2(100)
|
||||
REAL*8 GRIDX(100),GRIDY(100)
|
||||
!
|
||||
! define line numbers in map file
|
||||
!
|
||||
DIST(A,B,C,D)=SQRT((C-A)*2+(D-C)**2)
|
||||
XL(1,1)=0.
|
||||
XL(2,1)=320.
|
||||
XL(3,1)=530.
|
||||
YL(1,1)=0.
|
||||
YL(2,1)=20.
|
||||
YL(3,1)=50.
|
||||
MAPPT(1)=3
|
||||
XL(1,2)=0.
|
||||
XL(2,2)=600.
|
||||
YL(1,2)=70.
|
||||
YL(2,2)=90.
|
||||
MAPPT(2)=2
|
||||
K1=1
|
||||
K2=2
|
||||
|
||||
!
|
||||
! compute line length
|
||||
!
|
||||
XL1=0.
|
||||
nlpts1=mappt(k1)
|
||||
do n=2,nlpts1
|
||||
XL1(n)=XL1(n-1)+dist(XL(n-1,1),YL(n-1,1),XL(n,1),YL(n,1))
|
||||
enddo
|
||||
XL2=0.
|
||||
nlpts2=mappt(k2)
|
||||
do n=2,nlpts2
|
||||
XL2(n)=XL2(n-1)+dist(XL(n-1,2),YL(n-1,2),XL(n,2),YL(n,2))
|
||||
enddo
|
||||
xmean=(XL1(nlpts1)+XL2(nlpts2))/2.
|
||||
!
|
||||
! get size spacing
|
||||
!
|
||||
! read xsz,NY
|
||||
XSZ=100.
|
||||
NY=5
|
||||
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
|
||||
DO N=NY+2,NRT,NYP
|
||||
XALONG=XALONG+XALONG1
|
||||
NX1=2
|
||||
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
|
||||
NX2=2
|
||||
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
|
||||
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,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
|
||||
END DO
|
||||
!
|
||||
! query for depths
|
||||
!
|
||||
!
|
||||
! query for happY
|
||||
STOP
|
||||
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
|
||||
|
||||
@ -0,0 +1,278 @@
|
||||
SUBROUTINE CREATM
|
||||
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! Routine to create mesh from map contour lines
|
||||
|
||||
COMMON /CRMAP/ NCONT,CVALUE(1000),MSTART(1000),MFIN(1000),CINTDIS(1000),IACTCV(1000)
|
||||
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
|
||||
! Search map data for contoour lines and setup values
|
||||
|
||||
JS=1
|
||||
NCONT=0
|
||||
!
|
||||
K=0
|
||||
DO 20 J=1,MAXPTS
|
||||
MLEN=J-JS
|
||||
IF(XMAP(J) .LE. VDX .or. j .eq. maxpts) THEN
|
||||
!
|
||||
! We have found a line end, is itmore than 1 point long?
|
||||
!
|
||||
K=K+1
|
||||
IF(MLEN .GT. 1) THEN
|
||||
LTP=LINTYP(K)
|
||||
|
||||
IF(LTP .NE. 2) THEN
|
||||
IF(LTP .GT. 0) THEN
|
||||
NCONT=NCONT+1
|
||||
CVALUE(NCONT)=VAL(JS)
|
||||
MSTART(NCONT)=JS
|
||||
IF(XMAP(J) .LE. VDX) THEN
|
||||
MFIN(NCONT)=J-1
|
||||
ELSE
|
||||
MFIN(NCONT)=J
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
IF(MLEN .EQ. 0 .AND. LINTYP(K) .EQ. -999) GO TO 30
|
||||
JS=J+1
|
||||
ENDIF
|
||||
20 CONTINUE
|
||||
30 CONTINUE
|
||||
|
||||
|
||||
! Choose options and intervals
|
||||
|
||||
CALL PANELCRT(NCONT,CVALUE,IACTCV,CINTDIS,ICAN)
|
||||
IF(ICAN .EQ. 1) RETURN
|
||||
|
||||
! First form list of nodes working along contour lines
|
||||
|
||||
CALL CFORM
|
||||
|
||||
! Now generate elements
|
||||
|
||||
do n=1,np
|
||||
list(n)=1
|
||||
enddo
|
||||
|
||||
call deln2(np,0)
|
||||
|
||||
call checkpoly
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE PANELCRT(N1,R2,N3,R4,N5)
|
||||
|
||||
! Choose options and intervals
|
||||
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'D.inc'
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: N1,N2,N3(1000),IERR,ITIME,K,N5,NA,NB
|
||||
real :: R2(1000),R4(1000)
|
||||
data itime/0/
|
||||
|
||||
if(itime .eq. 0) then
|
||||
n2=0
|
||||
na=1
|
||||
nb=1
|
||||
itime=1
|
||||
do k=1,1000
|
||||
r4(k)=500.
|
||||
n3(k)=1
|
||||
enddo
|
||||
endif
|
||||
|
||||
call wdialogload(IDD_CREATM1)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutCheckBox(idf_check1,na)
|
||||
CALL WDialogPutCheckBox(idf_check2,nb)
|
||||
CALL WDialogPutReal(idf_real1,r4(1))
|
||||
|
||||
CALL WDialogSelect(IDD_CREATM1)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WDialogGetCheckBox(idf_check1,na)
|
||||
CALL WDialogGetCheckBox(idf_check2,nb)
|
||||
if(nb .eq. 1) then
|
||||
CALL WDialogGetReal(idf_real1,r4(1))
|
||||
do k=1,1000
|
||||
r4(k)=r4(1)
|
||||
enddo
|
||||
endif
|
||||
N5=0
|
||||
ELSE
|
||||
N5=1
|
||||
RETURN
|
||||
|
||||
ENDIF
|
||||
|
||||
if(na .eq. 1 .and. nb .eq. 1) return
|
||||
|
||||
call wdialogload(IDD_CREATM)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WGridPutCheckBox(idf_grid1,1,n3,n1)
|
||||
CALL WGridPutReal(idf_grid1,2,r2,n1)
|
||||
CALL WGridPutReal(idf_grid1,3,r4,n1)
|
||||
|
||||
CALL WDialogSelect(IDD_CREATM)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WGridGetCheckBox(idf_grid1,1,n3,n1)
|
||||
CALL WGridGetReal(idf_grid1,2,r2,n1)
|
||||
CALL WGridGetReal(idf_grid1,3,r4,n1)
|
||||
N5=0
|
||||
ELSE
|
||||
N5=1
|
||||
RETURN
|
||||
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE CFORM
|
||||
|
||||
! Form list of nodes working along contour lines
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
|
||||
COMMON /CRMAP/ NCONT,CVALUE(1000),MSTART(1000),MFIN(1000),CINTDIS(1000),IACTCV(1000)
|
||||
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
DISTC(N1,N2)=SQRT((XMAP(N1)-XMAP(N2))**2 &
|
||||
& +(YMAP(N1)-YMAP(N2))**2)
|
||||
|
||||
! Loop through each active contour
|
||||
|
||||
DO N=1,NCONT
|
||||
IF(IACTCV(N) .EQ. 1) THEN
|
||||
JS=MSTART(N)
|
||||
JF=MFIN(N)
|
||||
IF(XMAP(JS) .EQ. XMAP(JF) .AND. YMAP(JS) .EQ. YMAP(JF)) THEN
|
||||
IF(JF .GT. JS) JF=JF-1
|
||||
ENDIF
|
||||
IEND=0
|
||||
DO J=JS,JF
|
||||
IF(J .EQ. JS) THEN
|
||||
CDONE=0.
|
||||
CNODE=0
|
||||
CALL GETNOD(JJ)
|
||||
INSKP(JJ)=0
|
||||
INEW(JJ) = 1
|
||||
!
|
||||
XUSR(JJ) = XMAP(J)
|
||||
YUSR(JJ) = YMAP(J)
|
||||
CORD(JJ,1)=(XUSR(JJ)+XS)/TXSCAL
|
||||
CORD(JJ,2)=(YUSR(JJ)+YS)/TXSCAL
|
||||
WD(JJ)=CVALUE(N)
|
||||
WIDTH(JJ)=0.
|
||||
SS1(JJ)=0.
|
||||
SS2(JJ)=0.
|
||||
WIDS(JJ)=0.
|
||||
WIDBS(JJ)=0.
|
||||
SSO(JJ)=0.
|
||||
IF (JJ .GT. NP) NP = JJ
|
||||
CALL PLTNOD(JJ,0)
|
||||
ICHG=0
|
||||
ELSE
|
||||
CNODEO=CNODE
|
||||
CNODE=CNODE+DISTC(J,J-1)
|
||||
200 CONTINUE
|
||||
CDIS=CDONE+CINTDIS(N)
|
||||
IF(CDIS .LE. CNODE .OR. J .EQ. JF) THEN
|
||||
IF(CDIS .LE. CNODE) THEN
|
||||
FACT=(CDIS-CNODEO)/(DISTC(J,J-1))
|
||||
IF(J .EQ. JF .AND. FACT .GT. 0.999) IEND=1
|
||||
ELSE
|
||||
FACT=1.0
|
||||
IEND=1
|
||||
ENDIF
|
||||
CALL GETNOD(JJ)
|
||||
INSKP(JJ)=0
|
||||
INEW(JJ) = 1
|
||||
!
|
||||
XUSR(JJ) = (1.-FACT)*XMAP(J-1)+FACT*XMAP(J)
|
||||
YUSR(JJ) = (1.-FACT)*YMAP(J-1)+FACT*YMAP(J)
|
||||
CORD(JJ,1)=(XUSR(JJ)+XS)/TXSCAL
|
||||
CORD(JJ,2)=(YUSR(JJ)+YS)/TXSCAL
|
||||
WD(JJ)=CVALUE(N)
|
||||
WIDTH(JJ)=0.
|
||||
SS1(JJ)=0.
|
||||
SS2(JJ)=0.
|
||||
WIDS(JJ)=0.
|
||||
WIDBS(JJ)=0.
|
||||
SSO(JJ)=0.
|
||||
IF (JJ .GT. NP) NP = JJ
|
||||
CALL PLTNOD(JJ,0)
|
||||
ICHG=0
|
||||
CDONE=CDIS
|
||||
IF(IEND .NE. 1) GO TO 200
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE CHECKPOLY
|
||||
|
||||
! CHECK IF ELEMENTS ARE OUTSIDE POLYGON BY LOOKING AT CENTROID
|
||||
USE BLKOUT
|
||||
USE BLK1MOD
|
||||
|
||||
IF(NOUTLIN .EQ. 0) RETURN
|
||||
|
||||
call FILM(1)
|
||||
NETEMP=NE
|
||||
DO N=1,NETEMP
|
||||
IF(IMAT(N) .EQ. 0) CYCLE
|
||||
XM=(XUSR(NOP(N,1))+XUSR(NOP(N,3))+XUSR(NOP(N,5)))/3.
|
||||
YM=(YUSR(NOP(N,1))+YUSR(NOP(N,3))+YUSR(NOP(N,5)))/3.
|
||||
! do k=2,6,2
|
||||
! xm=xusr(nop(n,k))
|
||||
! ym=yusr(nop(n,k))
|
||||
if( IGRInsidePolygon(xoutl,youtl,noutlin,xm,ym)) then
|
||||
|
||||
else
|
||||
CALL DELTEL(n)
|
||||
go to 200
|
||||
endif
|
||||
! enddo
|
||||
|
||||
200 continue
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,376 @@
|
||||
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
|
||||
|
||||
@ -0,0 +1,158 @@
|
||||
!-----------------------------------------------------------------crsect
|
||||
subroutine crsect
|
||||
!----------------------------------------------------------------------c
|
||||
! purpose: c
|
||||
! To plot a selected cross section and calculate width and c
|
||||
! slopes. c
|
||||
! ycw mar97 c
|
||||
!----------------------------------------------------------------------c
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! include 'BLK1.COM'
|
||||
! include 'BLK2.COM'
|
||||
|
||||
real XPL(5),YPL(5),ss0(50)
|
||||
CHARACTER*1 ANS,ANSW(0:4),IFLAG
|
||||
CHARACTER*6 DESCR
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
COMMON /XYGRPH/ XVALUES(10000,10),YVALUES(10000,10),TIMMIN,VALMIN,TIMMAX,VALMAX,NVALUES,NSETS,LINPROP(10)
|
||||
|
||||
COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10),DESCR(10),ICRSR(10)
|
||||
DATA MAN/1/
|
||||
|
||||
!
|
||||
!------get cross section number
|
||||
!
|
||||
! 100 NHTP=0
|
||||
! NMESS=29
|
||||
! NBRR=6
|
||||
call selcrs(man)
|
||||
|
||||
if(man .eq. 2) then
|
||||
call setlim(timmin,timmax,valmin,valmax)
|
||||
else
|
||||
|
||||
!
|
||||
!......establish shape of curve
|
||||
!
|
||||
|
||||
timmin=1.e20
|
||||
valmin=1.e20
|
||||
timmax=-1.e20
|
||||
valmax=-1.e20
|
||||
endif
|
||||
|
||||
DO J=1,5
|
||||
icr=icrsr(j)
|
||||
if(icr .gt. 0) then
|
||||
do i=nrivl(icr),1,-1
|
||||
|
||||
ii=nrivl(icr)-i+1
|
||||
xvalues(ii,j)=-crsdat(icr,i,3)/2.
|
||||
yvalues(ii,j)=crsdat(icr,i,1)
|
||||
ij=nrivl(icr)+i
|
||||
xvalues(ij,j)=crsdat(icr,i,3)/2.
|
||||
yvalues(ij,j)=crsdat(icr,i,1)
|
||||
|
||||
enddo
|
||||
nsets=j
|
||||
|
||||
if(man .eq. 1) then
|
||||
timmin=min(timmin,-crsdat(icr,nrivl(icr),3)/2.)
|
||||
valmin=min(valmin,crsdat(icr,1,1))
|
||||
timmax=max(timmax,crsdat(icr,nrivl(icr),3)/2.)
|
||||
valmax=max(valmax,crsdat(icr,nrivl(icr),1))
|
||||
endif
|
||||
|
||||
NVALUES=2*nrivl(icr)
|
||||
write(DESCR(j),'(i6)') ICR
|
||||
endif
|
||||
enddo
|
||||
call dograph(2,icurwin)
|
||||
iscrns(icurwin)=3
|
||||
|
||||
return
|
||||
END
|
||||
|
||||
subroutine selcrs(MAN)
|
||||
|
||||
USE WINTERACTER
|
||||
INCLUDE 'D.INC'
|
||||
CHARACTER*6 DESCR
|
||||
|
||||
COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10),DESCR(10),ICRSR(10)
|
||||
|
||||
call wdialogload(IDD_SELCRSEC)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_SECCRSEC)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do i=1,5
|
||||
CALL WGridPutCellInteger(IDF_GRID1,i,1,icrsr(i))
|
||||
enddo
|
||||
|
||||
if(man .eq. 1) then
|
||||
CALL WDialogPutRadioButton(IDF_RADIO1)
|
||||
else
|
||||
CALL WDialogPutRadioButton(IDF_RADIO2)
|
||||
endif
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
do i=1,5
|
||||
CALL WGridGetCellInteger(IDF_GRID1,i,1,icrsr(i))
|
||||
enddo
|
||||
CALL WDialogGetRadioButton(IDF_RADIO1,man)
|
||||
return
|
||||
else
|
||||
return
|
||||
endif
|
||||
|
||||
enddo
|
||||
return
|
||||
|
||||
end
|
||||
|
||||
subroutine setlim(timmin,timmax,valmin,valmax)
|
||||
|
||||
USE WINTERACTER
|
||||
INCLUDE 'D.INC'
|
||||
CHARACTER*6 DESCR
|
||||
|
||||
call wdialogload(IDD_LIMITS)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_LIMITS)
|
||||
ierr=infoerror(1)
|
||||
|
||||
|
||||
CALL WDialogPutReal(IDF_REAL1,TIMMIN)
|
||||
CALL WDialogPutReal(IDF_REAL2,TIMMAX)
|
||||
CALL WDialogPutReal(IDF_REAL3,VALMIN)
|
||||
CALL WDialogPutReal(IDF_REAL4,VALMAX)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WDialogGetReal(IDF_REAL1,TIMMIN)
|
||||
CALL WDialogGetReal(IDF_REAL2,TIMMAX)
|
||||
CALL WDialogGetReal(IDF_REAL3,VALMIN)
|
||||
CALL WDialogGetReal(IDF_REAL4,VALMAX)
|
||||
return
|
||||
else
|
||||
return
|
||||
endif
|
||||
|
||||
enddo
|
||||
return
|
||||
|
||||
end
|
||||
@ -0,0 +1,407 @@
|
||||
SUBROUTINE CSET(TTMIN,TTMAX,isz)
|
||||
|
||||
USE WINTERACTER
|
||||
SAVE
|
||||
INTEGER ICK5
|
||||
!
|
||||
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||||
!IPK APR94
|
||||
COMMON /RECOD/ IRECD,TSPC
|
||||
DIMENSION NKEY(99)
|
||||
CHARACTER*80 ILIND
|
||||
LOGICAL SWITCH
|
||||
DATA ITIM,VDM /0,-1.E15/
|
||||
!
|
||||
call setd(24)
|
||||
IF(ITIM .EQ. 0) THEN
|
||||
OMAX=VDM
|
||||
OMIN=VDM
|
||||
ick5=0
|
||||
DO 200 N=1,99
|
||||
CONTUR(N)=VDM
|
||||
200 CONTINUE
|
||||
ITIM=ITIM+1
|
||||
ELSE
|
||||
ITIM=ITIM+1
|
||||
ENDIF
|
||||
!
|
||||
!
|
||||
13 continue
|
||||
!
|
||||
! isz = 0 means no choice for data
|
||||
! = 1 means data selectd
|
||||
!
|
||||
IF(TTMAX .EQ. TTMIN) THEN
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,&
|
||||
'There are no contours for this case MAX=MIN'//CHAR(13)//'The model will return ','CONTOUR ERROR')
|
||||
5010 FORMAT(F5.2)
|
||||
RETURN
|
||||
!ipk apr94
|
||||
ENDIF
|
||||
IF(ICK5 .EQ. 1) GO TO 250
|
||||
!
|
||||
! get an estimate of contour values
|
||||
!
|
||||
AT=ALOG10(TTMAX-TTMIN)
|
||||
IF(AT .LT. 0.) THEN
|
||||
CINTER = 10. ** (IFIX(AT - .5) - 1)
|
||||
ELSE
|
||||
CINTER = 10. ** (IFIX(AT + .5) - 1)
|
||||
ENDIF
|
||||
! CINTER = 10. ** (IFIX(ALOG10(TTMAX-TTMIN) + .5) - 1)
|
||||
235 FINTER = CINTER
|
||||
! write(*,*) cinter,numv
|
||||
IF(TTMIN .GT. 0.) THEN
|
||||
CONTUR(1)=IFIX(TTMIN/CINTER)*CINTER+0.001*cinter
|
||||
ELSE
|
||||
CONTUR(1)=IFIX((TTMIN-CINTER)/CINTER)*CINTER+0.001*cinter
|
||||
ENDIF
|
||||
NUMV=1
|
||||
DO 240 N=2,99
|
||||
CONTUR(N)=CONTUR(N-1)+FINTER
|
||||
IF(CONTUR(N) .GT. TTMAX) THEN
|
||||
NUMV=N
|
||||
GO TO 245
|
||||
ENDIF
|
||||
240 END DO
|
||||
NUMV=99
|
||||
245 IF(NUMV .GT. 16) THEN
|
||||
CINTER=CINTER*2.
|
||||
GO TO 235
|
||||
ENDIF
|
||||
DO 247 N=NUMV+1,99
|
||||
CONTUR(N)=VDM
|
||||
247 END DO
|
||||
250 CONTINUE
|
||||
!
|
||||
! print options when no startup data available
|
||||
!
|
||||
if(isz .eq. 1) then
|
||||
call conpanel(icsp,ttmin,ttmax,numv,contur,omax,omin,ick5)
|
||||
if(icsp .lt. 0) then
|
||||
GO TO 405
|
||||
elseif(icsp .eq. 0) then
|
||||
go to 405
|
||||
endif
|
||||
|
||||
|
||||
IF(ABS(ICSP) .EQ. 1) THEN
|
||||
icsp=0
|
||||
!
|
||||
! this is log spacing
|
||||
!
|
||||
IF(TTMAX .GT. 0.) THEN
|
||||
ALMAX=ALOG10(TTMAX)
|
||||
ELSE
|
||||
call clscrn
|
||||
call symbl (0.1,7.0,0.25, &
|
||||
& 'Maximum contour value is negative',0.0,33)
|
||||
call symbl (0.1,6.5,0.25, &
|
||||
& 'Reconsider your choice',0.0,22)
|
||||
GO TO 250
|
||||
ENDIF
|
||||
IF(TTMIN .GT. 0.) THEN
|
||||
ALMIN=ALOG10(TTMIN)
|
||||
!ipk oct94 add a switch
|
||||
IMINSW=0
|
||||
ELSE
|
||||
call clscrn
|
||||
call symbl (0.1,7.0,0.25, &
|
||||
& 'Minimum contour value is negative',0.0,33)
|
||||
call symbl (0.1,6.5,0.25, &
|
||||
& 'Value set to 10**10 less than max value',0.0,39)
|
||||
ALMIN=ALMAX-10.
|
||||
!ipk oct 94 add a switch
|
||||
IMINSW=1
|
||||
ENDIF
|
||||
!
|
||||
ALMIN=ALMAX-4.
|
||||
!
|
||||
IF(ALMAX .GT. 0.) THEN
|
||||
LMAX=ALMAX
|
||||
ELSE
|
||||
LMAX=ALMAX-1.
|
||||
ENDIF
|
||||
IF(ALMIN .GT. 0.) THEN
|
||||
LMIN=ALMIN+1.
|
||||
ELSE
|
||||
LMIN=ALMIN
|
||||
ENDIF
|
||||
!ipk oct94 NUMV=LMAX-LMIN+1
|
||||
NUMV=LMAX-LMIN+1+IMINSW
|
||||
IF(NUMV .LT. 8) THEN
|
||||
NUMV=NUMV*2
|
||||
IDB=2
|
||||
ELSE
|
||||
IDB=1
|
||||
ENDIF
|
||||
!ipk oct94
|
||||
IF(IMINSW .EQ. 1) THEN
|
||||
CONTUR(1)=0.
|
||||
CONTUR(2)=10.**LMIN
|
||||
K=2
|
||||
ELSE
|
||||
CONTUR(1)=10.**LMIN
|
||||
K=1
|
||||
ENDIF
|
||||
IPW=LMIN
|
||||
DO 350 N=IMINSW+2,NUMV,IDB
|
||||
IF(IDB .EQ. 2) THEN
|
||||
K=K+1
|
||||
CONTUR(K)=CONTUR(K-1)*3.
|
||||
ENDIF
|
||||
IPW=IPW+1
|
||||
K=K+1
|
||||
CONTUR(K)=10.**IPW
|
||||
350 CONTINUE
|
||||
numv=k
|
||||
!
|
||||
! this is for entry of chosen contours
|
||||
!
|
||||
ELSEIF(abs(ICSP) .EQ. 2) THEN
|
||||
icsp=0
|
||||
CALL SORT(CONTUR,NKEY,NUMV)
|
||||
ELSEIF(abs(ICSP) .EQ. 3) THEN
|
||||
icsp=0
|
||||
cinter=omax-omin
|
||||
if(cinter .gt. 0.) then
|
||||
cinter=cinter/(numv-1)
|
||||
else
|
||||
cinter=1.0
|
||||
endif
|
||||
contur(1)=omin
|
||||
do i=2,numv
|
||||
contur(i)=contur(i-1)+cinter
|
||||
enddo
|
||||
ENDIF
|
||||
GO TO 250
|
||||
!ipk july 1995 add this line
|
||||
405 CONTINUE
|
||||
ENDIF
|
||||
call setd(2)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
subroutine conpanel(icsp,ttmin,ttmax,numv,contur,omax,omin,ick5)
|
||||
|
||||
use winteracter
|
||||
implicit none
|
||||
|
||||
save
|
||||
|
||||
include 'D.inc'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: icsp,numv,nlim,ict,ictx,ick1,ick2,ick3,ick4,ick5,ierr,idf,ipos,numvold
|
||||
real :: ttmin,ttmax,contur(99),omax,omin,VDX
|
||||
character*80 labmax,labmin,labnum,labcon(30),labomax,labomin
|
||||
VDX=-1.E14
|
||||
write(labmax,'(f10.3)') ttmax
|
||||
write(labmin,'(f10.3)') ttmin
|
||||
|
||||
if(omax .lt. vdx) then
|
||||
labomax=labmax
|
||||
else
|
||||
write(labomax,'(f10.3)') omax
|
||||
endif
|
||||
|
||||
if(omin .lt. vdx) then
|
||||
labomin=labmin
|
||||
else
|
||||
write(labomin,'(f10.3)') omin
|
||||
endif
|
||||
write(labnum,'(i10)') numv
|
||||
nlim=numv
|
||||
if(nlim .gt. 30) nlim=numv
|
||||
do ict=1,nlim
|
||||
write(labcon(ict),'(f10.3)') contur(ict)
|
||||
enddo
|
||||
if(numv .lt. 30) then
|
||||
do ict=numv+1,30
|
||||
labcon(ict)=' '
|
||||
enddo
|
||||
endif
|
||||
|
||||
90 continue
|
||||
numvold=numv
|
||||
|
||||
call wdialogload(IDD_DIALOG02)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutString(idf_string1,labmax)
|
||||
CALL WDialogPutString(idf_string2,labmin)
|
||||
CALL WDialogPutString(idf_string3,labomax)
|
||||
CALL WDialogPutString(idf_string22,labomin)
|
||||
CALL WDialogPutString(idf_string23,labnum)
|
||||
|
||||
ictx=0
|
||||
do ict=idf_string4,idf_string4+18-1
|
||||
ictx=ictx+1
|
||||
CALL WDialogPutString(ict,labcon(ictx))
|
||||
enddo
|
||||
ictx=ictx+1
|
||||
ICT=idf_string24
|
||||
CALL WDialogPutString(ict,labcon(ictx))
|
||||
|
||||
DO ict=idf_string25,idf_string25+9
|
||||
ictx=ictx+1
|
||||
CALL WDialogPutString(ict,labcon(ictx))
|
||||
enddo
|
||||
ictx=ictx+1
|
||||
ICT=idf_string35
|
||||
CALL WDialogPutString(ict,labcon(ictx))
|
||||
|
||||
! call wdialogputcheckbox(idf_check1,0)
|
||||
! call wdialogputcheckbox(idf_check2,0)
|
||||
! call wdialogputcheckbox(idf_check3,0)
|
||||
! call wdialogputcheckbox(idf_check4,0)
|
||||
call wdialogputcheckbox(idf_check5,ick5)
|
||||
! if(icsp .eq. 0) then
|
||||
call wdialogputRadioButton(idf_check1)
|
||||
! endif
|
||||
|
||||
|
||||
CALL WDialogSelect(IDD_DIALOG02)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
! call wdialoggetcheckbox(idf_check1,ick1)
|
||||
! call wdialoggetcheckbox(idf_check2,ick2)
|
||||
! call wdialoggetcheckbox(idf_check3,ick3)
|
||||
! call wdialoggetcheckbox(idf_check4,ick4)
|
||||
call wdialoggetcheckbox(idf_check5,ick5)
|
||||
CALL WDialoggetString(idf_string1,labmax)
|
||||
CALL WDialoggetString(idf_string2,labmin)
|
||||
CALL WDialoggetString(idf_string3,labomax)
|
||||
CALL WDialoggetString(idf_string22,labomin)
|
||||
CALL WDialoggetString(idf_string23,labnum)
|
||||
call wdialoggetradiobutton(idf_check1,ipos)
|
||||
call IStringToInteger(labnum,numv)
|
||||
write(90,*) 'numvold',numvold,numv,ipos
|
||||
if(numvold .ne. numv .and. ipos .ne. 4) ipos=3
|
||||
!C if(ick1 .eq. 1) then
|
||||
!C icsp=0
|
||||
!C else
|
||||
icsp=0
|
||||
if(ipos .eq. 2) then
|
||||
icsp=1
|
||||
elseif(ipos .eq. 3) then
|
||||
icsp=3
|
||||
write(90,'(a)') 'numv',labnum
|
||||
call IStringToInteger(labnum,numv)
|
||||
if(infoError(1) .gt. 0) then
|
||||
call wdialogload(IDD_DIALOG04)
|
||||
CALL WDialogSelect(IDD_DIALOG04)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
120 continue
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
go to 90
|
||||
endif
|
||||
go to 120
|
||||
endif
|
||||
call IStringToReal(labomax,omax)
|
||||
if(infoError(1) .gt. 0) then
|
||||
call wdialogload(IDD_DIALOG04)
|
||||
CALL WDialogSelect(IDD_DIALOG04)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
130 continue
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
go to 90
|
||||
endif
|
||||
go to 130
|
||||
endif
|
||||
call IStringToReal(labomin,omin)
|
||||
if(infoError(1) .gt. 0) then
|
||||
call wdialogload(IDD_DIALOG04)
|
||||
CALL WDialogSelect(IDD_DIALOG04)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
140 continue
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
go to 90
|
||||
endif
|
||||
go to 140
|
||||
endif
|
||||
elseif(ipos .eq. 4) then
|
||||
icsp=2
|
||||
write(90,'(a)') 'numv-4',labnum
|
||||
! read(labnum,*) numv
|
||||
call IStringToInteger(labnum,numv)
|
||||
if(infoError(1) .gt. 0) then
|
||||
call wdialogload(IDD_DIALOG04)
|
||||
CALL WDialogSelect(IDD_DIALOG04)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
150 continue
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
go to 90
|
||||
endif
|
||||
go to 150
|
||||
endif
|
||||
write(90,*) numv
|
||||
ictx=0
|
||||
do ict=idf_string4,idf_string4+18-1
|
||||
ictx=ictx+1
|
||||
CALL WDialogGetString(ict,labcon(ictx))
|
||||
enddo
|
||||
ictx=ictx+1
|
||||
ICT=idf_string24
|
||||
CALL WDialogGetString(ict,labcon(ictx))
|
||||
do ict=idf_string25,idf_string25+9
|
||||
ictx=ictx+1
|
||||
CALL WDialogGetString(ict,labcon(ictx))
|
||||
enddo
|
||||
ictx=ictx+1
|
||||
ICT=idf_string35
|
||||
CALL WDialogGetString(ict,labcon(ictx))
|
||||
do ict=1,numv
|
||||
! read(labcon(ict),*) contur(ict)
|
||||
call IStringToReal(labcon(ict),contur(ict))
|
||||
if(infoError(1) .gt. 0) then
|
||||
call wdialogload(IDD_DIALOG04)
|
||||
CALL WDialogSelect(IDD_DIALOG04)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
160 continue
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
go to 90
|
||||
endif
|
||||
go to 160
|
||||
endif
|
||||
write(90,*) 'con',ict,contur(ict)
|
||||
enddo
|
||||
endif
|
||||
|
||||
if(ipos .eq. 5) then
|
||||
icsp=-5
|
||||
! abs(icsp)
|
||||
endif
|
||||
write(90,*) 'icsp',icsp,omax,omin,numv,ipos
|
||||
! write(90,*) 'ick',ick1,ick2,ick3,ick4,ick5
|
||||
return
|
||||
|
||||
endif
|
||||
return
|
||||
enddo
|
||||
return
|
||||
end
|
||||
@ -0,0 +1,409 @@
|
||||
! Winteracter resource identifiers. Created : 14/Sep/2018 14:52:39
|
||||
!
|
||||
! This file is generated by the Winteracter resource editor.
|
||||
! It should not be edited manually. It is also not advisable to load this
|
||||
! file in a text editor, while working on the associated resource file,
|
||||
! since this may prevent the resource identifiers file from being updated.
|
||||
! To view the names and values of resource identifiers, use the
|
||||
! "Identifier Names and Values" or "Used Identifiers" options on the
|
||||
! resource editor's "View" menu. Both dialogs also include a "Copy id"
|
||||
! button which allows identifier names to be copied via the clipboard.
|
||||
! Opening this file in an editor should therefore not be necessary.
|
||||
!
|
||||
INTEGER, PARAMETER :: IDR_MENU1 = 30001
|
||||
INTEGER, PARAMETER :: ID_FILE = 40001
|
||||
INTEGER, PARAMETER :: ID_EXIT = 40002
|
||||
INTEGER, PARAMETER :: ID_NODE = 40003
|
||||
INTEGER, PARAMETER :: ID_ELTS = 40004
|
||||
INTEGER, PARAMETER :: ID_ORDRT = 40005
|
||||
INTEGER, PARAMETER :: ID_CCLNA = 40006
|
||||
INTEGER, PARAMETER :: ID_CSEC1 = 40007
|
||||
INTEGER, PARAMETER :: ID_ZOOM = 40008
|
||||
INTEGER, PARAMETER :: ID_DRAW = 40009
|
||||
INTEGER, PARAMETER :: ID_HELP = 40010
|
||||
INTEGER, PARAMETER :: ID_STRING1 = 50001
|
||||
INTEGER, PARAMETER :: ID_STRING2 = 50002
|
||||
INTEGER, PARAMETER :: ID_STRING3 = 50003
|
||||
INTEGER, PARAMETER :: ID_STRING4 = 50004
|
||||
INTEGER, PARAMETER :: ID_STRING5 = 50005
|
||||
INTEGER, PARAMETER :: ID_STRING6 = 50006
|
||||
INTEGER, PARAMETER :: ID_STRING7 = 50007
|
||||
INTEGER, PARAMETER :: ID_STRING8 = 50008
|
||||
INTEGER, PARAMETER :: ID_STRING9 = 50009
|
||||
INTEGER, PARAMETER :: ID_STRING10 = 50010
|
||||
INTEGER, PARAMETER :: ID_STRING11 = 50011
|
||||
INTEGER, PARAMETER :: ID_ITEM11 = 40011
|
||||
INTEGER, PARAMETER :: ID_ITEM12 = 40012
|
||||
INTEGER, PARAMETER :: ID_ITEM13 = 40013
|
||||
INTEGER, PARAMETER :: ID_ITEM14 = 40014
|
||||
INTEGER, PARAMETER :: ID_ITEM15 = 40015
|
||||
INTEGER, PARAMETER :: ID_ITEM16 = 40016
|
||||
INTEGER, PARAMETER :: ID_ITEM17 = 40017
|
||||
INTEGER, PARAMETER :: ID_ITEM18 = 40018
|
||||
INTEGER, PARAMETER :: ID_ITEM19 = 40019
|
||||
INTEGER, PARAMETER :: IDF_STRING24 = 1041
|
||||
INTEGER, PARAMETER :: IDD_DIALOG1 = 101
|
||||
INTEGER, PARAMETER :: IDF_LABEL5 = 1042
|
||||
INTEGER, PARAMETER :: IDC_BUTTON2 = 20001
|
||||
INTEGER, PARAMETER :: ID_ITEM20 = 40021
|
||||
INTEGER, PARAMETER :: ID_ITEM73 = 40022
|
||||
INTEGER, PARAMETER :: ID_ITEM23 = 40023
|
||||
INTEGER, PARAMETER :: ID_ITEM24 = 40024
|
||||
INTEGER, PARAMETER :: ID_TOOLBAR1 = 30101
|
||||
INTEGER, PARAMETER :: ID_ZIN = 40025
|
||||
INTEGER, PARAMETER :: ID_ZOUT = 40026
|
||||
INTEGER, PARAMETER :: ID_OUT2 = 40027
|
||||
INTEGER, PARAMETER :: ID_OUT4 = 40028
|
||||
INTEGER, PARAMETER :: ID_RSET = 40029
|
||||
INTEGER, PARAMETER :: ID_PLEFT = 40031
|
||||
INTEGER, PARAMETER :: ID_PRIGHT = 40032
|
||||
INTEGER, PARAMETER :: ID_PUP = 40033
|
||||
INTEGER, PARAMETER :: ID_PDOWN = 40034
|
||||
INTEGER, PARAMETER :: ID_IDRWT = 40035
|
||||
INTEGER, PARAMETER :: ID_TYPD = 40039
|
||||
INTEGER, PARAMETER :: ID_DRAWD = 40041
|
||||
INTEGER, PARAMETER :: ID_MAPOPD = 40042
|
||||
INTEGER, PARAMETER :: ID_CONTR = 40060
|
||||
INTEGER, PARAMETER :: IDF_LABEL1 = 1001
|
||||
INTEGER, PARAMETER :: IDF_LABEL2 = 1002
|
||||
INTEGER, PARAMETER :: IDF_LABEL3 = 1003
|
||||
INTEGER, PARAMETER :: IDF_LABEL4 = 1004
|
||||
INTEGER, PARAMETER :: IDF_STRING1 = 1013
|
||||
INTEGER, PARAMETER :: IDF_STRING2 = 1014
|
||||
INTEGER, PARAMETER :: IDF_STRING3 = 1015
|
||||
INTEGER, PARAMETER :: IDF_STRING4 = 1016
|
||||
INTEGER, PARAMETER :: IDF_STRING5 = 1017
|
||||
INTEGER, PARAMETER :: IDF_STRING6 = 1018
|
||||
INTEGER, PARAMETER :: IDF_STRING7 = 1019
|
||||
INTEGER, PARAMETER :: IDF_STRING8 = 1020
|
||||
INTEGER, PARAMETER :: IDF_STRING9 = 1021
|
||||
INTEGER, PARAMETER :: IDF_STRING10 = 1022
|
||||
INTEGER, PARAMETER :: IDF_STRING11 = 1023
|
||||
INTEGER, PARAMETER :: IDF_STRING12 = 1024
|
||||
INTEGER, PARAMETER :: IDD_DIALOG02 = 102
|
||||
INTEGER, PARAMETER :: IDF_STRING13 = 1025
|
||||
INTEGER, PARAMETER :: IDF_STRING14 = 1026
|
||||
INTEGER, PARAMETER :: IDF_STRING15 = 1027
|
||||
INTEGER, PARAMETER :: IDF_STRING16 = 1028
|
||||
INTEGER, PARAMETER :: IDF_STRING17 = 1029
|
||||
INTEGER, PARAMETER :: IDF_STRING18 = 1030
|
||||
INTEGER, PARAMETER :: IDF_STRING19 = 1031
|
||||
INTEGER, PARAMETER :: IDF_STRING20 = 1032
|
||||
INTEGER, PARAMETER :: IDF_STRING21 = 1033
|
||||
INTEGER, PARAMETER :: IDF_STRING22 = 1034
|
||||
INTEGER, PARAMETER :: IDF_STRING23 = 1035
|
||||
INTEGER, PARAMETER :: IDF_CHECK1 = 1036
|
||||
INTEGER, PARAMETER :: IDF_CHECK2 = 1037
|
||||
INTEGER, PARAMETER :: IDF_CHECK3 = 1038
|
||||
INTEGER, PARAMETER :: IDF_CHECK4 = 1039
|
||||
INTEGER, PARAMETER :: IDF_CHECK5 = 1040
|
||||
INTEGER, PARAMETER :: ID_DCONTR = 40056
|
||||
INTEGER, PARAMETER :: ID_CONTOPT = 40061
|
||||
INTEGER, PARAMETER :: ID_ITYPN = 40064
|
||||
INTEGER, PARAMETER :: ID_ITYPC = 40065
|
||||
INTEGER, PARAMETER :: ID_ICOPY = 40067
|
||||
INTEGER, PARAMETER :: IDD_DIALOG04 = 104
|
||||
INTEGER, PARAMETER :: ID_BACGD = 40050
|
||||
INTEGER, PARAMETER :: ID_ITEM26 = 40071
|
||||
INTEGER, PARAMETER :: IDD_DIALOG05 = 103
|
||||
INTEGER, PARAMETER :: IDF_CMAP8 = 1005
|
||||
INTEGER, PARAMETER :: IDF_CMAP9 = 1006
|
||||
INTEGER, PARAMETER :: IDF_CMAP0 = 1007
|
||||
INTEGER, PARAMETER :: IDF_CMAP1 = 1008
|
||||
INTEGER, PARAMETER :: IDF_CMAP2 = 1009
|
||||
INTEGER, PARAMETER :: IDF_CMAP10 = 1010
|
||||
INTEGER, PARAMETER :: IDF_CMAP11 = 1011
|
||||
INTEGER, PARAMETER :: IDF_CMAP3 = 1012
|
||||
INTEGER, PARAMETER :: IDF_CMAP4 = 1043
|
||||
INTEGER, PARAMETER :: IDF_CMAP5 = 1044
|
||||
INTEGER, PARAMETER :: IDF_CMAP6 = 1045
|
||||
INTEGER, PARAMETER :: IDF_CMAP7 = 1046
|
||||
INTEGER, PARAMETER :: IDD_DIALOG006 = 105
|
||||
INTEGER, PARAMETER :: IDF_RADIO1 = 1047
|
||||
INTEGER, PARAMETER :: IDF_RADIO2 = 1048
|
||||
INTEGER, PARAMETER :: IDF_RADIO3 = 1049
|
||||
INTEGER, PARAMETER :: IDF_RADIO4 = 1050
|
||||
INTEGER, PARAMETER :: IDF_RADIO5 = 1051
|
||||
INTEGER, PARAMETER :: IDF_RADIO6 = 1052
|
||||
INTEGER, PARAMETER :: IDF_RADIO7 = 1053
|
||||
INTEGER, PARAMETER :: IDF_RADIO8 = 1054
|
||||
INTEGER, PARAMETER :: IDF_RADIO9 = 1055
|
||||
INTEGER, PARAMETER :: ID_MMAP = 40043
|
||||
INTEGER, PARAMETER :: IDD_DIALOG07 = 106
|
||||
INTEGER, PARAMETER :: IDD_DIALOG08 = 107
|
||||
INTEGER, PARAMETER :: ID_Help1 = 40040
|
||||
INTEGER, PARAMETER :: ID_Help2 = 40044
|
||||
INTEGER, PARAMETER :: IDD_DIALOG09 = 108
|
||||
INTEGER, PARAMETER :: IDF_LABEL7 = 1056
|
||||
INTEGER, PARAMETER :: IDD_DIALOG10 = 109
|
||||
INTEGER, PARAMETER :: IDF_INTEGER1 = 1057
|
||||
INTEGER, PARAMETER :: IDF_INTEGER2 = 1058
|
||||
INTEGER, PARAMETER :: ID_LAYFL = 40046
|
||||
INTEGER, PARAMETER :: IDF_RADIO10 = 1056
|
||||
INTEGER, PARAMETER :: IDD_DIALOG010 = 110
|
||||
INTEGER, PARAMETER :: IDD_DIALOG001 = 111
|
||||
INTEGER, PARAMETER :: ID_BKF = 40047
|
||||
INTEGER, PARAMETER :: IDD_DIALOG012 = 113
|
||||
INTEGER, PARAMETER :: IDF_CHECK6 = 1041
|
||||
INTEGER, PARAMETER :: IDF_CHECK7 = 1042
|
||||
INTEGER, PARAMETER :: IDF_CHECK8 = 1043
|
||||
INTEGER, PARAMETER :: IDF_CHECK9 = 1044
|
||||
INTEGER, PARAMETER :: IDF_CHECK10 = 1045
|
||||
INTEGER, PARAMETER :: IDF_CHECK11 = 1059
|
||||
INTEGER, PARAMETER :: ID_Clip = 40020
|
||||
INTEGER, PARAMETER :: ID_UNDOM = 40030
|
||||
INTEGER, PARAMETER :: ID_BSEL = 40036
|
||||
INTEGER, PARAMETER :: ID_REGST = 40037
|
||||
INTEGER, PARAMETER :: IDD_REGST = 112
|
||||
INTEGER, PARAMETER :: IDF_LABEL6 = 1005
|
||||
INTEGER, PARAMETER :: IDF_REAL1 = 1060
|
||||
INTEGER, PARAMETER :: IDF_REAL2 = 1061
|
||||
INTEGER, PARAMETER :: IDF_REAL3 = 1062
|
||||
INTEGER, PARAMETER :: IDF_REAL4 = 1063
|
||||
INTEGER, PARAMETER :: IDF_LABEL8 = 1006
|
||||
INTEGER, PARAMETER :: IDF_LABEL9 = 1007
|
||||
INTEGER, PARAMETER :: IDF_LABEL10 = 1008
|
||||
INTEGER, PARAMETER :: IDF_LABEL11 = 1043
|
||||
INTEGER, PARAMETER :: IDF_REAL5 = 1064
|
||||
INTEGER, PARAMETER :: IDF_REAL6 = 1065
|
||||
INTEGER, PARAMETER :: IDF_REAL7 = 1066
|
||||
INTEGER, PARAMETER :: IDF_REAL8 = 1067
|
||||
INTEGER, PARAMETER :: IDF_LABEL12 = 1009
|
||||
INTEGER, PARAMETER :: IDADJUST = 1068
|
||||
INTEGER, PARAMETER :: IDFSWITCH = 1069
|
||||
INTEGER, PARAMETER :: IDD_SLRGNO = 114
|
||||
INTEGER, PARAMETER :: IDD_CONFIRM = 115
|
||||
INTEGER, PARAMETER :: ID_network = 40038
|
||||
INTEGER, PARAMETER :: ID_NMAP = 40045
|
||||
INTEGER, PARAMETER :: ID_ITEM56 = 40048
|
||||
INTEGER, PARAMETER :: ID_Nodedata = 40049
|
||||
INTEGER, PARAMETER :: ID_Eltdata = 40051
|
||||
INTEGER, PARAMETER :: IDD_nodedata = 116
|
||||
INTEGER, PARAMETER :: IDF_REAL9 = 1068
|
||||
INTEGER, PARAMETER :: IDF_REAL10 = 1069
|
||||
INTEGER, PARAMETER :: IDD_eltdata = 117
|
||||
INTEGER, PARAMETER :: IDF_INTEGER3 = 1059
|
||||
INTEGER, PARAMETER :: IDF_INTEGER4 = 1060
|
||||
INTEGER, PARAMETER :: IDF_INTEGER5 = 1061
|
||||
INTEGER, PARAMETER :: IDF_INTEGER6 = 1062
|
||||
INTEGER, PARAMETER :: IDF_INTEGER7 = 1063
|
||||
INTEGER, PARAMETER :: IDF_INTEGER8 = 1064
|
||||
INTEGER, PARAMETER :: IDF_INTEGER9 = 1070
|
||||
INTEGER, PARAMETER :: IDF_INTEGER10 = 1071
|
||||
INTEGER, PARAMETER :: IDD_SELNODE = 118
|
||||
INTEGER, PARAMETER :: IDNEXT = 1072
|
||||
INTEGER, PARAMETER :: IDD_SELELT = 119
|
||||
INTEGER, PARAMETER :: IDD_ELTERR = 120
|
||||
INTEGER, PARAMETER :: ID_DRAG = 40052
|
||||
INTEGER, PARAMETER :: ID_DELM = 40103
|
||||
INTEGER, PARAMETER :: ID_FILL = 40102
|
||||
INTEGER, PARAMETER :: IDF_Delete = 1073
|
||||
INTEGER, PARAMETER :: IDFROTATE = 1074
|
||||
INTEGER, PARAMETER :: IDF_RADIO11 = 1057
|
||||
INTEGER, PARAMETER :: ID_GETELM = 40053
|
||||
INTEGER, PARAMETER :: ID_mapm = 40054
|
||||
INTEGER, PARAMETER :: ID_map = 40055
|
||||
INTEGER, PARAMETER :: IDD_GETINTP = 160
|
||||
INTEGER, PARAMETER :: ID_SBIN = 40057
|
||||
INTEGER, PARAMETER :: IDD_headertp = 121
|
||||
INTEGER, PARAMETER :: ID_TRIAN = 40058
|
||||
INTEGER, PARAMETER :: ID_SWMAP = 40059
|
||||
INTEGER, PARAMETER :: ID_SWRM1 = 40062
|
||||
INTEGER, PARAMETER :: IDD_TRIAN = 122
|
||||
INTEGER, PARAMETER :: IDD_NODERR = 123
|
||||
INTEGER, PARAMETER :: IDF_STRING25 = 1106
|
||||
INTEGER, PARAMETER :: IDF_STRING26 = 1107
|
||||
INTEGER, PARAMETER :: IDF_STRING27 = 1108
|
||||
INTEGER, PARAMETER :: IDF_STRING28 = 1109
|
||||
INTEGER, PARAMETER :: IDF_STRING29 = 1110
|
||||
INTEGER, PARAMETER :: IDF_STRING30 = 1111
|
||||
INTEGER, PARAMETER :: IDF_STRING31 = 1112
|
||||
INTEGER, PARAMETER :: IDF_STRING32 = 1113
|
||||
INTEGER, PARAMETER :: IDF_STRING33 = 1114
|
||||
INTEGER, PARAMETER :: IDF_STRING34 = 1115
|
||||
INTEGER, PARAMETER :: IDD_SELTFL2 = 148
|
||||
INTEGER, PARAMETER :: ID_LOADRM1 = 40063
|
||||
INTEGER, PARAMETER :: ID_cdata = 40066
|
||||
INTEGER, PARAMETER :: ID_SELRM1 = 40068
|
||||
INTEGER, PARAMETER :: ID_addmesh = 40069
|
||||
INTEGER, PARAMETER :: ID_MRGMESH = 40070
|
||||
INTEGER, PARAMETER :: ID_ITEM22 = 40072
|
||||
INTEGER, PARAMETER :: ID_ALLNODES = 40073
|
||||
INTEGER, PARAMETER :: ID_UNUSNODES = 40074
|
||||
INTEGER, PARAMETER :: ID_TRIANG = 40075
|
||||
INTEGER, PARAMETER :: IDD_TRIANG = 124
|
||||
INTEGER, PARAMETER :: IDD_QUAD = 125
|
||||
INTEGER, PARAMETER :: ID_QUAD = 40076
|
||||
INTEGER, PARAMETER :: ID_JOIN = 40104
|
||||
INTEGER, PARAMETER :: ID_CSEC = 40077
|
||||
INTEGER, PARAMETER :: ID_CRSCAL = 40078
|
||||
INTEGER, PARAMETER :: ID_SAVCRS = 40079
|
||||
INTEGER, PARAMETER :: ID_crsf = 40080
|
||||
INTEGER, PARAMETER :: IDD_DIALOG06 = 126
|
||||
INTEGER, PARAMETER :: IDF_RADIO13 = 1076
|
||||
INTEGER, PARAMETER :: IDF_RADIO12 = 1058
|
||||
INTEGER, PARAMETER :: IDD_GETFPN = 154
|
||||
INTEGER, PARAMETER :: IDD_GETINT = 153
|
||||
INTEGER, PARAMETER :: ID_CSLOC = 40081
|
||||
INTEGER, PARAMETER :: IDD_CSLOC = 127
|
||||
INTEGER, PARAMETER :: ID_UNDO = 40082
|
||||
INTEGER, PARAMETER :: ID_UNDOS = 40083
|
||||
INTEGER, PARAMETER :: ID_CREATM = 40084
|
||||
INTEGER, PARAMETER :: IDD_CREATM = 128
|
||||
INTEGER, PARAMETER :: IDD_TEMPLATE001 = 129
|
||||
INTEGER, PARAMETER :: IDF_GRID1 = 1075
|
||||
INTEGER, PARAMETER :: ISS1 = 1077
|
||||
INTEGER, PARAMETER :: ISS2 = 1078
|
||||
INTEGER, PARAMETER :: ISS3 = 1079
|
||||
INTEGER, PARAMETER :: IDD_CREATM1 = 130
|
||||
INTEGER, PARAMETER :: ID_CGEN = 40085
|
||||
INTEGER, PARAMETER :: IDF_STRING35 = 1042
|
||||
INTEGER, PARAMETER :: IDD_ORDEROUT = 131
|
||||
INTEGER, PARAMETER :: IDD_TEMPLATE002 = 132
|
||||
INTEGER, PARAMETER :: IDF_RADIO14 = 1080
|
||||
INTEGER, PARAMETER :: IDF_RADIO15 = 1081
|
||||
INTEGER, PARAMETER :: IDF_RADIO16 = 1082
|
||||
INTEGER, PARAMETER :: ID_selarea = 40086
|
||||
INTEGER, PARAMETER :: ID_crsect = 40087
|
||||
INTEGER, PARAMETER :: IDD_selcrsec = 133
|
||||
INTEGER, PARAMETER :: IDD_TEMPLATE003 = 134
|
||||
INTEGER, PARAMETER :: ISS4 = 1083
|
||||
INTEGER, PARAMETER :: ISS5 = 1084
|
||||
INTEGER, PARAMETER :: IDD_LIMITS = 135
|
||||
INTEGER, PARAMETER :: IDF_RADIO17 = 1059
|
||||
INTEGER, PARAMETER :: IDD_lAY = 136
|
||||
INTEGER, PARAMETER :: IDD_TEMPLATE004 = 137
|
||||
INTEGER, PARAMETER :: ISS6 = 1085
|
||||
INTEGER, PARAMETER :: ISS7 = 1086
|
||||
INTEGER, PARAMETER :: ID_EDLAY = 40088
|
||||
INTEGER, PARAMETER :: IDF_RADIO18 = 1062
|
||||
INTEGER, PARAMETER :: ID_ORDR = 40089
|
||||
INTEGER, PARAMETER :: ID_ORDR1 = 40090
|
||||
INTEGER, PARAMETER :: id_chk = 2002
|
||||
INTEGER, PARAMETER :: id_chck = 2001
|
||||
INTEGER, PARAMETER :: idchk = 2003
|
||||
INTEGER, PARAMETER :: ID_SPLITN = 40091
|
||||
INTEGER, PARAMETER :: IDD_DISPLIT = 138
|
||||
INTEGER, PARAMETER :: IDD_DIRSPLIT = 139
|
||||
INTEGER, PARAMETER :: ID_OUTLAY = 40093
|
||||
INTEGER, PARAMETER :: ID_FORM999 = 40092
|
||||
INTEGER, PARAMETER :: ID_g1d = 40094
|
||||
INTEGER, PARAMETER :: IDD_SETOPT = 140
|
||||
INTEGER, PARAMETER :: ID_CCLN = 40095
|
||||
INTEGER, PARAMETER :: ID_CHKCCLN = 40096
|
||||
INTEGER, PARAMETER :: ID_GOUTLIN = 40097
|
||||
INTEGER, PARAMETER :: ID_XOUTLIN = 40098
|
||||
INTEGER, PARAMETER :: IDD_SETMAXMAP = 141
|
||||
INTEGER, PARAMETER :: ID_RESETLIM = 40099
|
||||
INTEGER, PARAMETER :: IDD_MLIMITS = 143
|
||||
INTEGER, PARAMETER :: IDD_VIEWANG = 174
|
||||
INTEGER, PARAMETER :: ID_3DVIEW = 40100
|
||||
INTEGER, PARAMETER :: ID_VIEWANGLE = 40101
|
||||
INTEGER, PARAMETER :: ID_ROTATE = 40106
|
||||
INTEGER, PARAMETER :: ID_RESETRG = 40105
|
||||
INTEGER, PARAMETER :: IDD_CHKOPT = 142
|
||||
INTEGER, PARAMETER :: ID_ITEM103 = 40107
|
||||
INTEGER, PARAMETER :: ID_SECGRP = 40108
|
||||
INTEGER, PARAMETER :: IDD_SETSEL = 144
|
||||
INTEGER, PARAMETER :: ID_SELPR = 40109
|
||||
INTEGER, PARAMETER :: IDD_CHK1DOPT = 145
|
||||
INTEGER, PARAMETER :: ID_VROTATE = 40110
|
||||
INTEGER, PARAMETER :: id_mchck = 40111
|
||||
INTEGER, PARAMETER :: ID_MOVMESH = 40112
|
||||
INTEGER, PARAMETER :: IDD_DIALOG047 = 146
|
||||
INTEGER, PARAMETER :: IDD_DIALOG048 = 147
|
||||
INTEGER, PARAMETER :: ID_SELELTYP = 40113
|
||||
INTEGER, PARAMETER :: IDD_SELELTYP = 149
|
||||
INTEGER, PARAMETER :: ID_OPENGP = 40114
|
||||
INTEGER, PARAMETER :: ID_SAVGP = 40115
|
||||
INTEGER, PARAMETER :: IDF_RADIO19 = 1063
|
||||
INTEGER, PARAMETER :: ID_IGPN = 40116
|
||||
INTEGER, PARAMETER :: ID_IGPC = 40117
|
||||
INTEGER, PARAMETER :: ID_DISPTYP = 40118
|
||||
INTEGER, PARAMETER :: ID_TRANSFORM = 40119
|
||||
INTEGER, PARAMETER :: IDD_TRANSFORM = 151
|
||||
INTEGER, PARAMETER :: ID_deletelm = 40120
|
||||
INTEGER, PARAMETER :: IDD_ELTERR2 = 152
|
||||
INTEGER, PARAMETER :: ID_FORM2D = 40121
|
||||
INTEGER, PARAMETER :: ID_JOINALL = 40122
|
||||
INTEGER, PARAMETER :: ID_MOVGRP = 40123
|
||||
INTEGER, PARAMETER :: ID_CRGRID = 40124
|
||||
INTEGER, PARAMETER :: IDD_GENBLK = 155
|
||||
INTEGER, PARAMETER :: ID_SETUPLEV = 40125
|
||||
INTEGER, PARAMETER :: IDD_SETWRS = 156
|
||||
INTEGER, PARAMETER :: ID_findnode = 40126
|
||||
INTEGER, PARAMETER :: ID_findelem = 40127
|
||||
INTEGER, PARAMETER :: IDD_FORMLINE = 157
|
||||
INTEGER, PARAMETER :: ID_FILLAGAP = 40129
|
||||
INTEGER, PARAMETER :: IDD_MATTYP = 158
|
||||
INTEGER, PARAMETER :: ID_ITEM126 = 40130
|
||||
INTEGER, PARAMETER :: ID_SETTYPLEV = 40131
|
||||
INTEGER, PARAMETER :: IDD_LEVSETTYP = 159
|
||||
INTEGER, PARAMETER :: ID_Complex = 40132
|
||||
INTEGER, PARAMETER :: ID_attach = 40133
|
||||
INTEGER, PARAMETER :: IDD_CHSTYP = 161
|
||||
INTEGER, PARAMETER :: ID_SAVSHP = 40128
|
||||
INTEGER, PARAMETER :: ID_ADDMAP = 40134
|
||||
INTEGER, PARAMETER :: ID_OUTLINFL = 40135
|
||||
INTEGER, PARAMETER :: ID_GETSTRESSFIL = 40136
|
||||
INTEGER, PARAMETER :: IDD_FBED = 162
|
||||
INTEGER, PARAMETER :: IDD_SETYRDT = 163
|
||||
INTEGER, PARAMETER :: ID_SMOOTHMAP = 40137
|
||||
INTEGER, PARAMETER :: IDD_GETINTR = 164
|
||||
INTEGER, PARAMETER :: ID_RVSDIAG = 40138
|
||||
INTEGER, PARAMETER :: ID_TESTOUT = 40139
|
||||
INTEGER, PARAMETER :: ID_LOADELTLD = 40140
|
||||
INTEGER, PARAMETER :: ID_SHOWELTLD = 40141
|
||||
INTEGER, PARAMETER :: IDD_CHOOSEMODEL = 165
|
||||
INTEGER, PARAMETER :: IDD_SETUPELDISP = 166
|
||||
INTEGER, PARAMETER :: ID_SAVELTLD = 40142
|
||||
INTEGER, PARAMETER :: ID_RESHOWELTLD = 40143
|
||||
INTEGER, PARAMETER :: ID_ASSIGNELTLD = 40144
|
||||
INTEGER, PARAMETER :: ID_FILLTR = 40145
|
||||
INTEGER, PARAMETER :: IDD_FTRIAN = 167
|
||||
INTEGER, PARAMETER :: ID_addmeshtr = 40146
|
||||
INTEGER, PARAMETER :: ID_UNDOGEN = 40147
|
||||
INTEGER, PARAMETER :: IDD_GETFL = 168
|
||||
INTEGER, PARAMETER :: ID_DDRAW = 40148
|
||||
INTEGER, PARAMETER :: ID_3DMODEL = 40149
|
||||
INTEGER, PARAMETER :: ID_View = 40033
|
||||
INTEGER, PARAMETER :: IDM_MENU1 = 30002
|
||||
INTEGER, PARAMETER :: ID_COLR = 40003
|
||||
INTEGER, PARAMETER :: ID_CLOSE = 40005
|
||||
INTEGER, PARAMETER :: ID_WIRE = 40139
|
||||
INTEGER, PARAMETER :: ID_HIDDEN = 40007
|
||||
INTEGER, PARAMETER :: ID_UNLIT = 40008
|
||||
INTEGER, PARAMETER :: ID_FLAT = 40140
|
||||
INTEGER, PARAMETER :: ID_GOURAUD = 40141
|
||||
INTEGER, PARAMETER :: ID_ONECOL = 40012
|
||||
INTEGER, PARAMETER :: ID_MULTCOL = 40013
|
||||
INTEGER, PARAMETER :: ID_TOP = 40014
|
||||
INTEGER, PARAMETER :: ID_SIDE = 40015
|
||||
INTEGER, PARAMETER :: ID_SAVEVIEW = 40132
|
||||
INTEGER, PARAMETER :: ID_SAV3D = 40133
|
||||
INTEGER, PARAMETER :: ID_OPENNEW = 40137
|
||||
INTEGER, PARAMETER :: ID_ITEM149 = 40138
|
||||
INTEGER, PARAMETER :: ID_FZOOM = 40142
|
||||
INTEGER, PARAMETER :: IDT_TOOLBAR1 = 30102
|
||||
INTEGER, PARAMETER :: ID_ZOOMIN = 20002
|
||||
INTEGER, PARAMETER :: ID_ZOOMOUT = 20003
|
||||
INTEGER, PARAMETER :: ID_ROTATC = 40107
|
||||
INTEGER, PARAMETER :: ID_ROTATAC = 20013
|
||||
INTEGER, PARAMETER :: ID_UPAR = 40135
|
||||
INTEGER, PARAMETER :: ID_DWNAR = 40136
|
||||
INTEGER, PARAMETER :: IDF_GROUP1 = 1016
|
||||
INTEGER, PARAMETER :: IDF_APPLY = 1039
|
||||
INTEGER, PARAMETER :: IDD_MATERIALS = 150
|
||||
INTEGER, PARAMETER :: IDF_COLOUR = 1005
|
||||
INTEGER, PARAMETER :: IDF_SHINE = 1087
|
||||
INTEGER, PARAMETER :: IDF_GLOSS = 1008
|
||||
INTEGER, PARAMETER :: IDF_SHINE2 = 1009
|
||||
INTEGER, PARAMETER :: IDF_GLOSS2 = 1010
|
||||
INTEGER, PARAMETER :: IDF_RED = 1035
|
||||
INTEGER, PARAMETER :: IDF_GREEN = 1036
|
||||
INTEGER, PARAMETER :: IDF_BLUE = 1038
|
||||
INTEGER, PARAMETER :: IDD_DIALOG002 = 169
|
||||
INTEGER, PARAMETER :: ID_ADDSLOT = 40150
|
||||
INTEGER, PARAMETER :: IDF_CANCEL = 1088
|
||||
INTEGER, PARAMETER :: IDD_ADDSLOT = 171
|
||||
INTEGER, PARAMETER :: ID_ADDBEDLEV = 40151
|
||||
@ -0,0 +1,451 @@
|
||||
SUBROUTINE SUPERT(XPT,YPT,NVERT)
|
||||
|
||||
USE BLKMAP
|
||||
! INCLUDE 'BLK1.COM'
|
||||
REAL*8 XPT(*),YPT(*)
|
||||
|
||||
REAL*8 XMINM,YMINM,X45
|
||||
DATA VDX9/-9.E9/
|
||||
! Find minimum x and y
|
||||
xminm=1.e20
|
||||
yminm=1.e20
|
||||
x45=-1.e20
|
||||
DO J=1,NVERT
|
||||
IF(XPT(J) .GT. VDX9) THEN
|
||||
if(xminm .GT. XPT(j) ) then
|
||||
xminm=XPT(j)
|
||||
end if
|
||||
IF(yminm .GT. YPT(j)) then
|
||||
yminm=YPT(j)
|
||||
endif
|
||||
ENDIF
|
||||
ENDDO
|
||||
! Find max at 45 degrees
|
||||
DO J=1,NVERT
|
||||
IF(XPT(J) .GT. VDX9) THEN
|
||||
X45T=((XPT(J)-XMINM)+(YPT(J)-YMINM))/1.414
|
||||
IF(x45 .LT. X45T) THEN
|
||||
X45=X45T
|
||||
ENDIF
|
||||
ENDIF
|
||||
END DO
|
||||
XPT(NVERT+1)=XMINM-5
|
||||
YPT(NVERT+1)=YMINM-5.
|
||||
XPT(NVERT+2)=XMINM+1.414*X45+10.
|
||||
YPT(NVERT+2)=YMINM-5.
|
||||
XPT(NVERT+3)=XMINM-5.
|
||||
YPT(NVERT+3)=YMINM+1.414*X45+10.
|
||||
NELT=1
|
||||
NOPEL(1,1)=NVERT+1
|
||||
NOPEL(1,2)=NVERT+2
|
||||
NOPEL(1,3)=NVERT+3
|
||||
NVERT=NVERT+3
|
||||
CALL CCENTRE(XPT(NOPEL(1,1)),XPT(NOPEL(1,2)),XPT(NOPEL(1,3)) &
|
||||
&,YPT(NOPEL(1,1)),YPT(NOPEL(1,2)),YPT(NOPEL(1,3)) &
|
||||
&,XCEN(1),YCEN(1),RADS(1))
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
|
||||
SUBROUTINE INSIDCIRC(XPT,YPT,J,N,ISWT)
|
||||
|
||||
! Test for point inside circumcircle
|
||||
|
||||
USE BLKMAP
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
REAL*8 XPT(*),YPT(*)
|
||||
REAL*8 DISQ
|
||||
|
||||
! Get the distance for this element
|
||||
|
||||
DISQ=(XCEN(J)-XPT(N))**2+(YCEN(J)-YPT(N))**2
|
||||
|
||||
! Test against the radius
|
||||
|
||||
IF(DISQ .GT. RADS(J)*RADS(J)) THEN
|
||||
ISWT=0
|
||||
ELSE
|
||||
ISWT=1
|
||||
ENDIF
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
|
||||
SUBROUTINE PROCESS(J,NEDGE,NGAP)
|
||||
|
||||
! Drop triangle and form edge buffers
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
NEDGE=NEDGE+3
|
||||
IEDGE(NEDGE-2,1)=NOPEL(J,1)
|
||||
IEDGE(NEDGE-1,1)=NOPEL(J,2)
|
||||
IEDGE(NEDGE,1) =NOPEL(J,3)
|
||||
IEDGE(NEDGE-2,2)=NOPEL(J,2)
|
||||
IEDGE(NEDGE-1,2)=NOPEL(J,3)
|
||||
IEDGE(NEDGE,2) =NOPEL(J,1)
|
||||
NOPEL(J,1)=0
|
||||
NOPEL(J,2)=0
|
||||
NOPEL(J,3)=0
|
||||
NGAP=NGAP+1
|
||||
IGAP(NGAP)=J
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
|
||||
SUBROUTINE FORMT(XPT,YPT,J,N,NGAP,K,WD)
|
||||
|
||||
! Form the triangle
|
||||
|
||||
USE BLKMAP
|
||||
|
||||
REAL*8 XPT(*),YPT(*)
|
||||
REAL WD(*)
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
IF(NGAP .GT. 0) THEN
|
||||
K=IGAP(NGAP)
|
||||
NGAP=NGAP-1
|
||||
ELSE
|
||||
NELTS=NELTS+1
|
||||
K=NELTS
|
||||
ENDIF
|
||||
NOPEL(K,1)=IEDGE(J,1)
|
||||
NOPEL(K,2)=IEDGE(J,2)
|
||||
NOPEL(K,3)=N
|
||||
|
||||
CALL TESTANG(XPT,YPT,K,WD)
|
||||
|
||||
! Now get circumcircle data
|
||||
|
||||
CALL CCENTRE(XPT(NOPEL(K,1)),XPT(NOPEL(K,2)),XPT(NOPEL(K,3)) &
|
||||
&,YPT(NOPEL(K,1)),YPT(NOPEL(K,2)),YPT(NOPEL(K,3)) &
|
||||
&,XCEN(K),YCEN(K),RADS(K))
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
|
||||
SUBROUTINE CCENTRE(X1,X2,X3,Y1,Y2,Y3,XC,YC,RC)
|
||||
|
||||
! get circumcentre and radius
|
||||
|
||||
REAL*8 X1,Y1,X2,Y2,X3,Y3,A,B,C,D,AF,R1,R2,RC,XC,YC
|
||||
A=X2-X1
|
||||
B=Y2-Y1
|
||||
C=X3-X1
|
||||
D=Y3-Y1
|
||||
AF=2.*(B*C-A*D)
|
||||
R1=(-D*(A**2+B**2) + B*(C**2+D**2))/AF
|
||||
R2=( C*(A**2+B**2) - A*(C**2+D**2))/AF
|
||||
RC=SQRT(R1**2+R2**2)
|
||||
XC=X1+R1
|
||||
YC=Y1+R2
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
|
||||
SUBROUTINE RIDPOINT(NVERT)
|
||||
|
||||
USE BLKMAP
|
||||
|
||||
NCOUNT=0
|
||||
DO N=1,NELTS
|
||||
DO K=1,3
|
||||
IF(NOPEL(N,K) .GT. NVERT-3) THEN
|
||||
DO L=1,3
|
||||
NOPEL(N,L)=0
|
||||
ENDDO
|
||||
GO TO 500
|
||||
ENDIF
|
||||
ENDDO
|
||||
NCOUNT=NCOUNT+1
|
||||
DO K=1,3
|
||||
NOPEL(NCOUNT,K)=NOPEL(N,K)
|
||||
ENDDO
|
||||
XCEN(NCOUNT)=XCEN(N)
|
||||
YCEN(NCOUNT)=YCEN(N)
|
||||
RADS(NCOUNT)=RADS(N)
|
||||
500 CONTINUE
|
||||
ENDDO
|
||||
NELTS=NCOUNT
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE SORTDB(A,NKEY,N)
|
||||
!*********************************** .....SORT.....
|
||||
!-
|
||||
!......SORT IS A SIMPLE SHELL SORT ROUTINE IN DOUBLE PRECISION
|
||||
!-
|
||||
! SHELL SORT
|
||||
SAVE
|
||||
!
|
||||
!IPK JAN94 INTEGER*2 NKEY
|
||||
REAL*8 A(*)
|
||||
INTEGER NKEY(*)
|
||||
|
||||
IF(N.LT.2) RETURN
|
||||
DO 90 J=1,N
|
||||
NKEY(J)=J
|
||||
90 END DO
|
||||
ID = N
|
||||
100 ID = ID / 2
|
||||
110 IB = 1
|
||||
120 GO TO 200
|
||||
130 IB = IB + 1
|
||||
IF( IB .LE. ID ) GO TO 200
|
||||
IF( ID .GT. 1 ) GO TO 100
|
||||
RETURN
|
||||
200 I = IB
|
||||
210 K = I + ID
|
||||
220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250
|
||||
NKT = NKEY(K)
|
||||
NKEY(K) = NKEY(I)
|
||||
J = I
|
||||
230 K = J - ID
|
||||
IF( K .LT. 1 ) GO TO 240
|
||||
IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240
|
||||
NKEY(J) = NKEY(K)
|
||||
J = K
|
||||
GO TO 230
|
||||
240 NKEY(J) = NKT
|
||||
250 I = I + ID
|
||||
IF( I + ID .LE. N ) GO TO 210
|
||||
GO TO 130
|
||||
END
|
||||
|
||||
SUBROUTINE SETEDG(NEDGE)
|
||||
|
||||
USE BLKMAP
|
||||
|
||||
! Setup to form new triangles
|
||||
|
||||
DO J=1,NEDGE
|
||||
IF(J .LT. NEDGE) THEN
|
||||
DO K=J+1,NEDGE
|
||||
IF(IEDGE(K,1) .EQ. IEDGE(J,1)) THEN
|
||||
IF(IEDGE(K,2) .EQ. IEDGE(J,2)) THEN
|
||||
IEDGE(J,1)=0
|
||||
IEDGE(J,2)=0
|
||||
IEDGE(K,1)=0
|
||||
IEDGE(K,2)=0
|
||||
ENDIF
|
||||
ELSEIF(IEDGE(K,1) .EQ. IEDGE(J,2)) THEN
|
||||
IF(IEDGE(K,2) .EQ. IEDGE(J,1)) THEN
|
||||
IEDGE(J,1)=0
|
||||
IEDGE(J,2)=0
|
||||
IEDGE(K,1)=0
|
||||
IEDGE(K,2)=0
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE TESTANG(XPT,YPT,K,WD)
|
||||
|
||||
USE BLKMAP
|
||||
REAL*8 XPT(*),YPT(*)
|
||||
REAL WD(*)
|
||||
DATA PI/3.14159/
|
||||
|
||||
! IF(WD(NOPEL(K,1)) .EQ. WD(NOPEL(K,2)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN
|
||||
! RETURN
|
||||
! ENDIF
|
||||
!
|
||||
IFD=0
|
||||
DO N=1,NELTS
|
||||
IF(N .NE. K) THEN
|
||||
DO J=1,3
|
||||
IF(NOPEL(K,1) .EQ. NOPEL(N,J)) THEN
|
||||
IF(J .GT. 1) THEN
|
||||
IF(NOPEL(K,2) .EQ. NOPEL(N,J-1)) THEN
|
||||
IFD=N
|
||||
ISIDE=J
|
||||
GO TO 400
|
||||
ENDIF
|
||||
ELSE
|
||||
IF(NOPEL(K,2) .EQ. NOPEL(N,3)) THEN
|
||||
IFD=N
|
||||
ISIDE=J
|
||||
GO TO 400
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
400 CONTINUE
|
||||
|
||||
J1=ISIDE+1
|
||||
IF(J1 .GT. 3) J1=1
|
||||
!
|
||||
! IF(WD(NOPEL(K,3)) .EQ. WD(NOPEL(IFD,J1)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN
|
||||
! WRITE(148,'(12I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
||||
! IF(NELTS .GT. 20) WRITE(148,'(12I8)') NOPEL(21,1),NOPEL(21,2),NOPEL(21,3)
|
||||
! NOPEL(IFD,1)=NOPEL(K,3)
|
||||
! NOPEL(IFD,2)=NOPEL(K,1)
|
||||
! NOPEL(IFD,3)=NOPEL(IFD,J1)
|
||||
! NOPEL(K,1)=NOPEL(IFD,3)
|
||||
!
|
||||
! WRITE(148,'(12I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
||||
! IF(NELTS .GT. 20) WRITE(148,'(12I8)') NOPEL(21,1),NOPEL(21,2),NOPEL(21,3)
|
||||
!
|
||||
! CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) &
|
||||
!& ,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) &
|
||||
!& ,XCEN(IFD),YCEN(IFD),RADS(K))
|
||||
! CALL CCENTRE(XPT(NOPEL(K,1)),XPT(NOPEL(K,2)),XPT(NOPEL(K,3)) &
|
||||
!& ,YPT(NOPEL(K,1)),YPT(NOPEL(K,2)),YPT(NOPEL(K,3)) &
|
||||
!& ,XCEN(K),YCEN(K),RADS(K))
|
||||
!
|
||||
! RETURN
|
||||
! ENDIF
|
||||
A1=ATAN2(YPT(NOPEL(K,1))-YPT(NOPEL(K,3)),XPT(NOPEL(K,1))-XPT(NOPEL(K,3)))
|
||||
A2=ATAN2(YPT(NOPEL(K,2))-YPT(NOPEL(K,3)),XPT(NOPEL(K,2))-XPT(NOPEL(K,3)))
|
||||
IF(A1 .LT. 0) A1=A1+2.*PI
|
||||
IF(A2 .LT. 0) A2=A2+2.*PI
|
||||
DIFFA=A2-A1
|
||||
! WRITE(148,*) 'DIFFA',K,DIFFA,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3)
|
||||
IF(DIFFA .LT. 0) DIFFA=DIFFA+PI*2.
|
||||
IF(DIFFA .LT. 2./3.*PI) RETURN
|
||||
|
||||
! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
||||
|
||||
B1=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,2)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,2)))
|
||||
B2=ATAN2(YPT(NOPEL(K, 3))-YPT(NOPEL(K,2)),XPT(NOPEL(K, 3))-XPT(NOPEL(K,2)))
|
||||
IF(B1 .LT. 0) B1=B1+2.*PI
|
||||
IF(B2 .LT. 0) B2=B2+2.*PI
|
||||
|
||||
DIFFB=B2-B1
|
||||
|
||||
! WRITE(148,*) 'DIFFB',DIFFB,B2,B1
|
||||
IF(DIFFB .LT. 0) DIFFB=DIFFB+2.*PI
|
||||
IF(DIFFB .GT. DIFFA) RETURN
|
||||
|
||||
C1=ATAN2(YPT(NOPEL(K, 3))-YPT(NOPEL(K,1)),XPT(NOPEL(K, 3))-XPT(NOPEL(K,1)))
|
||||
C2=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,1)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,1)))
|
||||
IF(C1 .LT. 0) C1=C1+2.*PI
|
||||
IF(C2 .LT. 0) C2=C2+2.*PI
|
||||
|
||||
DIFFC=C2-C1
|
||||
! WRITE(148,*) 'DIFFC',DIFFC,C2,C1
|
||||
IF(DIFFC .LT. 0) DIFFC=DIFFC+2.*PI
|
||||
IF(DIFFC .GT. DIFFA) RETURN
|
||||
|
||||
NOPEL(IFD,1)=NOPEL(K,3)
|
||||
NOPEL(IFD,2)=NOPEL(K,1)
|
||||
NOPEL(IFD,3)=NOPEL(IFD,J1)
|
||||
NOPEL(K,1)=NOPEL(IFD,3)
|
||||
|
||||
! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
||||
|
||||
CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) &
|
||||
&,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) &
|
||||
&,XCEN(IFD),YCEN(IFD),RADS(IFD))
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE TESTTR(XPT,YPT,K,WD)
|
||||
|
||||
USE BLKMAP
|
||||
REAL WD(*)
|
||||
REAL*8 XPT(*),YPT(*)
|
||||
DATA PI/3.14159/
|
||||
|
||||
IF(WD(NOPEL(K,1)) .EQ. WD(NOPEL(K,2)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
|
||||
IFD=0
|
||||
DO N=1,NELTS
|
||||
IF(N .NE. K) THEN
|
||||
DO J=1,3
|
||||
IF(NOPEL(K,2) .EQ. NOPEL(N,J)) THEN
|
||||
IF(J .GT. 1) THEN
|
||||
IF(NOPEL(K,3) .EQ. NOPEL(N,J-1)) THEN
|
||||
IFD=N
|
||||
ISIDE=J
|
||||
GO TO 400
|
||||
ENDIF
|
||||
ELSE
|
||||
IF(NOPEL(K,3) .EQ. NOPEL(N,3)) THEN
|
||||
IFD=N
|
||||
ISIDE=J
|
||||
GO TO 400
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
400 CONTINUE
|
||||
|
||||
WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
||||
write(148,'(9x,6f8.0)')wd(NOPEL(K,1)),wd(NOPEL(K,2)),wd(NOPEL(K,3)),wd(NOPEL(IFD,1)),wd(NOPEL(IFD,2)),wd(NOPEL(IFD,3))
|
||||
J1=ISIDE+1
|
||||
IF(J1 .GT. 3) J1=1
|
||||
WRITE(148,*) J1
|
||||
|
||||
IF(WD(NOPEL(K,1)) .EQ. WD(NOPEL(IFD,J1)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN
|
||||
ITEMP=NOPEL(IFD,J1)
|
||||
NOPEL(IFD,1)=NOPEL(K,3)
|
||||
NOPEL(IFD,2)=NOPEL(K,1)
|
||||
NOPEL(IFD,3)=ITEMP
|
||||
NOPEL(K,1)=NOPEL(IFD,3)
|
||||
|
||||
WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
||||
|
||||
CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) &
|
||||
& ,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) &
|
||||
& ,XCEN(IFD),YCEN(IFD),RADS(IFD))
|
||||
|
||||
RETURN
|
||||
ENDIF
|
||||
A1=ATAN2(YPT(NOPEL(K,2))-YPT(NOPEL(K,1)),XPT(NOPEL(K,2))-XPT(NOPEL(K,1)))
|
||||
A2=ATAN2(YPT(NOPEL(K,3))-YPT(NOPEL(K,1)),XPT(NOPEL(K,3))-XPT(NOPEL(K,1)))
|
||||
IF(A1 .LT. 0) A1=A1+2.*PI
|
||||
IF(A2 .LT. 0) A2=A2+2.*PI
|
||||
DIFFA=A2-A1
|
||||
! WRITE(148,*) 'DIFFA',K,DIFFA,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3)
|
||||
IF(DIFFA .LT. 0) DIFFA=DIFFA+PI*2.
|
||||
IF(DIFFA .LT. 2./3.*PI) RETURN
|
||||
|
||||
B1=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,3)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,3)))
|
||||
B2=ATAN2(YPT(NOPEL(K, 1))-YPT(NOPEL(K,3)),XPT(NOPEL(K, 1))-XPT(NOPEL(K,3)))
|
||||
IF(B1 .LT. 0) B1=B1+2.*PI
|
||||
IF(B2 .LT. 0) B2=B2+2.*PI
|
||||
|
||||
DIFFB=B2-B1
|
||||
|
||||
! WRITE(148,*) 'DIFFB',DIFFB,B2,B1
|
||||
IF(DIFFB .LT. 0) DIFFB=DIFFB+2.*PI
|
||||
IF(DIFFB .GT. DIFFA) RETURN
|
||||
|
||||
C1=ATAN2(YPT(NOPEL(K, 1))-YPT(NOPEL(K,2)),XPT(NOPEL(K, 1))-XPT(NOPEL(K,2)))
|
||||
C2=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,2)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,2)))
|
||||
IF(C1 .LT. 0) C1=C1+2.*PI
|
||||
IF(C2 .LT. 0) C2=C2+2.*PI
|
||||
|
||||
DIFFC=C2-C1
|
||||
! WRITE(148,*) 'DIFFC',DIFFC,C2,C1
|
||||
IF(DIFFC .LT. 0) DIFFC=DIFFC+2.*PI
|
||||
IF(DIFFC .GT. DIFFA) RETURN
|
||||
ITEMP=NOPEL(IFD,J1)
|
||||
NOPEL(IFD,1)=NOPEL(K,1)
|
||||
NOPEL(IFD,2)=NOPEL(K,2)
|
||||
NOPEL(IFD,3)=ITEMP
|
||||
NOPEL(K,2)=NOPEL(IFD,3)
|
||||
|
||||
! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3)
|
||||
|
||||
CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) &
|
||||
&,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) &
|
||||
&,XCEN(IFD),YCEN(IFD),RADS(IFD))
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,265 @@
|
||||
SUBROUTINE TRIANG
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
DATA VOID10/-1.E10/,SPAC/0.0/
|
||||
|
||||
NELTS=0
|
||||
NVERT=MAXPTS
|
||||
NINTV=1
|
||||
CALL TRIANOPT(NINTV,SPAC)
|
||||
|
||||
|
||||
! FIRST WRITE EXISTING MAP TO SCRATCH
|
||||
OPEN(99,FORM='BINARY',STATUS='SCRATCH')
|
||||
|
||||
CALL WRTMAP(99)
|
||||
REWIND 99
|
||||
|
||||
DO N=1,NVERT
|
||||
IF(MOD(N-1,NINTV) .EQ. 0) THEN
|
||||
IMAP(N)=1
|
||||
ELSE
|
||||
IMAP(N)=0
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
IF(SPAC .GT. 0.) THEN
|
||||
DO N=1,NVERT
|
||||
IF(IMAP(N) .EQ. 1) THEN
|
||||
IF(N .LT. NVERT) THEN
|
||||
DO M=N+1,NVERT
|
||||
DISQ=(XMAP(M)-XMAP(N))**2+(YMAP(M)-YMAP(N))**2
|
||||
IF(DISQ .LT. SPAC**2) THEN
|
||||
IMAP(M)=0
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
NN=0
|
||||
DO N=1,NVERT
|
||||
IF(IMAP(N) .GT. 0) THEN
|
||||
NN=NN+1
|
||||
XMAP(NN)=XMAP(N)
|
||||
YMAP(NN)=YMAP(N)
|
||||
IMAP(NN)=IMAP(N)
|
||||
val(nn)=val(n)
|
||||
ENDIF
|
||||
ENDDO
|
||||
NVERT=NN
|
||||
! WRITE(185,*) 'NEW NVERT',NVERT
|
||||
|
||||
|
||||
call WcursorShape(CurHourGlass)
|
||||
CALL DELAUNAY(NVERT)
|
||||
call WcursorShape(CurArrow)
|
||||
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
! Last change: IPK 2 Feb 2003 6:25 pm
|
||||
SUBROUTINE DELAUNAY(NVERT)
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*80 LIND
|
||||
CHARACTER*1 ANS
|
||||
DATA VDX9/-9.E9/,NEDGE/0/
|
||||
|
||||
! Get location of supertriangle
|
||||
|
||||
iprt=0
|
||||
ngap=0
|
||||
YLV=7.5
|
||||
|
||||
|
||||
|
||||
call supert(XMAP,YMAP,NVERT)
|
||||
|
||||
NELTS=1
|
||||
|
||||
NVERTM=NVERT-3
|
||||
IF(NVERT .GT. MAXP) THEN
|
||||
DEALLOCATE (NKEY)
|
||||
ALLOCATE (NKEY(NVERT))
|
||||
NKEY=0
|
||||
ENDIF
|
||||
|
||||
! Sort points into ascending x order
|
||||
|
||||
CALL SORTDB(XMAP,NKEY,NVERTM)
|
||||
|
||||
! Loop on the vertices
|
||||
|
||||
DO NN=1,NVERT-3
|
||||
|
||||
! IF(MOD(NN,5) .EQ. 0) WRITE(185,*) 'LOOP',NN
|
||||
if(mod(NN,2500) .eq. 0) then
|
||||
WRITE(90,*) NN,' points processed'
|
||||
ylv=ylv-0.3
|
||||
if(ylv .lt. 0.1) then
|
||||
ylv=7.9
|
||||
call clscrn
|
||||
endif
|
||||
write(lind,6010) NN
|
||||
6010 format(i8,' points processed')
|
||||
call symbl &
|
||||
& (1.1,ylv,0.20,LIND,0.0,80)
|
||||
endif
|
||||
|
||||
! process next point
|
||||
|
||||
N=NKEY(NN)
|
||||
|
||||
! Skip out if inactive point
|
||||
IF(N .EQ. 0) GO TO 500
|
||||
IF(IMAP(N) .EQ. 0) GO TO 500
|
||||
IF(XMAP(N) .LT. VDX9) GO TO 500
|
||||
IF(VAL(N) .LT. -9000.) GO TO 500
|
||||
! IF(NN .GT. 1700. .AND. MOD(NN,5) .EQ. 0) WRITE(185,*) 'N',N,IMAP(N),XMAP(N),VAL(N)
|
||||
|
||||
! WRITE(45,*) NN,N,NVERT,XMAP(N),YMAP(N)
|
||||
IF(NN .LT. NVERTM) THEN
|
||||
DO KK=NN+1,NVERTM
|
||||
K=NKEY(KK)
|
||||
! IF(NN .GT. 1700) WRITE(185,*) 'NKEY',K,KK
|
||||
|
||||
IF(K .NE. 0) THEN
|
||||
IF(XMAP(N) .EQ. XMAP(K)) THEN
|
||||
IF(YMAP(N) .EQ. YMAP(K)) THEN
|
||||
WRITE(45,*) 'IDENT',N,K
|
||||
NKEY(KK)=0
|
||||
ENDIF
|
||||
ELSE
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ENDIF
|
||||
200 CONTINUE
|
||||
ENDDO
|
||||
ENDIF
|
||||
|
||||
! Set edge buffers to zero
|
||||
! IF(NN .GT. 1700 .AND. MOD(NN,5) .EQ. 0) WRITE(185,*) 'AFTER 200 NEDGE',NEDGE
|
||||
|
||||
IF(NEDGE .GT. 0) THEN
|
||||
DO J=1,NEDGE
|
||||
IEDGE(J,1)=0
|
||||
IEDGE(J,2)=0
|
||||
END DO
|
||||
ELSE
|
||||
DO J=1,100
|
||||
IEDGE(J,1)=0
|
||||
IEDGE(J,2)=0
|
||||
END DO
|
||||
ENDIF
|
||||
NEDGE=0
|
||||
|
||||
! test for point in circumcircle
|
||||
|
||||
DO J=1,NELTS
|
||||
CALL INSIDCIRC(XMAP,YMAP,J,N,ISWT)
|
||||
|
||||
! If inside process edges
|
||||
|
||||
IF(ISWT .EQ. 1) THEN
|
||||
CALL PROCESS(J,NEDGE,NGAP)
|
||||
ENDIF
|
||||
END DO
|
||||
|
||||
! Setup to form new triangles
|
||||
|
||||
CALL SETEDG(NEDGE)
|
||||
|
||||
! Now form triangles as needed
|
||||
|
||||
DO J=1,NEDGE
|
||||
IF(IEDGE(J,1) .NE. 0) THEN
|
||||
CALL FORMT(XMAP,YMAP,J,N,NGAP,KK,WD)
|
||||
ENDIF
|
||||
END DO
|
||||
|
||||
NEDGE=0
|
||||
if(iprt .eq. 0) go to 500
|
||||
DO J=1,NELTS
|
||||
IF(NOPEL(J,1) .GT. 0) THEN
|
||||
WRITE(3,'(2i5,2i10,19x,''1'')') J,(NOPEL(J,K),K=1,3)
|
||||
ENDIF
|
||||
END DO
|
||||
|
||||
|
||||
IF(NN .EQ. 1) THEN
|
||||
write(41,'('' 9999'')')
|
||||
do j=1,nvert
|
||||
write(41,'(i10,2f20.4,F10.3)') j,XMAP(j),YMAP(j),VAL(J)
|
||||
enddo
|
||||
write(41,'('' 9999'')')
|
||||
write(41,'('' 9999'')')
|
||||
write(41,'('' 0 NENTRY'')')
|
||||
write(41,'('' 0 NCLM'')')
|
||||
WRITE(41,'(''ENDDATA'')')
|
||||
ENDIF
|
||||
500 continue
|
||||
END DO
|
||||
|
||||
! Get rid of elements from super point
|
||||
|
||||
CALL RIDPOINT(NVERT)
|
||||
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
|
||||
SUBROUTINE TRIANOPT(NINTV,SPAC)
|
||||
|
||||
USE WINTERACTER
|
||||
include 'd.inc'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
INTEGER :: NINTV
|
||||
INTEGER :: IERR
|
||||
REAL :: SPAC
|
||||
CHARACTER*1 :: IFLAG
|
||||
|
||||
call wdialogload(IDD_TRIAN)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_TRIAN)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,NINTV)
|
||||
CALL WDialogPutReal(IDF_REAL1,SPAC)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER1,NINTV)
|
||||
IF(NINTV .EQ. 0) NINTV=1
|
||||
CALL WDialogGetREAL(IDF_REAL1,SPAC)
|
||||
ELSE
|
||||
SPAC=0.0
|
||||
NINTV=1
|
||||
ENDIF
|
||||
RETURN
|
||||
enddo
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,45 @@
|
||||
SUBROUTINE DEMOS
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
COMMON /RECOD/ IRECD,TSPC
|
||||
COMMON /PAGE/ XL,XH,YL,YH
|
||||
common /cols/ ibakk,icolr,iblkk
|
||||
|
||||
CHARACTER*255 FNAME
|
||||
CHARACTER*40 LIND,dlin
|
||||
|
||||
xl=0.
|
||||
yl=0.
|
||||
xh=HSIZE
|
||||
yh=8.0
|
||||
ibakk=8
|
||||
icolr=11
|
||||
iblkk=14
|
||||
OPEN(75,FILE='DINFO.OUT',FORM='FORMATTED',STATUS='UNKNOWN')
|
||||
|
||||
WRITE(75,*) 'IN DEMOS'
|
||||
FNAME='RECORD.REC'
|
||||
OPEN(9,FILE='PALMIS.MAP',STATUS='OLD', FORM='FORMATTED')
|
||||
IMP=9
|
||||
IIN=0
|
||||
|
||||
OPEN(91,FILE=FNAME,STATUS='OLD')
|
||||
CALL RBLUE
|
||||
nmess=45
|
||||
call getfpn(tspc)
|
||||
! WRITE(LIND,6005)
|
||||
! 6005 FORMAT('Enter time interval between events')
|
||||
! call symbl(1.1,3.5,0.25,LIND,0.0,80)
|
||||
! ndig=32
|
||||
! CALL GTFPNX(TSPC,NDEC,NDIG,5.0,6.0)
|
||||
! write(75,'(a)') 'demos-lind',lind
|
||||
! call get_label(lind,dlin)
|
||||
! write(75,'(a)') 'label',dlin
|
||||
! read(dlin,'(f20.2)') tspc
|
||||
IRECD=2
|
||||
WRITE(75,*) 'tspc', tspc
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,306 @@
|
||||
SUBROUTINE dograph(noptt,icurrwin)
|
||||
!!!!!! (XVALUES,YVALUES,NVALUES,XMIN,XMAX,VALMIN,YMAX)
|
||||
!
|
||||
! Graph plotting code generated by GraphEd at 21:20 on 11 Apr 1999.
|
||||
!
|
||||
! XVALUES = Array of X values to plot
|
||||
! YVALUES = Array of Y values to plot
|
||||
! NVALUES = Number of values
|
||||
! TIMMIN = Min X
|
||||
! TIMMAX = Max X
|
||||
! VALMIN = Min Y
|
||||
! VALMAX = Max Y
|
||||
!
|
||||
!
|
||||
! USE module containing routine definitions and symbolic names.
|
||||
!
|
||||
USE WINTERACTER
|
||||
!
|
||||
!
|
||||
! Common arguments.
|
||||
!
|
||||
CHARACTER*6 DESCR
|
||||
CHARACTER*48 XLABEL, YYLABEL
|
||||
CHARACTER*48 PTITL
|
||||
CHARACTER*4 AXTYPE, YAXTYPE
|
||||
COMMON /XYGRPH/ XVALUES(10000,10),YVALUES(10000,10),TIMMIN,VALMIN,TIMMAX,VALMAX,NVALUES,NSETS,LINPROP(10)
|
||||
COMMON /PAXC/ PTITL,AXTYPE,XLABEL,YAXTYPE,YYLABEL
|
||||
|
||||
COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10),DESCR(10)
|
||||
|
||||
|
||||
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||||
CHARACTER*80 TITLE
|
||||
CHARACTER*24 HLABL
|
||||
character*40 mpnam
|
||||
CHARACTER*1 ALABL(10)
|
||||
COMMON /BLKA1/ TITLE,HLABL,ALABL,MPNAM
|
||||
|
||||
character*8 labl
|
||||
character*72 data
|
||||
CHARACTER*20 TITL1,TITL4
|
||||
CHARACTER*64 TITL2,TITL3
|
||||
COMMON /BLKA11/ TITL1,TITL2,TITL3,TITL4&
|
||||
, labl(400),data(400)
|
||||
|
||||
!IPK JAN03
|
||||
|
||||
INTEGER IHANDLE1
|
||||
|
||||
! REAL, INTENT(IN), DIMENSION(NVALUES) :: XVALUES
|
||||
! REAL, INTENT(IN), DIMENSION(NVALUES) :: YVALUES
|
||||
! REAL TIMMIN,TIMMAX,VALMIN,VALMAX
|
||||
! INTEGER NVALUES
|
||||
|
||||
|
||||
nopt=abs(noptt)
|
||||
WRITE(90,*) 'IN DOGRAPH',NOPT,icurrwin
|
||||
|
||||
! nopt = 999 skip to draw current page
|
||||
! nopt = -2 skip to draw current page
|
||||
! nopt = 2 draw time plots
|
||||
! nopt = 4 from brkarea
|
||||
|
||||
if(nopt .eq. 999) go to 300
|
||||
IF(NOPTT .EQ. -2) GO TO 300
|
||||
if(nopt .ne. 3) then
|
||||
|
||||
! do this only for nopt = 4 or nopt = 2 first search for empty window
|
||||
|
||||
do n=1,nwindws
|
||||
if(iwndws(n) .eq. 0) then
|
||||
icurrwin=n
|
||||
go to 290
|
||||
endif
|
||||
enddo
|
||||
|
||||
! or increase window count
|
||||
|
||||
|
||||
nwindws=nwindws+1
|
||||
if(nwindws .eq. 10) then
|
||||
call WMessageBox(0,3,1,'Warning 10 windows now open','WARNING')
|
||||
IF(WInfoDialog(4) .eq. 1) then
|
||||
ENDIF
|
||||
endif
|
||||
icurrwin=nwindws
|
||||
290 continue
|
||||
else
|
||||
|
||||
! do this for nopt = 3 ie
|
||||
! draw the bitmap in icurrwin and return
|
||||
|
||||
call backp(2,icurrwin)
|
||||
return
|
||||
endif
|
||||
!ipk jan03
|
||||
|
||||
! if no window defined yet open a child window for it and give it a handle
|
||||
|
||||
IF(Iwndws(icurrwin) .EQ. 0) THEN
|
||||
CALL WindowOpenChild(IHANDLE1,FLAGS=SysMenuOn+MinButton+MaxButton, &
|
||||
TITLE='Cross-Section')
|
||||
Iwndws(icurrwin)=ihandle1
|
||||
ENDIF
|
||||
|
||||
! setup to draw bitmap in icurrwin
|
||||
|
||||
CALL BACKP(1,icurrwin)
|
||||
300 continue
|
||||
!
|
||||
! Start new presentation graphics plot
|
||||
!
|
||||
! CALL IPgNewGraph(NSETS,NVALUES,' ',' ','X')
|
||||
CALL IPgNewPlot(6,nsets,nvalues)
|
||||
!
|
||||
! Set Clipping Rectangle
|
||||
!
|
||||
CALL IPgClipRectangle('G')
|
||||
!
|
||||
! Set style for each data set
|
||||
!
|
||||
! CALL IPgStyle( 1, 0, 0, 0,223, 96)
|
||||
! CALL IPgStyle( 2, 1, 0, 0, 31,128)
|
||||
! CALL IPgStyle( 3, 2, 0, 0,159,160)
|
||||
! CALL IPgStyle( 4, 3, 0, 0, 95,192)
|
||||
! CALL IPgStyle( 5, 5, 0, 0,223,224)
|
||||
|
||||
ICL=255+256*255+256*256*255
|
||||
IF(LINPROP(1) .EQ. 0) THEN
|
||||
CALL IPgStyle( 1, 0, 0, 0,223,195)
|
||||
ELSE
|
||||
CALL IPgStyle( 1, 0, 3, 0,ICL,195)
|
||||
ENDIF
|
||||
IF(LINPROP(2) .EQ. 0) THEN
|
||||
CALL IPgStyle( 2, 1, 0, 0,33405,33405)
|
||||
ELSE
|
||||
CALL IPgStyle( 2, 1, 3, 0,ICL,33405)
|
||||
ENDIF
|
||||
IF(LINPROP(3) .EQ. 0) THEN
|
||||
CALL IPgStyle( 3, 2, 0, 0,8551680,8551680)
|
||||
ELSE
|
||||
CALL IPgStyle( 3, 2, 3, 0,ICL,8551680)
|
||||
ENDIF
|
||||
IF(LINPROP(4) .EQ. 0) THEN
|
||||
CALL IPgStyle( 4, 3, 0, 0,65415,65415)
|
||||
ELSE
|
||||
CALL IPgStyle( 4, 3, 3, 0,ICL,65415)
|
||||
ENDIF
|
||||
IF(LINPROP(5) .EQ. 0) THEN
|
||||
CALL IPgStyle( 5, 5, 0, 0,0,0)
|
||||
ELSE
|
||||
CALL IPgStyle( 5, 5, 3, 0,ICL,0)
|
||||
ENDIF
|
||||
!
|
||||
! Set marker number for data sets not using default marker
|
||||
!
|
||||
CALL IPgMarker( 1, 1)
|
||||
CALL IPgMarker( 2, 2)
|
||||
CALL IPgMarker( 3, 2)
|
||||
CALL IPgMarker( 4, 2)
|
||||
CALL IPgMarker( 5, 2)
|
||||
!
|
||||
! Set units for plot
|
||||
!
|
||||
CALL IPgUnits( TIMMIN, VALMIN, TIMMAX, VALMAX)
|
||||
!
|
||||
! Set presentation graphics area
|
||||
!
|
||||
CALL IPgArea( .150, .100, .900, .800)
|
||||
!
|
||||
! Draw main title
|
||||
!
|
||||
CALL IGrCharSet('H')
|
||||
CALL IGrCharFont( 1)
|
||||
CALL IGrCharSpacing('F')
|
||||
CALL IGrCharSize( 0.67, 0.67)
|
||||
CALL IGrColourN( 208)
|
||||
|
||||
CALL IPgTitle('CROSS-SECTION','C')
|
||||
!
|
||||
! Label bottom X axis
|
||||
!
|
||||
CALL IPgXLabelPos( .70)
|
||||
CALL IPgXLabel('Section Dimension','C')
|
||||
|
||||
!
|
||||
! Label left Y axis
|
||||
!
|
||||
CALL IPgYLabelPos( .80)
|
||||
|
||||
CALL IPgYLabelLeft('Elevation','C9')
|
||||
!
|
||||
! Draw axes
|
||||
!
|
||||
CALL IGrColourN( 208)
|
||||
CALL IPgAxes(TIMMIN,VALMIN)
|
||||
!
|
||||
! Adjust tick position for X Axes
|
||||
!
|
||||
CALL IPgXTickPos(VALMIN,VALMAX)
|
||||
!DEC09 CALL IPgXTickPos(1,TIMMIN)
|
||||
!
|
||||
! Scale for bottom X Axis
|
||||
!
|
||||
CALL IPgXUserScale((/0.0/),0)
|
||||
CALL IPgXScaleAngle( .00, .00)
|
||||
CALL IPgXScalePos( .38)
|
||||
CALL IPgXScale('NT')
|
||||
!
|
||||
! Adjust tick position for Y Axes
|
||||
!
|
||||
CALL IPgYTickPos( TIMMIN , TIMMAX )
|
||||
!DEC09 CALL IPgYTickPos( 1,VALMIN)
|
||||
!DEC09 ISIDE=1
|
||||
!DEC09 CALL IPgYTickPos( ISIDE,TIMMAX)
|
||||
! Scale for left Y Axis
|
||||
!
|
||||
CALL IPgYUserScale((/0.0/),0)
|
||||
CALL IPgYScaleAngle( .00, .00)
|
||||
CALL IPgYScalePos( 1.50)
|
||||
CALL IPgYScaleLeft('NT')
|
||||
!
|
||||
! Draw graph.
|
||||
!
|
||||
DO ISET = 1,NSETS
|
||||
|
||||
CALL IPgXYPairs(XVALUES(1,iset),YVALUES(1,ISET))
|
||||
|
||||
END DO
|
||||
|
||||
call IPgKeyAll(DESCR,' ')
|
||||
|
||||
! CALL SYMBL(0.1,7.60,0.18,TITL2,0.0,+64)
|
||||
|
||||
|
||||
if(nopt .ne. 999 .and. NOPTT .NE. -2) CALL BACKP(2,icurrwin)
|
||||
|
||||
RETURN
|
||||
END SUBROUTINE dograph
|
||||
|
||||
|
||||
SUBROUTINE BACKP(IENT,icurrwin)
|
||||
|
||||
! ient = 1 means either set to draw bitmap or create window for plotting ihandle(icurrwin)
|
||||
! then select to draw bitmap
|
||||
! ient = 2 means select drawing of window and putting the bitmap into it, folloed by return
|
||||
! to main window
|
||||
! ient = 3 means destroy slected window
|
||||
|
||||
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'D.INC'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
INTEGER :: iw,ih,ihandle,ient,icurrwin,ihandlem
|
||||
common /handP/ ihandle(10)
|
||||
! write(128,*) 'ient',ient,icurrwin,ihandle(icurrwin)
|
||||
if(ient .eq. 1) then
|
||||
iw=WinfoWindow(WindowWidth)
|
||||
ih=WinfoWindow(WindowHeight)
|
||||
IF(IHANDLE(icurrwin) .EQ. 0) THEN
|
||||
call WBitmapCreate(ihandle(icurrwin),iw,ih)
|
||||
call IGrSelect(DrawBitmap,ihandle(icurrwin))
|
||||
ELSE
|
||||
call IGrSelect(DrawBitmap,ihandle(icurrwin))
|
||||
ENDIF
|
||||
return
|
||||
elseif(ient .eq. 2) then
|
||||
call IGrSelect(DrawWin)
|
||||
call WBitmapPut(ihandle(icurrwin),0,1)
|
||||
!!! call WBitmapDestroy(ihandle)
|
||||
ihandlem=0
|
||||
call WindowSelect(ihandlem)
|
||||
else
|
||||
CALL WBitmapDestroy(ihandle(icurrwin))
|
||||
|
||||
endif
|
||||
return
|
||||
end
|
||||
|
||||
SUBROUTINE DOPLOT(IMZ)
|
||||
|
||||
|
||||
COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10)
|
||||
|
||||
if(nwindws .gt. 0) then
|
||||
do n=1,nwindws
|
||||
if(iscrns(n) .eq. 3) then
|
||||
call WindowSelect(iwndws(n))
|
||||
call clscrn
|
||||
call dograph(3,n)
|
||||
endif
|
||||
enddo
|
||||
call WindowSelect(0)
|
||||
endif
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,12 @@
|
||||
|
||||
SUBROUTINE PLOTSV(I)
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE NDPLSV
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE SETD(I)
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,84 @@
|
||||
SUBROUTINE DUMPBIN(KKK,KENT)
|
||||
USE BLK1MOD
|
||||
USE BLKMAP
|
||||
CHARACTER*11 FNAME
|
||||
ISLP=0
|
||||
IPRT=1
|
||||
IPNN=1
|
||||
IPEN=1
|
||||
IPO=1
|
||||
IRO=1
|
||||
IPP=0
|
||||
IRFN=0
|
||||
IGEN=0
|
||||
NXZL=0
|
||||
NITST=1
|
||||
ISCTXT=0
|
||||
IFILL=0
|
||||
IALTGM=1
|
||||
NLAYD=0
|
||||
HORIZ=10.
|
||||
VERT=8.
|
||||
XSALE=0.
|
||||
YSALE=0.
|
||||
XFACT=0.
|
||||
YFACT=0.
|
||||
AR=0.
|
||||
ANG=0.
|
||||
xadded=0.
|
||||
yadded=0.
|
||||
ntempin=0
|
||||
|
||||
WRITE(FNAME,6001) KKK
|
||||
6001 FORMAT('DMP-',I3.3,'.RST')
|
||||
OPEN(240,FILE=FNAME,STATUS='UNKNOWN',FORM='UNFORMATTED')
|
||||
IF(KENT .EQ. 0) THEN
|
||||
DO J=1,NELTS
|
||||
DO K=1,3
|
||||
NOPSTO(J,2*K-1,1)=NOPEL(J,K)
|
||||
NOPSTO(J,2*K,1)=0
|
||||
ENDDO
|
||||
NOPSTO(J,7,1)=0
|
||||
NOPSTO(J,8,1)=0
|
||||
IMATSTO(J,1)=1
|
||||
THTASTO(J,1)=0.
|
||||
ENDDO
|
||||
ELSE
|
||||
DO J=1,NE
|
||||
DO K=1,6
|
||||
NOPSTO(J,K,1)=NOP(J,K)
|
||||
ENDDO
|
||||
NOPSTO(J,7,1)=0
|
||||
NOPSTO(J,8,1)=0
|
||||
if(nop(j,1) .gt. 0) then
|
||||
IMATSTO(J,1)=1
|
||||
else
|
||||
IMATSTO(J,1)=0
|
||||
endif
|
||||
THTASTO(J,1)=0.
|
||||
ENDDO
|
||||
NELTS=NE
|
||||
ENDIF
|
||||
NPSTO(1)=NP
|
||||
NESTO(1)=NELTS
|
||||
NLST=0
|
||||
NENTRY=0
|
||||
NLAYD=0
|
||||
NCLM=0
|
||||
WRITE(240) TITLE,NP,NELTS
|
||||
WRITE(240) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
||||
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
||||
WRITE(240) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG
|
||||
WRITE(240) ((NOPSTO(J,K,1),K=1,8),IMATSTO(J,1),THTASTO(J,1),J=1,NELTS)
|
||||
WRITE(240) &
|
||||
& (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), &
|
||||
& WIDBS(J),SSO(J),BS1(J),J=1,NP)
|
||||
!IPK MAR02 add BS1
|
||||
!IPK JUL98 + (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J)
|
||||
WRITE(240) NLST
|
||||
!IPK JAN01
|
||||
WRITE(240) NENTRY,NLAYD,NCLM
|
||||
CLOSE(240)
|
||||
RETURN
|
||||
END
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,245 @@
|
||||
!----------------------------------------------------------------elevint
|
||||
subroutine elevint(XX,YY,soln)
|
||||
!----------------------------------------------------------------------c
|
||||
! purpose: c
|
||||
! To interpolate elevation from map data. c
|
||||
!----------------------------------------------------------------------c
|
||||
! Input data: c
|
||||
! (XX, YY) -- a coordinate
|
||||
!----------------------------------------------------------------------c
|
||||
! Output data: c
|
||||
! soln -- elevation value c
|
||||
!----------------------------------------------------------------------c
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
|
||||
INTEGER LISTM,NLIST
|
||||
DIMENSION NLIST(200),ADIST(200)
|
||||
DIMENSION LISTM(1000),listt(60,4),nlf(4),icomp(4),xnear(4)
|
||||
! common /mapc/imap(maxpl)
|
||||
!
|
||||
! Establish size for range
|
||||
!
|
||||
JS=1
|
||||
K=0
|
||||
KPT=0
|
||||
DO 120 J=1,MAXPTS
|
||||
!
|
||||
! Determine how long each line is
|
||||
!
|
||||
MLEN=J-JS
|
||||
! print *,XMAP(J),VDX,MAXPTS,MLEN,J,JS
|
||||
IF(CMAP(J,1) .LT. VDX) THEN
|
||||
!
|
||||
! Now check it.
|
||||
!
|
||||
K=K+1
|
||||
IF(MLEN .GT. 1) THEN
|
||||
! LTP=LINTYP(K)
|
||||
DO 110 M=1,MLEN
|
||||
IF(VAL(JS+M-1) .GT. -9000.) THEN
|
||||
KPT=KPT+1
|
||||
ENDIF
|
||||
110 CONTINUE
|
||||
ENDIF
|
||||
NMAP=J
|
||||
IF(MLEN .EQ. 0) GO TO 130
|
||||
JS=J+1
|
||||
go to 120
|
||||
ENDIF
|
||||
cxcur=xmap(j)
|
||||
cycur=ymap(j)
|
||||
120 END DO
|
||||
130 CONTINUE
|
||||
!
|
||||
! Estimate areal density to get 100 points
|
||||
!
|
||||
ADEN=AMAP*40./(FLOAT(KPT)*TXSCAL**2)
|
||||
!
|
||||
! Find square coverage
|
||||
!
|
||||
XNEARS=SQRT(ADEN)
|
||||
xnearo=xnears
|
||||
!
|
||||
! initialize range
|
||||
!
|
||||
ict=0
|
||||
xnears=xnearo
|
||||
do nang=1,4
|
||||
XNEAR(nang)=XNEARO
|
||||
icomp(nang)=0
|
||||
enddo
|
||||
!
|
||||
! set imap to zero to start or -1 if no value
|
||||
!
|
||||
220 continue
|
||||
do n=1,nmap
|
||||
if(cmap(n,1) .lt. vdx) then
|
||||
imap(n)=-1
|
||||
elseif(val(n) .lt. -9000.) then
|
||||
imap(n)=-1
|
||||
else
|
||||
imap(n)=0
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
! initialize list and completeness test
|
||||
!
|
||||
do nang=1,4
|
||||
icomp(nang)=0
|
||||
do n=1,50
|
||||
listt(n,nang)=0
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! start processing
|
||||
!
|
||||
280 continue
|
||||
!
|
||||
! check for completeness intialize counter
|
||||
!
|
||||
do nang=1,4
|
||||
if(icomp(nang) .eq. 0) then
|
||||
nlf(nang)=0
|
||||
else
|
||||
ict=ict+1
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
! if ict = 4 we are done
|
||||
!
|
||||
if(ict .lt. 4) then
|
||||
!
|
||||
! loop through map points
|
||||
!
|
||||
DO 300 N=1,NMAP
|
||||
!
|
||||
! skip if no useful value
|
||||
!
|
||||
if(imap(n) .eq. -1) go to 300
|
||||
!
|
||||
! use nang if we have been through before
|
||||
!
|
||||
if(imap(n) .gt. 0) then
|
||||
nang=imap(n)
|
||||
!
|
||||
! skip to end if done
|
||||
!
|
||||
if(icomp(nang) .eq. 1) then
|
||||
go to 300
|
||||
endif
|
||||
!
|
||||
! otherwise check range skipping out if out of range
|
||||
!
|
||||
d1=cmap(n,1)-XX
|
||||
d2=cmap(n,2)-YY
|
||||
IF(ABS(D1) .GT. XNEAR(NANG)) THEN
|
||||
IMAP(N)=-1
|
||||
GO TO 300
|
||||
ELSEIF(ABS(D2) .GT. XNEAR(NANG)) THEN
|
||||
IMAP(N)=-1
|
||||
GO TO 300
|
||||
ENDIF
|
||||
!
|
||||
! process new point checking range and setting direction
|
||||
!
|
||||
else
|
||||
d1=cmap(n,1)-XX
|
||||
d2=cmap(n,2)-YY
|
||||
IF(ABS(D1) .LT. XNEAR(1)) THEN
|
||||
IF(ABS(D2) .LT. XNEAR(1)) THEN
|
||||
if(d1 .lt. 0) then
|
||||
if(d2 .lt. 0) then
|
||||
imap(n)=3
|
||||
nang=3
|
||||
else
|
||||
imap(n)=2
|
||||
nang=2
|
||||
endif
|
||||
elseif(d2 .lt. 0) then
|
||||
imap(n)=4
|
||||
nang=4
|
||||
else
|
||||
imap(n)=1
|
||||
nang=1
|
||||
endif
|
||||
!
|
||||
! set to skip out if out of range
|
||||
!
|
||||
ELSE
|
||||
imap(n)=-1
|
||||
go to 300
|
||||
ENDIF
|
||||
ELSE
|
||||
imap(n)=-1
|
||||
go to 300
|
||||
ENDIF
|
||||
endif
|
||||
!
|
||||
! save value if total less then 50
|
||||
!
|
||||
NLF(NANG)=NLF(NANG)+1
|
||||
IF(NLF(NANG) .LT. 51) THEN
|
||||
LISTT(NLF(NANG),NANG)=N
|
||||
ENDIF
|
||||
300 CONTINUE
|
||||
!
|
||||
! now reset range if we need to
|
||||
!
|
||||
ictz=0
|
||||
do nang=1,4
|
||||
if(nlf(nang) .gt. 50) then
|
||||
rat=sqrt(45./nlf(nang))
|
||||
if(rat .lt. 0.2) rat=0.2
|
||||
xnear(nang)=xnear(nang)*rat
|
||||
elseif(nlf(nang) .eq. 0) then
|
||||
if(xnear(nang) .eq. xnears) then
|
||||
ictz=ictz+1
|
||||
else
|
||||
icomp(nang)=1
|
||||
endif
|
||||
else
|
||||
icomp(nang)=1
|
||||
endif
|
||||
enddo
|
||||
if(ictz .gt. 1) then
|
||||
do nang=1,4
|
||||
xnear(nang)=xnear(nang)*2.
|
||||
xnears=xnears*2.
|
||||
enddo
|
||||
if(xnear(1) .lt. 4.) then
|
||||
go to 220
|
||||
endif
|
||||
endif
|
||||
!
|
||||
! go back and try again
|
||||
!
|
||||
go to 280
|
||||
endif
|
||||
!
|
||||
! finished now compact list
|
||||
!
|
||||
nlg=0
|
||||
do nang=1,4
|
||||
nlim=nlf(nang)
|
||||
if(nlim .eq. 0) then
|
||||
nlim=50
|
||||
endif
|
||||
do nlgg=1,nlim
|
||||
if(listt(nlgg,nang) .gt. 0) then
|
||||
nlg=nlg+1
|
||||
listm(nlg)=listt(nlgg,nang)
|
||||
endif
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
!-----perform interpolation
|
||||
!
|
||||
SOLN=-9999.0
|
||||
CALL GRIDIN(XX,YY,SOLN,LISTM,NLG)
|
||||
return
|
||||
END
|
||||
@ -0,0 +1,426 @@
|
||||
Subroutine EltDisp(nsw)
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
!
|
||||
include 'd.inc'
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
|
||||
!
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
INTEGER :: N,IBOX,NN,NOOP(16),NEAC(8)
|
||||
INTEGER :: IERR
|
||||
CHARACTER*1 :: IFLAG
|
||||
|
||||
DATA N/1/
|
||||
ims=0
|
||||
100 continue
|
||||
call wdialogload(IDD_ELTDATA)
|
||||
ierr=infoerror(1)
|
||||
IF(NSW .NE. 0) N=ABS(NSW)
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,N)
|
||||
NN=N
|
||||
DO N1=1,8
|
||||
NOOP(N1)=NOP(N,N1)
|
||||
NOOP(N1+8)=NOP(N,N1)
|
||||
ENDDO
|
||||
IMAAT=IMAT(N)
|
||||
120 CONTINUE
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,N)
|
||||
CALL WDialogPutInteger(IDF_INTEGER2,NOOP(1))
|
||||
CALL WDialogPutInteger(IDF_INTEGER3,NOOP(2))
|
||||
CALL WDialogPutInteger(IDF_INTEGER4,NOOP(3))
|
||||
CALL WDialogPutInteger(IDF_INTEGER5,NOOP(4))
|
||||
CALL WDialogPutInteger(IDF_INTEGER6,NOOP(5))
|
||||
CALL WDialogPutInteger(IDF_INTEGER7,NOOP(6))
|
||||
CALL WDialogPutInteger(IDF_INTEGER8,NOOP(7))
|
||||
CALL WDialogPutInteger(IDF_INTEGER9,NOOP(8))
|
||||
CALL WDialogPutInteger(IDF_INTEGER10,IMAAT)
|
||||
CALL WDialogSelect(IDD_ELTDATA)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modeless)
|
||||
ierr=infoerror(1)
|
||||
|
||||
if(ims .eq. 1) go to 200
|
||||
150 CONTINUE
|
||||
IF(NSW .LE. 0) THEN
|
||||
call wdialogload(IDD_SELELT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,N)
|
||||
|
||||
CALL WDialogSelect(IDD_SELELT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,ModaL)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
ims=1
|
||||
go to 100
|
||||
endif
|
||||
!ipksep02
|
||||
ims=1
|
||||
go to 100
|
||||
enddo
|
||||
ELSE
|
||||
call wdialogload(IDD_ELTERR)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,N)
|
||||
|
||||
CALL WDialogSelect(IDD_ELTERR)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,ModaL)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
ims=1
|
||||
go to 100
|
||||
endif
|
||||
!ipk sep02
|
||||
ims=1
|
||||
go to 100
|
||||
enddo
|
||||
ENDIF
|
||||
|
||||
200 continue
|
||||
|
||||
DO
|
||||
CALL WMessage(ITYPE,MESSAGE)
|
||||
SELECT CASE (ITYPE)
|
||||
CASE (PushButton)
|
||||
IF(MESSAGE%VALUE1.EQ.IDOK) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
CALL WDialogGetInteger(IDF_INTEGER2,NOOP(1))
|
||||
CALL WDialogGetInteger(IDF_INTEGER3,NOOP(2))
|
||||
CALL WDialogGetInteger(IDF_INTEGER4,NOOP(3))
|
||||
CALL WDialogGetInteger(IDF_INTEGER5,NOOP(4))
|
||||
CALL WDialogGetInteger(IDF_INTEGER6,NOOP(5))
|
||||
CALL WDialogGetInteger(IDF_INTEGER7,NOOP(6))
|
||||
CALL WDialogGetInteger(IDF_INTEGER8,NOOP(7))
|
||||
CALL WDialogGetInteger(IDF_INTEGER9,NOOP(8))
|
||||
CALL WDialogGetInteger(IDF_INTEGER10,IMAAT)
|
||||
ISUM=0
|
||||
DO N1=1,8
|
||||
NOP(N,N1)=NOOP(N1)
|
||||
ISUM=ISUM+NOOP(N1)
|
||||
ENDDO
|
||||
IMAT(N)=IMAAT
|
||||
IF(ISUM .EQ. 0) THEN
|
||||
XC(N)=VOID
|
||||
YC(N)=VOID
|
||||
IF(N .LT. NELAST) NELAST=N
|
||||
IESKP(N)=1
|
||||
NCORN(N)=0
|
||||
IMAT(N)=0
|
||||
ENDIF
|
||||
call WDialogHide()
|
||||
call wdialogUNload()
|
||||
RETURN
|
||||
ELSEIF(MESSAGE%VALUE1.EQ.IDNEXT) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
CALL WDialogGetInteger(IDF_INTEGER2,NOOP(1))
|
||||
CALL WDialogGetInteger(IDF_INTEGER3,NOOP(2))
|
||||
CALL WDialogGetInteger(IDF_INTEGER4,NOOP(3))
|
||||
CALL WDialogGetInteger(IDF_INTEGER5,NOOP(4))
|
||||
CALL WDialogGetInteger(IDF_INTEGER6,NOOP(5))
|
||||
CALL WDialogGetInteger(IDF_INTEGER7,NOOP(6))
|
||||
CALL WDialogGetInteger(IDF_INTEGER8,NOOP(7))
|
||||
CALL WDialogGetInteger(IDF_INTEGER9,NOOP(8))
|
||||
CALL WDialogGetInteger(IDF_INTEGER10,IMAAT)
|
||||
ISUM=0
|
||||
DO N1=1,8
|
||||
NOP(N,N1)=NOOP(N1)
|
||||
ISUM=ISUM+NOOP(N1)
|
||||
ENDDO
|
||||
IMAT(N)=IMAAT
|
||||
IF(ISUM .EQ. 0) THEN
|
||||
XC(N)=VOID
|
||||
YC(N)=VOID
|
||||
IF(N .LT. NELAST) NELAST=N
|
||||
IESKP(N)=1
|
||||
NCORN(N)=0
|
||||
IMAT(N)=0
|
||||
ENDIF
|
||||
GO TO 150
|
||||
ELSEIF(MESSAGE%VALUE1.EQ.IDF_delete) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
CALL DELTEL(N)
|
||||
call WDialogHide()
|
||||
call wdialogUNload()
|
||||
RETURN
|
||||
ELSEIF(MESSAGE%VALUE1.EQ.IDCANCEL) THEN
|
||||
call WDialogHide()
|
||||
call wdialogUNload()
|
||||
RETURN
|
||||
ELSEIF(MESSAGE%VALUE1.EQ.IDFROTATE) THEN
|
||||
call WDialogHide()
|
||||
call wdialogUNload()
|
||||
call plotot(1)
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select starting node','CHOOSE NODE')
|
||||
IBOX=1
|
||||
DO K=1,8
|
||||
NEAC(K)=NOP(N,K)
|
||||
ENDDO
|
||||
CALL PROXEL(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX,NEAC)
|
||||
DO K=1,NCORN(N)
|
||||
IF(NOOP(K) .EQ. INODE) THEN
|
||||
LL=K-1
|
||||
DO L=1,NCORN(N)
|
||||
LL=LL+1
|
||||
IF(NCORN(N) .EQ. 6 .AND. LL .EQ. 7) LL=LL+2
|
||||
NOOP(L)=NOOP(LL)
|
||||
ENDDO
|
||||
IF(NCORN(N) .EQ. 6) THEN
|
||||
NOOP(7)=0
|
||||
NOOP(8)=0
|
||||
ENDIF
|
||||
call wdialogload(IDD_ELTDATA)
|
||||
GO TO 120
|
||||
ENDIF
|
||||
enddo
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Selected node not within element','CHOOSE NODE')
|
||||
call wdialogload(IDD_ELTDATA)
|
||||
GO TO 120
|
||||
|
||||
ENDIF
|
||||
END SELECT
|
||||
END DO
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE GETELMNO
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*1 IFLAG
|
||||
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select element','CHOOSE ELEMENT')
|
||||
IBOX=1
|
||||
CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX)
|
||||
INEG=-IELEM
|
||||
CALL ELTDISP1(INEG)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
Subroutine EltDisp1(nsw)
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
!
|
||||
include 'd.inc'
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
|
||||
!
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
INTEGER :: N,IBOX,NN,NOOP(16),NEAC(8)
|
||||
INTEGER :: IERR
|
||||
CHARACTER*1 :: IFLAG
|
||||
|
||||
DATA N/1/
|
||||
ims=0
|
||||
100 continue
|
||||
call wdialogload(IDD_ELTDATA)
|
||||
ierr=infoerror(1)
|
||||
IF(NSW .NE. 0) N=ABS(NSW)
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,N)
|
||||
NN=N
|
||||
DO N1=1,8
|
||||
NOOP(N1)=NOP(N,N1)
|
||||
NOOP(N1+8)=NOP(N,N1)
|
||||
ENDDO
|
||||
IMAAT=IMAT(N)
|
||||
120 CONTINUE
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,N)
|
||||
CALL WDialogPutInteger(IDF_INTEGER2,NOOP(1))
|
||||
CALL WDialogPutInteger(IDF_INTEGER3,NOOP(2))
|
||||
CALL WDialogPutInteger(IDF_INTEGER4,NOOP(3))
|
||||
CALL WDialogPutInteger(IDF_INTEGER5,NOOP(4))
|
||||
CALL WDialogPutInteger(IDF_INTEGER6,NOOP(5))
|
||||
CALL WDialogPutInteger(IDF_INTEGER7,NOOP(6))
|
||||
CALL WDialogPutInteger(IDF_INTEGER8,NOOP(7))
|
||||
CALL WDialogPutInteger(IDF_INTEGER9,NOOP(8))
|
||||
CALL WDialogPutInteger(IDF_INTEGER10,IMAAT)
|
||||
CALL WDialogSelect(IDD_ELTDATA)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
150 CONTINUE
|
||||
|
||||
DO
|
||||
! Branch depending on type of message.
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
CALL WDialogGetInteger(IDF_INTEGER2,NOOP(1))
|
||||
CALL WDialogGetInteger(IDF_INTEGER3,NOOP(2))
|
||||
CALL WDialogGetInteger(IDF_INTEGER4,NOOP(3))
|
||||
CALL WDialogGetInteger(IDF_INTEGER5,NOOP(4))
|
||||
CALL WDialogGetInteger(IDF_INTEGER6,NOOP(5))
|
||||
CALL WDialogGetInteger(IDF_INTEGER7,NOOP(6))
|
||||
CALL WDialogGetInteger(IDF_INTEGER8,NOOP(7))
|
||||
CALL WDialogGetInteger(IDF_INTEGER9,NOOP(8))
|
||||
CALL WDialogGetInteger(IDF_INTEGER10,IMAAT)
|
||||
ISUM=0
|
||||
DO N1=1,8
|
||||
NOP(N,N1)=NOOP(N1)
|
||||
ISUM=ISUM+NOOP(N1)
|
||||
ENDDO
|
||||
IMAT(N)=IMAAT
|
||||
IF(ISUM .EQ. 0) THEN
|
||||
XC(N)=VOID
|
||||
YC(N)=VOID
|
||||
IF(N .LT. NELAST) NELAST=N
|
||||
IESKP(N)=1
|
||||
NCORN(N)=0
|
||||
IMAT(N)=0
|
||||
ENDIF
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ELSEIF (WInfoDialog(ExitButton) .EQ. IDNEXT) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
CALL WDialogGetInteger(IDF_INTEGER2,NOOP(1))
|
||||
CALL WDialogGetInteger(IDF_INTEGER3,NOOP(2))
|
||||
CALL WDialogGetInteger(IDF_INTEGER4,NOOP(3))
|
||||
CALL WDialogGetInteger(IDF_INTEGER5,NOOP(4))
|
||||
CALL WDialogGetInteger(IDF_INTEGER6,NOOP(5))
|
||||
CALL WDialogGetInteger(IDF_INTEGER7,NOOP(6))
|
||||
CALL WDialogGetInteger(IDF_INTEGER8,NOOP(7))
|
||||
CALL WDialogGetInteger(IDF_INTEGER9,NOOP(8))
|
||||
CALL WDialogGetInteger(IDF_INTEGER10,IMAAT)
|
||||
ISUM=0
|
||||
DO N1=1,8
|
||||
NOP(N,N1)=NOOP(N1)
|
||||
ISUM=ISUM+NOOP(N1)
|
||||
ENDDO
|
||||
IMAT(N)=IMAAT
|
||||
IF(ISUM .EQ. 0) THEN
|
||||
XC(N)=VOID
|
||||
YC(N)=VOID
|
||||
IF(N .LT. NELAST) NELAST=N
|
||||
IESKP(N)=1
|
||||
NCORN(N)=0
|
||||
IMAT(N)=0
|
||||
ENDIF
|
||||
GO TO 150
|
||||
ELSEIF (WInfoDialog(ExitButton) .EQ. IDF_DELETE) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
CALL DELTEL(N)
|
||||
RETURN
|
||||
ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
RETURN
|
||||
ELSEIF (WInfoDialog(ExitButton) .EQ. IDFROTATE) THEN
|
||||
call plotot(1)
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select starting node','CHOOSE NODE')
|
||||
IBOX=1
|
||||
DO K=1,8
|
||||
NEAC(K)=NOP(N,K)
|
||||
ENDDO
|
||||
CALL PROXEL(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX,NEAC)
|
||||
DO K=1,NCORN(N)
|
||||
IF(NOOP(K) .EQ. INODE) THEN
|
||||
LL=K-1
|
||||
DO L=1,NCORN(N)
|
||||
LL=LL+1
|
||||
IF(NCORN(N) .EQ. 6 .AND. LL .EQ. 7) LL=LL+2
|
||||
NOOP(L)=NOOP(LL)
|
||||
ENDDO
|
||||
IF(NCORN(N) .EQ. 6) THEN
|
||||
NOOP(7)=0
|
||||
NOOP(8)=0
|
||||
ENDIF
|
||||
call wdialogload(IDD_ELTDATA)
|
||||
GO TO 120
|
||||
ENDIF
|
||||
enddo
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Selected node not within element','CHOOSE NODE')
|
||||
call wdialogload(IDD_ELTDATA)
|
||||
GO TO 120
|
||||
|
||||
ENDIF
|
||||
END DO
|
||||
RETURN
|
||||
END
|
||||
|
||||
Subroutine EltERRDisp(nsw,ims)
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
!
|
||||
include 'd.inc'
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
|
||||
!
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
INTEGER :: NSW,IBOX,NN,NOOP(16)
|
||||
INTEGER :: IERR
|
||||
CHARACTER*1 :: IFLAG
|
||||
|
||||
DATA N/1/
|
||||
ims=0
|
||||
100 continue
|
||||
call wdialogload(IDD_ELTERR2)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,NSW)
|
||||
|
||||
CALL WDialogSelect(IDD_ELTERR)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,ModaL)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,NSW)
|
||||
ims=1
|
||||
return
|
||||
else
|
||||
ims=0
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
return
|
||||
end
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,712 @@
|
||||
! Last change: IPK 12 Jan 98 1:59 pm
|
||||
!ipk delete old calls to char(7)
|
||||
!ipk last updated Nov 18 1997
|
||||
!ipk last updated June 24 1996
|
||||
!
|
||||
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
!
|
||||
SUBROUTINE ELTS
|
||||
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
CHARACTER*1 ANS,ANSW(0:9)
|
||||
DATA ANSW/'s','j','f','g','t','i','h','z','r','q'/
|
||||
!
|
||||
! Draw box around selections
|
||||
!
|
||||
2 CONTINUE
|
||||
NHTP=6
|
||||
NMESS=0
|
||||
NBRR=0
|
||||
CALL HEDR
|
||||
!
|
||||
! Get answer
|
||||
!
|
||||
3 call xyloc(XPT,YPT,ANS,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(ANS .EQ. 'c') THEN
|
||||
I=IBOX-1
|
||||
if(i .lt. 0) go to 3
|
||||
ANS=ANSW(I)
|
||||
ENDIF
|
||||
!
|
||||
IF(ANS .EQ. 's') THEN
|
||||
CALL SELECT
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
ELSEIF (ANS .EQ. 'j') THEN
|
||||
CALL MKELEM
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
ELSEIF (ANS .EQ. 'd') THEN
|
||||
CALL DELEL
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
ELSEIF (ANS .EQ. 'f') THEN
|
||||
CALL FINDEL
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
ELSEIF (ANS .EQ. 'g') THEN
|
||||
CALL GEL
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
ELSEIF (ANS .EQ. 't') THEN
|
||||
CALL MATTYP
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
ELSEIF (ANS .EQ. 'i') THEN
|
||||
!ipk aug02
|
||||
CALL FILM(0)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
ELSEIF (ANS .EQ. 'h') THEN
|
||||
CALL HELPS(2)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
ELSEIF (ANS .EQ. 'q') THEN
|
||||
RETURN
|
||||
ELSE
|
||||
GO TO 3
|
||||
ENDIF
|
||||
GO TO 2
|
||||
END
|
||||
!
|
||||
!****************************************************************
|
||||
!
|
||||
SUBROUTINE MATTYP
|
||||
!
|
||||
USE BLK1MOD
|
||||
SAVE
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
!ipk feb97 CHARACTER*1 IFLAG
|
||||
!
|
||||
CHARACTER*1 IFLAG,ANSW(10)
|
||||
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
!
|
||||
!
|
||||
! Assign new material type
|
||||
!
|
||||
!
|
||||
!
|
||||
data itime/0/
|
||||
|
||||
if(itime .eq. 0) then
|
||||
mat=1
|
||||
itime=1
|
||||
endif
|
||||
ht=0.2
|
||||
!ipk feb97
|
||||
4 CONTINUE
|
||||
NHTP=0
|
||||
NBRR=4
|
||||
!ipk feb97 NBRR=0
|
||||
NMESS=45
|
||||
CALL HEDR
|
||||
NMESS=2
|
||||
XPRT=3.2
|
||||
! READ(*,*) MAT
|
||||
!
|
||||
! Write out current material types
|
||||
!
|
||||
IF(NEFL .GT. 0) GO TO 100
|
||||
!ipk feb97 4 HT = .20
|
||||
HT = .15
|
||||
DO 10 J=1,NE
|
||||
IF (IMAT(J) .GT. 0 .AND. IMAT(J) .LT. 901) THEN
|
||||
IF(IESKP(J) .EQ. 0) THEN
|
||||
IF(IQSW(1) .EQ. 1 .OR. IQSW(2) .EQ. 1) FPN = IMAT(J)
|
||||
IF(IQSW(1) .EQ. 2 .OR. IQSW(2) .EQ. 2) FPN = IGRPSER(J)
|
||||
X = XC(J)
|
||||
!ipk jul02 Y = YC(J) - .11
|
||||
Y = YC(J) + .01
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||||
CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
10 END DO
|
||||
CALL GETINT(MAT)
|
||||
|
||||
5 CONTINUE
|
||||
IBOX=1
|
||||
CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. 9.6) XPRT=0.
|
||||
FPN= IELEM
|
||||
CALL NUMBR(XPRT,7.20,0.18,FPN,0.0,-1)
|
||||
!ipk feb97 new setup
|
||||
!
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
RETURN
|
||||
ELSEIF(IFLAG .EQ. 'e' .OR. IFLAG .EQ. 'n') THEN
|
||||
!ipk nov97 add (1)
|
||||
CALL PLOTOT(1)
|
||||
GO TO 4
|
||||
ENDIF
|
||||
IF(IQSW(1) .EQ. 1 .OR. IQSW(2) .EQ. 1) IMAT(IELEM) = MAT
|
||||
IF(IQSW(1) .EQ. 2 .OR. IQSW(2) .EQ. 2) IGRPSER(IELEM) = MAT
|
||||
FPN = MAT
|
||||
X = XC(IELEM)
|
||||
Y = YC(IELEM) + .01
|
||||
CALL NUMBR(X,Y,0.15,FPN,0.0,-1)
|
||||
!
|
||||
!ipk feb97 ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
!ipkfeb94 CALL WRTOUT(0)
|
||||
!ipk feb97 RETURN
|
||||
!
|
||||
!ipk feb97 ELSE
|
||||
!ipk feb97 WRITE(*,*) CHAR(7),CHAR(7)
|
||||
!ipk feb97 ENDIF
|
||||
!
|
||||
GOTO 5
|
||||
!
|
||||
! Process list from prior selection
|
||||
!
|
||||
100 CONTINUE
|
||||
DO 150 K=1,NEFL
|
||||
J=NEFLAG(K)
|
||||
IMAT(J)=MAT
|
||||
150 END DO
|
||||
NEFL=0
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
SUBROUTINE FINDEL
|
||||
!
|
||||
USE BLK1MOD
|
||||
SAVE NELSE
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
! Read desired element number
|
||||
!
|
||||
data itime/0/
|
||||
if(itime .eq. 0) then
|
||||
itime=1
|
||||
nelse=0
|
||||
endif
|
||||
2 CONTINUE
|
||||
NHTPSAV=NHTP
|
||||
NMESSAV=NMESS
|
||||
NBRRSAV=NBRR
|
||||
NHTP=0
|
||||
NBRR=0
|
||||
NMESS=3
|
||||
CALL HEDR
|
||||
NMESS=3
|
||||
CALL GETINT(NELSE)
|
||||
! READ(*,*) NELSE
|
||||
!
|
||||
! Obtain location of centroid
|
||||
!
|
||||
!ipkdec93 IF(IMAT(NELSE) .EQ. 0) GO TO 2
|
||||
IF(IMAT(NELSE) .EQ. 0) RETURN
|
||||
DO 4 I=1,NP
|
||||
IF(CORD(I,1) .GT. VOID) THEN
|
||||
INSKP(I)=0
|
||||
ENDIF
|
||||
4 END DO
|
||||
DO 5 I=1,NE
|
||||
IF(IMAT(I) .GT. 0) THEN
|
||||
IESKP(I)=0
|
||||
ENDIF
|
||||
5 END DO
|
||||
NCN=NCORN(NELSE)
|
||||
XX=0.
|
||||
YY=0.
|
||||
DO 150 K=1,NCN,2
|
||||
XX=XX+CORD(NOP(NELSE,K),1)
|
||||
YY=YY+CORD(NOP(NELSE,K),2)
|
||||
150 END DO
|
||||
XP=XX/FLOAT((NCN+1)/2)
|
||||
YP=YY/FLOAT((NCN+1)/2)
|
||||
!
|
||||
! Make it center of screen and redraw
|
||||
!
|
||||
XMIN=XP-5.0*PSCALE
|
||||
YMIN=YP-3.5*PSCALE
|
||||
! CALL PLOTS(0)
|
||||
!ipk nov97 add (1)
|
||||
CALL PLOTOT(1)
|
||||
HT=0.15
|
||||
FPN=NELSE
|
||||
CALL RRED
|
||||
CALL NUMBR(5.,3.5,HT,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
NHTP=NHTPSAV
|
||||
NMESS=NMESSAV
|
||||
NBRR=NBRRSAV
|
||||
CALL HEDR
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
SUBROUTINE DELEL
|
||||
!
|
||||
! Routine to define element for deleting
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*1 IFLAG
|
||||
IF(NEFL .GT. 0) GO TO 150
|
||||
100 CONTINUE
|
||||
!
|
||||
! Check out mouse
|
||||
!
|
||||
IBOX=0
|
||||
CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
! Go and start again if quit called
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') RETURN
|
||||
IECHG=0
|
||||
!IPK MAY03
|
||||
ICHG=0
|
||||
CALL DELTEL(IELEM)
|
||||
GO TO 100
|
||||
!
|
||||
! Call routine to delete elements in list
|
||||
!
|
||||
|
||||
150 CONTINUE
|
||||
IECHG=0
|
||||
!IPK MAY03
|
||||
ICHG=0
|
||||
DO 200 K=1,NEFL
|
||||
J=NEFLAG(K)
|
||||
CALL DELTEL(J)
|
||||
200 END DO
|
||||
NEFL=0
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
SUBROUTINE DELTEL(J)
|
||||
!
|
||||
! Routine to delete a given element
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
IMAT(J)=0
|
||||
XC(J)=VOID
|
||||
YC(J)=VOID
|
||||
IF(J .LT. NELAST) NELAST=J
|
||||
DO 170 KK=1,8
|
||||
NOP(J,KK)=0
|
||||
170 END DO
|
||||
IESKP(J)=1
|
||||
NCORN(J)=0
|
||||
JJ=0
|
||||
!IPK FEB08 TEST FOR LOWERING NE
|
||||
IF(J .EQ. NE) THEN
|
||||
DO J=NE,1,-1
|
||||
IF(IMAT(J) .NE. 0) THEN
|
||||
JJ=J
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ENDDO
|
||||
200 NE=JJ
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
SUBROUTINE SELECT
|
||||
!
|
||||
! Routine to select elements
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*1 ANSW(10)
|
||||
CHARACTER*1 IFLAG
|
||||
DATA ANSW/'d','e','n','a','g','t','h','z','r','q'/
|
||||
data itime/0/
|
||||
|
||||
if(itime .eq. 0) then
|
||||
ielem=1
|
||||
itime=1
|
||||
endif
|
||||
|
||||
!
|
||||
! Draw box around selections
|
||||
!
|
||||
|
||||
2 CONTINUE
|
||||
!IPK MAY94 DROP THIS PLOTTING
|
||||
! CALL PLOTOT
|
||||
NEFL=0
|
||||
95 NHTP=7
|
||||
NMESS=0
|
||||
NBRR=0
|
||||
CALL HEDR
|
||||
100 CONTINUE
|
||||
!
|
||||
! Check out mouse
|
||||
!
|
||||
IBOX=1
|
||||
CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
! Return if quit called
|
||||
!
|
||||
IF(IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ELSEIF(IFLAG .EQ. 'c') THEN
|
||||
GO TO 120
|
||||
ENDIF
|
||||
!
|
||||
! Check for reading number
|
||||
!
|
||||
IF(IFLAG .EQ. 'n') THEN
|
||||
NHTP=0
|
||||
NMESS=45
|
||||
CALL HEDR
|
||||
NMESS=20
|
||||
CALL GETINT(IELEM)
|
||||
NEFL=NEFL+1
|
||||
NEFLAG(NEFL)=IELEM
|
||||
CALL FILLEM(IELEM)
|
||||
GO TO 95
|
||||
!
|
||||
! Check for selecting all elements
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 'a') THEN
|
||||
DO I=1,NE
|
||||
IF(IMAT(I) .GT. 0) THEN
|
||||
IF(IMAT(I) .LT. 901 .or. imat(i) .gt. 903) THEN
|
||||
NEFL=NEFL+1
|
||||
NEFLAG(NEFL)=I
|
||||
CALL FILLEM(I)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
GO TO 95
|
||||
!
|
||||
! Check for only rectangles
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 'g') THEN
|
||||
DO I=1,NE
|
||||
IF(NCORN(I) .EQ. 8) THEN
|
||||
NEFL=NEFL+1
|
||||
NEFLAG(NEFL)=I
|
||||
CALL FILLEM(I)
|
||||
ENDIF
|
||||
ENDDO
|
||||
GO TO 95
|
||||
!
|
||||
! Check for only triangles
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 't') THEN
|
||||
DO I=1,NE
|
||||
IF(NCORN(I) .EQ. 6) THEN
|
||||
NEFL=NEFL+1
|
||||
NEFLAG(NEFL)=I
|
||||
CALL FILLEM(I)
|
||||
ENDIF
|
||||
ENDDO
|
||||
GO TO 95
|
||||
!
|
||||
! Check for only line elements
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 'l') THEN
|
||||
DO I=1,NE
|
||||
IF((NCORN(I) .LT. 6 .and. ncorn(i) .gt. 2) .and. &
|
||||
(imat(i) .lt. 901 .or. imat(i) .gt. 903)) THEN
|
||||
NEFL=NEFL+1
|
||||
NEFLAG(NEFL)=I
|
||||
CALL FILLEM(I)
|
||||
xa=(cord(nop(i,1),1)+cord(nop(i,3),1))/2.
|
||||
ya=(cord(nop(i,1),2)+cord(nop(i,3),2))/2.
|
||||
fpn=i
|
||||
CALL NUMBR(xa,ya,0.18,FPN,0.0,-1)
|
||||
ENDIF
|
||||
ENDDO
|
||||
GO TO 95
|
||||
!
|
||||
! Check for delete option
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 'd') THEN
|
||||
CALL DELEL
|
||||
!
|
||||
! Check for refine option
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 'e') THEN
|
||||
CALL REFB
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
! Check for help
|
||||
!
|
||||
ELSEIF (IFLAG .EQ. 'h') THEN
|
||||
CALL HELPS(6)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 'U') THEN
|
||||
NEFLAG(NEFL)=0
|
||||
NEFL=NEFL-1
|
||||
CALL PLOTOT(1)
|
||||
CALL HEDR
|
||||
DO IELEM=1,NEFL
|
||||
CALL FILLEM(NEFLAG(IELEM))
|
||||
ENDDO
|
||||
GO TO 100
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
RETURN
|
||||
ENDIF
|
||||
GO TO 2
|
||||
120 NEFL=NEFL+1
|
||||
NEFLAG(NEFL)=IELEM
|
||||
CALL FILLEM(IELEM)
|
||||
IF(NCORN(ielem) .LT. 6 .and. ncorn(ielem) .gt. 2) THEN
|
||||
|
||||
xa=(cord(nop(ielem,1),1)+cord(nop(ielem,3),1))/2.
|
||||
ya=(cord(nop(ielem,1),2)+cord(nop(ielem,3),2))/2.
|
||||
fpn=ielem
|
||||
CALL NUMBR(xa,ya,0.18,FPN,0.0,-1)
|
||||
endif
|
||||
GO TO 100
|
||||
END
|
||||
!
|
||||
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||||
!
|
||||
SUBROUTINE MKELEM
|
||||
|
||||
!
|
||||
USE BLK1MOD
|
||||
INCLUDE 'BFILES.I90'
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
CHARACTER*1 IFLAG
|
||||
CHARACTER*32 IJNK
|
||||
CHARACTER*23 ELTH
|
||||
!ipk jan98
|
||||
CHARACTER*80 LIND
|
||||
CHARACTER*60 MESSAGE,MESSAG1
|
||||
!ipk jun96 add messag2
|
||||
CHARACTER*26 MESSAG2
|
||||
DATA MESSAG2/' Press return to continue'/
|
||||
!ipkjul94 add a line
|
||||
MEL=MAXE
|
||||
!
|
||||
! Form element nodal list by clicking on nodes with cursor
|
||||
!
|
||||
3 CONTINUE
|
||||
CALL GETELM(J)
|
||||
5 CONTINUE
|
||||
IECHG=0
|
||||
!IPK MAY03
|
||||
ICHG=0
|
||||
WRITE(ELTH,5000) j
|
||||
5000 FORMAT('Processing element',i5)
|
||||
CALL CLRBOX
|
||||
!ipk jun96 clear a strip
|
||||
call clrstp(7.2,7.5)
|
||||
CALL SYMBL(0.,7.70,0.18,ELTH,0.,23)
|
||||
XPRT=3.5
|
||||
|
||||
6 DO 10 K=1,10,2
|
||||
!
|
||||
! Find node nearest to cursor
|
||||
!
|
||||
7 CONTINUE
|
||||
!ipk sep94 reset ibox
|
||||
IBOX=1
|
||||
!ipk sep49 add call to hedr
|
||||
nhtp=0
|
||||
!ipk jun96 nmess=22
|
||||
nmess=15
|
||||
nbrr=3
|
||||
call hedr
|
||||
! write(155,*) width(1),width(2),width(3)
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
! IF(IFLAG .EQ. 'z') THEN
|
||||
! DO 62 I=1,NP
|
||||
! IF(CORD(I,1) .GT. VOID) THEN
|
||||
! INSKP(I)=0
|
||||
! ENDIF
|
||||
! 62 CONTINUE
|
||||
! DO 63 I=1,NE
|
||||
! IF(IMAT(I) .GT. 0) THEN
|
||||
! IESKP(I)=0
|
||||
! ENDIF
|
||||
! 63 CONTINUE
|
||||
CALL RBLUE
|
||||
if(inode .lt. 1) return
|
||||
CALL PLTNOD(INODE,1)
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. 9.6) then
|
||||
XPRT=0.
|
||||
!ipk jun96 clear a strip
|
||||
call clrstp(7.2,7.5)
|
||||
endif
|
||||
FPN= INODE
|
||||
CALL RBLUE
|
||||
CALL NUMBR(XPRT,7.30,0.18,FPN,0.0,-1)
|
||||
!
|
||||
IF(K .EQ. 9) THEN
|
||||
IF(IFLAG .EQ. 'm') THEN
|
||||
NOP(J,K-1) = INODE
|
||||
WD(INODE) = 0.
|
||||
!
|
||||
! Five node element
|
||||
!
|
||||
ELSEIF (IFLAG .EQ. 'f') THEN
|
||||
NOP(J,4)=NOP(J,5)
|
||||
NOP(J,5)=NOP(J,7)
|
||||
NOP(J,7) = 0
|
||||
NOP(J,8) = 0
|
||||
ENDIF
|
||||
GO TO 10
|
||||
ENDIF
|
||||
IF (IFLAG .NE. 'r') THEN
|
||||
NOP(J,K) = 0
|
||||
NOP(J,K+1) = 0
|
||||
ENDIF
|
||||
!
|
||||
! Corner node
|
||||
!
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
NOP(J,K) = INODE
|
||||
!
|
||||
! Midside node
|
||||
!
|
||||
ELSEIF (IFLAG .EQ. 'm') THEN
|
||||
NOP(J,K-1) = INODE
|
||||
GOTO 7
|
||||
!
|
||||
! Triangular element
|
||||
!
|
||||
ELSEIF (IFLAG .EQ. 't' .AND. K .EQ. 7) THEN
|
||||
NOP(J,7) = 0
|
||||
NOP(J,8) = 0
|
||||
GOTO 20
|
||||
!
|
||||
! 1-d element
|
||||
!
|
||||
ELSEIF (IFLAG .EQ. 'l' .AND. K .EQ. 5) THEN
|
||||
NOP(J,4) = 0
|
||||
NOP(J,5) = 0
|
||||
NOP(J,6) = 0
|
||||
NOP(J,7) = 0
|
||||
NOP(J,8) = 0
|
||||
GOTO 20
|
||||
!
|
||||
! Junction element
|
||||
!
|
||||
ELSEIF (IFLAG .EQ. 'j' .AND. K .EQ. 3) THEN
|
||||
INODE= NOP(J,1)
|
||||
NOP(J,1)=0
|
||||
CALL JUNGEN(J,INODE,IER)
|
||||
IF(IER .EQ. 1) THEN
|
||||
!
|
||||
! Redo if error
|
||||
!
|
||||
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||||
GOTO 7
|
||||
ENDIF
|
||||
GO TO 20
|
||||
!
|
||||
! Exit input
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 'q') THEN
|
||||
NE=NE-1
|
||||
!ipkfeb94 CALL WRTOUT(0)
|
||||
IRDONE=0
|
||||
RETURN
|
||||
!
|
||||
! Redo if error
|
||||
!
|
||||
ELSE
|
||||
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||||
GOTO 6
|
||||
ENDIF
|
||||
10 END DO
|
||||
!
|
||||
20 IF (IMAT(J) .EQ. 0) IMAT(J) = 1
|
||||
!
|
||||
! rearrange if nop(j,4) .ne. 0 separate it from
|
||||
! a transition element
|
||||
!
|
||||
IF(NOP(J,4) .NE. 0 .AND. NOP(J,6) .EQ. 0) THEN
|
||||
IF(IFLAG .NE. 'f' .AND. IMAT(J) .LT. 901) THEN
|
||||
|
||||
ITMP1 = NOP(J,1)
|
||||
ITMP2 = NOP(J,2)
|
||||
DO 30 KK=1,6
|
||||
NOP(J,KK) = NOP(J,KK+2)
|
||||
30 CONTINUE
|
||||
IF(NOP(J,5) .EQ. 0) THEN
|
||||
NOP(J,5)=ITMP1
|
||||
NOP(J,6)=ITMP2
|
||||
ELSE
|
||||
NOP(J,7)=ITMP1
|
||||
NOP(J,8)=ITMP2
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
NCN = 2
|
||||
IF (NOP(J,3) .NE. 0) NCN = 3
|
||||
IF (NOP(J,4) .NE. 0) NCN = 4
|
||||
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5
|
||||
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6
|
||||
IF (NOP(J,6) .NE. 0) NCN = 6
|
||||
IF (NOP(J,7) .NE. 0) NCN = 8
|
||||
!
|
||||
! Check to see if duplicate node numbers have been defined
|
||||
!
|
||||
DO 40 KK=1,NCN-1
|
||||
IF(NOP(J,KK) .EQ. 0) GO TO 40
|
||||
DO 37 LL=KK+1,NCN
|
||||
IF(NOP(J,KK) .EQ. NOP(J,LL)) THEN
|
||||
WRITE(MESSAGE,6000) J
|
||||
6000 FORMAT(' **ERROR** NODES AT ELEMENT NUMBER',I5,' ARE DUPLICATED RE&
|
||||
&TRY')
|
||||
WRITE(MESSAG1,6001) (NOP(J,II),II=1,8)
|
||||
6001 FORMAT(' NODE LIST FOLLOWS ',8I5)
|
||||
CALL CLRBOX
|
||||
CALL SYMBL(0.,7.75,0.18,MESSAGE,0.,60)
|
||||
CALL SYMBL(0.,7.55,0.18,MESSAG1,0.,60)
|
||||
!IPK JUN96
|
||||
CALL SYMBL(0.,7.35,0.18,MESSAG2,0.,25)
|
||||
call keybrd(k)
|
||||
!cc read(*,'(A)') ijnk
|
||||
!ipk jun96 change transfer location
|
||||
! GO TO 6
|
||||
go to 5
|
||||
ENDIF
|
||||
37 CONTINUE
|
||||
40 END DO
|
||||
NCORN(J) = NCN
|
||||
IESKP(J) = 0
|
||||
NE = MAX(J,NE)
|
||||
!IPK JAN98
|
||||
IERC=0
|
||||
CALL PLTELM(J,IERC)
|
||||
!
|
||||
! WRITE(IOT,'(10I5)') J, (NOP(J,K),K=1,8), IMAT(J)
|
||||
!
|
||||
! Return if dimensions exceeded
|
||||
!
|
||||
!ipk jul94 IF (J .GE. MAXE) THEN
|
||||
IF (J .GE. MEL) THEN
|
||||
CALL WRTOUT(0)
|
||||
CALL CLSCRN
|
||||
!ipk jan98 CALL SETD(24)
|
||||
!ipk jan98 WRITE(*,*) ' Element number exceeds MAXE. Press retur
|
||||
WRITE(lind,*) &
|
||||
& ' Element number exceeds MAXE. Press return to exit'
|
||||
call symbl &
|
||||
& (1.1,4.0,0.20,LIND,0.0,80)
|
||||
!ipk jan98 READ(*,'(A)') IJNK
|
||||
ndig=1
|
||||
CALL GTCHARX(IJNK,NDIG,5.0,4.0)
|
||||
RETURN
|
||||
ENDIF
|
||||
!
|
||||
! Go do another element
|
||||
!
|
||||
GOTO 3
|
||||
|
||||
!
|
||||
END
|
||||
@ -0,0 +1,425 @@
|
||||
SUBROUTINE SETRNG(XNEARS,NMAP)
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
!
|
||||
! Establish size for range
|
||||
!
|
||||
JS=1
|
||||
K=0
|
||||
KPT=0
|
||||
VDX=-1.E9
|
||||
write(90,*) 'maxpts', maxpts
|
||||
DO 120 J=1,MAXPTS+1
|
||||
!
|
||||
! Determine how long each line is
|
||||
!
|
||||
MLEN=J-JS
|
||||
! write(90,*) 'mlen',j,js,mlen,xmap(j),nmap,vdx
|
||||
! write(90,*) j,js,mlen,cmap(j,1),xmap(j),vdx,maxpts
|
||||
IF(XMAP(J) .LT. VDX) THEN
|
||||
!IPK NOV05 IF(CMAP(J,1) .LT. VDX) THEN
|
||||
!
|
||||
! Now check it.
|
||||
!
|
||||
K=K+1
|
||||
IF(MLEN .GT. 1) THEN
|
||||
! LTP=LINTYP(K)
|
||||
DO 110 M=1,MLEN
|
||||
! write(191,*) j,m,js+m-1,nmap
|
||||
IF(VAL(JS+M-1) .GT. -9000.) THEN
|
||||
KPT=KPT+1
|
||||
ENDIF
|
||||
110 CONTINUE
|
||||
ENDIF
|
||||
NMAP=J
|
||||
IF(MLEN .EQ. 0) GO TO 130
|
||||
JS=J+1
|
||||
go to 120
|
||||
ENDIF
|
||||
cxcur=xmap(j)
|
||||
cycur=ymap(j)
|
||||
120 END DO
|
||||
130 CONTINUE
|
||||
write(90,*) 'number of points forming map',nmap
|
||||
write(90,*) 'last map coordinates',cxcur,cycur
|
||||
!
|
||||
! Estimate areal density to get 100 points
|
||||
!
|
||||
ADEN=AMAP*40./(FLOAT(KPT)*TXSCAL**2)
|
||||
!
|
||||
! Find square coverage
|
||||
!
|
||||
XNEARS=SQRT(ADEN)
|
||||
xnearo=xnears
|
||||
xnearf=xnears
|
||||
!ipk sep97 xnearo forms the current value xnearp is limiting plus side
|
||||
XNEARP=XNEARS
|
||||
! xnears=2.0
|
||||
WRITE(90,*) 'Radius for nearby points',XNEARS
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE SETELV(XNEARS,NMAP,M,ISWT)
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
! common /mapc/imap(maxpl),NCRS(MAXPL)
|
||||
! dimension ccmap(maxpl)
|
||||
|
||||
DIMENSION LISTM(1000),listt(1600,4),nlf(4),icomp(4),xnear(4)
|
||||
dimension xnearkp(4)
|
||||
|
||||
|
||||
DATA ITIME/0/
|
||||
|
||||
IF(.NOT. ALLOCATED(CCMAP)) THEN
|
||||
ALLOCATE (CCMAP(MAXPL))
|
||||
ENDIF
|
||||
call WcursorShape(CurHourGlass)
|
||||
|
||||
|
||||
!ipk feb94 change logic to allow 4 passes and check angles
|
||||
!
|
||||
! initialize range
|
||||
!
|
||||
ict=0
|
||||
!ipk sep97 xnears=xnearo
|
||||
xnearo=xnears
|
||||
xnearp=xnears
|
||||
xnearf=xnears
|
||||
write(90,*) 'working node',m
|
||||
do nang=1,4
|
||||
XNEAR(nang)=XNEARS
|
||||
xnearkp(nang)=0.
|
||||
icomp(nang)=0
|
||||
enddo
|
||||
!
|
||||
! set imap to zero to start or -1 if no value
|
||||
!
|
||||
!IPK MAY97 INITIALIZE COUNTER
|
||||
ntime=0
|
||||
220 continue
|
||||
|
||||
do n=1,nmap
|
||||
if(cmap(n,1) .lt. vdx) then
|
||||
imap(n)=-1
|
||||
elseif(val(n) .lt. -9000.) then
|
||||
imap(n)=-1
|
||||
else
|
||||
imap(n)=0
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
!ipk sep97 Sortlist of map points in increasing x except for single poin
|
||||
!
|
||||
IF(ielvsw .EQ. 0 .AND. ISWT .NE. 1) THEN
|
||||
!ipk mar99
|
||||
do n=1,nmap
|
||||
ccmap(n)=cmap(n,1)
|
||||
enddo
|
||||
CALL SORTMAP(CCMAP,NCRS,NMAP,IMAP)
|
||||
ielvsw=1
|
||||
! DO N=1,NMAP
|
||||
! WRITE(90,*) N,CMAP(NCRS(N),1),IMAP(NCRS(N))
|
||||
! ENDDO
|
||||
ENDIF
|
||||
!ipk sep97 end addition
|
||||
!
|
||||
! initialize list and completeness test
|
||||
!
|
||||
do nang=1,4
|
||||
icomp(nang)=0
|
||||
do n=1,1600
|
||||
listt(n,nang)=0
|
||||
enddo
|
||||
enddo
|
||||
!
|
||||
! start processing
|
||||
!
|
||||
280 continue
|
||||
!
|
||||
! check for completeness intialize counter
|
||||
!
|
||||
ict=0
|
||||
do nang=1,4
|
||||
if(icomp(nang) .eq. 0) then
|
||||
nlf(nang)=0
|
||||
else
|
||||
ict=ict+1
|
||||
endif
|
||||
enddo
|
||||
!
|
||||
! if ict = 4 we are done
|
||||
!
|
||||
if(ict .lt. 4) then
|
||||
!
|
||||
! loop through map points
|
||||
!
|
||||
!ipk sep97 change loop
|
||||
do nang=1,4
|
||||
nlf(nang)=0
|
||||
icomp(nang)=0
|
||||
enddo
|
||||
IFND=0
|
||||
NN=0
|
||||
285 NN=NN+1
|
||||
IF(NN .GT. NMAP) GO TO 305
|
||||
! DO 300 NNN=1,NMAP
|
||||
N=NN
|
||||
if(val(n) .lt. -9990.) go to 285
|
||||
IF(ISWT .EQ. 1) GO TO 297
|
||||
IF(IFND .EQ. 1) GO TO 295
|
||||
IF(XNEARO .LT. XNEARF) THEN
|
||||
IFND=1
|
||||
GO TO 294
|
||||
ENDIF
|
||||
|
||||
!IPK SEP97 START SEARCH
|
||||
NLOCA=NMAP/2
|
||||
NSTEPS=NMAP/2
|
||||
290 CONTINUE
|
||||
|
||||
! WRITE(90,*) 'elvset-164',NLOCA
|
||||
! write(90,*) NSTEPS,NCRS(NLOCA)
|
||||
! WRITE(90,*) CMAP(NCRS(NLOCA),1),CORD(M,1),XNEAR(1)
|
||||
NCUR=NCRS(NLOCA)
|
||||
! IF(CMAP(NCUR,1) .GT. 1.E34) THEN
|
||||
! WE ARE AOUT OF RANGE
|
||||
! GO TO
|
||||
! ENDIF
|
||||
IF(CMAP(NCUR,1)+XNEARO .LT. CORD(M,1).and. val(ncur) .gt. -9000.) THEN
|
||||
! still below increase nloca
|
||||
NSTEPS=NSTEPS/2
|
||||
IF(NSTEPS .EQ. 0) THEN
|
||||
! we are there
|
||||
NLOCA=NLOCA-1
|
||||
IFND=1
|
||||
GO TO 293
|
||||
ENDIF
|
||||
NLOCA=NLOCA+NSTEPS
|
||||
GO TO 290
|
||||
ELSE
|
||||
! too great decrease nloca
|
||||
NSTEPS=(NSTEPS+1)/2
|
||||
NLOCA=NLOCA-NSTEPS
|
||||
IF(NLOCA .LE. 0) THEN
|
||||
NLOCA=0
|
||||
IFND=1
|
||||
GO TO 293
|
||||
ENDIF
|
||||
GO TO 290
|
||||
ENDIF
|
||||
293 NLOCS=NLOCA
|
||||
! WRITE(90,*) 'elvset-201',NLOCA,NSTEPS,NCRS(NLOCA)
|
||||
! WRITE(90,*) CMAP(NCRS(NLOCA),1),CORD(M,1),XNEAR(1)
|
||||
GO TO 295
|
||||
294 NLOCA=NLOCS
|
||||
295 CONTINUE
|
||||
NLOCA=NLOCA+1
|
||||
if(nloca .gt. nmap) go to 305
|
||||
NCUR=NCRS(NLOCA)
|
||||
!
|
||||
! test to see if we are past area
|
||||
!
|
||||
if(ncur .eq. 0) go to 305
|
||||
IF(CMAP(NCUR,1)-XNEARP .GT. CORD(M,1)) GO TO 305
|
||||
if(val(ncur) .lt. -9000.) go to 295
|
||||
N=NCUR
|
||||
297 CONTINUE
|
||||
d1=cmap(n,1)-cord(m,1)
|
||||
d2=cmap(n,2)-cord(m,2)
|
||||
!ipk may97 IF(ABS(D1) .LT. XNEAR(1)) THEN
|
||||
!ipk may97 IF(ABS(D2) .LT. XNEAR(1)) THEN
|
||||
IF(ABS(D1) .LT. max(XNEARO,xnearp)) THEN
|
||||
IF(ABS(D2) .LT. max(XNEARO,xnearp)) THEN
|
||||
if(d1 .lt. 0) then
|
||||
if(d2 .lt. 0) then
|
||||
nang=3
|
||||
if(abs(d1) .lt. xnear(NANG) .and. &
|
||||
& abs(d2) .lt. xnear(NANG)) then
|
||||
imap(n)=3
|
||||
else
|
||||
imap(n)=-1
|
||||
go to 300
|
||||
endif
|
||||
else
|
||||
nang=2
|
||||
if(abs(d1) .lt. xnear(NANG) .and. &
|
||||
& abs(d2) .lt. xnear(NANG)) then
|
||||
imap(n)=2
|
||||
else
|
||||
imap(n)=-1
|
||||
go to 300
|
||||
endif
|
||||
endif
|
||||
elseif(d2 .lt. 0) then
|
||||
nang=4
|
||||
if(abs(d1) .lt. xnear(NANG) .and. &
|
||||
& abs(d2) .lt. xnear(NANG)) then
|
||||
imap(n)=4
|
||||
else
|
||||
imap(n)=-1
|
||||
go to 300
|
||||
endif
|
||||
else
|
||||
nang=1
|
||||
if(abs(d1) .lt. xnear(NANG) .and. &
|
||||
& abs(d2) .lt. xnear(NANG)) then
|
||||
imap(n)=1
|
||||
else
|
||||
imap(n)=-1
|
||||
go to 300
|
||||
endif
|
||||
endif
|
||||
!
|
||||
! set to skip out if out of range
|
||||
!
|
||||
else
|
||||
imap(n)=-1
|
||||
go to 300
|
||||
endif
|
||||
else
|
||||
imap(n)=-1
|
||||
go to 300
|
||||
endif
|
||||
!
|
||||
!IPK SEP97 END MAJOR REWRITE
|
||||
!
|
||||
! save value if total less then 50
|
||||
!
|
||||
NLF(NANG)=NLF(NANG)+1
|
||||
IF(NLF(NANG) .LT. 101) THEN
|
||||
LISTT(NLF(NANG),NANG)=N
|
||||
ENDIF
|
||||
300 CONTINUE
|
||||
GO TO 285
|
||||
305 CONTINUE
|
||||
!
|
||||
! now reset range if we need to
|
||||
!
|
||||
ictz=0
|
||||
! write(90,*) ' '
|
||||
! write(90,*) ntime
|
||||
! write(90,*) 'nlf',nlf
|
||||
! write(90,*) 'xnear',xnear
|
||||
do nang=1,4
|
||||
if(nlf(nang) .gt. 150) then
|
||||
! rat=sqrt((45.+ntime*3.)/nlf(nang))
|
||||
! if(rat .lt. 0.2) rat=0.2
|
||||
rat=sqrt(0.1+0.06*ntime)
|
||||
xnearkp(nang)=xnear(nang)
|
||||
xnear(nang)=xnear(nang)*rat
|
||||
!ipk may97 elseif(nlf(nang) .eq. 0) then
|
||||
elseif(nlf(nang) .lt. 2) then
|
||||
!ipk may97 if(xnear(nang) .eq. xnears) then
|
||||
ictz=ictz+1
|
||||
!ipk may97 else
|
||||
!ipk may97 icomp(nang)=1
|
||||
!ipk may97 endif
|
||||
else
|
||||
icomp(nang)=1
|
||||
endif
|
||||
enddo
|
||||
xnearf=xnearo
|
||||
! write(90,*) 'ntime,ictz,xnear',ntime,ictz
|
||||
! write(90,*) 'icomp',icomp
|
||||
! write(90,*) 'xneara',xnear
|
||||
if(ictz .gt. 0) then
|
||||
do nang=1,4
|
||||
if(nlf(nang) .lt. 2) then
|
||||
if(xnearkp(nang) .gt. 0.) then
|
||||
xnear(nang)=xnearkp(nang)
|
||||
else
|
||||
xnear(nang)=xnear(nang)*1.5
|
||||
endif
|
||||
if(nang .eq. 2 .or. nang .eq. 3) then
|
||||
if(xnear(nang) .gt. xnearo) xnearo=xnear(nang)
|
||||
endif
|
||||
if(nang .eq. 1 .or. nang .eq. 4) then
|
||||
if(xnear(nang) .gt. xnearp) xnearp=xnear(nang)
|
||||
endif
|
||||
endif
|
||||
!ipk may97 xnears=xnears*2.
|
||||
! write(90,*) 'nang,xnear',nang,xnear(nang)
|
||||
! write(90,*) 'xnearo,xnearp',xnearo,xnearp
|
||||
|
||||
enddo
|
||||
!ipk sep97 xnears=xnears*2.
|
||||
ntime=ntime+1
|
||||
if(ntime .lt. 12) go to 220
|
||||
! go to 220
|
||||
! endif
|
||||
endif
|
||||
!
|
||||
! go back and try again
|
||||
!
|
||||
!ipk may97 go to 280
|
||||
ntime=ntime+1
|
||||
if(ntime .lt. 16) go to 280
|
||||
endif
|
||||
!
|
||||
! finished now compact list
|
||||
!
|
||||
do nang=1,4
|
||||
! write(90,*)'nang',nang,nlf(nang),xnear(nang)
|
||||
enddo
|
||||
nlg=0
|
||||
do nang=1,4
|
||||
nlim=nlf(nang)
|
||||
!ipksep97 if(nlim .eq. 0) then
|
||||
!ipksep97 nlim=50
|
||||
!ipk sep97 endif
|
||||
!ipk sep97 chnage limit and act only if nlim > 0
|
||||
! write(90,*) 'nlim',nlim
|
||||
if(nlim .gt. 1600) nlim=1600
|
||||
if(nlim .gt. 0) then
|
||||
do nlgg=1,nlim
|
||||
if(listt(nlgg,nang) .gt. 0) then
|
||||
if(nlg .eq. 1000) nlg=999
|
||||
nlg=nlg+1
|
||||
listm(nlg)=listt(nlgg,nang)
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
! write(90,*) nlg
|
||||
! write(90,*) m,(listm(n),n=1,nlg),xnear
|
||||
!ipk feb94 end changes
|
||||
! do n=1,nmap
|
||||
! write(90,*) n,cmap(n,1),cmap(n,2),val(n)
|
||||
! enddo
|
||||
! write(90,*) 'LIST MAP POINTS NEAR ',M,CORD(M,1),CORD(M,2)
|
||||
! DO N=1,NLG
|
||||
! WRITE(90,*) listm(n),CMAP(LISTM(N),1),CMAP(LISTM(N),2),val(listm(n))
|
||||
! ENDDO
|
||||
! read(*,*) n234
|
||||
|
||||
!IPK JUL98 CALL GRIDIN(M,SOLN,LISTM,NLG)
|
||||
XXX=CORD(M,1)
|
||||
YYY=CORD(M,2)
|
||||
CALL GRIDIN(XXX,YYY,SOLN,LISTM,NLG)
|
||||
IF(IRMAIN .EQ. 1) then
|
||||
call WcursorShape(CurArrow)
|
||||
RETURN
|
||||
endif
|
||||
WD(M)=SOLN
|
||||
FPN = WD(M)*10.
|
||||
X = CORD(M,1)
|
||||
Y = CORD(M,2) - .11
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.1,FPN,0.0,-1)
|
||||
ENDIF
|
||||
! call WcursorShape(0)
|
||||
call WcursorShape(CurArrow)
|
||||
RETURN
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,162 @@
|
||||
! last update March 6 2000 add default values for CMAP
|
||||
SUBROUTINE FILE(ientry)
|
||||
!
|
||||
! Define input output units
|
||||
!
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'BFILES.I90'
|
||||
!IPK APR94
|
||||
COMMON /RECOD/ IRECD,TSPC
|
||||
common /cols/ ibakk,icolr,iblkk
|
||||
COMMON /PAGE/ XL,XH,YL,YH
|
||||
!
|
||||
CHARACTER*80 LIND
|
||||
!IPK APR94 CHARACTER*40 FNAM,FNAMB
|
||||
CHARACTER*40 FNAM,FNAMB,FNAMC
|
||||
CHARACTER*3 SUB
|
||||
CHARACTER*1 ANS
|
||||
LOGICAL*4 EXST,STATM
|
||||
data ihere/0/
|
||||
if(ihere .eq. 1) return
|
||||
mpnam='elt.mpb'
|
||||
ibakk=8
|
||||
icolr=11
|
||||
iblkk= 9
|
||||
xl=0.
|
||||
yl=0.
|
||||
xh=HSIZE
|
||||
yh=8.0
|
||||
ielvsw=0
|
||||
if(ientry .eq. 1) then
|
||||
ihere=1
|
||||
! MAXPL=200000
|
||||
MAXELMP=100000
|
||||
|
||||
ALLOCATE (NOPEL(MAXELMP,3),XCEN(MAXELMP),YCEN(MAXELMP)&
|
||||
,RADS(MAXELMP) ,NKEY(MAXELMP),CMAP(MAXPL,2)&
|
||||
,XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL))
|
||||
|
||||
ALLOCATE (imap(maxpl),NCRS(MAXPL))
|
||||
|
||||
ALLOCATE (VALLIN(MAXLIN),XCOL(MAXLIN),YCOL(MAXLIN))
|
||||
RADS=0.
|
||||
XCEN=0.
|
||||
YCEN=0.
|
||||
endif
|
||||
|
||||
!ipk jan98
|
||||
OPEN(UNIT=90,FILE='messgen.out',STATUS='UNKNOWN', IOSTAT=iost)
|
||||
if(iost .gt. 0) then
|
||||
OPEN(UNIT=90,FILE='messgen1.out',STATUS='UNKNOWN', IOSTAT=iost)
|
||||
if(iost .gt. 0) then
|
||||
OPEN(UNIT=90,FILE='messgen2.out',STATUS='UNKNOWN', IOSTAT=iost)
|
||||
if(iost .gt. 0) then
|
||||
write(*,*) 'ERROR UNABLE TO OPEN MESSGEN.OUT FILE'
|
||||
write(*,*) 'PRESS RETURN TO END'
|
||||
read(*,'(I5)') junk
|
||||
STOP
|
||||
endif
|
||||
endif
|
||||
endif
|
||||
!ipk jan98
|
||||
write(lind,6010)
|
||||
6010 format(' Compilation limits are')
|
||||
call symbl(1.1,1.5,0.20,LIND,0.0,80)
|
||||
write(lind,6110) maxe
|
||||
6110 FORMAT( ' Maximum elements =',i8)
|
||||
call symbl(1.1,1.2,0.20,LIND,0.0,80)
|
||||
write(lind,6111) maxp
|
||||
6111 FORMAT( ' Maximum nodes =',i8)
|
||||
call symbl(1.1,0.9,0.20,LIND,0.0,80)
|
||||
|
||||
!
|
||||
! Open files
|
||||
!
|
||||
IBAK = 21
|
||||
OPEN(IBAK,FILE='ELT.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost)
|
||||
if(iost .gt. 0) then
|
||||
OPEN(IBAK,FILE='ELT1.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost)
|
||||
if(iost .gt. 0) then
|
||||
OPEN(IBAK,FILE='ELT2.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost)
|
||||
if(iost .gt. 0) then
|
||||
write(*,*) 'ERROR UNABLE TO OPEN ELT.BAK FILE'
|
||||
write(*,*) 'PRESS RETURN TO END'
|
||||
read(*,'(I5)') junk
|
||||
STOP
|
||||
endif
|
||||
ENDIF
|
||||
ENDIF
|
||||
! OPEN(IBAK,FILE='ELT.BAK',STATUS='UNKNOWN',FORM='BINARY')
|
||||
|
||||
IS11=94
|
||||
INQUIRE(FILE='startup.dat',EXIST= EXST)
|
||||
IF(EXST) THEN
|
||||
OPEN(IS11 ,FILE='startup.dat',STATUS='OLD',FORM='FORMATTED')
|
||||
ELSE
|
||||
IS11=0
|
||||
ENDIF
|
||||
|
||||
! Initialize variables
|
||||
NCLM=0
|
||||
|
||||
!ipk may94 add 2 lines below
|
||||
XREF=0.
|
||||
YREF=0.
|
||||
MNP = MAXP
|
||||
MEL = MAXE
|
||||
!! uncertain call INITSIZ(0,0,1)
|
||||
nmapf=1
|
||||
NSIGF=1
|
||||
DO I=1,MNP
|
||||
XUSR(I) = -1.D20
|
||||
YUSR(I) = -1.D20
|
||||
CORD(I,1) = -1.D20
|
||||
CORD(I,2) = -1.D20
|
||||
WD(I) = -9999.
|
||||
LAY(I) = -9999
|
||||
WIDTH(I) = 0.0
|
||||
SS1(I) = 0.0
|
||||
SS2(I) = 0.0
|
||||
WIDS(I) = 0.0
|
||||
WIDBS(I)=0.
|
||||
SSO(I)=0.
|
||||
INSKP(I) = 1
|
||||
INEW(I) = 0
|
||||
!ipk mar02
|
||||
lock(i)=0
|
||||
bs1(I)=0.
|
||||
ENDDO
|
||||
!
|
||||
DO I=1,MEL
|
||||
DO K=1,8
|
||||
NOP(I,K) = 0
|
||||
ENDDO
|
||||
!
|
||||
IEM(I) = 0
|
||||
IMAT(I) = 0
|
||||
THTA(I)=0.
|
||||
XC(I) = -1.E20
|
||||
YC(I) = -1.E20
|
||||
IESKP(I) = -1
|
||||
ENDDO
|
||||
!
|
||||
MLIN = MAXLIN
|
||||
DO I=1,MLIN
|
||||
LINTYP(I) = -999
|
||||
ENDDO
|
||||
!IPK OCT96
|
||||
DO I=1,10
|
||||
ICOLON(I)=1
|
||||
ENDDO
|
||||
|
||||
!ipk mar00 define default values for CMAP
|
||||
DO J=1,MAXPTS
|
||||
CMAP(J,1) = -1.e20
|
||||
CMAP(J,2) = -1.e20
|
||||
enddo
|
||||
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,269 @@
|
||||
!IPK LAST UPDATE jAN 25 2001 INCREMENT NP FOR ALREADY EXISTING NODES IN NOP
|
||||
!IPK LAST UPDATE APR 6 1998
|
||||
SUBROUTINE FILM(ISWT)
|
||||
!june93 SUBROUTINE FILM(IFILL)
|
||||
!-
|
||||
! ISWT = 0 means read a value for IFILL
|
||||
! ISWT = 1 means use a value of 1 for IFILL
|
||||
! If IFILL = 1, use all unused node nos. for filling midside nodes
|
||||
! If IFILL = 0, start midside node numbering with max node no.
|
||||
!-
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
INCLUDE 'BFILES.I90'
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
|
||||
INTEGER NUSED(MAXP)
|
||||
|
||||
!IPK MAY02
|
||||
REAL*8 XX,YY
|
||||
data itime/0/
|
||||
|
||||
if(itime .eq. 0) then
|
||||
ifill=0
|
||||
itime=1
|
||||
endif
|
||||
! call WcursorShape(1)
|
||||
NHTPsv = nhtp
|
||||
NMESSsv = nmess
|
||||
NBRRsv = nbrr
|
||||
NHTP = 0
|
||||
NBRR = 0
|
||||
NMESS=45
|
||||
CALL HEDR
|
||||
NMESS = 19
|
||||
xprt=3.2
|
||||
!
|
||||
IF(ISWT .EQ. 0) THEN
|
||||
CALL GETINT(IFILL)
|
||||
ELSE
|
||||
IFILL=1
|
||||
ENDIF
|
||||
!
|
||||
|
||||
!-
|
||||
!-.....FIND MISSING NODE NUMBERS.....
|
||||
!-
|
||||
NP0 = 0
|
||||
DO 10 I=1,MAXP
|
||||
10 NUSED(I) = 0
|
||||
DO 101 J = 1, NE
|
||||
IF( IMAT(J) .EQ. 0 ) GO TO 101
|
||||
DO 100 K = 1, 8
|
||||
IF( NOP(J,K) .LE. 0) GOTO 100
|
||||
NUSED(NOP(J,K))=999
|
||||
100 END DO
|
||||
101 END DO
|
||||
|
||||
! Form list of elements connected to nodes
|
||||
IERR=0
|
||||
CALL NDNECON(IERR)
|
||||
IF(IERR .GT. 0) THEN
|
||||
LIMIT=MAXECON
|
||||
CALL NODERR(IERR,LIMIT)
|
||||
GO TO 200
|
||||
ENDIF
|
||||
!C-
|
||||
!C-.....PUT INPUTS INTO PROPER LOCATIONS.....
|
||||
!C-
|
||||
! DO 140 J = 1, NE
|
||||
! IF( IMAT(J) .EQ. 0 ) GO TO 140
|
||||
! IF( NOP(J,5) .GT. 0 ) GO TO 140
|
||||
! DO 130 K = 1, 4
|
||||
! IT(K) = NOP(J,K)
|
||||
! NOP(J,K) = 0
|
||||
! 130 CONTINUE
|
||||
! KK = 0
|
||||
! DO 135 K = 1, 8, 2
|
||||
! KK = KK + 1
|
||||
! NOP(J,K) = IT(KK)
|
||||
! 135 CONTINUE
|
||||
! 140 CONTINUE
|
||||
!-
|
||||
!-.....INSERT NEW NUMBERS.....
|
||||
!-
|
||||
NP0=0
|
||||
IF(IFILL .EQ. 0) NP0=NP
|
||||
DO 190 J = 1, NE
|
||||
!ipk apr98 IF( IMAT(J) .GT. 0 .AND. IMAT(J) .LT.901) THEN
|
||||
IF(( IMAT(J) .GT. 0 .AND. IMAT(J) .LT.901) .or. &
|
||||
& imat(j) .gt. 903) THEN
|
||||
NCN = NCORN(J)
|
||||
JN = J + 1
|
||||
DO 180 K = 2, NCN, 2
|
||||
if((imat(j) .gt. 995 .and. imat(j) .lt. 1999) .and. (k .eq. 4 .or. k .eq. 8) &
|
||||
& ) go to 180
|
||||
NA = K - 1
|
||||
NB = MOD(K+1,NCN)
|
||||
IF(NB .EQ. 0) NB=NCN
|
||||
NA = NOP(J,NA)
|
||||
NB = NOP(J,NB)
|
||||
AA=(WD(NA)+WD(NB))/2.
|
||||
AB=(WD1(NA)+WD1(NB))/2.
|
||||
IF( NOP(J,K) .EQ. 0 ) THEN
|
||||
IRDONE=0
|
||||
99 NP0 = NP0 + 1
|
||||
IF(NP0 .GT. MAXP) THEN
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Execution terminated, nodal limits exceeded. Backup written','LIMITS EXCEEDED')
|
||||
CALL WRTOUT(0)
|
||||
STOP
|
||||
ENDIF
|
||||
IF(INEW(NP0) .EQ. 1) GO TO 99
|
||||
IF (NUSED(NP0) .GT. 0) GOTO 99
|
||||
NOP(J,K) = NP0
|
||||
XX=(CORD(NA,1)+CORD(NB,1))/2.
|
||||
YY=(CORD(NA,2)+CORD(NB,2))/2.
|
||||
CORD(NP0,1)=XX
|
||||
CORD(NP0,2)=YY
|
||||
WD(NP0)=AA
|
||||
WD1(NP0)=AB
|
||||
WIDTH(NP0)=(WIDTH(NA)+WIDTH(NB))/2.
|
||||
SS1(NP0)=(SS1(NA)+SS1(NB))/2.
|
||||
SS2(NP0)=(SS2(NA)+SS2(NB))/2.
|
||||
WIDS(NP0)=(WIDS(NA)+WIDS(NB))/2.
|
||||
WIDBS(NP0)=(WIDBS(NA)+WIDBS(NB))/2.
|
||||
BS1(NP0)=(BS1(NA)+BS1(NB))/2.
|
||||
|
||||
|
||||
INEW(NP0) = 1
|
||||
IF(LOCK(NA) .EQ. 1 .AND. LOCK(NB) .EQ. 1) LOCK(NP0)=1
|
||||
XUSR(NP0) = XX*TXSCAL - XS
|
||||
|
||||
YUSR(NP0) = YY*TXSCAL - YS
|
||||
INSKP(NP0) = 0
|
||||
!SSO(N),-
|
||||
!,BS1(N)-.....SEARCH FOR OTHER ELEMENT.....
|
||||
!-
|
||||
!ipk dec98 set a counter
|
||||
ielct=0
|
||||
|
||||
!ipk0ct93 DO 170 JJ = JN, NE
|
||||
|
||||
DO 170 JJJ=1,NDELM(NA)
|
||||
JJ=NECON(NA,JJJ)
|
||||
!IPK SEP02 DO 170 JJ = 1, NE
|
||||
!ipkoct93 IF( IMAT(JJ) .GT. 0 .OR. IMAT(JJ) .LT.901) THE
|
||||
if(jj .eq. j) go to 170
|
||||
if(imat(jj) .gt. 0) then
|
||||
NNCN = NCORN(JJ)
|
||||
DO 160 KK = 2, NNCN, 2
|
||||
IF( NOP(JJ,KK-1) .EQ. NB ) THEN
|
||||
KN = MOD(KK+1,NNCN)
|
||||
IF(KN .EQ. 0) KN=NNCN
|
||||
IF( NOP(JJ,KN) .EQ. NA ) THEN
|
||||
NOP(JJ,KK) = NP0
|
||||
!ipk dec98
|
||||
ielct=ielct+1
|
||||
if(ielct .eq. 2) then
|
||||
GO TO 180
|
||||
else
|
||||
go to 170
|
||||
endif
|
||||
!ipk dec98 end changes
|
||||
ENDIF
|
||||
!IPK APR98 ADD
|
||||
ELSEIF( NOP(JJ,KK-1) .EQ. NA ) THEN
|
||||
KN = MOD(KK+1,NNCN)
|
||||
IF(KN .EQ. 0) KN=NNCN
|
||||
IF( NOP(JJ,KN) .EQ. NB ) THEN
|
||||
NOP(JJ,KK) = NP0
|
||||
!ipk dec98
|
||||
ielct=ielct+1
|
||||
if(ielct .eq. 2) then
|
||||
GO TO 180
|
||||
else
|
||||
go to 170
|
||||
endif
|
||||
!ipk dec98 end changes
|
||||
ENDIF
|
||||
!IPK APR98
|
||||
ENDIF
|
||||
160 CONTINUE
|
||||
ENDIF
|
||||
170 CONTINUE
|
||||
ELSE
|
||||
NM=NOP(J,K)
|
||||
IF(INEW(NM) .NE. 1) THEN
|
||||
XX=(CORD(NA,1)+CORD(NB,1))/2.
|
||||
YY=(CORD(NA,2)+CORD(NB,2))/2.
|
||||
CORD(NM,1)=XX
|
||||
CORD(NM,2)=YY
|
||||
WD(NM)=AA
|
||||
WD1(NM)=AB
|
||||
WIDTH(NM)=(WIDTH(NA)+WIDTH(NB))/2.
|
||||
SS1(NM)=(SS1(NA)+SS1(NB))/2.
|
||||
SS2(NM)=(SS2(NA)+SS2(NB))/2.
|
||||
WIDS(NM)=(WIDS(NA)+WIDS(NB))/2.
|
||||
WIDBS(NM)=(WIDBS(NA)+WIDBS(NB))/2.
|
||||
BS1(NM)=(BS1(NA)+BS1(NB))/2.
|
||||
INEW(NM) = 1
|
||||
IF(LOCK(NA) .EQ. 1 .AND. LOCK(NB) .EQ. 1) LOCK(NM)=1
|
||||
XUSR(NM) = XX*TXSCAL - XS
|
||||
YUSR(NM) = YY*TXSCAL - YS
|
||||
INSKP(NM) = 0
|
||||
!ipk jan01
|
||||
IF(NM .GT. NP) NP=NM
|
||||
ELSE
|
||||
WD(NM)=AA
|
||||
WD1(NM)=AB
|
||||
ENDIF
|
||||
ENDIF
|
||||
180 CONTINUE
|
||||
ENDIF
|
||||
190 CONTINUE
|
||||
IF (NP0 .GT. NP) NP=NP0
|
||||
200 CONTINUE
|
||||
NHTP = nhtpsv
|
||||
NMESS = nmesssv
|
||||
NBRR = nbrrsv
|
||||
! call WcursorShape(0)
|
||||
|
||||
!IPK MAY03
|
||||
ICHG=0
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE NODERR(NODER,LIMIT)
|
||||
|
||||
USE WINTERACTER
|
||||
include 'd.inc'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
|
||||
INTEGER :: IERR,NODER,LIMIT
|
||||
|
||||
call wdialogload(IDD_NODERR)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_NODERR)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(IDF_INTEGER2,LIMIT)
|
||||
CALL WDialogPutInteger(IDF_INTEGER3,NODER)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
RETURN
|
||||
ELSE
|
||||
RETURN
|
||||
ENDIF
|
||||
enddo
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,293 @@
|
||||
SUBROUTINE FILLTR
|
||||
USE WINTERACTER
|
||||
USE IFPORT
|
||||
USE BLKMAP
|
||||
CHARACTER(LEN=256) :: FILTER,FNAME
|
||||
CHARACTER(LEN=80) :: DATAIN,OPTIONS
|
||||
CHARACTER(LEN=96) :: LOCDIR
|
||||
CHARACTER(LEN=3) :: SUB
|
||||
INTEGER INOUTL,NOUTL,OUTPOL
|
||||
INTEGER NTRIAN(5000,2),TWO,ZERO,ntrans(5000)
|
||||
INTEGER*2 RESULT
|
||||
LOGICAL EXISTS
|
||||
do k=1,80
|
||||
options(k:k)=' '
|
||||
enddo
|
||||
TWO=2
|
||||
ZERO=0
|
||||
INOUTL=22
|
||||
OUTPOL=23
|
||||
VOID = - 1.0E+10
|
||||
VDX = - 1.0E+9
|
||||
|
||||
!
|
||||
! get filename
|
||||
|
||||
! FILTER ="Data files|*.dat;*.txt;*.map|Map file -- *.map|*.map|"
|
||||
! CALL WSelectFile(FILTER,PromptOn+DirChange+Appendext,FNAME,'Load data file')
|
||||
|
||||
! IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
! OPEN(INOUTL,FILE=FNAME,STATUS='OLD')
|
||||
! CALL IlowerCase(FNAME)
|
||||
! CALL GETSUB(FNAME,SUB)
|
||||
! IF(SUB .EQ. 'map') then
|
||||
! IMAPIN=1
|
||||
! ELSE
|
||||
! IMAPIN=0
|
||||
! ENDIF
|
||||
! ELSE
|
||||
! WRITE(*,*) 'ERROR NO FILE'
|
||||
! ENDIF
|
||||
IMAPIN=1
|
||||
! read outline
|
||||
!
|
||||
IF(IMAPIN .EQ. 1) THEN
|
||||
OPEN(113,FORM='BINARY',STATUS='SCRATCH')
|
||||
WRITE(113) XMAP,YMAP
|
||||
REWIND (113)
|
||||
DO K=1,5000
|
||||
IF(XMAP(K) .LT. VDX) THEN
|
||||
NOUTL=K-1
|
||||
GO TO 90
|
||||
ENDIF
|
||||
ENDDO
|
||||
90 CONTINUE
|
||||
ELSE
|
||||
! IF(IMAPIN .EQ. 1) READ(INOUTL,'(A80)') DATAIN
|
||||
DO K=1,5000
|
||||
READ(INOUTL,'(A80)') DATAIN
|
||||
IF(DATAIN(1:3) .EQ. 'END' .OR. DATAIN(1:3) .EQ. 'end') then
|
||||
NOUTL=K-1
|
||||
GO TO 100
|
||||
ELSE
|
||||
READ(DATAIN,*) XMAP(K),YMAP(K)
|
||||
ENDIF
|
||||
ENDDO
|
||||
100 CONTINUE
|
||||
ENDIF
|
||||
IF(XMAP(NOUTL) .EQ. XMAP(1) .AND. YMAP(NOUTL) .EQ. YMAP(1)) THEN
|
||||
XMAP(NOUTL)=VOID
|
||||
YMAP(NOUTL)=VOID
|
||||
NOUTL=NOUTL-1
|
||||
LOOPC=1
|
||||
ELSE
|
||||
LOOPC=0
|
||||
ENDIF
|
||||
|
||||
DO J=1, NOUTL
|
||||
NTRIAN(J,1)=J
|
||||
NTRIAN(J,2)=J+1
|
||||
ENDDO
|
||||
NTRIAN(NOUTL,2)=1
|
||||
JC=NOUTL
|
||||
! read contours
|
||||
NOUTBE=NOUTL+1
|
||||
NOUTT=NOUTL
|
||||
DO N=1,100
|
||||
if(imapin .eq. 1) then
|
||||
noutb=noutt+2+LOOPC
|
||||
ncnt=0
|
||||
DO K=NOUTB,5000
|
||||
if(k .eq. noutb) then
|
||||
if(xmap(k) .lt. vdx) go to 300
|
||||
endif
|
||||
IF(XMAP(K) .LT. VDX) THEN
|
||||
NOUTT=K-1
|
||||
GO TO 110
|
||||
ENDIF
|
||||
ncnt=ncnt+1
|
||||
ENDDO
|
||||
110 CONTINUE
|
||||
else
|
||||
READ(INOUTL,'(A80)', END=300) DATAIN
|
||||
IF(DATAIN(1:3) .EQ. 'END') GO TO 300
|
||||
NOUTB=NOUTT+1
|
||||
NCNT=0
|
||||
DO K=NOUTB,5000
|
||||
READ(INOUTL,'(A80)') DATAIN
|
||||
IF(DATAIN(1:3) .EQ. 'END' .OR. DATAIN(1:3) .EQ. 'end') then
|
||||
NOUTT=K-1
|
||||
GO TO 200
|
||||
ELSE
|
||||
READ(DATAIN,*) XMAP(K),YMAP(K)
|
||||
NCNT=NCNT+1
|
||||
ENDIF
|
||||
ENDDO
|
||||
200 CONTINUE
|
||||
endif
|
||||
IF(XMAP(NOUTT) .EQ. XMAP(NOUTB) .AND. YMAP(NOUTT) .EQ. YMAP(NOUTB)) THEN
|
||||
XMAP(NOUTT)=VOID
|
||||
YMAP(NOUTT)=VOID
|
||||
NOUTT=NOUTT-1
|
||||
LOOPC=1
|
||||
ELSE
|
||||
LOOPC=0
|
||||
ENDIF
|
||||
JC=NOUTB-1
|
||||
JCB=JC+1
|
||||
DO J=NOUTBE, NOUTBE+NCNT-2-LOOPC
|
||||
JC=JC+1
|
||||
NTRIAN(J,1)=JC
|
||||
NTRIAN(J,2)=JC+1
|
||||
ENDDO
|
||||
IF(LOOPC .EQ. 1) THEN
|
||||
NTRIAN(NOUTBE+NCNT-2,1)=JC+1
|
||||
NTRIAN(NOUTBE+NCNT-2,2)=JCB
|
||||
NOUTBE=NOUTBE+NCNT-1
|
||||
ELSE
|
||||
NOUTBE=NOUTBE+NCNT-1
|
||||
ENDIF
|
||||
JC=JC+1
|
||||
ENDDO
|
||||
! copy to a file
|
||||
300 CONTINUE
|
||||
OPEN(OUTPOL,FILE='TEST.POLY', STATUS='UNKNOWN')
|
||||
ncnt=0
|
||||
DO K=1,NOUTT
|
||||
if(xmap(k) .lt. vdx) cycle
|
||||
ncnt=ncnt+1
|
||||
ntrans(k)=ncnt
|
||||
ENDDO
|
||||
WRITE(OUTPOL,*) NCNT,TWO,ZERO,ZERO
|
||||
ncnt=0
|
||||
DO K=1,noutt
|
||||
if(xmap(k) .lt. vdx) cycle
|
||||
ncnt=ncnt+1
|
||||
WRITE(OUTPOL,*) ncnt,XMAP(K),YMAP(K)
|
||||
ENDDO
|
||||
WRITE(OUTPOL,*) NOUTBE-1,ZERO
|
||||
DO J=1, NOUTBE-1
|
||||
WRITE(OUTPOL,*) J,ntrans(NTRIAN(J,1)),ntrans(NTRIAN(J,2))
|
||||
ENDDO
|
||||
WRITE(OUTPOL,*) ZERO
|
||||
FLUSH (OUTPOL)
|
||||
REWIND (OUTPOL)
|
||||
CLOSE (OUTPOL)
|
||||
! close (inoutl)
|
||||
! setup options
|
||||
|
||||
! OPTIONS = ' -pqa5000V TEST'
|
||||
OPTIONS(1:3) = ' -p'
|
||||
nct=3
|
||||
iswq=1
|
||||
iswy=0
|
||||
id1=100
|
||||
CALL PANELFILLT(ISWQ,ISWY,ID1)
|
||||
|
||||
IF(ISWQ .EQ. 1) THEN
|
||||
NCT=NCT+1
|
||||
OPTIONS(NCT:NCT)='q'
|
||||
ENDIF
|
||||
IF(ISWY .EQ. 1) THEN
|
||||
NCT=NCT+1
|
||||
OPTIONS(NCT:NCT)='q'
|
||||
ENDIF
|
||||
ID1=ID1**2/2
|
||||
WRITE(OPTIONS(NCT+1:NCT+12),'(''a'',I6.6,'' TEST'')') ID1
|
||||
! go to TRIANGLE
|
||||
|
||||
INQUIRE (FILE = 'test.1.ele', EXIST = exists)
|
||||
if(exists) then
|
||||
open(77,file= 'test.1.ele')
|
||||
close(77,status='DELETE')
|
||||
ENDIF
|
||||
|
||||
INQUIRE (FILE = 'test.1.node', EXIST = exists)
|
||||
if(exists) then
|
||||
open(77,file= 'test.1.node')
|
||||
close(77,status='DELETE')
|
||||
ENDIF
|
||||
|
||||
INQUIRE (FILE = 'test.1.poly', EXIST = exists)
|
||||
if(exists) then
|
||||
open(77,file= 'test.1.poly')
|
||||
close(77,status='DELETE')
|
||||
ENDIF
|
||||
INQUIRE (FILE = "C:\Program Files\RMA\TRIANGLE.EXE", EXIST = exists)
|
||||
if(.not. exists) then
|
||||
INQUIRE (FILE = "TRIANGLE.EXE", EXIST = exists)
|
||||
if(.not. exists) then
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'TRIANGLE is not available in '//CHAR(13)//&
|
||||
'C:\Program Files\RMA\ directory'//CHAR(13)//'Do you wish to define directory?'&
|
||||
,'WARNING TRIANGLE IS NOT AVAILABLE')
|
||||
|
||||
! If answer 'No', return
|
||||
!
|
||||
IF (WInfoDialog(4).EQ.2) return
|
||||
CALL GETDIR(LOCDIR)
|
||||
else
|
||||
LOCDIR(1:8)='TRIANGLE'
|
||||
! WRITE(155,*) LOCDIR
|
||||
RESULT= RUNQQ(LOCDIR, OPTIONS)
|
||||
GO TO 600
|
||||
endif
|
||||
endif
|
||||
|
||||
RESULT= RUNQQ("C:\Program Files\RMA\TRIANGLE", OPTIONS)
|
||||
! RESULT= RUNQQ("TRIANGLE", OPTIONS)
|
||||
600 CONTINUE
|
||||
IF(IMAPIN .EQ. 1) THEN
|
||||
READ(113) XMAP,YMAP
|
||||
CLOSE (113)
|
||||
ENDIF
|
||||
IIN=10
|
||||
OPEN(IIN,FILE='TEST.1.ELE', STATUS='OLD')
|
||||
|
||||
CALL GETNEWFIL(IIN,0,1,1)
|
||||
|
||||
|
||||
! finish up
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE PANELFILLT(N1,N2,N3)
|
||||
|
||||
use winteracter
|
||||
implicit none
|
||||
SAVE
|
||||
|
||||
include 'D.inc'
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: N1,N2,N3,IERR,ITIME
|
||||
! real ::
|
||||
! character*3 ::
|
||||
DATA ITIME/0/
|
||||
! IF(ITIME .EQ. 0) THEN
|
||||
! ITIME=1
|
||||
! N1=1
|
||||
! N2=0
|
||||
! N3=100
|
||||
! ENDIF
|
||||
|
||||
call wdialogload(IDD_FTRIAN)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutCheckBox(idf_check1,n1)
|
||||
CALL WDialogPutCheckBox(idf_check2,n2)
|
||||
CALL WDialogPutInteger(idf_integer1,n3)
|
||||
|
||||
|
||||
CALL WDialogSelect(IDD_FTRIAN)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WDialogGetCheckBox(idf_check1,n1)
|
||||
CALL WDialogGetCheckBox(idf_check2,n2)
|
||||
CALL WDialogGetInteger(idf_integer1,n3)
|
||||
ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
N3=-1
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,145 @@
|
||||
SUBROUTINE FORMGP
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
include 'd.inc'
|
||||
|
||||
CHARACTER*47 MESSAGE
|
||||
|
||||
DATA MESSAGE /'Enter Group Number'/
|
||||
|
||||
DATA ITIME/0/
|
||||
|
||||
! SWITCH TO GROUP ACTIVITY
|
||||
|
||||
IF(IQSW(1) .EQ. 1) IQSW(1)=2
|
||||
IF(IQSW(2) .EQ. 1) IQSW(2)=2
|
||||
|
||||
|
||||
! IF FIRST TIME ASK TO LOAD FILE OR SET GROUPS = 1
|
||||
|
||||
if(ITIME .EQ. 0) THEN
|
||||
! ALLOCATE ARRAY SIZES
|
||||
|
||||
IF(.NOT. ALLOCATED(IGRPNUM)) THEN
|
||||
ALLOCATE (IGRPNUM(25,MAXE),MAXENT(25))
|
||||
CALL TOPAR
|
||||
ENDIF
|
||||
ISW=2
|
||||
ITIME=1
|
||||
ELSE
|
||||
CALL TOPAR
|
||||
ENDIF
|
||||
|
||||
|
||||
! ASSIGN A NUMBER TO THE NEW GROUP
|
||||
|
||||
call wdialogload(IDD_GETINT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_GETINT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutString(IDF_STRING1,MESSAGE)
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,ISW)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
! Branch depending on type of message.
|
||||
!
|
||||
DO
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,ISW)
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
200 CONTINUE
|
||||
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish add these elements to the current group?'//&
|
||||
CHAR(13)//' ','ADD ELEMENTS?')
|
||||
|
||||
! If answer 'No', start afresh
|
||||
!
|
||||
IF (WInfoDialog(4).EQ.2) then
|
||||
|
||||
! STORE GROUP NUMBERS STARTING AT 1
|
||||
|
||||
DO K=1,NEFL
|
||||
IGRPNUM(ISW,K)=NEFLAG(K)
|
||||
ENDDO
|
||||
MAXENT(ISW)=NEFL
|
||||
ELSE
|
||||
!
|
||||
! FOR EACH ELEMENT SEARCH FIRST IF NOT FOUND ADD TO THE END
|
||||
|
||||
DO K=1,NEFL
|
||||
DO J=1,MAXENT(ISW)
|
||||
IF(NEFLAG(K) .EQ. IGRPNUM(ISW,J)) GO TO 240
|
||||
ENDDO
|
||||
MAXENT(ISW)=MAXENT(ISW)+1
|
||||
IGRPNUM(ISW,MAXENT(ISW))=NEFLAG(K)
|
||||
240 CONTINUE
|
||||
ENDDO
|
||||
ENDIF
|
||||
|
||||
! REMOVE FROM OLD LIST
|
||||
DO I=1,25
|
||||
IF(I .NE. ISW) THEN
|
||||
DO J=1,MAXENT(I)
|
||||
DO K=1,NEFL
|
||||
IF(NEFLAG(K) .EQ. IGRPNUM(I,J)) THEN
|
||||
IGRPNUM(I,J)=0
|
||||
GO TO 260
|
||||
ENDIF
|
||||
ENDDO
|
||||
260 CONTINUE
|
||||
ENDDO
|
||||
JT=0
|
||||
LIMIT=MAXENT(I)
|
||||
J=0
|
||||
270 J=J+1
|
||||
275 IF(J+JT .LE. LIMIT) THEN
|
||||
IF(IGRPNUM(I,J+JT) .EQ. 0) THEN
|
||||
JT=JT+1
|
||||
GO TO 275
|
||||
ENDIF
|
||||
IGRPNUM(I,J)=IGRPNUM(I,J+JT)
|
||||
GO TO 270
|
||||
ENDIF
|
||||
DO J=MAXENT(I),MAXENT(I)+1-JT,-1
|
||||
IGRPNUM(I,J)=0
|
||||
ENDDO
|
||||
MAXENT(I)=MAXENT(I)-JT
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
CALL TOSER
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE TOSER
|
||||
USE BLK1MOD
|
||||
DO I=1,25
|
||||
DO J=1,MAXENT(I)
|
||||
IGRPSER(IGRPNUM(I,J))=I
|
||||
ENDDO
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE TOPAR
|
||||
USE BLK1MOD
|
||||
|
||||
MAXENT=0
|
||||
IGRPNUM=0
|
||||
|
||||
DO K=1,NE
|
||||
I=IGRPSER(K)
|
||||
MAXENT(I)=MAXENT(I)+1
|
||||
IGRPNUM(I,MAXENT(I))=K
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,455 @@
|
||||
subroutine formshp2(istyp,ivecact)
|
||||
use winteracter
|
||||
|
||||
include 'D.inc'
|
||||
|
||||
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||||
character*1 ai1a,ai1b,ai1c,ai1d,label,ai1f
|
||||
character*3 sub
|
||||
character*4 ai1,ai7,aai7,ai8,ai9,anrs,aii,aioff
|
||||
character*10 as
|
||||
character*11 name
|
||||
character*80 headr
|
||||
character*255 fnamein,filter
|
||||
integer*2 i3s,i4s
|
||||
integer status,i1,i2,i3,i4,i5,i6,i7,i8,i9,ia1,ia7,ia8,ia9,nrs&
|
||||
,nars,ii,ioff,iaoff,i1a,i1b,i1c,i1d,istyp,nptemp
|
||||
integer*8 i88
|
||||
real*8 fp1,fp2,fp3,fp4,fp5,fp6,fp7,fp8,bx(1000),by(1000),bm(1000)&
|
||||
,bxmn,bymn,bxmx,bymx,bmmn,bmmx,axmn,aymn,axmx,aymx,fz,ammn,ammx
|
||||
real bed,val
|
||||
integer ityp,icl
|
||||
allocatable bed(:),val(:,:),ityp(:),icl(:)
|
||||
|
||||
LOGICAL OPENED
|
||||
equivalence(ai1,ia1),(ai7,ia7),(aii,ii),(anrs,nrs),(aioff,ioff)
|
||||
|
||||
if(.not. allocated(bed)) then
|
||||
allocate (bed(250000),val(250000,4),ityp(250000),icl(250000))
|
||||
bed=0.
|
||||
val=0.
|
||||
ityp=0
|
||||
icl=0
|
||||
endif
|
||||
filter='Shape file *.shp|*.shp|'
|
||||
INQUIRE(99,opened= OPENED)
|
||||
IF( .NOT. OPENED) THEN
|
||||
CALL WSelectFile(filter,SaveDialog+PromptOn+AppendExt,FNAMEIN,'Shapefile Name')
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
open(99,file=fnamein,form='binary')
|
||||
sub='shx'
|
||||
call ADDSUB(fnamein,sub)
|
||||
open(98,file=fnamein,form='binary')
|
||||
sub='dbf'
|
||||
call ADDSUB(fnamein,sub)
|
||||
open(97,file=fnamein,form='binary')
|
||||
ELSE
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDIF
|
||||
! read data file to establish sizes and max/min
|
||||
nfils=50
|
||||
axmn=1.e36
|
||||
aymn=1.e36
|
||||
ammn=1.e36
|
||||
axmx=-1.e36
|
||||
aymx=-1.e36
|
||||
ammx=-1.e36
|
||||
! if(ivecact .ne. 1) then
|
||||
! read(70,'(a80)') headr
|
||||
! read(70,'(a80)') headr
|
||||
! read(headr(9:16),'(i8)') istyp
|
||||
! endif
|
||||
do i=1,250000
|
||||
if(istyp .eq. 25) then
|
||||
read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts)
|
||||
do j=1,npts
|
||||
write(155,*) bx(j),by(j),bm(j)
|
||||
enddo
|
||||
icl(i)=iclt
|
||||
write(155,*) icl(i),ityp(i),npts
|
||||
do j=1,npts
|
||||
axmn=min(axmn,bx(j))
|
||||
aymn=min(aymn,by(j))
|
||||
ammn=min(ammn,bm(j))
|
||||
axmx=max(axmx,bx(j))
|
||||
aymx=max(aymx,by(j))
|
||||
ammx=max(ammx,bm(j))
|
||||
enddo
|
||||
! NEED TO FIX THIS
|
||||
nfils=nfils+36+12*npts
|
||||
! NEED TO FIX THIS
|
||||
elseif(istyp .eq. 5) then
|
||||
IF(IVECACT .EQ. 5) THEN
|
||||
read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts)
|
||||
ELSE
|
||||
read(113,end=100) iclt,npts,(bx(j),by(j),j=1,npts)
|
||||
ENDIF
|
||||
icl(i)=iclt
|
||||
do j=1,npts
|
||||
axmn=min(axmn,bx(j))
|
||||
aymn=min(aymn,by(j))
|
||||
axmx=max(axmx,bx(j))
|
||||
aymx=max(aymx,by(j))
|
||||
enddo
|
||||
ammn=0.
|
||||
ammx=0.
|
||||
nfils=nfils+28+8*npts
|
||||
elseif(istyp .eq. 3) then
|
||||
read(113,end=100) npts,(bx(j),by(j),j=1,npts),d1
|
||||
do j=1,npts
|
||||
axmn=min(axmn,bx(j))
|
||||
aymn=min(aymn,by(j))
|
||||
axmx=max(axmx,bx(j))
|
||||
aymx=max(aymx,by(j))
|
||||
enddo
|
||||
ammn=0.
|
||||
ammx=0.
|
||||
nfils=nfils+28+8*npts
|
||||
elseif(istyp .eq. 1 .and. ivecact .eq. 0) then
|
||||
read(70,9875,end=100) bx(1),by(1)
|
||||
9875 format(10x,2f20.0,f10.0)
|
||||
axmn=min(axmn,bx(1))
|
||||
aymn=min(aymn,by(1))
|
||||
axmx=max(axmx,bx(1))
|
||||
aymx=max(aymx,by(1))
|
||||
ammn=0.
|
||||
ammx=0.
|
||||
nfils=nfils+14
|
||||
elseif(istyp .eq. 1 .and. ivecact .eq. 1) then
|
||||
! read(113,end=100) NR,bxt,byt,d1,d2,d3,d4,d5,d6
|
||||
read(113,end=100) NR,bxt,byt,d1,d2,d3,d4
|
||||
9874 format(9x,8f14.0)
|
||||
axmn=min(axmn,bxt)
|
||||
aymn=min(aymn,byt)
|
||||
axmx=max(axmx,bxt)
|
||||
aymx=max(aymx,byt)
|
||||
ammn=0.
|
||||
ammx=0.
|
||||
nfils=nfils+14
|
||||
elseif(istyp .eq. 1 .and. ivecact .eq. 6) then
|
||||
read(113,end=100) NR,bx(1),by(1),d1
|
||||
axmn=min(axmn,bx(1))
|
||||
aymn=min(aymn,by(1))
|
||||
axmx=max(axmx,bx(1))
|
||||
aymx=max(aymx,by(1))
|
||||
ammn=0.
|
||||
ammx=0.
|
||||
nfils=nfils+14
|
||||
endif
|
||||
numdat=i
|
||||
enddo
|
||||
100 rewind 113
|
||||
|
||||
! read(70,'(a80)') headr
|
||||
!c if(ivecact .eq. 1) read(70,'(a80)') headr
|
||||
!c setup header
|
||||
ia1=9994
|
||||
call BTOL(ai1,i1)
|
||||
i2=0
|
||||
i3=0
|
||||
i4=0
|
||||
i5=0
|
||||
i6=0
|
||||
ia7=nfils
|
||||
call BTOL(ai7,i7)
|
||||
i8=1
|
||||
i9=istyp
|
||||
fz=0.
|
||||
write(99) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,fz,fz,ammn,ammx
|
||||
ia7=50+4*numdat
|
||||
call BTOL(ai7,i7)
|
||||
write(98) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,fz,fz,ammn,ammx
|
||||
ioff=50
|
||||
|
||||
! header now complete for shp and shx options
|
||||
do i=1,numdat
|
||||
if(istyp .eq. 25) then
|
||||
read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts)
|
||||
icl(i)=iclt
|
||||
nrs=32+12*npts
|
||||
nrsc=nrs+4
|
||||
! write(155,*) 'nrs',nrs
|
||||
call btol(anrs,nars)
|
||||
elseif(istyp .eq. 5) then
|
||||
IF(IVECACT .EQ. 5) THEN
|
||||
read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts)
|
||||
ELSE
|
||||
read(113) iclt,npts,(bx(j),by(j),j=1,npts)
|
||||
ENDIF
|
||||
icl(i)=iclt
|
||||
nrs=24+8*npts
|
||||
nrsc=nrs+4
|
||||
! write(155,*) 'nrs',nrs
|
||||
call btol(anrs,nars)
|
||||
elseif(istyp .eq. 3) then
|
||||
read(113) npts,(bx(j),by(j),j=1,npts),val(i,1)
|
||||
icl(i)=iclt
|
||||
nrs=24+8*npts
|
||||
nrsc=nrs+4
|
||||
! write(155,*) 'nrs',nrs
|
||||
call btol(anrs,nars)
|
||||
elseif(istyp .eq. 1) then
|
||||
if(ivecact .eq. 0) then
|
||||
read(70,9875) bx(1),by(1),bed(i)
|
||||
elseif(ivecact .eq. 6) then
|
||||
read(113) ityp(i),bx(1),by(1),val(i,1)
|
||||
else
|
||||
read(113) idum,bxt,byt,(val(i,j),j=1,4)
|
||||
bx(1)=bxt
|
||||
by(1)=byt
|
||||
endif
|
||||
nrs=10
|
||||
nrsc=14
|
||||
! write(155,*) 'nrs',nrs
|
||||
call btol(anrs,nars)
|
||||
endif
|
||||
ii=i
|
||||
call btol(aii,nrec)
|
||||
write(99) nrec,nars
|
||||
if(istyp .eq. 25) then
|
||||
j1=istyp
|
||||
j2=1
|
||||
bxmn=bx(1)
|
||||
bymn=by(1)
|
||||
bmmn=bm(1)
|
||||
bxmx=bx(1)
|
||||
bymx=by(1)
|
||||
bmmx=bm(1)
|
||||
do k=2,npts
|
||||
bxmn=min(bxmn,bx(k))
|
||||
bymn=min(bymn,by(k))
|
||||
bmmn=min(bmmn,bm(k))
|
||||
bxmx=max(bxmx,bx(k))
|
||||
bymx=max(bymx,by(k))
|
||||
bmmx=max(bmmx,bm(k))
|
||||
enddo
|
||||
j3=npts
|
||||
j4=0
|
||||
write(99) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4
|
||||
do k=1,npts
|
||||
write(99) bx(k),by(k)
|
||||
enddo
|
||||
write(99) bmmn,bmmx
|
||||
do k=1,npts
|
||||
write(99) bm(k)
|
||||
enddo
|
||||
|
||||
elseif(istyp .gt. 2) then
|
||||
j1=istyp
|
||||
j2=1
|
||||
bxmn=bx(1)
|
||||
bymn=by(1)
|
||||
bxmx=bx(1)
|
||||
bymx=by(1)
|
||||
do k=2,npts
|
||||
bxmn=min(bxmn,bx(k))
|
||||
bymn=min(bymn,by(k))
|
||||
bxmx=max(bxmx,bx(k))
|
||||
bymx=max(bymx,by(k))
|
||||
enddo
|
||||
j3=npts
|
||||
j4=0
|
||||
write(99) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4
|
||||
! write(155,*) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4
|
||||
do k=1,npts
|
||||
write(99) bx(k),by(k)
|
||||
! write(155,*) k,bx(k),by(k)
|
||||
enddo
|
||||
elseif(istyp .eq. 1) then
|
||||
j4=1
|
||||
write(99) j4,bx(1),by(1)
|
||||
endif
|
||||
! write(155,*) ioff,nrs
|
||||
call btol(aioff,iaoff)
|
||||
write(98) iaoff,nars
|
||||
ioff=ioff+nrsc
|
||||
enddo
|
||||
i1a=3
|
||||
i1b=115
|
||||
i1c=12
|
||||
i1d=9
|
||||
ai1a=char(i1a)
|
||||
ai1b=char(i1b)
|
||||
ai1c=char(i1c)
|
||||
ai1d=char(i1d)
|
||||
i2=numdat
|
||||
if(ivecact .eq. 0 .or. ivecact .gt. 3) then
|
||||
i4s=18
|
||||
i3s=97
|
||||
elseif(ivecact .eq. 3) then
|
||||
i4s=11
|
||||
i3s=65
|
||||
else
|
||||
i4s=37
|
||||
i3s=161
|
||||
endif
|
||||
i5=0
|
||||
write(97) ai1a,ai1b,ai1c,ai1d,i2,i3s,i4s,i5
|
||||
ai1a=char(0)
|
||||
ai1b='W'
|
||||
write(97) i5,i5,i5,ai1a,ai1a,ai1b,ai1a
|
||||
i2a=0
|
||||
IF(ISTYP .EQ. 25) THEN
|
||||
name='ID '
|
||||
label='N'
|
||||
i2=0
|
||||
ai1a=char(8)
|
||||
ai1b=char(0)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
ai1d=char(0)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
|
||||
name='Type '
|
||||
label='N'
|
||||
i2=0
|
||||
ai1a=char(9)
|
||||
ai1b=char(0)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f
|
||||
ELSEIF(ISTYP .EQ. 5) THEN
|
||||
name='ID '
|
||||
label='N'
|
||||
i2=0
|
||||
ai1a=char(8)
|
||||
ai1b=char(0)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
ai1d=char(0)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
|
||||
name='Contour '
|
||||
label='N'
|
||||
i2=0
|
||||
ai1a=char(9)
|
||||
ai1b=char(2)
|
||||
IF(IVECACT .EQ. 5) THEN
|
||||
name='TYPE * '
|
||||
label='N'
|
||||
ai1b=char(0)
|
||||
ENDIF
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f
|
||||
elseif(istyp .eq. 3) then
|
||||
name='CONTOUR '
|
||||
label='N'
|
||||
i2=0
|
||||
ai1a=char(10)
|
||||
ai1b=char(4)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
ai1d=char(0)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f
|
||||
elseif(istyp .eq. 1) then
|
||||
if(ivecact .eq. 6) then
|
||||
name='NODE '
|
||||
label='N'
|
||||
i2=0
|
||||
ai1a=char(8)
|
||||
ai1b=char(0)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
ai1d=char(0)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
|
||||
name='Bed Elev '
|
||||
label='F'
|
||||
i2=0
|
||||
ai1a=char(9)
|
||||
ai1b=char(3)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f
|
||||
else
|
||||
name='VEL '
|
||||
label='N'
|
||||
i2=0
|
||||
ai1a=char(9)
|
||||
ai1b=char(4)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
ai1d=char(0)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
|
||||
name='DIR '
|
||||
label='N'
|
||||
i2=0
|
||||
ai1a=char(9)
|
||||
ai1b=char(2)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
|
||||
name='DEP '
|
||||
label='F'
|
||||
i2=0
|
||||
ai1a=char(9)
|
||||
ai1b=char(3)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
|
||||
name='WS-ELEV '
|
||||
label='N'
|
||||
i2=0
|
||||
ai1a=char(9)
|
||||
ai1b=char(3)
|
||||
ai1c=char(0)
|
||||
ai1f=char(13)
|
||||
write(97)name,label,i2,ai1a,ai1b,i2,i2,i2,ai1d,ai1c
|
||||
write(97)ai1f
|
||||
endif
|
||||
endif
|
||||
ai1a=char(32)
|
||||
ai1f=char(32)
|
||||
do i=1,numdat
|
||||
write(97) ai1a
|
||||
if(istyp .eq. 25) then
|
||||
write(as(1:8),'(i8)') icl(i)
|
||||
write(97) as(1:8)
|
||||
write(as(1:9),'(i9)') ityp(i)
|
||||
write(97) as(1:9)
|
||||
elseif(istyp .eq. 5) then
|
||||
write(as(1:8),'(i8)') icl(i)
|
||||
write(97) as(1:8)
|
||||
if(IVECACT .EQ. 5) then
|
||||
write(as(1:9),'(i9)') ityp(i)
|
||||
write(97) as(1:9)
|
||||
else
|
||||
ficl=contur(icl(i))
|
||||
write(as(1:9),'(f9.2)') ficl
|
||||
write(97) as(1:9)
|
||||
endif
|
||||
elseif(istyp .eq. 3) then
|
||||
write(as(1:10),'(f10.4)') val(i,1)
|
||||
write(97) as(1:10)
|
||||
elseif(istyp .eq. 1) then
|
||||
if(ivecact .eq. 0) then
|
||||
write(as(1:8),'(i8)') i
|
||||
write(97) as(1:8)
|
||||
write(as(1:8),'(f8.2)') bed(i)
|
||||
write(97) as(1:8)
|
||||
elseif(ivecact .eq. 6) then
|
||||
write(as(1:8),'(i8)') ityp(i)
|
||||
write(97) as(1:8)
|
||||
write(as(1:9),'(f9.2)') val(i,1)
|
||||
write(97) as(1:9)
|
||||
else
|
||||
write(as(1:9),'(f9.4)') val(i,1)
|
||||
write(97) as(1:9)
|
||||
write(as(1:9),'(f9.2)') val(i,2)
|
||||
write(97) as(1:9)
|
||||
write(as(1:9),'(f9.3)') val(i,3)
|
||||
write(97) as(1:9)
|
||||
write(as(1:9),'(f9.3)') val(i,4)
|
||||
write(97) as(1:9)
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
ai1a=char(26)
|
||||
write(97) ai1a
|
||||
close (99)
|
||||
close (98)
|
||||
close (97)
|
||||
return
|
||||
end
|
||||
|
||||
|
||||
@ -0,0 +1,29 @@
|
||||
SUBROUTINE FRMNODQ(X1,Y1,X2,Y2,X3,Y3,X4,Y4,NPTS1,NPTS2)
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
! X1,X2,X3,X4 AND Y1,Y2,Y3,Y4 are vertices of quad
|
||||
! NPTS1 and NPTS2 are the nominal number of elements on each side
|
||||
|
||||
|
||||
! Work along first side AND backwards along second line
|
||||
|
||||
DO N=1,NPTS1-1
|
||||
RATIO=FLOAT(N)/FLOAT(NPTS1)
|
||||
X12=X1+RATIO*(X2-X1)
|
||||
Y12=Y1+RATIO*(Y2-Y1)
|
||||
X43=X4+RATIO*(X3-X4)
|
||||
Y43=Y4+RATIO*(Y3-Y4)
|
||||
|
||||
! Now get interior points
|
||||
|
||||
DO M=1,NPTS2-1
|
||||
RATIO=FLOAT(M)/FLOAT(NPTS2)
|
||||
XNEW=X12+RATIO*(X43-X12)
|
||||
YNEW=Y12+RATIO*(Y43-Y12)
|
||||
CALL DEFNOD(XNEW,YNEW)
|
||||
ENDDO
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,144 @@
|
||||
SUBROUTINE GETALLANGS
|
||||
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
SAVE ICOUNTMX
|
||||
|
||||
DIMENSION ANGA(2),ANGB(2)
|
||||
|
||||
DATA ICOUNTMX/0/
|
||||
|
||||
IF(.NOT. ALLOCATED(NKEY1)) THEN
|
||||
ALLOCATE (NKEY1(MAXE))
|
||||
ENDIF
|
||||
IF(.NOT. ALLOCATED(ANGOP)) THEN
|
||||
ALLOCATE (ANGOP(MAXP))
|
||||
ENDIF
|
||||
|
||||
CALL HEDR
|
||||
ICOUNTMX=50
|
||||
ILMIT=0
|
||||
CALL GEtrev(ICOUNTMX,ILMIT)
|
||||
IF(ICOUNTMX .LT. 0) RETURN
|
||||
NKEY1=0
|
||||
! set all the nodal angles negative
|
||||
ANGOP=-1.
|
||||
! get elements connected to nodes table
|
||||
IERR=0
|
||||
CALL NDNECON(IERR)
|
||||
! loop on the elements to find mid-sides
|
||||
DO N=1,NE
|
||||
! work only with triangles
|
||||
IF(NCORN(N) .EQ. 6) THEN
|
||||
! go to each mid-side
|
||||
DO K=2,6,2
|
||||
N1=NOP(N,K-1)
|
||||
KN=MOD(K+1,6)
|
||||
N3=NOP(N,KN)
|
||||
KP=MOD(K+3,6)
|
||||
N2=NOP(N,KP)
|
||||
NCUR=NOP(N,K)
|
||||
IF(NCUR .EQ. 0) THEN
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK, &
|
||||
'You have tried to reverse before executing "FILL"'//CHAR(13) &
|
||||
//'Reversing terminated',&
|
||||
'UNABLE TO REVERSE')
|
||||
! CALL SYMBL(0.,7.30,0.20,STRELS,0.,60)
|
||||
RETURN
|
||||
ENDIF
|
||||
! call GETANG to get angle opposite N1-N3 line
|
||||
ANGTMP=GETANG(N1,N2,N3)
|
||||
IF(ANGTMP .GT. ANGOP(NCUR)) ANGOP(NCUR)=ANGTMP
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
! get the angles in ascending order
|
||||
CALL SORT(ANGOP,ICN,NP)
|
||||
|
||||
ICOUNT=0
|
||||
! loop backwards and use the sorrt key ICN
|
||||
DO J=NP,1,-1
|
||||
MIDND=ICN(J)
|
||||
! only work when angles greater than 90 deg
|
||||
IF(ANGOP(MIDND) .GT. 1.5708) THEN
|
||||
! check if there are two elements connected to this mid side
|
||||
IF(NECON(MIDND,2) .GT. 0) THEN
|
||||
! make sure the opposite elements are not quadrilaterals
|
||||
IF(NCORN(NECON(MIDND,1)) .EQ. 6 .AND. NCORN(NECON(MIDND,2)) .EQ. 6) THEN
|
||||
! only proceed when the first mid-side has not been processed
|
||||
IF(NKEY1(NECON(MIDND,1)) .EQ. 0) THEN
|
||||
NEL1=NECON(MIDND,1)
|
||||
! only proceed when the second mid-side has not been processed
|
||||
IF(NKEY1(NECON(MIDND,2)) .EQ. 0) THEN
|
||||
! we really have a candidate lest check if it will make the angles worse
|
||||
! first find the locations of the mid sides in the order data to get more angles
|
||||
DO KK=1,2
|
||||
DO K=2,6,2
|
||||
! test for a fit
|
||||
IF(NOP(NECON(MIDND,KK),K) .EQ. MIDND) THEN
|
||||
! get angles before and after
|
||||
! corner before
|
||||
N1=NOP(NECON(MIDND,KK),K-1)
|
||||
! corner after
|
||||
N3=MOD(K+1,6)
|
||||
N3=NOP(NECON(MIDND,KK),N3)
|
||||
! test for possible equal elev
|
||||
if(ilmit .eq. 1) then
|
||||
if(wd(n1) .gt. -9000.) then
|
||||
if(wd(n1) .eq. wd(n3)) go to 180
|
||||
endif
|
||||
endif
|
||||
! corner opposite
|
||||
N2=MOD(K+3,6)
|
||||
N2=NOP(NECON(MIDND,KK),N2)
|
||||
! call GETANG to get angle opposite N2-N3 LINE
|
||||
ANGB(KK)=GETANG(N2,N1,N3)
|
||||
! call GETANG to get angle opposite N1-N2 LINE
|
||||
ANGA(KK)=GETANG(N1,N3,N2)
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDDO
|
||||
! test if the side angles are larger, if so skip out
|
||||
IF(ANGOP(MIDND) .LT. ANGB(2)+ANGA(1)) GO TO 180
|
||||
IF(ANGOP(MIDND) .LT. ANGB(1)+ANGA(2)) GO TO 180
|
||||
! finally we can proceed
|
||||
ICOUNT=ICOUNT+1
|
||||
! NELPR(ICOUNT,2)=NECON(MIDND,2)
|
||||
! NELPR(ICOUNT,1)=NEL1
|
||||
NKEY1(NECON(MIDND,1))=1
|
||||
NKEY1(NECON(MIDND,2))=1
|
||||
N1=NEL1
|
||||
N2=NECON(MIDND,2)
|
||||
! carry out reversal
|
||||
CALL REVERS(N1,N2)
|
||||
! show the elements
|
||||
call fillemc(n1,4)
|
||||
call fillemc(n2,4)
|
||||
IF(ICOUNT .GE. ICOUNTMX) GO TO 200
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
ELSE
|
||||
GO TO 200
|
||||
ENDIF
|
||||
180 CONTINUE
|
||||
ENDDO
|
||||
200 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
FUNCTION GETANG(N1,N2,N3)
|
||||
|
||||
USE BLK1MOD
|
||||
|
||||
A=SQRT((XUSR(N1)-XUSR(N2))**2+(YUSR(N1)-YUSR(N2))**2)
|
||||
B=SQRT((XUSR(N2)-XUSR(N3))**2+(YUSR(N2)-YUSR(N3))**2)
|
||||
C=SQRT((XUSR(N3)-XUSR(N1))**2+(YUSR(N3)-YUSR(N1))**2)
|
||||
ANG1=(A**2+B**2-C**2)/(2.*A*B)
|
||||
IF(ANG1 .GT. 1.) ANG1=1.
|
||||
|
||||
GETANG=ACOS(ANG1)
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,276 @@
|
||||
SUBROUTINE GETCRS(CRSTIT)
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
CHARACTER*8 ID1
|
||||
CHARACTER*72 DLIN1,CRSTIT
|
||||
|
||||
!IPK JUN06
|
||||
DATA VOIDCR/-1.E15/
|
||||
MCRS=0
|
||||
MPTS=00
|
||||
DO
|
||||
call ginpt(icrin,id1,dlin1)
|
||||
IF(ID1(1:3) .EQ. 'ICS') THEN
|
||||
READ(DLIN1,'(I8)') MILCT
|
||||
MCRS=MAX(MILCT,MCRS)
|
||||
MPTCT=0
|
||||
DO
|
||||
call ginpt(icrin,id1,dlin1)
|
||||
IF(ID1(1:3) .EQ. 'CRS') THEN
|
||||
MPTCT=MPTCT+1
|
||||
ELSE
|
||||
MPTS=MAX(MPTCT,MPTS)
|
||||
EXIT
|
||||
ENDIF
|
||||
ENDDO
|
||||
ELSEIF(ID1(1:7) .EQ. 'ENDDATA') THEN
|
||||
REWIND (ICRIN)
|
||||
EXIT
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
ALLOCATE (IVMIL(MCRS),NRIVL(MCRS),NOREACH(MCRS)&
|
||||
,CRSDAT(MCRS,-4:MPTS,3),XCRS(MCRS),YCRS(MCRS))
|
||||
|
||||
XCRS=VOIDCR
|
||||
YCRS=VOIDCR
|
||||
NRIVCR1=0
|
||||
NRIVCR2=0
|
||||
!ipk jun11
|
||||
NOREACH=0
|
||||
NRIVL=0
|
||||
IVMIL=0
|
||||
|
||||
call ginpt(icrin,id1,dlin1)
|
||||
|
||||
IF(ID1(1:2) .EQ. 'TC') THEN
|
||||
CRSTIT=DLIN1
|
||||
call ginpt(icrin,id1,dlin1)
|
||||
ELSE
|
||||
CALL WMessageBox(0,3,1,'Cross-section Title not found'//char(13)//&
|
||||
'Cross-section file input terminated','ERROR')
|
||||
return
|
||||
ENDIF
|
||||
N=0
|
||||
|
||||
200 N=N+1
|
||||
IF(N .GT. MCRS) THEN
|
||||
CALL WMessageBox(0,3,1,'Allowable number of sections (1000) exceeded'//char(13)//&
|
||||
'Cross-section file input terminated','ERROR')
|
||||
return
|
||||
ENDIF
|
||||
IF(ID1(1:3) .EQ. 'RCH') THEN
|
||||
READ(DLIN1,'(I8)') NOREACHTMP
|
||||
write(90,'(a)') 'rch',id1,dlin1
|
||||
Call ginpt(icrin,id1,dlin1)
|
||||
ENDIF
|
||||
|
||||
IF(ID1(1:3) .EQ. 'ICS') THEN
|
||||
READ(DLIN1,'(2I8,8x,2f16.0)') IVMIL(N),NRIVL(IVMIL(N)),XCRS(IVMIL(N)),YCRS(IVMIL(N))
|
||||
|
||||
!
|
||||
! IVMIL = CROSS-SECTION NUMBER
|
||||
! NRIVL = NUMBER OF POINTS IN SECTION
|
||||
! NOREACH = REACH/TYPE NUMBER
|
||||
! CRSDAT 1 = ELEVATION
|
||||
! CRSDAT 2 = AREA
|
||||
! CRSDAT 3 = WIDTH
|
||||
|
||||
write(90,'(a)') 'ics',id1,dlin1
|
||||
NOREACH(IVMIL(N))=NOREACHTMP
|
||||
IF(NRIVL(IVMIL(N)) .GT. MPTS) THEN
|
||||
CALL WMessageBox(0,3,1,'Allowable number of points in a cross-section (75) exceeded'//char(13)//&
|
||||
'Cross-section file input terminated','ERROR')
|
||||
return
|
||||
ENDIF
|
||||
! IF(NOREACH(N) .EQ. 0) THEN
|
||||
! IF(N .GT. 1) THEN
|
||||
! NOREACH(N)=NOREACH(N-1)
|
||||
! ELSE
|
||||
! NOREACH(N)=1
|
||||
! ENDIF
|
||||
! ENDIF
|
||||
call ginpt(icrin,id1,dlin1)
|
||||
DO I=1,NRIVL(IVMIL(N))
|
||||
write(90,'(a)') 'crs',id1,dlin1
|
||||
READ(DLIN1,'(3F8.0)') (CRSDAT(IVMIL(N),I,J),J=1,3)
|
||||
!IPK JUN04
|
||||
if(i .gt. 1) then
|
||||
CRSDAT(IVMIL(N),I,2)=CRSDAT(IVMIL(N),I-1,2)+&
|
||||
(CRSDAT(IVMIL(N),I,1)-CRSDAT(IVMIL(N),I-1,1))*&
|
||||
(CRSDAT(IVMIL(N),I,3)+CRSDAT(IVMIL(N),I-1,3))/2.
|
||||
endif
|
||||
call ginpt(icrin,id1,dlin1)
|
||||
ENDDO
|
||||
NCRSEC=N
|
||||
! TEST NCRSEC=MAX(N,IVMIL(N))
|
||||
GO TO 200
|
||||
ENDIF
|
||||
|
||||
!ipk jun06 DO N=1,NCRSEC
|
||||
|
||||
DO N=1,MCRS
|
||||
IF(ID1(1:3) .EQ. 'XYL') THEN
|
||||
READ(DLIN1,'(I8,2F16.0)') NN,XCRS(NN),YCRS(NN)
|
||||
!IPK JUN06
|
||||
IF(NN .GT. NCRSEC) NCRSEC=NN
|
||||
call ginpt(icrin,id1,dlin1)
|
||||
ELSE
|
||||
GO TO 400
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
400 CONTINUE
|
||||
DO N=1,MAXP
|
||||
IF(ID1(1:3) .EQ. 'CRF') THEN
|
||||
READ(DLIN1,'(2I8,F8.0,I8,F8.0)') NODCRS&
|
||||
,NRIVCR1(NODCRS),WTRIVCR1(NODCRS)&
|
||||
,NRIVCR2(NODCRS),WTRIVCR2(NODCRS)
|
||||
call ginpt(icrin,id1,dlin1)
|
||||
ELSE
|
||||
GO TO 500
|
||||
ENDIF
|
||||
ENDDO
|
||||
500 CONTINUE
|
||||
|
||||
CLOSE(ICRIN)
|
||||
|
||||
! CHECK THE DATA LOADED
|
||||
|
||||
IERR=0
|
||||
DO N=1,NE
|
||||
IF(IMAT(N) .LT. 900) THEN
|
||||
IF(NCORN(N) .EQ. 3 .OR. NCORN(N) .EQ. 5) THEN
|
||||
DO J=1,3,2
|
||||
IF(NRIVCR1(NOP(N,J)) .NE. 0) THEN
|
||||
WD1(NOP(N,J))=&
|
||||
CRSDAT(NRIVCR1(NOP(N,J)),1,1)*WTRIVCR1(NOP(N,J))+&
|
||||
CRSDAT(NRIVCR2(NOP(N,J)),1,1)*WTRIVCR2(NOP(N,J))
|
||||
! ELSE
|
||||
! WRITE(75,*) ' NO CROSS-SECTION FILE REFERENCE FOR',NOP(N,J)
|
||||
! WRITE(75,*) ' EXECUTION TERMINATED'
|
||||
! WRITE(*,*) ' NO CROSS-SECTION FILE REFERENCE FOR',NOP(N,J)
|
||||
! WRITE(*,*) ' EXECUTION TERMINATED'
|
||||
! IERR=IERR+1
|
||||
ELSE
|
||||
WD1(NOP(N,J))=WD(NOP(N,J))
|
||||
ENDIF
|
||||
!
|
||||
ENDDO
|
||||
|
||||
WD1(NOP(N,2))=(WD1(NOP(N,1))+WD1(NOP(N,3)))/2.
|
||||
!
|
||||
ELSE
|
||||
DO J=1,NCORN(N)
|
||||
WD1(NOP(N,J))=WD(NOP(N,J))
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE WRTCRS(ICROUT,CRSTIT)
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! COMMON/ICN1/ ICN(MAXP)
|
||||
|
||||
|
||||
CHARACTER*8 ID1,ENDDAT
|
||||
CHARACTER*72 CRSTIT
|
||||
|
||||
!IPK JUN06
|
||||
DATA VOIDCRP/-1.E14/
|
||||
|
||||
DO J=1,MAXP
|
||||
ICN(J)=0
|
||||
END DO
|
||||
! First sort out the potential midsides
|
||||
! Note that transition elements caues a problem
|
||||
! Find these first
|
||||
DO 200 N=1,NE
|
||||
if(NCORN(N) .GT. 5) GO TO 200
|
||||
IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN
|
||||
!
|
||||
! We have a transition mark node number as if it were corner
|
||||
!
|
||||
ICN(NOP(N,3))=1
|
||||
ICN(NOP(N,1))=2
|
||||
ICN(NOP(N,4))=2
|
||||
ICN(NOP(N,5))=2
|
||||
ELSE
|
||||
!
|
||||
! Store ICN = 2 for corner nodes
|
||||
!
|
||||
NCN=NCORN(N)
|
||||
!IPKOCT93 IF(IMAT(N) .GT. 900) THEN
|
||||
IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN
|
||||
MST=1
|
||||
ELSE
|
||||
MST=2
|
||||
ENDIF
|
||||
|
||||
DO 180 M=1,NCN,MST
|
||||
|
||||
ICN(NOP(N,M))=2
|
||||
180 CONTINUE
|
||||
ENDIF
|
||||
200 END DO
|
||||
ID1='TC '
|
||||
WRITE(ICROUT,'(A8,A72)') ID1,CRSTIT
|
||||
|
||||
|
||||
DO N=1,NCRSEC
|
||||
!ipk jun06
|
||||
!! IF(NRIVL(N) .GT. 0) THEN
|
||||
ID1='RCH '
|
||||
WRITE(ICROUT,'(A8,I8)') ID1,NOREACH(IVMIL(N))
|
||||
ID1='ICS '
|
||||
!! write(icrout,'(A8,2I8,8x,2f16.4)') ID1,IVMIL(N),NRIVL(N),XCRS(N),YCRS(N)
|
||||
!!jul15 write(icrout,'(A8,2I8,8x,2f16.4)') ID1,N,NRIVL(N),XCRS(N),YCRS(N)
|
||||
write(icrout,'(A8,2I8,8x,2f16.4)') ID1,IVMIL(N),NRIVL(IVMIL(N)),XCRS(IVMIL(N)),YCRS(IVMIL(N))
|
||||
ID1='CRS '
|
||||
DO I=1,NRIVL(IVMIL(N))
|
||||
if(crsdat(IVMIL(N),i,2) .gt. 999999.) then
|
||||
WRITE(ICROUT,'(A8,3F8.0)') ID1,(CRSDAT(IVMIL(N),I,J),J=1,3)
|
||||
elseif(crsdat(IVMIL(N),i,2) .gt. 99999.) then
|
||||
WRITE(ICROUT,'(A8,3F8.1)') ID1,(CRSDAT(IVMIL(N),I,J),J=1,3)
|
||||
else
|
||||
WRITE(ICROUT,'(A8,3F8.2)') ID1,(CRSDAT(IVMIL(N),I,J),J=1,3)
|
||||
endif
|
||||
ENDDO
|
||||
!ipk jun06
|
||||
!! ENDIF
|
||||
ENDDO
|
||||
|
||||
|
||||
DO N=1,NCRSEC
|
||||
!ipk jun06
|
||||
IF(XCRS(N) .GT. VOIDCRP) THEN
|
||||
ID1='XYL '
|
||||
WRITE(ICROUT,'(A8,I8,2F16.4)') ID1,IVMIL(N),XCRS(IVMIL(N)),YCRS(IVMIL(N))
|
||||
!ipk jun06
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
ID1='CRF '
|
||||
DO N=1,NP
|
||||
IF(ICN(N) .EQ. 2) THEN
|
||||
IF(NRIVCR1(N) .GT. 0) THEN
|
||||
WRITE(ICROUT,'(A8,2I8,F8.4,I8,F8.4)') ID1,N&
|
||||
,NRIVCR1(N),WTRIVCR1(N)&
|
||||
,NRIVCR2(N),WTRIVCR2(N)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
ENDDAT='ENDDATA '
|
||||
WRITE(ICROUT,'(A8)') ENDDAT
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
@ -0,0 +1,485 @@
|
||||
!IPK LAST UPDATE OCT 23 2015 ADD DECODAT OPTION FOR INPUT
|
||||
!IPK LAST UPDATE nov 20 2014 IMPLEMENT BINARY FILE SAVE FOR ELEMENT INFLOW DATA
|
||||
!IPK LAST UPDATE nov 17 2014 initialise TPRVH FOR ALL TYPES
|
||||
!IPK last update oct 22 2012 initialize TPRVH
|
||||
!IPK LAST UPDATE MAY 04 2011 FIX BUG CAUSED WHEN SPANNING MULTIPLE FILES
|
||||
!IPK LAST UPDATE SEPT 3 2007 ADD FULL DATE TO INPUT
|
||||
!IPK last update sept 01 2007 permit comma delimited entry of data
|
||||
!IPK LAST UPDATE SEP 06 2004 ADD ERROR FILE
|
||||
! Last change: IPK 19 Sep 2000 11:44 am
|
||||
!IPK LAST UPDATE APR 16 1997
|
||||
!IPK last update Jan 23 1996
|
||||
!IPK last update jan 9 1996
|
||||
SUBROUTINE GETEQ
|
||||
!IPK APR97 SAVE
|
||||
|
||||
use winteracter
|
||||
USE BLKELTLD
|
||||
|
||||
include 'D.inc'
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
!IPK AUG05 SAVE
|
||||
INTEGER JCNV(12)
|
||||
CHARACTER*32 FNAM
|
||||
CHARACTER*8 ID
|
||||
CHARACTER*80 QHTITLE,DLIN
|
||||
CHARACTER*10 DATE
|
||||
character*255 fnamein,filter
|
||||
!IPK oct 12 add initial value
|
||||
data tprvh/0./,ITIME/0/
|
||||
DATA JCNV/0,31,59,90,120,151,181,212,243,273,304,334/
|
||||
LOGICAL OPENED
|
||||
IF(ITIME .EQ. 0) THEN
|
||||
DAYOFY=-9999
|
||||
ITIME=1
|
||||
IQEUNIT=0
|
||||
IBINEL=0
|
||||
IRMATYP=10
|
||||
NQHYD=0
|
||||
NQP=0
|
||||
ENDIF
|
||||
call wdialogload(IDD_CHOOSEMODEL)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_CHOOSEMODEL)
|
||||
ierr=infoerror(1)
|
||||
|
||||
call wdialogputRadioButton(idf_radio1)
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
call wdialoggetradiobutton(idf_radio1,ntyp)
|
||||
|
||||
GO TO 50
|
||||
ENDIF
|
||||
|
||||
enddo
|
||||
|
||||
50 CONTINUE
|
||||
IF(NTYP .EQ. 1) IRMATYP=2
|
||||
IF(NTYP .EQ. 2) IRMATYP=10
|
||||
IF(NTYP .EQ. 3) THEN
|
||||
IRMATYP=11
|
||||
NQP=1
|
||||
call wdialogload(IDD_GETINT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_GETINT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutString(IDF_STRING1,'NUMBER OF WQ GRAPH ENTRIES')
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,NQP)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
! Branch depending on type of message.
|
||||
!
|
||||
DO
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,NQP)
|
||||
|
||||
! TEMPORARY LIMIT
|
||||
IF(NQP .GT. 3) NQP=3
|
||||
|
||||
GO TO 70
|
||||
ELSE
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
|
||||
!IPK NOV14 ADD IBINEL TO TEST
|
||||
70 CONTINUE
|
||||
IF(IQEUNIT .EQ. 0 .and. ibinel .eq. 0) THEN
|
||||
INQUIRE(201,opened= OPENED)
|
||||
filter='Element Input files|*.elt;*.elf;*.dat;*.txt;*.grh|All files --|*.*|'
|
||||
IF( .NOT. OPENED) THEN
|
||||
CALL WSelectFile(filter,PromptOn+DirChange,FNAMEIN,'Element Load File Name')
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
OPEN(201,FILE=FNAMEIN,STATUS='OLD')
|
||||
ELSE
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDIF
|
||||
IQEUNIT=201
|
||||
ENDIF
|
||||
IF(NQHYD .EQ. 0) THEN
|
||||
|
||||
!IPK NOV14 READ AND ALLOCATE DATA FROM BINARY FILE
|
||||
IF(IBINEL .GT. 0) THEN
|
||||
TSTARTS=(DAYOFY-1)*24.+TIME-TETH
|
||||
READ(IBINEL)NEDPTS,NQHYD,TSTARTKP,IYRKP
|
||||
YEARC=0.
|
||||
IF(IYRR .NE. IYRKP) THEN
|
||||
IF(IYRR .GT. IYRKP) THEN
|
||||
80 CALL HRYRT(IYRKP,HRYR)
|
||||
YEARC=YEARC+HRYR
|
||||
IYRKP=IYRKP+1
|
||||
IF(IYRR .GT. IYRKP) GO TO 80
|
||||
ELSE
|
||||
90 CALL HRYRT(IYRKP,HRYR)
|
||||
YEARC=YEARC-HRYR
|
||||
IYRKP=IYRKP-1
|
||||
IF(IYRR .LT. IYRKP) GO TO 90
|
||||
ENDIF
|
||||
ENDIF
|
||||
ALLOCATE(DYE(NEDPTS,NQHYD),TAE(NEDPTS,NQHYD),HAE(NEDPTS,NQHYD),HDE(NEDPTS,NQHYD,3),ILAYRE(NEDPTS,NQHYD))
|
||||
do j=1,NQHYD
|
||||
READ(IBINEL) NCLINE(j),NEST(j),IYDATE(j),NHYE(J)
|
||||
READ(IBINEL) (DYE(I,j),TAE(I,j),HAE(I,j),I=1,nedpts)
|
||||
DO I=1,NEDPTS
|
||||
TAE(I,J)=TAE(I,J)+TSTARTKP-TSTARTS-YEARC
|
||||
ENDDO
|
||||
enddo
|
||||
GO TO 199
|
||||
ENDIF
|
||||
!IPK NOV14 END UPDATE
|
||||
NEDPTS=0
|
||||
CALL ALLOCFL(NEDPTS,NELDS,IQEUNIT,3)
|
||||
!
|
||||
! set starting time in hours of the year
|
||||
! teth contains the first time step
|
||||
|
||||
95 READ(IQEUNIT,'(A8,A72)') ID,QHTITLE
|
||||
!IPK sep07 CHECK FOR COMMA'S
|
||||
98 IFREE=0
|
||||
DO K=1,8
|
||||
IF(ID(K:K) .NE. ',') THEN
|
||||
IFREE=0
|
||||
ELSE
|
||||
KFIRST=K+1
|
||||
IFREE=1
|
||||
GO TO 99
|
||||
ENDIF
|
||||
ENDDO
|
||||
99 IF(IFREE .EQ. 1) THEN
|
||||
QHTITLE=ID(KFIRST:8)//QHTITLE(1:71+KFIRST)
|
||||
ENDIF
|
||||
READ(IQEUNIT,'(A8,A72)') ID,DLIN
|
||||
IF(ID(1:3) .EQ. 'QEI' .OR. ID(1:3) .EQ. 'QT ') THEN
|
||||
101 NQHYD=NQHYD+1
|
||||
!IPK sep07 CHECK FOR COMMA'S
|
||||
!IPK nov14 initialise TPRVH
|
||||
tprvh=0
|
||||
IFREE=0
|
||||
DO K=1,8
|
||||
IF(ID(K:K) .NE. ',') THEN
|
||||
IFREE=0
|
||||
ELSE
|
||||
KFIRST=K+1
|
||||
IFREE=1
|
||||
GO TO 102
|
||||
ENDIF
|
||||
ENDDO
|
||||
102 IF(IFREE .EQ. 1) THEN
|
||||
DLIN=ID(KFIRST:8)//DLIN(1:71+KFIRST)
|
||||
ENDIF
|
||||
!IPK APR97 TEST FOR LIMIT
|
||||
IF(NQHYD .GT. NELDS) THEN
|
||||
!IPK SEP04
|
||||
CLOSE(75)
|
||||
OPEN(75,file='ERROR.OUT')
|
||||
WRITE(75,*) 'ERROR STOP TOO MANY ELEMENT INFLOWS'
|
||||
WRITE(*,*) 'ERROR STOP TOO MANY ELEMENT INFLOWS'
|
||||
STOP 'ERROR STOP TOO MANY ELEMENT INFLOWS'
|
||||
ENDIF
|
||||
NHYE(NQHYD)=0
|
||||
!IPK sep07
|
||||
if(ifree .eq. 0) then
|
||||
READ(DLIN,'(3I8,2F16.2)',ERR=801) NCLINE(NQHYD),NEST(NQHYD),IYDATE(NQHYD),XYCEL(NQHYD,1),XYCEL(NQHYD,2)
|
||||
GO TO 811
|
||||
801 READ(DLIN,'(3I8)') NCLINE(NQHYD),NEST(NQHYD),IYDATE(NQHYD)
|
||||
811 CONTINUE
|
||||
else
|
||||
READ(DLIN,*) NCLINE(NQHYD),NEST(NQHYD),IYDATE(NQHYD)
|
||||
endif
|
||||
IF(NCLINE(NQHYD) .EQ. 0) NCLINE(NQHYD)=-9999
|
||||
!
|
||||
IYD=IYDATE(NQHYD)
|
||||
!IPK may11 set IYDOLD
|
||||
IYDOLD=IYD
|
||||
DO 120 I=1,NEDPTS+1
|
||||
READ(IQEUNIT,'(A8,A72)') ID,DLIN
|
||||
!IPK sep07 ADD QN
|
||||
IF(ID(1:3) .EQ. 'TI ') GO TO 98
|
||||
IF(ID(1:3) .EQ. 'QEI' .OR. ID(1:3) .EQ. 'QT ') THEN
|
||||
! NHYE(NQHYD)=NHYE(NQHYD)+1
|
||||
!IPK jan96 add day of year to logic
|
||||
! DYE(NHYE(NQHYD),NQHYD)=1.E+6
|
||||
! TAE(NHYE(NQHYD),NQHYD)=1.E+8
|
||||
! HAE(NHYE(NQHYD),NQHYD)=HAE(NHYE(NQHYD)-1,NQHYD)
|
||||
GO TO 101
|
||||
ELSEIF(ID(1:2) .EQ. 'QE' .OR. ID(1:2) .EQ. 'QN' .OR. ID(1:2) .EQ. 'QD' .or. ID(1:2) .EQ. 'QM') THEN
|
||||
!IPK jan96 add day of year to logic
|
||||
!IPK sep07 CHECK FOR COMMA'S
|
||||
IFREE=0
|
||||
DO K=1,8
|
||||
IF(ID(K:K) .NE. ',') THEN
|
||||
IFREE=0
|
||||
ELSE
|
||||
KFIRST=K+1
|
||||
IFREE=1
|
||||
GO TO 105
|
||||
ENDIF
|
||||
ENDDO
|
||||
105 IF(IFREE .EQ. 1) THEN
|
||||
DLIN=ID(KFIRST:8)//DLIN(1:71+KFIRST)
|
||||
ENDIF
|
||||
!IPK sep07 ALLOW FOR QN
|
||||
IF(ID(1:2) .EQ. 'QE' .OR. ID(1:2) .EQ. 'QD') THEN
|
||||
IF(IFREE .EQ. 0) THEN
|
||||
READ(ID(5:8),'(F4.0)') DYE(I,NQHYD)
|
||||
IF(IRMATYP .EQ. 2) READ(DLIN,'(2F8.0)') TAE(I,NQHYD),HAE(I,NQHYD)
|
||||
IF(IRMATYP .EQ. 10) READ(DLIN,'(F8.0,I8,4F8.0)') TAE(I,NQHYD),ILAYRE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,3)
|
||||
IF(IRMATYP .EQ. 11) READ(DLIN,'(F8.0,4F8.0)') TAE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,NQP)
|
||||
else
|
||||
IF(IRMATYP .EQ. 2) READ(DLIN,*) TAE(I,NQHYD),HAE(I,NQHYD)
|
||||
IF(IRMATYP .EQ. 10) READ(DLIN,*) DYE(I,NQHYD),TAE(I,NQHYD),ILAYRE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,3)
|
||||
IF(IRMATYP .EQ. 11) READ(DLIN,*) TAE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,NQP)
|
||||
endif
|
||||
!IPK SEP07 ADD DATE INPUT
|
||||
ELSE
|
||||
!IPK oct15 add decodat option
|
||||
IF(IFREE .EQ. 1) THEN
|
||||
READ(DLIN,'(A10)') DATE
|
||||
READ(DLIN(12:80),*) TAE(I,NQHYD),HAE(I,NQHYD)
|
||||
READ(DATE,'(I2,1X,I2,1X,I4)') IDAYY,IMTHH,IYYR
|
||||
DYE(I,NQHYD)=IDAYY+JCNV(IMTHH)
|
||||
IF(MOD(IYYR,4) .EQ. 0 .AND. IYYR .NE. 2000) THEN
|
||||
IF(IMTHH .GT. 2) DYE(I,NQHYD)=DYE(I,NQHYD)+1
|
||||
ENDIF
|
||||
ELSE
|
||||
CALL DECODDAT(DLIN,DYE(I,NQHYD),TAE(I,NQHYD))
|
||||
IF(IRMATYP .EQ. 2) READ(DLIN(17:24),'(F8.0)') HAE(I,NQHYD)
|
||||
IF(IRMATYP .EQ. 10) READ(DLIN(17:64),'(I8,4F8.0)') ILAYRE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,3)
|
||||
IF(IRMATYP .EQ. 11) READ(DLIN(17:64),'(4F8.0)') HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,NQP)
|
||||
ENDIF
|
||||
!IPK oct15 end decodat update
|
||||
ENDIF
|
||||
IF(DAYOFY .LT. 0) THEN
|
||||
DAYOFY=DYE(I,NQHYD)
|
||||
TSTARTS=(DAYOFY-1)*24.
|
||||
IYRR=IYD
|
||||
ENDIF
|
||||
NHYE(NQHYD)=NHYE(NQHYD)+1
|
||||
! IF(I .EQ. 1) THEN
|
||||
!
|
||||
! reduce input time to time since that set to start simulation
|
||||
!
|
||||
110 CONTINUE
|
||||
! IF(MOD(IYD,4) .EQ. 0) THEN
|
||||
! ILP=1
|
||||
! ELSE
|
||||
! ILP=0
|
||||
! ENDIF
|
||||
! IF(IYD .EQ. IYRR) THEN
|
||||
!
|
||||
! If now for for the same year
|
||||
!
|
||||
TCUR1=(DYE(I,NQHYD)-1.)*24.+TAE(I,NQHYD)
|
||||
!
|
||||
! set time as the difference
|
||||
!
|
||||
TAE(I,NQHYD)=TCUR1
|
||||
! WRITE(75,*) I,TAE(I,NQHYD),HAE(I,NQHYD)
|
||||
! ELSEIF(IYD .LT. IYRR) THEN
|
||||
! IF(MOD(IYD,4) .EQ. 0) THEN
|
||||
! TPRVH=TPRVH+366.*24.
|
||||
! ELSE
|
||||
! TPRVH=TPRVH+365.*24.
|
||||
! ENDIF
|
||||
! IYD=IYD+1
|
||||
! GO TO 110
|
||||
! ELSE
|
||||
!IPK SEP04
|
||||
! CLOSE(75)
|
||||
! OPEN(75,file='ERROR.OUT')
|
||||
!IPK SEP00
|
||||
! WRITE(*,*) ' Element inflows for wrong year'
|
||||
! WRITE(*,*) ' Execution stopped'
|
||||
! WRITE(75,*) ' Element inflows for wrong year'
|
||||
! WRITE(75,*) ' Excution stopped'
|
||||
! STOP
|
||||
! ENDIF
|
||||
! ELSE
|
||||
!IPK may11 reset IYD
|
||||
! IYD=IYDOLD
|
||||
! IF(DYE(I,NQHYD) .LT. DYE(I-1,NQHYD)) THEN
|
||||
! TCUR1=TCUR1-365.*24.
|
||||
!IPK MAY11 IF(ILP .EQ. 1) TCUR1=TCUR1-24.
|
||||
!IPK MAY11 IYD=IYD+1
|
||||
! IF(MOD(IYD,4) .EQ. 0) THEN
|
||||
! ILP=1
|
||||
! ELSE
|
||||
! ILP=0
|
||||
! ENDIF
|
||||
!IPK may11
|
||||
! IYDOLD=IYDOLD+1
|
||||
! IF(ILP .EQ. 1) TCUR1=TCUR1-24.
|
||||
! ENDIF
|
||||
! TCUR=(DYE(I,NQHYD)-1.)*24.+TAE(I,NQHYD)
|
||||
! TAE(I,NQHYD)=TAE(I-1,NQHYD)+TCUR-TCUR1
|
||||
! TCUR1=TCUR
|
||||
! WRITE(75,*) I,TAE(I,NQHYD),HAE(I,NQHYD)
|
||||
! ENDIF
|
||||
ELSE
|
||||
! NHYE(NQHYD)=NHYE(NQHYD)+1
|
||||
!IPK jan96 add day of year to logic
|
||||
! DYE(NHYE(NQHYD),NQHYD)=1.E+6
|
||||
! TAE(NHYE(NQHYD),NQHYD)=1.E+8
|
||||
! HAE(NHYE(NQHYD),NQHYD)=HAE(NHYE(NQHYD)-1,NQHYD)
|
||||
! IF(IRMATYP .EQ. 10) THEN
|
||||
! DO K=1,3
|
||||
! HDE(NHYE(NQHYD),NQHYD,K)=HDE(NHYE(NQHYD)-1,NQHYD,K)
|
||||
! ENDDO
|
||||
! ENDIF
|
||||
GO TO 199
|
||||
ENDIF
|
||||
120 CONTINUE
|
||||
!IPK SEP04
|
||||
CLOSE(75)
|
||||
OPEN(75,file='ERROR.OUT')
|
||||
!IPK SEP00
|
||||
WRITE(*,*) 'Execution terminated more lines than allowed in element graph'
|
||||
WRITE(75,*)'Execution terminated more lines than allowed in element graph'
|
||||
stop
|
||||
ENDIF
|
||||
199 continue
|
||||
ENDIF
|
||||
200 CONTINUE
|
||||
CLOSE(IQEUNIT)
|
||||
IQEUNIT=0
|
||||
|
||||
DO I=1,NQHYD
|
||||
IF(XYCEL(I,1) .EQ. 0. .AND. XYCEL(I,2) .EQ. 0) THEN
|
||||
JJ=NCLINE(I)
|
||||
CALL GETXCL(JJ,XYCEL(I,1),XYCEL(I,2))
|
||||
ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
|
||||
!IPK NOV14 ADD LEAP YEAR ROUTINE
|
||||
|
||||
SUBROUTINE HRYRT(IYRKP,HRYR)
|
||||
|
||||
IF(MOD(IYRKP,4) .EQ. 0) THEN
|
||||
ILP=1
|
||||
HRYR=366.*24.
|
||||
ELSE
|
||||
ILP=0
|
||||
HRYR=365.*24.
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
|
||||
!IPK NEW WITH VERSION 9.0H OCT 25 2015
|
||||
|
||||
! DECODE JULIAN DAY FROM DAY/MONTH/YEAR DATA
|
||||
|
||||
SUBROUTINE DECODDAT(DATAIN,DAYJUL,TIME)
|
||||
CHARACTER*72 DATAIN
|
||||
REAL DAYJUL,TIME
|
||||
INTEGER IMTS(12,2),IDAY,IMO,IYR,HR,MIN
|
||||
DATA IMTS/0,31,59,90,120,151,181,212,243,273,304,334,0,31,60,91,121,152,182,213,244,274,305,335/
|
||||
!
|
||||
! LOOP THROUGH COLUMNS ADDING A COMMA
|
||||
IDBLNK=0
|
||||
DO I=1,16
|
||||
IF(DATAIN(I:I) .EQ. ':') THEN
|
||||
IHSW=0
|
||||
DATAIN(I:I)=','
|
||||
ELSEIF(DATAIN(I:I) .EQ. '.') THEN
|
||||
IHSW=1
|
||||
ENDIF
|
||||
IF(DATAIN(I:I) .EQ. '/') DATAIN(I:I)=','
|
||||
IF(I .GT. 8 .AND. DATAIN(I:I) .EQ. ' ') THEN
|
||||
IF(IDBLNK .EQ. 0) THEN
|
||||
DATAIN(I:I)=','
|
||||
IDBLNK=1
|
||||
IHSW=1
|
||||
ELSE
|
||||
DATAIN(I:I)='0'
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
! write(155,*) ihsw,datain(1:16)
|
||||
IF(IHSW .EQ. 0) THEN
|
||||
READ(DATAIN(1:16),*) IDAY,IMO,IYR,HR,MIN
|
||||
TIME=HR+MIN/60.
|
||||
ELSE
|
||||
READ(DATAIN(1:16),*) IDAY,IMO,IYR,TIME
|
||||
! write(155,*) IDAY,IMO,IYR,TIME
|
||||
ENDIF
|
||||
IF(MOD(IYR,4) .EQ. 0) THEN
|
||||
DAYJUL=IMTS(IMO,2)+IDAY
|
||||
ELSE
|
||||
DAYJUL=IMTS(IMO,1)+IDAY
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE ALLOCFL(MAXPT,MAXTYP,IUNIT,ITYP)
|
||||
|
||||
USE BLKELTLD
|
||||
|
||||
CHARACTER*8 ID
|
||||
NELDS=200
|
||||
MAXPT=0
|
||||
!IPK JUN09 RESTORE MAXTYP1
|
||||
MAXTYP1=0
|
||||
NQLM=0
|
||||
200 CONTINUE
|
||||
|
||||
READ(IUNIT,'(A8)', END=500) ID
|
||||
!IPK JUN09 ADD TO IF OPTIONS
|
||||
IF(ID(1:2) .EQ. 'TT' .OR. ID(1:2) .EQ. 'TH' .OR. ID(1:2) .EQ. 'TE' .OR. ID(1:2) .EQ. 'TI' &
|
||||
& .OR. ID(1:3) .eq. 'CLQ' .OR. ID(1:3) .eq. 'CLH' &
|
||||
& .OR. ID(1:3) .eq. 'QEI' .OR. ID(1:3) .eq. 'QT ' &
|
||||
& .OR. ID(1:3) .EQ. 'TIT' .OR. ID(1:3) .EQ. 'CTL') THEN
|
||||
!IPK SEP14 ADD TYPE 4 (STAGE FLOW) OPTION
|
||||
!IPK JUN09 RESTORE MAXTYP1
|
||||
MAXTYP1=MAXTYP1+1
|
||||
! MAXTYP1=MAXTYP1+1
|
||||
!IPK JUN09 IF(NQLM .GT. MAXQPT) MAXPT=NQLM
|
||||
IF(NQLM .GE. MAXPT) MAXPT=NQLM+1
|
||||
NQLM=0
|
||||
GO TO 200
|
||||
ELSEIF(ID(1:6) .EQ. 'ENDDAT') THEN
|
||||
!IPK JUN09 ADD TO NQLM
|
||||
|
||||
IF(NQLM .GT. MAXPT) MAXPT=NQLM+1
|
||||
GO TO 500
|
||||
ELSE
|
||||
NQLM=NQLM+1
|
||||
GO TO 200
|
||||
ENDIF
|
||||
|
||||
500 CONTINUE
|
||||
!IPK JUN09
|
||||
write(90,*) maxtyp,maxtyp1,maxpt,nelds
|
||||
IF(MAXTYP1 .GT. MAXTYP) MAXTYP=MAXTYP1
|
||||
|
||||
ALLOCATE (TAE(MAXPT,MAXTYP),HAE(MAXPT,MAXTYP),DYE(MAXPT,MAXTYP),HDE(MAXPT,MAXTYP,3),ILAYRE(MAXPT,MAXTYP))
|
||||
ALLOCATE (NCLINE(NELDS),NHYE(NELDS),IYDATE(NELDS),NEST(NELDS),XYCEL(NELDS,2))
|
||||
TAE=0.
|
||||
HAE=0.
|
||||
HDE=0.
|
||||
DYE=0.
|
||||
XYCEL=0.
|
||||
ILAYRE=0
|
||||
REWIND IUNIT
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,92 @@
|
||||
SUBROUTINE GETGRDELEV(M,IERREL)
|
||||
|
||||
USE BLK1MOD
|
||||
USE BLKMAP
|
||||
REAL*8 XXX,YYY
|
||||
|
||||
XXX=XUSR(M)
|
||||
YYY=YUSR(M)
|
||||
|
||||
! test for XXX and YYY outside grid limits
|
||||
|
||||
IF(XXX .LT. XXORG-CELLSIZX/2. .OR. XXX .GT. XXORG+(FLOAT(NCOLS1)+0.5)*CELLSIZX) THEN
|
||||
WD(M)=-9998.
|
||||
RETURN
|
||||
ELSE
|
||||
IF(YYY .LT. YYORG-CELLSIZY/2. .OR. YYY .GT. YYORG+(FLOAT(NROWS1)+0.5)*CELLSIZY) THEN
|
||||
WD(M)=-9998.
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDIF
|
||||
! Set row length in bytes and set temp origin
|
||||
LENROW=NCOLS1*4
|
||||
XORGT=XXORG
|
||||
YORGT=YYORG
|
||||
! Get row and column from lower left
|
||||
|
||||
NCOL=INT((XXX-XORGT)/CELLSIZX)+1
|
||||
NROWU=INT((YYY-YORGT)/CELLSIZY)+1
|
||||
|
||||
! Establish fraction within cell
|
||||
|
||||
XFRAC=(XXX-XORGT-(NCOL-1)*CELLSIZX)/CELLSIZX
|
||||
YFRAC=((YYY-YORGT-(NROWU-1)*CELLSIZY))/CELLSIZY
|
||||
|
||||
! Let fraction overlap outer edge
|
||||
|
||||
IF(XFRAC .LT. 0.) XFRAC=0.
|
||||
IF(YFRAC .LT. 0.) YFRAC=0.
|
||||
|
||||
! Set up file position across columns, up rows and combine
|
||||
NCOLFIL=(NCOL-1)*4
|
||||
NROWFIL=(NROWS1-NROWU+1)*LENROW
|
||||
NFILPOS=NCOLFIL+NROWFIL
|
||||
|
||||
! Read lower left the lower right allow fo upper limit
|
||||
|
||||
READ(203,POS=NFILPOS+1) ELEVLL
|
||||
IF(NCOL .LT. NCOLS1) NFILPOS=NFILPOS+4
|
||||
READ(203,POS=NFILPOS+1) ELEVLR
|
||||
|
||||
! Test for point ouside grid
|
||||
|
||||
IF(ELEVLL .LT. -9000. .OR. ELEVLR .LT. -9000.) THEN
|
||||
WD(M)=-9998.
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
! Now mode to next row up and column
|
||||
|
||||
NROWFIL=(NROWS1-NROWU)*LENROW
|
||||
NFILPOS=NCOLFIL+NROWFIL
|
||||
READ(203,POS=NFILPOS+1) ELEVUL
|
||||
IF(NCOL .LT. NCOLS1) NFILPOS=NFILPOS+4
|
||||
READ(203,POS=NFILPOS+1) ELEVUR
|
||||
|
||||
! Test again
|
||||
|
||||
IF(ELEVUL .LT. -9000. .OR. ELEVUR .LT. -9000.) THEN
|
||||
WD(M)=-9998.
|
||||
RETURN
|
||||
ENDIF
|
||||
! interpolate along along lower and upper level
|
||||
|
||||
ELEVL=XFRAC*(ELEVLR-ELEVLL)+ELEVLL
|
||||
ELEVU=XFRAC*(ELEVUR-ELEVUL)+ELEVUL
|
||||
|
||||
! Get final value, store and display
|
||||
|
||||
AMAPVAL=YFRAC*(ELEVU-ELEVL)+ELEVL
|
||||
wd(m)=amapval
|
||||
FPN = WD(M)*10.
|
||||
X = CORD(M,1)
|
||||
Y = CORD(M,2) - .11
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.1,FPN,0.0,-1)
|
||||
endif
|
||||
|
||||
RETURN
|
||||
|
||||
|
||||
END
|
||||
@ -0,0 +1,757 @@
|
||||
SUBROUTINE GETNEWFIL(IIN,IGFG,ITRIAN,ISWT)
|
||||
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
! WRITE CURRENT DATA TO A SCRATCH FILE
|
||||
|
||||
IF(IACTVFIL .GT. 0 .AND. ISWT .NE. -1) THEN
|
||||
IFILOUT=IACTVFIL+50
|
||||
CALL WRTFIL(IFILOUT)
|
||||
CALL ZEROOUT
|
||||
IACTVFIL=ITOTFIL
|
||||
ELSEIF(IACTVFIL .EQ. 0) THEN
|
||||
IACTVFIL=1
|
||||
ENDIF
|
||||
IF(abs(ISWT) .EQ. 1) THEN
|
||||
ITOTFIL=ITOTFIL+1
|
||||
FNAMKEP='TEST.1.ELE'
|
||||
IACTVFIL=ITOTFIL
|
||||
FNAMEOUT(IACTVFIL)='TEST.1.ELE'
|
||||
WRITE(90,*) 'ITOTFIL,IACTVFIL',ITOTFIL,IACTVFIL
|
||||
WRITE(90,'(A80)') (FNAMEOUT(KKK),KKK=1,3)
|
||||
ENDIF
|
||||
IF(ITRIAN .EQ. 1) THEN
|
||||
CALL READGFG(IIN,1)
|
||||
|
||||
! TEST FOR GFG FORMAT
|
||||
ELSEIF(IGFG .EQ. 1) THEN
|
||||
CALL READGFG(IIN,0)
|
||||
|
||||
! TEST FOR rm1 FORMAT
|
||||
|
||||
ELSEIF(IIN .EQ. 10) THEN
|
||||
CALL READRM1(IIN)
|
||||
|
||||
! TEST FOR rm1 FORMAT
|
||||
|
||||
!ipk feb08 replace iin of 11 with 12
|
||||
ELSEIF(IIN .EQ. 12 .and. IGFG .EQ. 0) THEN
|
||||
CALL READGEO(IIN)
|
||||
|
||||
ELSEIF(IIN .EQ. 12 .and. IGFG .EQ. 2) THEN
|
||||
CALL RDBIN(IIN)
|
||||
|
||||
ENDIF
|
||||
|
||||
IFILOUT=IACTVFIL+50
|
||||
WRITE(90,*) 'IFILOUT', IFILOUT
|
||||
CALL WRTFIL(IFILOUT)
|
||||
IACTVFIL=1
|
||||
CALL LOADFIL
|
||||
|
||||
|
||||
CALL RESCAL
|
||||
CALL HEDR
|
||||
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
! Write data to a file
|
||||
SUBROUTINE WRTFIL(IFILOUT)
|
||||
|
||||
USE BLK1MOD
|
||||
CHARACTER*80 ALINE
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
CLOSE (IFILOUT)
|
||||
OPEN(IFILOUT,STATUS='scratch',FORM='binary')
|
||||
|
||||
ISLP=0
|
||||
IPRT=1
|
||||
IPNN=1
|
||||
IPEN=1
|
||||
IPO=1
|
||||
IRO=1
|
||||
IPP=0
|
||||
IRFN=0
|
||||
IGEN=0
|
||||
NXZL=0
|
||||
NITST=1
|
||||
ISCTXT=0
|
||||
IFILL=0
|
||||
IALTGM=1
|
||||
NLAYD=0
|
||||
HORIZ=10.
|
||||
VERT=8.
|
||||
XSALE=0.
|
||||
YSALE=0.
|
||||
XFACT=0.
|
||||
YFACT=0.
|
||||
AR=0.
|
||||
ANG=0.
|
||||
xadded=0.
|
||||
yadded=0.
|
||||
ntempin=0.
|
||||
! WRITE(90,*) 'IN GETNEWFIL', IFILOUT,NP,NE,IPRT
|
||||
WRITE(IFILOUT) TITLE,NP,NE
|
||||
WRITE(IFILOUT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
||||
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
||||
! WRITE(90,*) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
||||
! & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
||||
WRITE(IFILOUT) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG
|
||||
IF(IPP .GT. 0) WRITE(IFILOUT) ALINE
|
||||
|
||||
WRITE(IFILOUT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE)
|
||||
WRITE(IFILOUT) &
|
||||
(XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), &
|
||||
& WIDBS(J),SSO(J),BS1(J),J=1,NP)
|
||||
|
||||
WRITE(IFILOUT) NLST
|
||||
IF(NLST .GT. 0) THEN
|
||||
WRITE(IFILOUT) (LLIST(J),J=1,NLST), &
|
||||
& ((ILIST(J,I),I=1,LLIST(J)),J=1,NLST)
|
||||
ENDIF
|
||||
|
||||
WRITE(IFILOUT) NENTRY,NLAYD,NCLM
|
||||
|
||||
IF(NENTRY .GT. 0) THEN
|
||||
WRITE(IFILOUT) ((NEF(I,J),J=1,3),I=1,NENTRY)
|
||||
ENDIF
|
||||
|
||||
IF(NLAYD .GT. 0) THEN
|
||||
WRITE(IFILOUT) (LAY(I),I=1,NP)
|
||||
ENDIF
|
||||
|
||||
IF(NCLM .GT. 0) THEN
|
||||
WRITE(IFILOUT) ((ICCLN(I,J),J=1,350),I=1,NCLM)
|
||||
ENDIF
|
||||
REWIND IFILOUT
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE READRM1(IIIN)
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*48 DLIN
|
||||
|
||||
IIN=IIIN
|
||||
! Read in header lines
|
||||
|
||||
ISET=1
|
||||
WRITE(90,*) 'GOING TO HEADIN'
|
||||
CALL HEADIN(IIN,ISET)
|
||||
|
||||
! Read in existing elements
|
||||
WRITE(90,*) 'GOING TO RDELEM'
|
||||
CALL RDELEM(IIN)
|
||||
|
||||
! Read in nodal coordinates
|
||||
|
||||
WRITE(90,*) 'GOING TO RDCORD'
|
||||
CALL RDCORD(IIN)
|
||||
|
||||
! Close input file
|
||||
|
||||
CLOSE(IIN)
|
||||
|
||||
! Scale for plotting
|
||||
|
||||
IF(NP .GT. 0) THEN
|
||||
DO J=1,NP
|
||||
IF (CORD(J,1) .GT. VDX) THEN
|
||||
XMIN=MIN(XMIN,CORD(J,1))
|
||||
XMAX=MAX(XMAX,CORD(J,1))
|
||||
YMIN=MIN(YMIN,CORD(J,2))
|
||||
YMAX=MAX(YMAX,CORD(J,2))
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
! Read GEO file
|
||||
SUBROUTINE READGEO(IIIN)
|
||||
USE BLK1MOD
|
||||
CHARACTER*1000 HEADER
|
||||
CHARACTER*8 ID8
|
||||
CHARACTER*32 IJNK
|
||||
CHARACTER*80 ALINE,DLIN
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
INTEGER*2 NOP2(MAXE,8)
|
||||
|
||||
|
||||
IIN=IIIN
|
||||
read(iin,err=100) header
|
||||
if(header(1:6) .eq. 'RMAGEN') then
|
||||
inopt=2
|
||||
else
|
||||
inopt=1
|
||||
rewind iin
|
||||
endif
|
||||
read(iin) n1,m1
|
||||
rewind iin
|
||||
write(90,*) 'Apparent nodes and elements from file are'
|
||||
write(90,'(i15,i10)') n1,m1
|
||||
if(n1 .gt. maxp .or. m1 .gt. maxe) then
|
||||
!
|
||||
!...... Perhaps the file format is wrong, close and reopen
|
||||
!
|
||||
WRITE(DLIN,'(A32)') 'Parameter limits may be violated'
|
||||
call symbl(0.5,4.5,0.20,dlin,0.0,32)
|
||||
WRITE(DLIN,'(A35)') 'Retrying with alternate file format'
|
||||
call symbl(0.5,4.2,0.20,dlin,0.0,35)
|
||||
close (iin)
|
||||
open(iin ,file=fnamkep,status='old',form='unformatted')
|
||||
read(iin) n1,m1
|
||||
write(90,*) 'Revised nodes and elements from file are'
|
||||
write(90,'(i15,i10)') n1,m1
|
||||
if(n1 .gt. maxp .or. m1 .gt. maxe) then
|
||||
WRITE(DLIN,'(A31)') 'Parameter limits still violated'
|
||||
call symbl(0.5,3.9,0.20,dlin,0.0,31)
|
||||
WRITE(DLIN,'(A27)') 'Apparent nodes and elts are'
|
||||
call symbl(0.5,3.6,0.20,dlin,0.0,27)
|
||||
WRITE(DLIN,'(2i10)') n1,m1
|
||||
call symbl(0.5,3.3,0.20,dlin,0.0,20)
|
||||
WRITE(DLIN,'(A24)') 'Press enter to terminate'
|
||||
call symbl(0.5,4.5,0.20,dlin,0.0,24)
|
||||
CALL GTCHARX(ijnk,ndig,5.0,4.0)
|
||||
!cipk aug00 read(*,'(i1)') junk
|
||||
call quit_pgm
|
||||
endif
|
||||
endif
|
||||
rewind iin
|
||||
!
|
||||
!
|
||||
if(inopt .eq. 2) then
|
||||
read(iin,err=100) header
|
||||
READ(IIN,ERR=100) &
|
||||
& N1,M1,((CORD(J,K),K=1,2),ALPHA,WD(J),J=1,N1), &
|
||||
& ((NOP(J,K),K=1,8),IMAT(J),THTA(J),I3,J=1,M1) &
|
||||
& , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1)
|
||||
DO J=1,N1
|
||||
XUSR(J)=CORD(J,1)
|
||||
YUSR(J)=CORD(J,2)
|
||||
ENDDO
|
||||
!
|
||||
else
|
||||
READ(IIN,ERR=100) &
|
||||
& N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), &
|
||||
& ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1) &
|
||||
& , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1)
|
||||
DO J=1,N1
|
||||
DO K=1,2
|
||||
CORD(J,K)=CORDSN(J,K)
|
||||
ENDDO
|
||||
XUSR(J)=CORD(J,1)
|
||||
YUSR(J)=CORD(J,2)
|
||||
ENDDO
|
||||
DO J=1,M1
|
||||
!ipk feb08
|
||||
ncorn(j)=0
|
||||
DO K=1,8
|
||||
NOP(J,K)=NOP2(J,K)
|
||||
!ipk feb08
|
||||
if(nop(j,k) .gt. 0) ncorn(j)=k
|
||||
ENDDO
|
||||
ENDDO
|
||||
endif
|
||||
read(IIN,err=120,end=120) id8
|
||||
if(id8(1:6) .eq. 'part-2') then
|
||||
read(IIN,err=104) (widbs(j),sso(j),j=1,n1)
|
||||
read(IIN,err=120,end=120) id8
|
||||
endif
|
||||
|
||||
! Add part 3 write for continuity lines
|
||||
if(id8(1:6) .eq. 'part-3') then
|
||||
|
||||
!ipk aug02 IF(NCLM .GT. 0) THEN
|
||||
READ(IIN,ERR=104) NCLM,((ICCLN(I,J),J=1,350),I=1,NCLM)
|
||||
!ipk aug02 ENDIF
|
||||
read(IIN,err=120,end=120) id8
|
||||
endif
|
||||
!IPK DEB02 Add part 4 write for lock and BS1 lines and reordering
|
||||
if(id8(1:6) .eq. 'part-4') then
|
||||
read(iin,err=104,end=120) (lock(j),bs1(j),j=1,n1)
|
||||
read(iin,err=104,end=120) &
|
||||
nlst,((ilist(j,k),k=1,maeln),llist(j),j=1,maxln)
|
||||
endif
|
||||
DO J=1,M1
|
||||
!ipk feb08
|
||||
ncorn(j)=0
|
||||
DO K=1,8
|
||||
!ipk feb08
|
||||
if(nop(j,k) .gt. 0) ncorn(j)=k
|
||||
ENDDO
|
||||
ENDDO
|
||||
|
||||
GO TO 120
|
||||
|
||||
100 READ(IIN,ERR=104) &
|
||||
& N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), &
|
||||
& ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1)
|
||||
DO J=1,N1
|
||||
DO K=1,2
|
||||
CORD(J,K)=CORDSN(J,K)
|
||||
ENDDO
|
||||
XUSR(J)=CORD(J,1)
|
||||
YUSR(J)=CORD(J,2)
|
||||
ENDDO
|
||||
DO J=1,M1
|
||||
!ipk feb08
|
||||
ncorn(j)=0
|
||||
DO K=1,8
|
||||
NOP(J,K)=NOP2(J,K)
|
||||
!ipk feb08
|
||||
if(nop(j,k) .gt. 0) ncorn(j)=k
|
||||
ENDDO
|
||||
ENDDO
|
||||
GO TO 120
|
||||
|
||||
104 WRITE(90,*) 'Error reading binary geometry file'
|
||||
!ipk jan98 CALL SETD(23)
|
||||
call clscrn()
|
||||
WRITE(aline,*) 'Error reading binary geometry file'
|
||||
call symbl &
|
||||
& (1.1,3.3,0.20,aline,0.0,80)
|
||||
WRITE(aline,*) 'Press enter to exit'
|
||||
call symbl &
|
||||
& (1.1,3.0,0.20,aline,0.0,80)
|
||||
ndig=1
|
||||
CALL GTCHARX(IJNK,NDIG,5.0,7.6)
|
||||
CALL Quit_Pgm
|
||||
STOP
|
||||
|
||||
120 CONTINUE
|
||||
NP=N1
|
||||
NE=M1
|
||||
|
||||
! Close input file
|
||||
|
||||
CLOSE(IIN)
|
||||
|
||||
! Scale for plotting
|
||||
|
||||
IF(NP .GT. 0) THEN
|
||||
DO J=1,NP
|
||||
IF (CORD(J,1) .GT. VDX) THEN
|
||||
XMIN=MIN(XMIN,CORD(J,1))
|
||||
XMAX=MAX(XMAX,CORD(J,1))
|
||||
YMIN=MIN(YMIN,CORD(J,2))
|
||||
YMAX=MAX(YMAX,CORD(J,2))
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
RETURN
|
||||
|
||||
END
|
||||
|
||||
SUBROUTINE READGFG(IUNIT,ISW)
|
||||
|
||||
USE BLK1MOD
|
||||
INCLUDE "BFILES.I90"
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*1 ANS
|
||||
CHARACTER*32 ANS32
|
||||
CHARACTER*3 ID
|
||||
CHARACTER*77 DLIN
|
||||
CHARACTER*150 DLIN1
|
||||
CHARACTER*80 LIND
|
||||
DIMENSION NTMP(9),NTEMPLIN(200,10),ATT(9)
|
||||
|
||||
REAL*8 CX,CY,VALS(7)
|
||||
|
||||
MEL=MAXE
|
||||
ylv=7.5
|
||||
IIN=IUNIT
|
||||
IPRT=1
|
||||
IPNN=1
|
||||
IPEN=1
|
||||
IPO=1
|
||||
IRO=1
|
||||
IPP=0
|
||||
IRFN=0
|
||||
IGEN=0
|
||||
NXZL=0
|
||||
NITST=1
|
||||
ISCTXT=0
|
||||
IFILL=0
|
||||
IALTGM=1
|
||||
NLAYD=0
|
||||
HORIZ=10.
|
||||
VERT=8.
|
||||
XSALE=0.
|
||||
YSALE=0.
|
||||
XFACT=0.
|
||||
YFACT=0.
|
||||
AR=0.
|
||||
ANG=0.
|
||||
xadded=0.
|
||||
yadded=0.
|
||||
ntempin=0.
|
||||
KLIN=0
|
||||
IF(ISW .EQ. 1) GO TO 500
|
||||
DO I=1,10000
|
||||
READ(IIN,'(A3,A77)') ID,DLIN
|
||||
IF(ID .EQ. 'T1 ') THEN
|
||||
TITLE(1:77)=DLIN
|
||||
GO TO 10
|
||||
ENDIF
|
||||
ENDDO
|
||||
10 CONTINUE
|
||||
REWIND IIN
|
||||
|
||||
! READ ELEMENT AND CCLINE DATA
|
||||
|
||||
20 CONTINUE
|
||||
DO ICOUNTC=1,200000
|
||||
DO JJ=1,150
|
||||
DLIN1(JJ:JJ)=' '
|
||||
ENDDO
|
||||
READ(IIN,'(A3,A150)', END=175) ID,DLIN1
|
||||
IF(ID .EQ. 'GE ' .or. ID .EQ. 'GO') THEN
|
||||
! Count the number of variables
|
||||
I=0
|
||||
ICOUNT=0
|
||||
25 CONTINUE
|
||||
IF(DLIN1(I+1:I+1) .NE. ' ') THEN
|
||||
GO TO 30
|
||||
ELSE
|
||||
I=I+1
|
||||
GO TO 25
|
||||
ENDIF
|
||||
30 I=I+1
|
||||
IF(I .EQ. 151) THEN
|
||||
ICOUNT =ICOUNT+1
|
||||
GO TO 40
|
||||
ENDIF
|
||||
IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN
|
||||
ICOUNT=ICOUNT+1
|
||||
35 CONTINUE
|
||||
IF(I+1 .EQ. 151) GO TO 40
|
||||
IF(DLIN1(I+1:I+1) .EQ. ' ') THEN
|
||||
I=I+1
|
||||
GO TO 35
|
||||
ELSE
|
||||
GO TO 30
|
||||
ENDIF
|
||||
ELSE
|
||||
GO TO 30
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
40 CONTINUE
|
||||
IF(ID .EQ. 'GO') THEN
|
||||
KLIN=KLIN+1
|
||||
READ(DLIN1,*) (NTEMPLIN(KLIN,K),K=1,ICOUNT)
|
||||
GO TO 20
|
||||
ENDIF
|
||||
IF(ICOUNT .GT. 10) THEN
|
||||
READ(DLIN1,*) J, (NTMP(K),K=1,9),THT
|
||||
ELSE
|
||||
READ(DLIN1,*) J, (NTMP(K),K=1,9)
|
||||
ENDIF
|
||||
|
||||
|
||||
IF (J .GE. MEL) THEN
|
||||
CALL SETD(23)
|
||||
!cipk aug00
|
||||
WRITE(lind,*) ' Element number exceeds MAXE in RDELEM'
|
||||
call symbl (1.1,ylv-0.3,0.20,lind,0.0,80)
|
||||
ndig=1
|
||||
WRITE(90,*) ' Element number exceeds MAXE in RDELEM'
|
||||
WRITE(lind,6000)
|
||||
CALL GTCHARX(ANS32,IJNK,5.0,4.0)
|
||||
CALL Quit_Pgm
|
||||
STOP
|
||||
ENDIF
|
||||
!
|
||||
! Check to ensure there are no duplicate numbers in input stream
|
||||
! of element connections
|
||||
!
|
||||
DO K=1,7
|
||||
IF(NTMP(K) .NE. 0) THEN
|
||||
DO L=K+1,8
|
||||
IF(NTMP(K) .EQ. NTMP(L)) THEN
|
||||
CALL SETD(23)
|
||||
DO KK=1,8
|
||||
NOP(J,KK) = NTMP(KK)
|
||||
ENDDO
|
||||
IMAT(J)=NTMP(9)
|
||||
call eltdisp(j)
|
||||
DO KK=1,8
|
||||
NTMP(KK) = NOP(J,KK)
|
||||
ENDDO
|
||||
NTMP(9)=IMAT(J)
|
||||
GO TO 45
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
45 CONTINUE
|
||||
DO K=1,8
|
||||
NOP(J,K) = NTMP(K)
|
||||
ND = NTMP(K)
|
||||
IF (ND .GT. 0) THEN
|
||||
INEW(ND) = 2
|
||||
NP = MAX(NP,ND)
|
||||
ENDIF
|
||||
ENDDO
|
||||
!
|
||||
NCN = 2
|
||||
IF (NOP(J,3) .NE. 0) NCN = 3
|
||||
IF (NOP(J,4) .NE. 0) NCN = 4
|
||||
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5
|
||||
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6
|
||||
IF (NOP(J,6) .NE. 0) NCN = 6
|
||||
IF (NOP(J,7) .NE. 0) NCN = 8
|
||||
NCORN(J) = NCN
|
||||
IESKP(J) = 0
|
||||
IMAT(J) = NTMP(9)
|
||||
THTA(J)=THT
|
||||
IEM(J) = J
|
||||
DO 50 K=2,NCN,2
|
||||
ND = NTMP(K)
|
||||
IF (ND .GT. 0) THEN
|
||||
IF(NCN .EQ. 5 .AND. K .EQ. 4) GO TO 50
|
||||
WD(ND)=0.
|
||||
ENDIF
|
||||
50 CONTINUE
|
||||
NE = MAX(J,NE)
|
||||
!
|
||||
GOTO 20
|
||||
!
|
||||
175 CONTINUE
|
||||
|
||||
REWIND IIN
|
||||
70 CONTINUE
|
||||
DO ICOUNTC=1,100000
|
||||
DO JJ=1,150
|
||||
DLIN1(JJ:JJ)=' '
|
||||
ENDDO
|
||||
READ(IIN,'(A3,A150)', END=400) ID,DLIN1
|
||||
IF(ID .EQ. 'GNN' .OR. ID .EQ. 'GWN') THEN
|
||||
! Count the number of variables
|
||||
I=0
|
||||
ICOUNT=0
|
||||
75 CONTINUE
|
||||
IF(DLIN1(I+1:I+1) .NE. ' ') THEN
|
||||
GO TO 80
|
||||
ELSE
|
||||
I=I+1
|
||||
GO TO 75
|
||||
ENDIF
|
||||
80 I=I+1
|
||||
IF(I .EQ. 151) THEN
|
||||
ICOUNT =ICOUNT+1
|
||||
GO TO 90
|
||||
ENDIF
|
||||
IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN
|
||||
ICOUNT=ICOUNT+1
|
||||
85 CONTINUE
|
||||
IF(I+1 .EQ. 151) GO TO 90
|
||||
IF(DLIN1(I+1:I+1) .EQ. ' ') THEN
|
||||
I=I+1
|
||||
GO TO 85
|
||||
ELSE
|
||||
GO TO 80
|
||||
ENDIF
|
||||
ELSE
|
||||
GO TO 80
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
90 CONTINUE
|
||||
DO K=1,7
|
||||
VALS(K)=0.
|
||||
ENDDO
|
||||
READ(DLIN1,*) J,(VALS(K),K=1,ICOUNT-1)
|
||||
IF(ID .EQ. 'GNN') THEN
|
||||
CX=VALS(1)
|
||||
CY=VALS(2)
|
||||
BELEV=VALS(3)
|
||||
NP = MAX(NP,J)
|
||||
CORD(J,1) = CX
|
||||
CORD(J,2) = CY
|
||||
XUSR(J) = CX
|
||||
YUSR(J) = CY
|
||||
WD(J) = BELEV
|
||||
INSKP(J)=0
|
||||
INEW(J) = 1
|
||||
GO TO 70
|
||||
ELSE
|
||||
WDTHX=VALS(1)
|
||||
SS1X=VALS(2)
|
||||
SS2X=VALS(3)
|
||||
WDSX=VALS(4)
|
||||
WIDTH(J)=WDTHX
|
||||
SS1(J)=SS1X
|
||||
SS2(J)=SS2X
|
||||
WIDS(J)=WDSX
|
||||
GO TO 70
|
||||
ENDIF
|
||||
|
||||
400 CONTINUE
|
||||
|
||||
! CHECKOUT THE CCLINE DATA
|
||||
|
||||
KK=0
|
||||
IF(KLIN .GT. 0) THEN
|
||||
NCLM=1
|
||||
IF(NTEMPLIN(1,1) .EQ. 1) THEN
|
||||
DO K=1,KLIN
|
||||
DO J=1,10
|
||||
IF(K .EQ. 1 .AND. J .EQ. 1) GO TO 410
|
||||
IF(NTEMPLIN(K,J) .LT. 0) THEN
|
||||
NCLM=NCLM+1
|
||||
KK=0
|
||||
GO TO 420
|
||||
ELSEIF(NTEMPLIN(K,J) .EQ. 0) THEN
|
||||
GO TO 420
|
||||
ELSE
|
||||
KK=KK+1
|
||||
ICCLN(NCLM,KK)=NTEMPLIN(K,J)
|
||||
ENDIF
|
||||
410 CONTINUE
|
||||
ENDDO
|
||||
420 CONTINUE
|
||||
ENDDO
|
||||
NCLM=NCLM-1
|
||||
ENDIF
|
||||
ENDIF
|
||||
RETURN
|
||||
|
||||
500 CONTINUE
|
||||
|
||||
READ(IUNIT,*) NE,NCNTR,NATTR
|
||||
IMIDS=0
|
||||
DO JJ=1,NE
|
||||
READ(IUNIT,*) J,(NTMP(K),K=1,NCNTR),(ATT(K),K=1,NATTR)
|
||||
IF (J .GE. MEL) THEN
|
||||
CALL SETD(23)
|
||||
WRITE(lind,*) ' Element number exceeds MAXE in RDELEM'
|
||||
call symbl &
|
||||
& (1.1,ylv-0.3,0.20,lind,0.0,80)
|
||||
ndig=1
|
||||
WRITE(90,*) ' Element number exceeds MAXE in RDELEM'
|
||||
WRITE(lind,6000)
|
||||
CALL GTCHARX(ANS32,IJNK,5.0,4.0)
|
||||
CALL Quit_Pgm
|
||||
STOP
|
||||
ENDIF
|
||||
DO KK=1,3
|
||||
NOP(J,2*KK-1) = NTMP(KK)
|
||||
NOP(J,2*KK)=0
|
||||
ENDDO
|
||||
IF(NATTR .GT. 0) THEN
|
||||
IMAT(J)=ATT(1)
|
||||
ELSE
|
||||
IMAT(J)=1
|
||||
ENDIF
|
||||
NCORN(J)=6
|
||||
IESKP(J)=0
|
||||
ENDDO
|
||||
CLOSE(IUNIT)
|
||||
DO L=255,1,-1
|
||||
IF(FNAMKEP(L:L) .EQ. '.') THEN
|
||||
FNAMKEP(L+1:L+4)='node'
|
||||
OPEN(IUNIT,FILE=FNAMKEP,STATUS='OLD',ACTION='READ')
|
||||
GO TO 510
|
||||
ENDIF
|
||||
ENDDO
|
||||
510 CONTINUE
|
||||
|
||||
READ(IUNIT,*) NPPP,NDUM,NATTR
|
||||
DO KK=1,NPPP
|
||||
READ(IUNIT,*) J,CX,CY,(VALS(K),K=1,NATTR)
|
||||
IF(J .EQ. 0) THEN
|
||||
J=NPPP
|
||||
JZ=1
|
||||
ENDIF
|
||||
BELEV=-9999.
|
||||
WEL=0.
|
||||
LOCK1=0
|
||||
IF(NATTR .GT. 0) BELEV=VALS(1)
|
||||
IF (J .GE. MAXP) THEN
|
||||
call clscrn()
|
||||
WRITE(dlin,*) ' Node number exceeds MAXP in RDCORD',j
|
||||
call symbl &
|
||||
& (1.1,3.3,0.20,dlin,0.0,80)
|
||||
WRITE(90,*) ' Node number exceeds MAXP in RDCORD'
|
||||
WRITE(DLIN,*) ' Press enter to exit'
|
||||
call symbl &
|
||||
& (1.1,3.0,0.20,dlin,0.0,80)
|
||||
ndig=1
|
||||
CALL GTCHARX(ANS32,ndig,5.0,4.0)
|
||||
CALL Quit_Pgm
|
||||
STOP
|
||||
ENDIF
|
||||
NP = MAX(NP,J)
|
||||
CORD(J,1) = CX
|
||||
CORD(J,2) = CY
|
||||
XUSR(J) = CX
|
||||
YUSR(J) = CY
|
||||
WD(J) = BELEV
|
||||
WIDTH(J)=0.
|
||||
SS1(J)=0.
|
||||
SS2(J)=0.
|
||||
WIDS(J)=0.
|
||||
WIDBS(J)=0.
|
||||
SSO(J)=0.
|
||||
INSKP(J)=0
|
||||
INEW(J) = 1
|
||||
LOCK(J)=LOCK1
|
||||
BS1(J)=0.
|
||||
ENDDO
|
||||
|
||||
CLOSE(IUNIT)
|
||||
6000 FORMAT(' Press enter to exit')
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE ZEROOUT
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
MNP = MAXP
|
||||
MEL = MAXE
|
||||
DO I=1,MEL
|
||||
DO M=1,8
|
||||
NOP(I,M)=0
|
||||
ENDDO
|
||||
IESKP(I)=-1
|
||||
IEM(I) = 0
|
||||
IMAT(I) = 0
|
||||
THTA(I)=0.
|
||||
XC(I) = -1.E20
|
||||
YC(I) = -1.E20
|
||||
ENDDO
|
||||
DO I=1,MNP
|
||||
XUSR(I) = -1.D20
|
||||
YUSR(I) = -1.D20
|
||||
CORD(I,1) = -1.D20
|
||||
CORD(I,2) = -1.D20
|
||||
WD(I) = -9999.
|
||||
LAY(I) = -9999
|
||||
WIDTH(I) = 0.0
|
||||
SS1(I) = 0.0
|
||||
SS2(I) = 0.0
|
||||
WIDS(I) = 0.0
|
||||
WIDBS(I)=0.
|
||||
SSO(I)=0.
|
||||
INSKP(I) = 1
|
||||
INEW(I) = 0
|
||||
!ipk mar02
|
||||
lock(i)=0
|
||||
bs1(I)=0.
|
||||
ENDDO
|
||||
NP=0
|
||||
NE=0
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,784 @@
|
||||
SUBROUTINE GETNEWFIL(IIN,IGFG,ITRIAN,ISWT)
|
||||
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
! WRITE CURRENT DATA TO A SCRATCH FILE
|
||||
|
||||
|
||||
IF(IACTVFIL .GT. 0 .AND. ISWT .NE. -1) THEN
|
||||
IFILOUT=IACTVFIL+50
|
||||
WRITE(90,*) 'INGETNEWFIL IFILOUT',IFILOUT
|
||||
CALL WRTFIL(IFILOUT)
|
||||
CALL ZEROOUT
|
||||
IACTVFIL=ITOTFIL
|
||||
ELSEIF(IACTVFIL .EQ. 0) THEN
|
||||
IACTVFIL=1
|
||||
ENDIF
|
||||
IF(ISWT .EQ. 1) THEN
|
||||
ITOTFIL=ITOTFIL+1
|
||||
FNAMKEP='TEST.1.ELE'
|
||||
IACTVFIL=ITOTFIL
|
||||
FNAMEOUT(IACTVFIL)='TEST.1.ELE'
|
||||
WRITE(90,*) 'ITOTFIL,IACTVFIL',ITOTFIL,IACTVFIL
|
||||
WRITE(90,'(A80)') (FNAMEOUT(KKK),KKK=1,3)
|
||||
ELSE
|
||||
FNAMKEP='TEST.1.ELE'
|
||||
ENDIF
|
||||
IF(ABS(ITRIAN) .EQ. 1) THEN
|
||||
CALL READGFG(IIN,ITRIAN)
|
||||
|
||||
! TEST FOR GFG FORMAT
|
||||
ELSEIF(IGFG .EQ. 1) THEN
|
||||
CALL READGFG(IIN,0)
|
||||
|
||||
! TEST FOR rm1 FORMAT
|
||||
|
||||
ELSEIF(IIN .EQ. 10) THEN
|
||||
CALL READRM1(IIN)
|
||||
|
||||
! TEST FOR rm1 FORMAT
|
||||
|
||||
!ipk feb08 replace iin of 11 with 12
|
||||
ELSEIF(IIN .EQ. 12 .and. IGFG .EQ. 0) THEN
|
||||
CALL READGEO(IIN)
|
||||
|
||||
ELSEIF(IIN .EQ. 12 .and. IGFG .EQ. 2) THEN
|
||||
CALL RDBIN(IIN)
|
||||
|
||||
ENDIF
|
||||
IF(ITRIAN .EQ. -1) RETURN
|
||||
|
||||
IFILOUT=IACTVFIL+50
|
||||
WRITE(90,*) 'IFILOUT', IFILOUT
|
||||
CALL WRTFIL(IFILOUT)
|
||||
IACTVFIL=1
|
||||
CALL LOADFIL
|
||||
|
||||
|
||||
CALL RESCAL
|
||||
CALL HEDR
|
||||
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
! Write data to a file
|
||||
SUBROUTINE WRTFIL(IFILOUT)
|
||||
|
||||
USE BLK1MOD
|
||||
CHARACTER*80 ALINE
|
||||
CHARACTER*10 FMT
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
CLOSE (IFILOUT)
|
||||
FMT(1:8)='TEMPFIL.'
|
||||
WRITE(FMT(9:10),'(I2)') IFILOUT
|
||||
! OPEN(IFILOUT,STATUS='scratch',FORM='binary')
|
||||
WRITE(90,*) 'IFILOUT',IFILOUT
|
||||
! OPEN(IFILOUT,STATUS='scratch',FORM='unformatted')
|
||||
OPEN(IFILOUT,FILE=FMT,STATUS='UNKNOWN',FORM='BINARY')
|
||||
|
||||
ISLP=0
|
||||
IPRT=1
|
||||
IPNN=1
|
||||
IPEN=1
|
||||
IPO=1
|
||||
IRO=1
|
||||
IPP=0
|
||||
IRFN=0
|
||||
IGEN=0
|
||||
NXZL=0
|
||||
NITST=1
|
||||
ISCTXT=0
|
||||
IFILL=0
|
||||
IALTGM=1
|
||||
NLAYD=0
|
||||
HORIZ=10.
|
||||
VERT=8.
|
||||
XSALE=0.
|
||||
YSALE=0.
|
||||
XFACT=0.
|
||||
YFACT=0.
|
||||
AR=0.
|
||||
ANG=0.
|
||||
xadded=0.
|
||||
yadded=0.
|
||||
ntempin=0.
|
||||
WRITE(90,*) 'IN WRTFIL', IFILOUT,NP,NE,IPRT
|
||||
WRITE(IFILOUT) TITLE,NP,NE
|
||||
WRITE(IFILOUT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
||||
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
||||
WRITE(90,*) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
||||
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
||||
WRITE(IFILOUT) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG
|
||||
WRITE(90,*) 'IPP',IPP
|
||||
IF(IPP .GT. 0) WRITE(IFILOUT) ALINE
|
||||
|
||||
WRITE(IFILOUT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE)
|
||||
WRITE(IFILOUT) &
|
||||
(XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), &
|
||||
& WIDBS(J),SSO(J),BS1(J),J=1,NP)
|
||||
|
||||
WRITE(IFILOUT) NLST
|
||||
IF(NLST .GT. 0) THEN
|
||||
WRITE(IFILOUT) (LLIST(J),J=1,NLST), &
|
||||
& ((ILIST(J,I),I=1,LLIST(J)),J=1,NLST)
|
||||
ENDIF
|
||||
|
||||
WRITE(IFILOUT) NENTRY,NLAYD,NCLM
|
||||
|
||||
IF(NENTRY .GT. 0) THEN
|
||||
WRITE(IFILOUT) ((NEF(I,J),J=1,3),I=1,NENTRY)
|
||||
ENDIF
|
||||
|
||||
IF(NLAYD .GT. 0) THEN
|
||||
WRITE(IFILOUT) (LAY(I),I=1,NP)
|
||||
ENDIF
|
||||
|
||||
IF(NCLM .GT. 0) THEN
|
||||
WRITE(IFILOUT) ((ICCLN(I,J),J=1,350),I=1,NCLM)
|
||||
ENDIF
|
||||
REWIND IFILOUT
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE READRM1(IIIN)
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*48 DLIN
|
||||
|
||||
IIN=IIIN
|
||||
! Read in header lines
|
||||
|
||||
ISET=1
|
||||
WRITE(90,*) 'GOING TO HEADIN'
|
||||
CALL HEADIN(IIN,ISET)
|
||||
|
||||
! Read in existing elements
|
||||
WRITE(90,*) 'GOING TO RDELEM'
|
||||
CALL RDELEM(IIN)
|
||||
|
||||
! Read in nodal coordinates
|
||||
|
||||
WRITE(90,*) 'GOING TO RDCORD'
|
||||
CALL RDCORD(IIN)
|
||||
|
||||
! Close input file
|
||||
|
||||
CLOSE(IIN)
|
||||
|
||||
! Scale for plotting
|
||||
|
||||
IF(NP .GT. 0) THEN
|
||||
DO J=1,NP
|
||||
IF (CORD(J,1) .GT. VDX) THEN
|
||||
XMIN=MIN(XMIN,CORD(J,1))
|
||||
XMAX=MAX(XMAX,CORD(J,1))
|
||||
YMIN=MIN(YMIN,CORD(J,2))
|
||||
YMAX=MAX(YMAX,CORD(J,2))
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
! Read GEO file
|
||||
SUBROUTINE READGEO(IIIN)
|
||||
USE BLK1MOD
|
||||
CHARACTER*1000 HEADER
|
||||
CHARACTER*8 ID8
|
||||
CHARACTER*32 IJNK
|
||||
CHARACTER*80 ALINE,DLIN
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
INTEGER*2 NOP2(MAXE,8)
|
||||
|
||||
|
||||
IIN=IIIN
|
||||
read(iin,err=100) header
|
||||
if(header(1:6) .eq. 'RMAGEN') then
|
||||
inopt=2
|
||||
else
|
||||
inopt=1
|
||||
rewind iin
|
||||
endif
|
||||
read(iin) n1,m1
|
||||
rewind iin
|
||||
write(90,*) 'Apparent nodes and elements from file are'
|
||||
write(90,'(i15,i10)') n1,m1
|
||||
if(n1 .gt. maxp .or. m1 .gt. maxe) then
|
||||
!
|
||||
!...... Perhaps the file format is wrong, close and reopen
|
||||
!
|
||||
WRITE(DLIN,'(A32)') 'Parameter limits may be violated'
|
||||
call symbl(0.5,4.5,0.20,dlin,0.0,32)
|
||||
WRITE(DLIN,'(A35)') 'Retrying with alternate file format'
|
||||
call symbl(0.5,4.2,0.20,dlin,0.0,35)
|
||||
close (iin)
|
||||
open(iin ,file=fnamkep,status='old',form='unformatted')
|
||||
read(iin) n1,m1
|
||||
write(90,*) 'Revised nodes and elements from file are'
|
||||
write(90,'(i15,i10)') n1,m1
|
||||
if(n1 .gt. maxp .or. m1 .gt. maxe) then
|
||||
WRITE(DLIN,'(A31)') 'Parameter limits still violated'
|
||||
call symbl(0.5,3.9,0.20,dlin,0.0,31)
|
||||
WRITE(DLIN,'(A27)') 'Apparent nodes and elts are'
|
||||
call symbl(0.5,3.6,0.20,dlin,0.0,27)
|
||||
WRITE(DLIN,'(2i10)') n1,m1
|
||||
call symbl(0.5,3.3,0.20,dlin,0.0,20)
|
||||
WRITE(DLIN,'(A24)') 'Press enter to terminate'
|
||||
call symbl(0.5,4.5,0.20,dlin,0.0,24)
|
||||
CALL GTCHARX(ijnk,ndig,5.0,4.0)
|
||||
!cipk aug00 read(*,'(i1)') junk
|
||||
call quit_pgm
|
||||
endif
|
||||
endif
|
||||
rewind iin
|
||||
!
|
||||
!
|
||||
if(inopt .eq. 2) then
|
||||
read(iin,err=100) header
|
||||
READ(IIN,ERR=100) &
|
||||
& N1,M1,((CORD(J,K),K=1,2),ALPHA,WD(J),J=1,N1), &
|
||||
& ((NOP(J,K),K=1,8),IMAT(J),THTA(J),I3,J=1,M1) &
|
||||
& , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1)
|
||||
DO J=1,N1
|
||||
XUSR(J)=CORD(J,1)
|
||||
YUSR(J)=CORD(J,2)
|
||||
ENDDO
|
||||
!
|
||||
else
|
||||
READ(IIN,ERR=100) &
|
||||
& N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), &
|
||||
& ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1) &
|
||||
& , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1)
|
||||
DO J=1,N1
|
||||
DO K=1,2
|
||||
CORD(J,K)=CORDSN(J,K)
|
||||
ENDDO
|
||||
XUSR(J)=CORD(J,1)
|
||||
YUSR(J)=CORD(J,2)
|
||||
ENDDO
|
||||
DO J=1,M1
|
||||
!ipk feb08
|
||||
ncorn(j)=0
|
||||
DO K=1,8
|
||||
NOP(J,K)=NOP2(J,K)
|
||||
!ipk feb08
|
||||
if(nop(j,k) .gt. 0) ncorn(j)=k
|
||||
ENDDO
|
||||
ENDDO
|
||||
endif
|
||||
read(IIN,err=120,end=120) id8
|
||||
if(id8(1:6) .eq. 'part-2') then
|
||||
read(IIN,err=104) (widbs(j),sso(j),j=1,n1)
|
||||
read(IIN,err=120,end=120) id8
|
||||
endif
|
||||
|
||||
! Add part 3 write for continuity lines
|
||||
if(id8(1:6) .eq. 'part-3') then
|
||||
|
||||
!ipk aug02 IF(NCLM .GT. 0) THEN
|
||||
READ(IIN,ERR=104) NCLM,((ICCLN(I,J),J=1,350),I=1,NCLM)
|
||||
!ipk aug02 ENDIF
|
||||
read(IIN,err=120,end=120) id8
|
||||
endif
|
||||
!IPK DEB02 Add part 4 write for lock and BS1 lines and reordering
|
||||
if(id8(1:6) .eq. 'part-4') then
|
||||
read(iin,err=104,end=120) (lock(j),bs1(j),j=1,n1)
|
||||
read(iin,err=104,end=120) &
|
||||
nlst,((ilist(j,k),k=1,maeln),llist(j),j=1,maxln)
|
||||
endif
|
||||
DO J=1,M1
|
||||
!ipk feb08
|
||||
ncorn(j)=0
|
||||
DO K=1,8
|
||||
!ipk feb08
|
||||
if(nop(j,k) .gt. 0) ncorn(j)=k
|
||||
ENDDO
|
||||
ENDDO
|
||||
|
||||
GO TO 120
|
||||
|
||||
100 READ(IIN,ERR=104) &
|
||||
& N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), &
|
||||
& ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1)
|
||||
DO J=1,N1
|
||||
DO K=1,2
|
||||
CORD(J,K)=CORDSN(J,K)
|
||||
ENDDO
|
||||
XUSR(J)=CORD(J,1)
|
||||
YUSR(J)=CORD(J,2)
|
||||
ENDDO
|
||||
DO J=1,M1
|
||||
!ipk feb08
|
||||
ncorn(j)=0
|
||||
DO K=1,8
|
||||
NOP(J,K)=NOP2(J,K)
|
||||
!ipk feb08
|
||||
if(nop(j,k) .gt. 0) ncorn(j)=k
|
||||
ENDDO
|
||||
ENDDO
|
||||
GO TO 120
|
||||
|
||||
104 WRITE(90,*) 'Error reading binary geometry file'
|
||||
!ipk jan98 CALL SETD(23)
|
||||
call clscrn()
|
||||
WRITE(aline,*) 'Error reading binary geometry file'
|
||||
call symbl &
|
||||
& (1.1,3.3,0.20,aline,0.0,80)
|
||||
WRITE(aline,*) 'Press enter to exit'
|
||||
call symbl &
|
||||
& (1.1,3.0,0.20,aline,0.0,80)
|
||||
ndig=1
|
||||
CALL GTCHARX(IJNK,NDIG,5.0,7.6)
|
||||
CALL Quit_Pgm
|
||||
STOP
|
||||
|
||||
120 CONTINUE
|
||||
NP=N1
|
||||
NE=M1
|
||||
|
||||
! Close input file
|
||||
|
||||
CLOSE(IIN)
|
||||
|
||||
! Scale for plotting
|
||||
|
||||
IF(NP .GT. 0) THEN
|
||||
DO J=1,NP
|
||||
IF (CORD(J,1) .GT. VDX) THEN
|
||||
XMIN=MIN(XMIN,CORD(J,1))
|
||||
XMAX=MAX(XMAX,CORD(J,1))
|
||||
YMIN=MIN(YMIN,CORD(J,2))
|
||||
YMAX=MAX(YMAX,CORD(J,2))
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
RETURN
|
||||
|
||||
END
|
||||
|
||||
SUBROUTINE READGFG(IUNIT,ISW)
|
||||
|
||||
USE BLK1MOD
|
||||
INCLUDE "BFILES.I90"
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'TXFRM.COM'
|
||||
CHARACTER*1 ANS
|
||||
CHARACTER*32 ANS32
|
||||
CHARACTER*3 ID
|
||||
CHARACTER*77 DLIN
|
||||
CHARACTER*150 DLIN1
|
||||
CHARACTER*80 LIND
|
||||
DIMENSION NTMP(9),NTEMPLIN(200,10),ATT(9)
|
||||
|
||||
REAL*8 CX,CY,VALS(7)
|
||||
|
||||
MEL=MAXE
|
||||
ylv=7.5
|
||||
IIN=IUNIT
|
||||
IPRT=1
|
||||
IPNN=1
|
||||
IPEN=1
|
||||
IPO=1
|
||||
IRO=1
|
||||
IPP=0
|
||||
IRFN=0
|
||||
IGEN=0
|
||||
NXZL=0
|
||||
NITST=1
|
||||
ISCTXT=0
|
||||
IFILL=0
|
||||
IALTGM=1
|
||||
NLAYD=0
|
||||
HORIZ=10.
|
||||
VERT=8.
|
||||
XSALE=0.
|
||||
YSALE=0.
|
||||
XFACT=0.
|
||||
YFACT=0.
|
||||
AR=0.
|
||||
ANG=0.
|
||||
xadded=0.
|
||||
yadded=0.
|
||||
ntempin=0.
|
||||
KLIN=0
|
||||
IF(ABS(ISW) .EQ. 1) GO TO 500
|
||||
DO I=1,10000
|
||||
READ(IIN,'(A3,A77)') ID,DLIN
|
||||
IF(ID .EQ. 'T1 ') THEN
|
||||
TITLE(1:77)=DLIN
|
||||
GO TO 10
|
||||
ENDIF
|
||||
ENDDO
|
||||
10 CONTINUE
|
||||
REWIND IIN
|
||||
|
||||
! READ ELEMENT AND CCLINE DATA
|
||||
|
||||
20 CONTINUE
|
||||
DO ICOUNTC=1,200000
|
||||
DO JJ=1,150
|
||||
DLIN1(JJ:JJ)=' '
|
||||
ENDDO
|
||||
READ(IIN,'(A3,A150)', END=175) ID,DLIN1
|
||||
IF(ID .EQ. 'GE ' .or. ID .EQ. 'GO') THEN
|
||||
! Count the number of variables
|
||||
I=0
|
||||
ICOUNT=0
|
||||
25 CONTINUE
|
||||
IF(DLIN1(I+1:I+1) .NE. ' ') THEN
|
||||
GO TO 30
|
||||
ELSE
|
||||
I=I+1
|
||||
GO TO 25
|
||||
ENDIF
|
||||
30 I=I+1
|
||||
IF(I .EQ. 151) THEN
|
||||
ICOUNT =ICOUNT+1
|
||||
GO TO 40
|
||||
ENDIF
|
||||
IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN
|
||||
ICOUNT=ICOUNT+1
|
||||
35 CONTINUE
|
||||
IF(I+1 .EQ. 151) GO TO 40
|
||||
IF(DLIN1(I+1:I+1) .EQ. ' ') THEN
|
||||
I=I+1
|
||||
GO TO 35
|
||||
ELSE
|
||||
GO TO 30
|
||||
ENDIF
|
||||
ELSE
|
||||
GO TO 30
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
40 CONTINUE
|
||||
IF(ID .EQ. 'GO') THEN
|
||||
KLIN=KLIN+1
|
||||
READ(DLIN1,*) (NTEMPLIN(KLIN,K),K=1,ICOUNT)
|
||||
GO TO 20
|
||||
ENDIF
|
||||
IF(ICOUNT .GT. 10) THEN
|
||||
READ(DLIN1,*) J, (NTMP(K),K=1,9),THT
|
||||
ELSE
|
||||
READ(DLIN1,*) J, (NTMP(K),K=1,9)
|
||||
ENDIF
|
||||
|
||||
|
||||
IF (J .GE. MEL) THEN
|
||||
CALL SETD(23)
|
||||
!cipk aug00
|
||||
WRITE(lind,*) ' Element number exceeds MAXE in RDELEM'
|
||||
call symbl (1.1,ylv-0.3,0.20,lind,0.0,80)
|
||||
ndig=1
|
||||
WRITE(90,*) ' Element number exceeds MAXE in RDELEM'
|
||||
WRITE(lind,6000)
|
||||
CALL GTCHARX(ANS32,IJNK,5.0,4.0)
|
||||
CALL Quit_Pgm
|
||||
STOP
|
||||
ENDIF
|
||||
!
|
||||
! Check to ensure there are no duplicate numbers in input stream
|
||||
! of element connections
|
||||
!
|
||||
DO K=1,7
|
||||
IF(NTMP(K) .NE. 0) THEN
|
||||
DO L=K+1,8
|
||||
IF(NTMP(K) .EQ. NTMP(L)) THEN
|
||||
CALL SETD(23)
|
||||
DO KK=1,8
|
||||
NOP(J,KK) = NTMP(KK)
|
||||
ENDDO
|
||||
IMAT(J)=NTMP(9)
|
||||
call eltdisp(j)
|
||||
DO KK=1,8
|
||||
NTMP(KK) = NOP(J,KK)
|
||||
ENDDO
|
||||
NTMP(9)=IMAT(J)
|
||||
GO TO 45
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
45 CONTINUE
|
||||
DO K=1,8
|
||||
NOP(J,K) = NTMP(K)
|
||||
ND = NTMP(K)
|
||||
IF (ND .GT. 0) THEN
|
||||
INEW(ND) = 2
|
||||
NP = MAX(NP,ND)
|
||||
ENDIF
|
||||
ENDDO
|
||||
!
|
||||
NCN = 2
|
||||
IF (NOP(J,3) .NE. 0) NCN = 3
|
||||
IF (NOP(J,4) .NE. 0) NCN = 4
|
||||
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5
|
||||
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6
|
||||
IF (NOP(J,6) .NE. 0) NCN = 6
|
||||
IF (NOP(J,7) .NE. 0) NCN = 8
|
||||
NCORN(J) = NCN
|
||||
IESKP(J) = 0
|
||||
IMAT(J) = NTMP(9)
|
||||
THTA(J)=THT
|
||||
IEM(J) = J
|
||||
DO 50 K=2,NCN,2
|
||||
ND = NTMP(K)
|
||||
IF (ND .GT. 0) THEN
|
||||
IF(NCN .EQ. 5 .AND. K .EQ. 4) GO TO 50
|
||||
WD(ND)=0.
|
||||
ENDIF
|
||||
50 CONTINUE
|
||||
NE = MAX(J,NE)
|
||||
!
|
||||
GOTO 20
|
||||
!
|
||||
175 CONTINUE
|
||||
|
||||
REWIND IIN
|
||||
70 CONTINUE
|
||||
DO ICOUNTC=1,100000
|
||||
DO JJ=1,150
|
||||
DLIN1(JJ:JJ)=' '
|
||||
ENDDO
|
||||
READ(IIN,'(A3,A150)', END=400) ID,DLIN1
|
||||
IF(ID .EQ. 'GNN' .OR. ID .EQ. 'GWN') THEN
|
||||
! Count the number of variables
|
||||
I=0
|
||||
ICOUNT=0
|
||||
75 CONTINUE
|
||||
IF(DLIN1(I+1:I+1) .NE. ' ') THEN
|
||||
GO TO 80
|
||||
ELSE
|
||||
I=I+1
|
||||
GO TO 75
|
||||
ENDIF
|
||||
80 I=I+1
|
||||
IF(I .EQ. 151) THEN
|
||||
ICOUNT =ICOUNT+1
|
||||
GO TO 90
|
||||
ENDIF
|
||||
IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN
|
||||
ICOUNT=ICOUNT+1
|
||||
85 CONTINUE
|
||||
IF(I+1 .EQ. 151) GO TO 90
|
||||
IF(DLIN1(I+1:I+1) .EQ. ' ') THEN
|
||||
I=I+1
|
||||
GO TO 85
|
||||
ELSE
|
||||
GO TO 80
|
||||
ENDIF
|
||||
ELSE
|
||||
GO TO 80
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
90 CONTINUE
|
||||
DO K=1,7
|
||||
VALS(K)=0.
|
||||
ENDDO
|
||||
READ(DLIN1,*) J,(VALS(K),K=1,ICOUNT-1)
|
||||
IF(ID .EQ. 'GNN') THEN
|
||||
CX=VALS(1)
|
||||
CY=VALS(2)
|
||||
BELEV=VALS(3)
|
||||
NP = MAX(NP,J)
|
||||
CORD(J,1) = CX
|
||||
CORD(J,2) = CY
|
||||
XUSR(J) = CX
|
||||
YUSR(J) = CY
|
||||
WD(J) = BELEV
|
||||
INSKP(J)=0
|
||||
INEW(J) = 1
|
||||
GO TO 70
|
||||
ELSE
|
||||
WDTHX=VALS(1)
|
||||
SS1X=VALS(2)
|
||||
SS2X=VALS(3)
|
||||
WDSX=VALS(4)
|
||||
WIDTH(J)=WDTHX
|
||||
SS1(J)=SS1X
|
||||
SS2(J)=SS2X
|
||||
WIDS(J)=WDSX
|
||||
GO TO 70
|
||||
ENDIF
|
||||
|
||||
400 CONTINUE
|
||||
|
||||
! CHECKOUT THE CCLINE DATA
|
||||
|
||||
KK=0
|
||||
IF(KLIN .GT. 0) THEN
|
||||
NCLM=1
|
||||
IF(NTEMPLIN(1,1) .EQ. 1) THEN
|
||||
DO K=1,KLIN
|
||||
DO J=1,10
|
||||
IF(K .EQ. 1 .AND. J .EQ. 1) GO TO 410
|
||||
IF(NTEMPLIN(K,J) .LT. 0) THEN
|
||||
NCLM=NCLM+1
|
||||
KK=0
|
||||
GO TO 420
|
||||
ELSEIF(NTEMPLIN(K,J) .EQ. 0) THEN
|
||||
GO TO 420
|
||||
ELSE
|
||||
KK=KK+1
|
||||
ICCLN(NCLM,KK)=NTEMPLIN(K,J)
|
||||
ENDIF
|
||||
410 CONTINUE
|
||||
ENDDO
|
||||
420 CONTINUE
|
||||
ENDDO
|
||||
NCLM=NCLM-1
|
||||
ENDIF
|
||||
ENDIF
|
||||
RETURN
|
||||
|
||||
500 CONTINUE
|
||||
IF(ISW .EQ. -1) THEN
|
||||
NESV=NE
|
||||
NPSV=NP
|
||||
ENDIF
|
||||
READ(IUNIT,*) NE,NCNTR,NATTR
|
||||
IMIDS=0
|
||||
NMESS=2
|
||||
inattr=1
|
||||
call GETINT(INATTR)
|
||||
|
||||
DO JJ=1,NE
|
||||
READ(IUNIT,*) J,(NTMP(K),K=1,NCNTR),(ATT(K),K=1,NATTR)
|
||||
IF(ISW .EQ. -1) J=J+NESV
|
||||
IF (J .GE. MEL) THEN
|
||||
CALL SETD(23)
|
||||
WRITE(lind,*) ' Element number exceeds MAXE in RDELEM'
|
||||
call symbl &
|
||||
& (1.1,ylv-0.3,0.20,lind,0.0,80)
|
||||
ndig=1
|
||||
WRITE(90,*) ' Element number exceeds MAXE in RDELEM'
|
||||
WRITE(lind,6000)
|
||||
CALL GTCHARX(ANS32,IJNK,5.0,4.0)
|
||||
CALL Quit_Pgm
|
||||
STOP
|
||||
ENDIF
|
||||
DO KK=1,3
|
||||
IF(ISW .EQ. -1) THEN
|
||||
NOP(J,2*KK-1) = NTMP(KK)+NPSV
|
||||
ELSE
|
||||
NOP(J,2*KK-1) = NTMP(KK)
|
||||
ENDIF
|
||||
NOP(J,2*KK)=0
|
||||
ENDDO
|
||||
IF(NATTR .GT. 0) THEN
|
||||
IMAT(J)=ATT(1)
|
||||
ELSE
|
||||
IMAT(J)=INATTR
|
||||
ENDIF
|
||||
NCORN(J)=6
|
||||
IESKP(J)=0
|
||||
ENDDO
|
||||
NE=J
|
||||
CLOSE(IUNIT)
|
||||
DO L=255,1,-1
|
||||
IF(FNAMKEP(L:L) .EQ. '.') THEN
|
||||
FNAMKEP(L+1:L+4)='node'
|
||||
OPEN(IUNIT,FILE=FNAMKEP,STATUS='OLD',ACTION='READ')
|
||||
GO TO 510
|
||||
ENDIF
|
||||
ENDDO
|
||||
510 CONTINUE
|
||||
|
||||
READ(IUNIT,*) NPPP,NDUM,NATTR
|
||||
DO KK=1,NPPP
|
||||
READ(IUNIT,*) J,CX,CY,(VALS(K),K=1,NATTR)
|
||||
IF(ISW .EQ. -1) J=J+NPSV
|
||||
IF(J .EQ. 0) THEN
|
||||
J=NPPP
|
||||
JZ=1
|
||||
ENDIF
|
||||
BELEV=-9999.
|
||||
WEL=0.
|
||||
LOCK1=0
|
||||
IF(NATTR .GT. 0) BELEV=VALS(1)
|
||||
IF (J .GE. MAXP) THEN
|
||||
call clscrn()
|
||||
WRITE(dlin,*) ' Node number exceeds MAXP in RDCORD',j
|
||||
call symbl &
|
||||
& (1.1,3.3,0.20,dlin,0.0,80)
|
||||
WRITE(90,*) ' Node number exceeds MAXP in RDCORD'
|
||||
WRITE(DLIN,*) ' Press enter to exit'
|
||||
call symbl &
|
||||
& (1.1,3.0,0.20,dlin,0.0,80)
|
||||
ndig=1
|
||||
CALL GTCHARX(ANS32,ndig,5.0,4.0)
|
||||
CALL Quit_Pgm
|
||||
STOP
|
||||
ENDIF
|
||||
NP = MAX(NP,J)
|
||||
XUSR(J) = CX
|
||||
YUSR(J) = CY
|
||||
CORD(J,1) = (XUSR(J)+XS)/TXSCAL
|
||||
CORD(J,2) = (YUSR(J)+YS)/TXSCAL
|
||||
WD(J) = BELEV
|
||||
WIDTH(J)=0.
|
||||
SS1(J)=0.
|
||||
SS2(J)=0.
|
||||
WIDS(J)=0.
|
||||
WIDBS(J)=0.
|
||||
SSO(J)=0.
|
||||
INSKP(J)=0
|
||||
INEW(J) = 1
|
||||
LOCK(J)=LOCK1
|
||||
BS1(J)=0.
|
||||
ENDDO
|
||||
|
||||
CLOSE(IUNIT)
|
||||
6000 FORMAT(' Press enter to exit')
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE ZEROOUT
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
MNP = MAXP
|
||||
MEL = MAXE
|
||||
DO I=1,MEL
|
||||
DO M=1,8
|
||||
NOP(I,M)=0
|
||||
ENDDO
|
||||
IESKP(I)=-1
|
||||
IEM(I) = 0
|
||||
IMAT(I) = 0
|
||||
THTA(I)=0.
|
||||
XC(I) = -1.E20
|
||||
YC(I) = -1.E20
|
||||
ENDDO
|
||||
DO I=1,MNP
|
||||
XUSR(I) = -1.D20
|
||||
YUSR(I) = -1.D20
|
||||
CORD(I,1) = -1.D20
|
||||
CORD(I,2) = -1.D20
|
||||
WD(I) = -9999.
|
||||
LAY(I) = -9999
|
||||
WIDTH(I) = 0.0
|
||||
SS1(I) = 0.0
|
||||
SS2(I) = 0.0
|
||||
WIDS(I) = 0.0
|
||||
WIDBS(I)=0.
|
||||
SSO(I)=0.
|
||||
INSKP(I) = 1
|
||||
INEW(I) = 0
|
||||
!ipk mar02
|
||||
lock(i)=0
|
||||
bs1(I)=0.
|
||||
ENDDO
|
||||
NP=0
|
||||
NE=0
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,109 @@
|
||||
SUBROUTINE GETGRP
|
||||
|
||||
USE BLK1MOD
|
||||
|
||||
CHARACTER*8 IDSAV,ID
|
||||
CHARACTER*72 DLINSAV,DLIN
|
||||
|
||||
IDSAV=ID
|
||||
DLINSAV=DLIN
|
||||
|
||||
! ALLOCATE ARRAY SIZES
|
||||
|
||||
IF(.NOT. ALLOCATED(IGRPNUM)) THEN
|
||||
ALLOCATE (IGRPNUM(25,MAXE),MAXENT(25))
|
||||
IGRPNUM=0
|
||||
ENDIF
|
||||
!
|
||||
! NOW READ DATA TO FILE
|
||||
|
||||
CALL GINPT(IGRP,ID,DLIN)
|
||||
IF(ID(1:3) .EQ. 'TIT') THEN
|
||||
|
||||
! READ TITLE
|
||||
|
||||
READ(DLIN,'(A72)') HEDR
|
||||
CALL GINPT(IGRP,ID,DLIN)
|
||||
ENDIF
|
||||
MAXIGRP=0
|
||||
|
||||
301 READ(DLIN,'(I8)') IGRPA
|
||||
CALL GINPT(IGRP,ID,DLIN)
|
||||
NL=1
|
||||
NH=9
|
||||
|
||||
401 CONTINUE
|
||||
IF(ID(1:3) .EQ. 'NGP') THEN
|
||||
READ(DLIN,'(9I8)') (IGRPNUM(IGRPA,I),I=NL,NH)
|
||||
CALL GINPT(IGRP,ID,DLIN)
|
||||
IF(IGRPNUM(IGRPA,NH) .NE. 0) THEN
|
||||
NL=NL+9
|
||||
NH=NH+9
|
||||
GO TO 401
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
! SET MAXIMA FROM INPUT FILE
|
||||
|
||||
IF(MAXIGRP .LT. IGRPA) MAXIGRP=IGRPA
|
||||
MAXENT(IGRPA)=NH
|
||||
|
||||
IF(ID(1:3) .EQ. 'GRP') GO TO 301
|
||||
CALL TOSER
|
||||
ID=IDSAV
|
||||
DLIN=DLINSAV
|
||||
CALL PLOTOT(1)
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE WRTGP
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
include 'd.inc'
|
||||
|
||||
CHARACTER(LEN=256) :: FILTER
|
||||
CHARACTER(LEN=96) :: FNAME
|
||||
LOGICAL :: OPENED
|
||||
|
||||
IGRPOUT=29
|
||||
INQUIRE(29, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
Filter='TXT file -- *.txt|*.txt|'
|
||||
|
||||
CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Group File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
OPEN(IGRPOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE')
|
||||
ELSE
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDIF
|
||||
CALL TOPAR
|
||||
REWIND IGRPOUT
|
||||
WRITE(IGRPOUT,'(a)') 'TIT GROUP FILE'
|
||||
|
||||
DO K=1,25
|
||||
IF(MAXENT(K) .GT. 0) THEN
|
||||
WRITE(IGRPOUT,6001) K
|
||||
LROWS=MAXENT(K)/9+1
|
||||
LASTCOL=MOD(MAXENT(K),9)
|
||||
IF(LASTCOL .EQ. 0) THEN
|
||||
IF(IGRPNUM(K,MAXENT(K)) .EQ. 0) THEN
|
||||
LROWS=LROWS-1
|
||||
ENDIF
|
||||
ENDIF
|
||||
NL=-8
|
||||
DO LL=1,LROWS
|
||||
NL=NL+9
|
||||
NH=NL+8
|
||||
WRITE(IGRPOUT,6002) (IGRPNUM(K,L),L=NL,NH)
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
6001 FORMAT('NGP ',I8)
|
||||
6002 FORMAT('GRP ',9I8)
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,175 @@
|
||||
SUBROUTINE GETSTRESSFIL
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
include 'd.inc'
|
||||
|
||||
ALLOCATABLE WDTEMP(:)
|
||||
CHARACTER*256 FILTER,FNAME
|
||||
INTEGER IYRR,IMON,IDAY
|
||||
REAL HOUR
|
||||
LOGICAL OPENED
|
||||
DATA IYRR/2015/,IMON/1/,IDAY/1/
|
||||
DATA HOUR/0.0/
|
||||
|
||||
IF(.NOT. ALLOCATED(WDTEMP)) THEN
|
||||
|
||||
ALLOCATE (WDTEMP(NP))
|
||||
ENDIF
|
||||
DO N=1,NP
|
||||
WDTEMP(N)=WD(N)
|
||||
ENDDO
|
||||
|
||||
100 CONTINUE
|
||||
|
||||
ISWT=-1
|
||||
|
||||
IWRTMP=0
|
||||
IF(IMP .GT. 0) THEN
|
||||
! FIRST WRITE EXISTING MAP TO SCRATCH
|
||||
OPEN(98,FORM='BINARY',STATUS='SCRATCH')
|
||||
|
||||
CALL WRTMAP(98)
|
||||
REWIND 98
|
||||
IWRTMP=1
|
||||
ENDIF
|
||||
CALL GMAP
|
||||
|
||||
CALL GRIDSB(ISWT)
|
||||
|
||||
INQUIRE(104, OPENED=OPENED)
|
||||
IF(OPENED) GO TO 200
|
||||
Filter='Output file -- *.dat|*.dat|'
|
||||
|
||||
CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Stress File')
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
IOT=104
|
||||
OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN')
|
||||
ELSE
|
||||
GO TO 500
|
||||
ENDIF
|
||||
200 CONTINUE
|
||||
CALL SETDT(IYRR,IMON,IDAY,HOUR)
|
||||
WRITE(IOT,'(''DATE '',3I8,F8.3)') IYRR,IMON,IDAY,HOUR
|
||||
DO J=1,NP
|
||||
IF (INEW(J) .EQ. 1) THEN
|
||||
WRITE(IOT,'(''WAVESS '',I8,F8.4)') J,WD(J)
|
||||
ENDIF
|
||||
ENDDO
|
||||
WRITE(IOT,'(''ENDBLOCK'')')
|
||||
FLUSH(IOT)
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to process another map file?'//&
|
||||
CHAR(13)//' ','PROCESS ANOTHER?')
|
||||
!
|
||||
! If answer 'No', return
|
||||
!
|
||||
IF (WInfoDialog(4).EQ.2) THEN
|
||||
WRITE(IOT,'(''ENDDATA'')')
|
||||
FLUSH(IOT)
|
||||
GO TO 500
|
||||
ENDIF
|
||||
GO TO 100
|
||||
!
|
||||
! Delete all unused nodes
|
||||
!
|
||||
CALL DELETM(2)
|
||||
|
||||
500 DO N=1,NP
|
||||
WD(N)=WDTEMP(N)
|
||||
ENDDO
|
||||
DEALLOCATE (WDTEMP)
|
||||
IF(IWRTMP .GT. 0) THEN
|
||||
|
||||
CALL RDMAP(2,98,0,0)
|
||||
CLOSE (98)
|
||||
ENDIF
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE SETDT(N1,N2,N3,R1)
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'D.inc'
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: N1,N2,N3,IERR
|
||||
real :: R1
|
||||
character*3 :: sub
|
||||
|
||||
call wdialogload(IDD_SETYRDT)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(idf_integer1,n1)
|
||||
CALL WDialogPutInteger(idf_integer2,n2)
|
||||
CALL WDialogPutInteger(idf_integer3,n3)
|
||||
CALL WDialogPutReal(idf_real1,r1)
|
||||
|
||||
CALL WDialogSelect(IDD_setyrdt)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
DO
|
||||
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,r1)
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE GMAP
|
||||
USE WINTERACTER
|
||||
|
||||
include 'd.inc'
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=3) :: SUB,SUB1
|
||||
INTEGER IMP
|
||||
|
||||
CALL WSelectFile(ID_STRING1,PromptOn,FNAME,'Load Map File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
IF(SUB .EQ. 'map') then
|
||||
IMP=9
|
||||
OPEN(9,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then
|
||||
IMP=94
|
||||
OPEN(94,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'mpb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read')
|
||||
ELSEIF(SUB .EQ. 'mbb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read')
|
||||
ELSEIF(SUB .EQ. 'rm1') then
|
||||
imp=13
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'shp') then
|
||||
IMP=113
|
||||
OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
SUB='DBF'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
ENDIF
|
||||
ENDIF
|
||||
CALL RDMAP(2,IMP,0,0)
|
||||
CLOSE (IMP)
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,140 @@
|
||||
! Last change: IPK 2 Feb 2003 6:25 pm
|
||||
SUBROUTINE DELAUNAY1(XMAP1,YMAP1,NVERT)
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*80 LIND
|
||||
CHARACTER*1 ANS
|
||||
REAL*8 XMAP1(*),YMAP1(*)
|
||||
DATA VDX9/-9.E9/,NEDGE/0/
|
||||
|
||||
! Get location of supertriangle
|
||||
|
||||
iprt=0
|
||||
ngap=0
|
||||
|
||||
|
||||
|
||||
call supert(XMAP1,YMAP1,NVERT)
|
||||
|
||||
NELTS=1
|
||||
|
||||
NVERTM=NVERT-3
|
||||
|
||||
! Sort points into ascending x order
|
||||
|
||||
CALL SORTDB(XMAP1,NKEY,NVERTM)
|
||||
|
||||
! Loop on the vertices
|
||||
|
||||
YLV=7.5
|
||||
DO NN=1,NVERT-3
|
||||
|
||||
|
||||
if(mod(NN,2500) .eq. 0) then
|
||||
ylv=ylv-0.3
|
||||
if(ylv .lt. 0.1) then
|
||||
ylv=7.9
|
||||
call clscrn
|
||||
endif
|
||||
write(lind,6010) NN
|
||||
6010 format(i8,' points processed')
|
||||
call symbl &
|
||||
& (1.1,ylv,0.20,LIND,0.0,80)
|
||||
endif
|
||||
|
||||
! process next point
|
||||
|
||||
N=NKEY(NN)
|
||||
|
||||
! Skip out if inactive point
|
||||
IF(N .EQ. 0) GO TO 500
|
||||
IF(XMAP1(N) .LT. VDX9) GO TO 500
|
||||
|
||||
IF(NN .LT. NVERTM) THEN
|
||||
DO KK=NN+1,NVERTM
|
||||
K=NKEY(KK)
|
||||
IF(K .NE. 0) THEN
|
||||
IF(XMAP1(N) .EQ. XMAP1(K)) THEN
|
||||
IF(YMAP1(N) .EQ. YMAP1(K)) THEN
|
||||
WRITE(45,*) 'IDENT',N,K
|
||||
NKEY(KK)=0
|
||||
ENDIF
|
||||
ELSE
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ENDIF
|
||||
200 CONTINUE
|
||||
ENDDO
|
||||
ENDIF
|
||||
|
||||
! Set edge buffers to zero
|
||||
|
||||
IF(NEDGE .GT. 0) THEN
|
||||
DO J=1,NEDGE
|
||||
IEDGE(J,1)=0
|
||||
IEDGE(J,2)=0
|
||||
END DO
|
||||
ELSE
|
||||
DO J=1,100
|
||||
IEDGE(J,1)=0
|
||||
IEDGE(J,2)=0
|
||||
END DO
|
||||
ENDIF
|
||||
NEDGE=0
|
||||
|
||||
! test for point in circumcircle
|
||||
|
||||
DO J=1,NELTS
|
||||
CALL INSIDCIRC(XMAP1,YMAP1,J,N,ISWT)
|
||||
|
||||
! If inside process edges
|
||||
|
||||
IF(ISWT .EQ. 1) THEN
|
||||
CALL PROCESS(J,NEDGE,NGAP)
|
||||
ENDIF
|
||||
END DO
|
||||
|
||||
! Setup to form new triangles
|
||||
|
||||
CALL SETEDG(NEDGE)
|
||||
|
||||
! Now form triangles as needed
|
||||
|
||||
DO J=1,NEDGE
|
||||
IF(IEDGE(J,1) .NE. 0) THEN
|
||||
!ipk dec17 add wd
|
||||
CALL FORMT(XMAP1,YMAP1,J,N,NGAP,KK,wd)
|
||||
ENDIF
|
||||
END DO
|
||||
|
||||
NEDGE=0
|
||||
if(iprt .eq. 0) go to 500
|
||||
DO J=1,NELTS
|
||||
IF(NOPEL(J,1) .GT. 0) THEN
|
||||
WRITE(3,'(2i5,2i10,19x,''1'')') J,(NOPEL(J,K),K=1,3)
|
||||
ENDIF
|
||||
END DO
|
||||
|
||||
|
||||
IF(NN .EQ. 1) THEN
|
||||
write(41,'('' 9999'')')
|
||||
do j=1,nvert
|
||||
write(41,'(i10,2f20.4,F10.3)') j,XMAP1(j),YMAP1(j),VAL(J)
|
||||
enddo
|
||||
write(41,'('' 9999'')')
|
||||
write(41,'('' 9999'')')
|
||||
write(41,'('' 0 NENTRY'')')
|
||||
write(41,'('' 0 NCLM'')')
|
||||
WRITE(41,'(''ENDDATA'')')
|
||||
ENDIF
|
||||
500 continue
|
||||
END DO
|
||||
|
||||
! Get rid of elements from super point
|
||||
|
||||
CALL RIDPOINT(NVERT)
|
||||
|
||||
RETURN
|
||||
END SUBROUTINE
|
||||
@ -0,0 +1,244 @@
|
||||
SUBROUTINE TRIANINT(NMAP,M,ISWT,ITIME)
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
SAVE
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
DIMENSION WGT(8)
|
||||
REAL*8 XMINL,YMINL,XMAXL,YMAXL
|
||||
! data itime/0/
|
||||
|
||||
! LOOK FOR MATCHING POINTS
|
||||
ITIMESKP=0
|
||||
DO K=1,MAXPTS
|
||||
DISQ=(XUSR(M)-XMAP(K))**2+(YUSR(M)-YMAP(K))**2
|
||||
IF(DISQ .LT. 1.) THEN
|
||||
WD(M)=VAL(K)
|
||||
FPN = WD(M)*10.
|
||||
X = CORD(M,1)
|
||||
Y = CORD(M,2) - .11
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.1,FPN,0.0,-1)
|
||||
endif
|
||||
ITIMESKP=1
|
||||
GO TO 300
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
! Search for element that has circumcircle around the node
|
||||
|
||||
IF(ISWT .NE. 0) THEN
|
||||
IF(ITIME .EQ. 0) NSTART=1
|
||||
ELSE
|
||||
NSTART=1
|
||||
ENDIF
|
||||
DO N=NSTART,NELTS
|
||||
IF(NOPEL(N,1) .EQ. 0) GO TO 200
|
||||
if(RADS(N) .eq. 0.) then
|
||||
CALL CCENTRE(XMAP(NOPEL(N,1)),XMAP(NOPEL(N,2)),XMAP(NOPEL(N,3)) &
|
||||
&,YMAP(NOPEL(N,1)),YMAP(NOPEL(N,2)),YMAP(NOPEL(N,3)) &
|
||||
&,XCEN(N),YCEN(N),RADS(N))
|
||||
endif
|
||||
|
||||
IF(RADS(N)+XCEN(N) .GE. XUSR(M)) THEN
|
||||
NSTART=N
|
||||
GO TO 210
|
||||
ENDIF
|
||||
200 CONTINUE
|
||||
ENDDO
|
||||
210 CONTINUE
|
||||
220 continue
|
||||
! WRITE(155,*) M,NSTART
|
||||
DO N=NSTART,NELTS
|
||||
IF(NOPEL(N,1) .EQ. 0) GO TO 250
|
||||
if(RADS(N) .eq. 0.) then
|
||||
CALL CCENTRE(XMAP(NOPEL(N,1)),XMAP(NOPEL(N,2)),XMAP(NOPEL(N,3)) &
|
||||
&,YMAP(NOPEL(N,1)),YMAP(NOPEL(N,2)),YMAP(NOPEL(N,3)) &
|
||||
&,XCEN(N),YCEN(N),RADS(N))
|
||||
endif
|
||||
xminl=min(XMAP(NOPEL(N,1)),XMAP(NOPEL(N,2)),XMAP(NOPEL(N,3)))
|
||||
xmaxl=max(XMAP(NOPEL(N,1)),XMAP(NOPEL(N,2)),XMAP(NOPEL(N,3)))
|
||||
yminl=min(YMAP(NOPEL(N,1)),YMAP(NOPEL(N,2)),YMAP(NOPEL(N,3)))
|
||||
ymaxl=max(YMAP(NOPEL(N,1)),YMAP(NOPEL(N,2)),YMAP(NOPEL(N,3)))
|
||||
! IF(M .EQ. 6316) THEN
|
||||
! WRITE(156,'(2I6,6F15.2)') M,N,XUSR(M),XMINL,XMAXL,YUSR(M),YMINL,YMAXL
|
||||
! ENDIF
|
||||
if(xusr(m) .lt. xminl-0.01 .or. xusr(m) .gt. xmaxl+0.01) then
|
||||
go to 250
|
||||
elseif(yusr(m) .lt. yminl-0.01 .or. yusr(m) .gt. ymaxl+0.01) then
|
||||
go to 250
|
||||
endif
|
||||
! IF(M .EQ. 6316) WRITE(156,*) 'PASSED X AND Y TEST',N
|
||||
|
||||
DISQ=(XUSR(M)-XCEN(N))**2+(YUSR(M)-YCEN(N))**2
|
||||
|
||||
IF(DISQ .LE. RADS(N)**2*1.0001) THEN
|
||||
|
||||
! IF(M .EQ. 6316) write(156,*) m,n,disq,rads(n)**2,xusr(m),xcen(n)
|
||||
|
||||
! We have a candidate
|
||||
|
||||
CALL GETWT(N,XUSR(M),YUSR(M),WGT,1)
|
||||
DO K=1,3
|
||||
IF(WGT(K) .LT. -1E-4 .OR. WGT(K) .GT. 1.0001) THEN
|
||||
WRITE(142,*) 'REJECT',m,n,disq,rads(n)**2,wgt(1),wgt(2),wgt(3)
|
||||
if(nstart .gt. 1) then
|
||||
nstart=1
|
||||
go to 220
|
||||
endif
|
||||
GO TO 250
|
||||
ENDIF
|
||||
ENDDO
|
||||
WD(M)=WGT(1)*VAL(NOPEL(N,1))+WGT(2)*VAL(NOPEL(N,2))+WGT(3)*VAL(NOPEL(N,3))
|
||||
FPN = WD(M)*10.
|
||||
X = CORD(M,1)
|
||||
Y = CORD(M,2) - .11
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||||
CALL RRED
|
||||
CALL NUMBR(X,Y,0.1,FPN,0.0,-1)
|
||||
endif
|
||||
GO TO 300
|
||||
ENDIF
|
||||
250 CONTINUE
|
||||
ENDDO
|
||||
300 CONTINUE
|
||||
IF(ITIMESKP .EQ. 0) ITIME=1
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE GETWT(N,XSW,YSW,WGT,ISWT)
|
||||
|
||||
!-
|
||||
!......SUBROUTINE TO EVALUATE FUNCTION AT GRID POINTS
|
||||
!-
|
||||
!- N = ELEMENT NUMBER
|
||||
!_ XSW = X COORDINATE OF DESIRED POINT
|
||||
!_ YSW = Y COORDINATE OF DESIRED POINT
|
||||
! WGT(8) = ARRAY OF WEIGHTING FUNCTIONS
|
||||
! ISWT = SWITCH FOR CHOICE BETWEEN LINEAR AND QUADRATIC WEIGHTING
|
||||
! = 1 FOR LINEAR
|
||||
! = 2 FOR QUADRATIC
|
||||
! FROM COMMON
|
||||
! NOP = LIST OF NODAL CONNECTIONS AROUND AN ELEMET
|
||||
! CORD = REAL*8 ARRAY OF NODAL COORDINATES
|
||||
!
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
REAL*8 XN,DNX,DNY,XSW,YSW
|
||||
DOUBLE PRECISION XG,YG,XK,YK,XP,YP
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!-
|
||||
DIMENSION X(9),Y(9),WGT(8)
|
||||
!-
|
||||
DATA TOL/0.01/
|
||||
!-
|
||||
|
||||
!-
|
||||
!......DETERMINE ELEMENT TYPE
|
||||
!-
|
||||
!IPKOCT93 ADD
|
||||
if(n .eq. 1910) then
|
||||
aaa=0
|
||||
endif
|
||||
NCN=6
|
||||
IT=2
|
||||
!-
|
||||
!......ESTABLISH LOCAL COORDINATES FOR EACH NODE POINT OF ELEMENT
|
||||
!-
|
||||
K1=NOPEL(N,1)
|
||||
X(1)=0.
|
||||
Y(1)=0.
|
||||
DO 300 K=3,NCN,2
|
||||
K2=NOPEL(N,K/2+1)
|
||||
X(K)=XMAP(K2)-XMAP(K1)
|
||||
Y(K)=YMAP(K2)-YMAP(K1)
|
||||
300 END DO
|
||||
X(2)=X(3)/2.
|
||||
Y(2)=Y(3)/2.
|
||||
X(4)=(X(3)+X(5))/2.
|
||||
Y(4)=(Y(3)+Y(5))/2.
|
||||
X(6)=X(5)/2.
|
||||
Y(6)=Y(5)/2.
|
||||
xminl=min(x(1),x(3),x(5))
|
||||
yminl=min(y(1),y(3),y(5))
|
||||
xmaxl=max(x(1),x(3),x(5))
|
||||
ymaxl=max(y(1),y(3),y(5))
|
||||
|
||||
|
||||
!-
|
||||
!......ESTABLISH LOCAL COORDINATES OF DESIRED POINT
|
||||
!-
|
||||
XP=XSW-XMAP(K1)
|
||||
YP=YSW-YMAP(K1)
|
||||
|
||||
if(xp .lt. xminl .or. xp .gt. xmaxl) then
|
||||
wgt(1)=2.0
|
||||
return
|
||||
elseif(yp .lt. yminl .or. yp .gt. ymaxl) then
|
||||
wgt(1)=2.0
|
||||
return
|
||||
endif
|
||||
XG=0.
|
||||
YG=0.
|
||||
!-
|
||||
!......ITERATE TO FIND LOCAL COORDINATE
|
||||
!-
|
||||
DO 400 ITER=1,10
|
||||
DXKDX=0.
|
||||
DXKDY=0.
|
||||
DYKDX=0.
|
||||
DYKDY=0.
|
||||
XK=-XP
|
||||
YK=-YP
|
||||
DO 350 K=2,NCN
|
||||
XK=XK+XN(IT,K,XG,YG)*X(K)
|
||||
YK=YK+XN(IT,K,XG,YG)*Y(K)
|
||||
DXKDX=DXKDX+DNX(IT,K,XG,YG)*X(K)
|
||||
DYKDX=DYKDX+DNX(IT,K,XG,YG)*Y(K)
|
||||
DXKDY=DXKDY+DNY(IT,K,XG,YG)*X(K)
|
||||
DYKDY=DYKDY+DNY(IT,K,XG,YG)*Y(K)
|
||||
350 END DO
|
||||
DET=DXKDX*DYKDY-DXKDY*DYKDX
|
||||
DX=(-DYKDY*XK+DXKDY*YK)/DET
|
||||
DY=( DYKDX*XK-DXKDX*YK)/DET
|
||||
XG=XG+DX
|
||||
YG=YG+DY
|
||||
IF(ABS(DX).LT.TOL .AND. ABS(DY).LT.TOL) GO TO 420
|
||||
400 END DO
|
||||
!-
|
||||
!......NOW GET WEIGHTING FUNCTIONS FOR QUAD FUNCTION
|
||||
!-
|
||||
420 CONTINUE
|
||||
DO K=1,NCN
|
||||
WGT(K)=XN(IT,K,XG,YG)
|
||||
END DO
|
||||
|
||||
IF(ISWT .EQ. 1) THEN
|
||||
!-
|
||||
!- REDUCE TO LINEAR FUNCTION BY ADDING TERMS
|
||||
!-
|
||||
DO K=2,NCN,2
|
||||
WGT(K-1)=WGT(K-1)+WGT(K)/2.
|
||||
IF(K .LT. NCN) THEN
|
||||
WGT(K+1)=WGT(K+1)+WGT(K)/2.
|
||||
ELSE
|
||||
WGT(1)=WGT(1)+WGT(K)/2.
|
||||
ENDIF
|
||||
ENDDO
|
||||
!-
|
||||
!- THEN COMPACT ARRAY
|
||||
!-
|
||||
DO K=1,NCN/2
|
||||
WGT(K)=WGT(2*K-1)
|
||||
ENDDO
|
||||
|
||||
ENDIF
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,47 @@
|
||||
SUBROUTINE GINPT(irm2,ID,DLIN)
|
||||
CHARACTER ID*8,DLIN*72
|
||||
100 CONTINUE
|
||||
READ(irm2,7000) ID,DLIN
|
||||
write(90,7000) id,dlin
|
||||
!ipk jul03
|
||||
call to_upper(id)
|
||||
7000 FORMAT(A8,A72)
|
||||
do i=1,8
|
||||
if(id(i:i) .eq. char(9)) go to 200
|
||||
enddo
|
||||
do i=1,72
|
||||
if(dlin(i:i) .eq. char(9)) go to 200
|
||||
enddo
|
||||
IF(ID(1:1) .EQ. ':') GO TO 100
|
||||
IF(ID(1:1) .EQ. ';') GO TO 100
|
||||
IF(ID(1:3) .EQ. 'com') GO TO 100
|
||||
IF(ID(1:3) .EQ. 'COM') GO TO 100
|
||||
IF(ID(1:3) .EQ. 'Com') GO TO 100
|
||||
IF(ID(1:8) .EQ. ' ') GO TO 100
|
||||
RETURN
|
||||
200 continue
|
||||
write(*,*) 'Error Tab character found in the following line'
|
||||
write(90,*) 'Error Tab character found in the following line'
|
||||
write(90,7000) id,dlin
|
||||
write(*,7000) id,dlin
|
||||
stop
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE TO_UPPER(STR)
|
||||
|
||||
CHARACTER*(*) STR
|
||||
CHARACTER*1 CH
|
||||
|
||||
L = LEN(STR)
|
||||
|
||||
DO I=1,L
|
||||
CH = STR(I:I)
|
||||
IF ( ICHAR(CH) .GT. 96 .AND. ICHAR(CH) .LE. 122) THEN
|
||||
STR(I:I) = CHAR(ICHAR(CH)-32)
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
END
|
||||
|
||||
|
||||
@ -0,0 +1,127 @@
|
||||
SUBROUTINE GOUTLIN
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
CHARACTER(LEN=255) :: FNAME,FILTER
|
||||
CHARACTER(LEN=4) :: SUB
|
||||
LOGICAL OPENED
|
||||
CHARACTER*1 IFLAG,ANS(10)
|
||||
! DIMENSION XOUT(1000),YOUT(1000)
|
||||
DATA ANS/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
|
||||
IF(.NOT. ALLOCATED(XOUT)) THEN
|
||||
ALLOCATE (XOUT(5000,10),YOUT(5000,10))
|
||||
ENDIF
|
||||
N=0
|
||||
IOUTOUT=25
|
||||
INQUIRE(25, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
Filter='OUTLINE file -- *.dat|*.dat|POLY file -- *.poly|*.poly|'
|
||||
|
||||
CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Outline File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
OPEN(IOUTOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE')
|
||||
ELSE
|
||||
GO TO 1
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
1 CONTINUE
|
||||
|
||||
IF(SUB(1:3) .EQ. 'dat') THEN
|
||||
IOUTSW=0
|
||||
ELSE
|
||||
IOUTSW=1
|
||||
ENDIF
|
||||
|
||||
!IPK GET STRING OF MAP COORDINATES
|
||||
|
||||
!
|
||||
! Draw box around selections
|
||||
!
|
||||
2 CONTINUE
|
||||
|
||||
NHTPSV=NHTP
|
||||
NMESSV=NMESS
|
||||
NBRRSV=NBRR
|
||||
|
||||
NHTP=0
|
||||
NBRR=1
|
||||
NMESS=45
|
||||
CALL HEDR
|
||||
!
|
||||
! Get answer
|
||||
!
|
||||
! 3 call xyloc(XPT,YPT,ANS,IBOX)
|
||||
3 call xyloc(XPT,YPT,IFLAG,IBOX)
|
||||
!
|
||||
IF(IRMAIN .NE. 1 .and. ibox .ne. 10) THEN
|
||||
|
||||
N=N+1
|
||||
XTMP = XPT*TXSCAL - XS
|
||||
YTMP = YPT*TXSCAL - YS
|
||||
IF(IOUTSW .EQ. 0) THEN
|
||||
WRITE(IOUTOUT,*) XTMP,YTMP
|
||||
ELSE
|
||||
XOUT(N,1)=XTMP
|
||||
YOUT(N,1)=YTMP
|
||||
ENDIF
|
||||
GO TO 3
|
||||
|
||||
ENDIF
|
||||
IF(IOUTSW .EQ. 1) THEN
|
||||
NDIM=2
|
||||
NZERO=0
|
||||
NONE=1
|
||||
WRITE(IOUTOUT,*)N,NDIM,NZERO,NZERO
|
||||
DO I=1,N
|
||||
WRITE(IOUTOUT,*) I,XOUT(I,1),YOUT(I,1)
|
||||
ENDDO
|
||||
WRITE(IOUTOUT,*) N,NZERO
|
||||
DO I=1,N-1
|
||||
WRITE(IOUTOUT,*) I,I,I+1
|
||||
ENDDO
|
||||
WRITE(IOUTOUT,*) N,N,NONE
|
||||
|
||||
WRITE(IOUTOUT,*) NZERO
|
||||
ENDIF
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSV
|
||||
NBRR=NBRRSV
|
||||
CALL HEDR
|
||||
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE GETSUB4(FNAME,SUB)
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=4) :: SUB
|
||||
INTEGER ,EXTERNAL :: LENSTR
|
||||
INTEGER :: LNNAM,K
|
||||
|
||||
LNNAM=LENSTR(FNAME)
|
||||
SUB=' '
|
||||
DO K=LNNAM,1,-1
|
||||
IF(FNAME(K:K) .EQ. '.') THEN
|
||||
IF(LNNAM .GT. K+3) THEN
|
||||
SUB=FNAME(K+1:K+4)
|
||||
ELSEIF(LNNAM .GT. K+2) THEN
|
||||
SUB(1:3)=FNAME(K+1:K+3)
|
||||
SUB(4:4)=' '
|
||||
ELSE
|
||||
SUB=' '
|
||||
ENDIF
|
||||
GO TO 110
|
||||
ENDIF
|
||||
ENDDO
|
||||
110 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,885 @@
|
||||
!IPK LAST UPDATE FEB 11 2002 ADD LOCK AS VARIABLE
|
||||
!ipk last update Feb 10 1997
|
||||
SUBROUTINE GRIDSB(ISWTIN)
|
||||
!
|
||||
! Routines to control interpolation of nodal elevations
|
||||
!
|
||||
USE WINTERACTER
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
|
||||
include 'd.inc'
|
||||
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
!iPK APR94
|
||||
COMMON /RECOD/ IRECD,TSPC
|
||||
|
||||
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
!
|
||||
!IPKJAN94 INTEGER*2 LISTM
|
||||
! INTEGER LISTM
|
||||
!ipk feb94 add ARF then remove may97
|
||||
|
||||
! DIMENSION LISTM(1000),listt(1600,4),nlf(4),icomp(4),xnear(4)
|
||||
!ipk feb03 common /mapc/imap(maxpl),NCRS(MAXPL)
|
||||
!ipk sep97 add NCRS above
|
||||
!
|
||||
!ipknov93 CHARACTER*1 ANS,ANSW(10)
|
||||
CHARACTER*1 ANS,ANSW(10),IFLAG
|
||||
CHARACTER*63 STRELS
|
||||
DATA STRELS/' You have tried set to set elevation with no mapfile"'/
|
||||
!
|
||||
DATA ANSW/'m','a','f','s','k','u','t','w','h','q'/
|
||||
!JUN08 DATA ISWTAGN/0/
|
||||
!ipk feb94 add DATA and FUNCTION below
|
||||
! DATA ARF/-180.,-90.,0.,90.,180./
|
||||
! ANGN(K,L)=
|
||||
! + ATAN2((CMAP(K,2)-CORD(L,2)),(CMAP(K,1)-CORD(L,1)))*57.296
|
||||
!
|
||||
! Draw box around selections
|
||||
!
|
||||
!IPK SEP97
|
||||
100 CONTINUE
|
||||
IDONET=0
|
||||
NHTP = 9
|
||||
NMESS = 0
|
||||
NBRR = 0
|
||||
IERREL=0
|
||||
IF(ISWTIN .EQ. -1) GO TO 190
|
||||
CALL HEDR
|
||||
!
|
||||
! Get answer
|
||||
!
|
||||
110 call xyloc(XPT,YPT,ANS,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
IF(ANS .EQ. 'c') THEN
|
||||
if(ibox .eq. 0) go to 110
|
||||
ANS=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(ANS .EQ. 'm') THEN
|
||||
!
|
||||
! This option allows changes to bottom elevations
|
||||
!
|
||||
CALL ADDPTH
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
GO TO 100
|
||||
|
||||
ELSEIF (ANS .EQ. 'a') THEN
|
||||
!
|
||||
! All nodes
|
||||
!
|
||||
ISWT = -1
|
||||
DO N=1,NP
|
||||
IF(INEW(N) .EQ. 1) WD(N)=-9999.
|
||||
ENDDO
|
||||
ELSEIF(ANS .EQ. 'f') THEN
|
||||
!
|
||||
! Fill nodes
|
||||
!
|
||||
ISWT = 0
|
||||
ELSEIF(ANS .EQ. 's') THEN
|
||||
!
|
||||
! Single node at a time
|
||||
!
|
||||
ISWT = 1
|
||||
|
||||
!ipk feb02 add lock/unlock and remove cdata
|
||||
|
||||
ELSEIF(ANS .EQ. 'k') THEN
|
||||
!
|
||||
! lock node
|
||||
!
|
||||
! Get M from mouse
|
||||
!
|
||||
115 CONTINUE
|
||||
NHTP=0
|
||||
NMESS=21
|
||||
NBRR=3
|
||||
CALL HEDR
|
||||
IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,M,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
if(iflag .eq. 'q') go to 100
|
||||
lock(m)=1
|
||||
go to 115
|
||||
ELSEIF(ANS .EQ. 'u') THEN
|
||||
!
|
||||
! unlock node
|
||||
!
|
||||
! Get M from mouse
|
||||
!
|
||||
120 CONTINUE
|
||||
NHTP=0
|
||||
NMESS=21
|
||||
NBRR=3
|
||||
CALL HEDR
|
||||
IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,M,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
if(iflag .eq. 'q') go to 100
|
||||
lock(m)=0
|
||||
go to 120
|
||||
ELSEIF(ANS .EQ. 't') THEN
|
||||
!
|
||||
! Create data for layers
|
||||
!
|
||||
CALL ADDLAY
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
GO TO 100
|
||||
ELSEIF(ANS .EQ. 'w') THEN
|
||||
!
|
||||
! This option allows changes to nodal widths
|
||||
!
|
||||
CALL ADDWID
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
GO TO 100
|
||||
!
|
||||
! Call to help screen
|
||||
!
|
||||
ELSEIF(ANS .EQ. 'h') THEN
|
||||
CALL HELPS(4)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
GO TO 100
|
||||
!
|
||||
ELSEIF(ANS .EQ. 'q') THEN
|
||||
!
|
||||
! Writeout and return
|
||||
!
|
||||
CALL WRTOUT(0)
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
190 CONTINUE
|
||||
|
||||
IF(IMP .EQ. 0) THEN
|
||||
CALL SYMBL(0.,7.25,0.20,STRELS,0.,63)
|
||||
go to 100
|
||||
endif
|
||||
!
|
||||
! Establish size for range
|
||||
!
|
||||
call setrng(xnears,nmap)
|
||||
|
||||
ITIME=0
|
||||
ICOUNTF=0
|
||||
MM=0
|
||||
200 MM=MM+1
|
||||
! write(90,*) 'gridsb-111',mm,np,iswt,inew(mm)
|
||||
IF(MM .LE. NP) THEN
|
||||
!
|
||||
! Decode which alternative we are processing
|
||||
! ipk feb 03 determine interpolation method
|
||||
!
|
||||
IF(MM .EQ. 1 .AND. ISWTAGN .EQ. 0) THEN
|
||||
|
||||
IF(IRECD .EQ. 2) THEN
|
||||
iswtintp=0
|
||||
iswtagn=0
|
||||
go to 210
|
||||
ENDIF
|
||||
IF(IGUNIT .EQ. 203) THEN
|
||||
ISWTINTP=1
|
||||
iswtagn=1
|
||||
GO TO 210
|
||||
ENDIF
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to interpolate '//&
|
||||
CHAR(13)//'from the triangulated map file?'//&
|
||||
'or from a grid file',&
|
||||
'Select Interpolation method?')
|
||||
! If answer 'Yes' set interpolate switch to 1
|
||||
!
|
||||
IF (WInfoDialog(4) .EQ. 2) then
|
||||
iswtintp=0
|
||||
ELSE
|
||||
iswtintp=1
|
||||
ENDIF
|
||||
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Ask this question again?'//&
|
||||
CHAR(13)//' ' ,&
|
||||
'Ask again?')
|
||||
! If answer 'Yes' set again switch to 0
|
||||
!
|
||||
IF (WInfoDialog(4) .EQ. 2) then
|
||||
iswtagn=1
|
||||
ELSE
|
||||
iswtagn=0
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
210 CONTINUE
|
||||
|
||||
IF(iswtintp .eq. 1 .AND. IGUNIT .NE. 203) then
|
||||
if(iswt .ne. 1) then
|
||||
|
||||
! Sort the x-coordinates
|
||||
|
||||
call sortdb(xusr,ncrs,np)
|
||||
else
|
||||
ncrs(mm)=mm
|
||||
endif
|
||||
m=ncrs(mm)
|
||||
else
|
||||
m=mm
|
||||
endif
|
||||
! IPK OCT 2 1991
|
||||
IF(ISWT .EQ. 1) THEN
|
||||
! Single node at a time ISWT = 1
|
||||
!
|
||||
! Get M from mouse and set MM to NP
|
||||
!
|
||||
NHTP=0
|
||||
NMESS=21
|
||||
!ipk jun08 NBRR=0
|
||||
NBRR=1
|
||||
CALL HEDR
|
||||
IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
if(iflag .eq. 'q') go to 100
|
||||
M=INODE
|
||||
MM=NP
|
||||
endif
|
||||
IF(INEW(M) .EQ. 0) GO TO 200
|
||||
! IPK END OCT 2 1991
|
||||
|
||||
IF(ISWT .EQ. -1) THEN
|
||||
! All nodes ISWT = -1
|
||||
!ipk feb02
|
||||
if(lock(m) .eq. 1) go to 200
|
||||
|
||||
ELSEIF(ISWT .EQ. 0) THEN
|
||||
! Fill nodes ISWT = 0
|
||||
!ipk feb02
|
||||
IF(WD(M) .GT. -9000. .or. lock(m) .eq. 1) go to 200
|
||||
|
||||
ENDIF
|
||||
! write(90,*) 'gridsb-138', m,mm,iswt,wd(m),xnears
|
||||
|
||||
IF(ISWTINTP .EQ. 0) THEN
|
||||
if(lock(m) .eq. 0) CALL SETELV(XNEARS,NMAP,M,ISWT)
|
||||
ELSE
|
||||
if(nelts .eq. 0 .and. igunit .ne. 203) then
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'No triangulated exists'//&
|
||||
CHAR(13)//'Do you wish to triangulate now?' ,&
|
||||
'NO TRIANGULATION AVAILABLE?')
|
||||
! If answer 'Yes' set triangulate now
|
||||
!
|
||||
IF (WInfoDialog(4) .EQ. 2) then
|
||||
return
|
||||
ELSE
|
||||
call triang
|
||||
IDONET=1
|
||||
ENDIF
|
||||
|
||||
endif
|
||||
if(lock(m) .eq. 0) then
|
||||
if(igunit .ne. 203) then
|
||||
CALL TRIANINT(NMAP,M,ISWT,ITIME)
|
||||
else
|
||||
call GETGRDELEV(M,IERREL)
|
||||
endif
|
||||
endif
|
||||
ENDIF
|
||||
|
||||
! write(90,*) 'gridsb-141', m,iswt,wd(m)
|
||||
if(wd(m) .lt. -9997.) THEN
|
||||
icountf=icountf+1
|
||||
WD(M)=-9998.
|
||||
ENDIF
|
||||
GO TO 200
|
||||
ENDIF
|
||||
IF(IDONET .EQ. 1) THEN
|
||||
CALL RDMAP(2,99,0,0) ! XXXXX
|
||||
CLOSE(99)
|
||||
ENDIF
|
||||
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to plot contours?'//&
|
||||
CHAR(13)//' ','PLOT CONTOURS?')
|
||||
!
|
||||
! If answer 'No', return
|
||||
!
|
||||
IF (WInfoDialog(4).EQ.2) THEN
|
||||
go to 220
|
||||
ENDIF
|
||||
215 menus=13
|
||||
call conout(menus)
|
||||
MENUS=12
|
||||
CALL CONOUT(MENUS)
|
||||
|
||||
!ipkjan94 IF(ISWT .EQ. -1) GO TO 210
|
||||
220 if(icountf .gt. 0) then
|
||||
|
||||
CALL FMESS(ICOUNTF,ISWTT)
|
||||
!
|
||||
! If answer 'Yes', use search for adjacent nodes
|
||||
!
|
||||
IF(ISWTT .EQ. 1) then
|
||||
call fillin(icountf)
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to plot contours again?'//&
|
||||
CHAR(13)//' ','PLOT CONTOURS?')
|
||||
!
|
||||
! If answer 'No', return
|
||||
!
|
||||
IF (WInfoDialog(4).EQ.2) THEN
|
||||
IF(ICOUNTF .GT. 0) GO TO 220
|
||||
ELSE
|
||||
GO TO 215
|
||||
ENDIF
|
||||
END IF
|
||||
endif
|
||||
IF(ISWTIN .EQ. -1) RETURN
|
||||
IF(ISWT .EQ. 1) THEN
|
||||
!ipk jun08 CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
if(iflag .eq. 'q') go to 100
|
||||
M=INODE
|
||||
MM=NP-1
|
||||
GO TO 200
|
||||
ELSEIF(ISWT .EQ. -1) THEN
|
||||
GO TO 100
|
||||
ENDIF
|
||||
!ipk jun08 IF(ABS(ISWT) .EQ. 1) GO TO 100
|
||||
RETURN
|
||||
END
|
||||
!ipk jul98 revise call
|
||||
!IPK SUBROUTINE GRIDIN(I,SOLN,LISTM,NLG)
|
||||
SUBROUTINE GRIDIN(XZ,YZ,SOLN,LISTM,NLG)
|
||||
!
|
||||
! Routine to interpolate values from map to node points
|
||||
!
|
||||
! I is the location in the CORD array to be interpolated
|
||||
! SOLN is the interpolated value developed
|
||||
! NLG is the number of entries in the map array
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
!IPK JAN94 INTEGER*2 LISTM,NLIST,NKEY
|
||||
!IPK DEC09 INTEGER LISTM,NLIST,NKEY
|
||||
INTEGER LISTM,NLIST
|
||||
DIMENSION LISTM(*)
|
||||
DIMENSION NLIST(1000),ADIST(1000),WT(1000)
|
||||
!
|
||||
! Function statements
|
||||
!
|
||||
DIST(K,X,Y)=SQRT((CMAP(K,1)-X)**2+(CMAP(K,2)-Y)**2)
|
||||
!IPK FEB97 ANG(K,X,Y)=ATAN2((CMAP(K,2)-Y),(CMAP(K,1)-X))*57.296
|
||||
ANG(K,X,Y)=ATAN2((CMAP(K,1)-X),(CMAP(K,2)-Y))*57.296
|
||||
!
|
||||
! Initialize
|
||||
!
|
||||
TOL=120.
|
||||
! DO KK=1,NLG
|
||||
! WRITE(90,*) 'LISTM',KK,LISTM(KK)
|
||||
! ENDDO
|
||||
!
|
||||
! Form list of distances from I to data locations
|
||||
!
|
||||
NTMP=0
|
||||
IPAS=1
|
||||
!IPK JUL98 X=CORD(I,1)
|
||||
!PK JUL98 Y=CORD(I,2)
|
||||
X=XZ
|
||||
Y=YZ
|
||||
140 CONTINUE
|
||||
DO 150 KK=1,NLG
|
||||
K=LISTM(KK)
|
||||
IF(K .EQ. NTMP) THEN
|
||||
ADIST(KK)=-VOID
|
||||
ELSE
|
||||
ADIST(KK)=DIST(K,X,Y)
|
||||
ENDIF
|
||||
150 END DO
|
||||
!
|
||||
! Sort order for nearest points
|
||||
!
|
||||
CALL SORT(ADIST,NKEY,NLG)
|
||||
do nnnn=1,nlg
|
||||
nn=nkey(nnnn)
|
||||
nzz=listm(nn)
|
||||
WRITE(90,*) NZZ,X,Y,cmap(nzz,1),cmap(nzz,2)
|
||||
ATMP=ANG(NZZ,X,Y)
|
||||
write(90,*) nnnn,adist(nnnn),val(nzz),ATMP
|
||||
enddo
|
||||
! read(*,*) aaa
|
||||
KK=1
|
||||
!
|
||||
! Search through sorted list
|
||||
!
|
||||
INIT=1
|
||||
180 DO 260 K=1,NLG
|
||||
NN=NKEY(K)
|
||||
IF(NN .EQ. 0) GO TO 260
|
||||
N=LISTM(NN)
|
||||
!
|
||||
! Initialize
|
||||
!
|
||||
IF(N .EQ. NTMP) GO TO 260
|
||||
IF(INIT .EQ. 1) THEN
|
||||
NLIST(1)=N
|
||||
YY=(CMAP(N,2)-Y)
|
||||
XX=(CMAP(N,1)-X)
|
||||
IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN
|
||||
RANGEF=0.
|
||||
RANGEB=360.
|
||||
ELSE
|
||||
RANGEF=ANG(N,X,Y)
|
||||
RANGEB=ANG(N,X,Y)+360.
|
||||
ENDIF
|
||||
INIT=2
|
||||
GO TO 260
|
||||
ENDIF
|
||||
!
|
||||
! Skip out if already processed
|
||||
!
|
||||
YY=(CMAP(N,2)-Y)
|
||||
XX=(CMAP(N,1)-X)
|
||||
IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN
|
||||
ANGLE=0.
|
||||
ELSE
|
||||
ANGLE=ANG(N,X,Y)
|
||||
ENDIF
|
||||
200 CONTINUE
|
||||
! write(90,*) 'angls',n,angle,rangef,rangeb,val(n)
|
||||
!
|
||||
! Test if angle greater than high value
|
||||
!
|
||||
IF(ANGLE .GT. RANGEF) THEN
|
||||
!
|
||||
! Test if the new point is within the allowable range
|
||||
!
|
||||
IF(ANGLE .LT. RANGEF+TOL) THEN
|
||||
!
|
||||
! Process this point
|
||||
!
|
||||
RANGEF=ANGLE
|
||||
KK=KK+1
|
||||
NLIST(KK)=N
|
||||
NKEY(K)=0
|
||||
!
|
||||
! Test if we now have enough points to exit
|
||||
!
|
||||
IF(RANGEF+TOL .GT. RANGEB) THEN
|
||||
GO TO 300
|
||||
ELSE
|
||||
GO TO 180
|
||||
ENDIF
|
||||
!
|
||||
! Test if angle lies inside the already spanned area
|
||||
! If so it cannot be used
|
||||
!
|
||||
ELSEIF(ANGLE .GT. RANGEB) THEN
|
||||
NKEY(K)=0
|
||||
!
|
||||
! Test if it close enough to the low value
|
||||
!
|
||||
ELSEIF(ANGLE .GT. RANGEB-TOL) THEN
|
||||
!
|
||||
! Process this point
|
||||
!
|
||||
RANGEB=ANGLE
|
||||
KK=KK+1
|
||||
NLIST(KK)=N
|
||||
NKEY(K)=0
|
||||
!
|
||||
! Test if we have enough points to exit
|
||||
!
|
||||
IF(RANGEF+TOL .GT. RANGEB) THEN
|
||||
GO TO 300
|
||||
ELSE
|
||||
GO TO 180
|
||||
ENDIF
|
||||
!
|
||||
! Not a usable point at this time, move on to next point
|
||||
!
|
||||
ELSE
|
||||
GO TO 260
|
||||
!
|
||||
! Increase angle by 360 and test again
|
||||
!
|
||||
ENDIF
|
||||
ELSE
|
||||
ANGLE=ANGLE+360.
|
||||
GO TO 200
|
||||
ENDIF
|
||||
260 END DO
|
||||
!
|
||||
! We have finished loop without completing polygon
|
||||
!
|
||||
GO TO 500
|
||||
!
|
||||
! Process least squares fit on this list
|
||||
!
|
||||
300 CONTINUE
|
||||
! WRITE(90,*) 'least squares list',KK,x,y
|
||||
! WRITE(90,*) (NLIST(N),N=1,KK)
|
||||
! do n=1,kk
|
||||
! write(90,*) nlist(n),cmap(nlist(n),1),cmap(nlist(n),2)
|
||||
! + ,val(nlist(n)),dist(nlist(n),x,y)
|
||||
! enddo
|
||||
!ipk feb97 changes to refine processing
|
||||
!
|
||||
! Check if points are close together relative to the centre point
|
||||
!
|
||||
! write(90,*) kk,x,y,nlg
|
||||
do n=1,kk
|
||||
l=nlist(n)
|
||||
dc=dist(l,x,y)
|
||||
xx=cmap(l,1)
|
||||
yy=cmap(l,2)
|
||||
if(n .lt. kk) then
|
||||
do m=n+1,kk
|
||||
ll=nlist(m)
|
||||
dr=dist(ll,xx,yy)
|
||||
if(dr .lt. 0.1*dc) then
|
||||
if(kk .gt. 3) then
|
||||
ds=dist(ll,x,y)
|
||||
if(ds .lt. dc) then
|
||||
ndrp=n
|
||||
else
|
||||
ndrp=m
|
||||
endif
|
||||
!
|
||||
! drop this point
|
||||
!
|
||||
do mm=ndrp,kk-1
|
||||
nlist(mm)=nlist(mm+1)
|
||||
enddo
|
||||
kk=kk-1
|
||||
go to 300
|
||||
else
|
||||
go to 310
|
||||
endif
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
310 continue
|
||||
!ipk feb97 end changes for processing
|
||||
! WRITE(90,*) '310',kk
|
||||
! WRITE(90,*) (NLIST(N),N=1,KK)
|
||||
!ipk feb97 chnage to add weighting
|
||||
do n=1,kk
|
||||
!ipk jul98 if(dist(nlist(n),CORD(I,1),CORD(I,2)) .gt. 0.) then
|
||||
!ipk jul98 wt(n)=1./dist(nlist(n),CORD(I,1),CORD(I,2))
|
||||
if(dist(nlist(n),XZ,YZ) .gt. 0.) then
|
||||
wt(n)=1./dist(nlist(n),XZ,YZ)
|
||||
else
|
||||
soln=val(nlist(n))
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
!IPK JUL98 CALL ALSQ(KK,NLIST,I,SOLN,WT)
|
||||
CALL ALSQ(KK,NLIST,XZ,YZ,SOLN,WT)
|
||||
!ipk feb97 end changes
|
||||
!
|
||||
! final value is SOLN
|
||||
!
|
||||
RETURN
|
||||
500 TOL=TOL+25.
|
||||
IF(TOL .GT. 180.) GO TO 550
|
||||
IF(RANGEF+TOL .GT. RANGEB) THEN
|
||||
GO TO 300
|
||||
ENDIF
|
||||
GO TO 180
|
||||
550 CONTINUE
|
||||
!c write(90,*) ' in trouble split',rangef,rangeb
|
||||
SPLIT=(RANGEF+RANGEB)/2.-180.
|
||||
AMIN=180.
|
||||
DO 600 N=1,KK
|
||||
IF(NLIST(N) .EQ. NTMP) GO TO 600
|
||||
YY=(CMAP(NLIST(N),2)-Y)
|
||||
XX=(CMAP(NLIST(N),1)-X)
|
||||
IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN
|
||||
ANGL=0.
|
||||
ELSE
|
||||
ANGL=ANG(NLIST(N),X,Y)
|
||||
ENDIF
|
||||
IF(IPAS .EQ. 2) GO TO 600
|
||||
!
|
||||
! Find line closest to split
|
||||
!
|
||||
IF(ABS(SPLIT-ANGL) .LT. AMIN) THEN
|
||||
AMIN=ABS(SPLIT-ANGL)
|
||||
! write(90,*) 'ntmp reset',ntmp,nlist(n),amin,split
|
||||
NTMP=NLIST(N)
|
||||
ENDIF
|
||||
ANGLP=ANGL-360.
|
||||
IF(ABS(SPLIT-ANGLP) .LT. AMIN) THEN
|
||||
AMIN=ABS(SPLIT-ANGLP)
|
||||
NTMP=NLIST(N)
|
||||
ENDIF
|
||||
! 580 WRITE(90,*) NLIST(N),ANGL
|
||||
600 END DO
|
||||
IF(IPAS .EQ. 1) THEN
|
||||
IPAS=2
|
||||
X=CMAP(NTMP,1)
|
||||
Y=CMAP(NTMP,2)
|
||||
TOL=120.
|
||||
write(90,*) 'INTERP FOR ',xz,yz,' MOVED TO',x,y,ntmp
|
||||
GO TO 140
|
||||
ENDIF
|
||||
WRITE(90,*) 'ERROR NO POLYGON RANGEF,RANGEB',RANGEF,RANGEB,SPLIT
|
||||
WRITE(90,*) 'OPPOSITE NODE AND ANGULAR DIFF',NTMP,AMIN
|
||||
SOLN=-9998.
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
! FUNCTION ANG(K,X,Y)
|
||||
!
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
! YY=(CMAP(K,2)-Y)
|
||||
! XX=(CMAP(K,1)-X)
|
||||
! IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN
|
||||
! ANG=0.
|
||||
! ELSE
|
||||
! ANG=ATAN2(YY,XX)*57.296
|
||||
! ENDIF
|
||||
! RETURN
|
||||
! END
|
||||
|
||||
SUBROUTINE SORT(A,NKEY,N)
|
||||
!*********************************** .....SORT.....
|
||||
!-
|
||||
!......SORT IS A SIMPLE SHELL SORT ROUTINE
|
||||
!-
|
||||
! SHELL SORT
|
||||
SAVE
|
||||
!
|
||||
!IPK JAN94 INTEGER*2 NKEY
|
||||
DIMENSION A(*),NKEY(1)
|
||||
IF(N.LT.2) RETURN
|
||||
DO 90 J=1,N
|
||||
NKEY(J)=J
|
||||
90 END DO
|
||||
ID = N
|
||||
100 ID = ID / 2
|
||||
110 IB = 1
|
||||
120 GO TO 200
|
||||
130 IB = IB + 1
|
||||
IF( IB .LE. ID ) GO TO 200
|
||||
IF( ID .GT. 1 ) GO TO 100
|
||||
RETURN
|
||||
200 I = IB
|
||||
210 K = I + ID
|
||||
220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250
|
||||
NKT = NKEY(K)
|
||||
NKEY(K) = NKEY(I)
|
||||
J = I
|
||||
230 K = J - ID
|
||||
IF( K .LT. 1 ) GO TO 240
|
||||
IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240
|
||||
NKEY(J) = NKEY(K)
|
||||
J = K
|
||||
GO TO 230
|
||||
240 NKEY(J) = NKT
|
||||
250 I = I + ID
|
||||
IF( I + ID .LE. N ) GO TO 210
|
||||
GO TO 130
|
||||
END
|
||||
!ipk feb97 add weighting
|
||||
!iok jul98 SUBROUTINE ALSQ(NPTS,NLIST,I,SOLN,WT)
|
||||
SUBROUTINE ALSQ(NPTS,NLIST,xx,yy,SOLN,WT)
|
||||
!
|
||||
! Least squares routine
|
||||
!
|
||||
! INCLUDE 'PARAM.COM'
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!IPK JAN94 INTEGER*2 NLIST
|
||||
REAL*8 A,R,B,S,X,Y,ATR,ATR2,BTR,C,T,X3,X2,X1
|
||||
DIMENSION A(3,3),R(3),B(2,2),S(2),wt(*)
|
||||
DIMENSION NLIST(*)
|
||||
!
|
||||
! Initialize matrices
|
||||
!
|
||||
!ipk jul98 X=CORD(I,1)
|
||||
!ipk jul98 Y=CORD(I,2)
|
||||
X=XX
|
||||
Y=YY
|
||||
! write(*,*) (nnn,cmap(nnn,1),cmap(nnn,2),nnn=1,16)
|
||||
! write(*,*) (nlist(n),n=1,npts)
|
||||
DO 160 K=1,3
|
||||
R(K)=0.
|
||||
DO 150 J=1,3
|
||||
A(J,K)=0.
|
||||
150 CONTINUE
|
||||
160 END DO
|
||||
!
|
||||
! Form A and R matrices
|
||||
!
|
||||
DO 200 N=1,NPTS
|
||||
KK=NLIST(N)
|
||||
! write(*,*) cmap(kk,1),cmap(kk,2),val(kk)
|
||||
!ipk feb97 add weighting
|
||||
A(1,1)=A(1,1)+1.0*wt(n)
|
||||
A(1,2)=A(1,2)+CMAP(KK,1)*wt(n)
|
||||
A(1,3)=A(1,3)+CMAP(KK,2)*wt(n)
|
||||
A(2,2)=A(2,2)+CMAP(KK,1)**2*wt(n)
|
||||
A(2,3)=A(2,3)+CMAP(KK,1)*CMAP(KK,2)*wt(n)
|
||||
A(3,3)=A(3,3)+CMAP(KK,2)**2*wt(n)
|
||||
R(1)=R(1)+VAL(KK)*wt(n)
|
||||
R(2)=R(2)+CMAP(KK,1)*VAL(KK)*wt(n)
|
||||
R(3)=R(3)+CMAP(KK,2)*VAL(KK)*wt(n)
|
||||
!ipk feb97 end addition of weighting
|
||||
200 END DO
|
||||
! read(*,*) al
|
||||
!
|
||||
! Solve equations
|
||||
!
|
||||
ATR=A(1,2)/A(1,1)
|
||||
ATR2=A(1,3)/A(1,1)
|
||||
B(1,1)=A(2,2)-ATR*A(1,2)
|
||||
B(1,2)=A(2,3)-ATR*A(1,3)
|
||||
S(1)=R(2)-ATR*R(1)
|
||||
B(2,2)=A(3,3)-ATR2*A(1,3)
|
||||
S(2)=R(3)-ATR2*R(1)
|
||||
BTR=B(1,2)/B(1,1)
|
||||
C=B(2,2)-BTR*B(1,2)
|
||||
T=S(2)-BTR*S(1)
|
||||
X3=T/C
|
||||
X2=S(1)/B(1,1)-BTR*X3
|
||||
X1=R(1)/A(1,1)-ATR*X2-ATR2*X3
|
||||
!
|
||||
! Substitute to get interpolated value
|
||||
!
|
||||
SOLN=X1+X2*X+X3*Y
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
!ipksep97 new routine for soring map lines
|
||||
!
|
||||
SUBROUTINE SORTMAP(A,NKEY,N,IMAP)
|
||||
!*********************************** .....SORT.....
|
||||
!-
|
||||
!......SORT IS A SIMPLE SHELL SORT ROUTINE
|
||||
!-
|
||||
! SHELL SORT
|
||||
SAVE
|
||||
!
|
||||
!IPK JAN94 INTEGER*2 NKEY
|
||||
DIMENSION A(*),NKEY(1),IMAP(*)
|
||||
DATA VOID/1.E35/
|
||||
IF(N.LT.2) RETURN
|
||||
DO 90 J=1,N
|
||||
NKEY(J)=J
|
||||
IF(IMAP(J) .LT. 0) A(J)=VOID
|
||||
90 END DO
|
||||
ID = N
|
||||
100 ID = ID / 2
|
||||
110 IB = 1
|
||||
120 GO TO 200
|
||||
130 IB = IB + 1
|
||||
IF( IB .LE. ID ) GO TO 200
|
||||
IF( ID .GT. 1 ) GO TO 100
|
||||
RETURN
|
||||
200 I = IB
|
||||
210 K = I + ID
|
||||
220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250
|
||||
NKT = NKEY(K)
|
||||
NKEY(K) = NKEY(I)
|
||||
J = I
|
||||
230 K = J - ID
|
||||
IF( K .LT. 1 ) GO TO 240
|
||||
IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240
|
||||
NKEY(J) = NKEY(K)
|
||||
J = K
|
||||
GO TO 230
|
||||
240 NKEY(J) = NKT
|
||||
250 I = I + ID
|
||||
IF( I + ID .LE. N ) GO TO 210
|
||||
GO TO 130
|
||||
END
|
||||
subroutine fillin(icountf)
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
DIST(N,M)=(cord(n,1)-cord(m,1))**2+(cord(n,2)-cord(m,2))**2
|
||||
CALL KCON(0)
|
||||
MCOUNT=0
|
||||
MCOUNTF=0
|
||||
DO N=1,NP
|
||||
IF(WD(N) .LT. -9997. .and. WD(N) .GT. -9998.5) THEN
|
||||
MCOUNT=MCOUNT+1
|
||||
DISTCUR=1.E20
|
||||
NADJCT=0
|
||||
DO K=1,NDELM(N)
|
||||
J=NECON(N,K)
|
||||
DO I=1,NCORN(J)
|
||||
NC=NOP(J,I)
|
||||
IF(NC .NE. 0 .AND. NC .NE. N) THEN
|
||||
IF(WD(NC) .GT. -9997.) THEN
|
||||
distance=dist(n,nc)
|
||||
if(distance .lt. distcur) then
|
||||
distcur=distance
|
||||
nadjct=nc
|
||||
endif
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDDO
|
||||
if(nadjct .gt. 0) then
|
||||
wd(n)=wd(nadjct)
|
||||
else
|
||||
mcounfT=mcountf+1
|
||||
ENDIF
|
||||
if(mcount .eq. icountf) THEN
|
||||
ICOUNTF=MCOUNTF
|
||||
return
|
||||
ENDIF
|
||||
endif
|
||||
enddo
|
||||
ICOUNTF=MCOUNTF
|
||||
return
|
||||
end
|
||||
|
||||
SUBROUTINE FMESS(N1,N2)
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'D.inc'
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: N1,N2,IERR
|
||||
! real ::
|
||||
character*3 :: sub
|
||||
|
||||
call wdialogload(IDD_FBED)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(idf_integer1,n1)
|
||||
|
||||
|
||||
CALL WDialogSelect(IDD_FBED)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
DO
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
N2=1
|
||||
RETURN
|
||||
ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
N2=0
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,334 @@
|
||||
!IPk last updated July 15 1998
|
||||
!IPk last updated Nov 18 1997
|
||||
!IPk last updated Oct 31 1996 fix bug in map option
|
||||
!IPK LAST UPDATED OCT 16 1996
|
||||
!IPk last updated Oct 14 1996
|
||||
!IPk last updated Oct 25 1995
|
||||
SUBROUTINE HEDR
|
||||
SAVE
|
||||
|
||||
! Routine to draw NSIZ header boxes at top of page with the HEAD label
|
||||
|
||||
CHARACTER*80 TITLE
|
||||
CHARACTER*24 HLABL
|
||||
CHARACTER*1 ALABL(10)
|
||||
CHARACTER*40 MPDUM
|
||||
|
||||
COMMON /SSIZE/ HSIZE
|
||||
|
||||
COMMON /BLKA1/ TITLE,HLABL,ALABL,MPDUM
|
||||
|
||||
!IPk oct 95 lines defining MPDUM added
|
||||
!ipk jan01 Expand IPSW to 10
|
||||
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||||
!IPk feb94 HEAD array and NHEDL enlarged
|
||||
!IPk oct96 HEAD AND NHEDL MESS, ENLARGED
|
||||
|
||||
common /cols/ ibakk,icolr,iblkk
|
||||
|
||||
CHARACTER*8 HED(10),HEAD(10,16)
|
||||
CHARACTER*47 MESOUT,MESS(48)
|
||||
!ipk lan01 add to MESS
|
||||
!ipk jan99 add to MESS
|
||||
!ycw mar97 change HEADR(5,5) to HEADR(6,7)
|
||||
!ipk add extra headr
|
||||
CHARACTER*8 HEADR(6,10)
|
||||
DIMENSION NHEDL(16)
|
||||
DIMENSION X(5),Y(5),IRV(10)
|
||||
!IPk feb 94 this statement reconstructed
|
||||
!IPK OCT 96 THIS STATMENT DONE AGAIN
|
||||
DATA HEAD/ ' (e)lts ','(n)odes ','(o)rder ',' (h)elp ',' ',&
|
||||
'cc(l)ine',' csec(t)',' (z)oom ',' (r)draw',' (q)uit ','(n)od bk',& !1/2
|
||||
' (e)l bk',&
|
||||
're(f)ine','spli(t) ','c(l)ean ',5*' ','pr(l)st ','get(g)rp'& ! 2/3
|
||||
,'(p)rgrp ','c(o)ptnd','cop(t)el',' (h)elp ',' ',' (z)oom ',' (r)draw',' (q)uit'& !3
|
||||
,' (a)dd ',' (m)ove ',' (d)el ',' (f)ind ',' (g)line',' (e)lev '& !4
|
||||
,' (h)elp ',' (z)oom ',' (r)draw',' (q)uit ',' (m)ap ',' (o)utln'& !4/5
|
||||
,' (e)lts ','(n)odes ',' ne(t)w ',' t(y)pe ','cc(l)ine',' (d)ata '& !5
|
||||
,'(b)elev ',' d(r)aw ',' (s)el ',' (j)oin ',' (f)ind ',' (g)blok'& !5/6
|
||||
,' (t)ype ',' f(i)ll ',' (h)elp ',' (z)oom ',' (r)draw',' (q)uit '& !6
|
||||
,' (d)el ','r(e)fin ',' (n)umb ',' (a)ll ','rectn(g)','(t)riang'& !7
|
||||
,' (h)elp ',' (z)oom ',' (r)draw',' (q)uit ',' (f)our ','two(l)g '& !7/8
|
||||
,'two(s)h ','spli(t) ','re(v)rs ','clea(n) ',' ','s(m)plfy',' ',' (q)uit '& !8
|
||||
,'(m)an/el','(a)ll/el','(f)il/el','(s)in/el',' loc(k) ','(u)nlock'& !9
|
||||
,'(t)hree ','man/(w)d',' (h)elp ','(q)uit ','al(l)mid','cen(m)id'& !9/10
|
||||
,'sin(g)le','un(u)sed',' (f)ill ',' (j)oin ',' (h)elp ',' (z)oom '& !0
|
||||
,' (r)draw',' (q)uit ','a(s)ave ','(b)save ','(m)save ',' (p)save'& !10/11
|
||||
,2*' ',' (h)elp ',' (z)oom ',' (r)draw',' (q)uit ',' z(e)ro '& !11/12
|
||||
,' (o)ne ',' (t)wo ','t(h)ree ',' (f)our ',' f(i)ve ',' (s)ix '& !12
|
||||
,' se(v)en',' ei(g)ht',' (q)uit ',' (w)idth',' ss(1) ',' ss(2) '& !12/13
|
||||
,'strw(d) ','str(e)lv','str(s)lp',' (b)s1 ',' (z)oom ',' (r)draw'& !13
|
||||
,' (q)uit ','(d)elete','s(e)t999','se(t)elv','set(l)ay',' loc(k) ','(u)nlock','(f)orm-t',' (z)oom ',' (r)draw'& !13/14
|
||||
,' (q)uit ','(d)elete','r(e)fin ','se(t)yp ','s(m)plfy','form(g)p','elev und',' ',' (z)oom ',' (r)draw'& !14/15
|
||||
,' (q)uit ','(m)an/el','(a)ll/el','(f)il/el',' ',' ',' '& !15/16
|
||||
,' ',' ',' (h)elp ','(q)uit '/
|
||||
|
||||
|
||||
!IPk apr95 changed structure of messages added 3 more entries
|
||||
|
||||
|
||||
DATA MESS /'Enter node to search for',' Enter material type',& ! 1,2
|
||||
'Enter element to search for ',& ! 3
|
||||
'Enter numbr of layers ',& ! 4
|
||||
'Enter width ',& ! 5
|
||||
'Click mouse at end of line ',& ! 6
|
||||
'Enter nmbr of nodes in line ',& ! 7
|
||||
'Click at corners of block ',& ! 8
|
||||
'Enter nmbr of elts in x-dir ',& ! 9
|
||||
'Enter nmbr of elts in y-dir ',& ! 10
|
||||
'Click to move boundaries or (q)uit to save ',& ! 11
|
||||
'Click on elements', 'Enter starting list number ',& ! 12,13
|
||||
'Enter bottom elevation', 'Click on node ',& ! 14,15
|
||||
'Click location of new node', 'Click at node to move ',&! 16,17
|
||||
'Click at node to delete ',& ! 18
|
||||
'Type 1 to use all nodes else type 0 ',& ! 19
|
||||
'Enter element to select','Click location of node',& ! 20,21
|
||||
'Enter ss1','Enter ss2','Enter strwid','Enter storage elevation',& ! 22,23,24,25
|
||||
'Click mouse on node','click mouse on next node',& ! 26,27
|
||||
'ERROR - Midside node selected - Select node again',& ! 28
|
||||
'Plotting a selected cross section',& ! 29
|
||||
'Click two locations to form a cross section',&! 30
|
||||
'Click to adjust the cross section',& ! 31
|
||||
'Compute cross section parameters',& ! 32
|
||||
'Click a node for the cross section',& ! 33
|
||||
|
||||
'Click two locations to form the width','Click to adjust the line','Click two locations to form left slope',& ! 34 35 36
|
||||
'Click two locations to form right slope','Click a location'& ! 37 38
|
||||
,'Enter storage elevation','Enter storage slope',& ! 39 40
|
||||
'Click at two locations to determine distance'& ! 41
|
||||
,'Enter continuity line number use 0 to end','Click at location on image to define register point'& ! 42 43
|
||||
,'Enter 1-d cross-section bed slope','Click at location to define outline point'& ! 44 45
|
||||
,' ','Click two locations to define move'& ! 46 47
|
||||
,'Click locations to form outline'/ ! 48
|
||||
! last line Jan 2001
|
||||
! line above added Jan 1999
|
||||
DATA HEADR /&
|
||||
' (q)uit ',5*' ',&
|
||||
' (r)draw',' (q)uit ',4*' ',&
|
||||
' (z)oom ',' (r)draw', ' (q)uit ',3*' ',&
|
||||
' (n)ext ',' (z)oom ', ' (r)draw',' (q)uit ',2*' ',&
|
||||
' (b)ack ',' cn(n)ect', ' (z)oom ',' (r)draw',' (q)uit ',' ',&
|
||||
' (l)ine ',' (d)rawcs', ' (z)oom ',' (r)draw',' (q)uit ',' ',&
|
||||
' (d)ist ',' (w)idth', ' (1)slop',' (2)slop',' b(e)lev',' (q)uit',&
|
||||
' (d)el ',' (z)oom ', ' (r)draw',' (q)uit ',2*' ',&
|
||||
' s(a)ve ',' (z)oom ', ' (r)draw',' (q)uit ',2*' ',&
|
||||
' u(n)do ',' (c)ancl', ' (z)oom ',' (r)draw',' (q)uit ',1*' '/
|
||||
DATA IRV/1 , 2 , 5 , 3 , 4 , 7 , 10 , 6 , 9, 5/
|
||||
DATA NHEDL/10,5,10,10,10,10,10,10,10,10,10,10,10,10,10,10/
|
||||
! DATA IBAKK/12/,ICOLR/11/
|
||||
IF(NHTP .NE. 0) THEN
|
||||
|
||||
! Clear upper box area
|
||||
|
||||
CALL CLRBOX
|
||||
|
||||
! Copy appropriate heading for output
|
||||
|
||||
NSIZ=NHEDL(NHTP)
|
||||
DO 120 N=1,NSIZ
|
||||
HED(N)=HEAD(N,NHTP)
|
||||
120 CONTINUE
|
||||
|
||||
! Draw box around selections with colour
|
||||
!
|
||||
Y(1)=7.5
|
||||
Y(2)=7.5
|
||||
Y(3)=7.995
|
||||
Y(4)=7.995
|
||||
Y(5)=7.5
|
||||
XPT=0.
|
||||
DO 150 I=1,NSIZ
|
||||
X(1)=XPT
|
||||
X(4)=XPT
|
||||
X(5)=XPT
|
||||
! XPT=XPT+1.0
|
||||
XPT=XPT+HSIZE/10.
|
||||
X(2)=XPT
|
||||
X(3)=XPT
|
||||
IF(I .EQ. 10) THEN
|
||||
IBLK=IBAKK
|
||||
!IPK OCT96 ADD COLOR OPTIONS
|
||||
ELSEIF((NHTP .EQ. 5 .AND. IPSW(IRV(I)) .EQ. 1) .OR. &
|
||||
(NHTP .EQ. 12 .AND. ICOLON(I) .EQ. 1)) THEN
|
||||
IBLK=iblkk
|
||||
ELSE
|
||||
IBLK=IBAKK
|
||||
ENDIF
|
||||
CALL POLYFL(X,Y,5,IBLK)
|
||||
CALL RBLACK
|
||||
CALL PLOTT(X(1),Y(1),3)
|
||||
CALL PLOTT(X(2),Y(2),2)
|
||||
CALL PLOTT(X(3),Y(3),2)
|
||||
CALL PLOTT(X(4),Y(4),2)
|
||||
CALL PLOTT(X(1),Y(1),2)
|
||||
150 CONTINUE
|
||||
XSY=0.
|
||||
YSY=7.65
|
||||
DO 200 N=1,NSIZ
|
||||
!ipk mar01
|
||||
CALL SYMBL(XSY,YSY,0.20,HED(N),0.0, 8)
|
||||
! XSY=XSY+1.0
|
||||
XSY=XSY+HSIZE/10.
|
||||
200 CONTINUE
|
||||
ENDIF
|
||||
IF(NMESS .GT. 0) THEN
|
||||
|
||||
! Clear upper box area
|
||||
|
||||
CALL CLRBOX
|
||||
|
||||
! Write out message
|
||||
|
||||
MESOUT=MESS(NMESS)
|
||||
!ipk mar01
|
||||
CALL SYMBL(0.,7.65,0.20,MESOUT,0.,47)
|
||||
|
||||
ENDIF
|
||||
IF(NBRR .NE. 0) THEN
|
||||
|
||||
! Put box on right
|
||||
|
||||
! Draw box around selections
|
||||
|
||||
NBX=NBRR
|
||||
if(NBX.gt.5) NBX=NBRR-1 !ycw mar97
|
||||
IF(NBX .GT. 6) NBX=4
|
||||
if(nbrr .eq. 10) NBX=5
|
||||
! XLEFT=10-NBX
|
||||
XLEFT=(10-NBX)*HSIZE/10.
|
||||
DO 250 K=1,NBX
|
||||
X(1)=XLEFT
|
||||
X(4)=XLEFT
|
||||
X(5)=XLEFT
|
||||
! XLEFT=XLEFT+1.0
|
||||
XLEFT=XLEFT+HSIZE/10.
|
||||
X(2)=XLEFT
|
||||
X(3)=XLEFT
|
||||
IBLK=IBAKK
|
||||
CALL POLYFL(X,Y,5,IBLK)
|
||||
CALL RBLACK
|
||||
CALL PLOTT(X(1),Y(1),3)
|
||||
CALL PLOTT(X(2),Y(2),2)
|
||||
CALL PLOTT(X(3),Y(3),2)
|
||||
CALL PLOTT(X(4),Y(4),2)
|
||||
CALL PLOTT(X(1),Y(1),2)
|
||||
!ipk mar01
|
||||
CALL SYMBL(XLEFT-1.,7.65,0.20,HEADR(K,NBRR),0.0,8)
|
||||
250 CONTINUE
|
||||
! ENDIF
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
! Get xy location of cursor in screen coordinates (inches)
|
||||
|
||||
|
||||
subroutine xyloc(xscrn,yscrn,iflag,ibox)
|
||||
save
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
|
||||
CHARACTER*80 TITLE
|
||||
CHARACTER*24 HLABL
|
||||
CHARACTER*1 ALABL(10)
|
||||
CHARACTER*40 MPDUM
|
||||
|
||||
COMMON /SSIZE/ HSIZE
|
||||
|
||||
COMMON /BLKA1/ TITLE,HLABL,ALABL,MPDUM
|
||||
!IPk oct 95 lines defining MPDUM added
|
||||
|
||||
!ipk jan01 Expand IPSW to 10
|
||||
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||||
|
||||
character*1 iflag
|
||||
common /blktek/ xmin, xmax, ymin, ymax,&
|
||||
xpiv, ypiv, cthet, sthet,&
|
||||
xscal, yscal, theta, thetdg,&
|
||||
pgscl,scrnx,scrny,ix,iy
|
||||
|
||||
! IRDISP= 0 means no redisplay
|
||||
|
||||
irdisp=0
|
||||
100 continue
|
||||
! iy=ymax
|
||||
! write(90,*) 'to tekgin nhtp',nhtp
|
||||
call tekgin(xscrn,yscrn,iflag)
|
||||
! write(90,*) 'back tekgin nhtp',nhtp,xscrn,yscrn,IRDISP
|
||||
! write(90,'(a)') 'iflag',iflag
|
||||
|
||||
if(iflag .eq. 'P') then
|
||||
call hedr
|
||||
!IPk nov97 add (0)
|
||||
call plotot(0)
|
||||
call hedr
|
||||
!ipk may01
|
||||
irdisp=1
|
||||
go to 100
|
||||
endif
|
||||
|
||||
|
||||
!IPk mar94 if(yscrn .gt. 7.0 .and. iflag .eq. 'c') then
|
||||
if(yscrn .gt. 7.5 .and. iflag .eq. 'c') then
|
||||
! ibox=ifix(xscrn+0.9999)
|
||||
ibox=ifix(xscrn*10./HSIZE+0.9999)
|
||||
iflag='c'
|
||||
elseif(iflag .eq. 'M') then
|
||||
irmain = 1
|
||||
elseif(iflag .ne. 'c') then
|
||||
ibox=1
|
||||
else
|
||||
ibox=0
|
||||
endif
|
||||
if(irmain .eq. 1) return
|
||||
|
||||
! Check for zoom command
|
||||
|
||||
if(nhtp .eq. 2 .or. nhtp .eq. 5 .or. nhtp .eq. 12 .or.&
|
||||
nhtp .eq. 8 .or. nhtp .eq. 9) then
|
||||
return
|
||||
elseif(nhtp .eq. 0 .and. (nbrr .eq. 0 .or. nbrr .eq. 2&
|
||||
.or. nbrr .eq. 7)) then
|
||||
return
|
||||
elseif(ibox .eq. 8 .or. iflag .eq. 'z') then
|
||||
n1=nhtp
|
||||
n2=nbrr
|
||||
nhtp=0
|
||||
nbrr=0
|
||||
CALL ZOOM
|
||||
nhtp=n1
|
||||
nbrr=n2
|
||||
!ipk may01
|
||||
irdisp=1
|
||||
if(irmain .eq. 1) return
|
||||
call hedr
|
||||
IF(N2 .EQ. 10) CALL PLTPT
|
||||
go to 100
|
||||
elseif(ibox .eq. 9 .or. iflag .eq. 'r') then
|
||||
|
||||
! Save display parameters
|
||||
|
||||
n1=nhtp
|
||||
n2=nmess
|
||||
n3=nbrr
|
||||
CALL RDRW(0)
|
||||
if(n2 .eq. 11) call pltpt
|
||||
!ipk may01
|
||||
irdisp=1
|
||||
if(irmain .eq. 1) return
|
||||
|
||||
! Restore display parameters
|
||||
|
||||
nhtp=n1
|
||||
nmess=n2
|
||||
nbrr=n3
|
||||
call hedr
|
||||
go to 100
|
||||
endif
|
||||
|
||||
return
|
||||
|
||||
end
|
||||
@ -0,0 +1,99 @@
|
||||
!ipk last update Nov 18 1997
|
||||
!
|
||||
SUBROUTINE HELPS(NTPIN)
|
||||
USE WINTERACTER
|
||||
!
|
||||
! Master routine controlling the help facility
|
||||
!
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'BFILES.I90'
|
||||
!
|
||||
CHARACTER(LEN=256) :: FILTER
|
||||
CHARACTER*32 ANS
|
||||
CHARACTER*78 AHP
|
||||
character*55 strels
|
||||
! INTEGER*2 IPAG
|
||||
! INTEGER*2 NT
|
||||
DIMENSION NPOS(11),NFIN(10)
|
||||
LOGICAL*4 EXST
|
||||
|
||||
INQUIRE(FILE=DIRECT,EXIST=EXST)
|
||||
IF(.not. EXST) THEN
|
||||
CALL CLSCRN
|
||||
! WRITE(strels,6000)
|
||||
! 6000 format( 'Help files not available, press enter to return to menu')
|
||||
! CALL SYMBL(0.2,7.0,0.25,STRELS,0.0,55)
|
||||
! NDIG=1
|
||||
! call gtcharx(ans,ndig,6.0,7.0)
|
||||
|
||||
Filter='HTM file -- *.htm|*.htm|'
|
||||
|
||||
! CALL WSelectFile(FILTER,PromptOn,DIRECT,'Help files not available - BROWSE')
|
||||
|
||||
CALL WSelectFile(FILTER,LoadDialog+MustExist,DIRECT,'Help files not available - BROWSE')
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
GO TO 200
|
||||
ELSE
|
||||
CALL PLOTOT(1)
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDIF
|
||||
!
|
||||
! Write list of options and request choice
|
||||
!
|
||||
200 CONTINUE
|
||||
!
|
||||
! Decode choice and open appropriate file
|
||||
!
|
||||
IF(NTPIN .EQ. 0) THEN
|
||||
if(nhtp .lt. 3) then
|
||||
call WHelpfile(DIRECT)
|
||||
elseif(nhtp .eq. 3) then
|
||||
call WHelpfile(DIRECT,'REORDER')
|
||||
elseif(nhtp .eq. 4) then
|
||||
call WHelpfile(DIRECT,'NODE')
|
||||
elseif(nhtp .eq. 5) then
|
||||
call WHelpfile(DIRECT,'REDRAW')
|
||||
elseif(nhtp .eq. 6) then
|
||||
call WHelpfile(DIRECT,'ELEMENT')
|
||||
elseif(nhtp .eq. 7) then
|
||||
call WHelpfile(DIRECT,'SELECT')
|
||||
elseif(nhtp .eq. 8) then
|
||||
call WHelpfile(DIRECT,'REFINE')
|
||||
elseif(nhtp .eq. 9) then
|
||||
call WHelpfile(DIRECT,'ELEVATION')
|
||||
elseif(nhtp .eq. 10) then
|
||||
call WHelpfile(DIRECT,'DELETE')
|
||||
elseif(nhtp .eq. 11) then
|
||||
call WHelpfile(DIRECT,'SAVE')
|
||||
elseif(nhtp .eq. 12) then
|
||||
call WHelpfile(DIRECT,'MAP')
|
||||
elseif(nhtp .eq. 13) then
|
||||
call WHelpfile(DIRECT,'WIDTH')
|
||||
elseif(nhtp .eq. 14) then
|
||||
call WHelpfile(DIRECT,'POLNODE')
|
||||
elseif(nhtp .eq. 15) then
|
||||
call WHelpfile(DIRECT,'POLELEM')
|
||||
endif
|
||||
ELSEIF(NTPIN .EQ. 1) THEN
|
||||
call WHelpfile(DIRECT,'FILE')
|
||||
ELSEIF(NTPIN .EQ. 2) THEN
|
||||
call WHelpfile(DIRECT,'ELEMENT')
|
||||
ELSEIF(NTPIN .EQ. 3) THEN
|
||||
call WHelpfile(DIRECT,'NODE')
|
||||
ELSEIF(NTPIN .EQ. 4) THEN
|
||||
call WHelpfile(DIRECT,'ELEVATION')
|
||||
ELSEIF(NTPIN .EQ. 5) THEN
|
||||
call WHelpfile(DIRECT,'REORDER')
|
||||
ELSEIF(NTPIN .EQ. 6) THEN
|
||||
call WHelpfile(DIRECT,'SELECT')
|
||||
ELSEIF(NTPIN .EQ. 7) THEN
|
||||
call WHelpfile(DIRECT,'DELETE')
|
||||
ELSEIF(NTPIN .EQ. 8) THEN
|
||||
call WHelpfile(DIRECT,'SAVE')
|
||||
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,121 @@
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// THIS FILE SHOULD NOT BE EDITED USING A TEXT
|
||||
// EDITOR OR 3RD PARTY RESOURCE EDITOR, EXCEPT
|
||||
// WHEN SPECIFICALLY INSTRUCTED BY I.S.S.
|
||||
//
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Winteracter exported resources.
|
||||
//
|
||||
// Exported : 01/Mar/2017 10:58:19
|
||||
//
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// To use this file it should be imported into
|
||||
// your main resource script
|
||||
//
|
||||
///////////////////////////////////////////////////
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Parameter Definitions
|
||||
//
|
||||
#define ID_FILE 40001
|
||||
#define ID_View 40033
|
||||
#define IDM_MENU1 30002
|
||||
#define ID_RSET 40131
|
||||
#define ID_COLR 40003
|
||||
#define ID_CLOSE 40005
|
||||
#define ID_WIRE 40139
|
||||
#define ID_HIDDEN 40007
|
||||
#define ID_UNLIT 40008
|
||||
#define ID_FLAT 40140
|
||||
#define ID_GOURAUD 40141
|
||||
#define ID_ITEM11 40011
|
||||
#define ID_ONECOL 40012
|
||||
#define ID_MULTCOL 40013
|
||||
#define ID_TOP 40014
|
||||
#define ID_SIDE 40015
|
||||
#define ID_SAVEVIEW 40132
|
||||
#define ID_SAV3D 40133
|
||||
#define ID_OPENNEW 40137
|
||||
#define ID_ITEM149 40138
|
||||
#define ID_FZOOM 40142
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Menus
|
||||
//
|
||||
IDM_MENU1 MENU
|
||||
BEGIN
|
||||
POPUP "FILE"
|
||||
BEGIN
|
||||
MENUITEM "Save as a W3D file\aAlt+S", ID_SAV3D
|
||||
MENUITEM "Close this Window\aAlt+X", ID_CLOSE
|
||||
MENUITEM "Open a New W3D File\aCtrl+N", ID_OPENNEW
|
||||
END
|
||||
POPUP "TYPE"
|
||||
BEGIN
|
||||
MENUITEM "&Wireframe\aF2", ID_WIRE
|
||||
MENUITEM "&Hidden lines removed\aF3", ID_HIDDEN
|
||||
MENUITEM "U&nlit\aF4", ID_UNLIT
|
||||
MENUITEM "&Flat shading\aF5", ID_FLAT
|
||||
MENUITEM "&Gouraud shading\aF6", ID_GOURAUD
|
||||
END
|
||||
POPUP "VIEW"
|
||||
BEGIN
|
||||
MENUITEM "Fast Zoom\aF7", ID_FZOOM
|
||||
MENUITEM "Top View\aF8", ID_TOP
|
||||
MENUITEM "Side View\aF9", ID_SIDE
|
||||
MENUITEM "Reset View", ID_RSET
|
||||
END
|
||||
POPUP "COLOUR"
|
||||
BEGIN
|
||||
MENUITEM "Single Colour", ID_ONECOL
|
||||
MENUITEM "Multi-Colour", ID_MULTCOL
|
||||
END
|
||||
POPUP "SAVE"
|
||||
BEGIN
|
||||
MENUITEM "Save View", ID_SAVEVIEW
|
||||
END
|
||||
END
|
||||
|
||||
IDM_MENU1 RCDATA
|
||||
BEGIN
|
||||
ID_FILE,1,0,
|
||||
ID_ITEM149,2,0,
|
||||
ID_View,3,0,
|
||||
ID_COLR,4,0,
|
||||
ID_ITEM11,5,0,
|
||||
0
|
||||
END
|
||||
|
||||
IDM_MENU1 ISSMENUSTRING
|
||||
BEGIN
|
||||
ID_UNLIT,"Unlit\0",
|
||||
ID_HIDDEN,"Wireframe model, hidden lines removed\0",
|
||||
ID_FLAT,"Solid model, with lighting and constant shading\0",
|
||||
ID_GOURAUD,"Solid model, with lighting and Gouraud shading\0",
|
||||
0
|
||||
END
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Accelerators
|
||||
//
|
||||
IDM_MENU1 ACCELERATORS
|
||||
BEGIN
|
||||
83 , ID_SAV3D ,NOINVERT,VIRTKEY,ALT
|
||||
88 , ID_CLOSE ,NOINVERT,VIRTKEY,ALT
|
||||
78 , ID_OPENNEW ,NOINVERT,VIRTKEY,CONTROL
|
||||
VK_F2 , ID_WIRE ,NOINVERT,VIRTKEY
|
||||
VK_F3 , ID_HIDDEN ,NOINVERT,VIRTKEY
|
||||
VK_F4 , ID_UNLIT ,NOINVERT,VIRTKEY
|
||||
VK_F5 , ID_FLAT ,NOINVERT,VIRTKEY
|
||||
VK_F6 , ID_GOURAUD ,NOINVERT,VIRTKEY
|
||||
VK_F7 , ID_FZOOM ,NOINVERT,VIRTKEY
|
||||
VK_F8 , ID_TOP ,NOINVERT,VIRTKEY
|
||||
VK_F9 , ID_SIDE ,NOINVERT,VIRTKEY
|
||||
END
|
||||
|
||||
@ -0,0 +1,74 @@
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// THIS FILE SHOULD NOT BE EDITED USING A TEXT
|
||||
// EDITOR OR 3RD PARTY RESOURCE EDITOR, EXCEPT
|
||||
// WHEN SPECIFICALLY INSTRUCTED BY I.S.S.
|
||||
//
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Winteracter exported resources.
|
||||
//
|
||||
// Exported : 01/Mar/2017 10:59:52
|
||||
//
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// To use this file it should be imported into
|
||||
// your main resource script
|
||||
//
|
||||
///////////////////////////////////////////////////
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Parameter Definitions
|
||||
//
|
||||
#define IDT_TOOLBAR1 30102
|
||||
#define ID_PRIGHT 40101
|
||||
#define ID_ZOOMIN 40102
|
||||
#define ID_ZOOMOUT 40103
|
||||
#define ID_PLEFT 40105
|
||||
#define ID_ROTATC 40107
|
||||
#define ID_ROTATAC 20013
|
||||
#define ID_UPAR 40135
|
||||
#define ID_DWNAR 40136
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Bitmaps
|
||||
//
|
||||
IDT_TOOLBAR1 BITMAP DISCARDABLE "tbar1.bmp"
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Strings
|
||||
//
|
||||
STRINGTABLE DISCARDABLE
|
||||
BEGIN
|
||||
ID_ZOOMOUT "Zoom Out"
|
||||
ID_ZOOMIN "Zoom In"
|
||||
ID_PLEFT "Pan Left"
|
||||
ID_PRIGHT "Pan Right"
|
||||
ID_ROTATC "Rotate Clockwise"
|
||||
ID_ROTATAC "Rotate Anti-Clockwise"
|
||||
ID_UPAR "Pan Upwards"
|
||||
ID_DWNAR "Pan Down"
|
||||
END
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Toolbar Data
|
||||
//
|
||||
IDT_TOOLBAR1 RCDATA
|
||||
BEGIN
|
||||
16, 16,
|
||||
ID_ZOOMIN,
|
||||
ID_ZOOMOUT,
|
||||
ID_PLEFT,
|
||||
ID_PRIGHT,
|
||||
ID_ROTATC,
|
||||
ID_ROTATAC,
|
||||
ID_UPAR,
|
||||
ID_DWNAR,
|
||||
0,0
|
||||
END
|
||||
|
||||
|
||||
@ -0,0 +1,162 @@
|
||||
SUBROUTINE INITSIZ(IIN1,N1,M1,K1)
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
USE BLKMAP
|
||||
|
||||
INCLUDE 'D.INC'
|
||||
|
||||
IF(K1 .EQ. 0) THEN
|
||||
MAXPL=200000
|
||||
MAXP=200000
|
||||
MAXE=120000
|
||||
MAXSTO=2
|
||||
MAXLIN=3000
|
||||
MAXECON=60
|
||||
MAXECON1=30
|
||||
MAXLN=20
|
||||
MAELN=300
|
||||
RETURN
|
||||
ENDIF
|
||||
IMIDS=0
|
||||
IF(IIN1 .EQ. 10. .AND. IGFG .EQ. 0 .AND. ITRIAN .EQ. 0) THEN
|
||||
CALL RDRM1(IIN1,N1,M1,IMIDS)
|
||||
ENDIF
|
||||
IF(ITRIAN .EQ. 0) NMIDS=1
|
||||
iqsw(1)=1
|
||||
iqsw(2)=0
|
||||
CALL WMenuSetState(ID_ITYPN,ItemChecked,1)
|
||||
|
||||
IF(N1 .GT. MAXP .OR. M1 .GT. MAXE .AND. IMIDS .EQ. 0) then
|
||||
|
||||
CALL WMessageBox(YesNo, QuestionIcon, 1,'Do you wish to add 20,000 nodes and elements to the limit (YES) or reset sizes (NO)','LIMITS EXCEEDED')
|
||||
|
||||
IF (WInfoDialog(4) .ne. 2) then
|
||||
! yes
|
||||
MAXP=N1+20000
|
||||
MAXE=M1+20000
|
||||
ELSE
|
||||
CALL RESETSIZ
|
||||
ENDIF
|
||||
ELSEIF((N1 .GT. MAXP/3 .OR. M1 .GT. MAXE) .AND. IMIDS .EQ. 1) then
|
||||
CALL WMessageBox(YesNo, QuestionIcon, 1,'This is a large unfilled network, do you wish to reset sizes?','LIMITS EXCEEDED')
|
||||
IF (WInfoDialog(4) .ne. 2) then
|
||||
! yes
|
||||
CALL RESETSIZ
|
||||
ENDIF
|
||||
|
||||
endif
|
||||
|
||||
ALLOCATE (CORD(MAXP,2),XUSR(MAXP),YUSR(MAXP),XC(MAXE),YC(MAXE)&
|
||||
,NOP(MAXE,8),IMAT(MAXE),THTA(MAXE),IMATL(MAXE),CORDSN(MAXP,2)&
|
||||
,WD(MAXP) ,WD1(MAXP),INSKP(MAXP), IESKP(MAXE),NCORN(MAXE)&
|
||||
,WIDTH(MAXP), SS1(MAXP), SS2(MAXP), WIDS(MAXP)&
|
||||
,IJUN(MAXP),INEW(MAXP),IEM(MAXE),LINTYP(MAXLIN),NEFLAG(MAXP),NEF(MAXP,3),LAY(0:MAXP+1),WTLAY(0:MAXP+1,9)&
|
||||
,WIDBS(MAXP),SSO(MAXP),NODDEL(MAXP),IELDEL(MAXE)&
|
||||
,NOPSV(MAXE,8),nefsv(MAXP,3),IMATSV(MAXE),LOCK(MAXP),BS1(MAXP),EDIF(0:MAXP),IGRPSER(MAXE),IOD(MAXP))
|
||||
|
||||
IJUN=0
|
||||
lay=0
|
||||
IGRPSER=1
|
||||
|
||||
ALLOCATE (NRIVCR1(MAXP),WTRIVCR1(MAXP),NRIVCR2(MAXP),WTRIVCR2(MAXP))
|
||||
|
||||
|
||||
ALLOCATE (xusrsto(MAXP,MAXSTO),yusrsto(MAXP,MAXSTO),wdsto(MAXP,MAXSTO),&
|
||||
WIDTHsto(MAXP,MAXSTO), SS1sto(MAXP,MAXSTO), SS2sto(MAXP,MAXSTO), WIDSsto(MAXP,MAXSTO)&
|
||||
,WIDBSsto(MAXP,MAXSTO),SSOsto(MAXP,MAXSTO),bs1sto(MAXP,MAXSTO)&
|
||||
,nopsto(MAXE,8,MAXSTO),imatsto(MAXE,MAXSTO),thtasto(MAXE,MAXSTO))
|
||||
|
||||
ALLOCATE (ICCLNSTO(50,350,MAXSTO)&
|
||||
,NPSTO(MAXSTO),NESTO(MAXSTO),NLSTSTO(MAXSTO),NCLMSTO(MAXSTO))
|
||||
|
||||
ALLOCATE (ILISTSTO(MAXLN,MAELN,MAXSTO),LLISTSTO(MAXLN,MAXSTO))
|
||||
|
||||
|
||||
ALLOCATE (MLIST(MAXE),ENXT(MAXE),NDELM(MAXP),LIST(MAXP) &
|
||||
,NINC(MAXP),NELIM(MAXE))
|
||||
|
||||
ALLOCATE (ICON(MAXE,MAXECON))
|
||||
|
||||
ALLOCATE (NECON(MAXP,MAXECON))
|
||||
|
||||
ALLOCATE (MSN(MAXP),ICN(MAXP))
|
||||
|
||||
ALLOCATE (ILIST(MAXLN,MAELN),LLIST(MAXLN))
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE RESETSIZ
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
USE BLKMAP
|
||||
include 'd.inc'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: NTYP,NLOCC
|
||||
|
||||
|
||||
call wdialogload(IDD_MLIMITS)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_MLIMITS)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER1,MAXP)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER2,MAXE)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER3,MAXPL)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER1,MAXP)
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER2,MAXE)
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER3,MAXPL)
|
||||
|
||||
GO TO 100
|
||||
ENDIF
|
||||
|
||||
enddo
|
||||
|
||||
100 CONTINUE
|
||||
return
|
||||
end
|
||||
|
||||
SUBROUTINE SETGFGTRIAN(I1,I2,N2,M2)
|
||||
USE BLK1MOD
|
||||
! Define a common block with file names etc
|
||||
|
||||
INCLUDE 'BFILES.I90'
|
||||
CHARACTER (LEN=255) :: FNAMTMP
|
||||
IGFG=I1
|
||||
ITRIAN=I2
|
||||
IF(ITRIAN .EQ. 1) THEN
|
||||
READ(10,*) M2
|
||||
REWIND (10)
|
||||
itunit=14
|
||||
FNAMTMP=FNAMKEP
|
||||
DO L=255,1,-1
|
||||
IF(FNAMTMP(L:L) .EQ. '.') THEN
|
||||
FNAMTMP(L+1:L+4)='node'
|
||||
OPEN(ITUNIT,FILE=FNAMTMP,STATUS='OLD',ACTION='READ')
|
||||
READ(ITUNIT,*) N2
|
||||
CLOSE(ITUNIT)
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,438 @@
|
||||
SUBROUTINE GRELV
|
||||
!
|
||||
! THIS ROUTINE COMPUTES THE GRIDDED ELEVATION
|
||||
!
|
||||
use winteracter
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!-
|
||||
|
||||
include 'd.inc'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
INTEGER :: IERR,ISET
|
||||
REAL :: ASET
|
||||
DATA NXP,NYP/30,20/
|
||||
DATA ITIM/0/
|
||||
|
||||
IF(ITIM .EQ. 0) THEN
|
||||
NX=NXP+2
|
||||
NY=NYP+2
|
||||
ITIM=0
|
||||
ENDIF
|
||||
|
||||
call wdialogload(IDD_GETINTP)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_GETINTP)
|
||||
ierr=infoerror(1)
|
||||
|
||||
100 continue
|
||||
NXP=NX-2
|
||||
NYP=NY-2
|
||||
XGR=XGRID*TXSCAL
|
||||
YGR=YGRID*TXSCAL
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER1,NXP)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER2,NYP)
|
||||
CALL WDialogPutREAL(IDF_REAL1,XGR)
|
||||
CALL WDialogPutREAL(IDF_REAL2,YGR)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER1,NXP)
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER2,NYP)
|
||||
CALL WDialogGetREAL(IDF_REAL1,XGR)
|
||||
CALL WDialogGetREAL(IDF_REAL2,YGR)
|
||||
GO TO 200
|
||||
else
|
||||
NRECC=0
|
||||
endif
|
||||
|
||||
enddo
|
||||
|
||||
200 CONTINUE
|
||||
NX=NXP+2
|
||||
NY=NYP+2
|
||||
XGRID=XGR/TXSCAL
|
||||
YGRID=YGR/TXSCAL
|
||||
!-
|
||||
AXMAX = HSIZE
|
||||
AYMAX = 7.0
|
||||
if(xgrid .eq. 0.) then
|
||||
XGRID = AXMAX/FLOAT(NX-3)
|
||||
ELSE
|
||||
NX=(AXMAX/XGRID+0.5)+3
|
||||
ENDIF
|
||||
IF(YGRID .EQ. 0.) THEN
|
||||
YGRID = AYMAX/FLOAT(NY-3)
|
||||
ELSE
|
||||
NY=(AYMAX/YGRID+0.5)+3
|
||||
ENDIF
|
||||
|
||||
IF(NX .GT. MAXGRD .OR. NY .GT. MAXGRD) THEN
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK, &
|
||||
'Maximum number of interpolation points exceeded '//CHAR(13) &
|
||||
//'Choose a lower resolution.', &
|
||||
'Warning')
|
||||
go to 100
|
||||
endif
|
||||
|
||||
CALL LOCATE
|
||||
!
|
||||
CALL POINTEL
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE POINTEL
|
||||
!*********************************** .....POINTS.....
|
||||
!-
|
||||
!......SUBROUTINE TO EVALUATE FUNCTION AT GRID POINTS
|
||||
!-
|
||||
!-
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
|
||||
include 'd.inc'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!
|
||||
REAL*8 XN,DNX,DNY
|
||||
DOUBLE PRECISION XG,YG,XK,YK,XP,YP
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLKV1.COM'
|
||||
! INCLUDE 'BLKV2.COM'
|
||||
INCLUDE 'BFILES.I90'
|
||||
!-
|
||||
!ipk jul94 DIMENSION X(8),Y(8)
|
||||
DIMENSION X(9),Y(9)
|
||||
CHARACTER(LEN=255) :: FNAME,FNAMR
|
||||
CHARACTER(LEN=256) :: FILTER
|
||||
CHARACTER(LEN=3) :: SUB,SUB1
|
||||
!-
|
||||
DATA TOL/0.01/
|
||||
!-
|
||||
|
||||
!-
|
||||
!......LOOP ON ALL GRID POINTS
|
||||
!-
|
||||
FILTER = 'Map file *.map|*.map|'
|
||||
CALL WSelectFile(FILTER,SaveDialog+PromptOn,FNAME,'Save Map File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
OPEN(199,FILE=FNAME,STATUS='UNKNOWN')
|
||||
WRITE(199,8000)
|
||||
8000 FORMAT('2,0.')
|
||||
ELSE
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
DO 1000 NN=1,NX
|
||||
DO 950 MM=1,NY
|
||||
N=IGRID(NN,MM)
|
||||
IF(N.EQ.0) GO TO 950
|
||||
HGN=0.
|
||||
250 CONTINUE
|
||||
!-
|
||||
!......DETERMINE ELEMENT TYPE
|
||||
!-
|
||||
!IPKOCT93 ADD
|
||||
NCN=8
|
||||
IT=1
|
||||
|
||||
IF(NOP(N,7).NE.0) GO TO 275
|
||||
NCN=6
|
||||
IT=2
|
||||
275 CONTINUE
|
||||
!-
|
||||
!......ESTABLISH LOCAL COORDINATES FOR EACH NODE POINT
|
||||
!-
|
||||
K1=NOP(N,1)
|
||||
X(1)=0.
|
||||
Y(1)=0.
|
||||
DO 300 K=2,NCN
|
||||
K2=NOP(N,K)
|
||||
X(K)=CORD(K2,1)-CORD(K1,1)
|
||||
Y(K)=CORD(K2,2)-CORD(K1,2)
|
||||
300 END DO
|
||||
!-
|
||||
!......ESTABLISH LOCAL COORDINATES OF DESIRED POINT
|
||||
!-
|
||||
XP=FLOAT(NN-2)*XGRID
|
||||
XRL=XP*TXSCAL-XS
|
||||
XP=XP-CORD(K1,1)
|
||||
YP=FLOAT(MM-2)*YGRID
|
||||
YRL=YP*TXSCAL-YS
|
||||
YP=YP-CORD(K1,2)
|
||||
XG=0.
|
||||
YG=0.
|
||||
!-
|
||||
!......ITERATE TO FIND LOCAL COORDINATE
|
||||
!-
|
||||
DO 400 ITER=1,10
|
||||
DXKDX=0.
|
||||
DXKDY=0.
|
||||
DYKDX=0.
|
||||
DYKDY=0.
|
||||
XK=-XP
|
||||
YK=-YP
|
||||
DO 350 K=2,NCN
|
||||
XK=XK+XN(IT,K,XG,YG)*X(K)
|
||||
YK=YK+XN(IT,K,XG,YG)*Y(K)
|
||||
DXKDX=DXKDX+DNX(IT,K,XG,YG)*X(K)
|
||||
DYKDX=DYKDX+DNX(IT,K,XG,YG)*Y(K)
|
||||
DXKDY=DXKDY+DNY(IT,K,XG,YG)*X(K)
|
||||
DYKDY=DYKDY+DNY(IT,K,XG,YG)*Y(K)
|
||||
350 END DO
|
||||
DET=DXKDX*DYKDY-DXKDY*DYKDX
|
||||
DX=(-DYKDY*XK+DXKDY*YK)/DET
|
||||
DY=( DYKDX*XK-DXKDX*YK)/DET
|
||||
XG=XG+DX
|
||||
YG=YG+DY
|
||||
IF(ABS(DX).LT.TOL .AND. ABS(DY).LT.TOL) GO TO 420
|
||||
400 END DO
|
||||
!-
|
||||
!......NOW EVALUATE GRID POINT
|
||||
!-
|
||||
420 CONTINUE
|
||||
DO 450 K=1,NCN
|
||||
J=NOP(N,K)
|
||||
HGN=HGN+XN(IT,K,XG,YG)*WD(J)
|
||||
450 END DO
|
||||
WRITE(199,9800) XRL,YRL,HGN
|
||||
9800 FORMAT(F14.2',',F14.2,',',F14.3)
|
||||
950 END DO
|
||||
1000 END DO
|
||||
! IF(NVEL .EQ. 1) WRITE(6,9803) ((UGRID(NN,MM),MM=1,32),
|
||||
! 1NN=1,32)
|
||||
! IF(NVEL .EQ. 1) WRITE(6,9803) ((VGRID(NN,MM),MM=1,32),
|
||||
! 1NN=1,32)
|
||||
9803 FORMAT(8E12.4)
|
||||
! WRITE(6,9802)((GRID(NN,MM),MM=1,16),NN=1,16)
|
||||
!9802 FORMAT(16F8.2)
|
||||
WRITE(199,8001)
|
||||
8001 FORMAT('END')
|
||||
WRITE(199,8001)
|
||||
RETURN
|
||||
END
|
||||
|
||||
!
|
||||
SUBROUTINE LOCATE
|
||||
!*********************************** .....LOCATE.....
|
||||
!-
|
||||
!......LOCATE ESTABLISHES ELEMENT NUMBERS FOR ALL GRID POINTS
|
||||
!-
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLKV1.COM'
|
||||
! INCLUDE 'BLKV2.COM'
|
||||
INCLUDE 'BFILES.I90'
|
||||
!
|
||||
COMMON XS(4,3),YS(4,3),XM(4,3),ROOT(10)
|
||||
!
|
||||
VOID=1.E+20
|
||||
NPTS= 7
|
||||
DS=1./(FLOAT(NPTS)-1.)
|
||||
DO 340 N=1,MAXGRD
|
||||
DO 340 M=1,MAXGRD
|
||||
340 IGRID(N,M)=0
|
||||
!-
|
||||
!....... PROCESS EACH ELEMENT
|
||||
!-
|
||||
DO 900 N=1,NE
|
||||
IF(IESKP(N) .NE. 0) GO TO 900
|
||||
IF(IMAT(N).LE.0) GO TO 900
|
||||
IF(NOP(N,6) .EQ. 0) GO TO 900
|
||||
XMINN=VOID
|
||||
YMINN=VOID
|
||||
XMAXX=-VOID
|
||||
YMAXX=-VOID
|
||||
!-
|
||||
!...... TRACE AROUND EACH SIDE FOR MAX AND MIN LOCATIONS
|
||||
!-
|
||||
NCN=8
|
||||
IF(NOP(N,7).EQ.0) NCN=6
|
||||
NSIDE=NCN/2
|
||||
K=0
|
||||
DO 600 M=1,NCN,2
|
||||
K=K+1
|
||||
M1=NOP(N,M)
|
||||
M2=NOP(N,M+1)
|
||||
M3=MOD(M+2,NCN)
|
||||
M3=NOP(N,M3)
|
||||
XS(K,1)=CORD(M1,1)
|
||||
XS(K,2)=CORD(M2,1)
|
||||
XS(K,3)=CORD(M3,1)
|
||||
YS(K,1)=CORD(M1,2)
|
||||
YS(K,2)=CORD(M2,2)
|
||||
YS(K,3)=CORD(M3,2)
|
||||
XM(K,1)=2.*XS(K,1)-4.*XS(K,2)+2.*XS(K,3)
|
||||
XM(K,2)=-3.*XS(K,1)+4.*XS(K,2)-XS(K,3)
|
||||
XM(K,3)=XS(K,1)
|
||||
!-
|
||||
!..... WORK ALONG BOUNDARY OF ELEMENT
|
||||
!-
|
||||
S=0.
|
||||
DO 550 J=1,NPTS
|
||||
XN1=(1.-S)*(1.-2.*S)
|
||||
XN2=4.*(1.-S)*S
|
||||
XN3=S*(2.*S-1.)
|
||||
X=XN1*XS(K,1)+XN2*XS(K,2)+XN3*XS(K,3)
|
||||
Y=XN1*YS(K,1)+XN2*YS(K,2)+XN3*YS(K,3)
|
||||
IF(X.LT.XMINN) XMINN=X
|
||||
IF(X.GT.XMAXX) XMAXX=X
|
||||
IF(Y.LT.YMINN) YMINN=Y
|
||||
IF(Y.GT.YMAXX) YMAXX=Y
|
||||
S=S+DS
|
||||
550 END DO
|
||||
600 END DO
|
||||
!-
|
||||
!...... ESTABLISH GRID FRAMEWORK
|
||||
!-
|
||||
XLH=XMINN/XGRID
|
||||
XRH=XMAXX/XGRID
|
||||
YBT=YMINN/YGRID
|
||||
YTP=YMAXX/YGRID
|
||||
IXL=XLH+2.999
|
||||
IXT=XRH+2.001
|
||||
IYL=YBT+2.999
|
||||
IYT=YTP+2.001
|
||||
IERR=0
|
||||
!$$$
|
||||
IF(IXL.LT.0) IERR=1
|
||||
IF (IXL .LT. 1) IXL = 1
|
||||
IF(IYL.LT.0) IERR=1
|
||||
IF (IYL .LT. 1) IYL = 1
|
||||
IF(IXT.GT.NX) IERR=1
|
||||
IF (IXT .GT. NX) IXT = NX
|
||||
IF(IYT.GT.NY) IERR=1
|
||||
IF (IYT .GT. NY) IYT = NY
|
||||
!
|
||||
IF(IERR.EQ.0) GO TO 620
|
||||
! WRITE(6,9989) N
|
||||
! 9989 FORMAT(///' ERROR STOP FOR ELEMENT',I5)
|
||||
! WRITE(6,9990) (K,(XS(K,M),YS(K,M),XM(K,M),M=1,3),K=1,NSIDE)
|
||||
! 9990 FORMAT(I10,9E13.4)
|
||||
! WRITE(6,9992) XLH,XRH,YBT,YTP,IXL,IXT,IYL,IYT
|
||||
! 9992 FORMAT(4F20.6,4I8)
|
||||
!$$$ STOP
|
||||
620 CONTINUE
|
||||
!-
|
||||
!...... FIND INTERSECTIONS FOR HORIZONTAL GRID LINE
|
||||
!-
|
||||
DO 800 M=IYL,IYT
|
||||
Y=(M-2)*YGRID
|
||||
IL=0
|
||||
DO 700 K=1,NSIDE
|
||||
A=2.*YS(K,1)-4.*YS(K,2)+2.*YS(K,3)
|
||||
B=-3.*YS(K,1)+4.*YS(K,2)-YS(K,3)
|
||||
C=YS(K,1)-Y
|
||||
SQ=B**2-4.*A*C
|
||||
IF(ABS(A).LT.0.01) GO TO 650
|
||||
IF(SQ.GT..001) GO TO 660
|
||||
IF(SQ.LT.-.001) GO TO 700
|
||||
S=-B/(2.*A)
|
||||
IF(S.LT.0. .OR. S.GT.1.0) GO TO 700
|
||||
IL=IL+1
|
||||
ROOT(IL)=XM(K,1)*S**2+XM(K,2)*S+XM(K,3)
|
||||
IL=IL+1
|
||||
ROOT(IL)=ROOT(IL-1)
|
||||
GO TO 700
|
||||
650 IF(ABS(B).LT. 0.001) GO TO 700
|
||||
S=-C/B
|
||||
GO TO 670
|
||||
660 CONTINUE
|
||||
S=(-B+SQRT(SQ))/(2.*A)
|
||||
IF(S.LT.0. .OR. S.GT.1.0) GO TO 665
|
||||
IL=IL+1
|
||||
ROOT(IL)=XM(K,1)*S**2+XM(K,2)*S+XM(K,3)
|
||||
665 S=(-B-SQRT(SQ))/(2.*A)
|
||||
670 CONTINUE
|
||||
IF(S.LT.0. .OR. S.GT.1.0) GO TO 700
|
||||
IL=IL+1
|
||||
ROOT(IL)=XM(K,1)*S**2+XM(K,2)*S+XM(K,3)
|
||||
700 END DO
|
||||
IF(IL.GT.0) GO TO 705
|
||||
DO 703 K=1,NSIDE
|
||||
IF(ABS(YS(K,3)-Y).LT.0.05) GO TO 704
|
||||
703 END DO
|
||||
GO TO 800
|
||||
704 IL=2
|
||||
ROOT(1)=XS(K,3)-0.05
|
||||
ROOT(2)=XS(K,3)+0.05
|
||||
705 CONTINUE
|
||||
CALL SORTE(ROOT,IL)
|
||||
! ISET=0
|
||||
IC=1
|
||||
!-
|
||||
!....... LOCATE VALUES INTO IGRID
|
||||
!-
|
||||
9908 FORMAT(I10,F20.2)
|
||||
9997 FORMAT(5F20.4)
|
||||
DO 750 K=IXL,IXT
|
||||
X=(K-2)*XGRID
|
||||
710 CONTINUE
|
||||
IF(X.LE.ROOT(IC)) GO TO 720
|
||||
IC=IC+1
|
||||
IF(IC.GT.IL) GO TO 800
|
||||
GO TO 710
|
||||
720 IF(MOD(IC,2).EQ.0) IGRID(K,M)=N
|
||||
750 END DO
|
||||
800 END DO
|
||||
900 END DO
|
||||
!CC WRITE(*,9800) ((IGRID(N,M),N=1,20),M=1,20)
|
||||
9800 FORMAT(20I3)
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
SUBROUTINE SORTE(A,N)
|
||||
!*********************************** .....SORT.....
|
||||
!-
|
||||
!......SORT IS A SIMPLE SHELL SORT ROUTINE
|
||||
!-
|
||||
! SHELL SORT
|
||||
SAVE
|
||||
!
|
||||
DIMENSION A(*)
|
||||
IF(N.LT.2) RETURN
|
||||
ID = N
|
||||
100 ID = ID / 2
|
||||
110 IB = 1
|
||||
120 GO TO 200
|
||||
130 IB = IB + 1
|
||||
IF( IB .LE. ID ) GO TO 200
|
||||
IF( ID .GT. 1 ) GO TO 100
|
||||
RETURN
|
||||
200 I = IB
|
||||
210 K = I + ID
|
||||
220 IF( A(I) .LE. A(K) ) GO TO 250
|
||||
T = A(K)
|
||||
A(K) = A(I)
|
||||
J = I
|
||||
230 K = J - ID
|
||||
IF( K .LT. 1 ) GO TO 240
|
||||
IF( T .GT. A(K) ) GO TO 240
|
||||
A(J) = A(K)
|
||||
J = K
|
||||
GO TO 230
|
||||
240 A(J) = T
|
||||
250 I = I + ID
|
||||
IF( I + ID .LE. N ) GO TO 210
|
||||
GO TO 130
|
||||
END
|
||||
!
|
||||
@ -0,0 +1,122 @@
|
||||
SUBROUTINE JLINE(ILIN,CVAL)
|
||||
|
||||
! Routine to join up points
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
INCLUDE 'TXFRM.COM'
|
||||
COMMON /CCGEN/ XCLIN(4000,2),YCLIN(4000,2),ALIN(-4000:4000,2),IUSED(4000)
|
||||
|
||||
|
||||
VOID=-1.0E+10
|
||||
|
||||
DO K=1,MAXLIN
|
||||
IF(LINTYP(K) .EQ. -999) THEN
|
||||
NLIN=K-1
|
||||
GO TO 100
|
||||
ENDIF
|
||||
ENDDO
|
||||
NLIN=MAXLIN
|
||||
100 CONTINUE
|
||||
|
||||
DO I=1,ILIN
|
||||
IUSED(I)=0
|
||||
ENDDO
|
||||
! Loop through remaining poins
|
||||
|
||||
DO I=1,ILIN
|
||||
IF(IUSED(I) .EQ. 0) THEN
|
||||
|
||||
! Set first points
|
||||
|
||||
IFW=2
|
||||
IFB=1
|
||||
IUSED(I)=1
|
||||
ALIN(1,1)=XCLIN(I,1)
|
||||
ALIN(1,2)=YCLIN(I,1)
|
||||
ALIN(2,1)=XCLIN(I,2)
|
||||
ALIN(2,2)=YCLIN(I,2)
|
||||
|
||||
! Look at remaining points for match
|
||||
|
||||
200 CONTINUE
|
||||
|
||||
DO J=I,ILIN
|
||||
IF(IUSED(J) .EQ. 0) THEN
|
||||
! First for forward points
|
||||
|
||||
IF(XCLIN(J,1) .EQ. ALIN(IFW,1) .AND. YCLIN(J,1) .EQ. ALIN(IFW,2)) THEN
|
||||
IFW=IFW+1
|
||||
ALIN(IFW,1)=XCLIN(J,2)
|
||||
ALIN(IFW,2)=YCLIN(J,2)
|
||||
IUSED(J)=1
|
||||
ELSEIF(XCLIN(J,2) .EQ. ALIN(IFW,1) .AND. YCLIN(J,2) .EQ. ALIN(IFW,2)) THEN
|
||||
IFW=IFW+1
|
||||
ALIN(IFW,1)=XCLIN(J,1)
|
||||
ALIN(IFW,2)=YCLIN(J,1)
|
||||
IUSED(J)=1
|
||||
ELSEIF(XCLIN(J,1) .EQ. ALIN(IFB,1) .AND. YCLIN(J,1) .EQ. ALIN(IFB,2)) THEN
|
||||
IFB=IFB-1
|
||||
ALIN(IFB,1)=XCLIN(J,2)
|
||||
ALIN(IFB,2)=YCLIN(J,2)
|
||||
IUSED(J)=1
|
||||
ELSEIF(XCLIN(J,2) .EQ. ALIN(IFB,1) .AND. YCLIN(J,2) .EQ. ALIN(IFB,2)) THEN
|
||||
IFB=IFB-1
|
||||
ALIN(IFB,1)=XCLIN(J,1)
|
||||
ALIN(IFB,2)=YCLIN(J,1)
|
||||
IUSED(J)=1
|
||||
ENDIF
|
||||
IF(IUSED(J) .EQ. 1) GO TO 200
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
! No new points found line must be complete
|
||||
! Check for loops
|
||||
! First end points
|
||||
|
||||
250 CONTINUE
|
||||
! IF((ALIN(IFB,1) .EQ. ALIN(IFW,1)) .AND. (ALIN(IFB,2) .EQ. ALIN(IFW,2))) THEN
|
||||
! IFB=IFB+1
|
||||
! IF(IFB .EQ. IFW) GO TO 300
|
||||
! GO TO 250
|
||||
! ENDIF
|
||||
NLIN=NLIN+1
|
||||
LINTYP(NLIN)=3
|
||||
IF(IMP .EQ. 0) IMP=9
|
||||
N=0
|
||||
IF(MAXPTS .EQ. MAXPL) MAXPTS=0
|
||||
IF(MAXPTS .GT. 0) THEN
|
||||
MAXPTS=MAXPTS+1
|
||||
CMAP(MAXPTS,1) = VOID
|
||||
CMAP(MAXPTS,2) = VOID
|
||||
XMAP(MAXPTS) = VOID
|
||||
YMAP(MAXPTS) = VOID
|
||||
! WRITE(198,'(I5,3F15.6)') MAXPTS,XMAP(MAXPTS),YMAP(MAXPTS),VAL(MAXPTS)
|
||||
ENDIF
|
||||
A1= VOID
|
||||
A2= VOID
|
||||
DO J=IFB,IFW
|
||||
IF(ALIN(J,1) .EQ. A1 .AND. ALIN(J,2) .EQ. A2) GO TO 275
|
||||
MAXPTS=MAXPTS+1
|
||||
! Check for double points
|
||||
XMAP(MAXPTS) = ALIN(J,1)
|
||||
YMAP(MAXPTS) = ALIN(J,2)
|
||||
VAL(MAXPTS) = CVAL
|
||||
CMAP(MAXPTS,1)=(XMAP(MAXPTS)+XS)/TXSCAL
|
||||
CMAP(MAXPTS,2)=(YMAP(MAXPTS)+YS)/TXSCAL
|
||||
|
||||
! WRITE(198,'(I5,3F15.6)') MAXPTS,XMAP(MAXPTS),YMAP(MAXPTS),VAL(MAXPTS)
|
||||
275 CONTINUE
|
||||
ENDDO
|
||||
300 CONTINUE
|
||||
ENDIF
|
||||
|
||||
! Copy values into contour line array
|
||||
|
||||
ENDDO
|
||||
klint=nlin
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 246 B |
@ -0,0 +1,452 @@
|
||||
!IPK LAST UPDATE SEP 23 2015 ADD OPTION FOR JOINING ELEMENTS
|
||||
subroutine joinel
|
||||
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
use blkmap
|
||||
INTEGER LIST1(1000),LIST2(1000),idel(1000)
|
||||
real xmapt(1000),ymapt(1000)
|
||||
|
||||
|
||||
CHARACTER*1 IFLAG,ANSW(10)
|
||||
CHARACTER*60 STRELS
|
||||
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
|
||||
|
||||
DATA STRELS/' You have tried to join before executing "FILL"'/
|
||||
!
|
||||
!
|
||||
! Test to make sure fill has been executed.
|
||||
!
|
||||
DO N=1,NE
|
||||
IF(IMAT(N) .GT. 0) THEN
|
||||
DO M=2,NCORN(N),2
|
||||
!ipkoct93
|
||||
if(imat(n) .LT. 900) THEN
|
||||
IF(NOP(N,M) .EQ. 0) THEN
|
||||
CALL SYMBL(0.,7.30,0.20,STRELS,0.,60)
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
! Initiliaze list etc
|
||||
|
||||
NHTPSV=NHTP
|
||||
NMESSSV=NMESS
|
||||
NBRRSV=NBRR
|
||||
|
||||
! get starting elements
|
||||
CALL KCON(0)
|
||||
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=0
|
||||
list1=0
|
||||
list2=0
|
||||
! SELECT FIRST ELEMENT
|
||||
10 CONTINUE
|
||||
CALL PANELTYP(NMTYP)
|
||||
NHTP=0
|
||||
NMESS=20
|
||||
NBRR=8
|
||||
CALL HEDR
|
||||
|
||||
CALL PROX(XC,YC,NE,XX,YY,NEL1,IFLAG,IESKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
CALL fillem(NEL1)
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
CALL PROX(XC,YC,NE,XX,YY,NEL2,IFLAG,IESKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
CALL fillem(NEL1)
|
||||
CALL fillem(NEL2)
|
||||
|
||||
CALL PROX(XC,YC,NE,XX,YY,NEL3,IFLAG,IESKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
CALL fillem(NEL1)
|
||||
CALL fillem(NEL2)
|
||||
CALL fillem(NEL3)
|
||||
CALL PROX(XC,YC,NE,XX,YY,NEL4,IFLAG,IESKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
CALL fillem(NEL1)
|
||||
CALL fillem(NEL2)
|
||||
CALL fillem(NEL3)
|
||||
CALL fillem(NEL4)
|
||||
|
||||
! work on first pair
|
||||
! get starting mid-side
|
||||
ilc=0
|
||||
call findbcel(nel1,nd1,nd2,nd3,ierr,ilc)
|
||||
! save back node
|
||||
list1(1)=nd1
|
||||
write(90,*) '1',nd1
|
||||
|
||||
! get adjacent corner save corner
|
||||
m=2
|
||||
list1(m)=nd3
|
||||
write(90,*) m,nd3
|
||||
nelc=nel1
|
||||
nelcsv=nel1
|
||||
! start looop
|
||||
do nss=1,1000
|
||||
! find next element and get mid side
|
||||
nadj=ndelm(nd3)
|
||||
do kkk=1,nadj
|
||||
nd3=list1(m)
|
||||
nelc=nelcsv
|
||||
if(necon(nd3,kkk) .ne. nelc) then
|
||||
nelc=necon(nd3,kkk)
|
||||
ilc=2
|
||||
call findbcel(nelc,nd1,nd2,nd3,ierr,ilc)
|
||||
if(ierr .eq. 0) go to 200
|
||||
endif
|
||||
enddo
|
||||
200 continue
|
||||
nelcsv=nelc
|
||||
! get and save next corner
|
||||
m=m+1
|
||||
if(m .gt. 1000) THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
list1(m)=nd3
|
||||
write(90,*) m,nd3
|
||||
! test for last element
|
||||
if(nelc .eq. nel2) go to 250
|
||||
enddo
|
||||
250 continue
|
||||
m1=m
|
||||
|
||||
! repeat for second pair
|
||||
! get starting mid-side
|
||||
ilc=1
|
||||
call findbcel(nel3,nd1,nd2,nd3,ierr,ilc)
|
||||
! save back node
|
||||
list2(1)=nd1
|
||||
write(90,*) m,nd1
|
||||
|
||||
! get adjacent corner save corner
|
||||
m=2
|
||||
list2(m)=nd3
|
||||
write(90,*) m,nd3
|
||||
nelc=nel3
|
||||
nelcsv=nel3
|
||||
! start looop
|
||||
do nss=1,1000
|
||||
! find next element and get mid side
|
||||
nadj=ndelm(nd3)
|
||||
do kkk=1,nadj
|
||||
nd3=list2(m)
|
||||
nelc=nelcsv
|
||||
if(necon(nd3,kkk) .ne. nelc) then
|
||||
nelc=necon(nd3,kkk)
|
||||
ilc=2
|
||||
if(nelc .eq. nel4) ilc=4
|
||||
call findbcel(nelc,nd1,nd2,nd3,ierr,ilc)
|
||||
if(ierr .eq. 0) go to 300
|
||||
|
||||
endif
|
||||
enddo
|
||||
300 continue
|
||||
nelcsv=nelc
|
||||
! get and save next corner
|
||||
m=m+1
|
||||
if(m .gt. 1000) THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
ENDIF
|
||||
list2(m)=nd3
|
||||
write(90,*) m,nd3
|
||||
! test for last element
|
||||
if(nelc .eq. nel4) go to 350
|
||||
enddo
|
||||
350 continue
|
||||
m2=m
|
||||
! add points in triangle list
|
||||
do j=1,m2
|
||||
list1(m1+j)=list2(j)
|
||||
enddo
|
||||
nvert=m1+m2
|
||||
do n=1,nvert
|
||||
write(90,*) n,list1(n)
|
||||
enddo
|
||||
do j=1,nvert
|
||||
xmap(j)=xusr(list1(j))
|
||||
ymap(j)=yusr(list1(j))
|
||||
xmapt(j)=xusr(list1(j))
|
||||
ymapt(j)=yusr(list1(j))
|
||||
imap(j)=1
|
||||
val(j)=1.
|
||||
enddo
|
||||
! call for triangulation
|
||||
|
||||
CALL DELAUNAY(NVERT)
|
||||
|
||||
do n=1,nelts
|
||||
if(nopel(n,1) .le. m1) then
|
||||
if(nopel(n,2) .le. m1 .and. nopel(n,3) .le. m1) then
|
||||
cycle
|
||||
endif
|
||||
else
|
||||
if(nopel(n,2) .gt. m1 .and. nopel(n,3) .gt. m1) then
|
||||
cycle
|
||||
endif
|
||||
500 continue
|
||||
endif
|
||||
! FORM A NEW ELEMENT ASSIGN TYPE AS INDICATED
|
||||
CALL GETELM(J)
|
||||
NOP(J,1)=list1(nopel(n,1))
|
||||
NOP(J,3)=list1(nopel(n,2))
|
||||
NOP(J,5)=list1(nopel(n,3))
|
||||
NOP(J,2)=0
|
||||
NOP(J,4)=0
|
||||
NOP(J,6)=0
|
||||
NOP(J,7)=0
|
||||
NOP(J,8)=0
|
||||
IMAT(J)=NMTYP
|
||||
IESKP(J) = 0
|
||||
NCORN(J)=6
|
||||
enddo
|
||||
CALL PLOTOT(1)
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
|
||||
CALL HEDR
|
||||
return
|
||||
end
|
||||
|
||||
subroutine findbcel(nel,nd1,nd2,nd3,ierr,ilc)
|
||||
use blk1mod
|
||||
USE BLK2MOD
|
||||
integer nel,nd1,nd2,nd3,mlc(5),ndkp
|
||||
ndkp=nd3
|
||||
ierr=0
|
||||
kk=0
|
||||
do k=2,ncorn(nel),2
|
||||
nd2=nop(nel,k)
|
||||
if(ndelm(nd2) .eq. 1) then
|
||||
nd1=nop(nel,k-1)
|
||||
if(nd1 .ne. ndkp .and. ilc .gt. 1) cycle
|
||||
jj=mod(k,ncorn(nel))+1
|
||||
nd3=nop(nel,jj)
|
||||
if(ilc .eq. 4) return
|
||||
if(ilc .gt. 0) then
|
||||
kk=kk+1
|
||||
mlc(kk)=k
|
||||
cycle
|
||||
else
|
||||
! check for more than 1
|
||||
kj=k+2
|
||||
if(kj .gt. ncorn(nel)) kj=2
|
||||
nd2a=nop(nel,kj)
|
||||
if(ndelm(nd2a) .eq. 1) then
|
||||
nd1=nop(nel,kj-1)
|
||||
jj=mod(kj,ncorn(nel))+1
|
||||
nd3=nop(nel,jj)
|
||||
nd2=nd2a
|
||||
endif
|
||||
return
|
||||
endif
|
||||
|
||||
endif
|
||||
enddo
|
||||
if(ilc .gt. 0) then
|
||||
if(kk .eq. 1) then
|
||||
if(nd1 .eq. ndkp) then
|
||||
return
|
||||
else
|
||||
ierr=1
|
||||
return
|
||||
endif
|
||||
elseif(kk .eq. 2) then
|
||||
if(abs(mlc(2)-mlc(1)) .eq. 4) then
|
||||
do kk=1,2
|
||||
nd1=nop(nel,mlc(kk)-1)
|
||||
if(nd1 .eq. ndkp) then
|
||||
nd2=nop(nel,mlc(kk))
|
||||
nd3=mod(mlc(kk),ncorn(nel))+1
|
||||
nd3=nop(nel,nd3)
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
endif
|
||||
if(ilc .eq. 1) then
|
||||
if(mlc(kk) .eq. ncorn(nel) .and. mlc(kk-1) .eq. 2) then
|
||||
nd1=nop(nel,1)
|
||||
nd2=nop(nel,2)
|
||||
nd3=nop(nel,3)
|
||||
else
|
||||
return
|
||||
endif
|
||||
else
|
||||
if(mlc(kk) .eq. ncorn(nel) .and. mlc(kk-1) .eq. 2) then
|
||||
return
|
||||
else
|
||||
nd1=nop(nel,mlc(1)-1)
|
||||
nd2=nop(nel,mlc(1))
|
||||
nd3=nop(nel,mlc(1)+1)
|
||||
endif
|
||||
endif
|
||||
elseif(kk .eq. 3) then
|
||||
if(mlc(kk) .eq. ncorn(nel)) then
|
||||
if(mlc(kk-1) .eq. ncorn(nel)-2) then
|
||||
nd1=nop(nel,1)
|
||||
nd2=nop(nel,2)
|
||||
nd3=nop(nel,3)
|
||||
elseif(mlc(kk-1) .eq. ncorn(nel)-4) then
|
||||
nd1=nop(nel,3)
|
||||
nd2=nop(nel,4)
|
||||
nd3=nop(nel,5)
|
||||
else
|
||||
return
|
||||
endif
|
||||
else
|
||||
return
|
||||
endif
|
||||
endif
|
||||
! else
|
||||
! return
|
||||
endif
|
||||
ierr=1
|
||||
return
|
||||
end
|
||||
|
||||
SUBROUTINE PANELTYP(N1)
|
||||
|
||||
! Choose options and intervals
|
||||
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'D.inc'
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
integer :: N1,itime,IERR
|
||||
data itime/0/
|
||||
|
||||
if(itime .eq. 0) then
|
||||
n1=1
|
||||
itime=1
|
||||
endif
|
||||
|
||||
call wdialogload(IDD_MATTYP)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(idf_integer1,N1)
|
||||
|
||||
CALL WDialogSelect(IDD_MATTYP)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WDialogGetInteger(idf_integer1,N1)
|
||||
ELSE
|
||||
N1=1
|
||||
RETURN
|
||||
|
||||
ENDIF
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,69 @@
|
||||
Subroutine LayDisp
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
!
|
||||
include 'd.inc'
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
!
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
INTEGER :: INODE,IBOX,NN
|
||||
INTEGER :: IERR
|
||||
CHARACTER*1 :: IFLAG
|
||||
|
||||
DATA INODE/1/
|
||||
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select node','CHOOSE NODE')
|
||||
IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
|
||||
100 continue
|
||||
call wdialogload(IDD_LAY)
|
||||
ierr=infoerror(1)
|
||||
|
||||
|
||||
IF(ILAYTP .EQ. 1) THEN
|
||||
call wdialogputRadioButton(idf_radio1)
|
||||
ELSE
|
||||
call wdialogputRadioButton(idf_radio2)
|
||||
ENDIF
|
||||
lno=lay(INODE)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER1,lno)
|
||||
do i=1,7
|
||||
CALL WGridPutCellReal(IDF_GRID1,i,1,wtlay(INODE,i))
|
||||
enddo
|
||||
|
||||
|
||||
CALL WDialogSelect(IDD_LAY)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
call wdialoggetradiobutton(idf_radio1,ilaytp)
|
||||
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER1,lno)
|
||||
lay(INODE)=lno
|
||||
do i=1,7
|
||||
CALL WGridGetCellReal(IDF_GRID1,i,1,wtlay(INODE,i))
|
||||
enddo
|
||||
return
|
||||
ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
RETURN
|
||||
endif
|
||||
!IPK SEP02
|
||||
return
|
||||
enddo
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,50 @@
|
||||
SUBROUTINE LEVSETTYP
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
include 'd.inc'
|
||||
|
||||
CHARACTER*47 MESSAGE
|
||||
|
||||
DATA ITIME/0/
|
||||
IMATTYP=1
|
||||
BLELVEL=0.
|
||||
|
||||
call wdialogload(IDD_LEVSETTYP)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_LEVSETTYP)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutReal(IDF_REAL1,BLEVEL)
|
||||
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,IMATTYP)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
! Branch depending on type of message.
|
||||
!
|
||||
DO
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,IMATTYP)
|
||||
CALL WDialogGetReal(IDF_REAL1,BLEVEL)
|
||||
GO TO 200
|
||||
ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
RETURN
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
200 CONTINUE
|
||||
|
||||
DO N=1,NE
|
||||
IF(IMAT(N) .EQ. 99) CYCLE
|
||||
DO K=1,NCORN(N)
|
||||
IF(NOP(N,K) .EQ. 0) CYCLE
|
||||
IF(WD(NOP(N,K)) .LT. BLEVEL) GO TO 300
|
||||
ENDDO
|
||||
IMAT(N)=IMATTYP
|
||||
300 CONTINUE
|
||||
ENDDO
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,23 @@
|
||||
SUBROUTINE LOADFIL
|
||||
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
|
||||
IFILOUT=IACTVFIL+50
|
||||
|
||||
! Zero out current arrays
|
||||
|
||||
CALL ZEROOUT
|
||||
|
||||
IFNUM=IACTVFIL+50
|
||||
WRITE(90,*) 'IN LOADFIL IFNUM',IFNUM
|
||||
CALL RDRST(1,IFNUM)
|
||||
CALL RDRST(2,IFNUM)
|
||||
CALL RDRST(3,IFNUM)
|
||||
REWIND IFNUM
|
||||
|
||||
CALL RESCAL
|
||||
CALL HEDR
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,102 @@
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// THIS FILE SHOULD NOT BE EDITED USING A TEXT
|
||||
// EDITOR OR 3RD PARTY RESOURCE EDITOR, EXCEPT
|
||||
// WHEN SPECIFICALLY INSTRUCTED BY I.S.S.
|
||||
//
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Winteracter exported resources.
|
||||
//
|
||||
// Exported : 25/Feb/2017 14:50:26
|
||||
//
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// To use this file it should be imported into
|
||||
// your main resource script
|
||||
//
|
||||
///////////////////////////////////////////////////
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Parameter Definitions
|
||||
//
|
||||
#define IDF_LABEL1 1001
|
||||
#define IDF_LABEL2 1002
|
||||
#define IDF_GROUP1 1016
|
||||
#define IDF_LABEL9 1017
|
||||
#define IDF_LABEL11 1019
|
||||
#define IDD_TEMPLATE001 107
|
||||
#define IDF_GRID1 1032
|
||||
#define ISS1 1033
|
||||
#define IDF_APPLY 1039
|
||||
#define IDD_MATERIALS 109
|
||||
#define IDF_COLOUR 1005
|
||||
#define ISS2 1034
|
||||
#define IDF_SHINE 1007
|
||||
#define IDF_GLOSS 1008
|
||||
#define IDF_SHINE2 1009
|
||||
#define IDF_GLOSS2 1010
|
||||
#define IDF_RED 1035
|
||||
#define IDF_GREEN 1036
|
||||
#define IDF_BLUE 1038
|
||||
#define IDF_LABEL8 1040
|
||||
|
||||
///////////////////////////////////////////////////
|
||||
//
|
||||
// Dialogs
|
||||
//
|
||||
IDD_MATERIALS DIALOG 0, 0, 270, 96
|
||||
STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME
|
||||
FONT 8, "MS Sans Serif"
|
||||
CAPTION "Materials"
|
||||
BEGIN
|
||||
CONTROL "&Shine",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 115, 34, 20, 8
|
||||
CONTROL "0.00",IDF_SHINE2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER | SS_SUNKEN, 243, 32, 18, 14
|
||||
CONTROL "&Gloss",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 115, 52, 20, 8
|
||||
CONTROL "0.00",IDF_GLOSS2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER | SS_SUNKEN, 243, 50, 18, 14
|
||||
CONTROL "Current Material",IDF_GROUP1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | BS_GROUPBOX | BS_TEXT, 111, 2, 155, 65
|
||||
CONTROL "",IDF_GRID1,"ISSGRID",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_VSCROLL | WS_HSCROLL | WS_GROUP | WS_TABSTOP | GS_READONLYCOLOUR | GS_DEFROWLABELS | GS_COLUMNLABELS, 9, 5, 97, 86
|
||||
CONTROL "&Colour",IDF_COLOUR,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 115, 14, 32, 14
|
||||
CONTROL "0",IDF_SHINE,"MSCTLS_TRACKBAR32",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | TBS_AUTOTICKS, 139, 32, 100, 12
|
||||
CONTROL "0",IDF_GLOSS,"MSCTLS_TRACKBAR32",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | TBS_AUTOTICKS, 139, 50, 100, 12
|
||||
CONTROL "&Apply",IDF_APPLY,"BUTTON",WS_CHILD | WS_VISIBLE | WS_DISABLED | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 113, 76, 34, 14
|
||||
CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 153, 76, 34, 14
|
||||
CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 193, 76, 34, 14
|
||||
CONTROL "",IDF_RED,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER | SS_SUNKEN, 162, 16, 20, 10
|
||||
CONTROL "",IDF_GREEN,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER | SS_SUNKEN, 200, 16, 20, 10
|
||||
CONTROL "",IDF_BLUE,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER | SS_SUNKEN, 240, 16, 20, 10
|
||||
CONTROL "R",IDF_LABEL8,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 153, 17, 8, 8
|
||||
CONTROL "G",IDF_LABEL9,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 190, 17, 8, 8
|
||||
CONTROL "B",IDF_LABEL11,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 229, 17, 8, 8
|
||||
CONTROL "Help",IDHELP,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 232, 76, 34, 14
|
||||
END
|
||||
|
||||
IDD_MATERIALS RCDATA
|
||||
BEGIN
|
||||
"[Ranges] \n"
|
||||
" 1007 0 100 \n"
|
||||
" 1008 0 100 \n"
|
||||
"[Trackbars] \n"
|
||||
" 1007 10 1 10 0 0 \n"
|
||||
" 1008 10 1 10 0 0 \n"
|
||||
"[Grids] \n"
|
||||
" 1032 2 500 107 \n"
|
||||
,0
|
||||
END
|
||||
|
||||
IDD_TEMPLATE001 DIALOG 0, 0, 1000, 16
|
||||
STYLE DS_3DLOOK
|
||||
FONT 8, "MS Sans Serif"
|
||||
BEGIN
|
||||
CONTROL "Material",ISS1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_READONLY, 0, 0, 40, 14
|
||||
CONTROL "Modify",ISS2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT | BS_PUSHLIKE, 0, 0, 40, 14
|
||||
END
|
||||
|
||||
IDD_TEMPLATE001 RCDATA
|
||||
BEGIN
|
||||
"[Checks] \n"
|
||||
" 1034 0 \n"
|
||||
,0
|
||||
END
|
||||
|
||||
@ -0,0 +1,99 @@
|
||||
!IPK LAST UPDATE SEP 23 2015 ADD NEW FORMAT TO 6 DEC
|
||||
Subroutine MMap
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
CALL OPENMP
|
||||
|
||||
CALL SVELEM(IYES)
|
||||
|
||||
rewind 99
|
||||
|
||||
! if IYES .eq. 1 save as an element format
|
||||
|
||||
valmap=0.
|
||||
mapno=2
|
||||
IF(IYES .EQ. 1) THEN
|
||||
do n=1,ne
|
||||
write(99,6001)
|
||||
6001 format(' 3,9999.')
|
||||
if(imat(n) .gt. 0) then
|
||||
ncn=ncorn(n)
|
||||
do m=1,ncn
|
||||
j=nop(n,m)
|
||||
if(j .gt. 0) then
|
||||
write(99,'(3f16.3)') xusr(j),yusr(j),wd(j)
|
||||
endif
|
||||
enddo
|
||||
j=nop(n,1)
|
||||
if(j .gt. 0) then
|
||||
write(99,'(3f16.3)') xusr(j),yusr(j),wd(j)
|
||||
endif
|
||||
endif
|
||||
write(99,6000)
|
||||
6000 format('END')
|
||||
enddo
|
||||
|
||||
! if IYES .eq. 0 save as a nodal list
|
||||
|
||||
|
||||
ELSE
|
||||
write(99,6002)
|
||||
6002 format(' 2,0')
|
||||
do j=1,np
|
||||
if(inew(j) .eq. 1) then
|
||||
write(99,'(3f16.6)') xusr(j),yusr(j),wd(j)
|
||||
endif
|
||||
enddo
|
||||
write(99,6000)
|
||||
ENDIF
|
||||
write(99,6000)
|
||||
close (99)
|
||||
return
|
||||
end
|
||||
|
||||
subroutine openmp
|
||||
|
||||
use winteracter
|
||||
|
||||
implicit none
|
||||
|
||||
include 'd.inc'
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=3) :: SUB
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
CALL WSelectFile(ID_STRING7,SaveDialog+PromptOn,FNAME,'Save Network as Mapfile')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='map'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
open(99,file=fname, form='formatted', status='unknown')
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE SVELEM(IYES)
|
||||
|
||||
USE WINTERACTER
|
||||
|
||||
INCLUDE 'D.INC'
|
||||
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save element layout?'//&
|
||||
CHAR(13)//' ','Map option')
|
||||
!
|
||||
! If answer 'No', return
|
||||
!
|
||||
iyes=1
|
||||
IF (WInfoDialog(4).EQ.2) iyes=0
|
||||
return
|
||||
end
|
||||
|
||||
@ -0,0 +1,386 @@
|
||||
SUBROUTINE MOVMESH
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
|
||||
SAVE
|
||||
|
||||
! implicit none
|
||||
|
||||
include 'd.inc'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
CHARACTER*1 IFLAG
|
||||
REAL xlocorg,ylocorg,xlocscl,ylocscl,XREFPT,YREFPT,xlocs,ylocs,xlocf,ylocf,stscalx,stscaly,xtest,ytest
|
||||
INTEGER NTYPR,ITIMETHRU
|
||||
|
||||
allocatable xusrt(:),yusrt(:),xcrst(:),ycrst(:)
|
||||
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
DATA ITIMTHRU/0/,NTYPR/1/,xlocorg/0./,ylocorg/0./,xlocscl/0./,ylocscl/0./
|
||||
|
||||
call wdialogload(IDD_DIALOG048)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_DIALOG048)
|
||||
ierr=infoerror(1)
|
||||
|
||||
IF(NTYPR .EQ. 1) THEN
|
||||
call wdialogputRadioButton(idf_radio1)
|
||||
ELSE
|
||||
call wdialogputRadioButton(idf_radio2)
|
||||
ENDIF
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
!
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
call wdialoggetradiobutton(idf_radio1,ntypr)
|
||||
go to 100
|
||||
|
||||
elseif(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
return
|
||||
ENDIF
|
||||
|
||||
enddo
|
||||
|
||||
100 continue
|
||||
|
||||
IF(NTYPR .EQ. 1) THEN
|
||||
|
||||
call wdialogload(IDD_DIALOG047)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_DIALOG047)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutReal(IDF_REAL1,xlocorg)
|
||||
CALL WDialogPutReal(IDF_REAL2,ylocorg)
|
||||
CALL WDialogPutReal(IDF_REAL3,xlocscl)
|
||||
CALL WDialogPutReal(IDF_REAL4,ylocscl)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
CALL WDialogGetReal(IDF_REAL1,xlocorg)
|
||||
CALL WDialogGetReal(IDF_REAL2,ylocorg)
|
||||
CALL WDialogGetReal(IDF_REAL3,xlocscl)
|
||||
CALL WDialoggetReal(IDF_REAL4,ylocscl)
|
||||
|
||||
allocate (xusrt(np),yusrt(np))
|
||||
|
||||
if(xlocscl .eq. 0.) then
|
||||
do j=1,np
|
||||
xusrt(j)=xusr(j)
|
||||
yusrt(j)=yusr(j)
|
||||
xusr(j)=xusr(j)+xlocorg
|
||||
yusr(j)=yusr(j)+ylocorg
|
||||
CORD(J,1)=(XUSR(J)+XS)/TXSCAL
|
||||
CORD(J,2)=(YUSR(J)+YS)/TXSCAL
|
||||
enddo
|
||||
if(ncrsec .gt. 0) then
|
||||
allocate (xcrst(nrsec),ycrst(nrsec))
|
||||
do j=1,ncrsec
|
||||
xcrst(j)=xcrs(j)
|
||||
ycrst(j)=ycrs(j)
|
||||
xcrs(j)=xcrs(j)+xlocorg
|
||||
ycrs(j)=ycrs(j)+ylocorg
|
||||
enddo
|
||||
endif
|
||||
else
|
||||
do j=1,np
|
||||
xusr(j)=(xusr(j)-xlocorg)*xlocscl
|
||||
yusr(j)=(yusr(j)-ylocorg)*ylocscl
|
||||
CORD(J,1)=(XUSR(J)+XS)/TXSCAL
|
||||
CORD(J,2)=(YUSR(J)+YS)/TXSCAL
|
||||
enddo
|
||||
if(ncrsec .gt. 0) then
|
||||
allocate (xcrst(nrsec),ycrst(nrsec))
|
||||
do j=1,ncrsec
|
||||
xcrst(j)=xcrs(j)
|
||||
ycrst(j)=ycrs(j)
|
||||
xcrs(j)=(xcrs(j)-xlocorg)*xlocscl
|
||||
ycrs(j)=(ycrs(j)-ylocorg)*ylocscl
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
|
||||
go to 300
|
||||
|
||||
elseif(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
return
|
||||
endif
|
||||
enddo
|
||||
|
||||
else
|
||||
|
||||
! get reference point
|
||||
! xrefpt
|
||||
! yrefpt
|
||||
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select Fixed Reference point','CHOOSE REFERENCE')
|
||||
CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX)
|
||||
XREFPT = XTEMP*TXSCAL - XS
|
||||
YREFPT = YTEMP*TXSCAL - YS
|
||||
|
||||
! get start move point
|
||||
! xlocs
|
||||
! ylocs
|
||||
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select Starting point','CHOOSE START')
|
||||
CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX)
|
||||
XLOCS = XTEMP*TXSCAL - XS
|
||||
YLOCS = YTEMP*TXSCAL - YS
|
||||
|
||||
! get finish move point
|
||||
! xlocf
|
||||
! ylocf
|
||||
|
||||
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select Finishing point','CHOOSE FINISH')
|
||||
CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX)
|
||||
XLOCF = XTEMP*TXSCAL - XS
|
||||
YLOCF = YTEMP*TXSCAL - YS
|
||||
|
||||
! establish x moves
|
||||
stscalx=(xlocf-xrefpt)/(xlocs-xrefpt)
|
||||
|
||||
! establish y moves
|
||||
stscaly=(ylocf-yrefpt)/(ylocs-yrefpt)
|
||||
|
||||
allocate (xusrt(np),yusrt(np))
|
||||
do j=1,np
|
||||
xusrt(j)=xusr(j)
|
||||
yusrt(j)=yusr(j)
|
||||
xusr(j)=xrefpt-(xrefpt-xusr(j))*stscalx
|
||||
yusr(j)=yrefpt-(yrefpt-yusr(j))*stscaly
|
||||
CORD(J,1)=(XUSR(J)+XS)/TXSCAL
|
||||
CORD(J,2)=(YUSR(J)+YS)/TXSCAL
|
||||
enddo
|
||||
if(ncrsec .gt. 0) then
|
||||
allocate (xcrst(nrsec),ycrst(nrsec))
|
||||
do j=1,ncrsec
|
||||
xcrst(j)=xcrs(j)
|
||||
ycrst(j)=ycrs(j)
|
||||
xcrs(j)=xrefpt-(xrefpt-xcrs(j))*stscalx
|
||||
ycrs(j)=yrefpt-(yrefpt-ycrs(j))*stscaly
|
||||
enddo
|
||||
endif
|
||||
|
||||
endif
|
||||
|
||||
300 continue
|
||||
CALL CLSCRN
|
||||
CALL PLOTOT(1)
|
||||
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to keep '//&
|
||||
CHAR(13)//' ','new locations?')
|
||||
!
|
||||
! If answer 'No', reset
|
||||
!
|
||||
IF (WInfoDialog(4).EQ.2) then
|
||||
do j=1,np
|
||||
xusr(j)=xusrt(j)
|
||||
yusr(j)=yusrt(j)
|
||||
CORD(J,1)=(XUSR(J)+XS)/TXSCAL
|
||||
CORD(J,2)=(YUSR(J)+YS)/TXSCAL
|
||||
enddo
|
||||
if(ncrsec .gt. 0) then
|
||||
do j=1,ncrsec
|
||||
xcrs(j)=xcrst(j)
|
||||
ycrs(j)=ycrst(j)
|
||||
enddo
|
||||
deallocate (xcrst,ycrst)
|
||||
endif
|
||||
CALL CLSCRN
|
||||
CALL PLOTOT(1)
|
||||
endif
|
||||
|
||||
deallocate(xusrt,yusrt)
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE TRANSMESH
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
|
||||
SAVE
|
||||
|
||||
! implicit none
|
||||
|
||||
include 'd.inc'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
CHARACTER*1 IFLAG
|
||||
allocatable xusrt(:),yusrt(:),xcrst(:),ycrst(:)
|
||||
data iopt1/1/
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
call wdialogload(IDD_TRANSFORM)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogSelect(IDD_TRANSFORM)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER1,IOPT1)
|
||||
|
||||
CALL WDialogPutReal(IDF_REAL3,COEF1)
|
||||
CALL WDialogPutReal(IDF_REAL4,COEF2)
|
||||
CALL WDialogPutReal(IDF_REAL5,COEF3)
|
||||
CALL WDialogPutReal(IDF_REAL6,COEF4)
|
||||
CALL WDialogPutReal(IDF_REAL7,COEF5)
|
||||
CALL WDialogPutReal(IDF_REAL8,COEF6)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER2,ICOEF1)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER3,ICOEF2)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER4,ICOEF3)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER5,ICOEF4)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER9,ICOEF5)
|
||||
CALL WDialogPutINTEGER(IDF_INTEGER10,ICOEF6)
|
||||
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER1,IOPT1)
|
||||
CALL WDialogGetReal(IDF_REAL3,COEF1)
|
||||
CALL WDialogGetReal(IDF_REAL4,COEF2)
|
||||
CALL WDialogGetReal(IDF_REAL5,COEF3)
|
||||
CALL WDialoggetReal(IDF_REAL6,COEF4)
|
||||
CALL WDialoggetReal(IDF_REAL7,COEF5)
|
||||
CALL WDialoggetReal(IDF_REAL8,COEF6)
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER2,ICOEF1)
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER3,ICOEF2)
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER4,ICOEF3)
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER5,ICOEF4)
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER9,ICOEF5)
|
||||
CALL WDialogGetINTEGER(IDF_INTEGER10,ICOEF6)
|
||||
go to 200
|
||||
elseif(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||||
return
|
||||
ENDIF
|
||||
|
||||
enddo
|
||||
200 continue
|
||||
if(.not. allocated(xusrt)) then
|
||||
allocate (xusrt(np),yusrt(np))
|
||||
|
||||
do j=1,np
|
||||
xusrt(j)=xusr(j)
|
||||
yusrt(j)=yusr(j)
|
||||
enddo
|
||||
if(ncrsec .gt. 0) then
|
||||
allocate (xcrst(nrsec),ycrst(nrsec))
|
||||
do j=1,ncrsec
|
||||
xcrst(j)=xcrs(j)
|
||||
ycrst(j)=ycrs(j)
|
||||
enddo
|
||||
endif
|
||||
endif
|
||||
IF(IOPT1 .EQ. 1) THEN
|
||||
DO J=1,NP
|
||||
XUSR(J)=COEF1*XUSR(J)+COEF2
|
||||
YUSR(J)=COEF3*YUSR(J)+COEF4
|
||||
CORD(J,1)=(XUSR(J)+XS)/TXSCAL
|
||||
CORD(J,2)=(YUSR(J)+YS)/TXSCAL
|
||||
IF(COEF5 .EQ. 0. .AND. COEF6 .EQ. 0.) CYCLE
|
||||
WD(J)=COEF5*WD(J)+COEF6
|
||||
ENDDO
|
||||
if(ncrsec .gt. 0) then
|
||||
do j=1,ncrsec
|
||||
xcrs(j)=coef1*XCRS(J)+COEF2
|
||||
ycrs(j)=coef3*YCRS(J)+COEF4
|
||||
enddo
|
||||
endif
|
||||
ELSE IF(IOPT1 .EQ. 2) THEN
|
||||
do j=1,np
|
||||
reff=coef3
|
||||
angl=(xusr(j)-coef1)/reff
|
||||
a=cos(angl)
|
||||
a=reff*cos(angl)
|
||||
b=reff*sin(angl)
|
||||
xusr(j)=reff*sin(angl)-(yusr(j)-coef2)*sin(angl)
|
||||
yusr(j)=(yusr(j)-coef2)*cos(angl)+reff*(1.-cos(angl))
|
||||
CORD(J,1)=(XUSR(J)+XS)/TXSCAL
|
||||
CORD(J,2)=(YUSR(J)+YS)/TXSCAL
|
||||
enddo
|
||||
if(ncrsec .gt. 0) then
|
||||
do j=1,ncrsec
|
||||
reff=coef3+coef2-ycrs(j)
|
||||
ang=(xcrs(j)-coef1)/reff
|
||||
xcrs(j)=coef1+reff*sin(angl)
|
||||
ycrs(j)=coef2+reff*cos(angl)
|
||||
enddo
|
||||
endif
|
||||
ELSEIF(IOPT1 .EQ. 3) THEN
|
||||
DO J=1,NP
|
||||
A=(XUSR(J)-COEF1)*COS(COEF3)-(YUSR(J)-COEF2)*SIN(COEF3)
|
||||
B=(XUSR(J)-COEF1)*SIN(COEF3)+(YUSR(J)-COEF2)*COS(COEF3)
|
||||
XUSR(J)=A
|
||||
YUSR(J)=B
|
||||
CORD(J,1)=(XUSR(J)+XS)/TXSCAL
|
||||
CORD(J,2)=(YUSR(J)+YS)/TXSCAL
|
||||
ENDDO
|
||||
if(ncrsec .gt. 0) then
|
||||
do j=1,ncrsec
|
||||
A=(XCRS(J)-COEF1)*COS(COEF3)-(YCRS(J)-COEF2)*SIN(COEF3)
|
||||
B=(XCRS(J)-COEF1)*SIN(COEF3)+(YCRS(J)-COEF2)*COS(COEF3)
|
||||
xcrs(j)=A
|
||||
ycrs(j)=B
|
||||
enddo
|
||||
endif
|
||||
ENDIF
|
||||
CALL CLSCRN
|
||||
CALL PLOTOT(1)
|
||||
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to keep '//&
|
||||
CHAR(13)//' ','new locations?')
|
||||
!
|
||||
! If answer 'No', reset
|
||||
!
|
||||
IF (WInfoDialog(4).EQ.2) then
|
||||
do j=1,np
|
||||
xusr(j)=xusrt(j)
|
||||
yusr(j)=yusrt(j)
|
||||
CORD(J,1)=(XUSR(J)+XS)/TXSCAL
|
||||
CORD(J,2)=(YUSR(J)+YS)/TXSCAL
|
||||
enddo
|
||||
deallocate (Xusrt,yusrt)
|
||||
if(ncrsec .gt. 0) then
|
||||
do j=1,ncrsec
|
||||
xcrs(j)=xcrst(j)
|
||||
ycrs(j)=ycrst(j)
|
||||
enddo
|
||||
deallocate (xcrst,ycrst)
|
||||
endif
|
||||
CALL CLSCRN
|
||||
CALL PLOTOT(1)
|
||||
endif
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,44 @@
|
||||
SUBROUTINE NDNECON(IERR)
|
||||
!
|
||||
! ESTABLISH ELEMENT CONNECTED TO ELEMENT TABLE
|
||||
!
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
!
|
||||
! INITIALIZE
|
||||
!
|
||||
ISWT=IERR
|
||||
NCM=MAXECON
|
||||
DO J=1,NCM
|
||||
DO N=1,NP
|
||||
NECON(N,J)=0
|
||||
ENDDO
|
||||
ENDDO
|
||||
DO N=1,NP
|
||||
NDELM(N)=0
|
||||
ENDDO
|
||||
!
|
||||
! FORM TABLE OF ELEMENTS CONNECTED TO EACH NODE
|
||||
!
|
||||
! IERR=0
|
||||
DO M=1,NE
|
||||
IF(IMAT(M) .NE. 0) THEN
|
||||
DO K=1,8
|
||||
IF(ISWT .EQ. 1 .AND. MOD(K,2) .EQ. 1) CYCLE
|
||||
N=NOP(M,K)
|
||||
IF (N .GT. 0) THEN
|
||||
NDELM(N)=NDELM(N)+1
|
||||
J=NDELM(N)
|
||||
IF(J .GT. MAXECON) THEN
|
||||
IERR=MAX(IERR,J)
|
||||
ELSE
|
||||
NECON(N,J)=M
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
END DO
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,949 @@
|
||||
!IPK LAST UPDATE SEP 23 2015 ADD MORE INFO ON FRAME
|
||||
!
|
||||
PROGRAM NEWRMAGEN
|
||||
!
|
||||
! Use of the module is compulsory
|
||||
!
|
||||
USE WINTERACTER
|
||||
USE DFLIB
|
||||
!
|
||||
IMPLICIT NONE
|
||||
!
|
||||
! Define some parameters to match those in the resource file
|
||||
!
|
||||
include 'd.inc'
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
REAL HSIZE,scratio
|
||||
COMMON /SSIZE/ HSIZE
|
||||
|
||||
!
|
||||
INTEGER :: IBASEV =40042
|
||||
INTEGER :: I,IRES,N2,M2,ID1,ID2
|
||||
INTEGER :: ITYPE, IX, IY, IWIDTH, IHEIGHT, KEY,IYES
|
||||
INTEGER :: MOUSEX, MOUSEY, MBUTTON, ITIME, IWINDOW
|
||||
INTEGER :: IDFIELDOLD, IDFIELDNEW, IDBUTN, IDFIELD,TOOLID(4)
|
||||
INTEGER :: LNNAM,K,LMPNAM,IMP,IIN,MENUS,IOT,IOT1,impf,IGFG,ITRIAN,INFO(3)
|
||||
INTEGER , DIMENSION(5) :: WIDSTAT
|
||||
INTEGER*2 :: N1,STATUS,lnnnam,iswtfl,n
|
||||
CHARACTER(LEN=255) :: FNAME,FNAMD,FILTER
|
||||
CHARACTER(LEN=3) :: SUB,SUB1
|
||||
CHARACTER(LEN=4) :: SUB2
|
||||
CHARACTER(LEN=1000) :: HEADR
|
||||
INTEGER ,EXTERNAL :: LENSTR
|
||||
LOGICAL :: OPENED,exists
|
||||
LOGICAL(4) :: statud
|
||||
REAL :: XX1,XX2,XX3,XX4,XX5,XX6
|
||||
INTEGER :: iw,ih,ihandle,ient,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
|
||||
common /hands/ ihandle,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
|
||||
|
||||
|
||||
INTEGER ISCRWID,ISCRHGT
|
||||
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
TYPE (WIN_FONT) :: FONT
|
||||
|
||||
! Define a common block with background file names
|
||||
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
! Get initial directory and add help name
|
||||
|
||||
fname = FILE$CURDRIVE
|
||||
IRES=GETDRIVEDIRQQ (fname)
|
||||
! lnnnam=windowstringlength(fname)
|
||||
lnnnam=lenstr(fname)
|
||||
direct=fname(1:lnnnam)//'\doc\rmagen83d.htm'
|
||||
|
||||
! write(128,*) fname,lnnnam,direct
|
||||
|
||||
!
|
||||
!
|
||||
! Initialise WiSK
|
||||
!
|
||||
CALL WInitialise()
|
||||
!
|
||||
! Create a root window with :
|
||||
! - System menu
|
||||
! - Minimise button
|
||||
! - Maximise button
|
||||
!
|
||||
! WINDOW%FLAGS = SysMenuOn + MinButton + MaxButton + StatusBar
|
||||
|
||||
ISCRWID = WInfoScreen(1) ! Get screen width
|
||||
ISCRHGT = WInfoScreen(2) ! Get screen height
|
||||
scratio=float(iscrwid)/float(iscrhgt)
|
||||
HSIZE=scratio*8.
|
||||
|
||||
!
|
||||
! Centre the window on the screen at 80% of screen size
|
||||
!
|
||||
WINDOW%X = -1
|
||||
WINDOW%Y = -1
|
||||
WINDOW%WIDTH = 0
|
||||
WINDOW%HEIGHT = 0
|
||||
!
|
||||
! Identify the menu to be attached to the window
|
||||
! and specify the initial window title
|
||||
!
|
||||
! WINDOW%MENUID = IDR_MENU1
|
||||
! WINDOW%TITLE = 'RMAGEN'
|
||||
!
|
||||
! Now open the root window
|
||||
!
|
||||
CALL WindowOpen(FLAGS =SysMenuOn+MinButton+MaxButton+StatusBar, &
|
||||
MENUID=IDR_MENU1, &
|
||||
TOOLID=(/0,ID_TOOLBAR1,0,0/), &
|
||||
TITLE ='RMAGEN')
|
||||
! CALL WindowOpen(WINDOW,TITLE ='RMAGEN') ! Open root window
|
||||
|
||||
!
|
||||
! Add a toolbar
|
||||
!
|
||||
! CALL WMenuToolbar(ID_TOOLBAR1)
|
||||
!
|
||||
! Main message loop
|
||||
!
|
||||
! initialise palette
|
||||
!
|
||||
CALL IGrPaletteInit
|
||||
!
|
||||
! set fill style to solid
|
||||
!
|
||||
CALL IGrFillPattern(Solid)
|
||||
|
||||
FONT%IBCOL = TextWhite
|
||||
CALL WindowFont(FONT)
|
||||
! CALL WindowClear(RGB=RGB_yellow) ! clear window to yellow
|
||||
! IRGB = WRGB(220,220,220)
|
||||
! IRGB = WRGB(191,191,191)
|
||||
IRGB = WRGB(227,227,227)
|
||||
CALL WindowClear(rgb=irgb) ! clear to yellow
|
||||
|
||||
WIDSTAT(1) = 1000
|
||||
WIDSTAT(2) = 2000
|
||||
WIDSTAT(3) = 1500
|
||||
WIDSTAT(4) = 1000
|
||||
WIDSTAT(5) = 2500
|
||||
CALL WindowStatusBarParts(5, WIDSTAT)
|
||||
CALL WindowOutStatusBar(1, ' X and Y location')
|
||||
CALL WindowOutStatusBar(4, ' Active File Name')
|
||||
CALL IgrUnits(0.,0.,HSIZE,8.0)
|
||||
|
||||
! IF(ISW .EQ. 1) THEN
|
||||
! CALL WMessageEnable(MouseMove , Enabled)
|
||||
! MENUS=-3
|
||||
! CALL RMAGEN(MENUS,IMP,IIN,1,IOT,IOT1,IGFG)
|
||||
! ENDIF
|
||||
|
||||
|
||||
! CALL WMenuSetState(ID_NETWD,ItemChecked,1)
|
||||
! DO I=1,12
|
||||
! CALL WMenuSetState(IBASEV+I,ItemChecked,1)
|
||||
! ENDDO
|
||||
IDDSW=-1
|
||||
IHANDLE=0
|
||||
IHAND1=0
|
||||
IHAND2=0
|
||||
N2=0
|
||||
M2=0
|
||||
TXSCAL = 1.
|
||||
XS=0.
|
||||
YS=0.
|
||||
NBKFL=0
|
||||
IRDONE=-1
|
||||
DO I=1,10
|
||||
ISWBKFL(I)=0
|
||||
ENDDO
|
||||
IACTVFIL=0
|
||||
ITOTFIL=0
|
||||
IOT=0
|
||||
IOT1=0
|
||||
IMP=0
|
||||
|
||||
CALL INITSIZ(IIN,N2,M2,0)
|
||||
|
||||
CALL WMenuSetState(ID_loadrm1,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_sbin,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_crsf,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_savcrs,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_LAYFL,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM13,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM14,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM18,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM15,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM16,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ICOPY,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_Clip,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM24,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_MMAP,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_MAPM,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_NETWORK,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_NODE,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ELTS,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ORDR,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CCLN,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CONTR,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CSEC,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CSEC1,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM20,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM26,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ZOOM,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_DRAW,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_UNDOM,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_NMAP,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CDATA,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM56,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_SECGRP,ItemEnabled,0)
|
||||
|
||||
iswtfl=0
|
||||
N1=1
|
||||
CALL GETARG(N1,FNAME,STATUS)
|
||||
if(status .ne. -1 ) then
|
||||
|
||||
CALL SHORTNAME(FNAME,FNAMEDISP)
|
||||
do n=status,1,-1
|
||||
if(fname(n:n) .eq. '\') then
|
||||
lnnnam=n-1
|
||||
go to 99
|
||||
endif
|
||||
enddo
|
||||
99 continue
|
||||
if(lnnnam .gt. 0) then
|
||||
fnamd=fname(1:lnnnam)
|
||||
statud = CHANGEDIRQQ(fnamd)
|
||||
endif
|
||||
iswtfl=1
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
ITRIAN=0
|
||||
IF(SUB .EQ. 'geo') then
|
||||
IIN=12
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ')
|
||||
FNAMKEP=FNAME
|
||||
READ(IIN) HEADR
|
||||
READ(IIN) N2,M2
|
||||
REWIND (IIN)
|
||||
|
||||
ELSEIF(SUB .EQ. 'gfg') then
|
||||
IIN = 10
|
||||
IGFG=1
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ELSEIF(SUB .EQ. '2dm') then
|
||||
IIN = 10
|
||||
IGFG=3
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ELSEIF(SUB .EQ. 'rst') then
|
||||
IIN=11
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
|
||||
! OPEN(IIN,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
IGFG=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'bin') then
|
||||
IIN=12
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
|
||||
IGFG=2
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'ele') then
|
||||
IIN=10
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=1
|
||||
IGFG=0
|
||||
FNAMKEP=FNAME
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,N2,M2)
|
||||
ELSEIF(SUB .EQ. 'map') then
|
||||
IMP=9
|
||||
OPEN(9,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then
|
||||
IMP=94
|
||||
OPEN(94,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'shp') then
|
||||
IMP=113
|
||||
OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
sub='dbf'
|
||||
call addsub(fname,sub)
|
||||
OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
ELSE
|
||||
IIN = 10
|
||||
IGFG=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ENDIF
|
||||
IF(IMP .EQ. 0) THEN
|
||||
IACTVFIL=1
|
||||
ITOTFIL=1
|
||||
FNAMEOUT(1)=FNAME
|
||||
ENDIF
|
||||
CALL WMenuSetState(ID_loadrm1,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_sbin,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_crsf,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_savcrs,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_LAYFL,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM13,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM14,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM18,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM15,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM16,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ICOPY,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_Clip,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM24,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MAPM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NETWORK,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NODE,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ELTS,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ORDR,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CCLN,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CONTR,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_CSEC,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CSEC1,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM20,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM26,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ZOOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_DRAW,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_UNDOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CDATA,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM56,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0)
|
||||
CALL WMessageEnable(MouseMove , Enabled)
|
||||
|
||||
IF(IMP .GT. 0) THEN
|
||||
MENUS=-2
|
||||
CALL INITSIZ(IIN,N2,M2,1)
|
||||
go to 500
|
||||
ENDIF
|
||||
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to load '//&
|
||||
CHAR(13)//'a map file?' ,&
|
||||
'Map File Input?')
|
||||
!
|
||||
! If answer 'No' skip out
|
||||
!
|
||||
IMP=0
|
||||
IF (WInfoDialog(4) .NE. 2) then
|
||||
|
||||
fname=' '
|
||||
CALL WSelectFile(ID_STRING1,PromptOn,FNAME,'Load Map File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
IF(SUB .EQ. 'map') then
|
||||
IMP=9
|
||||
OPEN(9,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then
|
||||
IMP=94
|
||||
OPEN(94,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'mpb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read')
|
||||
ELSEIF(SUB .EQ. 'mbb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read')
|
||||
ELSEIF(SUB .EQ. 'rm1') then
|
||||
imp=13
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'shp') then
|
||||
IMP=113
|
||||
OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
SUB='DBF'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
ENDIF
|
||||
ENDIF
|
||||
END IF
|
||||
MENUS=-2
|
||||
CALL INITSIZ(IIN,N2,M2,1)
|
||||
|
||||
go to 500
|
||||
endif
|
||||
|
||||
|
||||
|
||||
DO WHILE (.TRUE.) ! Loop until user terminates
|
||||
|
||||
100 continue
|
||||
CALL WMessage(ITYPE, MESSAGE)
|
||||
SELECT CASE (ITYPE)
|
||||
CASE (KeyDown) ! Key pressed
|
||||
KEY = MESSAGE%VALUE1
|
||||
MOUSEX = MESSAGE%X
|
||||
MOUSEY = MESSAGE%Y
|
||||
CASE (MenuSelect) ! Menu item selected
|
||||
SELECT CASE (MESSAGE%VALUE1)
|
||||
! CASE (ID_FILE) ! File option selected
|
||||
CASE (ID_RESETLIM)
|
||||
CALL RESETSIZ
|
||||
|
||||
CASE (ID_ITEM11) ! New option
|
||||
IMP=0
|
||||
IIN=0
|
||||
CALL INITSIZ(IIN,N2,M2,1)
|
||||
CALL WMenuSetState(ID_loadrm1,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_sbin,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_crsf,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_savcrs,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_LAYFL,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM13,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM14,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM18,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM15,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM16,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ICOPY,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_Clip,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM24,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MAPM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NETWORK,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NODE,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ELTS,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ORDR,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CCLN,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CONTR,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_CSEC,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CSEC1,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM20,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM26,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ZOOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_DRAW,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_UNDOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CDATA,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM56,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0)
|
||||
CALL WMessageEnable(MouseMove , Enabled)
|
||||
|
||||
|
||||
MENUS=-2
|
||||
EXIT
|
||||
CASE (ID_ITEM12) ! Open option
|
||||
IMP=0
|
||||
IIN=0
|
||||
if(iswtfl .eq. 1) go to 200
|
||||
fname=' '
|
||||
FILTER ="Network Files|*.rm1;*.geo;*.gfg;*.bin;*.ele;*.2dm|Rm1 file -- *.rm1|*.rm1|Geo file -- *.geo|*.geo|GFGEN file -- *.gfg|*.gfg|GFGEN bin file -- *.bin|*.bin|Rst file -- *.rst|*.rst|ele file -- *.ele|*.ele|MESH2D file -- *.2dm|*.2dm|All files|All files|*.*|"
|
||||
CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
GO TO 200
|
||||
ELSE
|
||||
GO TO 250
|
||||
ENDIF
|
||||
200 CONTINUE
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
IF(SUB .EQ. 'geo') then
|
||||
IIN=12
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ')
|
||||
FNAMKEP=FNAME
|
||||
READ(IIN) HEADR
|
||||
READ(IIN) N2,M2
|
||||
REWIND (IIN)
|
||||
|
||||
ITRIAN=0
|
||||
ELSEIF(SUB .EQ. 'gfg') then
|
||||
IIN = 10
|
||||
IGFG=1
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. '2dm') then
|
||||
IIN = 10
|
||||
IGFG=3
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. '2dm') then
|
||||
IIN = 10
|
||||
IGFG=3
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'bin') then
|
||||
IIN=12
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
|
||||
IGFG=2
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'rst') then
|
||||
IIN=11
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
|
||||
! OPEN(IIN,FILE=FNAME,STATUS='OLD',FORM ='BINARY')
|
||||
IGFG=0
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'ele') then
|
||||
IIN=10
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=1
|
||||
IGFG=0
|
||||
FNAMKEP=FNAME
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,N2,M2)
|
||||
ELSE
|
||||
IIN = 10
|
||||
IGFG=0
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ENDIF
|
||||
IACTVFIL=1
|
||||
ITOTFIL=1
|
||||
FNAMEOUT(1)=FNAME
|
||||
CALL SHORTNAME(FNAME,FNAMEDISP)
|
||||
250 CONTINUE
|
||||
fname=' '
|
||||
filter="Map file -- *.map |*.map|Bin Map file -- *.mpb|*.mpb|Bin Map file (no head) -- *.mbb|*.mbb|RM1 file (as map) -- *.rm1|*.rm1|ESRI ASC file -- *.asc|*.asc|SURFER GRD file -- *.grd|*.grd|ESRI SHP file -- *.shp|*.shp|"
|
||||
CALL WSelectFile(filter,PromptOn,FNAME,'Load Map File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
IF(SUB .EQ. 'map') then
|
||||
IMP=9
|
||||
OPEN(9,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then
|
||||
IMP=94
|
||||
OPEN(94,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'shp') then
|
||||
IMP=113
|
||||
OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
SUB='DBF'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
ELSEIF(SUB .EQ. 'mpb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read')
|
||||
ELSEIF(SUB .EQ. 'mbb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read')
|
||||
ELSEIF(SUB .EQ. 'rm1') then
|
||||
imp=13
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ENDIF
|
||||
ENDIF
|
||||
CALL WMenuSetState(ID_loadrm1,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_sbin,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_crsf,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_savcrs,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_LAYFL,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM13,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM14,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM18,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM15,ItemEnabled,1)
|
||||
!CALL WMenuSetState(ID_ITEM16,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ICOPY,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_Clip,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM24,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MAPM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NETWORK,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NODE,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ELTS,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ORDR,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CCLN,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CONTR,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CSEC1,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_CSEC,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM20,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM26,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ZOOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_DRAW,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_UNDOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CDATA,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM56,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0)
|
||||
CALL WMessageEnable(MouseMove , Enabled)
|
||||
|
||||
|
||||
MENUS=-2
|
||||
CALL INITSIZ(IIN,N2,M2,1)
|
||||
EXIT
|
||||
CASE (ID_ITEM13) ! Save option
|
||||
WRITE(90,*) 'NWRM ITEM13'
|
||||
INQUIRE(20, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
FILTER ="Network Files|*.rm1;*.gfg;*.ele|Rm1 file -- *.rm1|*.rm1|GFGEN file -- *.gfg|*.gfg|ele file -- *.ele|*.ele|All files|*.*|"
|
||||
|
||||
CALL WSelectFile(FILTER,SaveDialog+PromptOn,FNAME,'Save Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='rm1'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
|
||||
WRITE(90,*) 'IN ITEM13-NEW',IOT
|
||||
WRITE(90,'(A)') FNAME,SUB
|
||||
IOT = 20
|
||||
OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN',ACTION='READWRITE')
|
||||
|
||||
call wrtout(1)
|
||||
ENDIF
|
||||
else
|
||||
call wrtout(1)
|
||||
endif
|
||||
|
||||
CASE (ID_ITEM14) ! Save option
|
||||
WRITE(90,*) 'NWRM ITEM14'
|
||||
|
||||
INQUIRE(22, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
CALL WSelectFile(ID_STRING4,SaveDialog+PromptOn,FNAME,'Save Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='geo'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
|
||||
WRITE(90,*) 'IN ITEM14-NEW',IOT1
|
||||
WRITE(90,'(A)') FNAME,SUB
|
||||
IOT1=22
|
||||
OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary',ACTION='READWRITE')
|
||||
call wrtout(2)
|
||||
ENDIF
|
||||
else
|
||||
call wrtout(2)
|
||||
endif
|
||||
|
||||
CASE (ID_ITEM18) ! Save As option
|
||||
|
||||
CALL WSelectFile(ID_STRING5,SaveDialog+PromptOn,FNAME,'Save Bin Map File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='mpb'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
impf=93
|
||||
OPEN(IMPF ,FILE=fname,STATUS='unknown',form='unformatted',ACTION='READWRITE')
|
||||
|
||||
call wrtmap(1)
|
||||
|
||||
ENDIF
|
||||
|
||||
CASE (ID_ITEM15) ! Save As option
|
||||
|
||||
CALL WSelectFile(ID_STRING3,SaveDialog+PromptOn,FNAME,'Save Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='rm1'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
|
||||
IOT = 20
|
||||
OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN',ACTION='READWRITE')
|
||||
call wrtout(1)
|
||||
ENDIF
|
||||
|
||||
CASE (ID_ITEM16) ! Save As option
|
||||
|
||||
CALL WSelectFile(ID_STRING4,SaveDialog+PromptOn,FNAME,'Save Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='geo'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
|
||||
IOT1 = 22
|
||||
OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary',ACTION='READWRITE')
|
||||
call wrtout(2)
|
||||
ENDIF
|
||||
|
||||
CASE (ID_BKF) ! Read background option
|
||||
|
||||
fname=' '
|
||||
FILTER ="Background File|*.wmf;*.bmp;*.pcx;*.png;*.cgm;*.pic;*.jpg|wmf file -- *.wmf|*.wmf|bmp file -- *.bmp|*.bmp|pcx file -- *.pcx|*.pcx|png file -- *.png|*.png|jpeg file -- *.jpg|*.jpg|cgm file -- *.cgm|*.cgm|pic file -- *.pic|*.pic|"
|
||||
CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Background file')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
NBKFL=NBKFL+1
|
||||
BFNAME(NBKFL)=FNAME
|
||||
SUB1=SUB
|
||||
IF(SUB .EQ. 'bmp') then
|
||||
ISWBKFL(NBKFL) = 2
|
||||
ELSEIF(SUB .EQ. 'pcx') then
|
||||
ISWBKFL(NBKFL) = 2
|
||||
ELSEIF(SUB .EQ. 'png' .or. sub .eq. 'jpg') then
|
||||
ISWBKFL(NBKFL) = 2
|
||||
ELSE
|
||||
ISWBKFL(NBKFL)=1
|
||||
ENDIF
|
||||
SUB='ORG'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
BFNAMR(NBKFL)=FNAME
|
||||
INQUIRE (FILE = fname, EXIST = exists)
|
||||
IF (.NOT. exists) THEN
|
||||
IF(SUB1 .EQ. 'PNG' .or. SUB1 .EQ. 'png') SUB2='PNGW'
|
||||
IF(SUB1 .EQ. 'JPG' .or. SUB1 .EQ. 'jpg') SUB2='JPGW'
|
||||
CALL ADDSUB(FNAME,SUB2)
|
||||
BFNAMR(NBKFL)=FNAME
|
||||
INQUIRE (FILE = fname, EXIST = exists)
|
||||
IF (.NOT. exists) THEN
|
||||
IF(SUB2 .EQ. 'JPGW') THEN
|
||||
SUB1='JGW'
|
||||
CALL ADDSUB(FNAME,SUB1)
|
||||
BFNAMR(NBKFL)=FNAME
|
||||
ENDIF
|
||||
ENDIF
|
||||
INQUIRE (FILE = fname, EXIST = exists)
|
||||
IF (.NOT. exists) THEN
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Location file does not exist!!'//CHAR(13)// &
|
||||
'Do you wish to create file and view image','Looking for location file')
|
||||
! If answer 'Yes' set ifrmel to 0
|
||||
!
|
||||
IF (WInfoDialog(4) .ne. 2) then
|
||||
OPEN(104,FILE=FNAME,STATUS ='NEW', FORM ='FORMATTED')
|
||||
BFMINMAX(NBKFL,1) = - XS
|
||||
BFMINMAX(NBKFL,2) = - YS
|
||||
BFMINMAX(NBKFL,3) = HSIZE*TXSCAL - XS
|
||||
BFMINMAX(NBKFL,4) = 7.50*TXSCAL - YS
|
||||
WRITE(104,'(4G16.8)') (BFMINMAX(NBKFL,I),I=1,4)
|
||||
CLOSE(104)
|
||||
|
||||
EXIT
|
||||
ELSE
|
||||
NBKFL=NBKFL-1
|
||||
EXIT
|
||||
ENDIF
|
||||
ENDIF
|
||||
! yes
|
||||
OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED')
|
||||
READ(104,'(G16.8)') XX1
|
||||
READ(104,'(G16.8)') XX2
|
||||
READ(104,'(G16.8)') XX3
|
||||
READ(104,'(G16.8)') XX4
|
||||
READ(104,'(G16.8)') XX5
|
||||
READ(104,'(G16.8)') XX6
|
||||
CLOSE(104)
|
||||
call IGrFileInfo(BFNAME(NBKFL),INFO,3)
|
||||
|
||||
BFMINMAX(NBKFL,1) = XX5
|
||||
BFMINMAX(NBKFL,2) = XX6+INFO(3)*XX4
|
||||
BFMINMAX(NBKFL,3) = XX5+INFO(2)*XX1
|
||||
BFMINMAX(NBKFL,4) = XX6
|
||||
|
||||
CLOSE(104)
|
||||
GO TO 125
|
||||
ENDIF
|
||||
|
||||
OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED')
|
||||
READ(104,'(4G16.8)') (BFMINMAX(NBKFL,I),I=1,4)
|
||||
CLOSE(104)
|
||||
125 CONTINUE
|
||||
ENDIF
|
||||
|
||||
CASE (ID_ITEM24) ! Print option is selected
|
||||
CALL WHardcopyOptions(3)
|
||||
!
|
||||
! If the user clicked OK on page setup dialog then output the contents
|
||||
! of the subroutine DOPLOT to the selected printer
|
||||
!
|
||||
IF (WinfoDialog(ExitButtonCommon).EQ.CommonOK) THEN
|
||||
CALL IGrInit('HP') ! hardcopy only output
|
||||
CALL IGrFillPattern(Solid)
|
||||
|
||||
CALL IgrUnits(0.,0.,HSIZE,7.5)
|
||||
CALL IGrHardcopy(' ') ! Start print manager
|
||||
call clscrn
|
||||
CALL PLOTOT(0) ! plot graph
|
||||
call rblack
|
||||
CALL IGrRectangle(0.,0.,HSIZE,7.5)
|
||||
|
||||
CALL IGrHardcopy('S') ! Send data to the printer
|
||||
CALL IGrInit('P') ! Turn graphics back on
|
||||
CALL IGrFillPattern(Solid)
|
||||
|
||||
CALL IgrUnits(0.,0.,HSIZE,8.0)
|
||||
CALL PLOTOT(0)
|
||||
CALL HEDR
|
||||
call rblack
|
||||
CALL IGrRectangle(0.,0.,HSIZE,7.5)
|
||||
END IF
|
||||
|
||||
CASE (ID_ITEM19) ! Demo option
|
||||
MENUS=-1
|
||||
IMP=0
|
||||
IIN=0
|
||||
EXIT
|
||||
CASE (ID_ITEM17) ! Exit option
|
||||
call rquit(iyes)
|
||||
if(iyes .ne. 1) go to 100
|
||||
MENUS=0
|
||||
EXIT
|
||||
CASE (ID_EXIT) ! Exit program (menu option)
|
||||
call rquit(iyes)
|
||||
if(iyes .ne. 1) go to 100
|
||||
MENUS=0
|
||||
EXIT
|
||||
CASE (ID_NODE)
|
||||
MENUS=2
|
||||
EXIT
|
||||
CASE (ID_ELTS)
|
||||
MENUS=1
|
||||
EXIT
|
||||
CASE (ID_ORDR)
|
||||
MENUS=3
|
||||
EXIT
|
||||
CASE (ID_CCLN)
|
||||
MENUS=6
|
||||
EXIT
|
||||
CASE (ID_CSEC)
|
||||
MENUS=7
|
||||
EXIT
|
||||
CASE (ID_ZOOM)
|
||||
MENUS=8
|
||||
EXIT
|
||||
CASE (ID_DRAW)
|
||||
MENUS=9
|
||||
EXIT
|
||||
|
||||
CASE (ID_HELP1)
|
||||
call helps(0)
|
||||
go to 100
|
||||
|
||||
CASE (ID_HELP2)
|
||||
call RMINFO
|
||||
go to 100
|
||||
|
||||
CASE (ID_ITEM20)
|
||||
CALL GDIST
|
||||
CYCLE
|
||||
|
||||
CASE (ID_ITEM22)
|
||||
CALL SELNODE(0)
|
||||
CYCLE
|
||||
|
||||
CASE (ID_ALLNODES)
|
||||
CALL SELNODE(1)
|
||||
CYCLE
|
||||
|
||||
CASE (ID_UNUSNODES)
|
||||
CALL SELNODE(2)
|
||||
CYCLE
|
||||
|
||||
CASE (ID_ITEM23)
|
||||
CALL SELELT(0)
|
||||
CYCLE
|
||||
END SELECT
|
||||
CASE (PushButton) ! Dialog button pressed
|
||||
IDBUTN = MESSAGE%VALUE1
|
||||
IDFIELD = MESSAGE%VALUE2
|
||||
CASE (MouseButDown,MouseButUp) ! Mouse button down/up
|
||||
MBUTTON = MESSAGE%VALUE1
|
||||
ITIME = MESSAGE%VALUE2
|
||||
MOUSEX = MESSAGE%X
|
||||
MOUSEY = MESSAGE%Y
|
||||
CASE (MouseMove) ! Mouse moved
|
||||
ITIME = MESSAGE%VALUE2
|
||||
MOUSEX = MESSAGE%X
|
||||
MOUSEY = MESSAGE%Y
|
||||
CASE (Expose) ! Window partly/wholly exposed
|
||||
IX = MESSAGE%X
|
||||
IY = MESSAGE%Y
|
||||
IWIDTH = MESSAGE%VALUE1
|
||||
IHEIGHT = MESSAGE%VALUE2
|
||||
CASE (Resize) ! Window resized
|
||||
IWIDTH = MESSAGE%VALUE1
|
||||
IHEIGHT = MESSAGE%VALUE2
|
||||
CASE (CloseRequest) ! Close window (e.g. Alt/F4)
|
||||
IWINDOW = MESSAGE%WIN
|
||||
call rquit(iyes)
|
||||
if(iyes .ne. 1) go to 100
|
||||
menus=0
|
||||
exit
|
||||
! IF (IWINDOW.EQ.0) EXIT ! Root window : exit program
|
||||
! CALL WindowCloseChild(IWINDOW)
|
||||
CASE (FieldChanged) ! Field change in modeless dialog
|
||||
IDFIELDOLD = MESSAGE%VALUE1
|
||||
IDFIELDNEW = MESSAGE%VALUE2
|
||||
END SELECT
|
||||
END DO
|
||||
|
||||
500 continue
|
||||
IF(MENUS .NE. 0) THEN
|
||||
CALL RMAGEN(MENUS,IMP,IIN,0,IOT,IOT1,IGFG,ITRIAN,N2,M2)
|
||||
ENDIF
|
||||
close(90)
|
||||
CALL WindowClose ! Remove program window
|
||||
stop
|
||||
!! CALL WindowClose ! Remove program window
|
||||
END PROGRAM NEWRMAGEN
|
||||
|
||||
SUBROUTINE GETSUB(FNAME,SUB)
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=3) :: SUB
|
||||
INTEGER ,EXTERNAL :: LENSTR
|
||||
INTEGER :: LNNAM,K
|
||||
|
||||
LNNAM=LENSTR(FNAME)
|
||||
SUB=' '
|
||||
DO K=LNNAM,1,-1
|
||||
IF(FNAME(K:K) .EQ. '.') THEN
|
||||
IF(LNNAM .GT. K+2) THEN
|
||||
SUB=FNAME(K+1:K+3)
|
||||
ELSE
|
||||
SUB=' '
|
||||
ENDIF
|
||||
GO TO 110
|
||||
ENDIF
|
||||
ENDDO
|
||||
110 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE ADDSUB(FNAME,SUB)
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=*) :: SUB
|
||||
INTEGER ,EXTERNAL :: LENSTR
|
||||
INTEGER :: LNNAM,K,LMPNAM
|
||||
|
||||
LNNAM=LENSTR(FNAME)
|
||||
DO K=LNNAM,1,-1
|
||||
IF(FNAME(K:K) .EQ. '.') THEN
|
||||
lmpnam=k
|
||||
FNAME=FNAME(1:LMPNAM)//SUB
|
||||
GO TO 110
|
||||
ENDIF
|
||||
ENDDO
|
||||
FNAME=FNAME(1:LNNAM)//'.'//SUB
|
||||
110 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE SHORTNAME(FNAMELL,FNAMES)
|
||||
CHARACTER(LEN=255) :: FNAMELL
|
||||
CHARACTER(LEN=48) :: FNAMES
|
||||
INTEGER ,EXTERNAL :: LENSTR
|
||||
INTEGER :: LNNAM,K,KSTART,KEND
|
||||
|
||||
LNNAM=LENSTR(FNAMELL)
|
||||
DO K=1,48
|
||||
FNAMES(K:K)=' '
|
||||
ENDDO
|
||||
KSTART=1
|
||||
DO K=LNNAM,1,-1
|
||||
IF(FNAMELL(K:K) .EQ. '\') THEN
|
||||
KSTART=K+1
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ENDDO
|
||||
200 KEND=LNNAM-KSTART+1
|
||||
IF(KEND .GT. 48) KEND=48
|
||||
|
||||
FNAMES(1:KEND)=FNAMELL(KSTART:KSTART+KEND-1)
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,951 @@
|
||||
!IPK LAST UPDATE SEP 23 2015 ADD MORE INFO ON FRAME
|
||||
!
|
||||
PROGRAM NEWRMAGEN
|
||||
!
|
||||
! Use of the module is compulsory
|
||||
!
|
||||
USE WINTERACTER
|
||||
USE DFLIB
|
||||
!
|
||||
IMPLICIT NONE
|
||||
!
|
||||
! Define some parameters to match those in the resource file
|
||||
!
|
||||
include 'd.inc'
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
REAL HSIZE,scratio
|
||||
COMMON /SSIZE/ HSIZE
|
||||
|
||||
!
|
||||
INTEGER :: IBASEV =40042
|
||||
INTEGER :: I,IRES,N2,M2,ID1,ID2
|
||||
INTEGER :: ITYPE, IX, IY, IWIDTH, IHEIGHT, KEY,IYES
|
||||
INTEGER :: MOUSEX, MOUSEY, MBUTTON, ITIME, IWINDOW
|
||||
INTEGER :: IDFIELDOLD, IDFIELDNEW, IDBUTN, IDFIELD,TOOLID(4)
|
||||
INTEGER :: LNNAM,K,LMPNAM,IMP,IIN,MENUS,IOT,IOT1,impf,IGFG,ITRIAN,INFO(3)
|
||||
INTEGER , DIMENSION(5) :: WIDSTAT
|
||||
INTEGER*2 :: N1,STATUS,lnnnam,iswtfl,n
|
||||
CHARACTER(LEN=255) :: FNAME,FNAMD,FILTER
|
||||
CHARACTER(LEN=3) :: SUB,SUB1
|
||||
CHARACTER(LEN=4) :: SUB2
|
||||
CHARACTER(LEN=1000) :: HEADR
|
||||
INTEGER ,EXTERNAL :: LENSTR
|
||||
LOGICAL :: OPENED,exists
|
||||
LOGICAL(4) :: statud
|
||||
REAL :: XX1,XX2,XX3,XX4,XX5,XX6
|
||||
INTEGER :: iw,ih,ihandle,ient,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
|
||||
common /hands/ iw,ih,ihandle,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
|
||||
|
||||
|
||||
INTEGER ISCRWID,ISCRHGT
|
||||
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
TYPE (WIN_FONT) :: FONT
|
||||
|
||||
! Define a common block with background file names
|
||||
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
! Get initial directory and add help name
|
||||
|
||||
fname = FILE$CURDRIVE
|
||||
IRES=GETDRIVEDIRQQ (fname)
|
||||
! lnnnam=windowstringlength(fname)
|
||||
lnnnam=lenstr(fname)
|
||||
direct=fname(1:lnnnam)//'\doc\rmagen83d.htm'
|
||||
|
||||
! write(128,*) fname,lnnnam,direct
|
||||
|
||||
!
|
||||
!
|
||||
! Initialise WiSK
|
||||
!
|
||||
CALL WInitialise()
|
||||
!
|
||||
! Create a root window with :
|
||||
! - System menu
|
||||
! - Minimise button
|
||||
! - Maximise button
|
||||
!
|
||||
! WINDOW%FLAGS = SysMenuOn + MinButton + MaxButton + StatusBar
|
||||
|
||||
ISCRWID = WInfoScreen(1) ! Get screen width
|
||||
ISCRHGT = WInfoScreen(2) ! Get screen height
|
||||
scratio=float(iscrwid)/float(iscrhgt)
|
||||
HSIZE=scratio*8.
|
||||
|
||||
!
|
||||
! Centre the window on the screen at 80% of screen size
|
||||
!
|
||||
WINDOW%X = -1
|
||||
WINDOW%Y = -1
|
||||
WINDOW%WIDTH = 0
|
||||
WINDOW%HEIGHT = 0
|
||||
!
|
||||
! Identify the menu to be attached to the window
|
||||
! and specify the initial window title
|
||||
!
|
||||
! WINDOW%MENUID = IDR_MENU1
|
||||
! WINDOW%TITLE = 'RMAGEN'
|
||||
!
|
||||
! Now open the root window
|
||||
!
|
||||
CALL WindowOpen(FLAGS =SysMenuOn+MinButton+MaxButton+StatusBar, &
|
||||
MENUID=IDR_MENU1, &
|
||||
TOOLID=(/0,ID_TOOLBAR1,0,0/), &
|
||||
TITLE ='RMAGEN')
|
||||
! CALL WindowOpen(WINDOW,TITLE ='RMAGEN') ! Open root window
|
||||
|
||||
!
|
||||
! Add a toolbar
|
||||
!
|
||||
! CALL WMenuToolbar(ID_TOOLBAR1)
|
||||
!
|
||||
! Main message loop
|
||||
!
|
||||
! initialise palette
|
||||
!
|
||||
CALL IGrPaletteInit
|
||||
!
|
||||
! set fill style to solid
|
||||
!
|
||||
CALL IGrFillPattern(Solid)
|
||||
|
||||
FONT%IBCOL = TextWhite
|
||||
CALL WindowFont(FONT)
|
||||
! CALL WindowClear(RGB=RGB_yellow) ! clear window to yellow
|
||||
! IRGB = WRGB(220,220,220)
|
||||
! IRGB = WRGB(191,191,191)
|
||||
IRGB = WRGB(227,227,227)
|
||||
CALL WindowClear(rgb=irgb) ! clear to yellow
|
||||
|
||||
WIDSTAT(1) = 1000
|
||||
WIDSTAT(2) = 2000
|
||||
WIDSTAT(3) = 1500
|
||||
WIDSTAT(4) = 1000
|
||||
WIDSTAT(5) = 2500
|
||||
CALL WindowStatusBarParts(5, WIDSTAT)
|
||||
CALL WindowOutStatusBar(1, ' X and Y location')
|
||||
CALL WindowOutStatusBar(4, ' Active File Name')
|
||||
CALL IgrUnits(0.,0.,HSIZE,8.0)
|
||||
|
||||
! IF(ISW .EQ. 1) THEN
|
||||
! CALL WMessageEnable(MouseMove , Enabled)
|
||||
! MENUS=-3
|
||||
! CALL RMAGEN(MENUS,IMP,IIN,1,IOT,IOT1,IGFG)
|
||||
! ENDIF
|
||||
|
||||
|
||||
! CALL WMenuSetState(ID_NETWD,ItemChecked,1)
|
||||
! DO I=1,12
|
||||
! CALL WMenuSetState(IBASEV+I,ItemChecked,1)
|
||||
! ENDDO
|
||||
|
||||
IDDSW=-1
|
||||
IHANDLE=0
|
||||
IHAND1=0
|
||||
IHAND2=0
|
||||
N2=0
|
||||
M2=0
|
||||
TXSCAL = 1.
|
||||
XS=0.
|
||||
YS=0.
|
||||
NBKFL=0
|
||||
IRDONE=-1
|
||||
DO I=1,10
|
||||
ISWBKFL(I)=0
|
||||
ENDDO
|
||||
IACTVFIL=0
|
||||
ITOTFIL=0
|
||||
IOT=0
|
||||
IOT1=0
|
||||
IMP=0
|
||||
|
||||
CALL INITSIZ(IIN,N2,M2,0)
|
||||
|
||||
CALL WMenuSetState(ID_loadrm1,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_sbin,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_crsf,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_savcrs,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_LAYFL,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM13,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM14,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM18,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM15,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM16,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ICOPY,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_Clip,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM24,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_MMAP,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_MAPM,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_NETWORK,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_NODE,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ELTS,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ORDR,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CCLN,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CONTR,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CSEC,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CSEC1,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM20,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM26,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ZOOM,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_DRAW,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_UNDOM,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_NMAP,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CDATA,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM56,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_SECGRP,ItemEnabled,0)
|
||||
|
||||
iswtfl=0
|
||||
N1=1
|
||||
|
||||
CALL GETARG(N1,FNAME,STATUS)
|
||||
if(status .ne. -1 ) then
|
||||
|
||||
CALL SHORTNAME(FNAME,FNAMEDISP)
|
||||
do n=status,1,-1
|
||||
if(fname(n:n) .eq. '\') then
|
||||
lnnnam=n-1
|
||||
go to 99
|
||||
endif
|
||||
enddo
|
||||
99 continue
|
||||
if(lnnnam .gt. 0) then
|
||||
fnamd=fname(1:lnnnam)
|
||||
statud = CHANGEDIRQQ(fnamd)
|
||||
endif
|
||||
iswtfl=1
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
ITRIAN=0
|
||||
IF(SUB .EQ. 'geo') then
|
||||
IIN=12
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ')
|
||||
FNAMKEP=FNAME
|
||||
READ(IIN) HEADR
|
||||
READ(IIN) N2,M2
|
||||
REWIND (IIN)
|
||||
|
||||
ELSEIF(SUB .EQ. 'gfg') then
|
||||
IIN = 10
|
||||
IGFG=1
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ELSEIF(SUB .EQ. '2dm') then
|
||||
IIN = 10
|
||||
IGFG=3
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ELSEIF(SUB .EQ. 'rst') then
|
||||
IIN=11
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
|
||||
! OPEN(IIN,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
IGFG=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'bin') then
|
||||
IIN=12
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
|
||||
IGFG=2
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'ele') then
|
||||
IIN=10
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=1
|
||||
IGFG=0
|
||||
FNAMKEP=FNAME
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,N2,M2)
|
||||
ELSEIF(SUB .EQ. 'map') then
|
||||
IMP=9
|
||||
OPEN(9,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then
|
||||
IMP=94
|
||||
OPEN(94,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'shp') then
|
||||
IMP=113
|
||||
OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
sub='dbf'
|
||||
call addsub(fname,sub)
|
||||
OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
ELSE
|
||||
IIN = 10
|
||||
IGFG=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ENDIF
|
||||
IF(IMP .EQ. 0) THEN
|
||||
IACTVFIL=1
|
||||
ITOTFIL=1
|
||||
FNAMEOUT(1)=FNAME
|
||||
ENDIF
|
||||
CALL WMenuSetState(ID_loadrm1,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_sbin,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_crsf,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_savcrs,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_LAYFL,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM13,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM14,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM18,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM15,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM16,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ICOPY,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_Clip,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM24,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MAPM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NETWORK,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NODE,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ELTS,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ORDR,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CCLN,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CONTR,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_CSEC,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CSEC1,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM20,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM26,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ZOOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_DRAW,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_UNDOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CDATA,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM56,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0)
|
||||
CALL WMessageEnable(MouseMove , Enabled)
|
||||
|
||||
IF(IMP .GT. 0) THEN
|
||||
MENUS=-2
|
||||
CALL INITSIZ(IIN,N2,M2,1)
|
||||
go to 500
|
||||
ENDIF
|
||||
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to load '//&
|
||||
CHAR(13)//'a map file?' ,&
|
||||
'Map File Input?')
|
||||
!
|
||||
! If answer 'No' skip out
|
||||
!
|
||||
IMP=0
|
||||
IF (WInfoDialog(4) .NE. 2) then
|
||||
|
||||
fname=' '
|
||||
CALL WSelectFile(ID_STRING1,PromptOn,FNAME,'Load Map File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
IF(SUB .EQ. 'map') then
|
||||
IMP=9
|
||||
OPEN(9,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then
|
||||
IMP=94
|
||||
OPEN(94,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'mpb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read')
|
||||
ELSEIF(SUB .EQ. 'mbb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read')
|
||||
ELSEIF(SUB .EQ. 'rm1') then
|
||||
imp=13
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'shp') then
|
||||
IMP=113
|
||||
OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
SUB='DBF'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
ENDIF
|
||||
ENDIF
|
||||
END IF
|
||||
MENUS=-2
|
||||
CALL INITSIZ(IIN,N2,M2,1)
|
||||
|
||||
go to 500
|
||||
endif
|
||||
|
||||
|
||||
|
||||
DO WHILE (.TRUE.) ! Loop until user terminates
|
||||
|
||||
100 continue
|
||||
CALL WMessage(ITYPE, MESSAGE)
|
||||
SELECT CASE (ITYPE)
|
||||
CASE (KeyDown) ! Key pressed
|
||||
KEY = MESSAGE%VALUE1
|
||||
MOUSEX = MESSAGE%X
|
||||
MOUSEY = MESSAGE%Y
|
||||
CASE (MenuSelect) ! Menu item selected
|
||||
SELECT CASE (MESSAGE%VALUE1)
|
||||
! CASE (ID_FILE) ! File option selected
|
||||
CASE (ID_RESETLIM)
|
||||
CALL RESETSIZ
|
||||
|
||||
CASE (ID_ITEM11) ! New option
|
||||
IMP=0
|
||||
IIN=0
|
||||
CALL INITSIZ(IIN,N2,M2,1)
|
||||
CALL WMenuSetState(ID_loadrm1,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_sbin,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_crsf,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_savcrs,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_LAYFL,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM13,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM14,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM18,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM15,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM16,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ICOPY,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_Clip,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM24,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MAPM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NETWORK,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NODE,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ELTS,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ORDR,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CCLN,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CONTR,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_CSEC,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_CSEC1,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM20,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM26,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ZOOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_DRAW,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_UNDOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CDATA,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM56,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0)
|
||||
CALL WMessageEnable(MouseMove , Enabled)
|
||||
|
||||
|
||||
MENUS=-2
|
||||
EXIT
|
||||
CASE (ID_ITEM12) ! Open option
|
||||
IMP=0
|
||||
IIN=0
|
||||
if(iswtfl .eq. 1) go to 200
|
||||
fname=' '
|
||||
FILTER ="Network Files|*.rm1;*.geo;*.gfg;*.bin;*.ele;*.2dm|Rm1 file -- *.rm1|*.rm1|Geo file -- *.geo|*.geo|GFGEN file -- *.gfg|*.gfg|GFGEN bin file -- *.bin|*.bin|Rst file -- *.rst|*.rst|ele file -- *.ele|*.ele|MESH2D file -- *.2dm|*.2dm|All files|All files|*.*|"
|
||||
CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
GO TO 200
|
||||
ELSE
|
||||
GO TO 250
|
||||
ENDIF
|
||||
200 CONTINUE
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
IF(SUB .EQ. 'geo') then
|
||||
IIN=12
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ')
|
||||
FNAMKEP=FNAME
|
||||
READ(IIN) HEADR
|
||||
READ(IIN) N2,M2
|
||||
REWIND (IIN)
|
||||
|
||||
ITRIAN=0
|
||||
ELSEIF(SUB .EQ. 'gfg') then
|
||||
IIN = 10
|
||||
IGFG=1
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. '2dm') then
|
||||
IIN = 10
|
||||
IGFG=3
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. '2dm') then
|
||||
IIN = 10
|
||||
IGFG=3
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'bin') then
|
||||
IIN=12
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
|
||||
IGFG=2
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'rst') then
|
||||
IIN=11
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
|
||||
! OPEN(IIN,FILE=FNAME,STATUS='OLD',FORM ='BINARY')
|
||||
IGFG=0
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ELSEIF(SUB .EQ. 'ele') then
|
||||
IIN=10
|
||||
OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=1
|
||||
IGFG=0
|
||||
FNAMKEP=FNAME
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,N2,M2)
|
||||
ELSE
|
||||
IIN = 10
|
||||
IGFG=0
|
||||
OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ')
|
||||
ITRIAN=0
|
||||
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
|
||||
ENDIF
|
||||
IACTVFIL=1
|
||||
ITOTFIL=1
|
||||
FNAMEOUT(1)=FNAME
|
||||
CALL SHORTNAME(FNAME,FNAMEDISP)
|
||||
250 CONTINUE
|
||||
fname=' '
|
||||
filter="Map files -- *.map, *.grd |*.map;*.grd|Bin Map file -- *.mpb|*.mpb|Bin Map file (no head) -- *.mbb|*.mbb|RM1 file (as map) -- *.rm1|*.rm1|ESRI ASC file -- *.asc|*.asc|SURFER GRD file -- *.grd|*.grd|ESRI SHP file -- *.shp|*.shp|"
|
||||
CALL WSelectFile(filter,PromptOn,FNAME,'Load Map File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
IF(SUB .EQ. 'map') then
|
||||
IMP=9
|
||||
OPEN(9,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then
|
||||
IMP=94
|
||||
OPEN(94,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ELSEIF(SUB .EQ. 'shp') then
|
||||
IMP=113
|
||||
OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
SUB='DBF'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
|
||||
ELSEIF(SUB .EQ. 'mpb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read')
|
||||
ELSEIF(SUB .EQ. 'mbb') then
|
||||
imp=92
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read')
|
||||
ELSEIF(SUB .EQ. 'rm1') then
|
||||
imp=13
|
||||
OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read')
|
||||
ENDIF
|
||||
ENDIF
|
||||
CALL WMenuSetState(ID_loadrm1,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_sbin,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_crsf,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_savcrs,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_LAYFL,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM13,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM14,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM18,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM15,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM16,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ICOPY,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_Clip,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM24,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_MAPM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NETWORK,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NODE,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ELTS,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ORDR,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CCLN,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CONTR,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CSEC1,ItemEnabled,1)
|
||||
! CALL WMenuSetState(ID_CSEC,ItemEnabled,0)
|
||||
CALL WMenuSetState(ID_ITEM20,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM26,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ZOOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_DRAW,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_UNDOM,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_NMAP,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_CDATA,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_ITEM56,ItemEnabled,1)
|
||||
CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0)
|
||||
CALL WMessageEnable(MouseMove , Enabled)
|
||||
|
||||
|
||||
MENUS=-2
|
||||
CALL INITSIZ(IIN,N2,M2,1)
|
||||
EXIT
|
||||
CASE (ID_ITEM13) ! Save option
|
||||
WRITE(90,*) 'NWRM ITEM13'
|
||||
INQUIRE(20, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
FILTER ="Network Files|*.rm1;*.gfg;*.ele|Rm1 file -- *.rm1|*.rm1|GFGEN file -- *.gfg|*.gfg|ele file -- *.ele|*.ele|All files|*.*|"
|
||||
|
||||
CALL WSelectFile(FILTER,SaveDialog+PromptOn,FNAME,'Save Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='rm1'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
|
||||
WRITE(90,*) 'IN ITEM13-NEW',IOT
|
||||
WRITE(90,'(A)') FNAME,SUB
|
||||
IOT = 20
|
||||
OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN',ACTION='READWRITE')
|
||||
|
||||
call wrtout(1)
|
||||
ENDIF
|
||||
else
|
||||
call wrtout(1)
|
||||
endif
|
||||
|
||||
CASE (ID_ITEM14) ! Save option
|
||||
WRITE(90,*) 'NWRM ITEM14'
|
||||
|
||||
INQUIRE(22, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
CALL WSelectFile(ID_STRING4,SaveDialog+PromptOn,FNAME,'Save Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='geo'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
|
||||
WRITE(90,*) 'IN ITEM14-NEW',IOT1
|
||||
WRITE(90,'(A)') FNAME,SUB
|
||||
IOT1=22
|
||||
OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary',ACTION='READWRITE')
|
||||
call wrtout(2)
|
||||
ENDIF
|
||||
else
|
||||
call wrtout(2)
|
||||
endif
|
||||
|
||||
CASE (ID_ITEM18) ! Save As option
|
||||
|
||||
CALL WSelectFile(ID_STRING5,SaveDialog+PromptOn,FNAME,'Save Bin Map File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='mpb'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
impf=93
|
||||
OPEN(IMPF ,FILE=fname,STATUS='unknown',form='unformatted',ACTION='READWRITE')
|
||||
|
||||
call wrtmap(1)
|
||||
|
||||
ENDIF
|
||||
|
||||
CASE (ID_ITEM15) ! Save As option
|
||||
|
||||
CALL WSelectFile(ID_STRING3,SaveDialog+PromptOn,FNAME,'Save Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='rm1'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
|
||||
IOT = 20
|
||||
OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN',ACTION='READWRITE')
|
||||
call wrtout(1)
|
||||
ENDIF
|
||||
|
||||
CASE (ID_ITEM16) ! Save As option
|
||||
|
||||
CALL WSelectFile(ID_STRING4,SaveDialog+PromptOn,FNAME,'Save Network File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
SUB='geo'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
|
||||
IOT1 = 22
|
||||
OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary',ACTION='READWRITE')
|
||||
call wrtout(2)
|
||||
ENDIF
|
||||
|
||||
CASE (ID_BKF) ! Read background option
|
||||
|
||||
fname=' '
|
||||
FILTER ="Background File|*.wmf;*.bmp;*.pcx;*.png;*.cgm;*.pic;*.jpg|wmf file -- *.wmf|*.wmf|bmp file -- *.bmp|*.bmp|pcx file -- *.pcx|*.pcx|png file -- *.png|*.png|jpeg file -- *.jpg|*.jpg|cgm file -- *.cgm|*.cgm|pic file -- *.pic|*.pic|"
|
||||
CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Background file')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
NBKFL=NBKFL+1
|
||||
BFNAME(NBKFL)=FNAME
|
||||
SUB1=SUB
|
||||
IF(SUB .EQ. 'bmp') then
|
||||
ISWBKFL(NBKFL) = 2
|
||||
ELSEIF(SUB .EQ. 'pcx') then
|
||||
ISWBKFL(NBKFL) = 2
|
||||
ELSEIF(SUB .EQ. 'png' .or. sub .eq. 'jpg') then
|
||||
ISWBKFL(NBKFL) = 2
|
||||
ELSE
|
||||
ISWBKFL(NBKFL)=1
|
||||
ENDIF
|
||||
SUB='ORG'
|
||||
CALL ADDSUB(FNAME,SUB)
|
||||
BFNAMR(NBKFL)=FNAME
|
||||
INQUIRE (FILE = fname, EXIST = exists)
|
||||
IF (.NOT. exists) THEN
|
||||
IF(SUB1 .EQ. 'PNG' .or. SUB1 .EQ. 'png') SUB2='PNGW'
|
||||
IF(SUB1 .EQ. 'JPG' .or. SUB1 .EQ. 'jpg') SUB2='JPGW'
|
||||
CALL ADDSUB(FNAME,SUB2)
|
||||
BFNAMR(NBKFL)=FNAME
|
||||
INQUIRE (FILE = fname, EXIST = exists)
|
||||
IF (.NOT. exists) THEN
|
||||
IF(SUB2 .EQ. 'JPGW') THEN
|
||||
SUB1='JGW'
|
||||
CALL ADDSUB(FNAME,SUB1)
|
||||
BFNAMR(NBKFL)=FNAME
|
||||
ENDIF
|
||||
ENDIF
|
||||
INQUIRE (FILE = fname, EXIST = exists)
|
||||
IF (.NOT. exists) THEN
|
||||
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Location file does not exist!!'//CHAR(13)// &
|
||||
'Do you wish to create file and view image','Looking for location file')
|
||||
! If answer 'Yes' set ifrmel to 0
|
||||
!
|
||||
IF (WInfoDialog(4) .ne. 2) then
|
||||
OPEN(104,FILE=FNAME,STATUS ='NEW', FORM ='FORMATTED')
|
||||
BFMINMAX(NBKFL,1) = - XS
|
||||
BFMINMAX(NBKFL,2) = - YS
|
||||
BFMINMAX(NBKFL,3) = HSIZE*TXSCAL - XS
|
||||
BFMINMAX(NBKFL,4) = 7.50*TXSCAL - YS
|
||||
WRITE(104,'(4G16.8)') (BFMINMAX(NBKFL,I),I=1,4)
|
||||
CLOSE(104)
|
||||
|
||||
EXIT
|
||||
ELSE
|
||||
NBKFL=NBKFL-1
|
||||
EXIT
|
||||
ENDIF
|
||||
ENDIF
|
||||
! yes
|
||||
OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED')
|
||||
READ(104,'(G16.8)') XX1
|
||||
READ(104,'(G16.8)') XX2
|
||||
READ(104,'(G16.8)') XX3
|
||||
READ(104,'(G16.8)') XX4
|
||||
READ(104,'(G16.8)') XX5
|
||||
READ(104,'(G16.8)') XX6
|
||||
CLOSE(104)
|
||||
call IGrFileInfo(BFNAME(NBKFL),INFO,3)
|
||||
|
||||
BFMINMAX(NBKFL,1) = XX5
|
||||
BFMINMAX(NBKFL,2) = XX6+INFO(3)*XX4
|
||||
BFMINMAX(NBKFL,3) = XX5+INFO(2)*XX1
|
||||
BFMINMAX(NBKFL,4) = XX6
|
||||
|
||||
CLOSE(104)
|
||||
GO TO 125
|
||||
ENDIF
|
||||
|
||||
OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED')
|
||||
READ(104,'(4G16.8)') (BFMINMAX(NBKFL,I),I=1,4)
|
||||
CLOSE(104)
|
||||
125 CONTINUE
|
||||
ENDIF
|
||||
|
||||
CASE (ID_ITEM24) ! Print option is selected
|
||||
CALL WHardcopyOptions(3)
|
||||
!
|
||||
! If the user clicked OK on page setup dialog then output the contents
|
||||
! of the subroutine DOPLOT to the selected printer
|
||||
!
|
||||
IF (WinfoDialog(ExitButtonCommon).EQ.CommonOK) THEN
|
||||
CALL IGrInit('HP') ! hardcopy only output
|
||||
CALL IGrFillPattern(Solid)
|
||||
|
||||
CALL IgrUnits(0.,0.,HSIZE,7.5)
|
||||
CALL IGrHardcopy(' ') ! Start print manager
|
||||
call clscrn
|
||||
CALL PLOTOT(0) ! plot graph
|
||||
call rblack
|
||||
CALL IGrRectangle(0.,0.,HSIZE,7.5)
|
||||
|
||||
CALL IGrHardcopy('S') ! Send data to the printer
|
||||
CALL IGrInit('P') ! Turn graphics back on
|
||||
CALL IGrFillPattern(Solid)
|
||||
|
||||
CALL IgrUnits(0.,0.,HSIZE,8.0)
|
||||
CALL PLOTOT(0)
|
||||
CALL HEDR
|
||||
call rblack
|
||||
CALL IGrRectangle(0.,0.,HSIZE,7.5)
|
||||
END IF
|
||||
|
||||
CASE (ID_ITEM19) ! Demo option
|
||||
MENUS=-1
|
||||
IMP=0
|
||||
IIN=0
|
||||
EXIT
|
||||
CASE (ID_ITEM17) ! Exit option
|
||||
call rquit(iyes)
|
||||
if(iyes .ne. 1) go to 100
|
||||
MENUS=0
|
||||
EXIT
|
||||
CASE (ID_EXIT) ! Exit program (menu option)
|
||||
call rquit(iyes)
|
||||
if(iyes .ne. 1) go to 100
|
||||
MENUS=0
|
||||
EXIT
|
||||
CASE (ID_NODE)
|
||||
MENUS=2
|
||||
EXIT
|
||||
CASE (ID_ELTS)
|
||||
MENUS=1
|
||||
EXIT
|
||||
CASE (ID_ORDR)
|
||||
MENUS=3
|
||||
EXIT
|
||||
CASE (ID_CCLN)
|
||||
MENUS=6
|
||||
EXIT
|
||||
CASE (ID_CSEC)
|
||||
MENUS=7
|
||||
EXIT
|
||||
CASE (ID_ZOOM)
|
||||
MENUS=8
|
||||
EXIT
|
||||
CASE (ID_DRAW)
|
||||
MENUS=9
|
||||
EXIT
|
||||
|
||||
CASE (ID_HELP1)
|
||||
call helps(0)
|
||||
go to 100
|
||||
|
||||
CASE (ID_HELP2)
|
||||
call RMINFO
|
||||
go to 100
|
||||
|
||||
CASE (ID_ITEM20)
|
||||
CALL GDIST
|
||||
CYCLE
|
||||
|
||||
CASE (ID_ITEM22)
|
||||
CALL SELNODE(0)
|
||||
CYCLE
|
||||
|
||||
CASE (ID_ALLNODES)
|
||||
CALL SELNODE(1)
|
||||
CYCLE
|
||||
|
||||
CASE (ID_UNUSNODES)
|
||||
CALL SELNODE(2)
|
||||
CYCLE
|
||||
|
||||
CASE (ID_ITEM23)
|
||||
CALL SELELT(0)
|
||||
CYCLE
|
||||
END SELECT
|
||||
CASE (PushButton) ! Dialog button pressed
|
||||
IDBUTN = MESSAGE%VALUE1
|
||||
IDFIELD = MESSAGE%VALUE2
|
||||
CASE (MouseButDown,MouseButUp) ! Mouse button down/up
|
||||
MBUTTON = MESSAGE%VALUE1
|
||||
ITIME = MESSAGE%VALUE2
|
||||
MOUSEX = MESSAGE%X
|
||||
MOUSEY = MESSAGE%Y
|
||||
CASE (MouseMove) ! Mouse moved
|
||||
ITIME = MESSAGE%VALUE2
|
||||
MOUSEX = MESSAGE%X
|
||||
MOUSEY = MESSAGE%Y
|
||||
CASE (Expose) ! Window partly/wholly exposed
|
||||
IX = MESSAGE%X
|
||||
IY = MESSAGE%Y
|
||||
IWIDTH = MESSAGE%VALUE1
|
||||
IHEIGHT = MESSAGE%VALUE2
|
||||
CASE (Resize) ! Window resized
|
||||
IWIDTH = MESSAGE%VALUE1
|
||||
IHEIGHT = MESSAGE%VALUE2
|
||||
CASE (CloseRequest) ! Close window (e.g. Alt/F4)
|
||||
IWINDOW = MESSAGE%WIN
|
||||
call rquit(iyes)
|
||||
if(iyes .ne. 1) go to 100
|
||||
menus=0
|
||||
exit
|
||||
! IF (IWINDOW.EQ.0) EXIT ! Root window : exit program
|
||||
! CALL WindowCloseChild(IWINDOW)
|
||||
CASE (FieldChanged) ! Field change in modeless dialog
|
||||
IDFIELDOLD = MESSAGE%VALUE1
|
||||
IDFIELDNEW = MESSAGE%VALUE2
|
||||
END SELECT
|
||||
END DO
|
||||
|
||||
500 continue
|
||||
IF(MENUS .NE. 0) THEN
|
||||
CALL RMAGEN(MENUS,IMP,IIN,0,IOT,IOT1,IGFG,ITRIAN,N2,M2)
|
||||
ENDIF
|
||||
close(90)
|
||||
CALL WindowClose ! Remove program window
|
||||
stop
|
||||
!! CALL WindowClose ! Remove program window
|
||||
END PROGRAM NEWRMAGEN
|
||||
|
||||
SUBROUTINE GETSUB(FNAME,SUB)
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=3) :: SUB
|
||||
INTEGER ,EXTERNAL :: LENSTR
|
||||
INTEGER :: LNNAM,K
|
||||
|
||||
LNNAM=LENSTR(FNAME)
|
||||
SUB=' '
|
||||
DO K=LNNAM,1,-1
|
||||
IF(FNAME(K:K) .EQ. '.') THEN
|
||||
IF(LNNAM .GT. K+2) THEN
|
||||
SUB=FNAME(K+1:K+3)
|
||||
ELSE
|
||||
SUB=' '
|
||||
ENDIF
|
||||
GO TO 110
|
||||
ENDIF
|
||||
ENDDO
|
||||
110 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE ADDSUB(FNAME,SUB)
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=*) :: SUB
|
||||
INTEGER ,EXTERNAL :: LENSTR
|
||||
INTEGER :: LNNAM,K,LMPNAM
|
||||
|
||||
LNNAM=LENSTR(FNAME)
|
||||
DO K=LNNAM,1,-1
|
||||
IF(FNAME(K:K) .EQ. '.') THEN
|
||||
lmpnam=k
|
||||
FNAME=FNAME(1:LMPNAM)//SUB
|
||||
GO TO 110
|
||||
ENDIF
|
||||
ENDDO
|
||||
FNAME=FNAME(1:LNNAM)//'.'//SUB
|
||||
110 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE SHORTNAME(FNAMELL,FNAMES)
|
||||
CHARACTER(LEN=255) :: FNAMELL
|
||||
CHARACTER(LEN=48) :: FNAMES
|
||||
INTEGER ,EXTERNAL :: LENSTR
|
||||
INTEGER :: LNNAM,K,KSTART,KEND
|
||||
|
||||
LNNAM=LENSTR(FNAMELL)
|
||||
DO K=1,48
|
||||
FNAMES(K:K)=' '
|
||||
ENDDO
|
||||
KSTART=1
|
||||
DO K=LNNAM,1,-1
|
||||
IF(FNAMELL(K:K) .EQ. '\') THEN
|
||||
KSTART=K+1
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ENDDO
|
||||
200 KEND=LNNAM-KSTART+1
|
||||
IF(KEND .GT. 48) KEND=48
|
||||
|
||||
FNAMES(1:KEND)=FNAMELL(KSTART:KSTART+KEND-1)
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,149 @@
|
||||
Subroutine NodeDisp(nin)
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
!
|
||||
include 'd.inc'
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
!
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
INTEGER :: N,IBOX,NN
|
||||
INTEGER :: IERR
|
||||
CHARACTER*1 :: IFLAG
|
||||
|
||||
if(nin .eq. 0) then
|
||||
n=1
|
||||
else
|
||||
n=nin
|
||||
endif
|
||||
ims=0
|
||||
100 continue
|
||||
call wdialogload(IDD_NODEDATA)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,N)
|
||||
NN=N
|
||||
XTEMP=XUSR(N)
|
||||
YTEMP=YUSR(N)
|
||||
WDTEMP=WIDTH(N)
|
||||
CALL WDialogPutReal(IDF_REAL1,XTEMP,'(F10.2)')
|
||||
CALL WDialogPutReal(IDF_REAL2,YTEMP,'(F10.2)')
|
||||
CALL WDialogPutReal(IDF_REAL3,WD(N),'(F10.2)')
|
||||
CALL WDialogPutReal(IDF_REAL4,WDTEMP,'(F10.2)')
|
||||
CALL WDialogPutReal(IDF_REAL5,SS1(N),'(F10.2)')
|
||||
CALL WDialogPutReal(IDF_REAL6,SS2(N),'(F10.2)')
|
||||
CALL WDialogPutReal(IDF_REAL7,WIDS(N),'(F10.2)')
|
||||
CALL WDialogPutReal(IDF_REAL8,WIDBS(N),'(F10.2)')
|
||||
CALL WDialogPutReal(IDF_REAL9,SSO(N),'(F10.2)')
|
||||
CALL WDialogPutReal(IDF_REAL10,BS1(N),'(F10.4)')
|
||||
IF(LOCK(N) .NE. 0) then
|
||||
CALL WDialogPutCheckBox(IDF_CHECK1,1)
|
||||
ELSE
|
||||
CALL WDialogPutCheckBox(IDF_CHECK1,0)
|
||||
ENDIF
|
||||
|
||||
CALL WDialogSelect(IDD_NODEDATA)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modeless)
|
||||
ierr=infoerror(1)
|
||||
|
||||
if(ims .eq. 1 .or. nin .gt. 0) go to 200
|
||||
150 CONTINUE
|
||||
call wdialogload(IDD_SELNODE)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogPutInteger(IDF_INTEGER1,N)
|
||||
|
||||
CALL WDialogSelect(IDD_SELNODE)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,ModaL)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
ims=1
|
||||
go to 100
|
||||
endif
|
||||
!ipk sep02
|
||||
ims=1
|
||||
go to 100
|
||||
enddo
|
||||
|
||||
200 continue
|
||||
! CALL WDialogSelect(IDD_NODEDATA)
|
||||
! ierr=infoerror(1)
|
||||
! Branch depending on type of message.
|
||||
!
|
||||
! CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
! WRITE(90,*) 'IN NODEDISP N,NN', N,NN
|
||||
! IF(N .NE. NN) go to 100
|
||||
|
||||
DO
|
||||
!WHILE(.NOT.QUIT)
|
||||
CALL WMessage(ITYPE,MESSAGE)
|
||||
SELECT CASE (ITYPE)
|
||||
CASE (PushButton)
|
||||
IF(MESSAGE%VALUE1.EQ.IDOK) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
CALL WDialogGetReal(IDF_REAL1,XTEMP)
|
||||
CALL WDialogGetReal(IDF_REAL2,YTEMP)
|
||||
XUSR(N)=XTEMP
|
||||
YUSR(N)=YTEMP
|
||||
CALL WDialogGetReal(IDF_REAL3,WD(N))
|
||||
CALL WDialogGetReal(IDF_REAL4,WDTEMP)
|
||||
CALL WDialogGetReal(IDF_REAL5,SS1(N))
|
||||
CALL WDialogGetReal(IDF_REAL6,SS2(N))
|
||||
CALL WDialogGetReal(IDF_REAL7,WIDS(N))
|
||||
CALL WDialogGetReal(IDF_REAL8,WIDBS(N))
|
||||
CALL WDialogGetReal(IDF_REAL9,SSO(N))
|
||||
CALL WDialogGetReal(IDF_REAL10,BS1(N))
|
||||
CORD(N,1)=(XUSR(N)+XS)/TXSCAL
|
||||
CORD(N,2)=(YUSR(N)+YS)/TXSCAL
|
||||
call WDialogHide()
|
||||
call wdialogUNload()
|
||||
WIDTH(N)=WDTEMP
|
||||
RETURN
|
||||
ELSEIF(MESSAGE%VALUE1.EQ.IDNEXT) THEN
|
||||
CALL WDialogGetInteger(IDF_INTEGER1,N)
|
||||
CALL WDialogGetReal(IDF_REAL1,XTEMP)
|
||||
CALL WDialogGetReal(IDF_REAL2,YTEMP)
|
||||
XUSR(N)=XTEMP
|
||||
YUSR(N)=YTEMP
|
||||
CALL WDialogGetReal(IDF_REAL3,WD(N))
|
||||
CALL WDialogGetReal(IDF_REAL4,WDTEMP)
|
||||
CALL WDialogGetReal(IDF_REAL5,SS1(N))
|
||||
CALL WDialogGetReal(IDF_REAL6,SS2(N))
|
||||
CALL WDialogGetReal(IDF_REAL7,WIDS(N))
|
||||
CALL WDialogGetReal(IDF_REAL8,WIDBS(N))
|
||||
CALL WDialogGetReal(IDF_REAL9,SSO(N))
|
||||
CALL WDialogGetReal(IDF_REAL10,BS1(N))
|
||||
CORD(N,1)=(XUSR(N)+XS)/TXSCAL
|
||||
CORD(N,2)=(YUSR(N)+YS)/TXSCAL
|
||||
WIDTH(N)=WDTEMP
|
||||
GO TO 150
|
||||
ELSEIF(MESSAGE%VALUE1.EQ.IDCANCEL) THEN
|
||||
call WDialogHide()
|
||||
call wdialogUNload()
|
||||
RETURN
|
||||
ENDIF
|
||||
END SELECT
|
||||
END DO
|
||||
|
||||
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
@ -0,0 +1,911 @@
|
||||
!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR CHNAGED ELEMENTS/NODES
|
||||
! Last change: IPK 13 Jan 98 10:01 am
|
||||
!ipk last update to add deletion opton when moving nodes
|
||||
!ipk last update Jan 12 1998
|
||||
!ipk last update Nov18 1997
|
||||
!
|
||||
!****************************************************************
|
||||
!
|
||||
SUBROUTINE ADDNOD
|
||||
!
|
||||
! Input additional node locations from screen
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
!IPK MAY02
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!
|
||||
CHARACTER*1 IFLAG,ANS,ANSW(0:9)
|
||||
CHARACTER*32 JUNK
|
||||
CHARACTER*20 NODH
|
||||
!ipk jan98
|
||||
CHARACTER*80 LIND
|
||||
DATA ANSW/'a','m','d','f','g','e','h','z','r','q'/
|
||||
data itime/0/
|
||||
|
||||
if(itime .eq. 0) then
|
||||
nodsh=1
|
||||
itime=1
|
||||
endif
|
||||
ISWT=3
|
||||
!
|
||||
! Draw box around selections
|
||||
!
|
||||
2 CONTINUE
|
||||
NHTP=4
|
||||
NMESS=0
|
||||
NBRR=0
|
||||
CALL HEDR
|
||||
!
|
||||
! Get answer
|
||||
!
|
||||
3 call xyloc(XPT,YPT,ANS,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
|
||||
IF(ANS .EQ. 'c') THEN
|
||||
if(ibox .eq. 0) go to 3
|
||||
I=IBOX-1
|
||||
ANS=ANSW(I)
|
||||
ENDIF
|
||||
!
|
||||
IF(ANS .EQ. 'a') THEN
|
||||
ISWT=1
|
||||
NHTP=0
|
||||
NBRR=0
|
||||
NMESS=16
|
||||
ELSEIF(ANS .EQ. 'm') THEN
|
||||
ISWT=0
|
||||
NHTP=0
|
||||
NBRR=0
|
||||
NMESS=17
|
||||
ELSEIF(ANS .EQ. 'd') THEN
|
||||
!
|
||||
! Call deleting operations
|
||||
!
|
||||
CALL DELOP
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
GO TO 2
|
||||
ELSEIF(ANS .EQ. 'e') THEN
|
||||
CALL GRIDSB(0)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
GO TO 2
|
||||
ELSEIF(ANS .EQ. 'q') THEN
|
||||
RETURN
|
||||
ELSEIF(ANS .EQ. 'f') THEN
|
||||
!
|
||||
! Search for a plot a grid centered around a node
|
||||
!
|
||||
NHTP=0
|
||||
NBRR=0
|
||||
NMESS=1
|
||||
CALL HEDR
|
||||
NMESS=1
|
||||
CALL GETINT(NODSH)
|
||||
IF(INEW(NODSH) .LE. 0) GO TO 2
|
||||
DO 4 I=1,NP
|
||||
IF(CORD(I,1) .GT. VOID) THEN
|
||||
INSKP(I)=0
|
||||
ENDIF
|
||||
4 CONTINUE
|
||||
DO 5 I=1,NE
|
||||
IF(IMAT(I) .GT. 0) THEN
|
||||
IESKP(I)=0
|
||||
ENDIF
|
||||
5 CONTINUE
|
||||
XP=CORD(NODSH,1)
|
||||
YP=CORD(NODSH,2)
|
||||
XMIN=XP-5.0*PSCALE
|
||||
YMIN=YP-3.5*PSCALE
|
||||
!ipk nov97 add (1)
|
||||
CALL PLOTOT(1)
|
||||
FPN=NODSH
|
||||
HT=0.15
|
||||
XP=CORD(NODSH,1)
|
||||
YP=CORD(NODSH,2)
|
||||
CALL RCYAN
|
||||
CALL NUMBR(XP,YP+0.07,HT,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
!
|
||||
GO TO 2
|
||||
ELSEIF(ANS .EQ. 'g') THEN
|
||||
!
|
||||
! This option generates nodes on a line
|
||||
!
|
||||
CALL GNODE(1)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
GO TO 2
|
||||
ELSEIF(ANS .EQ. 'h') THEN
|
||||
CALL HELPS(3)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
GO TO 2
|
||||
ELSE
|
||||
GO TO 3
|
||||
ENDIF
|
||||
6 CONTINUE
|
||||
!
|
||||
! Test for adding operation
|
||||
!
|
||||
IF(ISWT .EQ. 1) THEN
|
||||
!
|
||||
CALL GETNOD(J)
|
||||
CALL GETNOD(J)
|
||||
CALL GETNOD(J)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
! Get number of node nearest cursor (if ISWT = 0)
|
||||
!
|
||||
ELSE
|
||||
61 IBOX=1
|
||||
! CALL CLRBOX
|
||||
CALL HEDR
|
||||
!ipk jan98
|
||||
call wrtbox(idelv)
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!ipk jan98 add option for deleting elevation on move
|
||||
IF(IBOX .EQ. 7 .or. iflag .eq. 'e') THEN
|
||||
IDELV=MOD(IDELV+1,2)
|
||||
GO TO 61
|
||||
ENDIF
|
||||
J=INODE
|
||||
!ipk jan98
|
||||
if(idelv .eq. 1) then
|
||||
WD(J)=-9999.
|
||||
WIDTH(J)=0.
|
||||
SS1(J)=0.
|
||||
SS2(J)=0.
|
||||
WIDS(J)=0.
|
||||
WIDBS(J)=0.
|
||||
SSO(J)=0.
|
||||
endif
|
||||
!ipk jan98
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
!ipk feb94 CALL WRTOUT(0)
|
||||
GO TO 2
|
||||
ENDIF
|
||||
CALL PLTNOD(J,1)
|
||||
!
|
||||
ENDIF
|
||||
!
|
||||
! Deleting operation
|
||||
!
|
||||
IF(ISWT .EQ. 2) THEN
|
||||
WRITE(NODH,5000) j
|
||||
! CALL CLRBOX
|
||||
CALL HEDR
|
||||
CALL SYMBL(0.,7.70,0.20,NODH,0.,20)
|
||||
CALL DELETN(J)
|
||||
GO TO 6
|
||||
ENDIF
|
||||
WRITE(NODH,5000) j
|
||||
5000 FORMAT('Processing node',i5)
|
||||
7 CALL CLRBOX
|
||||
CALL SYMBL(0.,7.70,0.20,NODH,0.,20)
|
||||
NHTP=0
|
||||
! NMESS=0
|
||||
NBRR=3
|
||||
IF(ISWT .EQ. 0) then
|
||||
NMESS=16
|
||||
endif
|
||||
CALL HEDR
|
||||
!
|
||||
IF (J .GE. MAXP) THEN
|
||||
CALL SETD(23)
|
||||
!IPK JAN98 WRITE(*,*) ' Node number exceeds MAXP '
|
||||
!IPK JAN98 WRITE(*,*) ' Enter -save- to save the file as is'
|
||||
!IPK JAN98 WRITE(*,*) ' Enter -quit- to terminate'
|
||||
!IPK JAN98 READ(*,'(A)') JUNK
|
||||
CALL CLSCRN()
|
||||
WRITE(LIND,*) ' Node number exceeds MAXP '
|
||||
call symbl &
|
||||
& (1.1,4.6,0.25,LIND,0.0,80)
|
||||
WRITE(LIND,*) ' Enter -save- to save the file as is'
|
||||
call symbl &
|
||||
& (1.1,4.1,0.25,LIND,0.0,80)
|
||||
WRITE(LIND,*) ' Enter -quit- to terminate'
|
||||
call symbl &
|
||||
& (1.1,3.8,0.25,LIND,0.0,80)
|
||||
ndig=4
|
||||
CALL GTCHARX(JUNK,NDIG,5.0,4.0)
|
||||
IF(JUNK .NE. 'save') THEN
|
||||
CALL WRTOUT(0)
|
||||
CALL Quit_Pgm()
|
||||
stop
|
||||
else
|
||||
call wrtout(1)
|
||||
CALL Quit_Pgm()
|
||||
stop
|
||||
ENDIF
|
||||
!ipk an97 RETURN
|
||||
ENDIF
|
||||
!
|
||||
! Get screen coordinate of node
|
||||
!
|
||||
CALL XYLOC(XX,YY,IFLAG,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN
|
||||
!ipk feb94 CALL WRTOUT(0)
|
||||
! IF(ISWT .EQ. 2) NP=NP-1
|
||||
if(inew(j) .eq. 0 .and. j .eq. np) np=np-1
|
||||
GO TO 2
|
||||
ENDIF
|
||||
!
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
!
|
||||
IF(YY .GT. 7.5) THEN
|
||||
CALL DELETN(J)
|
||||
GO TO 6
|
||||
ENDIF
|
||||
INSKP(J)=0
|
||||
CORD(J,1) = XX
|
||||
CORD(J,2) = YY
|
||||
INEW(J) = 1
|
||||
!
|
||||
XUSR(J) = XX*TXSCAL - XS
|
||||
YUSR(J) = YY*TXSCAL - YS
|
||||
IF (J .GT. NP) NP = J
|
||||
! WRITE(IOT,'(I10,2F10.3)') J, XUSR(J),YUSR(J)
|
||||
CALL PLTNOD(J,0)
|
||||
ICHG=0
|
||||
!
|
||||
IF(ISWT .EQ. 0) NMESS=17
|
||||
GOTO 6
|
||||
ENDIF
|
||||
RETURN
|
||||
!
|
||||
END
|
||||
!
|
||||
!****************************************************************
|
||||
!
|
||||
SUBROUTINE ADDPTH
|
||||
!
|
||||
! Add nodal bottom elevations
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
CHARACTER*1 IFLAG,ANSW(10)
|
||||
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
DATA NTYPP,NLOCC,BELEV/1,0,0./
|
||||
!
|
||||
4 CONTINUE
|
||||
NHTP = 0
|
||||
NMESS = 45
|
||||
NBRR = 0
|
||||
CALL HEDR
|
||||
xprt=3.2
|
||||
NMESS = 14
|
||||
!
|
||||
CALL ADJUSTOPT(NTYPP,NLOCC)
|
||||
|
||||
CALL GETFPN(BELEV)
|
||||
!
|
||||
! Write out current depths
|
||||
!
|
||||
7 HT = .15
|
||||
DO 10 J=1,NP
|
||||
IF(INSKP(J) .EQ. 0) THEN
|
||||
IF (CORD(J,1) .GT. VDX) THEN
|
||||
!!SEP02 FPN = WD(J)*10.
|
||||
FPN = WD(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) + .07
|
||||
IF(X .GT. 0. .AND. X .LT. 10.0 .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||||
!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||||
call numbr(x,y,0.12,fpn,0.0,1)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
10 END DO
|
||||
!
|
||||
! Input new depths
|
||||
!
|
||||
NMESS = 15
|
||||
NBRR = 4
|
||||
CALL HEDR
|
||||
5 IBOX=1
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
!ipk feb94 CALL WRTOUT(0)
|
||||
RETURN
|
||||
ELSEIF(IFLAG .EQ. 'e' .OR. IFLAG .EQ. 'n') THEN
|
||||
!ipk nov97 add (1)
|
||||
CALL PLOTOT(1)
|
||||
GO TO 4
|
||||
ENDIF
|
||||
XPRT=XPRT+0.5
|
||||
IF(XPRT .GT. 10.) XPRT=0.
|
||||
FPN= INODE
|
||||
CALL RRED
|
||||
CALL NUMBR(XPRT,7.70,HT,FPN,0.0,-1)
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
IF(NTYPP .EQ. 1) THEN
|
||||
WD(INODE) = BELEV
|
||||
ELSE
|
||||
WD(INODE) = WD(INODE)+BELEV
|
||||
ENDIF
|
||||
IF(NLOCC .EQ. 1) THEN
|
||||
LOCK(INODE)=1
|
||||
ENDIF
|
||||
ichg=0
|
||||
FPN = WD(INODE)
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) -0.10
|
||||
call numbr(x,y,0.12,fpn,0.0,1)
|
||||
!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
!
|
||||
ELSEIF(IFLAG .EQ. 'a') THEN
|
||||
CALL RRED
|
||||
ichg=0
|
||||
DO 100 J=1,NP
|
||||
IF (CORD(J,1) .GE. VDX) THEN
|
||||
WD(J)=BELEV
|
||||
FPN=BELEV
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) + .11
|
||||
CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||||
ENDIF
|
||||
100 CONTINUE
|
||||
CALL RBLUE
|
||||
CALL WRTOUT(0)
|
||||
ELSEIF(IFLAG .EQ. 'f') THEN
|
||||
CALL RRED
|
||||
DO 110 J=1,NP
|
||||
IF (CORD(J,1) .GE. VDX .AND. WD(J) .LT. -9000.) THEN
|
||||
WD(J)=BELEV
|
||||
ichg=0
|
||||
FPN=BELEV
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) + .11
|
||||
CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||||
ENDIF
|
||||
110 CONTINUE
|
||||
CALL RBLUE
|
||||
CALL WRTOUT(0)
|
||||
!
|
||||
ELSE
|
||||
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||||
ENDIF
|
||||
!
|
||||
GOTO 5
|
||||
!
|
||||
END
|
||||
!
|
||||
SUBROUTINE JUNGEN(J,I,IERR)
|
||||
!
|
||||
! Find elements coming into node J, change all but first node
|
||||
! Form a new junction element
|
||||
!
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
!IPK MAY02
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
!
|
||||
KOUNT=1
|
||||
DO 200 N=1,NE
|
||||
!IPKOCT93 IF(IMAT(N) .GT. 0 .AND. IMAT(N) .LT. 901) THEN
|
||||
IF(IMAT(N) .GT. 0 .AND. (IMAT(N) .LT. 901 .OR. &
|
||||
& IMAT(N) .GT. 903) ) THEN
|
||||
DO 180 K=1,8
|
||||
IF(NOP(N,K) .EQ. I) THEN
|
||||
IF(K .GT. 3) THEN
|
||||
IERR=1
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(KOUNT .EQ. 1) THEN
|
||||
NOP(J,1)=I
|
||||
IJUN(J)=1
|
||||
KOUNT=2
|
||||
ELSE
|
||||
CALL GETNOD(N2)
|
||||
NOP(J,KOUNT)=N2
|
||||
IJUN(N2)=KOUNT
|
||||
KOUNT=KOUNT+1
|
||||
CORD(N2,1) = CORD(I,1)
|
||||
CORD(N2,2) = CORD(I,2)
|
||||
WD(N2)=WD(I)
|
||||
WIDTH(N2) = WIDTH(I)
|
||||
SS1(N2)=SS1(I)
|
||||
SS2(N2)=SS2(I)
|
||||
WIDS(N2)=WIDS(I)
|
||||
INSKP(N2)=0
|
||||
INEW(N2) = 1
|
||||
NOP(N,K) = N2
|
||||
!
|
||||
XUSR(N2) = CORD(N2,1)*TXSCAL - XS
|
||||
YUSR(N2) = CORD(N2,2)*TXSCAL - YS
|
||||
CALL PLTNOD(N2,1)
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ENDIF
|
||||
180 CONTINUE
|
||||
ENDIF
|
||||
200 END DO
|
||||
IF(KOUNT .LT. 9) THEN
|
||||
DO 300 K=KOUNT,8
|
||||
NOP(J,K)=0
|
||||
300 CONTINUE
|
||||
ENDIF
|
||||
IMAT(J)=901
|
||||
IESKP(J)=1
|
||||
RETURN
|
||||
END
|
||||
!
|
||||
!****************************************************************
|
||||
!
|
||||
SUBROUTINE ELDAT
|
||||
!
|
||||
! Add bottom elevations to message file and display
|
||||
!
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
USE WINTERACTER
|
||||
|
||||
include 'd.inc'
|
||||
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
!IPK MAY02
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!
|
||||
CHARACTER*1 IFLAG,ANSW(10)
|
||||
CHARACTER(LEN=256) :: FILTER
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
CHARACTER(LEN=3) :: SUB
|
||||
LOGICAL :: OPENED
|
||||
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
!
|
||||
!ipk mar00
|
||||
jp=2
|
||||
DO 200 N=1,MAXLIN
|
||||
IF(LINTYP(N) .EQ. -999) THEN
|
||||
NLIN=N
|
||||
GO TO 205
|
||||
ENDIF
|
||||
200 END DO
|
||||
205 CONTINUE
|
||||
IF(NLIN .GT. 1) THEN
|
||||
IF(LINTYP(NLIN-1) .NE. 2) THEN
|
||||
LINTYP(NLIN)=2
|
||||
ELSE
|
||||
NLIN=NLIN-1
|
||||
ENDIF
|
||||
ENDIF
|
||||
DO 250 J=MAXPL,1,-1
|
||||
IF(CMAP(J,1) .GE. VDX) THEN
|
||||
JP=J+1
|
||||
GO TO 255
|
||||
ENDIF
|
||||
250 END DO
|
||||
255 JP=JP-1
|
||||
IPSW(6)=1
|
||||
!ipk nov97 add (1)
|
||||
CALL PLOTOT(1)
|
||||
write(90,6010)
|
||||
6010 format(' The lines that follow are locations and new bottom ' &
|
||||
& ,'elevations.'/' Note that a zoom operation may insert'&
|
||||
& ,' other information')
|
||||
!
|
||||
4 CONTINUE
|
||||
NHTP = 0
|
||||
NMESS = 45
|
||||
NBRR = 0
|
||||
CALL HEDR
|
||||
!
|
||||
NMESS = 14
|
||||
CALL GETFPN(BELEV)
|
||||
!
|
||||
! Input new depths
|
||||
!
|
||||
7 CONTINUE
|
||||
NMESS = 15
|
||||
NBRR = 4
|
||||
CALL HEDR
|
||||
!
|
||||
! Get screen coordinates
|
||||
!
|
||||
IBOX = 0
|
||||
CALL XYLOC(XX,YY,IFLAG,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'q')THEN
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'e') THEN
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'n')THEN
|
||||
GO TO 4
|
||||
ENDIF
|
||||
!
|
||||
IF (IFLAG .EQ. 'c') THEN
|
||||
!
|
||||
JP=JP+1
|
||||
CMAP(JP,1) = XX
|
||||
CMAP(JP,2) = YY
|
||||
VAL(JP)=BELEV
|
||||
!
|
||||
XMAP(JP) = XX*TXSCAL - XS
|
||||
YMAP(JP) = YY*TXSCAL - YS
|
||||
IMAPOUT=27
|
||||
INQUIRE(27, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
Filter='MAP file -- *.map|*.map|'
|
||||
|
||||
CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Map Data File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
OPEN(IMAPOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE')
|
||||
WRITE(IMAPOUT,*) '2,0'
|
||||
ELSE
|
||||
GO TO 260
|
||||
ENDIF
|
||||
ENDIF
|
||||
WRITE(IMAPOUT,6000) XMAP(JP),YMAP(JP),VAL(JP)
|
||||
260 CONTINUE
|
||||
WRITE(90,6000) XMAP(JP),YMAP(JP),VAL(JP)
|
||||
6000 FORMAT(3F16.4)
|
||||
FPN = BELEV
|
||||
HT=0.15
|
||||
CALL RRED
|
||||
CALL NUMBR(XX,YY,HT,FPN,0.0,-1)
|
||||
!
|
||||
GOTO 7
|
||||
!
|
||||
ELSE
|
||||
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||||
ENDIF
|
||||
!
|
||||
GOTO 7
|
||||
!
|
||||
END
|
||||
!
|
||||
SUBROUTINE DELOP
|
||||
!
|
||||
! Input additional delete options from screen
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
!IPK MAY02
|
||||
INCLUDE 'TXFRM.COM'
|
||||
|
||||
INCLUDE 'BFILES.I90'
|
||||
|
||||
!
|
||||
CHARACTER*1 IFLAG,ANS,ANSW(0:9)
|
||||
CHARACTER*20 NODH
|
||||
DATA ANSW/'l','m','g','u','f','j','h','z','r','q'/
|
||||
!
|
||||
! Draw box around selections
|
||||
!
|
||||
2 CONTINUE
|
||||
NHTP=10
|
||||
NMESS=0
|
||||
NBRR=0
|
||||
CALL HEDR
|
||||
!
|
||||
! Get answer
|
||||
!
|
||||
3 call xyloc(XPT,YPT,ANS,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
!
|
||||
IF(ANS .EQ. 'c') THEN
|
||||
if(ibox .eq. 0) go to 3
|
||||
I=IBOX-1
|
||||
ANS=ANSW(I)
|
||||
ENDIF
|
||||
IF(ANS .EQ. 'l') THEN
|
||||
!
|
||||
! Delete all midside nodes
|
||||
!
|
||||
CALL DELETM(0)
|
||||
ELSEIF(ANS .EQ. 'm') THEN
|
||||
!
|
||||
! Delete all center located midsides
|
||||
!
|
||||
CALL DELETM(1)
|
||||
ELSEIF(ANS .EQ. 'g') THEN
|
||||
!
|
||||
! Deleting operation for nodes
|
||||
!
|
||||
NHTP=0
|
||||
NBRR=3
|
||||
NMESS=18
|
||||
|
||||
6 CONTINUE
|
||||
!
|
||||
IBOX=1
|
||||
CALL HEDR
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
J=INODE
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
!ipk feb94 CALL WRTOUT(0)
|
||||
GO TO 2
|
||||
ENDIF
|
||||
CALL PLTNOD(J,1)
|
||||
!
|
||||
WRITE(NODH,5000) j
|
||||
5000 FORMAT('Processing node',i5)
|
||||
CALL HEDR
|
||||
CALL SYMBL(0.,7.70,0.20,NODH,0.,20)
|
||||
CALL DELETN(J)
|
||||
IRDONE=0
|
||||
GO TO 6
|
||||
ELSEIF(ANS .EQ. 'u') THEN
|
||||
!
|
||||
! Delete all unused nodes
|
||||
!
|
||||
CALL DELETM(2)
|
||||
ELSEIF(ANS .EQ. 'j') THEN
|
||||
!
|
||||
! Join two nodes together in the element lists
|
||||
!
|
||||
CALL JOIN(1)
|
||||
ELSEIF(ANS .EQ. 'f') THEN
|
||||
!
|
||||
! Fill midside nodes
|
||||
!
|
||||
!ipk aug02
|
||||
CALL FILM(0)
|
||||
ELSEIF(ANS .EQ. 'h') THEN
|
||||
CALL HELPS(7)
|
||||
ELSEIF(ANS .EQ. 'q') THEN
|
||||
RETURN
|
||||
ENDIF
|
||||
GO TO 2
|
||||
END
|
||||
!
|
||||
SUBROUTINE JOIN(ISWTJ)
|
||||
!
|
||||
! Routine to join references to two nodes
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*1 IFLAG
|
||||
!
|
||||
61 IBOX=1
|
||||
NHTP=0
|
||||
NBRR=3
|
||||
NMESS=15
|
||||
CALL HEDR
|
||||
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
RETURN
|
||||
ENDIF
|
||||
FPN= INODE
|
||||
CALL NUMBR(2.0,7.70,0.2,FPN,0.0,-1)
|
||||
! CALL PROX(CORD(1,1),CORD(1,2),NP,XX2,YY2,INODE2,IFLAG,INSKP,IBOX)
|
||||
! IF(IFLAG .EQ. 'q') THEN
|
||||
! RETURN
|
||||
! ELSEIF(INODE2 .EQ. INODE) THEN
|
||||
!
|
||||
! Get second node
|
||||
!
|
||||
CALL PROX2(CORD(1,1),CORD(1,2),NP,XX,YY,INODE, &
|
||||
& XX2,YY2,INODE2,IFLAG,INSKP,IBOX)
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
RETURN
|
||||
ENDIF
|
||||
! ENDIF
|
||||
! FPN= INODE2
|
||||
! CALL NUMBR(2.5,7.70,0.2,FPN,0.0,-1)
|
||||
|
||||
INODE1=INODE
|
||||
CALL JOINDEL(INODE1,INODE2)
|
||||
|
||||
CALL PLOTOT(1)
|
||||
GO TO 61
|
||||
! ENDIF
|
||||
END
|
||||
|
||||
SUBROUTINE JOINDEL(INODE1,INODE2)
|
||||
! Routine to join references to two nodes
|
||||
!
|
||||
USE BLK1MOD
|
||||
!
|
||||
! Search for references to INODE2
|
||||
!
|
||||
DO N=1,NE
|
||||
NCN=NCORN(N)
|
||||
IF(NCN .GT. 0) THEN
|
||||
DO M=1,NCN
|
||||
IF(NOP(N,M) .EQ. INODE2) THEN
|
||||
!
|
||||
! Change them to INODE
|
||||
!
|
||||
NOP(N,M)=INODE1
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
!
|
||||
! Remove node now
|
||||
!
|
||||
CORD(INODE2,1)=VOID
|
||||
CORD(INODE2,2)=VOID
|
||||
XUSR(INODE2) = VOID
|
||||
YUSR(INODE2) = VOID
|
||||
INSKP(INODE2)=1
|
||||
INEW(INODE2) = 0
|
||||
WD(INODE2)=-9999.
|
||||
WIDTH(INODE2)=0.
|
||||
SS1(INODE2)=0.
|
||||
SS2(INODE2)=0.
|
||||
WIDS(INODE2)=0.
|
||||
!IPK MAY03
|
||||
ICHG=0
|
||||
!ipk nov97 add (1)
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE JOINALL
|
||||
USE BLK1MOD
|
||||
|
||||
NMESS = 46
|
||||
TOLER=0.1
|
||||
CALL GETFPN(TOLER)
|
||||
|
||||
DO N=1,NP-1
|
||||
IF(CORD(N,1) .EQ. VOID) CYCLE
|
||||
DO M=N+1,NP
|
||||
IF(CORD(M,1) .EQ. VOID) CYCLE
|
||||
DIST=SQRT((YUSR(M)-YUSR(N))**2+(XUSR(M)-XUSR(N))**2)
|
||||
IF(DIST .LT. TOLER) THEN
|
||||
CALL JOINDEL(N,M)
|
||||
GO TO 100
|
||||
ENDIF
|
||||
ENDDO
|
||||
100 CONTINUE
|
||||
ENDDO
|
||||
|
||||
CALL PLOTOT(1)
|
||||
RETURN
|
||||
END
|
||||
!****************************************************************
|
||||
!
|
||||
SUBROUTINE ADDPTH2(nodlist,ndlist)
|
||||
!
|
||||
! Add nodal bottom elevations
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
!
|
||||
CHARACTER*1 IFLAG,ANSW(10)
|
||||
|
||||
dimension nodlist(*)
|
||||
|
||||
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
DATA NTYPP,NLOCC/1,0/
|
||||
!
|
||||
4 CONTINUE
|
||||
NHTP = 0
|
||||
NMESS = 45
|
||||
NBRR = 0
|
||||
CALL HEDR
|
||||
xprt=3.2
|
||||
NMESS = 14
|
||||
!
|
||||
CALL ADJUSTOPT(NTYPP,NLOCC)
|
||||
|
||||
CALL GETFPN(BELEV)
|
||||
!
|
||||
! Write out current depths
|
||||
!
|
||||
7 HT = .15
|
||||
DO 10 J=1,NP
|
||||
IF(INSKP(J) .EQ. 0) THEN
|
||||
IF (CORD(J,1) .GT. VDX) THEN
|
||||
!!SEP02 FPN = WD(J)*10.
|
||||
FPN = WD(J)
|
||||
X = CORD(J,1)
|
||||
Y = CORD(J,2) + .07
|
||||
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||||
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||||
!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||||
call numbr(x,y,0.12,fpn,0.0,1)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDIF
|
||||
10 END DO
|
||||
!
|
||||
! Input new depths
|
||||
!
|
||||
DO J=1,NDLIST
|
||||
INODE=NODLIST(J)
|
||||
FPN= INODE
|
||||
CALL RRED
|
||||
|
||||
IF(NTYPP .EQ. 1) THEN
|
||||
WD(INODE) = BELEV
|
||||
ELSE
|
||||
WD(INODE) = WD(INODE)+BELEV
|
||||
ENDIF
|
||||
IF(NLOCC .EQ. 1) THEN
|
||||
LOCK(INODE)=1
|
||||
ENDIF
|
||||
ichg=0
|
||||
FPN = WD(INODE)
|
||||
X = CORD(INODE,1)
|
||||
Y = CORD(INODE,2) -0.10
|
||||
call numbr(x,y,0.12,fpn,0.0,1)
|
||||
!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
ENDDO
|
||||
!
|
||||
!
|
||||
RETURN
|
||||
!
|
||||
END
|
||||
!
|
||||
SUBROUTINE FINDNOD
|
||||
!
|
||||
! Search for a plot a grid centered around a node
|
||||
!
|
||||
!
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
!IPK MAY02
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!
|
||||
NHTPSAV=NHTP
|
||||
NMESSAV=NMESS
|
||||
NBRRSAV=NBRR
|
||||
NHTP=0
|
||||
NBRR=0
|
||||
NMESS=1
|
||||
CALL HEDR
|
||||
NMESS=1
|
||||
CALL GETINT(NODSH)
|
||||
IF(INEW(NODSH) .LE. 0) RETURN
|
||||
DO 4 I=1,NP
|
||||
IF(CORD(I,1) .GT. VOID) THEN
|
||||
INSKP(I)=0
|
||||
ENDIF
|
||||
4 CONTINUE
|
||||
DO 5 I=1,NE
|
||||
IF(IMAT(I) .GT. 0) THEN
|
||||
IESKP(I)=0
|
||||
ENDIF
|
||||
5 CONTINUE
|
||||
XP=CORD(NODSH,1)
|
||||
YP=CORD(NODSH,2)
|
||||
XMIN=XP-5.0*PSCALE
|
||||
YMIN=YP-3.5*PSCALE
|
||||
!ipk nov97 add (1)
|
||||
CALL PLOTOT(1)
|
||||
FPN=NODSH
|
||||
HT=0.15
|
||||
XP=CORD(NODSH,1)
|
||||
YP=CORD(NODSH,2)
|
||||
CALL RCYAN
|
||||
CALL NUMBR(XP,YP+0.07,HT,FPN,0.0,-1)
|
||||
CALL RBLUE
|
||||
NHTP=NHTPSAV
|
||||
NMESS=NMESSAV
|
||||
NBRR=NBRRSAV
|
||||
CALL HEDR
|
||||
!
|
||||
RETURN
|
||||
END
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 1.4 KiB |
@ -0,0 +1,303 @@
|
||||
SUBROUTINE OUTLINES(ISWT)
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLK1MOD
|
||||
include 'd.inc'
|
||||
! INCLUDE 'BLK1.COM'
|
||||
|
||||
! INTEGER*2 MSN
|
||||
! COMMON /MID/ MSN(MAXP)
|
||||
|
||||
CHARACTER(LEN=255) :: FNAME,FILTER
|
||||
CHARACTER(LEN=4) :: SUB
|
||||
REAL XCEN(10),YCEN(10),MTYP(10)
|
||||
LOGICAL OPENED,LSTAT
|
||||
CHARACTER*1 IFLAG,ANS(10)
|
||||
DATA ANS/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
DATA PI2/1.5708/
|
||||
IF(.NOT. ALLOCATED(ICONNCT)) THEN
|
||||
ALLOCATE (ICONNCT(MAXP,3),IOUTLST(10,5000),NOUTLST(10),NKEP(MAXP))
|
||||
ENDIF
|
||||
IF(.NOT. ALLOCATED(XOUT)) THEN
|
||||
ALLOCATE (XOUT(5000,10),YOUT(5000,10))
|
||||
ENDIF
|
||||
NOUTLST=0
|
||||
IOUTSW=2
|
||||
IPOS=2
|
||||
IF(ISWT .EQ. 1) GO TO 80
|
||||
IOUTOUT=26
|
||||
INQUIRE(26, OPENED=OPENED)
|
||||
if(.not. opened) then
|
||||
Filter='OUTLINE file -- *.dat|*.dat|POLY file -- *.poly|*.poly|'
|
||||
|
||||
CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Outline File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
OPEN(IOUTOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE')
|
||||
ELSE
|
||||
GO TO 1
|
||||
ENDIF
|
||||
ENDIF
|
||||
|
||||
1 CONTINUE
|
||||
|
||||
call wdialogload(IDD_DIALOG08)
|
||||
ierr=infoerror(1)
|
||||
|
||||
|
||||
call wdialogputRadioButton(idf_radio1)
|
||||
|
||||
|
||||
CALL WDialogSelect(IDD_DIALOG08)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
|
||||
do
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
|
||||
call wdialoggetradiobutton(idf_radio1,ipos)
|
||||
ipos=3-ipos
|
||||
go to 50
|
||||
endif
|
||||
ipos= 0
|
||||
go to 50
|
||||
enddo
|
||||
ipos= 2
|
||||
50 continue
|
||||
IF(SUB(1:3) .EQ. 'dat') THEN
|
||||
IOUTSW=0
|
||||
ELSE
|
||||
IOUTSW=1
|
||||
ENDIF
|
||||
!
|
||||
! FORM LIST OF ELEMENT SIDES THAT ARE ON THE OUTSIDE
|
||||
80 CONTINUE
|
||||
DO N=1,NP
|
||||
MSN(N)=0
|
||||
ENDDO
|
||||
ILINEL=0
|
||||
DO N=1,NE
|
||||
IF(IMAT(N) .LE. 0) CYCLE
|
||||
IF(IMAT(N) .NE. 999 .AND. NCORN(N) .GT. 5 .AND. (IMAT(N) .LT. 900 .OR. IMAT(N) .GT. 903)) THEN
|
||||
NCN=NCORN(N)
|
||||
DO K=2,NCN,2
|
||||
J = NOP(N,K)
|
||||
if(J .gt. 0) then
|
||||
MSN(J) = MSN(J) + 1
|
||||
ICONNCT(J,3)=N
|
||||
ICONNCT(J,1)=NOP(N,K-1)
|
||||
IF(K .EQ. NCN) THEN
|
||||
ICONNCT(J,2)=NOP(N,1)
|
||||
ELSE
|
||||
ICONNCT(J,2)=NOP(N,K+1)
|
||||
ENDIF
|
||||
endif
|
||||
ENDDO
|
||||
ELSEIF(IMAT(N) .NE. 999 .AND. NCORN(N) .LE. 5 .AND. (IMAT(N) .LT. 900 .OR. IMAT(N) .GT. 903)) THEN
|
||||
ILINEL=1
|
||||
IF(NCORN(N) .EQ. 5) THEN
|
||||
DO K=1,5,4
|
||||
J=NOP(N,K)
|
||||
MSN(J)=MSN(J)-1
|
||||
ICONNCT(J,-MSN(J))=N
|
||||
ENDDO
|
||||
ELSE
|
||||
DO K=1,3,2
|
||||
J=NOP(N,K)
|
||||
MSN(J)=MSN(J)-1
|
||||
ICONNCT(J,-MSN(J))=N
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
|
||||
! WORK THROUGH OUTSIDE NODES FORMING UP TO 10 CONTIUOUS SEQUENCES
|
||||
|
||||
DO K=1,10
|
||||
JJ=0
|
||||
DO J=1,NP
|
||||
IF(MSN(J) .EQ. 1) THEN
|
||||
MTYP(K)=1
|
||||
!
|
||||
! THIS IS A STARTING POINT EXTRACT A CORNER NODE
|
||||
IOUTLST(K,1)=ICONNCT(J,1)
|
||||
if(ipos .eq. 1) then
|
||||
IOUTLST(K,2)=ICONNCT(J,2)
|
||||
JJ=2
|
||||
else
|
||||
IOUTLST(K,2)=J
|
||||
IOUTLST(K,3)=ICONNCT(J,2)
|
||||
JJ=3
|
||||
endif
|
||||
N=ICONNCT(J,3)
|
||||
IF(NOP(N,7) .EQ. 0) THEN
|
||||
XCEN(K)=(XUSR(NOP(N,1))+XUSR(NOP(N,3))+XUSR(NOP(N,5)))/3.
|
||||
YCEN(K)=(YUSR(NOP(N,1))+YUSR(NOP(N,3))+YUSR(NOP(N,5)))/3.
|
||||
ELSE
|
||||
XCEN(K)=(XUSR(NOP(N,1))+XUSR(NOP(N,3))+XUSR(NOP(N,5))+XUSR(NOP(N,7)))/4.
|
||||
YCEN(K)=(YUSR(NOP(N,1))+YUSR(NOP(N,3))+YUSR(NOP(N,5))+YUSR(NOP(N,7)))/4.
|
||||
ENDIF
|
||||
MSN(J)=0
|
||||
ICONNCT(J,1)=0
|
||||
ICONNCT(J,2)=0
|
||||
|
||||
! NOW LOOK FOR A CONNECTION TO ICONNCT(J,2)
|
||||
|
||||
100 CONTINUE
|
||||
DO L=1,NP
|
||||
IF(MSN(L) .EQ. 1) THEN
|
||||
IF(ICONNCT(L,1) .EQ. IOUTLST(K,JJ)) THEN
|
||||
|
||||
! FOUND ONE
|
||||
|
||||
if(ipos .eq. 2) then
|
||||
IOUTLST(K,JJ+1)=ICONNCT(L,2)
|
||||
JJ=JJ+1
|
||||
else
|
||||
IOUTLST(K,JJ+1)=L
|
||||
IOUTLST(K,JJ+2)=ICONNCT(L,2)
|
||||
JJ=JJ+2
|
||||
endif
|
||||
MSN(L)=0
|
||||
ICONNCT(L,1)=0
|
||||
JTEMP=ICONNCT(L,2)
|
||||
ICONNCT(L,2)=0
|
||||
IF(JTEMP .EQ. IOUTLST(K,1)) GO TO 200
|
||||
GO TO 100
|
||||
ELSEIF(ICONNCT(L,2) .EQ. IOUTLST(K,JJ)) THEN
|
||||
|
||||
! FOUND ONE THE OPPOSITE WAY
|
||||
|
||||
IOUTLST(K,JJ+1)=L
|
||||
IOUTLST(K,JJ+2)=ICONNCT(L,1)
|
||||
JJ=JJ+2
|
||||
MSN(L)=0
|
||||
JTEMP=ICONNCT(L,1)
|
||||
ICONNCT(L,1)=0
|
||||
ICONNCT(L,2)=0
|
||||
IF(JTEMP .EQ. IOUTLST(K,1)) GO TO 200
|
||||
GO TO 100
|
||||
ENDIF
|
||||
|
||||
ENDIF
|
||||
ENDDO
|
||||
ELSEIF(MSN(J) .EQ. -1) THEN
|
||||
MTYP(K)=-1
|
||||
JJ=J
|
||||
JO=J
|
||||
LL=1
|
||||
NN=ICONNCT(JJ,LL)
|
||||
IOUTLST(K,LL)=JJ
|
||||
130 LL=LL+1
|
||||
IF(NCORN(NN) .EQ. 5) THEN
|
||||
NNOP=5
|
||||
ELSE
|
||||
NNOP=3
|
||||
ENDIF
|
||||
IF(NOP(NN,1) .EQ. JJ) THEN
|
||||
JJ=NOP(NN,NNOP)
|
||||
JL=NOP(NN,3)
|
||||
IOUTLST(K,LL)=JL
|
||||
ELSE
|
||||
JJ=NOP(NN,1)
|
||||
JL=JJ
|
||||
IOUTLST(K,LL)=JJ
|
||||
ENDIF
|
||||
CALL GETLINANG(ANGL,JO,JJ)
|
||||
ANGL1=ANGL-PI2
|
||||
IF(LL .EQ. 2) THEN
|
||||
XOUT(1,K)=XUSR(JO)+WIDTH(JO)/2.*COS(ANGL1)
|
||||
YOUT(1,K)=YUSR(JO)+WIDTH(JO)/2.*SIN(ANGL1)
|
||||
XOUT(4999,K)=XUSR(JO)-WIDTH(JO)/2.*COS(ANGL1)
|
||||
YOUT(4999,K)=YUSR(JO)-WIDTH(JO)/2.*SIN(ANGL1)
|
||||
ENDIF
|
||||
XOUT(LL,K)=XUSR(JL)+WIDTH(JL)/2.*COS(ANGL1)
|
||||
YOUT(LL,K)=YUSR(JL)+WIDTH(JL)/2.*SIN(ANGL1)
|
||||
XOUT(5000-LL,K)=XUSR(JL)-WIDTH(JL)/2.*COS(ANGL1)
|
||||
YOUT(5000-LL,K)=YUSR(JL)-WIDTH(JL)/2.*SIN(ANGL1)
|
||||
|
||||
IF(MSN(JJ) .EQ. -1) GO TO 150
|
||||
IF(ICONNCT(JJ,1) .EQ. NN) THEN
|
||||
NN=ICONNCT(JJ,2)
|
||||
ELSE
|
||||
NN=ICONNCT(JJ,1)
|
||||
ENDIF
|
||||
GO TO 130
|
||||
150 MSN(JJ)=0
|
||||
JJ=LL
|
||||
DO JJJ=LL,1,-1
|
||||
JJ=JJ+1
|
||||
XOUT(JJ,K)=XOUT(5000-JJJ,K)
|
||||
YOUT(JJ,K)=YOUT(5000-JJJ,K)
|
||||
ENDDO
|
||||
JJ=JJ+1
|
||||
XOUT(JJ,K)=XOUT(1,K)
|
||||
YOUT(JJ,K)=YOUT(1,K)
|
||||
MSN(J)=0
|
||||
GO TO 200
|
||||
ENDIF
|
||||
ENDDO
|
||||
GO TO 300
|
||||
200 CONTINUE
|
||||
NOUTLST(K)=JJ
|
||||
IF(JJ .GT. 0) THEN
|
||||
IF(IOUTSW .EQ. 1) THEN
|
||||
NDIM=2
|
||||
NZERO=0
|
||||
NONE=1
|
||||
WRITE(IOUTOUT,*)NOUTLST(K)-1,NDIM,NZERO,NZERO
|
||||
DO L=1,NOUTLST(K)-1
|
||||
WRITE(IOUTOUT,*) L,XUSR(IOUTLST(K,L)),YUSR(IOUTLST(K,L))
|
||||
ENDDO
|
||||
WRITE(IOUTOUT,*) NOUTLST(K)-1,NZERO
|
||||
DO I=1,NOUTLST(K)-2
|
||||
WRITE(IOUTOUT,*) I,I,I+1
|
||||
ENDDO
|
||||
WRITE(IOUTOUT,*) NOUTLST(K)-1,NOUTLST(K)-1,NONE
|
||||
|
||||
WRITE(IOUTOUT,*) NZERO
|
||||
ELSE
|
||||
DO L=1,NOUTLST(K)
|
||||
IF(MTYP(K) .EQ. 1) THEN
|
||||
XOUT(L,K)=XUSR(IOUTLST(K,L))
|
||||
YOUT(L,K)=YUSR(IOUTLST(K,L))
|
||||
ENDIF
|
||||
IF(IOUTSW .EQ. 0) THEN
|
||||
WRITE(IOUTOUT,*) XOUT(L,K),YOUT(L,K)
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDIF
|
||||
ENDDO
|
||||
300 CONTINUE
|
||||
DO K=1,10
|
||||
IF(NOUTLST(K) .EQ. 0) GO TO 400
|
||||
IF(MTYP(K) .EQ. 1) THEN
|
||||
LSTAT=IGrInsidePolygon(XOUT(1,K),YOUT(1,K),NOUTLST(K),XCEN(K),YCEN(K))
|
||||
ELSE
|
||||
LSTAT=.TRUE.
|
||||
ENDIF
|
||||
IF(LSTAT) THEN
|
||||
NOUTLST(K)=ABS(NOUTLST(K))
|
||||
ELSE
|
||||
NOUTLST(K)=-ABS(NOUTLST(K))
|
||||
ENDIF
|
||||
ENDDO
|
||||
400 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE GETLINANG(angle,n1,n2)
|
||||
USE BLK1MOD
|
||||
! use ATAN2 and angle into range 0 to 2*pi
|
||||
ANGLE=ATAN2(YUSR(N2)-YUSR(N1),XUSR(N2)-XUSR(N1))
|
||||
IF(ANGLE .LT. 0.) ANGLE=ANGLE+6.28318515
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,65 @@
|
||||
!IPK LAST UPDATED JULY 17 1998
|
||||
!ipk last update Dec 10 1997
|
||||
!IPK LAST UPDATED OCT 18 1996
|
||||
!
|
||||
SAVE
|
||||
!
|
||||
! This version is compiled for: LARGE
|
||||
! MAXE = maximum number of elements = 200000
|
||||
! MAXP = maximum number of nodes =400000
|
||||
! MAXPL = maximum number of map data points =1800000
|
||||
! MAXLIN = maximum number of map lines = 3000
|
||||
! MAXLN = maximum number of reordering lines = 20
|
||||
! MAELN = maximum number of elements in a reodering list = 300
|
||||
! MAXPGEN= maximum number elements in a genreated block = 2000
|
||||
! MAXGRD = maximum number of grid points = 3000
|
||||
!
|
||||
!
|
||||
!
|
||||
! PARAMETER (MAXE= 200000,MAXP=400000,MAXLIN=6000,MAXECON=60)
|
||||
! PARAMETER (MAXLN=20,MAELN=300,MAXPGEN=2000,MAXGRD=3000,MAXSTO=2)
|
||||
! PARAMETER (MAXE8=8*MAXE,MAXP2=2*MAXP)
|
||||
|
||||
! This version is compiled for: MEDIUM
|
||||
! MAXE = maximum number of elements =130000
|
||||
! MAXP = maximum number of nodes =200000
|
||||
! MAXPL = maximum number of map data points =1500000
|
||||
! MAXLIN = maximum number of map lines = 3000
|
||||
! MAXLN = maximum number of reordering lines = 20
|
||||
! MAELN = maximum number of elements in a reodering list = 300
|
||||
! MAXPGEN= maximum number elements in a genreated block = 2000
|
||||
! MAXGRD = maximum number of grid points = 1000
|
||||
! MAXSTO = maximum storage locations = 2
|
||||
!
|
||||
!
|
||||
PARAMETER (MAXPGEN=20000,MAXGRD=1000)
|
||||
! PARAMETER (MAXE8=8*MAXE,MAXP2=2*MAXP)
|
||||
! PARAMETER (MCRS=7000,MPTS=75)
|
||||
|
||||
! This version is compiled for: STANDARD
|
||||
! MAXE = maximum number of elements = 40000
|
||||
! MAXP = maximum number of nodes = 50000
|
||||
! MAXPL = maximum number of map data points = 200000
|
||||
! MAXLIN = maximum number of map lines = 3000
|
||||
! MAXLN = maximum number of reordering lines = 20
|
||||
! MAELN = maximum number of elements in a reodering list = 300
|
||||
! MAXPGEN= maximum number elements in a genreated block = 2000
|
||||
! MAXGRD = maximum number of grid points = 300
|
||||
! MAXSTO = maximum storage locations = 2
|
||||
!
|
||||
!
|
||||
! PARAMETER (MAXE= 40000,MAXP=50000,MAXLIN=6000,MAXECON=60)
|
||||
! PARAMETER (MAXLN=20,MAELN=300,MAXPGEN=2000,MAXGRD=3000,MAXSTO=2)
|
||||
! PARAMETER (MCRS=600,MPTS=50)
|
||||
! PARAMETER (MAXE8=8*MAXE,MAXP2=2*MAXP)
|
||||
|
||||
!
|
||||
! CORD is the screen scale variable
|
||||
! XUSR is the map scale variable
|
||||
! To get to CORD from XUSR use
|
||||
! CORD(N,1)=(XUSR(N)+XS)/TXSCAL
|
||||
! To get to XUSR from CORD use
|
||||
! XUSR(N2) = CORD(N2,1)*TXSCAL - XS
|
||||
! XS,YS and TXSCAL are kept in TXFRM.COM
|
||||
! REAL*8 XS,YS,TXSCAL
|
||||
! COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
@ -0,0 +1,41 @@
|
||||
SUBROUTINE PLOTORDS
|
||||
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
! INCLUDE 'BLK2.COM'
|
||||
|
||||
NLSTP=NLST+1
|
||||
call getxc
|
||||
DO N=1,NLSTP
|
||||
FPN=N
|
||||
DO M=1,NE
|
||||
|
||||
! Get element in list
|
||||
|
||||
IF(N .LT. NLSTP) THEN
|
||||
J=ILIST(N,M)
|
||||
ELSE
|
||||
J=ilisttmp(M)
|
||||
ENDIF
|
||||
! IF(IMAT(J) .EQ. 0) THEN
|
||||
! ENDIF
|
||||
|
||||
IF(J .GT. 0) THEN
|
||||
IF(XC(J) .GT. 0. .AND. XC(J) .LT. HSIZE) THEN
|
||||
IF(YC(J) .GT. 0. .AND. YC(J) .LT. 7.5) THEN
|
||||
xxc=xc(j)
|
||||
yyc=yc(j)
|
||||
CALL NUMBR(XXC,YYC,0.15,FPN,0.0,-1)
|
||||
ENDIF
|
||||
ENDIF
|
||||
ELSE
|
||||
GO TO 300
|
||||
ENDIF
|
||||
|
||||
ENDDO
|
||||
300 CONTINUE
|
||||
ENDDO
|
||||
|
||||
RETURN
|
||||
END
|
||||
@ -0,0 +1,204 @@
|
||||
!ipk last change July 14 updating of cycw changes in 97
|
||||
! Last change: IPK 12 Jan 98 1:55 pm
|
||||
!ipk last update Nov 18 1997
|
||||
!ipk last updated Oct 17 1996
|
||||
!ipk last updated Oct 14 1996
|
||||
|
||||
SUBROUTINE RDRW(IS)
|
||||
|
||||
! Determine how to draw grid according to switch setting
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*1 ANS,ANSW(10)
|
||||
character*38 mesg
|
||||
|
||||
! Draw box around selections
|
||||
|
||||
DATA ANSW/'m','o','e','n','t','y','l','d','b','r'/
|
||||
! m 1 o 2 e 5 n 3 t 4 u 7 g 8 d 6 b 9
|
||||
NHTP=5
|
||||
NMESS=0
|
||||
NBRR=0
|
||||
100 CONTINUE
|
||||
CALL HEDR
|
||||
|
||||
! Get answer
|
||||
|
||||
call xyloc(XPT,YPT,ANS,IBOX)
|
||||
IF(IRMAIN .EQ. 1) RETURN
|
||||
if(ibox .le. 0) go to 100
|
||||
IF(ANS .EQ. 'c') THEN
|
||||
ANS=ANSW(IBOX)
|
||||
ENDIF
|
||||
IF(ANS .EQ. 'm') THEN
|
||||
!ipk oct96
|
||||
if(ipsw(1) .eq. 0) then
|
||||
call getmpcl
|
||||
NHTP=5
|
||||
endif
|
||||
!ipk oc96 end addition
|
||||
IPSW(1)=MOD(IPSW(1)+1,2)
|
||||
GO TO 100
|
||||
ELSEIF(ANS .EQ. 'o') THEN
|
||||
IPSW(2)=MOD(IPSW(2)+1,2)
|
||||
GO TO 100
|
||||
ELSEIF(ANS .EQ. 'n') THEN
|
||||
IPSW(3)=MOD(IPSW(3)+1,2)
|
||||
IF(IPSW(3) .EQ. 1) IPSW(9)=0
|
||||
IF(IPSW(3) .EQ. 1) IPSW(14)=0
|
||||
GO TO 100
|
||||
ELSEIF(ANS .EQ. 't') THEN
|
||||
IPSW(4)=MOD(IPSW(4)+1,2)
|
||||
GO TO 100
|
||||
ELSEIF(ANS .EQ. 'e') THEN
|
||||
IPSW(5)=MOD(IPSW(5)+1,2)
|
||||
if(ipsw(5) .eq. 1) ipsw(7)=0
|
||||
GO TO 100
|
||||
ELSEIF(ANS .EQ. 'd') THEN
|
||||
IPSW(6)=MOD(IPSW(6)+1,2)
|
||||
if(ipsw(6) .eq. 1) then
|
||||
!ipk apr02
|
||||
call getmdis(nmapf,nsigf,icolsw,rad,colint)
|
||||
! write(mesg,*) 'Enter output frequency for map display'
|
||||
! call symbl (1.1,7.3,0.25,mesg,0.0,38)
|
||||
! call getint(nmapf)
|
||||
endif
|
||||
GO TO 100
|
||||
ELSEIF(ANS .EQ. 'y') THEN
|
||||
IPSW(7)=MOD(IPSW(7)+1,2)
|
||||
if(ipsw(7) .eq. 1) ipsw(5)=0
|
||||
GO TO 100
|
||||
!ipk feb01 drop this option in favour of ccline ELSEIF(ANS .EQ. 'g') THEN
|
||||
!ipk feb01 IPSW(8)=MOD(IPSW(8)+1,2)
|
||||
!ipk feb01 GO TO 100
|
||||
ELSEIF(ANS .EQ. 'l') THEN
|
||||
IPSW(10)=MOD(IPSW(10)+1,2)
|
||||
GO TO 100
|
||||
ELSEIF(ANS .EQ. 'b') THEN
|
||||
IPSW(9)=MOD(IPSW(9)+1,2)
|
||||
IF(IPSW(9) .EQ. 1) IPSW(3)=0
|
||||
IF(IPSW(9) .EQ. 1) IPSW(14)=0
|
||||
GO TO 100
|
||||
ELSEIF(ANS .EQ. 'r') THEN
|
||||
|
||||
! CALL PLOTS(IS)
|
||||
!ipk nov97 add (0)
|
||||
CALL PLOTOT(1)
|
||||
RETURN
|
||||
ENDIF
|
||||
GO TO 100
|
||||
END
|
||||
|
||||
SUBROUTINE GETMPCL
|
||||
|
||||
! Determine how to draw grid according to switch setting
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*1 ANS,ANSW(10)
|
||||
|
||||
! Draw box around selections
|
||||
|
||||
DATA ANSW/'e','o','t','h','f','i','s','v','g','q'/
|
||||
! m 1 o 2 e 5 n 3 t 4 u 7 g 8 d 6 b 9
|
||||
NHTP=12
|
||||
100 CONTINUE
|
||||
CALL HEDR
|
||||
|
||||
! Get answer
|
||||
|
||||
call xyloc(XPT,YPT,ANS,IBOX)
|
||||
IF(ANS .NE. 'c') then
|
||||
DO K=1,10
|
||||
IF(ANS .EQ. ANSW(K)) THEN
|
||||
IBOX=K
|
||||
GO TO 102
|
||||
ENDIF
|
||||
ENDDO
|
||||
102 CONTINUE
|
||||
ENDIF
|
||||
IF(IBOX .EQ. 10) GO TO 150
|
||||
ICOLON(IBOX)=MOD(ICOLON(IBOX)+1,2)
|
||||
CALL HEDR
|
||||
GO TO 100
|
||||
150 NHTP=5
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE GDIST
|
||||
|
||||
USE BLK1MOD
|
||||
! INCLUDE 'BLK1.COM'
|
||||
CHARACTER*1 ANS,ANSW(10)
|
||||
|
||||
|
||||
INCLUDE 'TXFRM.COM'
|
||||
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
||||
|
||||
DATA ANSW/6*' ','n','z','r','q'/
|
||||
!
|
||||
NHTPSV=NHTP
|
||||
NMESSV=NMESS
|
||||
NBRRSV=NBRR
|
||||
100 CONTINUE
|
||||
NHTP=0
|
||||
NMESS=41
|
||||
NBRR=4
|
||||
CALL CLRBOX
|
||||
CALL HEDR
|
||||
call xyloc(XPT1,YPT1,ANS,IBOX)
|
||||
call xyloc(XPT2,YPT2,ANS,IBOX)
|
||||
DIST=SQRT((YPT2-YPT1)**2+(XPT2-XPT1)**2)*TXSCAL
|
||||
CALL CLRBOX
|
||||
NMESS=0
|
||||
NBRR=4
|
||||
CALL HEDR
|
||||
CALL NUMBR(0.5,7.55,0.20,DIST,0.0,2)
|
||||
CALL XYLOC(XPT1,YPT1,ANS,IBOX)
|
||||
IF(ANS .NE. 'c') then
|
||||
DO K=1,10
|
||||
IF(ANS .EQ. ANSW(K)) THEN
|
||||
IBOX=K
|
||||
GO TO 102
|
||||
ENDIF
|
||||
ENDDO
|
||||
102 CONTINUE
|
||||
ENDIF
|
||||
IF(IBOX .EQ. 7) GO TO 100
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSV
|
||||
NBRR=NBRRSV
|
||||
CALL CLRBOX
|
||||
CALL HEDR
|
||||
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE CHEXIT
|
||||
USE WINTERACTER
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
INTEGER :: ITYPE
|
||||
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||||
|
||||
CALL WMessagePeek(ITYPE, MESSAGE)
|
||||
|
||||
SELECT CASE (ITYPE)
|
||||
CASE (-1)
|
||||
RETURN
|
||||
CASE (KeyDown) ! Key pressed
|
||||
IPSW(1)=0
|
||||
IPSW(2)=1
|
||||
IPSW(3)=0
|
||||
IPSW(4)=0
|
||||
IPSW(5)=0
|
||||
IPSW(6)=0
|
||||
IPSW(7)=0
|
||||
IPSW(8)=0
|
||||
IPSW(9)=0
|
||||
IPSW(12)=0
|
||||
RETURN
|
||||
ENDSELECT
|
||||
RETURN
|
||||
END
|
||||
File diff suppressed because it is too large
Load Diff
@ -0,0 +1,46 @@
|
||||
MODULE BLKOUT
|
||||
ALLOCATABLE XOUTL(:),YOUTL(:)
|
||||
INTEGER NOUTLIN
|
||||
ENDMODULE
|
||||
|
||||
SUBROUTINE RDOUTLIN
|
||||
!
|
||||
! ROUTINE TO READ COORDINATES OF MESH OUTLINE
|
||||
|
||||
USE WINTERACTER
|
||||
USE BLKOUT
|
||||
|
||||
CHARACTER(LEN=255) :: FNAME
|
||||
! CHARACTER(LEN=3) :: SUB,SUB1
|
||||
CHARACTER(LEN=256) :: FILTER
|
||||
CHARACTER*3 SUB
|
||||
|
||||
FILTER ="Outline files -- *.txt,*.map|*.txt;*.map|txt files -- |*.txt|map files -- |*.map|All files -- |*.*|"
|
||||
CALL WSelectFile(FILTER,PromptOn,FNAME,'Load Outline File')
|
||||
|
||||
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||||
|
||||
OPEN(99,FILE=FNAME,STATUS='OLD')
|
||||
CALL IlowerCase(FNAME)
|
||||
CALL GETSUB(FNAME,SUB)
|
||||
|
||||
IF(SUB .EQ. 'map') then
|
||||
KTYP=2
|
||||
ELSE
|
||||
KTYP=1
|
||||
ENDIF
|
||||
ELSE
|
||||
RETURN
|
||||
ENDIF
|
||||
|
||||
ALLOCATE (XOUTL(5000),YOUTL(5000))
|
||||
IF(KTYP .EQ. 2) READ(99,*) INDM
|
||||
DO N=1,5000
|
||||
READ(99,*,END=500,ERR=500) XOUTL(N),YOUTL(N)
|
||||
ENDDO
|
||||
close(99)
|
||||
500 CONTINUE
|
||||
NOUTLIN=N-1
|
||||
RETURN
|
||||
END
|
||||
|
||||
@ -0,0 +1,111 @@
|
||||
SUBROUTINE RDRM1(IFILE,NPTEMP,NETEMP,IMIDS)
|
||||
|
||||
SAVE
|
||||
|
||||
REAL*8 CX,CY
|
||||
CHARACTER DLINE*140,ID1*3,BLANK*20
|
||||
DIMENSION ILN(8)
|
||||
|
||||
data blank/' '/
|
||||
|
||||
|
||||
REWIND (IFILE)
|
||||
READ(ifile,'(A80)') TITLE
|
||||
READ(IFILE,'(100X,I5)') IFORM1
|
||||
READ(IFILE,'(A80)') DLINE(1:80)
|
||||
|
||||
IMIDS=0
|
||||
NP=0
|
||||
NE=0
|
||||
NPTEMP=0
|
||||
NETEMP=0
|
||||
|
||||
100 CALL GINPT1(IFILE,DLINE)
|
||||
|
||||
|
||||
!ipk feb12 add format test
|
||||
IF(MOD(IFORM1,2) .EQ. 1) THEN
|
||||
READ(DLINE,'(10I6,F10.3,I6)') J,ILN,IMT,EDIR,INU
|
||||
ELSE
|
||||
READ(DLINE,'(10I5,F10.3,I5)') J,ILN,IMT,EDIR,INU
|
||||
ENDIF
|
||||
IF(ILN(1) .EQ. 0 .AND. (J .EQ. 9999 .OR. J .EQ. 99999)) THEN
|
||||
GO TO 120
|
||||
ELSE
|
||||
IF(ILN(7) .NE. 0) THEN
|
||||
NCN=8
|
||||
ELSEIF(ILN(5) .NE. 0) THEN
|
||||
NCN=6
|
||||
ELSEIF(ILN(3) .NE. 0) THEN
|
||||
NCN=3
|
||||
ENDIF
|
||||
|
||||
DO K=1,NCN
|
||||
NPTEMP=MAX(NPTEMP,ILN(K))
|
||||
NETEMP=MAX(NETEMP,J)
|
||||
IF(MOD(K,2) .EQ. 0 .AND. ILN(K) .EQ. 0) IMIDS=1
|
||||
ENDDO
|
||||
GO TO 100
|
||||
ENDIF
|
||||
|
||||
120 continue
|
||||
|
||||
CALL GINPT1(IFILE,DLINE)
|
||||
|
||||
IF(IFORM1 .LT. 2) THEN
|
||||
READ(DLINE,'(I10,9F10.0,I10,F10.0)') J, CX, CY, BELEV,&
|
||||
WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11
|
||||
ELSE
|
||||
! do kct=1,140
|
||||
! if(dline(kct:kct) .eq. '*') then
|
||||
do kcl=61,140
|
||||
dline(kcl:kcl)=' '
|
||||
enddo
|
||||
! go to 8888
|
||||
! endif
|
||||
! enddo
|
||||
!8888 continue
|
||||
READ(DLINE,'(I10,2F20.0,7F10.0,I10,F10.0)',err=8888) J, CX, CY, BELEV,&
|
||||
WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11
|
||||
go to 8889
|
||||
8888 do kcl=61,140
|
||||
dline(kcl:kcl)=' '
|
||||
enddo
|
||||
READ(DLINE,'(I10,2F20.0,7F10.0,I10,F10.0)') J, CX, CY, BELEV,&
|
||||
WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11
|
||||
8889 continue
|
||||
ENDIF
|
||||
|
||||
|
||||
IF(DLINE(11:30) .eq. blank .AND. (J .EQ. 9999 .OR. J .EQ. 99999)) THEN
|
||||
GO TO 140
|
||||
ELSE
|
||||
NPTEMP=MAX(NPTEMP,J)
|
||||
GO TO 120
|
||||
ENDIF
|
||||
140 CONTINUE
|
||||
|
||||
REWIND(IFILE)
|
||||
RETURN
|
||||
END
|
||||
|
||||
SUBROUTINE GINPT1(IIN,DLIN)
|
||||
CHARACTER DLIN*140
|
||||
100 CONTINUE
|
||||
READ(IIN,7000) DLIN
|
||||
!IPK SEP08 write(75,7000) dlin
|
||||
7000 FORMAT(A140)
|
||||
do i=1,140
|
||||
if(dlin(i:i) .eq. char(9)) go to 200
|
||||
enddo
|
||||
RETURN
|
||||
200 continue
|
||||
!IPK SEP04
|
||||
CLOSE(75)
|
||||
OPEN(75,file='ERROR.OUT')
|
||||
write(*,*) 'Error Tab character found in the following line'
|
||||
write(75,*) 'Error Tab character found in the following line'
|
||||
write(75,7000) dlin
|
||||
write(*,7000) dlin
|
||||
stop
|
||||
END
|
||||
@ -0,0 +1,226 @@
|
||||
SUBROUTINE READSHP
|
||||
|
||||
USE BLKMAP
|
||||
USE BLK1MOD
|
||||
character*4 temp
|
||||
character*100 header
|
||||
character*256 field
|
||||
character*4 ai7,aai7,ai8
|
||||
integer status,i1,i2,i3,i4,i5,i6,i7,i8,i9
|
||||
integer*2 i1s,i2s,i3s
|
||||
integer*1 i1vs(20),i2vs(20)
|
||||
real*8 fp1,fp2,fp3,fp4,fp5,fp6,fp7,fp8,vtemp(20)
|
||||
character*11 label(20),fomat(20)
|
||||
character*1 type(20),a2,a3,a4
|
||||
character*2 a32
|
||||
equivalence (aai7,ia7),(aai8,ia8)
|
||||
|
||||
c read header
|
||||
|
||||
read(113) i1,i2,i3,i4,i5,i6,ai7,i8,i9
|
||||
read(113) fp1,fp2,fp3,fp4,fp5,fp6,fp7,fp8
|
||||
CALL BTOL(AI7,IA7)
|
||||
write(90,*) 'file length',ia7
|
||||
write(90,*) 'version',i8
|
||||
write(90,*) 'shapetype',i9
|
||||
|
||||
c read data
|
||||
|
||||
read(114) i1,i2,i1s,i2s,i3,i4,i5,i6,i7
|
||||
nrecs=i2
|
||||
nbytesh=i1s
|
||||
nrecsh=nbytesh/32-1
|
||||
ndytesrec=i2s
|
||||
nfl=0
|
||||
|
||||
c now process labels
|
||||
|
||||
do k=1,nrecsh
|
||||
read(114) label(k),type(k),i3,i1vs(k),i2vs(k),i3s,i4,i5,i6
|
||||
if(type(k) .eq. 'F' .or. type(k) .eq. 'N') then
|
||||
if(i2vs(k) .gt. 9) then
|
||||
write(fomat(k),5999) i1vs(k),i2vs(k)
|
||||
5999 format('(F',i2,'.',i2,')')
|
||||
else
|
||||
write(fomat(k),6000) i1vs(k),i2vs(k)
|
||||
6000 format('(F',i2,'.',i1,')')
|
||||
endif
|
||||
else
|
||||
if(i1vs(k) .lt. 0) then
|
||||
itemp= i1vs(k)+256
|
||||
write(fomat(k),60011) itemp
|
||||
60011 format('(A',i3,')')
|
||||
|
||||
elseif(i1vs (k) .lt. 10) then
|
||||
write(fomat(k),6001) i1vs(k)
|
||||
6001 format('(A',i1,')')
|
||||
else
|
||||
write(fomat(k),6002) i1vs(k)
|
||||
6002 format('(A',i2,')')
|
||||
endif
|
||||
endif
|
||||
nfl=nfl+i1vs(k)
|
||||
enddo
|
||||
read(114) a32
|
||||
call choosrec(label,nrecsh,nchs)
|
||||
|
||||
|
||||
230 continue
|
||||
JK=0
|
||||
JL=0
|
||||
if(i9 .eq. 1) then
|
||||
do JJ=1,200000
|
||||
read(113,end=300) ai7,ai8
|
||||
CALL BTOL(AI7,IA7)
|
||||
CALL BTOL(AI8,IA8)
|
||||
READ(113) I1,FP1,FP2
|
||||
CMAP(JJ,1)=FP1
|
||||
CMAP(JJ,2)=FP2
|
||||
XMAP(JJ)=FP1
|
||||
YMAP(JJ)=FP2
|
||||
MAXPTS=JJ
|
||||
c VAL(JJ)=-2.
|
||||
ENDDO
|
||||
300 CONTINUE
|
||||
XMAP(MAXPTS+1)= VOID
|
||||
LINTYP(1)=2
|
||||
|
||||
!
|
||||
!c finished shape file now read dbf stat with header
|
||||
!
|
||||
! read(114) i1,i2,i1s,i2s,i3,i4,i5,i6,i7
|
||||
! nrecs=i2
|
||||
! nbytesh=i1s
|
||||
! nrecsh=nbytesh/32-1
|
||||
! ndytesrec=i2s
|
||||
! nfl=0
|
||||
!
|
||||
!c now process labels
|
||||
!
|
||||
! do k=1,nrecsh
|
||||
! read(114) label(k),type(k),i3,i1vs(k),i2vs(k),i3s,i4,i5,i6
|
||||
! if(type(k) .eq. 'F' .or. type(k) .eq. 'N') then
|
||||
! write(fomat(k),6000) i1vs(k),i2vs(k)
|
||||
! 6000 format('(F',i2,'.',i1,')')
|
||||
! else
|
||||
! if(i1vs (k) .lt. 10) then
|
||||
! write(fomat(k),6001) i1vs(k)
|
||||
! 6001 format('(A',i1,')')
|
||||
! else
|
||||
! write(fomat(k),6002) i1vs(k)
|
||||
! 6002 format('(A',i2,')')
|
||||
! endif
|
||||
! endif
|
||||
! nfl=nfl+i1vs(k)
|
||||
! enddo
|
||||
!read(114) a3
|
||||
!call choosrec(label,nrecsh,nchs)
|
||||
do j=1,nrecs
|
||||
do k=1,nrecsh
|
||||
if(i1vs(k) .lt. 0) then
|
||||
itemp=i1vs(k)+256
|
||||
else
|
||||
itemp=i1vs(k)
|
||||
endif
|
||||
read(114) field(1:itemp)
|
||||
read(field,fomat(k)) vtemp(k)
|
||||
enddo
|
||||
val(j)=vtemp(NCHS)
|
||||
read(114) a3
|
||||
enddo
|
||||
else
|
||||
do JJ=1,200000
|
||||
read(113,end=500) ai7,ai8
|
||||
CALL BTOL(AI7,IA7)
|
||||
CALL BTOL(AI8,IA8)
|
||||
read(113) istp,FP1,FP2,FP3,FP4,npart,npts,nd1
|
||||
! do j=1,nrecs
|
||||
do k=1,nrecsh
|
||||
read(114) field(1:i1vs(k))
|
||||
read(field,fomat(k)) vtemp(k)
|
||||
enddo
|
||||
read(114) a3
|
||||
! enddo
|
||||
JL=JL+1
|
||||
LINTYP(JL)=1
|
||||
do k=1,npts
|
||||
read(113) fp1,fp2
|
||||
WRITE(155,*) JK,JL,FP1,FP2,VTEMP(NCHS)
|
||||
jk=jk+1
|
||||
CMAP(jk,1)=FP1
|
||||
CMAP(jk,2)=FP2
|
||||
XMAP(jk)=FP1
|
||||
YMAP(jk)=FP2
|
||||
MAXPTS=jk
|
||||
val(jK)=vtemp(NCHS)
|
||||
|
||||
enddo
|
||||
jk=jk+1
|
||||
CMAP(jk,1)=-1.e10
|
||||
CMAP(jk,2)=-1.e10
|
||||
XMAP(jk)=-1.e10
|
||||
YMAP(jk)=-1.e10
|
||||
MAXPTS=jk
|
||||
val(jK)=0.
|
||||
enddo
|
||||
500 continue
|
||||
MAXPTS=JK-1
|
||||
KLINT=JL
|
||||
JLINT=MAXPTS
|
||||
endif
|
||||
CLOSE (113)
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
SUBROUTINE BTOL(AICHG,ICHG)
|
||||
INTEGER ICHG,ITEMP
|
||||
CHARACTER*4 AICHG,AAICHG
|
||||
EQUIVALENCE(ITEMP,AAICHG)
|
||||
aaICHG(1:1)=aICHG(4:4)
|
||||
aaICHG(2:2)=aICHG(3:3)
|
||||
aaICHG(3:3)=aICHG(2:2)
|
||||
aaICHG(4:4)=aICHG(1:1)
|
||||
ICHG=ITEMP
|
||||
RETURN
|
||||
END
|
||||
|
||||
subroutine choosrec(label,nrecsh,nchs)
|
||||
use winteracter
|
||||
implicit none
|
||||
include 'D.inc'
|
||||
SAVE
|
||||
character*11 label(*)
|
||||
INTEGER NRECSH,NCHS,IERR,N
|
||||
|
||||
|
||||
!
|
||||
! Declare window-type and message variables
|
||||
!
|
||||
TYPE(WIN_STYLE) :: WINDOW
|
||||
|
||||
TYPE(WIN_MESSAGE) :: MESSAGE
|
||||
|
||||
call wdialogload(IDD_CHSTYP)
|
||||
ierr=infoerror(1)
|
||||
|
||||
do n=1,NRECSH
|
||||
write(90,'(a)') 'file',n,LABEL(N)
|
||||
CALL WDialogPutString(idf_string25+n-1,LABEL(n))
|
||||
call wdialogputradiobutton(idf_radio1)
|
||||
enddo
|
||||
CALL WDialogSelect(IDD_CHSTYP)
|
||||
ierr=infoerror(1)
|
||||
|
||||
CALL WDialogShow(-1,-1,0,Modal)
|
||||
ierr=infoerror(1)
|
||||
|
||||
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||||
call wdialogGetradiobutton(idf_radio1,NCHS)
|
||||
ENDIF
|
||||
RETURN
|
||||
END
|
||||
|
||||
|
||||
|
||||
|
||||
@ -0,0 +1,110 @@
|
||||
SUBROUTINE REATTACH
|
||||
|
||||
|
||||
USE BLK1MOD
|
||||
USE BLK2MOD
|
||||
|
||||
INTEGER NS1(3,4),NT1(3,4)
|
||||
CHARACTER*1 IFLAG,ANSW(10)
|
||||
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||||
|
||||
! SETUP CONNECTIVITY TABLE
|
||||
CALL KCON(0)
|
||||
! SELECT FIRST ELEMENT
|
||||
10 CONTINUE
|
||||
NHTPSV=NHTP
|
||||
NMESSSV=NMESS
|
||||
NBRRSV=NBRR
|
||||
NHTP=0
|
||||
NMESS=20
|
||||
NBRR=8
|
||||
CALL HEDR
|
||||
|
||||
CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX)
|
||||
IF(IRMAIN .EQ. 1) THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||||
IFLAG=ANSW(IBOX)
|
||||
ENDIF
|
||||
!
|
||||
IF(IFLAG .EQ. 'q') THEN
|
||||
NHTP=NHTPSV
|
||||
NMESS=NMESSSV
|
||||
NBRR=NBRRSV
|
||||
CALL HEDR
|
||||
RETURN
|
||||
ENDIF
|
||||
call fillem(ielem)
|
||||
! GET UNATTACHED NOP
|
||||
kk=0
|
||||
DO K=2,NCORN(IELEM),2
|
||||
NSX=NOP(IELEM,K)
|
||||
IF(NDELM(NSX) .EQ. 1) THEN
|
||||
! FOUND IT
|
||||
KK=KK+1
|
||||
NS1(1,KK)=NOP(IELEM,K-1)
|
||||
NS1(2,KK)=NSX
|
||||
KKK=MOD(K,NCORN(IELEM))+1
|
||||
NS1(3,KK)=NOP(IELEM,KKK)
|
||||
! GO TO 280
|
||||
ENDIF
|
||||
ENDDO
|
||||
280 CONTINUE
|
||||
|
||||
|
||||
! SELECT NEXT ELEMENT
|
||||
|
||||
CALL PROX(XC,YC,NE,XX,YY,IELEM1,IFLAG,IESKP,IBOX)
|
||||
call fillem(ielem1)
|
||||
|
||||
! GET UNNATCHED SIDE
|
||||
! FIND AN UNATTACHED SIDE (INDICATE OF TRIANGLE OR QUADRILATERAL)
|
||||
LL=0
|
||||
DO K=2,NCORN(IELEM1),2
|
||||
NSX=NOP(IELEM1,K)
|
||||
IF(NDELM(NSX) .EQ. 1) THEN
|
||||
! FOUND IT
|
||||
LL=LL+1
|
||||
NT1(1,LL)=NOP(IELEM1,K-1)
|
||||
NT1(2,LL)=NSX
|
||||
KKK=MOD(K,NCORN(IELEM1))+1
|
||||
NT1(3,LL)=NOP(IELEM1,KKK)
|
||||
! GO TO 300
|
||||
ENDIF
|
||||
ENDDO
|
||||
300 CONTINUE
|
||||
|
||||
! FORM A NEW ELEMENT ASSIGN TYPE AS INDICATED
|
||||
! GET THE NEAREST TWO FACES
|
||||
DISTKP=1.E20
|
||||
DO NN=1,KK
|
||||
DO MM=1,LL
|
||||
DIST=(XUSR(NS1(2,NN))-XUSR(NT1(2,MM)))**2+(YUSR(NS1(2,NN))-YUSR(NT1(2,MM)))**2
|
||||
IF(DIST .LT. DISTKP) THEN
|
||||
NNN=NN
|
||||
MMM=MM
|
||||
DISTKP=DIST
|
||||
ENDIF
|
||||
ENDDO
|
||||
ENDDO
|
||||
CALL GETELM(J)
|
||||
DO K=1,3
|
||||
NOP(J,K)=NS1(K,NNN)
|
||||
NOP(J,K+4)=NT1(K,MMM)
|
||||
ENDDO
|
||||
NOP(J,4)=0
|
||||
NOP(J,8)=0
|
||||
IMAT(J)=1
|
||||
IESKP(J) = 0
|
||||
NCORN(J)=8
|
||||
|
||||
! GO BACK TO LOOK FOR NEW PAIR
|
||||
CALL PLOTOT(1)
|
||||
GO TO 10
|
||||
RETURN
|
||||
END
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue