!! Copyright (C) Stichting Deltares, 2005-2017. !! !! This file is part of iMOD. !! !! This program is free software: you can redistribute it and/or modify !! it under the terms of the GNU General Public License as published by !! the Free Software Foundation, either version 3 of the License, or !! (at your option) any later version. !! !! This program is distributed in the hope that it will be useful, !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! GNU General Public License for more details. !! !! You should have received a copy of the GNU General Public License !! along with this program. If not, see . !! !! Contact: imod.support@deltares.nl !! Stichting Deltares !! P.O. Box 177 !! 2600 MH Delft, The Netherlands. !! MODULE MOD_3D_ENGINE USE WINTERACTER USE RESOURCE USE MODPLOT USE IMODVAR, ONLY : IBACKSLASH,ILABELNAME USE MOD_IDF, ONLY : IDFREAD,IDFDEALLOCATE,IDFGETVAL,IDFREADPART,IDFDEALLOCATEX,IDFNULLIFY,IDFEQUAL,& IDFREADSCALE_GETX,IDFCOPY,IDF_EXTENT,IDFALLOCATEX,IDFGETLOC,IDFIROWICOL USE MOD_IDF_PAR, ONLY : IDFOBJ USE MOD_COLOURS, ONLY : ICOLOR USE MOD_UTL, ONLY : INVERSECOLOUR,UTL_CAP,UTL_GETUNIT,ITOS,RTOS,UTL_FILLARRAY,UTL_IDFGETCLASS, & UTL_IDFSNAPTOGRID,UTL_MESSAGEHANDLE,UTL_INSIDEPOLYGON,UTL_WAITMESSAGE,NEWLINE,UTL_LOADIMAGE, & UTL_EQUALS_REAL,UTL_GETAXESCALES,SXVALUE,SYVALUE,NSX,NSY,UTL_GETFORMAT USE MOD_GENPLOT_PAR USE MOD_IFF, ONLY : UTL_GETUNITIFF,IFF,IFFPLOT_GETIFFVAL USE MOD_IPFASSFILE, ONLY : IPFOPENASSFILE,IPFREADASSFILELABEL,IPFREADASSFILE,IPFCLOSEASSFILE,IPFDRAWITOPIC2_ICLR, & IPFASSFILEALLOCATE,IPFINITASSFILE USE MOD_IPF_PAR, ONLY : ASSF,IPF,NIPF,MAXLITHO,BH,NLITHO USE MOD_IPF, ONLY : IPFINIT,IPFREAD,IPFDEALLOCATE USE MOD_3D_PAR USE MOD_3D_UTL, ONLY : IMOD3D_RETURNCOLOR,IMOD3D_SETCOLOR,IMOD3D_DRAWIDF_SIZE,IMOD3D_CREATE_SXY,IMOD3D_BLANKOUT,IMOD3D_BLANKOUT_XY USE MOD_MDF, ONLY : READMDF,READMDF_GETN,MDF,MDFDEALLOCATE USE MOD_OSD, ONLY : OSD_OPEN USE MOD_SOLID_PAR, ONLY : SPF,NSPF,PX,PZ,SLD USE MOD_SOF, ONLY : SOF_COMPUTE_GRAD,SOF_COMPUTE_GRAD_3D USE MOD_POLYGON_UTL, ONLY : POLYGON1SAVELOADSHAPE,POLYGON1INIT,POLYGON1CLOSE USE MOD_POLYGON_PAR, ONLY : SHPNCRD,SHPNO,SHPXC,SHPYC USE MOD_DEMO_PAR TYPE(IDFOBJ),ALLOCATABLE,DIMENSION(:),PRIVATE :: IDF !## idf (part) CHARACTER(LEN=12),DIMENSION(5) :: IDFTYPES DATA IDFTYPES/'Planes','Cubes','Voxels','Vectors','Off'/ CONTAINS !###====================================================================== SUBROUTINE IMOD3D_SETUPDISPLAY_MISC(LADJTB) !###====================================================================== IMPLICIT NONE LOGICAL,INTENT(IN) :: LADJTB INTEGER :: IZR !## nothing changed IF(.NOT.LADJTB)RETURN !## fill display with background IF(.NOT.IMOD3D_GEN())THEN; ENDIF IZR=0 CALL WINDOWSELECT(IWIN) IF(WMENUGETSTATE(ID_ZRATIO1,ITEMCHECKED))IZR=1 IF(WMENUGETSTATE(ID_ZRATIO2,ITEMCHECKED))IZR=2 IF(WMENUGETSTATE(ID_ZRATIO3,ITEMCHECKED))IZR=3 IF(WMENUGETSTATE(ID_ZRATIO4,ITEMCHECKED))IZR=4 IF(WMENUGETSTATE(ID_ZRATIO5,ITEMCHECKED))IZR=5 IF(NIPFLIST.GT.0.OR.NIDFLIST.GT.0.OR.NIFFLIST.GT.0)THEN !## depends on vertical size of drills IF(IZR.GT.0)THEN ZSCALE_FACTOR=4.0_GLDOUBLE/(TOP%Z-BOT%Z)/IZR ELSE ZSCALE_FACTOR=4.0_GLDOUBLE/(TOP%Z-BOT%Z) ENDIF INIT_ZSCALE_FACTOR=ZSCALE_FACTOR ENDIF !## set mid-location of view MIDPOS%Z=(TOP%Z+BOT%Z)/2.0_GLDOUBLE !## set/initiate lookat and lookfrom positions CALL IMOD3D_SETLOOKAT_LOOKFROM() !## make drawinglist for orientation CALL IMOD3D_SETUPORIENTATION() !## make drawinglist for axes CALL IMOD3D_SETUPAXES() !## make drawinglist for labels CALL IMOD3D_SETUPAXES_LABELS() !## make labels for ipfs CALL IMOD3D_IPF_LABELS() END SUBROUTINE IMOD3D_SETUPDISPLAY_MISC !###====================================================================== SUBROUTINE IMOD3D_SETLOOKAT_LOOKFROM() !###====================================================================== !## sets lookat to fit current view represented as a circle IMPLICIT NONE INTEGER :: IZR DOUBLE PRECISION :: D1,FOVYRAD IZR=3 CALL WINDOWSELECT(IWIN) IF(WMENUGETSTATE(ID_ZRATIO1,ITEMCHECKED))IZR=1 IF(WMENUGETSTATE(ID_ZRATIO2,ITEMCHECKED))IZR=2 IF(WMENUGETSTATE(ID_ZRATIO3,ITEMCHECKED))IZR=3 IF(WMENUGETSTATE(ID_ZRATIO4,ITEMCHECKED))IZR=4 IF(WMENUGETSTATE(ID_ZRATIO5,ITEMCHECKED))IZR=5 INIT_SHIFTX =0.0_GLDOUBLE INIT_SHIFTY =0.0_GLDOUBLE INIT_SHIFTZ =0.0_GLDOUBLE LOOKAT%X=0.0_GLDOUBLE LOOKAT%Y=0.0_GLDOUBLE LOOKAT%Z=2.0_GLDOUBLE*XYZAXES(3)*(MIDPOS%Z/(TOP%Z-BOT%Z)) LOOKAT%Z=LOOKAT%Z/REAL(IZR) !3.0_GLDOUBLE FOVYRAD=FOVY/(360.0_GLDOUBLE/(2.0_GLDOUBLE*PI)) !## circle to describe entire volume D1=SQRT(XYZAXES(1)**2.0+XYZAXES(2)**2.0+XYZAXES(3)**2.0) !## distance D1=(1.0_GLDOUBLE*D1)/ATAN(FOVYRAD) LOOKFROM%X=LOOKAT%X-0.5*D1 LOOKFROM%Y=LOOKAT%Y-D1 LOOKFROM%Z=LOOKAT%Z+0.5*D1 END SUBROUTINE IMOD3D_SETLOOKAT_LOOKFROM !###====================================================================== SUBROUTINE IMOD3D_SETUPAXES() !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT) :: X1,X2,Y1,Y2,Z1,Z2,DX,DY,DZ,V1,V2,VI,F,DXY INTEGER :: I,J REAL,PARAMETER :: D= 100.0 !## 1/d=percentage of axes-lines X1=-XYZAXES(1) X2= XYZAXES(1) Y1=-XYZAXES(2) Y2= XYZAXES(2) Z1= BOT%Z Z2= TOP%Z !##---------------------------- !## get filled background first !##---------------------------- !## destroy current display list index IF(AXESINDEX(0).NE.0)CALL GLDELETELISTS(AXESINDEX(0),1_GLSIZEI) !## generate display-lists AXESINDEX(0)=GLGENLISTS(1); CALL GLNEWLIST(AXESINDEX(0),GL_COMPILE) !## draw bottom CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X1,Y1,Z1) CALL GLVERTEX3F(X2,Y1,Z1) CALL GLVERTEX3F(X2,Y2,Z1) CALL GLVERTEX3F(X1,Y2,Z1) CALL GLEND() !## draw top CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X1,Y1,Z2) CALL GLVERTEX3F(X1,Y2,Z2) CALL GLVERTEX3F(X2,Y2,Z2) CALL GLVERTEX3F(X2,Y1,Z2) CALL GLEND() !## draw east CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X2,Y1,Z1) CALL GLVERTEX3F(X2,Y1,Z2) CALL GLVERTEX3F(X2,Y2,Z2) CALL GLVERTEX3F(X2,Y2,Z1) CALL GLEND() !## draw west CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X1,Y1,Z1) CALL GLVERTEX3F(X1,Y2,Z1) CALL GLVERTEX3F(X1,Y2,Z2) CALL GLVERTEX3F(X1,Y1,Z2) CALL GLEND() !## draw south CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X1,Y2,Z1) CALL GLVERTEX3F(X2,Y2,Z1) CALL GLVERTEX3F(X2,Y2,Z2) CALL GLVERTEX3F(X1,Y2,Z2) CALL GLEND() !## draw north CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X1,Y1,Z1) CALL GLVERTEX3F(X1,Y1,Z2) CALL GLVERTEX3F(X2,Y1,Z2) CALL GLVERTEX3F(X2,Y1,Z1) CALL GLEND() CALL GLENDLIST() !##---------------------------- !## get ribs of box secondly !##---------------------------- !## destroy current display list index IF(AXESINDEX(1).NE.0)CALL GLDELETELISTS(AXESINDEX(1),1_GLSIZEI) !## generate display-lists AXESINDEX(1)=GLGENLISTS(1) CALL GLNEWLIST(AXESINDEX(1),GL_COMPILE) CALL GLLINEWIDTH(2.0_GLFLOAT) !## draw axes so we know the orientation CALL GLBEGIN(GL_LINES) !## bottom CALL GLVERTEX3F(X1,Y1,Z1) CALL GLVERTEX3F(X2,Y1,Z1) CALL GLVERTEX3F(X2,Y1,Z1) CALL GLVERTEX3F(X2,Y2,Z1) CALL GLVERTEX3F(X2,Y2,Z1) CALL GLVERTEX3F(X1,Y2,Z1) CALL GLVERTEX3F(X1,Y2,Z1) CALL GLVERTEX3F(X1,Y1,Z1) !## top CALL GLVERTEX3F(X2,Y1,Z2) CALL GLVERTEX3F(X2,Y2,Z2) CALL GLVERTEX3F(X2,Y2,Z2) CALL GLVERTEX3F(X1,Y2,Z2) !## ribs CALL GLVERTEX3F(X2,Y1,Z2) CALL GLVERTEX3F(X2,Y1,Z1) CALL GLVERTEX3F(X1,Y2,Z2) CALL GLVERTEX3F(X1,Y2,Z1) CALL GLVERTEX3F(X2,Y2,Z2) CALL GLVERTEX3F(X2,Y2,Z1) CALL GLEND() CALL GLLINEWIDTH(1.0_GLFLOAT) CALL GLENDLIST() !##---------------------------- !## get axes secondly !##---------------------------- !## destroy current display list index IF(AXESINDEX(2).NE.0)CALL GLDELETELISTS(AXESINDEX(2),1_GLSIZEI) !## generate display-lists AXESINDEX(2)=GLGENLISTS(1) CALL GLNEWLIST(AXESINDEX(2),GL_COMPILE) !## draw axes so we know the orientation CALL GLBEGIN(GL_LINES) !##=============== !## x-axis !##=============== !## get classes CALL UTL_GETAXESCALES(REAL(BOT%X),REAL(BOT%Y),REAL(TOP%X),REAL(TOP%Y)) DX=(X2-X1)/100.0; DY=(Y2-Y1)/100.0; DXY=MIN(DX,DY) !## get axes-values in coordinate system of 3D V1= SXVALUE(1) -(SXVALUE(2)-SXVALUE(1)) V2= SXVALUE(NSX)+(SXVALUE(2)-SXVALUE(1)) F =(X2-X1)/(TOP%X-BOT%X) V1= X1+(V1-BOT%X)*F V2= X1+(V2-BOT%X)*F VI=(SXVALUE(2)-SXVALUE(1))*F VI=VI/4.0 I=0; DO I=I+1 DX=V1+VI*REAL(I-1) IF(DX.GT.X1.AND.DX.LT.X2)THEN IF(MOD(I-1,4).EQ.0)THEN CALL GLVERTEX3F(DX,Y1-DXY*2.0,Z1); CALL GLVERTEX3F(DX,Y1+DXY*2.0,Z1) CALL GLVERTEX3F(DX,Y2-DXY*2.0,Z1); CALL GLVERTEX3F(DX,Y2+DXY*2.0,Z1) CALL GLVERTEX3F(DX,Y2-DXY*2.0,Z2); CALL GLVERTEX3F(DX,Y2+DXY*2.0,Z2) ELSE CALL GLVERTEX3F(DX,Y1-DXY,Z1); CALL GLVERTEX3F(DX,Y1+DXY,Z1) CALL GLVERTEX3F(DX,Y2-DXY,Z1); CALL GLVERTEX3F(DX,Y2+DXY,Z1) CALL GLVERTEX3F(DX,Y2-DXY,Z2); CALL GLVERTEX3F(DX,Y2+DXY,Z2) ENDIF ENDIF IF(DX.GT.X2)EXIT END DO !##=============== !## y-axis !##=============== V1= SYVALUE(1) -(SYVALUE(2)-SYVALUE(1)) V2= SYVALUE(NSY)+(SYVALUE(2)-SYVALUE(1)) F =(Y2-Y1)/(TOP%Y-BOT%Y) V1= Y1+(V1-BOT%Y)*F V2= Y1+(V2-BOT%Y)*F VI=(SYVALUE(2)-SYVALUE(1))*F VI=VI/4.0 I=0; DO I=I+1 DY=V1+VI*REAL(I-1) IF(DY.GT.Y1.AND.DY.LT.Y2)THEN IF(MOD(I-1,4).EQ.0)THEN CALL GLVERTEX3F(X1-DXY*2.0,DY,Z1); CALL GLVERTEX3F(X1+DXY*2.0,DY,Z1) CALL GLVERTEX3F(X2-DXY*2.0,DY,Z1); CALL GLVERTEX3F(X2+DXY*2.0,DY,Z1) CALL GLVERTEX3F(X2-DXY*2.0,DY,Z2); CALL GLVERTEX3F(X2+DXY*2.0,DY,Z2) ELSE CALL GLVERTEX3F(X1-DXY,DY,Z1); CALL GLVERTEX3F(X1+DXY,DY,Z1) CALL GLVERTEX3F(X2-DXY,DY,Z1); CALL GLVERTEX3F(X2+DXY,DY,Z1) CALL GLVERTEX3F(X2-DXY,DY,Z2); CALL GLVERTEX3F(X2+DXY,DY,Z2) ENDIF ENDIF IF(DY.GT.Y2)EXIT END DO !##=============== !## z-axis !##=============== CALL UTL_GETAXESCALES(REAL(BOT%X),REAL(BOT%Z),REAL(TOP%X),REAL(TOP%Z)) V1= SYVALUE(1) V2= SYVALUE(NSY) F =(Z2-Z1)/(TOP%Z-BOT%Z) V1= Z1+(V1-BOT%Z)*F V2= Z1+(V2-BOT%Z)*F VI=(SYVALUE(2)-SYVALUE(1))*F DO I=1,NSY DO J=0,1 DZ=V1+VI*(REAL(I-1)+(REAL(J)*0.5)) IF(DZ.GT.Z1.AND.DZ.LT.Z2)THEN CALL GLVERTEX3F(X2-DXY,Y1,DZ); CALL GLVERTEX3F(X2+DXY,Y1,DZ) CALL GLVERTEX3F(X1-DXY,Y2,DZ); CALL GLVERTEX3F(X1+DXY,Y2,DZ) CALL GLVERTEX3F(X2-DXY,Y1,DZ); CALL GLVERTEX3F(X2+DXY,Y1,DZ) ENDIF END DO END DO CALL GLEND() CALL GLENDLIST() CALL IMOD3D_ERROR('IMOD3D_SETUPAXES') END SUBROUTINE IMOD3D_SETUPAXES !###====================================================================== SUBROUTINE IMOD3D_SETUPAXES_LABELS() !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT) :: X1,X2,Y1,Y2,Z1,Z2,DX,DY,DZ,V1,V2,VI,T1,TI,TT,DT,F,FCT REAL(KIND=GLDOUBLE) :: XS,YS,ZS INTEGER :: I REAL,PARAMETER :: D=100.0 !## 1/d=percentage of axes-lines REAL(KIND=GLDOUBLE),PARAMETER :: TS= 0.2 !0.25 !## textsize CHARACTER(LEN=15) :: STRING X1=-XYZAXES(1) X2= XYZAXES(1) Y1=-XYZAXES(2) Y2= XYZAXES(2) Z1= BOT%Z Z2= TOP%Z !## kilometers FCT=1000.0 DT=MIN((Y2-Y1)/D,(X2-X1)/D) XS=XSCALE_FACTOR YS=YSCALE_FACTOR ZS=ZSCALE_FACTOR !## destroy current display list index IF(AXESINDEX(3).NE.0)CALL GLDELETELISTS(AXESINDEX(3),1_GLSIZEI) AXESINDEX(3)=GLGENLISTS(1) CALL GLNEWLIST(AXESINDEX(3),GL_COMPILE) CALL UTL_GETAXESCALES(REAL(BOT%X),REAL(BOT%Y),REAL(TOP%X),REAL(TOP%Y)) !## ------------------------ !## write X-axes-information !## ------------------------ V1=SXVALUE(1) V2=SXVALUE(NSX) T1= V1 TI=(SXVALUE(2)-SXVALUE(1)) F =ABS((X2-X1)/(TOP%X-BOT%X)) V1= X1+(V1-BOT%X)*F V2= X1+(V2-BOT%X)*F VI=(SXVALUE(2)-SXVALUE(1))*F !## write X-axes-information DY=DT*2.0 I=0; DO I=I+1 DX=V1+VI*REAL(I-1) IF(DX.GT.X2)EXIT IF(DX.GT.X1.AND.DX.LT.X2)THEN TT=T1+TI*REAL(I-1) WRITE(STRING,UTL_GETFORMAT(REAL(TT/FCT))) TT/FCT !## bottom CALL WGLTEXTORIENTATION(ALIGNLEFT) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(DX,Y1-DY,Z1) CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) CALL GLSCALED(TS,TS,TS) CALL GLROTATED(-90.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE) CALL WGLTEXTSTRING(TRIM(ADJUSTL(STRING))) CALL GLPOPMATRIX() ! !## top ! CALL WGLTEXTORIENTATION(ALIGNRIGHT) ! CALL GLPUSHMATRIX() ! CALL GLTRANSLATEF(DX,Y2+DY,Z2) ! CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) ! CALL GLSCALED(TS,TS,TS) ! CALL GLROTATED(-90.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE) ! CALL WGLTEXTSTRING(TRIM(ADJUSTR(STRING))) ! CALL GLPOPMATRIX() ENDIF END DO DY=DT*3.0 !2.0 CALL WGLTEXTORIENTATION(ALIGNCENTRE) ! CALL GLPUSHMATRIX() ! CALL GLTRANSLATEF((V2+V1)/2.0,Y1-DY,Z1) ! CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) ! CALL GLSCALED(TS,TS,TS) ! CALL WGLTEXTSTRING('x coordinate (km)') ! CALL GLPOPMATRIX() CALL GLPUSHMATRIX() CALL GLTRANSLATEF((V2+V1)/2.0,Y2+DY,Z2) CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) CALL GLSCALED(TS,TS,TS) CALL WGLTEXTSTRING('x coordinate (km)') CALL GLPOPMATRIX() !## ------------------------ !## write Y-axes-information !## ------------------------ V1=SYVALUE(1) V2=SYVALUE(NSY) T1= V1 TI=(SYVALUE(2)-SYVALUE(1)) F =ABS((Y2-Y1)/(TOP%Y-BOT%Y)) V1= Y1+(V1-BOT%Y)*F V2= Y1+(V2-BOT%Y)*F VI=(SYVALUE(2)-SYVALUE(1))*F DX=DT*2.0 I=0; DO I=I+1 DY=V1+VI*REAL(I-1) IF(DY.GT.Y2)EXIT IF(DY.GT.Y1.AND.DY.LT.Y2)THEN TT=T1+TI*REAL(I-1) WRITE(STRING,UTL_GETFORMAT(REAL(TT/FCT))) TT/FCT !## left CALL WGLTEXTORIENTATION(ALIGNRIGHT) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X1-DX,DY,Z1) CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) CALL GLSCALED(TS,TS,TS) CALL WGLTEXTSTRING(TRIM(ADJUSTR(STRING))) CALL GLPOPMATRIX() !## right ! CALL WGLTEXTORIENTATION(ALIGNLEFT) ! CALL GLPUSHMATRIX() ! CALL GLTRANSLATEF(X2+DX,DY,Z2) ! CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) ! CALL GLSCALED(TS,TS,TS) ! CALL WGLTEXTSTRING(TRIM(ADJUSTL(STRING))) ! CALL GLPOPMATRIX() ENDIF ENDDO DX=DT*3.0 !2.0 CALL WGLTEXTORIENTATION(ALIGNCENTRE) ! CALL GLPUSHMATRIX() ! CALL GLTRANSLATEF(X1-DX,(V1+V2)/2.0,Z1) ! CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) ! CALL GLSCALED(TS,TS,TS) ! CALL GLROTATED(-90.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE) ! CALL WGLTEXTSTRING('y coordinate (km)') ! CALL GLPOPMATRIX() CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X2+DX,(V1+V2)/2.0,Z2) CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) CALL GLSCALED(TS,TS,TS) CALL GLROTATED(-90.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE) CALL WGLTEXTSTRING('y coordinate (km)') CALL GLPOPMATRIX() !## ------------------------ !## write Z-axes-information !## ------------------------ CALL UTL_GETAXESCALES(REAL(BOT%X),REAL(BOT%Z),REAL(TOP%X),REAL(TOP%Z)) V1=SYVALUE(1) V2=SYVALUE(NSY) T1= V1 TI=(SYVALUE(2)-SYVALUE(1)) F =(Z2-Z1)/(TOP%Z-BOT%Z) V1= Z1+(V1-BOT%Z)*F V2= Z1+(V2-BOT%Z)*F VI=(SYVALUE(2)-SYVALUE(1))*F DX=DT*2.0 DO I=1,NSY DZ=V1+VI*REAL(I-1) IF(DZ.GT.Z1.AND.DZ.LT.Z2)THEN TT=T1+TI*REAL(I-1) WRITE(STRING,UTL_GETFORMAT(REAL(TT))) TT !## left CALL WGLTEXTORIENTATION(ALIGNRIGHT) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X1-DX,Y2,DZ) CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) CALL GLSCALED(TS,TS,TS) CALL GLROTATED( 90.0_GLDOUBLE,1.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE) CALL WGLTEXTSTRING(TRIM(ADJUSTR(STRING))) CALL GLPOPMATRIX() ! !## right ! CALL WGLTEXTORIENTATION(ALIGNLEFT) ! CALL GLPUSHMATRIX() ! CALL GLTRANSLATEF(X2+DX,Y1,DZ) ! CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) ! CALL GLSCALED(TS,TS,TS) ! CALL GLROTATED( 90.0_GLDOUBLE,1.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE) ! CALL WGLTEXTSTRING(TRIM(ADJUSTL(STRING))) ! CALL GLPOPMATRIX() ENDIF ENDDO ! CALL GLPUSHMATRIX() ! CALL GLTRANSLATEF(X1-DX,Y2,REAL(TOP%Z+BOT%Z)/2.0) ! CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) ! CALL GLSCALED(TS,TS,TS) ! CALL GLROTATED( 90.0_GLDOUBLE,1.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE) ! CALL GLTRANSLATEF(-DX*60.0,0.0,0.0) ! CALL GLROTATED(-90.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE) ! CALL WGLTEXTORIENTATION(ALIGNCENTRE) ! CALL WGLTEXTSTRING('elevation (m)') ! CALL GLPOPMATRIX() CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X2+DX,Y1,REAL(TOP%Z+BOT%Z)/2.0) CALL GLSCALED(1.0_GLDOUBLE/XS,1.0_GLDOUBLE/YS,1.0_GLDOUBLE/ZS) CALL GLSCALED(TS,TS,TS) CALL GLROTATED( 90.0_GLDOUBLE,1.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE) ! CALL GLTRANSLATEF(DX*60.0,0.0,0.0) CALL GLTRANSLATEF(DX*5.0,0.0,0.0) CALL GLROTATED(-90.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE) CALL WGLTEXTORIENTATION(ALIGNCENTRE) CALL WGLTEXTSTRING('elevation (m)') CALL GLPOPMATRIX() CALL GLENDLIST() CALL IMOD3D_ERROR('IMOD3D_SETUPAXES_LABELS') END SUBROUTINE IMOD3D_SETUPAXES_LABELS !###====================================================================== SUBROUTINE IMOD3D_SETUPORIENTATION() !###====================================================================== IMPLICIT NONE REAL(KIND=GLDOUBLE) :: DX,DY,DZ,X,Y,Z REAL(KIND=GLDOUBLE),PARAMETER :: TS= 0.25 !## textsize !## destroy current display list index IF(ORIENTINDEX.NE.0)CALL GLDELETELISTS(ORIENTINDEX,1_GLSIZEI) ORIENTINDEX=GLGENLISTS(1); CALL GLNEWLIST(ORIENTINDEX,GL_COMPILE) !## draw axes so we know the orientation CALL GLBEGIN(GL_LINES) DX=0.75_GLDOUBLE; DY=0.75_GLDOUBLE; DZ=0.75_GLDOUBLE X=0.0_GLDOUBLE; Y=0.0_GLDOUBLE; Z=LOOKAT%Z !## dit werkt ... logisch??? !## bottom CALL GLVERTEX3D(X,Y,Z) CALL GLVERTEX3D(DX,Y,Z) CALL GLVERTEX3D(X,Y,Z) CALL GLVERTEX3D(X,DY,Z) CALL GLVERTEX3D(X,Y,Z) CALL GLVERTEX3D(X,Y,DZ+Z) CALL GLEND() CALL WGLTEXTORIENTATION(ALIGNLEFT) CALL GLPUSHMATRIX() CALL GLTRANSLATED(DX,0.0_GLDOUBLE,Z) CALL GLSCALED(TS,TS,TS) CALL WGLTEXTSTRING('East') CALL GLPOPMATRIX() CALL GLPUSHMATRIX() CALL GLTRANSLATED(0.0_GLDOUBLE,DY,Z) CALL GLSCALED(TS,TS,TS) CALL GLROTATED(90.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE) CALL WGLTEXTSTRING('North') CALL GLPOPMATRIX() CALL GLPUSHMATRIX() CALL GLTRANSLATED(0.0_GLDOUBLE,0.0_GLDOUBLE,DZ+Z) CALL GLSCALED(TS,TS,TS) CALL GLROTATED(-90.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE,0.0_GLDOUBLE) CALL WGLTEXTSTRING('Top') CALL GLPOPMATRIX() CALL GLENDLIST() CALL IMOD3D_ERROR('IMOD3D_SETUPORIENTATION') END SUBROUTINE IMOD3D_SETUPORIENTATION !###====================================================================== SUBROUTINE IMOD3D_LEGEND_MAIN() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,LLST,ILEG REAL(KIND=GLFLOAT) :: X,Y,DX,DY,DDY,RAT INTEGER(GLINT) :: IVIEWPORT(4) REAL(KIND=GLFLOAT),PARAMETER :: XSIZE=1.5_GLFLOAT REAL(KIND=GLFLOAT),PARAMETER :: TS=XSIZE*0.9_GLFLOAT !## textsize IF(LEGENDINDEX.NE.0)CALL GLDELETELISTS(LEGENDINDEX,1_GLSIZEI); LEGENDINDEX=0 I=0 IF(NIDFLIST.GT.0)THEN; IF(SUM(IDFPLOT%IPLOTLEGEND).GT.0)I=I+1; ENDIF IF(NIPFLIST.GT.0)THEN; IF(SUM(IPFPLOT%IPLOTLEGEND).GT.0)I=I+1; ENDIF IF(NIFFLIST.GT.0)THEN; IF(SUM(IFFPLOT%IPLOTLEGEND).GT.0)I=I+1; ENDIF IF(I.EQ.0)RETURN CALL GLGETINTEGERV(GL_VIEWPORT,IVIEWPORT) RAT=REAL(IVIEWPORT(4))/REAL(IVIEWPORT(3)) !## size of colour box (1% of width = 100) !## width>heigth IF(RAT.LT.1.0)THEN DY=XSIZE; DX=DY*RAT !## heigth>width ELSE DX=XSIZE; DY=DX/RAT ENDIF LEGENDINDEX=GLGENLISTS(1) CALL GLNEWLIST(LEGENDINDEX,GL_COMPILE) CALL IMOD3D_SETCOLOR(WRGB(255,255,255)) !## white CALL WGLTEXTORIENTATION(ALIGNLEFT) !## start box X=DX; Y=100_GLFLOAT-DY DO I=1,NIDFLIST IF(IDFPLOT(I)%ISEL.EQ.0.OR.IDFPLOT(I)%IPLOTLEGEND.EQ.0)CYCLE !## single colour legend IF(IDFPLOT(I)%ILEG.EQ.1)THEN !## colour box CALL IMOD3D_SETCOLOR(IDFPLOT(I)%ICOLOR) CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLEND() CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS) CALL WGLTEXTSTRING(TRIM(IDFPLOT(I)%ALIAS)) CALL GLPOPMATRIX() !## legend colouring ELSEIF(IDFPLOT(I)%ILEG.EQ.2)THEN LLST=IDFPLOT(IDFPLOT(I)%IDFLEGEND)%ILIST !## classes IF(IDFPLOT(LLST)%LEG%NCLR.LE.MXCLASS)THEN DO J=1,IDFPLOT(LLST)%LEG%NCLR CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(IDFPLOT(LLST)%LEG%LEGTXT(J))) CALL GLPOPMATRIX() CALL IMOD3D_SETCOLOR(IDFPLOT(LLST)%LEG%RGB(J)) CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLEND() IF(J.NE.IDFPLOT(LLST)%LEG%NCLR)Y=Y-(DY*1.5_GLFLOAT) ENDDO !## 256 colours ELSE CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(IDFPLOT(LLST)%LEG%LEGTXT(1))) CALL GLPOPMATRIX() DDY=3.0_GLFLOAT; DDY=((DDY-1.0_GLFLOAT)*1.5_GLFLOAT)+1.5_GLFLOAT DDY=(DDY*DY)/REAL(IDFPLOT(LLST)%LEG%NCLR) DO J=1,IDFPLOT(I)%LEG%NCLR CALL IMOD3D_SETCOLOR(IDFPLOT(LLST)%LEG%RGB(J)) CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DDY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DDY,0.0_GLFLOAT) CALL GLEND() Y=Y-DDY ENDDO Y=Y+DY CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(IDFPLOT(LLST)%LEG%LEGTXT(IDFPLOT(LLST)%LEG%NCLR))) CALL GLPOPMATRIX() ENDIF ENDIF Y=Y-(DY*1.5_GLFLOAT) ENDDO DO I=1,NIFFLIST IF(IFFPLOT(I)%ISEL.EQ.0.OR.IFFPLOT(I)%IPLOTLEGEND.EQ.0)CYCLE !## single colour legend IF(MP(IFFPLOT(I)%IPLOT)%ILEG.EQ.0)THEN !## colour box CALL IMOD3D_SETCOLOR(MP(IFFPLOT(I)%IPLOT)%SCOLOR) CALL GLBEGIN(GL_LINES) !POLYGON) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX*0.3,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX*0.3,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX*0.6,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX*0.6,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX ,Y ,0.0_GLFLOAT) CALL GLEND() CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) !X,Y,0.0_glfloat) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS) CALL WGLTEXTSTRING(TRIM(IFFPLOT(I)%FNAME)) CALL GLPOPMATRIX() !## legend colouring ELSEIF(MP(IFFPLOT(I)%IPLOT)%ILEG.EQ.1)THEN !## classes IF(MP(IFFPLOT(I)%IPLOT)%LEG%NCLR.LE.MXCLASS)THEN DO J=1,MP(IFFPLOT(I)%IPLOT)%LEG%NCLR CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(MP(IFFPLOT(I)%IPLOT)%LEG%LEGTXT(J))) CALL GLPOPMATRIX() CALL IMOD3D_SETCOLOR(MP(IFFPLOT(I)%IPLOT)%LEG%RGB(J)) CALL GLBEGIN(GL_LINES) !POLYGON) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX*0.3,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX*0.3,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX*0.6,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX*0.6,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX ,Y ,0.0_GLFLOAT) CALL GLEND() IF(J.NE.MP(IFFPLOT(I)%IPLOT)%LEG%NCLR)Y=Y-(DY*1.5_GLFLOAT) ENDDO !## 256 colours ELSE CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(MP(IFFPLOT(I)%IPLOT)%LEG%LEGTXT(1))) CALL GLPOPMATRIX() DDY=3.0_GLFLOAT; DDY=((DDY-1.0_GLFLOAT)*1.5_GLFLOAT)+1.5_GLFLOAT DDY=(DDY*DY)/REAL(MP(IFFPLOT(I)%IPLOT)%LEG%NCLR) DO J=1,MP(IFFPLOT(I)%IPLOT)%LEG%NCLR CALL IMOD3D_SETCOLOR(MP(IFFPLOT(I)%IPLOT)%LEG%RGB(J)) CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DDY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DDY,0.0_GLFLOAT) CALL GLEND() Y=Y-DDY ENDDO Y=Y+DY CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(MP(IFFPLOT(I)%IPLOT)%LEG%LEGTXT(MP(IFFPLOT(I)%IPLOT)%LEG%NCLR))) CALL GLPOPMATRIX() ENDIF ENDIF Y=Y-(DY*1.5_GLFLOAT) ENDDO DO I=1,NIPF IF(IPFPLOT(I)%ISEL.EQ.0.OR.IPFPLOT(I)%IPLOTLEGEND.EQ.0)CYCLE !## plot legend (dlf) IF(IPF(I)%ACOL.NE.0)THEN ILEG=IPFPLOT(I)%ILEGDLF DO J=1,NLITHO(ILEG) CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(BH(ILEG,J)%LITHOTXT)) CALL GLPOPMATRIX() CALL IMOD3D_SETCOLOR(BH(ILEG,J)%LITHOCLR) CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLEND() IF(J.NE.NLITHO(ILEG))Y=Y-(DY*1.5_GLFLOAT) ENDDO ELSE !## single colour legend IF(MP(IPFPLOT(I)%IPLOT)%ILEG.EQ.0)THEN !## colour box CALL IMOD3D_SETCOLOR(MP(IPFPLOT(I)%IPLOT)%SCOLOR) CALL GLBEGIN(GL_LINES) !POLYGON) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX*0.3,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX*0.3,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX*0.6,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX*0.6,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX ,Y ,0.0_GLFLOAT) CALL GLEND() CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) !X,Y,0.0_glfloat) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS) CALL WGLTEXTSTRING(TRIM(IPFPLOT(I)%FNAME)) CALL GLPOPMATRIX() !## legend colouring ELSEIF(MP(IPFPLOT(I)%IPLOT)%ILEG.EQ.1)THEN !## classes IF(MP(IPFPLOT(I)%IPLOT)%LEG%NCLR.LE.MXCLASS)THEN DO J=1,MP(IPFPLOT(I)%IPLOT)%LEG%NCLR CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(MP(IPFPLOT(I)%IPLOT)%LEG%LEGTXT(J))) CALL GLPOPMATRIX() CALL IMOD3D_SETCOLOR(MP(IPFPLOT(I)%IPLOT)%LEG%RGB(J)) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX*0.3,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX*0.3,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX*0.6,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX*0.6,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX ,Y ,0.0_GLFLOAT) CALL GLEND() IF(J.NE.MP(IPFPLOT(I)%IPLOT)%LEG%NCLR)Y=Y-(DY*1.5_GLFLOAT) ENDDO !## 256 colours ELSE CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(MP(IPFPLOT(I)%IPLOT)%LEG%LEGTXT(1))) CALL GLPOPMATRIX() DDY=3.0_GLFLOAT; DDY=((DDY-1.0_GLFLOAT)*1.5_GLFLOAT)+1.5_GLFLOAT DDY=(DDY*DY)/REAL(MP(IPFPLOT(I)%IPLOT)%LEG%NCLR) DO J=1,MP(IPFPLOT(I)%IPLOT)%LEG%NCLR CALL IMOD3D_SETCOLOR(MP(IPFPLOT(I)%IPLOT)%LEG%RGB(J)) CALL GLBEGIN(GL_POLYGON) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DDY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DDY,0.0_GLFLOAT) CALL GLEND() Y=Y-DDY ENDDO Y=Y+DY CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) !255,255,255)) CALL GLPUSHMATRIX() CALL GLTRANSLATEF(X+(DX*1.5_GLFLOAT),Y- DY+((XSIZE-TS)/2.0_GLFLOAT),0.0_GLFLOAT) CALL GLSCALEF(1.0_GLFLOAT,1.0_GLFLOAT/RAT,1.0_GLFLOAT) CALL GLSCALEF(TS,TS,TS); CALL WGLTEXTSTRING(TRIM(MP(IPFPLOT(I)%IPLOT)%LEG%LEGTXT(MP(IPFPLOT(I)%IPLOT)%LEG%NCLR))) CALL GLPOPMATRIX() ENDIF ENDIF ENDIF Y=Y-(DY*1.5_GLFLOAT) ENDDO CALL GLENDLIST() END SUBROUTINE IMOD3D_LEGEND_MAIN !###====================================================================== LOGICAL FUNCTION IMOD3D_LEGEND_INIT() !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT) :: X1,X2,Y1,Y2,Z IMOD3D_LEGEND_INIT=.FALSE. X1=-XYZAXES(1); X2= XYZAXES(1); Y1=-XYZAXES(2); Y2= XYZAXES(2) Z=0.0_GLFLOAT !## destroy current display list index IF(LEGENDINDEX.NE.0)CALL GLDELETELISTS(LEGENDINDEX,1_GLSIZEI) LEGENDINDEX=GLGENLISTS(1); CALL GLNEWLIST(LEGENDINDEX,GL_COMPILE) !## draw axes so we know the orientation CALL GLBEGIN(GL_QUADS) !## connect 2d texture to 3d object CALL GLVERTEX3F(X1,Y1,Z) CALL GLVERTEX3F(X1,Y2,Z) CALL GLVERTEX3F(X2,Y2,Z) CALL GLVERTEX3F(X2,Y1,Z) CALL GLEND() CALL GLENDLIST() IMOD3D_LEGEND_INIT=.TRUE. CALL IMOD3D_ERROR('IMOD3D_LEGEND') END FUNCTION IMOD3D_LEGEND_INIT !###====================================================================== LOGICAL FUNCTION IMOD3D_LEGEND_BITMAP() !###====================================================================== IMPLICIT NONE INTEGER(GLSIZEI) :: IWIDTH,IHEIGHT INTEGER,ALLOCATABLE,DIMENSION(:) :: IBMPDATA INTEGER :: I,J,IW,IH,IOS REAL(KIND=GLFLOAT),ALLOCATABLE,DIMENSION(:) :: FRGB IMOD3D_LEGEND_BITMAP=.FALSE. !## get display-list pointers LEGENDINDEX=0 !## create legend ... IWIDTH =WINFOBITMAP(MPW%IBITMAP,BITMAPWIDTH) IHEIGHT=WINFOBITMAP(MPW%IBITMAP,BITMAPHEIGHT) ALLOCATE(IBMPDATA(IWIDTH*IHEIGHT),STAT=IOS) IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot allocate enough memory IBMPDATA() to store background image','Error'); RETURN ENDIF ALPHA=0.75_GLFLOAT IALPHA=1 ALLOCATE(FRGB(IWIDTH*IHEIGHT*(3+IALPHA)),STAT=IOS) IF(IOS.NE.0)THEN DEALLOCATE(IBMPDATA) CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot allocate enough memory FRGB() to store background image','Error'); RETURN ENDIF CALL WBITMAPPUTDATA(MPW%IBITMAP,IBMPDATA) !## draw pixels at the current rasterposition J=-2-IALPHA DO IH=IHEIGHT,1,-1 DO IW=1,IWIDTH J=J+3+IALPHA I=(IH-1)*IWIDTH+IW CALL IMOD3D_RETURNCOLOR(IBMPDATA(I),FRGB(J)) IF(IALPHA.EQ.1)THEN FRGB(J+3)=ALPHA !## alpha value ENDIF ENDDO ENDDO !## turns on texturing CALL GLENABLE(GL_TEXTURE_2D) !## sets the drawing mode to GL_DECAL so that the textured !## polygons are drawn using the colors from the texture map (rather than taking into account what color the polygons !## would have been drawn without the texture) CALL GLTEXENVI(GL_TEXTURE_ENV,GL_TEXTURE_ENV_MODE,GL_MODULATE) CALL GLCOLOR4F(1.0_GLFLOAT,1.0_GLFLOAT,1.0_GLFLOAT,1.0_GLFLOAT) !## it describes how the bitmap data is stored in computer memory CALL GLPIXELSTOREI(GL_UNPACK_ALIGNMENT,1) !## parameters indicate the size of the image, type of the image, location of the image, and other properties of it IF(IALPHA.EQ.0)THEN CALL GLTEXIMAGE2D(GL_TEXTURE_2D,0_GLINT,3_GLINT,IWIDTH,IHEIGHT,0_GLINT,GL_RGB ,GL_FLOAT,FRGB) ELSE CALL GLTEXIMAGE2D(GL_TEXTURE_2D,0_GLINT,GL_RGBA,IWIDTH,IHEIGHT,0_GLINT,GL_RGBA,GL_FLOAT,FRGB) ENDIF DEALLOCATE(IBMPDATA,FRGB) IMOD3D_LEGEND_BITMAP=.TRUE. CALL WINDOWOUTSTATUSBAR(2,'') CALL IMOD3D_ERROR('IMOD3D_LEGEND_INIT') END FUNCTION IMOD3D_LEGEND_BITMAP !###====================================================================== LOGICAL FUNCTION IMOD3D_IDF_INIT() !###====================================================================== IMPLICIT NONE INTEGER :: IPLOT,I,N,ICLR IMOD3D_IDF_INIT=.FALSE. NIDFLIST=0 DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.(MP(IPLOT)%IPLOT.EQ.1.OR.MP(IPLOT)%IPLOT.EQ.5))THEN IF(MP(IPLOT)%IPLOT.EQ.5)THEN NIDFLIST=NIDFLIST+READMDF_GETN(MP(IPLOT)%IDFNAME) ELSE NIDFLIST=NIDFLIST+1 ENDIF ENDIF ENDDO !## nothing to do - no idf"s found IF(NIDFLIST.LE.0)THEN; IMOD3D_IDF_INIT=.TRUE.; RETURN; ENDIF !## all idfs ALLOCATE(IDFPLOT(NIDFLIST)) !## get display-list pointers - wireframe/solid ALLOCATE(IDFLISTINDEX(NIDFLIST)); IDFLISTINDEX=0 CALL WINDOWSELECT(IWIN) !## read idf NIDFLIST=0 ICLR=0 DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.(MP(IPLOT)%IPLOT.EQ.1.OR.MP(IPLOT)%IPLOT.EQ.5))THEN !## get idf for mdf file IF(MP(IPLOT)%IPLOT.EQ.5)THEN IF(READMDF(MP(IPLOT)%IDFNAME,N))THEN DO I=1,N NIDFLIST= NIDFLIST+1; ICLR=ICLR+1 IDFPLOT(NIDFLIST)%ICOLOR =MDF(I)%SCOLOR !ICOLOR(ICLR) !## constant colour IDFPLOT(NIDFLIST)%ILEG =1 !## constant colour IDFPLOT(NIDFLIST)%IFILL =1 !## coloured (2=fishnet) IDFPLOT(NIDFLIST)%ISHADED=1 !## shaded IDFPLOT(NIDFLIST)%ISEL =1 !## activated IDFPLOT(NIDFLIST)%ILIST =NIDFLIST !## list sequence IDFPLOT(NIDFLIST)%ALIAS =MDF(I)%ALIAS IDFPLOT(NIDFLIST)%FNAME =MDF(I)%FNAME IDFPLOT(NIDFLIST)%IPLOT =IPLOT !## IPLOT IDFPLOT(NIDFLIST)%ICOMBINE=NIDFLIST IDFPLOT(NIDFLIST)%IDFLEGEND=NIDFLIST IDFPLOT(NIDFLIST)%ICUBE =1 !## plane IDFPLOT(NIDFLIST)%LEG =MDF(I)%LEG !## legend IDFPLOT(NIDFLIST)%IPLOTLEGEND=0 !## plOT LEGEND IDFPLOT(NIDFLIST)%ZMIN=0.0 IDFPLOT(NIDFLIST)%ZMAX=0.0 IDFPLOT(NIDFLIST)%ITRANSPARANCY=100 IDFPLOT(NIDFLIST)%ICONFIG=1 IDFPLOT(NIDFLIST)%IACC=1 IDFPLOT(NIDFLIST)%ISTACKED=0 ENDDO CALL MDFDEALLOCATE() ENDIF ELSE NIDFLIST=NIDFLIST+1; ICLR=ICLR+1 IDFPLOT(NIDFLIST)%ICOLOR =MP(IPLOT)%SCOLOR !## constant colour IDFPLOT(NIDFLIST)%ILEG =1 !## constant colour IDFPLOT(NIDFLIST)%IFILL =1 !## coloured (2=fishnet) IDFPLOT(NIDFLIST)%ISHADED=1 !## shaded IDFPLOT(NIDFLIST)%ISEL =1 !## activated IDFPLOT(NIDFLIST)%ILIST =NIDFLIST !## list sequence IDFPLOT(NIDFLIST)%FNAME =MP(IPLOT)%IDFNAME IDFPLOT(NIDFLIST)%IPLOT =IPLOT IDFPLOT(NIDFLIST)%ALIAS =MP(IPLOT)%ALIAS IDFPLOT(NIDFLIST)%ICOMBINE=NIDFLIST IDFPLOT(NIDFLIST)%IDFLEGEND=NIDFLIST IDFPLOT(NIDFLIST)%ICUBE =1 !## plane IDFPLOT(NIDFLIST)%LEG =MP(IPLOT)%LEG !## legend IDFPLOT(NIDFLIST)%IPLOTLEGEND=0 !## plOT LEGEND IDFPLOT(NIDFLIST)%ZMIN=0.0 IDFPLOT(NIDFLIST)%ZMAX=0.0 IDFPLOT(NIDFLIST)%ITRANSPARANCY=100 IDFPLOT(NIDFLIST)%ICONFIG=1 IDFPLOT(NIDFLIST)%IACC=1 IDFPLOT(NIDFLIST)%ISTACKED=0 ENDIF ENDIF ENDDO CALL WINDOWSELECT(IWIN) !## see what meat we have in the bucket ALLOCATE(IDF(1)); CALL IDFNULLIFY(IDF(1)) DO I=1,NIDFLIST IF(.NOT.IDFREAD(IDF(1),IDFPLOT(I)%FNAME,0))EXIT IF(IDF(1)%ITB.EQ.1)IDFPLOT(I)%ICUBE=3 !## voxel ENDDO CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF) CALL UTL_MESSAGEHANDLE(1) CALL IMOD3D_SETTINGS_IDF_ALIAS() IF(.NOT.IMOD3D_SETTINGS_IDF(0))RETURN CALL UTL_MESSAGEHANDLE(0) CALL IMOD3D_SETTINGS_IDF_ALIAS() !## draw planes/cubes/voxels IF(IMOD3D_REDRAWIDF(0))THEN; ENDIF !## draw vectors IF(IMOD3D_REDRAWIDF(1))THEN; ENDIF CALL WINDOWOUTSTATUSBAR(2,'') IMOD3D_IDF_INIT=.TRUE. CALL IMOD3D_ERROR('IMOD3D_IDF') END FUNCTION IMOD3D_IDF_INIT !###====================================================================== SUBROUTINE IMOD3D_SETTINGS_IDF_ALIAS() !###====================================================================== IMPLICIT NONE INTEGER :: I,J CHARACTER(LEN=12) :: TXT DO I=1,SIZE(IDFPLOT) IF(IDFPLOT(I)%ICUBE.EQ.0) THEN; TXT='outside' ELSEIF(IDFPLOT(I)%ICUBE.EQ.1)THEN; TXT='plane' ELSEIF(IDFPLOT(I)%ICUBE.EQ.2)THEN; TXT='cubes' ELSEIF(IDFPLOT(I)%ICUBE.EQ.3)THEN; TXT='voxel' ELSEIF(IDFPLOT(I)%ICUBE.EQ.4)THEN; TXT='vector' ELSEIF(IDFPLOT(I)%ICUBE.EQ.5)THEN; TXT='off'; ENDIF IDFPLOT(I)%DISP_ALIAS='('//TRIM(ITOS(I))//'-'//TRIM(TXT)//') '//TRIM(IDFPLOT(I)%ALIAS) IF(IDFPLOT(I)%ICUBE.EQ.3)THEN IDFPLOT(I)%ILEG=2 ELSE IF(IDFPLOT(I)%IDFLEGEND.NE.I)IDFPLOT(I)%ILEG=2 ENDIF END DO IDFPLOT%DISP_ILIST=0; J=0 DO I=1,NIDFLIST IF(IDFPLOT(I)%ICUBE.NE.5)THEN; J=J+1; IDFPLOT(J)%DISP_ILIST=I; IDFPLOT(J)%DISP_ALIAS=IDFPLOT(I)%DISP_ALIAS; ENDIF ENDDO CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB1); IDFPLOT%DISP_ISEL=1 DISP_NIDFLIST=J; CALL WDIALOGPUTMENU(IDF_MENU1,IDFPLOT%DISP_ALIAS,DISP_NIDFLIST,IDFPLOT%DISP_ISEL) END SUBROUTINE IMOD3D_SETTINGS_IDF_ALIAS !###====================================================================== LOGICAL FUNCTION IMOD3D_SETTINGS_IPF(IIPF) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IIPF INTEGER :: I,ITYPE TYPE(WIN_MESSAGE) :: MESSAGE CALL WDIALOGLOAD(ID_D3DIPFSETTINGS,ID_D3DIPFSETTINGS) IF(NSOLLIST.LE.0)THEN IPFPLOT(IIPF)%ISELECT(3)=0 CALL WDIALOGFIELDSTATE(IDF_CHECK3,0) ENDIF !## put selections CALL WDIALOGPUTCHECKBOX(IDF_CHECK1,IPFPLOT(IIPF)%ISELECT(1)) CALL WDIALOGPUTCHECKBOX(IDF_CHECK2,IPFPLOT(IIPF)%ISELECT(2)) CALL WDIALOGPUTCHECKBOX(IDF_CHECK3,IPFPLOT(IIPF)%ISELECT(3)) CALL WDIALOGPUTREAL(IDF_REAL1,IPFPLOT(IIPF)%RSELECT(1),'(F10.2)') CALL WDIALOGPUTREAL(IDF_REAL2,IPFPLOT(IIPF)%RSELECT(2),'(F10.2)') CALL WDIALOGPUTREAL(IDF_REAL3,IPFPLOT(IIPF)%RSELECT(3),'(F10.2)') CALL WDIALOGFIELDSTATE(IDF_REAL1,IPFPLOT(IIPF)%ISELECT(1)) CALL WDIALOGFIELDSTATE(IDF_REAL2,IPFPLOT(IIPF)%ISELECT(2)) CALL WDIALOGFIELDSTATE(IDF_REAL3,IPFPLOT(IIPF)%ISELECT(3)) CALL WDIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_CHECK1) CALL WDIALOGGETCHECKBOX(IDF_CHECK1,I) CALL WDIALOGFIELDSTATE(IDF_REAL1,I) CASE (IDF_CHECK2) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,I) CALL WDIALOGFIELDSTATE(IDF_REAL2,I) CASE (IDF_CHECK3) CALL WDIALOGGETCHECKBOX(IDF_CHECK3,I) CALL WDIALOGFIELDSTATE(IDF_REAL3,I) END SELECT CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK,IDCANCEL) EXIT CASE (IDHELP) CALL IMODGETHELP('5.3.2','TMO.3DT.PlotSet') END SELECT END SELECT END DO IMOD3D_SETTINGS_IPF=.FALSE. IF(MESSAGE%VALUE1.EQ.IDOK)THEN CALL WDIALOGGETCHECKBOX(IDF_CHECK1,IPFPLOT(IIPF)%ISELECT(1)) CALL WDIALOGGETCHECKBOX(IDF_CHECK2,IPFPLOT(IIPF)%ISELECT(2)) CALL WDIALOGGETCHECKBOX(IDF_CHECK3,IPFPLOT(IIPF)%ISELECT(3)) CALL WDIALOGGETREAL(IDF_REAL1,IPFPLOT(IIPF)%RSELECT(1)) CALL WDIALOGGETREAL(IDF_REAL2,IPFPLOT(IIPF)%RSELECT(2)) CALL WDIALOGGETREAL(IDF_REAL3,IPFPLOT(IIPF)%RSELECT(3)) CALL IMOD3D_IPF_SELECTION(IIPF) IMOD3D_SETTINGS_IPF=.TRUE. ENDIF CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB2) END FUNCTION IMOD3D_SETTINGS_IPF !###====================================================================== LOGICAL FUNCTION IMOD3D_SETTINGS_IDF(IOPTION) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IOPTION INTEGER :: I,J,ITYPE,ICONFIG,N,M,IC1,IC2,IR1,IR2 TYPE(WIN_MESSAGE) :: MESSAGE CHARACTER(LEN=52),DIMENSION(6) :: CACC INTEGER,DIMENSION(6,2) :: IACC ! REAL :: DX,DY CALL WDIALOGLOAD(ID_D3DIDFSETTINGS,ID_D3DIDFSETTINGS) CALL WGRIDROWS(IDF_GRID1,NIDFLIST) CALL WGRIDPUTSTRING(IDF_GRID1,1,IDFPLOT%ALIAS,NIDFLIST) CALL WGRIDSTATE(IDF_GRID1,1,2) CALL WGRIDPUTMENU (IDF_GRID1,2,IDFTYPES,SIZE(IDFTYPES),IDFPLOT%ICUBE,NIDFLIST) CALL WGRIDPUTMENU (IDF_GRID1,3,IDFPLOT%ALIAS,NIDFLIST,IDFPLOT%ICOMBINE ,NIDFLIST) CALL WGRIDPUTMENU (IDF_GRID1,4,IDFPLOT%ALIAS,NIDFLIST,IDFPLOT%IDFLEGEND,NIDFLIST) CALL WDIALOGPUTMENU(IDF_MENU3,IDFTYPES,SIZE(IDFTYPES),1) IDFDATA(3)=10 CALL WDIALOGPUTMENU(IDF_MENU2,(/'BOUNDARY ','ARITHMETIC MEAN','GEOMETRIC MEAN ', & 'SUM ','SUM TIME RATIO ','INVERSE ','MOST.FREQ.OCCUR',& 'SUM INVERSE ','PERCENTILE ','BLOCK VALUE '/),10,IDFDATA(3)) N=0; M=0 DO I=1,NIDFLIST CALL IDFIROWICOL(MP(IDFPLOT(I)%IPLOT)%IDF,IR2,IC1,MPW%XMIN,MPW%YMIN) CALL IDFIROWICOL(MP(IDFPLOT(I)%IPLOT)%IDF,IR1,IC2,MPW%XMAX,MPW%YMAX) IF(MPW%XMIN.LE.MP(IDFPLOT(I)%IPLOT)%IDF%XMIN)IC1=1 IF(MPW%XMAX.GE.MP(IDFPLOT(I)%IPLOT)%IDF%XMAX)IC2=MP(IDFPLOT(I)%IPLOT)%IDF%NCOL IF(MPW%YMIN.LE.MP(IDFPLOT(I)%IPLOT)%IDF%YMIN)IR2=MP(IDFPLOT(I)%IPLOT)%IDF%NROW IF(MPW%YMAX.GE.MP(IDFPLOT(I)%IPLOT)%IDF%YMAX)IR1=1 N=MAX(N,(IC2-IC1)+1) M=MAX(M,(IR2-IR1)+1) ENDDO I=N/5; J=M/5; I=MIN(100,I) ; J=MIN(100,J) !; DX=(MPW%XMAX-MPW%XMIN)/REAL(I); DY=(MPW%YMAX-MPW%YMIN)/REAL(I) ! CACC(1)='Minimal (cells '//TRIM(ITOS(I*J))//'; dx/dy '//TRIM(RTOS(DX,'F',1))//'/'//TRIM(RTOS(DY,'F',1))//')' CACC(1)='Minimal (ncol '//TRIM(ITOS(I))//' x nrow '//TRIM(ITOS(J))//')' IACC(1,1)=I; IACC(1,2)=J I=N/4; J=M/4; I=MIN(250,I) ; J=MIN(250,J) !; DX=(MPW%XMAX-MPW%XMIN)/REAL(I); DY=(MPW%YMAX-MPW%YMIN)/REAL(I) ! CACC(2)='Low (cells '//TRIM(ITOS(I*J))//'; dx/dy '//TRIM(RTOS(DX,'F',1))//'/'//TRIM(RTOS(DY,'F',1))//')' CACC(2)='Low (ncol '//TRIM(ITOS(I))//' x nrow '//TRIM(ITOS(J))//')' IACC(2,1)=I; IACC(2,2)=J I=N/3; J=M/3; I=MIN(500,I) ; J=MIN(500,J) !; DX=(MPW%XMAX-MPW%XMIN)/REAL(I); DY=(MPW%YMAX-MPW%YMIN)/REAL(I) ! CACC(3)='Normal (cells '//TRIM(ITOS(I*J))//'; dx/dy '//TRIM(RTOS(DX,'F',1))//'/'//TRIM(RTOS(DY,'F',1))//')' CACC(3)='Normal (ncol '//TRIM(ITOS(I))//' x nrow '//TRIM(ITOS(J))//')' IACC(3,1)=I; IACC(3,2)=J I=N/2; J=M/2; I=MIN(750,I) ; J=MIN(750,J) !; DX=(MPW%XMAX-MPW%XMIN)/REAL(I); DY=(MPW%YMAX-MPW%YMIN)/REAL(I) ! CACC(4)='High (cells '//TRIM(ITOS(I*J))//'; dx/dy '//TRIM(RTOS(DX,'F',1))//'/'//TRIM(RTOS(DY,'F',1))//')' CACC(4)='High (ncol '//TRIM(ITOS(I))//' x nrow '//TRIM(ITOS(J))//')' IACC(4,1)=I; IACC(4,2)=J I=N/1; J=M/1; I=MIN(1000,I); J=MIN(1000,J)!; DX=(MPW%XMAX-MPW%XMIN)/REAL(I); DY=(MPW%YMAX-MPW%YMIN)/REAL(I) ! CACC(5)='Very High (cells '//TRIM(ITOS(I*J))//'; dx/dy '//TRIM(RTOS(DX,'F',1))//'/'//TRIM(RTOS(DY,'F',1))//')' CACC(5)='Very High (ncol '//TRIM(ITOS(I))//' x nrow '//TRIM(ITOS(J))//')' IACC(5,1)=I; IACC(5,2)=J I=N/1; J=M/1; !; DX=(MPW%XMAX-MPW%XMIN)/REAL(I); DY=(MPW%YMAX-MPW%YMIN)/REAL(I) ! CACC(6)='Maximal (cells '//TRIM(ITOS(I*J))//'; dx/dy '//TRIM(RTOS(DX,'F',1))//'/'//TRIM(RTOS(DY,'F',1))//')' CACC(6)='Maximal (ncol '//TRIM(ITOS(I))//' x nrow '//TRIM(ITOS(J))//')' IACC(6,1)=I; IACC(6,2)=J DO I=6,1,-1; IF(IACC(I,1).LE.150.AND.IACC(I,2).LE.150)EXIT; ENDDO; I=MAX(I,1) IF(IOPTION.EQ.0)THEN CALL WDIALOGPUTMENU(IDF_MENU1,CACC,6,I) ELSE CALL WDIALOGPUTMENU(IDF_MENU1,CACC,6,IDFPLOT(1)%IACC) ENDIF CALL WDIALOGPUTSTRING(IDF_LABEL5,IMOD3D_CONFIGTXT(1)) IF(DEMO%IDEMO.EQ.2)THEN ICONFIG=DEMO%CONFLAG I=DEMO%ACCFLAG CALL IMOD3D_SETTINGS_IDF_CONFIG(ICONFIG) MESSAGE%VALUE1=IDOK CALL WDIALOGPUTINTEGER(IDF_MENU1,I) DEMO%IDEMO=0 ELSE CALL WDIALOGSHOW(-1,-1,0,3) DO CALL WMESSAGE(ITYPE,MESSAGE) SELECT CASE (ITYPE) CASE (PUSHBUTTON) SELECT CASE (MESSAGE%VALUE1) CASE (IDOK,IDCANCEL) EXIT CASE (IDHELP) CALL IMODGETHELP('5.3.2','TMO.3DT.PlotSet') END SELECT CASE (FIELDCHANGED) SELECT CASE (MESSAGE%VALUE2) CASE (IDF_MENU4) CALL WDIALOGGETMENU(IDF_MENU4,ICONFIG) IDFPLOT%ICONFIG=ICONFIG CALL IMOD3D_SETTINGS_IDF_CONFIG(ICONFIG) CASE (IDF_MENU3) CALL WDIALOGGETMENU(IDF_MENU3,J) DO I=1,NIDFLIST; IDFPLOT(I)%ICUBE=J; ENDDO CALL WGRIDPUTMENU(IDF_GRID1,2,IDFTYPES,SIZE(IDFTYPES),IDFPLOT%ICUBE,NIDFLIST) END SELECT END SELECT CALL WDIALOGGETMENU(IDF_MENU1,I) IDFPLOT%IACC=I END DO ENDIF IMOD3D_SETTINGS_IDF=.FALSE. IF(MESSAGE%VALUE1.EQ.IDOK)THEN CALL WGRIDGETMENU (IDF_GRID1,2,IDFPLOT%ICUBE ,NIDFLIST) CALL WGRIDGETMENU (IDF_GRID1,3,IDFPLOT%ICOMBINE ,NIDFLIST) CALL WGRIDGETMENU (IDF_GRID1,4,IDFPLOT%IDFLEGEND,NIDFLIST) IDFDATA(1)=IACC(I,1); IDFDATA(2)=IACC(I,2) !## col,row CALL WDIALOGGETMENU(IDF_MENU2,IDFDATA(3)) IMOD3D_SETTINGS_IDF=.TRUE. ENDIF CALL WDIALOGUNLOAD(); CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB1) END FUNCTION IMOD3D_SETTINGS_IDF !###====================================================================== SUBROUTINE IMOD3D_SETTINGS_IDF_CONFIG(ICONFIG) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICONFIG INTEGER :: I,J,IS CALL WDIALOGPUTSTRING(IDF_LABEL5,IMOD3D_CONFIGTXT(ICONFIG)) CALL WDIALOGGETMENU(IDF_MENU3,J) !## turn them all on (reset them) DO I=1,NIDFLIST; IDFPLOT(I)%ICOMBINE=I; IDFPLOT(I)%IDFLEGEND=I; IF(IDFPLOT(I)%ICUBE.NE.3)IDFPLOT(I)%ICUBE=J; ENDDO DO I=1,NIDFLIST; IF(IDFPLOT(I)%ICUBE.NE.3)EXIT; ENDDO; IS=I+1 SELECT CASE (ICONFIG) !## create clay and top and bottom are fishnets CASE (2) J=0; DO I=IS,NIDFLIST-1,2; J=J+1; IDFPLOT(I)%ICOMBINE=I+1; ENDDO !## turn bot-clay to top-next clay off IDFPLOT%IPLOTLEGEND=1 IF(DEMO%IDEMO.EQ.2)THEN; IDFPLOT%IFILL=DEMO%IFILL; ELSE; IDFPLOT%IFILL=3; IDFPLOT(IS-1)%IFILL=2; ENDIF DO I=IS+1,NIDFLIST,2; IDFPLOT(I)%ICUBE=5; IDFPLOT(I)%IPLOTLEGEND=0; ENDDO !## create aquifers as solids top/bot bot/top CASE (3) !## combine top-bot, top-bot, top-bot DO I=IS-1,NIDFLIST-1,2; IDFPLOT(I)%ICOMBINE=I+1; IDFPLOT(I+1)%ICUBE=5; ENDDO IDFPLOT%IPLOTLEGEND=0 IF(DEMO%IDEMO.EQ.2)THEN IDFPLOT%IFILL=DEMO%IFILL ELSE IDFPLOT%IFILL=3 ENDIF !## combine top-bot, bot-top, bot-top CASE (4) DO I=IS-1,NIDFLIST-1; IDFPLOT(I)%ICOMBINE=I+1; ENDDO !## turn bot-clay to top-next clay off IDFPLOT%IPLOTLEGEND=0 IF(DEMO%IDEMO.EQ.2)THEN; IDFPLOT%IFILL=DEMO%IFILL; ELSE; IDFPLOT%IFILL=3; ENDIF !## solid clays coloured by e.g. c-value CASE (5) IDFPLOT%IPLOTLEGEND=0 IF(DEMO%IDEMO.EQ.2)THEN; IDFPLOT%IFILL=DEMO%IFILL; ELSE; IDFPLOT%IFILL=3; ENDIF DO I=IS,NIDFLIST-1,3 IDFPLOT(I)%ICOMBINE=MIN(NIDFLIST,I+2); IDFPLOT(I)%IDFLEGEND=MIN(NIDFLIST,I+1) IF(I+1.LE.SIZE(IDFPLOT))IDFPLOT(I+1)%ICUBE=5 IF(I+2.LE.SIZE(IDFPLOT))IDFPLOT(I+2)%ICUBE=5 ENDDO !## fishnet for surface IDFPLOT(IS-1)%IPLOTLEGEND=1 IF(IS.LE.SIZE(IDFPLOT))IDFPLOT(IS)%IPLOTLEGEND=1 IDFPLOT(NIDFLIST)%IPLOTLEGEND=1 IF(DEMO%IDEMO.EQ.2)THEN; IDFPLOT%IFILL=DEMO%IFILL; ELSE; IDFPLOT(IS-1)%IFILL=2; ENDIF !## solid aquifers cooured by e.g. k-value CASE (6) IDFPLOT%IPLOTLEGEND=0 IF(DEMO%IDEMO.EQ.2)THEN; IDFPLOT%IFILL=DEMO%IFILL; ELSE; IDFPLOT%IFILL=3; ENDIF DO I=IS-1,NIDFLIST-1,3 IDFPLOT(I)%ICOMBINE=MIN(NIDFLIST,I+2); IDFPLOT(I)%IDFLEGEND=MIN(NIDFLIST,I+1) IF(I+1.LE.SIZE(IDFPLOT))IDFPLOT(I+1)%ICUBE=5 IF(I+2.LE.SIZE(IDFPLOT))IDFPLOT(I+2)%ICUBE=5 ENDDO !## coloured solid for aquifers/aquitards CASE (7) DO I=IS,NIDFLIST-2,2 IF(DEMO%IDEMO.EQ.2)THEN; IDFPLOT%IFILL=DEMO%IFILL; ELSE; IDFPLOT%IFILL=3; ENDIF IDFPLOT(I)%ICOMBINE=MIN(NIDFLIST,I+2); IDFPLOT(I)%IDFLEGEND=MIN(NIDFLIST,I+1); IDFPLOT(I+1)%ICUBE=5 ENDDO IDFPLOT(NIDFLIST)%ICUBE=5 END SELECT CALL WGRIDPUTMENU(IDF_GRID1,2,IDFTYPES,SIZE(IDFTYPES),IDFPLOT%ICUBE,NIDFLIST) CALL WGRIDPUTMENU(IDF_GRID1,3,IDFPLOT%ALIAS,NIDFLIST,IDFPLOT%ICOMBINE ,NIDFLIST) CALL WGRIDPUTMENU(IDF_GRID1,4,IDFPLOT%ALIAS,NIDFLIST,IDFPLOT%IDFLEGEND,NIDFLIST) END SUBROUTINE IMOD3D_SETTINGS_IDF_CONFIG !###====================================================================== FUNCTION IMOD3D_CONFIGTXT(ICONFIG) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ICONFIG CHARACTER(LEN=256) :: IMOD3D_CONFIGTXT IMOD3D_CONFIGTXT='Configuration:' !## configuration SELECT CASE (ICONFIG) !## interfaces CASE (1) IMOD3D_CONFIGTXT=TRIM(IMOD3D_CONFIGTXT)//NEWLINE//'Interfaces for all entries.' !## quasi 3d model (aquitards) CASE (2) IMOD3D_CONFIGTXT=TRIM(IMOD3D_CONFIGTXT)//NEWLINE//'Surface Level represented as a fishnet;'//NEWLINE// & 'Solid appearances for interfaces 2-3,4-5,...;'//NEWLINE// & 'Interface for the hydrological base.' !## quasi 3d model (aquifer) CASE (3) IMOD3D_CONFIGTXT=TRIM(IMOD3D_CONFIGTXT)//NEWLINE//'Solid appearances for all adjacent interfaces 1-2,3-4,5-6,... .' !## 3d model CASE (4) IMOD3D_CONFIGTXT=TRIM(IMOD3D_CONFIGTXT)//NEWLINE//'Solid appearances for all adjacent interfaces 1-2,2-3,3-4,... .' !## coloured quasi 3d model (aquitard) CASE (5) IMOD3D_CONFIGTXT=TRIM(IMOD3D_CONFIGTXT)//NEWLINE//'Surface Level represented as a fishnet;'//NEWLINE// & 'Solid appearances for interfaces 2-4,5-7,..., coloured for given parameters in 3,6,9,...;'//NEWLINE// & 'Interface for the hydrological base.' !## coloured quasi 3d model (aquifer) CASE (6) IMOD3D_CONFIGTXT=TRIM(IMOD3D_CONFIGTXT)//NEWLINE//'Solid appearances for all adjacent interfaces 1-3,4-6,7-9,..., coloured for given parameters in 2,5,8... .' !## coloured 3d model CASE (7) IMOD3D_CONFIGTXT=TRIM(IMOD3D_CONFIGTXT)//NEWLINE//'Solid appearances for all adjacent interfaces 1-3,3-5,5-8,..., coloured for given parameters in 2,4,6... .' END SELECT END FUNCTION IMOD3D_CONFIGTXT !###====================================================================== LOGICAL FUNCTION IMOD3D_REDRAWIDF(IMODE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IMODE INTEGER :: I,II,JJ,ILST,KLST,LLST INTEGER,DIMENSION(3) :: ID_IDF,ND_IDF IMOD3D_REDRAWIDF=.FALSE. !## skip this if nof IDF-files are active IF(NIDFLIST.LE.0)THEN; IMOD3D_REDRAWIDF=.TRUE.; RETURN; ENDIF !## create cookie-cutter IF(IMODE.EQ.0)THEN IF(IMOD3D_CREATECOOKIECUTTERS())THEN; ENDIF ENDIF !## allocate idf memory ALLOCATE(IDF(5)); DO I=1,SIZE(IDF); CALL IDFNULLIFY(IDF(I)); ENDDO !## read idf ILST=0; DO I=1,SIZE(IDFPLOT) !## skip processing of vectors the first loop IF(IMODE.EQ.0.AND.IDFPLOT(I)%ICUBE.EQ.4)CYCLE !## skip others for the other loop IF(IMODE.EQ.1.AND.IDFPLOT(I)%ICUBE.NE.4)CYCLE !## deselected in menu field IF(IDFPLOT(I)%ISEL.EQ.0)CYCLE !## off IF(IDFPLOT(I)%ICUBE.EQ.5)THEN ILST=IDFPLOT(I)%ILIST; IDFPLOT(ILST)%ISEL=0 CYCLE ENDIF JJ=1; ID_IDF(1)=I; ID_IDF(2)=IDFPLOT(I)%ICOMBINE; ID_IDF(3)=IDFPLOT(I)%IDFLEGEND IF(ID_IDF(1).NE.ID_IDF(2))JJ=2 !## combine make a solid IF(ID_IDF(1).NE.ID_IDF(3))JJ=3 !## use another legend KLST=IDFPLOT(ID_IDF(2))%ILIST; LLST=IDFPLOT(ID_IDF(3))%ILIST !## filled with data initially ND_IDF=1 DO II=1,JJ IF(II.GT.1.AND.(ID_IDF(II).EQ.ID_IDF(1)))CYCLE IF(.NOT.IDFREAD(IDF(II),IDFPLOT(ID_IDF(II))%FNAME,0))EXIT CALL WINDOWOUTSTATUSBAR(2,'Processing '//TRIM(IDFPLOT(I)%FNAME)//'('//TRIM(RTOS(REAL(I*100)/REAL(SIZE(IDFPLOT)),'F',2))//'%)') !## first is template IF(II.EQ.1)THEN !## create mother if number of columns/rows to large IF(.NOT.IDFREAD(IDF(5),IDFPLOT(ID_IDF(II))%FNAME,0))EXIT !## template idf will become idf(1) based upon original idf(4) IF(IMOD3D_DRAWIDF_SIZE(IDF(5),IDF(1)))THEN IF(.NOT.IDFREADSCALE_GETX(IDF(5),IDF(1),IDFDATA(3),1,0.0))EXIT !## child,mother,blockvalue,percentile ELSE !## copy idf(5) to idf(1) to become the original CALL IDFCOPY(IDF(5),IDF(1)); IDF(1)%IU=IDF(5)%IU !## read part of idf(1) IF(.NOT.IDFREADPART(IDF(1),REAL(BOT%X)+IDF(1)%DX,REAL(BOT%Y)+IDF(1)%DY, & REAL(TOP%X)-IDF(1)%DX,REAL(TOP%Y)-IDF(1)%DY))EXIT IF(IDF(1)%IVF.EQ.0)THEN IF(MAXVAL(IDF(1)%X).EQ.IDF(1)%NODATA.AND.& MINVAL(IDF(1)%X).EQ.IDF(1)%NODATA)ND_IDF(1)=0 ENDIF ENDIF !## second follows template of first, is obliged to make nice cubes ELSEIF(II.EQ.2)THEN CALL IDFCOPY(IDF(1),IDF(4)) IF(.NOT.IDFREADSCALE_GETX(IDF(2),IDF(4),IDFDATA(3),1,0.0))EXIT !## child,mother,arithmetic mean,percentile IF(MAXVAL(IDF(4)%X).EQ.IDF(4)%NODATA.AND. & MINVAL(IDF(4)%X).EQ.IDF(4)%NODATA)ND_IDF(2)=0 !## third follows template of first ELSEIF(II.EQ.3)THEN CALL IDFCOPY(IDF(1),IDF(5)); IDF(5)%IXV=IDF(3)%IXV IF(.NOT.IDFREADSCALE_GETX(IDF(3),IDF(5),IDFDATA(3),1,0.0))EXIT !## child,mother,arithmetic mean,percentile IF(MAXVAL(IDF(5)%X).EQ.IDF(5)%NODATA.AND. & MINVAL(IDF(5)%X).EQ.IDF(5)%NODATA)ND_IDF(3)=0 ENDIF IF(IDF(II)%IU.NE.0)THEN; CLOSE(IDF(II)%IU); ENDIF ENDDO IF(II.GT.JJ.AND.SUM(ND_IDF).EQ.3)THEN !## read part of idf and store in idf()x() - create smaller resolution! IF(IDFPLOT(I)%ILIST.NE.0)THEN ILST=IDFPLOT(I)%ILIST ELSE ILST=ILST+1 ENDIF IF(IMOD3D_CREATE_SXY(IDF(1),I,VIEWDX,VIEWDY))THEN; ENDIF !## to skip IF(IDFPLOT(I)%ICUBE.EQ.0)THEN !## not within current view-extent IF(IDFLISTINDEX(ILST).NE.0)CALL GLDELETELISTS(IDFLISTINDEX(ILST),1_GLSIZEI) IDFPLOT(ILST)%ILIST=0; IDFPLOT(ILST)%ISEL=0 !## planes ELSEIF(IDFPLOT(I)%ICUBE.EQ.1)THEN IF(ID_IDF(1).EQ.ID_IDF(2))THEN !## create 3D LAYER for current idf CALL IMOD3D_DRAWIDF_STRIP(ILST,LLST) ELSE !## create 3D Solid-LAYER for current idf CALL IMOD3D_DRAWIDF_STRIP_DUO(ILST,LLST,IDFPLOT(LLST)%LEG) ENDIF IDFPLOT(ILST)%ILIST=ILST; IDFPLOT(ILST)%ISEL=1 !## cubes ELSEIF(IDFPLOT(I)%ICUBE.EQ.2)THEN IF(ID_IDF(1).EQ.ID_IDF(2))THEN !## create 3D CUBE for current idf CALL IMOD3D_DRAWIDF_CUBE(ILST,LLST) ELSE CALL IMOD3D_DRAWIDF_CUBE_DUO(ILST,LLST,IDFPLOT(LLST)%LEG) ENDIF IDFPLOT(ILST)%ILIST=ILST; IDFPLOT(ILST)%ISEL=1 !## voxel ELSEIF(IDFPLOT(I)%ICUBE.EQ.3)THEN !## create 3D VOXEL for current idf CALL IMOD3D_DRAWIDF_VOXEL(ILST) IDFPLOT(ILST)%ILIST=ILST; IDFPLOT(ILST)%ISEL=1 ELSEIF(IDFPLOT(I)%ICUBE.EQ.4)THEN !## create 3D VECTOR for current idf CALL IMOD3D_DRAWIDF_VECTOR(ILST,KLST,LLST) IDFPLOT(ILST)%ILIST=ILST; IDFPLOT(ILST)%ISEL=1 ENDIF BOT%Z=MIN(BOT%Z,IDFPLOT(ILST)%ZMIN) TOP%Z=MAX(TOP%Z,IDFPLOT(ILST)%ZMAX) CALL IDFDEALLOCATE(IDF,SIZE(IDF)) ELSE !## not within current view-extent ILST=ILST+1; IDFPLOT(ILST)%ILIST=0; IDFPLOT(ILST)%ISEL=0 ENDIF ENDDO IF(ALLOCATED(IDF))THEN; CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF); ENDIF CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB1) CALL WINDOWOUTSTATUSBAR(2,'') IMOD3D_REDRAWIDF=.TRUE. CALL IMOD3D_ERROR('IMOD3D_REDRAWIDF') END FUNCTION IMOD3D_REDRAWIDF !###====================================================================== SUBROUTINE IMOD3D_DRAWIDF_STRIP(ILST,LLST) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILST,LLST REAL(KIND=GLFLOAT),DIMENSION(4) :: X,Y,Z INTEGER :: IROW,ICOL,I CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_STRIP_BEGIN') !## destroy current display list index IF(IDFLISTINDEX(ILST).NE.0)CALL GLDELETELISTS(IDFLISTINDEX(ILST),1_GLSIZEI) !## list index for, !## start new drawing list IDFLISTINDEX(ILST)=GLGENLISTS(1); CALL GLNEWLIST(IDFLISTINDEX(ILST),GL_COMPILE) IDFPLOT(ILST)%ZMIN= 10.0E10; IDFPLOT(ILST)%ZMAX=-10.0E10 IF(IMOD3D_BLANKOUT(IDF(1)))THEN; ENDIF !## blank nodata (color white) in case legend is used IF(IDFPLOT(ILST)%ILEG.EQ.2)THEN DO IROW=1,IDF(1)%NROW; DO ICOL=1,IDF(1)%NCOL I=UTL_IDFGETCLASS(IDFPLOT(ILST)%LEG,IDF(1)%X(ICOL,IROW)) IF(I.EQ.WRGB(255,255,255))IDF(1)%X(ICOL,IROW)=IDF(1)%NODATA ENDDO; ENDDO ENDIF CALL GLCOLORMATERIAL(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE) CALL GLENABLE(GL_COLOR_MATERIAL) !goto 10 DO IROW=1,IDF(1)%NROW-1 !## translate current position to view=position I=0 DO ICOL=1,IDF(1)%NCOL-1 !## skip nodata points IF(IDF(1)%X(ICOL,IROW) .NE.IDF(1)%NODATA.AND. & IDF(1)%X(ICOL,IROW+1).NE.IDF(1)%NODATA)THEN !## get x/y-coordinate X(3)=IDF(1)%SX(ICOL); Y(3)=IDF(1)%SY(IROW); Z(3)=IDF(1)%X(ICOL,IROW) !## get x/y-coordinate X(4)=IDF(1)%SX(ICOL); Y(4)=IDF(1)%SY(IROW+1); Z(4)=IDF(1)%X(ICOL,IROW+1) I=I+1 ELSE IF(I.GT.1)CALL GLEND(); I=0 ENDIF !## begin strip IF(I.EQ.2)CALL GLBEGIN(GL_QUAD_STRIP) IF(I.GE.2)THEN IF(IDFPLOT(ILST)%ILEG.EQ.2)THEN !## get color for z-mean between two segments IF(ILST.EQ.LLST)THEN CALL IMOD3D_IDF_COLOUR(SUM(Z)/4.0,ILST) !## get color from legend other idf(5) ELSE CALL IMOD3D_IDF_COLOUR(IDF(5)%X(ICOL,IROW),LLST) ENDIF ENDIF CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) DO I=1,4; CALL GLVERTEX3F(X(I),Y(I),Z(I)); ENDDO IDFPLOT(ILST)%ZMIN=MIN(IDFPLOT(ILST)%ZMIN,MINVAL(Z)) IDFPLOT(ILST)%ZMAX=MAX(IDFPLOT(ILST)%ZMAX,MAXVAL(Z)) ENDIF X(1)=X(3); Y(1)=Y(3); Z(1)=Z(3); X(2)=X(4); Y(2)=Y(4); Z(2)=Z(4) ENDDO IF(I.GT.1)CALL GLEND() ENDDO !10 continue CALL GLDISABLE(GL_COLOR_MATERIAL) CALL GLENDLIST() END SUBROUTINE IMOD3D_DRAWIDF_STRIP !###====================================================================== SUBROUTINE IMOD3D_DRAWIDF_STRIP_DUO(ILST,LLST,LEG) !###====================================================================== IMPLICIT NONE TYPE(LEGENDOBJ),INTENT(IN) :: LEG INTEGER,INTENT(IN) :: ILST,LLST REAL(KIND=GLFLOAT),DIMENSION(4) :: X,Y,Z INTEGER :: IROW,ICOL,I,II CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_STRIP_BEGIN') !## destroy current display list index IF(IDFLISTINDEX(ILST).NE.0)CALL GLDELETELISTS(IDFLISTINDEX(ILST),1_GLSIZEI) !## list index for, !## start new drawing list IDFLISTINDEX(ILST)=GLGENLISTS(1); CALL GLNEWLIST(IDFLISTINDEX(ILST),GL_COMPILE) IDFPLOT(ILST)%ZMIN= 10.0E10; IDFPLOT(ILST)%ZMAX=-10.0E10 IF(IMOD3D_BLANKOUT(IDF(1)))THEN; ENDIF IF(IMOD3D_BLANKOUT(IDF(4)))THEN; ENDIF CALL IMOD3D_THICKNESS(ILST,LLST,LEG) CALL GLCOLORMATERIAL(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE) CALL GLENABLE(GL_COLOR_MATERIAL) !## top/bottom DO II=1,4,3 DO IROW=1,IDF(1)%NROW-1 !## translate current position to view=position I=0 DO ICOL=1,IDF(1)%NCOL-1 !## skip nodata points, and thickness<=0.0 IF(IDF(1)%X(ICOL,IROW) .NE.IDF(1)%NODATA.AND. & IDF(1)%X(ICOL,IROW+1).NE.IDF(1)%NODATA)THEN !## get x/y-coordinate X(3)=IDF(1)%SX(ICOL) Y(3)=IDF(1)%SY(IROW) Z(3)=IDF(II)%X(ICOL,IROW) !## get x/y-coordinate X(4)=IDF(1)%SX(ICOL) Y(4)=IDF(1)%SY(IROW+1) Z(4)=IDF(II)%X(ICOL,IROW+1) I=I+1 ELSE IF(I.GT.1)CALL GLEND(); I=0 ENDIF !## begin strip IF(I.EQ.2)CALL GLBEGIN(GL_QUAD_STRIP) IF(I.GE.2)THEN IF(IDFPLOT(ILST)%ILEG.EQ.2)THEN !## get color for z-mean between two segments IF(ILST.EQ.LLST)THEN CALL IMOD3D_IDF_COLOUR(SUM(Z)/4.0,ILST) !## get color from legend other idf(5) ELSE CALL IMOD3D_IDF_COLOUR(IDF(5)%X(ICOL,IROW),LLST) ENDIF ENDIF CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) DO I=1,4; CALL GLVERTEX3F(X(I),Y(I),Z(I)); ENDDO IDFPLOT(ILST)%ZMIN=MIN(IDFPLOT(ILST)%ZMIN,MINVAL(Z)) IDFPLOT(ILST)%ZMAX=MAX(IDFPLOT(ILST)%ZMAX,MAXVAL(Z)) ENDIF X(1)=X(3); Y(1)=Y(3); Z(1)=Z(3); X(2)=X(4); Y(2)=Y(4); Z(2)=Z(4) ENDDO IF(I.GT.1)CALL GLEND() ENDDO ENDDO CALL IMOD3D_DRAWIDF_EDGE_PLANE(ILST,LLST) CALL GLDISABLE(GL_COLOR_MATERIAL) CALL GLENDLIST() END SUBROUTINE IMOD3D_DRAWIDF_STRIP_DUO !###====================================================================== SUBROUTINE IMOD3D_THICKNESS(ILST,LLST,LEG) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILST,LLST TYPE(LEGENDOBJ),INTENT(IN) :: LEG INTEGER :: IROW,ICOL,ICLR !## make thicknesses DO IROW=1,IDF(1)%NROW DO ICOL=1,IDF(1)%NCOL !## apply exclude value whenever value outside legend IF(ILST.NE.LLST)THEN ICLR=UTL_IDFGETCLASS(LEG,IDF(5)%X(ICOL,IROW)) !## outside legend class IF(ICLR.EQ.WRGB(255,255,255))THEN IDF(1)%X(ICOL,IROW)=IDF(1)%NODATA IDF(4)%X(ICOL,IROW)=IDF(4)%NODATA ENDIF ENDIF IF(IDF(1)%X(ICOL,IROW).EQ.IDF(1)%NODATA.OR. & IDF(4)%X(ICOL,IROW).EQ.IDF(4)%NODATA.OR. & IDF(1)%X(ICOL,IROW).LE.IDF(4)%X(ICOL,IROW))THEN IDF(1)%X(ICOL,IROW)=IDF(1)%NODATA IDF(4)%X(ICOL,IROW)=IDF(1)%NODATA ENDIF ENDDO ENDDO END SUBROUTINE IMOD3D_THICKNESS !###====================================================================== SUBROUTINE IMOD3D_DRAWIDF_EDGE_PLANE(ILST,LLST) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILST,LLST REAL(KIND=GLFLOAT),DIMENSION(4) :: X,Y,Z REAL :: C INTEGER :: IROW,ICOL LOGICAL :: LEDGE CALL GLBEGIN(GL_QUADS) !## sides DO IROW=1,IDF(1)%NROW-1 DO ICOL=1,IDF(1)%NCOL-1 !## active cell IF(IDF(1)%X(ICOL,IROW) .NE.IDF(1)%NODATA.AND. & IDF(1)%X(ICOL,IROW+1).NE.IDF(1)%NODATA)THEN LEDGE=.FALSE. !## west IF(ICOL.GT.1)THEN IF(IDF(1)%X(ICOL-1,IROW) .EQ.IDF(1)%NODATA.OR. & IDF(1)%X(ICOL-1,IROW+1).EQ.IDF(1)%NODATA)THEN LEDGE=.TRUE. ENDIF ENDIF !## east IF(IDF(1)%X(ICOL+1,IROW) .EQ.IDF(1)%NODATA.OR. & IDF(1)%X(ICOL+1,IROW+1).EQ.IDF(1)%NODATA)THEN LEDGE=.TRUE. ENDIF IF(LEDGE)THEN X(1)=IDF(1)%SX(ICOL); Y(1)=IDF(1)%SY(IROW) ; Z(1)=IDF(1)%X(ICOL,IROW) X(2)=IDF(1)%SX(ICOL); Y(2)=IDF(1)%SY(IROW+1); Z(2)=IDF(1)%X(ICOL,IROW+1) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL,IROW+1) X(4)=X(1); Y(4)=Y(1); Z(4)=IDF(4)%X(ICOL,IROW) IF(ILST.NE.LLST)C=(IDF(5)%X(ICOL,IROW)+IDF(5)%X(ICOL,IROW+1))/2.0 CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF ENDIF !## active cell IF(IDF(1)%X(ICOL,IROW) .NE.IDF(1)%NODATA.AND. & IDF(1)%X(ICOL+1,IROW).NE.IDF(1)%NODATA)THEN LEDGE=.FALSE. !## north IF(IROW.GT.1)THEN IF(IDF(1)%X(ICOL,IROW-1) .EQ.IDF(1)%NODATA.OR. & IDF(1)%X(ICOL+1,IROW-1).EQ.IDF(1)%NODATA)THEN LEDGE=.TRUE. ENDIF ENDIF !## south IF(IDF(1)%X(ICOL,IROW+1) .EQ.IDF(1)%NODATA.OR. & IDF(1)%X(ICOL+1,IROW+1).EQ.IDF(1)%NODATA)THEN LEDGE=.TRUE. ENDIF IF(LEDGE)THEN X(1)=IDF(1)%SX(ICOL); Y(1)=IDF(1)%SY(IROW); Z(1)=IDF(1)%X(ICOL,IROW) X(2)=IDF(1)%SX(ICOL+1); Y(2)=IDF(1)%SY(IROW); Z(2)=IDF(1)%X(ICOL+1,IROW) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL+1,IROW) X(4)=X(1); Y(4)=Y(1); Z(4)=IDF(4)%X(ICOL,IROW) IF(ILST.NE.LLST)C=(IDF(5)%X(ICOL,IROW)+IDF(5)%X(ICOL+1,IROW))/2.0 CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF ENDIF ENDDO ENDDO !## outer bounds ICOL=1; DO IROW=1,IDF(1)%NROW-1 !## active cell IF(IDF(1)%X(ICOL,IROW) .NE.IDF(1)%NODATA.AND. & IDF(1)%X(ICOL,IROW+1).NE.IDF(1)%NODATA)THEN X(1)=IDF(1)%SX(ICOL); Y(1)=IDF(1)%SY(IROW) ; Z(1)=IDF(1)%X(ICOL,IROW) X(2)=IDF(1)%SX(ICOL); Y(2)=IDF(1)%SY(IROW+1); Z(2)=IDF(1)%X(ICOL,IROW+1) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL,IROW+1) X(4)=X(1); Y(4)=Y(1); Z(4)=IDF(4)%X(ICOL,IROW) IF(ILST.NE.LLST)C=(IDF(5)%X(ICOL,IROW)+IDF(5)%X(ICOL,IROW+1))/2.0 CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF ENDDO ICOL=IDF(1)%NCOL-1; DO IROW=1,IDF(1)%NROW-1 !## active cell IF(IDF(1)%X(ICOL,IROW) .NE.IDF(1)%NODATA.AND. & IDF(1)%X(ICOL,IROW+1).NE.IDF(1)%NODATA)THEN X(1)=IDF(1)%SX(ICOL); Y(1)=IDF(1)%SY(IROW) ; Z(1)=IDF(1)%X(ICOL,IROW) X(2)=IDF(1)%SX(ICOL); Y(2)=IDF(1)%SY(IROW+1); Z(2)=IDF(1)%X(ICOL,IROW+1) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL,IROW+1) X(4)=X(1); Y(4)=Y(1); Z(4)=IDF(4)%X(ICOL,IROW) IF(ILST.NE.LLST)C=(IDF(5)%X(ICOL,IROW)+IDF(5)%X(ICOL,IROW+1))/2.0 CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF ENDDO IROW=1; DO ICOL=1,IDF(1)%NCOL-2 !## active cell IF(IDF(1)%X(ICOL,IROW) .NE.IDF(1)%NODATA.AND. & IDF(1)%X(ICOL+1,IROW).NE.IDF(1)%NODATA)THEN X(1)=IDF(1)%SX(ICOL); Y(1)=IDF(1)%SY(IROW); Z(1)=IDF(1)%X(ICOL,IROW) X(2)=IDF(1)%SX(ICOL+1); Y(2)=IDF(1)%SY(IROW); Z(2)=IDF(1)%X(ICOL+1,IROW) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL+1,IROW) X(4)=X(1); Y(4)=Y(1); Z(4)=IDF(4)%X(ICOL,IROW) IF(ILST.NE.LLST)C=(IDF(5)%X(ICOL,IROW)+IDF(5)%X(ICOL+1,IROW))/2.0 CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF ENDDO IROW=IDF(1)%NROW; DO ICOL=1,IDF(1)%NCOL-2 !## active cell IF(IDF(1)%X(ICOL,IROW) .NE.IDF(1)%NODATA.AND. & IDF(1)%X(ICOL+1,IROW).NE.IDF(1)%NODATA)THEN X(1)=IDF(1)%SX(ICOL); Y(1)=IDF(1)%SY(IROW); Z(1)=IDF(1)%X(ICOL,IROW) X(2)=IDF(1)%SX(ICOL+1); Y(2)=IDF(1)%SY(IROW); Z(2)=IDF(1)%X(ICOL+1,IROW) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL+1,IROW) X(4)=X(1); Y(4)=Y(1); Z(4)=IDF(4)%X(ICOL,IROW) IF(ILST.NE.LLST)C=(IDF(5)%X(ICOL,IROW)+IDF(5)%X(ICOL+1,IROW))/2.0 CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF ENDDO CALL GLEND() END SUBROUTINE IMOD3D_DRAWIDF_EDGE_PLANE !###====================================================================== SUBROUTINE IMOD3D_DRAWIDF_EDGE_CUBE(ILST,LLST) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILST,LLST REAL(KIND=GLFLOAT),DIMENSION(4) :: X,Y,Z REAL :: C INTEGER :: IROW,ICOL,IC1,IC2,IR1,IR2 LOGICAL :: LEDGE CALL GLBEGIN(GL_QUADS) !## sides DO IROW=1,IDF(1)%NROW DO ICOL=1,IDF(1)%NCOL !## active cell IF(IDF(1)%X(ICOL,IROW).NE.IDF(1)%NODATA)THEN IC1=ICOL-1; IC2=ICOL+1; IR1=IROW-1; IR2=IROW+1 !## west LEDGE=.FALSE. IF(ICOL.GT.1)THEN IF(IDF(1)%X(IC1,IROW).EQ.IDF(1)%NODATA)LEDGE=.TRUE. ELSE LEDGE=.TRUE. ENDIF IF(LEDGE)THEN X(1)=IDF(1)%SX(IC1); Y(1)=IDF(1)%SY(IR1); Z(1)=IDF(1)%X(ICOL,IROW) X(2)=X(1); Y(2)=IDF(1)%SY(IROW); Z(2)=Z(1) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL,IROW) X(4)=X(1); Y(4)=Y(1); Z(4)=Z(3) IF(ILST.NE.LLST)C=IDF(5)%X(ICOL,IROW) CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF !## east LEDGE=.FALSE. IF(ICOL.LT.IDF(1)%NCOL)THEN IF(IDF(1)%X(IC2,IROW).EQ.IDF(1)%NODATA)LEDGE=.TRUE. ELSE LEDGE=.TRUE. ENDIF IF(LEDGE)THEN X(1)=IDF(1)%SX(ICOL); Y(1)=IDF(1)%SY(IR1); Z(1)=IDF(1)%X(ICOL,IROW) X(2)=X(1); Y(2)=IDF(1)%SY(IROW); Z(2)=Z(1) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL,IROW) X(4)=X(1); Y(4)=Y(1); Z(4)=Z(3) IF(ILST.NE.LLST)C=IDF(5)%X(ICOL,IROW) CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF !## north LEDGE=.FALSE. IF(IROW.GT.1)THEN IF(IDF(1)%X(ICOL,IR1).EQ.IDF(1)%NODATA)LEDGE=.TRUE. ELSE LEDGE=.TRUE. ENDIF IF(LEDGE)THEN X(1)=IDF(1)%SX(IC1); Y(1)=IDF(1)%SY(IR1); Z(1)=IDF(1)%X(ICOL,IROW) X(2)=IDF(1)%SX(ICOL); Y(2)=Y(1); Z(2)=Z(1) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL,IROW) X(4)=X(1); Y(4)=Y(1); Z(4)=Z(3) IF(ILST.NE.LLST)C=IDF(5)%X(ICOL,IROW) CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF !## south LEDGE=.FALSE. IF(IROW.LT.IDF(1)%NROW)THEN IF(IDF(1)%X(ICOL,IR2).EQ.IDF(1)%NODATA)LEDGE=.TRUE. ELSE LEDGE=.TRUE. ENDIF IF(LEDGE)THEN X(1)=IDF(1)%SX(IC1) ; Y(1)=IDF(1)%SY(IROW); Z(1)=IDF(1)%X(ICOL,IROW) X(2)=IDF(1)%SX(ICOL); Y(2)=IDF(1)%SY(IROW); Z(2)=Z(1) X(3)=X(2); Y(3)=Y(2); Z(3)=IDF(4)%X(ICOL,IROW) X(4)=X(1); Y(4)=Y(1); Z(4)=Z(3) IF(ILST.NE.LLST)C=IDF(5)%X(ICOL,IROW) CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) ENDIF ENDIF ENDDO ENDDO CALL GLEND() END SUBROUTINE IMOD3D_DRAWIDF_EDGE_CUBE !###====================================================================== SUBROUTINE IMOD3D_IDF_COLOUR(V,ILST) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILST REAL,INTENT(IN) :: V INTEGER :: ICLR CALL IMOD3D_ERROR('IMOD3D_IDF_COLOUR BEGIN') ICLR=UTL_IDFGETCLASS(IDFPLOT(ILST)%LEG,V) CALL IMOD3D_SETCOLOR(ICLR) CALL IMOD3D_ERROR('IMOD3D_IDF_COLOUR END') END SUBROUTINE IMOD3D_IDF_COLOUR !###====================================================================== SUBROUTINE IMOD3D_DRAWIDF_CUBE(ILST,LLST) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILST,LLST REAL(KIND=GLFLOAT),DIMENSION(2) :: X,Y REAL(KIND=GLFLOAT),DIMENSION(0:4) :: Z INTEGER :: IROW,ICOL,I,IC1,IC2,IR1,IR2 INTEGER,DIMENSION(4) :: IB CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_CUBE BEGIN') IF(IMOD3D_BLANKOUT(IDF(1)))THEN; ENDIF !## blank nodata (color white) in case legend is used IF(IDFPLOT(ILST)%ILEG.EQ.2)THEN DO IROW=1,IDF(1)%NROW; DO ICOL=1,IDF(1)%NCOL I=UTL_IDFGETCLASS(IDFPLOT(ILST)%LEG,IDF(1)%X(ICOL,IROW)) IF(I.EQ.WRGB(255,255,255))IDF(1)%X(ICOL,IROW)=IDF(1)%NODATA ENDDO; ENDDO ENDIF !## destroy current display list index IF(IDFLISTINDEX(ILST).NE.0)CALL GLDELETELISTS(IDFLISTINDEX(ILST),1_GLSIZEI) !## list index for IDFLISTINDEX(ILST)=GLGENLISTS(1) !## start new drawing list CALL GLNEWLIST(IDFLISTINDEX(ILST),GL_COMPILE) IDFPLOT(ILST)%ZMIN= 10.0E10; IDFPLOT(ILST)%ZMAX=-10.0E10 CALL GLCOLORMATERIAL(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE) CALL GLENABLE(GL_COLOR_MATERIAL) DO IROW=1,IDF(1)%NROW !## translate current position to view=postition DO ICOL=1,IDF(1)%NCOL IF(IDF(1)%X(ICOL,IROW).EQ.IDF(1)%NODATA)CYCLE IC1=ICOL-1; IC2=ICOL+1; IR1=IROW-1; IR2=IROW+1 !## value of raster cell Z(0)= IDF(1)%X(ICOL,IROW) IB=0 !## draw none of the side IF(ICOL.GT.1)THEN IF(IDF(1)%X(IC1,IROW).NE.IDF(1)%NODATA.AND.IDF(1)%X(IC1,IROW).LT.Z(0))THEN IB(1)=1; Z(1) =IDF(1)%X(IC1,IROW) ENDIF ENDIF IF(IROW.GT.1)THEN IF(IDF(1)%X(ICOL,IR1).NE.IDF(1)%NODATA.AND.IDF(1)%X(ICOL,IR1).LT.Z(0))THEN IB(2)=1; Z(2) =IDF(1)%X(ICOL,IR1) ENDIF ENDIF IF(ICOL.LT.IDF(1)%NCOL)THEN IF(IDF(1)%X(IC2,IROW).NE.IDF(1)%NODATA.AND.IDF(1)%X(IC2,IROW).LT.Z(0))THEN IB(3)=1; Z(3) =IDF(1)%X(IC2,IROW) ENDIF ENDIF IF(IROW.LT.IDF(1)%NROW)THEN IF(IDF(1)%X(ICOL,IR2).NE.IDF(1)%NODATA.AND.IDF(1)%X(ICOL,IR2).LT.Z(0))THEN IB(4)=1; Z(4) =IDF(1)%X(ICOL,IR2) ENDIF ENDIF !## get x/y/z-coordinate X(1)=IDF(1)%SX(IC1); Y(1)=IDF(1)%SY(IROW) !## get x/y/z-coordinate X(2)=IDF(1)%SX(ICOL); Y(2)=IDF(1)%SY(IR1) IF(IDFPLOT(ILST)%ILEG.EQ.2)THEN IF(ILST.EQ.LLST)THEN !## get color for z-mean between two segments CALL IMOD3D_IDF_COLOUR(Z(0),ILST) ELSE CALL IMOD3D_IDF_COLOUR(IDF(5)%X(ICOL,IROW),LLST) ENDIF ENDIF CALL IMOD3D_CUBE(X,Y,Z,IB) IDFPLOT(ILST)%ZMIN=MIN(IDFPLOT(ILST)%ZMIN,Z(0)) IDFPLOT(ILST)%ZMAX=MAX(IDFPLOT(ILST)%ZMAX,Z(0)) ENDDO ENDDO CALL GLDISABLE(GL_COLOR_MATERIAL) CALL GLENDLIST() CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_CUBE END') END SUBROUTINE IMOD3D_DRAWIDF_CUBE !###====================================================================== SUBROUTINE IMOD3D_DRAWIDF_CUBE_DUO(ILST,LLST,LEG) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILST,LLST TYPE(LEGENDOBJ),INTENT(IN) :: LEG REAL(KIND=GLFLOAT),DIMENSION(2) :: X,Y REAL(KIND=GLFLOAT),DIMENSION(0:4) :: Z INTEGER :: IROW,ICOL,II,IC1,IC2,IR1,IR2 INTEGER,DIMENSION(4) :: IB CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_CUBE BEGIN') IF(IMOD3D_BLANKOUT(IDF(1)))THEN; ENDIF IF(IMOD3D_BLANKOUT(IDF(4)))THEN; ENDIF CALL IMOD3D_THICKNESS(ILST,LLST,LEG) !## destroy current display list index IF(IDFLISTINDEX(ILST).NE.0)CALL GLDELETELISTS(IDFLISTINDEX(ILST),1_GLSIZEI) !## list index for IDFLISTINDEX(ILST)=GLGENLISTS(1) !## start new drawing list CALL GLNEWLIST(IDFLISTINDEX(ILST),GL_COMPILE) IDFPLOT(ILST)%ZMIN= 10.0E10; IDFPLOT(ILST)%ZMAX=-10.0E10 CALL GLCOLORMATERIAL(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE) CALL GLENABLE(GL_COLOR_MATERIAL) !## top/bottom DO II=1,4,3 DO IROW=1,IDF(1)%NROW !## translate current position to view=postition DO ICOL=1,IDF(1)%NCOL IF(IDF(1)%X(ICOL,IROW).EQ.IDF(1)%NODATA)CYCLE IC1=ICOL-1; IC2=ICOL+1; IR1=IROW-1; IR2=IROW+1 !## value of raster cell Z(0)= IDF(II)%X(ICOL,IROW) IB=0 !## draw none of the side IF(ICOL.GT.1)THEN IF(IDF(II)%X(IC1,IROW).NE.IDF(1)%NODATA.AND.IDF(II)%X(IC1,IROW).LT.Z(0))THEN IB(1)=1; Z(1) =IDF(II)%X(IC1,IROW) ENDIF ENDIF IF(IROW.GT.1)THEN IF(IDF(II)%X(ICOL,IR1).NE.IDF(1)%NODATA.AND.IDF(II)%X(ICOL,IR1).LT.Z(0))THEN IB(2)=1; Z(2) =IDF(II)%X(ICOL,IR1) ENDIF ENDIF IF(ICOL.LT.IDF(1)%NCOL)THEN IF(IDF(II)%X(IC2,IROW).NE.IDF(1)%NODATA.AND.IDF(II)%X(IC2,IROW).LT.Z(0))THEN IB(3)=1; Z(3) =IDF(II)%X(IC2,IROW) ENDIF ENDIF IF(IROW.LT.IDF(1)%NROW)THEN IF(IDF(II)%X(ICOL,IR2).NE.IDF(1)%NODATA.AND.IDF(II)%X(ICOL,IR2).LT.Z(0))THEN IB(4)=1; Z(4) =IDF(II)%X(ICOL,IR2) ENDIF ENDIF !## get x/y/z-coordinate X(1)=IDF(1)%SX(IC1); Y(1)=IDF(1)%SY(IROW) !## get x/y/z-coordinate X(2)=IDF(1)%SX(ICOL); Y(2)=IDF(1)%SY(IR1) IF(IDFPLOT(ILST)%ILEG.EQ.2)THEN IF(ILST.EQ.LLST)THEN !## get color for z-mean between two segments CALL IMOD3D_IDF_COLOUR(Z(0),ILST) ELSE CALL IMOD3D_IDF_COLOUR(IDF(5)%X(ICOL,IROW),LLST) ENDIF ENDIF CALL IMOD3D_CUBE(X,Y,Z,IB) IDFPLOT(ILST)%ZMIN=MIN(IDFPLOT(ILST)%ZMIN,Z(0)) IDFPLOT(ILST)%ZMAX=MAX(IDFPLOT(ILST)%ZMAX,Z(0)) ENDDO ENDDO ENDDO CALL IMOD3D_DRAWIDF_EDGE_CUBE(ILST,LLST) CALL GLDISABLE(GL_COLOR_MATERIAL) CALL GLENDLIST() CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_CUBE END') END SUBROUTINE IMOD3D_DRAWIDF_CUBE_DUO !###====================================================================== SUBROUTINE IMOD3D_CUBE(X,Y,Z,IB) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN),DIMENSION(4) :: IB REAL(KIND=GLFLOAT),DIMENSION(2),INTENT(IN) :: X,Y REAL(KIND=GLFLOAT),DIMENSION(0:4),INTENT(IN) :: Z !## top CALL GLBEGIN(GL_QUADS) CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(2),Z(0)/),(/X(2),Y(2),Z(0)/),(/X(2),Y(1),Z(0)/)) CALL GLVERTEX3F(X(1),Y(2),Z(0)) CALL GLVERTEX3F(X(2),Y(2),Z(0)) CALL GLVERTEX3F(X(2),Y(1),Z(0)) CALL GLVERTEX3F(X(1),Y(1),Z(0)) CALL GLEND() IF(SUM(IB).EQ.0)RETURN CALL GLBEGIN(GL_QUADS) IF(IB(1).EQ.1)THEN !## west-rib CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(1),Y(1),Z(0)/),(/X(1),Y(2),Z(0)/)) !## left CALL GLVERTEX3F(X(1),Y(1),Z(1)) CALL GLVERTEX3F(X(1),Y(1),Z(0)) CALL GLVERTEX3F(X(1),Y(2),Z(0)) CALL GLVERTEX3F(X(1),Y(2),Z(1)) ENDIF IF(IB(2).EQ.1)THEN !## north-rib CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(2),Z(2)/),(/X(1),Y(2),Z(0)/),(/X(2),Y(2),Z(0)/)) !## back CALL GLVERTEX3F(X(1),Y(2),Z(2)) CALL GLVERTEX3F(X(1),Y(2),Z(0)) CALL GLVERTEX3F(X(2),Y(2),Z(0)) CALL GLVERTEX3F(X(2),Y(2),Z(2)) ENDIF IF(IB(3).EQ.1)THEN !## eastrib CALL IMOD3D_SETNORMALVECTOR((/X(2),Y(2),Z(3)/),(/X(2),Y(2),Z(0)/),(/X(2),Y(1),Z(0)/)) !## back CALL GLVERTEX3F(X(2),Y(2),Z(3)) CALL GLVERTEX3F(X(2),Y(2),Z(0)) CALL GLVERTEX3F(X(2),Y(1),Z(0)) CALL GLVERTEX3F(X(2),Y(1),Z(3)) ENDIF IF(IB(4).EQ.1)THEN !## frontrib CALL IMOD3D_SETNORMALVECTOR((/X(2),Y(1),Z(4)/),(/X(2),Y(1),Z(0)/),(/X(1),Y(1),Z(4)/)) !## right CALL GLVERTEX3F(X(2),Y(1),Z(4)) CALL GLVERTEX3F(X(2),Y(1),Z(0)) CALL GLVERTEX3F(X(1),Y(1),Z(0)) CALL GLVERTEX3F(X(1),Y(1),Z(4)) ENDIF CALL GLEND() END SUBROUTINE IMOD3D_CUBE !###====================================================================== SUBROUTINE IMOD3D_DRAWIDF_VOXEL(ILST) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILST REAL(KIND=GLFLOAT),DIMENSION(2) :: X,Y,Z INTEGER :: IROW,ICOL,ICLR INTEGER,DIMENSION(4) :: IB CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_VOXEL BEGIN') IF(IMOD3D_BLANKOUT(IDF(1)))THEN; ENDIF !## blank nodata (color white) in case legend is used IF(IDFPLOT(ILST)%ILEG.EQ.2)THEN DO IROW=1,IDF(1)%NROW; DO ICOL=1,IDF(1)%NCOL ICLR=UTL_IDFGETCLASS(IDFPLOT(ILST)%LEG,IDF(1)%X(ICOL,IROW)) IF(ICLR.EQ.WRGB(255,255,255))IDF(1)%X(ICOL,IROW)=IDF(1)%NODATA ENDDO; ENDDO ENDIF !## destroy current display list index IF(IDFLISTINDEX(ILST).NE.0)CALL GLDELETELISTS(IDFLISTINDEX(ILST),1_GLSIZEI) !## list index for IDFLISTINDEX(ILST)=GLGENLISTS(1) !## start new drawing list CALL GLNEWLIST(IDFLISTINDEX(ILST),GL_COMPILE) !## not voxel, asume one IF(IDF(1)%ITB.EQ.0)THEN Z(1)=-1.0*REAL(ILST-1); Z(2)=Z(1)-1.0 !## true voxel ELSE Z(1)=IDF(1)%TOP; Z(2)=IDF(1)%BOT ENDIF CALL GLCOLORMATERIAL(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE) CALL GLENABLE(GL_COLOR_MATERIAL) DO IROW=1,IDF(1)%NROW !## translate current position to view=postition Y(1)=IDF(1)%SY(IROW) Y(2)=IDF(1)%SY(IROW-1) DO ICOL=1,IDF(1)%NCOL IF(IDF(1)%X(ICOL,IROW).EQ.IDF(1)%NODATA)CYCLE !## get x/y/z-coordinate X(1)=IDF(1)%SX(ICOL-1) X(2)=IDF(1)%SX(ICOL) IB=0 !## draw none IB(1)=0; IF(ICOL.EQ.1)IB(1)=1 IB(3)=0; IF(ICOL.EQ.IDF(1)%NCOL)IB(3)=1 IB(2)=0; IF(IROW.EQ.1)IB(2)=1 IB(4)=0; IF(IROW.EQ.IDF(1)%NROW)IB(4)=1 IF(ICOL.GT.1)THEN IF(IDF(1)%X(ICOL-1,IROW).EQ.IDF(1)%NODATA)IB(1)=1 ENDIF IF(IROW.GT.1)THEN IF(IDF(1)%X(ICOL,IROW-1).EQ.IDF(1)%NODATA)IB(2)=1 ENDIF IF(ICOL.LT.IDF(1)%NCOL)THEN IF(IDF(1)%X(ICOL+1,IROW).EQ.IDF(1)%NODATA)IB(3)=1 ENDIF IF(IROW.LT.IDF(1)%NROW)THEN IF(IDF(1)%X(ICOL,IROW+1).EQ.IDF(1)%NODATA)IB(4)=1 ENDIF !## get color for z-mean between two segments IF(IDFPLOT(ILST)%ILEG.EQ.2)CALL IMOD3D_IDF_COLOUR(IDF(1)%X(ICOL,IROW),ILST) CALL IMOD3D_VOXEL(X,Y,Z,IB) ENDDO ENDDO IDFPLOT(ILST)%ZMIN=Z(2) !IDF(1)%BOT IDFPLOT(ILST)%ZMAX=Z(1) !IDF(1)%TOP CALL GLDISABLE(GL_COLOR_MATERIAL) CALL GLENDLIST() CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_VOXEL END') END SUBROUTINE IMOD3D_DRAWIDF_VOXEL !###====================================================================== SUBROUTINE IMOD3D_VOXEL(X,Y,Z,IB) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN),DIMENSION(4) :: IB REAL(KIND=GLFLOAT),DIMENSION(2),INTENT(IN) :: X,Y,Z !## top CALL GLBEGIN(GL_QUADS) CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(2),Z(1)/),(/X(2),Y(2),Z(1)/),(/X(2),Y(1),Z(1)/)) CALL GLVERTEX3F(X(1),Y(2),Z(1)) CALL GLVERTEX3F(X(2),Y(2),Z(1)) CALL GLVERTEX3F(X(2),Y(1),Z(1)) CALL GLVERTEX3F(X(1),Y(1),Z(1)) CALL GLEND() IF(Z(1).EQ.Z(2))RETURN IF(SUM(IB).NE.0)THEN CALL GLBEGIN(GL_QUADS) IF(IB(1).EQ.1)THEN !## west-rib CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(2)/),(/X(1),Y(1),Z(1)/),(/X(1),Y(2),Z(1)/)) !## left CALL GLVERTEX3F(X(1),Y(1),Z(2)) CALL GLVERTEX3F(X(1),Y(1),Z(1)) CALL GLVERTEX3F(X(1),Y(2),Z(1)) CALL GLVERTEX3F(X(1),Y(2),Z(2)) ENDIF IF(IB(2).EQ.1)THEN !## north-rib CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(2),Z(2)/),(/X(1),Y(2),Z(1)/),(/X(2),Y(2),Z(1)/)) !## back CALL GLVERTEX3F(X(1),Y(2),Z(2)) CALL GLVERTEX3F(X(1),Y(2),Z(1)) CALL GLVERTEX3F(X(2),Y(2),Z(1)) CALL GLVERTEX3F(X(2),Y(2),Z(2)) ENDIF IF(IB(3).EQ.1)THEN !## eastrib CALL IMOD3D_SETNORMALVECTOR((/X(2),Y(2),Z(2)/),(/X(2),Y(2),Z(1)/),(/X(2),Y(1),Z(1)/)) !## back CALL GLVERTEX3F(X(2),Y(2),Z(2)) CALL GLVERTEX3F(X(2),Y(2),Z(1)) CALL GLVERTEX3F(X(2),Y(1),Z(1)) CALL GLVERTEX3F(X(2),Y(1),Z(2)) ENDIF IF(IB(4).EQ.1)THEN !## frontrib CALL IMOD3D_SETNORMALVECTOR((/X(2),Y(1),Z(1)/),(/X(2),Y(1),Z(1)/),(/X(1),Y(1),Z(2)/)) !## right CALL GLVERTEX3F(X(2),Y(1),Z(2)) CALL GLVERTEX3F(X(2),Y(1),Z(1)) CALL GLVERTEX3F(X(1),Y(1),Z(1)) CALL GLVERTEX3F(X(1),Y(1),Z(2)) ENDIF CALL GLEND() ENDIF !## bottom CALL GLBEGIN(GL_QUADS) CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(2),Z(2)/),(/X(2),Y(2),Z(2)/),(/X(2),Y(1),Z(2)/)) CALL GLVERTEX3F(X(1),Y(2),Z(2)) CALL GLVERTEX3F(X(2),Y(2),Z(2)) CALL GLVERTEX3F(X(2),Y(1),Z(2)) CALL GLVERTEX3F(X(1),Y(1),Z(2)) CALL GLEND() END SUBROUTINE IMOD3D_VOXEL !###====================================================================== SUBROUTINE IMOD3D_DRAWIDF_VECTOR(ILST,KLST,LLST) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ILST,KLST,LLST REAL(KIND=GLFLOAT) :: X,Y,Z REAL :: F,FF,VL,MINZ,MAXZ,DZDX,DZDY,DZDZ INTEGER :: IROW,ICOL,IIDF CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_VECTOR BEGIN') !## destroy current display list index IF(IDFLISTINDEX(ILST).NE.0)CALL GLDELETELISTS(IDFLISTINDEX(ILST),1_GLSIZEI) !## list index for IDFLISTINDEX(ILST)=GLGENLISTS(1) !## start new drawing list CALL GLNEWLIST(IDFLISTINDEX(ILST),GL_COMPILE) FF=(2.0_GLFLOAT*XYZAXES(1))/IDF(1)%NCOL !*IDF(1)%DX) FF= FF*1.0_GLFLOAT IIDF=1; IF(ILST.NE.LLST)IIDF=5 MINZ=10.0E10; MAXZ=-10.0E10 CALL GLCOLORMATERIAL(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE) CALL GLENABLE(GL_COLOR_MATERIAL) DO IROW=1,IDF(1)%NROW !## translate current position to view=postition Y=(IDF(1)%SY(IROW)+IDF(1)%SY(IROW-1))/2.0 DO ICOL=1,IDF(1)%NCOL !## normal IDF DZDZ=0.0 IF(IDF(1)%IVF.EQ.0)CALL SOF_COMPUTE_GRAD(IDF(1),ICOL,IROW,DZDX,DZDY) !## 3IDF IF(IDF(1)%IVF.EQ.1)CALL SOF_COMPUTE_GRAD_3D(IDF(1),ICOL,IROW,DZDX,DZDY,DZDZ) F=DZDX**2.0+DZDY**2.0; IF(F.NE.0.0)F=SQRT(F) IF(F.NE.IDF(1)%NODATA)THEN !## get color for velocity IF(IDFPLOT(ILST)%ILEG.EQ.2)CALL IMOD3D_IDF_COLOUR(VL,LLST) !## get x/y/z-coordinate X=(IDF(1)%SX(ICOL-1)+IDF(1)%SX(ICOL))/2.0 IF(IDF(1)%IVF.EQ.0)THEN IF(ILST.NE.LLST)THEN Z=IDF(1)%X(ICOL,IROW) IF(ILST.NE.KLST)Z=(Z+IDF(4)%X(ICOL,IROW))/2.0_GLFLOAT ELSE IF(TOP%Z.LT.BOT%Z)THEN Z=0.0_GLFLOAT ELSE Z=(TOP%Z+BOT%Z)/2.0_GLFLOAT ENDIF ENDIF ELSEIF(IDF(1)%IVF.EQ.1)THEN Z=(IDF(1)%XV(ICOL,IROW,1)+IDF(1)%XV(ICOL,IROW,2))/2.0 ENDIF MINZ=MIN(MINZ,Z); MAXZ=MAX(MAXZ,Z) CALL IMOD3D_VECTOR(X,Y,Z,-DZDX,DZDY,-DZDZ,6,FF,F) ENDIF ENDDO ENDDO IDFPLOT(ILST)%ZMIN=MINZ IDFPLOT(ILST)%ZMAX=MAXZ CALL GLDISABLE(GL_COLOR_MATERIAL) CALL GLENDLIST() CALL IMOD3D_ERROR('IMOD3D_DRAWIDF_VECTOR END') END SUBROUTINE IMOD3D_DRAWIDF_VECTOR !###====================================================================== SUBROUTINE IMOD3D_VECTOR(X,Y,Z,DX,DY,DZ,NINT,FF,VL) !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT),INTENT(IN) :: X,Y,Z,DX,DY,DZ INTEGER,INTENT(IN) :: NINT REAL,INTENT(IN) :: FF,VL REAL(KIND=GLFLOAT) :: DGRAD,FGRAD,X1,Y1,Z1,Z2,XPOS,YPOS,RADIUS,ZF,XGRAD,DXY,L !,MAXL,MINL INTEGER :: J DGRAD=2.0*PI/REAL(NINT) !## stepsize angle radials CALL GLPUSHMATRIX() !## translate CALL GLTRANSLATEF(X,Y,Z) !## to ensure appropriate scaling of vector CALL GLSCALED(1.0_GLDOUBLE/XSCALE_FACTOR,1.0_GLDOUBLE/YSCALE_FACTOR,1.0_GLDOUBLE/ZSCALE_FACTOR) !## rotate CALL GLROTATEF(-90.0,1.0_GLFLOAT,0.0_GLFLOAT,0.0_GLFLOAT) !## put them flat in xy plane CALL GLROTATEF( 90.0,0.0_GLFLOAT,1.0_GLFLOAT,0.0_GLFLOAT) !## rotate them to east XGRAD=ATAN2(DY,DX)*(360.0/(2.0*PI)) CALL GLROTATEF(-XGRAD,0.0_GLFLOAT,1.0_GLFLOAT,0.0_GLFLOAT)!## turn vector in xy plane DXY=SQRT(DX**2.0+DY**2.0) XGRAD=ATAN2(DZ,DXY)*(360.0/(2.0*PI)) CALL GLROTATEF(XGRAD,1.0_GLFLOAT,0.0_GLFLOAT,0.0_GLFLOAT) !## Z-axes L=FF X1=0.0_GLFLOAT; Y1=0.0_GLFLOAT; Z1=0.0_GLFLOAT Z2=L !## length of array ZF=0.75_GLFLOAT*Z2 !## start of arrow-cap RADIUS=0.05_GLFLOAT*Z2 !## width of arrow !## bottom FGRAD=0.0_GLFLOAT CALL GLBEGIN(GL_TRIANGLE_FAN) CALL GLNORMAL3F(0.0_GLFLOAT,0.0_GLFLOAT,-1.0_GLFLOAT) CALL GLVERTEX3F(X1,Y1,Z1) DO J=NINT,0,-1 XPOS=X1+COS(FGRAD)*RADIUS; YPOS=Y1+SIN(FGRAD)*RADIUS CALL GLVERTEX3F(XPOS,YPOS,Z1); FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() !## side CALL GLBEGIN(GL_QUAD_STRIP) FGRAD=0.0_GLFLOAT DO J=0,NINT XPOS=X1+COS(FGRAD)*RADIUS; YPOS=Y1+SIN(FGRAD)*RADIUS CALL GLNORMAL3F(COS(FGRAD),SIN(FGRAD),0.0_GLFLOAT) CALL GLVERTEX3F(XPOS,YPOS,Z1); CALL GLVERTEX3F(XPOS,YPOS,Z1+ZF) FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() !## bottom of arrow cap RADIUS=RADIUS*2.0_GLFLOAT FGRAD=0.0_GLFLOAT CALL GLBEGIN(GL_TRIANGLE_FAN) CALL GLNORMAL3F(0.0_GLFLOAT,0.0_GLFLOAT,-1.0_GLFLOAT) CALL GLVERTEX3F(X1,Y1,Z1+ZF) DO J=NINT,0,-1 XPOS=X1+COS(FGRAD)*RADIUS; YPOS=Y1+SIN(FGRAD)*RADIUS CALL GLVERTEX3F(XPOS,YPOS,Z1+ZF); FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() !## arrow cap FGRAD=0.0_GLFLOAT CALL GLBEGIN(GL_TRIANGLE_FAN) CALL GLVERTEX3F(X1,Y1,Z2) DO J=0,NINT XPOS=X1+COS(FGRAD)*RADIUS YPOS=Y1+SIN(FGRAD)*RADIUS CALL GLNORMAL3F(-COS(FGRAD),-SIN(FGRAD),0.0_GLFLOAT) CALL GLVERTEX3F(XPOS,YPOS,Z1+ZF) FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() CALL GLPOPMATRIX() END SUBROUTINE IMOD3D_VECTOR !###====================================================================== LOGICAL FUNCTION IMOD3D_IPF_INIT() !###====================================================================== IMPLICIT NONE INTEGER :: IIPF,IPLOT IMOD3D_IPF_INIT=.FALSE. !## allocate memory for ipf-plotting, they will be read in memory and drawn from that CALL IPFINIT() IF(ALLOCATED(IPFPLOT))DEALLOCATE(IPFPLOT); ALLOCATE(IPFPLOT(NIPF)) !## read ipf IIPF=0 DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.2)THEN IIPF=IIPF+1 IPFPLOT(IIPF)%IPLOT=IPLOT IPFPLOT(IIPF)%FNAME='('//TRIM(ITOS(IIPF))//') '//MP(IPLOT)%ALIAS IPFPLOT(IIPF)%ISEL =1 IPFPLOT(IIPF)%IFANCY =1 IPFPLOT(IIPF)%ISHADE =1 IPFPLOT(IIPF)%RADIUS =1.0 !% IPFPLOT(IIPF)%ISUB =12 IPFPLOT(IIPF)%ISTYLE =4 IPFPLOT(IIPF)%ASSCOL1=MP(IPLOT)%ASSCOL1 IPFPLOT(IIPF)%ASSCOL2=MP(IPLOT)%ASSCOL2 IPFPLOT(IIPF)%ISELECT=0 IPFPLOT(IIPF)%RSELECT=0 IPFPLOT(IIPF)%IPLOTLABELS=0 IPFPLOT(IIPF)%IPLOTLEGEND=0 !## plOT LEGEND IPFPLOT(IIPF)%ILEGDLF=MP(IPLOT)%ILEGDLF ENDIF ENDDO IF(.NOT.IMOD3D_IPF())RETURN IMOD3D_IPF_INIT=.TRUE. END FUNCTION IMOD3D_IPF_INIT !###====================================================================== LOGICAL FUNCTION IMOD3D_IPF() !###====================================================================== IMPLICIT NONE INTEGER :: IIPF,I,II,J,IPLOT,IU,IRAT,IRAT1 REAL(KIND=GLFLOAT) :: X,Y,Z,Z2 CHARACTER(LEN=256) :: FNAME,DIR LOGICAL :: LEX TYPE(WIN_MESSAGE) :: MESSAGE INTEGER :: ITYPE,ICLR,ACOL REAL :: XVAL IMOD3D_IPF=.FALSE. !## allocate memory for ipf-plotting, they will be read in memory and drawn from that CALL IPFINIT() !## nothing to do - no drills or ipf's files found IF(NIPF.LE.0)THEN; IMOD3D_IPF=.TRUE.; RETURN; ENDIF !## read ipf IIPF=0 DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.2)THEN IIPF=IIPF+1 CALL WINDOWSELECT(IWIN) !## check whether information for current ipf is already in memory IF(UTL_CAP(IPF(IIPF)%FNAME,'U').EQ.UTL_CAP(MP(IPLOT)%IDFNAME,'U'))THEN CALL WINDOWOUTSTATUSBAR(2,'RF Memory ...'//TRIM(MP(IPLOT)%IDFNAME)) ELSE !## read always from disc CALL WINDOWOUTSTATUSBAR(2,'RF Disc ...'//TRIM(MP(IPLOT)%IDFNAME)) IF(.NOT.IPFREAD(IPLOT,IIPF))THEN CALL IPFDEALLOCATE() CALL WINDOWOUTSTATUSBAR(2,'') RETURN ENDIF ENDIF ENDIF ENDDO !## get number of points inside current view-frame NIPFLIST=0; NASSLIST=0 DO IIPF=1,NIPF CALL WINDOWOUTSTATUSBAR(2,'Get selection for '//TRIM(IPF(IIPF)%FNAME)//' ...') !## initialise ipos IPF(IIPF)%IPOS=INT(0,1) DO I=1,IPF(IIPF)%NROW X=IPF(IIPF)%XYZ(1,I); Y=IPF(IIPF)%XYZ(2,I) IF(X.GE.BOT%X .AND.X.LE.TOP%X .AND.Y.GE.BOT%Y .AND.Y.LE.TOP%Y)THEN IF(IMOD3D_BLANKOUT_XY(X,Y))THEN IPF(IIPF)%IPOS(I)=INT(1,1) NIPFLIST=NIPFLIST+1 IF(IPF(IIPF)%ACOL.NE.0.AND.IPF(IIPF)%ACOL.LE.IPF(IIPF)%NCOL)NASSLIST=NASSLIST+1 ENDIF ENDIF ENDDO ENDDO !## get display-list pointers IF(ALLOCATED(IPFLISTINDEX))THEN CALL WINDOWOUTSTATUSBAR(2,'Cleaning memory ...') DO I=1,SIZE(IPFLISTINDEX,1); DO J=1,SIZE(IPFLISTINDEX,2) IF(IPFLISTINDEX(I,J).NE.0)CALL GLDELETELISTS(IPFLISTINDEX(I,J),1_GLSIZEI) ENDDO; ENDDO DEALLOCATE(IPFLISTINDEX) ENDIF ALLOCATE(IPFLISTINDEX(NIPFLIST,3)); IPFLISTINDEX=0 !## storage of ipf specific information used for selection purposes IF(ALLOCATED(IPFDLIST))DEALLOCATE(IPFDLIST); ALLOCATE(IPFDLIST(5,NIPFLIST)) IPFDLIST=0 !## plot associated files CALL IPFINITASSFILE() !## store each drill in memory for picking purposes IF(NASSLIST.GT.0)CALL IPFASSFILEALLOCATE(NASSLIST) NIPFLIST =0 NASSLIST=0 IRAT=0; IRAT1=IRAT DO IIPF=1,NIPF !## create sphere-object IF(IPFPLOT(IIPF)%IFANCY.EQ.1)CALL IMOD3D_IPF_CREATEBALL(IPFPLOT(IIPF)%ISUB,IPFPLOT(IIPF)%ISTYLE) IPLOT=IPFPLOT(IIPF)%IPLOT I =INDEX(IPF(IIPF)%FNAME,'\',.TRUE.) DIR=IPF(IIPF)%FNAME(1:I-1) DO I=1,IPF(IIPF)%NROW !## reset acol since it can be altered ACOL=IPF(IIPF)%ACOL !## cancel operation CALL WMESSAGEPEEK(ITYPE,MESSAGE) IF(ITYPE.EQ.KEYDOWN.AND.MESSAGE%VALUE1.EQ.KEYESCAPE)EXIT IF(IPF(IIPF)%IPOS(I).EQ.INT(1,1))THEN X =IPF(IIPF)%XYZ(1,I); Y=IPF(IIPF)%XYZ(2,I); Z=IPF(IIPF)%XYZ(3,I); Z2=IPF(IIPF)%XYZ(4,I) II=NIPFLIST II=II+1 NIPFLIST=II ! NIPFLIST=NIPFLIST+1 !## translate current position to view=position X=(X-MIDPOS%X)/VIEWDX; Y=(Y-MIDPOS%Y)/VIEWDY LEX=.FALSE. IF(ACOL.NE.0.AND.IPF(IIPF)%ACOL.LE.IPF(IIPF)%NCOL)THEN FNAME=TRIM(DIR)//'\'//TRIM(IPF(IIPF)%INFO(IPF(IIPF)%ACOL,I))//'.'//TRIM(ADJUSTL(IPF(IIPF)%FEXT)) NASSLIST=NASSLIST+1 !## read dimensions of associated file IF(IPFOPENASSFILE(IU,NASSLIST,FNAME))THEN !## drill found IF(ASSF(NASSLIST)%ITOPIC.EQ.2)THEN IF(IPFREADASSFILELABEL(IU,NASSLIST,FNAME).AND. & IPFREADASSFILE(IU,NASSLIST,FNAME))THEN !## write message on window CALL UTL_WAITMESSAGE(IRAT,IRAT1,I,IPF(IIPF)%NROW,'Get boreholes for '//TRIM(IPF(IIPF)%FNAME),IBOX=2) ASSF(NASSLIST)%IROW=I ASSF(NASSLIST)%ASSCOL1=IPFPLOT(IIPF)%ASSCOL1 !## column used with dlf ASSF(NASSLIST)%ASSCOL2=IPFPLOT(IIPF)%ASSCOL2 !## on default not used --- border rings ASSF(NASSLIST)%ILEGDLF=IPFPLOT(IIPF)%ILEGDLF !## legend for colouring CALL IMOD3D_DRAWIPF(X,Y,Z,Z2,1,1,ICLR,IIPF) !## actual drills CALL IMOD3D_DRAWIPF(X,Y,Z,Z2,1,2,ICLR,IIPF) !## selection numbers drills !## put label in centre ! IPF(IIPF)%XYZ(3,I)=ASSF(NASSLIST)%Z(1)+ASSF(NASSLIST)%Z(ASSF(NASSLIST)%NRASS))/2.0 !## forces label on bottom IPF(IIPF)%XYZ(3,I)=ASSF(NASSLIST)%Z(ASSF(NASSLIST)%NRASS) !## forces label on bottom LEX=.TRUE. ELSE CLOSE(IU) CALL WMESSAGEBOX(YESNO,QUESTIONICON,COMMONYES,'There might be an error in the following file:'//CHAR(13)// & TRIM(FNAME)//CHAR(13)//'Do you want to continue (yes) or quit reading the file (no)','Error') IF(WINFODIALOG(4).NE.1)EXIT ENDIF ELSE !## overrule if not a borehole (2) - plot dot ACOL=0; LEX=.TRUE.; NASSLIST=MAX(0,NASSLIST-1) ENDIF CLOSE(IU) ELSE !## file not found - plot dot ACOL=0; LEX=.TRUE.; NASSLIST=MAX(0,NASSLIST-1) ENDIF IF(.NOT.LEX)THEN; NASSLIST=MAX(0,NASSLIST-1); NIPFLIST=MAX(0,NIPFLIST-1); ENDIF ENDIF IF(ACOL.EQ.0)THEN !## write message on window CALL UTL_WAITMESSAGE(IRAT,IRAT1,I,IPF(IIPF)%NROW,'Get points for '//TRIM(IPF(IIPF)%FNAME),IBOX=2) !## current ipf single-coloured? IF(MP(IPLOT)%ILEG.EQ.0)THEN ICLR=MP(IPLOT)%SCOLOR ELSEIF(MP(IPLOT)%ILEG.EQ.1)THEN J=INFOERROR(1) CALL ISTRINGTOREAL(IPF(IIPF)%INFO(MP(IPLOT)%IATTRIB,I),XVAL) ICLR=WRGB(200,200,200) IF(INFOERROR(1).EQ.0)THEN; ICLR=UTL_IDFGETCLASS(MP(IPLOT)%LEG,XVAL); ENDIF ENDIF !## draw position only - no drill found CALL IMOD3D_DRAWIPF(X,Y,Z,Z2,0,1,ICLR,IIPF) !## actual drills (NIPFLIST) CALL IMOD3D_DRAWIPF(X,Y,Z,Z2,0,2,ICLR,IIPF) !## selection numbers drills (NIPFLIST) ENDIF IF(NIPFLIST.GT.0)THEN !## store information for selection purposes IPFDLIST(1,NIPFLIST)=IIPF !## number of ipf IPFDLIST(2,NIPFLIST)=I !## number of row in ipf IPFDLIST(3,NIPFLIST)=INT(IPF(IIPF)%XYZ(1,I)) !## xpos IPFDLIST(4,NIPFLIST)=INT(IPF(IIPF)%XYZ(2,I)) !## ypos IPFDLIST(5,NIPFLIST)=1 ENDIF ENDIF ENDDO ENDDO !## nothing found to be plotted IF(NIPFLIST.EQ.0)NIPF=0 CALL WINDOWOUTSTATUSBAR(1,'') CALL WINDOWOUTSTATUSBAR(2,'') IMOD3D_IPF=.TRUE. CALL IMOD3D_ERROR('IMOD3D_IPF') END FUNCTION IMOD3D_IPF !###====================================================================== SUBROUTINE IMOD3D_IPF_SELECTION(IIPF) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IIPF INTEGER :: I,J,II REAL :: Z,DZ !## associated file drawn DO II=1,NIPFLIST !## inside buffer of active cross-sections IF(IPFPLOT(IIPF)%ISELECT(3).EQ.1)THEN IPFDLIST(5,II)=0 Z=IPFPLOT(IIPF)%RSELECT(3) SOLLOOP: DO I=1,NSOLLIST IF(SOLPLOT(I)%ISEL.NE.1)CYCLE DO J=2,SPF(I)%NXY DZ=IGRDISTANCELINE(SPF(I)%X(J-1),SPF(I)%Y(J-1),SPF(I)%X(J),SPF(I)%Y(J), & REAL(IPFDLIST(3,II)),REAL(IPFDLIST(4,II)),0) IF(DZ.LE.Z)THEN; IPFDLIST(5,II)=1; EXIT SOLLOOP; ENDIF ENDDO ENDDO SOLLOOP ELSE IPFDLIST(5,II)=1 ENDIF IF(ALLOCATED(ASSF))THEN IF(ASSOCIATED(ASSF(II)%Z))THEN Z=ASSF(II)%Z(1)-ASSF(II)%Z(ASSF(II)%NRASS) !## less than IF(IPFPLOT(IIPF)%ISELECT(1).EQ.1.AND.Z.LT.IPFPLOT(IIPF)%RSELECT(1))IPFDLIST(5,II)=0 !## greater than IF(IPFPLOT(IIPF)%ISELECT(2).EQ.1.AND.Z.GT.IPFPLOT(IIPF)%RSELECT(2))IPFDLIST(5,II)=0 ENDIF ENDIF ENDDO END SUBROUTINE IMOD3D_IPF_SELECTION !###====================================================================== SUBROUTINE IMOD3D_DRAWIPF(X,Y,Z,Z2,IPLOTTYPE,IMODE,ICLR,IIPF) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IPLOTTYPE,IMODE,ICLR,IIPF REAL(KIND=GLFLOAT),INTENT(IN) :: X,Y,Z,Z2 REAL(KIND=GLFLOAT) :: ZD,ZT,BSIZE,FRAC,MXW INTEGER :: I,JCLR REAL :: IWIDTH BSIZE=XYZAXES(1)*(IPFPLOT(IIPF)%RADIUS/100.0) MXW =MAXVAL(BH%LITHOWIDTH) !## imode=1: drawing list !## imode=2: selection drawing list to be drawn in background only IPFLISTINDEX(NIPFLIST,IMODE)=GLGENLISTS(1) !## start new drawing list for current object CALL GLNEWLIST(IPFLISTINDEX(NIPFLIST,IMODE),GL_COMPILE) !## draw drill IF(IPLOTTYPE.EQ.1)THEN ZD =ASSF(NASSLIST)%Z(1) IF(NIDFLIST.EQ.0)THEN TOP%Z=MAX(TOP%Z,ZD) ELSE IF(SUM(IDFPLOT%ISEL).EQ.0)TOP%Z=MAX(TOP%Z,ZD) ENDIF !## foreground drawing IF(IMODE.EQ.1)THEN IF(IPFPLOT(IIPF)%IFANCY.EQ.0)THEN CALL GLBEGIN(GL_LINES) DO I=1,ASSF(NASSLIST)%NRASS-1 IF(ASSF(NASSLIST)%Z(I) .EQ.ASSF(NASSLIST)%NODATA(1).OR. & ASSF(NASSLIST)%Z(I+1).EQ.ASSF(NASSLIST)%NODATA(1))CYCLE CALL IPFDRAWITOPIC2_ICLR(I,NASSLIST,JCLR,IWIDTH) CALL IMOD3D_SETCOLOR(JCLR) CALL GLVERTEX3F(X,Y,ZD) ZD=ASSF(NASSLIST)%Z(I+1) CALL GLVERTEX3F(X,Y,ZD) ENDDO CALL GLEND() ELSEIF(IPFPLOT(IIPF)%IFANCY.EQ.1)THEN IF(ASSF(NASSLIST)%NRASS.GE.2)THEN DO I=1,ASSF(NASSLIST)%NRASS-1 IF(ASSF(NASSLIST)%Z(I) .EQ.ASSF(NASSLIST)%NODATA(1).OR. & ASSF(NASSLIST)%Z(I+1).EQ.ASSF(NASSLIST)%NODATA(1))CYCLE CALL IPFDRAWITOPIC2_ICLR(I,NASSLIST,JCLR,IWIDTH) FRAC=IWIDTH/MXW CALL IMOD3D_SETCOLOR(JCLR) IF(IPFPLOT(IIPF)%ISHADE.EQ.1)THEN !## show shaded surface CALL IMOD3D_RETURNCOLOR(JCLR,AMBIENT) CALL GLMATERIALFV(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE,AMBIENT) ENDIF ! ZT=ZD; ZD=ASSF(NASSLIST)%Z(I) ZT=ASSF(NASSLIST)%Z(I); ZD=ASSF(NASSLIST)%Z(I+1) CALL IMOD3D_IPF_FANCY(X,Y,(/ZT,ZD/),IPFPLOT(IIPF)%ISUB,BSIZE*FRAC,(/1,1,1,IPFPLOT(IIPF)%ISHADE/)) !## plot top/bottom/sides all ENDDO ENDIF ENDIF !## background only - plot iassf for feedback mechanism ELSEIF(IMODE.EQ.2)THEN IF(IPFPLOT(IIPF)%IFANCY.EQ.0)THEN CALL GLBEGIN(GL_LINES) CALL IMOD3D_SETCOLOR(NASSLIST) CALL GLVERTEX3F(X,Y,ZD) ZD=ASSF(NASSLIST)%Z(ASSF(NASSLIST)%NRASS) CALL GLVERTEX3F(X,Y,ZD) CALL GLEND() ELSEIF(IPFPLOT(IIPF)%IFANCY.EQ.1)THEN IF(ASSF(NASSLIST)%NRASS.GE.2)THEN CALL IMOD3D_SETCOLOR(NASSLIST) ZT=ZD; ZD=ASSF(NASSLIST)%Z(ASSF(NASSLIST)%NRASS) CALL IMOD3D_IPF_FANCY(X,Y,(/ZT,ZD/),IPFPLOT(IIPF)%ISUB,BSIZE,(/1,1,1,0/)) !## plot top,sides,bottom ENDIF ENDIF ENDIF IF(NIDFLIST.EQ.0)THEN BOT%Z=MIN(BOT%Z,ZD) ELSE IF(SUM(IDFPLOT%ISEL).EQ.0)BOT%Z=MIN(BOT%Z,ZD) ENDIF !## points only ELSEIF(IPLOTTYPE.EQ.0)THEN IF(IMODE.EQ.1)THEN CALL IMOD3D_SETCOLOR(ICLR) IF(IPFPLOT(IIPF)%IFANCY.EQ.1)THEN CALL IMOD3D_RETURNCOLOR(ICLR,AMBIENT) CALL GLMATERIALFV(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE,AMBIENT) ENDIF ELSEIF(IMODE.EQ.2)THEN CALL IMOD3D_SETCOLOR(NASSLIST) ENDIF ! IF(ABS(Z-Z2).LT.0.1)Z2=Z-0.1 !## draw point if z equals z2 IF(Z.EQ.Z2)THEN ! IF(IPFPLOT(IIPF)%IFANCY.EQ.1)THEN ! CALL GLPUSHMATRIX() ! CALL GLTRANSLATEF(X,Y,Z) ! CALL GLCALLLIST(SPHEREINDEX) ! RENDER SPHERE DISPLAY LIST ! CALL GLPOPMATRIX() ! ELSE !## draw point of drill/ipf CALL GLBEGIN(GL_POINTS); CALL GLVERTEX3F(X,Y,Z); CALL GLEND() ! ENDIF !## draw line between top and bottom ELSE IF(IPFPLOT(IIPF)%IFANCY.EQ.0)THEN CALL GLBEGIN(GL_LINES); CALL GLVERTEX3F(X,Y,Z); CALL GLVERTEX3F(X,Y,Z2); CALL GLEND() ELSEIF(IPFPLOT(IIPF)%IFANCY.EQ.1)THEN IF(IMODE.EQ.1)CALL IMOD3D_IPF_FANCY(X,Y,(/Z,Z2/),IPFPLOT(IIPF)%ISUB,BSIZE,(/1,1,1,IPFPLOT(IIPF)%ISHADE/)) IF(IMODE.EQ.2)CALL IMOD3D_IPF_FANCY(X,Y,(/Z,Z2/),IPFPLOT(IIPF)%ISUB,BSIZE,(/1,1,1,0/)) ENDIF ENDIF IF(NIDFLIST.EQ.0)THEN TOP%Z=MAX(TOP%Z,Z,Z2); BOT%Z=MIN(BOT%Z,Z,Z2) ELSE IF(SUM(IDFPLOT%ISEL).EQ.0)THEN; TOP%Z=MAX(TOP%Z,Z,Z2); BOT%Z=MIN(BOT%Z,Z,Z2); ENDIF ENDIF ENDIF CALL GLENDLIST() CALL IMOD3D_ERROR('IMOD3D_DRAWIPF') END SUBROUTINE IMOD3D_DRAWIPF !###====================================================================== SUBROUTINE IMOD3D_IPF_CREATEBALL(ISUB,ISTYLE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ISUB,ISTYLE INTEGER :: I,J,NLAT,NLONG REAL(GLFLOAT) :: LAT,LONG,X,Y,Z,DLAT,DLONG,R NLAT=ISUB !## north south NLONG=ISUB !## west east R=0.05 !## Create the sphere display list IF(SPHEREINDEX.NE.0)CALL GLDELETELISTS(SPHEREINDEX,1_GLSIZEI); SPHEREINDEX=0 SPHEREINDEX=GLGENLISTS(1) CALL GLNEWLIST(SPHEREINDEX,GL_COMPILE) CALL GLBEGIN(GL_POINTS) LAT=0.0; DLAT=(2*PI)/REAL(NLAT); DLONG=PI/REAL(NLONG) DO J=1,NLAT; LAT=LAT+DLAT; LONG=0.0; DO I=1,NLONG LONG=LONG+DLONG X=R*SIN(LAT)*COS(LONG) Y=R*SIN(LAT)*SIN(LONG) Z=R*COS(LAT)*(1.0_GLDOUBLE/ZSCALE_FACTOR) CALL GLVERTEX3F(X,Y,Z) ENDDO; ENDDO CALL GLEND() CALL GLENDLIST() END SUBROUTINE IMOD3D_IPF_CREATEBALL !###====================================================================== SUBROUTINE IMOD3D_IPF_FANCY(XMID,YMID,Z,NINT,RADIUS,IPLT) !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT),INTENT(IN) :: XMID,YMID REAL(KIND=GLFLOAT),INTENT(IN),DIMENSION(2) :: Z REAL(KIND=GLFLOAT),INTENT(IN) :: RADIUS REAL(KIND=GLFLOAT) :: DGRAD,FGRAD,XPOS,YPOS INTEGER,INTENT(IN) :: NINT INTEGER,INTENT(IN),DIMENSION(4) :: IPLT INTEGER :: I,J DGRAD=2.0*PI/REAL(NINT) !## stepsize angle radials DO I=1,2 IF(IPLT(I).EQ.0)CYCLE FGRAD=0.0_GLFLOAT CALL GLBEGIN(GL_TRIANGLE_FAN) IF(IPLT(4).EQ.1)CALL GLNORMAL3F(0.0_GLFLOAT,0.0_GLFLOAT,-1.0_GLFLOAT) CALL GLVERTEX3F(XMID,YMID,Z(I)) DO J=1,NINT+1 XPOS=XMID+COS(FGRAD)*RADIUS YPOS=YMID+SIN(FGRAD)*RADIUS CALL GLVERTEX3F(XPOS,YPOS,Z(I)) FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() ENDDO IF(IPLT(3).EQ.1)THEN CALL GLBEGIN(GL_QUAD_STRIP) FGRAD=0.0_GLFLOAT DO J=1,NINT+1 XPOS=XMID+COS(FGRAD)*RADIUS YPOS=YMID+SIN(FGRAD)*RADIUS IF(IPLT(4).EQ.1)CALL GLNORMAL3F(-COS(FGRAD),-SIN(FGRAD),0.0_GLFLOAT) CALL GLVERTEX3F(XPOS,YPOS,Z(1)) CALL GLVERTEX3F(XPOS,YPOS,Z(2)) FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() ENDIF END SUBROUTINE IMOD3D_IPF_FANCY !###====================================================================== SUBROUTINE IMOD3D_IPF_LABELS() !###====================================================================== IMPLICIT NONE INTEGER :: IIPF,I,J,K,IPLOT,IASSF REAL(KIND=GLFLOAT) :: X,Y,Z,BSIZE CHARACTER(LEN=256) :: LINE,TLINE INTEGER,ALLOCATABLE,DIMENSION(:) :: ILIST REAL(KIND=GLDOUBLE),PARAMETER :: TS= 0.025 !## textsize REAL(KIND=GLDOUBLE) :: TSIZE IF(NIPF.EQ.0)RETURN !## get labels IASSF=0 DO IIPF=1,NIPF BSIZE=XYZAXES(1)*(IPFPLOT(IIPF)%RADIUS/100.0) BSIZE=BSIZE*1.1 IPLOT=IPFPLOT(IIPF)%IPLOT ALLOCATE(ILIST(IPF(IIPF)%NCOL)) !## get selected labels for printing CALL UTL_FILLARRAY(ILIST,IPF(IIPF)%NCOL,ABS(MP(IPLOT)%IEQ)) TSIZE=TS*MP(IPLOT)%TSIZE DO I=1,IPF(IIPF)%NROW IF(IPF(IIPF)%IPOS(I).EQ.INT(1,1))THEN !## label-drawing list IASSF=IASSF+1 IPFLISTINDEX(IASSF,3)=GLGENLISTS(1) !## start new drawing list for current object CALL GLNEWLIST(IPFLISTINDEX(IASSF,3),GL_COMPILE) CALL WGLTEXTORIENTATION(ALIGNLEFT) X =IPF(IIPF)%XYZ(1,I) Y =IPF(IIPF)%XYZ(2,I) Z =IPF(IIPF)%XYZ(3,I) !## translate current position to view=postition X=(X-MIDPOS%X)/VIEWDX Y=(Y-MIDPOS%Y)/VIEWDY X=X-BSIZE !## copy temporary the modelmatrix CALL GLPUSHMATRIX() !## make sure z is within top%z,bot%z (in case wrong kolom is used or column is missing) IF(Z.LT.BOT%Z.OR.Z.GT.TOP%Z)Z=TOP%Z !## go to the location of point CALL GLTRANSLATEF(X,Y,Z) CALL GLSCALED(1.0_GLDOUBLE/XSCALE_FACTOR,1.0_GLDOUBLE/YSCALE_FACTOR,1.0_GLDOUBLE/ZSCALE_FACTOR) CALL GLSCALED(TSIZE,TSIZE,TSIZE) CALL GLROTATED( 90.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE) CALL GLROTATED(-90.0_GLDOUBLE,0.0_GLDOUBLE,1.0_GLDOUBLE,0.0_GLDOUBLE) IF(SUM(ILIST).EQ.0)THEN LINE='no label' ELSE LINE='' DO J=1,IPF(IIPF)%NCOL IF(ILIST(J).EQ.1)THEN TLINE=IPF(IIPF)%INFO(J,I) K=0 IF(IBACKSLASH.EQ.1)THEN K=INDEX(TLINE,'\',.TRUE.) IF(K.GT.0)K=K+1 ENDIF K=MAX(1,K) IF(ILABELNAME.EQ.0)THEN LINE=TRIM(LINE)//TRIM(TLINE(K:))//';' ELSE LINE=TRIM(LINE)//TRIM(IPF(IIPF)%ATTRIB(J))//'='//TRIM(TLINE(K:))//';' ENDIF ENDIF END DO J=INDEX(LINE,';',.TRUE.) IF(J.NE.0)LINE(J:J)=' ' ENDIF CALL WGLTEXTSTRING(TRIM(LINE)) !## get previous modelmatrix again CALL GLPOPMATRIX() !## end ipflabellist CALL GLENDLIST() ENDIF ENDDO DEALLOCATE(ILIST) ENDDO CALL IMOD3D_ERROR('IMOD3D_IPF_LABELS') END SUBROUTINE IMOD3D_IPF_LABELS !###====================================================================== LOGICAL FUNCTION IMOD3D_IFF() !###====================================================================== IMPLICIT NONE INTEGER :: IPLOT,I,J,K,NINIFF IMOD3D_IFF=.FALSE. NIFFLIST=0 DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.3)NIFFLIST=NIFFLIST+1 ENDDO !## nothing to do - no drills or ipf's files found IF(NIFFLIST.LE.0)THEN; IMOD3D_IFF=.TRUE.; RETURN; ENDIF !## get display-list pointers ALLOCATE(IFFLISTINDEX(NIFFLIST),IFFPLOT(NIFFLIST)); IFFLISTINDEX=0 NIFFLIST=0; NINIFF =0 DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.3)THEN J=NIFFLIST; J=J+1; NIFFLIST=J IFFPLOT(NIFFLIST)%ISEL=1 IFFPLOT(NIFFLIST)%ITHICKNESS=1 IFFPLOT(NIFFLIST)%IPLOT=IPLOT IFFPLOT(NIFFLIST)%IPLOTLEGEND=0 J=INDEX(MP(IPLOT)%IDFNAME,'\',.TRUE.)+1 K=LEN_TRIM(MP(IPLOT)%IDFNAME) IFFPLOT(NIFFLIST)%FNAME='('//TRIM(ITOS(NIFFLIST))//') '//MP(IPLOT)%IDFNAME(J:K) CALL IMOD3D_DRAWIFF(VIEWDX,VIEWDY,IPLOT,NINIFF) ENDIF ENDDO !## nothing to be seen of the selected iff's IF(NINIFF.LE.0)THEN DO I=1,NIFFLIST !## destroy current display list index - solid CALL GLDELETELISTS(IFFLISTINDEX(I),1_GLSIZEI) END DO NIFFLIST=0 ENDIF IMOD3D_IFF=.TRUE. CALL IMOD3D_ERROR('IMOD3D_IFF') END FUNCTION IMOD3D_IFF !###====================================================================== LOGICAL FUNCTION IMOD3D_REDRAWIFF() !###====================================================================== IMPLICIT NONE INTEGER :: IPLOT,NINIFF IMOD3D_REDRAWIFF=.FALSE. NIFFLIST=0; NINIFF=0 DO IPLOT=1,MXMPLOT IF(MP(IPLOT)%ISEL.AND.MP(IPLOT)%IPLOT.EQ.3)THEN NIFFLIST=NIFFLIST+1 !## destroy current display list index CALL GLDELETELISTS(IFFLISTINDEX(NIFFLIST),1_GLSIZEI) CALL IMOD3D_DRAWIFF(VIEWDX,VIEWDY,IPLOT,NINIFF) ENDIF ENDDO IMOD3D_REDRAWIFF=.TRUE. CALL IMOD3D_ERROR('IMOD3D_REDRAWIFF') END FUNCTION IMOD3D_REDRAWIFF !###====================================================================== SUBROUTINE IMOD3D_DRAWIFF(DX,DY,IPLOT,NINIFF) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(INOUT) :: NINIFF REAL(KIND=GLFLOAT),INTENT(IN) :: DX,DY INTEGER,INTENT(IN) :: IPLOT INTEGER :: I,J,N,IOS,IU,ICLR REAL(KIND=GLFLOAT),DIMENSION(2) :: XCOR,YCOR,ZCOR REAL :: XVAL CALL WINDOWSELECT(IWIN); CALL WINDOWOUTSTATUSBAR(2,'Reading '//TRIM(MP(IPLOT)%IDFNAME)//'...') !## open idf-file - get idfkind IU=UTL_GETUNITIFF(MP(IPLOT)%IDFNAME,'OLD'); IF(IU.LE.0)RETURN CALL WINDOWSELECT(IWIN) !## list index for IFFLISTINDEX(NIFFLIST)=GLGENLISTS(1) !## start new drawing list CALL GLNEWLIST(IFFLISTINDEX(NIFFLIST),GL_COMPILE) CALL GLBEGIN(GL_LINES) READ(IU,*) N DO I=1,N; READ(IU,*) ; END DO ALLOCATE(IFF(2)); N=N-5 DO I=1,SIZE(IFF); NULLIFY(IFF(I)%XVAL); ALLOCATE(IFF(I)%XVAL(N)); ENDDO IFF(2)%IPART=0 DO READ(IU,*,IOSTAT=IOS) IFF(1)%IPART,IFF(1)%IL,IFF(1)%X,IFF(1)%Y,IFF(1)%Z,(IFF(1)%XVAL(J),J=1,N) IF(IOS.NE.0)EXIT !## same particle IF(IFF(1)%IPART.EQ.IFF(2)%IPART)THEN !## current point insize viewable extent IF(IFF(1)%X.LT.TOP%X.AND.IFF(1)%X.GE.BOT%X.AND. & IFF(1)%Y.LT.TOP%Y.AND.IFF(1)%Y.GE.BOT%Y)THEN !## length line is zero! IF(IFF(1)%X-IFF(2)%X.NE.0.0.OR.IFF(1)%Y-IFF(2)%Y.NE.0.0.OR. & IFF(1)%Z-IFF(2)%Z.NE.0.0)THEN !## use of line-colouring IF(MP(IPLOT)%ILEG.EQ.1)THEN CALL IFFPLOT_GETIFFVAL(MP(IPLOT)%IATTRIB,XVAL) ICLR=UTL_IDFGETCLASS(MP(IPLOT)%LEG,XVAL) CALL IMOD3D_SETCOLOR(ICLR) ENDIF NINIFF =NINIFF+1 XCOR(1)=(IFF(1)%X-MIDPOS%X)/DX YCOR(1)=(IFF(1)%Y-MIDPOS%Y)/DY XCOR(2)=(IFF(2)%X-MIDPOS%X)/DX YCOR(2)=(IFF(2)%Y-MIDPOS%Y)/DY ZCOR(1)= IFF(1)%Z ZCOR(2)= IFF(2)%Z CALL IMOD3D_LINE(XCOR,YCOR,ZCOR) ENDIF ENDIF ENDIF IFF(2)%IPART=IFF(1)%IPART IFF(2)%IL =IFF(1)%IL IFF(2)%X =IFF(1)%X IFF(2)%Y =IFF(1)%Y IFF(2)%Z =IFF(1)%Z DO J=1,N; IFF(2)%XVAL(J)=IFF(1)%XVAL(J); ENDDO ENDDO CLOSE(IU) DO I=1,SIZE(IFF); DEALLOCATE(IFF(I)%XVAL); ENDDO; DEALLOCATE(IFF) CALL GLEND() CALL GLENDLIST() CALL WINDOWOUTSTATUSBAR(2,'') CALL IMOD3D_ERROR('IMOD3D_DRAWIFF') END SUBROUTINE IMOD3D_DRAWIFF !###====================================================================== LOGICAL FUNCTION IMOD3D_CREATECOOKIECUTTERS() !###====================================================================== IMPLICIT NONE INTEGER :: I,N,NIDF_CC LOGICAL :: LEX IMOD3D_CREATECOOKIECUTTERS=.TRUE. IF(ALLOCATED(IDF_CC))RETURN N=0; DO I=1,SIZE(MP); IF(MP(I)%ISEL.AND.MP(I)%IPLOT.EQ.6)N=N+1; ENDDO; IF(N.EQ.0)RETURN ALLOCATE(IDF(NIDFLIST)); DO I=1,NIDFLIST; CALL IDFNULLIFY(IDF(I)); ENDDO DO I=1,NIDFLIST; IF(.NOT.IDFREAD(IDF(I),IDFPLOT(I)%FNAME,0))EXIT; ENDDO IMOD3D_CREATECOOKIECUTTERS=.FALSE. ALLOCATE(IDF_CC(1)); CALL IDFNULLIFY(IDF_CC(1)) !## copy settings - maximal extent IF(.NOT.IDF_EXTENT(SIZE(IDF),IDF,IDF_CC(1),1))RETURN IF(.NOT.IDFALLOCATEX(IDF_CC(1)))THEN; ENDIF; IDF_CC(1)%X=0.0; IDF_CC(1)%NODATA=0.0 CALL POLYGON1INIT() NIDF_CC=0; DO I=1,SIZE(MP) IF(MP(I)%IACT.AND.MP(I)%ISEL.AND.MP(I)%IPLOT.EQ.6)THEN INQUIRE(FILE=MP(I)%IDFNAME,EXIST=LEX) IF(LEX)THEN CALL POLYGON1SAVELOADSHAPE(ID_LOADSHAPE,0,MP(I)%IDFNAME) IF(IMOD3D_CREATECOOKIECUTTERS_FILL(NIDF_CC))THEN; ENDIF ENDIF ENDIF ENDDO CALL POLYGON1CLOSE() IF(NIDF_CC.EQ.0)CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'No active cells found in current GEN-files','Warning') CALL IDFDEALLOCATE(IDF,SIZE(IDF)); DEALLOCATE(IDF) IMOD3D_CREATECOOKIECUTTERS=.TRUE. END FUNCTION IMOD3D_CREATECOOKIECUTTERS !###====================================================================== LOGICAL FUNCTION IMOD3D_CREATECOOKIECUTTERS_FILL(M) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(INOUT) :: M REAL :: X1,X2,Y1,Y2,XVAL,YVAL INTEGER :: IC1,IR1,IC2,IR2,IROW,ICOL,I IMOD3D_CREATECOOKIECUTTERS_FILL=.FALSE. DO I=1,SHPNO IF(SHPNCRD(I).GT.0)THEN X1=MINVAL(SHPXC(1:SHPNCRD(I),I)); X2=MAXVAL(SHPXC(1:SHPNCRD(I),I)) Y1=MINVAL(SHPYC(1:SHPNCRD(I),I)); Y2=MAXVAL(SHPYC(1:SHPNCRD(I),I)) !## get ofset from xmin/ymin in the number of cells !## increase them in case of frf en fff computation CALL IDFIROWICOL(IDF_CC(1),IR1,IC1,X1,Y2) CALL IDFIROWICOL(IDF_CC(1),IR2,IC2,X2,Y1) IF(IC2.EQ.0)IC2=IDF_CC(1)%NCOL IF(IR2.EQ.0)IR2=IDF_CC(1)%NROW IC1=MAX(1,IC1); IC2=MIN(IC2,IDF_CC(1)%NCOL) IR1=MAX(1,IR1); IR2=MIN(IR2,IDF_CC(1)%NROW) DO IROW=IR1,IR2; DO ICOL=IC1,IC2 CALL IDFGETLOC(IDF_CC(1),IROW,ICOL,XVAL,YVAL) IF(UTL_INSIDEPOLYGON(XVAL,YVAL,SHPXC(:,I),SHPYC(:,I),SHPNCRD(I)).EQ.1)THEN IDF_CC(1)%X(ICOL,IROW)=REAL(I); M=M+1 ENDIF ENDDO; ENDDO ENDIF ENDDO IMOD3D_CREATECOOKIECUTTERS_FILL=.TRUE. END FUNCTION IMOD3D_CREATECOOKIECUTTERS_FILL !###====================================================================== LOGICAL FUNCTION IMOD3D_GEN() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,K,NINGEN LOGICAL :: LEX IF(ALLOCATED(GENLISTINDEX))THEN K=NGENLIST; NGENLIST=0 DO I=1,K NINGEN=0; NGENLIST=NGENLIST+1; CALL IMOD3D_DRAWGEN(VIEWDX,VIEWDY,GENPLOT(I)%GENFNAME,GENPLOT(I)%L3D,NINGEN) ENDDO IMOD3D_GEN=.TRUE.; RETURN ENDIF IMOD3D_GEN=.FALSE. NGENLIST=0 DO I=1,MXGEN IF(GEN(I)%IACT.AND.GEN(I)%ISEL.AND.ABS(GEN(I)%ITYPE).EQ.1)NGENLIST=NGENLIST+1 ENDDO IF(NGENLIST.EQ.0)RETURN !## get display-list pointers IF(ALLOCATED(GENLISTINDEX))DEALLOCATE(GENLISTINDEX) IF(ALLOCATED(GENPLOT))DEALLOCATE(GENPLOT) ALLOCATE(GENLISTINDEX(NGENLIST),GENPLOT(NGENLIST)) GENLISTINDEX=0 !## read gen NGENLIST=0 DO I=1,MXGEN NINGEN=0 IF(GEN(I)%IACT.AND.GEN(I)%ISEL.AND.ABS(GEN(I)%ITYPE).EQ.1)THEN INQUIRE(FILE=GEN(I)%GENFNAME,EXIST=LEX) IF(LEX)THEN NGENLIST=NGENLIST+1 GENPLOT(NGENLIST)%GENFNAME=GEN(I)%GENFNAME GENPLOT(NGENLIST)%ISEL=1 GENPLOT(NGENLIST)%ITHICKNESS=1 GENPLOT(NGENLIST)%ICOLOR=WRGB(0,0,0) GENPLOT(NGENLIST)%L3D=.FALSE. GENPLOT(NGENLIST)%ITRANSPARANCY=50 J=INDEX(GEN(I)%GENFNAME,'\',.TRUE.)+1; K=LEN_TRIM(GEN(I)%GENFNAME) GENPLOT(NGENLIST)%FNAME='('//TRIM(ITOS(NGENLIST))//') '//GEN(I)%GENFNAME(J:K) CALL IMOD3D_DRAWGEN(VIEWDX,VIEWDY,GENPLOT(NGENLIST)%GENFNAME,GENPLOT(NGENLIST)%L3D,NINGEN) IF(NINGEN.LE.0)THEN CALL GLDELETELISTS(GENLISTINDEX(NGENLIST),1_GLSIZEI); GENLISTINDEX(NGENLIST)=0 NGENLIST=NGENLIST-1 ENDIF ENDIF ENDIF ENDDO CALL WINDOWOUTSTATUSBAR(2,'') IMOD3D_GEN=.TRUE. CALL IMOD3D_ERROR('IMOD3D_GEN') END FUNCTION IMOD3D_GEN !###====================================================================== SUBROUTINE IMOD3D_DRAWGEN(DX,DY,FNAME,L3D,NINGEN) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(INOUT) :: NINGEN REAL(KIND=GLFLOAT),INTENT(IN) :: DX,DY LOGICAL,INTENT(OUT) :: L3D LOGICAL :: LS3D CHARACTER(LEN=*),INTENT(IN) :: FNAME CHARACTER(LEN=256) :: LINE INTEGER :: IU,IOS,I,NX REAL(KIND=GLFLOAT),DIMENSION(:),POINTER :: X,Y,Z,X_DUM,Y_DUM,Z_DUM REAL(KIND=GLFLOAT),DIMENSION(4) :: XCOR,YCOR !## no need to reread 3d-gen file IF(L3D)RETURN CALL WINDOWSELECT(IWIN); CALL WINDOWOUTSTATUSBAR(2,'Reading '//TRIM(FNAME)//'...') IU=UTL_GETUNIT() CALL OSD_OPEN(IU,FILE=FNAME,STATUS='OLD',FORM='FORMATTED',ACTION='READ,DENYWRITE',ACCESS='SEQUENTIAL') !## list index for GENLISTINDEX(NGENLIST)=GLGENLISTS(1) !## start new drawing list CALL GLNEWLIST(GENLISTINDEX(NGENLIST),GL_COMPILE) L3D=.TRUE.; NX=100; ALLOCATE(X(NX),Y(NX),Z(NX)) DO !## read id READ(IU,*,IOSTAT=IOS); IF(IOS.NE.0)EXIT I=0; LS3D=.TRUE.; DO !## read coordinates READ(IU,'(A256)',IOSTAT=IOS) LINE; IF(IOS.NE.0)EXIT I=I+1; IF(I.GT.NX)THEN ALLOCATE(X_DUM(NX*2),Y_DUM(NX*2),Z_DUM(NX*2)) X_DUM(1:NX)=X; Y_DUM(1:NX)=Y; Z_DUM(1:NX)=Z DEALLOCATE(X,Y,Z); X=>X_DUM; Y=>Y_DUM; Z=>Z_DUM; NX=NX*2 ENDIF !## try to read 3d info READ(LINE,*,IOSTAT=IOS) X(I),Y(I),Z(I) IF(IOS.NE.0)THEN !## read 2d info READ(LINE,*,IOSTAT=IOS) X(I),Y(I); Z(I)=TOP%Z; IF(IOS.NE.0)EXIT L3D=.FALSE.; LS3D=.FALSE. ENDIF ENDDO NX=I-1; IF(NX.LT.2)CYCLE !## determine polygon/line IF(.NOT.UTL_EQUALS_REAL(X(NX),X(1)).OR..NOT.UTL_EQUALS_REAL(Y(NX),Y(1)))THEN ! !## 2d-lines ! IF(NX.GT.5.OR..NOT.LS3D)THEN CALL GLBEGIN(GL_LINES) DO I=1,NX-1 IF((X(I).GT.BOT%X.OR.X(I+1).GT.BOT%X).AND.(X(I).LT.TOP%X.OR.X(I+1).LT.TOP%X).AND. & (Y(I).GT.BOT%Y.OR.Y(I+1).GT.BOT%Y).AND.(Y(I).LT.TOP%Y.OR.Y(I+1).LT.TOP%Y))THEN NINGEN =NINGEN+1 XCOR(1)=(X(I) -MIDPOS%X)/DX; YCOR(1)=(Y(I) -MIDPOS%Y)/DY XCOR(2)=(X(I+1)-MIDPOS%X)/DX; YCOR(2)=(Y(I+1)-MIDPOS%Y)/DY CALL IMOD3D_LINE(XCOR,YCOR,Z(I:)) ENDIF ENDDO CALL GLEND() !## 3d-squads ELSE IF((X(1).GT.BOT%X.OR.X(2).GT.BOT%X).AND.(X(1).LT.TOP%X.OR.X(2).LT.TOP%X).AND. & (Y(1).GT.BOT%Y.OR.Y(2).GT.BOT%Y).AND.(Y(1).LT.TOP%Y.OR.Y(2).LT.TOP%Y))THEN NINGEN =NINGEN+1 IF(X(1).GT.X(2))THEN XCOR(1)=X(2); X(2)=X(1); X(1)=XCOR(1) YCOR(1)=Y(2); Y(2)=Y(1); Y(1)=YCOR(1) ENDIF XCOR(1)=(X(1)-MIDPOS%X)/DX; YCOR(1)=(Y(1)-MIDPOS%Y)/DY XCOR(2)=(X(2)-MIDPOS%X)/DX; YCOR(2)=(Y(2)-MIDPOS%Y)/DY XCOR(3)=(X(4)-MIDPOS%X)/DX; YCOR(3)=(Y(4)-MIDPOS%Y)/DY XCOR(4)=(X(3)-MIDPOS%X)/DX; YCOR(4)=(Y(3)-MIDPOS%Y)/DY !## begin OpenGL-Quads CALL GLBEGIN(GL_QUADS) DO I=1,4; CALL GLVERTEX3F(XCOR(I),YCOR(I),Z(I)); ENDDO !## end OpenGL-Quads CALL GLEND() ENDIF END IF ENDDO DEALLOCATE(X,Y,Z); CLOSE(IU) CALL GLENDLIST() CALL WINDOWOUTSTATUSBAR(2,'') CALL IMOD3D_ERROR('IMOD3D_DRAWGEN') END SUBROUTINE IMOD3D_DRAWGEN !###====================================================================== LOGICAL FUNCTION IMOD3D_SOL() !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT) :: DXX,DYY,GX,GY,GZ,DXY INTEGER :: I,J,K,II,JJ,IPROF,IPOS,N,I1,I2,IICLR REAL(KIND=GLFLOAT),DIMENSION(4) :: X,Y,XCOR,YCOR,Z REAL(KIND=GLFLOAT),DIMENSION(2) :: TX REAL,DIMENSION(:),ALLOCATABLE :: XT REAL,DIMENSION(:,:),ALLOCATABLE :: ZT REAL,PARAMETER :: NODATA_Z=-999.99 IMOD3D_SOL=.FALSE. !## solid active, although loaded im memory (could be) IF(ISOLID_3D.EQ.0)RETURN IF(NSOLLIST.EQ.0)RETURN !## get display-list pointers SOLLISTINDEX=0 !## process each spf-(file) NSOLLIST=0 DO I=1,NSPF NSOLLIST=NSOLLIST+1 !## list index for SOLLISTINDEX(NSOLLIST,1)=GLGENLISTS(1) !## start new drawing list CALL GLNEWLIST(SOLLISTINDEX(NSOLLIST,1),GL_COMPILE) !## process each cross-section (nidf) --- two-by-two DO IPROF=1,SIZE(SPF(I)%PROF)-1 IF(SPF(I)%PROF(IPROF)%NPOS .LE.0)CYCLE IF(SPF(I)%PROF(IPROF+1)%NPOS.LE.0)CYCLE !## make sure xt has a small offset (except for xt=0.0) TX(1)=0.0 DO J=2,SPF(I)%NXY DXX=SPF(I)%X(J)-SPF(I)%X(J-1); DYY=SPF(I)%Y(J)-SPF(I)%Y(J-1); DXY=DXX**2.0+DYY**2.0 IF(DXY.GT.0.0)DXY=SQRT(DXY) TX(1)=TX(1)+DXY ENDDO !## minimal offset = fraction of total distance DXX=TX(1)/1000.0 N=SPF(I)%PROF(IPROF)%NPOS+SPF(I)%PROF(IPROF+1)%NPOS+SPF(I)%NXY-2 ALLOCATE(XT(N),ZT(N,2)) XT=0.0 ZT=NODATA_Z IPOS=0 II =0 DO K=IPROF,IPROF+1 II=II+1 !## create table with distances and z-values for top/bot of current iprof-layer DO J=1,SPF(I)%PROF(K)%NPOS IPOS=IPOS+1 IF(J.EQ.1)THEN XT(IPOS)=SPF(I)%PROF(K)%PX(J) ELSE XT(IPOS)=MAX(XT(IPOS-1)+DXX,SPF(I)%PROF(K)%PX(J)) ENDIF ZT(IPOS,II)=SPF(I)%PROF(K)%PZ(J) ENDDO END DO !## include knickpoints TX(1)=0.0 DO J=2,SPF(I)%NXY-1 DXX=SPF(I)%X(J)-SPF(I)%X(J-1); DYY=SPF(I)%Y(J)-SPF(I)%Y(J-1); DXY=0.0 IF(DXX.NE.0.0.OR.DYY.NE.0.0)DXY=SQRT(DXX**2.0+DYY**2.0) TX(1) =TX(1)+DXY IPOS =IPOS+1 XT(IPOS) =TX(1) ZT(IPOS,1)=NODATA_Z !## to be filled in later ZT(IPOS,2)=NODATA_Z !## to be filled in later ENDDO N=IPOS !CALL SORTEM(1,N,XT,2,ZT(:,1),ZT(:,2),XT,XT,XT,XT,XT) CALL SORTEM(1,N,XT,2,ZT(:,1),ZT(:,2),(/0.0/),(/0.0/),(/0.0/),(/0.0/),(/0.0/)) !## fill first and last DO K=1,2 IF(ZT(1,K).EQ.NODATA_Z)THEN DO J=2,N IF(ZT(J,K).NE.NODATA_Z)THEN ZT(1,K)=ZT(J,K) EXIT ENDIF ENDDO ENDIF IF(ZT(N,K).EQ.NODATA_Z)THEN DO J=N-1,1,-1 IF(ZT(J,K).NE.NODATA_Z)THEN ZT(N,K)=ZT(J,K) EXIT ENDIF ENDDO ENDIF ENDDO !## interpolate unknown values DO J=1,N DO K=1,2 IF(ZT(J,K).EQ.NODATA_Z)THEN DO I1=J-1,1,-1; IF(ZT(I1,K).NE.NODATA_Z)EXIT; ENDDO DO I2=J+1,N; IF(ZT(I2,K).NE.NODATA_Z)EXIT; ENDDO GZ=0.0 IF(XT(I2)-XT(I1).NE.0.0)GZ=(ZT(I2,K)-ZT(I1,K))/(XT(I2)-XT(I1)) ZT(J,K)=ZT(I1,K)+GZ*(XT(J)-XT(I1)) ENDIF END DO ENDDO !## remove doubles K=1 DO J=2,N IF(XT(K).NE.XT(J))THEN K=K+1 IF(K.NE.J)THEN XT(K) =XT(J) ZT(K,1)=ZT(J,1) ZT(K,2)=ZT(J,2) ENDIF ENDIF END DO !## number of unique points in table N=K !## make sure last point is equal to %tx XT(N)=SPF(I)%TX !## llc X(1)=SPF(I)%X(1) Y(1)=SPF(I)%Y(1) Z(1)=ZT(1,2) !## ulc X(2)=X(1) Y(2)=Y(1) Z(2)=ZT(1,1) !## for each (interpolated) coordinate DO IPOS=2,N !## assign coordinate and z-values to knickpoints TX=0.0 DO J=2,SPF(I)%NXY DXX=SPF(I)%X(J)-SPF(I)%X(J-1); DYY=SPF(I)%Y(J)-SPF(I)%Y(J-1); DXY=0.0 IF(DXX.NE.0.0.OR.DYY.NE.0.0)DXY=SQRT(DXX**2.0+DYY**2.0) GX=0.0; GY=0.0 IF(DXY.GT.0.0)THEN; GX=DXX/DXY; GY=DYY/DXY; ENDIF TX(2)=TX(1)+DXY !## between interval or in last interval IF(XT(IPOS).GE.TX(1).AND.XT(IPOS).LT.TX(2).OR. & J.EQ.SPF(I)%NXY)THEN !## urc X(3)=SPF(I)%X(J-1)+GX*(XT(IPOS)-TX(1)) Y(3)=SPF(I)%Y(J-1)+GY*(XT(IPOS)-TX(1)) Z(3)=ZT(IPOS,1) !## lrc X(4)=X(3) Y(4)=Y(3) Z(4)=ZT(IPOS,2) !## if inside current viewable domain, add to OpenGL-statement IF((X(1).GT.BOT%X.OR.X(3).GT.BOT%X).AND.(X(1).LT.TOP%X.OR.X(3).LT.TOP%X).AND. & (Y(1).GT.BOT%Y.OR.Y(3).GT.BOT%Y).AND.(Y(1).LT.TOP%Y.OR.Y(3).LT.TOP%Y))THEN !## correct x/y for current viewable ratios XCOR(1)=(X(1)-MIDPOS%X)/VIEWDX; YCOR(1)=(Y(1)-MIDPOS%Y)/VIEWDY XCOR(2)= XCOR(1) ; YCOR(2)= YCOR(1) XCOR(3)=(X(3)-MIDPOS%X)/VIEWDX; YCOR(3)=(Y(3)-MIDPOS%Y)/VIEWDY XCOR(4)= XCOR(3) ; YCOR(4)= YCOR(3) !## show filled in polygons IF(SOLPLOT(I)%IINTERFACE.EQ.0)THEN !## get color for z-mean between two segments IICLR=SLD(1)%INTCLR(IPROF) CALL IMOD3D_SETCOLOR(IICLR) !## include alpha !## show shaded surface CALL IMOD3D_RETURNCOLOR(IICLR,AMBIENT) CALL GLMATERIALFV(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE,AMBIENT) !## begin OpenGL-Quads CALL GLBEGIN(GL_QUADS) CALL IMOD3D_SETNORMALVECTOR((/XCOR(1),YCOR(1),Z(1)/),(/XCOR(2),YCOR(2),Z(2)/),(/XCOR(3),YCOR(3),Z(3)/)) DO JJ=1,4; CALL GLVERTEX3F(XCOR(JJ),YCOR(JJ),Z(JJ)); ENDDO !## end OpenGL-Quads CALL GLEND() CALL IMOD3D_SETCOLOR(WRGB(10,10,10)) ENDIF !## show interfaces IF(SOLPLOT(I)%IINTERFACE.EQ.1)THEN IICLR=SPF(I)%PROF(IPROF)%ICLR CALL IMOD3D_SETCOLOR(IICLR) ENDIF !## begin OpenGL-LINES CALL GLLINEWIDTH(1.0_GLFLOAT) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(XCOR(2),YCOR(2),Z(2)) CALL GLVERTEX3F(XCOR(3),YCOR(3),Z(3)) CALL GLEND() !## draw bottom (only for the last) IF(IPROF.EQ.SIZE(SPF(I)%PROF)-1)THEN !## show interfaces IF(SOLPLOT(I)%IINTERFACE.EQ.1)THEN IICLR=SPF(I)%PROF(IPROF+1)%ICLR CALL IMOD3D_SETCOLOR(IICLR) ENDIF CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(XCOR(1),YCOR(1),Z(1)) CALL GLVERTEX3F(XCOR(4),YCOR(4),Z(4)) CALL GLEND() ENDIF ENDIF !## copy current position to previous position X(1)=X(4); Y(1)=Y(4); Z(1)=Z(4) X(2)=X(3); Y(2)=Y(3); Z(2)=Z(3) EXIT ENDIF TX(1)=TX(2) ENDDO ENDDO DEALLOCATE(XT,ZT) NULLIFY(PX,PZ) ENDDO !## OpenGL-drawing list CALL GLENDLIST() ENDDO CALL WINDOWOUTSTATUSBAR(2,'') !## read, process and stick bitmaps to cross-sections IMOD3D_SOL=IMOD3D_SOL_BMP(VIEWDX,VIEWDY) !## read background again if this has been updated IREADBMP=0 CALL IMOD3D_ERROR('IMOD3D_SOL') END FUNCTION IMOD3D_SOL !###====================================================================== LOGICAL FUNCTION IMOD3D_SOL_BMP(DX,DY) !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT),INTENT(IN) :: DX,DY REAL(KIND=GLFLOAT) :: X1,X2,Y1,Y2,XT1,XT2,YT1,YT2,BZ1,BZ2,BX1,BX2,BDX,DXX,DYY,DXY,TDX INTEGER :: I,J IMOD3D_SOL_BMP=.FALSE. !## fill display current bitmap NSOLLIST=0 DO I=1,NSPF NSOLLIST=NSOLLIST+1 SOLLISTINDEX(NSOLLIST,2)=0 IF(SPF(I)%PBITMAP%IACT.EQ.0)CYCLE !## skip whenever interfaces need to be drawn IF(SOLPLOT(NSOLLIST)%IINTERFACE.EQ.1)THEN; SOLPLOT(NSOLLIST)%IBITMAP=0; CYCLE; ENDIF !## list index for SOLLISTINDEX(NSOLLIST,2)=GLGENLISTS(1) IF(SOLLISTINDEX(NSOLLIST,2).NE.0)CALL GLDELETELISTS(SOLLISTINDEX(NSOLLIST,2),1_GLSIZEI) !## start new drawing list CALL GLNEWLIST(SOLLISTINDEX(NSOLLIST,2),GL_COMPILE) !## read in bitmap and bind it to a texture IF(.NOT.IMOD3D_SOL_BMP_LOAD(I))EXIT !## turns on texturing CALL GLENABLE(GL_TEXTURE_2D) !## repeating texture in both directions CALL GLTEXPARAMETERI(GL_TEXTURE_2D,GL_TEXTURE_WRAP_S, GL_REPEAT) CALL GLTEXPARAMETERI(GL_TEXTURE_2D,GL_TEXTURE_WRAP_T, GL_REPEAT) !## magnification and minification method CALL GLTEXPARAMETERI(GL_TEXTURE_2D,GL_TEXTURE_MAG_FILTER,GL_NEAREST) CALL GLTEXPARAMETERI(GL_TEXTURE_2D,GL_TEXTURE_MIN_FILTER,GL_NEAREST) !## hint to compute perspective correction CALL GLHINT(GL_PERSPECTIVE_CORRECTION_HINT,GL_FASTEST) BX1=SPF(I)%PBITMAP%GX1 !## minx BX2=SPF(I)%PBITMAP%GX2 !## maxx BZ1=SPF(I)%PBITMAP%GY1 !## minz BZ2=SPF(I)%PBITMAP%GY2 !## maxz BDX=BX2-BX1 TDX=0.0_GLFLOAT DO J=2,SPF(I)%NXY DXX=SPF(I)%X(J)-SPF(I)%X(J-1); DYY=SPF(I)%Y(J)-SPF(I)%Y(J-1) DXY=DXX**2.0+DYY**2.0; IF(DXY.NE.0.0)DXY=SQRT(DXY) !## skip distances of zero IF(DXY.EQ.0.0)CYCLE X1=(SPF(I)%X(J-1)-MIDPOS%X)/DX X2=(SPF(I)%X(J) -MIDPOS%X)/DX Y1=(SPF(I)%Y(J-1)-MIDPOS%Y)/DY Y2=(SPF(I)%Y(J) -MIDPOS%Y)/DY !## compute texture fractions XT1=(TDX-BX1)/BDX TDX= TDX+DXY XT2=(TDX-BX1)/BDX YT1=0.0_GLFLOAT YT2=1.0_GLFLOAT !## connect 2d texture to 3d object (in this case top of cube) CALL GLBEGIN(GL_QUADS) CALL GLTEXCOORD2F(XT1,YT1); CALL GLVERTEX3F(X1,Y1,BZ2) CALL GLTEXCOORD2F(XT1,YT2); CALL GLVERTEX3F(X1,Y1,BZ1) CALL GLTEXCOORD2F(XT2,YT2); CALL GLVERTEX3F(X2,Y2,BZ1) CALL GLTEXCOORD2F(XT2,YT1); CALL GLVERTEX3F(X2,Y2,BZ2) CALL GLEND() ENDDO CALL GLDISABLE(GL_TEXTURE_2D) CALL GLENDLIST() SOLPLOT(NSOLLIST)%IBITMAP=1 ENDDO IMOD3D_SOL_BMP=.TRUE. CALL IMOD3D_ERROR('IMOD3D_SOL_BMP') END FUNCTION IMOD3D_SOL_BMP !###====================================================================== LOGICAL FUNCTION IMOD3D_SOL_BMP_LOAD(ISPF) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ISPF INTEGER(GLSIZEI) :: IWIDTH,IHEIGHT INTEGER,ALLOCATABLE,DIMENSION(:) :: IBMPDATA INTEGER :: I,J,IW,IH,IOS REAL(KIND=GLFLOAT),ALLOCATABLE,DIMENSION(:) :: FRGB INTEGER,DIMENSION(11) :: INFO IMOD3D_SOL_BMP_LOAD=.FALSE. CALL IGRFILEINFO(SPF(ISPF)%PBITMAP%FNAME,INFO,11) SPF(ISPF)%PBITMAP%IW=INFO(2) SPF(ISPF)%PBITMAP%IH=INFO(3) IWIDTH =SPF(ISPF)%PBITMAP%IW IHEIGHT=SPF(ISPF)%PBITMAP%IH ALLOCATE(IBMPDATA(IWIDTH*IHEIGHT),STAT=IOS) IF(IOS.NE.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot allocate enough memory IBMPDATA() to store image'//CHAR(13)// & TRIM(SPF(ISPF)%PBITMAP%FNAME),'Error'); RETURN ENDIF ALPHA=0.75_GLFLOAT IALPHA=0 ALLOCATE(FRGB(IWIDTH*IHEIGHT*(3+IALPHA)),STAT=IOS) IF(IOS.NE.0)THEN DEALLOCATE(IBMPDATA) CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'Cannot allocate enough memory FRGB() to store image'//CHAR(13)// & TRIM(SPF(ISPF)%PBITMAP%FNAME),'Error'); RETURN ENDIF IF(.NOT.UTL_LOADIMAGE(SPF(ISPF)%PBITMAP%FNAME,SIZE(IBMPDATA),IBMPDATA,0))THEN DEALLOCATE(IBMPDATA,FRGB); RETURN ENDIF !## draw pixels at the current rasterposition J=-2-IALPHA DO IH=IHEIGHT,1,-1 DO IW=1,IWIDTH J=J+3+IALPHA I=(IH-1)*IWIDTH+IW CALL IMOD3D_RETURNCOLOR(IBMPDATA(I),FRGB(J)) !## mask out white, to be translucent (make pure black=background) IF(IALPHA.EQ.1)THEN !## white IF(FRGB(I).EQ.1.0)THEN FRGB(J+3)=0.0_GLFLOAT !ALPHA !## alpha value ELSE FRGB(J+3)=1.0_GLFLOAT !ALPHA !## alpha value ENDIF ENDIF ENDDO ENDDO !## turns on texturing CALL GLENABLE(GL_TEXTURE_2D) !## sets the drawing mode to GL_DECAL so that the textured !## polygons are drawn using the colors from the texture map (rather than taking into account what color the polygons !## would have been drawn without the texture) IF(IALPHA.EQ.0)THEN !## print image over the polygons CALL GLTEXENVI(GL_TEXTURE_ENV,GL_TEXTURE_ENV_MODE,GL_DECAL) !MODULATE) ELSE CALL GLTEXENVI(GL_TEXTURE_ENV,GL_TEXTURE_ENV_MODE,GL_BLEND) CALL GLTEXENVFV(GL_TEXTURE_ENV,GL_TEXTURE_ENV_COLOR,FRGB) !GL_RGBA) ENDIF !kan weg ! CALL GLCOLOR4F(1.0_GLFLOAT,1.0_GLFLOAT,1.0_GLFLOAT,0.0_GLFLOAT) !1.0_GLFLOAT) !## it describes how the bitmap data is stored in computer memory CALL GLPIXELSTOREI(GL_UNPACK_ALIGNMENT,1) !## parameters indicate the size of the image, type of the image, location of the image, and other properties of it IF(IALPHA.EQ.0)THEN CALL GLTEXIMAGE2D(GL_TEXTURE_2D,0_GLINT,3_GLINT,IWIDTH,IHEIGHT,0_GLINT,GL_RGB ,GL_FLOAT,FRGB) ELSE CALL GLTEXIMAGE2D(GL_TEXTURE_2D,0_GLINT,GL_RGBA,IWIDTH,IHEIGHT,0_GLINT,GL_RGBA,GL_FLOAT,FRGB) ENDIF !## free memory DEALLOCATE(IBMPDATA,FRGB) IMOD3D_SOL_BMP_LOAD=.TRUE. END FUNCTION IMOD3D_SOL_BMP_LOAD !###====================================================================== SUBROUTINE IMOD3D_CLP_ADD(X,Y,Z,XPOS,YPOS,ZPOS,CLIPNAME) !###====================================================================== IMPLICIT NONE REAL(KIND=GLDOUBLE),INTENT(IN) :: X,Y,Z,XPOS,YPOS,ZPOS CHARACTER(LEN=*),INTENT(IN) :: CLIPNAME INTEGER :: I,N !## add clipping plane NCLPLIST=MAX(1,NCLPLIST+1) CLPPLOT(NCLPLIST)%ISEL=0 CLPPLOT(NCLPLIST)%ITHICKNESS=1 CLPPLOT(NCLPLIST)%ICOLOR=WRGB(255,0,0) IF(CLIPNAME.EQ.'')THEN; CLPPLOT(NCLPLIST)%FNAME='ClippingPlane '//TRIM(ITOS(NCLPLIST)) ELSE; CLPPLOT(NCLPLIST)%FNAME=TRIM(CLIPNAME); ENDIF IF(X.EQ.0.0_GLDOUBLE.AND.Y.EQ.0.0_GLDOUBLE.AND.Z.EQ.0.0_GLDOUBLE)THEN !## richtings-coefficienten in scaling x/y !## NEGATIEF is andere deel weggeclipt (tegen x/y in) IF(NCLPLIST.EQ.1)CLPPLOT(NCLPLIST)%EQN=(/1.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE/) IF(NCLPLIST.EQ.2)CLPPLOT(NCLPLIST)%EQN=(/1.0_GLDOUBLE,1.0_GLDOUBLE,0.0_GLDOUBLE,0.0_GLDOUBLE/) ELSE !## search for keyword: N=NCLPLIST; DO I=1,N; IF(TRIM(CLPPLOT(I)%FNAME).EQ.TRIM(CLIPNAME))EXIT; ENDDO CLPPLOT(I)%EQN=(/X,Y,Z,0.0_GLDOUBLE/); CLPPLOT(I)%X=XPOS; CLPPLOT(I)%Y=YPOS; CLPPLOT(I)%Z=ZPOS IF(I.LT.N)NCLPLIST=MAX(0,NCLPLIST-1) ENDIF ! CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB7) ! CALL WDIALOGPUTMENU(IDF_MENU1,CLPPLOT%FNAME,NCLPLIST,CLPPLOT%ISEL) END SUBROUTINE IMOD3D_CLP_ADD !###====================================================================== LOGICAL FUNCTION IMOD3D_CLP() !###====================================================================== IMPLICIT NONE IMOD3D_CLP=.FALSE. !## list index for NCLPLIST=NCLPLIST+1 CLPLISTINDEX(NCLPLIST)=GLGENLISTS(1) !## start new drawing list CALL GLNEWLIST(CLPLISTINDEX(NCLPLIST),GL_COMPILE) CLPPLOT(NCLPLIST)%ISEL=1 CLPPLOT(NCLPLIST)%ITHICKNESS=1 CLPPLOT(NCLPLIST)%ICOLOR=WRGB(0,0,0) IMOD3D_CLP=.TRUE. CALL IMOD3D_ERROR('IMOD3D_CLP') END FUNCTION IMOD3D_CLP !###====================================================================== SUBROUTINE IMOD3D_QUAD(X,Y,Z,C,ILST,LLST) !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT),DIMENSION(4),INTENT(IN) :: X,Y,Z REAL,INTENT(IN) :: C INTEGER,INTENT(IN) :: ILST,LLST INTEGER :: I,ICLR REAL :: ZM DO I=1,4 !## get color for z-mean between two segments IF(IDFPLOT(ILST)%ILEG.EQ.2)THEN IF(ILST.EQ.LLST)THEN IF(I.LT.4)ZM=(Z(I)+Z(I+1))/2.0 IF(I.EQ.4)ZM=(Z(I)+Z(1))/2.0 ICLR=UTL_IDFGETCLASS(IDFPLOT(ILST)%LEG,ZM) ELSE ICLR=UTL_IDFGETCLASS(IDFPLOT(LLST)%LEG,C) ENDIF CALL IMOD3D_SETCOLOR(ICLR) ENDIF CALL GLVERTEX3F(X(I),Y(I),Z(I)) END DO CALL IMOD3D_ERROR('IMOD3D_QUAD') END SUBROUTINE IMOD3D_QUAD !###====================================================================== SUBROUTINE IMOD3D_TRIANGLE(X,Y,Z,IX,IY,IZ) !###====================================================================== IMPLICIT NONE INTEGER,DIMENSION(3),INTENT(IN) :: IX,IY,IZ REAL(KIND=GLFLOAT),DIMENSION(3),INTENT(IN) :: X,Y,Z INTEGER :: I,ICLR REAL :: ZM DO I=1,3 !## get color for z-mean between two segments IF(IDFPLOT(NIDFLIST)%ILEG.EQ.2)THEN IF(I.LT.3)ZM=(Z(IZ(I))+Z(IZ(I+1)))/2.0 IF(I.EQ.3)ZM=(Z(IZ(I))+Z(IZ(1)))/2.0 ICLR=UTL_IDFGETCLASS(IDFPLOT(NIDFLIST)%LEG,ZM) CALL IMOD3D_SETCOLOR(ICLR) ENDIF CALL GLVERTEX3F(X(IX(I)),Y(IY(I)),Z(IZ(I))) END DO CALL IMOD3D_ERROR('IMOD3D_TRIANGLE') END SUBROUTINE IMOD3D_TRIANGLE !###====================================================================== SUBROUTINE IMOD3D_TRIANGLE_SOLID(X,Y,Z,IX,IY,IZ) !###====================================================================== IMPLICIT NONE INTEGER,DIMENSION(3),INTENT(IN) :: IX,IY,IZ REAL(KIND=GLFLOAT),DIMENSION(3),INTENT(IN) :: X,Y,Z INTEGER :: I DO I=1,3 CALL GLVERTEX3F(X(IX(I)),Y(IY(I)),Z(IZ(I))) END DO CALL IMOD3D_ERROR('IMOD3D_TRIANGLE_SOLID') END SUBROUTINE IMOD3D_TRIANGLE_SOLID !###====================================================================== SUBROUTINE IMOD3D_LINE(X,Y,Z) !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT),DIMENSION(2),INTENT(IN) :: X,Y,Z CALL GLVERTEX3F(X(1),Y(1),Z(1)) CALL GLVERTEX3F(X(2),Y(2),Z(2)) BOT%Z=MIN(BOT%Z,Z(1),Z(2)) TOP%Z=MAX(TOP%Z,Z(1),Z(2)) CALL IMOD3D_ERROR('IMOD3D_LINE') END SUBROUTINE IMOD3D_LINE !###====================================================================== SUBROUTINE IMOD3D_SETNORMALVECTOR(P1,P2,P3) !###====================================================================== IMPLICIT NONE REAL(GLFLOAT),INTENT(IN),DIMENSION(3) :: P1,P2,P3 REAL(GLFLOAT),DIMENSION(3) :: NV REAL(GLFLOAT) :: QX,QY,QZ,PX,PY,PZ CALL IMOD3D_ERROR('IMOD3D_SETNORMALVECTOR_BEGIN') QX=P2(1)-P1(1); QY=P2(2)-P1(2); QZ=P2(3)-P1(3) PX=P3(1)-P1(1); PY=P3(2)-P1(2); PZ=P3(3)-P1(3) NV(1)=PY*QZ-PZ*QY NV(2)=PZ*QX-PX*QZ NV(3)=PX*QY-PY*QX CALL GLNORMAL3F(NV(1),NV(2),NV(3)) CALL IMOD3D_ERROR('IMOD3D_SETNORMALVECTOR_END') END SUBROUTINE IMOD3D_SETNORMALVECTOR END MODULE MOD_3D_ENGINE