!! 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 MOD_PREF_PAR, ONLY : PREFVAL USE MODPLOT USE MOD_COLOURS, ONLY : COLOUR_RANDOM USE IMODVAR, ONLY : IBACKSLASH,ILABELNAME USE MOD_IDF, ONLY : IDFREAD,IDFDEALLOCATE,IDFGETVAL,IDFREADPART,IDFDEALLOCATEX,IDFNULLIFY,IDFEQUAL,& IDFREADSCALE_GETX,IDFCOPY,IDF_EXTENT,IDFALLOCATEX,IDFGETLOC,IDFIROWICOL,IDFREADSCALE 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,UTL_ROTATE_XYZ, & UTL_GETCURRENTDATE,UTL_GETCURRENTTIME,PEUCKER_SIMPLIFYLINE,UTL_SUBST,UTL_WSELECTFILE 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_PROFILE, ONLY : PROFILE_COMPUTEPLOT,PROFILE_DEALLOCATE USE MOD_PROFILE_PAR, ONLY : MXNIDF,PROFIDF,SERIE,MXSERIE,NXY,XY,MXSAMPLING,ICCOL USE MOD_3D_PAR USE MOD_3D_UTL, ONLY : IMOD3D_RETURNCOLOR,IMOD3D_SETCOLOR,IMOD3D_DRAWIDF_SIZE,IMOD3D_CREATE_SXY, & IMOD3D_BLANKOUT,IMOD3D_BLANKOUT_XY,IMOD3D_MAPWINDOWTOOBJ,IMOD3D_SETNORMALVECTOR USE MOD_3D_DISPLAY, ONLY : IMOD3D_DISPLAY 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,ISEL_IDF,IACT,ICHECK,ICLEAN,IEXIST,XEXCLUDE,DTOL,NSPF,ISPF,NTBSOL USE MOD_SOLID_PROFILE, ONLY : SOLID_PROFILEFITDRILL_CALC,SOLID_PROFILEDELETE,SOLID_PROFILEADD_SPFMEMORY USE MOD_SOLID_UTL, ONLY : SOLIDOPENSPF,SOLID_INITSLD,SOLIDDEALLOCATESLD,SOLID_INITSLDPOINTER 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(WMENUGETSTATE(ID_ZRATIO6,ITEMCHECKED))IZR=6 !## make sure one is selected IF(IZR.EQ.0)IZR=3 IF(NIPFLIST.GT.0.OR.NIDFLIST.GT.0.OR.NIFFLIST.GT.0)THEN ZSCALE_FACTOR=ZR(IZR) 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 DOUBLE PRECISION :: D1,FOVYRAD,F INIT_SHIFTX =0.0_GLDOUBLE INIT_SHIFTY =0.0_GLDOUBLE INIT_SHIFTZ =0.0_GLDOUBLE LOOKAT%X=MIDPOS%X LOOKAT%Y=MIDPOS%Y LOOKAT%Z=MIDPOS%Z*ZSCALE_FACTOR FOVYRAD=FOVY/(360.0_GLDOUBLE/(2.0_GLDOUBLE*PI)) !## circle to describe entire volume D1=SQRT((TOP%X-BOT%X)**2.0+(TOP%Y-BOT%Y)**2.0+(ZSCALE_FACTOR*(TOP%Z-BOT%Z))**2.0) !## distance D1=(1.0_GLDOUBLE*D1)/ATAN(FOVYRAD) F=0.7 LOOKFROM%X=LOOKAT%X-F*(0.5*D1) LOOKFROM%Y=LOOKAT%Y-F*(D1) LOOKFROM%Z=LOOKAT%Z+F*(0.5*D1) ZFAR =2_GLDOUBLE*D1 !## znear as far as you can, the depth buffer is scales non-linear, more detail in the beginning and less further ZNEAR=0.01_GLDOUBLE*D1 ! !## printen ... ! write(*,*) zfar,znear,log(2.0)*zfar/znear 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,DXY INTEGER :: I,J REAL,PARAMETER :: D= 100.0 !## 1/d=percentage of axes-lines X1=BOT%X X2=TOP%X Y1=BOT%Y Y2=TOP%Y 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)) V1= X1+(V1-BOT%X) V2= X1+(V2-BOT%X) VI=(SXVALUE(2)-SXVALUE(1)) 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)) V1= Y1+(V1-BOT%Y) V2= Y1+(V2-BOT%Y) VI=(SYVALUE(2)-SYVALUE(1)) 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) V1= Z1+(V1-BOT%Z) V2= Z1+(V2-BOT%Z) VI=(SYVALUE(2)-SYVALUE(1)) 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,DT,FCT REAL(KIND=GLDOUBLE) :: XS,YS,ZS,TS INTEGER :: I REAL,PARAMETER :: D=100.0 !## 1/d=percentage of axes-lines CHARACTER(LEN=15) :: STRING X1=BOT%X X2=TOP%X Y1=BOT%Y Y2=TOP%Y Z1=BOT%Z Z2=TOP%Z !## kilometers FCT=1000.0 DT=MIN((Y2-Y1)/D,(X2-X1)/D) TS=2.5_GLDOUBLE*DT 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) V1= X1+(V1-BOT%X) V2= X1+(V2-BOT%X) VI=(SXVALUE(2)-SXVALUE(1)) !## 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 WRITE(STRING,UTL_GETFORMAT(REAL(DX/FCT))) DX/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) V1= Y1+(V1-BOT%Y) V2= Y1+(V2-BOT%Y) VI=(SYVALUE(2)-SYVALUE(1)) 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 WRITE(STRING,UTL_GETFORMAT(REAL(DY/FCT))) DY/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) V1= Z1+(V1-BOT%Z) V2= Z1+(V2-BOT%Z) VI=(SYVALUE(2)-SYVALUE(1)) DX=DT*2.0 DO I=1,NSY DZ=V1+VI*REAL(I-1) IF(DZ.GT.Z1.AND.DZ.LT.Z2)THEN WRITE(STRING,UTL_GETFORMAT(REAL(DZ))) DZ !## 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 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)) CALL GLLINEWIDTH(1.0) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT) CALL GLEND() 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)) 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() CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) CALL GLLINEWIDTH(1.0) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y ,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)) 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)) 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 GLLINEWIDTH(2.0) 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() CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) CALL GLLINEWIDTH(1.0) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT) CALL GLEND() 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)) 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 GLLINEWIDTH(2.0) 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() CALL GLLINEWIDTH(1.0) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,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)) 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)) 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)) 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() CALL GLLINEWIDTH(1.0) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y ,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 GLLINEWIDTH(2.0) 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() CALL IMOD3D_SETCOLOR(WRGB(0,0,0)) CALL GLLINEWIDTH(1.0) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT) CALL GLEND() 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)) 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 GLLINEWIDTH(2.0) 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() CALL GLLINEWIDTH(1.0) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(X ,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y ,0.0_GLFLOAT); CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X+DX,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT) CALL GLVERTEX3F(X ,Y-DY,0.0_GLFLOAT); CALL GLVERTEX3F(X ,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)) 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)) 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)%ICLIP =1 !## clipped 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=0 !## opaque mode 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)%ICLIP =1 !## clipped 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=0 !## opagua mode 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 IF(ALLOCATED(NANSTRING))DEALLOCATE(NANSTRING) ALLOCATE(NANSTRING(NIDFLIST)); NANSTRING='NaN' 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 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,REAL(BOT%X),REAL(BOT%Y)) CALL IDFIROWICOL(MP(IDFPLOT(I)%IPLOT)%IDF,IR1,IC2,REAL(TOP%X),REAL(TOP%Y)) IF(BOT%X.LE.MP(IDFPLOT(I)%IPLOT)%IDF%XMIN)IC1=1 IF(TOP%X.GE.MP(IDFPLOT(I)%IPLOT)%IDF%XMAX)IC2=MP(IDFPLOT(I)%IPLOT)%IDF%NCOL IF(BOT%Y.LE.MP(IDFPLOT(I)%IPLOT)%IDF%YMIN)IR2=MP(IDFPLOT(I)%IPLOT)%IDF%NROW IF(TOP%Y.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) 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) 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) 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) 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) 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; 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=1; 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=1 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=1; 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=1; 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 coloured by e.g. k-value CASE (6) IDFPLOT%IPLOTLEGEND=0 IF(DEMO%IDEMO.EQ.2)THEN; IDFPLOT%IFILL=DEMO%IFILL; ELSE; IDFPLOT%IFILL=1; 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-1,NIDFLIST-2,2 IF(DEMO%IDEMO.EQ.2)THEN; IDFPLOT%IFILL=DEMO%IFILL; ELSE; IDFPLOT%IFILL=1; 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(5) 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 ! IF(.NOT.IDFREADSCALE(IDF(5)%FNAME,IDF(1),IDFDATA(3),1,0.0,0))EXIT 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) ! IDF(1)%XMIN=BOT%X; IDF(1)%XMAX=TOP%X ! IDF(1)%YMIN=BOT%Y; IDF(1)%YMAX=TOP%Y ! IF(.NOT.IDFREADSCALE(IDF(5)%FNAME,IDF(1),IDFDATA(3),1,0.0,0))EXIT IF(.NOT.IDFREADPART(IDF(1),REAL(BOT%X),REAL(BOT%Y),REAL(TOP%X),REAL(TOP%Y)))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(.NOT.IDFREADSCALE(IDF(2)%FNAME,IDF(4),IDFDATA(3),1,0.0,0))EXIT 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(.NOT.IDFREADSCALE(IDF(3)%FNAME,IDF(5),IDFDATA(3),1,0.0,0))EXIT 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))THEN; ENDIF !,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) DO IROW=1,IDF(1)%NROW-1 !## translate current position to view=position I=0 DO ICOL=1,IDF(1)%NCOL !## 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 !## 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 ICOL=IDF(1)%NCOL; 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-1 !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-1 !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,RADIUS 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=(TOP%X-BOT%X)/100.0_GLFLOAT !(2.0_GLFLOAT*XYZAXES(1))/IDF(1)%NCOL RADIUS=0.05_GLFLOAT*FF !## width of arrow 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,RADIUS,F,.TRUE.) 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_TUBE2(XBH,YBH,ZBH,RBH,CBH,NINT,IMODE,ISHADE,IB,ZTOLERANCE) !###====================================================================== IMPLICIT NONE REAL,INTENT(INOUT),DIMENSION(:) :: XBH,YBH,ZBH,RBH REAL,INTENT(IN) :: ZTOLERANCE INTEGER,INTENT(INOUT),DIMENSION(:) :: CBH INTEGER,INTENT(IN) :: NINT,IMODE,ISHADE,IB REAL(KIND=GLFLOAT) :: AD,AX,AY,DX,DY,DZ REAL(KIND=GLFLOAT),DIMENSION(:,:),ALLOCATABLE :: XPOS,YPOS,ZPOS REAL,ALLOCATABLE,DIMENSION(:) :: ZDIST,XDIST REAL,ALLOCATABLE,DIMENSION(:,:) :: GCODE REAL :: ZTOL INTEGER :: I,J,N,NP,ICLR TYPE KPOBJ REAL(KIND=GLFLOAT) :: X,Y,Z,W,AX,AY INTEGER :: C END TYPE KPOBJ TYPE(KPOBJ),ALLOCATABLE,DIMENSION(:) :: KP !## stepsize angle radials AD=2.0*PI/REAL(NINT) !## allocate memory for storage of points on previous- and next cicle ALLOCATE(XPOS(0:NINT,2),YPOS(0:NINT,2),ZPOS(0:NINT,2)) CALL GLPUSHMATRIX() !## to ensure appropriate scaling of vector CALL GLSCALED(1.0_GLDOUBLE/XSCALE_FACTOR,1.0_GLDOUBLE/YSCALE_FACTOR,1.0_GLDOUBLE/ZSCALE_FACTOR) IF(ZTOLERANCE.GT.0.0)THEN !## compute line-simplication in three directions ALLOCATE(ZDIST(SIZE(XBH)),XDIST(SIZE(XBH)),GCODE(SIZE(XBH),4)); GCODE=0.0 DO J=1,SIZE(XBH); XDIST(J)=REAL(J); ENDDO DO I=1,3 IF(I.EQ.1)THEN; DO J=1,SIZE(XBH); ZDIST(J)=XBH(J); ENDDO; ENDIF IF(I.EQ.2)THEN; DO J=1,SIZE(YBH); ZDIST(J)=YBH(J); ENDDO; ENDIF IF(I.EQ.3)THEN; DO J=1,SIZE(ZBH); ZDIST(J)=ZBH(J); ENDDO; ENDIF !## process line CALL PEUCKER_SIMPLIFYLINE(XDIST,ZDIST,GCODE(:,I),SIZE(XBH)) ENDDO !## set simplification tolerance ZTOL=ZTOLERANCE !## see what point is in and what point is out GCODE(1 ,4)=1.0 GCODE(SIZE(XBH),4)=1.0 DO I=2,SIZE(XBH)-1 N=0 IF(GCODE(I,1).GT.ZTOL)N=N+1 IF(GCODE(I,2).GT.ZTOL)N=N+1 IF(GCODE(I,3).GT.ZTOL)N=N+1 !## if other class, always keep point IF(CBH(I).NE.CBH(I-1))N=N+2 !## point need to be kept IF(N.GE.2)GCODE(I,4)=1.0 ENDDO NP=1; DO I=2,SIZE(XBH) IF(GCODE(I,4).EQ.1.0)THEN NP =NP+1 XBH(NP)=XBH(I) YBH(NP)=YBH(I) ZBH(NP)=ZBH(I) RBH(NP)=RBH(I) CBH(NP)=CBH(I) ENDIF ENDDO ELSE NP=SIZE(XBH) ENDIF !## allocate all points ALLOCATE(KP(2*NP)) !## correct points (except first and last) and add knickpoints N=0; DO I=1,NP IF(I.LT.NP)THEN !## get angles from tube DX=XBH(I+1)-XBH(I) DY=YBH(I+1)-YBH(I) DZ=ZBH(I+1)-ZBH(I) AX=-ATAN2(DZ,DX) !## depending on sign AY= ATAN2(DY,SQRT(DX**2.0+DZ**2.0)) !## correct for direction IF(DX.LT.0.0)AY=-1.0*AY ENDIF !## add previous point, always as dimensions changes IF(I.GT.1)THEN N=N+1 KP(N)%X =XBH(I) KP(N)%Y =YBH(I) KP(N)%Z =ZBH(I) KP(N)%W =KP(N-1)%W KP(N)%AX=KP(N-1)%AX KP(N)%AY=KP(N-1)%AY KP(N)%C =KP(N-1)%C ENDIF !## add next point IF(I.LT.NP)THEN N=N+1 KP(N)%X =XBH(I) KP(N)%Y =YBH(I) KP(N)%Z =ZBH(I) KP(N)%W =RBH(I) KP(N)%AX=AX KP(N)%AY=AY KP(N)%C =CBH(I) ENDIF ENDDO DO I=1,N IF(IMODE.EQ.1)THEN !## what colour ICLR=KP(I)%C IF(I.GT.1)THEN IF(KP(I-1)%W.GT.KP(I)%W)ICLR=KP(I-1)%C ENDIF CALL IMOD3D_SETCOLOR(ICLR) !## show shaded surface IF(ISHADE.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(IB) ENDIF !## get coordinates - on circle and projected for ax,ay,ad CALL IMOD3D_TUBE_COORDINATES(NINT,XPOS(0,1),YPOS(0,1),ZPOS(0,1), & KP(I)%AX,KP(I)%AY,AD,KP(I)%X,KP(I)%Y,KP(I)%Z,KP(I)%W) !## draw fan of tube on first/last segment IF(I.EQ.1.OR.I.EQ.N)THEN !## draw triangle fan CALL GLBEGIN(GL_TRIANGLE_FAN) CALL IMOD3D_SETNORMALVECTOR((/XPOS(0,1),YPOS(0,1),ZPOS(0,1)/), & (/XPOS(1,1),YPOS(1,1),ZPOS(1,1)/), & (/KP(I)%X ,KP(I)%Y ,KP(I)%Z /)) CALL GLVERTEX3F(KP(I)%X,KP(I)%Y,KP(I)%Z) DO J=NINT,0,-1 CALL GLVERTEX3F(XPOS(J,1),YPOS(J,1),ZPOS(J,1)) ENDDO CALL GLEND() ENDIF IF(I.GT.1)THEN !## side of tube CALL GLBEGIN(GL_QUAD_STRIP) DO J=0,NINT IF(J.NE.NINT)THEN CALL IMOD3D_SETNORMALVECTOR((/XPOS(J,1) ,YPOS(J,1) ,ZPOS(J,1) /), & (/XPOS(J,2) ,YPOS(J,2) ,ZPOS(J,2) /), & (/XPOS(J+1,2),YPOS(J+1,2),ZPOS(J+1,2)/)) ENDIF CALL GLVERTEX3F(XPOS(J,1),YPOS(J,1),ZPOS(J,1)) CALL GLVERTEX3F(XPOS(J,2),YPOS(J,2),ZPOS(J,2)) ENDDO CALL GLEND() ENDIF DO J=0,NINT XPOS(J,2)=XPOS(J,1) YPOS(J,2)=YPOS(J,1) ZPOS(J,2)=ZPOS(J,1) ENDDO ENDDO CALL GLPOPMATRIX() !## deallocate memory DEALLOCATE(KP,XPOS,YPOS,ZPOS,ZDIST,XDIST,GCODE) END SUBROUTINE IMOD3D_TUBE2 ! !###====================================================================== ! SUBROUTINE IMOD3D_TUBE(XBH,YBH,ZBH,RBH,CBH,NINT,IMODE,ISHADE,IB) ! !###====================================================================== ! IMPLICIT NONE ! REAL,INTENT(IN),DIMENSION(:) :: XBH,YBH,ZBH,RBH ! INTEGER,INTENT(IN),DIMENSION(:) :: CBH ! INTEGER,INTENT(IN) :: NINT,IMODE,ISHADE,IB ! REAL(KIND=GLFLOAT) :: AD,AZ,AX,AY,DX,DY,DZ,XP,YP,ZP,AX2,AY2,AZ2 ! REAL(KIND=GLFLOAT),DIMENSION(:,:),ALLOCATABLE :: XPOS,YPOS,ZPOS ! INTEGER :: I,J,II,NFX,NFY,NF ! ! !## stepsize angle radials ! AD=2.0*PI/REAL(NINT) ! ! !## allocate memory for storage of points on previous- and next cicle ! ALLOCATE(XPOS(0:NINT,2),YPOS(0:NINT,2),ZPOS(0:NINT,2)) ! ! CALL GLPUSHMATRIX() ! ! !## to ensure appropriate scaling of vector ! CALL GLSCALED(1.0_GLDOUBLE/XSCALE_FACTOR,1.0_GLDOUBLE/YSCALE_FACTOR,1.0_GLDOUBLE/ZSCALE_FACTOR) ! ! DO I=1,SIZE(XBH)-1 ! ! IF(IMODE.EQ.1)THEN ! CALL IMOD3D_SETCOLOR(CBH(I)) ! IF(ISHADE.EQ.1)THEN !## show shaded surface ! CALL IMOD3D_RETURNCOLOR(CBH(I),AMBIENT) ! CALL GLMATERIALFV(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE,AMBIENT) ! ENDIF ! ELSEIF(IMODE.EQ.2)THEN ! CALL IMOD3D_SETCOLOR(IB) ! ENDIF ! ! !## get angles from tube ! DX=XBH(I+1)-XBH(I) ! DY=YBH(I+1)-YBH(I) ! DZ=ZBH(I+1)-ZBH(I) ! ! AX=-ATAN2(DZ,DX) ! !## afhankelijk sign dx/dz sla je nu plat ... ! AY= ATAN2(DY,SQRT(DX**2.0+DZ**2.0)) ! !## correct for direction ! IF(DX.LT.0.0)AY=-1.0*AY ! !! !## correct for direction !! IF(DZ.LT.0.0)AZ=-1.0*AZ ! ! AZ= 0.0 ! ! !## get coordinates ! CALL IMOD3D_TUBE_COORDINATES(NINT,XPOS(0,1),YPOS(0,1),ZPOS(0,1), & ! AX,AY,AD,XBH(I),YBH(I),ZBH(I),RBH(I)) ! ! !## draw top-fan of tube only for first segment ! IF(I.EQ.1)THEN ! XP=XBH(I); YP=YBH(I); ZP=ZBH(I) ! !## draw triangle fan ! CALL GLBEGIN(GL_TRIANGLE_FAN) ! CALL IMOD3D_SETNORMALVECTOR((/XPOS(0,1),YPOS(0,1),ZPOS(0,1)/), & ! (/XPOS(1,1),YPOS(1,1),ZPOS(1,1)/), & ! (/XP ,YP ,ZP /)) ! CALL GLVERTEX3F(XP,YP,ZP) ! DO J=NINT,0,-1 ! CALL GLVERTEX3F(XPOS(J,1),YPOS(J,1),ZPOS(J,1)) ! ENDDO ! CALL GLEND() ! ENDIF ! ! !## draw knee-part ! IF(I.GT.1)THEN ! ! !## draw knee-parts only whenever sequentially tubes have same dimensions ! IF(RBH(I-1).EQ.RBH(I))THEN ! ! !## get coordinates from ! CALL IMOD3D_TUBE_COORDINATES(NINT,XPOS(0,1),YPOS(0,1),ZPOS(0,1), & ! AX2,AY2,AD,XBH(I),YBH(I),ZBH(I),RBH(I)) ! ! !## fill in area in knickpoint ! DX=(AX-AX2) ! DY=(AY-AY2) ! ! !## number of segments in between equal to angle shift and 0.25*pi (45 degrees) ! NFX=ABS(DX/(0.25*PI)) ! NFY=ABS(DY/(0.25*PI)) ! NF =MAX(NFX,NFY,1) ! !! dx=(pi)/real(nf) !! dy=0.0 ! ! DX=DX/REAL(NF) ! DY=DY/REAL(NF) ! ! DO II=1,NF ! ! AX2=AX2+DX ! AY2=AY2+DY ! ! !## get coordinates to ! CALL IMOD3D_TUBE_COORDINATES(NINT,XPOS(0,2),YPOS(0,2),ZPOS(0,2), & ! AX2,AY2,AD,XBH(I),YBH(I),ZBH(I),RBH(I)) ! ! CALL GLBEGIN(GL_QUAD_STRIP) ! DO J=NINT,0,-1 ! IF(J.NE.NINT)THEN ! IF(XPOS(J,1).EQ.XPOS(J,2).AND. & ! YPOS(J,1).EQ.YPOS(J,2).AND. & ! ZPOS(J,1).EQ.ZPOS(J,2))THEN ! CALL IMOD3D_SETNORMALVECTOR((/XPOS(J+1,2),YPOS(J+1,2),ZPOS(J+1,2)/), & ! (/XPOS(J+1,1),YPOS(J+1,1),ZPOS(J+1,1)/), & ! (/XPOS(J,1) ,YPOS(J,1) ,ZPOS(J,1) /)) ! ELSE ! CALL IMOD3D_SETNORMALVECTOR((/XPOS(J,1) ,YPOS(J,1) ,ZPOS(J,1)/), & ! (/XPOS(J,2) ,YPOS(J,2) ,ZPOS(J,2)/), & ! (/XPOS(J+1,2),YPOS(J+1,2),ZPOS(J+1,2)/)) ! ENDIF ! ELSE ! IF(XPOS(J,1).EQ.XPOS(J,2).AND. & ! YPOS(J,1).EQ.YPOS(J,2).AND. & ! ZPOS(J,1).EQ.ZPOS(J,2))THEN ! CALL IMOD3D_SETNORMALVECTOR((/XPOS(J,1) ,YPOS(J,1) ,ZPOS(J,1) /), & ! (/XPOS(0,1) ,YPOS(0,1) ,ZPOS(0,1) /), & ! (/XPOS(0,2) ,YPOS(0,2) ,ZPOS(0,2)/)) ! ELSE ! CALL IMOD3D_SETNORMALVECTOR((/XPOS(J,1) ,YPOS(J,1) ,ZPOS(J,1) /), & ! (/XPOS(J,2) ,YPOS(J,2) ,ZPOS(J,2) /), & ! (/XPOS(0,2) ,YPOS(0,2) ,ZPOS(0,2)/)) ! ENDIF ! ENDIF ! CALL GLVERTEX3F(XPOS(J,2),YPOS(J,2),ZPOS(J,2)) ! CALL GLVERTEX3F(XPOS(J,1),YPOS(J,1),ZPOS(J,1)) ! ENDDO ! CALL GLEND() ! DO J=0,NINT ! XPOS(J,1)=XPOS(J,2) ! YPOS(J,1)=YPOS(J,2) ! ZPOS(J,1)=ZPOS(J,2) ! ENDDO ! ENDDO ! ! ENDIF ! ENDIF ! ! !## get coordinates - from ! CALL IMOD3D_TUBE_COORDINATES(NINT,XPOS(0,1),YPOS(0,1),ZPOS(0,1), & ! AX,AY,AD,XBH(I) ,YBH(I) ,ZBH(I) ,RBH(I)) ! !## get coordinates - to ! CALL IMOD3D_TUBE_COORDINATES(NINT,XPOS(0,2),YPOS(0,2),ZPOS(0,2), & ! AX,AY,AD,XBH(I+1),YBH(I+1),ZBH(I+1),RBH(I)) ! ! !## side of tube ! CALL GLBEGIN(GL_QUAD_STRIP) ! DO J=0,NINT ! IF(J.NE.NINT)THEN ! CALL IMOD3D_SETNORMALVECTOR((/XPOS(J,1) ,YPOS(J,1) ,ZPOS(J,1) /), & ! (/XPOS(J,2) ,YPOS(J,2) ,ZPOS(J,2) /), & ! (/XPOS(J+1,2),YPOS(J+1,2),ZPOS(J+1,2)/)) ! ENDIF ! CALL GLVERTEX3F(XPOS(J,1),YPOS(J,1),ZPOS(J,1)) ! CALL GLVERTEX3F(XPOS(J,2),YPOS(J,2),ZPOS(J,2)) ! ENDDO ! CALL GLEND() ! ! !## draw bottom of current trajectory ! IF(I.EQ.SIZE(XBH)-1.OR.RBH(I).NE.RBH(I+1))THEN ! XP=XBH(I+1); YP=YBH(I+1); ZP=ZBH(I+1) ! !## draw triangle fan ! CALL GLBEGIN(GL_TRIANGLE_FAN) ! CALL IMOD3D_SETNORMALVECTOR((/XPOS(0,2),YPOS(0,2),ZPOS(0,2)/), & ! (/XPOS(1,2),YPOS(1,2),ZPOS(1,2)/), & ! (/XP ,YP ,ZP /)) ! CALL GLVERTEX3F(XP,YP,ZP) ! DO J=NINT,0,-1 ! CALL GLVERTEX3F(XPOS(J,2),YPOS(J,2),ZPOS(J,2)) ! ENDDO ! CALL GLEND() ! ENDIF ! ! AX2=AX ! AY2=AY ! AZ2=AZ ! ! ENDDO ! ! CALL GLPOPMATRIX() ! ! END SUBROUTINE IMOD3D_TUBE !###====================================================================== SUBROUTINE IMOD3D_TUBE_COORDINATES(NINT,XPOS,YPOS,ZPOS,AX,AY,AD,XBH,YBH,ZBH,RBH) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: NINT REAL(KIND=GLFLOAT),INTENT(IN) :: AX,AY,AD REAL(KIND=GLFLOAT),INTENT(OUT),DIMENSION(0:NINT) :: XPOS,YPOS,ZPOS REAL(KIND=GLFLOAT) :: AR REAL,INTENT(IN) :: XBH,YBH,ZBH,RBH INTEGER :: J !## top or bottom - compute coordinates AR=0.0_GLFLOAT DO J=0,NINT XPOS(J)=RBH YPOS(J)=0.0_GLFLOAT ZPOS(J)=0.0_GLFLOAT !## rotate appropriately in 3D CALL UTL_ROTATE_XYZ(XPOS(J),YPOS(J),ZPOS(J), AX, AY,AR ) CALL UTL_ROTATE_XYZ(XPOS(J),YPOS(J),ZPOS(J), 0.0,REAL(0.5*PI),0.0) CALL UTL_ROTATE_XYZ(XPOS(J),YPOS(J),ZPOS(J),-REAL(0.5*PI), 0.0,0.0) !## transform XPOS(J)=XPOS(J)+XBH YPOS(J)=YPOS(J)+YBH ZPOS(J)=ZPOS(J)+ZBH AR=AR+AD ENDDO END SUBROUTINE IMOD3D_TUBE_COORDINATES !###====================================================================== SUBROUTINE IMOD3D_VECTOR(X,Y,Z,DX,DY,DZ,NINT,RADIUS,VL,LARROW) !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT),INTENT(IN) :: X,Y,Z,DX,DY,DZ,RADIUS LOGICAL,INTENT(IN) :: LARROW INTEGER,INTENT(IN) :: NINT REAL,INTENT(IN) :: VL REAL(KIND=GLFLOAT) :: DGRAD,FGRAD,X1,Y1,Z1,Z2,XPOS,YPOS,ZF,XGRAD,DXY,R INTEGER :: J DGRAD=2.0*PI/REAL(NINT) !## stepsize angle radials CALL GLPUSHMATRIX() !## to ensure appropriate scaling of vector CALL GLSCALED(1.0_GLDOUBLE/XSCALE_FACTOR,1.0_GLDOUBLE/YSCALE_FACTOR,1.0_GLDOUBLE/ZSCALE_FACTOR) !## translate CALL GLTRANSLATEF(X,Y,Z) !## 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 !## local coordinates before rotating and transfering X1=0.0_GLFLOAT; Y1=0.0_GLFLOAT; Z1=0.0_GLFLOAT !## top of tube Z2=Z1+VL !## start of arrow IF(LARROW)THEN ZF=Z1+0.75_GLFLOAT*VL !## start of arrow-cap ELSE ZF=Z1+VL ENDIF !## bottom triangle fan 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 of tube 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,ZF) FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() !## increase radius in case of arrows R=RADIUS; IF(LARROW)R=RADIUS*2.0_GLFLOAT !## top triangle fan 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)*R; YPOS=Y1+SIN(FGRAD)*R CALL GLVERTEX3F(XPOS,YPOS,ZF); FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() !## add arrow cap IF(LARROW)THEN 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,ZF) FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() ENDIF 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)%IFILL =1 !## coloured IPFPLOT(IIPF)%ISEL =1 IPFPLOT(IIPF)%ICLIP =1 !## initially use the fancy mode - this will be changed if more than 250 boreholes are considered IPFPLOT(IIPF)%IFANCY =1 IPFPLOT(IIPF)%ISHADE =1 IPFPLOT(IIPF)%RADIUS =1.0 !scale IPFPLOT(IIPF)%SIMPLIFY=1.0 !simplification (meter) IPFPLOT(IIPF)%ISUB =12 IPFPLOT(IIPF)%ISTYLE =4 IPFPLOT(IIPF)%ASSCOL1=MP(IPLOT)%ASSCOL1 IPFPLOT(IIPF)%ASSCOL2=MP(IPLOT)%ASSCOL2 IPFPLOT(IIPF)%IPLOTACOL=0 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(0,1))RETURN IMOD3D_IPF_INIT=.TRUE. END FUNCTION IMOD3D_IPF_INIT !###====================================================================== LOGICAL FUNCTION IMOD3D_IPF(IGL,IOVERRULE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IGL !## igl=0 do not include drawing lists for OpenGL INTEGER,INTENT(IN) :: IOVERRULE INTEGER :: IIPF,I,J,IPLOT,IU,IRAT,IRAT1,N REAL(KIND=GLFLOAT) :: X,Y,Z,Z2,MXW CHARACTER(LEN=256) :: FNAME,DIR LOGICAL :: LEX INTEGER :: ICLR,ACOL,IPLUS REAL :: XVAL,S IMOD3D_IPF=.FALSE. !## width scaling S =SQRT((TOP%Y-BOT%Y)**2.0+(TOP%X-BOT%X)**2.0)/500.0 MXW=MAXVAL(BH%LITHOWIDTH) !## 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 !## number of drawing lists NIPFLIST=0 !## number of picking lists NASSLIST=0 DO IIPF=1,NIPF CALL WINDOWOUTSTATUSBAR(2,'Get selection for '//TRIM(IPF(IIPF)%FNAME)//' ...') !## initialise ipos IPF(IIPF)%IPOS=INT(0,1) ACOL=IPF(IIPF)%ACOL; IF(ACOL.LT.0.OR.ACOL.GT.IPF(IIPF)%NCOL)ACOL=0 IF(IOVERRULE.EQ.1)THEN IF(ACOL.EQ.0)IPFPLOT(IIPF)%RADIUS=5.0 IF(ACOL.NE.0)IPFPLOT(IIPF)%RADIUS=2.0 ENDIF !## create separate drawinglists for boreholes not for non-connected points IPLUS=0; IF(ACOL.NE.0)IPLUS=1 !## create new drawinglist position IF(IPLUS.EQ.0)NIPFLIST=NIPFLIST+1 N=0 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) IF(IPLUS.NE.0)THEN NIPFLIST=NIPFLIST+IPLUS NASSLIST=NASSLIST+IPLUS ENDIF N=N+1 ENDIF ENDIF ENDDO !## change to non-fancy mode in case many boreholes are considered in active window IF(N.GT.MXROWFORFANCY.AND.IOVERRULE.EQ.1)IPFPLOT(IIPF)%IFANCY=0 ENDDO !## get display-list pointers IF(ALLOCATED(IPFLISTINDEX))THEN CALL WINDOWOUTSTATUSBAR(2,'Releasing 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 memory for drawinglists 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 !## reset acol since it can be altered ACOL=IPF(IIPF)%ACOL; IF(ACOL.LT.0.OR.ACOL.GT.IPF(IIPF)%NCOL)ACOL=0 !## overrula acol from the dialog IF(IPFPLOT(IIPF)%IPLOTACOL.EQ.1)ACOL=0 !## create separate drawinglists for boreholes not for non-connected points IPLUS=0; IF(ACOL.NE.0)IPLUS=1 !## create new drawinglist position IF(IPLUS.EQ.0)NIPFLIST=NIPFLIST+1 !## all point in a single drawing list IF(ACOL.EQ.0.AND.IGL.EQ.1)THEN !## create sphere-object IF(IPFPLOT(IIPF)%IFANCY.EQ.1)CALL IMOD3D_IPF_CREATEBALL(IPFPLOT(IIPF)%ISUB,IPFPLOT(IIPF)%ISTYLE,S*IPFPLOT(IIPF)%RADIUS) IPFLISTINDEX(NIPFLIST,1)=GLGENLISTS(1) !## start new drawing list for current object CALL GLNEWLIST(IPFLISTINDEX(NIPFLIST,1),GL_COMPILE) ENDIF CALL WINDOWOUTSTATUSBAR(2,'Reading '//TRIM(ITOS(IPF(IIPF)%NROW))//' points from '//TRIM(IPF(IIPF)%FNAME)) IPLOT=IPFPLOT(IIPF)%IPLOT I =INDEX(IPF(IIPF)%FNAME,'\',.TRUE.) DIR=IPF(IIPF)%FNAME(1:I-1) DO I=1,IPF(IIPF)%NROW ! !## 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) !## add another drawing list for this entry IF(IPLUS.NE.0)NIPFLIST=NIPFLIST+IPLUS LEX=.FALSE. IF(ACOL.NE.0)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 (1D and 3D) IF(ASSF(NASSLIST)%ITOPIC.EQ.2.OR.ASSF(NASSLIST)%ITOPIC.EQ.4)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,ASSF(NASSLIST)%ITOPIC,1,ICLR,IIPF,IGL,S,MXW) !## actual drills CALL IMOD3D_DRAWIPF(X,Y,Z,Z2,ASSF(NASSLIST)%ITOPIC,2,ICLR,IIPF,IGL,S,MXW) !## selection numbers drills !## put label in centre IPF(IIPF)%XYZ(3,I)=ASSF(NASSLIST)%Z(ASSF(NASSLIST)%NRASS) !## forces label on bottom LEX=.TRUE. ELSE 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)THEN; CLOSE(IU); EXIT; ENDIF ENDIF ENDIF CLOSE(IU) ENDIF IF(.NOT.LEX)THEN; NASSLIST=MAX(0,NASSLIST-1); NIPFLIST=MAX(0,NIPFLIST-1); 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 !## no associated additional files ELSE ! !## write message on window ! CALL UTL_WAITMESSAGE(IRAT,IRAT1,I,IPF(IIPF)%NROW,'Get points for '//TRIM(IPF(IIPF)%FNAME),IBOX=2) IF(IGL.EQ.1)THEN !## 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 ENDIF !## draw position only - no drill found CALL IMOD3D_DRAWIPF(X,Y,Z,Z2,0,1,ICLR,IIPF,IGL,S,MXW) !## actual drills ENDIF ENDIF ENDDO IF(ACOL.EQ.0.AND.NIPFLIST.GT.0)THEN !## store information for selection purposes IPFDLIST(1,NIPFLIST)=IIPF !## number of ipf IPFDLIST(2,NIPFLIST)=0 !I !## number of row in ipf IPFDLIST(3,NIPFLIST)=0.0 !INT(IPF(IIPF)%XYZ(1,I)) !## xpos IPFDLIST(4,NIPFLIST)=0.0 !INT(IPF(IIPF)%XYZ(2,I)) !## ypos IPFDLIST(5,NIPFLIST)=1 ENDIF !## all point in a single drawing list IF(ACOL.EQ.0.AND.IGL.EQ.1)CALL GLENDLIST() 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,ZZ,IPLOTTYPE,IMODE,ICLR,IIPF,IGL,S,MXW) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: IPLOTTYPE,IMODE,ICLR,IIPF,IGL REAL,INTENT(IN) :: S REAL(KIND=GLFLOAT),INTENT(IN) :: X,Y,Z,ZZ,MXW REAL(KIND=GLFLOAT) :: X1,X2,Y1,Y2,Z1,Z2,BSIZE,FRAC INTEGER :: I,JCLR,N REAL :: IWIDTH,R REAL,DIMENSION(:),ALLOCATABLE :: XBH,YBH,ZBH,RBH INTEGER,DIMENSION(:), ALLOCATABLE :: CBH BSIZE=IPFPLOT(IIPF)%RADIUS !## imode=1: drawing list !## imode=2: selection drawing list to be drawn in background only !## draw 1D (=2) or 3D (=4) borehole IF(IPLOTTYPE.EQ.2.OR.IPLOTTYPE.EQ.4)THEN IF(IGL.EQ.1)THEN IPFLISTINDEX(NIPFLIST,IMODE)=GLGENLISTS(1) !## start new drawing list for current object CALL GLNEWLIST(IPFLISTINDEX(NIPFLIST,IMODE),GL_COMPILE) ENDIF !## 1D borehole IF(IPLOTTYPE.EQ.2)THEN X1=X; Y1=Y; Z1=ASSF(NASSLIST)%Z(1) ELSEIF(IPLOTTYPE.EQ.4)THEN X1=X+ASSF(NASSLIST)%DX(1); Y1=Y+ASSF(NASSLIST)%DY(1); Z1=ASSF(NASSLIST)%Z(1) ENDIF !## simple lines IF(IPFPLOT(IIPF)%IFANCY.EQ.0)THEN IF(IGL.EQ.1)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 IF(IMODE.EQ.1)THEN CALL IPFDRAWITOPIC2_ICLR(I,NASSLIST,JCLR,IWIDTH); CALL IMOD3D_SETCOLOR(JCLR) ELSEIF(IMODE.EQ.2)THEN CALL IMOD3D_SETCOLOR(NASSLIST) ENDIF !## from location IF(IGL.EQ.1)CALL GLVERTEX3F(X1,Y1,Z1) !## 1D borehole IF(IPLOTTYPE.EQ.2)THEN X2=X1; Y2=Y1; Z2=ASSF(NASSLIST)%Z(I+1) ELSEIF(IPLOTTYPE.EQ.4)THEN X2=X+ASSF(NASSLIST)%DX(I+1); Y2=Y+ASSF(NASSLIST)%DY(I+1); Z2=ASSF(NASSLIST)%Z(I+1) ENDIF !## to location IF(IGL.EQ.1)THEN CALL GLVERTEX3F(X2,Y2,Z2) ELSE TOP%X=MAX(TOP%X,X1,X2); BOT%X=MIN(BOT%X,X1,X2) TOP%Y=MAX(TOP%Y,Y1,Y2); BOT%Y=MIN(BOT%Y,Y1,Y2) TOP%Z=MAX(TOP%Z,Z1,Z2); BOT%Z=MIN(BOT%Z,Z1,Z2) ENDIF X1=X2; Y1=Y2; Z1=Z2 ENDDO IF(IGL.EQ.1)CALL GLEND() !## 3D-pipes ELSEIF(IPFPLOT(IIPF)%IFANCY.EQ.1)THEN N=ASSF(NASSLIST)%NRASS; ALLOCATE(XBH(N),YBH(N),ZBH(N),RBH(N),CBH(N)) R=IPFPLOT(IIPF)%RADIUS !## read in complete borehole DO I=1,ASSF(NASSLIST)%NRASS CALL IPFDRAWITOPIC2_ICLR(I,NASSLIST,JCLR,IWIDTH) !## normalize according to other sizes FRAC=IWIDTH/MXW CBH(I)=JCLR !## scale to percentage of graphical dimensions RBH(I)=FRAC*(S*R) !## 1D borehole IF(IPLOTTYPE.EQ.2)THEN XBH(I)=X YBH(I)=Y ELSEIF(IPLOTTYPE.EQ.4)THEN !##v41 XBH(I)=X+ASSF(NASSLIST)%DX(I) YBH(I)=Y+ASSF(NASSLIST)%DY(I) ENDIF ZBH(I)=ASSF(NASSLIST)%Z(I) ENDDO IF(IGL.EQ.0)THEN TOP%X=MAX(TOP%X,MAXVAL(XBH)); BOT%X=MIN(BOT%X,MINVAL(XBH)) TOP%Y=MAX(TOP%Y,MAXVAL(YBH)); BOT%Y=MIN(BOT%Y,MINVAL(YBH)) TOP%Z=MAX(TOP%Z,MAXVAL(ZBH)); BOT%Z=MIN(BOT%Z,MINVAL(ZBH)) ENDIF !## apply scaling ZBH=ZBH*ZSCALE_FACTOR IF(IGL.EQ.1)CALL IMOD3D_TUBE2(XBH,YBH,ZBH,RBH,CBH,IPFPLOT(IIPF)%ISUB,IMODE,IPFPLOT(IIPF)%ISHADE, & NASSLIST,IPFPLOT(IIPF)%SIMPLIFY) DEALLOCATE(XBH,YBH,ZBH,RBH,CBH) ENDIF IF(IGL.EQ.1)CALL GLENDLIST() !## points only ELSEIF(IPLOTTYPE.EQ.0)THEN IF(IGL.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 !## draw point if z equals z2 IF(Z.EQ.ZZ)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,ZZ); CALL GLEND() ELSEIF(IPFPLOT(IIPF)%IFANCY.EQ.1)THEN ! IF(IMODE.EQ.1) CALL IMOD3D_IPF_FANCY((/X,X/),(/Y,Y/),(/Z,ZZ/),IPFPLOT(IIPF)%ISUB,BSIZE*S,(/1,1,1,IPFPLOT(IIPF)%ISHADE/)) ! IF(IMODE.EQ.2)CALL IMOD3D_IPF_FANCY((/X,X/),(/Y,Y/),(/Z,ZZ/),IPFPLOT(IIPF)%ISUB,BSIZE, & ! (/1,1,1,0/)) ENDIF ENDIF ENDIF TOP%Z=MAX(TOP%Z,Z,ZZ); BOT%Z=MIN(BOT%Z,Z,ZZ) ENDIF CALL IMOD3D_ERROR('IMOD3D_DRAWIPF') END SUBROUTINE IMOD3D_DRAWIPF !###====================================================================== SUBROUTINE IMOD3D_IPF_CREATEBALL(ISUB,ISTYLE,R) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ISUB,ISTYLE REAL,INTENT(IN) :: R REAL(GLDOUBLE) :: RD TYPE(GLUQUADRICOBJ), POINTER :: QUADOBJ !## 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 GLPUSHMATRIX() !## to ensure appropriate scaling of vector CALL GLSCALED(1.0_GLDOUBLE/XSCALE_FACTOR,1.0_GLDOUBLE/YSCALE_FACTOR,1.0_GLDOUBLE/ZSCALE_FACTOR) QUADOBJ => GLUNEWQUADRIC() SELECT CASE (ISTYLE) CASE (1); CALL GLUQUADRICDRAWSTYLE(QUADOBJ, GLU_POINT) CASE (2); CALL GLUQUADRICDRAWSTYLE(QUADOBJ, GLU_LINE) CASE (3); CALL GLUQUADRICDRAWSTYLE(QUADOBJ, GLU_SILHOUETTE) CASE (4); CALL GLUQUADRICDRAWSTYLE(QUADOBJ, GLU_FILL) END SELECT CALL GLUQUADRICNORMALS(QUADOBJ, GLU_SMOOTH) RD=R !100.0_GLDOUBLE CALL GLUSPHERE(QUADOBJ,RD,ISUB,ISUB) CALL GLPOPMATRIX() CALL GLENDLIST() END SUBROUTINE IMOD3D_IPF_CREATEBALL !###====================================================================== SUBROUTINE IMOD3D_IPF_FANCY(XMID,YMID,ZMID,NINT,RADIUS,IPLT) !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT),INTENT(IN),DIMENSION(2) :: XMID,YMID,ZMID REAL(KIND=GLFLOAT),INTENT(IN) :: RADIUS REAL(KIND=GLFLOAT) :: DGRAD,FGRAD,XPOS,YPOS,ZPOS INTEGER,INTENT(IN) :: NINT INTEGER,INTENT(IN),DIMENSION(4) :: IPLT INTEGER :: I,J DGRAD=2.0*PI/REAL(NINT) !## stepsize angle radials !## generate triangle_fan for the top/bottom of current interval DO I=1,2 IF(IPLT(I).EQ.0)CYCLE FGRAD=0.0_GLFLOAT CALL GLBEGIN(GL_TRIANGLE_FAN) !## add shades IF(IPLT(4).EQ.1)CALL GLNORMAL3F(0.0_GLFLOAT,0.0_GLFLOAT,-1.0_GLFLOAT) CALL GLVERTEX3F(XMID(I),YMID(I),ZMID(I)) DO J=1,NINT+1 XPOS=COS(FGRAD)*RADIUS YPOS=SIN(FGRAD)*RADIUS ZPOS=0.0_GLFLOAT CALL GLVERTEX3F(XMID(I)+XPOS,YMID(I)+YPOS,ZMID(I)+ZPOS) FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() ENDDO !## generate side of the triangle_fan IF(IPLT(3).EQ.1)THEN CALL GLBEGIN(GL_QUAD_STRIP) FGRAD=0.0_GLFLOAT DO J=1,NINT+1 XPOS=COS(FGRAD)*RADIUS YPOS=SIN(FGRAD)*RADIUS ZPOS=0.0_GLFLOAT !## add shades IF(IPLT(4).EQ.1)CALL GLNORMAL3F(-COS(FGRAD),-SIN(FGRAD),0.0_GLFLOAT) CALL GLVERTEX3F(XMID(1)+XPOS,YMID(1)+YPOS,ZMID(1)+ZPOS) CALL GLVERTEX3F(XMID(2)+XPOS,YMID(2)+YPOS,ZMID(2)+ZPOS) FGRAD=FGRAD+DGRAD ENDDO CALL GLEND() ENDIF END SUBROUTINE IMOD3D_IPF_FANCY !###====================================================================== SUBROUTINE IMOD3D_IPF_LABELS() !###====================================================================== IMPLICIT NONE INTEGER :: IIPF,I,J,K,IPLOT,N,ACOL REAL(KIND=GLFLOAT) :: X,Y,Z,BSIZE CHARACTER(LEN=256) :: LINE,TLINE INTEGER,ALLOCATABLE,DIMENSION(:) :: ILIST REAL(KIND=GLDOUBLE),PARAMETER :: TS= 10.0 !0.025 !## textsize REAL(KIND=GLDOUBLE) :: TSIZE IF(NIPF.EQ.0)RETURN !## get labels N=0 DO IIPF=1,NIPF BSIZE=IPFPLOT(IIPF)%RADIUS 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 ACOL=IPF(IIPF)%ACOL; IF(ACOL.LT.0.OR.ACOL.GT.IPF(IIPF)%NCOL)ACOL=0 IF(ACOL.EQ.0)N=N+1 DO I=1,IPF(IIPF)%NROW IF(IPF(IIPF)%IPOS(I).EQ.INT(1,1))THEN !## label-drawing list IF(ACOL.NE.0)N=N+1 IF(IPFLISTINDEX(N,3).NE.0)CALL GLDELETELISTS(IPFLISTINDEX(N,3),1_GLSIZEI) IPFLISTINDEX(N,3)=GLGENLISTS(1) !## start new drawing list for current object CALL GLNEWLIST(IPFLISTINDEX(N,3),GL_COMPILE) CALL WGLTEXTORIENTATION(ALIGNLEFT) X =IPF(IIPF)%XYZ(1,I) Y =IPF(IIPF)%XYZ(2,I) Z =IPF(IIPF)%XYZ(3,I) 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)%ICLIP=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(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(IPLOT,NINIFF) !VIEWDX,VIEWDY, ENDIF ENDDO IMOD3D_REDRAWIFF=.TRUE. CALL IMOD3D_ERROR('IMOD3D_REDRAWIFF') END FUNCTION IMOD3D_REDRAWIFF !###====================================================================== SUBROUTINE IMOD3D_DRAWIFF(IPLOT,NINIFF) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(INOUT) :: NINIFF 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 YCOR(1)=IFF(1)%Y XCOR(2)=IFF(2)%X YCOR(2)=IFF(2)%Y 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(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)%ICLIP=1 GENPLOT(NGENLIST)%ITHICKNESS=1 GENPLOT(NGENLIST)%ICOLOR=WRGB(0,0,0) GENPLOT(NGENLIST)%L3D=.FALSE. GENPLOT(NGENLIST)%ISHADE=1 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(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(FNAME,L3D,NINGEN) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(INOUT) :: NINGEN LOGICAL,INTENT(OUT) :: L3D LOGICAL :: LS3D CHARACTER(LEN=*),INTENT(IN) :: FNAME CHARACTER(LEN=256) :: LINE INTEGER :: IU,IOS,I,J,NX REAL(KIND=GLFLOAT),DIMENSION(:),POINTER :: X,Y,Z,X_DUM,Y_DUM,Z_DUM ! !## 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) CALL GLCOLORMATERIAL(GL_FRONT_AND_BACK,GL_AMBIENT_AND_DIFFUSE) CALL GLENABLE(GL_COLOR_MATERIAL) L3D=.TRUE.; LS3D=.FALSE.; 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+100),Y_DUM(NX+100),Z_DUM(NX+100)) DO J=1,NX; X_DUM(J)=X(J); Y_DUM(J)=Y(J); Z_DUM(J)=Z(J); ENDDO DEALLOCATE(X,Y,Z); X=>X_DUM; Y=>Y_DUM; Z=>Z_DUM; NX=NX+100 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); IF(IOS.NE.0)EXIT L3D=.FALSE.; LS3D=.FALSE. ENDIF ENDDO NX=I-1; IF(NX.LT.2)CYCLE !## determine polygon - all coordinates are equal (xyz) between first and last mentioned and NXY equals 5 IF(NX.EQ.5.AND. & UTL_EQUALS_REAL(X(NX),X(1)).AND. & UTL_EQUALS_REAL(Y(NX),Y(1)).AND. & UTL_EQUALS_REAL(Z(NX),Z(1)))THEN 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 !.AND. & ! (Z(1).GT.BOT%Z.OR.Z(2).GT.BOT%Z).AND.(Z(1).LT.TOP%Z.OR.Z(2).LT.TOP%Z))THEN NINGEN =NINGEN+1 !## top CALL GLBEGIN(GL_QUADS) CALL IMOD3D_SETNORMALVECTOR((/X(1),Y(1),Z(1)/),(/X(2),Y(2),Z(2)/),(/X(3),Y(3),Z(3)/)) CALL GLVERTEX3F(X(1),Y(1),Z(1)) CALL GLVERTEX3F(X(2),Y(2),Z(2)) CALL GLVERTEX3F(X(3),Y(3),Z(3)) CALL GLVERTEX3F(X(4),Y(4),Z(4)) CALL GLEND() IF(LS3D)THEN TOP%Z=MAX(TOP%Z,Z(1),Z(3)) BOT%Z=MIN(BOT%Z,Z(1),Z(3)) ENDIF ENDIF ELSE !## 2d-lines 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) ; YCOR(1)=Y(I) ! XCOR(2)=X(I+1); YCOR(2)=Y(I+1) CALL GLVERTEX3F(X(I) ,Y(I),0.0_GLFLOAT) CALL GLVERTEX3F(X(I+1),Y(I+1),0.0_GLFLOAT) ! CALL IMOD3D_LINE(XCOR,YCOR,(/0.0_GLFLOAT,0.0_GLFLOAT/)) ENDIF ENDDO CALL GLEND() ENDIF ENDDO DEALLOCATE(X,Y,Z); CLOSE(IU) CALL GLDISABLE(GL_COLOR_MATERIAL) CALL GLENDLIST() CALL WINDOWOUTSTATUSBAR(2,'') CALL IMOD3D_ERROR('IMOD3D_DRAWGEN') END SUBROUTINE IMOD3D_DRAWGEN !###====================================================================== LOGICAL FUNCTION IMOD3D_SOL_ADD() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,II REAL :: XTOL CHARACTER(LEN=52) :: CDATE INTEGER,DIMENSION(:,:),ALLOCATABLE :: ICOMBINE IMOD3D_SOL_ADD=.FALSE. !## vertical tolerance (from menu) CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB6) CALL WDIALOGGETREAL(IDF_REAL1,XTOL) IF(XTOL.LE.0.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'It is not allowed to enter a Tolerance of '//TRIM(RTOS(XTOL,'G',5)),'Error') RETURN ENDIF !## maximum sample points for a fench-diagram (from menu) MXSAMPLING=1000 !## not synchronizing of fench-diagram necessary ICCOL=0 !## copy dimensions for profile-tool MXNIDF=NIDFLIST !## all idf in new-list storing idf-configuration ALLOCATE(PROFIDF(MXNIDF)); DO I=1,SIZE(PROFIDF); CALL IDFNULLIFY(PROFIDF(I)%IDF); ENDDO DO I=1,NIDFLIST IF(.NOT.IDFREAD(PROFIDF(I)%IDF,IDFPLOT(I)%FNAME,0))EXIT PROFIDF(I)%PRFTYPE=1 ENDDO ALLOCATE(SERIE(MXNIDF)) DO I=1,MXNIDF NULLIFY(SERIE(I)%X); NULLIFY(SERIE(I)%Y) ALLOCATE(SERIE(I)%X(MXSERIE),SERIE(I)%Y(MXSERIE)) END DO !## start drawing a cross-section without those extra lines ALLOCATE(IEXIST(MXNIDF+1) ,ICLEAN(MXNIDF+1) ,IACT(MXNIDF+1), & XEXCLUDE(MXNIDF+1),ISEL_IDF(MXNIDF+1),DTOL(MXNIDF+1)) !## common settings DTOL=XTOL; IEXIST=1; IACT=1; ICLEAN=1 DO I=1,MXNIDF; XEXCLUDE(I+1)=PROFIDF(I)%IDF%NODATA; ENDDO DO I=1,MXNIDF; ISEL_IDF(I+1)=I; ENDDO !## set colour - equal to the colour assigned to the IDF files ... CALL SOLID_INITSLD(1) CALL SOLID_INITSLDPOINTER(1,MXNIDF) DO I=1,SIZE(SLD); DO J=1,MXNIDF SLD(I)%INTCLR(J)=IDFPLOT(J)%ICOLOR ENDDO; ENDDO !## create drawing list NTBSOL=MXNIDF ALLOCATE(ICOMBINE(NTBSOL,3)); ICOMBINE=0 DO J=1,NTBSOL !-1 !## not to be processed IF(IDFPLOT(J)%ICUBE.EQ.5)CYCLE !## voxel, use colouring only IF(IDFPLOT(J)%ICUBE.EQ.3)THEN ICOMBINE(J,3)=J ELSE ICOMBINE(J,1)=J ICOMBINE(J,2)=IDFPLOT(J)%ICOMBINE IF(IDFPLOT(J)%IDFLEGEND.NE.J)ICOMBINE(J,3)=IDFPLOT(J)%IDFLEGEND ENDIF ENDDO DO II=1,SIZE(NXYZCROSS) IF(NXYZCROSS(II).LE.0)CYCLE !## number of coordinates NXY=NXYZCROSS(II) IF(ASSOCIATED(XY))DEALLOCATE(XY); ALLOCATE(XY(2,NXY)); XY=0.0 !## set coordinates of cross-section DO I=1,NXYZCROSS(II) XY(1,I)=XYZCROSS(I,II)%X XY(2,I)=XYZCROSS(I,II)%Y ENDDO !## compute profile through idf in 3D CALL PROFILE_COMPUTEPLOT() ! !## start drawing a cross-section without those extra lines ! ALLOCATE(IEXIST(MXNIDF+1) ,ICLEAN(MXNIDF+1) ,IACT(MXNIDF+1), & ! XEXCLUDE(MXNIDF+1),ISEL_IDF(MXNIDF+1),DTOL(MXNIDF+1)) ! !## common settings ! DTOL=XTOL; IEXIST=1; IACT=1; ICLEAN=1 ! DO I=1,MXNIDF; XEXCLUDE(I+1)=PROFIDF(I)%IDF%NODATA; ENDDO ! DO I=1,MXNIDF; ISEL_IDF(I+1)=I; ENDDO ISPF=NSOLLIST+1 ! NTBSOL=MXNIDF NSPF=ISPF !## add memory for cross-section CALL SOLID_PROFILEADD_SPFMEMORY(1.0,-1.0) !## fill in cross-section - including nodata CALL SOLID_PROFILEFITDRILL_CALC() ! !## set colour - equal to the colour assigned to the IDF files ... ! CALL SOLID_INITSLD(1) ! CALL SOLID_INITSLDPOINTER(1,MXNIDF) ! DO I=1,SIZE(SLD); DO J=1,MXNIDF ! SLD(I)%INTCLR(J)=IDFPLOT(J)%ICOLOR ! ENDDO; ENDDO ! !## create drawing list ! ALLOCATE(ICOMBINE(NTBSOL,3)); ICOMBINE=0 ! DO J=1,NTBSOL !-1 ! !## not to be processed ! IF(IDFPLOT(J)%ICUBE.EQ.5)CYCLE ! !## voxel, use colouring only ! IF(IDFPLOT(J)%ICUBE.EQ.3)THEN ! ICOMBINE(J,3)=J ! ELSE ! ICOMBINE(J,1)=J ! ICOMBINE(J,2)=IDFPLOT(J)%ICOMBINE ! IF(IDFPLOT(J)%IDFLEGEND.NE.J)ICOMBINE(J,3)=IDFPLOT(J)%IDFLEGEND ! ENDIF ! ENDDO NSOLLIST=ISPF; CALL IMOD3D_SOL_DRAWINGLIST(ISPF,NSOLLIST,ICOMBINE) !## add cross-section name WRITE(CDATE,'(I8,A)') UTL_GETCURRENTDATE(),'_'//TRIM(UTL_GETCURRENTTIME()) SPF(ISPF)%FNAME='Cross-Section_'//TRIM(CDATE) !## replace ":"-signs DO IF(INDEX(SPF(ISPF)%FNAME,':').GT.0)THEN SPF(ISPF)%FNAME=UTL_SUBST(SPF(ISPF)%FNAME,':','_') ELSE EXIT ENDIF ENDDO !## activate last created SOLPLOT(NSPF)%ISEL=1 SOLPLOT(NSPF)%ICLIP=1 ENDDO !## deallocate memory needed to compute profile CALL PROFILE_DEALLOCATE(); DEALLOCATE(ISEL_IDF,IACT,DTOL,ICLEAN,XEXCLUDE,IEXIST) CALL SOLIDDEALLOCATESLD() !## add to the existing menu CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB6) CALL WDIALOGPUTMENU(IDF_MENU1,SPF%FNAME,NSPF,SOLPLOT%ISEL) CALL WDIALOGPUTCHECKBOX(IDF_CHECK4,SOLPLOT(NSPF)%ICLIP) IF(NSPF.GE.SIZE(SOLPLOT))THEN CALL WDIALOGFIELDSTATE(ID_NEW,2) CALL WDIALOGFIELDSTATE(ID_LOAD,2) ENDIF IF(NSPF.GT.0)THEN CALL WDIALOGFIELDSTATE(ID_DELETE,1) CALL WDIALOGFIELDSTATE(ID_SAVEAS,1) ENDIF !## remove the drawn cross-section NXYZCROSS=0 IMOD3D_SOL_ADD=.TRUE. END FUNCTION IMOD3D_SOL_ADD !###====================================================================== LOGICAL FUNCTION IMOD3D_SOL_DELETE() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,N IMOD3D_SOL_DELETE=.FALSE. CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB6) N=NSPF; IF(.NOT.SOLID_PROFILEDELETE(ID_D3DSETTINGS_TAB6,SOLPLOT%ISEL))RETURN !## shift drawing list indices NSOLLIST=0; DO I=1,N !## remove drawing list IF(SOLPLOT(I)%ISEL.EQ.1)THEN DO J=1,2 ! DO J=1,3 IF(SOLLISTINDEX(I,J).NE.0)THEN IF(GLISLIST(SOLLISTINDEX(I,J)))CALL GLDELETELISTS(SOLLISTINDEX(I,J),1_GLSIZEI) SOLLISTINDEX(I,J)=0_GLUINT ENDIF ENDDO CYCLE ENDIF NSOLLIST=NSOLLIST+1 DO J=1,2; SOLLISTINDEX(NSOLLIST,J)=SOLLISTINDEX(I,J); ENDDO ! DO J=1,3; SOLLISTINDEX(NSOLLIST,J)=SOLLISTINDEX(I,J); ENDDO SOLPLOT(NSOLLIST)=SOLPLOT(I) ENDDO ! !## delete drawinglist not active anymore ! DO I=NSOLLIST+1,SIZE(SOLPLOT) ! DO J=1,2; SOLLISTINDEX(NSOLLIST,J)=SOLLISTINDEX(I,J); ENDDO ! ENDDO ! !## reshuffle remaining rawinglists ! NSOLLIST=0; DO I=1,SIZE(SOLPLOT) ! IF(SOLPLOT(I)%ISEL.EQ.1)CYCLE ! NSOLLIST=NSOLLIST+1 ! DO J=1,2; SOLLISTINDEX(NSOLLIST,J)=SOLLISTINDEX(I,J); ENDDO ! SOLPLOT(NSOLLIST)=SOLPLOT(I) ! ENDDO ! NSPF=NSOLLIST !## add to the existing menu CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB6) IF(NSPF.LT.SIZE(SOLPLOT))THEN CALL WDIALOGFIELDSTATE(ID_NEW,1) CALL WDIALOGFIELDSTATE(ID_LOAD,1) ENDIF IF(NSPF.GT.0)THEN CALL WDIALOGPUTMENU(IDF_MENU1,SPF%FNAME,NSPF,SOLPLOT%ISEL) ELSE CALL WDIALOGCLEARFIELD(IDF_MENU1) ENDIF CALL WDIALOGFIELDSTATE(ID_DELETE,0) CALL WDIALOGFIELDSTATE(ID_SAVEAS,0) IMOD3D_SOL_DELETE=.TRUE. END FUNCTION IMOD3D_SOL_DELETE !###====================================================================== SUBROUTINE IMOD3D_SOL_SAVE() !###====================================================================== IMPLICIT NONE INTEGER :: I CHARACTER(LEN=256) :: DIR DIR=TRIM(PREFVAL(1))//'\TMP\' DO I=1,SIZE(SOLPLOT) IF(SOLPLOT(I)%ISEL.EQ.1)THEN IF(.NOT.SOLIDOPENSPF(I,'W',DIR))RETURN ENDIF ENDDO CALL WMESSAGEBOX(OKONLY,INFORMATIONICON,COMMONOK,'The selected fence diagrams are saved in the folder:'//CHAR(13)// & TRIM(DIR),'Information') END SUBROUTINE IMOD3D_SOL_SAVE !###====================================================================== SUBROUTINE IMOD3D_SPF_LOAD() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,K,NF,II,N,M CHARACTER(LEN=10000) :: FNAME,FLIST CHARACTER(LEN=256),ALLOCATABLE,DIMENSION(:) :: FNAMES INTEGER,DIMENSION(:,:),ALLOCATABLE :: ICOMBINE IF(.NOT.UTL_WSELECTFILE('Load iMOD Solid Profile File (*.spf)|*.spf|', & LOADDIALOG+MUSTEXIST+PROMPTON+DIRCHANGE+MULTIFILE,FNAME,& 'Load iMOD Solid Profile File (*.spf)'))RETURN K=INDEX(FNAME,CHAR(0)) IF(K.GT.0)THEN FLIST=FNAME NF=0 I=K+1 DO J=INDEX(FLIST(I:),CHAR(0)) NF=NF+1 IF(J.EQ.0)EXIT I=I+J END DO ELSE NF=1 ENDIF ALLOCATE(FNAMES(NF)) DO II=1,NF !## construct new name in multi-file selection mode IF(NF.GT.1)THEN I=INDEX(FLIST,CHAR(0))+1 DO K=1,II-1 J=INDEX(FLIST(I:),CHAR(0)) I=I+J END DO J=INDEX(FLIST(I:),CHAR(0)) K=INDEX(FLIST,CHAR(0))-1 IF(J.EQ.0)THEN FNAMES(II)=FLIST(:K)//'\'//FLIST(I:) ELSE J=J+I FNAMES(II)=FLIST(:K)//'\'//FLIST(I:J-1) ENDIF J=INDEXNOCASE(FNAMES(II),CHAR(0),.TRUE.) IF(J.GT.0)FNAMES(II)=FNAMES(II)(:J-1) ELSE FNAMES(II)=FNAME ENDIF CALL IUPPERCASE(FNAMES(II)) ENDDO N=SIZE(SPF) M=MIN(N,NSPF+NF) !## read maximal cross-section which is possible J=0 DO I=NSPF+1,M !## read cross-section information J=J+1 SPF(I)%FNAME=FNAMES(J)(:INDEX(FNAMES(J),'.',.TRUE.)-1) IF(.NOT.SOLIDOPENSPF(I,'R',''))EXIT SOLPLOT(I)%ISEL=1 SOLPLOT(I)%ICLIP=1 !## create drawing list N=SIZE(SPF(I)%PROF); ALLOCATE(ICOMBINE(N,3)); ICOMBINE=0 DO K=1,N ICOMBINE(K,1)=K ICOMBINE(K,2)=MIN(K+1,N) !## colour ! ICOMBINE(J,3)=... ENDDO !## create drawing list CALL IMOD3D_SOL_DRAWINGLIST(I,I,ICOMBINE) DEALLOCATE(ICOMBINE) END DO DEALLOCATE(FNAMES) !## new number of cross-sections NSPF=I-1 NSOLLIST=NSPF ! !## deallocate memory needed to compute profile ! CALL PROFILE_DEALLOCATE(); DEALLOCATE(ISEL_IDF,IACT,DTOL,ICLEAN,XEXCLUDE,IEXIST) ! CALL SOLIDDEALLOCATESLD() !## add to the existing menu CALL WDIALOGSELECT(ID_D3DSETTINGS_TAB6) CALL WDIALOGPUTMENU(IDF_MENU1,SPF%FNAME,NSPF,SOLPLOT%ISEL) CALL WDIALOGPUTCHECKBOX(IDF_CHECK4,SOLPLOT(NSPF)%ICLIP) IF(NSPF.GE.SIZE(SOLPLOT))THEN CALL WDIALOGFIELDSTATE(ID_NEW,2) CALL WDIALOGFIELDSTATE(ID_LOAD,2) ENDIF IF(NSPF.GT.0)THEN CALL WDIALOGFIELDSTATE(ID_DELETE,1) CALL WDIALOGFIELDSTATE(ID_SAVEAS,1) ENDIF END SUBROUTINE IMOD3D_SPF_LOAD !###====================================================================== LOGICAL FUNCTION IMOD3D_SOL() !###====================================================================== IMPLICIT NONE INTEGER :: I,J,N INTEGER,DIMENSION(:,:),ALLOCATABLE :: ICOMBINE IMOD3D_SOL=.TRUE. !## solid active, although loaded in memory (could be) IF(ISOLID_3D.EQ.0)RETURN IF(NSOLLIST.EQ.0)RETURN IMOD3D_SOL=.FALSE. !## get display-list pointers SOLLISTINDEX=0 !## process each spf-(file) NSOLLIST=0 DO I=1,NSPF NSOLLIST=NSOLLIST+1 N=SIZE(SPF(I)%PROF); ALLOCATE(ICOMBINE(N,3)); ICOMBINE=0 DO J=1,N-1 ICOMBINE(J,1)=J ICOMBINE(J,2)=J+1 ICOMBINE(J,3)=0 ENDDO CALL IMOD3D_SOL_DRAWINGLIST(I,NSOLLIST,ICOMBINE) DEALLOCATE(ICOMBINE) ENDDO CALL WINDOWOUTSTATUSBAR(2,'') !## read, process and stick bitmaps to cross-sections IMOD3D_SOL=IMOD3D_SOL_BMP() !## read background again if this has been updated IREADBMP=0 CALL IMOD3D_ERROR('IMOD3D_SOL') END FUNCTION IMOD3D_SOL !###====================================================================== SUBROUTINE IMOD3D_SOL_DRAWINGLIST(I,ISOL,ICOMBINE) !###====================================================================== IMPLICIT NONE INTEGER,INTENT(IN) :: ISOL,I INTEGER,INTENT(IN),DIMENSION(:,:) :: ICOMBINE REAL(KIND=GLFLOAT) :: DXX,DYY,GX,GY,GZ,DXY INTEGER :: J,K,II,JJ,KK,JPROF,IPOS,N,I1,I2,IICLR INTEGER,DIMENSION(3) :: IPROF 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 !## list index for SOLLISTINDEX(ISOL,1)=GLGENLISTS(1) !## start new drawing list CALL GLNEWLIST(SOLLISTINDEX(ISOL,1),GL_COMPILE) !## process each cross-section (nidf) --- two-by-two DO JPROF=1,SIZE(SPF(I)%PROF) !## first interval IPROF(1)=ICOMBINE(JPROF,1) IF(IPROF(1).NE.0)THEN IF(SPF(I)%PROF(IPROF(1))%NPOS.LE.0)IPROF(1)=0 ENDIF !## second interval IPROF(2)=ICOMBINE(JPROF,2) IF(IPROF(2).NE.0)THEN IF(SPF(I)%PROF(IPROF(2))%NPOS.LE.0)IPROF(2)=0 ENDIF !## use other interface if one of the two is not defined IF(IPROF(1).EQ.0)IPROF(1)=IPROF(2) IF(IPROF(2).EQ.0)IPROF(2)=IPROF(1) !## colouring in intermediate profile IPROF(3)=ICOMBINE(JPROF,3) IF(IPROF(3).NE.0)THEN IF(SPF(I)%PROF(IPROF(3))%NPOS.LE.0)IPROF(3)=0 ENDIF !## skip this one IF(SUM(IPROF).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=0 IF(IPROF(1).GT.0)N=N+SPF(I)%PROF(IPROF(1))%NPOS IF(IPROF(2).GT.0)N=N+SPF(I)%PROF(IPROF(2))%NPOS IF(IPROF(3).GT.0)N=N+SPF(I)%PROF(IPROF(3))%NPOS N=N+SPF(I)%NXY-2 !## allocate enough memory to add intermediate places N=N*2 ALLOCATE(XT(N),ZT(N,3)) XT=0.0 ZT=NODATA_Z IPOS=0 II =0 DO KK=1,3 II=II+1 K=IPROF(KK); IF(K.EQ.0)CYCLE !## 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) IF(IPROF(1).GT.0)ZT(IPOS,1)=NODATA_Z !## to be filled in later IF(IPROF(2).GT.0)ZT(IPOS,2)=NODATA_Z !## to be filled in later IF(IPROF(3).GT.0)ZT(IPOS,3)=NODATA_Z !## to be filled in later ENDDO N=IPOS CALL SORTEM(1,N,XT,3,ZT(:,1),ZT(:,2),ZT(:,3),(/0.0/),(/0.0/),(/0.0/),(/0.0/)) !## fill first and last DO K=1,3 !## skip missing interfaces IF(IPROF(K).EQ.0)CYCLE 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,3 !## skip missing interfaces IF(IPROF(K).EQ.0)CYCLE 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) IF(IPROF(1).GT.0)ZT(K,1)=ZT(J,1) IF(IPROF(2).GT.0)ZT(K,2)=ZT(J,2) IF(IPROF(3).GT.0)ZT(K,3)=ZT(J,3) 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) IF(IPROF(1).NE.0)THEN Z(2)=ZT(1,1) ELSE Z(2)=IDFPLOT(IPROF(3))%ZMAX ENDIF !## ulc X(2)=X(1) Y(2)=Y(1) IF(IPROF(2).NE.0)THEN Z(1)=ZT(1,2) ELSE Z(1)=IDFPLOT(IPROF(3))%ZMIN ENDIF !## 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)) IF(IPROF(1).NE.0)THEN Z(3)=ZT(IPOS,1) ELSE Z(3)=IDFPLOT(IPROF(3))%ZMAX ENDIF !## lrc X(4)=X(3) Y(4)=Y(3) IF(IPROF(2).NE.0)THEN Z(4)=ZT(IPOS,2) ELSE Z(4)=IDFPLOT(IPROF(3))%ZMIN ENDIF !## 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); YCOR(1)=Y(1) XCOR(2)=XCOR(1); YCOR(2)=YCOR(1) XCOR(3)=X(3); YCOR(3)=Y(3) XCOR(4)=XCOR(3); YCOR(4)=YCOR(3) !## colour by voxel value IF(IPROF(3).GT.0)THEN IICLR=UTL_IDFGETCLASS(IDFPLOT(IPROF(3))%LEG,ZT(IPOS,3)) ELSE !## get color for z-mean between two segments IF(ALLOCATED(SLD))THEN IICLR=SLD(1)%INTCLR(IPROF(1)) ELSE IICLR=SPF(I)%PROF(JPROF)%ICLR ENDIF ENDIF !## skip white ... IF(IICLR.NE.WRGB(255,255,255))THEN 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() !## begin OpenGL-LINES CALL IMOD3D_SETCOLOR(WRGB(10,10,10)) 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() ENDIF !## draw bottom (only for the last) IF(JPROF.EQ.SIZE(SPF(I)%PROF)-1)THEN !## show interfaces IF(IPROF(3).GT.0)THEN IICLR=UTL_IDFGETCLASS(IDFPLOT(IPROF(3))%LEG,ZT(IPOS,3)) ELSE IICLR=SPF(I)%PROF(IPROF(2))%ICLR ENDIF !## skip white ... IF(IICLR.NE.WRGB(255,255,255))THEN CALL IMOD3D_SETCOLOR(IICLR) CALL GLBEGIN(GL_LINES) CALL GLVERTEX3F(XCOR(1),YCOR(1),Z(1)) CALL GLVERTEX3F(XCOR(4),YCOR(4),Z(4)) CALL GLEND() ENDIF 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() END SUBROUTINE IMOD3D_SOL_DRAWINGLIST !###====================================================================== LOGICAL FUNCTION IMOD3D_SOL_BMP() !###====================================================================== IMPLICIT NONE REAL(KIND=GLFLOAT) :: X1,X2,Y1,Y2,XT1,XT2,YT1,YT2,BZ1,BZ2,BX1,BX2,BDX,BDY,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 ! SOLLISTINDEX(NSOLLIST,3)=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) ! SOLLISTINDEX(NSOLLIST,3)=GLGENLISTS(1) ! IF(SOLLISTINDEX(NSOLLIST,3).NE.0)CALL GLDELETELISTS(SOLLISTINDEX(NSOLLIST,3),1_GLSIZEI) IF(SOLLISTINDEX(NSOLLIST,2).NE.0)CALL GLDELETELISTS(SOLLISTINDEX(NSOLLIST,2),1_GLSIZEI) !## start new drawing list ! CALL GLNEWLIST(SOLLISTINDEX(NSOLLIST,3),GL_COMPILE) 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 BDY=BZ2-BZ1 !## error in image position - skip it IF(BDX.LE.0.0.OR.BDY.GE.0.0)THEN CALL WMESSAGEBOX(OKONLY,EXCLAMATIONICON,COMMONOK,'iMOD cannot display '//TRIM(SPF(I)%PBITMAP%FNAME)//CHAR(13)// & 'Probably you have misplaced the image','Error') CYCLE ENDIF 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) X2=SPF(I)%X(J) Y1=SPF(I)%Y(J-1) Y2=SPF(I)%Y(J) !## 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(LCAP)THEN ! CLPPLOT(NCLPLIST)%ICAP=1 ! ELSE CLPPLOT(NCLPLIST)%ICAP=0 ! ENDIF IF(CLIPNAME.EQ.'')THEN CLPPLOT(NCLPLIST)%FNAME='ClippingPlane '//TRIM(ITOS(NCLPLIST)) ELSE CLPPLOT(NCLPLIST)%FNAME=TRIM(CLIPNAME) ENDIF !## 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/) !## position of the clipping plane CLPPLOT(I)%X=XPOS CLPPLOT(I)%Y=YPOS CLPPLOT(I)%Z=ZPOS CLPPLOT(I)%ITHICKNESS=3 CLPPLOT(I)%ICOLOR=COLOUR_RANDOM() CLPPLOT(I)%IPOS=0 IF(I.LT.N)NCLPLIST=MAX(0,NCLPLIST-1) END SUBROUTINE IMOD3D_CLP_ADD !###====================================================================== 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 END MODULE MOD_3D_ENGINE