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