diff --git a/.gitignore b/.gitignore index b06e864..4f45054 100644 --- a/.gitignore +++ b/.gitignore @@ -210,3 +210,45 @@ FakesAssemblies/ GeneratedArtifacts/ _Pvt_Extensions/ ModelManifest.xml +/RMAGEN/INSTALL/RMAGEN82B_files +/RMAGEN/INSTALL/RMAGEN82E_files +/RMAGEN/INSTALL/RMAGEN82H_files +/RMAGEN/INSTALL/RMAGEN82J_files +/RMAGEN/INSTALL/RMAGEN82K_files +/RMAGEN/INSTALL/Rmagen82_files +/RMAGEN/INSTALL/RMAGEN83a_files +/RMAGEN/INSTALL/RMAGEN83b_files +/RMAGEN/INSTALL/src81b +/RMAGEN/INSTALL/src81n +/RMAGEN/INSTALL/src82 +/RMAGEN/INSTALL/src82b +/RMAGEN/INSTALL/srcrmagen82e +/RMAGEN/INSTALL +/RMAGEN/RMAGENV82C.EXE.exe.intermediate.manifest +/RMAGEN/RMAGENV82C.EXE.exe.embed.manifest.res +/RMAGEN/RMAGENV82C.EXE.exe.embed.manifest.rc +/RMAGEN/RMAGENV82C.EXE.exe.embed.manifest +/RMAGEN/RMAGENV82B.EXE.exe.intermediate.manifest +/RMAGEN/RMAGENV82B.EXE.exe.embed.manifest.res +/RMAGEN/RMAGENV82B.EXE.exe.embed.manifest.rc +/RMAGEN/RMAGENV82B.EXE.exe.embed.manifest +/RMAGEN/RMAGEN.vfproj +/RMAGEN/RMAGEN.u2d +/RMAGEN/messgen.out +/RMAGEN/ELT.BAK +/src/srcrmagen82k.zip +/src/srcrmagen82k-old.zip +/src/srcrmagen82J.zip +/gettingbedcontoursand views.avi +/FILES2.xlsx +/FILES1.xlsx +/addng more network and joining.avi +/src/TEMP.rc +/src/RMAGENV83A.rc +/src/RMAGENV83.rc +/src/rmagenv82.res +/src/RMAGENV82.rc +/src/rmagenv81.res +/src/RMAGENV81.rc +/src/RMAGENV83I.zip +/src/RMAGENV83c.res diff --git a/RMAGEN.sln b/RMAGEN.sln new file mode 100644 index 0000000..166a944 --- /dev/null +++ b/RMAGEN.sln @@ -0,0 +1,20 @@ + +Microsoft Visual Studio Solution File, Format Version 11.00 +# Visual Studio 2010 +Project("{6989167D-11E4-40FE-8C1A-2192A86A7E90}") = "RMAGEN", "RMAGEN\RMAGEN.vfproj", "{411AA8E0-6D33-4DC0-97E4-AEC394012B4C}" +EndProject +Global + GlobalSection(SolutionConfigurationPlatforms) = preSolution + Debug|Win32 = Debug|Win32 + Release|Win32 = Release|Win32 + EndGlobalSection + GlobalSection(ProjectConfigurationPlatforms) = postSolution + {411AA8E0-6D33-4DC0-97E4-AEC394012B4C}.Debug|Win32.ActiveCfg = Debug|Win32 + {411AA8E0-6D33-4DC0-97E4-AEC394012B4C}.Debug|Win32.Build.0 = Debug|Win32 + {411AA8E0-6D33-4DC0-97E4-AEC394012B4C}.Release|Win32.ActiveCfg = Release|Win32 + {411AA8E0-6D33-4DC0-97E4-AEC394012B4C}.Release|Win32.Build.0 = Release|Win32 + EndGlobalSection + GlobalSection(SolutionProperties) = preSolution + HideSolutionNode = FALSE + EndGlobalSection +EndGlobal diff --git a/src/ADD999.F90 b/src/ADD999.F90 new file mode 100644 index 0000000..905ee4e --- /dev/null +++ b/src/ADD999.F90 @@ -0,0 +1,487 @@ + SUBROUTINE ADD999(ISWT9,NELC) + +! add type 999 elements to all 1-d elements + + USE BLK1MOD + USE BLK2MOD + COMMON ISEQ(4000,10),LIST1(2000),LIST2(2000) + INCLUDE 'TXFRM.COM' + + IF(.NOT. ALLOCATED(IUSEDM)) THEN + ALLOCATE (IUSEDM(MAXE)) + IUSEDM=0 + ENDIF + IF(.NOT. ALLOCATED(HSET)) THEN + ISWTH=0 + ELSE + ISWTH=1 + ENDIF +! loop on elements looking for 1-d + PI2=3.14159/2. + + NTEMPLC=0 + NCM=MAXECON + NCMi=MAXECON + IUSEDM=0 + DO N=1,NE + IF(IMAT(N) .NE. 999) CYCLE + CALL KCON(0) + GO TO 75 + ENDDO + GO TO 90 + 75 CONTINUE + DO N=1,NE + IF(IMAT(N) .EQ. 999) THEN + DO J=1,NCMi + IF(NCORN(ICON(N,J)) .EQ. 3) THEN + M=ICON(N,J) + IF(NOP(M,1) .EQ. NOP(N,1) .AND. NOP(M,3) .EQ. NOP(N,3) .OR.& + NOP(M,1) .EQ. NOP(N,3) .AND. NOP(M,3) .EQ. NOP(N,1)) THEN + IUSEDM(ICON(N,J))=1 + GO TO 80 + ENDIF + ENDIF + ENDDO + ENDIF + 80 CONTINUE + ENDDO +90 n=1 + ICL=0 + do k=1,10 + iseqp=2000 + iseqm=2000 + do ns=n,ne + if(imat(ns) .eq. 0 .or. (imat(ns) .ge. 900 .and. imat(ns) .lt. 2000)) cycle + if(ncorn(ns) .gt. 3) cycle + if(IUSEDM(ns) .eq. 1) cycle +! renumber elements to put them in order + N=NS + N1=NOP(NS,1) + N3=NOP(NS,3) + iseq(iseqp,k)=ns + IUSEDM(n)=1 + go to 100 + enddo + go to 200 + 100 continue +! search for element connected to n1 or n3 + do m=1,ne + if(imat(ns) .eq. 0 .or. (imat(ns) .ge. 900 .and. imat(ns) .lt. 2000)) cycle +! if(imat(m) .gt. 0 .and. imat(m) .lt. 900) then + if(ncorn(m) .lt. 4) then + if(IUSEDM(m) .eq. 1) cycle + if(nop(m,1) .eq. n3) then + IUSEDM(m)=1 + iseqp=iseqp+1 + iseq(iseqp,k)=m +! n1=nop(m,1) + n3=nop(m,3) + n=m + go to 100 + elseif(nop(m,1) .eq. n1) then + nop(m,1)=nop(m,3) + nop(m,3)=n1 + IUSEDM(m)=1 + iseqm=iseqm-1 + iseq(iseqm,k)=m + n1=nop(m,1) +! n3=nop(m,3) + n=m + go to 100 + elseif(nop(m,3) .eq. n1) then + IUSEDM(m)=1 + iseqm=iseqm-1 + iseq(iseqm,k)=m + n1=nop(m,1) +! n3=nop(m,3) + n=m + go to 100 + elseif(nop(m,3) .eq. n3) then + nop(m,3)=nop(m,1) + nop(m,1)=n3 + IUSEDM(m)=1 + iseqp=iseqp+1 + iseq(iseqp,k)=m +! n1=nop(m,1) + n3=nop(m,3) + n=m + go to 100 + endif + endif +! endif + enddo + enddo +200 continue +! do n=990,1005 +! write(150,*) n,(iseq(n,m),m=1,5) +! enddo + NETEMP=NE + + do k=1,10 + nss=0 + do ns=1,4000 + if(iseq(ns,k) .eq. 0) cycle + n=iseq(ns,k) + N1=NOP(N,1) + N2=NOP(N,2) + N3=NOP(N,3) + + if(nss .eq. 0) then + ELDIR=ATAN2(YUSR(N3)-YUSR(N1),XUSR(N3)-XUSR(N1)) + CALL GETNOD(J1) + INEW(J1) = 1 + INSKP(J1) =0 + IF(ISWTH .EQ. 1) THEN + WD(J1)=HSET(N1,3) + ELSE + WD(J1)=-9999. + ENDIF + CALL GETNOD(J2) + INEW(J2) = 1 + INSKP(J2) =0 + IF(ISWTH .EQ. 1) THEN + WD(J2)=HSET(N1,1) + ELSE + WD(J2)=-9999. + ENDIF + +! XUSR(J1)=+WIDTHD(N1)/2.*COS(ELDIR-PI2)+XUSR(N1) +! YUSR(J1)=+WIDTHD(N1)/2.*SIN(ELDIR-PI2)+YUSR(N1) + XUSR(J1)=+WIDTH(N1)/2.*COS(ELDIR-PI2)+XUSR(N1) + YUSR(J1)=+WIDTH(N1)/2.*SIN(ELDIR-PI2)+YUSR(N1) + CORD(J1,1)=(XUSR(J1)+XS)/TXSCAL + CORD(J1,2)=(YUSR(J1)+YS)/TXSCAL + IF(ISWT9 .EQ. 2) THEN + WD(J1)=WD(N1) + ENDIF + nnn=iseq(ns+1,k) + if(nnn .eq. 0) then + ELDIR=ATAN2(YUSR(N3)-YUSR(N1),XUSR(N3)-XUSR(N1)) + else + n4=nop(nnn,3) + ELDIR=ATAN2(YUSR(N4)-YUSR(N1),XUSR(N4)-XUSR(N1)) + endif +! XUSR(J2)=+WIDTHD(N1)/2.*COS(ELDIR+PI2)+XUSR(N1) +! YUSR(J2)=+WIDTHD(N1)/2.*SIN(ELDIR+PI2)+YUSR(N1) + XUSR(J2)=+WIDTH(N1)/2.*COS(ELDIR+PI2)+XUSR(N1) + YUSR(J2)=+WIDTH(N1)/2.*SIN(ELDIR+PI2)+YUSR(N1) + CORD(J2,1)=(XUSR(J2)+XS)/TXSCAL + CORD(J2,2)=(YUSR(J2)+YS)/TXSCAL + IF(ISWT9 .EQ. 2) THEN + WD(J2)=WD(N1) + ENDIF + nss=1 + else + nnn=iseq(ns+1,k) + if(nnn .eq. 0) then + ELDIR=ATAN2(YUSR(N3)-YUSR(N1),XUSR(N3)-XUSR(N1)) + else + n4=nop(nnn,3) + ELDIR=ATAN2(YUSR(N4)-YUSR(N1),XUSR(N4)-XUSR(N1)) + endif + endif + N0=N1 +! get two node numbers and store in ntempc + CALL GETNOD(J3) + INEW(J3) = 1 + INSKP(J3) =0 + IF(ISWTH .EQ. 1) THEN + WD(J3)=HSET(N3,3) + ELSE + WD(J3)=-9999. + ENDIF + CALL GETNOD(J4) + INEW(J4) = 1 + INSKP(J4) =0 + IF(ISWTH .EQ. 1) THEN + WD(J4)=HSET(N3,1) + ELSE + WD(J4)=-9999. + ENDIF + IF(J4 .GT. NP) NP=J4 + nn= imat(n) + if(nn .gt. 1999) then +! XUSR(J3)=+WIDTHD(N3)/2.*COS(ELDIR-PI2)+XUSR(N3) +! YUSR(J3)=+WIDTHD(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3) +! XUSR(J4)=+WIDTHD(N3)/2.*COS(ELDIR+PI2)+XUSR(N3) +! YUSR(J4)=+WIDTHD(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3) + XUSR(J3)=+WIDTH(N3)/2.*COS(ELDIR-PI2)+XUSR(N3) + YUSR(J3)=+WIDTH(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3) + XUSR(J4)=+WIDTH(N3)/2.*COS(ELDIR+PI2)+XUSR(N3) + YUSR(J4)=+WIDTH(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3) + ELSEIF(KID(nn,1) .NE. 0) THEN + JR2=KID(IMAT(N),2) + JR1=KID(IMAT(N),3) + JR4=KID(IMAT(N),4) + JR3=KID(IMAT(N),5) + XUSR(J1)=XUSR(JR1) + YUSR(J1)=YUSR(JR1) + XUSR(J2)=XUSR(JR2) + YUSR(J2)=YUSR(JR2) + XUSR(J3)=XUSR(JR3) + YUSR(J3)=YUSR(JR3) + XUSR(J4)=XUSR(JR4) + YUSR(J4)=YUSR(JR4) +! nop(n-1,7)=jr3 + ELSE +! XUSR(J3)=+WIDTHD(N3)/2.*COS(ELDIR-PI2)+XUSR(N3) +! YUSR(J3)=+WIDTHD(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3) +! XUSR(J4)=+WIDTHD(N3)/2.*COS(ELDIR+PI2)+XUSR(N3) +! YUSR(J4)=+WIDTHD(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3) + XUSR(J3)=+WIDTH(N3)/2.*COS(ELDIR-PI2)+XUSR(N3) + YUSR(J3)=+WIDTH(N3)/2.*SIN(ELDIR-PI2)+YUSR(N3) + XUSR(J4)=+WIDTH(N3)/2.*COS(ELDIR+PI2)+XUSR(N3) + YUSR(J4)=+WIDTH(N3)/2.*SIN(ELDIR+PI2)+YUSR(N3) + ENDIF + + CORD(J3,1)=(XUSR(J3)+XS)/TXSCAL + CORD(J3,2)=(YUSR(J3)+YS)/TXSCAL + CORD(J4,1)=(XUSR(J4)+XS)/TXSCAL + CORD(J4,2)=(YUSR(J4)+YS)/TXSCAL + IF(ISWT9 .EQ. 2) THEN + WD(J3)=WD(N3) + WD(J4)=WD(N3) + ENDIF +350 CONTINUE + CALL GETELM(I3) +! RECORD IN LIST FOR FUTURE + ICL=ICL+1 + LIST1(ICL)=I3 + LIST2(I3)=icl + NCORN(I3) = 8 + IESKP(I3) = 0 + NOP(I3,1)=J1 + NOP(I3,3)=J3 + NOP(I3,5)=N3 + NOP(I3,6)=N2 + NOP(I3,7)=N1 + IF(ISWT9 .EQ. 0) THEN + IMAT(I3)=999 + ELSE + IMAT(I3)=IMAT(N) + ENDIF + CALL GETELM(I4) +! RECORD IN LIST FOR FUTURE + ICL=ICL+1 + LIST1(ICL)=I4 + LIST2(I4)=-icl + NCORN(I4) = 8 + IESKP(I4) = 0 + IF(I4 .GT. NETEMP) NETEMP=I4 + IMAT(I4)=999 + NOP(I4,1)=J4 + NOP(I4,2)= 0 + NOP(I4,3)=J2 + NOP(I4,5)=N1 + NOP(I4,6)=N2 + NOP(I4,7)=N3 + IF(ISWT9 .EQ. 0) THEN + IMAT(I4)=999 + ELSE + IMAT(I4)=IMAT(N) + CALL DELTEL(N) + ENDIF + J2=J4 + J1=J3 + ENDDO + enddo + NE=NETEMP + ICLM=ICL + NELCT=2 +400 CONTINUE + CALL FILM(1) + call KCON(0) + + do n=1,ne + + if(imat(n) .eq. 2000) then + nm=nop(n,4) + if(necon(nm,1) .eq. n) then + nat=necon(nm,2) + else + nat=necon(nm,1) + endif + if(list2(n) .gt. 0) then + nm=nop(n,4) + if(necon(nm,1) .eq. n) then + nat=necon(nm,2) + else + nat=necon(nm,1) + endif + n1=nop(nat,7) + n2=nop(nat,1) + j1=nop(n,5) + j2=nop(n,7) + j3=nop(n,1) + j4=nop(n,3) + else + nm=nop(n,8) + if(necon(nm,1) .eq. n) then + nat=necon(nm,2) + else + nat=necon(nm,1) + endif + n1=nop(nat,3) + n2=nop(nat,5) + j1=nop(n,1) + j2=nop(n,3) + j3=nop(n,5) + j4=nop(n,7) + endif + xusr(j1)=xusr(n1) + yusr(j1)=yusr(n1) + cord(j1,1)=cord(n1,1) + cord(j1,2)=cord(n1,2) + xusr(j2)=xusr(n1) + yusr(j2)=yusr(n1) + cord(j2,1)=cord(n1,1) + cord(j2,2)=cord(n1,2) + xusr(j3)=xusr(n2) + yusr(j3)=yusr(n2) + cord(j3,1)=cord(n2,1) + cord(j3,2)=cord(n2,2) + xusr(j4)=xusr(n2) + yusr(j4)=yusr(n2) + cord(j4,1)=cord(n2,1) + cord(j4,2)=cord(n2,2) + elseif(imat(n) .eq. 2001) then + if(list2(n) .gt. 0) then + nm=nop(n,8) + if(necon(nm,1) .eq. n) then + nat=necon(nm,2) + else + nat=necon(nm,1) + endif + n1=nop(nat,5) + n2=nop(nat,3) + j1=nop(n,5) + j2=nop(n,7) + j3=nop(n,1) + j4=nop(n,3) + else + nm=nop(n,4) + if(necon(nm,1) .eq. n) then + nat=necon(nm,2) + else + nat=necon(nm,1) + endif + n1=nop(nat,1) + n2=nop(nat,7) + j1=nop(n,1) + j2=nop(n,3) + j3=nop(n,5) + j4=nop(n,7) + endif + xusr(j1)=xusr(n1) + yusr(j1)=yusr(n1) + cord(j1,1)=cord(n1,1) + cord(j1,2)=cord(n1,2) + xusr(j2)=xusr(n1) + yusr(j2)=yusr(n1) + cord(j2,1)=cord(n1,1) + cord(j2,2)=cord(n1,2) + xusr(j3)=xusr(n2) + yusr(j3)=yusr(n2) + cord(j3,1)=cord(n2,1) + cord(j3,2)=cord(n2,2) + xusr(j4)=xusr(n2) + yusr(j4)=yusr(n2) + cord(j4,1)=cord(n2,1) + cord(j4,2)=cord(n2,2) + endif + enddo + 450 CALL DELETM(0) + IF(NELC .LE. NELCT) THEN + do n=1,ne + if(imat(n) .gt. 1000) then + CALL DELTEL(n) + endif + enddo + RETURN + ENDIF + DO I=1,ICLM,2 + NEL=LIST1(I) + IF(IMAT(NEL) .EQ. 0) CYCLE + IF(I .GT. 1) THEN + J3=J4 + ELSE + CALL GETNOD(J3) + XUSR(J3)=(XUSR(NOP(NEL,7))+XUSR(NOP(NEL,1)))/2. + YUSR(J3)=(YUSR(NOP(NEL,7))+YUSR(NOP(NEL,1)))/2. + CORD(J3,1)=(XUSR(J3)+XS)/TXSCAL + CORD(J3,2)=(YUSR(J3)+YS)/TXSCAL + WD(J3)=(WD(NOP(NEL,1))+WD(NOP(NEL,7)))/2. + INEW(J3) = 1 + INSKP(J3) =0 + IF(J3 .GT. NP) NP=J3 + ENDIF + + CALL GETNOD(J4) + XUSR(J4)=(XUSR(NOP(NEL,3))+XUSR(NOP(NEL,5)))/2. + YUSR(J4)=(YUSR(NOP(NEL,3))+YUSR(NOP(NEL,5)))/2. + CORD(J4,1)=(XUSR(J4)+XS)/TXSCAL + CORD(J4,2)=(YUSR(J4)+YS)/TXSCAL + WD(J4)=(WD(NOP(NEL,3))+WD(NOP(NEL,5)))/2. + INEW(J4) = 1 + INSKP(J4) =0 + IF(J4 .GT. NP) NP=J4 + CALL GETELM(I3) +! RECORD IN LIST FOR FUTURE + ICL=ICL+1 + LIST1(ICL)=I3 + NCORN(I3) = 8 + IESKP(I3) = 0 + IF(I3 .GT. NETEMP) NETEMP=I3 + NOP(I3,5)=J4 + NOP(I3,7)=J3 + NOP(I3,1)=NOP(NEL,1) + NOP(I3,3)=NOP(NEL,3) + NOP(NEL,1)=J3 + NOP(NEL,3)=J4 + IMAT(I3)=IMAT(NEL) + + NEL=LIST1(I+1) + IF(IMAT(NEL) .EQ. 0) CYCLE + IF(I .GT. 1) THEN + J3A=J4A + ELSE + CALL GETNOD(J3A) + XUSR(J3A)=(XUSR(NOP(NEL,3))+XUSR(NOP(NEL,5)))/2. + YUSR(J3A)=(YUSR(NOP(NEL,3))+YUSR(NOP(NEL,5)))/2. + CORD(J3A,1)=(XUSR(J3A)+XS)/TXSCAL + CORD(J3A,2)=(YUSR(J3A)+YS)/TXSCAL + WD(J3A)=(WD(NOP(NEL,3))+WD(NOP(NEL,5)))/2. + INEW(J3A) = 1 + INSKP(J3A) =0 + IF(J3A .GT. NP) NP=J3A + ENDIF + CALL GETNOD(J4A) + XUSR(J4A)=(XUSR(NOP(NEL,1))+XUSR(NOP(NEL,7)))/2. + YUSR(J4A)=(YUSR(NOP(NEL,1))+YUSR(NOP(NEL,7)))/2. + CORD(J4A,1)=(XUSR(J4A)+XS)/TXSCAL + CORD(J4A,2)=(YUSR(J4A)+YS)/TXSCAL + WD(J4A)=(WD(NOP(NEL,1))+WD(NOP(NEL,7)))/2. + INEW(J4A) = 1 + INSKP(J4A) =0 + IF(J4A .GT. NP) NP=J4A + CALL GETELM(I3) +! RECORD IN LIST FOR FUTURE + ICL=ICL+1 + LIST1(ICL)=I3 + NCORN(I3) = 8 + IESKP(I3) = 0 + IF(I3 .GT. NETEMP) NETEMP=I3 + NOP(I3,1)=J4A + NOP(I3,3)=J3A + NOP(I3,5)=NOP(NEL,5) + NOP(I3,7)=NOP(NEL,7) + NOP(NEL,5)=J3A + NOP(NEL,7)=J4A + IMAT(I3)=IMAT(NEL) + + ENDDO + NELCT=NELCT*2 + GO TO 450 +! RETURN + END + \ No newline at end of file diff --git a/src/ADDLAY.F90 b/src/ADDLAY.F90 new file mode 100644 index 0000000..fad4044 --- /dev/null +++ b/src/ADDLAY.F90 @@ -0,0 +1,343 @@ +! Last change: IPK 12 Jan 98 11:21 am +! +!**************************************************************** +! + SUBROUTINE ADDLAY +! +! Add nodal layer data and write to file +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + CHARACTER*1 IFLAG,ANSW(10) + REAL RLAY(9) + DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/ +! + 4 CONTINUE + + call openlay + + NHTP=0 + NBRR=0 + NMESS=45 + CALL HEDR + NMESS=4 + xprt=3.2 +! + IPOS=ILAYTP + call GETLAYDAT(NLAY,ipos,RLAY) + ILAYTP=IPOS +! call getint(nlay) +! READ(*,*) NLAY +! +! Write out current layers +! + 7 CONTINUE + NHTP=0 + NMESS=0 + NBRR=4 + CALL HEDR + CALL RCYAN + DO 10 K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .GT. 5) THEN + DO 9 N=1,NCORN(K),2 + J=NOP(K,N) + FPN = LAY(J) + X = CORD(J,1) + Y = CORD(J,2) - .11 + IF(X .GT. 0. .AND. X .LT. HSIZE .AND. & + & Y .GT. 0. .AND. Y .LT. 7.0) THEN + CALL NUMBR(X,Y,0.2,FPN,0.0,-1) + ENDIF + 9 CONTINUE + ENDIF + ENDIF + 10 END DO + CALL RBLUE +! +! Input new layers +! + 5 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + + IF(IRMAIN .EQ. 1) THEN + REWIND 102 + DO J=1,NP + IF(LAY(J) .GT. -9998) THEN + if(ILAYTP .eq. 1) then + write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + 6000 format('LD2 ',2i8,9F8.2) + else + write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + 6001 format('LD3 ',2i8,9F8.2) + endif + ENDIF + ENDDO + RETURN + ENDIF +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + IF(IFLAG .EQ. 'n') THEN + GO TO 4 + ELSEIF(IFLAG .EQ. 'q') THEN + NLAYD=1 + REWIND 102 + DO J=1,NP + IF(LAY(J) .GT. -9998) THEN + if(ILAYTP .eq. 1) then + write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + else + write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + endif + ENDIF + ENDDO + CALL WRTOUT(0) + RETURN + ENDIF +! + XPRT=XPRT+0.5 + IF(XPRT .GT. HSIZE) XPRT=0. + FPN= INODE + CALL NUMBR(XPRT,7.20,0.2,FPN,0.0,-1) + IF (IFLAG .EQ. 'c') THEN + LAY(INODE) = NLAY + DO J=1,7 + WTLAY(INODE,J)=RLAY(J) + ENDDO + FPN = NLAY + X = CORD(INODE,1) + Y = CORD(INODE,2) + .11 + CALL RRED + CALL NUMBR(X,Y,0.2,FPN,0.0,-1) + CALL RBLUE +! + ELSEIF(IFLAG .EQ. 'a') THEN + DO 100 K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .GT. 5) THEN + DO 90 N=1,NCORN(K),2 + J=NOP(K,N) + DO I=1,7 + WTLAY(J,I)=RLAY(I) + ENDDO + LAY(J)=NLAY + FPN=NLAY + X = CORD(J,1) + Y = CORD(J,2) + .11 + IF(X .GT. 0. .AND. X .LT. HSIZE .AND. & + & Y .GT. 0. .AND. Y .LT. 7.0) THEN + CALL RRED + CALL NUMBR(X,Y,0.2,FPN,0.0,-1) + CALL RBLUE + ENDIF + 90 CONTINUE + ENDIF + ENDIF + 100 CONTINUE + NLAYD=1 + CALL WRTOUT(0) + ELSEIF(IFLAG .EQ. 'f') THEN + DO 120 K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .GT. 5) THEN + DO 110 N=1,NCORN(K),2 + J=NOP(K,N) + IF(LAY(J) .EQ. -9999.) THEN + LAY(J)=NLAY + DO I=1,7 + WTLAY(J,I)=RLAY(I) + ENDDO + FPN=NLAY + X = CORD(J,1) + Y = CORD(J,2) + .11 + IF(X .GT. 0. .AND. X .LT. HSIZE .AND. & + & Y .GT. 0. .AND. Y .LT. 7.0) THEN + CALL RRED + CALL NUMBR(X,Y,0.2,FPN,0.0,-1) + CALL RBLUE + ENDIF + ENDIF + 110 CONTINUE + ENDIF + ENDIF + 120 CONTINUE + NLAYD=1 + CALL WRTOUT(0) +! + ELSE +!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7) + ENDIF +! + GOTO 5 +! + END + subroutine openlay + use winteracter + + implicit none + + include 'd.inc' + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB + LOGICAL :: OPENED + INTEGER :: IERR + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INQUIRE(102, OPENED=OPENED) + if(.not. opened) then + CALL WSelectFile(ID_STRING9,SaveDialog+PromptOn,FNAME,'Save layer file') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='lay' + CALL ADDSUB(FNAME,SUB) + open(102,file=fname, form='formatted', status='unknown') + ENDIF + endif + + RETURN + END + + SUBROUTINE RDLAYER +! +! Read nodal layer data +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*8 ID + CHARACTER*72 DLIN + DIMENSION WTTEMP(7) + +! + 100 CONTINUE + READ(103,7000,END=400) ID,DLIN + 7000 FORMAT(A8,A72) + IF(ID(1:2) .EQ. 'LD') THEN + READ(DLIN,5000) NODNUM,NLAYD,(WTTEMP(I),I=1,7) + 5000 FORMAT(2I8,7F8.0) + IF(NODNUM .EQ. 0) THEN + DO N=0,NP + LAY(N)=NLAYD + IF(NLAYD .GT. 0) THEN + DO I=0,NLAYD + WTLAY(N,I)=WTTEMP(I) + ENDDO + ENDIF + ENDDO + ELSEIF(NODNUM .GT. 0) THEN + LAY(NODNUM)=NLAYD + IF(NLAYD .GT. 0) THEN + DO I=1,NLAYD + WTLAY(NODNUM,I)=WTTEMP(I) + ENDDO + ENDIF + + ENDIF + ENDIF + IF(ID(3:3) .EQ. '2') THEN + ILAYTP=1 + ELSE + ILAYTP=0 + ENDIF + GO TO 100 + 400 CONTINUE + DO K=1,NE + IF(IMAT(K) .GT. 0) THEN + NCN=NCORN(K) + IF(NCN .EQ. 5) NCN=3 + DO N=1,NCORN(K),2 + J=NOP(K,N) + FPN=LAY(N) + X = CORD(J,1) + Y = CORD(J,2) + .11 + IF(X .GT. 0. .AND. X .LT. HSIZE .AND. & + & Y .GT. 0. .AND. Y .LT. 7.0) THEN + CALL RRED + CALL NUMBR(X,Y,0.2,FPN,0.0,-1) + CALL RBLUE + ENDIF + ENDDO + ENDIF + ENDDO + RETURN + END + + SUBROUTINE WRTLAYER + use winteracter + +! +! Read nodal layer data +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*8 ID + CHARACTER*72 DLIN + DIMENSION WTTEMP(7) + LOGICAL :: OPENED + include 'd.inc' + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INQUIRE(102, OPENED=OPENED) + if(.not. opened) then + CALL WSelectFile(ID_STRING9,SaveDialog+PromptOn,FNAME,'Save layer file') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='lay' + CALL ADDSUB(FNAME,SUB) + open(102,file=fname, form='formatted', status='unknown') + ENDIF + else + rewind 102 + endif + + DO J=0,NP + IF(LAY(J) .GT. -9998) THEN + if(j .gt. 0) then + if(lay(j) .ne. lay(0)) then + go to 300 + else + do i=1,lay(j) + if(wtlay(j,i) .ne. wtlay(0,i)) then + go to 300 + endif + enddo + endif + go to 500 + 300 continue + if(ILAYTP .eq. 1) then + write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + 6000 format('LD2 ',2i8,9F8.2) + else + write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + 6001 format('LD3 ',2i8,9F8.2) + endif + else + if(ILAYTP .eq. 1) then + write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + else + write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + endif + endif + ENDIF + 500 CONTINUE + ENDDO + RETURN + END diff --git a/src/ADDQUAD.F90 b/src/ADDQUAD.F90 new file mode 100644 index 0000000..a273dae --- /dev/null +++ b/src/ADDQUAD.F90 @@ -0,0 +1,192 @@ + SUBROUTINE ADDQUAD + +! Subroutine to add a quadrilateral block + + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + + INCLUDE 'TXFRM.COM' + + CHARACTER*1 IFLAG + + DATA N1,N2,N3,N4/1,1,1,1/ + +! Initiliaze list etc + + NHTPSV=NHTP + NMESSSV=NMESS + NBRRSV=NBRR + + DO N=1,NP + LIST(N)=0 + ENDDO +! Get the points that form the triangle + + 4 CONTINUE + NHTP=0 + NMESS=8 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ALX=XTEMP + ALY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + CALL WRTOUT(0) + RETURN + elseif(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + ENDIF +! +! Exit input +! +! 9 CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + NBRR=0 + CALL HEDR + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ARX=XTEMP + ARY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + CALL PLOTT(ALX,ALY,3) + CALL PLOTT(XTEMP,YTEMP,2) + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + BRX=XTEMP + BRY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + 16 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + BLX=XTEMP + BLY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + 20 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + CALL PLOTT(ALX,ALY,2) + +! Get the number of element information + + CALL PANELQUAD(N1,N2,N3,N4) + +! Get number For 1 and 3 and 2 and 4 + + NMID1=(N1+N3)/2 + NMID2=(N2+N4)/2 + +! Form the new nodes + + CALL DEFNOD(ALX,ALY) + CALL DEFNOD(ARX,ARY) + CALL DEFNOD(BRX,BRY) + CALL DEFNOD(BLX,BLY) + +! Now work on sides + + DO N=1,N1-1 + RATIO=FLOAT(N)/FLOAT(N1) + X1=ALX+RATIO*(ARX-ALX) + Y1=ALY+RATIO*(ARY-ALY) + CALL DEFNOD(X1,Y1) + ENDDO + DO N=1,N2-1 + RATIO=FLOAT(N)/FLOAT(N2) + X1=ARX+RATIO*(BRX-ARX) + Y1=ARY+RATIO*(BRY-ARY) + CALL DEFNOD(X1,Y1) + ENDDO + DO N=1,N3-1 + RATIO=FLOAT(N)/FLOAT(N3) + X1=BRX+RATIO*(BLX-BRX) + Y1=BRY+RATIO*(BLY-BRY) + CALL DEFNOD(X1,Y1) + ENDDO + DO N=1,N4-1 + RATIO=FLOAT(N)/FLOAT(N4) + X1=BLX+RATIO*(ALX-BLX) + Y1=BLY+RATIO*(ALY-BLY) + CALL DEFNOD(X1,Y1) + ENDDO + CALL FRMNODQ(ALX,ALY,ARX,ARY,BRX,BRY,BLX,BLY,NMID1,NMID2) + +! Form triangles for the added nodes + + CALL DELN2(NP,1) + + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + + RETURN + END + + SUBROUTINE PANELQUAD(N1,N2,N3,N4) + + use winteracter + + implicit none + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3,N4,IERR +! real :: + character*3 :: sub + + call wdialogload(IDD_QUAD) + ierr=infoerror(1) + + CALL WDialogPutInteger(idf_integer1,n1) + CALL WDialogPutInteger(idf_integer2,n2) + CALL WDialogPutInteger(idf_integer3,n3) + CALL WDialogPutInteger(idf_integer4,n4) + + + CALL WDialogSelect(IDD_QUAD) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(idf_integer1,n1) + CALL WDialogGetInteger(idf_integer2,n2) + CALL WDialogGetInteger(idf_integer3,n3) + CALL WDialogGetInteger(idf_integer4,n4) + + + ENDIF + RETURN + END diff --git a/src/ADDTRIANG.F90 b/src/ADDTRIANG.F90 new file mode 100644 index 0000000..9694a10 --- /dev/null +++ b/src/ADDTRIANG.F90 @@ -0,0 +1,191 @@ + SUBROUTINE ADDTRIANG + +! Subroutine to add a triangular block + + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + + INCLUDE 'TXFRM.COM' + + CHARACTER*1 IFLAG + + DATA N1,N2,N3/1,1,1/ + +! Initiliaze list etc + + NHTPSV=NHTP + NMESSSV=NMESS + NBRRSV=NBRR + + DO N=1,NP + LIST(N)=0 + ENDDO +! Get the points that form the triangle + + 4 CONTINUE + NHTP=0 + NMESS=8 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ALX=XTEMP + ALY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + CALL WRTOUT(0) + RETURN + elseif(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + ENDIF +! +! Exit input +! +! 9 CALL PLOTT(ALX,ALY,3) +! CALL PLOTT(ALX,ALY,2) + NBRR=0 + CALL HEDR + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ARX=XTEMP + ARY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! +! 12 CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(ALX,ALY,3) + CALL PLOTT(XTEMP,YTEMP,2) + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + BRX=XTEMP + BRY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + 16 CONTINUE + ! CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + CALL PLOTT(ALX,ALY,2) + +! Get the number of element information + + CALL PANELTRG(N1,N2,N3) + +! Get middle number + + IF(N1 .GT. N2) THEN + IF(N1 .GT. N3) THEN + IF(N2 .GT. N3) THEN + NMID=N2 + ELSE + NMID=N1 + ENDIF + ELSE + NMID=N1 + ENDIF + ELSE + IF(N2 .GT. N3) THEN + IF(N1 .GT. N3) THEN + NMID=N1 + ELSE + NMID=N3 + ENDIF + ELSE + NMID=N2 + ENDIF + ENDIF + +! Form the new nodes + + CALL DEFNOD(ALX,ALY) + CALL DEFNOD(ARX,ARY) + CALL DEFNOD(BRX,BRY) + +! Now work on sides + + DO N=1,N1-1 + RATIO=FLOAT(N)/FLOAT(N1) + X1=ALX+RATIO*(ARX-ALX) + Y1=ALY+RATIO*(ARY-ALY) + CALL DEFNOD(X1,Y1) + ENDDO + DO N=1,N2-1 + RATIO=FLOAT(N)/FLOAT(N2) + X1=ARX+RATIO*(BRX-ARX) + Y1=ARY+RATIO*(BRY-ARY) + CALL DEFNOD(X1,Y1) + ENDDO + DO N=1,N3-1 + RATIO=FLOAT(N)/FLOAT(N3) + X1=BRX+RATIO*(ALX-BRX) + Y1=BRY+RATIO*(ALY-BRY) + CALL DEFNOD(X1,Y1) + ENDDO + CALL FRMNODT(ALX,ALY,ARX,ARY,BRX,BRY,NMID) + +! For triangles for the added nodes + + CALL DELN2(NP,1) + + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + + RETURN + END + + SUBROUTINE PANELTRG(N1,N2,N3) + + use winteracter + + implicit none + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3,IERR +! real :: + character*3 :: sub + + call wdialogload(IDD_TRIANG) + ierr=infoerror(1) + + CALL WDialogPutInteger(idf_integer1,n1) + CALL WDialogPutInteger(idf_integer2,n2) + CALL WDialogPutInteger(idf_integer3,n3) + + + CALL WDialogSelect(IDD_TRIANG) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(idf_integer1,n1) + CALL WDialogGetInteger(idf_integer2,n2) + CALL WDialogGetInteger(idf_integer3,n3) + + + ENDIF + RETURN + END diff --git a/src/ADDWID.F90 b/src/ADDWID.F90 new file mode 100644 index 0000000..abfd900 --- /dev/null +++ b/src/ADDWID.F90 @@ -0,0 +1,464 @@ +!IPK LAST UPDATE JULY 18 1998 MAJOR CHANGES +! Last change: IPK 12 Jan 98 11:22 am +!ipk jan98 delete old call to char(7) +!**************************************************************** +! + SUBROUTINE ADDWID +! +! Add nodal width data +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + CHARACTER*1 IFLAG,ANSW(10),ANSW1(10) + DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/ + DATA ANSW1/ 'w','1','2','d','e','s','b','z','r','q'/ +! + 4 CONTINUE + NHTP=13 + NMESS=0 + NBRR=0 +!ipk apr95 add call to flushwn + call flushwn + CALL HEDR + 102 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW1(IBOX) + ENDIF + IF(IFLAG .EQ. 'w') THEN +! +! get width +! + 104 continue + call plotot(1) + CALL RCYAN + DO K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .LT. 6) THEN + IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN + DO N=1,3,2 + J=NOP(K,N) + FPN = WIDTH(J) + X = CORD(J,1) + Y = CORD(J,2) - .11 + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + enddo + ENDIF + ENDIF + ENDIF + enddo + CALL RBLUE + nmess=45 + nhtp=0 + nbrr=4 + call flushwn + CALL HEDR + nmess=5 + xprt=3.2 + call getfpn(cwid) +! +! Input new widths +! + 105 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + IF(IFLAG .EQ. 'n') THEN + GO TO 104 + ELSEIF(IFLAG .EQ. 'q') THEN + CALL WRTOUT(0) + go to 4 + ENDIF + XPRT=XPRT+0.5 + IF(XPRT .GT. HSIZE) XPRT=0. + FPN= INODE + CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1) + IF (IFLAG .EQ. 'c') THEN + WIDTH(INODE) = CWID + FPN = WIDTH(INODE) + X = CORD(INODE,1) + Y = CORD(INODE,2) + .11 + CALL RRED + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + CALL RBLUE + endif + go to 105 + elseif(iflag .eq. '1') then +! +! get ss1 +! + 204 continue + call plotot(1) + CALL RCYAN + DO K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .LT. 6) THEN + IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN + DO N=1,3,2 + J=NOP(K,N) + FPN = ss1(J) + X = CORD(J,1) + Y = CORD(J,2) - .11 + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + enddo + ENDIF + ENDIF + ENDIF + enddo + CALL RBLUE + nmess=45 + nhtp=0 + nbrr=4 + call flushwn + CALL HEDR + nmess=22 + xprt=3.2 + call getfpn(ss1tp) +! +! Input new ss1 +! + 205 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + IF(IFLAG .EQ. 'n') THEN + GO TO 204 + ELSEIF(IFLAG .EQ. 'q') THEN + CALL WRTOUT(0) + go to 4 + ENDIF + XPRT=XPRT+0.5 + IF(XPRT .GT. HSIZE) XPRT=0. + FPN= INODE + CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1) + IF (IFLAG .EQ. 'c') THEN + SS1(INODE) = SS1TP + FPN = SS1TP + X = CORD(INODE,1) + Y = CORD(INODE,2) + .11 + CALL RRED + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + CALL RBLUE + endif + go to 205 + elseif(iflag .eq. '2') then +! +! get ss2 +! + 304 continue + call plotot(1) + CALL RCYAN + DO K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .LT. 6) THEN + IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN + DO N=1,3,2 + J=NOP(K,N) + FPN = ss2(J) + X = CORD(J,1) + Y = CORD(J,2) - .11 + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + enddo + ENDIF + ENDIF + ENDIF + enddo + CALL RBLUE + nmess=45 + nhtp=0 + nbrr=4 + call flushwn + CALL HEDR + nmess=23 + xprt=3.2 + call getfpn(ss2tp) +! +! Input new ss2 +! + 305 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + IF(IFLAG .EQ. 'n') THEN + GO TO 304 + ELSEIF(IFLAG .EQ. 'q') THEN + CALL WRTOUT(0) + go to 4 + ENDIF + XPRT=XPRT+0.5 + IF(XPRT .GT. HSIZE) XPRT=0. + FPN= INODE + CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1) + IF (IFLAG .EQ. 'c') THEN + SS2(INODE) = SS2TP + FPN = SS2TP + X = CORD(INODE,1) + Y = CORD(INODE,2) + .11 + CALL RRED + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + CALL RBLUE + endif + go to 305 + elseif(iflag .eq. 'd') then +! +! get storage width +! + 404 continue + call plotot(1) + CALL RCYAN + DO K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .LT. 6) THEN + IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN + DO N=1,3,2 + J=NOP(K,N) + FPN = wids(J) + X = CORD(J,1) + Y = CORD(J,2) - .11 + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + enddo + ENDIF + ENDIF + ENDIF + enddo + CALL RBLUE + nmess=45 + nhtp=0 + nbrr=4 + call flushwn + CALL HEDR + nmess=24 + xprt=3.2 + call getfpn(wids1tp) +! +! Input new storgae width +! + 405 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + IF(IFLAG .EQ. 'n') THEN + GO TO 404 + ELSEIF(IFLAG .EQ. 'q') THEN + CALL WRTOUT(0) + go to 4 + ENDIF + XPRT=XPRT+0.5 + IF(XPRT .GT. HSIZE) XPRT=0. + FPN= INODE + CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1) + IF (IFLAG .EQ. 'c') THEN + WIDS(INODE) = wids1TP + FPN = wids1TP + X = CORD(INODE,1) + Y = CORD(INODE,2) + .11 + CALL RRED + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + CALL RBLUE + endif + go to 405 + elseif(iflag .eq. 'e') then +! +! get storage elevation +! + 504 continue + call plotot(1) + CALL RCYAN + DO K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .LT. 6) THEN + IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN + DO N=1,3,2 + J=NOP(K,N) + FPN = widbs(J) + X = CORD(J,1) + Y = CORD(J,2) - .11 + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + enddo + ENDIF + ENDIF + ENDIF + enddo + CALL RBLUE + nmess=45 + nhtp=0 + nbrr=4 + call flushwn + CALL HEDR + nmess=39 + xprt=3.2 + call getfpn(widbs1tp) +! +! Input new storage elevations +! + 505 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + IF(IFLAG .EQ. 'n') THEN + GO TO 504 + ELSEIF(IFLAG .EQ. 'q') THEN + CALL WRTOUT(0) + go to 4 + ENDIF + XPRT=XPRT+0.5 + IF(XPRT .GT. HSIZE) XPRT=0. + FPN= INODE + CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1) + IF (IFLAG .EQ. 'c') THEN + WIDBS(INODE) = widbs1TP + FPN = widbs1tp + X = CORD(INODE,1) + Y = CORD(INODE,2) + .11 + CALL RRED + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + CALL RBLUE + endif + go to 505 + elseif(iflag .eq. 's') then +! +! get storage slopes +! + 604 continue + call plotot(1) + CALL RCYAN + DO K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .LT. 6) THEN + IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN + DO N=1,3,2 + J=NOP(K,N) + FPN = sso(J) + X = CORD(J,1) + Y = CORD(J,2) - .11 + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + enddo + ENDIF + ENDIF + ENDIF + enddo + CALL RBLUE + nmess=45 + nhtp=0 + nbrr=4 + call flushwn + CALL HEDR + nmess=40 + xprt=3.2 + call getfpn(widslp) +! +! Input new storage slopes +! + 605 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + IF(IFLAG .EQ. 'n') THEN + GO TO 604 + ELSEIF(IFLAG .EQ. 'q') THEN + CALL WRTOUT(0) + go to 4 + ENDIF + XPRT=XPRT+0.5 + IF(XPRT .GT. HSIZE) XPRT=0. + FPN= INODE + CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1) + IF (IFLAG .EQ. 'c') THEN + SSO(INODE) = widslp + FPN = widslp + X = CORD(INODE,1) + Y = CORD(INODE,2) + .11 + CALL RRED + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + CALL RBLUE + endif + go to 605 +!ipk mar02 +! +! get bed slopes +! + elseif(iflag .eq. 'b') then + 704 continue + call plotot(1) + CALL RCYAN + DO K=1,NE + IF(IMAT(K) .GT. 0) THEN + IF(NCORN(K) .LT. 6) THEN + IF(NCORN(K) .GT. 2 .AND. IMAT(K) .LT. 900) THEN + DO N=1,3,2 + J=NOP(K,N) + FPN = BS1(J) + X = CORD(J,1) + Y = CORD(J,2) - .11 + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + enddo + ENDIF + ENDIF + ENDIF + enddo + CALL RBLUE + nmess=45 + nhtp=0 + nbrr=4 + call flushwn + CALL HEDR + nmess=44 + xprt=3.2 + call getfpn(bedslp) +! +! Input new bed slopes +! + 705 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + IF(IFLAG .EQ. 'n') THEN + GO TO 704 + ELSEIF(IFLAG .EQ. 'q') THEN + CALL WRTOUT(0) + go to 4 + ENDIF + XPRT=XPRT+0.5 + IF(XPRT .GT. HSIZE) XPRT=0. + FPN= INODE + CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1) + IF (IFLAG .EQ. 'c') THEN + BS1(INODE) = bedslp + FPN = bedslp + X = CORD(INODE,1) + Y = CORD(INODE,2) + .11 + CALL RRED + CALL NUMBR(X,Y,0.20,FPN,0.0,-1) + CALL RBLUE + endif + go to 705 + + elseif(iflag .eq. 'q') then + return + endif + go to 4 + END diff --git a/src/AREA.F90 b/src/AREA.F90 new file mode 100644 index 0000000..2cbf190 --- /dev/null +++ b/src/AREA.F90 @@ -0,0 +1,457 @@ +!IPK LAST UPDATE JULY 7 2016 ADD TEST FOR ZERO WIDTH + SUBROUTINE CHKAREA + + USE WINTERACTER + USE BLK1MOD + include 'd.inc' +! INCLUDE 'BLK1.COM' + + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL + + dimension itran(0:16) + data itran/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/ + + DATA I1,I2,I3,I4/1,0,0,0/,EMAX/-1./ + + WRITE(90,*) 'GOING TO CHKOPT' + CALL GETCHOPT(I1,I2,I3,I4,EREF,WIDEL) + WRITE(90,*) I1 + IF(I1 .LT. 0) THEN + I1=1 + I2=0 + RETURN + ENDIF + IF(I1 .EQ. 1) THEN +! and see if all corner nodes exist +! +! Test for areas of each element +! + INEG = 0 +!IPK JUL16 + IERW=0 + DO 250 N=1,NE + IF(IMAT(N) .GT. 0 .AND. NCORN(N) .GT. 5) THEN + J1=NOP(N,1) + J2=NOP(N,3) + J3=NOP(N,5) + if(cord(j1,1) .lt. -1.e9 .or. cord(j2,1) .lt. -1.e9 .or. cord(j3,1) .lt. -1.e9) then + WRITE(90,*) ' NODE UNDEFINED FOR ELEMENT NUMBER',N + CALL DELTEL(N) + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Element removed','ELEMENT REMOVED') + GO TO 250 + ENDIF + AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- & + & (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2)) + IF(AREA .LT. 0.) THEN + WRITE(90,*) ' NEGATIVE AREA FOR ELEMENT NUMBER',N + INEG = 1 + GO TO 250 + ENDIF + IF(NCORN(N) .EQ. 8) THEN + J1=NOP(N,3) + J2=NOP(N,5) + J3=NOP(N,7) + if(cord(j1,1) .lt. -1.e9 .or. cord(j2,1) .lt. -1.e9 .or. cord(j3,1) .lt. -1.e9) then + WRITE(90,*) ' NODE UNDEFINED FOR ELEMENT NUMBER',N + CALL DELTEL(N) + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Element removed','ELEMENT REMOVED') + GO TO 250 + ENDIF + AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- & + & (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2)) + IF(AREA .LT. 0.) THEN + WRITE(90,*) ' NEGATIVE AREA FOR ELEMENT NUMBER',N + INEG = 1 + ENDIF + ENDIF +!IPK JUL16 ADD TEST FOR MISSING WIDTH + ELSEIF(IMAT(N) .GT. 0) THEN + IF(WIDTH(NOP(N,1)) .EQ. 0. .OR. WIDTH(NOP(N,3)) .EQ. 0) THEN + IF(IERW .EQ. 0) THEN + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Nodal width missing in 1-D element'//Char(13)//& + 'See file MESSGEN.OUT for details' ,'WARNING 1-D WIDTH MISSING') + write(90,6000) + write(90,6001) n,nop(n,1),width(nop(n,1)),nop(n,3),width(nop(n,3)) +6000 FORMAT(' NODAL WIDTH MISSING FOR 1-D ELEMENT'/' ELEMENT NODE1 WIDTH1 NODE2 WIDTH2') +6001 FORMAT(I8,2(I10,F10.2)) + IERW=1 + ELSE + write(90,6001) n,nop(n,1),width(nop(n,1)),nop(n,3),width(nop(n,3)) + ENDIF + ENDIF + ENDIF + 250 END DO + + IF(INEG .EQ. 1) THEN +!cipk aug00 + + Call WMessageBox(3,2,1,'Negative Areas have been found'//Char(13)//& + 'See file MESSGEN.OUT for details'//'Press YES to set positive',& + 'ERROR IN NETWORK AREAS!!') + + IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then +! +! Test for areas of each element +! + INEG=0 + DO 300 N=1,NE + IF(IMAT(N) .GT. 0 .AND. NCORN(N) .GT. 5) THEN + J1=NOP(N,1) + J2=NOP(N,3) + J3=NOP(N,5) + AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- & + & (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2)) + IF(AREA .LT. 0.) THEN + if(NCORN(N) .EQ. 6) THEN + JM12=NOP(N,2) + JM23=NOP(N,4) + JM31=NOP(N,6) + NOP(N,2)=JM31 + NOP(N,3)=J3 + NOP(N,4)=JM23 + NOP(N,5)=J2 + NOP(N,6)=JM12 + GO TO 300 + ELSEIF(NCORN(N) .EQ. 8) THEN + INEG=1 + ENDIF + ENDIF + IF(NCORN(N) .EQ. 8) THEN + J1=NOP(N,3) + J2=NOP(N,5) + J3=NOP(N,7) + AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- & + & (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2)) + IF(AREA .LT. 0.) THEN + IF(INEG .EQ. 1) THEN + J0=NOP(N,1) + JM01=NOP(N,2) + JM12=NOP(N,4) + JM23=NOP(N,6) + JM30=NOP(N,8) + NOP(N,2)=JM30 + NOP(N,3)=J3 + NOP(N,4)=JM23 + NOP(N,5)=J2 + NOP(N,6)=JM12 + NOP(N,7)=J1 + NOP(N,8)=JM01 + ELSE + WRITE(90,*) ' CROSS OVER NEGATIVE AREA FOR ELEMENT NUMBER',N + Call WMessageBox(3,2,1,'cross-over element diagonals have been found'//Char(13)//& + 'See file MESSGEN.OUT for details'//'Press YES to set delete',& + 'ERROR IN NETWORK AREAS!!') + IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then + CALL DELTEL(N) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + 300 END DO + ENDIF + ENDIF + ENDIF +! CARRY OUT TEST FOR ELEMENT ELEVATION DIFFERENCES + IF(I2 .EQ. 1) THEN + EMAX=0. + DO N=1,NE + EDIF(N)=0 + IF(IMAT(N) .LE. 0) GO TO 400 + IF(NCORN(N) .GT. 5) THEN + DO M=1,NCORN(N)-1,2 + DO MM=M,NCORN(N)-1,2 + EDIF(N)=MAX(ABS(WD(NOP(N,M))-WD(NOP(N,MM))),EDIF(N)) + ENDDO + ENDDO + ELSE + IF(I4 .EQ. 0) THEN + EDIF(N)=ABS(WD(NOP(N,3))-WD(NOP(N,1))) + ELSE + if(icrin .eq. 0) then + CALL WMessageBox(0, 4, 1,'Cross-section data not loaded '//CHAR(13)// & + 'Click OK start again','ERROR GETTING NO SECTION DATA') + RETURN + endif + N1=NOP(N,1) + N2=NOP(N,3) + BT1= & + CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ & + CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1) + BT2= & + CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ & + CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2) + H1=WIDEL-BT1 + H2=WIDEL-BT2 + IF(H1 .LT. 0. .OR. H2 .LT. 0.) THEN + CALL WMessageBox(1, 4, 1,'Depth negative '//CHAR(13)// & + 'Click OK to continue with depth=1.'//CHAR(13)//'Click Cancel to start again','ERROR GETTING SECTION DATA') + if(WInfoDialog(4) .eq. 0) then + RETURN + else + IF(H1 .LT. 0.) H1=1.0 + IF(H2 .LT. 0.) H2=1.0 + endif + ENDIF + CALL INTERPWLV(N1,H1,AR1,WR1,DWR1) + CALL INTERPWLV(N2,H2,AR2,WR2,DWR2) + IF(I4 .EQ. 1) THEN + EDIF(N)=ABS(WR1-WR2) + ELSE + EDIF(N)=ABS(AR1-AR2) + ENDIF + ENDIF + ENDIF + IF(EDIF(N) .GT. EMAX) EMAX=EDIF(N) + 400 CONTINUE + ENDDO + NUMV=11 + CONTUR(1)=0. + DO K=2,11 + CONTUR(K)=EMAX/10.+CONTUR(K-1) + ENDDO + + DO N=1,NE + IF(IMAT(N) .GT. 0) THEN + ICOL=EDIF(N)*10./EMAX+.999 + icll=itran(icol) + CALL FILLEMC(N,ICLL) + ENDIF + ENDDO + XLEG=8.8 + YLEG=7.4 + + CALL LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL) + + ENDIF + EDIF(0)=EMAX + CALL WMenuSetState(ID_SECGRP,ItemEnabled,1) + IF(I2 .EQ. 1) RETURN +! CARRY OUT TEST FOR ELEMENT NORMAILZED DEPTH DIFFERENCES + IF(I3 .EQ. 1) THEN + EMAX=0. + DO N=1,NE + EDIF(N)=0 + IF(IMAT(N) .LE. 0) GO TO 500 + IF(NCORN(N) .GT. 5) THEN + DO M=1,NCORN(N)-1,2 + DO MM=M,NCORN(N)-1,2 + D1=EREF-WD(NOP(N,M)) + D2=EREF-WD(NOP(N,MM)) + if(d1 .lt. 0.0) d1=0.0 + if(d2 .lt. 0.0) d2=0.0 + DMEAN=(D1+D2)/2. + if(DMEAN .LE. 1.) DMEAN=1.0 + EDIF(N)=MAX(ABS(D1-D2)/DMEAN,EDIF(N)) + ENDDO + ENDDO + ELSE + IF(I4 .EQ. 0) THEN + D1=EREF-WD(NOP(N,1)) + D2=EREF-WD(NOP(N,3)) + IF(D1 .LT. 0. .OR. D2 .LT. 0.) THEN + CALL WMessageBox(1, 4, 1,'Depth negative '//CHAR(13)// & + 'Click OK to continue with depth=1.'//CHAR(13)//'Click Cancel to start again','ERROR GETTING SECTION DATA') + if(WInfoDialog(4) .eq. 0) then + RETURN + else + IF(D1 .LT. 0.) D1=1.0 + IF(D2 .LT. 0.) D2=1.0 + endif + ENDIF + + DMEAN=(D1+D2)/2. + if(DMEAN .LE. 1.) DMEAN=1.0 + EDIF(N)=ABS(D1-D2)/DMEAN + ELSE + if(icrin .eq. 0) then + CALL WMessageBox(0, 4, 1,'Cross-section data not loaded '//CHAR(13)// & + 'Click OK start again','ERROR GETTING NO SECTION DATA') + RETURN + endif + N1=NOP(N,1) + N2=NOP(N,3) + BT1= & + CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ & + CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1) + BT2= & + CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ & + CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2) + H1=WIDEL-BT1 + H2=WIDEL-BT2 + IF(H1 .LT. 0. .OR. H2 .LT. 0.) THEN + CALL WMessageBox(1, 4, 1,'Depth negative '//CHAR(13)// & + 'Click OK to continue with depth=1.'//CHAR(13)//'Click Cancel to start again','ERROR GETTING SECTION DATA') + if(WInfoDialog(4) .eq. 0) then + RETURN + else + IF(H1 .LT. 0.) H1=1.0 + IF(H2 .LT. 0.) H2=1.0 + endif + ENDIF + CALL INTERPWLV(N1,H1,AR1,WR1,DWR1) + CALL INTERPWLV(N2,H2,AR2,WR2,DWR2) + IF(I4 .EQ. 1) THEN + EDIF(N)=ABS(WR1-WR2)*2./(WR1+WR2) + ELSE + EDIF(N)=ABS(AR1-AR2)*2./(AR1+AR2) + ENDIF + ENDIF + + ENDIF + IF(EDIF(N) .GT. EMAX) EMAX=EDIF(N) + 500 CONTINUE + ENDDO + NUMV=11 + CONTUR(1)=0. + DO K=2,11 + CONTUR(K)=EMAX/10.+CONTUR(K-1) + ENDDO + + DO N=1,NE + IF(IMAT(N) .GT. 0) THEN + ICOL=EDIF(N)*10./EMAX+.999 + icll=itran(icol) + CALL FILLEMC(N,ICLL) + ENDIF + ENDDO + XLEG=8.8 + YLEG=7.4 + + CALL LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL) + + ENDIF + EDIF(0)=EMAX + CALL WMenuSetState(ID_SECGRP,ItemEnabled,1) + FLUSH(90) + IF(I3 .EQ. 1) RETURN + + CALL PLOTOT(0) + CALL HEDR + RETURN + END + + + SUBROUTINE GETCHOPT(I1,I2,I3,I4,EREF,WIDEL) +! +! Generate continuity lines +! + + USE WINTERACTER + include 'd.inc' + SAVE + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: I1,I2,I3,I4,I4A,ITIME,IPOS + + REAL :: WIDEL + + REAL :: EREF + + data itime/0/ + + IF(ITIME .EQ. 0) THEN + EREF=0. + WIDEL=0. + itime=1. + I4=0 + ENDIF + + call wdialogload(IDD_CHKOPT) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_CHKOPT) + ierr=infoerror(1) + + I4A=I4 + IF(I4 .GT. 0) I4A=1 + call wdialogputCheckBox(idf_check1,I1) + call wdialogputCheckBox(idf_check2,I4A) + if(i2 .eq. 1) then + CALL WDialogPutRadioButton(IDF_RADIO1) + elseif(i3 .eq. 1) then + CALL WDialogPutRadioButton(IDF_RADIO2) + endif + CALL WDialogPutReal(IDF_REAL1,EREF) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialogGetCheckBox(idf_check1,I1) + call wdialogGetCheckBox(idf_check2,I4A) + call wdialogGetRadioButton(idf_radio1,IPOS) + IF(IPOS .EQ. 1) THEN + I2=1 + I3=0 + ELSEIF(IPOS .EQ. 2) THEN + I2=0 + I3=1 + ELSE + I2=0 + I3=0 + ENDIF + CALL WDialoggetReal(IDF_REAL1,EREF) + GO TO 100 + + ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + I1=-1 + I2=0 + I3=0 + WRITE(90,*) 'CANCEL',I1,I2,I3,I4A + return + ENDIF + + enddo + 100 CONTINUE + WRITE(90,*) 'IN CHKOPT',I1,I2,I3,I4A + + IF(I4A .NE. 0) THEN + call wdialogload(IDD_CHK1DOPT) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_CHK1DOPT) + ierr=infoerror(1) + + if(i4 .le. 1) then + CALL WDialogPutRadioButton(IDF_RADIO1) + elseif(i4 .eq. 2) then + CALL WDialogPutRadioButton(IDF_RADIO2) + endif + CALL WDialogPutReal(IDF_REAL1,WIDEL) + + CALL WDialogShow(-1,-1,0,Modal) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialogGetRadioButton(idf_radio1,I4) + CALL WDialogGetReal(IDF_REAL1,WIDEL) + + WRITE(90,*) 'OUT OF CHKOPT',I1,I2,I3,I4A + return + + ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + + I4=0 + I4A=0 + + ENDIF + + enddo + + ENDIF + WRITE(90,*) 'OUT OF CHKOPT',I1,I2,I3,I4A + return + end + \ No newline at end of file diff --git a/src/ASSIGNEQ.f90 b/src/ASSIGNEQ.f90 new file mode 100644 index 0000000..497f782 --- /dev/null +++ b/src/ASSIGNEQ.f90 @@ -0,0 +1,33 @@ + SUBROUTINE ASSIGNEQ + + USE BLK1MOD + USE BLKELTLD + COMMON XCEN(5000),YCEN(5000) + DIST(I,J)=(XYCEL(I,1)-XCEN(J))**2+(XYCEL(I,2)-YCEN(J))**2 + VOID=1.E20 + +! get centroids of mesh + XCEN=VOID + YCEN=VOID + DO J=1,NE + CALL GETXCL(J,XCJ,YCJ) + XCEN(J)=XCJ + YCEN(J)=YCJ + ENDDO + +! test for nearest centroid + DO I=1,NQHYD + NCLINE(I)=0 + DISTM=VOID + DO J=1,NE + IF(XCEN(J) .GE. VOID) CYCLE + IF(DIST(I,J) .LT. DISTM) THEN + DISTM=DIST(I,J) + NCLINE(I)=J + ENDIF + ENDDO + WRITE(103,6001) NCLINE(I),ILAYRE(1,NQHYD),HAE(1,I),(HDE(1,I,K),K=1,3) +6001 FORMAT('EFE',5X,2I8,7X,'1',F8.3,3F8.2,7X,'1') + ENDDO + RETURN + END \ No newline at end of file diff --git a/src/BFILES.I90 b/src/BFILES.I90 new file mode 100644 index 0000000..3e14d2f --- /dev/null +++ b/src/BFILES.I90 @@ -0,0 +1,9 @@ + INTEGER :: NBKFL,ISWBKFL,IACTVFIL,ITOTFIL,I3DVIEW,IRDONE + REAL :: BFMINMAX + CHARACTER(LEN=255) :: BFNAME,BFNAMR,FNAMKEP,DIRECT + CHARACTER(LEN=48) :: FNAMEDISP + COMMON /BFLSI/ NBKFL,ISWBKFL(10),I3DVIEW,IRDONE + COMMON /BFLSR/ BFMINMAX(10,4) + COMMON /BFLSC/ BFNAME(10),BFNAMR(10),FNAMKEP,DIRECT,FNAMEDISP + CHARACTER(LEN=255) :: FNAMEOUT + COMMON /RSTOR/ IACTVFIL,ITOTFIL,FNAMEOUT(10) diff --git a/src/BLK1 - Copy.f90 b/src/BLK1 - Copy.f90 new file mode 100644 index 0000000..211cf18 --- /dev/null +++ b/src/BLK1 - Copy.f90 @@ -0,0 +1,117 @@ + MODULE BLK1MOD + + INCLUDE 'PARAM.COM' +! BLK1 +!- + REAL HSIZE + COMMON /SSIZE/ HSIZE + + INTEGER MAXP,MAXE,MAXLIN,MAXSTO,MAXECON,MAXLN,MAELN + + + INTEGER*2 INSKP,IESKP,INEW,NCORN,IJUN,ISWTAGN,iswtintp +!IPK MAY02 INTEGER*2 NOP,IMAT,IEM,NEF,NEFLAG,LINTYP,LAY + INTEGER*2 IMAT,LINTYP,LAY + INTEGER*4 NOP,IEM,NEF,NEFLAG +! REAL*8 CORD,XUSR,YUSR,XC,YC,CMAP,XMAP,YMAP,pscale,xref,yref + REAL*8 CORD,XUSR,YUSR,XC,YC,pscale,xref,yref + + INTEGER*2 MSN + ALLOCATABLE MSN(:) + + + ALLOCATABLE CORD(:,:),XUSR(:),YUSR(:),XC(:),YC(:)& + ,NOP(:,:),IMAT(:),THTA(:),IMATL(:),CORDSN(:,:)& + ,WD(:) ,WD1(:),INSKP(:), IESKP(:),NCORN(:)& + ,WIDTH(:), SS1(:), SS2(:), WIDS(:)& + ,IJUN(:),INEW(:),IEM(:),LINTYP(:),NEFLAG(:),NEF(:,:),LAY(:),WTLAY(:,:)& + ,WIDBS(:),SSO(:),NODDEL(:),IELDEL(:)& + ,NOPSV(:,:),nefsv(:,:),IMATSV(:),LOCK(:),BS1(:),NKEY1(:),EDIF(:),ANGOP(:)& + ,IGRPNUM(:,:),MAXENT(:),IGRPSER(:),IUSEDM(:) + ALLOCATABLE NRF(:),AREF(:),LEVREM(:),TRANSEL(:),WLEN(:),WHGT(:) + INTEGER*8 MAXPTS + COMMON /BLK/ MAXPTS,PSCALE,xref,yref& + , IPNN, IPEN, XMIN, YMIN, XMAX, YMAX, NLAYD,ILAYTP& + ,VOID, VDX, XSCALE, YSCALE,AMAP,IRESTT& + ,NXPMIN, NYPMIN, NXPMAX, NYPMAX, IPP& + ,XPMIN, YPMIN, XPMAX, YPMAX, WDSCAL,IESW& + ,NPLAST,NELAST,NEFL,NENTRY,IECHG,ICHG& + ,IIN, IBAK, LUNIT,IGIN,IS11,IMP,IGFG,ISWAP,ITRIAN& + ,klint,jlint,lmpnam,IDELV,nmapf,NSIGF,NPUNDO,NEUNDO,nefsav,nesav& + ,xadded,yadded,icolsw,rad,colint,ielvsw,ISWTAGN,iswtintp,eref,igrp,igrpout,MAXIGRP +!IPK MAR02 ADD BS1 +!IPK FEB02 ADD LOCK +!IPK MAY01 ADD NODDEL AND IELDEL +!IPK JUL98 WIDBS AND SSO ADDED +!IPK JAN98 IDELV ADDED +!ipk feb94 line above added, two lines changed may 94 to add xref,yref +! 9 ,LINTYP(MAXLIN),NEFLAG(150),NEF(600,3),LAY(MAXP) +! +!IPK MAR04 INTEGER*2 ILIST,LLIST + INTEGER*4 ILIST,LLIST + + ALLOCATABLE ILIST(:,:),LLIST(:) + COMMON /BLK1/ NLST, ICCLN(140,350),NCLM +! + CHARACTER*80 TITLE + CHARACTER*24 HLABL +!ipk feb94 add + character*40 mpnam +!ipk dec97 line above modified + + CHARACTER*1 ALABL(10) + COMMON /BLKA1/ TITLE,HLABL,ALABL,MPNAM +!ipk dec97 line above modified +! +!IPK JAN01 INCREASE IPSW TO 10 + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout +!ycw mar97 add + COMMON /CROSS/ ICRS,XPCS(2),YPCS(2),NCSNOD,XCND(50),YCND(50),& + NCSPTS,XELVP(50),YELVP(50),ZELVP(50),SELVP(50),& + ZREF,DFACTOR,ZMIN,IXNOD,LCROSS& + ,IVMIL(MCRS),NRIVL(MCRS),NOREACH(MCRS)& + ,CRSDAT(MCRS,MPTS,3),NCRSEC,XCRS(MCRS),YCRS(MCRS) + + ALLOCATABLE NRIVCR1(:),WTRIVCR1(:),NRIVCR2(:),WTRIVCR2(:) + +!NRIVCR1(MAXP),WTRIVCR1(MAXP)& +! ,NRIVCR2(MAXP),WTRIVCR2(MAXP), + + LOGICAL LCROSS + + COMMON /UNITS/IOT,IOT1 + + COMMON /INTERPL/ IGRID(MAXGRD,MAXGRD),NX,NY,XGRID,YGRID + + real*8 xusrsto,yusrsto + INTEGER*2 IMATSTO + + ALLOCATABLE xusrsto(:,:),yusrsto(:,:),wdsto(:,:),& + WIDTHsto(:,:), SS1sto(:,:), SS2sto(:,:), WIDSsto(:,:)& + ,WIDBSsto(:,:),SSOsto(:,:),bs1sto(:,:)& + ,nopsto(:,:,:),imatsto(:,:),thtasto(:,:) + +! loaded/ xusrsto(maxp,maxsto),yusrsto(maxp,maxsto),wdsto(maxp,maxsto),& +! WIDTHsto(MAXP,maxsto), SS1sto(MAXP,maxsto), SS2sto(MAXP,maxsto), WIDSsto(MAXP,maxsto)& +! ,WIDBSsto(MAXP,maxsto),SSOsto(MAXP,maxsto),bs1sto(maxp,maxsto)& +! ,nopsto(maxe,8,maxsto),imatsto(maxe,maxsto),thtasto(maxe,maxsto) + + ALLOCATABLE ICCLNSTO(:,:,:)& + ,NPSTO(:),NESTO(:),NLSTSTO(:),NCLMSTO(:) + + + INTEGER*4 ILISTSTO,LLISTSTO + ALLOCATABLE ILISTSTO(:,:,:),LLISTSTO(:,:) + + COMMON /TMPLIST/ ilisttmp(100),INREORD + + ALLOCATABLE ICN(:) + + ALLOCATABLE ICONNCT(:,:) + + ALLOCATABLE IOUTLST(:,:),NOUTLST(:),XOUT(:,:),YOUT(:,:) + + COMMON /VIEWS/ HANG,VANG,VRTSCAL,HANGOLD,VANGOLD,VRTORIG,IASPCT + + + END MODULE \ No newline at end of file diff --git a/src/BLK1.f90 b/src/BLK1.f90 new file mode 100644 index 0000000..2ffe1b5 --- /dev/null +++ b/src/BLK1.f90 @@ -0,0 +1,123 @@ + MODULE BLK1MOD + + INCLUDE 'PARAM.COM' +! BLK1 +!- + REAL HSIZE + COMMON /SSIZE/ HSIZE + + INTEGER MAXP,MAXE,MAXLIN,MAXSTO,MAXECON,MAXLN,MAELN + + + INTEGER*2 INSKP,IESKP,INEW,NCORN,IJUN,ISWTAGN,iswtintp +!IPK MAY02 INTEGER*2 NOP,IMAT,IEM,NEF,NEFLAG,LINTYP,LAY + INTEGER*2 IMAT,LINTYP,LAY,IRTYP + INTEGER*4 NOP,IEM,NEF,NEFLAG +! REAL*8 CORD,XUSR,YUSR,XC,YC,CMAP,XMAP,YMAP,pscale,xref,yref + REAL*8 CORD,XUSR,YUSR,XC,YC,pscale,xref,yref + REAL*8 ALXX,ALYY,ALWD,BLXX,BLYY,BLWD,XBRLEN,CNX,CNY,WIDTHD,HLEFT,HMID,HRIGHT,HSET + + INTEGER*2 MSN + ALLOCATABLE MSN(:) + + + ALLOCATABLE CORD(:,:),XUSR(:),YUSR(:),XC(:),YC(:),IRTYP(:)& + ,NOP(:,:),IMAT(:),THTA(:),IMATL(:),CORDSN(:,:)& + ,WD(:) ,WD1(:),INSKP(:), IESKP(:),NCORN(:)& + ,WIDTH(:), SS1(:), SS2(:), WIDS(:)& + ,IJUN(:),INEW(:),IEM(:),LINTYP(:),NEFLAG(:),NEF(:,:),LAY(:),WTLAY(:,:)& + ,WIDBS(:),SSO(:),NODDEL(:),IELDEL(:)& + ,NOPSV(:,:),nefsv(:,:),IMATSV(:),LOCK(:),BS1(:),NKEY1(:),EDIF(:),ANGOP(:)& + ,IGRPNUM(:,:),MAXENT(:),IGRPSER(:),IUSEDM(:),IOD(:)& + ,ALXX(:),ALYY(:),BLXX(:),BLYY(:),ALWD(:),BLWD(:),ITYPBC(:),CNX(:,:),CNY(:,:),XBRLEN(:)& + ,HLEFT(:),HMID(:),HRIGHT(:),HSET(:,:),WIDTHD(:) + ALLOCATABLE NRF(:),AREF(:),LEVREM(:),TRANSEL(:),WLEN(:),WHGT(:) + INTEGER*8 MAXPTS + COMMON /BLK/ MAXPTS,PSCALE,xref,yref& + , IPNN, IPEN, XMIN, YMIN, XMAX, YMAX, NLAYD,ILAYTP& + ,VOID, VDX, XSCALE, YSCALE,AMAP,IRESTT& + ,NXPMIN, NYPMIN, NXPMAX, NYPMAX, IPP& + ,XPMIN, YPMIN, XPMAX, YPMAX, WDSCAL,IESW& + ,NPLAST,NELAST,NEFL,NENTRY,IECHG,ICHG& + ,IIN, IBAK, LUNIT,IGIN,IS11,IMP,IGFG,ISWAP,ITRIAN& + ,klint,jlint,lmpnam,IDELV,nmapf,NSIGF,NPUNDO,NEUNDO,nefsav,nesav& + ,xadded,yadded,icolsw,rad,colint,ielvsw,ISWTAGN,iswtintp,eref,igrp,igrpout,MAXIGRP& + ,JPTSB +!IPK MAR02 ADD BS1 +!IPK FEB02 ADD LOCK +!IPK MAY01 ADD NODDEL AND IELDEL +!IPK JUL98 WIDBS AND SSO ADDED +!IPK JAN98 IDELV ADDED +!ipk feb94 line above added, two lines changed may 94 to add xref,yref +! 9 ,LINTYP(MAXLIN),NEFLAG(150),NEF(600,3),LAY(MAXP) +! +!IPK MAR04 INTEGER*2 ILIST,LLIST + INTEGER*4 ILIST,LLIST + + ALLOCATABLE ILIST(:,:),LLIST(:) + COMMON /BLK1/ NLST, ICCLN(140,350),NCLM +! + CHARACTER*80 TITLE + CHARACTER*24 HLABL +!ipk feb94 add + character*40 mpnam +!ipk dec97 line above modified + + CHARACTER*1 ALABL(10) + COMMON /BLKA1/ TITLE,HLABL,ALABL,MPNAM +!ipk dec97 line above modified +! +!IPK JAN01 INCREASE IPSW TO 10 + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout +!ycw mar97 add + COMMON /CROSS/ ICRS,XPCS(2),YPCS(2),NCSNOD,XCND(50),YCND(50),& + NCSPTS,XELVP(50),YELVP(50),ZELVP(50),SELVP(50),& + ZREF,DFACTOR,ZMIN,IXNOD,LCROSS& + ,IVMIL(MCRS),NRIVL(MCRS),NOREACH(MCRS)& + ,CRSDAT(MCRS,MPTS,3),NCRSEC,XCRS(MCRS),YCRS(MCRS) + + ALLOCATABLE NRIVCR1(:),WTRIVCR1(:),NRIVCR2(:),WTRIVCR2(:) + +!NRIVCR1(MAXP),WTRIVCR1(MAXP)& +! ,NRIVCR2(MAXP),WTRIVCR2(MAXP), + + LOGICAL LCROSS + + COMMON /UNITS/IOT,IOT1 + + COMMON /INTERPL/ IGRID(MAXGRD,MAXGRD),NX,NY,XGRID,YGRID + + real*8 xusrsto,yusrsto + INTEGER*2 IMATSTO + + ALLOCATABLE xusrsto(:,:),yusrsto(:,:),wdsto(:,:),& + WIDTHsto(:,:), SS1sto(:,:), SS2sto(:,:), WIDSsto(:,:)& + ,WIDBSsto(:,:),SSOsto(:,:),bs1sto(:,:)& + ,nopsto(:,:,:),imatsto(:,:),thtasto(:,:) + +! loaded/ xusrsto(maxp,maxsto),yusrsto(maxp,maxsto),wdsto(maxp,maxsto),& +! WIDTHsto(MAXP,maxsto), SS1sto(MAXP,maxsto), SS2sto(MAXP,maxsto), WIDSsto(MAXP,maxsto)& +! ,WIDBSsto(MAXP,maxsto),SSOsto(MAXP,maxsto),bs1sto(maxp,maxsto)& +! ,nopsto(maxe,8,maxsto),imatsto(maxe,maxsto),thtasto(maxe,maxsto) + + ALLOCATABLE ICCLNSTO(:,:,:)& + ,NPSTO(:),NESTO(:),NLSTSTO(:),NCLMSTO(:) + + + INTEGER*4 ILISTSTO,LLISTSTO + ALLOCATABLE ILISTSTO(:,:,:),LLISTSTO(:,:) + + COMMON /TMPLIST/ ilisttmp(100),INREORD + + ALLOCATABLE ICN(:) + + ALLOCATABLE ICONNCT(:,:) + + ALLOCATABLE IOUTLST(:,:),NOUTLST(:),XOUT(:,:),YOUT(:,:) + + COMMON /VIEWS/ HANG,VANG,VRTSCAL,HANGOLD,VANGOLD,VRTORIG,IASPCT + + INTEGER KID(900,5) + + + END MODULE \ No newline at end of file diff --git a/src/BLK1OLD.COM b/src/BLK1OLD.COM new file mode 100644 index 0000000..ce4fbc1 --- /dev/null +++ b/src/BLK1OLD.COM @@ -0,0 +1,85 @@ + + + INCLUDE 'PARAM.COM' +! BLK1 +!- + REAL HSIZE + COMMON /SSIZE/ HSIZE + + + INTEGER*2 INSKP,IESKP,INEW,NCORN,IJUN,ISWTAGN,iswtintp +!IPK MAY02 INTEGER*2 NOP,IMAT,IEM,NEF,NEFLAG,LINTYP,LAY + INTEGER*2 IMAT,LINTYP,LAY + INTEGER*4 NOP,IEM,NEF,NEFLAG +! REAL*8 CORD,XUSR,YUSR,XC,YC,CMAP,XMAP,YMAP,pscale,xref,yref + REAL*8 CORD,XUSR,YUSR,XC,YC,pscale,xref,yref +! + COMMON /BLK/ CORD(MAXP,2),XUSR(MAXP),YUSR(MAXP),XC(MAXP),YC(MAXP)& + ,PSCALE,xref,yref& + , IPNN, IPEN, XMIN, YMIN, XMAX, YMAX, NLAYD,ILAYTP& + ,VOID, VDX, XSCALE, YSCALE,AMAP,IRESTT& + ,NXPMIN, NYPMIN, NXPMAX, NYPMAX, IPP& + ,XPMIN, YPMIN, XPMAX, YPMAX, WDSCAL,IESW& + ,MAXPTS,NPLAST,NELAST,NEFL,NENTRY,IECHG,ICHG& + ,NOP(MAXE,8),IMAT(MAXE),THTA(MAXE),IMATL(MAXE),CORDSN(MAXP,2)& + ,WD(MAXP) ,WD1(MAXP) ,INSKP(MAXP), IESKP(MAXE)& + ,NCORN(MAXP),IIN, IBAK, LUNIT,IGIN,IS11,IMP,IGFG,ISWAP,ITRIAN& + ,WIDTH(MAXP), SS1(MAXP), SS2(MAXP), WIDS(MAXP)& + ,IJUN(MAXP),INEW(MAXP),IEM(MAXE)& + ,LINTYP(MAXLIN),NEFLAG(MAXP),NEF(MAXP,3),LAY(0:MAXP+1),WTLAY(0:MAXP,9)& + ,klint,jlint,lmpnam,IDELV& + ,WIDBS(MAXP),SSO(MAXP),nmapf,NSIGF,NODDEL(MAXP),IELDEL(MAXE)& + ,NPUNDO,NEUNDO,NOPSV(MAXE,8),nesav,nefsv(maxp,3),nefsav,IMATSV(MAXE)& + ,LOCK(MAXP),xadded,yadded,BS1(MAXP),icolsw,rad,colint,ielvsw,ISWTAGN,iswtintp +!IPK MAR02 ADD BS1 +!IPK FEB02 ADD LOCK +!IPK MAY01 ADD NODDEL AND IELDEL +!IPK JUL98 WIDBS AND SSO ADDED +!IPK JAN98 IDELV ADDED +!ipk feb94 line above added, two lines changed may 94 to add xref,yref +! 9 ,LINTYP(MAXLIN),NEFLAG(150),NEF(600,3),LAY(MAXP) +! +!IPK MAR04 INTEGER*2 ILIST,LLIST + INTEGER*4 ILIST,LLIST + COMMON /BLK1/ ILIST(MAXLN,MAELN),LLIST(MAXLN),NLST& + , ICCLN(50,350),NCLM +! + CHARACTER*80 TITLE + CHARACTER*24 HLABL +!ipk feb94 add + character*40 mpnam +!ipk dec97 line above modified + + CHARACTER*1 ALABL(10) + COMMON /BLKA1/ TITLE,HLABL,ALABL,MPNAM +!ipk dec97 line above modified +! +!IPK JAN01 INCREASE IPSW TO 10 + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout +!ycw mar97 add + COMMON /CROSS/ ICRS,XPCS(2),YPCS(2),NCSNOD,XCND(50),YCND(50),& + NCSPTS,XELVP(50),YELVP(50),ZELVP(50),SELVP(50),& + ZREF,DFACTOR,ZMIN,IXNOD,LCROSS& + ,IVMIL(MCRS),NRIVL(MCRS),NOREACH(MCRS)& + ,CRSDAT(MCRS,MPTS,3),NRIVCR1(MAXP),WTRIVCR1(MAXP)& + ,NRIVCR2(MAXP),WTRIVCR2(MAXP),NCRSEC,XCRS(MCRS),YCRS(MCRS) + LOGICAL LCROSS + + COMMON /UNITS/IOT,IOT1 + + COMMON /INTERPL/ IGRID(MAXGRD,MAXGRD),NX,NY,XGRID,YGRID + + real*8 xusrsto,yusrsto + INTEGER*2 IMATSTO + common /loaded/ xusrsto(maxp,maxsto),yusrsto(maxp,maxsto),wdsto(maxp,maxsto),& + WIDTHsto(MAXP,maxsto), SS1sto(MAXP,maxsto), SS2sto(MAXP,maxsto), WIDSsto(MAXP,maxsto)& + ,WIDBSsto(MAXP,maxsto),SSOsto(MAXP,maxsto),bs1sto(maxp,maxsto)& + ,nopsto(maxe,8,maxsto),imatsto(maxe,maxsto),thtasto(maxe,maxsto)& + ,ICCLNSTO(50,350,MAXSTO)& + ,NPSTO(MAXSTO),NESTO(MAXSTO),NLSTSTO(MAXSTO),NCLMSTO(MAXSTO) + + + INTEGER*4 ILISTSTO,LLISTSTO + COMMON /LOADED2/ ILISTSTO(MAXLN,MAELN,MAXSTO),LLISTSTO(MAXLN,MAXSTO) + + COMMON /TMPLIST/ ilisttmp(100),INREORD \ No newline at end of file diff --git a/src/BLK2.COM b/src/BLK2.COM new file mode 100644 index 0000000..740bd0d --- /dev/null +++ b/src/BLK2.COM @@ -0,0 +1,23 @@ +!IPK LAST UPDATED OCT 18 1996 +! +! BLK2 +! + INTEGER*8 MTSUM,MRSUM,MTSUMSV,MSUM + COMMON /BLKKB4/MTSUM,MRSUM,MTSUMSV(0:100),MSUM + INTEGER ENXT,NCM,NCMI,KNT,NDP,NNEW,MP,NAD,NAE,MLIST,NDELM & + ,LIST,NINC,LNEW,NDROP,NELIM,NITST,NFWSAV,MTSUM1,NSEQ,NFWSV + COMMON /BLKB/ NCM,NCMI,KNT,NDP,NNEW,MP,NAD,NAE & + ,MLIST(MAXE),ENXT(MAXE),NDELM(MAXP),LIST(MAXP) & + ,NINC(MAXP),LNEW(8),NDROP(8),NELIM(MAXE),NITST & + ,NFWS,NFWSAV,mtsum1,NSEQ,NFWSV(0:100) +!IPK MAY94 LINE ABOVE ADDED +! + INTEGER ICON + COMMON /BLKB1/ ICON(MAXE,MAXECON) +! + INTEGER NECON + COMMON /BLKB2/ NECON(MAXP,MAXECON) +! + INTEGER ITRAC,NTRAC + COMMON /BLKB3/ ITRAC(350),NTRAC,JTRAC(350),KTRAC(350) +! \ No newline at end of file diff --git a/src/BLK2MOD.F90 b/src/BLK2MOD.F90 new file mode 100644 index 0000000..811cf15 --- /dev/null +++ b/src/BLK2MOD.F90 @@ -0,0 +1,30 @@ + MODULE BLK2MOD + +!IPK LAST UPDATED OCT 18 1996 +! +! BLK2 +! + INTEGER*8 MTSUM,MRSUM,MTSUMSV,MSUM,MTSUM1 + COMMON /BLKKB4/MTSUM,MRSUM,MTSUMSV(0:100),MSUM + INTEGER ENXT,NCM,NCMI,KNT,NDP,NNEW,MP,NAD,NAE,MLIST,NDELM & + ,LIST,NINC,LNEW,NDROP,NELIM,NITST,NFWSAV,NSEQ,NFWSV + COMMON /BLKB/ mtsum1,NCM,NCMI,KNT,NDP,NNEW,MP,NAD,NAE & + ,LNEW(8),NDROP(8),NITST & + ,NFWS,NFWSAV,NSEQ,NFWSV(0:100) +!IPK MAY94 LINE ABOVE ADDED + + ALLOCATABLE MLIST(:),ENXT(:),NDELM(:),LIST(:) & + ,NINC(:),NELIM(:) + +! + INTEGER ICON + ALLOCATABLE ICON(:,:) +! + INTEGER NECON + ALLOCATABLE NECON(:,:) +! + INTEGER ITRAC,NTRAC,NTRACT + COMMON /BLKB3/ ITRAC(1000),NTRAC,JTRAC(1000),KTRAC(1000) +! + END MODULE + \ No newline at end of file diff --git a/src/BLKELTLD.F90 b/src/BLKELTLD.F90 new file mode 100644 index 0000000..eb21fdc --- /dev/null +++ b/src/BLKELTLD.F90 @@ -0,0 +1,6 @@ + MODULE BLKELTLD + REAL DYE,TAE,HAE,XYCEL + INTEGER NCLINE,NEST,IYDATE,NHYE,IQUENIT,IBINEL,NQHYD,NQP,IRMATYP + ALLOCATABLE DYE(:,:),TAE(:,:),HAE(:,:),NCLINE(:),NEST(:),IYDATE(:),NHYE(:),ILAYRE(:,:),HDE(:,:,:),XYCEL(:,:) + + END \ No newline at end of file diff --git a/src/BLKMAP.COM b/src/BLKMAP.COM new file mode 100644 index 0000000..a7b70e2 --- /dev/null +++ b/src/BLKMAP.COM @@ -0,0 +1,14 @@ + + PARAMETER (MAXPL=500000,MAXELMP=50000) + + REAL*8 XCEN,YCEN,RADS,MAP,XMAP,YMAP,CMAP + + COMMON /MAPBLK/ NOPEL(MAXELMP,3),XCEN(MAXELMP),YCEN(MAXELMP)& + ,RADS(MAXELMP) ,NKEY(MAXELMP),IEDGE(500,2),IGAP(500),CMAP(MAXPL,2)& + ,XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL),NELFM(500) + + + COMMON /MAPINFO/ NELTS + + common /mapc/imap(maxpl),NCRS(MAXPL) + diff --git a/src/BRKDWN.F90 b/src/BRKDWN.F90 new file mode 100644 index 0000000..3f5039b --- /dev/null +++ b/src/BRKDWN.F90 @@ -0,0 +1,856 @@ +!ipk lsdt update nov 10 1995 + SUBROUTINE BRKDWN(NCN,NELNO) +! SUBROUTINE BRKDWN(X,Y,VL,NCN) + SAVE + DOUBLE PRECISION XN,XLN,YLN,XLP,YLP + PARAMETER (NTB=100) +! +! Routine to subdivide quadrilaterals and triangles for plotting +! +!ipkoct93 COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL + COMMON /PLTC/IPSAV,IFLG,XLL,YLL + LOGICAL SWITCH +! +! DIMENSION X(10),Y(10),VL(10) + COMMON /BRK/ X(10),Y(10),VL(10),DL(10),VLM(10) + DIMENSION IQ(3,8),RIX(3,8),RIY(3,8) + DIMENSION IT(3,4),ZIX(3,4),ZIY(3,4) + DIMENSION IST(3,3) + DIMENSION CX(3,NTB),CY(3,NTB),VAL(3,NTB),XLC(3,NTB),YLC(3,NTB) + DIMENSION ISPLT(3),XP(6),YP(6),VP(6),XLP(6),YLP(6) + DATA IQ / 1, 2, 9, 2, 3, 4, 2, 4, 9, 4, 5, 9,& + 1, 9, 8, 8, 9, 6, 8, 6, 7, 9, 5, 6/ + DATA RIX/ -1.,0.,0., 0.,1.,1., 0.,1.,0., 1.,1.,0.,& + -1.,0.,-1., -1.,0.,0., -1.,0.,-1., 0.,1.,0./ + DATA RIY/ -1.,-1.,0., -1.,-1.,0., -1.,0.,0., 0.,1.,0.,& + -1.,0.,0., 0.,0.,1., 0.,1.,1., 0.,1.,1./ + DATA IT / 1, 2, 6, 3, 4, 2, 5, 6, 4, 2, 4, 6/ + DATA ZIX/0.,.5,0., 1.,.5,.5, 0.,0.,.5, .5,.5,0./ + DATA ZIY/0.,0.,.5, 0.,.5,0., 1.,.5,.5, 0.,.5,.5/ + DATA IST/ 1,4,5, 4,2,5, 1,5,3/ +! DATA XCSQ/1.0/ +! +! Distance function squared +! + DISTSQ(AX,AY,BX,BY)=(AX-BX)**2+(AY-BY)**2 + +! do n=1,ncn +! write(90,*) n,x(n),y(n),vl(n) +! enddo + IF(NCN .LT. 6) THEN + CALL EXPND(NCN,NELNO) + ENDIF + + XCSQ=0.25 +! +! If NCN = 3 then copy over values +! + IF(NCN .EQ. 3) THEN + ITT=-1 + DO 180 L=1,3 + CX(L,1)=X(L) + CY(L,1)=Y(L) + VAL(L,1)=VL(L) + 180 CONTINUE + XLC(1,1)=0. + XLC(2,1)=1. + XLC(3,1)=0. + YLC(1,1)=0. + YLC(2,1)=0. + YLC(3,1)=0. + NTAB=1 +! +! Subdivide quadrilateral to 2 triangles and develop list +! + ELSEIF(NCN .EQ. 4) THEN + ITT=0 + DO 190 I=1,3 + X(I+4)=X(I) + Y(I+4)=Y(I) + VL(I+4)=VL(I) + 190 CONTINUE +! +! Pick long side for diagonal +! + IF (DISTSQ(X(1),Y(1),X(3),Y(3)) .GT. DISTSQ(X(2),Y(2),X(4),Y(4))) THEN +! +! Rotate if its longer +! + DO 200 I=1,5 + X(I)=X(I+1) + Y(I)=Y(I+1) + VL(I)=VL(I+1) + 200 CONTINUE + ENDIF +! +! Now process it +! + DO 210 L=1,3 + CX(L,1)=X(L) + CY(L,1)=Y(L) + VAL(L,1)=VL(L) + 210 CONTINUE + XLC(1,1)=-1. + XLC(2,1)=1. + XLC(3,1)=1. + YLC(1,1)=-1. + YLC(2,1)=-1. + YLC(3,1)=1. + DO 220 L=1,3 + CX(L,2)=X(L+2) + CY(L,2)=Y(L+2) + VAL(L,2)=VL(L+2) + 220 CONTINUE + XLC(1,2)=1. + XLC(2,2)=-1. + XLC(3,2)=-1. + YLC(1,2)=1. + YLC(2,2)=1. + YLC(3,2)=-1. + NTAB=2 +! +! Subdivide 6 node triangle to 4 triangles and develop list +! + ELSEIF(NCN .EQ. 6) THEN + ITT=2 +! write(90,*) (x(i),i=1,8) + DO 300 K=1,4 + DO 280 L=1,3 + CX(L,K)=X(IT(L,K)) + CY(L,K)=Y(IT(L,K)) + VAL(L,K)=VL(IT(L,K)) + XLC(L,K)=ZIX(L,K) + YLC(L,K)=ZIY(L,K) + 280 CONTINUE + 300 CONTINUE + NTAB=4 +! +! Subdivide 8 node quadrilateral to 8 triangles and develop list +! + ELSEIF(NCN .GE. 8) THEN + IF(NCN .EQ. 8) THEN + ITT=1 + ELSE + ITT=0 + X9=X(9) + Y9=Y(9) + VL9=VL(9) + ENDIF + DO 310 I=1,2 + X(I+8)=X(I) + Y(I+8)=Y(I) + VL(I+8)=VL(I) + 310 CONTINUE +! +! Pick long side for diagonal +! + IF (DISTSQ(X(1),Y(1),X(5),Y(5)) .GT. & + DISTSQ(X(3),Y(3),X(7),Y(7))) THEN +! +! Rotate if its longer +! + DO 320 I=1,8 + X(I)=X(I+2) + Y(I)=Y(I+2) + VL(I)=VL(I+2) + 320 CONTINUE + ENDIF +! +! Define center point +! + IF(NCN .LT. 9) THEN + X(9)=0. + Y(9)=0. + VL(9)=0. + DO 360 I=1,8 + SH=XN(ITT,I,0.d0,0.d0) + X(9)=X(9)+SH*X(I) + Y(9)=Y(9)+SH*Y(I) + VL(9)=VL(9)+SH*VL(I) + 360 CONTINUE + ELSE + X(9)=X9 + Y(9)=Y9 + VL(9)=VL9 + ENDIF + DO 400 K=1,8 + DO 380 L=1,3 + CX(L,K)=X(IQ(L,K)) + CY(L,K)=Y(IQ(L,K)) + VAL(L,K)=VL(IQ(L,K)) + XLC(L,K)=RIX(L,K) + YLC(L,K)=RIY(L,K) + 380 CONTINUE + 400 CONTINUE + NTAB=8 + ENDIF +! +! Start at bottom of list +! + 420 CONTINUE + N=NTAB +! +! Check lengths of sides and nore values +! + ISTART=0 + ICNT=0 + IF(DISTSQ(CX(1,N),CY(1,N),CX(2,N),CY(2,N)) .GT. XCSQ) THEN + ICNT=1 + ISPLT(1)=1 + ISTART=1 + ELSE + ISPLT(1)=0 + ENDIF + IF(DISTSQ(CX(2,N),CY(2,N),CX(3,N),CY(3,N)) .GT. XCSQ) THEN + ICNT=ICNT+1 + ISPLT(2)=1 + ISTART=2 + ELSE + ISPLT(2)=0 + ENDIF + IF(DISTSQ(CX(3,N),CY(3,N),CX(1,N),CY(1,N)) .GT. XCSQ) THEN + ICNT=ICNT+1 + ISPLT(3)=1 + ISTART=3 + ELSE + ISPLT(3)=0 + ENDIF + IF(ICNT .EQ. 0) THEN +! +! Call to plot contours for each triangle +! + IF(IPSAV .EQ. 0) THEN + CALL CBLOK(CX(1,N),CY(1,N),VAL(1,N)) + ELSE + CALL CONTRD(CX(1,N),CY(1,N),VAL(1,N)) + ENDIF + NTAB=N-1 + IF(NTAB .EQ. 0) THEN + RETURN + ELSE + GO TO 420 + ENDIF + ELSEIF(ICNT .EQ. 1) THEN +! +! We must split the triangle into 2. Rotate first into temporary array. +! + IF(NTAB .GT. NTB-1) THEN + WRITE(*,*) 'ELEMENT TABLE SIZE EXCEEDED PLOT CURTAILED' + RETURN + ENDIF + DO 440 I=1,3 + J=MOD(ISTART+I-2,3)+1 + XP(I)=CX(J,N) + YP(I)=CY(J,N) + VP(I)=VAL(J,N) + XLP(I)=XLC(J,N) + YLP(I)=YLC(J,N) + 440 CONTINUE + XLN=(XLP(1)+XLP(2))/2. + YLN=(YLP(1)+YLP(2))/2. + XNEW=0. + YNEW=0. + VNEW=0. + DO 460 I=1,NCN + SH=XN(ITT,I,XLN,YLN) + XNEW=XNEW+SH*X(I) + YNEW=YNEW+SH*Y(I) + VNEW=VNEW+SH*VL(I) + 460 CONTINUE + CX(1,N)=XP(1) + CX(2,N)=XNEW + CX(3,N)=XP(3) + CY(1,N)=YP(1) + CY(2,N)=YNEW + CY(3,N)=YP(3) + VAL(1,N)=VP(1) + VAL(2,N)=VNEW + VAL(3,N)=VP(3) + XLC(1,N)=XLP(1) + XLC(2,N)=XLN + XLC(3,N)=XLP(3) + YLC(1,N)=YLP(1) + YLC(2,N)=YLN + YLC(3,N)=YLP(3) + + CX(1,N+1)=XP(2) + CX(2,N+1)=XP(3) + CX(3,N+1)=XNEW + CY(1,N+1)=YP(2) + CY(2,N+1)=YP(3) + CY(3,N+1)=YNEW + VAL(1,N+1)=VP(2) + VAL(2,N+1)=VP(3) + VAL(3,N+1)=VNEW + XLC(1,N+1)=XLP(2) + XLC(2,N+1)=XLP(3) + XLC(3,N+1)=XLN + YLC(1,N+1)=YLP(2) + YLC(2,N+1)=YLP(3) + YLC(3,N+1)=YLN + NTAB=N+1 + ELSEIF(ICNT .EQ. 2) THEN + IF(NTAB .GT. NTB-2) THEN + WRITE(*,*) 'ELEMENT TABLE SIZE EXCEEDED PLOT CURTAILED' + RETURN + ENDIF +! +! We must split the triangle into 3. Rotate first into temporary array. +! + IF(ISTART .EQ. 3) THEN + IF(ISPLT(1) .EQ. 1) ISTART=3 + IF(ISPLT(2) .EQ. 1) ISTART=2 + ELSE + ISTART=1 + ENDIF + DO 540 I=1,3 + J=MOD(ISTART+I-2,3)+1 + XP(I)=CX(J,N) + YP(I)=CY(J,N) + VP(I)=VAL(J,N) + XLP(I)=XLC(J,N) + YLP(I)=YLC(J,N) + 540 CONTINUE + XLP(4)=(XLP(1)+XLP(2))/2. + YLP(4)=(YLP(1)+YLP(2))/2. + XLP(5)=(XLP(2)+XLP(3))/2. + YLP(5)=(YLP(2)+YLP(3))/2. + XP(4)=0. + YP(4)=0. + VP(4)=0. + XP(5)=0. + YP(5)=0. + VP(5)=0. + DO 560 I=1,NCN + SH=XN(ITT,I,XLP(4),YLP(4)) + XP(4)=XP(4)+SH*X(I) + YP(4)=YP(4)+SH*Y(I) + VP(4)=VP(4)+SH*VL(I) + SH=XN(ITT,I,XLP(5),YLP(5)) + XP(5)=XP(5)+SH*X(I) + YP(5)=YP(5)+SH*Y(I) + VP(5)=VP(5)+SH*VL(I) + 560 CONTINUE + N=NTAB-1 + DO 600 K=1,3 + N=N+1 + DO 580 L=1,3 + CX(L,N)=XP(IST(L,K)) + CY(L,N)=YP(IST(L,K)) + VAL(L,N)=VP(IST(L,K)) + XLC(L,N)=XLP(IST(L,K)) + YLC(L,N)=YLP(IST(L,K)) + 580 CONTINUE + 600 CONTINUE + NTAB=N + ELSEIF(ICNT .EQ. 3) THEN + IF(NTAB .GT. NTB-3) THEN + WRITE(*,*) 'ELEMENT TABLE SIZE EXCEEDED PLOT CURTAILED' + RETURN + ENDIF +! +! We must split the triangle into 4. Fill midsides +! + DO 640 I=1,3 + XP(2*I-1)=CX(I,N) + YP(2*I-1)=CY(I,N) + VP(2*I-1)=VAL(I,N) + XLP(2*I-1)=XLC(I,N) + YLP(2*I-1)=YLC(I,N) + 640 CONTINUE + XLP(2)=(XLP(1)+XLP(3))/2. + YLP(2)=(YLP(1)+YLP(3))/2. + XLP(4)=(XLP(3)+XLP(5))/2. + YLP(4)=(YLP(3)+YLP(5))/2. + XLP(6)=(XLP(5)+XLP(1))/2. + YLP(6)=(YLP(5)+YLP(1))/2. + XP(2)=0. + YP(2)=0. + VP(2)=0. + XP(4)=0. + YP(4)=0. + VP(4)=0. + XP(6)=0. + YP(6)=0. + VP(6)=0. + DO 660 I=1,NCN + SH=XN(ITT,I,XLP(2),YLP(2)) + XP(2)=XP(2)+SH*X(I) + YP(2)=YP(2)+SH*Y(I) + VP(2)=VP(2)+SH*VL(I) + SH=XN(ITT,I,XLP(4),YLP(4)) + XP(4)=XP(4)+SH*X(I) + YP(4)=YP(4)+SH*Y(I) + VP(4)=VP(4)+SH*VL(I) + SH=XN(ITT,I,XLP(6),YLP(6)) + XP(6)=XP(6)+SH*X(I) + YP(6)=YP(6)+SH*Y(I) + VP(6)=VP(6)+SH*VL(I) + 660 CONTINUE + N=NTAB-1 + DO 700 K=1,4 + N=N+1 + DO 680 L=1,3 + CX(L,N)=XP(IT(L,K)) + CY(L,N)=YP(IT(L,K)) + VAL(L,N)=VP(IT(L,K)) + XLC(L,N)=XLP(IT(L,K)) + YLC(L,N)=YLP(IT(L,K)) + 680 CONTINUE + 700 CONTINUE + NTAB=N + ENDIF + GO TO 420 +! + END + SUBROUTINE CONTRD(X,Y,V) + SAVE +! +! Routine to draw contours across triangle +! + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL + LOGICAL SWITCH + DIMENSION X(3),Y(3),V(3),XX(2),YY(2) +! +! Get VMIN and VMAX +! + VMIN=MIN(V(1),V(2),V(3)) + VMAX=MAX(V(1),V(2),V(3)) +! +! Process each contour value +! + DO 500 N=1,NUMV +! +! Test if contour lies in range +! + IF(CONTUR(N) .LT. VMIN) GO TO 500 + IF(CONTUR(N) .GT. VMAX) GO TO 500 +! +! Its active +! + I=0 +! +! Look for an intercept V(1) AND V(2) +! + IF(CONTUR(N) .GE. MIN(V(1),V(2)) & + .AND. CONTUR(N) .LE. MAX(V(1),V(2))) THEN +! +! We have an intercept +! + I=I+1 + if(v(2) .ne. v(1)) then + FACT=(CONTUR(N)-V(1))/(V(2)-V(1)) + else + fact=0.5 + endif +! +! Locate point +! + XX(I)=X(1)+FACT*(X(2)-X(1)) + YY(I)=Y(1)+FACT*(Y(2)-Y(1)) + ENDIF +! +! Look for an intercept V(2) AND V(3) +! + IF(CONTUR(N) .GE. MIN(V(2),V(3)) & + .AND. CONTUR(N) .LE. MAX(V(2),V(3))) THEN +! +! We have an intercept +! + I=I+1 + if(v(3) .ne. v(2)) then + FACT=(CONTUR(N)-V(2))/(V(3)-V(2)) + else + fact=0.5 + endif +! +! Locate point +! + XX(I)=X(2)+FACT*(X(3)-X(2)) + YY(I)=Y(2)+FACT*(Y(3)-Y(2)) + IF(I .EQ. 2) GO TO 450 + ENDIF +! +! Look for an intercept V(3) AND V(1) +! + IF(CONTUR(N) .GE. MIN(V(3),V(1)) & + .AND. CONTUR(N) .LE. MAX(V(3),V(1))) THEN +! +! We have an intercept +! + I=I+1 + if(v(1) .ne. v(3)) then + FACT=(CONTUR(N)-V(3))/(V(1)-V(3)) + else + fact=0.5 + endif +! +! Locate point +! + XX(I)=X(3)+FACT*(X(1)-X(3)) + YY(I)=Y(3)+FACT*(Y(1)-Y(3)) + ENDIF +! +! Test for no intercept *ERROR* +! + IF(I .LT. 2) THEN + WRITE(*,*) 'ERROR NO INTERCEPT NOTED, PLOT CURTAILED' + WRITE(90,*) ' NON INTERCEPT VALUES ARE' + WRITE(90,*) v(1),v(2),v(3),contur(n) + RETURN + ENDIF +! +! Now draw line +! + 450 CONTINUE + CALL PLOTT(XX(1),YY(1),3) + CALL PLOTT(XX(2),YY(2),2) +! +! Go back for next contour +! + 500 CONTINUE +! +! We are done +! + RETURN + END + SUBROUTINE CBLOK(X,Y,V) +! +! Given a triangle (X,Y) with values V Draw polygons of the +! contours in CONTUR that cross the triangle +! + DIMENSION X(3),Y(3),V(3),AX(10),AY(10) + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL + LOGICAL SWITCH +! +! Sort out order for values of V +! + 200 IF(V(1) .LE. V(2)) THEN + IF(V(3) .LT. V(2)) THEN + VT=V(2) + V(2)=V(3) + V(3)=VT + XT=X(2) + X(2)=X(3) + X(3)=XT + YT=Y(2) + Y(2)=Y(3) + Y(3)=YT + GO TO 200 + ENDIF + ELSE + VT=V(1) + V(1)=V(2) + V(2)=VT + XT=X(1) + X(1)=X(2) + X(2)=XT + YT=Y(1) + Y(1)=Y(2) + Y(2)=YT + GO TO 200 + ENDIF +! +! INITIALIZE +! + IPAN12=0 + IPAN23=0 +! +! Loop on contours +! + cjfact=1.001 + DO 900 N=1,NUMV + nn=float(n)*cjfact + if(numv .le. 10) nn=nn+2 +! +! Check for passing lowest contour +! + IF(CONTUR(N) .GE. V(1)) THEN +! +! Possible active contour +! + IF(CONTUR(N) .LE. V(3)) THEN +! +! Definitely active. Get intercept on 1-3 +! + if(v(3) .ne. v(1)) then + FACT=(CONTUR(N)-V(1))/(V(3)-V(1)) + else + fact=0.5 + endif +! +! Locate point +! + XX1=X(1)+FACT*(X(3)-X(1)) + YY1=Y(1)+FACT*(Y(3)-Y(1)) + IF(CONTUR(N) .LE. V(2)) THEN +! +! Second intercept is on 1-2 +! + IPAN12=IPAN12+1 + if(v(2) .ne. v(1)) then + FACT=(CONTUR(N)-V(1))/(V(2)-V(1)) + else + fact=0.5 + endif +! +! Locate point +! + XX2=X(1)+FACT*(X(2)-X(1)) + YY2=Y(1)+FACT*(Y(2)-Y(1)) + IF(IPAN12 .EQ. 1) THEN +! +! This is the first contour across 1-2 +! + AX(1)=X(1) + AX(2)=XX1 + AX(3)=XX2 + AY(1)=Y(1) + AY(2)=YY1 + AY(3)=YY2 + XX1F=XX1 + XX2F=XX2 + YY1F=YY1 + YY2F=YY2 + CALL POLYG(AX,AY,3,NN) + ELSE +! +! This is a second contour line +! + AX(1)=XX1 + AX(2)=XX2 + AX(3)=XX2F + AX(4)=XX1F + AY(1)=YY1 + AY(2)=YY2 + AY(3)=YY2F + AY(4)=YY1F + XX1F=XX1 + XX2F=XX2 + YY1F=YY1 + YY2F=YY2 + CALL POLYG(AX,AY,4,NN) + ENDIF + ELSE +! +! Second intercept is on 2-3 +! + IPAN23=IPAN23+1 + if(v(3) .ne. v(2)) then + FACT=(CONTUR(N)-V(2))/(V(3)-V(2)) + else + fact=0.5 + endif +! +! Locate point +! + XX2=X(2)+FACT*(X(3)-X(2)) + YY2=Y(2)+FACT*(Y(3)-Y(2)) + IF(IPAN23 .EQ. 1) THEN +! +! This is the first contour on 2-3 +! + IF(IPAN12 .EQ. 0) THEN +! +! There is no previous contour across this element +! + AX(1)=X(1) + AX(2)=XX1 + AX(3)=XX2 + AX(4)=X(2) + AY(1)=Y(1) + AY(2)=YY1 + AY(3)=YY2 + AY(4)=Y(2) + XX1F=XX1 + XX2F=XX2 + YY1F=YY1 + YY2F=YY2 + CALL POLYG(AX,AY,4,NN) + ELSE +! +! There is a previous contour across 1-2 +! + AX(1)=XX1 + AX(2)=XX2 + AX(3)=X(2) + AX(4)=XX2F + AX(5)=XX1F + AY(1)=YY1 + AY(2)=YY2 + AY(3)=Y(2) + AY(4)=YY2F + AY(5)=YY1F + XX1F=XX1 + XX2F=XX2 + YY1F=YY1 + YY2F=YY2 + CALL POLYG(AX,AY,5,NN) + ENDIF + ELSE +! +! This is a second contour line on 2-3 +! + AX(1)=XX1 + AX(2)=XX2 + AX(3)=XX2F + AX(4)=XX1F + AY(1)=YY1 + AY(2)=YY2 + AY(3)=YY2F + AY(4)=YY1F + XX1F=XX1 + XX2F=XX2 + YY1F=YY1 + YY2F=YY2 + CALL POLYG(AX,AY,4,NN) + ENDIF + ENDIF + ELSE +! +! Complete drawing of contour checking to see where previous +! contour was +! + IF(IPAN23 .GT. 0) THEN +! +! It was on 2-3 +! + AX(1)=X(3) + AX(2)=XX2F + AX(3)=XX1F + AY(1)=Y(3) + AY(2)=YY2F + AY(3)=YY1F + CALL POLYG(AX,AY,3,NN) + ELSEIF(IPAN12 .GT. 0) THEN +! +! It was on 1-2 +! + AX(1)=X(3) + AX(2)=X(2) + AX(3)=XX2F + AX(4)=XX1F + AY(1)=Y(3) + AY(2)=Y(2) + AY(3)=YY2F + AY(4)=YY1F + CALL POLYG(AX,AY,4,NN) + ELSE + AX(1)=X(3) + AX(2)=X(2) + AX(3)=X(1) + AY(1)=Y(3) + AY(2)=Y(2) + AY(3)=Y(1) + CALL POLYG(AX,AY,3,NN) + ENDIF + GO TO 905 + ENDIF + ENDIF + 900 CONTINUE + 905 CONTINUE + RETURN + END + + SUBROUTINE EXPND(NCN,N) + + USE BLK1MOD + + INCLUDE 'TXFRM.COM' +! INCLUDE 'PARAM.COM' +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLKBRK.COM' +! INCLUDE 'BFILES.I90' +! WRITE(90,*) 'BEFORE',N,X(1),X(2),X(3),Y(1),Y(2),Y(3) + COMMON /BRK/ X(10),Y(10),VL(10),DL(10),VLM(10) +! expand + DSTRTN1=1.0 + N1=NOP(N,1) + N2=NOP(N,2) + N3=NOP(N,3) + x1= cord(n1,1) + x2= cord(n3,1) + y1= cord(n1,2) + y2= cord(n3,2) + eldir=atan2(y2-y1,x2-x1) + ALFAN1=eldir-1.5708 + ALFAN2=ALFAN1 + ALFAN3=ALFAN1 + NCN=8 + width(n2)=(width(n1)+width(n3))/2. + TX2=X(2) + TY2=Y(2) + TX3=X(3) + TY3=Y(3) + VL2=VL(2) + VL3=VL(3) + X(6)=X(3) + Y(6)=Y(3) + VL(6)=VL(3) + X(2)=X(1) + Y(2)=Y(1) + VL(2)=VL(1) + VL(3)=VL(1) + X(1)=X(2)-WIDTH(N1)*COS(ALFAN1)/(2.*TXSCAL)*DSTRTN1 + X(3)=X(2)+WIDTH(N1)*COS(ALFAN1)/(2.*TXSCAL)*DSTRTN1 + Y(1)=Y(2)-WIDTH(N1)*SIN(ALFAN1)/(2.*TXSCAL)*DSTRTN1 + Y(3)=Y(2)+WIDTH(N1)*SIN(ALFAN1)/(2.*TXSCAL)*DSTRTN1 + VL(4)=VL2 + VL(8)=VL2 + X(4)=TX2+WIDTH(N2)*COS(ALFAN2)/(2.*TXSCAL)*DSTRTN1 + X(8)=TX2-WIDTH(N2)*COS(ALFAN2)/(2.*TXSCAL)*DSTRTN1 + Y(4)=TY2+WIDTH(N2)*SIN(ALFAN2)/(2.*TXSCAL)*DSTRTN1 + Y(8)=TY2-WIDTH(N2)*SIN(ALFAN2)/(2.*TXSCAL)*DSTRTN1 + VL(5)=VL3 + VL(7)=VL3 + X(5)=TX3+WIDTH(N3)*COS(ALFAN3)/(2.*TXSCAL)*DSTRTN1 + X(7)=TX3-WIDTH(N3)*COS(ALFAN3)/(2.*TXSCAL)*DSTRTN1 + Y(5)=TY3+WIDTH(N3)*SIN(ALFAN3)/(2.*TXSCAL)*DSTRTN1 + Y(7)=TY3-WIDTH(N3)*SIN(ALFAN3)/(2.*TXSCAL)*DSTRTN1 +! check areas + + aj=x(3)-x(1) + bj=y(3)-y(1) + ak=x(5)-x(1) + bk=y(5)-y(1) + a1=aj*bk-ak*bj + if(a1 .lt. 0.) then + tx1=x(1) + ty1=y(1) + x(1)=x(3) + y(1)=y(3) + x(3)=tx1 + y(3)=ty1 + + endif + aj=x(5)-x(1) + bj=y(5)-y(1) + ak=x(7)-x(1) + bk=y(7)-y(1) + a2=aj*bk-ak*bj + if(a2 .lt. 0) then + tx1=x(5) + ty1=y(5) + x(5)=x(7) + y(5)=y(7) + x(7)=tx1 + y(7)=ty1 + endif + + aj=x(4)-x(1) + bj=y(4)-y(1) + ak=x(8)-x(1) + bk=y(8)-y(1) + a1=aj*bk-ak*bj + if(a1 .lt. 0.) then + tx1=x(4) + ty1=y(4) + x(4)=x(8) + y(4)=y(8) + x(8)=tx1 + y(8)=ty1 + endif + RETURN + END + diff --git a/src/BUTTON.ICO b/src/BUTTON.ICO new file mode 100644 index 0000000..90b9993 Binary files /dev/null and b/src/BUTTON.ICO differ diff --git a/src/CANCEL.ICO b/src/CANCEL.ICO new file mode 100644 index 0000000..b1028bf Binary files /dev/null and b/src/CANCEL.ICO differ diff --git a/src/CCLINE.F90 b/src/CCLINE.F90 new file mode 100644 index 0000000..cb883b8 --- /dev/null +++ b/src/CCLINE.F90 @@ -0,0 +1,496 @@ +! Last change: IPK 2 Mar 1999 12:58 pm +!IPK NEW ROUTINE OCT 23 1996 + SUBROUTINE CCLINE(ISW) +! +! Generate continuity lines +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + CHARACTER*1 IFLAG + DIMENSION XLIN(350),YLIN(350),INODE1(350) +! DIMENSION ICN(MAXP) + LOGICAL :: OPENED + DO J=1,MAXP + ICN(J)=0 + ENDDO + + IF(ISW .EQ. 1) THEN + call opencln(ipos) + if(ipos .eq. 0) return + ELSE + ipos=2 + ENDIF +! +! First sort out the potential midsides +! Note that transition elements caues a problem +! Find these first + DO N=1,NE + IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN +! +! We have a transition mark node number as if it were corner +! + ICN(NOP(N,3))=1 + ICN(NOP(N,1))=2 + ICN(NOP(N,4))=2 + ICN(NOP(N,5))=2 + ELSE +! +! Store ICN = 2 for corner nodes +! + NCN=NCORN(N) +!IPKOCT93 IF(IMAT(N) .GT. 900) THEN + IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN + MST=1 + ELSE + MST=2 + ENDIF + DO M=1,NCN,MST + ICN(NOP(N,M))=2 + ENDDO + ENDIF + ENDDO + +! +! Get connections +! + CALL NTONCON(ipos) + 100 CONTINUE + NHTP=0 + NMESS=26 + NBRR=8 + NTRACT=0 + + CALL HEDR + NCLL=0 +! +! Get first point +! + 110 CONTINUE + K=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE1(1),IFLAG,INSKP,IBOX) + if(inode1(1) .eq. 0) go to 110 + IF(IRMAIN .EQ. 1) THEN + NTRACT=0 + RETURN + ENDIF + IF(IFLAG .EQ. 'q') THEN + NTRACT=0 + GO TO 500 + ENDIF +!IPK JAN01 + IF(IBOX .EQ. 7 .OR. IFLAG .EQ. 'n' .or. & + IBOX .EQ. 5 .OR. IFLAG .EQ. 'd') THEN + ipos=ncll+1 + CALL GETCLN(ipos) +!IPK JAN02 + IF(ISW .EQ. 1) THEN + IF(IPOS .EQ. 0) THEN + DO NCLL=1,140 + DO KK=1,350 + ICCLN(NCLL,KK)=0 + ENDDO + ENDDO + NCLM=0 + ELSE + ncll=ipos + DO KK=1,350 + ICCLN(NCLL,KK)=0 + ENDDO + IF(NCLM .EQ. NCLL) NCLM=NCLM-1 + ENDIF + GO TO 100 + ENDIF + ENDIF + IF(ICN(INODE1(1)) .NE. 2) THEN + NMESS=28 + CALL HEDR + GO TO 110 + ENDIF + + NBRR=5 + NMESS=27 + CALL HEDR + fpn=inode1(1) + CALL NUMBR(0.5,7.2,0.2,FPN,0.0,-1) + call pltnod(inode1(1),0) +! +! Get second point +! + 150 CONTINUE + K=K+1 + 160 CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE1(K),IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) THEN + NTRACT=0 + RETURN + ENDIF + IF(IFLAG .EQ. 'q') THEN + NTRACT=0 + GO TO 500 + ENDIF + NMESS=26 + CALL HEDR + IF(IBOX .EQ. 6 .OR. IFLAG .EQ. 'b' ) THEN + K=K-2 + GO TO 150 + ELSEIF(IBOX .EQ. 7 .OR. IFLAG .EQ. 'n') THEN + KL=K-2 + + IF(ISW .EQ. 1) THEN + +!IPK Get continuity line number + ipos=ncll+1 + CALL GETCLN(ipos) + ncll=ipos + IF(NCLL .EQ. 0) GO TO 500 + ENDIF +! +! Trace along line +! + NTRACT=1 + IF(KL .GT. 0) THEN + DO LS=1,KL + CALL TRACE(INODE1(LS),INODE1(LS+1)) + ENDDO + ELSE + NTRACT=1 + ITRAC(1)=INODE1(1) + ENDIF +! +! Output line to file +! +! WRITE(90,6000) (ITRAC(KK),KK=1,NTRAC) +!ipk jan01 + INQUIRE(98, OPENED=OPENED) + if(opened) then + IF(IPOS .EQ. 1) THEN + DO KK=1,NTRACT + WRITE(98,6001) ITRAC(KK),XUSR(ITRAC(KK)),YUSR(ITRAC(KK)) +6001 FORMAT('NODE',I7,2F15.3) + ENDDO + ELSE + WRITE(98,6000) NCLL,(ITRAC(KK),KK=1,NTRACT) + ENDIF + endif +!IPK JAN01 + 6000 FORMAT('CC1',I5,9I8/('CC2',5X,9I8)) + DO KK=1,NTRACT + XLIN(KK)=CORD(ITRAC(KK),1) + YLIN(KK)=CORD(ITRAC(KK),2) + ENDDO + +!ipk jan01 +! Save to an array by line number +! + IF(ISW .EQ. 1) THEN + DO KK=1,NTRACT + ICCLN(NCLL,KK)=ITRAC(KK) + ENDDO + IF(NCLL .GT. NCLM) NCLM=NCLL + ENDIF + + CALL RRED +!ipk jan01 + CALL THICKL + CALL DASHLN(XLIN,YLIN,NTRACT,0) +!ipk jan01 + + CALL THINL +! +! Go to get another line +! + IF(ISW .EQ. 2) RETURN + GO TO 100 + ELSE + IF(ICN(INODE1(K)) .NE. 2) THEN + NMESS=27 + CALL HEDR + GO TO 160 + ENDIF + KL=K-1 +! +! Trace along line +! + call pltnod(inode1(1),0) + NTRACT=1 + DO LS=1,KL + CALL TRACE(INODE1(LS),INODE1(LS+1)) + call pltnod(inode1(ls+1),0) + ENDDO + if(ntracT .gt. 0) then + DO KK=1,NTRACT + if(itrac(kk) .eq. 0) go to 300 + XLIN(KK)=CORD(ITRAC(KK),1) + YLIN(KK)=CORD(ITRAC(KK),2) + ENDDO + CALL RRED +!ipk jan01 + CALL THICKL + CALL DASHLN(XLIN,YLIN,NTRACT,0) +!ipk jan01 + CALL THINL + endif + 300 CONTINUE + fpn=inode1(KL+1) + CALL NUMBR(0.5+KL*0.5,7.2,0.2,FPN,0.0,-1) +! +! Get another point +! + GO TO 150 + ENDIF +! +! Exit +! + 500 CONTINUE + END + SUBROUTINE NTONCON(ipos) +! +! Generate Connections +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' +! +! Initialize to zero +! + NCM=MAXECON + DO N=1,NP + DO L=1,NCM + NECON(N,L)=0 + ENDDO + ENDDO +! +! Loop on elements +! + DO N=1,NE +! +! Check to see that this element is active +! + IF(IMAT(N) .NE. 0) THEN + NCN=NCORN(N) +! +! Search to see if connection M and K made +! + +! DO M=1,NCN,2 + DO M=1,NCN,ipos + + +! IF(M .GT. NCN-1) GO TO 200 +! K=M+2 + K=M+ipos + IF(K .GT. NCN) K=1 + DO L=1,NCM + IF(NECON(NOP(N,M),L) .EQ. 0) THEN +! +! This is new connection +! + NECON(NOP(N,M),L)=NOP(N,K) + GO TO 150 + ELSEIF(NECON(NOP(N,M),L) .EQ. NOP(N,K)) THEN +! +! This is an old connection +! + GO TO 150 + ENDIF + ENDDO + 150 CONTINUE +! +! Now look in the revers direction +! + DO L=1,NCM + IF(NECON(NOP(N,K),L) .EQ. 0) THEN + NECON(NOP(N,K),L)=NOP(N,M) +! +! This is new connection +! + GO TO 175 + ELSEIF(NECON(NOP(N,K),L) .EQ. NOP(N,M)) THEN +! +! This is an old connection +! + GO TO 175 + ENDIF + ENDDO + 175 CONTINUE + ENDDO + ENDIF + 200 CONTINUE + ENDDO + +! + RETURN + END + SUBROUTINE TRACE(INODE1,INODE2) +! +! Generate continuity lines +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + DIST(N,M)=(cord(n,1)-cord(m,1))**2+(cord(n,2)-cord(m,2))**2 +! +! Start at INODE1 +! + ITRAC(NTRACT)=INODE1 + LAT=INODE1 + 100 CONTINUE +! +! Look for new nearer node to INODE2 +! + CURR=1.E30 + LAT1=0 + DO K=1,NCM + LATTMP=NECON(LAT,K) + IF(LATTMP .NE. 0) THEN + IF(DIST(INODE2,LATTMP) .LT. CURR) THEN + LAT1=LATTMP + CURR=DIST(INODE2,LATTMP) + ENDIF + ELSE + GO TO 150 + ENDIF + ENDDO + 150 CONTINUE + IF(LAT1 .EQ. 0) RETURN + NTRACT=NTRACT+1 + ITRAC(NTRACT)=LAT1 + IF(LAT1 .EQ. INODE2) RETURN + IF(NTRACT .GT. 350) RETURN + LAT=LAT1 + GO TO 100 + END + + subroutine opencln(ipos) + use winteracter + + implicit none + + include 'd.inc' + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB + LOGICAL :: OPENED + INTEGER :: IPOS,IERR + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INQUIRE(98, OPENED=OPENED) + if(.not. opened) then + CALL WSelectFile(ID_STRING8,SaveDialog+PromptOn,FNAME,'Save continuity line') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='cln' + CALL ADDSUB(FNAME,SUB) + open(98,file=fname, form='formatted', status='unknown') + ENDIF + endif + + call wdialogload(IDD_DIALOG08) + ierr=infoerror(1) + + + call wdialogputRadioButton(idf_radio1) + + + CALL WDialogSelect(IDD_DIALOG08) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,ipos) + ipos=3-ipos + return + endif + ipos= 0 + RETURN + enddo + ipos= 2 + RETURN + END + + +!ipk jan01 + subroutine getcln(ipos) + use winteracter + + implicit none + + include 'd.inc' + + INTEGER :: IPOS,IERR + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + + call wdialogload(IDD_DIALOG010) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_DIALOG010) + ierr=infoerror(1) + + CALL WDialogPutINTEGER(IDF_INTEGER1,IPOS) + + write(90,*) 'iposin',ipos + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetINTEGER(IDF_INTEGER1,IPOS) + write(90,*) 'iposout',ipos + + return + endif + return + enddo + + RETURN + END + SUBROUTINE CHKLIN +! +! Generate continuity lines +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + + IPOS=2 + CALL NTONCON(ipos) + + DO I=1,NCLM + NTRACT=1 + ITRAC(1)=ICCLN(I,1) + DO J=1,350 + INODE1=ICCLN(I,J) + INODE2=ICCLN(I,J+1) + IF(INODE2 .EQ. 0) GO TO 300 + CALL TRACE(INODE1,INODE2) + ENDDO + 300 DO J=1,NTRACT + ICCLN(I,J)=ITRAC(J) + ENDDO + ENDDO + + RETURN + END diff --git a/src/COMPACT.F90 b/src/COMPACT.F90 new file mode 100644 index 0000000..369a921 --- /dev/null +++ b/src/COMPACT.F90 @@ -0,0 +1,120 @@ +!IPK LAST UPDATE jAN 25 2001 CORRECT REFERENCE TO INEW + SUBROUTINE COMPACT(ISW) +! +! Compact nodes or element numbers +! ISW = 3 compact nodes +! ISW = 4 compact elements +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + DIMENSION ICREFN(MAXP),ICREFE(MAXE) +! +! + IF(ISW .EQ. 3) THEN +! +! First compact node list and create cross reference +! + JJ=1 + DO J=1,NP +!IPK JAN01 FIX TEST + IF(INEW(J) .NE. 0) THEN + INEW(JJ)= INEW(J) + CORD(JJ,1)=CORD(J,1) + CORD(JJ,2)=CORD(J,2) + XUSR(JJ)=XUSR(J) + YUSR(JJ)=YUSR(J) + WD(JJ)=WD(J) + LAY(JJ)=LAY(J) + WIDTH(JJ)=WIDTH(J) + SS1(JJ)=SS1(J) + SS2(JJ)=SS2(J) + WIDS(JJ)=WIDS(J) + WIDBS(JJ)=WIDBS(J) + SSO(JJ)=SSO(J) + INSKP(JJ)=INSKP(J) + LOCK(JJ)=LOCK(J) + ICREFN(J)=JJ + JJ=JJ+1 + ENDIF + ENDDO + DO J=JJ,NP + CORD(J,1)=-1.D20 + CORD(J,2)=-1.D20 + XUSR(J)=-1.D20 + YUSR(J)=-1.D20 + WD(J)=-9999. + LAY(J)=-9999 + WIDTH(J)=0. + SS1(J)=0 + SS2(J)=0. + WIDS(J)=0. + WIDBS(J)=0. + SSO(J)=0. + INSKP(J)=1 +!IPK JAN01 ADD INEW + INEW(J)=0 + LOCK(J)=0 + ENDDO + NP=JJ-1 +! +! Next renumber element connections +! + DO N=1,NE + DO M=1,8 + IF(NOP(N,M) .NE. 0) THEN + NOP(N,M)=ICREFN(NOP(N,M)) + ENDIF + ENDDO + ENDDO + +! Renumber continuity lines + + DO I=1,NCLM + DO J=1,350 + IF(ICCLN(I,J) .GT. 0) THEN + ICCLN(I,J)=ICREFN(ICCLN(I,J)) + ENDIF + ENDDO + ENDDO + + ELSEIF(ISW .EQ. 4) THEN +! +! Compact elements +! + JJ=1 + DO J=1,NE + IF(NOP(J,1) .NE. 0) THEN + DO M=1,8 + NOP(JJ,M)=NOP(J,M) + ENDDO + ICREFE(J)=JJ + XC(JJ)=XC(J) + YC(JJ)=YC(J) + IMAT(JJ)=IMAT(J) + THTA(JJ)=THTA(J) + IEM(JJ)=0 + NCORN(JJ)=NCORN(J) + IESKP(JJ)=IESKP(J) + JJ=JJ+1 + ENDIF + ENDDO + DO J=JJ,NE + DO M=1,8 + NOP(J,M)=0 + ENDDO + IMAT(J)=0 + THTA(J)=0 + IEM(J)=0 + NCORN(J)=0 + IESKP(JJ)=-1 + ENDDO + NE=JJ-1 + DO J=1,NLST + DO I=1,LLIST(J) + ILIST(J,I)=ICREFE(ILIST(J,I)) + ENDDO + ENDDO + ENDIF + RETURN + END diff --git a/src/COMPSCAL.F90 b/src/COMPSCAL.F90 new file mode 100644 index 0000000..4248ab6 --- /dev/null +++ b/src/COMPSCAL.F90 @@ -0,0 +1,147 @@ + SUBROUTINE COMPWGT + + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! COMMON/ICN1/ ICN(MAXP) + + DIST(X1,X2,Y1,Y2)=SQRT((X1-X2)**2+(Y1-Y2)**2) + + DO J=1,MAXP + ICN(J)=0 + END DO +! First sort out the potential midsides +! Note that transition elements caues a problem +! Find these first + DO 200 N=1,NE + if(NCORN(N) .GT. 5) GO TO 200 + IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN +! +! We have a transition mark node number as if it were corner +! + ICN(NOP(N,3))=-1 + ICN(NOP(N,1))=IMAT(N) + ICN(NOP(N,4))=IMAT(N) + ICN(NOP(N,5))=IMAT(N) + ELSE +! +! Store ICN = 2 for corner nodes +! + NCN=NCORN(N) +!IPKOCT93 IF(IMAT(N) .GT. 900) THEN + IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN + GO TO 185 + ELSE + MST=2 + ENDIF + + DO 180 M=1,NCN,MST + ICN(NOP(N,M))=IMAT(N) + 180 CONTINUE + 185 CONTINUE + ENDIF + 200 END DO + + DO N=1,NP + IF(ICN(N) .GT. 0) THEN + ADIST=1.E20 + DO J=1,NCRSEC + IF(ICN(N) .EQ. NOREACH(IVMIL(J))) THEN + A1=DIST(XUSR(N),XCRS(IVMIL(J)),YUSR(N),YCRS(IVMIL(J))) + IF(A1 .LT. ADIST) THEN + ADIST=A1 + NSEC1=IVMIL(J) + ENDIF + ENDIF + ENDDO +!IPK JUN04 + IF(ADIST .EQ. 1.E20) THEN + NRIVCR1(N)=0 + NRIVCR2(N)=0 + WTRIVCR1(N)=0 + WTRIVCR2(N)=0 + ELSE + BDIST=1.E20 + DO J=1,NCRSEC + IF(ICN(N) .EQ. NOREACH(IVMIL(J))) THEN + IF(IVMIL(J) .NE. NSEC1) THEN + A1=DIST(XUSR(N),XCRS(IVMIL(J)),YUSR(N),YCRS(IVMIL(J))) + A2=DIST(XCRS(NSEC1),XCRS(IVMIL(J)),YCRS(NSEC1),YCRS(IVMIL(J))) + +! A1 IS DISTANCE TO NODE +! A2 IS DISTANCE TO RECORDED POINT + + IF(A2 .GE. A1) THEN + IF(A1 .LT. BDIST) THEN + BDIST=A1 + NSEC2=IVMIL(J) + ENDIF + ENDIF + ENDIF + ENDIF + ENDDO + IF(BDIST .EQ. 1.E20) NSEC2=NSEC1 + NRIVCR1(N)=NSEC1 + NRIVCR2(N)=NSEC2 + WTRIVCR1(N)=BDIST/(ADIST+BDIST) + WTRIVCR2(N)=ADIST/(ADIST+BDIST) + ENDIF + ENDIF + ENDDO + RETURN + END + + SUBROUTINE GETCSLOC + use winteracter + USE BLK1MOD +! INCLUDE 'BLK1.COM' + INCLUDE 'TXFRM.COM' +!- + + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + INTEGER :: IERR,ISET,IBOX + REAL :: ASET + CHARACTER*1 :: IFLAG + + call wdialogload(IDD_CSLOC) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_CSLOC) + ierr=infoerror(1) + + ISET=1 + 100 continue + + + CALL WDialogPutINTEGER(IDF_INTEGER1,ISET) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + DO +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + + CALL WDialogGetINTEGER(IDF_INTEGER1,ISET) + GO TO 200 + else + RETURN + endif + ENDDO + 200 CONTINUE + + CALL XYLOC(XX,YY,IFLAG,IBOX) + IF(IRMAIN .EQ. 1) RETURN + XCRS(ISET) = XX*TXSCAL - XS + YCRS(ISET) = YY*TXSCAL - YS + GO TO 100 + + RETURN + END \ No newline at end of file diff --git a/src/CONT.F90 b/src/CONT.F90 new file mode 100644 index 0000000..1b16844 --- /dev/null +++ b/src/CONT.F90 @@ -0,0 +1,300 @@ + SUBROUTINE CONOUT(MENUS) +! + USE WINTERACTER + USE BLK1MOD + SAVE +! INCLUDE 'BLK1.COM' +! + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL +! + DIMENSION VALUS(MAXP) + + CHARACTER*60 STRELS + + DATA STRELS/' You have tried to reorder before executing "FILL"'/ +! +! +! Test to make sure fill has been executed. +! + IF(MENUUS .EQ. 13) ifilltmp=0 + DO N=1,NE + IF(IMAT(N) .GT. 0) THEN + DO M=2,NCORN(N),2 +!ipkoct93 + if(imat(n) .LT. 900) THEN + IF(NOP(N,M) .EQ. 0) THEN + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'You have tried to plot contours before filling'//char(13)//& + 'Do you wish to temporarily fill and proceed?'//& + CHAR(13)//' ','PLOTTING CONTOURS WITHOUT A FILLED NETWORK?') +! +! If answer 'No', return +! + IF (WInfoDialog(4).EQ.2) THEN + RETURN + ENDIF + CALL FILM(1) + ifilltmp=1 + call hedr + GO TO 300 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO +! +300 CONTINUE + DO N=1,NP + VALUS(N)=WD(N) + ENDDO +! + CALL TOLMAX(VALUS,TTMIN,TTMAX) + + ISZ=0 + IF(MENUS .EQ. 13) THEN + ISZ=1 + CALL CSET(TTMIN,TTMAX,isz) + RETURN + ENDIF + + PSCL=1.0 + CALL ELCONT(VALUS,PSCL) + + if(ifilltmp .eq. 1) CALL DELETM(0) + + RETURN + END + SUBROUTINE ELCONT(VALUS,PSCL) +! +! Routine to draw element contours +! + USE BLK1MOD + +! INCLUDE 'BLK1.COM' +! + INCLUDE 'BFILES.I90' + COMMON /BRK/ X(10),Y(10),VL(10),DL(10),VLM(10) + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL + LOGICAL SWITCH +! DIMENSION X(10),Y(10),VL(10),VALUS(*) + DIMENSION VALUS(*) + DATA PSCL1/1.0/ITIME/0/ + + IF(PSCL .eq. 0.) then + PSCL=PSCL1 + ELSE + PSCL1=PSCL + ENDIF + CALL RRed + + CALL GETXC + + IF(.NOT. ALLOCATED(NKEY1)) THEN + ALLOCATE (NKEY1(MAXE)) + ENDIF + CALL SORTDB(YC,NKEY1,NE) + + DO 500 NN=NE,1,-1 + N=NKEY1(NN) + IF(IESKP(N) .EQ. 1) GO TO 500 + NCN=NCORN(N) + IF(NCN .EQ. 9) NCN=8 + DO M=1,NCN,2 + if(nop(n,m) .eq. 0) go to 500 + IF(VALUS(NOP(N,M)) .LT. -9998.) GO TO 500 + ENDDO +! +! Copy values into work array +! + NCN=NCORN(N) +! if(ncn .lt. 6) go to 500 + IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) GO TO 500 + IOK=0 + DO 300 M=1,NCN + IF(NOP(N,M) .EQ. 0) GO TO 500 + X(M)=CORD(NOP(N,M),1) + Y(M)=CORD(NOP(N,M),2) + IF(I3DVIEW .EQ. 1) THEN + IF(VRTSCAL .GT. 0.) THEN + Y(M)=Y(M)+(WD(NOP(N,M))-VRTORIG)*COS(VANG/57.29578)/VRTSCAL + ENDIF + ENDIF + + IF(X(M) .GT. 0. .AND. X(M) .LT. HSIZE) THEN + IF(Y(M) .GT. 0. .AND. Y(M) .LT. 7.) THEN + IOK=1 + ENDIF + ENDIF + VL(M)=VALUS(NOP(N,M))*PSCL + 300 CONTINUE + IF(IOK .EQ. 0) GO TO 500 +! CALL BRKDWN(X,Y,VL,NCN) + NELNO=N + CALL BRKDWN(NCN,NELNO) + +!ipkoct93 + if(ipsw(4) .eq. 1) then + NLINP=NCN+1 + X(NLINP)=X(1) + Y(NLINP)=Y(1) + CALL DASHLN(X,Y,NLINP,0) + endif + + 500 CONTINUE +! +! Print title +! + ncharr=lenstr(title) + call rblue + IF(NCHARR .GT. 1) CALL SYMBL(0.5,7.25,0.20,TITLE,0.0,ncharr) + + XLEG=8.8 + YLEG=7.4 + + CALL LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL) + CALL RBlue + RETURN + END + + SUBROUTINE LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL) + SAVE + DIMENSION CONTUR(99),X(10),Y(10) + DATA LDIGO/2/ + XLOC=XLEG+0.5 + YLOC=YLEG + csfact=1.0001 + DO 80 N=1,NUMV + IF(N .LT. NUMV) THEN +! +! Define polygon +! + X(1)=XLEG + X(2)=XLEG + X(3)=XLEG+0.4 + X(4)=XLEG+0.4 + Y(1)=YLOC + Y(2)=YLOC-0.3 + Y(3)=YLOC-0.3 + Y(4)=YLOC + nn=(n+1)*csfact + if(numv .le. 10) nn=nn+2 + CALL POLYG(X,Y,4,nn) + ENDIF +! +! Plot the value on the screen +! + if(contur(n) .ne. 0.) then + DIG = ALOG10(ABS(CONTUR(N))) + else + dig = -2. + endif + IF(DIG .GT. 2.999) THEN + LDIG=-DIG - 1 + ELSEIF (DIG .GT. 1.999) THEN + LDIG = 0 + ELSEIF (DIG .GT. 0.999) THEN + LDIG = 1 + ELSEIF (DIG .GT. 0) THEN + LDIG = 2 + ELSE + LDIG = DIG - 2. + .01 + LDIG = -LDIG + ENDIF + IF(LDIG .LT. 0) GO TO 70 + DO 60 KK=1,3 + ANUM=10.**(-LDIG) + IF(N .EQ. 1) THEN + IF(ABS(CONTUR(2)-CONTUR(1)) .LT. ANUM) THEN + LDIG = LDIG + 1 + ELSE + GO TO 70 + ENDIF + ELSE + IF(ABS(CONTUR(N)-CONTUR(N-1)) .LT. ANUM) THEN + LDIG = LDIG + 1 + ELSE + GO TO 70 + ENDIF + ENDIF + 60 CONTINUE + 70 CONTINUE + call rblue + CTMP=CONTUR(N) + IF(ABS(CTMP) .LT. 1.E-7) THEN + CTMP=0. + LDIG=LDIGO + ENDIF + + CALL rblack + CALL NUMBR(XLOC,YLOC-0.09,0.2,CTMP,0.0,LDIG) + LDIGO=LDIG + CALL rblack +! + CALL PLOTT(X(1),Y(1),3) + CALL PLOTT(X(2),Y(2),2) + CALL PLOTT(X(3),Y(3),2) + CALL PLOTT(X(4),Y(4),2) + CALL PLOTT(X(1),Y(1),2) +! + YLOC=YLOC-0.30 + 80 CONTINUE + CALL RBlue + RETURN + END + + + SUBROUTINE TOLMAX(VALUS,TTMIN,TTMAX) +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + DIMENSION VALUS(*) +! + TMAX = -1.E+20 + TMIN = 1.E+20 + DO 218 J=1,NP + IF (VALUS(J) .GT. TMAX) THEN + TMAX = VALUS(J) + ITMAX = J + ENDIF + IF (VALUS(J) .LT. TMIN) THEN + TMIN = VALUS(J) + ITMIN = J + ENDIF + 218 CONTINUE + WRITE(90,*) ' ' + WRITE(90,*) ' Max, Min for entire network ' + WRITE(90,*) ' MAX value = ', TMAX, ' at node ', ITMAX + WRITE(90,*) ' MIN value = ', TMIN, ' at node ', ITMIN + WRITE(90,*) ' ' +! +! Check for max and min values of elements in the plotting area +! + TTMAX = -1.E+20 + TTMIN = 1.E+20 + DO 228 N=1,NE + IF(IESKP(N) .EQ. 0) THEN + DO 220 M=1,NCORN(N) + J=NOP(N,M) +!ipk sep99 + if(j .eq. 0) go to 220 + IF (VALUS(J) .GT. TTMAX) THEN + TTMAX = VALUS(J) + ITTMAX = J + ENDIF + IF (VALUS(J) .LT. TTMIN) THEN + TTMIN = VALUS(J) + ITTMIN = J + ENDIF + 220 CONTINUE + ENDIF + 228 CONTINUE +! + WRITE(90,*) ' ' + WRITE(90,*) ' Max, Min for plot area ' + WRITE(90,*) ' MAX value = ', TTMAX, ' at node ', ITTMAX + WRITE(90,*) ' MIN value = ', TTMIN, ' at node ', ITTMIN +! + RETURN + END + + diff --git a/src/CREATGRID.f90 b/src/CREATGRID.f90 new file mode 100644 index 0000000..57b3a04 --- /dev/null +++ b/src/CREATGRID.f90 @@ -0,0 +1,193 @@ + PROGRAM creatgrid + dimension XL(100,2),YL(100,2),mappt(2),XL1(100),XL2(100) + REAL*8 GRIDX(100),GRIDY(100) +! +! define line numbers in map file +! + DIST(A,B,C,D)=SQRT((C-A)*2+(D-C)**2) + XL(1,1)=0. + XL(2,1)=320. + XL(3,1)=530. + YL(1,1)=0. + YL(2,1)=20. + YL(3,1)=50. + MAPPT(1)=3 + XL(1,2)=0. + XL(2,2)=600. + YL(1,2)=70. + YL(2,2)=90. + MAPPT(2)=2 + K1=1 + K2=2 + +! +! compute line length +! + XL1=0. + nlpts1=mappt(k1) + do n=2,nlpts1 + XL1(n)=XL1(n-1)+dist(XL(n-1,1),YL(n-1,1),XL(n,1),YL(n,1)) + enddo + XL2=0. + nlpts2=mappt(k2) + do n=2,nlpts2 + XL2(n)=XL2(n-1)+dist(XL(n-1,2),YL(n-1,2),XL(n,2),YL(n,2)) + enddo + xmean=(XL1(nlpts1)+XL2(nlpts2))/2. +! +! get size spacing +! +! read xsz,NY + XSZ=100. + NY=5 + along=xmean/xsz + NX=(along+0.99) + + NXP=NX+1 + NYP=NY+1 + NRL=NX*NYP+1 + NRT=NXP*NYP + +! DO N=1,NE +! DO M=1,8 +! NOPSV(N,M)=NOP(N,M) +! ENDDO +! IMATSV(N)=IMAT(N) +! ENDDO +! NESAV=NE +! NEFSAV=NENTRY +! NPUNDO=NRT +! +! Initialize GRIDX and GRIDY +! + DO N=1,NRT + GRIDX(N)=0. + GRIDY(N)=0. +! IGSKP(N)=0 + END DO +! +! calculate lengths +! + xalong1=XL1(nlpts1)/NX + xalong2=XL2(nlpts2)/NX +! +! compute cords along the edges +! + XALONG=0. + XXALONG=0. + GRIDX(1)=XL(1,1) + GRIDY(1)=YL(1,1) + GRIDX(NYP)=XL(1,2) + GRIDY(NYP)=YL(1,2) + NRT=NXP*NYP + DO N=NY+2,NRT,NYP + XALONG=XALONG+XALONG1 + NX1=2 + DO M=NX1,NLPTS1 + IF(XALONG .LT. XL1(M)) THEN + M1=M + GO TO 200 + ENDIF + ENDDO + 200 CONTINUE + FRAC1=(XALONG-XL1(M1-1))/(XL1(M1)-XL1(M1-1)) + GRIDX(N)=XL(m1-1,1)+FRAC1*(XL(m1,1)-XL(m1-1,1)) + GRIDY(N)=YL(m1-1,1)+FRAC1*(YL(m1,1)-YL(m1-1,1)) + NX1=M1 + XXALONG=XXALONG+XALONG2 + NX2=2 + DO M=NX2,NLPTS2 + IF(XXALONG .LT. XL2(M)) THEN + M2=M + GO TO 250 + ENDIF + ENDDO + 250 CONTINUE + FRAC1=(XXALONG-XL2(M2-1))/(XL2(M2)-XL2(M2-1)) + GRIDX(N+NY)=XL(m2-1,2)+FRAC1*(XL(m2,2)-XL(m2-1,2)) + GRIDY(N+NY)=YL(m2-1,2)+FRAC1*(YL(m2,2)-YL(m2-1,2)) + NX2=M2 + ENDDO +! +! +! check if points ok allow for move +! +! +! form elements and other coordinates +! +! +! Interpolate interior points +! + DO M=1,NRT,NYP + NFS=NRL+M-1 + CALL INTERP(GRIDX,GRIDY,M,M+NY,1,GRIDX(M),GRIDY(M),GRIDX(M+NY) & + & ,GRIDY(M+NY),NY,0) +! DO N=M,NFS +! XTEMP=GRIDX(N) +! YTEMP=GRIDY(N) +! GRIDXL(N) = GRIDX(N)*TXSCAL - XS +! GRIDYL(N) = GRIDY(N)*TXSCAL - YS +! CALL RRed +! call drawcr(xtemp,ytemp,siz) +! CALL RBlue +! ENDDO + END DO +! +! query for depths +! +! +! query for happY + STOP + end + SUBROUTINE INTERP(GRIDX,GRIDY,NL,NH,INT,ALX,ALY,ATX,ATY,NINT,ISWT) +! +! Routine to fill GRIDX and GRIDY by interpolation +! NL = START OF GENERATED +! NH = END OF GENERATED +! INT = INTERVAL +! ALX, ALY = START LOC +! ATX, ATY = END LOC +! NINT = NUMBER OF POINTS +! ISWT = 0 BASELINE = 1 APPLY CHANGES +!IPK MAY02 + REAL*8 GRIDX(NH),GRIDY(NH),ALX,ALY,ATX,ATY +! +! Compute intervals +! + XINT=(ATX-ALX)/FLOAT(NINT) + YINT=(ATY-ALY)/FLOAT(NINT) +! +! Generate points +! + IF(ISWT .EQ. 0) THEN + KP=0 + DO 200 K=NL,NH,INT + IF(KP .EQ. 0) THEN + GRIDX(K)=ALX + GRIDY(K)=ALY + ELSE + GRIDX(K)=GRIDX(KP)+XINT + GRIDY(K)=GRIDY(KP)+YINT + ENDIF + KP=K + 200 CONTINUE + ELSE + XAD=ALX + YAD=ALY + KP=0 + DO 220 K=NL,NH,INT + IF(KP .EQ. 0) THEN + GRIDX(K)=GRIDX(K)+XAD + GRIDY(K)=GRIDY(K)+YAD + ELSE + XAD=XAD+XINT + YAD=YAD+YINT + GRIDX(K)=GRIDX(K)+XAD + GRIDY(K)=GRIDY(K)+YAD + ENDIF + KP=K + 220 CONTINUE + ENDIF + RETURN + END + \ No newline at end of file diff --git a/src/CREATM.F90 b/src/CREATM.F90 new file mode 100644 index 0000000..dcfe928 --- /dev/null +++ b/src/CREATM.F90 @@ -0,0 +1,278 @@ + SUBROUTINE CREATM + + + USE BLKMAP + USE BLK1MOD + USE BLK2MOD +! Routine to create mesh from map contour lines + + COMMON /CRMAP/ NCONT,CVALUE(1000),MSTART(1000),MFIN(1000),CINTDIS(1000),IACTCV(1000) + +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + +! Search map data for contoour lines and setup values + + JS=1 + NCONT=0 +! + K=0 + DO 20 J=1,MAXPTS + MLEN=J-JS + IF(XMAP(J) .LE. VDX .or. j .eq. maxpts) THEN +! +! We have found a line end, is itmore than 1 point long? +! + K=K+1 + IF(MLEN .GT. 1) THEN + LTP=LINTYP(K) + + IF(LTP .NE. 2) THEN + IF(LTP .GT. 0) THEN + NCONT=NCONT+1 + CVALUE(NCONT)=VAL(JS) + MSTART(NCONT)=JS + IF(XMAP(J) .LE. VDX) THEN + MFIN(NCONT)=J-1 + ELSE + MFIN(NCONT)=J + ENDIF + ENDIF + ENDIF + ENDIF + IF(MLEN .EQ. 0 .AND. LINTYP(K) .EQ. -999) GO TO 30 + JS=J+1 + ENDIF + 20 CONTINUE + 30 CONTINUE + + +! Choose options and intervals + + CALL PANELCRT(NCONT,CVALUE,IACTCV,CINTDIS,ICAN) + IF(ICAN .EQ. 1) RETURN + +! First form list of nodes working along contour lines + + CALL CFORM + +! Now generate elements + + do n=1,np + list(n)=1 + enddo + + call deln2(np,0) + + call checkpoly + + RETURN + END + + SUBROUTINE PANELCRT(N1,R2,N3,R4,N5) + +! Choose options and intervals + + use winteracter + + implicit none + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3(1000),IERR,ITIME,K,N5,NA,NB + real :: R2(1000),R4(1000) + data itime/0/ + + if(itime .eq. 0) then + n2=0 + na=1 + nb=1 + itime=1 + do k=1,1000 + r4(k)=500. + n3(k)=1 + enddo + endif + + call wdialogload(IDD_CREATM1) + ierr=infoerror(1) + + CALL WDialogPutCheckBox(idf_check1,na) + CALL WDialogPutCheckBox(idf_check2,nb) + CALL WDialogPutReal(idf_real1,r4(1)) + + CALL WDialogSelect(IDD_CREATM1) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetCheckBox(idf_check1,na) + CALL WDialogGetCheckBox(idf_check2,nb) + if(nb .eq. 1) then + CALL WDialogGetReal(idf_real1,r4(1)) + do k=1,1000 + r4(k)=r4(1) + enddo + endif + N5=0 + ELSE + N5=1 + RETURN + + ENDIF + + if(na .eq. 1 .and. nb .eq. 1) return + + call wdialogload(IDD_CREATM) + ierr=infoerror(1) + + CALL WGridPutCheckBox(idf_grid1,1,n3,n1) + CALL WGridPutReal(idf_grid1,2,r2,n1) + CALL WGridPutReal(idf_grid1,3,r4,n1) + + CALL WDialogSelect(IDD_CREATM) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WGridGetCheckBox(idf_grid1,1,n3,n1) + CALL WGridGetReal(idf_grid1,2,r2,n1) + CALL WGridGetReal(idf_grid1,3,r4,n1) + N5=0 + ELSE + N5=1 + RETURN + + ENDIF + RETURN + END + + SUBROUTINE CFORM + +! Form list of nodes working along contour lines + + USE BLKMAP + USE BLK1MOD + + COMMON /CRMAP/ NCONT,CVALUE(1000),MSTART(1000),MFIN(1000),CINTDIS(1000),IACTCV(1000) + +! INCLUDE 'BLK1.COM' + INCLUDE 'TXFRM.COM' + + DISTC(N1,N2)=SQRT((XMAP(N1)-XMAP(N2))**2 & + & +(YMAP(N1)-YMAP(N2))**2) + +! Loop through each active contour + + DO N=1,NCONT + IF(IACTCV(N) .EQ. 1) THEN + JS=MSTART(N) + JF=MFIN(N) + IF(XMAP(JS) .EQ. XMAP(JF) .AND. YMAP(JS) .EQ. YMAP(JF)) THEN + IF(JF .GT. JS) JF=JF-1 + ENDIF + IEND=0 + DO J=JS,JF + IF(J .EQ. JS) THEN + CDONE=0. + CNODE=0 + CALL GETNOD(JJ) + INSKP(JJ)=0 + INEW(JJ) = 1 +! + XUSR(JJ) = XMAP(J) + YUSR(JJ) = YMAP(J) + CORD(JJ,1)=(XUSR(JJ)+XS)/TXSCAL + CORD(JJ,2)=(YUSR(JJ)+YS)/TXSCAL + WD(JJ)=CVALUE(N) + WIDTH(JJ)=0. + SS1(JJ)=0. + SS2(JJ)=0. + WIDS(JJ)=0. + WIDBS(JJ)=0. + SSO(JJ)=0. + IF (JJ .GT. NP) NP = JJ + CALL PLTNOD(JJ,0) + ICHG=0 + ELSE + CNODEO=CNODE + CNODE=CNODE+DISTC(J,J-1) + 200 CONTINUE + CDIS=CDONE+CINTDIS(N) + IF(CDIS .LE. CNODE .OR. J .EQ. JF) THEN + IF(CDIS .LE. CNODE) THEN + FACT=(CDIS-CNODEO)/(DISTC(J,J-1)) + IF(J .EQ. JF .AND. FACT .GT. 0.999) IEND=1 + ELSE + FACT=1.0 + IEND=1 + ENDIF + CALL GETNOD(JJ) + INSKP(JJ)=0 + INEW(JJ) = 1 +! + XUSR(JJ) = (1.-FACT)*XMAP(J-1)+FACT*XMAP(J) + YUSR(JJ) = (1.-FACT)*YMAP(J-1)+FACT*YMAP(J) + CORD(JJ,1)=(XUSR(JJ)+XS)/TXSCAL + CORD(JJ,2)=(YUSR(JJ)+YS)/TXSCAL + WD(JJ)=CVALUE(N) + WIDTH(JJ)=0. + SS1(JJ)=0. + SS2(JJ)=0. + WIDS(JJ)=0. + WIDBS(JJ)=0. + SSO(JJ)=0. + IF (JJ .GT. NP) NP = JJ + CALL PLTNOD(JJ,0) + ICHG=0 + CDONE=CDIS + IF(IEND .NE. 1) GO TO 200 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + RETURN + END + + SUBROUTINE CHECKPOLY + +! CHECK IF ELEMENTS ARE OUTSIDE POLYGON BY LOOKING AT CENTROID + USE BLKOUT + USE BLK1MOD + + IF(NOUTLIN .EQ. 0) RETURN + + call FILM(1) + NETEMP=NE + DO N=1,NETEMP + IF(IMAT(N) .EQ. 0) CYCLE + XM=(XUSR(NOP(N,1))+XUSR(NOP(N,3))+XUSR(NOP(N,5)))/3. + YM=(YUSR(NOP(N,1))+YUSR(NOP(N,3))+YUSR(NOP(N,5)))/3. +! do k=2,6,2 +! xm=xusr(nop(n,k)) +! ym=yusr(nop(n,k)) + if( IGRInsidePolygon(xoutl,youtl,noutlin,xm,ym)) then + + else + CALL DELTEL(n) + go to 200 + endif +! enddo + +200 continue + ENDDO + RETURN + END \ No newline at end of file diff --git a/src/CRGRID.f90 b/src/CRGRID.f90 new file mode 100644 index 0000000..59feea3 --- /dev/null +++ b/src/CRGRID.f90 @@ -0,0 +1,376 @@ + SUBROUTINE crgrid + USE BLK1MOD + USE BLKMAP + REAL*8 GRIDX,GRIDY,GRIDXL,GRIDYL,XL,YL,ANGD,GETANG1,A,B,C,D + INTEGER*2 IGSKP + dimension XL(1500,3),YL(1500,3),mappt(2),XL1(500),XL2(500) + INCLUDE 'TXFRM.COM' + COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& + ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) +! +! define line numbers in map file +! + ITEST=1 + CALL PANELGENBLK(NY,XSZ,KL1,KL2,ISW1,ISW2,ITEST) + JS=1 +! + K=0 + KL=1 + CALL RCyan + DO 20 J=1,MAXPTS + MLEN=J-JS + IF(XMAP(J) .LE. VDX .or. j .eq. maxpts) THEN + IF(J .EQ. MAXPTS .AND. XMAP(J) .GT. VDX) MLEN=MLEN+1 +! +! + K=K+1 + IF(K .EQ. KL2) THEN + DO KK=1,MLEN + XL(KK,1)=XMAP(KK+JS-1) + YL(KK,1)=YMAP(KK+JS-1) + ENDDO + IF(ISW2 .EQ. 1) THEN + DO KK=MLEN,1,-1 + XL(KK,3)=XL(MLEN-KK+1,1) + YL(KK,3)=YL(MLEN-KK+1,1) + ENDDO + DO KK=1,MLEN + XL(KK,1)=XL(KK,3) + YL(KK,1)=YL(KK,3) + ENDDO + ENDIF + MAPPT(1)=MLEN + ENDIF + IF(K .EQ. KL1) THEN + DO KK=1,MLEN + XL(KK,2)=XMAP(KK+JS-1) + YL(KK,2)=YMAP(KK+JS-1) + ENDDO + IF(ISW1 .EQ. 1) THEN + DO KK=MLEN,1,-1 + XL(KK,3)=XL(MLEN-KK+1,2) + YL(KK,3)=YL(MLEN-KK+1,2) + ENDDO + DO KK=1,MLEN + XL(KK,2)=XL(KK,3) + YL(KK,2)=YL(KK,3) + ENDDO + ENDIF + MAPPT(2)=MLEN + ENDIF + JS=J+1 + KL=2 + ENDIF + 20 CONTINUE + K1=1 + K2=2 +! +! compute line length +! + XL1=0. + nlpts1=mappt(k1) + do n=2,nlpts1 + XL1(n)=XL1(n-1)+SQRT((XL(N,1)-XL(n-1,1))**2+(YL(n,1)-YL(n-1,1))**2) + enddo + XL2=0. + nlpts2=mappt(k2) + do n=2,nlpts2 + XL2(n)=XL2(n-1)+SQRT((XL(N,2)-XL(n-1,2))**2+(YL(n,2)-YL(n-1,2))**2) + enddo + xmean=(XL1(nlpts1)+XL2(nlpts2))/2. +! +! get size spacing +! + along=xmean/xsz + NX=(along+0.99) + + NXP=NX+1 + NYP=NY+1 + NRL=NX*NYP+1 + NRT=NXP*NYP + + DO N=1,NE + DO M=1,8 + NOPSV(N,M)=NOP(N,M) + ENDDO + IMATSV(N)=IMAT(N) + ENDDO + NESAV=NE + NEFSAV=NENTRY + NPUNDO=NRT + +! Initialize GRIDX and GRIDY + + DO N=1,NRT + GRIDX(N)=0. +! GRIDY(N)=0. + IGSKP(N)=0 + END DO +! +! calculate lengths +! + xalong1=XL1(nlpts1)/NX + xalong2=XL2(nlpts2)/NX +! +! compute cords along the edges +! + XALONG=0. + XXALONG=0. + GRIDX(1)=XL(1,1) + GRIDY(1)=YL(1,1) + GRIDX(NYP)=XL(1,2) + GRIDY(NYP)=YL(1,2) + NRT=NXP*NYP + NX1=2 + NX2=2 + NCR=1 + DO N=NY+2,NRT,NYP + NCR=NCR+1 + XALONG=XALONG+XALONG1 + DO M=NX1,NLPTS1 + IF(XALONG .LT. XL1(M)) THEN + M1=M + GO TO 200 + ENDIF + ENDDO + 200 CONTINUE + FRAC1=(XALONG-XL1(M1-1))/(XL1(M1)-XL1(M1-1)) + GRIDX(N)=XL(m1-1,1)+FRAC1*(XL(m1,1)-XL(m1-1,1)) + GRIDY(N)=YL(m1-1,1)+FRAC1*(YL(m1,1)-YL(m1-1,1)) + NX1=M1 + XXALONG=XXALONG+XALONG2 + DO M=NX2,NLPTS2 + IF(XXALONG .LT. XL2(M)) THEN + M2=M + GO TO 250 + ENDIF + ENDDO + 250 CONTINUE + FRAC1=(XXALONG-XL2(M2-1))/(XL2(M2)-XL2(M2-1)) + GRIDX(N+NY)=XL(m2-1,2)+FRAC1*(XL(m2,2)-XL(m2-1,2)) + GRIDY(N+NY)=YL(m2-1,2)+FRAC1*(YL(m2,2)-YL(m2-1,2)) + NX2=M2 + + ANGD1=GETANG1(GRIDX(N-NY-1),GRIDY(N-NY-1),GRIDX(N),GRIDY(N),GRIDX(N+NY),GRIDY(N+NY)) + ANGD2=GETANG1(GRIDX(N),GRIDY(N),GRIDX(N+NY),GRIDY(N+NY),GRIDX(N-1),GRIDY(N-1)) + ANGM1=(ANGD1+180-ANGD2)/2. +! WRITE(151,*) N,ANGD1,ANGD2,ANGM1 + IF(ITEST .EQ. 1) THEN + XALONGKP=XALONG + XXALONGKP=XXALONG +! write(151,*) 'b',xalong,xxalong + IF(ANGM1 .GT. 100. .OR. ANGM1 .LT. 80.) THEN + IF(ANGM1 .GT. 100) THEN + XALONG=XALONG+XALONG1/2. + XXALONG=XXALONG-XALONG2/2. + ELSE + XALONG=XALONG-XALONG1/2. + XXALONG=XXALONG+XALONG2/2. + ENDIF +! WRITE(151,*) 'a',XALONG,XXALONG + itag=0 + 275 CONTINUE + DO M=1,NLPTS1 + IF(XALONG .LT. XL1(M)) THEN + M1=M + GO TO 300 + ENDIF + ENDDO + 300 CONTINUE + FRAC1=(XALONG-XL1(M1-1))/(XL1(M1)-XL1(M1-1)) + GRIDX(N)=XL(m1-1,1)+FRAC1*(XL(m1,1)-XL(m1-1,1)) + GRIDY(N)=YL(m1-1,1)+FRAC1*(YL(m1,1)-YL(m1-1,1)) + NX1=M1 + DO M=1,NLPTS2 + IF(XXALONG .LT. XL2(M)) THEN + M2=M + GO TO 350 + ENDIF + ENDDO + 350 CONTINUE + FRAC1=(XXALONG-XL2(M2-1))/(XL2(M2)-XL2(M2-1)) + GRIDX(N+NY)=XL(m2-1,2)+FRAC1*(XL(m2,2)-XL(m2-1,2)) + GRIDY(N+NY)=YL(m2-1,2)+FRAC1*(YL(m2,2)-YL(m2-1,2)) + NX2=M2 + ANGD3=GETANG1(GRIDX(N-NY-1),GRIDY(N-NY-1),GRIDX(N),GRIDY(N),GRIDX(N+NY),GRIDY(N+NY)) + ANGD4=GETANG1(GRIDX(N),GRIDY(N),GRIDX(N+NY),GRIDY(N+NY),GRIDX(N-1),GRIDY(N-1)) + ANGM2=(ANGD3+180-ANGD4)/2. +! WRITE(151,*) N,ANGD3,ANGD4,ANGM2 + if(itag .eq. itest) go to 375 + IF(ANGM1 .LT. 80. .AND. ANGM2 .GT. 100.) THEN + FRAC=(ANGM2-90)/(ANGM2-ANGM1) + XALONG=XALONG+XALONG1/2.*FRAC + XXALONG=XXALONG-XALONG2/2.*FRAC + itag=1 +! WRITE(151,*) XALONG,XXALONG + GO TO 275 + ELSEIF(ANGM1 .GT. 100. .AND. ANGM2 .LT. 80.) THEN + FRAC=(90-ANGM2)/(ANGM1-ANGM2) + XALONG=XALONG-XALONG1/2.*FRAC + XXALONG=XXALONG+XALONG2/2.*FRAC + itag=1 +! WRITE(151,*) XALONG,XXALONG + GO TO 275 +! WRITE(151,*) XALONG,XXALONG + ENDIF + XALONG1=(XL1(nlpts1)-XALONG)/(NXP-NCR) + XALONG2=(XL2(nlpts2)-XXALONG)/(NXP-NCR) + 375 continue + ENDIF + ENDIF + ENDDO +! +! +! check if points ok allow for move +! +! +! form elements and other coordinates +! +! +! Interpolate interior points +! + DO M=1,NRT,NYP + NFS=NRL+M-1 + CALL INTERP(GRIDX,GRIDY,M,M+NY,1,GRIDX(M),GRIDY(M),GRIDX(M+NY) & + & ,GRIDY(M+NY),NY,0) + DO N=M,M+NY + GRIDXL(N)=GRIDX(N) + GRIDYL(N)=GRIDY(N) + GRIDX(N) =(GRIDXL(N)+XS)/TXSCAL + GRIDY(N) =(GRIDYL(N)+YS)/TXSCAL + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + SIZ=0.1 + CALL RRed + call drawcr(xtemp,ytemp,siz) + CALL RBlue + ENDDO + END DO +! +! query for depths +! +! +! query for happY + DO 500 N=1,NRT +! +! Find next blank node in CORD +! + CALL GETNOD(J) + NODDEL(N)=J +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = GRIDX(N) + CORD(J,2) = GRIDY(N) + IGRIDE(N) = J + INEW(J) = 1 + INSKP(J) = 0 + WD(J)=-9999. +! + XUSR(J) = GRIDX(N)*TXSCAL - XS + YUSR(J) = GRIDY(N)*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) +! + 500 END DO +! +! Generate elements +! + CALL GETELM(K) + IECHG=0 +! + DO 600 I=1,NX + DO 590 J=1,NY + CALL GETELM(K) + NOP(K,1)=IGRIDE((I-1)*NYP+J) + NOP(K,2)=0 + NOP(K,3)=IGRIDE(I*NYP+J) + NOP(K,4)=0 + NOP(K,5)=IGRIDE(I*NYP+J+1) + NOP(K,6)=0 + NOP(K,7)=IGRIDE((I-1)*NYP+J+1) + NOP(K,8)=0 + IMAT(K)=1 +! IF(K .GT. NE) NE=K + NCORN(K)=8 + IESKP(K)=0 +!IPK JAN98 + IERC=0 + CALL PLTELM(K,IERC) + 590 CONTINUE + 600 END DO + CALL WRTOUT(0) + RETURN + end + + REAL*8 FUNCTION GETANG1(X1,Y1,X2,Y2,X3,Y3) + REAL*8 X1,Y1,X2,Y2,X3,Y3,CAN + C=SQRT((X2-X1)**2+(Y2-Y1)**2) + B=SQRT((X3-X2)**2+(Y3-Y2)**2) + A=SQRT((X1-X3)**2+(Y1-Y3)**2) + CAN=(B**2+C**2-A**2)/(2.*B*C) + GETANG1=DACOSD(CAN) + RETURN + END + + SUBROUTINE PANELgenblk(N1,XL,N2,N3,ISW1,ISW2,ITEST) + + use winteracter + + implicit none + + include 'D.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3,IERR,IFIRST,ISW1,ISW2,ITEST + real :: XL + character*3 :: sub + DATA IFIRST/0/ + + IF(IFIRST .EQ. 0) THEN + IFIRST=1 + N1=1 + N2=1 + N3=2 + XL=5. + isw1=0 + isw2=0 + ENDIF + call wdialogload(IDD_GENBLK) + ierr=infoerror(1) + + CALL WDialogPutInteger(idf_integer1,n1) + CALL WDialogPutInteger(idf_integer2,n2) + CALL WDialogPutInteger(idf_integer3,n3) + CALL WDialogPutInteger(idf_integer5,ITEST) + CALL WDialogPutReal(idf_real1,xl) + CALL WDialogPutCheckBox(idf_check1,isw1) + CALL WDialogPutCheckBox(idf_check2,isw2) + CALL WDialogSelect(IDD_GENBLK) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(idf_integer1,n1) + CALL WDialogGetInteger(idf_integer2,n2) + CALL WDialogGetInteger(idf_integer3,n3) + CALL WDialogGetReal(idf_real1,xl) + CALL WDialogGetInteger(idf_integer5,ITEST) + CALL WDialogGetCheckBox(idf_check1,isw1) + CALL WDialogGetCheckBox(idf_check2,isw2) + + + ENDIF + RETURN + END + \ No newline at end of file diff --git a/src/CRSECT.F90 b/src/CRSECT.F90 new file mode 100644 index 0000000..5e50547 --- /dev/null +++ b/src/CRSECT.F90 @@ -0,0 +1,158 @@ +!-----------------------------------------------------------------crsect + subroutine crsect +!----------------------------------------------------------------------c +! purpose: c +! To plot a selected cross section and calculate width and c +! slopes. c +! ycw mar97 c +!----------------------------------------------------------------------c + USE BLKMAP + USE BLK1MOD + USE BLK2MOD +! include 'BLK1.COM' +! include 'BLK2.COM' + + real XPL(5),YPL(5),ss0(50) + CHARACTER*1 ANS,ANSW(0:4),IFLAG + CHARACTER*6 DESCR + + INCLUDE 'TXFRM.COM' + + COMMON /XYGRPH/ XVALUES(10000,10),YVALUES(10000,10),TIMMIN,VALMIN,TIMMAX,VALMAX,NVALUES,NSETS,LINPROP(10) + + COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10),DESCR(10),ICRSR(10) + DATA MAN/1/ + +! +!------get cross section number +! +! 100 NHTP=0 +! NMESS=29 +! NBRR=6 + call selcrs(man) + + if(man .eq. 2) then + call setlim(timmin,timmax,valmin,valmax) + else + +! +!......establish shape of curve +! + + timmin=1.e20 + valmin=1.e20 + timmax=-1.e20 + valmax=-1.e20 + endif + + DO J=1,5 + icr=icrsr(j) + if(icr .gt. 0) then + do i=nrivl(icr),1,-1 + + ii=nrivl(icr)-i+1 + xvalues(ii,j)=-crsdat(icr,i,3)/2. + yvalues(ii,j)=crsdat(icr,i,1) + ij=nrivl(icr)+i + xvalues(ij,j)=crsdat(icr,i,3)/2. + yvalues(ij,j)=crsdat(icr,i,1) + + enddo + nsets=j + + if(man .eq. 1) then + timmin=min(timmin,-crsdat(icr,nrivl(icr),3)/2.) + valmin=min(valmin,crsdat(icr,1,1)) + timmax=max(timmax,crsdat(icr,nrivl(icr),3)/2.) + valmax=max(valmax,crsdat(icr,nrivl(icr),1)) + endif + + NVALUES=2*nrivl(icr) + write(DESCR(j),'(i6)') ICR + endif + enddo + call dograph(2,icurwin) + iscrns(icurwin)=3 + + return + END + + subroutine selcrs(MAN) + + USE WINTERACTER + INCLUDE 'D.INC' + CHARACTER*6 DESCR + + COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10),DESCR(10),ICRSR(10) + + call wdialogload(IDD_SELCRSEC) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_SECCRSEC) + ierr=infoerror(1) + + do i=1,5 + CALL WGridPutCellInteger(IDF_GRID1,i,1,icrsr(i)) + enddo + + if(man .eq. 1) then + CALL WDialogPutRadioButton(IDF_RADIO1) + else + CALL WDialogPutRadioButton(IDF_RADIO2) + endif + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + do i=1,5 + CALL WGridGetCellInteger(IDF_GRID1,i,1,icrsr(i)) + enddo + CALL WDialogGetRadioButton(IDF_RADIO1,man) + return + else + return + endif + + enddo + return + + end + + subroutine setlim(timmin,timmax,valmin,valmax) + + USE WINTERACTER + INCLUDE 'D.INC' + CHARACTER*6 DESCR + + call wdialogload(IDD_LIMITS) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_LIMITS) + ierr=infoerror(1) + + + CALL WDialogPutReal(IDF_REAL1,TIMMIN) + CALL WDialogPutReal(IDF_REAL2,TIMMAX) + CALL WDialogPutReal(IDF_REAL3,VALMIN) + CALL WDialogPutReal(IDF_REAL4,VALMAX) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetReal(IDF_REAL1,TIMMIN) + CALL WDialogGetReal(IDF_REAL2,TIMMAX) + CALL WDialogGetReal(IDF_REAL3,VALMIN) + CALL WDialogGetReal(IDF_REAL4,VALMAX) + return + else + return + endif + + enddo + return + + end \ No newline at end of file diff --git a/src/CSETNEW.F90 b/src/CSETNEW.F90 new file mode 100644 index 0000000..d31ff3a --- /dev/null +++ b/src/CSETNEW.F90 @@ -0,0 +1,407 @@ + SUBROUTINE CSET(TTMIN,TTMAX,isz) + + USE WINTERACTER + SAVE + INTEGER ICK5 +! + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL +!IPK APR94 + COMMON /RECOD/ IRECD,TSPC + DIMENSION NKEY(99) + CHARACTER*80 ILIND + LOGICAL SWITCH + DATA ITIM,VDM /0,-1.E15/ +! + call setd(24) + IF(ITIM .EQ. 0) THEN + OMAX=VDM + OMIN=VDM + ick5=0 + DO 200 N=1,99 + CONTUR(N)=VDM + 200 CONTINUE + ITIM=ITIM+1 + ELSE + ITIM=ITIM+1 + ENDIF +! +! + 13 continue +! +! isz = 0 means no choice for data +! = 1 means data selectd +! + IF(TTMAX .EQ. TTMIN) THEN + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,& + 'There are no contours for this case MAX=MIN'//CHAR(13)//'The model will return ','CONTOUR ERROR') + 5010 FORMAT(F5.2) + RETURN +!ipk apr94 + ENDIF + IF(ICK5 .EQ. 1) GO TO 250 +! +! get an estimate of contour values +! + AT=ALOG10(TTMAX-TTMIN) + IF(AT .LT. 0.) THEN + CINTER = 10. ** (IFIX(AT - .5) - 1) + ELSE + CINTER = 10. ** (IFIX(AT + .5) - 1) + ENDIF +! CINTER = 10. ** (IFIX(ALOG10(TTMAX-TTMIN) + .5) - 1) + 235 FINTER = CINTER +! write(*,*) cinter,numv + IF(TTMIN .GT. 0.) THEN + CONTUR(1)=IFIX(TTMIN/CINTER)*CINTER+0.001*cinter + ELSE + CONTUR(1)=IFIX((TTMIN-CINTER)/CINTER)*CINTER+0.001*cinter + ENDIF + NUMV=1 + DO 240 N=2,99 + CONTUR(N)=CONTUR(N-1)+FINTER + IF(CONTUR(N) .GT. TTMAX) THEN + NUMV=N + GO TO 245 + ENDIF + 240 END DO + NUMV=99 + 245 IF(NUMV .GT. 16) THEN + CINTER=CINTER*2. + GO TO 235 + ENDIF + DO 247 N=NUMV+1,99 + CONTUR(N)=VDM + 247 END DO + 250 CONTINUE +! +! print options when no startup data available +! + if(isz .eq. 1) then + call conpanel(icsp,ttmin,ttmax,numv,contur,omax,omin,ick5) + if(icsp .lt. 0) then + GO TO 405 + elseif(icsp .eq. 0) then + go to 405 + endif + + + IF(ABS(ICSP) .EQ. 1) THEN + icsp=0 +! +! this is log spacing +! + IF(TTMAX .GT. 0.) THEN + ALMAX=ALOG10(TTMAX) + ELSE + call clscrn + call symbl (0.1,7.0,0.25, & + & 'Maximum contour value is negative',0.0,33) + call symbl (0.1,6.5,0.25, & + & 'Reconsider your choice',0.0,22) + GO TO 250 + ENDIF + IF(TTMIN .GT. 0.) THEN + ALMIN=ALOG10(TTMIN) +!ipk oct94 add a switch + IMINSW=0 + ELSE + call clscrn + call symbl (0.1,7.0,0.25, & + & 'Minimum contour value is negative',0.0,33) + call symbl (0.1,6.5,0.25, & + & 'Value set to 10**10 less than max value',0.0,39) + ALMIN=ALMAX-10. +!ipk oct 94 add a switch + IMINSW=1 + ENDIF +! + ALMIN=ALMAX-4. +! + IF(ALMAX .GT. 0.) THEN + LMAX=ALMAX + ELSE + LMAX=ALMAX-1. + ENDIF + IF(ALMIN .GT. 0.) THEN + LMIN=ALMIN+1. + ELSE + LMIN=ALMIN + ENDIF +!ipk oct94 NUMV=LMAX-LMIN+1 + NUMV=LMAX-LMIN+1+IMINSW + IF(NUMV .LT. 8) THEN + NUMV=NUMV*2 + IDB=2 + ELSE + IDB=1 + ENDIF +!ipk oct94 + IF(IMINSW .EQ. 1) THEN + CONTUR(1)=0. + CONTUR(2)=10.**LMIN + K=2 + ELSE + CONTUR(1)=10.**LMIN + K=1 + ENDIF + IPW=LMIN + DO 350 N=IMINSW+2,NUMV,IDB + IF(IDB .EQ. 2) THEN + K=K+1 + CONTUR(K)=CONTUR(K-1)*3. + ENDIF + IPW=IPW+1 + K=K+1 + CONTUR(K)=10.**IPW + 350 CONTINUE + numv=k +! +! this is for entry of chosen contours +! + ELSEIF(abs(ICSP) .EQ. 2) THEN + icsp=0 + CALL SORT(CONTUR,NKEY,NUMV) + ELSEIF(abs(ICSP) .EQ. 3) THEN + icsp=0 + cinter=omax-omin + if(cinter .gt. 0.) then + cinter=cinter/(numv-1) + else + cinter=1.0 + endif + contur(1)=omin + do i=2,numv + contur(i)=contur(i-1)+cinter + enddo + ENDIF + GO TO 250 +!ipk july 1995 add this line + 405 CONTINUE + ENDIF + call setd(2) + RETURN + END + + + + subroutine conpanel(icsp,ttmin,ttmax,numv,contur,omax,omin,ick5) + + use winteracter + implicit none + + save + + include 'D.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: icsp,numv,nlim,ict,ictx,ick1,ick2,ick3,ick4,ick5,ierr,idf,ipos,numvold + real :: ttmin,ttmax,contur(99),omax,omin,VDX + character*80 labmax,labmin,labnum,labcon(30),labomax,labomin + VDX=-1.E14 + write(labmax,'(f10.3)') ttmax + write(labmin,'(f10.3)') ttmin + + if(omax .lt. vdx) then + labomax=labmax + else + write(labomax,'(f10.3)') omax + endif + + if(omin .lt. vdx) then + labomin=labmin + else + write(labomin,'(f10.3)') omin + endif + write(labnum,'(i10)') numv + nlim=numv + if(nlim .gt. 30) nlim=numv + do ict=1,nlim + write(labcon(ict),'(f10.3)') contur(ict) + enddo + if(numv .lt. 30) then + do ict=numv+1,30 + labcon(ict)=' ' + enddo + endif + + 90 continue + numvold=numv + + call wdialogload(IDD_DIALOG02) + ierr=infoerror(1) + + CALL WDialogPutString(idf_string1,labmax) + CALL WDialogPutString(idf_string2,labmin) + CALL WDialogPutString(idf_string3,labomax) + CALL WDialogPutString(idf_string22,labomin) + CALL WDialogPutString(idf_string23,labnum) + + ictx=0 + do ict=idf_string4,idf_string4+18-1 + ictx=ictx+1 + CALL WDialogPutString(ict,labcon(ictx)) + enddo + ictx=ictx+1 + ICT=idf_string24 + CALL WDialogPutString(ict,labcon(ictx)) + + DO ict=idf_string25,idf_string25+9 + ictx=ictx+1 + CALL WDialogPutString(ict,labcon(ictx)) + enddo + ictx=ictx+1 + ICT=idf_string35 + CALL WDialogPutString(ict,labcon(ictx)) + +! call wdialogputcheckbox(idf_check1,0) +! call wdialogputcheckbox(idf_check2,0) +! call wdialogputcheckbox(idf_check3,0) +! call wdialogputcheckbox(idf_check4,0) + call wdialogputcheckbox(idf_check5,ick5) +! if(icsp .eq. 0) then + call wdialogputRadioButton(idf_check1) +! endif + + + CALL WDialogSelect(IDD_DIALOG02) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + +! call wdialoggetcheckbox(idf_check1,ick1) +! call wdialoggetcheckbox(idf_check2,ick2) +! call wdialoggetcheckbox(idf_check3,ick3) +! call wdialoggetcheckbox(idf_check4,ick4) + call wdialoggetcheckbox(idf_check5,ick5) + CALL WDialoggetString(idf_string1,labmax) + CALL WDialoggetString(idf_string2,labmin) + CALL WDialoggetString(idf_string3,labomax) + CALL WDialoggetString(idf_string22,labomin) + CALL WDialoggetString(idf_string23,labnum) + call wdialoggetradiobutton(idf_check1,ipos) + call IStringToInteger(labnum,numv) + write(90,*) 'numvold',numvold,numv,ipos + if(numvold .ne. numv .and. ipos .ne. 4) ipos=3 +!C if(ick1 .eq. 1) then +!C icsp=0 +!C else + icsp=0 + if(ipos .eq. 2) then + icsp=1 + elseif(ipos .eq. 3) then + icsp=3 + write(90,'(a)') 'numv',labnum + call IStringToInteger(labnum,numv) + if(infoError(1) .gt. 0) then + call wdialogload(IDD_DIALOG04) + CALL WDialogSelect(IDD_DIALOG04) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + 120 continue + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + go to 90 + endif + go to 120 + endif + call IStringToReal(labomax,omax) + if(infoError(1) .gt. 0) then + call wdialogload(IDD_DIALOG04) + CALL WDialogSelect(IDD_DIALOG04) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + 130 continue + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + go to 90 + endif + go to 130 + endif + call IStringToReal(labomin,omin) + if(infoError(1) .gt. 0) then + call wdialogload(IDD_DIALOG04) + CALL WDialogSelect(IDD_DIALOG04) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + 140 continue + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + go to 90 + endif + go to 140 + endif + elseif(ipos .eq. 4) then + icsp=2 + write(90,'(a)') 'numv-4',labnum +! read(labnum,*) numv + call IStringToInteger(labnum,numv) + if(infoError(1) .gt. 0) then + call wdialogload(IDD_DIALOG04) + CALL WDialogSelect(IDD_DIALOG04) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + 150 continue + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + go to 90 + endif + go to 150 + endif + write(90,*) numv + ictx=0 + do ict=idf_string4,idf_string4+18-1 + ictx=ictx+1 + CALL WDialogGetString(ict,labcon(ictx)) + enddo + ictx=ictx+1 + ICT=idf_string24 + CALL WDialogGetString(ict,labcon(ictx)) + do ict=idf_string25,idf_string25+9 + ictx=ictx+1 + CALL WDialogGetString(ict,labcon(ictx)) + enddo + ictx=ictx+1 + ICT=idf_string35 + CALL WDialogGetString(ict,labcon(ictx)) + do ict=1,numv +! read(labcon(ict),*) contur(ict) + call IStringToReal(labcon(ict),contur(ict)) + if(infoError(1) .gt. 0) then + call wdialogload(IDD_DIALOG04) + CALL WDialogSelect(IDD_DIALOG04) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + 160 continue + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + go to 90 + endif + go to 160 + endif + write(90,*) 'con',ict,contur(ict) + enddo + endif + + if(ipos .eq. 5) then + icsp=-5 +! abs(icsp) + endif + write(90,*) 'icsp',icsp,omax,omin,numv,ipos +! write(90,*) 'ick',ick1,ick2,ick3,ick4,ick5 + return + + endif + return + enddo + return + end diff --git a/src/D.INC b/src/D.INC new file mode 100644 index 0000000..df2bea6 --- /dev/null +++ b/src/D.INC @@ -0,0 +1,363 @@ +! Winteracter resource identifiers. Created : 03/Aug/2016 15:52:15 +! +! This file is generated by the Winteracter resource editor. +! It should not be edited manually. It is also not advisable to load this +! file in a text editor, while working on the associated resource file, +! since this may prevent the resource identifiers file from being updated. +! To view the names and values of resource identifiers, use the +! "Identifier Names and Values" or "Used Identifiers" options on the +! resource editor's "View" menu. Both dialogs also include a "Copy id" +! button which allows identifier names to be copied via the clipboard. +! Opening this file in an editor should therefore not be necessary. +! + INTEGER, PARAMETER :: IDR_MENU1 = 30001 + INTEGER, PARAMETER :: ID_FILE = 40001 + INTEGER, PARAMETER :: ID_EXIT = 40002 + INTEGER, PARAMETER :: ID_NODE = 40003 + INTEGER, PARAMETER :: ID_ELTS = 40004 + INTEGER, PARAMETER :: ID_ORDRT = 40005 + INTEGER, PARAMETER :: ID_CCLNA = 40006 + INTEGER, PARAMETER :: ID_CSEC1 = 40007 + INTEGER, PARAMETER :: ID_ZOOM = 40008 + INTEGER, PARAMETER :: ID_DRAW = 40009 + INTEGER, PARAMETER :: ID_HELP = 40010 + INTEGER, PARAMETER :: ID_STRING1 = 50001 + INTEGER, PARAMETER :: ID_STRING2 = 50002 + INTEGER, PARAMETER :: ID_STRING3 = 50003 + INTEGER, PARAMETER :: ID_STRING4 = 50004 + INTEGER, PARAMETER :: ID_STRING5 = 50005 + INTEGER, PARAMETER :: ID_STRING6 = 50006 + INTEGER, PARAMETER :: ID_STRING7 = 50007 + INTEGER, PARAMETER :: ID_STRING8 = 50008 + INTEGER, PARAMETER :: ID_STRING9 = 50009 + INTEGER, PARAMETER :: ID_STRING10 = 50010 + INTEGER, PARAMETER :: ID_STRING11 = 50011 + INTEGER, PARAMETER :: ID_ITEM11 = 40011 + INTEGER, PARAMETER :: ID_ITEM12 = 40012 + INTEGER, PARAMETER :: ID_ITEM13 = 40013 + INTEGER, PARAMETER :: ID_ITEM14 = 40014 + INTEGER, PARAMETER :: ID_ITEM15 = 40015 + INTEGER, PARAMETER :: ID_ITEM16 = 40016 + INTEGER, PARAMETER :: ID_ITEM17 = 40017 + INTEGER, PARAMETER :: ID_ITEM18 = 40018 + INTEGER, PARAMETER :: ID_ITEM19 = 40019 + INTEGER, PARAMETER :: IDF_STRING24 = 1041 + INTEGER, PARAMETER :: IDD_DIALOG1 = 101 + INTEGER, PARAMETER :: IDF_LABEL5 = 1042 + INTEGER, PARAMETER :: IDC_BUTTON2 = 20001 + INTEGER, PARAMETER :: ID_ITEM20 = 40021 + INTEGER, PARAMETER :: ID_ITEM73 = 40022 + INTEGER, PARAMETER :: ID_ITEM23 = 40023 + INTEGER, PARAMETER :: ID_ITEM24 = 40024 + INTEGER, PARAMETER :: ID_TOOLBAR1 = 30101 + INTEGER, PARAMETER :: ID_ZIN = 40025 + INTEGER, PARAMETER :: ID_ZOUT = 40026 + INTEGER, PARAMETER :: ID_OUT2 = 40027 + INTEGER, PARAMETER :: ID_OUT4 = 40028 + INTEGER, PARAMETER :: ID_RSET = 40029 + INTEGER, PARAMETER :: ID_PLEFT = 40031 + INTEGER, PARAMETER :: ID_PRIGHT = 40032 + INTEGER, PARAMETER :: ID_PUP = 40033 + INTEGER, PARAMETER :: ID_PDOWN = 40034 + INTEGER, PARAMETER :: ID_IDRWT = 40035 + INTEGER, PARAMETER :: ID_TYPD = 40039 + INTEGER, PARAMETER :: ID_DRAWD = 40041 + INTEGER, PARAMETER :: ID_MAPOPD = 40042 + INTEGER, PARAMETER :: ID_CONTR = 40060 + INTEGER, PARAMETER :: IDF_LABEL1 = 1001 + INTEGER, PARAMETER :: IDF_LABEL2 = 1002 + INTEGER, PARAMETER :: IDF_LABEL3 = 1003 + INTEGER, PARAMETER :: IDF_LABEL4 = 1004 + INTEGER, PARAMETER :: IDF_STRING1 = 1013 + INTEGER, PARAMETER :: IDF_STRING2 = 1014 + INTEGER, PARAMETER :: IDF_STRING3 = 1015 + INTEGER, PARAMETER :: IDF_STRING4 = 1016 + INTEGER, PARAMETER :: IDF_STRING5 = 1017 + INTEGER, PARAMETER :: IDF_STRING6 = 1018 + INTEGER, PARAMETER :: IDF_STRING7 = 1019 + INTEGER, PARAMETER :: IDF_STRING8 = 1020 + INTEGER, PARAMETER :: IDF_STRING9 = 1021 + INTEGER, PARAMETER :: IDF_STRING10 = 1022 + INTEGER, PARAMETER :: IDF_STRING11 = 1023 + INTEGER, PARAMETER :: IDF_STRING12 = 1024 + INTEGER, PARAMETER :: IDD_DIALOG02 = 102 + INTEGER, PARAMETER :: IDF_STRING13 = 1025 + INTEGER, PARAMETER :: IDF_STRING14 = 1026 + INTEGER, PARAMETER :: IDF_STRING15 = 1027 + INTEGER, PARAMETER :: IDF_STRING16 = 1028 + INTEGER, PARAMETER :: IDF_STRING17 = 1029 + INTEGER, PARAMETER :: IDF_STRING18 = 1030 + INTEGER, PARAMETER :: IDF_STRING19 = 1031 + INTEGER, PARAMETER :: IDF_STRING20 = 1032 + INTEGER, PARAMETER :: IDF_STRING21 = 1033 + INTEGER, PARAMETER :: IDF_STRING22 = 1034 + INTEGER, PARAMETER :: IDF_STRING23 = 1035 + INTEGER, PARAMETER :: IDF_CHECK1 = 1036 + INTEGER, PARAMETER :: IDF_CHECK2 = 1037 + INTEGER, PARAMETER :: IDF_CHECK3 = 1038 + INTEGER, PARAMETER :: IDF_CHECK4 = 1039 + INTEGER, PARAMETER :: IDF_CHECK5 = 1040 + INTEGER, PARAMETER :: ID_DCONTR = 40056 + INTEGER, PARAMETER :: ID_CONTOPT = 40061 + INTEGER, PARAMETER :: ID_ITYPN = 40064 + INTEGER, PARAMETER :: ID_ITYPC = 40065 + INTEGER, PARAMETER :: ID_ICOPY = 40067 + INTEGER, PARAMETER :: IDD_DIALOG04 = 104 + INTEGER, PARAMETER :: ID_BACGD = 40050 + INTEGER, PARAMETER :: ID_ITEM26 = 40071 + INTEGER, PARAMETER :: IDD_DIALOG05 = 103 + INTEGER, PARAMETER :: IDF_CMAP8 = 1005 + INTEGER, PARAMETER :: IDF_CMAP9 = 1006 + INTEGER, PARAMETER :: IDF_CMAP0 = 1007 + INTEGER, PARAMETER :: IDF_CMAP1 = 1008 + INTEGER, PARAMETER :: IDF_CMAP2 = 1009 + INTEGER, PARAMETER :: IDF_CMAP10 = 1010 + INTEGER, PARAMETER :: IDF_CMAP11 = 1011 + INTEGER, PARAMETER :: IDF_CMAP3 = 1012 + INTEGER, PARAMETER :: IDF_CMAP4 = 1043 + INTEGER, PARAMETER :: IDF_CMAP5 = 1044 + INTEGER, PARAMETER :: IDF_CMAP6 = 1045 + INTEGER, PARAMETER :: IDF_CMAP7 = 1046 + INTEGER, PARAMETER :: IDD_DIALOG006 = 105 + INTEGER, PARAMETER :: IDF_RADIO1 = 1047 + INTEGER, PARAMETER :: IDF_RADIO2 = 1048 + INTEGER, PARAMETER :: IDF_RADIO3 = 1049 + INTEGER, PARAMETER :: IDF_RADIO4 = 1050 + INTEGER, PARAMETER :: IDF_RADIO5 = 1051 + INTEGER, PARAMETER :: IDF_RADIO6 = 1052 + INTEGER, PARAMETER :: IDF_RADIO7 = 1053 + INTEGER, PARAMETER :: IDF_RADIO8 = 1054 + INTEGER, PARAMETER :: IDF_RADIO9 = 1055 + INTEGER, PARAMETER :: ID_MMAP = 40043 + INTEGER, PARAMETER :: IDD_DIALOG07 = 106 + INTEGER, PARAMETER :: IDD_DIALOG08 = 107 + INTEGER, PARAMETER :: ID_Help1 = 40040 + INTEGER, PARAMETER :: ID_Help2 = 40044 + INTEGER, PARAMETER :: IDD_DIALOG09 = 108 + INTEGER, PARAMETER :: IDF_LABEL7 = 1056 + INTEGER, PARAMETER :: IDD_DIALOG10 = 109 + INTEGER, PARAMETER :: IDF_INTEGER1 = 1057 + INTEGER, PARAMETER :: IDF_INTEGER2 = 1058 + INTEGER, PARAMETER :: ID_LAYFL = 40046 + INTEGER, PARAMETER :: IDF_RADIO10 = 1056 + INTEGER, PARAMETER :: IDD_DIALOG010 = 110 + INTEGER, PARAMETER :: IDD_DIALOG001 = 111 + INTEGER, PARAMETER :: ID_BKF = 40047 + INTEGER, PARAMETER :: IDD_DIALOG012 = 113 + INTEGER, PARAMETER :: IDF_CHECK6 = 1041 + INTEGER, PARAMETER :: IDF_CHECK7 = 1042 + INTEGER, PARAMETER :: IDF_CHECK8 = 1043 + INTEGER, PARAMETER :: IDF_CHECK9 = 1044 + INTEGER, PARAMETER :: IDF_CHECK10 = 1045 + INTEGER, PARAMETER :: IDF_CHECK11 = 1059 + INTEGER, PARAMETER :: ID_Clip = 40020 + INTEGER, PARAMETER :: ID_UNDOM = 40030 + INTEGER, PARAMETER :: ID_BSEL = 40036 + INTEGER, PARAMETER :: ID_REGST = 40037 + INTEGER, PARAMETER :: IDD_REGST = 112 + INTEGER, PARAMETER :: IDF_LABEL6 = 1005 + INTEGER, PARAMETER :: IDF_REAL1 = 1060 + INTEGER, PARAMETER :: IDF_REAL2 = 1061 + INTEGER, PARAMETER :: IDF_REAL3 = 1062 + INTEGER, PARAMETER :: IDF_REAL4 = 1063 + INTEGER, PARAMETER :: IDF_LABEL8 = 1006 + INTEGER, PARAMETER :: IDF_LABEL9 = 1007 + INTEGER, PARAMETER :: IDF_LABEL10 = 1008 + INTEGER, PARAMETER :: IDF_LABEL11 = 1043 + INTEGER, PARAMETER :: IDF_REAL5 = 1064 + INTEGER, PARAMETER :: IDF_REAL6 = 1065 + INTEGER, PARAMETER :: IDF_REAL7 = 1066 + INTEGER, PARAMETER :: IDF_REAL8 = 1067 + INTEGER, PARAMETER :: IDF_LABEL12 = 1009 + INTEGER, PARAMETER :: IDADJUST = 1068 + INTEGER, PARAMETER :: IDFSWITCH = 1069 + INTEGER, PARAMETER :: IDD_SLRGNO = 114 + INTEGER, PARAMETER :: IDD_CONFIRM = 115 + INTEGER, PARAMETER :: ID_network = 40038 + INTEGER, PARAMETER :: ID_NMAP = 40045 + INTEGER, PARAMETER :: ID_ITEM56 = 40048 + INTEGER, PARAMETER :: ID_Nodedata = 40049 + INTEGER, PARAMETER :: ID_Eltdata = 40051 + INTEGER, PARAMETER :: IDD_nodedata = 116 + INTEGER, PARAMETER :: IDF_REAL9 = 1068 + INTEGER, PARAMETER :: IDF_REAL10 = 1069 + INTEGER, PARAMETER :: IDD_eltdata = 117 + INTEGER, PARAMETER :: IDF_INTEGER3 = 1059 + INTEGER, PARAMETER :: IDF_INTEGER4 = 1060 + INTEGER, PARAMETER :: IDF_INTEGER5 = 1061 + INTEGER, PARAMETER :: IDF_INTEGER6 = 1062 + INTEGER, PARAMETER :: IDF_INTEGER7 = 1063 + INTEGER, PARAMETER :: IDF_INTEGER8 = 1064 + INTEGER, PARAMETER :: IDF_INTEGER9 = 1070 + INTEGER, PARAMETER :: IDF_INTEGER10 = 1071 + INTEGER, PARAMETER :: IDD_SELNODE = 118 + INTEGER, PARAMETER :: IDNEXT = 1072 + INTEGER, PARAMETER :: IDD_SELELT = 119 + INTEGER, PARAMETER :: IDD_ELTERR = 120 + INTEGER, PARAMETER :: ID_DRAG = 40052 + INTEGER, PARAMETER :: ID_DELM = 40103 + INTEGER, PARAMETER :: ID_FILL = 40102 + INTEGER, PARAMETER :: IDF_Delete = 1073 + INTEGER, PARAMETER :: IDFROTATE = 1074 + INTEGER, PARAMETER :: IDF_RADIO11 = 1057 + INTEGER, PARAMETER :: ID_GETELM = 40053 + INTEGER, PARAMETER :: ID_mapm = 40054 + INTEGER, PARAMETER :: ID_map = 40055 + INTEGER, PARAMETER :: IDD_GETINTP = 160 + INTEGER, PARAMETER :: ID_SBIN = 40057 + INTEGER, PARAMETER :: IDD_headertp = 121 + INTEGER, PARAMETER :: ID_TRIAN = 40058 + INTEGER, PARAMETER :: ID_SWMAP = 40059 + INTEGER, PARAMETER :: ID_SWRM1 = 40062 + INTEGER, PARAMETER :: IDD_TRIAN = 122 + INTEGER, PARAMETER :: IDD_NODERR = 123 + INTEGER, PARAMETER :: IDF_STRING25 = 1106 + INTEGER, PARAMETER :: IDF_STRING26 = 1107 + INTEGER, PARAMETER :: IDF_STRING27 = 1108 + INTEGER, PARAMETER :: IDF_STRING28 = 1109 + INTEGER, PARAMETER :: IDF_STRING29 = 1110 + INTEGER, PARAMETER :: IDF_STRING30 = 1111 + INTEGER, PARAMETER :: IDF_STRING31 = 1112 + INTEGER, PARAMETER :: IDF_STRING32 = 1113 + INTEGER, PARAMETER :: IDF_STRING33 = 1114 + INTEGER, PARAMETER :: IDF_STRING34 = 1115 + INTEGER, PARAMETER :: IDD_SELTFL2 = 148 + INTEGER, PARAMETER :: ID_LOADRM1 = 40063 + INTEGER, PARAMETER :: ID_cdata = 40066 + INTEGER, PARAMETER :: ID_SELRM1 = 40068 + INTEGER, PARAMETER :: ID_addmesh = 40069 + INTEGER, PARAMETER :: ID_MRGMESH = 40070 + INTEGER, PARAMETER :: ID_ITEM22 = 40072 + INTEGER, PARAMETER :: ID_ALLNODES = 40073 + INTEGER, PARAMETER :: ID_UNUSNODES = 40074 + INTEGER, PARAMETER :: ID_TRIANG = 40075 + INTEGER, PARAMETER :: IDD_TRIANG = 124 + INTEGER, PARAMETER :: IDD_QUAD = 125 + INTEGER, PARAMETER :: ID_QUAD = 40076 + INTEGER, PARAMETER :: ID_JOIN = 40104 + INTEGER, PARAMETER :: ID_CSEC = 40077 + INTEGER, PARAMETER :: ID_CRSCAL = 40078 + INTEGER, PARAMETER :: ID_SAVCRS = 40079 + INTEGER, PARAMETER :: ID_crsf = 40080 + INTEGER, PARAMETER :: IDD_DIALOG06 = 126 + INTEGER, PARAMETER :: IDF_RADIO13 = 1076 + INTEGER, PARAMETER :: IDF_RADIO12 = 1058 + INTEGER, PARAMETER :: IDD_GETFPN = 154 + INTEGER, PARAMETER :: IDD_GETINT = 153 + INTEGER, PARAMETER :: ID_CSLOC = 40081 + INTEGER, PARAMETER :: IDD_CSLOC = 127 + INTEGER, PARAMETER :: ID_UNDO = 40082 + INTEGER, PARAMETER :: ID_UNDOS = 40083 + INTEGER, PARAMETER :: ID_CREATM = 40084 + INTEGER, PARAMETER :: IDD_CREATM = 128 + INTEGER, PARAMETER :: IDD_TEMPLATE001 = 129 + INTEGER, PARAMETER :: IDF_GRID1 = 1075 + INTEGER, PARAMETER :: ISS1 = 1077 + INTEGER, PARAMETER :: ISS2 = 1078 + INTEGER, PARAMETER :: ISS3 = 1079 + INTEGER, PARAMETER :: IDD_CREATM1 = 130 + INTEGER, PARAMETER :: ID_CGEN = 40085 + INTEGER, PARAMETER :: IDF_STRING35 = 1042 + INTEGER, PARAMETER :: IDD_ORDEROUT = 131 + INTEGER, PARAMETER :: IDD_TEMPLATE002 = 132 + INTEGER, PARAMETER :: IDF_RADIO14 = 1080 + INTEGER, PARAMETER :: IDF_RADIO15 = 1081 + INTEGER, PARAMETER :: IDF_RADIO16 = 1082 + INTEGER, PARAMETER :: ID_selarea = 40086 + INTEGER, PARAMETER :: ID_crsect = 40087 + INTEGER, PARAMETER :: IDD_selcrsec = 133 + INTEGER, PARAMETER :: IDD_TEMPLATE003 = 134 + INTEGER, PARAMETER :: ISS4 = 1083 + INTEGER, PARAMETER :: ISS5 = 1084 + INTEGER, PARAMETER :: IDD_LIMITS = 135 + INTEGER, PARAMETER :: IDF_RADIO17 = 1059 + INTEGER, PARAMETER :: IDD_lAY = 136 + INTEGER, PARAMETER :: IDD_TEMPLATE004 = 137 + INTEGER, PARAMETER :: ISS6 = 1085 + INTEGER, PARAMETER :: ISS7 = 1086 + INTEGER, PARAMETER :: ID_EDLAY = 40088 + INTEGER, PARAMETER :: IDF_RADIO18 = 1062 + INTEGER, PARAMETER :: ID_ORDR = 40089 + INTEGER, PARAMETER :: ID_ORDR1 = 40090 + INTEGER, PARAMETER :: id_chk = 2002 + INTEGER, PARAMETER :: id_chck = 2001 + INTEGER, PARAMETER :: idchk = 2003 + INTEGER, PARAMETER :: ID_SPLITN = 40091 + INTEGER, PARAMETER :: IDD_DISPLIT = 138 + INTEGER, PARAMETER :: IDD_DIRSPLIT = 139 + INTEGER, PARAMETER :: ID_OUTLAY = 40093 + INTEGER, PARAMETER :: ID_FORM999 = 40092 + INTEGER, PARAMETER :: ID_g1d = 40094 + INTEGER, PARAMETER :: IDD_SETOPT = 140 + INTEGER, PARAMETER :: ID_CCLN = 40095 + INTEGER, PARAMETER :: ID_CHKCCLN = 40096 + INTEGER, PARAMETER :: ID_GOUTLIN = 40097 + INTEGER, PARAMETER :: ID_XOUTLIN = 40098 + INTEGER, PARAMETER :: IDD_SETMAXMAP = 141 + INTEGER, PARAMETER :: ID_RESETLIM = 40099 + INTEGER, PARAMETER :: IDD_MLIMITS = 143 + INTEGER, PARAMETER :: IDD_VIEWANG = 174 + INTEGER, PARAMETER :: ID_3DVIEW = 40100 + INTEGER, PARAMETER :: ID_VIEWANGLE = 40101 + INTEGER, PARAMETER :: ID_ROTATE = 40106 + INTEGER, PARAMETER :: ID_RESETRG = 40105 + INTEGER, PARAMETER :: IDD_CHKOPT = 142 + INTEGER, PARAMETER :: ID_ITEM103 = 40107 + INTEGER, PARAMETER :: ID_SECGRP = 40108 + INTEGER, PARAMETER :: IDD_SETSEL = 144 + INTEGER, PARAMETER :: ID_SELPR = 40109 + INTEGER, PARAMETER :: IDD_CHK1DOPT = 145 + INTEGER, PARAMETER :: ID_VROTATE = 40110 + INTEGER, PARAMETER :: id_mchck = 40111 + INTEGER, PARAMETER :: ID_MOVMESH = 40112 + INTEGER, PARAMETER :: IDD_DIALOG047 = 146 + INTEGER, PARAMETER :: IDD_DIALOG048 = 147 + INTEGER, PARAMETER :: ID_SELELTYP = 40113 + INTEGER, PARAMETER :: IDD_SELELTYP = 149 + INTEGER, PARAMETER :: ID_OPENGP = 40114 + INTEGER, PARAMETER :: ID_SAVGP = 40115 + INTEGER, PARAMETER :: IDF_RADIO19 = 1063 + INTEGER, PARAMETER :: ID_IGPN = 40116 + INTEGER, PARAMETER :: ID_IGPC = 40117 + INTEGER, PARAMETER :: ID_DISPTYP = 40118 + INTEGER, PARAMETER :: ID_TRANSFORM = 40119 + INTEGER, PARAMETER :: IDD_TRANSFORM = 151 + INTEGER, PARAMETER :: ID_deletelm = 40120 + INTEGER, PARAMETER :: IDD_ELTERR2 = 152 + INTEGER, PARAMETER :: ID_FORM2D = 40121 + INTEGER, PARAMETER :: ID_JOINALL = 40122 + INTEGER, PARAMETER :: ID_MOVGRP = 40123 + INTEGER, PARAMETER :: ID_CRGRID = 40124 + INTEGER, PARAMETER :: IDD_GENBLK = 155 + INTEGER, PARAMETER :: ID_SETUPLEV = 40125 + INTEGER, PARAMETER :: IDD_SETWRS = 156 + INTEGER, PARAMETER :: ID_findnode = 40126 + INTEGER, PARAMETER :: ID_findelem = 40127 + INTEGER, PARAMETER :: IDD_FORMLINE = 157 + INTEGER, PARAMETER :: ID_FILLAGAP = 40129 + INTEGER, PARAMETER :: IDD_MATTYP = 158 + INTEGER, PARAMETER :: ID_ITEM126 = 40130 + INTEGER, PARAMETER :: ID_SETTYPLEV = 40131 + INTEGER, PARAMETER :: IDD_LEVSETTYP = 159 + INTEGER, PARAMETER :: ID_Complex = 40132 + INTEGER, PARAMETER :: ID_attach = 40133 + INTEGER, PARAMETER :: IDD_CHSTYP = 161 + INTEGER, PARAMETER :: ID_SAVSHP = 40128 + INTEGER, PARAMETER :: ID_ADDMAP = 40134 + INTEGER, PARAMETER :: ID_OUTLINFL = 40135 + INTEGER, PARAMETER :: ID_GETSTRESSFIL = 40136 + INTEGER, PARAMETER :: IDD_FBED = 162 + INTEGER, PARAMETER :: IDD_SETYRDT = 163 + INTEGER, PARAMETER :: ID_SMOOTHMAP = 40137 + INTEGER, PARAMETER :: IDD_GETINTR = 164 + INTEGER, PARAMETER :: ID_RVSDIAG = 40138 + INTEGER, PARAMETER :: ID_TESTOUT = 40139 + INTEGER, PARAMETER :: ID_LOADELTLD = 40140 + INTEGER, PARAMETER :: ID_SHOWELTLD = 40141 + INTEGER, PARAMETER :: IDD_CHOOSEMODEL = 165 + INTEGER, PARAMETER :: IDD_SETUPELDISP = 166 + INTEGER, PARAMETER :: ID_SAVELTLD = 40142 + INTEGER, PARAMETER :: ID_RESHOWELTLD = 40143 + INTEGER, PARAMETER :: ID_ASSIGNELTLD = 40144 + INTEGER, PARAMETER :: ID_FILLTR = 40145 + INTEGER, PARAMETER :: IDD_FTRIAN = 167 diff --git a/src/DELAN2 - Copy.F90 b/src/DELAN2 - Copy.F90 new file mode 100644 index 0000000..40545e2 --- /dev/null +++ b/src/DELAN2 - Copy.F90 @@ -0,0 +1,401 @@ + SUBROUTINE SUPERT(XPT,YPT,NVERT) + + USE BLKMAP +! INCLUDE 'BLK1.COM' + REAL*8 XPT(*),YPT(*) + + REAL*8 XMINM,YMINM,X45 + DATA VDX9/-9.E9/ +! Find minimum x and y + xminm=1.e20 + yminm=1.e20 + x45=-1.e20 + DO J=1,NVERT + IF(XPT(J) .GT. VDX9) THEN + if(xminm .GT. XPT(j) ) then + xminm=XPT(j) + end if + IF(yminm .GT. YPT(j)) then + yminm=YPT(j) + endif + ENDIF + ENDDO +! Find max at 45 degrees + DO J=1,NVERT + IF(XPT(J) .GT. VDX9) THEN + X45T=((XPT(J)-XMINM)+(YPT(J)-YMINM))/1.414 + IF(x45 .LT. X45T) THEN + X45=X45T + ENDIF + ENDIF + END DO + XPT(NVERT+1)=XMINM-5 + YPT(NVERT+1)=YMINM-5. + XPT(NVERT+2)=XMINM+1.414*X45+10. + YPT(NVERT+2)=YMINM-5. + XPT(NVERT+3)=XMINM-5. + YPT(NVERT+3)=YMINM+1.414*X45+10. + NELT=1 + NOPEL(1,1)=NVERT+1 + NOPEL(1,2)=NVERT+2 + NOPEL(1,3)=NVERT+3 + NVERT=NVERT+3 + CALL CCENTRE(XPT(NOPEL(1,1)),XPT(NOPEL(1,2)),XPT(NOPEL(1,3)) & + &,YPT(NOPEL(1,1)),YPT(NOPEL(1,2)),YPT(NOPEL(1,3)) & + &,XCEN(1),YCEN(1),RADS(1)) + RETURN + END SUBROUTINE + + SUBROUTINE INSIDCIRC(XPT,YPT,J,N,ISWT) + +! Test for point inside circumcircle + + USE BLKMAP +! INCLUDE 'BLK1.COM' + + REAL*8 XPT(*),YPT(*) + REAL*8 DISQ + +! Get the distance for this element + + DISQ=(XCEN(J)-XPT(N))**2+(YCEN(J)-YPT(N))**2 + +! Test against the radius + + IF(DISQ .GT. RADS(J)*RADS(J)) THEN + ISWT=0 + ELSE + ISWT=1 + ENDIF + RETURN + END SUBROUTINE + + SUBROUTINE PROCESS(J,NEDGE,NGAP) + +! Drop triangle and form edge buffers + + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + NEDGE=NEDGE+3 + IEDGE(NEDGE-2,1)=NOPEL(J,1) + IEDGE(NEDGE-1,1)=NOPEL(J,2) + IEDGE(NEDGE,1) =NOPEL(J,3) + IEDGE(NEDGE-2,2)=NOPEL(J,2) + IEDGE(NEDGE-1,2)=NOPEL(J,3) + IEDGE(NEDGE,2) =NOPEL(J,1) + NOPEL(J,1)=0 + NOPEL(J,2)=0 + NOPEL(J,3)=0 + NGAP=NGAP+1 + IGAP(NGAP)=J + RETURN + END SUBROUTINE + + SUBROUTINE FORMT(XPT,YPT,J,N,NGAP,K) + +! Form the triangle + + USE BLKMAP + + REAL*8 XPT(*),YPT(*) +! INCLUDE 'BLK1.COM' + + IF(NGAP .GT. 0) THEN + K=IGAP(NGAP) + NGAP=NGAP-1 + ELSE + NELTS=NELTS+1 + K=NELTS + ENDIF + NOPEL(K,1)=IEDGE(J,1) + NOPEL(K,2)=IEDGE(J,2) + NOPEL(K,3)=N + + CALL TESTANG(XPT,YPT,K) + +! Now get circumcircle data + + CALL CCENTRE(XPT(NOPEL(K,1)),XPT(NOPEL(K,2)),XPT(NOPEL(K,3)) & + &,YPT(NOPEL(K,1)),YPT(NOPEL(K,2)),YPT(NOPEL(K,3)) & + &,XCEN(K),YCEN(K),RADS(K)) + RETURN + END SUBROUTINE + + SUBROUTINE CCENTRE(X1,X2,X3,Y1,Y2,Y3,XC,YC,RC) + +! get circumcentre and radius + + REAL*8 X1,Y1,X2,Y2,X3,Y3,A,B,C,D,AF,R1,R2,RC,XC,YC + A=X2-X1 + B=Y2-Y1 + C=X3-X1 + D=Y3-Y1 + AF=2.*(B*C-A*D) + R1=(-D*(A**2+B**2) + B*(C**2+D**2))/AF + R2=( C*(A**2+B**2) - A*(C**2+D**2))/AF + RC=SQRT(R1**2+R2**2) + XC=X1+R1 + YC=Y1+R2 + RETURN + END SUBROUTINE + + SUBROUTINE RIDPOINT(NVERT) + + USE BLKMAP + + NCOUNT=0 + DO N=1,NELTS + DO K=1,3 + IF(NOPEL(N,K) .GT. NVERT-3) THEN + DO L=1,3 + NOPEL(N,L)=0 + ENDDO + GO TO 500 + ENDIF + ENDDO + NCOUNT=NCOUNT+1 + DO K=1,3 + NOPEL(NCOUNT,K)=NOPEL(N,K) + ENDDO + XCEN(NCOUNT)=XCEN(N) + YCEN(NCOUNT)=YCEN(N) + RADS(NCOUNT)=RADS(N) + 500 CONTINUE + ENDDO + NELTS=NCOUNT + RETURN + END + + SUBROUTINE SORTDB(A,NKEY,N) +!*********************************** .....SORT..... +!- +!......SORT IS A SIMPLE SHELL SORT ROUTINE IN DOUBLE PRECISION +!- +! SHELL SORT + SAVE +! +!IPK JAN94 INTEGER*2 NKEY + REAL*8 A(*) + INTEGER NKEY(*) + + IF(N.LT.2) RETURN + DO 90 J=1,N + NKEY(J)=J + 90 END DO + ID = N + 100 ID = ID / 2 + 110 IB = 1 + 120 GO TO 200 + 130 IB = IB + 1 + IF( IB .LE. ID ) GO TO 200 + IF( ID .GT. 1 ) GO TO 100 + RETURN + 200 I = IB + 210 K = I + ID + 220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250 + NKT = NKEY(K) + NKEY(K) = NKEY(I) + J = I + 230 K = J - ID + IF( K .LT. 1 ) GO TO 240 + IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240 + NKEY(J) = NKEY(K) + J = K + GO TO 230 + 240 NKEY(J) = NKT + 250 I = I + ID + IF( I + ID .LE. N ) GO TO 210 + GO TO 130 + END + + SUBROUTINE SETEDG(NEDGE) + + USE BLKMAP + +! Setup to form new triangles + + DO J=1,NEDGE + IF(J .LT. NEDGE) THEN + DO K=J+1,NEDGE + IF(IEDGE(K,1) .EQ. IEDGE(J,1)) THEN + IF(IEDGE(K,2) .EQ. IEDGE(J,2)) THEN + IEDGE(J,1)=0 + IEDGE(J,2)=0 + IEDGE(K,1)=0 + IEDGE(K,2)=0 + ENDIF + ELSEIF(IEDGE(K,1) .EQ. IEDGE(J,2)) THEN + IF(IEDGE(K,2) .EQ. IEDGE(J,1)) THEN + IEDGE(J,1)=0 + IEDGE(J,2)=0 + IEDGE(K,1)=0 + IEDGE(K,2)=0 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + RETURN + END + + SUBROUTINE TESTANG(XPT,YPT,K) + + USE BLKMAP + REAL*8 XPT(*),YPT(*) + DATA PI/3.14159/ + + A1=ATAN2(YPT(NOPEL(K,1))-YPT(NOPEL(K,3)),XPT(NOPEL(K,1))-XPT(NOPEL(K,3))) + A2=ATAN2(YPT(NOPEL(K,2))-YPT(NOPEL(K,3)),XPT(NOPEL(K,2))-XPT(NOPEL(K,3))) + IF(A1 .LT. 0) A1=A1+2.*PI + IF(A2 .LT. 0) A2=A2+2.*PI + DIFFA=A2-A1 +! WRITE(148,*) 'DIFFA',K,DIFFA,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3) + IF(DIFFA .LT. 0) DIFFA=DIFFA+PI*2. + IF(DIFFA .LT. 2./3.*PI) RETURN + + IFD=0 + DO N=1,NELTS + IF(N .NE. K) THEN + DO J=1,3 + IF(NOPEL(K,1) .EQ. NOPEL(N,J)) THEN + IF(J .GT. 1) THEN + IF(NOPEL(K,2) .EQ. NOPEL(N,J-1)) THEN + IFD=N + ISIDE=J + GO TO 400 + ENDIF + ELSE + IF(NOPEL(K,2) .EQ. NOPEL(N,3)) THEN + IFD=N + ISIDE=J + GO TO 400 + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + RETURN + 400 CONTINUE + +! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + J1=ISIDE+1 + IF(J1 .GT. 3) J1=1 + + B1=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,2)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,2))) + B2=ATAN2(YPT(NOPEL(K, 3))-YPT(NOPEL(K,2)),XPT(NOPEL(K, 3))-XPT(NOPEL(K,2))) + IF(B1 .LT. 0) B1=B1+2.*PI + IF(B2 .LT. 0) B2=B2+2.*PI + + DIFFB=B2-B1 + +! WRITE(148,*) 'DIFFB',DIFFB,B2,B1 + IF(DIFFB .LT. 0) DIFFB=DIFFB+2.*PI + IF(DIFFB .GT. DIFFA) RETURN + + C1=ATAN2(YPT(NOPEL(K, 3))-YPT(NOPEL(K,1)),XPT(NOPEL(K, 3))-XPT(NOPEL(K,1))) + C2=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,1)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,1))) + IF(C1 .LT. 0) C1=C1+2.*PI + IF(C2 .LT. 0) C2=C2+2.*PI + + DIFFC=C2-C1 +! WRITE(148,*) 'DIFFC',DIFFC,C2,C1 + IF(DIFFC .LT. 0) DIFFC=DIFFC+2.*PI + IF(DIFFC .GT. DIFFA) RETURN + + NOPEL(IFD,1)=NOPEL(K,3) + NOPEL(IFD,2)=NOPEL(K,1) + NOPEL(IFD,3)=NOPEL(IFD,J1) + NOPEL(K,1)=NOPEL(IFD,3) + +! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + + CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) & + &,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) & + &,XCEN(IFD),YCEN(IFD),RADS(IFD)) + + RETURN + END + + + SUBROUTINE TESTTR(XPT,YPT,K) + + USE BLKMAP + REAL*8 XPT(*),YPT(*) + DATA PI/3.14159/ + + A1=ATAN2(YPT(NOPEL(K,2))-YPT(NOPEL(K,1)),XPT(NOPEL(K,2))-XPT(NOPEL(K,1))) + A2=ATAN2(YPT(NOPEL(K,3))-YPT(NOPEL(K,1)),XPT(NOPEL(K,3))-XPT(NOPEL(K,1))) + IF(A1 .LT. 0) A1=A1+2.*PI + IF(A2 .LT. 0) A2=A2+2.*PI + DIFFA=A2-A1 +! WRITE(148,*) 'DIFFA',K,DIFFA,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3) + IF(DIFFA .LT. 0) DIFFA=DIFFA+PI*2. + IF(DIFFA .LT. 2./3.*PI) RETURN + + IFD=0 + DO N=1,NELTS + IF(N .NE. K) THEN + DO J=1,3 + IF(NOPEL(K,2) .EQ. NOPEL(N,J)) THEN + IF(J .GT. 1) THEN + IF(NOPEL(K,3) .EQ. NOPEL(N,J-1)) THEN + IFD=N + ISIDE=J + GO TO 400 + ENDIF + ELSE + IF(NOPEL(K,3) .EQ. NOPEL(N,3)) THEN + IFD=N + ISIDE=J + GO TO 400 + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + RETURN + 400 CONTINUE + +! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + J1=ISIDE+1 + IF(J1 .GT. 3) J1=1 + + B1=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,3)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,3))) + B2=ATAN2(YPT(NOPEL(K, 1))-YPT(NOPEL(K,3)),XPT(NOPEL(K, 3))-XPT(NOPEL(K,3))) + IF(B1 .LT. 0) B1=B1+2.*PI + IF(B2 .LT. 0) B2=B2+2.*PI + + DIFFB=B2-B1 + +! WRITE(148,*) 'DIFFB',DIFFB,B2,B1 + IF(DIFFB .LT. 0) DIFFB=DIFFB+2.*PI + IF(DIFFB .GT. DIFFA) RETURN + + C1=ATAN2(YPT(NOPEL(K, 1))-YPT(NOPEL(K,2)),XPT(NOPEL(K, 1))-XPT(NOPEL(K,2))) + C2=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,2)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,2))) + IF(C1 .LT. 0) C1=C1+2.*PI + IF(C2 .LT. 0) C2=C2+2.*PI + + DIFFC=C2-C1 +! WRITE(148,*) 'DIFFC',DIFFC,C2,C1 + IF(DIFFC .LT. 0) DIFFC=DIFFC+2.*PI + IF(DIFFC .GT. DIFFA) RETURN + + NOPEL(IFD,1)=NOPEL(K,1) + NOPEL(IFD,2)=NOPEL(K,2) + NOPEL(IFD,3)=NOPEL(IFD,J1) + NOPEL(K,2)=NOPEL(IFD,3) + +! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + + CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) & + &,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) & + &,XCEN(IFD),YCEN(IFD),RADS(IFD)) + + RETURN + END diff --git a/src/DELAN2.F90 b/src/DELAN2.F90 new file mode 100644 index 0000000..64d9341 --- /dev/null +++ b/src/DELAN2.F90 @@ -0,0 +1,451 @@ + SUBROUTINE SUPERT(XPT,YPT,NVERT) + + USE BLKMAP +! INCLUDE 'BLK1.COM' + REAL*8 XPT(*),YPT(*) + + REAL*8 XMINM,YMINM,X45 + DATA VDX9/-9.E9/ +! Find minimum x and y + xminm=1.e20 + yminm=1.e20 + x45=-1.e20 + DO J=1,NVERT + IF(XPT(J) .GT. VDX9) THEN + if(xminm .GT. XPT(j) ) then + xminm=XPT(j) + end if + IF(yminm .GT. YPT(j)) then + yminm=YPT(j) + endif + ENDIF + ENDDO +! Find max at 45 degrees + DO J=1,NVERT + IF(XPT(J) .GT. VDX9) THEN + X45T=((XPT(J)-XMINM)+(YPT(J)-YMINM))/1.414 + IF(x45 .LT. X45T) THEN + X45=X45T + ENDIF + ENDIF + END DO + XPT(NVERT+1)=XMINM-5 + YPT(NVERT+1)=YMINM-5. + XPT(NVERT+2)=XMINM+1.414*X45+10. + YPT(NVERT+2)=YMINM-5. + XPT(NVERT+3)=XMINM-5. + YPT(NVERT+3)=YMINM+1.414*X45+10. + NELT=1 + NOPEL(1,1)=NVERT+1 + NOPEL(1,2)=NVERT+2 + NOPEL(1,3)=NVERT+3 + NVERT=NVERT+3 + CALL CCENTRE(XPT(NOPEL(1,1)),XPT(NOPEL(1,2)),XPT(NOPEL(1,3)) & + &,YPT(NOPEL(1,1)),YPT(NOPEL(1,2)),YPT(NOPEL(1,3)) & + &,XCEN(1),YCEN(1),RADS(1)) + RETURN + END SUBROUTINE + + SUBROUTINE INSIDCIRC(XPT,YPT,J,N,ISWT) + +! Test for point inside circumcircle + + USE BLKMAP +! INCLUDE 'BLK1.COM' + + REAL*8 XPT(*),YPT(*) + REAL*8 DISQ + +! Get the distance for this element + + DISQ=(XCEN(J)-XPT(N))**2+(YCEN(J)-YPT(N))**2 + +! Test against the radius + + IF(DISQ .GT. RADS(J)*RADS(J)) THEN + ISWT=0 + ELSE + ISWT=1 + ENDIF + RETURN + END SUBROUTINE + + SUBROUTINE PROCESS(J,NEDGE,NGAP) + +! Drop triangle and form edge buffers + + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + NEDGE=NEDGE+3 + IEDGE(NEDGE-2,1)=NOPEL(J,1) + IEDGE(NEDGE-1,1)=NOPEL(J,2) + IEDGE(NEDGE,1) =NOPEL(J,3) + IEDGE(NEDGE-2,2)=NOPEL(J,2) + IEDGE(NEDGE-1,2)=NOPEL(J,3) + IEDGE(NEDGE,2) =NOPEL(J,1) + NOPEL(J,1)=0 + NOPEL(J,2)=0 + NOPEL(J,3)=0 + NGAP=NGAP+1 + IGAP(NGAP)=J + RETURN + END SUBROUTINE + + SUBROUTINE FORMT(XPT,YPT,J,N,NGAP,K,WD) + +! Form the triangle + + USE BLKMAP + + REAL*8 XPT(*),YPT(*) + REAL WD(*) +! INCLUDE 'BLK1.COM' + + IF(NGAP .GT. 0) THEN + K=IGAP(NGAP) + NGAP=NGAP-1 + ELSE + NELTS=NELTS+1 + K=NELTS + ENDIF + NOPEL(K,1)=IEDGE(J,1) + NOPEL(K,2)=IEDGE(J,2) + NOPEL(K,3)=N + + CALL TESTANG(XPT,YPT,K,WD) + +! Now get circumcircle data + + CALL CCENTRE(XPT(NOPEL(K,1)),XPT(NOPEL(K,2)),XPT(NOPEL(K,3)) & + &,YPT(NOPEL(K,1)),YPT(NOPEL(K,2)),YPT(NOPEL(K,3)) & + &,XCEN(K),YCEN(K),RADS(K)) + RETURN + END SUBROUTINE + + SUBROUTINE CCENTRE(X1,X2,X3,Y1,Y2,Y3,XC,YC,RC) + +! get circumcentre and radius + + REAL*8 X1,Y1,X2,Y2,X3,Y3,A,B,C,D,AF,R1,R2,RC,XC,YC + A=X2-X1 + B=Y2-Y1 + C=X3-X1 + D=Y3-Y1 + AF=2.*(B*C-A*D) + R1=(-D*(A**2+B**2) + B*(C**2+D**2))/AF + R2=( C*(A**2+B**2) - A*(C**2+D**2))/AF + RC=SQRT(R1**2+R2**2) + XC=X1+R1 + YC=Y1+R2 + RETURN + END SUBROUTINE + + SUBROUTINE RIDPOINT(NVERT) + + USE BLKMAP + + NCOUNT=0 + DO N=1,NELTS + DO K=1,3 + IF(NOPEL(N,K) .GT. NVERT-3) THEN + DO L=1,3 + NOPEL(N,L)=0 + ENDDO + GO TO 500 + ENDIF + ENDDO + NCOUNT=NCOUNT+1 + DO K=1,3 + NOPEL(NCOUNT,K)=NOPEL(N,K) + ENDDO + XCEN(NCOUNT)=XCEN(N) + YCEN(NCOUNT)=YCEN(N) + RADS(NCOUNT)=RADS(N) + 500 CONTINUE + ENDDO + NELTS=NCOUNT + RETURN + END + + SUBROUTINE SORTDB(A,NKEY,N) +!*********************************** .....SORT..... +!- +!......SORT IS A SIMPLE SHELL SORT ROUTINE IN DOUBLE PRECISION +!- +! SHELL SORT + SAVE +! +!IPK JAN94 INTEGER*2 NKEY + REAL*8 A(*) + INTEGER NKEY(*) + + IF(N.LT.2) RETURN + DO 90 J=1,N + NKEY(J)=J + 90 END DO + ID = N + 100 ID = ID / 2 + 110 IB = 1 + 120 GO TO 200 + 130 IB = IB + 1 + IF( IB .LE. ID ) GO TO 200 + IF( ID .GT. 1 ) GO TO 100 + RETURN + 200 I = IB + 210 K = I + ID + 220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250 + NKT = NKEY(K) + NKEY(K) = NKEY(I) + J = I + 230 K = J - ID + IF( K .LT. 1 ) GO TO 240 + IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240 + NKEY(J) = NKEY(K) + J = K + GO TO 230 + 240 NKEY(J) = NKT + 250 I = I + ID + IF( I + ID .LE. N ) GO TO 210 + GO TO 130 + END + + SUBROUTINE SETEDG(NEDGE) + + USE BLKMAP + +! Setup to form new triangles + + DO J=1,NEDGE + IF(J .LT. NEDGE) THEN + DO K=J+1,NEDGE + IF(IEDGE(K,1) .EQ. IEDGE(J,1)) THEN + IF(IEDGE(K,2) .EQ. IEDGE(J,2)) THEN + IEDGE(J,1)=0 + IEDGE(J,2)=0 + IEDGE(K,1)=0 + IEDGE(K,2)=0 + ENDIF + ELSEIF(IEDGE(K,1) .EQ. IEDGE(J,2)) THEN + IF(IEDGE(K,2) .EQ. IEDGE(J,1)) THEN + IEDGE(J,1)=0 + IEDGE(J,2)=0 + IEDGE(K,1)=0 + IEDGE(K,2)=0 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + RETURN + END + + SUBROUTINE TESTANG(XPT,YPT,K,WD) + + USE BLKMAP + REAL*8 XPT(*),YPT(*) + REAL WD(*) + DATA PI/3.14159/ + + ! IF(WD(NOPEL(K,1)) .EQ. WD(NOPEL(K,2)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN + ! RETURN + ! ENDIF + ! + IFD=0 + DO N=1,NELTS + IF(N .NE. K) THEN + DO J=1,3 + IF(NOPEL(K,1) .EQ. NOPEL(N,J)) THEN + IF(J .GT. 1) THEN + IF(NOPEL(K,2) .EQ. NOPEL(N,J-1)) THEN + IFD=N + ISIDE=J + GO TO 400 + ENDIF + ELSE + IF(NOPEL(K,2) .EQ. NOPEL(N,3)) THEN + IFD=N + ISIDE=J + GO TO 400 + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + RETURN + 400 CONTINUE + + J1=ISIDE+1 + IF(J1 .GT. 3) J1=1 + ! + ! IF(WD(NOPEL(K,3)) .EQ. WD(NOPEL(IFD,J1)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN + ! WRITE(148,'(12I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + ! IF(NELTS .GT. 20) WRITE(148,'(12I8)') NOPEL(21,1),NOPEL(21,2),NOPEL(21,3) + ! NOPEL(IFD,1)=NOPEL(K,3) + ! NOPEL(IFD,2)=NOPEL(K,1) + ! NOPEL(IFD,3)=NOPEL(IFD,J1) + ! NOPEL(K,1)=NOPEL(IFD,3) + ! + ! WRITE(148,'(12I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + ! IF(NELTS .GT. 20) WRITE(148,'(12I8)') NOPEL(21,1),NOPEL(21,2),NOPEL(21,3) + ! + ! CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) & + !& ,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) & + !& ,XCEN(IFD),YCEN(IFD),RADS(K)) + ! CALL CCENTRE(XPT(NOPEL(K,1)),XPT(NOPEL(K,2)),XPT(NOPEL(K,3)) & + !& ,YPT(NOPEL(K,1)),YPT(NOPEL(K,2)),YPT(NOPEL(K,3)) & + !& ,XCEN(K),YCEN(K),RADS(K)) + ! + ! RETURN + ! ENDIF + A1=ATAN2(YPT(NOPEL(K,1))-YPT(NOPEL(K,3)),XPT(NOPEL(K,1))-XPT(NOPEL(K,3))) + A2=ATAN2(YPT(NOPEL(K,2))-YPT(NOPEL(K,3)),XPT(NOPEL(K,2))-XPT(NOPEL(K,3))) + IF(A1 .LT. 0) A1=A1+2.*PI + IF(A2 .LT. 0) A2=A2+2.*PI + DIFFA=A2-A1 +! WRITE(148,*) 'DIFFA',K,DIFFA,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3) + IF(DIFFA .LT. 0) DIFFA=DIFFA+PI*2. + IF(DIFFA .LT. 2./3.*PI) RETURN + +! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + + B1=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,2)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,2))) + B2=ATAN2(YPT(NOPEL(K, 3))-YPT(NOPEL(K,2)),XPT(NOPEL(K, 3))-XPT(NOPEL(K,2))) + IF(B1 .LT. 0) B1=B1+2.*PI + IF(B2 .LT. 0) B2=B2+2.*PI + + DIFFB=B2-B1 + +! WRITE(148,*) 'DIFFB',DIFFB,B2,B1 + IF(DIFFB .LT. 0) DIFFB=DIFFB+2.*PI + IF(DIFFB .GT. DIFFA) RETURN + + C1=ATAN2(YPT(NOPEL(K, 3))-YPT(NOPEL(K,1)),XPT(NOPEL(K, 3))-XPT(NOPEL(K,1))) + C2=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,1)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,1))) + IF(C1 .LT. 0) C1=C1+2.*PI + IF(C2 .LT. 0) C2=C2+2.*PI + + DIFFC=C2-C1 +! WRITE(148,*) 'DIFFC',DIFFC,C2,C1 + IF(DIFFC .LT. 0) DIFFC=DIFFC+2.*PI + IF(DIFFC .GT. DIFFA) RETURN + + NOPEL(IFD,1)=NOPEL(K,3) + NOPEL(IFD,2)=NOPEL(K,1) + NOPEL(IFD,3)=NOPEL(IFD,J1) + NOPEL(K,1)=NOPEL(IFD,3) + +! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + + CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) & + &,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) & + &,XCEN(IFD),YCEN(IFD),RADS(IFD)) + + RETURN + END + + + SUBROUTINE TESTTR(XPT,YPT,K,WD) + + USE BLKMAP + REAL WD(*) + REAL*8 XPT(*),YPT(*) + DATA PI/3.14159/ + + IF(WD(NOPEL(K,1)) .EQ. WD(NOPEL(K,2)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN + RETURN + ENDIF + + + IFD=0 + DO N=1,NELTS + IF(N .NE. K) THEN + DO J=1,3 + IF(NOPEL(K,2) .EQ. NOPEL(N,J)) THEN + IF(J .GT. 1) THEN + IF(NOPEL(K,3) .EQ. NOPEL(N,J-1)) THEN + IFD=N + ISIDE=J + GO TO 400 + ENDIF + ELSE + IF(NOPEL(K,3) .EQ. NOPEL(N,3)) THEN + IFD=N + ISIDE=J + GO TO 400 + ENDIF + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + RETURN + 400 CONTINUE + + WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + write(148,'(9x,6f8.0)')wd(NOPEL(K,1)),wd(NOPEL(K,2)),wd(NOPEL(K,3)),wd(NOPEL(IFD,1)),wd(NOPEL(IFD,2)),wd(NOPEL(IFD,3)) + J1=ISIDE+1 + IF(J1 .GT. 3) J1=1 + WRITE(148,*) J1 + + IF(WD(NOPEL(K,1)) .EQ. WD(NOPEL(IFD,J1)) .and. wd(nopel(k,1)) .gt. -9990. ) THEN + ITEMP=NOPEL(IFD,J1) + NOPEL(IFD,1)=NOPEL(K,3) + NOPEL(IFD,2)=NOPEL(K,1) + NOPEL(IFD,3)=ITEMP + NOPEL(K,1)=NOPEL(IFD,3) + + WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + + CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) & + & ,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) & + & ,XCEN(IFD),YCEN(IFD),RADS(IFD)) + + RETURN + ENDIF + A1=ATAN2(YPT(NOPEL(K,2))-YPT(NOPEL(K,1)),XPT(NOPEL(K,2))-XPT(NOPEL(K,1))) + A2=ATAN2(YPT(NOPEL(K,3))-YPT(NOPEL(K,1)),XPT(NOPEL(K,3))-XPT(NOPEL(K,1))) + IF(A1 .LT. 0) A1=A1+2.*PI + IF(A2 .LT. 0) A2=A2+2.*PI + DIFFA=A2-A1 +! WRITE(148,*) 'DIFFA',K,DIFFA,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3) + IF(DIFFA .LT. 0) DIFFA=DIFFA+PI*2. + IF(DIFFA .LT. 2./3.*PI) RETURN + + B1=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,3)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,3))) + B2=ATAN2(YPT(NOPEL(K, 1))-YPT(NOPEL(K,3)),XPT(NOPEL(K, 1))-XPT(NOPEL(K,3))) + IF(B1 .LT. 0) B1=B1+2.*PI + IF(B2 .LT. 0) B2=B2+2.*PI + + DIFFB=B2-B1 + +! WRITE(148,*) 'DIFFB',DIFFB,B2,B1 + IF(DIFFB .LT. 0) DIFFB=DIFFB+2.*PI + IF(DIFFB .GT. DIFFA) RETURN + + C1=ATAN2(YPT(NOPEL(K, 1))-YPT(NOPEL(K,2)),XPT(NOPEL(K, 1))-XPT(NOPEL(K,2))) + C2=ATAN2(YPT(NOPEL(IFD,J1))-YPT(NOPEL(K,2)),XPT(NOPEL(IFD,J1))-XPT(NOPEL(K,2))) + IF(C1 .LT. 0) C1=C1+2.*PI + IF(C2 .LT. 0) C2=C2+2.*PI + + DIFFC=C2-C1 +! WRITE(148,*) 'DIFFC',DIFFC,C2,C1 + IF(DIFFC .LT. 0) DIFFC=DIFFC+2.*PI + IF(DIFFC .GT. DIFFA) RETURN + ITEMP=NOPEL(IFD,J1) + NOPEL(IFD,1)=NOPEL(K,1) + NOPEL(IFD,2)=NOPEL(K,2) + NOPEL(IFD,3)=ITEMP + NOPEL(K,2)=NOPEL(IFD,3) + +! WRITE(148,'(9I8)') K,J,IFD,NOPEL(K,1),NOPEL(K,2),NOPEL(K,3),NOPEL(IFD,1),NOPEL(IFD,2),NOPEL(IFD,3) + + CALL CCENTRE(XPT(NOPEL(IFD,1)),XPT(NOPEL(IFD,2)),XPT(NOPEL(IFD,3)) & + &,YPT(NOPEL(IFD,1)),YPT(NOPEL(IFD,2)),YPT(NOPEL(IFD,3)) & + &,XCEN(IFD),YCEN(IFD),RADS(IFD)) + + RETURN + END diff --git a/src/DELAUNAY.F90 b/src/DELAUNAY.F90 new file mode 100644 index 0000000..a443ab9 --- /dev/null +++ b/src/DELAUNAY.F90 @@ -0,0 +1,264 @@ + SUBROUTINE TRIANG + + USE WINTERACTER + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + DATA VOID10/-1.E10/,SPAC/0.0/ + + NELTS=0 + NVERT=MAXPTS + NINTV=1 + CALL TRIANOPT(NINTV,SPAC) + + +! FIRST WRITE EXISTING MAP TO SCRATCH + OPEN(99,FORM='BINARY',STATUS='SCRATCH') + + CALL WRTMAP(99) + REWIND 99 + + DO N=1,NVERT + IF(MOD(N-1,NINTV) .EQ. 0) THEN + IMAP(N)=1 + ELSE + IMAP(N)=0 + ENDIF + ENDDO + + IF(SPAC .GT. 0.) THEN + DO N=1,NVERT + IF(IMAP(N) .EQ. 1) THEN + IF(N .LT. NVERT) THEN + DO M=N+1,NVERT + DISQ=(XMAP(M)-XMAP(N))**2+(YMAP(M)-YMAP(N))**2 + IF(DISQ .LT. SPAC**2) THEN + IMAP(M)=0 + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO + ENDIF + NN=0 + DO N=1,NVERT + IF(IMAP(N) .GT. 0) THEN + NN=NN+1 + XMAP(NN)=XMAP(N) + YMAP(NN)=YMAP(N) + IMAP(NN)=IMAP(N) + ENDIF + ENDDO + NVERT=NN +! WRITE(185,*) 'NEW NVERT',NVERT + + + call WcursorShape(CurHourGlass) + CALL DELAUNAY(NVERT) + call WcursorShape(CurArrow) + + + RETURN + END + + + +! Last change: IPK 2 Feb 2003 6:25 pm + SUBROUTINE DELAUNAY(NVERT) + + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*80 LIND + CHARACTER*1 ANS + DATA VDX9/-9.E9/,NEDGE/0/ + +! Get location of supertriangle + + iprt=0 + ngap=0 + YLV=7.5 + + + + call supert(XMAP,YMAP,NVERT) + + NELTS=1 + + NVERTM=NVERT-3 + IF(NVERT .GT. MAXP) THEN + DEALLOCATE (NKEY) + ALLOCATE (NKEY(NVERT)) + NKEY=0 + ENDIF + +! Sort points into ascending x order + + CALL SORTDB(XMAP,NKEY,NVERTM) + +! Loop on the vertices + + DO NN=1,NVERT-3 + +! IF(MOD(NN,5) .EQ. 0) WRITE(185,*) 'LOOP',NN + if(mod(NN,2500) .eq. 0) then + WRITE(90,*) NN,' points processed' + ylv=ylv-0.3 + if(ylv .lt. 0.1) then + ylv=7.9 + call clscrn + endif + write(lind,6010) NN + 6010 format(i8,' points processed') + call symbl & + & (1.1,ylv,0.20,LIND,0.0,80) + endif + +! process next point + + N=NKEY(NN) + +! Skip out if inactive point + IF(N .EQ. 0) GO TO 500 + IF(IMAP(N) .EQ. 0) GO TO 500 + IF(XMAP(N) .LT. VDX9) GO TO 500 + IF(VAL(N) .LT. -9000.) GO TO 500 +! IF(NN .GT. 1700. .AND. MOD(NN,5) .EQ. 0) WRITE(185,*) 'N',N,IMAP(N),XMAP(N),VAL(N) + +! WRITE(45,*) NN,N,NVERT,XMAP(N),YMAP(N) + IF(NN .LT. NVERTM) THEN + DO KK=NN+1,NVERTM + K=NKEY(KK) +! IF(NN .GT. 1700) WRITE(185,*) 'NKEY',K,KK + + IF(K .NE. 0) THEN + IF(XMAP(N) .EQ. XMAP(K)) THEN + IF(YMAP(N) .EQ. YMAP(K)) THEN + WRITE(45,*) 'IDENT',N,K + NKEY(KK)=0 + ENDIF + ELSE + GO TO 200 + ENDIF + ENDIF + 200 CONTINUE + ENDDO + ENDIF + +! Set edge buffers to zero +! IF(NN .GT. 1700 .AND. MOD(NN,5) .EQ. 0) WRITE(185,*) 'AFTER 200 NEDGE',NEDGE + + IF(NEDGE .GT. 0) THEN + DO J=1,NEDGE + IEDGE(J,1)=0 + IEDGE(J,2)=0 + END DO + ELSE + DO J=1,100 + IEDGE(J,1)=0 + IEDGE(J,2)=0 + END DO + ENDIF + NEDGE=0 + +! test for point in circumcircle + + DO J=1,NELTS + CALL INSIDCIRC(XMAP,YMAP,J,N,ISWT) + +! If inside process edges + + IF(ISWT .EQ. 1) THEN + CALL PROCESS(J,NEDGE,NGAP) + ENDIF + END DO + +! Setup to form new triangles + + CALL SETEDG(NEDGE) + +! Now form triangles as needed + + DO J=1,NEDGE + IF(IEDGE(J,1) .NE. 0) THEN + CALL FORMT(XMAP,YMAP,J,N,NGAP,KK,WD) + ENDIF + END DO + + NEDGE=0 + if(iprt .eq. 0) go to 500 + DO J=1,NELTS + IF(NOPEL(J,1) .GT. 0) THEN + WRITE(3,'(2i5,2i10,19x,''1'')') J,(NOPEL(J,K),K=1,3) + ENDIF + END DO + + + IF(NN .EQ. 1) THEN + write(41,'('' 9999'')') + do j=1,nvert + write(41,'(i10,2f20.4,F10.3)') j,XMAP(j),YMAP(j),VAL(J) + enddo + write(41,'('' 9999'')') + write(41,'('' 9999'')') + write(41,'('' 0 NENTRY'')') + write(41,'('' 0 NCLM'')') + WRITE(41,'(''ENDDATA'')') + ENDIF + 500 continue + END DO + +! Get rid of elements from super point + + CALL RIDPOINT(NVERT) + + RETURN + END SUBROUTINE + + SUBROUTINE TRIANOPT(NINTV,SPAC) + + USE WINTERACTER + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INTEGER :: NINTV + INTEGER :: IERR + REAL :: SPAC + CHARACTER*1 :: IFLAG + + call wdialogload(IDD_TRIAN) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_TRIAN) + ierr=infoerror(1) + + CALL WDialogPutInteger(IDF_INTEGER1,NINTV) + CALL WDialogPutReal(IDF_REAL1,SPAC) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + + CALL WDialogGetINTEGER(IDF_INTEGER1,NINTV) + IF(NINTV .EQ. 0) NINTV=1 + CALL WDialogGetREAL(IDF_REAL1,SPAC) + ELSE + SPAC=0.0 + NINTV=1 + ENDIF + RETURN + enddo + RETURN + END + \ No newline at end of file diff --git a/src/DEMOS.F90 b/src/DEMOS.F90 new file mode 100644 index 0000000..9e4f93e --- /dev/null +++ b/src/DEMOS.F90 @@ -0,0 +1,45 @@ + SUBROUTINE DEMOS + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + COMMON /RECOD/ IRECD,TSPC + COMMON /PAGE/ XL,XH,YL,YH + common /cols/ ibakk,icolr,iblkk + + CHARACTER*255 FNAME + CHARACTER*40 LIND,dlin + + xl=0. + yl=0. + xh=HSIZE + yh=8.0 + ibakk=8 + icolr=11 + iblkk=14 + OPEN(75,FILE='DINFO.OUT',FORM='FORMATTED',STATUS='UNKNOWN') + + WRITE(75,*) 'IN DEMOS' + FNAME='RECORD.REC' + OPEN(9,FILE='PALMIS.MAP',STATUS='OLD', FORM='FORMATTED') + IMP=9 + IIN=0 + + OPEN(91,FILE=FNAME,STATUS='OLD') + CALL RBLUE + nmess=45 + call getfpn(tspc) +! WRITE(LIND,6005) +! 6005 FORMAT('Enter time interval between events') +! call symbl(1.1,3.5,0.25,LIND,0.0,80) +! ndig=32 +! CALL GTFPNX(TSPC,NDEC,NDIG,5.0,6.0) +! write(75,'(a)') 'demos-lind',lind +! call get_label(lind,dlin) +! write(75,'(a)') 'label',dlin +! read(dlin,'(f20.2)') tspc + IRECD=2 + WRITE(75,*) 'tspc', tspc + + RETURN + END diff --git a/src/DOGRAPH.F90 b/src/DOGRAPH.F90 new file mode 100644 index 0000000..3b4e231 --- /dev/null +++ b/src/DOGRAPH.F90 @@ -0,0 +1,306 @@ + SUBROUTINE dograph(noptt,icurrwin) +!!!!!! (XVALUES,YVALUES,NVALUES,XMIN,XMAX,VALMIN,YMAX) +! +! Graph plotting code generated by GraphEd at 21:20 on 11 Apr 1999. +! +! XVALUES = Array of X values to plot +! YVALUES = Array of Y values to plot +! NVALUES = Number of values +! TIMMIN = Min X +! TIMMAX = Max X +! VALMIN = Min Y +! VALMAX = Max Y +! +! +! USE module containing routine definitions and symbolic names. +! + USE WINTERACTER +! +! +! Common arguments. +! + CHARACTER*6 DESCR + CHARACTER*48 XLABEL, YYLABEL + CHARACTER*48 PTITL + CHARACTER*4 AXTYPE, YAXTYPE + COMMON /XYGRPH/ XVALUES(10000,10),YVALUES(10000,10),TIMMIN,VALMIN,TIMMAX,VALMAX,NVALUES,NSETS,LINPROP(10) + COMMON /PAXC/ PTITL,AXTYPE,XLABEL,YAXTYPE,YYLABEL + + COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10),DESCR(10) + + + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout + CHARACTER*80 TITLE + CHARACTER*24 HLABL + character*40 mpnam + CHARACTER*1 ALABL(10) + COMMON /BLKA1/ TITLE,HLABL,ALABL,MPNAM + + character*8 labl + character*72 data + CHARACTER*20 TITL1,TITL4 + CHARACTER*64 TITL2,TITL3 + COMMON /BLKA11/ TITL1,TITL2,TITL3,TITL4& + , labl(400),data(400) + +!IPK JAN03 + + INTEGER IHANDLE1 + +! REAL, INTENT(IN), DIMENSION(NVALUES) :: XVALUES +! REAL, INTENT(IN), DIMENSION(NVALUES) :: YVALUES +! REAL TIMMIN,TIMMAX,VALMIN,VALMAX +! INTEGER NVALUES + + + nopt=abs(noptt) + WRITE(90,*) 'IN DOGRAPH',NOPT,icurrwin + +! nopt = 999 skip to draw current page +! nopt = -2 skip to draw current page +! nopt = 2 draw time plots +! nopt = 4 from brkarea + + if(nopt .eq. 999) go to 300 + IF(NOPTT .EQ. -2) GO TO 300 + if(nopt .ne. 3) then + +! do this only for nopt = 4 or nopt = 2 first search for empty window + + do n=1,nwindws + if(iwndws(n) .eq. 0) then + icurrwin=n + go to 290 + endif + enddo + +! or increase window count + + + nwindws=nwindws+1 + if(nwindws .eq. 10) then + call WMessageBox(0,3,1,'Warning 10 windows now open','WARNING') + IF(WInfoDialog(4) .eq. 1) then + ENDIF + endif + icurrwin=nwindws + 290 continue + else + +! do this for nopt = 3 ie +! draw the bitmap in icurrwin and return + + call backp(2,icurrwin) + return + endif +!ipk jan03 + +! if no window defined yet open a child window for it and give it a handle + + IF(Iwndws(icurrwin) .EQ. 0) THEN + CALL WindowOpenChild(IHANDLE1,FLAGS=SysMenuOn+MinButton+MaxButton, & + TITLE='Cross-Section') + Iwndws(icurrwin)=ihandle1 + ENDIF + +! setup to draw bitmap in icurrwin + + CALL BACKP(1,icurrwin) + 300 continue +! +! Start new presentation graphics plot +! +! CALL IPgNewGraph(NSETS,NVALUES,' ',' ','X') + CALL IPgNewPlot(6,nsets,nvalues) +! +! Set Clipping Rectangle +! + CALL IPgClipRectangle('G') +! +! Set style for each data set +! +! CALL IPgStyle( 1, 0, 0, 0,223, 96) +! CALL IPgStyle( 2, 1, 0, 0, 31,128) +! CALL IPgStyle( 3, 2, 0, 0,159,160) +! CALL IPgStyle( 4, 3, 0, 0, 95,192) +! CALL IPgStyle( 5, 5, 0, 0,223,224) + + ICL=255+256*255+256*256*255 + IF(LINPROP(1) .EQ. 0) THEN + CALL IPgStyle( 1, 0, 0, 0,223,195) + ELSE + CALL IPgStyle( 1, 0, 3, 0,ICL,195) + ENDIF + IF(LINPROP(2) .EQ. 0) THEN + CALL IPgStyle( 2, 1, 0, 0,33405,33405) + ELSE + CALL IPgStyle( 2, 1, 3, 0,ICL,33405) + ENDIF + IF(LINPROP(3) .EQ. 0) THEN + CALL IPgStyle( 3, 2, 0, 0,8551680,8551680) + ELSE + CALL IPgStyle( 3, 2, 3, 0,ICL,8551680) + ENDIF + IF(LINPROP(4) .EQ. 0) THEN + CALL IPgStyle( 4, 3, 0, 0,65415,65415) + ELSE + CALL IPgStyle( 4, 3, 3, 0,ICL,65415) + ENDIF + IF(LINPROP(5) .EQ. 0) THEN + CALL IPgStyle( 5, 5, 0, 0,0,0) + ELSE + CALL IPgStyle( 5, 5, 3, 0,ICL,0) + ENDIF +! +! Set marker number for data sets not using default marker +! + CALL IPgMarker( 1, 1) + CALL IPgMarker( 2, 2) + CALL IPgMarker( 3, 2) + CALL IPgMarker( 4, 2) + CALL IPgMarker( 5, 2) +! +! Set units for plot +! + CALL IPgUnits( TIMMIN, VALMIN, TIMMAX, VALMAX) +! +! Set presentation graphics area +! + CALL IPgArea( .150, .100, .900, .800) +! +! Draw main title +! + CALL IGrCharSet('H') + CALL IGrCharFont( 1) + CALL IGrCharSpacing('F') + CALL IGrCharSize( 0.67, 0.67) + CALL IGrColourN( 208) + + CALL IPgTitle('CROSS-SECTION','C') +! +! Label bottom X axis +! + CALL IPgXLabelPos( .70) + CALL IPgXLabel('Section Dimension','C') + +! +! Label left Y axis +! + CALL IPgYLabelPos( .80) + + CALL IPgYLabelLeft('Elevation','C9') +! +! Draw axes +! + CALL IGrColourN( 208) + CALL IPgAxes(TIMMIN,VALMIN) +! +! Adjust tick position for X Axes +! + CALL IPgXTickPos(VALMIN,VALMAX) +!DEC09 CALL IPgXTickPos(1,TIMMIN) +! +! Scale for bottom X Axis +! + CALL IPgXUserScale((/0.0/),0) + CALL IPgXScaleAngle( .00, .00) + CALL IPgXScalePos( .38) + CALL IPgXScale('NT') +! +! Adjust tick position for Y Axes +! + CALL IPgYTickPos( TIMMIN , TIMMAX ) +!DEC09 CALL IPgYTickPos( 1,VALMIN) +!DEC09 ISIDE=1 +!DEC09 CALL IPgYTickPos( ISIDE,TIMMAX) +! Scale for left Y Axis +! + CALL IPgYUserScale((/0.0/),0) + CALL IPgYScaleAngle( .00, .00) + CALL IPgYScalePos( 1.50) + CALL IPgYScaleLeft('NT') +! +! Draw graph. +! + DO ISET = 1,NSETS + + CALL IPgXYPairs(XVALUES(1,iset),YVALUES(1,ISET)) + + END DO + + call IPgKeyAll(DESCR,' ') + +! CALL SYMBL(0.1,7.60,0.18,TITL2,0.0,+64) + + + if(nopt .ne. 999 .and. NOPTT .NE. -2) CALL BACKP(2,icurrwin) + + RETURN + END SUBROUTINE dograph + + + SUBROUTINE BACKP(IENT,icurrwin) + +! ient = 1 means either set to draw bitmap or create window for plotting ihandle(icurrwin) +! then select to draw bitmap +! ient = 2 means select drawing of window and putting the bitmap into it, folloed by return +! to main window +! ient = 3 means destroy slected window + + + use winteracter + + implicit none + + include 'D.INC' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + INTEGER :: iw,ih,ihandle,ient,icurrwin,ihandlem + common /handP/ ihandle(10) +! write(128,*) 'ient',ient,icurrwin,ihandle(icurrwin) + if(ient .eq. 1) then + iw=WinfoWindow(WindowWidth) + ih=WinfoWindow(WindowHeight) + IF(IHANDLE(icurrwin) .EQ. 0) THEN + call WBitmapCreate(ihandle(icurrwin),iw,ih) + call IGrSelect(DrawBitmap,ihandle(icurrwin)) + ELSE + call IGrSelect(DrawBitmap,ihandle(icurrwin)) + ENDIF + return + elseif(ient .eq. 2) then + call IGrSelect(DrawWin) + call WBitmapPut(ihandle(icurrwin),0,1) +!!! call WBitmapDestroy(ihandle) + ihandlem=0 + call WindowSelect(ihandlem) + else + CALL WBitmapDestroy(ihandle(icurrwin)) + + endif + return + end + + SUBROUTINE DOPLOT(IMZ) + + + COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10) + + if(nwindws .gt. 0) then + do n=1,nwindws + if(iscrns(n) .eq. 3) then + call WindowSelect(iwndws(n)) + call clscrn + call dograph(3,n) + endif + enddo + call WindowSelect(0) + endif + + RETURN + END diff --git a/src/DUMMY.F90 b/src/DUMMY.F90 new file mode 100644 index 0000000..eb13a5d --- /dev/null +++ b/src/DUMMY.F90 @@ -0,0 +1,12 @@ + + SUBROUTINE PLOTSV(I) + RETURN + END + + SUBROUTINE NDPLSV + RETURN + END + + SUBROUTINE SETD(I) + RETURN + END \ No newline at end of file diff --git a/src/EGEN - Copy (2).F90 b/src/EGEN - Copy (2).F90 new file mode 100644 index 0000000..7213203 --- /dev/null +++ b/src/EGEN - Copy (2).F90 @@ -0,0 +1,1061 @@ + +! Last change: IPK 12 Jan 98 1:44 pm +! + SUBROUTINE GNODE +! +! Routine to create a series of nodes along a line +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + REAL*8 GRIDX(150),GRIDY(150),ALX,ALY,ATX,ATY,ALXX(1000),ALYY(1000),ALWD(1000) + REAL*8 BLXX(1000),BLYY(1000),BLWD(1000),CURRENTX,CURRENTY + INTEGER ITYPBC(1000),IREF(1000) +! + CHARACTER*1 IFLAG + data itime/0/ + + if(itime .eq. 0) then + nh=1 + itime=1 + endif +4 CONTINUE + CALL FORMLINEMENU(ITYP,I1D,I2D,IFIN,XLENGTH,ITYPIN,NELC) + IF(I1D .EQ. -999) RETURN + IF(ITYP .EQ. 1) THEN + NHTP = 0 + NMESS = 6 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ALX=XTEMP + ALY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + CALL WRTOUT(0) + RETURN + ENDIF +! +! Exit input +! + 9 CONTINUE + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + CALL HEDR +! + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ATX=XTEMP + ATY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) +! +! Define number of nodes in a line +! + NBRR = 0 + NMESS=45 + CALL HEDR + NMESS = 7 + call getint(nh) +! READ(*,*) NH + NINT=NH-1 +! +! zero GRIDX and GRIDY to hold generated coordinates +! + DO N=1,NH + GRIDX(N)=0. + GRIDY(N)=0. + END DO +! +! Interpolate points onto line +! + CALL INTERP(GRIDX,GRIDY,1,NH,1,ALX,ALY,ATX,ATY,NINT,0) +! +! Copy points into the coordinate array +! + DO N=1,NH +! +! Find next blank node in CORD +! + CALL GETNOD(J) +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = GRIDX(N) + CORD(J,2) = GRIDY(N) + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = GRIDX(N)*TXSCAL - XS + YUSR(J) = GRIDY(N)*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) +! + END DO + ELSE + IF(IFIN .EQ. 0) THEN + NHTP = 0 + NMESS = 6 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + DO J=1,1000 + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + IF(IFLAG .EQ. 'q' .or. ibox .eq. 10) go to 300 + ALXX(J)=XTEMP + ALYY(J)=YTEMP + JPTS=J + ENDDO +300 CONTINUE + ELSE + CALL FILEDAT(ALXX,ALYY,ALWD,JPTS,BLXX,BLYY,BLWD,JPTSB,ITYPBC) + ENDIF +! SORT OUT A NEW ORDER + + IREF=1 + CURRENTX=ALXX(1) + CURRENTY=ALYY(1) + KS=2 + KSP=1 + DO J=2,JPTS + DO K=KSP,JPTSB + TOTLEN=SQRT((ALXX(J)-CURRENTX)**2+(ALYY(J)-CURRENTY)**2) + TOTLENB=SQRT((BLXX(K)-CURRENTX)**2+(BLYY(K)-CURRENTY)**2) + IF(ABS(TOTLENB - TOTLEN) .LT. 1.0) THEN +! THIS IS A BREAKPOINT + IREF(KS)=-K + KS=KS+1 + KSP=KSP+1 + CURRENTX=BLXX(K) + CURRENTY=BLYY(K) + GO TO 320 + ENDIF + IF(TOTLENB .LT. TOTLEN) THEN +! THIS IS A BREAKPOINT + IREF(KS)=-K + KS=KS+1 + KSP=KSP+1 + CURRENTX=BLXX(K) + CURRENTY=BLYY(K) + GO TO 310 + ELSE + IREF(KS)=J + KS=KS+1 + CURRENTX=ALXX(J) + CURRENTY=ALYY(J) + GO TO 320 + ENDIF + 310 CONTINUE + ENDDO + 320 CONTINUE + ENDDO + IREF(KS)=JPTS + IF(IFIN .GT. 0) THEN + DO K=KS,1,-1 + IF(IREF(K) .LT. 0) THEN + ALXX(K)=BLXX(-IREF(K)) + ALYY(K)=BLYY(-IREF(K)) + ALWD(K)=BLWD(-IREF(K)) + WRITE(155,*) K,IREF(K),ALXX(K),ALYY(K) + ELSE + ALXX(K)=ALXX(IREF(K)) + ALYY(K)=ALYY(IREF(K)) + ALWD(K)=BLWD(IREF(K)) + WRITE(155,*) K,IREF(K),ALXX(K),ALYY(K) + ENDIF + ENDDO + DO J=1,KS + ALXX(J)=(ALXX(J)+XS)/TXSCAL + ALYY(J)=(ALYY(J)+YS)/TXSCAL + ENDDO + DO J=1,KS + BLXX(J)=(BLXX(J)+XS)/TXSCAL + BLYY(J)=(BLYY(J)+YS)/TXSCAL + ENDDO +! KS=KS-1 + ENDIF + JST=1 + JKP=0 + ICTYP=40 + DO K=2,KS + IF(IREF(K) .LT. 0 .OR. K .EQ. KS) THEN + ! IF(K .LT. KS) THEN + ! IF(IREF(K) .LT. 0 .AND. IREF(K+1) .GT. 0) THEN + ! ITYPB=ICTYP+1 + ! ICTYP=ICTYP+1 + ! ELSE + ! ITYPB=ITYPIN + ! ENDIF + ! ELSE + ! ITYPB=ITYPIN + ! ENDIF + IF(MOD(K,2) .EQ. 0) THEN + ITYPB=ITYPIN + ELSE + ITYPB=ICTYP + ICTYP=ICTYP+1 + ENDIF + IF(ITYPB .GT. 39) THEN + ICTT=(ITYPB-39)*2 + ICTT=ITYPBC(ICTT) + ELSE + ICTT=0 + ENDIF + JEND=K + XLENGTHP=XLENGTH +! GO AND FORM A LINE + CALL FORMLINEL(I1D,I2D,ALXX,ALYY,ALWD,JST,JEND,JKP,XLENGTHP,ITYPB,ICTT) + JST=JEND + ENDIF + ENDDO + ENDIF + + IF(I2D .EQ. 1) CALL FORM999(1,1,NELC) + + +! GO TO 4 +! + END + SUBROUTINE INTERP(GRIDX,GRIDY,NL,NH,INT,ALX,ALY,ATX,ATY,NINT,ISWT) +! +! Routine to fill GRIDX and GRIDY by interpolation +! NL = START OF GENERATED +! NH = END OF GENERATED +! INT = INTERVAL +! ALX, ALY = START LOC +! ATX, ATY = END LOC +! NINT = NUMBER OF POINTS +! ISWT = 0 BASELINE = 1 APPLY CHANGES +!IPK MAY02 + REAL*8 GRIDX(NH),GRIDY(NH),ALX,ALY,ATX,ATY +! +! Compute intervals +! + XINT=(ATX-ALX)/FLOAT(NINT) + YINT=(ATY-ALY)/FLOAT(NINT) +! +! Generate points +! + IF(ISWT .EQ. 0) THEN + KP=0 + DO 200 K=NL,NH,INT + IF(KP .EQ. 0) THEN + GRIDX(K)=ALX + GRIDY(K)=ALY + ELSE + GRIDX(K)=GRIDX(KP)+XINT + GRIDY(K)=GRIDY(KP)+YINT + ENDIF + KP=K + 200 CONTINUE + ELSE + XAD=ALX + YAD=ALY + KP=0 + DO 220 K=NL,NH,INT + IF(KP .EQ. 0) THEN + GRIDX(K)=GRIDX(K)+XAD + GRIDY(K)=GRIDY(K)+YAD + ELSE + XAD=XAD+XINT + YAD=YAD+YINT + GRIDX(K)=GRIDX(K)+XAD + GRIDY(K)=GRIDY(K)+YAD + ENDIF + KP=K + 220 CONTINUE + ENDIF + RETURN + END + SUBROUTINE GEL +! +! Routine to create a block of elements +! + + USE WINTERACTER + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + include 'd.inc' + + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + REAL*8 GRIDX,GRIDY,ALX,ALY,BLX,BLY,ARX,ARY,BRX,BRY,GRIDXL,GRIDYL + INTEGER*2 IGSKP + COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& + ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) +! + CHARACTER*1 IFLAG + data itime/0/ + + if(itime .eq. 0) then + nx=0 + ny=0 + itime=1 + endif + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to use'//& + CHAR(13)//'existing nodes?' ,& + 'ELEMENT CREATION OPTION') +! +! If answer 'No', point to location +! + IF (WInfoDialog(4) .EQ. 2) then + noptcr=0 + GO TO 4 + else + noptcr=1 + go to 1100 + END IF + + 4 CONTINUE + NHTP=0 + NMESS=8 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ALX=XTEMP + ALY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + CALL WRTOUT(0) + RETURN + elseif(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + ENDIF +! +! Exit input +! + 9 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + siz=0.1 + call drawcr(xtemp,ytemp,siz) + NBRR=0 + CALL HEDR + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ARX=XTEMP + ARY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! +12 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + call drawcr(xtemp,ytemp,siz) + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + BRX=XTEMP + BRY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + 16 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + call drawcr(xtemp,ytemp,siz) + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + BLX=XTEMP + BLY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + 20 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + call drawcr(xtemp,ytemp,siz) + go to 25 + +1100 continue + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE1,IFLAG,INSKP,IBOX) + ALX=CORD(INODE1,1) + ALY=CORD(INODE1,2) + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE2,IFLAG,INSKP,IBOX) + ARX=CORD(INODE2,1) + ARY=CORD(INODE2,2) + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE3,IFLAG,INSKP,IBOX) + BRX=CORD(INODE3,1) + BRY=CORD(INODE3,2) + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE4,IFLAG,INSKP,IBOX) + BLX=CORD(INODE4,1) + BLY=CORD(INODE4,2) + +! +! Define number of elements along x and y sides +! + 25 CONTINUE + NMESS=45 + CALL HEDR + NMESS = 9 + call getint(nx) +! READ(*,*) NX + NMESS=45 + CALL HEDR + NMESS = 10 + call getint(ny) +! READ(*,*) NY + NXP=NX+1 + NYP=NY+1 + NRL=NX*NYP+1 + NRT=NXP*NYP + +! ipk jul01 test for limit exceeded + if(nrt .gt. maxpgen) then + call panelegn + go to 25 + endif + + DO N=1,NE + DO M=1,8 + NOPSV(N,M)=NOP(N,M) + ENDDO + IMATSV(N)=IMAT(N) + ENDDO + NESAV=NE + NEFSAV=NENTRY + NPUNDO=NRT +! +! Initialize GRIDX and GRIDY +! + DO 100 N=1,NRT + GRIDX(N)=0. + GRIDY(N)=0. + IGSKP(N)=0 + 100 END DO +! +! Interpolate left and right side +! + CALL INTERP(GRIDX,GRIDY,1,NYP,1,ALX,ALY,BLX,BLY,NY,0) + CALL INTERP(GRIDX,GRIDY,NRL,NRT,1,ARX,ARY,BRX,BRY,NY,0) +! +! plot points +! + DO 200 N=1,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + siz=0.1 + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 200 END DO + DO 220 N=NRL,NRT +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 220 END DO +! +! Interpolate bottom and top sides +! + CALL INTERP(GRIDX,GRIDY,1,NRL,NYP,ALX,ALY,ARX,ARY,NX,0) + CALL INTERP(GRIDX,GRIDY,NYP,NRT,NYP,BLX,BLY,BRX,BRY,NX,0) +! +! plot points +! + DO 240 N=1,NRL,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 240 END DO + DO 260 N=NYP,NRT,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 260 END DO +! +! Interpolate interior points +! + DO 300 M=2,NYP + NFS=NRL+M-1 + CALL INTERP(GRIDX,GRIDY,M,NFS,NYP,GRIDX(M),GRIDY(M),GRIDX(NFS) & + & ,GRIDY(NFS),NX,0) + DO N=M,NFS + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL RRed + call drawcr(xtemp,ytemp,siz) + CALL RBlue + ENDDO + 300 END DO + 305 CONTINUE + NMESS=11 + NBRR=10 + CALL HEDR +310 IBOX=1 + ip=0 + CALL PROX(GRIDX(1),GRIDY(1),NRT,XX,YY,IP,IFLAG,IGSKP,IBOX) + IF(IBOX .NE. 6 .and. (ip .gt. 0 .and. ip .le. nrt)) THEN + XKP=GRIDX(IP) + YKP=GRIDY(IP) + IPK=IP + ENDIF + IF(IRMAIN .EQ. 1 .OR. IBOX .EQ. 7) RETURN + IF(IFLAG .EQ. 'q') THEN + GO TO 400 + ENDIF + DO N=1,NRT + GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL + GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL + ENDDO + IF(IBOX .EQ. 6) THEN + XX=XKP + YY=YKP + IP=IPK + GO TO 315 + ENDIF + write(90,*) 'back prox irdisp',IRDISP + IF(IRDISP .EQ. 1) THEN + CALL PLTPT + ENDIF +! +! Get screen coordinate of new node location +! + CALL XYLOC(XX,YY,IFLAG,IBOX) + write(90,*) 'back xyloc irdisp',IRDISP + IF(IRMAIN .EQ. 1 .OR. IBOX .EQ. 7) RETURN + 315 IF(IRDISP .EQ. 1) THEN + DO N=1,NRT + GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL + GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL + ENDDO + CALL PLTPT + ENDIF +! +! Establish difference from movement +! + ALX=XX-GRIDX(IP) + ALY=YY-GRIDY(IP) + CALL PLOTT(XX,YY,3) + CALL PLOTT(XX,YY,2) + FPN = IP +! CALL RRed +! CALL NUMBR(XX,YY,0.20,FPN,0.0,-1) +! CALL RBlue +! +! Find location on boundary +! + IF(IP .LE. NYP) THEN +! Left boundary + NLW=IP + NUP=NRL+IP-1 + NSTP=NYP + BLX=0. + BLY=0. + NS=NX + ELSEIF(IP .GE. NRL) THEN +! Right boundary + NLW=IP-NX*NYP + NUP=IP + NSTP=NYP + BLX=ALX + BLY=ALY + ALX=0. + ALY=0. + NS=NX + ELSE + LINENO=(IP-1)/NYP + IF(IP-LINENO*NYP .EQ. 1) THEN +! Lower boundary + NLW=IP + NUP=IP+NY + NSTP=1 + BLX=0. + BLY=0. + NS=NY + ELSEIF(IP-LINENO*NYP .EQ. NYP) THEN +! Upper boundary + NLW=IP-NY + NUP=IP + NSTP=1 + BLX=ALX + BLY=ALY + ALX=0. + ALY=0. + NS=NY + ELSE + GO TO 305 + ENDIF + ENDIF +! +! Interpolate change along x line +! 14935011 + IF(IRGB .EQ. 14935011) THEN + call rgrey + ELSE + CALL RWHITEB + ENDIF + do n=1,nrt + XTEMP=gridx(n) + YTEMP=gridy(n) + call drawcr(xtemp,ytemp,siz) + enddo + CALL RRed + CALL INTERP(GRIDX,GRIDY,NLW,NUP,NSTP,ALX,ALY,BLX,BLY,NS,1) + do n=1,nrt + XTEMP=gridx(n) + YTEMP=gridy(n) + call drawcr(xtemp,ytemp,siz) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + enddo + call Rblue + GO TO 310 +! +! Copy points into cord array +! + 400 CONTINUE + DO 500 N=1,NRT +! +! Find next blank node in CORD +! + IF(NOPTCR .EQ. 1) THEN + IF(N .EQ. 1) THEN + NODDEL(N)=0 + GO TO 500 + ELSEIF(N .EQ. NYP) THEN + NODDEL(N)=0 + GO TO 500 + ELSEIF(N .EQ. 1+NYP*NX) THEN + NODDEL(N)=0 + GO TO 500 + ELSEIF(N .EQ. NRT) THEN + NODDEL(N)=0 + GO TO 500 + ENDIF + ENDIF + CALL GETNOD(J) + NODDEL(N)=J +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = GRIDX(N) + CORD(J,2) = GRIDY(N) + IGRIDE(N) = J + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = GRIDX(N)*TXSCAL - XS + YUSR(J) = GRIDY(N)*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) +! + 500 END DO +! +! Generate elements +! + CALL GETELM(K) + IECHG=0 +! + DO 600 I=1,NX + DO 590 J=1,NY + CALL GETELM(K) + IF(I .EQ. 1 .AND. J .EQ. 1 .AND. NOPTCR .EQ. 1) THEN + NOP(K,1)=INODE1 + ELSE + NOP(K,1)=IGRIDE((I-1)*NYP+J) + ENDIF + NOP(K,2)=0 + IF(I .EQ. NX .AND. J .EQ. 1 .AND. NOPTCR .EQ. 1) THEN + NOP(K,3)=INODE2 + ELSE + NOP(K,3)=IGRIDE(I*NYP+J) + ENDIF + NOP(K,4)=0 + IF(I .EQ. NX .AND. J .EQ. NY .AND. NOPTCR .EQ. 1) THEN + NOP(K,5)=INODE3 + ELSE + NOP(K,5)=IGRIDE(I*NYP+J+1) + ENDIF + NOP(K,6)=0 + IF(I .EQ. 1 .AND. J .EQ. NY .AND. NOPTCR .EQ. 1) THEN + NOP(K,7)=INODE4 + ELSE + NOP(K,7)=IGRIDE((I-1)*NYP+J+1) + ENDIF + NOP(K,8)=0 + IMAT(K)=1 +! IF(K .GT. NE) NE=K + NCORN(K)=8 + IESKP(K)=0 +!IPK JAN98 + IERC=0 + CALL PLTELM(K,IERC) + 590 CONTINUE + 600 END DO +! CALL UNDO(IYES) +! IF(IYES .EQ. 1) THEN +! DO N=1,NEUNDO +! J=IELDEL(N) +! CALL DELTEL(J) +! ENDDO +! DO N=1,NPUNDO +! J=NODDEL(N) +! CALL DELETN(J) +! ENDDO +! ENDIF + CALL WRTOUT(0) + RETURN + END + + SUBROUTINE PLTPT + + USE BLK1MOD + INCLUDE 'TXFRM.COM' +! INCLUDE 'BLK1.COM' + +!IPK MAY02 + REAL*8 GRIDX,GRIDY,GRIDXL,GRIDYL + INTEGER*2 IGSKP + + COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& + ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) + + DO N=1,NRT + GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL + GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL + ENDDO + +! +! plot points +! + DO N=1,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + siz=0.1 + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO + DO N=NRL,NRT +!IP MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO +! +! plot points +! + DO N=1,NRL,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO + DO N=NYP,NRT,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO + RETURN + END + + subroutine panelegn + + USE WINTERACTER + + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'You have requested '//& + ' more than the allowable number of nodes.'//CHAR(13)//'The model will return '// & + 'to allow new numbers to be input','Limit error') +! +! If answer 'Yes', execute +! + IF (WInfoDialog(4) .EQ. 1) then + return + ENDIF + return + end + SUBROUTINE FORMLINEMENU(ITYP,I1D,I2D,IFIN,XLENGTH,ITYPIN,NELC) + + + use winteracter + + implicit none + SAVE + + include 'D.inc' + INCLUDE 'BFILES.I90' + DATA ITIME/0/ + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: ITYP,I1D,IERR,ITIME,I2D,IFIN,ITYPIN,NELC + real :: XLENGTH + character*3 :: sub + DATA ITIME/0/ + IF(ITIME .EQ. 0) THEN + XLENGTH=100. + ITIME=1 + I1D=0 + I2D=1 + IFIN=1 + ITYPIN=1 + NELC=2 + ENDIF + + + + call wdialogload(IDD_FORMLINE) + ierr=infoerror(1) + + call wdialogputRadioButton(idf_radio1) + call wdialogputRadioButton(idf_radio3) + CALL WDialogPutREAL(idf_REAL1,XLENGTH) + CALL WDialogPutInteger(idf_INTEGER1,ITYPIN) + call wdialogPutCheckBox(idf_check3,IFIN) + CALL WDialogPutInteger(idf_INTEGER2,NELC) + + + CALL WDialogSelect(IDD_FORMLINE) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + call wdialogGetRadioButton(idf_radio1,ITYP) + call wdialogGetRadioButton(idf_radio3,I1D) + call wdialogGetCheckBox(idf_check3,IFIN) + CALL WDialogGetREAL(idf_REAL1,XLENGTH) + CALL WDialogGetInteger(idf_INTEGER1,ITYPIN) + CALL WDialogGetInteger(idf_INTEGER2,NELC) + if(I1D .eq. 1) then + I1D=0 + I2D=0 + ELSEIF(I1D .EQ. 2) THEN + I1D=1 + I2D=0 + ELSEIF(I1D .EQ. 3) THEN + I1D=0 + I2D=1 + ENDIF + RETURN + ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + I1D=-999 + RETURN + ENDIF + ENDDO + RETURN + END + + SUBROUTINE FILEDAT(ALXX,ALYY,ALWD,NPTS,BLXX,BLYY,BLWD,NPTSB,ITYPBC) + USE WINTERACTER + USE DFLIB +! +! +! Define some parameters to match those in the resource file +! + include 'd.inc' + REAL*8 ALXX(*),ALYY(*),ALWD(*),BLXX(*),BLYY(*),BLWD(*) + INTEGER ITYPBC(*) + REAL*8 ATMPAR + CHARACTER(LEN=255) :: FNAME,FILTER + CHARACTER(LEN=3) :: SUB + CHARACTER ID*8,DLIN*72 + IINALN=45 + Filter='ALIGNMENT file -- *.dat|' + + CALL WSelectFile(Filter,PromptOn,FNAME,'Open Alignment File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(IINALN,FILE=FNAME,STATUS='OLD',action='read') + ELSE + RETURN + ENDIF + DO K=1,1000 + CALL GINPT(IINALN,ID,DLIN) + IF(ID(1:3) .EQ. 'XYW') THEN + READ(DLIN,*) ALXX(K),ALYY(K),ALWD(K) + ELSEIF(ID(1:3) .EQ. 'XY ') THEN + READ(DLIN,*) ALXX(K),ALYY(K) + ALWD(K)=0. + ELSE + NPTS=K-1 + BACKSPACE(IINALN) + GOTO 200 + ENDIF + ENDDO +200 CONTINUE + READ(IINALN,'(A8)') ID + IF(ID(1:7) .EQ. 'ENDFILE') RETURN + + CALL GETBRIDCUL(IINALN,ALXX,ALYY,BLXX,BLYY,BLWD,NPTSB,ITYPBC) + K=(NPTSB-2)/2+2 + ALXX(K)=ALXX(2) + ALYY(K)=ALYY(2) + NPTS=K + DO K=2,NPTSB-2,2 + ALXX(K+1)=(BLXX(K)+BLXX(K+1))/2. + ALYY(K+1)=(BLYY(K)+BLYY(K+1))/2. + ALWD(K+1)=(BLWD(K)+BLWD(K+1))/2. + ENDDO + +! DO K=1,1000 +! ATMPAR=BLXX(K) +! BLXX(K)=ALXX(K) +! ALXX(K)=ATMPAR +! ATMPAR=BLYY(K) +! BLYY(K)=ALYY(K) +! ALYY(K)=ATMPAR +! ENDDO +! NTEMP=NPTSB +! NPTSB=NPTS +! NPTS=NTEMP + RETURN + END + SUBROUTINE GETBRIDCUL(IINALN,ALXX,ALYY,BLXX,BLYY,BLWD,NPTSB,ITYPBC) + CHARACTER(LEN=140) :: DLINLARGE + CHARACTER(LEN=8) :: ID + REAL*8 TEMP(8) + REAL*8 ALXX(*),ALYY(*),BLXX(*),BLYY(*),BLWD(*) + INTEGER ITYPBC(*) + PI=3.14159 + KK=1 + DO K=1,1000 + CALL GINPT1(IINALN,DLINLARGE) + IF(DLINLARGE(1:7) .EQ. 'CULVERT') THEN + READ(DLINLARGE(8:140),*) IDN,(TEMP(J),J=1,8) + ITYPBC(KK)=1 + ITYPBC(KK+1)=1 + XCEN=(TEMP(2)+TEMP(4))/2. + YCEN=(TEMP(3)+TEMP(5))/2. + CW=TEMP(7)*TEMP(8)/2. + IF(KK .EQ. 1) THEN + DNORM=ATAN2(TEMP(3)-ALYY(1),TEMP(2)-ALXX(1)) + ELSE + DNORM=ATAN2(TEMP(3)-BLYY(KK-1),TEMP(2)-BLXX(KK-1)) + ENDIF + WRITE(155,*) KK,DNORM + IF(DNORM .LT. 0.) DNORM=DNORM+PI + IF(DNORM .GT. PI) DNORM=DNORM-PI + WRITE(155,*) KK,DNORM + BLXX(KK)=XCEN-CW*COS(DNORM) + BLYY(KK)=YCEN-CW*SIN(DNORM) + BLWD(KK)=TEMP(6) + KK=KK+1 + BLXX(KK)=XCEN+CW*COS(DNORM) + BLYY(KK)=YCEN+CW*SIN(DNORM) + BLWD(KK)=TEMP(6) + KK=KK+1 + ELSEIF(DLINLARGE(1:6) .EQ. 'BRIDGE') THEN + READ(DLINLARGE(7:140),*) IDN,(TEMP(J),J=1,7) + ITYPBC(KK)=2 + ITYPBC(KK+1)=2 + BLXX(KK)=TEMP(2) + BLYY(KK)=TEMP(3) + BLWD(KK)=TEMP(4) + KK=KK+1 + BLXX(KK)=TEMP(5) + BLYY(KK)=TEMP(6) + BLWD(KK)=TEMP(7) + KK=KK+1 + READ(DLINLARGE(8:140),*) ID,(TEMP(J),J=1,6) + ELSEIF(DLINLARGE(1:7) .EQ. 'ENDFILE') THEN + NPTSB=KK-1 + GO TO 200 + ENDIF + ENDDO +200 CONTINUE + DO K=1,NPTSB + WRITE(156,*) K,BLXX(K),BLYY(K),BLWD(K) + ENDDO + RETURN + END + + + \ No newline at end of file diff --git a/src/EGEN - Copy.F90 b/src/EGEN - Copy.F90 new file mode 100644 index 0000000..d17288f --- /dev/null +++ b/src/EGEN - Copy.F90 @@ -0,0 +1,1014 @@ + +! Last change: IPK 12 Jan 98 1:44 pm +! + SUBROUTINE GNODE +! +! Routine to create a series of nodes along a line +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + REAL*8 GRIDX(150),GRIDY(150),ALX,ALY,ATX,ATY,ALXX(1000),ALYY(1000),ALWD(1000) + REAL*8 BLXX(1000),BLYY(1000),BLWD(1000) + INTEGER ITYPBC(1000) +! + CHARACTER*1 IFLAG + data itime/0/ + + if(itime .eq. 0) then + nh=1 + itime=1 + endif +4 CONTINUE + CALL FORMLINEMENU(ITYP,I1D,I2D,IFIN,XLENGTH) + IF(I1D .EQ. -999) RETURN + IF(ITYP .EQ. 1) THEN + NHTP = 0 + NMESS = 6 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ALX=XTEMP + ALY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + CALL WRTOUT(0) + RETURN + ENDIF +! +! Exit input +! + 9 CONTINUE + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + CALL HEDR +! + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ATX=XTEMP + ATY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) +! +! Define number of nodes in a line +! + NBRR = 0 + NMESS=45 + CALL HEDR + NMESS = 7 + call getint(nh) +! READ(*,*) NH + NINT=NH-1 +! +! zero GRIDX and GRIDY to hold generated coordinates +! + DO N=1,NH + GRIDX(N)=0. + GRIDY(N)=0. + END DO +! +! Interpolate points onto line +! + CALL INTERP(GRIDX,GRIDY,1,NH,1,ALX,ALY,ATX,ATY,NINT,0) +! +! Copy points into the coordinate array +! + DO N=1,NH +! +! Find next blank node in CORD +! + CALL GETNOD(J) +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = GRIDX(N) + CORD(J,2) = GRIDY(N) + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = GRIDX(N)*TXSCAL - XS + YUSR(J) = GRIDY(N)*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) +! + END DO + ELSE + IF(IFIN .EQ. 0) THEN + NHTP = 0 + NMESS = 6 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + DO J=1,1000 + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + IF(IFLAG .EQ. 'q' .or. ibox .eq. 10) go to 300 + ALXX(J)=XTEMP + ALYY(J)=YTEMP + JPTS=J + ENDDO +300 CONTINUE + ELSE + CALL FILEDAT(ALXX,ALYY,ALWD,JPTS,BLXX,BLYY,BLWD,NPTSB,ITYPBC) + DO J=1,JPTS + ALXX(J)=(ALXX(J)+XS)/TXSCAL + ALYY(J)=(ALYY(J)+YS)/TXSCAL + ENDDO + ENDIF +! COMPUTE OVERALL LENGTH + + TOTLEN=0. + DO J=1,JPTS-1 + TOTLEN=TOTLEN+SQRT((ALXX(J+1)-ALXX(J))**2+(ALYY(J+1)-ALYY(J))**2) + ENDDO +! ESTIMATE NUMBER OF ELEMENTS + NELTS=TOTLEN*TXSCAL/XLENGTH+1 + XLENGTH=TOTLEN*TXSCAL/NELTS +! GET NEW NODE LOCATIONS AND CREAT ELEMENT + CALL GETNOD(J) + JKP=J +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = ALXX(1) + CORD(J,2) = ALYY(1) + IF(ALWD(1).GT. 0.) THEN + WIDTH(J)=ALWD(1) + ENDIF + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = ALXX(1)*TXSCAL - XS + YUSR(J) = ALYY(1)*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) + JPTC=2 + XLENGTHR=XLENGTH/TXSCAL + XCUR=ALXX(1) + YCUR=ALYY(1) + DO N=1,NELTS + 500 ANGLEL=ATAN2(ALYY(JPTC)-ALYY(JPTC-1),ALXX(JPTC)-ALXX(JPTC-1)) + XNEXT=XCUR+XLENGTHR*COS(ANGLEL) + YNEXT=YCUR+XLENGTHR*SIN(ANGLEL) + IF(ALXX(JPTC)-ALXX(JPTC-1) .NE. 0.) THEN + FRAC=(XNEXT-ALXX(JPTC-1))/(ALXX(JPTC)-ALXX(JPTC-1)) + ELSE + FRAC=(YNEXT-ALYY(JPTC-1))/(ALYY(JPTC)-ALYY(JPTC-1)) + ENDIF + IF(FRAC .GT. 1. .AND. JPTC .LT. JPTS) THEN + XLENGTHR=XLENGTHR-SQRT((ALXX(JPTC)-XCUR)**2+(ALYY(JPTC)-YCUR)**2) + XCUR=ALXX(JPTC) + YCUR=ALYY(JPTC) + JPTC=JPTC+1 + GO TO 500 + ENDIF +! GET NEW LOCATION + + CALL GETNOD(J) + + IF(ALWD(1).GT. 0.) THEN + WIDTH(J)=ALWD(JPTC-1)+FRAC*(ALWD(JPTC)-ALWD(JPTC-1)) + ENDIF +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = XNEXT + CORD(J,2) = YNEXT + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = XNEXT*TXSCAL - XS + YUSR(J) = YNEXT*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) + XCUR=XNEXT + YCUR=YNEXT + XLENGTHR=XLENGTH/TXSCAL + + IF(I1D .EQ. 1 .OR. I2D .EQ. 1) THEN + IF(N .EQ. 1) THEN + J1=JKP + IF(ALWD(1) .NE. 0.) GO TO 600 + call nodedisp(jKP) + ENDIF + IF(ALWD(1) .NE. 0.) GO TO 600 + WIDTH(J)=WIDTH(J1) + WD(J)=WD(J1) + SS1(J)=SS1(J1) + SS2(J)=SS2(J1) + WIDS(J)=WIDS(J1) + WIDBS(J)=WIDBS(J1) + SSO(J)=SSO(J1) + BS1(J)=BS1(J1) +600 call getelm(k) + NOP(K,1)=J1 + NOP(K,2)=0 + NOP(K,3)=J + NCORN(K)=3 + IMAT(K)=1 + IESKP(K) = 0 + NE = MAX(K,NE) + IERC=0 + CALL PLTELM(K,IERC) + J1=J + ENDIF + + ENDDO + ENDIF + + IF(I2D .EQ. 1) CALL FORM999(1,1) + + +! GO TO 4 +! + END + SUBROUTINE INTERP(GRIDX,GRIDY,NL,NH,INT,ALX,ALY,ATX,ATY,NINT,ISWT) +! +! Routine to fill GRIDX and GRIDY by interpolation +! NL = START OF GENERATED +! NH = END OF GENERATED +! INT = INTERVAL +! ALX, ALY = START LOC +! ATX, ATY = END LOC +! NINT = NUMBER OF POINTS +! ISWT = 0 BASELINE = 1 APPLY CHANGES +!IPK MAY02 + REAL*8 GRIDX(NH),GRIDY(NH),ALX,ALY,ATX,ATY +! +! Compute intervals +! + XINT=(ATX-ALX)/FLOAT(NINT) + YINT=(ATY-ALY)/FLOAT(NINT) +! +! Generate points +! + IF(ISWT .EQ. 0) THEN + KP=0 + DO 200 K=NL,NH,INT + IF(KP .EQ. 0) THEN + GRIDX(K)=ALX + GRIDY(K)=ALY + ELSE + GRIDX(K)=GRIDX(KP)+XINT + GRIDY(K)=GRIDY(KP)+YINT + ENDIF + KP=K + 200 CONTINUE + ELSE + XAD=ALX + YAD=ALY + KP=0 + DO 220 K=NL,NH,INT + IF(KP .EQ. 0) THEN + GRIDX(K)=GRIDX(K)+XAD + GRIDY(K)=GRIDY(K)+YAD + ELSE + XAD=XAD+XINT + YAD=YAD+YINT + GRIDX(K)=GRIDX(K)+XAD + GRIDY(K)=GRIDY(K)+YAD + ENDIF + KP=K + 220 CONTINUE + ENDIF + RETURN + END + SUBROUTINE GEL +! +! Routine to create a block of elements +! + + USE WINTERACTER + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + include 'd.inc' + + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + REAL*8 GRIDX,GRIDY,ALX,ALY,BLX,BLY,ARX,ARY,BRX,BRY,GRIDXL,GRIDYL + INTEGER*2 IGSKP + COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& + ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) +! + CHARACTER*1 IFLAG + data itime/0/ + + if(itime .eq. 0) then + nx=0 + ny=0 + itime=1 + endif + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to use'//& + CHAR(13)//'existing nodes?' ,& + 'ELEMENT CREATION OPTION') +! +! If answer 'No', point to location +! + IF (WInfoDialog(4) .EQ. 2) then + noptcr=0 + GO TO 4 + else + noptcr=1 + go to 1100 + END IF + + 4 CONTINUE + NHTP=0 + NMESS=8 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ALX=XTEMP + ALY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + CALL WRTOUT(0) + RETURN + elseif(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + ENDIF +! +! Exit input +! + 9 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + siz=0.1 + call drawcr(xtemp,ytemp,siz) + NBRR=0 + CALL HEDR + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ARX=XTEMP + ARY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! +12 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + call drawcr(xtemp,ytemp,siz) + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + BRX=XTEMP + BRY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + 16 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + call drawcr(xtemp,ytemp,siz) + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + BLX=XTEMP + BLY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + 20 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + call drawcr(xtemp,ytemp,siz) + go to 25 + +1100 continue + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE1,IFLAG,INSKP,IBOX) + ALX=CORD(INODE1,1) + ALY=CORD(INODE1,2) + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE2,IFLAG,INSKP,IBOX) + ARX=CORD(INODE2,1) + ARY=CORD(INODE2,2) + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE3,IFLAG,INSKP,IBOX) + BRX=CORD(INODE3,1) + BRY=CORD(INODE3,2) + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE4,IFLAG,INSKP,IBOX) + BLX=CORD(INODE4,1) + BLY=CORD(INODE4,2) + +! +! Define number of elements along x and y sides +! + 25 CONTINUE + NMESS=45 + CALL HEDR + NMESS = 9 + call getint(nx) +! READ(*,*) NX + NMESS=45 + CALL HEDR + NMESS = 10 + call getint(ny) +! READ(*,*) NY + NXP=NX+1 + NYP=NY+1 + NRL=NX*NYP+1 + NRT=NXP*NYP + +! ipk jul01 test for limit exceeded + if(nrt .gt. maxpgen) then + call panelegn + go to 25 + endif + + DO N=1,NE + DO M=1,8 + NOPSV(N,M)=NOP(N,M) + ENDDO + IMATSV(N)=IMAT(N) + ENDDO + NESAV=NE + NEFSAV=NENTRY + NPUNDO=NRT +! +! Initialize GRIDX and GRIDY +! + DO 100 N=1,NRT + GRIDX(N)=0. + GRIDY(N)=0. + IGSKP(N)=0 + 100 END DO +! +! Interpolate left and right side +! + CALL INTERP(GRIDX,GRIDY,1,NYP,1,ALX,ALY,BLX,BLY,NY,0) + CALL INTERP(GRIDX,GRIDY,NRL,NRT,1,ARX,ARY,BRX,BRY,NY,0) +! +! plot points +! + DO 200 N=1,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + siz=0.1 + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 200 END DO + DO 220 N=NRL,NRT +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 220 END DO +! +! Interpolate bottom and top sides +! + CALL INTERP(GRIDX,GRIDY,1,NRL,NYP,ALX,ALY,ARX,ARY,NX,0) + CALL INTERP(GRIDX,GRIDY,NYP,NRT,NYP,BLX,BLY,BRX,BRY,NX,0) +! +! plot points +! + DO 240 N=1,NRL,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 240 END DO + DO 260 N=NYP,NRT,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 260 END DO +! +! Interpolate interior points +! + DO 300 M=2,NYP + NFS=NRL+M-1 + CALL INTERP(GRIDX,GRIDY,M,NFS,NYP,GRIDX(M),GRIDY(M),GRIDX(NFS) & + & ,GRIDY(NFS),NX,0) + DO N=M,NFS + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL RRed + call drawcr(xtemp,ytemp,siz) + CALL RBlue + ENDDO + 300 END DO + 305 CONTINUE + NMESS=11 + NBRR=10 + CALL HEDR +310 IBOX=1 + ip=0 + CALL PROX(GRIDX(1),GRIDY(1),NRT,XX,YY,IP,IFLAG,IGSKP,IBOX) + IF(IBOX .NE. 6 .and. (ip .gt. 0 .and. ip .le. nrt)) THEN + XKP=GRIDX(IP) + YKP=GRIDY(IP) + IPK=IP + ENDIF + IF(IRMAIN .EQ. 1 .OR. IBOX .EQ. 7) RETURN + IF(IFLAG .EQ. 'q') THEN + GO TO 400 + ENDIF + DO N=1,NRT + GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL + GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL + ENDDO + IF(IBOX .EQ. 6) THEN + XX=XKP + YY=YKP + IP=IPK + GO TO 315 + ENDIF + write(90,*) 'back prox irdisp',IRDISP + IF(IRDISP .EQ. 1) THEN + CALL PLTPT + ENDIF +! +! Get screen coordinate of new node location +! + CALL XYLOC(XX,YY,IFLAG,IBOX) + write(90,*) 'back xyloc irdisp',IRDISP + IF(IRMAIN .EQ. 1 .OR. IBOX .EQ. 7) RETURN + 315 IF(IRDISP .EQ. 1) THEN + DO N=1,NRT + GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL + GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL + ENDDO + CALL PLTPT + ENDIF +! +! Establish difference from movement +! + ALX=XX-GRIDX(IP) + ALY=YY-GRIDY(IP) + CALL PLOTT(XX,YY,3) + CALL PLOTT(XX,YY,2) + FPN = IP +! CALL RRed +! CALL NUMBR(XX,YY,0.20,FPN,0.0,-1) +! CALL RBlue +! +! Find location on boundary +! + IF(IP .LE. NYP) THEN +! Left boundary + NLW=IP + NUP=NRL+IP-1 + NSTP=NYP + BLX=0. + BLY=0. + NS=NX + ELSEIF(IP .GE. NRL) THEN +! Right boundary + NLW=IP-NX*NYP + NUP=IP + NSTP=NYP + BLX=ALX + BLY=ALY + ALX=0. + ALY=0. + NS=NX + ELSE + LINENO=(IP-1)/NYP + IF(IP-LINENO*NYP .EQ. 1) THEN +! Lower boundary + NLW=IP + NUP=IP+NY + NSTP=1 + BLX=0. + BLY=0. + NS=NY + ELSEIF(IP-LINENO*NYP .EQ. NYP) THEN +! Upper boundary + NLW=IP-NY + NUP=IP + NSTP=1 + BLX=ALX + BLY=ALY + ALX=0. + ALY=0. + NS=NY + ELSE + GO TO 305 + ENDIF + ENDIF +! +! Interpolate change along x line +! 14935011 + IF(IRGB .EQ. 14935011) THEN + call rgrey + ELSE + CALL RWHITEB + ENDIF + do n=1,nrt + XTEMP=gridx(n) + YTEMP=gridy(n) + call drawcr(xtemp,ytemp,siz) + enddo + CALL RRed + CALL INTERP(GRIDX,GRIDY,NLW,NUP,NSTP,ALX,ALY,BLX,BLY,NS,1) + do n=1,nrt + XTEMP=gridx(n) + YTEMP=gridy(n) + call drawcr(xtemp,ytemp,siz) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + enddo + call Rblue + GO TO 310 +! +! Copy points into cord array +! + 400 CONTINUE + DO 500 N=1,NRT +! +! Find next blank node in CORD +! + IF(NOPTCR .EQ. 1) THEN + IF(N .EQ. 1) THEN + NODDEL(N)=0 + GO TO 500 + ELSEIF(N .EQ. NYP) THEN + NODDEL(N)=0 + GO TO 500 + ELSEIF(N .EQ. 1+NYP*NX) THEN + NODDEL(N)=0 + GO TO 500 + ELSEIF(N .EQ. NRT) THEN + NODDEL(N)=0 + GO TO 500 + ENDIF + ENDIF + CALL GETNOD(J) + NODDEL(N)=J +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = GRIDX(N) + CORD(J,2) = GRIDY(N) + IGRIDE(N) = J + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = GRIDX(N)*TXSCAL - XS + YUSR(J) = GRIDY(N)*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) +! + 500 END DO +! +! Generate elements +! + CALL GETELM(K) + IECHG=0 +! + DO 600 I=1,NX + DO 590 J=1,NY + CALL GETELM(K) + IF(I .EQ. 1 .AND. J .EQ. 1 .AND. NOPTCR .EQ. 1) THEN + NOP(K,1)=INODE1 + ELSE + NOP(K,1)=IGRIDE((I-1)*NYP+J) + ENDIF + NOP(K,2)=0 + IF(I .EQ. NX .AND. J .EQ. 1 .AND. NOPTCR .EQ. 1) THEN + NOP(K,3)=INODE2 + ELSE + NOP(K,3)=IGRIDE(I*NYP+J) + ENDIF + NOP(K,4)=0 + IF(I .EQ. NX .AND. J .EQ. NY .AND. NOPTCR .EQ. 1) THEN + NOP(K,5)=INODE3 + ELSE + NOP(K,5)=IGRIDE(I*NYP+J+1) + ENDIF + NOP(K,6)=0 + IF(I .EQ. 1 .AND. J .EQ. NY .AND. NOPTCR .EQ. 1) THEN + NOP(K,7)=INODE4 + ELSE + NOP(K,7)=IGRIDE((I-1)*NYP+J+1) + ENDIF + NOP(K,8)=0 + IMAT(K)=1 +! IF(K .GT. NE) NE=K + NCORN(K)=8 + IESKP(K)=0 +!IPK JAN98 + IERC=0 + CALL PLTELM(K,IERC) + 590 CONTINUE + 600 END DO +! CALL UNDO(IYES) +! IF(IYES .EQ. 1) THEN +! DO N=1,NEUNDO +! J=IELDEL(N) +! CALL DELTEL(J) +! ENDDO +! DO N=1,NPUNDO +! J=NODDEL(N) +! CALL DELETN(J) +! ENDDO +! ENDIF + CALL WRTOUT(0) + RETURN + END + + SUBROUTINE PLTPT + + USE BLK1MOD + INCLUDE 'TXFRM.COM' +! INCLUDE 'BLK1.COM' + +!IPK MAY02 + REAL*8 GRIDX,GRIDY,GRIDXL,GRIDYL + INTEGER*2 IGSKP + + COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& + ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) + + DO N=1,NRT + GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL + GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL + ENDDO + +! +! plot points +! + DO N=1,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + siz=0.1 + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO + DO N=NRL,NRT +!IP MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO +! +! plot points +! + DO N=1,NRL,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO + DO N=NYP,NRT,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO + RETURN + END + + subroutine panelegn + + USE WINTERACTER + + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'You have requested '//& + ' more than the allowable number of nodes.'//CHAR(13)//'The model will return '// & + 'to allow new numbers to be input','Limit error') +! +! If answer 'Yes', execute +! + IF (WInfoDialog(4) .EQ. 1) then + return + ENDIF + return + end + SUBROUTINE FORMLINEMENU(ITYP,I1D,I2D,IFIN,XLENGTH) + + + use winteracter + + implicit none + SAVE + + include 'D.inc' + INCLUDE 'BFILES.I90' + DATA ITIME/0/ + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: ITYP,I1D,IERR,ITIME,I2D,IFIN + real :: XLENGTH + character*3 :: sub + DATA ITIME/0/ + IF(ITIME .EQ. 0) THEN + XLENGTH=100. + ITIME=1 + I1D=0 + I2D=1 + IFIN=1 + ENDIF + + + + call wdialogload(IDD_FORMLINE) + ierr=infoerror(1) + + call wdialogputRadioButton(idf_radio1) + call wdialogputcheckbox(IDF_CHECK1,I1D) + call wdialogputcheckbox(IDF_CHECK2,I2D) + call wdialogputcheckbox(IDF_CHECK3,IFIN) + CALL WDialogPutREAL(idf_REAL1,XLENGTH) + + + CALL WDialogSelect(IDD_FORMLINE) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + call wdialogGetRadioButton(idf_radio1,ITYP) + call wdialogGetCheckBox(idf_check1,I1D) + call wdialogGetCheckBox(idf_check2,I2D) + call wdialogGetCheckBox(idf_check3,IFIN) + CALL WDialogGetREAL(idf_REAL1,XLENGTH) + RETURN + ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + I1D=-999 + RETURN + ENDIF + ENDDO + RETURN + END + + SUBROUTINE FILEDAT(ALXX,ALYY,ALWD,NPTS,BLXX,BLYY,BLWD,NPTSB,ITYPBC) + USE WINTERACTER + USE DFLIB +! +! +! Define some parameters to match those in the resource file +! + include 'd.inc' + REAL*8 ALXX(*),ALYY(*),ALWD(*),BLXX(*),BLYY(*),BLWD(*) + INTEGER ITYPBC(*) + REAL*8 ATMPAR + CHARACTER(LEN=255) :: FNAME,FILTER + CHARACTER(LEN=3) :: SUB + CHARACTER ID*8,DLIN*72 + IINALN=45 + Filter='ALIGNMENT file -- *.dat|' + + CALL WSelectFile(Filter,PromptOn,FNAME,'Open Alignment File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(IINALN,FILE=FNAME,STATUS='OLD',action='read') + ELSE + RETURN + ENDIF + DO K=1,1000 + CALL GINPT(IINALN,ID,DLIN) + IF(ID(1:3) .EQ. 'XYW') THEN + READ(DLIN,*) ALXX(K),ALYY(K),ALWD(K) + ELSEIF(ID(1:3) .EQ. 'XY ') THEN + READ(DLIN,*) ALXX(K),ALYY(K) + ALWD(K)=0. + ELSE + NPTS=K-1 + GOTO 200 + ENDIF + ENDDO +200 CONTINUE + READ(IINALN,'(A8)') ID + IF(ID(1:7) .EQ. 'ENDFILE') RETURN + + CALL GETBRIDCUL(BLXX,BLYY,BLWD,NPTSB,ITYPBC) + DO K=1,1000 + ATMPAR=BLXX(K) + BLXX(K)=ALXX(K) + ALXX(K)=ATMPAR + ATMPAR=BLYY(K) + BLYY(K)=ALYY(K) + ALYY(K)=ATMPAR + ENDDO + NTEMP=NPTSB + NPTSB=NPTS + NPTS=NTEMP + RETURN + END + SUBROUTINE GETBRIDCUL(BLXX,BLYY,BLWD,NPTSB,ITYPBC) + CHARACTER(LEN=140) :: DLINLARGE + DIMENSION TEMP(7) + REAL*8 BLXX(*),BLYY(*),BLWD(*) + INTEGER ITYPBC(*) + KK=1 + DO K=1,1000 + CALL GINPT1(IINALN,DLINLARGE) + READ(DLINLARGE(7:140),*) ID,(TEMP(J),J=1,6) + IF(DLINLARGE(1:6) .EQ. 'CULVERT') THEN + ITYPBC(KK)=1 + ELSEIF(DLINLARGE(1:6) .EQ. 'BRIDGE ') THEN + ITYPBC(KK)=2 + ELSEIF(DLINLARGE(1:6) .EQ. 'ENDFIL') THEN + NPTSB=KK + ENDIF + BLXX(KK)=TEMP(1) + BLYY(KK)=TEMP(2) + BLWD(KK)=TEMP(3) + KK=KK+1 + BLXX(KK)=TEMP(4) + BLYY(KK)=TEMP(5) + BLWD(KK)=TEMP(6) + + ENDDO + RETURN + END + + + \ No newline at end of file diff --git a/src/EGEN.F90 b/src/EGEN.F90 new file mode 100644 index 0000000..98bb2ac --- /dev/null +++ b/src/EGEN.F90 @@ -0,0 +1,1163 @@ + +! Last change: IPK 12 Jan 98 1:44 pm +! + SUBROUTINE GNODE(ITYPC) +! +! Routine to create a series of nodes along a line +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + REAL*8 GRIDX(150),GRIDY(150),ALX,ALY,ATX,ATY,CURRENTX,CURRENTY,X11,Y11 + INTEGER IREF(2000),JREF(2000) +! + CHARACTER*1 IFLAG + data itime/0/ + if(itime .eq. 0) then + ALLOCATE(ALXX(2000),ALYY(2000),ALWD(2000),BLXX(2000),BLYY(2000),BLWD(2000)& + ,CNX(2000,4),CNY(2000,4),ITYPBC(2000),XBRLEN(2000),HLEFT(2000),HMID(2000),HRIGHT(2000)& + ,HSET(MAXP,3),IRTYP(2000),WIDTHD(2000)) + nh=1 + itime=1 + endif +4 CONTINUE + IF(ITYPC .EQ. 1) THEN + NHTP = 0 + NMESS = 6 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ALX=XTEMP + ALY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + CALL WRTOUT(0) + RETURN + ENDIF +! +! Exit input +! + 9 CONTINUE + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + CALL HEDR +! + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ATX=XTEMP + ATY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) +! +! Define number of nodes in a line +! + NBRR = 0 + NMESS=45 + CALL HEDR + NMESS = 7 + call getint(nh) +! READ(*,*) NH + NINT=NH-1 +! +! zero GRIDX and GRIDY to hold generated coordinates +! + DO N=1,NH + GRIDX(N)=0. + GRIDY(N)=0. + END DO +! +! Interpolate points onto line +! + CALL INTERP(GRIDX,GRIDY,1,NH,1,ALX,ALY,ATX,ATY,NINT,0) +! +! Copy points into the coordinate array +! + DO N=1,NH +! +! Find next blank node in CORD +! + CALL GETNOD(J) +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = GRIDX(N) + CORD(J,2) = GRIDY(N) + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = GRIDX(N)*TXSCAL - XS + YUSR(J) = GRIDY(N)*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) +! + END DO + ELSE + KID=0 + ITYP=2 + CALL FORMLINEMENU(ITYP,I1D,I2D,IFIN,XLENGTH,ITYPIN,NELC,NBRID) + IF(I1D .EQ. -999) RETURN + IF(IFIN .EQ. 0) THEN + NHTP = 0 + NMESS = 6 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + DO J=1,2000 + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + IF(IFLAG .EQ. 'q' .or. ibox .eq. 10) go to 300 + ALXX(J)=XTEMP + ALYY(J)=YTEMP + JPTS=J + ENDDO +300 CONTINUE + ELSE + CALL FILEDAT(JPTS,NBRID) + ENDIF +! SORT OUT A NEW ORDER + + IREF=1 + CURRENTX=ALXX(1) + CURRENTY=ALYY(1) + KS=2 + KSP=1 + DO J=2,JPTS + IF(JPTSB .GT. 0) THEN + IF(KSP .LE. JPTSB) THEN + DO K=KSP,JPTSB + TOTLEN=SQRT((ALXX(J)-CURRENTX)**2+(ALYY(J)-CURRENTY)**2) + TOTLENB=SQRT((BLXX(K)-CURRENTX)**2+(BLYY(K)-CURRENTY)**2) + IF(ABS(TOTLENB - TOTLEN) .LT. 1.0) THEN +! THIS IS A BREAKPOINT + IREF(KS)=-K + KS=KS+1 + KSP=KSP+1 + CURRENTX=BLXX(K) + CURRENTY=BLYY(K) + GO TO 320 + ENDIF + IF(TOTLENB .LT. TOTLEN) THEN +! THIS IS A BREAKPOINT + IREF(KS)=-K + KS=KS+1 + KSP=KSP+1 + CURRENTX=BLXX(K) + CURRENTY=BLYY(K) + GO TO 310 + ELSE + IREF(KS)=J + KS=KS+1 + CURRENTX=ALXX(J) + CURRENTY=ALYY(J) + GO TO 320 + ENDIF +310 CONTINUE + ENDDO + ELSE +315 CONTINUE + IREF(KS)=J + KS=KS+1 + CURRENTX=ALXX(J) + CURRENTY=ALYY(J) + ENDIF +320 CONTINUE + ELSE + IREF(KS)=J + IF(KS .LT. JPTS)KS=KS+1 + CURRENTX=ALXX(J) + CURRENTY=ALYY(J) + ENDIF + + ENDDO +! IREF(KS)=JPTS + IF(IFIN .GT. 0) THEN + IREF(KS)=JPTS + DO K=KS,1,-1 + IF(IREF(K) .LT. 0) THEN + ALXX(K)=BLXX(-IREF(K)) + ALYY(K)=BLYY(-IREF(K)) + ALWD(K)=BLWD(-IREF(K)) + HMID(K)=BLWD(-IREF(K)) + HLEFT(K)=HMID(K) + HRIGHT(K)=HMID(K) + ELSE + ALXX(K)=ALXX(IREF(K)) + ALYY(K)=ALYY(IREF(K)) + ALWD(K)=ALWD(IREF(K)) + HMID(K)=HMID(IREF(K)) + HLEFT(K)=HLEFT(IREF(K)) + HRIGHT(K)=HRIGHT(IREF(K)) + ENDIF + ENDDO + DO J=1,KS + ALXX(J)=(ALXX(J)+XS)/TXSCAL + ALYY(J)=(ALYY(J)+YS)/TXSCAL + ENDDO + DO J=1,KS + BLXX(J)=(BLXX(J)+XS)/TXSCAL + BLYY(J)=(BLYY(J)+YS)/TXSCAL + ENDDO +! KS=KS-1 + ENDIF + JST=1 + JKP=0 + K=2 + 321 IF(IREF(K) .LT. 0) THEN + 323 IF(IREF(K+1) .GT. 0) THEN + IREF(K+1)=0 + K=K+1 + GO TO 323 + ELSE + K=K+2 + IF(K .GE. KS) GO TO 325 + GO TO 321 + ENDIF + ELSE + K=K+1 + IF(K .GE. KS) GO TO 325 + GO TO 321 + ENDIF +325 CONTINUE + KC=0 + DO K=1,KS + IF(IREF(K) .EQ. 0) CYCLE + KC=KC+1 + JREF(KC)=IREF(K) + ALXX(KC)=ALXX(K) + ALYY(KC)=ALYY(K) + ALWD(KC)=ALWD(K) + HLEFT(KC)=HLEFT(K) + HMID(KC)=HMID(K) + HRIGHT(KC)=HRIGHT(K) + ENDDO + IREF=JREF + KS=KC + ICTYP=NBRID + KFS=1 + DO K=1,KS + III=K + X11=ALXX(III)*TXSCAL - XS + Y11=ALYY(III)*TXSCAL - XS + ENDDO + DO K=2,KS + IF(IREF(K) .LT. 0 .OR. K .EQ. KS) THEN + ! IF(K .LT. KS) THEN + ! IF(IREF(K) .LT. 0 .AND. IREF(K+1) .GT. 0) THEN + ! ITYPB=ICTYP+1 + ! ICTYP=ICTYP+1 + ! ELSE + ! ITYPB=ITYPIN + ! ENDIF + ! ELSE + ! ITYPB=ITYPIN + ! ENDIF + IF(KFS .EQ. 2 .OR. JPTSB .EQ. 0) THEN + ITYPB=ICTYP + ICTYP=ICTYP+1 + KFS=1 + ELSE + KFS=KFS+1 + ITYPB=ITYPIN + ENDIF + IF(ITYPB .GT. NBRID-1) THEN + ICTT=(ITYPB-NBRID+1)*2 + ICTT=ITYPBC(ICTT) + IRTYP(ITYPB)=ICTT + ELSE + ICTT=0 + IRTYP(ITYPB)=0 + ENDIF + JEND=K + XLENGTHP=XLENGTH +! GO AND FORM A LINE +! IF(ICTT .EQ. 2) XLENGTHP=XBRLEN((ITYPB-39)*2) + CALL FORMLINEL(I1D,I2D,JST,JEND,JKP,XLENGTHP,ITYPB,ICTT) + JST=JEND + ENDIF + ENDDO + IF(I2D .EQ. 1) CALL FORM999(1,1,NELC) + ENDIF + + +! GO TO 4 +! + END + SUBROUTINE INTERP(GRIDX,GRIDY,NL,NH,INT,ALX,ALY,ATX,ATY,NINT,ISWT) +! +! Routine to fill GRIDX and GRIDY by interpolation +! NL = START OF GENERATED +! NH = END OF GENERATED +! INT = INTERVAL +! ALX, ALY = START LOC +! ATX, ATY = END LOC +! NINT = NUMBER OF POINTS +! ISWT = 0 BASELINE = 1 APPLY CHANGES +!IPK MAY02 + REAL*8 GRIDX(NH),GRIDY(NH),ALX,ALY,ATX,ATY +! +! Compute intervals +! + XINT=(ATX-ALX)/FLOAT(NINT) + YINT=(ATY-ALY)/FLOAT(NINT) +! +! Generate points +! + IF(ISWT .EQ. 0) THEN + KP=0 + DO 200 K=NL,NH,INT + IF(KP .EQ. 0) THEN + GRIDX(K)=ALX + GRIDY(K)=ALY + ELSE + GRIDX(K)=GRIDX(KP)+XINT + GRIDY(K)=GRIDY(KP)+YINT + ENDIF + KP=K + 200 CONTINUE + ELSE + XAD=ALX + YAD=ALY + KP=0 + DO 220 K=NL,NH,INT + IF(KP .EQ. 0) THEN + GRIDX(K)=GRIDX(K)+XAD + GRIDY(K)=GRIDY(K)+YAD + ELSE + XAD=XAD+XINT + YAD=YAD+YINT + GRIDX(K)=GRIDX(K)+XAD + GRIDY(K)=GRIDY(K)+YAD + ENDIF + KP=K + 220 CONTINUE + ENDIF + RETURN + END + SUBROUTINE GEL +! +! Routine to create a block of elements +! + + USE WINTERACTER + USE BLK1MOD + INCLUDE 'BFILES.I90' +! INCLUDE 'BLK1.COM' + + include 'd.inc' + + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + REAL*8 GRIDX,GRIDY,ALX,ALY,BLX,BLY,ARX,ARY,BRX,BRY,GRIDXL,GRIDYL + INTEGER*2 IGSKP + COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& + ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) +! + CHARACTER*1 IFLAG + data itime/0/ + + if(itime .eq. 0) then + nx=0 + ny=0 + itime=1 + endif + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to use'//& + CHAR(13)//'existing nodes?' ,& + 'ELEMENT CREATION OPTION') +! +! If answer 'No', point to location +! + IF (WInfoDialog(4) .EQ. 2) then + noptcr=0 + GO TO 4 + else + noptcr=1 + go to 1100 + END IF + + 4 CONTINUE + NHTP=0 + NMESS=8 + NBRR = 3 + CALL HEDR +! +! Get screen coordinates of each end of line +! + 7 CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ALX=XTEMP + ALY=YTEMP + IF(IRMAIN .EQ. 1) RETURN +! + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + CALL WRTOUT(0) + RETURN + elseif(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + ENDIF +! +! Exit input +! + 9 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + siz=0.1 + call drawcr(xtemp,ytemp,siz) + NBRR=0 + CALL HEDR + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + ARX=XTEMP + ARY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! +12 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + call drawcr(xtemp,ytemp,siz) + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + BRX=XTEMP + BRY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + 16 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + call drawcr(xtemp,ytemp,siz) + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + BLX=XTEMP + BLY=YTEMP + if(iflag .eq. 'n') then + call getfpna(XTEMP) + call getfpna(YTEMP) + endif + IF(IRMAIN .EQ. 1) RETURN +! + 20 CONTINUE +! CALL PLOTT(XTEMP,YTEMP,3) +! CALL PLOTT(XTEMP,YTEMP,2) + call drawcr(xtemp,ytemp,siz) + go to 25 + +1100 continue + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE1,IFLAG,INSKP,IBOX) + ALX=CORD(INODE1,1) + ALY=CORD(INODE1,2) + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE2,IFLAG,INSKP,IBOX) + ARX=CORD(INODE2,1) + ARY=CORD(INODE2,2) + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE3,IFLAG,INSKP,IBOX) + BRX=CORD(INODE3,1) + BRY=CORD(INODE3,2) + CALL PROX(CORD(1,1),CORD(1,2),NP,xx,yy,INODE4,IFLAG,INSKP,IBOX) + BLX=CORD(INODE4,1) + BLY=CORD(INODE4,2) + +! +! Define number of elements along x and y sides +! + 25 CONTINUE + NMESS=45 + CALL HEDR + NMESS = 9 + call getint(nx) +! READ(*,*) NX + NMESS=45 + CALL HEDR + NMESS = 10 + call getint(ny) +! READ(*,*) NY + NXP=NX+1 + NYP=NY+1 + NRL=NX*NYP+1 + NRT=NXP*NYP + +! ipk jul01 test for limit exceeded + if(nrt .gt. maxpgen) then + call panelegn + go to 25 + endif + + DO N=1,NE + DO M=1,8 + NOPSV(N,M)=NOP(N,M) + ENDDO + IMATSV(N)=IMAT(N) + ENDDO + NESAV=NE + NEFSAV=NENTRY + NPUNDO=NRT +! +! Initialize GRIDX and GRIDY +! + DO 100 N=1,NRT + GRIDX(N)=0. + GRIDY(N)=0. + IGSKP(N)=0 + 100 END DO +! +! Interpolate left and right side +! + CALL INTERP(GRIDX,GRIDY,1,NYP,1,ALX,ALY,BLX,BLY,NY,0) + CALL INTERP(GRIDX,GRIDY,NRL,NRT,1,ARX,ARY,BRX,BRY,NY,0) +! +! plot points +! + DO 200 N=1,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + siz=0.1 + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 200 END DO + DO 220 N=NRL,NRT +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 220 END DO +! +! Interpolate bottom and top sides +! + CALL INTERP(GRIDX,GRIDY,1,NRL,NYP,ALX,ALY,ARX,ARY,NX,0) + CALL INTERP(GRIDX,GRIDY,NYP,NRT,NYP,BLX,BLY,BRX,BRY,NX,0) +! +! plot points +! + DO 240 N=1,NRL,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 240 END DO + DO 260 N=NYP,NRT,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + 260 END DO +! +! Interpolate interior points +! + DO 300 M=2,NYP + NFS=NRL+M-1 + CALL INTERP(GRIDX,GRIDY,M,NFS,NYP,GRIDX(M),GRIDY(M),GRIDX(NFS) & + & ,GRIDY(NFS),NX,0) + DO N=M,NFS + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + CALL RRed + call drawcr(xtemp,ytemp,siz) + CALL RBlue + ENDDO + 300 END DO + 305 CONTINUE + NMESS=11 + NBRR=10 + CALL HEDR +310 IBOX=1 + ip=0 + CALL PROX(GRIDX(1),GRIDY(1),NRT,XX,YY,IP,IFLAG,IGSKP,IBOX) + IF(IBOX .NE. 6 .and. (ip .gt. 0 .and. ip .le. nrt)) THEN + XKP=GRIDX(IP) + YKP=GRIDY(IP) + IPK=IP + ENDIF + IF(IRMAIN .EQ. 1 .OR. IBOX .EQ. 7) RETURN + IF(IFLAG .EQ. 'q') THEN + GO TO 400 + ENDIF + DO N=1,NRT + GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL + GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL + ENDDO + IF(IBOX .EQ. 6) THEN + XX=XKP + YY=YKP + IP=IPK + GO TO 315 + ENDIF + write(90,*) 'back prox irdisp',IRDISP + IF(IRDISP .EQ. 1) THEN + CALL PLTPT + ENDIF +! +! Get screen coordinate of new node location +! + CALL XYLOC(XX,YY,IFLAG,IBOX) + write(90,*) 'back xyloc irdisp',IRDISP + IF(IRMAIN .EQ. 1 .OR. IBOX .EQ. 7) RETURN + 315 IF(IRDISP .EQ. 1) THEN + DO N=1,NRT + GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL + GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL + ENDDO + CALL PLTPT + ENDIF +! +! Establish difference from movement +! + ALX=XX-GRIDX(IP) + ALY=YY-GRIDY(IP) + CALL PLOTT(XX,YY,3) + CALL PLOTT(XX,YY,2) + FPN = IP +! CALL RRed +! CALL NUMBR(XX,YY,0.20,FPN,0.0,-1) +! CALL RBlue +! +! Find location on boundary +! + IF(IP .LE. NYP) THEN +! Left boundary + NLW=IP + NUP=NRL+IP-1 + NSTP=NYP + BLX=0. + BLY=0. + NS=NX + ELSEIF(IP .GE. NRL) THEN +! Right boundary + NLW=IP-NX*NYP + NUP=IP + NSTP=NYP + BLX=ALX + BLY=ALY + ALX=0. + ALY=0. + NS=NX + ELSE + LINENO=(IP-1)/NYP + IF(IP-LINENO*NYP .EQ. 1) THEN +! Lower boundary + NLW=IP + NUP=IP+NY + NSTP=1 + BLX=0. + BLY=0. + NS=NY + ELSEIF(IP-LINENO*NYP .EQ. NYP) THEN +! Upper boundary + NLW=IP-NY + NUP=IP + NSTP=1 + BLX=ALX + BLY=ALY + ALX=0. + ALY=0. + NS=NY + ELSE + GO TO 305 + ENDIF + ENDIF +! +! Interpolate change along x line +! 14935011 + IF(IRGB .EQ. 14935011) THEN + call rgrey + ELSE + CALL RWHITEB + ENDIF + do n=1,nrt + XTEMP=gridx(n) + YTEMP=gridy(n) + call drawcr(xtemp,ytemp,siz) + enddo + CALL RRed + CALL INTERP(GRIDX,GRIDY,NLW,NUP,NSTP,ALX,ALY,BLX,BLY,NS,1) + do n=1,nrt + XTEMP=gridx(n) + YTEMP=gridy(n) + call drawcr(xtemp,ytemp,siz) + GRIDXL(N) = GRIDX(N)*TXSCAL - XS + GRIDYL(N) = GRIDY(N)*TXSCAL - YS + enddo + call Rblue + GO TO 310 +! +! Copy points into cord array +! + 400 CONTINUE + DO 500 N=1,NRT +! +! Find next blank node in CORD +! + IF(NOPTCR .EQ. 1) THEN + IF(N .EQ. 1) THEN + NODDEL(N)=0 + GO TO 500 + ELSEIF(N .EQ. NYP) THEN + NODDEL(N)=0 + GO TO 500 + ELSEIF(N .EQ. 1+NYP*NX) THEN + NODDEL(N)=0 + GO TO 500 + ELSEIF(N .EQ. NRT) THEN + NODDEL(N)=0 + GO TO 500 + ENDIF + ENDIF + CALL GETNOD(J) + NODDEL(N)=J +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = GRIDX(N) + CORD(J,2) = GRIDY(N) + IGRIDE(N) = J + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = GRIDX(N)*TXSCAL - XS + YUSR(J) = GRIDY(N)*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) +! + 500 END DO +! +! Generate elements +! + CALL GETELM(K) + IECHG=0 +! + DO 600 I=1,NX + DO 590 J=1,NY + CALL GETELM(K) + IF(I .EQ. 1 .AND. J .EQ. 1 .AND. NOPTCR .EQ. 1) THEN + NOP(K,1)=INODE1 + ELSE + NOP(K,1)=IGRIDE((I-1)*NYP+J) + ENDIF + NOP(K,2)=0 + IF(I .EQ. NX .AND. J .EQ. 1 .AND. NOPTCR .EQ. 1) THEN + NOP(K,3)=INODE2 + ELSE + NOP(K,3)=IGRIDE(I*NYP+J) + ENDIF + NOP(K,4)=0 + IF(I .EQ. NX .AND. J .EQ. NY .AND. NOPTCR .EQ. 1) THEN + NOP(K,5)=INODE3 + ELSE + NOP(K,5)=IGRIDE(I*NYP+J+1) + ENDIF + NOP(K,6)=0 + IF(I .EQ. 1 .AND. J .EQ. NY .AND. NOPTCR .EQ. 1) THEN + NOP(K,7)=INODE4 + ELSE + NOP(K,7)=IGRIDE((I-1)*NYP+J+1) + ENDIF + NOP(K,8)=0 + IMAT(K)=1 +! IF(K .GT. NE) NE=K + NCORN(K)=8 + IESKP(K)=0 +!IPK JAN98 + IERC=0 + IRDONE=0 + CALL PLTELM(K,IERC) + 590 CONTINUE + 600 END DO +! CALL UNDO(IYES) +! IF(IYES .EQ. 1) THEN +! DO N=1,NEUNDO +! J=IELDEL(N) +! CALL DELTEL(J) +! ENDDO +! DO N=1,NPUNDO +! J=NODDEL(N) +! CALL DELETN(J) +! ENDDO +! ENDIF + CALL WRTOUT(0) + RETURN + END + + SUBROUTINE PLTPT + + USE BLK1MOD + INCLUDE 'TXFRM.COM' +! INCLUDE 'BLK1.COM' + +!IPK MAY02 + REAL*8 GRIDX,GRIDY,GRIDXL,GRIDYL + INTEGER*2 IGSKP + + COMMON /GBLK/ GRIDX(MAXPGEN),GRIDY(MAXPGEN),GRIDXL(MAXPGEN),GRIDYL(MAXPGEN)& + ,IGSKP(MAXPGEN),NRL,NRT,NYP,IGRIDE(MAXPGEN) + + DO N=1,NRT + GRIDX(N)=(GRIDXL(N)+XS)/TXSCAL + GRIDY(N)=(GRIDYL(N)+YS)/TXSCAL + ENDDO + +! +! plot points +! + DO N=1,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + siz=0.1 + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO + DO N=NRL,NRT +!IP MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO +! +! plot points +! + DO N=1,NRL,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO + DO N=NYP,NRT,NYP +!IPK MAY02 + XTEMP=GRIDX(N) + YTEMP=GRIDY(N) + CALL PLOTT(XTEMP,YTEMP,3) + CALL PLOTT(XTEMP,YTEMP,2) + FPN = N + CALL RRed +! CALL NUMBR(XTEMP,YTEMP,0.20,FPN,0.0,-1) + call drawcr(xtemp,ytemp,siz) + CALL RBlue + END DO + RETURN + END + + subroutine panelegn + + USE WINTERACTER + + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'You have requested '//& + ' more than the allowable number of nodes.'//CHAR(13)//'The model will return '// & + 'to allow new numbers to be input','Limit error') +! +! If answer 'Yes', execute +! + IF (WInfoDialog(4) .EQ. 1) then + return + ENDIF + return + end + SUBROUTINE FORMLINEMENU(ITYP,I1D,I2D,IFIN,XLENGTH,ITYPIN,NELC,NBRID) + + + use winteracter + + implicit none + SAVE + + include 'D.inc' + INCLUDE 'BFILES.I90' + DATA ITIME/0/ + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: ITYP,I1D,IERR,ITIME,I2D,IFIN,ITYPIN,NELC,NBRID + real :: XLENGTH +! character*3 :: sub +! DATA ITIME/0/ +! IF(ITIME .EQ. 0) THEN + XLENGTH=250. + ITIME=1 + I1D=0 + I2D=1 + IFIN=1 + ITYPIN=30 + NELC=2 + NBRID=40 +! idf_radio1=2 + ! ENDIF + + + + call wdialogload(IDD_FORMLINE) + ierr=infoerror(1) + + call wdialogputRadioButton(idf_radio2) + call wdialogputRadioButton(idf_radio3) + CALL WDialogPutREAL(idf_REAL1,XLENGTH) + CALL WDialogPutInteger(idf_INTEGER1,ITYPIN) + call wdialogPutCheckBox(idf_check3,IFIN) + CALL WDialogPutInteger(idf_INTEGER2,NELC) + CALL WDialogPutInteger(idf_INTEGER3,NBRID) + + + CALL WDialogSelect(IDD_FORMLINE) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + call wdialogGetRadioButton(idf_radio1,ITYP) + call wdialogGetRadioButton(idf_radio3,I1D) + call wdialogGetCheckBox(idf_check3,IFIN) + CALL WDialogGetREAL(idf_REAL1,XLENGTH) + CALL WDialogGetInteger(idf_INTEGER1,ITYPIN) + CALL WDialogGetInteger(idf_INTEGER2,NELC) + CALL WDialogGetInteger(idf_INTEGER3,NBRID) + if(I1D .eq. 1) then + I1D=0 + I2D=0 + ELSEIF(I1D .EQ. 2) THEN + I1D=1 + I2D=0 + ELSEIF(I1D .EQ. 3) THEN + I1D=0 + I2D=1 + ENDIF + RETURN + ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + I1D=-999 + RETURN + ENDIF + ENDDO + RETURN + END + + SUBROUTINE FILEDAT(JPTS,NBRID) + USE WINTERACTER + USE DFLIB + USE BLK1MOD +! +! +! Define some parameters to match those in the resource file +! + include 'd.inc' + REAL*8 ATMPAR + CHARACTER(LEN=255) :: FNAME,FILTER + CHARACTER(LEN=3) :: SUB + CHARACTER ID*8,DLIN*72 + IINALN=45 + Filter='ALIGNMENT file -- *.dat|' + + CALL WSelectFile(Filter,PromptOn,FNAME,'Open Alignment File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(IINALN,FILE=FNAME,STATUS='OLD',action='read') + ELSE + RETURN + ENDIF + DO K=1,2000 + CALL GINPT(IINALN,ID,DLIN) + IF(ID(1:3) .EQ. 'XYW') THEN + READ(DLIN,*) ALXX(K),ALYY(K),ALWD(K),HLEFT(K),HMID(K),HRIGHT(K) + ELSEIF(ID(1:3) .EQ. 'XY ') THEN + READ(DLIN,*) ALXX(K),ALYY(K) + ALWD(K)=0. + ELSE + JPTS=K-1 + BACKSPACE(IINALN) + GOTO 200 + ENDIF + ENDDO +200 CONTINUE + READ(IINALN,'(A8)') ID + IF(ID(1:7) .EQ. 'ENDFILE') RETURN + + CALL GETBRIDCUL(IINALN,NBRID) +! K=(JPTSB-2)/2+2 +! ALXX(K)=ALXX(2) +! ALYY(K)=ALYY(2) +! JPTS=K +! DO K=2,JPTSB-2,2 +! ALXX(K+1)=(BLXX(K)+BLXX(K+1))/2. +! ALYY(K+1)=(BLYY(K)+BLYY(K+1))/2. +! ALWD(K+1)=(BLWD(K)+BLWD(K+1))/2. +! ENDDO + +! DO K=1,1000 +! ATMPAR=BLXX(K) +! BLXX(K)=ALXX(K) +! ALXX(K)=ATMPAR +! ATMPAR=BLYY(K) +! BLYY(K)=ALYY(K) +! ALYY(K)=ATMPAR +! ENDDO +! NTEMP=JPTSB +! JPTSB=JPTS +! NPTS=NTEMP + RETURN + END + SUBROUTINE GETBRIDCUL(IINALN,NBRID) + USE BLK1MOD + INCLUDE 'TXFRM.COM' + CHARACTER(LEN=140) :: DLINLARGE + CHARACTER(LEN=8) :: IDN,ID + REAL*8 TEMP(9),CPX,CPY,XCEN,YCEN,CW + KID=0 + PI=3.14159 + KK=1 + DO K=1,2000 + CALL GINPT1(IINALN,DLINLARGE) + IF(DLINLARGE(1:7) .EQ. 'CULVERT') THEN + READ(DLINLARGE(9:140),*) idn,(TEMP(J),J=2,9) + ITYPBC(KK)=1 + ITYPBC(KK+1)=1 + XCEN=(TEMP(2)+TEMP(4))/2. + YCEN=(TEMP(3)+TEMP(5))/2. + CW=TEMP(9)*TEMP(8)/2. + IF(KK .EQ. 1) THEN + CPX=ALXX(1) + CPY=ALYY(1) + ELSE + CPX=BLXX(KK-1) + CPY=BLYY(KK-1) + ENDIF + DNORM=ATAN2(YCEN-CPY,XCEN-CPX) + IF(DNORM .LT. 0.) DNORM=DNORM+PI + IF(DNORM .GT. PI) DNORM=DNORM-PI + BLXX(KK)=XCEN-CW*COS(DNORM) + BLYY(KK)=YCEN-CW*SIN(DNORM) + BLWD(KK)=TEMP(7) + CNX(KK,1)=BLXX(KK)-TEMP(6)/2.*COS(DNORM-PI/2.) + CNX(KK,2)=BLXX(KK)+TEMP(6)/2.*COS(DNORM-PI/2.) + CNY(KK,1)=BLYY(KK)-TEMP(6)/2.*SIN(DNORM-PI/2.) + CNY(KK,2)=BLYY(KK)+TEMP(6)/2.*SIN(DNORM-PI/2.) + KPT=NBRID+KK/2 + KID(KPT,1)=KK + DO KLM=1,2 + CALL GETNOD(J) + KID(KPT,KLM+1)=J + INEW(J) = 1 + INSKP(J) =0 + XUSR(J)=CNX(KK,KLM) + YUSR(J)=CNY(KK,KLM) + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + ENDDO + + KK=KK+1 + BLXX(KK)=XCEN+CW*COS(DNORM) + BLYY(KK)=YCEN+CW*SIN(DNORM) + BLWD(KK)=TEMP(7) + CNX(KK-1,3)=BLXX(KK)-TEMP(6)/2.*COS(DNORM-PI/2.) + CNX(KK-1,4)=BLXX(KK)+TEMP(6)/2.*COS(DNORM-PI/2.) + CNY(KK-1,3)=BLYY(KK)-TEMP(6)/2.*SIN(DNORM-PI/2.) + CNY(KK-1,4)=BLYY(KK)+TEMP(6)/2.*SIN(DNORM-PI/2.) + + DO KLM=3,4 + CALL GETNOD(J) + KID(KPT,KLM+1)=J + INEW(J) = 1 + INSKP(J) =0 + XUSR(J)=CNX(KK-1,KLM) + YUSR(J)=CNY(KK-1,KLM) + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + ENDDO + KK=KK+1 + ELSEIF(DLINLARGE(1:6) .EQ. 'BRIDGE') THEN + READ(DLINLARGE(7:140),*) IDN,(TEMP(J),J=1,7) + ITYPBC(KK)=2 + ITYPBC(KK+1)=2 + BLXX(KK)=TEMP(1) + BLYY(KK)=TEMP(2) + BLWD(KK)=TEMP(3) + KK=KK+1 + BLXX(KK)=TEMP(4) + BLYY(KK)=TEMP(5) + BLWD(KK)=TEMP(6) + XBRLEN(KK)=SQRT((BLXX(KK)-BLXX(KK-1))**2+(BLYY(KK)-BLYY(KK-1))**2) + KK=KK+1 +! READ(DLINLARGE(8:140),*) ID,(TEMP(J),J=1,6) + ELSEIF(DLINLARGE(1:7) .EQ. 'ENDFILE') THEN + JPTSB=KK-1 + GO TO 200 + ENDIF + ENDDO +200 CONTINUE + RETURN + END + + + \ No newline at end of file diff --git a/src/ELEVINT.F90 b/src/ELEVINT.F90 new file mode 100644 index 0000000..fbc222b --- /dev/null +++ b/src/ELEVINT.F90 @@ -0,0 +1,245 @@ +!----------------------------------------------------------------elevint + subroutine elevint(XX,YY,soln) +!----------------------------------------------------------------------c +! purpose: c +! To interpolate elevation from map data. c +!----------------------------------------------------------------------c +! Input data: c +! (XX, YY) -- a coordinate +!----------------------------------------------------------------------c +! Output data: c +! soln -- elevation value c +!----------------------------------------------------------------------c + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + INTEGER LISTM,NLIST + DIMENSION NLIST(200),ADIST(200) + DIMENSION LISTM(1000),listt(60,4),nlf(4),icomp(4),xnear(4) +! common /mapc/imap(maxpl) +! +! Establish size for range +! + JS=1 + K=0 + KPT=0 + DO 120 J=1,MAXPTS +! +! Determine how long each line is +! + MLEN=J-JS +! print *,XMAP(J),VDX,MAXPTS,MLEN,J,JS + IF(CMAP(J,1) .LT. VDX) THEN +! +! Now check it. +! + K=K+1 + IF(MLEN .GT. 1) THEN +! LTP=LINTYP(K) + DO 110 M=1,MLEN + IF(VAL(JS+M-1) .GT. -9000.) THEN + KPT=KPT+1 + ENDIF + 110 CONTINUE + ENDIF + NMAP=J + IF(MLEN .EQ. 0) GO TO 130 + JS=J+1 + go to 120 + ENDIF + cxcur=xmap(j) + cycur=ymap(j) + 120 END DO + 130 CONTINUE +! +! Estimate areal density to get 100 points +! + ADEN=AMAP*40./(FLOAT(KPT)*TXSCAL**2) +! +! Find square coverage +! + XNEARS=SQRT(ADEN) + xnearo=xnears +! +! initialize range +! + ict=0 + xnears=xnearo + do nang=1,4 + XNEAR(nang)=XNEARO + icomp(nang)=0 + enddo +! +! set imap to zero to start or -1 if no value +! + 220 continue + do n=1,nmap + if(cmap(n,1) .lt. vdx) then + imap(n)=-1 + elseif(val(n) .lt. -9000.) then + imap(n)=-1 + else + imap(n)=0 + endif + enddo +! +! initialize list and completeness test +! + do nang=1,4 + icomp(nang)=0 + do n=1,50 + listt(n,nang)=0 + enddo + enddo +! +! start processing +! + 280 continue +! +! check for completeness intialize counter +! + do nang=1,4 + if(icomp(nang) .eq. 0) then + nlf(nang)=0 + else + ict=ict+1 + endif + enddo +! +! if ict = 4 we are done +! + if(ict .lt. 4) then +! +! loop through map points +! + DO 300 N=1,NMAP +! +! skip if no useful value +! + if(imap(n) .eq. -1) go to 300 +! +! use nang if we have been through before +! + if(imap(n) .gt. 0) then + nang=imap(n) +! +! skip to end if done +! + if(icomp(nang) .eq. 1) then + go to 300 + endif +! +! otherwise check range skipping out if out of range +! + d1=cmap(n,1)-XX + d2=cmap(n,2)-YY + IF(ABS(D1) .GT. XNEAR(NANG)) THEN + IMAP(N)=-1 + GO TO 300 + ELSEIF(ABS(D2) .GT. XNEAR(NANG)) THEN + IMAP(N)=-1 + GO TO 300 + ENDIF +! +! process new point checking range and setting direction +! + else + d1=cmap(n,1)-XX + d2=cmap(n,2)-YY + IF(ABS(D1) .LT. XNEAR(1)) THEN + IF(ABS(D2) .LT. XNEAR(1)) THEN + if(d1 .lt. 0) then + if(d2 .lt. 0) then + imap(n)=3 + nang=3 + else + imap(n)=2 + nang=2 + endif + elseif(d2 .lt. 0) then + imap(n)=4 + nang=4 + else + imap(n)=1 + nang=1 + endif +! +! set to skip out if out of range +! + ELSE + imap(n)=-1 + go to 300 + ENDIF + ELSE + imap(n)=-1 + go to 300 + ENDIF + endif +! +! save value if total less then 50 +! + NLF(NANG)=NLF(NANG)+1 + IF(NLF(NANG) .LT. 51) THEN + LISTT(NLF(NANG),NANG)=N + ENDIF + 300 CONTINUE +! +! now reset range if we need to +! + ictz=0 + do nang=1,4 + if(nlf(nang) .gt. 50) then + rat=sqrt(45./nlf(nang)) + if(rat .lt. 0.2) rat=0.2 + xnear(nang)=xnear(nang)*rat + elseif(nlf(nang) .eq. 0) then + if(xnear(nang) .eq. xnears) then + ictz=ictz+1 + else + icomp(nang)=1 + endif + else + icomp(nang)=1 + endif + enddo + if(ictz .gt. 1) then + do nang=1,4 + xnear(nang)=xnear(nang)*2. + xnears=xnears*2. + enddo + if(xnear(1) .lt. 4.) then + go to 220 + endif + endif +! +! go back and try again +! + go to 280 + endif +! +! finished now compact list +! + nlg=0 + do nang=1,4 + nlim=nlf(nang) + if(nlim .eq. 0) then + nlim=50 + endif + do nlgg=1,nlim + if(listt(nlgg,nang) .gt. 0) then + nlg=nlg+1 + listm(nlg)=listt(nlgg,nang) + endif + enddo + enddo +! +!-----perform interpolation +! + SOLN=-9999.0 + CALL GRIDIN(XX,YY,SOLN,LISTM,NLG) + return + END diff --git a/src/ELTDISP.F90 b/src/ELTDISP.F90 new file mode 100644 index 0000000..7bdc9e5 --- /dev/null +++ b/src/ELTDISP.F90 @@ -0,0 +1,426 @@ + Subroutine EltDisp(nsw) + + USE WINTERACTER + USE BLK1MOD +! + include 'd.inc' +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + +! +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INTEGER :: N,IBOX,NN,NOOP(16),NEAC(8) + INTEGER :: IERR + CHARACTER*1 :: IFLAG + + DATA N/1/ + ims=0 + 100 continue + call wdialogload(IDD_ELTDATA) + ierr=infoerror(1) + IF(NSW .NE. 0) N=ABS(NSW) + CALL WDialogPutInteger(IDF_INTEGER1,N) + NN=N + DO N1=1,8 + NOOP(N1)=NOP(N,N1) + NOOP(N1+8)=NOP(N,N1) + ENDDO + IMAAT=IMAT(N) + 120 CONTINUE + CALL WDialogPutInteger(IDF_INTEGER1,N) + CALL WDialogPutInteger(IDF_INTEGER2,NOOP(1)) + CALL WDialogPutInteger(IDF_INTEGER3,NOOP(2)) + CALL WDialogPutInteger(IDF_INTEGER4,NOOP(3)) + CALL WDialogPutInteger(IDF_INTEGER5,NOOP(4)) + CALL WDialogPutInteger(IDF_INTEGER6,NOOP(5)) + CALL WDialogPutInteger(IDF_INTEGER7,NOOP(6)) + CALL WDialogPutInteger(IDF_INTEGER8,NOOP(7)) + CALL WDialogPutInteger(IDF_INTEGER9,NOOP(8)) + CALL WDialogPutInteger(IDF_INTEGER10,IMAAT) + CALL WDialogSelect(IDD_ELTDATA) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modeless) + ierr=infoerror(1) + + if(ims .eq. 1) go to 200 + 150 CONTINUE + IF(NSW .LE. 0) THEN + call wdialogload(IDD_SELELT) + ierr=infoerror(1) + + CALL WDialogPutInteger(IDF_INTEGER1,N) + + CALL WDialogSelect(IDD_SELELT) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,ModaL) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + ims=1 + go to 100 + endif +!ipksep02 + ims=1 + go to 100 + enddo + ELSE + call wdialogload(IDD_ELTERR) + ierr=infoerror(1) + + CALL WDialogPutInteger(IDF_INTEGER1,N) + + CALL WDialogSelect(IDD_ELTERR) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,ModaL) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + ims=1 + go to 100 + endif +!ipk sep02 + ims=1 + go to 100 + enddo + ENDIF + + 200 continue + + DO + CALL WMessage(ITYPE,MESSAGE) + SELECT CASE (ITYPE) + CASE (PushButton) + IF(MESSAGE%VALUE1.EQ.IDOK) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + CALL WDialogGetInteger(IDF_INTEGER2,NOOP(1)) + CALL WDialogGetInteger(IDF_INTEGER3,NOOP(2)) + CALL WDialogGetInteger(IDF_INTEGER4,NOOP(3)) + CALL WDialogGetInteger(IDF_INTEGER5,NOOP(4)) + CALL WDialogGetInteger(IDF_INTEGER6,NOOP(5)) + CALL WDialogGetInteger(IDF_INTEGER7,NOOP(6)) + CALL WDialogGetInteger(IDF_INTEGER8,NOOP(7)) + CALL WDialogGetInteger(IDF_INTEGER9,NOOP(8)) + CALL WDialogGetInteger(IDF_INTEGER10,IMAAT) + ISUM=0 + DO N1=1,8 + NOP(N,N1)=NOOP(N1) + ISUM=ISUM+NOOP(N1) + ENDDO + IMAT(N)=IMAAT + IF(ISUM .EQ. 0) THEN + XC(N)=VOID + YC(N)=VOID + IF(N .LT. NELAST) NELAST=N + IESKP(N)=1 + NCORN(N)=0 + IMAT(N)=0 + ENDIF + call WDialogHide() + call wdialogUNload() + RETURN + ELSEIF(MESSAGE%VALUE1.EQ.IDNEXT) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + CALL WDialogGetInteger(IDF_INTEGER2,NOOP(1)) + CALL WDialogGetInteger(IDF_INTEGER3,NOOP(2)) + CALL WDialogGetInteger(IDF_INTEGER4,NOOP(3)) + CALL WDialogGetInteger(IDF_INTEGER5,NOOP(4)) + CALL WDialogGetInteger(IDF_INTEGER6,NOOP(5)) + CALL WDialogGetInteger(IDF_INTEGER7,NOOP(6)) + CALL WDialogGetInteger(IDF_INTEGER8,NOOP(7)) + CALL WDialogGetInteger(IDF_INTEGER9,NOOP(8)) + CALL WDialogGetInteger(IDF_INTEGER10,IMAAT) + ISUM=0 + DO N1=1,8 + NOP(N,N1)=NOOP(N1) + ISUM=ISUM+NOOP(N1) + ENDDO + IMAT(N)=IMAAT + IF(ISUM .EQ. 0) THEN + XC(N)=VOID + YC(N)=VOID + IF(N .LT. NELAST) NELAST=N + IESKP(N)=1 + NCORN(N)=0 + IMAT(N)=0 + ENDIF + GO TO 150 + ELSEIF(MESSAGE%VALUE1.EQ.IDF_delete) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + CALL DELTEL(N) + call WDialogHide() + call wdialogUNload() + RETURN + ELSEIF(MESSAGE%VALUE1.EQ.IDCANCEL) THEN + call WDialogHide() + call wdialogUNload() + RETURN + ELSEIF(MESSAGE%VALUE1.EQ.IDFROTATE) THEN + call WDialogHide() + call wdialogUNload() + call plotot(1) + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select starting node','CHOOSE NODE') + IBOX=1 + DO K=1,8 + NEAC(K)=NOP(N,K) + ENDDO + CALL PROXEL(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX,NEAC) + DO K=1,NCORN(N) + IF(NOOP(K) .EQ. INODE) THEN + LL=K-1 + DO L=1,NCORN(N) + LL=LL+1 + IF(NCORN(N) .EQ. 6 .AND. LL .EQ. 7) LL=LL+2 + NOOP(L)=NOOP(LL) + ENDDO + IF(NCORN(N) .EQ. 6) THEN + NOOP(7)=0 + NOOP(8)=0 + ENDIF + call wdialogload(IDD_ELTDATA) + GO TO 120 + ENDIF + enddo + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Selected node not within element','CHOOSE NODE') + call wdialogload(IDD_ELTDATA) + GO TO 120 + + ENDIF + END SELECT + END DO + + RETURN + END + + SUBROUTINE GETELMNO + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*1 IFLAG + + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select element','CHOOSE ELEMENT') + IBOX=1 + CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX) + INEG=-IELEM + CALL ELTDISP1(INEG) + RETURN + END + + + Subroutine EltDisp1(nsw) + + USE WINTERACTER + USE BLK1MOD +! + include 'd.inc' +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + +! +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INTEGER :: N,IBOX,NN,NOOP(16),NEAC(8) + INTEGER :: IERR + CHARACTER*1 :: IFLAG + + DATA N/1/ + ims=0 + 100 continue + call wdialogload(IDD_ELTDATA) + ierr=infoerror(1) + IF(NSW .NE. 0) N=ABS(NSW) + CALL WDialogPutInteger(IDF_INTEGER1,N) + NN=N + DO N1=1,8 + NOOP(N1)=NOP(N,N1) + NOOP(N1+8)=NOP(N,N1) + ENDDO + IMAAT=IMAT(N) + 120 CONTINUE + CALL WDialogPutInteger(IDF_INTEGER1,N) + CALL WDialogPutInteger(IDF_INTEGER2,NOOP(1)) + CALL WDialogPutInteger(IDF_INTEGER3,NOOP(2)) + CALL WDialogPutInteger(IDF_INTEGER4,NOOP(3)) + CALL WDialogPutInteger(IDF_INTEGER5,NOOP(4)) + CALL WDialogPutInteger(IDF_INTEGER6,NOOP(5)) + CALL WDialogPutInteger(IDF_INTEGER7,NOOP(6)) + CALL WDialogPutInteger(IDF_INTEGER8,NOOP(7)) + CALL WDialogPutInteger(IDF_INTEGER9,NOOP(8)) + CALL WDialogPutInteger(IDF_INTEGER10,IMAAT) + CALL WDialogSelect(IDD_ELTDATA) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + 150 CONTINUE + + DO +! Branch depending on type of message. +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + CALL WDialogGetInteger(IDF_INTEGER2,NOOP(1)) + CALL WDialogGetInteger(IDF_INTEGER3,NOOP(2)) + CALL WDialogGetInteger(IDF_INTEGER4,NOOP(3)) + CALL WDialogGetInteger(IDF_INTEGER5,NOOP(4)) + CALL WDialogGetInteger(IDF_INTEGER6,NOOP(5)) + CALL WDialogGetInteger(IDF_INTEGER7,NOOP(6)) + CALL WDialogGetInteger(IDF_INTEGER8,NOOP(7)) + CALL WDialogGetInteger(IDF_INTEGER9,NOOP(8)) + CALL WDialogGetInteger(IDF_INTEGER10,IMAAT) + ISUM=0 + DO N1=1,8 + NOP(N,N1)=NOOP(N1) + ISUM=ISUM+NOOP(N1) + ENDDO + IMAT(N)=IMAAT + IF(ISUM .EQ. 0) THEN + XC(N)=VOID + YC(N)=VOID + IF(N .LT. NELAST) NELAST=N + IESKP(N)=1 + NCORN(N)=0 + IMAT(N)=0 + ENDIF + CALL HEDR + RETURN + ELSEIF (WInfoDialog(ExitButton) .EQ. IDNEXT) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + CALL WDialogGetInteger(IDF_INTEGER2,NOOP(1)) + CALL WDialogGetInteger(IDF_INTEGER3,NOOP(2)) + CALL WDialogGetInteger(IDF_INTEGER4,NOOP(3)) + CALL WDialogGetInteger(IDF_INTEGER5,NOOP(4)) + CALL WDialogGetInteger(IDF_INTEGER6,NOOP(5)) + CALL WDialogGetInteger(IDF_INTEGER7,NOOP(6)) + CALL WDialogGetInteger(IDF_INTEGER8,NOOP(7)) + CALL WDialogGetInteger(IDF_INTEGER9,NOOP(8)) + CALL WDialogGetInteger(IDF_INTEGER10,IMAAT) + ISUM=0 + DO N1=1,8 + NOP(N,N1)=NOOP(N1) + ISUM=ISUM+NOOP(N1) + ENDDO + IMAT(N)=IMAAT + IF(ISUM .EQ. 0) THEN + XC(N)=VOID + YC(N)=VOID + IF(N .LT. NELAST) NELAST=N + IESKP(N)=1 + NCORN(N)=0 + IMAT(N)=0 + ENDIF + GO TO 150 + ELSEIF (WInfoDialog(ExitButton) .EQ. IDF_DELETE) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + CALL DELTEL(N) + RETURN + ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + RETURN + ELSEIF (WInfoDialog(ExitButton) .EQ. IDFROTATE) THEN + call plotot(1) + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select starting node','CHOOSE NODE') + IBOX=1 + DO K=1,8 + NEAC(K)=NOP(N,K) + ENDDO + CALL PROXEL(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX,NEAC) + DO K=1,NCORN(N) + IF(NOOP(K) .EQ. INODE) THEN + LL=K-1 + DO L=1,NCORN(N) + LL=LL+1 + IF(NCORN(N) .EQ. 6 .AND. LL .EQ. 7) LL=LL+2 + NOOP(L)=NOOP(LL) + ENDDO + IF(NCORN(N) .EQ. 6) THEN + NOOP(7)=0 + NOOP(8)=0 + ENDIF + call wdialogload(IDD_ELTDATA) + GO TO 120 + ENDIF + enddo + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Selected node not within element','CHOOSE NODE') + call wdialogload(IDD_ELTDATA) + GO TO 120 + + ENDIF + END DO + RETURN + END + + Subroutine EltERRDisp(nsw,ims) + + USE WINTERACTER + USE BLK1MOD +! + include 'd.inc' +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + +! +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INTEGER :: NSW,IBOX,NN,NOOP(16) + INTEGER :: IERR + CHARACTER*1 :: IFLAG + + DATA N/1/ + ims=0 + 100 continue + call wdialogload(IDD_ELTERR2) + ierr=infoerror(1) + + CALL WDialogPutInteger(IDF_INTEGER1,NSW) + + CALL WDialogSelect(IDD_ELTERR) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,ModaL) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(IDF_INTEGER1,NSW) + ims=1 + return + else + ims=0 + return + endif + enddo + return + end + + + + \ No newline at end of file diff --git a/src/ELTS.F90 b/src/ELTS.F90 new file mode 100644 index 0000000..8261fbd --- /dev/null +++ b/src/ELTS.F90 @@ -0,0 +1,712 @@ +! Last change: IPK 12 Jan 98 1:59 pm +!ipk delete old calls to char(7) +!ipk last updated Nov 18 1997 +!ipk last updated June 24 1996 +! +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! + SUBROUTINE ELTS + +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + CHARACTER*1 ANS,ANSW(0:9) + DATA ANSW/'s','j','f','g','t','i','h','z','r','q'/ +! +! Draw box around selections +! + 2 CONTINUE + NHTP=6 + NMESS=0 + NBRR=0 + CALL HEDR +! +! Get answer +! + 3 call xyloc(XPT,YPT,ANS,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(ANS .EQ. 'c') THEN + I=IBOX-1 + if(i .lt. 0) go to 3 + ANS=ANSW(I) + ENDIF +! + IF(ANS .EQ. 's') THEN + CALL SELECT + IF(IRMAIN .EQ. 1) RETURN + ELSEIF (ANS .EQ. 'j') THEN + CALL MKELEM + IF(IRMAIN .EQ. 1) RETURN + ELSEIF (ANS .EQ. 'd') THEN + CALL DELEL + IF(IRMAIN .EQ. 1) RETURN + ELSEIF (ANS .EQ. 'f') THEN + CALL FINDEL + IF(IRMAIN .EQ. 1) RETURN + ELSEIF (ANS .EQ. 'g') THEN + CALL GEL + IF(IRMAIN .EQ. 1) RETURN + ELSEIF (ANS .EQ. 't') THEN + CALL MATTYP + IF(IRMAIN .EQ. 1) RETURN + ELSEIF (ANS .EQ. 'i') THEN +!ipk aug02 + CALL FILM(0) + IF(IRMAIN .EQ. 1) RETURN + ELSEIF (ANS .EQ. 'h') THEN + CALL HELPS(2) + IF(IRMAIN .EQ. 1) RETURN + ELSEIF (ANS .EQ. 'q') THEN + RETURN + ELSE + GO TO 3 + ENDIF + GO TO 2 + END +! +!**************************************************************** +! + SUBROUTINE MATTYP +! + USE BLK1MOD + SAVE +! INCLUDE 'BLK1.COM' +! +!ipk feb97 CHARACTER*1 IFLAG +! + CHARACTER*1 IFLAG,ANSW(10) + DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/ +! +! +! Assign new material type +! +! +! + data itime/0/ + + if(itime .eq. 0) then + mat=1 + itime=1 + endif + ht=0.2 +!ipk feb97 + 4 CONTINUE + NHTP=0 + NBRR=4 +!ipk feb97 NBRR=0 + NMESS=45 + CALL HEDR + NMESS=2 + XPRT=3.2 +! READ(*,*) MAT +! +! Write out current material types +! + IF(NEFL .GT. 0) GO TO 100 +!ipk feb97 4 HT = .20 + HT = .15 + DO 10 J=1,NE + IF (IMAT(J) .GT. 0 .AND. IMAT(J) .LT. 901) THEN + IF(IESKP(J) .EQ. 0) THEN + IF(IQSW(1) .EQ. 1 .OR. IQSW(2) .EQ. 1) FPN = IMAT(J) + IF(IQSW(1) .EQ. 2 .OR. IQSW(2) .EQ. 2) FPN = IGRPSER(J) + X = XC(J) +!ipk jul02 Y = YC(J) - .11 + Y = YC(J) + .01 + IF(X .GT. 0. .AND. X .LT. HSIZE .AND. & + & Y .GT. 0. .AND. Y .LT. 7.5) THEN + CALL NUMBR(X,Y,HT,FPN,0.0,-1) + ENDIF + ENDIF + ENDIF + 10 END DO + CALL GETINT(MAT) + + 5 CONTINUE + IBOX=1 + CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN + XPRT=XPRT+0.5 + IF(XPRT .GT. 9.6) XPRT=0. + FPN= IELEM + CALL NUMBR(XPRT,7.20,0.18,FPN,0.0,-1) +!ipk feb97 new setup +! + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF +! + IF(IFLAG .EQ. 'q') THEN + RETURN + ELSEIF(IFLAG .EQ. 'e' .OR. IFLAG .EQ. 'n') THEN +!ipk nov97 add (1) + CALL PLOTOT(1) + GO TO 4 + ENDIF + IF(IQSW(1) .EQ. 1 .OR. IQSW(2) .EQ. 1) IMAT(IELEM) = MAT + IF(IQSW(1) .EQ. 2 .OR. IQSW(2) .EQ. 2) IGRPSER(IELEM) = MAT + FPN = MAT + X = XC(IELEM) + Y = YC(IELEM) + .01 + CALL NUMBR(X,Y,0.15,FPN,0.0,-1) +! +!ipk feb97 ELSEIF(IFLAG .EQ. 'q') THEN +!ipkfeb94 CALL WRTOUT(0) +!ipk feb97 RETURN +! +!ipk feb97 ELSE +!ipk feb97 WRITE(*,*) CHAR(7),CHAR(7) +!ipk feb97 ENDIF +! + GOTO 5 +! +! Process list from prior selection +! + 100 CONTINUE + DO 150 K=1,NEFL + J=NEFLAG(K) + IMAT(J)=MAT + 150 END DO + NEFL=0 + RETURN + END +! + SUBROUTINE FINDEL +! + USE BLK1MOD + SAVE NELSE +! INCLUDE 'BLK1.COM' +! +! Read desired element number +! + data itime/0/ + if(itime .eq. 0) then + itime=1 + nelse=0 + endif + 2 CONTINUE + NHTPSAV=NHTP + NMESSAV=NMESS + NBRRSAV=NBRR + NHTP=0 + NBRR=0 + NMESS=3 + CALL HEDR + NMESS=3 + CALL GETINT(NELSE) +! READ(*,*) NELSE +! +! Obtain location of centroid +! +!ipkdec93 IF(IMAT(NELSE) .EQ. 0) GO TO 2 + IF(IMAT(NELSE) .EQ. 0) RETURN + DO 4 I=1,NP + IF(CORD(I,1) .GT. VOID) THEN + INSKP(I)=0 + ENDIF + 4 END DO + DO 5 I=1,NE + IF(IMAT(I) .GT. 0) THEN + IESKP(I)=0 + ENDIF + 5 END DO + NCN=NCORN(NELSE) + XX=0. + YY=0. + DO 150 K=1,NCN,2 + XX=XX+CORD(NOP(NELSE,K),1) + YY=YY+CORD(NOP(NELSE,K),2) + 150 END DO + XP=XX/FLOAT((NCN+1)/2) + YP=YY/FLOAT((NCN+1)/2) +! +! Make it center of screen and redraw +! + XMIN=XP-5.0*PSCALE + YMIN=YP-3.5*PSCALE +! CALL PLOTS(0) +!ipk nov97 add (1) + CALL PLOTOT(1) + HT=0.15 + FPN=NELSE + CALL RRED + CALL NUMBR(5.,3.5,HT,FPN,0.0,-1) + CALL RBLUE + NHTP=NHTPSAV + NMESS=NMESSAV + NBRR=NBRRSAV + CALL HEDR + RETURN + END +! + SUBROUTINE DELEL +! +! Routine to define element for deleting +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*1 IFLAG + IF(NEFL .GT. 0) GO TO 150 + 100 CONTINUE +! +! Check out mouse +! + IBOX=0 + CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! +! Go and start again if quit called +! + IF(IFLAG .EQ. 'q') RETURN + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL DELTEL(IELEM) + GO TO 100 +! +! Call routine to delete elements in list +! + + 150 CONTINUE + IECHG=0 +!IPK MAY03 + ICHG=0 + DO 200 K=1,NEFL + J=NEFLAG(K) + CALL DELTEL(J) + 200 END DO + NEFL=0 + RETURN + END +! + SUBROUTINE DELTEL(J) +! +! Routine to delete a given element +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + IMAT(J)=0 + XC(J)=VOID + YC(J)=VOID + IF(J .LT. NELAST) NELAST=J + DO 170 KK=1,8 + NOP(J,KK)=0 + 170 END DO + IESKP(J)=1 + NCORN(J)=0 + JJ=0 +!IPK FEB08 TEST FOR LOWERING NE + IF(J .EQ. NE) THEN + DO J=NE,1,-1 + IF(IMAT(J) .NE. 0) THEN + JJ=J + GO TO 200 + ENDIF + ENDDO + 200 NE=JJ + ENDIF + RETURN + END +! + SUBROUTINE SELECT +! +! Routine to select elements +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*1 ANSW(10) + CHARACTER*1 IFLAG + DATA ANSW/'d','e','n','a','g','t','h','z','r','q'/ + data itime/0/ + + if(itime .eq. 0) then + ielem=1 + itime=1 + endif + +! +! Draw box around selections +! + + 2 CONTINUE +!IPK MAY94 DROP THIS PLOTTING +! CALL PLOTOT + NEFL=0 + 95 NHTP=7 + NMESS=0 + NBRR=0 + CALL HEDR + 100 CONTINUE +! +! Check out mouse +! + IBOX=1 + CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! +! Return if quit called +! + IF(IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ELSEIF(IFLAG .EQ. 'c') THEN + GO TO 120 + ENDIF +! +! Check for reading number +! + IF(IFLAG .EQ. 'n') THEN + NHTP=0 + NMESS=45 + CALL HEDR + NMESS=20 + CALL GETINT(IELEM) + NEFL=NEFL+1 + NEFLAG(NEFL)=IELEM + CALL FILLEM(IELEM) + GO TO 95 +! +! Check for selecting all elements +! + ELSEIF(IFLAG .EQ. 'a') THEN + DO I=1,NE + IF(IMAT(I) .GT. 0) THEN + IF(IMAT(I) .LT. 901 .or. imat(i) .gt. 903) THEN + NEFL=NEFL+1 + NEFLAG(NEFL)=I + CALL FILLEM(I) + ENDIF + ENDIF + ENDDO + GO TO 95 +! +! Check for only rectangles +! + ELSEIF(IFLAG .EQ. 'g') THEN + DO I=1,NE + IF(NCORN(I) .EQ. 8) THEN + NEFL=NEFL+1 + NEFLAG(NEFL)=I + CALL FILLEM(I) + ENDIF + ENDDO + GO TO 95 +! +! Check for only triangles +! + ELSEIF(IFLAG .EQ. 't') THEN + DO I=1,NE + IF(NCORN(I) .EQ. 6) THEN + NEFL=NEFL+1 + NEFLAG(NEFL)=I + CALL FILLEM(I) + ENDIF + ENDDO + GO TO 95 +! +! Check for only line elements +! + ELSEIF(IFLAG .EQ. 'l') THEN + DO I=1,NE + IF((NCORN(I) .LT. 6 .and. ncorn(i) .gt. 2) .and. & + (imat(i) .lt. 901 .or. imat(i) .gt. 903)) THEN + NEFL=NEFL+1 + NEFLAG(NEFL)=I + CALL FILLEM(I) + xa=(cord(nop(i,1),1)+cord(nop(i,3),1))/2. + ya=(cord(nop(i,1),2)+cord(nop(i,3),2))/2. + fpn=i + CALL NUMBR(xa,ya,0.18,FPN,0.0,-1) + ENDIF + ENDDO + GO TO 95 +! +! Check for delete option +! + ELSEIF(IFLAG .EQ. 'd') THEN + CALL DELEL +! +! Check for refine option +! + ELSEIF(IFLAG .EQ. 'e') THEN + CALL REFB + IF(IRMAIN .EQ. 1) RETURN +! +! Check for help +! + ELSEIF (IFLAG .EQ. 'h') THEN + CALL HELPS(6) + IF(IRMAIN .EQ. 1) RETURN +! + ELSEIF(IFLAG .EQ. 'U') THEN + NEFLAG(NEFL)=0 + NEFL=NEFL-1 + CALL PLOTOT(1) + CALL HEDR + DO IELEM=1,NEFL + CALL FILLEM(NEFLAG(IELEM)) + ENDDO + GO TO 100 + ELSEIF(IFLAG .EQ. 'q') THEN + RETURN + ENDIF + GO TO 2 + 120 NEFL=NEFL+1 + NEFLAG(NEFL)=IELEM + CALL FILLEM(IELEM) + IF(NCORN(ielem) .LT. 6 .and. ncorn(ielem) .gt. 2) THEN + + xa=(cord(nop(ielem,1),1)+cord(nop(ielem,3),1))/2. + ya=(cord(nop(ielem,1),2)+cord(nop(ielem,3),2))/2. + fpn=ielem + CALL NUMBR(xa,ya,0.18,FPN,0.0,-1) + endif + GO TO 100 + END +! +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! + SUBROUTINE MKELEM + +! + USE BLK1MOD + INCLUDE 'BFILES.I90' +! INCLUDE 'BLK1.COM' +! + CHARACTER*1 IFLAG + CHARACTER*32 IJNK + CHARACTER*23 ELTH +!ipk jan98 + CHARACTER*80 LIND + CHARACTER*60 MESSAGE,MESSAG1 +!ipk jun96 add messag2 + CHARACTER*26 MESSAG2 + DATA MESSAG2/' Press return to continue'/ +!ipkjul94 add a line + MEL=MAXE +! +! Form element nodal list by clicking on nodes with cursor +! + 3 CONTINUE + CALL GETELM(J) + 5 CONTINUE + IECHG=0 +!IPK MAY03 + ICHG=0 + WRITE(ELTH,5000) j + 5000 FORMAT('Processing element',i5) + CALL CLRBOX +!ipk jun96 clear a strip + call clrstp(7.2,7.5) + CALL SYMBL(0.,7.70,0.18,ELTH,0.,23) + XPRT=3.5 + + 6 DO 10 K=1,10,2 +! +! Find node nearest to cursor +! + 7 CONTINUE +!ipk sep94 reset ibox + IBOX=1 +!ipk sep49 add call to hedr + nhtp=0 +!ipk jun96 nmess=22 + nmess=15 + nbrr=3 + call hedr + write(155,*) width(1),width(2),width(3) + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! +! IF(IFLAG .EQ. 'z') THEN +! DO 62 I=1,NP +! IF(CORD(I,1) .GT. VOID) THEN +! INSKP(I)=0 +! ENDIF +! 62 CONTINUE +! DO 63 I=1,NE +! IF(IMAT(I) .GT. 0) THEN +! IESKP(I)=0 +! ENDIF +! 63 CONTINUE + CALL RBLUE + if(inode .lt. 1) return + CALL PLTNOD(INODE,1) + XPRT=XPRT+0.5 + IF(XPRT .GT. 9.6) then + XPRT=0. +!ipk jun96 clear a strip + call clrstp(7.2,7.5) + endif + FPN= INODE + CALL RBLUE + CALL NUMBR(XPRT,7.30,0.18,FPN,0.0,-1) +! + IF(K .EQ. 9) THEN + IF(IFLAG .EQ. 'm') THEN + NOP(J,K-1) = INODE + WD(INODE) = 0. +! +! Five node element +! + ELSEIF (IFLAG .EQ. 'f') THEN + NOP(J,4)=NOP(J,5) + NOP(J,5)=NOP(J,7) + NOP(J,7) = 0 + NOP(J,8) = 0 + ENDIF + GO TO 10 + ENDIF + IF (IFLAG .NE. 'r') THEN + NOP(J,K) = 0 + NOP(J,K+1) = 0 + ENDIF +! +! Corner node +! + IF (IFLAG .EQ. 'c') THEN + NOP(J,K) = INODE +! +! Midside node +! + ELSEIF (IFLAG .EQ. 'm') THEN + NOP(J,K-1) = INODE + GOTO 7 +! +! Triangular element +! + ELSEIF (IFLAG .EQ. 't' .AND. K .EQ. 7) THEN + NOP(J,7) = 0 + NOP(J,8) = 0 + GOTO 20 +! +! 1-d element +! + ELSEIF (IFLAG .EQ. 'l' .AND. K .EQ. 5) THEN + NOP(J,4) = 0 + NOP(J,5) = 0 + NOP(J,6) = 0 + NOP(J,7) = 0 + NOP(J,8) = 0 + GOTO 20 +! +! Junction element +! + ELSEIF (IFLAG .EQ. 'j' .AND. K .EQ. 3) THEN + INODE= NOP(J,1) + NOP(J,1)=0 + CALL JUNGEN(J,INODE,IER) + IF(IER .EQ. 1) THEN +! +! Redo if error +! +!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7) + GOTO 7 + ENDIF + GO TO 20 +! +! Exit input +! + ELSEIF(IFLAG .EQ. 'q') THEN + NE=NE-1 +!ipkfeb94 CALL WRTOUT(0) + IRDONE=0 + RETURN +! +! Redo if error +! + ELSE +!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7) + GOTO 6 + ENDIF + 10 END DO +! + 20 IF (IMAT(J) .EQ. 0) IMAT(J) = 1 +! +! rearrange if nop(j,4) .ne. 0 separate it from +! a transition element +! + IF(NOP(J,4) .NE. 0 .AND. NOP(J,6) .EQ. 0) THEN + IF(IFLAG .NE. 'f' .AND. IMAT(J) .LT. 901) THEN + + ITMP1 = NOP(J,1) + ITMP2 = NOP(J,2) + DO 30 KK=1,6 + NOP(J,KK) = NOP(J,KK+2) + 30 CONTINUE + IF(NOP(J,5) .EQ. 0) THEN + NOP(J,5)=ITMP1 + NOP(J,6)=ITMP2 + ELSE + NOP(J,7)=ITMP1 + NOP(J,8)=ITMP2 + ENDIF + ENDIF + ENDIF + NCN = 2 + IF (NOP(J,3) .NE. 0) NCN = 3 + IF (NOP(J,4) .NE. 0) NCN = 4 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6 + IF (NOP(J,6) .NE. 0) NCN = 6 + IF (NOP(J,7) .NE. 0) NCN = 8 +! +! Check to see if duplicate node numbers have been defined +! + DO 40 KK=1,NCN-1 + IF(NOP(J,KK) .EQ. 0) GO TO 40 + DO 37 LL=KK+1,NCN + IF(NOP(J,KK) .EQ. NOP(J,LL)) THEN + WRITE(MESSAGE,6000) J + 6000 FORMAT(' **ERROR** NODES AT ELEMENT NUMBER',I5,' ARE DUPLICATED RE& + &TRY') + WRITE(MESSAG1,6001) (NOP(J,II),II=1,8) + 6001 FORMAT(' NODE LIST FOLLOWS ',8I5) + CALL CLRBOX + CALL SYMBL(0.,7.75,0.18,MESSAGE,0.,60) + CALL SYMBL(0.,7.55,0.18,MESSAG1,0.,60) +!IPK JUN96 + CALL SYMBL(0.,7.35,0.18,MESSAG2,0.,25) + call keybrd(k) +!cc read(*,'(A)') ijnk +!ipk jun96 change transfer location +! GO TO 6 + go to 5 + ENDIF + 37 CONTINUE + 40 END DO + NCORN(J) = NCN + IESKP(J) = 0 + NE = MAX(J,NE) +!IPK JAN98 + IERC=0 + CALL PLTELM(J,IERC) +! +! WRITE(IOT,'(10I5)') J, (NOP(J,K),K=1,8), IMAT(J) +! +! Return if dimensions exceeded +! +!ipk jul94 IF (J .GE. MAXE) THEN + IF (J .GE. MEL) THEN + CALL WRTOUT(0) + CALL CLSCRN +!ipk jan98 CALL SETD(24) +!ipk jan98 WRITE(*,*) ' Element number exceeds MAXE. Press retur + WRITE(lind,*) & + & ' Element number exceeds MAXE. Press return to exit' + call symbl & + & (1.1,4.0,0.20,LIND,0.0,80) +!ipk jan98 READ(*,'(A)') IJNK + ndig=1 + CALL GTCHARX(IJNK,NDIG,5.0,4.0) + RETURN + ENDIF +! +! Go do another element +! + GOTO 3 + +! + END diff --git a/src/ELVSET.F90 b/src/ELVSET.F90 new file mode 100644 index 0000000..5dd39c6 --- /dev/null +++ b/src/ELVSET.F90 @@ -0,0 +1,425 @@ + SUBROUTINE SETRNG(XNEARS,NMAP) + + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! +! Establish size for range +! + JS=1 + K=0 + KPT=0 + VDX=-1.E9 + write(90,*) 'maxpts', maxpts + DO 120 J=1,MAXPTS+1 +! +! Determine how long each line is +! + MLEN=J-JS +! write(90,*) 'mlen',j,js,mlen,xmap(j),nmap,vdx +! write(90,*) j,js,mlen,cmap(j,1),xmap(j),vdx,maxpts + IF(XMAP(J) .LT. VDX) THEN +!IPK NOV05 IF(CMAP(J,1) .LT. VDX) THEN +! +! Now check it. +! + K=K+1 + IF(MLEN .GT. 1) THEN +! LTP=LINTYP(K) + DO 110 M=1,MLEN +! write(191,*) j,m,js+m-1,nmap + IF(VAL(JS+M-1) .GT. -9000.) THEN + KPT=KPT+1 + ENDIF + 110 CONTINUE + ENDIF + NMAP=J + IF(MLEN .EQ. 0) GO TO 130 + JS=J+1 + go to 120 + ENDIF + cxcur=xmap(j) + cycur=ymap(j) + 120 END DO + 130 CONTINUE + write(90,*) 'number of points forming map',nmap + write(90,*) 'last map coordinates',cxcur,cycur +! +! Estimate areal density to get 100 points +! + ADEN=AMAP*40./(FLOAT(KPT)*TXSCAL**2) +! +! Find square coverage +! + XNEARS=SQRT(ADEN) + xnearo=xnears + xnearf=xnears +!ipk sep97 xnearo forms the current value xnearp is limiting plus side + XNEARP=XNEARS +! xnears=2.0 + WRITE(90,*) 'Radius for nearby points',XNEARS + RETURN + END + + SUBROUTINE SETELV(XNEARS,NMAP,M,ISWT) + + USE WINTERACTER + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +! common /mapc/imap(maxpl),NCRS(MAXPL) +! dimension ccmap(maxpl) + + DIMENSION LISTM(1000),listt(1600,4),nlf(4),icomp(4),xnear(4) + dimension xnearkp(4) + + + DATA ITIME/0/ + + IF(.NOT. ALLOCATED(CCMAP)) THEN + ALLOCATE (CCMAP(MAXPL)) + ENDIF + call WcursorShape(CurHourGlass) + + +!ipk feb94 change logic to allow 4 passes and check angles +! +! initialize range +! + ict=0 +!ipk sep97 xnears=xnearo + xnearo=xnears + xnearp=xnears + xnearf=xnears + write(90,*) 'working node',m + do nang=1,4 + XNEAR(nang)=XNEARS + xnearkp(nang)=0. + icomp(nang)=0 + enddo +! +! set imap to zero to start or -1 if no value +! +!IPK MAY97 INITIALIZE COUNTER + ntime=0 + 220 continue + + do n=1,nmap + if(cmap(n,1) .lt. vdx) then + imap(n)=-1 + elseif(val(n) .lt. -9000.) then + imap(n)=-1 + else + imap(n)=0 + endif + enddo +! +!ipk sep97 Sortlist of map points in increasing x except for single poin +! + IF(ielvsw .EQ. 0 .AND. ISWT .NE. 1) THEN +!ipk mar99 + do n=1,nmap + ccmap(n)=cmap(n,1) + enddo + CALL SORTMAP(CCMAP,NCRS,NMAP,IMAP) + ielvsw=1 +! DO N=1,NMAP +! WRITE(90,*) N,CMAP(NCRS(N),1),IMAP(NCRS(N)) +! ENDDO + ENDIF +!ipk sep97 end addition +! +! initialize list and completeness test +! + do nang=1,4 + icomp(nang)=0 + do n=1,1600 + listt(n,nang)=0 + enddo + enddo +! +! start processing +! + 280 continue +! +! check for completeness intialize counter +! + ict=0 + do nang=1,4 + if(icomp(nang) .eq. 0) then + nlf(nang)=0 + else + ict=ict+1 + endif + enddo +! +! if ict = 4 we are done +! + if(ict .lt. 4) then +! +! loop through map points +! +!ipk sep97 change loop + do nang=1,4 + nlf(nang)=0 + icomp(nang)=0 + enddo + IFND=0 + NN=0 + 285 NN=NN+1 + IF(NN .GT. NMAP) GO TO 305 +! DO 300 NNN=1,NMAP + N=NN + if(val(n) .lt. -9990.) go to 285 + IF(ISWT .EQ. 1) GO TO 297 + IF(IFND .EQ. 1) GO TO 295 + IF(XNEARO .LT. XNEARF) THEN + IFND=1 + GO TO 294 + ENDIF + +!IPK SEP97 START SEARCH + NLOCA=NMAP/2 + NSTEPS=NMAP/2 +290 CONTINUE + +! WRITE(90,*) 'elvset-164',NLOCA +! write(90,*) NSTEPS,NCRS(NLOCA) +! WRITE(90,*) CMAP(NCRS(NLOCA),1),CORD(M,1),XNEAR(1) + NCUR=NCRS(NLOCA) +! IF(CMAP(NCUR,1) .GT. 1.E34) THEN +! WE ARE AOUT OF RANGE +! GO TO +! ENDIF + IF(CMAP(NCUR,1)+XNEARO .LT. CORD(M,1).and. val(ncur) .gt. -9000.) THEN +! still below increase nloca + NSTEPS=NSTEPS/2 + IF(NSTEPS .EQ. 0) THEN +! we are there + NLOCA=NLOCA-1 + IFND=1 + GO TO 293 + ENDIF + NLOCA=NLOCA+NSTEPS + GO TO 290 + ELSE +! too great decrease nloca + NSTEPS=(NSTEPS+1)/2 + NLOCA=NLOCA-NSTEPS + IF(NLOCA .LE. 0) THEN + NLOCA=0 + IFND=1 + GO TO 293 + ENDIF + GO TO 290 + ENDIF + 293 NLOCS=NLOCA +! WRITE(90,*) 'elvset-201',NLOCA,NSTEPS,NCRS(NLOCA) +! WRITE(90,*) CMAP(NCRS(NLOCA),1),CORD(M,1),XNEAR(1) + GO TO 295 + 294 NLOCA=NLOCS + 295 CONTINUE + NLOCA=NLOCA+1 + if(nloca .gt. nmap) go to 305 + NCUR=NCRS(NLOCA) +! +! test to see if we are past area +! + if(ncur .eq. 0) go to 305 + IF(CMAP(NCUR,1)-XNEARP .GT. CORD(M,1)) GO TO 305 + if(val(ncur) .lt. -9000.) go to 295 + N=NCUR + 297 CONTINUE + d1=cmap(n,1)-cord(m,1) + d2=cmap(n,2)-cord(m,2) +!ipk may97 IF(ABS(D1) .LT. XNEAR(1)) THEN +!ipk may97 IF(ABS(D2) .LT. XNEAR(1)) THEN + IF(ABS(D1) .LT. max(XNEARO,xnearp)) THEN + IF(ABS(D2) .LT. max(XNEARO,xnearp)) THEN + if(d1 .lt. 0) then + if(d2 .lt. 0) then + nang=3 + if(abs(d1) .lt. xnear(NANG) .and. & + & abs(d2) .lt. xnear(NANG)) then + imap(n)=3 + else + imap(n)=-1 + go to 300 + endif + else + nang=2 + if(abs(d1) .lt. xnear(NANG) .and. & + & abs(d2) .lt. xnear(NANG)) then + imap(n)=2 + else + imap(n)=-1 + go to 300 + endif + endif + elseif(d2 .lt. 0) then + nang=4 + if(abs(d1) .lt. xnear(NANG) .and. & + & abs(d2) .lt. xnear(NANG)) then + imap(n)=4 + else + imap(n)=-1 + go to 300 + endif + else + nang=1 + if(abs(d1) .lt. xnear(NANG) .and. & + & abs(d2) .lt. xnear(NANG)) then + imap(n)=1 + else + imap(n)=-1 + go to 300 + endif + endif +! +! set to skip out if out of range +! + else + imap(n)=-1 + go to 300 + endif + else + imap(n)=-1 + go to 300 + endif +! +!IPK SEP97 END MAJOR REWRITE +! +! save value if total less then 50 +! + NLF(NANG)=NLF(NANG)+1 + IF(NLF(NANG) .LT. 101) THEN + LISTT(NLF(NANG),NANG)=N + ENDIF + 300 CONTINUE + GO TO 285 + 305 CONTINUE +! +! now reset range if we need to +! + ictz=0 +! write(90,*) ' ' +! write(90,*) ntime +! write(90,*) 'nlf',nlf +! write(90,*) 'xnear',xnear + do nang=1,4 + if(nlf(nang) .gt. 150) then +! rat=sqrt((45.+ntime*3.)/nlf(nang)) +! if(rat .lt. 0.2) rat=0.2 + rat=sqrt(0.1+0.06*ntime) + xnearkp(nang)=xnear(nang) + xnear(nang)=xnear(nang)*rat +!ipk may97 elseif(nlf(nang) .eq. 0) then + elseif(nlf(nang) .lt. 2) then +!ipk may97 if(xnear(nang) .eq. xnears) then + ictz=ictz+1 +!ipk may97 else +!ipk may97 icomp(nang)=1 +!ipk may97 endif + else + icomp(nang)=1 + endif + enddo + xnearf=xnearo +! write(90,*) 'ntime,ictz,xnear',ntime,ictz +! write(90,*) 'icomp',icomp +! write(90,*) 'xneara',xnear + if(ictz .gt. 0) then + do nang=1,4 + if(nlf(nang) .lt. 2) then + if(xnearkp(nang) .gt. 0.) then + xnear(nang)=xnearkp(nang) + else + xnear(nang)=xnear(nang)*1.5 + endif + if(nang .eq. 2 .or. nang .eq. 3) then + if(xnear(nang) .gt. xnearo) xnearo=xnear(nang) + endif + if(nang .eq. 1 .or. nang .eq. 4) then + if(xnear(nang) .gt. xnearp) xnearp=xnear(nang) + endif + endif +!ipk may97 xnears=xnears*2. +! write(90,*) 'nang,xnear',nang,xnear(nang) +! write(90,*) 'xnearo,xnearp',xnearo,xnearp + + enddo +!ipk sep97 xnears=xnears*2. + ntime=ntime+1 + if(ntime .lt. 12) go to 220 +! go to 220 +! endif + endif +! +! go back and try again +! +!ipk may97 go to 280 + ntime=ntime+1 + if(ntime .lt. 16) go to 280 + endif +! +! finished now compact list +! + do nang=1,4 +! write(90,*)'nang',nang,nlf(nang),xnear(nang) + enddo + nlg=0 + do nang=1,4 + nlim=nlf(nang) +!ipksep97 if(nlim .eq. 0) then +!ipksep97 nlim=50 +!ipk sep97 endif +!ipk sep97 chnage limit and act only if nlim > 0 +! write(90,*) 'nlim',nlim + if(nlim .gt. 1600) nlim=1600 + if(nlim .gt. 0) then + do nlgg=1,nlim + if(listt(nlgg,nang) .gt. 0) then + if(nlg .eq. 1000) nlg=999 + nlg=nlg+1 + listm(nlg)=listt(nlgg,nang) + endif + enddo + endif + enddo +! write(90,*) nlg +! write(90,*) m,(listm(n),n=1,nlg),xnear +!ipk feb94 end changes +! do n=1,nmap +! write(90,*) n,cmap(n,1),cmap(n,2),val(n) +! enddo +! write(90,*) 'LIST MAP POINTS NEAR ',M,CORD(M,1),CORD(M,2) +! DO N=1,NLG +! WRITE(90,*) listm(n),CMAP(LISTM(N),1),CMAP(LISTM(N),2),val(listm(n)) +! ENDDO +! read(*,*) n234 + +!IPK JUL98 CALL GRIDIN(M,SOLN,LISTM,NLG) + XXX=CORD(M,1) + YYY=CORD(M,2) + CALL GRIDIN(XXX,YYY,SOLN,LISTM,NLG) + IF(IRMAIN .EQ. 1) then + call WcursorShape(CurArrow) + RETURN + endif + WD(M)=SOLN + FPN = WD(M)*10. + X = CORD(M,1) + Y = CORD(M,2) - .11 + IF(X .GT. 0. .AND. X .LT. HSIZE .AND. & + & Y .GT. 0. .AND. Y .LT. 7.5) THEN + CALL RRED + CALL NUMBR(X,Y,0.1,FPN,0.0,-1) + ENDIF +! call WcursorShape(0) + call WcursorShape(CurArrow) + RETURN + END \ No newline at end of file diff --git a/src/EVENT.F90 b/src/EVENT.F90 new file mode 100644 index 0000000..64f956c --- /dev/null +++ b/src/EVENT.F90 @@ -0,0 +1,2057 @@ +!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR status + SUBROUTINE gim_an_event(ix,iy,iflag) + + USE WINTERACTER + + include 'd.inc' + + COMMON /TMPLIST/ ilisttmp(100),INREORD + +! THIS BLOCK IS IN BLK1.F90 + + COMMON /VIEWS/ HANG,VANG,VRTSCAL,HANGOLD,VANGOLD,VRTORIG,IASPCT + + + INTEGER :: NP,NE,NHTP,NMESS,NBRR,IPSW,IRMAIN,ISCRN,icolon,nhtpsv,nmessv,nbrrsv,ntempin,IPW2 + + +!ipk jan01 Expand IPSW to 10 + CHARACTER*6 DESCR + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout + COMMON /HEDS1/ NWINDWS,IWNDWS(10),ISCRNS(10),DESCR(10),ICRSR(10) + + REAL HSIZE + COMMON /SSIZE/ HSIZE + + REAL :: RSCLX,RSCLY,HRAD,VRAD + + real*8 xms,yms + INTEGER :: MOUSEX, MOUSEY, MBUTTON, ITIME, IWINDOW,MENUS + INTEGER :: IMP,IIN,IOT,IOT1,impf,IBAKON,N,NDM,IDRAG,IYES,ITRIAN,INFO(3) + + LOGICAL :: OPENED,EXISTS + CHARACTER(LEN=255) :: FNAME,FNAMGE,FNAMRM,FNAMEB + CHARACTER(LEN=3) :: SUB,SUB1 + CHARACTER(LEN=4) :: SUB2 + character(len=43) :: zoomh + CHARACTER(LEN=50) :: STBAR + character(len=1000) :: header + CHARACTER(len=10) :: DATEC,TIMEC,ZONEC + INTEGER :: DTI(8) + CHARACTER(LEN=256) :: FILTER + CHARACTER(LEN=72) :: CRSTIT + REAL :: XX1,XX2,XX3,XX4,XX5,XX6 + + COMMON /UNITS/IOT,IOT1 + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + TYPE(WIN_MESSAGE) :: MESSAGE + TYPE (WIN_FONT) :: FONT + +! Define a common block with background file names + + INCLUDE 'BFILES.I90' + + DATA IBAKON/1/ + DATA rsclx,rscly/100.0,100./,IDOWN/0/ + +! +! Interacter graphics input routine +! Shows the mouse, collects mouse location and character +! on the mouse-click or on a keystroke + + + character*1 iflag + + CALL WMenuSetState(ID_ITEM11,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM12,ItemEnabled,0) + + nhtpsv=nhtp + nmessv=nmess + nbrrsv=nbrr + 100 continue + DO I=1,255 + FNAME(I:I)=' ' + ENDDO + MENUS=0 + idrag=0 + 101 continue + CALL WMessage(ITYPE, MESSAGE) + SELECT CASE (ITYPE) + CASE (KeyDown) ! Key pressed + KEY = MESSAGE%VALUE1 + MOUSEX = MESSAGE%X + MOUSEY = MESSAGE%Y + XM=MESSAGE%GX + YM=MESSAGE%GY + IFLAG=CHAR(KEY) +! WRITE(90,*) 'KEY PRESSED',KEY +! WRITE(90,'(A)') 'KEY PRESSED',IFLAG,menus + CASE (MenuSelect) ! Menu item selected + INREORD=0 + DO J=1,100 + ilisttmp (j)=0 + ENDDO + SELECT CASE (MESSAGE%VALUE1) + CASE (ID_ITEM11) ! New option + IMP=0 + IIN=0 + CASE (ID_ITEM12) ! Open option + IMP=0 + IIN=0 + CALL IgrUnits(0.,0.,HSIZE,8.0) + + CALL WSelectFile(ID_STRING1,PromptOn+DirChange,FNAME,'Load Map File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + IF(SUB .EQ. 'map') then + IMP=9 + OPEN(9,FILE=FNAME,STATUS='OLD') + ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then + IMP=94 + OPEN(94,FILE=FNAME,STATUS='OLD') + ELSEIF(SUB .EQ. 'mpb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read') + ELSEIF(SUB .EQ. 'mbb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read') + ENDIF + ENDIF + + FILTER ="Network Files|*.rm1;*.geo;*.gfg;*.bin;*.ele|Rm1 file -- *.rm1|*.rm1|Geo file -- *.geo|*.geo|GFGEN file -- *.gfg|*.gfg|GFGEN bin file -- *.bin|*.bin|Rst file -- *.rst|*.rst|TRIANG file -- *.ele|*.ele|MESH2D file -- *.2dm|*.2dm|All files|*.*|" + CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + CALL SHORTNAME(FNAME,FNAMEDISP) + + ITRIAN=0 + IF(SUB .EQ. 'rm1') then + IIN = 10 + OPEN(10,FILE=FNAME,STATUS='OLD') + ELSEIF(SUB .EQ. 'ele') then + IIN=10 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ') + ITRIAN=1 + IGFG=0 + FNAMKEP=FNAME + ELSEIF(SUB .EQ. 'rst') then + IIN=11 +! OPEN(IIN ,FILE=FNAME,STATUS='OLD',access='transparent') + OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') +! OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='BINARY') + ELSE + IIN=12 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary') + ENDIF + ENDIF + + CASE (ID_NMAP) + CALL WSelectFile(ID_STRING1,PromptOn,FNAME,'Load Map File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + IF(SUB .EQ. 'map') then + IMP=9 + OPEN(9,FILE=FNAME,STATUS='OLD') + ELSEIF(SUB .EQ. 'shp') then + IMP=113 + OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + SUB='DBF' + CALL ADDSUB(FNAME,SUB) + OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then + IMP=94 + OPEN(94,FILE=FNAME,STATUS='OLD') + ELSEIF(SUB .EQ. 'mpb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read') + ELSEIF(SUB .EQ. 'mbb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read') + ENDIF + ENDIF + CALL RDMAP(2,IMP,0,0) + CALL PLOTOT(0) + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv + call hedr + GO TO 100 + +!IPK MAY03 LOAD ADDITIONAL FILES + + CASE (ID_LOADRM1) + +! Load additional RM1 files + + FILTER ="Network Files|*.rm1;*.geo;*.gfg;*.bin;*.ele|Rm1 file -- *.rm1|*.rm1|Geo file -- *.geo|*.geo|Gfgen file -- *.gfg|*.gfg|GFGEN bin file -- *.bin|*.bin|Rst file -- *.rst|*.rst|TRIANG file -- *.ele|*.ele|All files|*.*|" + CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + GO TO 200 + ELSE + GO TO 250 + ENDIF + 200 CONTINUE + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + CALL SHORTNAME(FNAME,FNAMEDISP) + + ITRIAN=0 + IF(SUB .EQ. 'geo') then + IIN=12 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ') + FNAMKEP=FNAME + IGFG=0 + ELSEIF(SUB .EQ. 'gfg') then + IIN = 10 + IGFG=1 + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ELSEIF(SUB .EQ. '2dm') then + IIN = 10 + IGFG=3 + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ELSEIF(SUB .EQ. 'bin') then + IIN=12 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') + IGFG=2 + ELSEIF(SUB .EQ. 'rst') then + IIN=11 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') + IGFG=0 + ELSEIF(SUB .EQ. 'ele') then + IIN=10 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ') + ITRIAN=1 + IGFG=0 + FNAMKEP=FNAME + ELSE + IIN = 10 + IGFG=0 + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ENDIF + ITOTFIL=ITOTFIL+1 + FNAMEOUT(ITOTFIL)=FNAME + CALL GETNEWFIL(IIN,IGFG,ITRIAN,0) + + fname=' ' + GO TO 100 + + CASE (ID_CRSF) + +! Load cross-section files + + ICRIN=0 + FILTER ="Cross-Section files -- *.crs|*.crs|All files -- |*.*|" + CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Cross-Section File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + GO TO 210 + ELSE + GO TO 250 + ENDIF + 210 CONTINUE + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + ICRIN = 23 + OPEN(ICRIN,FILE=FNAME,STATUS='OLD',ACTION='READ') + CALL GETCRS(CRSTIT) + + fname=' ' + GO TO 100 + + +! Load group number files + + IGRPIN=0 + FILTER ="Group number files -- *.txt|*.txt|All files -- |*.*|" + CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Group Number File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + GO TO 215 + ELSE + GO TO 250 + ENDIF + 215 CONTINUE + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + IGRP = 28 + OPEN(IGRP,FILE=FNAME,STATUS='OLD',ACTION='READ') + CALL GETGRP + + fname=' ' + GO TO 100 + + CASE (ID_SAVCRS) + ICROUT=24 + INQUIRE(24, OPENED=OPENED) + if(.not. opened) then + Filter='CRS file -- *.crs|*.crs|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Cross Section File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(ICROUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') + ELSE + GO TO 250 + ENDIF + ENDIF + REWIND ICROUT + CALL WRTCRS(ICROUT,CRSTIT) + fname=' ' + GO TO 100 + + CASE (ID_SAVGP) + IGRPOUT=29 + INQUIRE(29, OPENED=OPENED) + if(.not. opened) then + Filter='TXT file -- *.txt|*.txt|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Group Number File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(IGRPOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') + ELSE + GO TO 250 + ENDIF + ENDIF + REWIND IGRP + CALL WRTGP + fname=' ' + GO TO 100 + + CASE (ID_ITEM13) ! Save option +! WRITE(90,*) 'WINTER AT ITEM13' + INQUIRE(20, OPENED=OPENED) + if(.not. opened) then + Filter='Network Files|*.rm1;*.gfg;*.ele|Rm1 file -- *.rm1|*.rm1|gfg file -- *.gfg|*.gfg|TRIANG file -- *.ele|*.ele|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + CALL SHORTNAME(FNAME,FNAMEDISP) +! SUB='rm1' +! CALL ADDSUB(FNAME,SUB) + +! WRITE(90,*) 'IN ITEM13',IOT +! WRITE(90,'(A)') FNAME,SUB + IOT = 20 + FNAMRM=FNAME + ITRIANOUT=0 + if(sub .eq. 'rm1') then + igfgsw=0 + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') +! +! Check if file cords format to be short or long +! +! + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save'//& + CHAR(13)//'coordinates in long format?' ,& + 'Coordinate save format') +! +! If answer 'No', use short format +! + IF (WInfoDialog(4) .EQ. 2) then + ntempin=0 + else + ntempin=2 + END IF +! + call wrtout(1) + CLOSE (IOT) + OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') + elseif(sub .eq. 'ele') then + igfgsw=0 + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') + itrianout=1 + call wrtout(1) + DO L=255,1,-1 + IF(FNAME(L:L) .EQ. '.') THEN + FNAME(L+1:L+1)='n' + FNAME(L+2:L+2)='o' + FNAME(L+3:L+3)='d' + FNAME(L+4:L+4)='e' + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') + itrianout=2 + call wrtout(1) + GO TO 220 + ENDIF + ENDDO + 220 continue + CLOSE (IOT) + OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') + else + igfgsw=1 + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') + call wrtout(1) + CLOSE (IOT) + OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') + endif + ENDIF + if(iactvfil .le. 0) iactvfil=1 + FNAMEOUT(IACTVFIL)=FNAMRM + + else + + CALL GETSUB(FNAMRM,SUB) + + if(sub .eq. 'ele') then + FNAME=FNAMRM + igfgsw=0 + itrianout=1 + call wrtout(1) + DO L=255,1,-1 + IF(FNAME(L:L) .EQ. '.') THEN + FNAME(L+1:L+1)='n' + FNAME(L+2:L+2)='o' + FNAME(L+3:L+3)='d' + FNAME(L+4:L+4)='e' + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') + itrianout=2 + call wrtout(1) + GO TO 221 + ENDIF + ENDDO + 221 continue + ELSE + call wrtout(1) + ENDIF + CLOSE (IOT) + fnamrm=FNAMEOUT(IACTVFIL) + OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') + endif + GO TO 100 + + CASE (ID_ITEM14) ! Save option for binary + +! WRITE(90,*) 'WINTER AT ITEM14' + INQUIRE(22, OPENED=OPENED) +! WRITE(90,'(L2)') OPENED + if(.not. opened) then + Filter='Geo file -- *.geo|*.geo|GFGEN file -- *.bin|*.bin|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') +! WRITE(90,'(A)') FNAME + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + CALL SHORTNAME(FNAME,FNAMEDISP) +! SUB='geo' +! CALL ADDSUB(FNAME,SUB) + +! WRITE(90,*) 'IN ITEM14',IOT1 +! WRITE(90,'(A)') FNAME,SUB + IOT1=22 + FNAMGE=FNAME + if(sub .eq. 'geo') then + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary') + igfgswb=0 + +! add header to binary file + + DO J=11,1000 + HEADER(J:J)=' ' + ENDDO + HEADER(1:10)='RMAGEN ' + CALL DATE_AND_TIME(DATEC,TIMEC,ZONEC,DTI) + HEADER(11:20)=DATEC + HEADER(21:30)=TIMEC + HEADER(31:40)=ZONEC + WRITE(IOT1) HEADER + call wrtout(2) + + CLOSE (IOT1) + OPEN(IOT1 ,FILE=FNAMGE,STATUS='UNKNOWN',form='binary') + else + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='unformatted') + igfgswb=1 + call wrtout(2) + CLOSE (IOT1) + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='unformatted') + endif + ENDIF + else + +! add header to binary file + + DO J=11,1000 + HEADER(J:J)=' ' + ENDDO + HEADER(1:10)='RMAGEN ' + CALL DATE_AND_TIME(DATEC,TIMEC,ZONEC,DTI) + HEADER(11:20)=DATEC + HEADER(21:30)=TIMEC + HEADER(31:40)=ZONEC + WRITE(IOT1) HEADER + call wrtout(2) + CLOSE (IOT1) + OPEN(IOT1 ,FILE=FNAMGE,STATUS='UNKNOWN',form='binary') + endif + FNAMEOUT(IACTVFIL)=FNAMRM + GO TO 100 + + CASE (ID_ITEM18) ! Save As option + FILTER ="Bin Map file -- *.mpb|*.mpb|Bin Map file (no head) -- *.mbb|*.mbb|" + CALL WSelectFile(filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Map File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + if(SUB .eq. 'mpb') then + CALL ADDSUB(FNAME,SUB) + impf=93 + OPEN(IMPF ,FILE=fname,STATUS='unknown',form='unformatted') + + call wrtmap(1) + elseif(Sub .eq. 'map') then + impf=94 + OPEN(IMPF ,FILE=fname,STATUS='unknown',form='formatted') + call wrtmap(2) + endif + ENDIF + + go to 100 + + CASE (ID_LAYFL) ! input layer data + + CALL WSelectFile(ID_STRING9,PromptOn+DirChange,FNAME,'Load Layer File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='lay' + CALL ADDSUB(FNAME,SUB) + impf=103 + OPEN(103,FILE=FNAME,STATUS='OLD') + call rdlayer + ENDIF + + go to 100 + + CASE (ID_OUTLAY) ! Save layer data + + call wrtlayer + GO TO 100 + + CASE (ID_ITEM15) ! Save As option + + Filter='Network Files|*.rm1;*.gfg;*.ele|Rm1 file -- *.rm1|*.rm1|GFGEN file -- *.gfg|*.gfg|TRIANG file -- *.ele|*.ele|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + CALL SHORTNAME(FNAME,FNAMEDISP) +! SUB='rm1' +! CALL ADDSUB(FNAME,SUB) + FNAMRM=FNAME + IOT = 20 + + if(sub .eq. 'rm1') then + igfgsw=0 + itrianout=0 + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') + +! +! Check if file cords format to be short or long +! + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save'//& + CHAR(13)//'coordinates in long format?' ,& + 'Coordinate save format') + +! If answer 'No', use short format + + IF (WInfoDialog(4).EQ.2) then + ntempin=0 + else + ntempin=2 + END IF +! + call wrtout(1) + CLOSE (IOT) + OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') + + elseif(sub .eq. 'ele') then + igfgsw=0 + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') + itrianout=1 + call wrtout(1) + DO L=255,1,-1 + IF(FNAME(L:L) .EQ. '.') THEN + FNAME(L+1:L+1)='n' + FNAME(L+2:L+2)='o' + FNAME(L+3:L+3)='d' + FNAME(L+4:L+4)='e' + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') + itrianout=2 + call wrtout(1) + GO TO 225 + ENDIF + ENDDO + 225 continue + CLOSE (IOT) + OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') + + elseif(sub .eq. 'gfg') then + igfgsw=1 + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') + call wrtout(1) + CLOSE (IOT) + OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') + endif + IF(IACTVFIL .LE. 0) IACTVFIL=1 + FNAMEOUT(IACTVFIL)=FNAMRM + ENDIF + + go to 100 + + CASE (ID_ITEM16) ! Save As option + + Filter='Geo file -- *.geo|*.geo|GFGEN file -- *.bin|*.bin|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + CALL SHORTNAME(FNAME,FNAMEDISP) +! SUB='geo' +! CALL ADDSUB(FNAME,SUB) + FNAMGE=FNAME + IOT1 = 22 + if(SUB .EQ. 'geo') then + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary') + igfgswb=0 +! add header to binary file + + DO J=11,1000 + HEADER(J:J)=' ' + ENDDO + HEADER(1:10)='RMAGEN ' + CALL DATE_AND_TIME(DATEC,TIMEC,ZONEC,DTI) + HEADER(11:20)=DATEC + HEADER(21:30)=TIMEC + HEADER(31:40)=ZONEC + WRITE(IOT1) HEADER + call wrtout(2) + CLOSE (IOT1) + OPEN(IOT1 ,FILE=FNAMGE,STATUS='UNKNOWN',form='binary') + else + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='unformatted') + igfgswb=1 + call wrtout(2) + CLOSE (IOT1) + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='unformatted') + endif + FNAMEOUT(IACTVFIL)=FNAMRM + ENDIF + + go to 100 + + CASE (ID_SBIN) ! Save As special binary format + + CALL GETHDRTYP(IHDSWT) + + Filter='Geo file -- *.geo|*.geo|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + CALL SHORTNAME(FNAME,FNAMEDISP) +! SUB='geo' +! CALL ADDSUB(FNAME,SUB) + FNAMGE=FNAME + IOT1 = 22 + if(SUB .EQ. 'geo') then + if(ihdswt .eq. 1) then + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='UNFORMATTED', CONVERT='LITTLE_ENDIAN') + else + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='UNFORMATTED', CONVERT='BIG_ENDIAN') + endif + igfgswb=0 +! add header to binary file + + DO J=11,1000 + HEADER(J:J)=' ' + ENDDO + HEADER(1:10)='RMAGEN ' + CALL DATE_AND_TIME(DATEC,TIMEC,ZONEC,DTI) + HEADER(11:20)=DATEC + HEADER(21:30)=TIMEC + HEADER(31:40)=ZONEC + WRITE(IOT1) HEADER + call wrtout(2) + CLOSE (IOT1) + if(ihdswt .eq. 1) then + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='UNFORMATTED', CONVERT='LITTLE_ENDIAN') + else + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='UNFORMATTED', CONVERT='BIG_ENDIAN') + endif + endif + ENDIF + + go to 100 + CASE (ID_BKF) ! Read background option + + fname=' ' +!!! CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Background file') + FILTER ="Background Files|*.wmf;*.bmp;*.pcx;*.png;*.cgm;*.pic;*.jpg|wmf file -- *.wmf|*.wmf|bmp file -- *.bmp|*.bmp|pcx file -- *.pcx|*.pcx|png file -- *.png|*.png|jpeg file -- *.jpg|*.jpg|cgm file -- *.cgm|*.cgm|pic file -- *.pic|*.pic|" + CALL WSelectFile(FILTER,PromptOn+DirChange+Appendext,FNAME,'Load Background file') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + NBKFL=NBKFL+1 + BFNAME(NBKFL)=FNAME + IF(SUB .EQ. 'bmp') then + ISWBKFL(NBKFL) = 2 + ELSEIF(SUB .EQ. 'pcx') then + ISWBKFL(NBKFL) = 2 + ELSEIF(SUB .EQ. 'png' .or. sub .eq. 'jpg') then + ISWBKFL(NBKFL) = 2 + ELSE + ISWBKFL(NBKFL)=1 + ENDIF + write(90,*) 'nbkfl in winnew',nbkfl + write(90,*) ' iswbkfl',iswbkfl(nbkfl) + SUB1=SUB + SUB='ORG' + CALL ADDSUB(FNAME,SUB) + BFNAMR(NBKFL)=FNAME + INQUIRE (FILE = fname, EXIST = exists) + IF (.NOT. exists) THEN + IF(SUB1 .EQ. 'PNG' .or. SUB1 .EQ. 'png') SUB2='PNGW' + IF(SUB1 .EQ. 'JPG' .or. SUB1 .EQ. 'jpg') SUB2='JPGW' + CALL ADDSUB(FNAME,SUB2) + BFNAMR(NBKFL)=FNAME + INQUIRE (FILE = fname, EXIST = exists) + IF (.NOT. exists) THEN + IF(SUB2 .EQ. 'JPGW') THEN + SUB1='JGW' + CALL ADDSUB(FNAME,SUB1) + BFNAMR(NBKFL)=FNAME + ENDIF + ENDIF + INQUIRE (FILE = fname, EXIST = exists) + IF (.NOT. exists) THEN + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'ORG file does not exist!!'//CHAR(13)// & + 'Do you wish to create file and view image','Looking for ORG file') +! If answer 'Yes' set ifrmel to 0 +! + IF (WInfoDialog(4) .ne. 2) then + OPEN(104,FILE=FNAME,STATUS ='NEW', FORM ='FORMATTED') + BFNAMR(NBKFL)=FNAME + BFMINMAX(NBKFL,1) = - XS + BFMINMAX(NBKFL,2) = - YS + BFMINMAX(NBKFL,3) = HSIZE*TXSCAL - XS + BFMINMAX(NBKFL,4) = 7.50*TXSCAL - YS + WRITE(104,'(4G16.8)') (BFMINMAX(NBKFL,I),I=1,4) + CLOSE(104) + GO TO 100 + ELSE + NBKFL=NBKFL-1 + GO TO 100 + ENDIF + ENDIF + OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED') + READ(104,'(G16.8)') XX1 + READ(104,'(G16.8)') XX2 + READ(104,'(G16.8)') XX3 + READ(104,'(G16.8)') XX4 + READ(104,'(G16.8)') XX5 + READ(104,'(G16.8)') XX6 + call IGrFileInfo(BFNAME(NBKFL),INFO,3) + + BFMINMAX(NBKFL,1) = XX5 + BFMINMAX(NBKFL,2) = XX6+INFO(3)*XX4 + BFMINMAX(NBKFL,3) = XX5+INFO(2)*XX1 + BFMINMAX(NBKFL,4) = XX6 + + CLOSE(104) + GO TO 100 +! yes + + ENDIF + + OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED') + READ(104,'(4G16.8)') (BFMINMAX(NBKFL,J),J=1,4) + CLOSE(104) + + ENDIF + +! ipk jan10 + go to 100 + + CASE (ID_ICOPY) + CALL WSelectFile(ID_STRING6,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Copy File Name') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + FNAMEB=FNAME + SUB1='ORG' + CALL ADDSUB(FNAMEB,SUB1) + CALL OUTORG(FNAMEB) + if(sub .eq. 'jpg' .or. sub .eq. 'png' .or. sub .eq. 'pcx' .or. sub .eq. 'bmp') then +! call doplot(0) + call igrsaveimage(fname) + call doplot(0) + CALL HEDR + go to 100 + endif + + CALL IGrInit('HP') ! hardcopy only output +!ipk may10 + IYPIX=HSIZE/7.5*540 + IXPIX=540 + + IF(SUB .EQ. 'wmf') then + CALL IGrHardCopySelect(1,11) + CALL IGrHardCopyOptions(27,1) +!ipk may10 + CALL IGrHardCopyOptions(1,IYPIX) + + ELSEIF(SUB .EQ. 'emf') then + CALL IGrHardCopySelect(1,11) + CALL IGrHardCopyOptions(27,2) +!ipk may10 + CALL IGrHardCopyOptions(1,IYPIX) + ELSEIF(SUB .EQ. 'dxf') then + CALL IGrHardCopySelect(1,8) + ELSEIF(SUB .EQ. 'pcx') then + CALL IGrHardCopySelect(1,6) + CALL IGrHardCopyOptions(26,0) +!ipk may10 + CALL IGrHardCopyOptions(1,IYPIX) + CALL IGrHardCopyOptions(2,540) + ELSEIF(SUB .EQ. 'bmp') then + CALL IGrHardCopySelect(1,6) + CALL IGrHardCopyOptions(26,1) +!ipk may10 + IYPIX=IYPIX*1.5 + IXPIX=810 + CALL IGrHardCopyOptions(1,IYPIX) +!IPK MAY10 CALL IGrHardCopyOptions(2,540) + CALL IGrHardCopyOptions(2,IXPIX) + ELSEIF(SUB .EQ. 'png') then + CALL IGrHardCopySelect(1,6) + CALL IGrHardCopyOptions(26,3) + CALL IGrHardCopyOptions(23,24) +!ipk may10 + CALL IGrHardCopyOptions(1,IYPIX) + CALL IGrHardCopyOptions(2,540) + ELSEIF(SUB .EQ. 'jpg') then + CALL IGrHardCopySelect(1,6) + CALL IGrHardCopyOptions(23,24) + CALL IGrHardCopyOptions(26,4) +!ipk may10 + CALL IGrHardCopyOptions(1,IYPIX) + CALL IGrHardCopyOptions(2,540) + ELSEIF(SUB .EQ. 'cgm') then + CALL IGrHardCopySelect(1,9) +!ipk may10 + CALL IGrHardCopyOptions(1,IYPIX) + ELSEIF(SUB .EQ. 'pic') then + CALL IGrHardCopySelect(1,7) +!ipk may10 + CALL IGrHardCopyOptions(1,IYPIX) + CALL IGrHardCopyOptions(2,540) + ENDIF + CALL IGrHardcopy(fname) ! Start print manager + CALL IGrFillPattern(Solid) + + CALL IgrUnits(0.,0.,HSIZE,7.5) + if(menus .eq. 12 .or. menus .eq. 13) then + call conout(menus) + else + CALL CLSCRN + CALL PLOTOT(-1) ! plot graph + endif + call rblack + call frame(0.,0.,HSIZE,7.5) + CALL IGrHardcopy('S') ! Send data to the printer + CALL IGrInit('P') ! Turn graphics back on + CALL IGrFillPattern(Solid) + + CALL IgrUnits(0.,0.,HSIZE,8.0) + if(menus .eq. 12 .or. menus .eq. 13) then + call conout(menus) + else + CALL CLSCRN + CALL PLOTOT(0) ! plot graph + endif + CALL HEDR + call rblack + CALL IGrHardCopySelect(1,10) + GO TO 100 + ENDIF + +! ipk jan10 + go to 100 + + CASE (ID_CLIP) + + call igrsaveimage( ) + call doplot(0) + CALL HEDR + go to 100 + +! Clipboard save +!ipk may10 +! IYPIX=HSIZE/7.5*540 +! IXPIX=540 +! CALL IGrHardCopySelect(1,11) +! CALL IGrHardCopyOptions(27,2) +!ipk may10 +! CALL IGrHardCopyOptions(1,IYPIX) +! CALL IGrHardcopy() ! Start print manager +! CALL IGrFillPattern(Solid) + +! CALL IgrUnits(0.,0.,HSIZE,7.5) +! if(menus .eq. 12 .or. menus .eq. 13) then +! call conout(menus) +! else +! CALL CLSCRN +! CALL PLOTOT(-1) ! plot graph +! endif +! call rblack +! CALL IGrHardcopy('S') ! Send data to the printer +! CALL IGrInit('P') ! Turn graphics back on +! CALL IGrFillPattern(Solid) +! +! CALL IgrUnits(0.,0.,HSIZE,8.0) +! if(menus .eq. 12 .or. menus .eq. 13) then +! call conout(menus) +! else +! CALL CLSCRN +! CALL PLOTOT(0) ! plot graph +! endif +! CALL HEDR +! call rblack +! CALL IGrHardCopySelect(1,10) +! GO TO 100 + + CASE (ID_SAVSHP) ! Copy to shape file selected is selected + call saveshp + go to 100 + + CASE (ID_ITEM24) ! Print option is selected + CALL WHardcopyOptions(3) +! +! If the user clicked OK on page setup dialog then output the contents +! to the selected printer +! + IF (WinfoDialog(ExitButtonCommon).EQ.CommonOK) THEN + CALL IGrInit('HP') ! hardcopy only output + CALL IGrFillPattern(Solid) + + CALL IgrUnits(0.,0.,HSIZE,7.5) + CALL IGrHardcopy(' ') ! Start print manager + if(menus .eq. 12 .or. menus .eq. 13) then + call conout(menus) + else + CALL CLSCRN + CALL PLOTOT(-1) ! plot graph + endif + call rblack + CALL IGrFillPattern(0,0,0) + CALL IGrRectangle(0.,0.,HSIZE,7.5) + CALL IGrHardcopy('S') ! Send data to the printer + CALL IGrInit('P') ! Turn graphics back on + CALL IGrFillPattern(Solid) + + CALL IgrUnits(0.,0.,HSIZE,8.0) + if(menus .eq. 12 .or. menus .eq. 13) then + call conout(menus) + else + CALL CLSCRN + CALL PLOTOT(0) ! plot graph + endif + CALL HEDR + call rblack + CALL IGrFillPattern(0,0,0) + CALL IGrRectangle(0.,0.,HSIZE,7.5) + GO TO 100 + END IF + +! ipk jan10 + go to 100 + + CASE (ID_ITEM19) ! Demo option + SUB='DEM' + CALL RBLUE + CALL SYMBL(1.,5.,0.25,SUB,0.0,3) + CALL DEMOS + +! ipk jan10 + go to 100 + + CASE (ID_MMAP) + call mmap + go to 100 + +!IPK MAY03 + CASE (ID_SELRM1) ! Select different mesh file + IOLDACT=IACTVFIL + CALL PANELFIL + IF (IOLDACT .NE. IACTVFIL) THEN +! Resave current file + + IFILOUT=IOLDACT+50 + CALL WRTFIL(IFILOUT) + CALL LOADFIL + ENDIF + GO TO 100 +!IPK MAY03 + CASE (ID_ADDMESH) ! Select file FOR MESH ADDITION + IOLDACT=IACTVFIL + CALL PANELFIL + IF( IOLDACT .EQ. IACTVFIL) THEN + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Same file selected for addition'//& + CHAR(13)//'Process ended','SAME FILE') + GO TO 100 + ENDIF + IFILADD=IACTVFIL + IACTVFIL=IOLDACT + CALL ADDTOMESH(IFILADD,0) + GO TO 100 +!IPK MAY03 + CASE (ID_MRGMESH) ! Select file FOR MESH MERGING + IOLDACT=IACTVFIL + CALL PANELFIL + IF( IOLDACT .EQ. IACTVFIL) THEN + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Same file selected for merging'//& + CHAR(13)//'Process ended','SAME FILE') + GO TO 100 + ENDIF + IFILADD=IACTVFIL + IACTVFIL=IOLDACT + CALL ADDTOMESH(IFILADD,1) + GO TO 100 +!ipk may03 + CASE (ID_TRIANG) ! add a triangle of elements + CALL ADDTRIANG + GO TO 100 + + CASE (ID_ADDMAP) ! add a triangle of elements + CALL ADDMAP + GO TO 100 + + CASE (ID_3DVIEW) + CALL SETANGLE + I3DVIEW=1 + if(menus .eq. 12 .or. menus .eq. 13) then + CALL CLSCRN + call conout(menus) + else + call plotot(0) + endif + call hedr + GO TO 100 + + CASE (ID_VIEWANGLE) + + I3DVIEW=1 + CALL SETANGLE + CALL PLOTOT(0) + call hedr + GO TO 100 + + + +!ipk may03 + CASE (ID_QUAD) ! add a quad of elements + CALL ADDQUAD + GO TO 100 + +!ipk may03 + CASE (ID_SETUPLEV) ! setup levees + CALL RESETWHGT + GO TO 100 + + CASE (ID_SETTYPLEV) ! setup levees + CALL LEVSETTYP + GO TO 100 + + + CASE (ID_G1D) + CALL FORM1DEL + GO TO 100 +!ipk apr04 + CASE (ID_CREATM) ! create mesh from contours + CALL CREATM + GO TO 100 + + CASE (ID_OUTLINFL) ! read outline file + CALL RDOUTLIN + GO TO 100 + + CASE (ID_TESTOUT) ! read outline file + CALL CHECKPOLY + GO TO 100 + + CASE (ID_CGEN) ! generate contours + CALL CGEN + GO TO 100 + + CASE (ID_SPLITN) + CALL SPLITN + GO TO 100 + + CASE (ID_FORM999) + CALL FORM999(0,0,1) + GO TO 100 + + CASE (ID_FORM2D) + CALL FORM999(1,0,1) + GO TO 100 +!IPK FEB03 + + CASE (ID_TRIAN) + CALL TRIANG + GO TO 100 + + CASE (ID_SWMAP) + CALL SWMAP + GO TO 100 + + CASE (ID_SWRM1) + CALL SWRM1 + GO TO 100 + + CASE (ID_MAP) + CALL GRELV + GO TO 100 + + CASE (ID_SELPR) + CALL GETALLANGS + GO TO 100 + + CASE (ID_RVSDIAG) + CALL RVSDIAG + GO TO 100 + + CASE (ID_LOADELTLD) + CALL GETEQ + GO TO 100 + + CASE (ID_SHOWELTLD) + CALL SHOWEQ(0) + GO TO 100 + + CASE (ID_RESHOWELTLD) + CALL SHOWEQ(1) + GO TO 100 + + CASE (ID_ASSIGNELTLD) + CALL ASSIGNEQ + GO TO 100 + + CASE (ID_SAVELTLD) + CALL SAVEEQ + GO TO 100 + + CASE (ID_ITEM17) ! Exit option +!IPK SEP02 + call rquit(iyes) + if(iyes .ne. 1) go to 100 + MENUS=0 + CALL QUIT_PGM + CASE (ID_EXIT) ! Exit program (menu option) + call rquit(iyes) + if(iyes .ne. 1) go to 100 + MENUS=0 + CALL QUIT_PGM + + CASE (ID_NODEDATA) + CALL NODEDISP(0) + GO TO 101 + + CASE (ID_ELTDATA) + CALL ELTDISP(0) + GO TO 101 + + CASE (ID_EDLAY) + CALL LAYDISP + GO TO 101 + + CASE (ID_RESETRG) + CALL RESETREG + GO TO 101 + + CASE (ID_MOVMESH) + CALL MOVMESH + GO TO 101 + + CASE (ID_TRANSFORM) + CALL TRANSMESH + GO TO 101 + +!IPK SEP02 + CASE (ID_GETELM) + CALL GETELMNO + GO TO 101 + + CASE (ID_ATTACH) + CALL REATTACH + GO TO 101 + + CASE (ID_COMPLEX) + CALL GNODE(2) + GO TO 101 + + CASE (ID_fillagap) + CALL JOINEL + GO TO 101 + + CASE (ID_GETSTRESSFIL) + CALL GETSTRESSFIL + GO TO 101 + + CASE (ID_NODE) + MENUS=2 + CASE (ID_DELM) + CALL DELETM(0) + go to 100 + CASE (ID_DELETELM) + CALL DELETEM + go to 100 + CASE (ID_ELTS) + MENUS=1 + CASE (ID_FILL) + CALL FILM(1) + call hedr + go to 100 + CASE (ID_FILLTR) + CALL FILLTR + call hedr + go to 100 + CASE (ID_JOIN) + CALL JOIN(1) + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv + call hedr + go to 100 + CASE (ID_JOINALL) + CALL JOINALL + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv + call hedr + go to 100 + CASE (ID_CRGRID) + CALL CRGRID + GO TO 100 + CASE (ID_CRSECT) + CALL CRSECT + GO TO 101 + CASE (ID_CRSCAL) + CALL COMPWGT + GO TO 101 + CASE (ID_CSLOC) + CALL GETCSLOC + GO TO 101 + CASE (ID_ORDR) + MENUS=3 + CASE (ID_ORDR1) + CALL ORDALL + GO TO 101 + CASE (ID_DCONTR) + MENUS=12 + CALL CONOUT(MENUS) + GO TO 101 + CASE (ID_CONTOPT) + MENUS=13 + CALL CONOUT(MENUS) + GO TO 101 +!ipk feb02 + CASE (ID_cdata) +! +! Create data for message file and display +! + CALL ELDAT + go to 101 + CASE (ID_CCLN) + MENUS=6 + CASE (ID_CHKCCLN) + CALL CHKLIN + GO TO 101 + CASE (ID_CSEC) + MENUS=7 + CASE (ID_ZIN) + MENUS=8 + iflag='z' + zoomh=' Zooming, click and drag to form rectangle' + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomh,0.,43) + go to 101 + CASE (ID_OUT2) + MENUS=8 + iflag='y' + CASE (ID_OUT4) + MENUS=8 + iflag='x' + CASE (ID_CHCK) + CALL CHKAREA + GO TO 101 + CASE (ID_FINDNODE) + CALL FINDNOD + GO TO 101 + CASE (ID_FINDELEM) + CALL FINDEL + GO TO 101 + CASE (ID_MCHCK) + CALL CHKAREA + GO TO 101 + CASE (ID_SMOOTHMAP) + CALL SMOOTHMP + GO TO 101 + CASE (ID_DRAG) + MENUS=8 + iflag='d' + idrag=1 + zoomh=' drag/pan , click right to end' + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomh,0.,30) + call WCursorShape(CurCrossHair) + go to 101 + CASE (ID_ROTATE) + MENUS=8 + iflag='d' + idrag=2 + zoomh=' rotate view , click right to end' + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomh,0.,30) + call WCursorShape(CurCrossHair) + go to 101 + CASE (ID_VROTATE) + MENUS=8 + iflag='d' + idrag=2 + zoomh=' rotate view , click right to end' + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomh,0.,30) + call WCursorShape(CurCrossHair) + go to 101 + CASE (ID_RSET) + MENUS=8 + iflag='w' + CASE (ID_PLEFT) + MENUS=8 + iflag='v' + CASE (ID_PRIGHT) + MENUS=8 + iflag='u' + CASE (ID_PUP) + MENUS=8 + iflag='t' + CASE (ID_PDOWN) + MENUS=8 + iflag='s' + CASE (ID_IDRWT) + + DO + call wdialogload(IDD_DIALOG06) + + call wdialogputcheckbox(IDF_RADIO1,IPSW(1)) + call wdialogputcheckbox(IDF_RADIO2,IPSW(2)) + call wdialogputcheckbox(IDF_RADIO3,IPSW(4)) +! call wdialogputcheckbox(IDF_RADIO4,IPSW(3)) +! call wdialogputcheckbox(IDF_RADIO5,IPSW(9)) + call wdialogputcheckbox(IDF_RADIO6,IPSW(5)) + call wdialogputcheckbox(IDF_RADIO7,IPSW(7)) + call wdialogputcheckbox(IDF_RADIO8,IPSW(6)) + call wdialogputcheckbox(IDF_RADIO19,IPSW(15)) + call wdialogputcheckbox(IDF_RADIO9,IPSW(8)) +!ipk jan01 + call wdialogputcheckbox(IDF_RADIO10,IPSW(10)) +!ipk oct02 + call wdialogputcheckbox(IDF_RADIO11,IPSW(11)) + call wdialogputcheckbox(IDF_RADIO12,IPSW(12)) + call wdialogputcheckbox(IDF_RADIO13,IPSW(13)) +! call wdialogputcheckbox(IDF_RADIO17,IPSW(14)) + IF(IPSW(3) .EQ. 1) THEN + call wdialogputradiobutton(IDF_RADIO4) + ELSEIF(IPSW(9) .EQ. 1) THEN + call wdialogputradiobutton(IDF_RADIO5) + ELSEIF(IPSW(14).EQ. 1) THEN + call wdialogputradiobutton(IDF_RADIO17) + ELSE + call wdialogputradiobutton(IDF_RADIO18) + ENDIF + IF(IPW1 .EQ. 1) THEN + call wdialogputradiobutton(IDF_RADIO14) + ELSEIF(IPW1 .EQ. 2) THEN + call wdialogputradiobutton(IDF_RADIO15) + ELSEIF(IPW1 .EQ. 3) THEN + call wdialogputradiobutton(IDF_RADIO16) + ENDIF + call wdialogputreal(IDF_REAL1,WIDEL) + call wdialogputreal(IDF_REAL2,WIDSCL) + + CALL WDialogSelect(IDD_DIALOG06) + CALL WDialogShow(-1,-1,0,Modal) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + call wdialoggetcheckbox(IDF_RADIO1,IPSW(1)) + call wdialoggetcheckbox(IDF_RADIO2,IPSW(2)) + call wdialoggetcheckbox(IDF_RADIO3,IPSW(4)) + call wdialoggetcheckbox(IDF_RADIO4,IPSW(3)) + call wdialoggetcheckbox(IDF_RADIO5,IPSW(9)) + call wdialoggetcheckbox(IDF_RADIO6,IPSW(5)) + call wdialoggetcheckbox(IDF_RADIO7,IPSW(7)) + call wdialoggetcheckbox(IDF_RADIO8,IPSW(6)) + call wdialoggetcheckbox(IDF_RADIO8,IPSW(15)) + call wdialoggetcheckbox(IDF_RADIO9,IPSW(8)) +!ipk jan01 + call wdialoggetcheckbox(IDF_RADIO10,IPSW(10)) +!ipk oct02 + call wdialoggetcheckbox(IDF_RADIO11,IPSW(11)) + call wdialogGetcheckbox(IDF_RADIO12,IPSW(12)) + call wdialogGetcheckbox(IDF_RADIO13,IPSW(13)) +! call wdialoggetcheckbox(IDF_RADIO4,IPSW(3)) +! call wdialoggetcheckbox(IDF_RADIO5,IPSW(9)) +! call wdialogGetcheckbox(IDF_RADIO17,IPSW(14)) + call wdialoggetradiobutton(IDF_RADIO4,ipw2) + IPSW(3)=0 + IPSW(9)=0 + IPSW(14)=0 + IF(IPW2 .EQ. 1) THEN + IPSW(3)=1 + ELSEIF(IPW2 .EQ. 2) THEN + IPSW(9)=1 + ELSEIF(IPW2 .EQ. 3) THEN + IPSW(14)=1 + ENDIF +! IF(IPSW(3) .EQ. 1) THEN +! IPSW(9)=0 +! call wdialogputcheckbox(IDF_RADIO5,0) +! IPSW(14)=0 +! call wdialogputcheckbox(IDF_RADIO17,0) +! ENDIF +! IF(IPSW(9) .EQ. 1) THEN +! IPSW(3)=0 +! call wdialogputcheckbox(IDF_RADIO4,0) +! IPSW(14)=0 +! call wdialogputcheckbox(IDF_RADIO17,0) +! ENDIF +! IF(IPSW(14) .EQ. 1) THEN +! IPSW(9)=0 +! call wdialogputcheckbox(IDF_RADIO5,0) +! IPSW(3)=0 +! call wdialogputcheckbox(IDF_RADIO4,0) +! ENDIF + + IF(IPSW(5) .EQ. 1) THEN + IPSW(7)=0 + call wdialogputcheckbox(IDF_RADIO7,0) + ENDIF + call wdialoggetradiobutton(IDF_RADIO14,ipw1) + call wdialoggetreal(IDF_REAL1,WIDEL) + call wdialoggetreal(IDF_REAL2,WIDSCL) + MENUS=9 + endif + CALL PLOTOT(0) + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv + call hedr + + GO TO 100 + ENDDO + GO TO 100 + + CASE (ID_ITYPN) + MENUS=9 +! IQSW(1)=1-IQSW(1) +! IF(IQSW(1) .EQ. 1) THEN +! IQSW(2)=0 +! ENDIF + IQSW(1)=1 + IQSW(2)=0 + CALL WMenuSetState(ID_ITYPN,ItemChecked,1) + CALL WMenuSetState(ID_ITYPC,ItemChecked,0) + CALL WMenuSetState(ID_IGPC,ItemChecked,0) + CALL WMenuSetState(ID_IGPN,ItemChecked,0) + go to 100 + CASE (ID_ITYPC) + MENUS=9 +! IQSW(2)=1-IQSW(2) +! IF(IQSW(2) .EQ. 1) THEN +! IQSW(1)=0 +! ENDIF + IQSW(2)=1 + IQSW(1)=0 + CALL WMenuSetState(ID_ITYPC,ItemChecked,1) + CALL WMenuSetState(ID_ITYPN,ItemChecked,0) + CALL WMenuSetState(ID_IGPC,ItemChecked,0) + CALL WMenuSetState(ID_IGPN,ItemChecked,0) + go to 100 + CASE (ID_IGPN) + MENUS=9 + IQSW(1)=2 + IQSW(2)=0 + CALL WMenuSetState(ID_ITYPN,ItemChecked,0) + CALL WMenuSetState(ID_ITYPC,ItemChecked,0) + CALL WMenuSetState(ID_IGPN,ItemChecked,1) + CALL WMenuSetState(ID_IGPC,ItemChecked,0) + go to 100 + CASE (ID_IGPC) + MENUS=9 + IQSW(1)=0 + IQSW(2)=2 + CALL WMenuSetState(ID_ITYPC,ItemChecked,0) + CALL WMenuSetState(ID_ITYPN,ItemChecked,0) + CALL WMenuSetState(ID_IGPN,ItemChecked,0) + CALL WMenuSetState(ID_IGPC,ItemChecked,1) + go to 100 + CASE (ID_MAPOPD) + DO + call wdialogload(IDD_DIALOG05) + + call wdialogputcheckbox(IDF_CMAP0,ICOLON(1)) + call wdialogputcheckbox(IDF_CMAP1,ICOLON(2)) + call wdialogputcheckbox(IDF_CMAP2,ICOLON(3)) + call wdialogputcheckbox(IDF_CMAP3,ICOLON(4)) + call wdialogputcheckbox(IDF_CMAP4,ICOLON(5)) + call wdialogputcheckbox(IDF_CMAP5,ICOLON(6)) + call wdialogputcheckbox(IDF_CMAP6,ICOLON(7)) + call wdialogputcheckbox(IDF_CMAP7,ICOLON(8)) + call wdialogputcheckbox(IDF_CMAP8,ICOLON(9)) + call wdialogputcheckbox(IDF_CMAP9,ICOLON(10)) + call wdialogputcheckbox(IDF_CMAP10,ICOLON(11)) + call wdialogputcheckbox(IDF_CMAP11,ICOLON(12)) + + CALL WDialogSelect(IDD_DIALOG05) + CALL WDialogShow(-1,-1,0,Modal) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetcheckbox(IDF_CMAP0,ICOLON(1)) + call wdialoggetcheckbox(IDF_CMAP1,ICOLON(2)) + call wdialoggetcheckbox(IDF_CMAP2,ICOLON(3)) + call wdialoggetcheckbox(IDF_CMAP3,ICOLON(4)) + call wdialoggetcheckbox(IDF_CMAP4,ICOLON(5)) + call wdialoggetcheckbox(IDF_CMAP5,ICOLON(6)) + call wdialoggetcheckbox(IDF_CMAP6,ICOLON(7)) + call wdialoggetcheckbox(IDF_CMAP7,ICOLON(8)) + call wdialoggetcheckbox(IDF_CMAP8,ICOLON(9)) + call wdialoggetcheckbox(IDF_CMAP9,ICOLON(10)) + call wdialoggetcheckbox(IDF_CMAP10,ICOLON(11)) + call wdialoggetcheckbox(IDF_CMAP11,ICOLON(12)) + + ENDIF + CALL PLOTOT(0) + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv + call hedr + GO TO 100 + + ENDDO + GO TO 100 + + CASE (ID_DRAWD) + CALL PLOTOT(0) + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv + call hedr + + GO TO 100 + + CASE (ID_BSEL) + CALL PANEL012(IBAKON) + IF(IBAKON .EQ. 1) THEN +! FONT%IBCOL = TextWhite +! call WindowFontColour(0,7) + IRGB = WRGB(220,220,220) + + ELSE +! FONT%IBCOL = TextWhiteBold +! call WindowFontColour(0,15) + IRGB = WRGB(255,255,255) + ENDIF +! CALL WindowFont(FONT) + call clear_screen + call plotot(0) + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv + call hedr + + GO TO 100 + + CASE (ID_REGST) + DO N=1,NBKFL + IF(ISWBKFL(N) .NE. 0) THEN + CALL REGISTR(N) + ENDIF + ENDDO + GO TO 100 + +! CASE (ID_BACGDG) +! call clear_screen +! call plotot(0) +! nhtp=nhtpsv +! nmess=nmessv +! nbrr=nbrrsv +! call hedr + +! GO TO 100 + + + CASE (ID_HELP1) + call helps(0) +! call WHelpfile('rmagenv5.htm') + go to 100 +! MENUS=4 + CASE (ID_HELP2) + call RMINFO + go to 100 + + CASE (ID_ITEM20) + CALL GDIST + GO TO 100 + + CASE (ID_ITEM22) + CALL SELNODE(0) + menus=2 + GO TO 100 + + CASE (ID_ALLNODES) + CALL SELNODE(1) + menus=2 + GO TO 100 + + CASE (ID_UNUSNODES) + CALL SELNODE(2) + menus=2 + GO TO 100 + + CASE (ID_SELELTYP) + CALL SELNODE(3) + menus=2 + GO TO 100 + + CASE (ID_MOVGRP) + CALL SELNODE(4) + menus=2 + GO TO 100 + + CASE (ID_ITEM23) + CALL SELELT(0) + menus=0 + GO TO 100 + CASE (ID_SECGRP) + CALL SELELT(2) + menus=0 + GO TO 100 +! CALL HEDR + CASE (ID_SELAREA) + CALL SELELT(1) + menus=2 + GO TO 100 + CASE (ID_DISPTYP) + CALL FINDTYP + menus=2 + GO TO 100 + + CASE (ID_UNDO) + CALL UNDOACT + GO TO 100 + CASE (ID_UNDOS) + IFLAG='U' + CASE (ID_GOUTLIN) + CALL GOUTLIN + GO TO 100 + CASE (ID_XOUTLIN) + CALL OUTLINES + GO TO 100 + + END SELECT + +! +! Mouse button down - only process mouse button 1 events +! + CASE (MouseButDown) + if(menus .eq. 8) then + call rred + IF (MESSAGE%VALUE1.EQ.1) THEN +! +! Enable button up and mouse movement events +! + CALL WMessageEnable(MouseButUp, Enabled) +! CALL WMessageEnable(MouseMove , Enabled) + IDOWN = 1 +! +! Save the current cursor position +! + XPOS = MESSAGE%GX + YPOS = MESSAGE%GY +! For box plotting we must initialise Exclusive-OR plotting, +! set the fill type, draw the initial box and save the corner +! co-ordinates +! + CALL IGrPlotMode('E') +!DEC09 CALL IGrPlotMode(0) + if(idrag .eq. 0) then + CALL IGrFillPattern(0,0,0) + CALL IGrRectangle(XPOS, YPOS, MESSAGE%GX, MESSAGE%GY) + else + call Rgreen + CALL IGrJoin(XPOS, YPOS, MESSAGE%GX, MESSAGE%GY) + iflag='d' + endif + XOLD = MESSAGE%GX + YOLD = MESSAGE%GY + ELSE + call WCursorShape(CurArrow) + idrag=0 + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv + call hedr + menus=0 + ENDIF + GO TO 101 + ELSE + MBUTTON = MESSAGE%VALUE1 + ITIME = MESSAGE%VALUE2 + MOUSEX = MESSAGE%X + MOUSEY = MESSAGE%Y + XM=MESSAGE%GX + YM=MESSAGE%GY + IF(MBUTTON .EQ. 1) THEN + IFLAG='c' + ELSE + if(idrag .eq. 0) then + IFLAG='r' + else + idrag=0 + menus=0 + go to 101 + endif + ENDIF + ENDIF +! +! Mouse Movement +! + CASE (MouseMove) + IF (IDOWN.EQ.1) THEN +! +! For rectangle plotting we must redraw the last box to erase it from the +! screen. We then update the co-ordinates and draw the new rectangle +! + IF(IDRAG .EQ. 0) THEN + CALL IGrRectangle(XPOS, YPOS, XOLD, YOLD) + XOLD = MESSAGE%GX + YOLD = MESSAGE%GY + XSCRN= XOLD + YSCRN= YOLD + XMS = XSCRN*TXSCAL - XS + YMS = YSCRN*TXSCAL - YS + WRITE(STBAR,'(2g19.10)') XMS,YMS + CALL WindowOutStatusBar(2,STBAR) + WRITE(STBAR,'('' NP = ''i6,'' NE = ''i6)') NP,NE + CALL WindowOutStatusBar(3,STBAR) + WRITE(STBAR,'(2x,A48)') FNAMEDISP + CALL WindowOutStatusBar(5,STBAR) + xsiz=abs(xold-xpos) + ysiz=abs(yold-ypos) + slen=sqrt(xsiz**2+ysiz**2) + + shapef=hsize/8. + +!jan09 if(xsiz .lt. 1.25*ysiz) then +!jan09 xsiz=1.25*ysiz + if(xsiz .lt. shapef*ysiz) then + xsiz=shapef*ysiz +! xsiz=16./25.*slen + if(xold .lt. xpos) then + xold=xpos-xsiz + else + xold=xpos+xsiz + endif +!jan09 elseif(ysiz .lt. 0.80*xsiz) then +!jan09 ysiz=0.80*xsiz + elseif(ysiz .lt. xsiz/shapef) then + ysiz=xsiz/shapef +! ysiz=9./25.*slen + if(yold .lt. ypos) then + yold=ypos-ysiz + else + yold=ypos+ysiz + endif + endif + CALL IGrRectangle(XPOS, YPOS, xold,yold) + go to 101 + ELSE + CALL IGrJoin(XPOS, YPOS, XOLD, YOLD) + XOLD = MESSAGE%GX + YOLD = MESSAGE%GY + XSCRN= XOLD + YSCRN= YOLD + XMS = XSCRN*TXSCAL - XS + YMS = YSCRN*TXSCAL - YS + WRITE(STBAR,'(2g19.10)') XMS,YMS + CALL WindowOutStatusBar(2,STBAR) + WRITE(STBAR,'('' NP = ''i6,'' NE = ''i6)') NP,NE + CALL WindowOutStatusBar(3,STBAR) + WRITE(STBAR,'(2x,A48)') FNAMEDISP + CALL WindowOutStatusBar(5,STBAR) + CALL IGrJoin(XPOS, YPOS, XOLD, YOLD) + go to 101 + ENDIF + ELSE + XOLD = MESSAGE%GX + YOLD = MESSAGE%GY + XSCRN= XOLD + YSCRN= YOLD + XMS = XSCRN*TXSCAL - XS + YMS = YSCRN*TXSCAL - YS + WRITE(STBAR,'(2g19.10)') XMS,YMS + CALL WindowOutStatusBar(2,STBAR) + WRITE(STBAR,'('' NP = ''i6,'' NE = ''i6)') NP,NE + CALL WindowOutStatusBar(3,STBAR) + WRITE(STBAR,'(2x,A48)') FNAMEDISP + CALL WindowOutStatusBar(5,STBAR) + GO TO 101 + ENDIF + +! CASE (PushButton) ! Dialog button pressed +! IDBUTN = MESSAGE%VALUE1 +! IDFIELD = MESSAGE%VALUE2 + + CASE (MouseButUp) ! Mouse button up + IF(MENUS .NE. 8) THEN + MBUTTON = MESSAGE%VALUE1 + ITIME = MESSAGE%VALUE2 + MOUSEX = MESSAGE%X + MOUSEY = MESSAGE%Y + XM=MESSAGE%GX + YM=MESSAGE%GY + IF(MBUTTON .EQ. 1) THEN + IFLAG='c' + ELSE + IFLAG='r' + ENDIF + ELSE +! +! We disable movement and button up events +! + IDOWN = 0 + CALL WMessageEnable(MouseButUp, Disabled) +! CALL WMessageEnable(MouseMove , Disabled) + IF(IDRAG .EQ. 0) THEN + CALL IGrRectangle(XPOS, YPOS, XOLD, YOLD) + CALL IGrPlotMode('N') + CALL IGrRectangle(XPOS, YPOS, xold,yold) + XPOS1=MESSAGE%GX + YPOS1=MESSAGE%GY + menus=-8 + zoomh=' Click right if size OK' +! + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomh,0.,23) + GO TO 101 + ELSEIF(IDRAG .EQ. 1) THEN + menus=8 + CALL IGrJoin(XPOS, YPOS, XOLD, YOLD) + CALL IGrPlotMode('N') + CALL IGrJoin(XPOS, YPOS, xold,yold) + + XPOS1=MESSAGE%GX + YPOS1=MESSAGE%GY + xpos=xpos1-xpos + ypos=ypos1-ypos + xpos1=xpos+HSIZE + ypos1=ypos+8. + iflag='d' + call zoomnew(xpos,ypos,xpos1,ypos1,iflag) + zoomh=' Click right to end ' +! + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomh,0.,20) + iflag='r' + GO TO 101 + ELSE + menus=8 + CALL IGrJoin(XPOS, YPOS, XOLD, YOLD) + CALL IGrPlotMode('N') + CALL IGrJoin(XPOS, YPOS, xold,yold) + + XPOS1=MESSAGE%GX + YPOS1=MESSAGE%GY + xpos=xpos1-xpos + ypos=ypos1-ypos + zoomh=' Click right to end ' + + IF(ABS(XPOS) .GT. ABS(YPOS)) THEN + hrad=xpos/(YPOS1-4) + VRAD=0. + ELSE + vrad=-ypos/10. + HRAD=0. + ENDIF + call adjustang(hrad,vrad) +! + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomh,0.,20) + iflag='r' + GO TO 101 + ENDIF + ENDIF +! WRITE(90,*) 'MOUSE BUT',MOUSEX,MOUSEY,XM,YM +! WRITE(90,'(A)') 'MOUSE BUT',IFLAG + CASE (Expose) ! Window partly/wholly exposed + iflag='P' + IX = MESSAGE%X + IY = MESSAGE%Y + IWIDTH = MESSAGE%VALUE1 + IHEIGHT = MESSAGE%VALUE2 + call hedr + if(menus .eq. 12 .or. menus .eq. 13) then + call conout(menus) + else + call plotot(0) + endif + call hedr +!IPK MAY01 + IRDISP=1 + if(nmess .eq. 11) CALL PLTPT + + if(menus .eq. 13) CALL CONOUT(MENUS) + + go to 100 + CASE (Resize) ! Window resized + CALL IGrUnits(0.,0.,HSIZE,8.0) + iflag='P' + IWIDTH = MESSAGE%VALUE1 + IHEIGHT = MESSAGE%VALUE2 + call hedr + + if(menus .eq. 12 .or. menus .eq. 13) then + call conout(menus) + else + call plotot(0) + endif + call hedr +!IPK MAY01 + IRDISP=1 + if(nmess .eq. 11) CALL PLTPT + + if(menus .eq. 13) CALL CONOUT(MENUS) + + go to 100 + CASE (CloseRequest) ! Close window (e.g. Alt/F4) + IWINDOW = MESSAGE%WIN + if(iwindow .eq. 0) then +!IPK SEP02 + call rquit(iyes) + if(iyes .ne. 1) go to 100 + CALL QUIT_PGM ! Root window : exit program + else + CALL WindowCloseChild(iwindow) + DO I=1,NWINDWS + IF(IWINDOW .EQ. IWNDWS(I)) THEN + IWNDWS(i)=0 + ISCRNS(i)=0 +! This call removes the bitmap + CALL BACKP(3,I) + ENDIF + ENDDO + go to 100 + endif +! CASE (FieldChanged) ! Field change in modeless dialog +! IDFIELDOLD = MESSAGE%VALUE1 +! IDFIELDNEW = MESSAGE%VALUE2 + END SELECT +! WRITE(90,'(A)') 'endselect',IFLAG +! write(90,*) 'endselect',menus + menus =abs(menus) + IF(MENUS .GT. 0 .and. menus .lt. 8) THEN + CALL RMAGEN(MENUS,IMP,IIN,1,IOT,IOT1,NDM,ITRIAN,N2,M2) + ENDIF + if(menus .eq. 8) then + IF(IFLAG .EQ. 'w') THEN + HANG=0. + VANG=90 + VRTSCAL=100. + VRTORIG=0. + i3dview=0 + endif + if( IFLAG .EQ. 'r' .or.& + iflag .eq. 'y' .or.& + iflag .eq. 'x' .or.& + iflag .eq. 'w' .or.& + iflag .eq. 'v' .or.& + iflag .eq. 'u' .or.& + iflag .eq. 't' .or.& + iflag .eq. 's' ) then + call zoomnew(xpos,ypos,xpos1,ypos1,iflag) + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv + call hedr + endif +!IPK MAY01 + IRDISP=1 + if(nmess .eq. 11) CALL PLTPT + go to 100 + endif + IF(MENUS .EQ. 9) GO TO 101 + + + ix=xm*100. + iy=ym*100. +! call IMouseCursorHide() + 250 continue + nhtp=nhtpsv + nmess=nmessv + nbrr=nbrrsv +! WRITE(90,'(A)') 'end',IFLAG +! write(90,*) 'end',menus,nhtp,nhtpsv +! call clscrn +! call hedr + END SUBROUTINE diff --git a/src/EXP.rc b/src/EXP.rc new file mode 100644 index 0000000..af4f1ff --- /dev/null +++ b/src/EXP.rc @@ -0,0 +1,47 @@ +/////////////////////////////////////////////////// +// +// THIS FILE SHOULD NOT BE EDITED USING A TEXT +// EDITOR OR 3RD PARTY RESOURCE EDITOR, EXCEPT +// WHEN SPECIFICALLY INSTRUCTED BY I.S.S. +// +/////////////////////////////////////////////////// +// +// Winteracter exported resources. +// +// Exported : 08/May/2015 15:41:09 +// +/////////////////////////////////////////////////// +// +// To use this file it should be imported into +// your main resource script +// +/////////////////////////////////////////////////// + +/////////////////////////////////////////////////// +// +// Parameter Definitions +// +#define IDF_LABEL1 1001 +#define IDF_INTEGER1 1057 +#define IDD_SELELT 119 + +/////////////////////////////////////////////////// +// +// Dialogs +// +IDD_SELELT DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Select Element Number" +BEGIN + CONTROL "Element Number",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 26, 21, 54, 8 + CONTROL "0",IDF_INTEGER1,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 18, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 46, 40, 14 +END + +IDD_SELELT RCDATA +BEGIN +"[Ranges] \n" +,0 +END + diff --git a/src/FILE.F90 b/src/FILE.F90 new file mode 100644 index 0000000..72e835c --- /dev/null +++ b/src/FILE.F90 @@ -0,0 +1,160 @@ +! last update March 6 2000 add default values for CMAP + SUBROUTINE FILE(ientry) +! +! Define input output units +! + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + INCLUDE 'BFILES.I90' +!IPK APR94 + COMMON /RECOD/ IRECD,TSPC + common /cols/ ibakk,icolr,iblkk + COMMON /PAGE/ XL,XH,YL,YH +! + CHARACTER*80 LIND +!IPK APR94 CHARACTER*40 FNAM,FNAMB + CHARACTER*40 FNAM,FNAMB,FNAMC + CHARACTER*3 SUB + CHARACTER*1 ANS + LOGICAL*4 EXST,STATM + data ihere/0/ + if(ihere .eq. 1) return + mpnam='elt.mpb' + ibakk=8 + icolr=11 + iblkk= 9 + xl=0. + yl=0. + xh=HSIZE + yh=8.0 + ielvsw=0 + if(ientry .eq. 1) then + ihere=1 +! MAXPL=200000 + MAXELMP=100000 + + ALLOCATE (NOPEL(MAXELMP,3),XCEN(MAXELMP),YCEN(MAXELMP)& + ,RADS(MAXELMP) ,NKEY(MAXELMP),CMAP(MAXPL,2)& + ,XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL)) + + ALLOCATE (imap(maxpl),NCRS(MAXPL)) + RADS=0. + XCEN=0. + YCEN=0. + endif + +!ipk jan98 + OPEN(UNIT=90,FILE='messgen.out',STATUS='UNKNOWN', IOSTAT=iost) + if(iost .gt. 0) then + OPEN(UNIT=90,FILE='messgen1.out',STATUS='UNKNOWN', IOSTAT=iost) + if(iost .gt. 0) then + OPEN(UNIT=90,FILE='messgen2.out',STATUS='UNKNOWN', IOSTAT=iost) + if(iost .gt. 0) then + write(*,*) 'ERROR UNABLE TO OPEN MESSGEN.OUT FILE' + write(*,*) 'PRESS RETURN TO END' + read(*,'(I5)') junk + STOP + endif + endif + endif +!ipk jan98 + write(lind,6010) + 6010 format(' Compilation limits are') + call symbl(1.1,1.5,0.20,LIND,0.0,80) + write(lind,6110) maxe + 6110 FORMAT( ' Maximum elements =',i8) + call symbl(1.1,1.2,0.20,LIND,0.0,80) + write(lind,6111) maxp + 6111 FORMAT( ' Maximum nodes =',i8) + call symbl(1.1,0.9,0.20,LIND,0.0,80) + +! +! Open files +! + IBAK = 21 + OPEN(IBAK,FILE='ELT.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost) + if(iost .gt. 0) then + OPEN(IBAK,FILE='ELT1.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost) + if(iost .gt. 0) then + OPEN(IBAK,FILE='ELT2.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost) + if(iost .gt. 0) then + write(*,*) 'ERROR UNABLE TO OPEN ELT.BAK FILE' + write(*,*) 'PRESS RETURN TO END' + read(*,'(I5)') junk + STOP + endif + ENDIF + ENDIF +! OPEN(IBAK,FILE='ELT.BAK',STATUS='UNKNOWN',FORM='BINARY') + + IS11=94 + INQUIRE(FILE='startup.dat',EXIST= EXST) + IF(EXST) THEN + OPEN(IS11 ,FILE='startup.dat',STATUS='OLD',FORM='FORMATTED') + ELSE + IS11=0 + ENDIF + +! Initialize variables + NCLM=0 + +!ipk may94 add 2 lines below + XREF=0. + YREF=0. + MNP = MAXP + MEL = MAXE +!! uncertain call INITSIZ(0,0,1) + nmapf=1 + NSIGF=1 + DO I=1,MNP + XUSR(I) = -1.D20 + YUSR(I) = -1.D20 + CORD(I,1) = -1.D20 + CORD(I,2) = -1.D20 + WD(I) = -9999. + LAY(I) = -9999 + WIDTH(I) = 0.0 + SS1(I) = 0.0 + SS2(I) = 0.0 + WIDS(I) = 0.0 + WIDBS(I)=0. + SSO(I)=0. + INSKP(I) = 1 + INEW(I) = 0 +!ipk mar02 + lock(i)=0 + bs1(I)=0. + ENDDO +! + DO I=1,MEL + DO K=1,8 + NOP(I,K) = 0 + ENDDO +! + IEM(I) = 0 + IMAT(I) = 0 + THTA(I)=0. + XC(I) = -1.E20 + YC(I) = -1.E20 + IESKP(I) = -1 + ENDDO +! + MLIN = MAXLIN + DO I=1,MLIN + LINTYP(I) = -999 + ENDDO +!IPK OCT96 + DO I=1,10 + ICOLON(I)=1 + ENDDO + +!ipk mar00 define default values for CMAP + DO J=1,MAXPTS + CMAP(J,1) = -1.e20 + CMAP(J,2) = -1.e20 + enddo + + + RETURN + END diff --git a/src/FILL.F90 b/src/FILL.F90 new file mode 100644 index 0000000..67cdfd8 --- /dev/null +++ b/src/FILL.F90 @@ -0,0 +1,269 @@ +!IPK LAST UPDATE jAN 25 2001 INCREMENT NP FOR ALREADY EXISTING NODES IN NOP +!IPK LAST UPDATE APR 6 1998 + SUBROUTINE FILM(ISWT) +!june93 SUBROUTINE FILM(IFILL) +!- +! ISWT = 0 means read a value for IFILL +! ISWT = 1 means use a value of 1 for IFILL +! If IFILL = 1, use all unused node nos. for filling midside nodes +! If IFILL = 0, start midside node numbering with max node no. +!- + USE WINTERACTER + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + INCLUDE 'BFILES.I90' + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + INTEGER NUSED(MAXP) + +!IPK MAY02 + REAL*8 XX,YY + data itime/0/ + + if(itime .eq. 0) then + ifill=0 + itime=1 + endif +! call WcursorShape(1) + NHTPsv = nhtp + NMESSsv = nmess + NBRRsv = nbrr + NHTP = 0 + NBRR = 0 + NMESS=45 + CALL HEDR + NMESS = 19 + xprt=3.2 +! + IF(ISWT .EQ. 0) THEN + CALL GETINT(IFILL) + ELSE + IFILL=1 + ENDIF +! + +!- +!-.....FIND MISSING NODE NUMBERS..... +!- + NP0 = 0 + DO 10 I=1,MAXP + 10 NUSED(I) = 0 + DO 101 J = 1, NE + IF( IMAT(J) .EQ. 0 ) GO TO 101 + DO 100 K = 1, 8 + IF( NOP(J,K) .LE. 0) GOTO 100 + NUSED(NOP(J,K))=999 + 100 END DO + 101 END DO + +! Form list of elements connected to nodes + IERR=0 + CALL NDNECON(IERR) + IF(IERR .GT. 0) THEN + LIMIT=MAXECON + CALL NODERR(IERR,LIMIT) + GO TO 200 + ENDIF +!C- +!C-.....PUT INPUTS INTO PROPER LOCATIONS..... +!C- +! DO 140 J = 1, NE +! IF( IMAT(J) .EQ. 0 ) GO TO 140 +! IF( NOP(J,5) .GT. 0 ) GO TO 140 +! DO 130 K = 1, 4 +! IT(K) = NOP(J,K) +! NOP(J,K) = 0 +! 130 CONTINUE +! KK = 0 +! DO 135 K = 1, 8, 2 +! KK = KK + 1 +! NOP(J,K) = IT(KK) +! 135 CONTINUE +! 140 CONTINUE +!- +!-.....INSERT NEW NUMBERS..... +!- + NP0=0 + IF(IFILL .EQ. 0) NP0=NP + DO 190 J = 1, NE +!ipk apr98 IF( IMAT(J) .GT. 0 .AND. IMAT(J) .LT.901) THEN + IF(( IMAT(J) .GT. 0 .AND. IMAT(J) .LT.901) .or. & + & imat(j) .gt. 903) THEN + NCN = NCORN(J) + JN = J + 1 + DO 180 K = 2, NCN, 2 + if((imat(j) .gt. 995 .and. imat(j) .lt. 1999) .and. (k .eq. 4 .or. k .eq. 8) & + & ) go to 180 + NA = K - 1 + NB = MOD(K+1,NCN) + IF(NB .EQ. 0) NB=NCN + NA = NOP(J,NA) + NB = NOP(J,NB) + AA=(WD(NA)+WD(NB))/2. + AB=(WD1(NA)+WD1(NB))/2. + IF( NOP(J,K) .EQ. 0 ) THEN + IRDONE=0 +99 NP0 = NP0 + 1 + IF(NP0 .GT. MAXP) THEN + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Execution terminated, nodal limits exceeded. Backup written','LIMITS EXCEEDED') + CALL WRTOUT(0) + STOP + ENDIF + IF(INEW(NP0) .EQ. 1) GO TO 99 + IF (NUSED(NP0) .GT. 0) GOTO 99 + NOP(J,K) = NP0 + XX=(CORD(NA,1)+CORD(NB,1))/2. + YY=(CORD(NA,2)+CORD(NB,2))/2. + CORD(NP0,1)=XX + CORD(NP0,2)=YY + WD(NP0)=AA + WD1(NP0)=AB + WIDTH(NP0)=(WIDTH(NA)+WIDTH(NB))/2. + SS1(NP0)=(SS1(NA)+SS1(NB))/2. + SS2(NP0)=(SS2(NA)+SS2(NB))/2. + WIDS(NP0)=(WIDS(NA)+WIDS(NB))/2. + WIDBS(NP0)=(WIDBS(NA)+WIDBS(NB))/2. + BS1(NP0)=(BS1(NA)+BS1(NB))/2. + + + INEW(NP0) = 1 + IF(LOCK(NA) .EQ. 1 .AND. LOCK(NB) .EQ. 1) LOCK(NP0)=1 + XUSR(NP0) = XX*TXSCAL - XS + + YUSR(NP0) = YY*TXSCAL - YS + INSKP(NP0) = 0 +!SSO(N),- +!,BS1(N)-.....SEARCH FOR OTHER ELEMENT..... +!- +!ipk dec98 set a counter + ielct=0 + +!ipk0ct93 DO 170 JJ = JN, NE + + DO 170 JJJ=1,NDELM(NA) + JJ=NECON(NA,JJJ) +!IPK SEP02 DO 170 JJ = 1, NE +!ipkoct93 IF( IMAT(JJ) .GT. 0 .OR. IMAT(JJ) .LT.901) THE + if(jj .eq. j) go to 170 + if(imat(jj) .gt. 0) then + NNCN = NCORN(JJ) + DO 160 KK = 2, NNCN, 2 + IF( NOP(JJ,KK-1) .EQ. NB ) THEN + KN = MOD(KK+1,NNCN) + IF(KN .EQ. 0) KN=NNCN + IF( NOP(JJ,KN) .EQ. NA ) THEN + NOP(JJ,KK) = NP0 +!ipk dec98 + ielct=ielct+1 + if(ielct .eq. 2) then + GO TO 180 + else + go to 170 + endif +!ipk dec98 end changes + ENDIF +!IPK APR98 ADD + ELSEIF( NOP(JJ,KK-1) .EQ. NA ) THEN + KN = MOD(KK+1,NNCN) + IF(KN .EQ. 0) KN=NNCN + IF( NOP(JJ,KN) .EQ. NB ) THEN + NOP(JJ,KK) = NP0 +!ipk dec98 + ielct=ielct+1 + if(ielct .eq. 2) then + GO TO 180 + else + go to 170 + endif +!ipk dec98 end changes + ENDIF +!IPK APR98 + ENDIF + 160 CONTINUE + ENDIF + 170 CONTINUE + ELSE + NM=NOP(J,K) + IF(INEW(NM) .NE. 1) THEN + XX=(CORD(NA,1)+CORD(NB,1))/2. + YY=(CORD(NA,2)+CORD(NB,2))/2. + CORD(NM,1)=XX + CORD(NM,2)=YY + WD(NM)=AA + WD1(NM)=AB + WIDTH(NM)=(WIDTH(NA)+WIDTH(NB))/2. + SS1(NM)=(SS1(NA)+SS1(NB))/2. + SS2(NM)=(SS2(NA)+SS2(NB))/2. + WIDS(NM)=(WIDS(NA)+WIDS(NB))/2. + WIDBS(NM)=(WIDBS(NA)+WIDBS(NB))/2. + BS1(NM)=(BS1(NA)+BS1(NB))/2. + INEW(NM) = 1 + IF(LOCK(NA) .EQ. 1 .AND. LOCK(NB) .EQ. 1) LOCK(NM)=1 + XUSR(NM) = XX*TXSCAL - XS + YUSR(NM) = YY*TXSCAL - YS + INSKP(NM) = 0 +!ipk jan01 + IF(NM .GT. NP) NP=NM + ELSE + WD(NM)=AA + WD1(NM)=AB + ENDIF + ENDIF + 180 CONTINUE + ENDIF + 190 CONTINUE + IF (NP0 .GT. NP) NP=NP0 + 200 CONTINUE + NHTP = nhtpsv + NMESS = nmesssv + NBRR = nbrrsv +! call WcursorShape(0) + +!IPK MAY03 + ICHG=0 + + RETURN + END + + + SUBROUTINE NODERR(NODER,LIMIT) + + USE WINTERACTER + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + + INTEGER :: IERR,NODER,LIMIT + + call wdialogload(IDD_NODERR) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_NODERR) + ierr=infoerror(1) + + CALL WDialogPutInteger(IDF_INTEGER2,LIMIT) + CALL WDialogPutInteger(IDF_INTEGER3,NODER) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + RETURN + ELSE + RETURN + ENDIF + enddo + RETURN + END diff --git a/src/FILLTR.F90 b/src/FILLTR.F90 new file mode 100644 index 0000000..dec64f5 --- /dev/null +++ b/src/FILLTR.F90 @@ -0,0 +1,272 @@ + SUBROUTINE FILLTR + USE WINTERACTER + USE IFPORT + USE BLKMAP + CHARACTER(LEN=256) :: FILTER,FNAME + CHARACTER(LEN=80) :: DATAIN,OPTIONS + CHARACTER(LEN=3) :: SUB + INTEGER INOUTL,NOUTL,OUTPOL + INTEGER NTRIAN(5000,2),TWO,ZERO,ntrans(5000) + INTEGER*2 RESULT + LOGICAL EXISTS + do k=1,80 + options(k:k)=' ' + enddo + TWO=2 + ZERO=0 + INOUTL=22 + OUTPOL=23 + VOID = - 1.0E+10 + VDX = - 1.0E+9 + +! +! get filename + +! FILTER ="Data files|*.dat;*.txt;*.map|Map file -- *.map|*.map|" +! CALL WSelectFile(FILTER,PromptOn+DirChange+Appendext,FNAME,'Load data file') + +! IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN +! OPEN(INOUTL,FILE=FNAME,STATUS='OLD') +! CALL IlowerCase(FNAME) +! CALL GETSUB(FNAME,SUB) +! IF(SUB .EQ. 'map') then +! IMAPIN=1 +! ELSE +! IMAPIN=0 +! ENDIF +! ELSE +! WRITE(*,*) 'ERROR NO FILE' +! ENDIF + IMAPIN=1 +! read outline +! + IF(IMAPIN .EQ. 1) THEN + OPEN(113,FORM='BINARY',STATUS='SCRATCH') + WRITE(113) XMAP,YMAP + REWIND (113) + DO K=1,5000 + IF(XMAP(K) .LT. VDX) THEN + NOUTL=K-1 + GO TO 90 + ENDIF + ENDDO +90 CONTINUE + ELSE +! IF(IMAPIN .EQ. 1) READ(INOUTL,'(A80)') DATAIN + DO K=1,5000 + READ(INOUTL,'(A80)') DATAIN + IF(DATAIN(1:3) .EQ. 'END' .OR. DATAIN(1:3) .EQ. 'end') then + NOUTL=K-1 + GO TO 100 + ELSE + READ(DATAIN,*) XMAP(K),YMAP(K) + ENDIF + ENDDO +100 CONTINUE + ENDIF + IF(XMAP(NOUTL) .EQ. XMAP(1) .AND. YMAP(NOUTL) .EQ. YMAP(1)) THEN + XMAP(NOUTL)=VOID + YMAP(NOUTL)=VOID + NOUTL=NOUTL-1 + LOOPC=1 + ELSE + LOOPC=0 + ENDIF + + DO J=1, NOUTL + NTRIAN(J,1)=J + NTRIAN(J,2)=J+1 + ENDDO + NTRIAN(NOUTL,2)=1 + JC=NOUTL +! read contours + NOUTBE=NOUTL+1 + NOUTT=NOUTL + DO N=1,100 + if(imapin .eq. 1) then + noutb=noutt+2+LOOPC + ncnt=0 + DO K=NOUTB,5000 + if(k .eq. noutb) then + if(xmap(k) .lt. vdx) go to 300 + endif + IF(XMAP(K) .LT. VDX) THEN + NOUTT=K-1 + GO TO 110 + ENDIF + ncnt=ncnt+1 + ENDDO +110 CONTINUE + else + READ(INOUTL,'(A80)', END=300) DATAIN + IF(DATAIN(1:3) .EQ. 'END') GO TO 300 + NOUTB=NOUTT+1 + NCNT=0 + DO K=NOUTB,5000 + READ(INOUTL,'(A80)') DATAIN + IF(DATAIN(1:3) .EQ. 'END' .OR. DATAIN(1:3) .EQ. 'end') then + NOUTT=K-1 + GO TO 200 + ELSE + READ(DATAIN,*) XMAP(K),YMAP(K) + NCNT=NCNT+1 + ENDIF + ENDDO +200 CONTINUE + endif + IF(XMAP(NOUTT) .EQ. XMAP(NOUTB) .AND. YMAP(NOUTT) .EQ. YMAP(NOUTB)) THEN + XMAP(NOUTT)=VOID + YMAP(NOUTT)=VOID + NOUTT=NOUTT-1 + LOOPC=1 + ELSE + LOOPC=0 + ENDIF + JC=NOUTB-1 + JCB=JC+1 + DO J=NOUTBE, NOUTBE+NCNT-2-LOOPC + JC=JC+1 + NTRIAN(J,1)=JC + NTRIAN(J,2)=JC+1 + ENDDO + IF(LOOPC .EQ. 1) THEN + NTRIAN(NOUTBE+NCNT-2,1)=JC+1 + NTRIAN(NOUTBE+NCNT-2,2)=JCB + NOUTBE=NOUTBE+NCNT-1 + ELSE + NOUTBE=NOUTBE+NCNT-1 + ENDIF + JC=JC+1 + ENDDO +! copy to a file +300 CONTINUE + OPEN(OUTPOL,FILE='TEST.POLY', STATUS='UNKNOWN') + ncnt=0 + DO K=1,NOUTT + if(xmap(k) .lt. vdx) cycle + ncnt=ncnt+1 + ntrans(k)=ncnt + ENDDO + WRITE(OUTPOL,*) NCNT,TWO,ZERO,ZERO + ncnt=0 + DO K=1,noutt + if(xmap(k) .lt. vdx) cycle + ncnt=ncnt+1 + WRITE(OUTPOL,*) ncnt,XMAP(K),YMAP(K) + ENDDO + WRITE(OUTPOL,*) NOUTBE-1,ZERO + DO J=1, NOUTBE-1 + WRITE(OUTPOL,*) J,ntrans(NTRIAN(J,1)),ntrans(NTRIAN(J,2)) + ENDDO + WRITE(OUTPOL,*) ZERO + FLUSH (OUTPOL) + REWIND (OUTPOL) + CLOSE (OUTPOL) +! close (inoutl) +! setup options + +! OPTIONS = ' -pqa5000V TEST' + OPTIONS(1:3) = ' -p' + nct=3 +! iswq=1 +! iswy=0 +! id1=105 + CALL PANELFILLT(ISWQ,ISWY,ID1) + + IF(ISWQ .EQ. 1) THEN + NCT=NCT+1 + OPTIONS(NCT:NCT)='q' + ENDIF + IF(ISWY .EQ. 1) THEN + NCT=NCT+1 + OPTIONS(NCT:NCT)='q' + ENDIF + ID1=ID1**2/2 + WRITE(OPTIONS(NCT+1:NCT+12),'(''a'',I6.6,'' TEST'')') ID1 +! go to TRIANGLE + + INQUIRE (FILE = 'test.1.ele', EXIST = exists) + if(exists) then + open(77,file= 'test.1.ele') + close(77,status='DELETE') + ENDIF + + INQUIRE (FILE = 'test.1.node', EXIST = exists) + if(exists) then + open(77,file= 'test.1.node') + close(77,status='DELETE') + ENDIF + + INQUIRE (FILE = 'test.1.poly', EXIST = exists) + if(exists) then + open(77,file= 'test.1.poly') + close(77,status='DELETE') + ENDIF + + RESULT= RUNQQ("C:\Program Files\RMA\TRIANGLE", OPTIONS) +! RESULT= RUNQQ("TRIANGLE", OPTIONS) + IF(IMAPIN .EQ. 1) THEN + READ(113) XMAP,YMAP + CLOSE (113) + ENDIF + IIN=10 + OPEN(IIN,FILE='TEST.1.ELE', STATUS='OLD') + + CALL GETNEWFIL(IIN,0,1,1) + + +! finish up + RETURN + END + + SUBROUTINE PANELFILLT(N1,N2,N3) + + use winteracter + implicit none + SAVE + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3,IERR,ITIME +! real :: +! character*3 :: + DATA ITIME/0/ + IF(ITIME .EQ. 0) THEN + ITIME=1 + N1=1 + N2=0 + N3=100 + ENDIF + + call wdialogload(IDD_FTRIAN) + ierr=infoerror(1) + + CALL WDialogPutCheckBox(idf_check1,n1) + CALL WDialogPutCheckBox(idf_check2,n2) + CALL WDialogPutInteger(idf_integer1,n3) + + + CALL WDialogSelect(IDD_FTRIAN) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetCheckBox(idf_check1,n1) + CALL WDialogGetCheckBox(idf_check2,n2) + CALL WDialogGetInteger(idf_integer1,n3) + ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + N3=-1 + ENDIF + RETURN + END + \ No newline at end of file diff --git a/src/FORMGP.F90 b/src/FORMGP.F90 new file mode 100644 index 0000000..add79ff --- /dev/null +++ b/src/FORMGP.F90 @@ -0,0 +1,145 @@ + SUBROUTINE FORMGP + + USE WINTERACTER + USE BLK1MOD + include 'd.inc' + + CHARACTER*47 MESSAGE + + DATA MESSAGE /'Enter Group Number'/ + + DATA ITIME/0/ + +! SWITCH TO GROUP ACTIVITY + + IF(IQSW(1) .EQ. 1) IQSW(1)=2 + IF(IQSW(2) .EQ. 1) IQSW(2)=2 + + +! IF FIRST TIME ASK TO LOAD FILE OR SET GROUPS = 1 + + if(ITIME .EQ. 0) THEN +! ALLOCATE ARRAY SIZES + + IF(.NOT. ALLOCATED(IGRPNUM)) THEN + ALLOCATE (IGRPNUM(25,MAXE),MAXENT(25)) + CALL TOPAR + ENDIF + ISW=2 + ITIME=1 + ELSE + CALL TOPAR + ENDIF + + +! ASSIGN A NUMBER TO THE NEW GROUP + + call wdialogload(IDD_GETINT) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_GETINT) + ierr=infoerror(1) + + CALL WDialogPutString(IDF_STRING1,MESSAGE) + CALL WDialogPutInteger(IDF_INTEGER1,ISW) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) +! Branch depending on type of message. +! + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetInteger(IDF_INTEGER1,ISW) + GO TO 200 + ENDIF + ENDDO + + 200 CONTINUE + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish add these elements to the current group?'//& + CHAR(13)//' ','ADD ELEMENTS?') + +! If answer 'No', start afresh +! + IF (WInfoDialog(4).EQ.2) then + +! STORE GROUP NUMBERS STARTING AT 1 + + DO K=1,NEFL + IGRPNUM(ISW,K)=NEFLAG(K) + ENDDO + MAXENT(ISW)=NEFL + ELSE +! +! FOR EACH ELEMENT SEARCH FIRST IF NOT FOUND ADD TO THE END + + DO K=1,NEFL + DO J=1,MAXENT(ISW) + IF(NEFLAG(K) .EQ. IGRPNUM(ISW,J)) GO TO 240 + ENDDO + MAXENT(ISW)=MAXENT(ISW)+1 + IGRPNUM(ISW,MAXENT(ISW))=NEFLAG(K) + 240 CONTINUE + ENDDO + ENDIF + +! REMOVE FROM OLD LIST + DO I=1,25 + IF(I .NE. ISW) THEN + DO J=1,MAXENT(I) + DO K=1,NEFL + IF(NEFLAG(K) .EQ. IGRPNUM(I,J)) THEN + IGRPNUM(I,J)=0 + GO TO 260 + ENDIF + ENDDO + 260 CONTINUE + ENDDO + JT=0 + LIMIT=MAXENT(I) + J=0 + 270 J=J+1 + 275 IF(J+JT .LE. LIMIT) THEN + IF(IGRPNUM(I,J+JT) .EQ. 0) THEN + JT=JT+1 + GO TO 275 + ENDIF + IGRPNUM(I,J)=IGRPNUM(I,J+JT) + GO TO 270 + ENDIF + DO J=MAXENT(I),MAXENT(I)+1-JT,-1 + IGRPNUM(I,J)=0 + ENDDO + MAXENT(I)=MAXENT(I)-JT + ENDIF + ENDDO + + CALL TOSER + + RETURN + END + + SUBROUTINE TOSER + USE BLK1MOD + DO I=1,25 + DO J=1,MAXENT(I) + IGRPSER(IGRPNUM(I,J))=I + ENDDO + ENDDO + RETURN + END + + SUBROUTINE TOPAR + USE BLK1MOD + + MAXENT=0 + IGRPNUM=0 + + DO K=1,NE + I=IGRPSER(K) + MAXENT(I)=MAXENT(I)+1 + IGRPNUM(I,MAXENT(I))=K + ENDDO + RETURN + END \ No newline at end of file diff --git a/src/FORMSHP.F90 b/src/FORMSHP.F90 new file mode 100644 index 0000000..f13c701 --- /dev/null +++ b/src/FORMSHP.F90 @@ -0,0 +1,455 @@ + subroutine formshp2(istyp,ivecact) + use winteracter + + include 'D.inc' + + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL + character*1 ai1a,ai1b,ai1c,ai1d,label,ai1f + character*3 sub + character*4 ai1,ai7,aai7,ai8,ai9,anrs,aii,aioff + character*10 as + character*11 name + character*80 headr + character*255 fnamein,filter + integer*2 i3s,i4s + integer status,i1,i2,i3,i4,i5,i6,i7,i8,i9,ia1,ia7,ia8,ia9,nrs& + ,nars,ii,ioff,iaoff,i1a,i1b,i1c,i1d,istyp,nptemp + integer*8 i88 + real*8 fp1,fp2,fp3,fp4,fp5,fp6,fp7,fp8,bx(1000),by(1000),bm(1000)& + ,bxmn,bymn,bxmx,bymx,bmmn,bmmx,axmn,aymn,axmx,aymx,fz,ammn,ammx + real bed,val + integer ityp,icl + allocatable bed(:),val(:,:),ityp(:),icl(:) + + LOGICAL OPENED + equivalence(ai1,ia1),(ai7,ia7),(aii,ii),(anrs,nrs),(aioff,ioff) + + if(.not. allocated(bed)) then + allocate (bed(250000),val(250000,4),ityp(250000),icl(250000)) + bed=0. + val=0. + ityp=0 + icl=0 + endif + filter='Shape file *.shp|*.shp|' + INQUIRE(99,opened= OPENED) + IF( .NOT. OPENED) THEN + CALL WSelectFile(filter,SaveDialog+PromptOn+AppendExt,FNAMEIN,'Shapefile Name') + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + open(99,file=fnamein,form='binary') + sub='shx' + call ADDSUB(fnamein,sub) + open(98,file=fnamein,form='binary') + sub='dbf' + call ADDSUB(fnamein,sub) + open(97,file=fnamein,form='binary') + ELSE + RETURN + ENDIF + ENDIF +! read data file to establish sizes and max/min + nfils=50 + axmn=1.e36 + aymn=1.e36 + ammn=1.e36 + axmx=-1.e36 + aymx=-1.e36 + ammx=-1.e36 +! if(ivecact .ne. 1) then +! read(70,'(a80)') headr +! read(70,'(a80)') headr +! read(headr(9:16),'(i8)') istyp +! endif + do i=1,250000 + if(istyp .eq. 25) then + read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts) + do j=1,npts + write(155,*) bx(j),by(j),bm(j) + enddo + icl(i)=iclt + write(155,*) icl(i),ityp(i),npts + do j=1,npts + axmn=min(axmn,bx(j)) + aymn=min(aymn,by(j)) + ammn=min(ammn,bm(j)) + axmx=max(axmx,bx(j)) + aymx=max(aymx,by(j)) + ammx=max(ammx,bm(j)) + enddo +! NEED TO FIX THIS + nfils=nfils+36+12*npts +! NEED TO FIX THIS + elseif(istyp .eq. 5) then + IF(IVECACT .EQ. 5) THEN + read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts) + ELSE + read(113,end=100) iclt,npts,(bx(j),by(j),j=1,npts) + ENDIF + icl(i)=iclt + do j=1,npts + axmn=min(axmn,bx(j)) + aymn=min(aymn,by(j)) + axmx=max(axmx,bx(j)) + aymx=max(aymx,by(j)) + enddo + ammn=0. + ammx=0. + nfils=nfils+28+8*npts + elseif(istyp .eq. 3) then + read(113,end=100) npts,(bx(j),by(j),j=1,npts),d1 + do j=1,npts + axmn=min(axmn,bx(j)) + aymn=min(aymn,by(j)) + axmx=max(axmx,bx(j)) + aymx=max(aymx,by(j)) + enddo + ammn=0. + ammx=0. + nfils=nfils+28+8*npts + elseif(istyp .eq. 1 .and. ivecact .eq. 0) then + read(70,9875,end=100) bx(1),by(1) + 9875 format(10x,2f20.0,f10.0) + axmn=min(axmn,bx(1)) + aymn=min(aymn,by(1)) + axmx=max(axmx,bx(1)) + aymx=max(aymx,by(1)) + ammn=0. + ammx=0. + nfils=nfils+14 + elseif(istyp .eq. 1 .and. ivecact .eq. 1) then +! read(113,end=100) NR,bxt,byt,d1,d2,d3,d4,d5,d6 + read(113,end=100) NR,bxt,byt,d1,d2,d3,d4 + 9874 format(9x,8f14.0) + axmn=min(axmn,bxt) + aymn=min(aymn,byt) + axmx=max(axmx,bxt) + aymx=max(aymx,byt) + ammn=0. + ammx=0. + nfils=nfils+14 + elseif(istyp .eq. 1 .and. ivecact .eq. 6) then + read(113,end=100) NR,bx(1),by(1),d1 + axmn=min(axmn,bx(1)) + aymn=min(aymn,by(1)) + axmx=max(axmx,bx(1)) + aymx=max(aymx,by(1)) + ammn=0. + ammx=0. + nfils=nfils+14 + endif + numdat=i + enddo + 100 rewind 113 + +! read(70,'(a80)') headr +!c if(ivecact .eq. 1) read(70,'(a80)') headr +!c setup header + ia1=9994 + call BTOL(ai1,i1) + i2=0 + i3=0 + i4=0 + i5=0 + i6=0 + ia7=nfils + call BTOL(ai7,i7) + i8=1000 + i9=istyp + fz=0. + write(99) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,fz,fz,ammn,ammx + ia7=50+4*numdat + call BTOL(ai7,i7) + write(98) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,fz,fz,ammn,ammx + ioff=50 + +! header now complete for shp and shx options + do i=1,numdat + if(istyp .eq. 25) then + read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts) + icl(i)=iclt + nrs=32+12*npts + nrsc=nrs+4 +! write(155,*) 'nrs',nrs + call btol(anrs,nars) + elseif(istyp .eq. 5) then + IF(IVECACT .EQ. 5) THEN + read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts) + ELSE + read(113) iclt,npts,(bx(j),by(j),j=1,npts) + ENDIF + icl(i)=iclt + nrs=24+8*npts + nrsc=nrs+4 +! write(155,*) 'nrs',nrs + call btol(anrs,nars) + elseif(istyp .eq. 3) then + read(113) npts,(bx(j),by(j),j=1,npts),val(i,1) + icl(i)=iclt + nrs=24+8*npts + nrsc=nrs+4 +! write(155,*) 'nrs',nrs + call btol(anrs,nars) + elseif(istyp .eq. 1) then + if(ivecact .eq. 0) then + read(70,9875) bx(1),by(1),bed(i) + elseif(ivecact .eq. 6) then + read(113) ityp(i),bx(1),by(1),val(i,1) + else + read(113) idum,bxt,byt,(val(i,j),j=1,4) + bx(1)=bxt + by(1)=byt + endif + nrs=10 + nrsc=14 +! write(155,*) 'nrs',nrs + call btol(anrs,nars) + endif + ii=i + call btol(aii,nrec) + write(99) nrec,nars + if(istyp .eq. 25) then + j1=istyp + j2=1 + bxmn=bx(1) + bymn=by(1) + bmmn=bm(1) + bxmx=bx(1) + bymx=by(1) + bmmx=bm(1) + do k=2,npts + bxmn=min(bxmn,bx(k)) + bymn=min(bymn,by(k)) + bmmn=min(bmmn,bm(k)) + bxmx=max(bxmx,bx(k)) + bymx=max(bymx,by(k)) + bmmx=max(bmmx,bm(k)) + enddo + j3=npts + j4=0 + write(99) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4 + do k=1,npts + write(99) bx(k),by(k) + enddo + write(99) bmmn,bmmx + do k=1,npts + write(99) bm(k) + enddo + + elseif(istyp .gt. 2) then + j1=istyp + j2=1 + bxmn=bx(1) + bymn=by(1) + bxmx=bx(1) + bymx=by(1) + do k=2,npts + bxmn=min(bxmn,bx(k)) + bymn=min(bymn,by(k)) + bxmx=max(bxmx,bx(k)) + bymx=max(bymx,by(k)) + enddo + j3=npts + j4=0 + write(99) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4 +! write(155,*) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4 + do k=1,npts + write(99) bx(k),by(k) +! write(155,*) k,bx(k),by(k) + enddo + elseif(istyp .eq. 1) then + j4=1 + write(99) j4,bx(1),by(1) + endif +! write(155,*) ioff,nrs + call btol(aioff,iaoff) + write(98) iaoff,nars + ioff=ioff+nrsc + enddo + i1a=3 + i1b=115 + i1c=12 + i1d=9 + ai1a=char(i1a) + ai1b=char(i1b) + ai1c=char(i1c) + ai1d=char(i1d) + i2=numdat + if(ivecact .eq. 0 .or. ivecact .gt. 3) then + i4s=18 + i3s=97 + elseif(ivecact .eq. 3) then + i4s=11 + i3s=65 + else + i4s=37 + i3s=161 + endif + i5=0 + write(97) ai1a,ai1b,ai1c,ai1d,i2,i3s,i4s,i5 + ai1a=char(0) + ai1b='W' + write(97) i5,i5,i5,ai1a,ai1a,ai1b,ai1a + i2a=0 + IF(ISTYP .EQ. 25) THEN + name='ID ' + label='N' + i2=0 + ai1a=char(8) + ai1b=char(0) + ai1c=char(0) + ai1f=char(13) + ai1d=char(0) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c + name='Type ' + label='N' + i2=0 + ai1a=char(9) + ai1b=char(0) + ai1c=char(0) + ai1f=char(13) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f + ELSEIF(ISTYP .EQ. 5) THEN + name='ID ' + label='N' + i2=0 + ai1a=char(8) + ai1b=char(0) + ai1c=char(0) + ai1f=char(13) + ai1d=char(0) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c + name='Contour ' + label='N' + i2=0 + ai1a=char(9) + ai1b=char(2) + IF(IVECACT .EQ. 5) THEN + name='TYPE * ' + label='N' + ai1b=char(0) + ENDIF + ai1c=char(0) + ai1f=char(13) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f + elseif(istyp .eq. 3) then + name='CONTOUR ' + label='N' + i2=0 + ai1a=char(10) + ai1b=char(4) + ai1c=char(0) + ai1f=char(13) + ai1d=char(0) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f + elseif(istyp .eq. 1) then + if(ivecact .eq. 6) then + name='NODE ' + label='N' + i2=0 + ai1a=char(8) + ai1b=char(0) + ai1c=char(0) + ai1f=char(13) + ai1d=char(0) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c + name='Bed Elev ' + label='N' + i2=0 + ai1a=char(9) + ai1b=char(0) + ai1c=char(0) + ai1f=char(13) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f + else + name='VEL ' + label='N' + i2=0 + ai1a=char(9) + ai1b=char(4) + ai1c=char(0) + ai1f=char(13) + ai1d=char(0) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c + name='DIR ' + label='N' + i2=0 + ai1a=char(9) + ai1b=char(2) + ai1c=char(0) + ai1f=char(13) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c + name='DEP ' + label='N' + i2=0 + ai1a=char(9) + ai1b=char(3) + ai1c=char(0) + ai1f=char(13) + write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c + name='WS-ELEV ' + label='N' + i2=0 + ai1a=char(9) + ai1b=char(3) + ai1c=char(0) + ai1f=char(13) + write(97)name,label,i2,ai1a,ai1b,i2,i2,i2,ai1d,ai1c + write(97)ai1f + endif + endif + ai1a=char(32) + ai1f=char(32) + do i=1,numdat + write(97) ai1a + if(istyp .eq. 25) then + write(as(1:8),'(i8)') icl(i) + write(97) as(1:8) + write(as(1:9),'(i9)') ityp(i) + write(97) as(1:9) + elseif(istyp .eq. 5) then + write(as(1:8),'(i8)') icl(i) + write(97) as(1:8) + if(IVECACT .EQ. 5) then + write(as(1:9),'(i9)') ityp(i) + write(97) as(1:9) + else + ficl=contur(icl(i)) + write(as(1:9),'(f9.2)') ficl + write(97) as(1:9) + endif + elseif(istyp .eq. 3) then + write(as(1:10),'(f10.4)') val(i,1) + write(97) as(1:10) + elseif(istyp .eq. 1) then + if(ivecact .eq. 0) then + write(as(1:8),'(i8)') i + write(97) as(1:8) + write(as(1:8),'(f8.2)') bed(i) + write(97) as(1:8) + elseif(ivecact .eq. 6) then + write(as(1:8),'(i8)') ityp(i) + write(97) as(1:8) + write(as(1:9),'(f9.2)') val(i,1) + write(97) as(1:9) + else + write(as(1:9),'(f9.4)') val(i,1) + write(97) as(1:9) + write(as(1:9),'(f9.2)') val(i,2) + write(97) as(1:9) + write(as(1:9),'(f9.3)') val(i,3) + write(97) as(1:9) + write(as(1:9),'(f9.3)') val(i,4) + write(97) as(1:9) + endif + endif + enddo + ai1a=char(26) + write(97) ai1a + close (99) + close (98) + close (97) + return + end + + \ No newline at end of file diff --git a/src/FRMNODQ.f90 b/src/FRMNODQ.f90 new file mode 100644 index 0000000..482e145 --- /dev/null +++ b/src/FRMNODQ.f90 @@ -0,0 +1,29 @@ + SUBROUTINE FRMNODQ(X1,Y1,X2,Y2,X3,Y3,X4,Y4,NPTS1,NPTS2) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +! X1,X2,X3,X4 AND Y1,Y2,Y3,Y4 are vertices of quad +! NPTS1 and NPTS2 are the nominal number of elements on each side + + +! Work along first side AND backwards along second line + + DO N=1,NPTS1-1 + RATIO=FLOAT(N)/FLOAT(NPTS1) + X12=X1+RATIO*(X2-X1) + Y12=Y1+RATIO*(Y2-Y1) + X43=X4+RATIO*(X3-X4) + Y43=Y4+RATIO*(Y3-Y4) + +! Now get interior points + + DO M=1,NPTS2-1 + RATIO=FLOAT(M)/FLOAT(NPTS2) + XNEW=X12+RATIO*(X43-X12) + YNEW=Y12+RATIO*(Y43-Y12) + CALL DEFNOD(XNEW,YNEW) + ENDDO + ENDDO + RETURN + END diff --git a/src/GETANG.F90 b/src/GETANG.F90 new file mode 100644 index 0000000..3f2e67d --- /dev/null +++ b/src/GETANG.F90 @@ -0,0 +1,144 @@ + SUBROUTINE GETALLANGS + + USE BLK1MOD + USE BLK2MOD + SAVE ICOUNTMX + + DIMENSION ANGA(2),ANGB(2) + + DATA ICOUNTMX/0/ + + IF(.NOT. ALLOCATED(NKEY1)) THEN + ALLOCATE (NKEY1(MAXE)) + ENDIF + IF(.NOT. ALLOCATED(ANGOP)) THEN + ALLOCATE (ANGOP(MAXP)) + ENDIF + + CALL HEDR + ICOUNTMX=50 + ILMIT=0 + CALL GEtrev(ICOUNTMX,ILMIT) + IF(ICOUNTMX .LT. 0) RETURN + NKEY1=0 +! set all the nodal angles negative + ANGOP=-1. +! get elements connected to nodes table + IERR=0 + CALL NDNECON(IERR) +! loop on the elements to find mid-sides + DO N=1,NE +! work only with triangles + IF(NCORN(N) .EQ. 6) THEN +! go to each mid-side + DO K=2,6,2 + N1=NOP(N,K-1) + KN=MOD(K+1,6) + N3=NOP(N,KN) + KP=MOD(K+3,6) + N2=NOP(N,KP) + NCUR=NOP(N,K) + IF(NCUR .EQ. 0) THEN + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK, & + 'You have tried to reverse before executing "FILL"'//CHAR(13) & + //'Reversing terminated',& + 'UNABLE TO REVERSE') +! CALL SYMBL(0.,7.30,0.20,STRELS,0.,60) + RETURN + ENDIF +! call GETANG to get angle opposite N1-N3 line + ANGTMP=GETANG(N1,N2,N3) + IF(ANGTMP .GT. ANGOP(NCUR)) ANGOP(NCUR)=ANGTMP + ENDDO + ENDIF + ENDDO +! get the angles in ascending order + CALL SORT(ANGOP,ICN,NP) + + ICOUNT=0 +! loop backwards and use the sorrt key ICN + DO J=NP,1,-1 + MIDND=ICN(J) +! only work when angles greater than 90 deg + IF(ANGOP(MIDND) .GT. 1.5708) THEN +! check if there are two elements connected to this mid side + IF(NECON(MIDND,2) .GT. 0) THEN +! make sure the opposite elements are not quadrilaterals + IF(NCORN(NECON(MIDND,1)) .EQ. 6 .AND. NCORN(NECON(MIDND,2)) .EQ. 6) THEN +! only proceed when the first mid-side has not been processed + IF(NKEY1(NECON(MIDND,1)) .EQ. 0) THEN + NEL1=NECON(MIDND,1) +! only proceed when the second mid-side has not been processed + IF(NKEY1(NECON(MIDND,2)) .EQ. 0) THEN +! we really have a candidate lest check if it will make the angles worse +! first find the locations of the mid sides in the order data to get more angles + DO KK=1,2 + DO K=2,6,2 +! test for a fit + IF(NOP(NECON(MIDND,KK),K) .EQ. MIDND) THEN +! get angles before and after +! corner before + N1=NOP(NECON(MIDND,KK),K-1) +! corner after + N3=MOD(K+1,6) + N3=NOP(NECON(MIDND,KK),N3) +! test for possible equal elev + if(ilmit .eq. 1) then + if(wd(n1) .gt. -9000.) then + if(wd(n1) .eq. wd(n3)) go to 180 + endif + endif +! corner opposite + N2=MOD(K+3,6) + N2=NOP(NECON(MIDND,KK),N2) +! call GETANG to get angle opposite N2-N3 LINE + ANGB(KK)=GETANG(N2,N1,N3) +! call GETANG to get angle opposite N1-N2 LINE + ANGA(KK)=GETANG(N1,N3,N2) + ENDIF + ENDDO + ENDDO +! test if the side angles are larger, if so skip out + IF(ANGOP(MIDND) .LT. ANGB(2)+ANGA(1)) GO TO 180 + IF(ANGOP(MIDND) .LT. ANGB(1)+ANGA(2)) GO TO 180 +! finally we can proceed + ICOUNT=ICOUNT+1 +! NELPR(ICOUNT,2)=NECON(MIDND,2) +! NELPR(ICOUNT,1)=NEL1 + NKEY1(NECON(MIDND,1))=1 + NKEY1(NECON(MIDND,2))=1 + N1=NEL1 + N2=NECON(MIDND,2) +! carry out reversal + CALL REVERS(N1,N2) +! show the elements + call fillemc(n1,4) + call fillemc(n2,4) + IF(ICOUNT .GE. ICOUNTMX) GO TO 200 + ENDIF + ENDIF + ENDIF + ENDIF + ELSE + GO TO 200 + ENDIF + 180 CONTINUE + ENDDO + 200 CONTINUE + RETURN + END + + FUNCTION GETANG(N1,N2,N3) + + USE BLK1MOD + + A=SQRT((XUSR(N1)-XUSR(N2))**2+(YUSR(N1)-YUSR(N2))**2) + B=SQRT((XUSR(N2)-XUSR(N3))**2+(YUSR(N2)-YUSR(N3))**2) + C=SQRT((XUSR(N3)-XUSR(N1))**2+(YUSR(N3)-YUSR(N1))**2) + ANG1=(A**2+B**2-C**2)/(2.*A*B) + IF(ANG1 .GT. 1.) ANG1=1. + + GETANG=ACOS(ANG1) + + RETURN + END diff --git a/src/GETCRS.F90 b/src/GETCRS.F90 new file mode 100644 index 0000000..767afdc --- /dev/null +++ b/src/GETCRS.F90 @@ -0,0 +1,241 @@ + SUBROUTINE GETCRS(CRSTIT) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + CHARACTER*8 ID1 + CHARACTER*72 DLIN1,CRSTIT + +!IPK JUN06 + DATA VOIDCR/-1.E15/ + + XCRS=VOIDCR + YCRS=VOIDCR + NRIVCR1=0 + NRIVCR2=0 +!ipk jun11 + NOREACH=0 + NRIVL=0 + + call ginpt(icrin,id1,dlin1) + + IF(ID1(1:2) .EQ. 'TC') THEN + CRSTIT=DLIN1 + call ginpt(icrin,id1,dlin1) + ELSE + CALL WMessageBox(0,3,1,'Cross-section Title not found'//char(13)//& + 'Cross-section file input terminated','ERROR') + return + ENDIF + N=0 + + 200 N=N+1 + IF(N .GT. MCRS) THEN + CALL WMessageBox(0,3,1,'Allowable number of sections (1000) exceeded'//char(13)//& + 'Cross-section file input terminated','ERROR') + return + ENDIF + IF(ID1(1:3) .EQ. 'RCH') THEN + READ(DLIN1,'(I8)') NOREACHTMP + write(90,'(a)') 'rch',id1,dlin1 + Call ginpt(icrin,id1,dlin1) + ENDIF + + IF(ID1(1:3) .EQ. 'ICS') THEN + READ(DLIN1,'(2I8,8x,2f16.0)') IVMIL(N),NRIVL(IVMIL(N)),XCRS(IVMIL(N)),YCRS(IVMIL(N)) + write(90,'(a)') 'ics',id1,dlin1 + NOREACH(IVMIL(N))=NOREACHTMP + IF(NRIVL(IVMIL(N)) .GT. MPTS) THEN + CALL WMessageBox(0,3,1,'Allowable number of points in a cross-section (75) exceeded'//char(13)//& + 'Cross-section file input terminated','ERROR') + return + ENDIF +! IF(NOREACH(N) .EQ. 0) THEN +! IF(N .GT. 1) THEN +! NOREACH(N)=NOREACH(N-1) +! ELSE +! NOREACH(N)=1 +! ENDIF +! ENDIF + call ginpt(icrin,id1,dlin1) + DO I=1,NRIVL(IVMIL(N)) + write(90,'(a)') 'crs',id1,dlin1 + READ(DLIN1,'(3F8.0)') (CRSDAT(IVMIL(N),I,J),J=1,3) +!IPK JUN04 + if(i .gt. 1) then + CRSDAT(IVMIL(N),I,2)=CRSDAT(IVMIL(N),I-1,2)+& + (CRSDAT(IVMIL(N),I,1)-CRSDAT(IVMIL(N),I-1,1))*& + (CRSDAT(IVMIL(N),I,3)+CRSDAT(IVMIL(N),I-1,3))/2. + endif + call ginpt(icrin,id1,dlin1) + ENDDO + NCRSEC=N +! TEST NCRSEC=MAX(N,IVMIL(N)) + GO TO 200 + ENDIF + +!ipk jun06 DO N=1,NCRSEC + + DO N=1,MCRS + IF(ID1(1:3) .EQ. 'XYL') THEN + READ(DLIN1,'(I8,2F16.0)') NN,XCRS(NN),YCRS(NN) +!IPK JUN06 + IF(NN .GT. NCRSEC) NCRSEC=NN + call ginpt(icrin,id1,dlin1) + ELSE + GO TO 400 + ENDIF + ENDDO + + 400 CONTINUE + DO N=1,MAXP + IF(ID1(1:3) .EQ. 'CRF') THEN + READ(DLIN1,'(2I8,F8.0,I8,F8.0)') NODCRS& + ,NRIVCR1(NODCRS),WTRIVCR1(NODCRS)& + ,NRIVCR2(NODCRS),WTRIVCR2(NODCRS) + call ginpt(icrin,id1,dlin1) + ELSE + GO TO 500 + ENDIF + ENDDO + 500 CONTINUE + + CLOSE(ICRIN) + +! CHECK THE DATA LOADED + + IERR=0 + DO N=1,NE + IF(IMAT(N) .LT. 900) THEN + IF(NCORN(N) .EQ. 3 .OR. NCORN(N) .EQ. 5) THEN + DO J=1,3,2 + IF(NRIVCR1(NOP(N,J)) .NE. 0) THEN + WD1(NOP(N,J))=& + CRSDAT(NRIVCR1(NOP(N,J)),1,1)*WTRIVCR1(NOP(N,J))+& + CRSDAT(NRIVCR2(NOP(N,J)),1,1)*WTRIVCR2(NOP(N,J)) +! ELSE +! WRITE(75,*) ' NO CROSS-SECTION FILE REFERENCE FOR',NOP(N,J) +! WRITE(75,*) ' EXECUTION TERMINATED' +! WRITE(*,*) ' NO CROSS-SECTION FILE REFERENCE FOR',NOP(N,J) +! WRITE(*,*) ' EXECUTION TERMINATED' +! IERR=IERR+1 + ELSE + WD1(NOP(N,J))=WD(NOP(N,J)) + ENDIF +! + ENDDO + + WD1(NOP(N,2))=(WD1(NOP(N,1))+WD1(NOP(N,3)))/2. +! + ELSE + DO J=1,NCORN(N) + WD1(NOP(N,J))=WD(NOP(N,J)) + ENDDO + ENDIF + ENDIF + ENDDO + + RETURN + END + + SUBROUTINE WRTCRS(ICROUT,CRSTIT) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! COMMON/ICN1/ ICN(MAXP) + + + CHARACTER*8 ID1,ENDDAT + CHARACTER*72 CRSTIT + +!IPK JUN06 + DATA VOIDCRP/-1.E14/ + + DO J=1,MAXP + ICN(J)=0 + END DO +! First sort out the potential midsides +! Note that transition elements caues a problem +! Find these first + DO 200 N=1,NE + if(NCORN(N) .GT. 5) GO TO 200 + IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN +! +! We have a transition mark node number as if it were corner +! + ICN(NOP(N,3))=1 + ICN(NOP(N,1))=2 + ICN(NOP(N,4))=2 + ICN(NOP(N,5))=2 + ELSE +! +! Store ICN = 2 for corner nodes +! + NCN=NCORN(N) +!IPKOCT93 IF(IMAT(N) .GT. 900) THEN + IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN + MST=1 + ELSE + MST=2 + ENDIF + + DO 180 M=1,NCN,MST + + ICN(NOP(N,M))=2 + 180 CONTINUE + ENDIF + 200 END DO + ID1='TC ' + WRITE(ICROUT,'(A8,A72)') ID1,CRSTIT + + + DO N=1,NCRSEC +!ipk jun06 +!! IF(NRIVL(N) .GT. 0) THEN + ID1='RCH ' + WRITE(ICROUT,'(A8,I8)') ID1,NOREACH(IVMIL(N)) + ID1='ICS ' +!! write(icrout,'(A8,2I8,8x,2f16.4)') ID1,IVMIL(N),NRIVL(N),XCRS(N),YCRS(N) +!!jul15 write(icrout,'(A8,2I8,8x,2f16.4)') ID1,N,NRIVL(N),XCRS(N),YCRS(N) + write(icrout,'(A8,2I8,8x,2f16.4)') ID1,IVMIL(N),NRIVL(IVMIL(N)),XCRS(IVMIL(N)),YCRS(IVMIL(N)) + ID1='CRS ' + DO I=1,NRIVL(IVMIL(N)) + if(crsdat(IVMIL(N),i,2) .gt. 999999.) then + WRITE(ICROUT,'(A8,3F8.0)') ID1,(CRSDAT(IVMIL(N),I,J),J=1,3) + elseif(crsdat(IVMIL(N),i,2) .gt. 99999.) then + WRITE(ICROUT,'(A8,3F8.1)') ID1,(CRSDAT(IVMIL(N),I,J),J=1,3) + else + WRITE(ICROUT,'(A8,3F8.2)') ID1,(CRSDAT(IVMIL(N),I,J),J=1,3) + endif + ENDDO +!ipk jun06 +!! ENDIF + ENDDO + + + DO N=1,NCRSEC +!ipk jun06 + IF(XCRS(N) .GT. VOIDCRP) THEN + ID1='XYL ' + WRITE(ICROUT,'(A8,I8,2F16.4)') ID1,IVMIL(N),XCRS(IVMIL(N)),YCRS(IVMIL(N)) +!ipk jun06 + ENDIF + ENDDO + + ID1='CRF ' + DO N=1,NP + IF(ICN(N) .EQ. 2) THEN + IF(NRIVCR1(N) .GT. 0) THEN + WRITE(ICROUT,'(A8,2I8,F8.4,I8,F8.4)') ID1,N& + ,NRIVCR1(N),WTRIVCR1(N)& + ,NRIVCR2(N),WTRIVCR2(N) + ENDIF + ENDIF + ENDDO + + ENDDAT='ENDDATA ' + WRITE(ICROUT,'(A8)') ENDDAT + RETURN + END + + diff --git a/src/GETEQ1.F90 b/src/GETEQ1.F90 new file mode 100644 index 0000000..461efc4 --- /dev/null +++ b/src/GETEQ1.F90 @@ -0,0 +1,485 @@ +!IPK LAST UPDATE OCT 23 2015 ADD DECODAT OPTION FOR INPUT +!IPK LAST UPDATE nov 20 2014 IMPLEMENT BINARY FILE SAVE FOR ELEMENT INFLOW DATA +!IPK LAST UPDATE nov 17 2014 initialise TPRVH FOR ALL TYPES +!IPK last update oct 22 2012 initialize TPRVH +!IPK LAST UPDATE MAY 04 2011 FIX BUG CAUSED WHEN SPANNING MULTIPLE FILES +!IPK LAST UPDATE SEPT 3 2007 ADD FULL DATE TO INPUT +!IPK last update sept 01 2007 permit comma delimited entry of data +!IPK LAST UPDATE SEP 06 2004 ADD ERROR FILE +! Last change: IPK 19 Sep 2000 11:44 am +!IPK LAST UPDATE APR 16 1997 +!IPK last update Jan 23 1996 +!IPK last update jan 9 1996 + SUBROUTINE GETEQ +!IPK APR97 SAVE + + use winteracter + USE BLKELTLD + + include 'D.inc' +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE +!IPK AUG05 SAVE + INTEGER JCNV(12) + CHARACTER*32 FNAM + CHARACTER*8 ID + CHARACTER*80 QHTITLE,DLIN + CHARACTER*10 DATE + character*255 fnamein,filter +!IPK oct 12 add initial value + data tprvh/0./,ITIME/0/ + DATA JCNV/0,31,59,90,120,151,181,212,243,273,304,334/ + LOGICAL OPENED + IF(ITIME .EQ. 0) THEN + DAYOFY=-9999 + ITIME=1 + IQEUNIT=0 + IBINEL=0 + IRMATYP=10 + NQHYD=0 + NQP=0 + ENDIF + call wdialogload(IDD_CHOOSEMODEL) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_CHOOSEMODEL) + ierr=infoerror(1) + + call wdialogputRadioButton(idf_radio1) + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,ntyp) + + GO TO 50 + ENDIF + + enddo + +50 CONTINUE + IF(NTYP .EQ. 1) IRMATYP=2 + IF(NTYP .EQ. 2) IRMATYP=10 + IF(NTYP .EQ. 3) THEN + IRMATYP=11 + NQP=1 + call wdialogload(IDD_GETINT) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_GETINT) + ierr=infoerror(1) + + CALL WDialogPutString(IDF_STRING1,'NUMBER OF WQ GRAPH ENTRIES') + CALL WDialogPutInteger(IDF_INTEGER1,NQP) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) +! Branch depending on type of message. +! + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetInteger(IDF_INTEGER1,NQP) + +! TEMPORARY LIMIT + IF(NQP .GT. 3) NQP=3 + + GO TO 70 + ELSE + RETURN + ENDIF + ENDDO + ENDIF + +!IPK NOV14 ADD IBINEL TO TEST + 70 CONTINUE + IF(IQEUNIT .EQ. 0 .and. ibinel .eq. 0) THEN + INQUIRE(201,opened= OPENED) + filter='Element Input files|*.elt;*.elf;*.dat;*.txt;*.grh|All files --|*.*|' + IF( .NOT. OPENED) THEN + CALL WSelectFile(filter,PromptOn+DirChange,FNAMEIN,'Element Load File Name') + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + OPEN(201,FILE=FNAMEIN,STATUS='OLD') + ELSE + RETURN + ENDIF + ENDIF + IQEUNIT=201 + ENDIF + IF(NQHYD .EQ. 0) THEN + +!IPK NOV14 READ AND ALLOCATE DATA FROM BINARY FILE + IF(IBINEL .GT. 0) THEN + TSTARTS=(DAYOFY-1)*24.+TIME-TETH + READ(IBINEL)NEDPTS,NQHYD,TSTARTKP,IYRKP + YEARC=0. + IF(IYRR .NE. IYRKP) THEN + IF(IYRR .GT. IYRKP) THEN + 80 CALL HRYRT(IYRKP,HRYR) + YEARC=YEARC+HRYR + IYRKP=IYRKP+1 + IF(IYRR .GT. IYRKP) GO TO 80 + ELSE + 90 CALL HRYRT(IYRKP,HRYR) + YEARC=YEARC-HRYR + IYRKP=IYRKP-1 + IF(IYRR .LT. IYRKP) GO TO 90 + ENDIF + ENDIF + ALLOCATE(DYE(NEDPTS,NQHYD),TAE(NEDPTS,NQHYD),HAE(NEDPTS,NQHYD),HDE(NEDPTS,NQHYD,3),ILAYRE(NEDPTS,NQHYD)) + do j=1,NQHYD + READ(IBINEL) NCLINE(j),NEST(j),IYDATE(j),NHYE(J) + READ(IBINEL) (DYE(I,j),TAE(I,j),HAE(I,j),I=1,nedpts) + DO I=1,NEDPTS + TAE(I,J)=TAE(I,J)+TSTARTKP-TSTARTS-YEARC + ENDDO + enddo + GO TO 199 + ENDIF +!IPK NOV14 END UPDATE + NEDPTS=0 + CALL ALLOCFL(NEDPTS,NELDS,IQEUNIT,3) +! +! set starting time in hours of the year +! teth contains the first time step + + 95 READ(IQEUNIT,'(A8,A72)') ID,QHTITLE +!IPK sep07 CHECK FOR COMMA'S + 98 IFREE=0 + DO K=1,8 + IF(ID(K:K) .NE. ',') THEN + IFREE=0 + ELSE + KFIRST=K+1 + IFREE=1 + GO TO 99 + ENDIF + ENDDO + 99 IF(IFREE .EQ. 1) THEN + QHTITLE=ID(KFIRST:8)//QHTITLE(1:71+KFIRST) + ENDIF + READ(IQEUNIT,'(A8,A72)') ID,DLIN + IF(ID(1:3) .EQ. 'QEI' .OR. ID(1:3) .EQ. 'QT ') THEN + 101 NQHYD=NQHYD+1 +!IPK sep07 CHECK FOR COMMA'S +!IPK nov14 initialise TPRVH + tprvh=0 + IFREE=0 + DO K=1,8 + IF(ID(K:K) .NE. ',') THEN + IFREE=0 + ELSE + KFIRST=K+1 + IFREE=1 + GO TO 102 + ENDIF + ENDDO + 102 IF(IFREE .EQ. 1) THEN + DLIN=ID(KFIRST:8)//DLIN(1:71+KFIRST) + ENDIF +!IPK APR97 TEST FOR LIMIT + IF(NQHYD .GT. NELDS) THEN +!IPK SEP04 + CLOSE(75) + OPEN(75,file='ERROR.OUT') + WRITE(75,*) 'ERROR STOP TOO MANY ELEMENT INFLOWS' + WRITE(*,*) 'ERROR STOP TOO MANY ELEMENT INFLOWS' + STOP 'ERROR STOP TOO MANY ELEMENT INFLOWS' + ENDIF + NHYE(NQHYD)=0 +!IPK sep07 + if(ifree .eq. 0) then + READ(DLIN,'(3I8,2F16.2)',ERR=801) NCLINE(NQHYD),NEST(NQHYD),IYDATE(NQHYD),XYCEL(NQHYD,1),XYCEL(NQHYD,2) + GO TO 811 +801 READ(DLIN,'(3I8)') NCLINE(NQHYD),NEST(NQHYD),IYDATE(NQHYD) +811 CONTINUE + else + READ(DLIN,*) NCLINE(NQHYD),NEST(NQHYD),IYDATE(NQHYD) + endif + IF(NCLINE(NQHYD) .EQ. 0) NCLINE(NQHYD)=-9999 +! + IYD=IYDATE(NQHYD) +!IPK may11 set IYDOLD + IYDOLD=IYD + DO 120 I=1,NEDPTS+1 + READ(IQEUNIT,'(A8,A72)') ID,DLIN +!IPK sep07 ADD QN + IF(ID(1:3) .EQ. 'TI ') GO TO 98 + IF(ID(1:3) .EQ. 'QEI' .OR. ID(1:3) .EQ. 'QT ') THEN +! NHYE(NQHYD)=NHYE(NQHYD)+1 +!IPK jan96 add day of year to logic +! DYE(NHYE(NQHYD),NQHYD)=1.E+6 +! TAE(NHYE(NQHYD),NQHYD)=1.E+8 +! HAE(NHYE(NQHYD),NQHYD)=HAE(NHYE(NQHYD)-1,NQHYD) + GO TO 101 + ELSEIF(ID(1:2) .EQ. 'QE' .OR. ID(1:2) .EQ. 'QN' .OR. ID(1:2) .EQ. 'QD' .or. ID(1:2) .EQ. 'QM') THEN +!IPK jan96 add day of year to logic +!IPK sep07 CHECK FOR COMMA'S + IFREE=0 + DO K=1,8 + IF(ID(K:K) .NE. ',') THEN + IFREE=0 + ELSE + KFIRST=K+1 + IFREE=1 + GO TO 105 + ENDIF + ENDDO + 105 IF(IFREE .EQ. 1) THEN + DLIN=ID(KFIRST:8)//DLIN(1:71+KFIRST) + ENDIF +!IPK sep07 ALLOW FOR QN + IF(ID(1:2) .EQ. 'QE' .OR. ID(1:2) .EQ. 'QD') THEN + IF(IFREE .EQ. 0) THEN + READ(ID(5:8),'(F4.0)') DYE(I,NQHYD) + IF(IRMATYP .EQ. 2) READ(DLIN,'(2F8.0)') TAE(I,NQHYD),HAE(I,NQHYD) + IF(IRMATYP .EQ. 10) READ(DLIN,'(F8.0,I8,4F8.0)') TAE(I,NQHYD),ILAYRE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,3) + IF(IRMATYP .EQ. 11) READ(DLIN,'(F8.0,4F8.0)') TAE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,NQP) + else + IF(IRMATYP .EQ. 2) READ(DLIN,*) TAE(I,NQHYD),HAE(I,NQHYD) + IF(IRMATYP .EQ. 10) READ(DLIN,*) DYE(I,NQHYD),TAE(I,NQHYD),ILAYRE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,3) + IF(IRMATYP .EQ. 11) READ(DLIN,*) TAE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,NQP) + endif +!IPK SEP07 ADD DATE INPUT + ELSE +!IPK oct15 add decodat option + IF(IFREE .EQ. 1) THEN + READ(DLIN,'(A10)') DATE + READ(DLIN(12:80),*) TAE(I,NQHYD),HAE(I,NQHYD) + READ(DATE,'(I2,1X,I2,1X,I4)') IDAYY,IMTHH,IYYR + DYE(I,NQHYD)=IDAYY+JCNV(IMTHH) + IF(MOD(IYYR,4) .EQ. 0 .AND. IYYR .NE. 2000) THEN + IF(IMTHH .GT. 2) DYE(I,NQHYD)=DYE(I,NQHYD)+1 + ENDIF + ELSE + CALL DECODDAT(DLIN,DYE(I,NQHYD),TAE(I,NQHYD)) + IF(IRMATYP .EQ. 2) READ(DLIN(17:24),'(F8.0)') HAE(I,NQHYD) + IF(IRMATYP .EQ. 10) READ(DLIN(17:64),'(I8,4F8.0)') ILAYRE(I,NQHYD),HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,3) + IF(IRMATYP .EQ. 11) READ(DLIN(17:64),'(4F8.0)') HAE(I,NQHYD),(HDE(I,NQHYD,K),K=1,NQP) + ENDIF +!IPK oct15 end decodat update + ENDIF + IF(DAYOFY .LT. 0) THEN + DAYOFY=DYE(I,NQHYD) + TSTARTS=(DAYOFY-1)*24. + IYRR=IYD + ENDIF + NHYE(NQHYD)=NHYE(NQHYD)+1 +! IF(I .EQ. 1) THEN +! +! reduce input time to time since that set to start simulation +! + 110 CONTINUE +! IF(MOD(IYD,4) .EQ. 0) THEN +! ILP=1 +! ELSE +! ILP=0 +! ENDIF +! IF(IYD .EQ. IYRR) THEN +! +! If now for for the same year +! + TCUR1=(DYE(I,NQHYD)-1.)*24.+TAE(I,NQHYD) +! +! set time as the difference +! + TAE(I,NQHYD)=TCUR1 +! WRITE(75,*) I,TAE(I,NQHYD),HAE(I,NQHYD) +! ELSEIF(IYD .LT. IYRR) THEN +! IF(MOD(IYD,4) .EQ. 0) THEN +! TPRVH=TPRVH+366.*24. +! ELSE +! TPRVH=TPRVH+365.*24. +! ENDIF +! IYD=IYD+1 +! GO TO 110 +! ELSE +!IPK SEP04 +! CLOSE(75) +! OPEN(75,file='ERROR.OUT') +!IPK SEP00 +! WRITE(*,*) ' Element inflows for wrong year' +! WRITE(*,*) ' Execution stopped' +! WRITE(75,*) ' Element inflows for wrong year' +! WRITE(75,*) ' Excution stopped' +! STOP +! ENDIF +! ELSE +!IPK may11 reset IYD +! IYD=IYDOLD +! IF(DYE(I,NQHYD) .LT. DYE(I-1,NQHYD)) THEN +! TCUR1=TCUR1-365.*24. +!IPK MAY11 IF(ILP .EQ. 1) TCUR1=TCUR1-24. +!IPK MAY11 IYD=IYD+1 +! IF(MOD(IYD,4) .EQ. 0) THEN +! ILP=1 +! ELSE +! ILP=0 +! ENDIF +!IPK may11 +! IYDOLD=IYDOLD+1 +! IF(ILP .EQ. 1) TCUR1=TCUR1-24. +! ENDIF +! TCUR=(DYE(I,NQHYD)-1.)*24.+TAE(I,NQHYD) +! TAE(I,NQHYD)=TAE(I-1,NQHYD)+TCUR-TCUR1 +! TCUR1=TCUR +! WRITE(75,*) I,TAE(I,NQHYD),HAE(I,NQHYD) +! ENDIF + ELSE +! NHYE(NQHYD)=NHYE(NQHYD)+1 +!IPK jan96 add day of year to logic +! DYE(NHYE(NQHYD),NQHYD)=1.E+6 +! TAE(NHYE(NQHYD),NQHYD)=1.E+8 +! HAE(NHYE(NQHYD),NQHYD)=HAE(NHYE(NQHYD)-1,NQHYD) +! IF(IRMATYP .EQ. 10) THEN +! DO K=1,3 +! HDE(NHYE(NQHYD),NQHYD,K)=HDE(NHYE(NQHYD)-1,NQHYD,K) +! ENDDO +! ENDIF + GO TO 199 + ENDIF + 120 CONTINUE +!IPK SEP04 + CLOSE(75) + OPEN(75,file='ERROR.OUT') +!IPK SEP00 + WRITE(*,*) 'Execution terminated more lines than allowed in element graph' + WRITE(75,*)'Execution terminated more lines than allowed in element graph' + stop + ENDIF + 199 continue + ENDIF +200 CONTINUE + CLOSE(IQEUNIT) + IQEUNIT=0 + + DO I=1,NQHYD + IF(XYCEL(I,1) .EQ. 0. .AND. XYCEL(I,2) .EQ. 0) THEN + JJ=NCLINE(I) + CALL GETXCL(JJ,XYCEL(I,1),XYCEL(I,2)) + ENDIF + ENDDO + RETURN + END + +!IPK NOV14 ADD LEAP YEAR ROUTINE + + SUBROUTINE HRYRT(IYRKP,HRYR) + + IF(MOD(IYRKP,4) .EQ. 0) THEN + ILP=1 + HRYR=366.*24. + ELSE + ILP=0 + HRYR=365.*24. + ENDIF + RETURN + END + +!IPK NEW WITH VERSION 9.0H OCT 25 2015 + +! DECODE JULIAN DAY FROM DAY/MONTH/YEAR DATA + + SUBROUTINE DECODDAT(DATAIN,DAYJUL,TIME) + CHARACTER*72 DATAIN + REAL DAYJUL,TIME + INTEGER IMTS(12,2),IDAY,IMO,IYR,HR,MIN + DATA IMTS/0,31,59,90,120,151,181,212,243,273,304,334,0,31,60,91,121,152,182,213,244,274,305,335/ +! +! LOOP THROUGH COLUMNS ADDING A COMMA + IDBLNK=0 + DO I=1,16 + IF(DATAIN(I:I) .EQ. ':') THEN + IHSW=0 + DATAIN(I:I)=',' + ELSEIF(DATAIN(I:I) .EQ. '.') THEN + IHSW=1 + ENDIF + IF(DATAIN(I:I) .EQ. '/') DATAIN(I:I)=',' + IF(I .GT. 8 .AND. DATAIN(I:I) .EQ. ' ') THEN + IF(IDBLNK .EQ. 0) THEN + DATAIN(I:I)=',' + IDBLNK=1 + IHSW=1 + ELSE + DATAIN(I:I)='0' + ENDIF + ENDIF + ENDDO +! write(155,*) ihsw,datain(1:16) + IF(IHSW .EQ. 0) THEN + READ(DATAIN(1:16),*) IDAY,IMO,IYR,HR,MIN + TIME=HR+MIN/60. + ELSE + READ(DATAIN(1:16),*) IDAY,IMO,IYR,TIME +! write(155,*) IDAY,IMO,IYR,TIME + ENDIF + IF(MOD(IYR,4) .EQ. 0) THEN + DAYJUL=IMTS(IMO,2)+IDAY + ELSE + DAYJUL=IMTS(IMO,1)+IDAY + ENDIF + RETURN + END + + SUBROUTINE ALLOCFL(MAXPT,MAXTYP,IUNIT,ITYP) + + USE BLKELTLD + + CHARACTER*8 ID + NELDS=200 + MAXPT=0 +!IPK JUN09 RESTORE MAXTYP1 + MAXTYP1=0 + NQLM=0 + 200 CONTINUE + + READ(IUNIT,'(A8)', END=500) ID +!IPK JUN09 ADD TO IF OPTIONS + IF(ID(1:2) .EQ. 'TT' .OR. ID(1:2) .EQ. 'TH' .OR. ID(1:2) .EQ. 'TE' .OR. ID(1:2) .EQ. 'TI' & + & .OR. ID(1:3) .eq. 'CLQ' .OR. ID(1:3) .eq. 'CLH' & + & .OR. ID(1:3) .eq. 'QEI' .OR. ID(1:3) .eq. 'QT ' & + & .OR. ID(1:3) .EQ. 'TIT' .OR. ID(1:3) .EQ. 'CTL') THEN +!IPK SEP14 ADD TYPE 4 (STAGE FLOW) OPTION +!IPK JUN09 RESTORE MAXTYP1 + MAXTYP1=MAXTYP1+1 +! MAXTYP1=MAXTYP1+1 +!IPK JUN09 IF(NQLM .GT. MAXQPT) MAXPT=NQLM + IF(NQLM .GE. MAXPT) MAXPT=NQLM+1 + NQLM=0 + GO TO 200 + ELSEIF(ID(1:6) .EQ. 'ENDDAT') THEN +!IPK JUN09 ADD TO NQLM + + IF(NQLM .GT. MAXPT) MAXPT=NQLM+1 + GO TO 500 + ELSE + NQLM=NQLM+1 + GO TO 200 + ENDIF + +500 CONTINUE +!IPK JUN09 + write(90,*) maxtyp,maxtyp1,maxpt,nelds + IF(MAXTYP1 .GT. MAXTYP) MAXTYP=MAXTYP1 + + ALLOCATE (TAE(MAXPT,MAXTYP),HAE(MAXPT,MAXTYP),DYE(MAXPT,MAXTYP),HDE(MAXPT,MAXTYP,3),ILAYRE(MAXPT,MAXTYP)) + ALLOCATE (NCLINE(NELDS),NHYE(NELDS),IYDATE(NELDS),NEST(NELDS),XYCEL(NELDS,2)) + TAE=0. + HAE=0. + HDE=0. + DYE=0. + XYCEL=0. + ILAYRE=0 + REWIND IUNIT + RETURN + END + \ No newline at end of file diff --git a/src/GETNEWFIL.F90 b/src/GETNEWFIL.F90 new file mode 100644 index 0000000..e6d485e --- /dev/null +++ b/src/GETNEWFIL.F90 @@ -0,0 +1,757 @@ + SUBROUTINE GETNEWFIL(IIN,IGFG,ITRIAN,ISWT) + + INCLUDE 'BFILES.I90' + +! WRITE CURRENT DATA TO A SCRATCH FILE + + IF(IACTVFIL .GT. 0) THEN + IFILOUT=IACTVFIL+50 + CALL WRTFIL(IFILOUT) + CALL ZEROOUT + IACTVFIL=ITOTFIL + ELSE + IACTVFIL=1 + ENDIF + IF(ISWT .EQ. 1) THEN + ITOTFIL=ITOTFIL+1 + FNAMKEP='TEST.1.ELE' + IACTVFIL=ITOTFIL + FNAMEOUT(IACTVFIL)='TEST.1.ELE' + WRITE(90,*) 'ITOTFIL,IACTVFIL',ITOTFIL,IACTVFIL + WRITE(90,'(A80)') (FNAMEOUT(KKK),KKK=1,3) + ENDIF + IF(ITRIAN .EQ. 1) THEN + CALL READGFG(IIN,1) + +! TEST FOR GFG FORMAT + ELSEIF(IGFG .EQ. 1) THEN + CALL READGFG(IIN,0) + +! TEST FOR rm1 FORMAT + + ELSEIF(IIN .EQ. 10) THEN + CALL READRM1(IIN) + +! TEST FOR rm1 FORMAT + +!ipk feb08 replace iin of 11 with 12 + ELSEIF(IIN .EQ. 12 .and. IGFG .EQ. 0) THEN + CALL READGEO(IIN) + + ELSEIF(IIN .EQ. 12 .and. IGFG .EQ. 2) THEN + CALL RDBIN(IIN) + + ENDIF + + IFILOUT=IACTVFIL+50 + WRITE(90,*) 'IFILOUT', IFILOUT + CALL WRTFIL(IFILOUT) + IACTVFIL=1 + CALL LOADFIL + + + CALL RESCAL + CALL HEDR + + + RETURN + END + +! Write data to a file + SUBROUTINE WRTFIL(IFILOUT) + + USE BLK1MOD + CHARACTER*80 ALINE +! INCLUDE 'BLK1.COM' + + CLOSE (IFILOUT) + OPEN(IFILOUT,STATUS='scratch',FORM='binary') + + ISLP=0 + IPRT=1 + IPNN=1 + IPEN=1 + IPO=1 + IRO=1 + IPP=0 + IRFN=0 + IGEN=0 + NXZL=0 + NITST=1 + ISCTXT=0 + IFILL=0 + IALTGM=1 + NLAYD=0 + HORIZ=10. + VERT=8. + XSALE=0. + YSALE=0. + XFACT=0. + YFACT=0. + AR=0. + ANG=0. + xadded=0. + yadded=0. + ntempin=0. +! WRITE(90,*) 'IN GETNEWFIL', IFILOUT,NP,NE,IPRT + WRITE(IFILOUT) TITLE,NP,NE + WRITE(IFILOUT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & + & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin +! WRITE(90,*) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & +! & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin + WRITE(IFILOUT) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG + IF(IPP .GT. 0) WRITE(IFILOUT) ALINE + + WRITE(IFILOUT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE) + WRITE(IFILOUT) & + (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), & + & WIDBS(J),SSO(J),BS1(J),J=1,NP) + + WRITE(IFILOUT) NLST + IF(NLST .GT. 0) THEN + WRITE(IFILOUT) (LLIST(J),J=1,NLST), & + & ((ILIST(J,I),I=1,LLIST(J)),J=1,NLST) + ENDIF + + WRITE(IFILOUT) NENTRY,NLAYD,NCLM + + IF(NENTRY .GT. 0) THEN + WRITE(IFILOUT) ((NEF(I,J),J=1,3),I=1,NENTRY) + ENDIF + + IF(NLAYD .GT. 0) THEN + WRITE(IFILOUT) (LAY(I),I=1,NP) + ENDIF + + IF(NCLM .GT. 0) THEN + WRITE(IFILOUT) ((ICCLN(I,J),J=1,350),I=1,NCLM) + ENDIF + REWIND IFILOUT + RETURN + END + + SUBROUTINE READRM1(IIIN) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*48 DLIN + + IIN=IIIN +! Read in header lines + + ISET=1 + WRITE(90,*) 'GOING TO HEADIN' + CALL HEADIN(IIN,ISET) + +! Read in existing elements + WRITE(90,*) 'GOING TO RDELEM' + CALL RDELEM(IIN) + +! Read in nodal coordinates + + WRITE(90,*) 'GOING TO RDCORD' + CALL RDCORD(IIN) + +! Close input file + + CLOSE(IIN) + +! Scale for plotting + + IF(NP .GT. 0) THEN + DO J=1,NP + IF (CORD(J,1) .GT. VDX) THEN + XMIN=MIN(XMIN,CORD(J,1)) + XMAX=MAX(XMAX,CORD(J,1)) + YMIN=MIN(YMIN,CORD(J,2)) + YMAX=MAX(YMAX,CORD(J,2)) + ENDIF + ENDDO + ENDIF + + RETURN + END + +! Read GEO file + SUBROUTINE READGEO(IIIN) + USE BLK1MOD + CHARACTER*1000 HEADER + CHARACTER*8 ID8 + CHARACTER*32 IJNK + CHARACTER*80 ALINE,DLIN +! INCLUDE 'BLK1.COM' + INCLUDE 'BFILES.I90' + + INTEGER*2 NOP2(MAXE,8) + + + IIN=IIIN + read(iin,err=100) header + if(header(1:6) .eq. 'RMAGEN') then + inopt=2 + else + inopt=1 + rewind iin + endif + read(iin) n1,m1 + rewind iin + write(90,*) 'Apparent nodes and elements from file are' + write(90,'(i15,i10)') n1,m1 + if(n1 .gt. maxp .or. m1 .gt. maxe) then +! +!...... Perhaps the file format is wrong, close and reopen +! + WRITE(DLIN,'(A32)') 'Parameter limits may be violated' + call symbl(0.5,4.5,0.20,dlin,0.0,32) + WRITE(DLIN,'(A35)') 'Retrying with alternate file format' + call symbl(0.5,4.2,0.20,dlin,0.0,35) + close (iin) + open(iin ,file=fnamkep,status='old',form='unformatted') + read(iin) n1,m1 + write(90,*) 'Revised nodes and elements from file are' + write(90,'(i15,i10)') n1,m1 + if(n1 .gt. maxp .or. m1 .gt. maxe) then + WRITE(DLIN,'(A31)') 'Parameter limits still violated' + call symbl(0.5,3.9,0.20,dlin,0.0,31) + WRITE(DLIN,'(A27)') 'Apparent nodes and elts are' + call symbl(0.5,3.6,0.20,dlin,0.0,27) + WRITE(DLIN,'(2i10)') n1,m1 + call symbl(0.5,3.3,0.20,dlin,0.0,20) + WRITE(DLIN,'(A24)') 'Press enter to terminate' + call symbl(0.5,4.5,0.20,dlin,0.0,24) + CALL GTCHARX(ijnk,ndig,5.0,4.0) +!cipk aug00 read(*,'(i1)') junk + call quit_pgm + endif + endif + rewind iin +! +! + if(inopt .eq. 2) then + read(iin,err=100) header + READ(IIN,ERR=100) & + & N1,M1,((CORD(J,K),K=1,2),ALPHA,WD(J),J=1,N1), & + & ((NOP(J,K),K=1,8),IMAT(J),THTA(J),I3,J=1,M1) & + & , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1) + DO J=1,N1 + XUSR(J)=CORD(J,1) + YUSR(J)=CORD(J,2) + ENDDO +! + else + READ(IIN,ERR=100) & + & N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), & + & ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1) & + & , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1) + DO J=1,N1 + DO K=1,2 + CORD(J,K)=CORDSN(J,K) + ENDDO + XUSR(J)=CORD(J,1) + YUSR(J)=CORD(J,2) + ENDDO + DO J=1,M1 +!ipk feb08 + ncorn(j)=0 + DO K=1,8 + NOP(J,K)=NOP2(J,K) +!ipk feb08 + if(nop(j,k) .gt. 0) ncorn(j)=k + ENDDO + ENDDO + endif + read(IIN,err=120,end=120) id8 + if(id8(1:6) .eq. 'part-2') then + read(IIN,err=104) (widbs(j),sso(j),j=1,n1) + read(IIN,err=120,end=120) id8 + endif + +! Add part 3 write for continuity lines + if(id8(1:6) .eq. 'part-3') then + +!ipk aug02 IF(NCLM .GT. 0) THEN + READ(IIN,ERR=104) NCLM,((ICCLN(I,J),J=1,350),I=1,NCLM) +!ipk aug02 ENDIF + read(IIN,err=120,end=120) id8 + endif +!IPK DEB02 Add part 4 write for lock and BS1 lines and reordering + if(id8(1:6) .eq. 'part-4') then + read(iin,err=104,end=120) (lock(j),bs1(j),j=1,n1) + read(iin,err=104,end=120) & + nlst,((ilist(j,k),k=1,maeln),llist(j),j=1,maxln) + endif + DO J=1,M1 +!ipk feb08 + ncorn(j)=0 + DO K=1,8 +!ipk feb08 + if(nop(j,k) .gt. 0) ncorn(j)=k + ENDDO + ENDDO + + GO TO 120 + + 100 READ(IIN,ERR=104) & + & N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), & + & ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1) + DO J=1,N1 + DO K=1,2 + CORD(J,K)=CORDSN(J,K) + ENDDO + XUSR(J)=CORD(J,1) + YUSR(J)=CORD(J,2) + ENDDO + DO J=1,M1 +!ipk feb08 + ncorn(j)=0 + DO K=1,8 + NOP(J,K)=NOP2(J,K) +!ipk feb08 + if(nop(j,k) .gt. 0) ncorn(j)=k + ENDDO + ENDDO + GO TO 120 + + 104 WRITE(90,*) 'Error reading binary geometry file' +!ipk jan98 CALL SETD(23) + call clscrn() + WRITE(aline,*) 'Error reading binary geometry file' + call symbl & + & (1.1,3.3,0.20,aline,0.0,80) + WRITE(aline,*) 'Press enter to exit' + call symbl & + & (1.1,3.0,0.20,aline,0.0,80) + ndig=1 + CALL GTCHARX(IJNK,NDIG,5.0,7.6) + CALL Quit_Pgm + STOP + + 120 CONTINUE + NP=N1 + NE=M1 + +! Close input file + + CLOSE(IIN) + +! Scale for plotting + + IF(NP .GT. 0) THEN + DO J=1,NP + IF (CORD(J,1) .GT. VDX) THEN + XMIN=MIN(XMIN,CORD(J,1)) + XMAX=MAX(XMAX,CORD(J,1)) + YMIN=MIN(YMIN,CORD(J,2)) + YMAX=MAX(YMAX,CORD(J,2)) + ENDIF + ENDDO + ENDIF + RETURN + + END + + SUBROUTINE READGFG(IUNIT,ISW) + + USE BLK1MOD + INCLUDE "BFILES.I90" +! INCLUDE 'BLK1.COM' + CHARACTER*1 ANS + CHARACTER*32 ANS32 + CHARACTER*3 ID + CHARACTER*77 DLIN + CHARACTER*150 DLIN1 + CHARACTER*80 LIND + DIMENSION NTMP(9),NTEMPLIN(200,10),ATT(9) + + REAL*8 CX,CY,VALS(7) + + MEL=MAXE + ylv=7.5 + IIN=IUNIT + IPRT=1 + IPNN=1 + IPEN=1 + IPO=1 + IRO=1 + IPP=0 + IRFN=0 + IGEN=0 + NXZL=0 + NITST=1 + ISCTXT=0 + IFILL=0 + IALTGM=1 + NLAYD=0 + HORIZ=10. + VERT=8. + XSALE=0. + YSALE=0. + XFACT=0. + YFACT=0. + AR=0. + ANG=0. + xadded=0. + yadded=0. + ntempin=0. + KLIN=0 + IF(ISW .EQ. 1) GO TO 500 + DO I=1,10000 + READ(IIN,'(A3,A77)') ID,DLIN + IF(ID .EQ. 'T1 ') THEN + TITLE(1:77)=DLIN + GO TO 10 + ENDIF + ENDDO + 10 CONTINUE + REWIND IIN + +! READ ELEMENT AND CCLINE DATA + + 20 CONTINUE + DO ICOUNTC=1,200000 + DO JJ=1,150 + DLIN1(JJ:JJ)=' ' + ENDDO + READ(IIN,'(A3,A150)', END=175) ID,DLIN1 + IF(ID .EQ. 'GE ' .or. ID .EQ. 'GO') THEN +! Count the number of variables + I=0 + ICOUNT=0 + 25 CONTINUE + IF(DLIN1(I+1:I+1) .NE. ' ') THEN + GO TO 30 + ELSE + I=I+1 + GO TO 25 + ENDIF + 30 I=I+1 + IF(I .EQ. 151) THEN + ICOUNT =ICOUNT+1 + GO TO 40 + ENDIF + IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN + ICOUNT=ICOUNT+1 + 35 CONTINUE + IF(I+1 .EQ. 151) GO TO 40 + IF(DLIN1(I+1:I+1) .EQ. ' ') THEN + I=I+1 + GO TO 35 + ELSE + GO TO 30 + ENDIF + ELSE + GO TO 30 + ENDIF + ENDIF + ENDDO + 40 CONTINUE + IF(ID .EQ. 'GO') THEN + KLIN=KLIN+1 + READ(DLIN1,*) (NTEMPLIN(KLIN,K),K=1,ICOUNT) + GO TO 20 + ENDIF + IF(ICOUNT .GT. 10) THEN + READ(DLIN1,*) J, (NTMP(K),K=1,9),THT + ELSE + READ(DLIN1,*) J, (NTMP(K),K=1,9) + ENDIF + + + IF (J .GE. MEL) THEN + CALL SETD(23) +!cipk aug00 + WRITE(lind,*) ' Element number exceeds MAXE in RDELEM' + call symbl (1.1,ylv-0.3,0.20,lind,0.0,80) + ndig=1 + WRITE(90,*) ' Element number exceeds MAXE in RDELEM' + WRITE(lind,6000) + CALL GTCHARX(ANS32,IJNK,5.0,4.0) + CALL Quit_Pgm + STOP + ENDIF +! +! Check to ensure there are no duplicate numbers in input stream +! of element connections +! + DO K=1,7 + IF(NTMP(K) .NE. 0) THEN + DO L=K+1,8 + IF(NTMP(K) .EQ. NTMP(L)) THEN + CALL SETD(23) + DO KK=1,8 + NOP(J,KK) = NTMP(KK) + ENDDO + IMAT(J)=NTMP(9) + call eltdisp(j) + DO KK=1,8 + NTMP(KK) = NOP(J,KK) + ENDDO + NTMP(9)=IMAT(J) + GO TO 45 + ENDIF + ENDDO + ENDIF + ENDDO + 45 CONTINUE + DO K=1,8 + NOP(J,K) = NTMP(K) + ND = NTMP(K) + IF (ND .GT. 0) THEN + INEW(ND) = 2 + NP = MAX(NP,ND) + ENDIF + ENDDO +! + NCN = 2 + IF (NOP(J,3) .NE. 0) NCN = 3 + IF (NOP(J,4) .NE. 0) NCN = 4 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6 + IF (NOP(J,6) .NE. 0) NCN = 6 + IF (NOP(J,7) .NE. 0) NCN = 8 + NCORN(J) = NCN + IESKP(J) = 0 + IMAT(J) = NTMP(9) + THTA(J)=THT + IEM(J) = J + DO 50 K=2,NCN,2 + ND = NTMP(K) + IF (ND .GT. 0) THEN + IF(NCN .EQ. 5 .AND. K .EQ. 4) GO TO 50 + WD(ND)=0. + ENDIF + 50 CONTINUE + NE = MAX(J,NE) +! + GOTO 20 +! + 175 CONTINUE + + REWIND IIN + 70 CONTINUE + DO ICOUNTC=1,100000 + DO JJ=1,150 + DLIN1(JJ:JJ)=' ' + ENDDO + READ(IIN,'(A3,A150)', END=400) ID,DLIN1 + IF(ID .EQ. 'GNN' .OR. ID .EQ. 'GWN') THEN +! Count the number of variables + I=0 + ICOUNT=0 + 75 CONTINUE + IF(DLIN1(I+1:I+1) .NE. ' ') THEN + GO TO 80 + ELSE + I=I+1 + GO TO 75 + ENDIF + 80 I=I+1 + IF(I .EQ. 151) THEN + ICOUNT =ICOUNT+1 + GO TO 90 + ENDIF + IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN + ICOUNT=ICOUNT+1 + 85 CONTINUE + IF(I+1 .EQ. 151) GO TO 90 + IF(DLIN1(I+1:I+1) .EQ. ' ') THEN + I=I+1 + GO TO 85 + ELSE + GO TO 80 + ENDIF + ELSE + GO TO 80 + ENDIF + ENDIF + ENDDO + 90 CONTINUE + DO K=1,7 + VALS(K)=0. + ENDDO + READ(DLIN1,*) J,(VALS(K),K=1,ICOUNT-1) + IF(ID .EQ. 'GNN') THEN + CX=VALS(1) + CY=VALS(2) + BELEV=VALS(3) + NP = MAX(NP,J) + CORD(J,1) = CX + CORD(J,2) = CY + XUSR(J) = CX + YUSR(J) = CY + WD(J) = BELEV + INSKP(J)=0 + INEW(J) = 1 + GO TO 70 + ELSE + WDTHX=VALS(1) + SS1X=VALS(2) + SS2X=VALS(3) + WDSX=VALS(4) + WIDTH(J)=WDTHX + SS1(J)=SS1X + SS2(J)=SS2X + WIDS(J)=WDSX + GO TO 70 + ENDIF + + 400 CONTINUE + +! CHECKOUT THE CCLINE DATA + + KK=0 + IF(KLIN .GT. 0) THEN + NCLM=1 + IF(NTEMPLIN(1,1) .EQ. 1) THEN + DO K=1,KLIN + DO J=1,10 + IF(K .EQ. 1 .AND. J .EQ. 1) GO TO 410 + IF(NTEMPLIN(K,J) .LT. 0) THEN + NCLM=NCLM+1 + KK=0 + GO TO 420 + ELSEIF(NTEMPLIN(K,J) .EQ. 0) THEN + GO TO 420 + ELSE + KK=KK+1 + ICCLN(NCLM,KK)=NTEMPLIN(K,J) + ENDIF + 410 CONTINUE + ENDDO + 420 CONTINUE + ENDDO + NCLM=NCLM-1 + ENDIF + ENDIF + RETURN + +500 CONTINUE + + READ(IUNIT,*) NE,NCNTR,NATTR + IMIDS=0 + DO JJ=1,NE + READ(IUNIT,*) J,(NTMP(K),K=1,NCNTR),(ATT(K),K=1,NATTR) + IF (J .GE. MEL) THEN + CALL SETD(23) + WRITE(lind,*) ' Element number exceeds MAXE in RDELEM' + call symbl & + & (1.1,ylv-0.3,0.20,lind,0.0,80) + ndig=1 + WRITE(90,*) ' Element number exceeds MAXE in RDELEM' + WRITE(lind,6000) + CALL GTCHARX(ANS32,IJNK,5.0,4.0) + CALL Quit_Pgm + STOP + ENDIF + DO KK=1,3 + NOP(J,2*KK-1) = NTMP(KK) + NOP(J,2*KK)=0 + ENDDO + IF(NATTR .GT. 0) THEN + IMAT(J)=ATT(1) + ELSE + IMAT(J)=1 + ENDIF + NCORN(J)=6 + IESKP(J)=0 + ENDDO + CLOSE(IUNIT) + DO L=255,1,-1 + IF(FNAMKEP(L:L) .EQ. '.') THEN + FNAMKEP(L+1:L+4)='node' + OPEN(IUNIT,FILE=FNAMKEP,STATUS='OLD',ACTION='READ') + GO TO 510 + ENDIF + ENDDO +510 CONTINUE + + READ(IUNIT,*) NPPP,NDUM,NATTR + DO KK=1,NPPP + READ(IUNIT,*) J,CX,CY,(VALS(K),K=1,NATTR) + IF(J .EQ. 0) THEN + J=NPPP + JZ=1 + ENDIF + BELEV=-9999. + WEL=0. + LOCK1=0 + IF(NATTR .GT. 0) BELEV=VALS(1) + IF (J .GE. MAXP) THEN + call clscrn() + WRITE(dlin,*) ' Node number exceeds MAXP in RDCORD',j + call symbl & + & (1.1,3.3,0.20,dlin,0.0,80) + WRITE(90,*) ' Node number exceeds MAXP in RDCORD' + WRITE(DLIN,*) ' Press enter to exit' + call symbl & + & (1.1,3.0,0.20,dlin,0.0,80) + ndig=1 + CALL GTCHARX(ANS32,ndig,5.0,4.0) + CALL Quit_Pgm + STOP + ENDIF + NP = MAX(NP,J) + CORD(J,1) = CX + CORD(J,2) = CY + XUSR(J) = CX + YUSR(J) = CY + WD(J) = BELEV + WIDTH(J)=0. + SS1(J)=0. + SS2(J)=0. + WIDS(J)=0. + WIDBS(J)=0. + SSO(J)=0. + INSKP(J)=0 + INEW(J) = 1 + LOCK(J)=LOCK1 + BS1(J)=0. + ENDDO + + CLOSE(IUNIT) + 6000 FORMAT(' Press enter to exit') + END + + + SUBROUTINE ZEROOUT + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + MNP = MAXP + MEL = MAXE + DO I=1,MEL + DO M=1,8 + NOP(I,M)=0 + ENDDO + IESKP(I)=-1 + IEM(I) = 0 + IMAT(I) = 0 + THTA(I)=0. + XC(I) = -1.E20 + YC(I) = -1.E20 + ENDDO + DO I=1,MNP + XUSR(I) = -1.D20 + YUSR(I) = -1.D20 + CORD(I,1) = -1.D20 + CORD(I,2) = -1.D20 + WD(I) = -9999. + LAY(I) = -9999 + WIDTH(I) = 0.0 + SS1(I) = 0.0 + SS2(I) = 0.0 + WIDS(I) = 0.0 + WIDBS(I)=0. + SSO(I)=0. + INSKP(I) = 1 + INEW(I) = 0 +!ipk mar02 + lock(i)=0 + bs1(I)=0. + ENDDO + NP=0 + NE=0 + RETURN + END + diff --git a/src/GETPGRP.F90 b/src/GETPGRP.F90 new file mode 100644 index 0000000..bda8585 --- /dev/null +++ b/src/GETPGRP.F90 @@ -0,0 +1,109 @@ + SUBROUTINE GETGRP + + USE BLK1MOD + + CHARACTER*8 IDSAV,ID + CHARACTER*72 DLINSAV,DLIN + + IDSAV=ID + DLINSAV=DLIN + +! ALLOCATE ARRAY SIZES + + IF(.NOT. ALLOCATED(IGRPNUM)) THEN + ALLOCATE (IGRPNUM(25,MAXE),MAXENT(25)) + IGRPNUM=0 + ENDIF +! +! NOW READ DATA TO FILE + + CALL GINPT(IGRP,ID,DLIN) + IF(ID(1:3) .EQ. 'TIT') THEN + +! READ TITLE + + READ(DLIN,'(A72)') HEDR + CALL GINPT(IGRP,ID,DLIN) + ENDIF + MAXIGRP=0 + + 301 READ(DLIN,'(I8)') IGRPA + CALL GINPT(IGRP,ID,DLIN) + NL=1 + NH=9 + + 401 CONTINUE + IF(ID(1:3) .EQ. 'NGP') THEN + READ(DLIN,'(9I8)') (IGRPNUM(IGRPA,I),I=NL,NH) + CALL GINPT(IGRP,ID,DLIN) + IF(IGRPNUM(IGRPA,NH) .NE. 0) THEN + NL=NL+9 + NH=NH+9 + GO TO 401 + ENDIF + ENDIF + +! SET MAXIMA FROM INPUT FILE + + IF(MAXIGRP .LT. IGRPA) MAXIGRP=IGRPA + MAXENT(IGRPA)=NH + + IF(ID(1:3) .EQ. 'GRP') GO TO 301 + CALL TOSER + ID=IDSAV + DLIN=DLINSAV + CALL PLOTOT(1) + RETURN + END + + SUBROUTINE WRTGP + + USE WINTERACTER + USE BLK1MOD + include 'd.inc' + + CHARACTER(LEN=256) :: FILTER + CHARACTER(LEN=96) :: FNAME + LOGICAL :: OPENED + + IGRPOUT=29 + INQUIRE(29, OPENED=OPENED) + if(.not. opened) then + Filter='TXT file -- *.txt|*.txt|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Group File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + OPEN(IGRPOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') + ELSE + RETURN + ENDIF + ENDIF + CALL TOPAR + REWIND IGRPOUT + WRITE(IGRPOUT,'(a)') 'TIT GROUP FILE' + + DO K=1,25 + IF(MAXENT(K) .GT. 0) THEN + WRITE(IGRPOUT,6001) K + LROWS=MAXENT(K)/9+1 + LASTCOL=MOD(MAXENT(K),9) + IF(LASTCOL .EQ. 0) THEN + IF(IGRPNUM(K,MAXENT(K)) .EQ. 0) THEN + LROWS=LROWS-1 + ENDIF + ENDIF + NL=-8 + DO LL=1,LROWS + NL=NL+9 + NH=NL+8 + WRITE(IGRPOUT,6002) (IGRPNUM(K,L),L=NL,NH) + ENDDO + ENDIF + ENDDO + 6001 FORMAT('NGP ',I8) + 6002 FORMAT('GRP ',9I8) + RETURN + END + \ No newline at end of file diff --git a/src/GETSTRESSFIL.F90 b/src/GETSTRESSFIL.F90 new file mode 100644 index 0000000..57e2f70 --- /dev/null +++ b/src/GETSTRESSFIL.F90 @@ -0,0 +1,175 @@ + SUBROUTINE GETSTRESSFIL + USE WINTERACTER + USE BLK1MOD + include 'd.inc' + + ALLOCATABLE WDTEMP(:) + CHARACTER*256 FILTER,FNAME + INTEGER IYRR,IMON,IDAY + REAL HOUR + LOGICAL OPENED + DATA IYRR/2015/,IMON/1/,IDAY/1/ + DATA HOUR/0.0/ + + IF(.NOT. ALLOCATED(WDTEMP)) THEN + + ALLOCATE (WDTEMP(NP)) + ENDIF + DO N=1,NP + WDTEMP(N)=WD(N) + ENDDO + +100 CONTINUE + + ISWT=-1 + + IWRTMP=0 + IF(IMP .GT. 0) THEN +! FIRST WRITE EXISTING MAP TO SCRATCH + OPEN(98,FORM='BINARY',STATUS='SCRATCH') + + CALL WRTMAP(98) + REWIND 98 + IWRTMP=1 + ENDIF + CALL GMAP + + CALL GRIDSB(ISWT) + + INQUIRE(104, OPENED=OPENED) + IF(OPENED) GO TO 200 + Filter='Output file -- *.dat|*.dat|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Stress File') + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + IOT=104 + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') + ELSE + GO TO 500 + ENDIF +200 CONTINUE + CALL SETDT(IYRR,IMON,IDAY,HOUR) + WRITE(IOT,'(''DATE '',3I8,F8.3)') IYRR,IMON,IDAY,HOUR + DO J=1,NP + IF (INEW(J) .EQ. 1) THEN + WRITE(IOT,'(''WAVESS '',I8,F8.4)') J,WD(J) + ENDIF + ENDDO + WRITE(IOT,'(''ENDBLOCK'')') + FLUSH(IOT) + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to process another map file?'//& + CHAR(13)//' ','PROCESS ANOTHER?') +! +! If answer 'No', return +! + IF (WInfoDialog(4).EQ.2) THEN + WRITE(IOT,'(''ENDDATA'')') + FLUSH(IOT) + GO TO 500 + ENDIF + GO TO 100 +! +! Delete all unused nodes +! + CALL DELETM(2) + +500 DO N=1,NP + WD(N)=WDTEMP(N) + ENDDO + DEALLOCATE (WDTEMP) + IF(IWRTMP .GT. 0) THEN + + CALL RDMAP(2,98,0,0) + CLOSE (98) + ENDIF + + RETURN + END + + SUBROUTINE SETDT(N1,N2,N3,R1) + use winteracter + + implicit none + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3,IERR + real :: R1 + character*3 :: sub + + call wdialogload(IDD_SETYRDT) + ierr=infoerror(1) + + CALL WDialogPutInteger(idf_integer1,n1) + CALL WDialogPutInteger(idf_integer2,n2) + CALL WDialogPutInteger(idf_integer3,n3) + CALL WDialogPutReal(idf_real1,r1) + + CALL WDialogSelect(IDD_setyrdt) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(idf_integer1,n1) + CALL WDialogGetInteger(idf_integer2,n2) + CALL WDialogGetInteger(idf_integer3,n3) + CALL WDialogGetReal(idf_real1,r1) + RETURN + ENDIF + ENDDO + RETURN + END + + SUBROUTINE GMAP + USE WINTERACTER + + include 'd.inc' + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB,SUB1 + INTEGER IMP + + CALL WSelectFile(ID_STRING1,PromptOn,FNAME,'Load Map File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + IF(SUB .EQ. 'map') then + IMP=9 + OPEN(9,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then + IMP=94 + OPEN(94,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'mpb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read') + ELSEIF(SUB .EQ. 'mbb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read') + ELSEIF(SUB .EQ. 'rm1') then + imp=13 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'shp') then + IMP=113 + OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + SUB='DBF' + CALL ADDSUB(FNAME,SUB) + OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + ENDIF + ENDIF + CALL RDMAP(2,IMP,0,0) + CLOSE (IMP) + RETURN + END \ No newline at end of file diff --git a/src/GETTRIANG.F90 b/src/GETTRIANG.F90 new file mode 100644 index 0000000..06f8e7a --- /dev/null +++ b/src/GETTRIANG.F90 @@ -0,0 +1,139 @@ +! Last change: IPK 2 Feb 2003 6:25 pm + SUBROUTINE DELAUNAY1(XMAP1,YMAP1,NVERT) + + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*80 LIND + CHARACTER*1 ANS + REAL*8 XMAP1(*),YMAP1(*) + DATA VDX9/-9.E9/,NEDGE/0/ + +! Get location of supertriangle + + iprt=0 + ngap=0 + + + + call supert(XMAP1,YMAP1,NVERT) + + NELTS=1 + + NVERTM=NVERT-3 + +! Sort points into ascending x order + + CALL SORTDB(XMAP1,NKEY,NVERTM) + +! Loop on the vertices + + YLV=7.5 + DO NN=1,NVERT-3 + + + if(mod(NN,2500) .eq. 0) then + ylv=ylv-0.3 + if(ylv .lt. 0.1) then + ylv=7.9 + call clscrn + endif + write(lind,6010) NN + 6010 format(i8,' points processed') + call symbl & + & (1.1,ylv,0.20,LIND,0.0,80) + endif + +! process next point + + N=NKEY(NN) + +! Skip out if inactive point + IF(N .EQ. 0) GO TO 500 + IF(XMAP1(N) .LT. VDX9) GO TO 500 + + IF(NN .LT. NVERTM) THEN + DO KK=NN+1,NVERTM + K=NKEY(KK) + IF(K .NE. 0) THEN + IF(XMAP1(N) .EQ. XMAP1(K)) THEN + IF(YMAP1(N) .EQ. YMAP1(K)) THEN + WRITE(45,*) 'IDENT',N,K + NKEY(KK)=0 + ENDIF + ELSE + GO TO 200 + ENDIF + ENDIF + 200 CONTINUE + ENDDO + ENDIF + +! Set edge buffers to zero + + IF(NEDGE .GT. 0) THEN + DO J=1,NEDGE + IEDGE(J,1)=0 + IEDGE(J,2)=0 + END DO + ELSE + DO J=1,100 + IEDGE(J,1)=0 + IEDGE(J,2)=0 + END DO + ENDIF + NEDGE=0 + +! test for point in circumcircle + + DO J=1,NELTS + CALL INSIDCIRC(XMAP1,YMAP1,J,N,ISWT) + +! If inside process edges + + IF(ISWT .EQ. 1) THEN + CALL PROCESS(J,NEDGE,NGAP) + ENDIF + END DO + +! Setup to form new triangles + + CALL SETEDG(NEDGE) + +! Now form triangles as needed + + DO J=1,NEDGE + IF(IEDGE(J,1) .NE. 0) THEN + CALL FORMT(XMAP1,YMAP1,J,N,NGAP,KK) + ENDIF + END DO + + NEDGE=0 + if(iprt .eq. 0) go to 500 + DO J=1,NELTS + IF(NOPEL(J,1) .GT. 0) THEN + WRITE(3,'(2i5,2i10,19x,''1'')') J,(NOPEL(J,K),K=1,3) + ENDIF + END DO + + + IF(NN .EQ. 1) THEN + write(41,'('' 9999'')') + do j=1,nvert + write(41,'(i10,2f20.4,F10.3)') j,XMAP1(j),YMAP1(j),VAL(J) + enddo + write(41,'('' 9999'')') + write(41,'('' 9999'')') + write(41,'('' 0 NENTRY'')') + write(41,'('' 0 NCLM'')') + WRITE(41,'(''ENDDATA'')') + ENDIF + 500 continue + END DO + +! Get rid of elements from super point + + CALL RIDPOINT(NVERT) + + RETURN + END SUBROUTINE diff --git a/src/GETWT.F90 b/src/GETWT.F90 new file mode 100644 index 0000000..aae3c8e --- /dev/null +++ b/src/GETWT.F90 @@ -0,0 +1,215 @@ + SUBROUTINE TRIANINT(NMAP,M,ISWT,ITIME) + + USE BLKMAP + USE BLK1MOD + SAVE +! INCLUDE 'BLK1.COM' + + DIMENSION WGT(8) +! data itime/0/ + + +! Search for element that has circumcircle around the node + + IF(ISWT .NE. 0) THEN + IF(ITIME .EQ. 0) NSTART=1 + ELSE + NSTART=1 + ENDIF + DO N=NSTART,NELTS + IF(NOPEL(N,1) .EQ. 0) GO TO 200 + if(RADS(N) .eq. 0.) then + CALL CCENTRE(XMAP(NOPEL(N,1)),XMAP(NOPEL(N,2)),XMAP(NOPEL(N,3)) & + &,YMAP(NOPEL(N,1)),YMAP(NOPEL(N,2)),YMAP(NOPEL(N,3)) & + &,XCEN(N),YCEN(N),RADS(N)) + endif + + IF(RADS(N)+XCEN(N) .GE. XUSR(M)) THEN + NSTART=N + GO TO 210 + ENDIF + 200 CONTINUE + ENDDO + 210 CONTINUE + WRITE(155,*) M,NSTART + DO N=NSTART,NELTS + IF(NOPEL(N,1) .EQ. 0) GO TO 250 + if(RADS(N) .eq. 0.) then + CALL CCENTRE(XMAP(NOPEL(N,1)),XMAP(NOPEL(N,2)),XMAP(NOPEL(N,3)) & + &,YMAP(NOPEL(N,1)),YMAP(NOPEL(N,2)),YMAP(NOPEL(N,3)) & + &,XCEN(N),YCEN(N),RADS(N)) + endif + xminl=min(XMAP(NOPEL(N,1)),XMAP(NOPEL(N,2)),XMAP(NOPEL(N,3))) + xmaxl=max(XMAP(NOPEL(N,1)),XMAP(NOPEL(N,2)),XMAP(NOPEL(N,3))) + yminl=min(YMAP(NOPEL(N,1)),YMAP(NOPEL(N,2)),YMAP(NOPEL(N,3))) + ymaxl=max(YMAP(NOPEL(N,1)),YMAP(NOPEL(N,2)),YMAP(NOPEL(N,3))) + if(xusr(m) .lt. xminl .or. xusr(m) .gt. xmaxl) then + go to 250 + elseif(yusr(m) .lt. yminl .or. yusr(m) .gt. ymaxl) then + go to 250 + endif + + DISQ=(XUSR(M)-XCEN(N))**2+(YUSR(M)-YCEN(N))**2 + +! write(142,*) m,n,disq,rads(n)**2,xusr(m),xcen(n) + IF(DISQ .LE. RADS(N)**2*1.0001) THEN + +! We have a candidate + + CALL GETWT(N,XUSR(M),YUSR(M),WGT,1) + DO K=1,3 + IF(WGT(K) .LT. -1E-4 .OR. WGT(K) .GT. 1.0001) THEN + WRITE(142,*) 'REJECT',n,disq,rads(n)**2,wgt(1),wgt(2),wgt(3) + GO TO 250 + ENDIF + ENDDO + WD(M)=WGT(1)*VAL(NOPEL(N,1))+WGT(2)*VAL(NOPEL(N,2))+WGT(3)*VAL(NOPEL(N,3)) + FPN = WD(M)*10. + X = CORD(M,1) + Y = CORD(M,2) - .11 + IF(X .GT. 0. .AND. X .LT. HSIZE .AND. & + & Y .GT. 0. .AND. Y .LT. 7.5) THEN + CALL RRED + CALL NUMBR(X,Y,0.1,FPN,0.0,-1) + endif + GO TO 300 + ENDIF + 250 CONTINUE + ENDDO + 300 CONTINUE + ITIME=1 + + RETURN + END + + + SUBROUTINE GETWT(N,XSW,YSW,WGT,ISWT) + +!- +!......SUBROUTINE TO EVALUATE FUNCTION AT GRID POINTS +!- +!- N = ELEMENT NUMBER +!_ XSW = X COORDINATE OF DESIRED POINT +!_ YSW = Y COORDINATE OF DESIRED POINT +! WGT(8) = ARRAY OF WEIGHTING FUNCTIONS +! ISWT = SWITCH FOR CHOICE BETWEEN LINEAR AND QUADRATIC WEIGHTING +! = 1 FOR LINEAR +! = 2 FOR QUADRATIC +! FROM COMMON +! NOP = LIST OF NODAL CONNECTIONS AROUND AN ELEMET +! CORD = REAL*8 ARRAY OF NODAL COORDINATES +! + USE BLKMAP + USE BLK1MOD + REAL*8 XN,DNX,DNY,XSW,YSW + DOUBLE PRECISION XG,YG,XK,YK,XP,YP +! INCLUDE 'BLK1.COM' +!- + DIMENSION X(9),Y(9),WGT(8) +!- + DATA TOL/0.01/ +!- + +!- +!......DETERMINE ELEMENT TYPE +!- +!IPKOCT93 ADD + if(n .eq. 1910) then + aaa=0 + endif + NCN=6 + IT=2 +!- +!......ESTABLISH LOCAL COORDINATES FOR EACH NODE POINT OF ELEMENT +!- + K1=NOPEL(N,1) + X(1)=0. + Y(1)=0. + DO 300 K=3,NCN,2 + K2=NOPEL(N,K/2+1) + X(K)=XMAP(K2)-XMAP(K1) + Y(K)=YMAP(K2)-YMAP(K1) + 300 END DO + X(2)=X(3)/2. + Y(2)=Y(3)/2. + X(4)=(X(3)+X(5))/2. + Y(4)=(Y(3)+Y(5))/2. + X(6)=X(5)/2. + Y(6)=Y(5)/2. + xminl=min(x(1),x(3),x(5)) + yminl=min(y(1),y(3),y(5)) + xmaxl=max(x(1),x(3),x(5)) + ymaxl=max(y(1),y(3),y(5)) + + +!- +!......ESTABLISH LOCAL COORDINATES OF DESIRED POINT +!- + XP=XSW-XMAP(K1) + YP=YSW-YMAP(K1) + + if(xp .lt. xminl .or. xp .gt. xmaxl) then + wgt(1)=2.0 + return + elseif(yp .lt. yminl .or. yp .gt. ymaxl) then + wgt(1)=2.0 + return + endif + XG=0. + YG=0. +!- +!......ITERATE TO FIND LOCAL COORDINATE +!- + DO 400 ITER=1,10 + DXKDX=0. + DXKDY=0. + DYKDX=0. + DYKDY=0. + XK=-XP + YK=-YP + DO 350 K=2,NCN + XK=XK+XN(IT,K,XG,YG)*X(K) + YK=YK+XN(IT,K,XG,YG)*Y(K) + DXKDX=DXKDX+DNX(IT,K,XG,YG)*X(K) + DYKDX=DYKDX+DNX(IT,K,XG,YG)*Y(K) + DXKDY=DXKDY+DNY(IT,K,XG,YG)*X(K) + DYKDY=DYKDY+DNY(IT,K,XG,YG)*Y(K) + 350 END DO + DET=DXKDX*DYKDY-DXKDY*DYKDX + DX=(-DYKDY*XK+DXKDY*YK)/DET + DY=( DYKDX*XK-DXKDX*YK)/DET + XG=XG+DX + YG=YG+DY + IF(ABS(DX).LT.TOL .AND. ABS(DY).LT.TOL) GO TO 420 + 400 END DO +!- +!......NOW GET WEIGHTING FUNCTIONS FOR QUAD FUNCTION +!- + 420 CONTINUE + DO K=1,NCN + WGT(K)=XN(IT,K,XG,YG) + END DO + + IF(ISWT .EQ. 1) THEN +!- +!- REDUCE TO LINEAR FUNCTION BY ADDING TERMS +!- + DO K=2,NCN,2 + WGT(K-1)=WGT(K-1)+WGT(K)/2. + IF(K .LT. NCN) THEN + WGT(K+1)=WGT(K+1)+WGT(K)/2. + ELSE + WGT(1)=WGT(1)+WGT(K)/2. + ENDIF + ENDDO +!- +!- THEN COMPACT ARRAY +!- + DO K=1,NCN/2 + WGT(K)=WGT(2*K-1) + ENDDO + + ENDIF + + RETURN + END diff --git a/src/GINPT.F90 b/src/GINPT.F90 new file mode 100644 index 0000000..9ee5ac7 --- /dev/null +++ b/src/GINPT.F90 @@ -0,0 +1,47 @@ + SUBROUTINE GINPT(irm2,ID,DLIN) + CHARACTER ID*8,DLIN*72 + 100 CONTINUE + READ(irm2,7000) ID,DLIN + write(90,7000) id,dlin +!ipk jul03 + call to_upper(id) + 7000 FORMAT(A8,A72) + do i=1,8 + if(id(i:i) .eq. char(9)) go to 200 + enddo + do i=1,72 + if(dlin(i:i) .eq. char(9)) go to 200 + enddo + IF(ID(1:1) .EQ. ':') GO TO 100 + IF(ID(1:1) .EQ. ';') GO TO 100 + IF(ID(1:3) .EQ. 'com') GO TO 100 + IF(ID(1:3) .EQ. 'COM') GO TO 100 + IF(ID(1:3) .EQ. 'Com') GO TO 100 + IF(ID(1:8) .EQ. ' ') GO TO 100 + RETURN + 200 continue + write(*,*) 'Error Tab character found in the following line' + write(90,*) 'Error Tab character found in the following line' + write(90,7000) id,dlin + write(*,7000) id,dlin + stop + END + + + SUBROUTINE TO_UPPER(STR) + + CHARACTER*(*) STR + CHARACTER*1 CH + + L = LEN(STR) + + DO I=1,L + CH = STR(I:I) + IF ( ICHAR(CH) .GT. 96 .AND. ICHAR(CH) .LE. 122) THEN + STR(I:I) = CHAR(ICHAR(CH)-32) + ENDIF + ENDDO + + END + + diff --git a/src/GOUTLIN.F90 b/src/GOUTLIN.F90 new file mode 100644 index 0000000..82de04a --- /dev/null +++ b/src/GOUTLIN.F90 @@ -0,0 +1,127 @@ + SUBROUTINE GOUTLIN + + USE WINTERACTER + USE BLK1MOD +! INCLUDE 'BLK1.COM' + INCLUDE 'TXFRM.COM' + + CHARACTER(LEN=255) :: FNAME,FILTER + CHARACTER(LEN=4) :: SUB + LOGICAL OPENED + CHARACTER*1 IFLAG,ANS(10) +! DIMENSION XOUT(1000),YOUT(1000) + DATA ANS/' ',' ',' ',' ',' ',' ','n','z','r','q'/ + + IF(.NOT. ALLOCATED(XOUT)) THEN + ALLOCATE (XOUT(5000,10),YOUT(5000,10)) + ENDIF + N=0 + IOUTOUT=25 + INQUIRE(25, OPENED=OPENED) + if(.not. opened) then + Filter='OUTLINE file -- *.dat|*.dat|POLY file -- *.poly|*.poly|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Outline File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(IOUTOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') + ELSE + GO TO 1 + ENDIF + ENDIF + + 1 CONTINUE + + IF(SUB(1:3) .EQ. 'dat') THEN + IOUTSW=0 + ELSE + IOUTSW=1 + ENDIF + +!IPK GET STRING OF MAP COORDINATES + +! +! Draw box around selections +! + 2 CONTINUE + + NHTPSV=NHTP + NMESSV=NMESS + NBRRSV=NBRR + + NHTP=0 + NBRR=1 + NMESS=45 + CALL HEDR +! +! Get answer +! +! 3 call xyloc(XPT,YPT,ANS,IBOX) + 3 call xyloc(XPT,YPT,IFLAG,IBOX) +! + IF(IRMAIN .NE. 1 .and. ibox .ne. 10) THEN + + N=N+1 + XTMP = XPT*TXSCAL - XS + YTMP = YPT*TXSCAL - YS + IF(IOUTSW .EQ. 0) THEN + WRITE(IOUTOUT,*) XTMP,YTMP + ELSE + XOUT(N,1)=XTMP + YOUT(N,1)=YTMP + ENDIF + GO TO 3 + + ENDIF + IF(IOUTSW .EQ. 1) THEN + NDIM=2 + NZERO=0 + NONE=1 + WRITE(IOUTOUT,*)N,NDIM,NZERO,NZERO + DO I=1,N + WRITE(IOUTOUT,*) I,XOUT(I,1),YOUT(I,1) + ENDDO + WRITE(IOUTOUT,*) N,NZERO + DO I=1,N-1 + WRITE(IOUTOUT,*) I,I,I+1 + ENDDO + WRITE(IOUTOUT,*) N,N,NONE + + WRITE(IOUTOUT,*) NZERO + ENDIF + NHTP=NHTPSV + NMESS=NMESSV + NBRR=NBRRSV + CALL HEDR + + + RETURN + END + + SUBROUTINE GETSUB4(FNAME,SUB) + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=4) :: SUB + INTEGER ,EXTERNAL :: LENSTR + INTEGER :: LNNAM,K + + LNNAM=LENSTR(FNAME) + SUB=' ' + DO K=LNNAM,1,-1 + IF(FNAME(K:K) .EQ. '.') THEN + IF(LNNAM .GT. K+3) THEN + SUB=FNAME(K+1:K+4) + ELSEIF(LNNAM .GT. K+2) THEN + SUB(1:3)=FNAME(K+1:K+3) + SUB(4:4)=' ' + ELSE + SUB=' ' + ENDIF + GO TO 110 + ENDIF + ENDDO +110 CONTINUE + RETURN + END diff --git a/src/GRIDSB.F90 b/src/GRIDSB.F90 new file mode 100644 index 0000000..fc0f780 --- /dev/null +++ b/src/GRIDSB.F90 @@ -0,0 +1,872 @@ +!IPK LAST UPDATE FEB 11 2002 ADD LOCK AS VARIABLE +!ipk last update Feb 10 1997 + SUBROUTINE GRIDSB(ISWTIN) +! +! Routines to control interpolation of nodal elevations +! + USE WINTERACTER + USE BLKMAP + USE BLK1MOD + + include 'd.inc' + +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' + +!iPK APR94 + COMMON /RECOD/ IRECD,TSPC + + +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! +!IPKJAN94 INTEGER*2 LISTM +! INTEGER LISTM +!ipk feb94 add ARF then remove may97 + +! DIMENSION LISTM(1000),listt(1600,4),nlf(4),icomp(4),xnear(4) +!ipk feb03 common /mapc/imap(maxpl),NCRS(MAXPL) +!ipk sep97 add NCRS above +! +!ipknov93 CHARACTER*1 ANS,ANSW(10) + CHARACTER*1 ANS,ANSW(10),IFLAG + CHARACTER*63 STRELS + DATA STRELS/' You have tried set to set elevation with no mapfile"'/ +! + DATA ANSW/'m','a','f','s','k','u','t','w','h','q'/ +!JUN08 DATA ISWTAGN/0/ +!ipk feb94 add DATA and FUNCTION below +! DATA ARF/-180.,-90.,0.,90.,180./ +! ANGN(K,L)= +! + ATAN2((CMAP(K,2)-CORD(L,2)),(CMAP(K,1)-CORD(L,1)))*57.296 +! +! Draw box around selections +! +!IPK SEP97 +100 CONTINUE + IDONET=0 + NHTP = 9 + NMESS = 0 + NBRR = 0 + IF(ISWTIN .EQ. -1) GO TO 190 + CALL HEDR +! +! Get answer +! + 110 call xyloc(XPT,YPT,ANS,IBOX) + IF(IRMAIN .EQ. 1) RETURN + IF(ANS .EQ. 'c') THEN + if(ibox .eq. 0) go to 110 + ANS=ANSW(IBOX) + ENDIF + IF(ANS .EQ. 'm') THEN +! +! This option allows changes to bottom elevations +! + CALL ADDPTH + IF(IRMAIN .EQ. 1) RETURN + GO TO 100 + + ELSEIF (ANS .EQ. 'a') THEN +! +! All nodes +! + ISWT = -1 + DO N=1,NP + IF(INEW(N) .EQ. 1) WD(N)=-9999. + ENDDO + ELSEIF(ANS .EQ. 'f') THEN +! +! Fill nodes +! + ISWT = 0 + ELSEIF(ANS .EQ. 's') THEN +! +! Single node at a time +! + ISWT = 1 + +!ipk feb02 add lock/unlock and remove cdata + + ELSEIF(ANS .EQ. 'k') THEN +! +! lock node +! +! Get M from mouse +! + 115 CONTINUE + NHTP=0 + NMESS=21 + NBRR=3 + CALL HEDR + IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,M,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN + if(iflag .eq. 'q') go to 100 + lock(m)=1 + go to 115 + ELSEIF(ANS .EQ. 'u') THEN +! +! unlock node +! +! Get M from mouse +! + 120 CONTINUE + NHTP=0 + NMESS=21 + NBRR=3 + CALL HEDR + IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,M,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN + if(iflag .eq. 'q') go to 100 + lock(m)=0 + go to 120 + ELSEIF(ANS .EQ. 't') THEN +! +! Create data for layers +! + CALL ADDLAY + IF(IRMAIN .EQ. 1) RETURN + GO TO 100 + ELSEIF(ANS .EQ. 'w') THEN +! +! This option allows changes to nodal widths +! + CALL ADDWID + IF(IRMAIN .EQ. 1) RETURN + GO TO 100 +! +! Call to help screen +! + ELSEIF(ANS .EQ. 'h') THEN + CALL HELPS(4) + IF(IRMAIN .EQ. 1) RETURN + GO TO 100 +! + ELSEIF(ANS .EQ. 'q') THEN +! +! Writeout and return +! + CALL WRTOUT(0) + RETURN + ENDIF + +190 CONTINUE + + IF(IMP .EQ. 0) THEN + CALL SYMBL(0.,7.25,0.20,STRELS,0.,63) + go to 100 + endif +! +! Establish size for range +! + call setrng(xnears,nmap) + + ITIME=0 + ICOUNTF=0 + MM=0 + 200 MM=MM+1 +! write(90,*) 'gridsb-111',mm,np,iswt,inew(mm) + IF(MM .LE. NP) THEN +! +! Decode which alternative we are processing +! ipk feb 03 determine interpolation method +! + IF(MM .EQ. 1 .AND. ISWTAGN .EQ. 0) THEN + + IF(IRECD .EQ. 2) THEN + iswtintp=0 + iswtagn=0 + go to 210 + ENDIF + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to interpolate '//& + CHAR(13)//'from the triangulated map file?' ,& + 'Select Interpolation method?') +! If answer 'Yes' set interpolate switch to 1 +! + IF (WInfoDialog(4) .EQ. 2) then + iswtintp=0 + ELSE + iswtintp=1 + ENDIF + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Ask this question again?'//& + CHAR(13)//' ' ,& + 'Ask again?') +! If answer 'Yes' set again switch to 0 +! + IF (WInfoDialog(4) .EQ. 2) then + iswtagn=1 + ELSE + iswtagn=0 + ENDIF + ENDIF + + 210 CONTINUE + + IF(iswtintp .eq. 1) then + if(iswt .ne. 1) then + +! Sort the x-coordinates + + call sortdb(xusr,ncrs,np) + else + ncrs(mm)=mm + endif + m=ncrs(mm) + else + m=mm + endif +! IPK OCT 2 1991 + IF(ISWT .EQ. 1) THEN +! Single node at a time ISWT = 1 +! +! Get M from mouse and set MM to NP +! + NHTP=0 + NMESS=21 +!ipk jun08 NBRR=0 + NBRR=1 + CALL HEDR + IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN + if(iflag .eq. 'q') go to 100 + M=INODE + MM=NP + endif + IF(INEW(M) .EQ. 0) GO TO 200 +! IPK END OCT 2 1991 + + IF(ISWT .EQ. -1) THEN +! All nodes ISWT = -1 +!ipk feb02 + if(lock(m) .eq. 1) go to 200 + + ELSEIF(ISWT .EQ. 0) THEN +! Fill nodes ISWT = 0 +!ipk feb02 + IF(WD(M) .GT. -9000. .or. lock(m) .eq. 1) go to 200 + + ENDIF +! write(90,*) 'gridsb-138', m,mm,iswt,wd(m),xnears + + IF(ISWTINTP .EQ. 0) THEN + if(lock(m) .eq. 0) CALL SETELV(XNEARS,NMAP,M,ISWT) + ELSE + if(nelts .eq. 0) then + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'No triangulated exists'//& + CHAR(13)//'Do you wish to triangulate now?' ,& + 'NO TRIANGULATION AVAILABLE?') +! If answer 'Yes' set triangulate now +! + IF (WInfoDialog(4) .EQ. 2) then + return + ELSE + call triang + IDONET=1 + ENDIF + + endif + if(lock(m) .eq. 0) CALL TRIANINT(NMAP,M,ISWT,ITIME) + ENDIF + +! write(90,*) 'gridsb-141', m,iswt,wd(m) + if(wd(m) .lt. -9997.) THEN + icountf=icountf+1 + WD(M)=-9998. + ENDIF + GO TO 200 + ENDIF + IF(IDONET .EQ. 1) THEN + CALL RDMAP(2,99,0,0) ! XXXXX + CLOSE(99) + ENDIF + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to plot contours?'//& + CHAR(13)//' ','PLOT CONTOURS?') +! +! If answer 'No', return +! + IF (WInfoDialog(4).EQ.2) THEN + go to 220 + ENDIF +215 menus=13 + call conout(menus) + MENUS=12 + CALL CONOUT(MENUS) + +!ipkjan94 IF(ISWT .EQ. -1) GO TO 210 +220 if(icountf .gt. 0) then + + CALL FMESS(ICOUNTF,ISWTT) +! +! If answer 'Yes', use search for adjacent nodes +! + IF(ISWTT .EQ. 1) then + call fillin(icountf) + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to plot contours again?'//& + CHAR(13)//' ','PLOT CONTOURS?') +! +! If answer 'No', return +! + IF (WInfoDialog(4).EQ.2) THEN + IF(ICOUNTF .GT. 0) GO TO 220 + ELSE + GO TO 215 + ENDIF + END IF + endif + IF(ISWTIN .EQ. -1) RETURN + IF(ISWT .EQ. 1) THEN +!ipk jun08 CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN + if(iflag .eq. 'q') go to 100 + M=INODE + MM=NP-1 + GO TO 200 + ELSEIF(ISWT .EQ. -1) THEN + GO TO 100 + ENDIF +!ipk jun08 IF(ABS(ISWT) .EQ. 1) GO TO 100 + RETURN + END +!ipk jul98 revise call +!IPK SUBROUTINE GRIDIN(I,SOLN,LISTM,NLG) + SUBROUTINE GRIDIN(XZ,YZ,SOLN,LISTM,NLG) +! +! Routine to interpolate values from map to node points +! +! I is the location in the CORD array to be interpolated +! SOLN is the interpolated value developed +! NLG is the number of entries in the map array + + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +!IPK JAN94 INTEGER*2 LISTM,NLIST,NKEY +!IPK DEC09 INTEGER LISTM,NLIST,NKEY + INTEGER LISTM,NLIST + DIMENSION LISTM(*) + DIMENSION NLIST(1000),ADIST(1000),WT(1000) +! +! Function statements +! + DIST(K,X,Y)=SQRT((CMAP(K,1)-X)**2+(CMAP(K,2)-Y)**2) +!IPK FEB97 ANG(K,X,Y)=ATAN2((CMAP(K,2)-Y),(CMAP(K,1)-X))*57.296 + ANG(K,X,Y)=ATAN2((CMAP(K,1)-X),(CMAP(K,2)-Y))*57.296 +! +! Initialize +! + TOL=120. +! DO KK=1,NLG +! WRITE(90,*) 'LISTM',KK,LISTM(KK) +! ENDDO +! +! Form list of distances from I to data locations +! + NTMP=0 + IPAS=1 +!IPK JUL98 X=CORD(I,1) +!PK JUL98 Y=CORD(I,2) + X=XZ + Y=YZ + 140 CONTINUE + DO 150 KK=1,NLG + K=LISTM(KK) + IF(K .EQ. NTMP) THEN + ADIST(KK)=-VOID + ELSE + ADIST(KK)=DIST(K,X,Y) + ENDIF + 150 END DO +! +! Sort order for nearest points +! + CALL SORT(ADIST,NKEY,NLG) + do nnnn=1,nlg + nn=nkey(nnnn) + nzz=listm(nn) +! WRITE(90,*) NZZ,X,Y,cmap(nzz,1),cmap(nzz,2) +! ATMP=ANG(NZZ,X,Y) +! write(90,*) nnnn,adist(nnnn),val(nzz),ATMP + enddo +! read(*,*) aaa + KK=1 +! +! Search through sorted list +! + INIT=1 + 180 DO 260 K=1,NLG + NN=NKEY(K) + IF(NN .EQ. 0) GO TO 260 + N=LISTM(NN) +! +! Initialize +! + IF(N .EQ. NTMP) GO TO 260 + IF(INIT .EQ. 1) THEN + NLIST(1)=N + YY=(CMAP(N,2)-Y) + XX=(CMAP(N,1)-X) + IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN + RANGEF=0. + RANGEB=360. + ELSE + RANGEF=ANG(N,X,Y) + RANGEB=ANG(N,X,Y)+360. + ENDIF + INIT=2 + GO TO 260 + ENDIF +! +! Skip out if already processed +! + YY=(CMAP(N,2)-Y) + XX=(CMAP(N,1)-X) + IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN + ANGLE=0. + ELSE + ANGLE=ANG(N,X,Y) + ENDIF + 200 CONTINUE +! write(90,*) 'angls',n,angle,rangef,rangeb,val(n) +! +! Test if angle greater than high value +! + IF(ANGLE .GT. RANGEF) THEN +! +! Test if the new point is within the allowable range +! + IF(ANGLE .LT. RANGEF+TOL) THEN +! +! Process this point +! + RANGEF=ANGLE + KK=KK+1 + NLIST(KK)=N + NKEY(K)=0 +! +! Test if we now have enough points to exit +! + IF(RANGEF+TOL .GT. RANGEB) THEN + GO TO 300 + ELSE + GO TO 180 + ENDIF +! +! Test if angle lies inside the already spanned area +! If so it cannot be used +! + ELSEIF(ANGLE .GT. RANGEB) THEN + NKEY(K)=0 +! +! Test if it close enough to the low value +! + ELSEIF(ANGLE .GT. RANGEB-TOL) THEN +! +! Process this point +! + RANGEB=ANGLE + KK=KK+1 + NLIST(KK)=N + NKEY(K)=0 +! +! Test if we have enough points to exit +! + IF(RANGEF+TOL .GT. RANGEB) THEN + GO TO 300 + ELSE + GO TO 180 + ENDIF +! +! Not a usable point at this time, move on to next point +! + ELSE + GO TO 260 +! +! Increase angle by 360 and test again +! + ENDIF + ELSE + ANGLE=ANGLE+360. + GO TO 200 + ENDIF + 260 END DO +! +! We have finished loop without completing polygon +! + GO TO 500 +! +! Process least squares fit on this list +! + 300 CONTINUE +! WRITE(90,*) 'least squares list',KK,x,y +! WRITE(90,*) (NLIST(N),N=1,KK) +! do n=1,kk +! write(90,*) nlist(n),cmap(nlist(n),1),cmap(nlist(n),2) +! + ,val(nlist(n)),dist(nlist(n),x,y) +! enddo +!ipk feb97 changes to refine processing +! +! Check if points are close together relative to the centre point +! +! write(90,*) kk,x,y,nlg + do n=1,kk + l=nlist(n) + dc=dist(l,x,y) + xx=cmap(l,1) + yy=cmap(l,2) + if(n .lt. kk) then + do m=n+1,kk + ll=nlist(m) + dr=dist(ll,xx,yy) + if(dr .lt. 0.1*dc) then + if(kk .gt. 3) then + ds=dist(ll,x,y) + if(ds .lt. dc) then + ndrp=n + else + ndrp=m + endif +! +! drop this point +! + do mm=ndrp,kk-1 + nlist(mm)=nlist(mm+1) + enddo + kk=kk-1 + go to 300 + else + go to 310 + endif + endif + enddo + endif + enddo + 310 continue +!ipk feb97 end changes for processing +! WRITE(90,*) '310',kk +! WRITE(90,*) (NLIST(N),N=1,KK) +!ipk feb97 chnage to add weighting + do n=1,kk +!ipk jul98 if(dist(nlist(n),CORD(I,1),CORD(I,2)) .gt. 0.) then +!ipk jul98 wt(n)=1./dist(nlist(n),CORD(I,1),CORD(I,2)) + if(dist(nlist(n),XZ,YZ) .gt. 0.) then + wt(n)=1./dist(nlist(n),XZ,YZ) + else + soln=val(nlist(n)) + return + endif + enddo +!IPK JUL98 CALL ALSQ(KK,NLIST,I,SOLN,WT) + CALL ALSQ(KK,NLIST,XZ,YZ,SOLN,WT) +!ipk feb97 end changes +! +! final value is SOLN +! + RETURN + 500 TOL=TOL+25. + IF(TOL .GT. 180.) GO TO 550 + IF(RANGEF+TOL .GT. RANGEB) THEN + GO TO 300 + ENDIF + GO TO 180 + 550 CONTINUE +!c write(90,*) ' in trouble split',rangef,rangeb + SPLIT=(RANGEF+RANGEB)/2.-180. + AMIN=180. + DO 600 N=1,KK + IF(NLIST(N) .EQ. NTMP) GO TO 600 + YY=(CMAP(NLIST(N),2)-Y) + XX=(CMAP(NLIST(N),1)-X) + IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN + ANGL=0. + ELSE + ANGL=ANG(NLIST(N),X,Y) + ENDIF + IF(IPAS .EQ. 2) GO TO 600 +! +! Find line closest to split +! + IF(ABS(SPLIT-ANGL) .LT. AMIN) THEN + AMIN=ABS(SPLIT-ANGL) +! write(90,*) 'ntmp reset',ntmp,nlist(n),amin,split + NTMP=NLIST(N) + ENDIF + ANGLP=ANGL-360. + IF(ABS(SPLIT-ANGLP) .LT. AMIN) THEN + AMIN=ABS(SPLIT-ANGLP) + NTMP=NLIST(N) + ENDIF +! 580 WRITE(90,*) NLIST(N),ANGL + 600 END DO + IF(IPAS .EQ. 1) THEN + IPAS=2 + X=CMAP(NTMP,1) + Y=CMAP(NTMP,2) + TOL=120. + write(90,*) 'INTERP FOR ',xz,yz,' MOVED TO',x,y,ntmp + GO TO 140 + ENDIF + WRITE(90,*) 'ERROR NO POLYGON RANGEF,RANGEB',RANGEF,RANGEB,SPLIT + WRITE(90,*) 'OPPOSITE NODE AND ANGULAR DIFF',NTMP,AMIN + SOLN=-9998. + RETURN + END +! +! FUNCTION ANG(K,X,Y) +! +! INCLUDE 'BLK1.COM' +! +! YY=(CMAP(K,2)-Y) +! XX=(CMAP(K,1)-X) +! IF(YY .EQ. 0. .AND. XX .EQ. 0.) THEN +! ANG=0. +! ELSE +! ANG=ATAN2(YY,XX)*57.296 +! ENDIF +! RETURN +! END + + SUBROUTINE SORT(A,NKEY,N) +!*********************************** .....SORT..... +!- +!......SORT IS A SIMPLE SHELL SORT ROUTINE +!- +! SHELL SORT + SAVE +! +!IPK JAN94 INTEGER*2 NKEY + DIMENSION A(*),NKEY(1) + IF(N.LT.2) RETURN + DO 90 J=1,N + NKEY(J)=J + 90 END DO + ID = N + 100 ID = ID / 2 + 110 IB = 1 + 120 GO TO 200 + 130 IB = IB + 1 + IF( IB .LE. ID ) GO TO 200 + IF( ID .GT. 1 ) GO TO 100 + RETURN + 200 I = IB + 210 K = I + ID + 220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250 + NKT = NKEY(K) + NKEY(K) = NKEY(I) + J = I + 230 K = J - ID + IF( K .LT. 1 ) GO TO 240 + IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240 + NKEY(J) = NKEY(K) + J = K + GO TO 230 + 240 NKEY(J) = NKT + 250 I = I + ID + IF( I + ID .LE. N ) GO TO 210 + GO TO 130 + END +!ipk feb97 add weighting +!iok jul98 SUBROUTINE ALSQ(NPTS,NLIST,I,SOLN,WT) + SUBROUTINE ALSQ(NPTS,NLIST,xx,yy,SOLN,WT) +! +! Least squares routine +! +! INCLUDE 'PARAM.COM' + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' +!IPK JAN94 INTEGER*2 NLIST + REAL*8 A,R,B,S,X,Y,ATR,ATR2,BTR,C,T,X3,X2,X1 + DIMENSION A(3,3),R(3),B(2,2),S(2),wt(*) + DIMENSION NLIST(*) +! +! Initialize matrices +! +!ipk jul98 X=CORD(I,1) +!ipk jul98 Y=CORD(I,2) + X=XX + Y=YY +! write(*,*) (nnn,cmap(nnn,1),cmap(nnn,2),nnn=1,16) +! write(*,*) (nlist(n),n=1,npts) + DO 160 K=1,3 + R(K)=0. + DO 150 J=1,3 + A(J,K)=0. + 150 CONTINUE + 160 END DO +! +! Form A and R matrices +! + DO 200 N=1,NPTS + KK=NLIST(N) +! write(*,*) cmap(kk,1),cmap(kk,2),val(kk) +!ipk feb97 add weighting + A(1,1)=A(1,1)+1.0*wt(n) + A(1,2)=A(1,2)+CMAP(KK,1)*wt(n) + A(1,3)=A(1,3)+CMAP(KK,2)*wt(n) + A(2,2)=A(2,2)+CMAP(KK,1)**2*wt(n) + A(2,3)=A(2,3)+CMAP(KK,1)*CMAP(KK,2)*wt(n) + A(3,3)=A(3,3)+CMAP(KK,2)**2*wt(n) + R(1)=R(1)+VAL(KK)*wt(n) + R(2)=R(2)+CMAP(KK,1)*VAL(KK)*wt(n) + R(3)=R(3)+CMAP(KK,2)*VAL(KK)*wt(n) +!ipk feb97 end addition of weighting + 200 END DO +! read(*,*) al +! +! Solve equations +! + ATR=A(1,2)/A(1,1) + ATR2=A(1,3)/A(1,1) + B(1,1)=A(2,2)-ATR*A(1,2) + B(1,2)=A(2,3)-ATR*A(1,3) + S(1)=R(2)-ATR*R(1) + B(2,2)=A(3,3)-ATR2*A(1,3) + S(2)=R(3)-ATR2*R(1) + BTR=B(1,2)/B(1,1) + C=B(2,2)-BTR*B(1,2) + T=S(2)-BTR*S(1) + X3=T/C + X2=S(1)/B(1,1)-BTR*X3 + X1=R(1)/A(1,1)-ATR*X2-ATR2*X3 +! +! Substitute to get interpolated value +! + SOLN=X1+X2*X+X3*Y + RETURN + END +! +!ipksep97 new routine for soring map lines +! + SUBROUTINE SORTMAP(A,NKEY,N,IMAP) +!*********************************** .....SORT..... +!- +!......SORT IS A SIMPLE SHELL SORT ROUTINE +!- +! SHELL SORT + SAVE +! +!IPK JAN94 INTEGER*2 NKEY + DIMENSION A(*),NKEY(1),IMAP(*) + DATA VOID/1.E35/ + IF(N.LT.2) RETURN + DO 90 J=1,N + NKEY(J)=J + IF(IMAP(J) .LT. 0) A(J)=VOID + 90 END DO + ID = N + 100 ID = ID / 2 + 110 IB = 1 + 120 GO TO 200 + 130 IB = IB + 1 + IF( IB .LE. ID ) GO TO 200 + IF( ID .GT. 1 ) GO TO 100 + RETURN + 200 I = IB + 210 K = I + ID + 220 IF( A(NKEY(I)) .LE. A(NKEY(K)) ) GO TO 250 + NKT = NKEY(K) + NKEY(K) = NKEY(I) + J = I + 230 K = J - ID + IF( K .LT. 1 ) GO TO 240 + IF( A(NKT) .GT. A(NKEY(K)) ) GO TO 240 + NKEY(J) = NKEY(K) + J = K + GO TO 230 + 240 NKEY(J) = NKT + 250 I = I + ID + IF( I + ID .LE. N ) GO TO 210 + GO TO 130 + END + subroutine fillin(icountf) + USE BLKMAP + USE BLK1MOD + USE BLK2MOD + DIST(N,M)=(cord(n,1)-cord(m,1))**2+(cord(n,2)-cord(m,2))**2 + CALL KCON(0) + MCOUNT=0 + MCOUNTF=0 + DO N=1,NP + IF(WD(N) .LT. -9997. .and. WD(N) .GT. -9998.5) THEN + MCOUNT=MCOUNT+1 + DISTCUR=1.E20 + NADJCT=0 + DO K=1,NDELM(N) + J=NECON(N,K) + DO I=1,NCORN(J) + NC=NOP(J,I) + IF(NC .NE. 0 .AND. NC .NE. N) THEN + IF(WD(NC) .GT. -9997.) THEN + distance=dist(n,nc) + if(distance .lt. distcur) then + distcur=distance + nadjct=nc + endif + ENDIF + ENDIF + ENDDO + ENDDO + if(nadjct .gt. 0) then + wd(n)=wd(nadjct) + else + mcounfT=mcountf+1 + ENDIF + if(mcount .eq. icountf) THEN + ICOUNTF=MCOUNTF + return + ENDIF + endif + enddo + ICOUNTF=MCOUNTF + return + end + + SUBROUTINE FMESS(N1,N2) + use winteracter + + implicit none + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,IERR +! real :: + character*3 :: sub + + call wdialogload(IDD_FBED) + ierr=infoerror(1) + + CALL WDialogPutInteger(idf_integer1,n1) + + + CALL WDialogSelect(IDD_FBED) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + N2=1 + RETURN + ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + N2=0 + RETURN + ENDIF + ENDDO + RETURN + END + \ No newline at end of file diff --git a/src/HEDR.F90 b/src/HEDR.F90 new file mode 100644 index 0000000..f27a03c --- /dev/null +++ b/src/HEDR.F90 @@ -0,0 +1,333 @@ +!IPk last updated July 15 1998 +!IPk last updated Nov 18 1997 +!IPk last updated Oct 31 1996 fix bug in map option +!IPK LAST UPDATED OCT 16 1996 +!IPk last updated Oct 14 1996 +!IPk last updated Oct 25 1995 + SUBROUTINE HEDR + SAVE + +! Routine to draw NSIZ header boxes at top of page with the HEAD label + + CHARACTER*80 TITLE + CHARACTER*24 HLABL + CHARACTER*1 ALABL(10) + CHARACTER*40 MPDUM + + COMMON /SSIZE/ HSIZE + + COMMON /BLKA1/ TITLE,HLABL,ALABL,MPDUM + +!IPk oct 95 lines defining MPDUM added +!ipk jan01 Expand IPSW to 10 + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout +!IPk feb94 HEAD array and NHEDL enlarged +!IPk oct96 HEAD AND NHEDL MESS, ENLARGED + + common /cols/ ibakk,icolr,iblkk + + CHARACTER*8 HED(10),HEAD(10,16) + CHARACTER*47 MESOUT,MESS(47) +!ipk lan01 add to MESS +!ipk jan99 add to MESS +!ycw mar97 change HEADR(5,5) to HEADR(6,7) +!ipk add extra headr + CHARACTER*8 HEADR(6,10) + DIMENSION NHEDL(16) + DIMENSION X(5),Y(5),IRV(10) +!IPk feb 94 this statement reconstructed +!IPK OCT 96 THIS STATMENT DONE AGAIN + DATA HEAD/ ' (e)lts ','(n)odes ','(o)rder ',' (h)elp ',' (s)ave ',& +'cc(l)ine',' csec(t)',' (z)oom ',' (r)draw',' (q)uit ','(n)od bk',& !1/2 +' (e)l bk',& +'re(f)ine','spli(t) ','c(l)ean ',5*' ','pr(l)st ','get(g)rp'& ! 2/3 +,'(p)rgrp ','c(o)ptnd','cop(t)el',' (h)elp ',' ',' (z)oom ',' (r)draw',' (q)uit'& !3 +,' (a)dd ',' (m)ove ',' (d)el ',' (f)ind ',' (g)line',' (e)lev '& !4 +,' (h)elp ',' (z)oom ',' (r)draw',' (q)uit ',' (m)ap ',' (o)utln'& !4/5 +,' (e)lts ','(n)odes ',' ne(t)w ',' t(y)pe ','cc(l)ine',' (d)ata '& !5 +,'(b)elev ',' d(r)aw ',' (s)el ',' (j)oin ',' (f)ind ',' (g)blok'& !5/6 +,' (t)ype ',' f(i)ll ',' (h)elp ',' (z)oom ',' (r)draw',' (q)uit '& !6 +,' (d)el ','r(e)fin ',' (n)umb ',' (a)ll ','rectn(g)','(t)riang'& !7 +,' (h)elp ',' (z)oom ',' (r)draw',' (q)uit ',' (f)our ','two(l)g '& !7/8 +,'two(s)h ','spli(t) ','re(v)rs ','clea(n) ',' ','s(m)plfy',' ',' (q)uit '& !8 +,'(m)an/el','(a)ll/el','(f)il/el','(s)in/el',' loc(k) ','(u)nlock'& !9 +,'(t)hree ','man/(w)d',' (h)elp ','(q)uit ','al(l)mid','cen(m)id'& !9/10 +,'sin(g)le','un(u)sed',' (f)ill ',' (j)oin ',' (h)elp ',' (z)oom '& !0 +,' (r)draw',' (q)uit ','a(s)ave ','(b)save ','(m)save ',' (p)save'& !10/11 +,2*' ',' (h)elp ',' (z)oom ',' (r)draw',' (q)uit ',' z(e)ro '& !11/12 +,' (o)ne ',' (t)wo ','t(h)ree ',' (f)our ',' f(i)ve ',' (s)ix '& !12 +,' se(v)en',' ei(g)ht',' (q)uit ',' (w)idth',' ss(1) ',' ss(2) '& !12/13 +,'strw(d) ','str(e)lv','str(s)lp',' (b)s1 ',' (z)oom ',' (r)draw'& !13 +,' (q)uit ','(d)elete','s(e)t999','se(t)elv','set(l)ay',' loc(k) ','(u)nlock','(f)orm-t',' (z)oom ',' (r)draw'& !13/14 +,' (q)uit ','(d)elete','r(e)fin ','se(t)yp ','s(m)plfy','form(g)p','elev und',' ',' (z)oom ',' (r)draw'& !14/15 +,' (q)uit ','(m)an/el','(a)ll/el','(f)il/el',' ',' ',' '& !15/16 +,' ',' ',' (h)elp ','(q)uit '/ + + +!IPk apr95 changed structure of messages added 3 more entries + + + DATA MESS /'Enter node to search for',' Enter material type',& ! 1,2 + 'Enter element to search for ',& ! 3 + 'Enter numbr of layers ',& ! 4 + 'Enter width ',& ! 5 + 'Click mouse at end of line ',& ! 6 + 'Enter nmbr of nodes in line ',& ! 7 + 'Click at corners of block ',& ! 8 + 'Enter nmbr of elts in x-dir ',& ! 9 + 'Enter nmbr of elts in y-dir ',& ! 10 + 'Click to move boundaries or (q)uit to save ',& ! 11 + 'Click on elements', 'Enter starting list number ',& ! 12,13 + 'Enter bottom elevation', 'Click on node ',& ! 14,15 + 'Click location of new node', 'Click at node to move ',&! 16,17 + 'Click at node to delete ',& ! 18 + 'Type 1 to use all nodes else type 0 ',& ! 19 + 'Enter element to select','Click location of node',& ! 20,21 + 'Enter ss1','Enter ss2','Enter strwid','Enter storage elevation',& ! 22,23,24,25 + 'Click mouse on node','click mouse on next node',& ! 26,27 + 'ERROR - Midside node selected - Select node again',& ! 28 + 'Plotting a selected cross section',& ! 29 + 'Click two locations to form a cross section',&! 30 + 'Click to adjust the cross section',& ! 31 + 'Compute cross section parameters',& ! 32 + 'Click a node for the cross section',& ! 33 + + 'Click two locations to form the width','Click to adjust the line','Click two locations to form left slope',& ! 34 35 36 + 'Click two locations to form right slope','Click a location'& ! 37 38 + ,'Enter storage elevation','Enter storage slope',& ! 39 40 + 'Click at two locations to determine distance'& ! 41 + ,'Enter continuity line number use 0 to end','Click at location on image to define register point'& ! 42 43 + ,'Enter 1-d cross-section bed slope','Click at location to define outline point'& ! 44 45 + ,' ','Click two locations to define move'/ ! 46 47 +! last line Jan 2001 +! line above added Jan 1999 + DATA HEADR /& + ' (q)uit ',5*' ',& + ' (r)draw',' (q)uit ',4*' ',& + ' (z)oom ',' (r)draw', ' (q)uit ',3*' ',& + ' (n)ext ',' (z)oom ', ' (r)draw',' (q)uit ',2*' ',& + ' (b)ack ',' cn(n)ect', ' (z)oom ',' (r)draw',' (q)uit ',' ',& + ' (l)ine ',' (d)rawcs', ' (z)oom ',' (r)draw',' (q)uit ',' ',& + ' (d)ist ',' (w)idth', ' (1)slop',' (2)slop',' b(e)lev',' (q)uit',& + ' (d)el ',' (z)oom ', ' (r)draw',' (q)uit ',2*' ',& + ' s(a)ve ',' (z)oom ', ' (r)draw',' (q)uit ',2*' ',& + ' u(n)do ',' (c)ancl', ' (z)oom ',' (r)draw',' (q)uit ',1*' '/ + DATA IRV/1 , 2 , 5 , 3 , 4 , 7 , 10 , 6 , 9, 5/ + DATA NHEDL/10,5,10,10,10,10,10,10,10,10,10,10,10,10,10,10/ +! DATA IBAKK/12/,ICOLR/11/ + IF(NHTP .NE. 0) THEN + +! Clear upper box area + + CALL CLRBOX + +! Copy appropriate heading for output + + NSIZ=NHEDL(NHTP) + DO 120 N=1,NSIZ + HED(N)=HEAD(N,NHTP) + 120 CONTINUE + +! Draw box around selections with colour +! + Y(1)=7.5 + Y(2)=7.5 + Y(3)=7.995 + Y(4)=7.995 + Y(5)=7.5 + XPT=0. + DO 150 I=1,NSIZ + X(1)=XPT + X(4)=XPT + X(5)=XPT +! XPT=XPT+1.0 + XPT=XPT+HSIZE/10. + X(2)=XPT + X(3)=XPT + IF(I .EQ. 10) THEN + IBLK=IBAKK +!IPK OCT96 ADD COLOR OPTIONS + ELSEIF((NHTP .EQ. 5 .AND. IPSW(IRV(I)) .EQ. 1) .OR. & + (NHTP .EQ. 12 .AND. ICOLON(I) .EQ. 1)) THEN + IBLK=iblkk + ELSE + IBLK=IBAKK + ENDIF + CALL POLYFL(X,Y,5,IBLK) + CALL RBLACK + CALL PLOTT(X(1),Y(1),3) + CALL PLOTT(X(2),Y(2),2) + CALL PLOTT(X(3),Y(3),2) + CALL PLOTT(X(4),Y(4),2) + CALL PLOTT(X(1),Y(1),2) + 150 CONTINUE + XSY=0. + YSY=7.65 + DO 200 N=1,NSIZ +!ipk mar01 + CALL SYMBL(XSY,YSY,0.20,HED(N),0.0, 8) +! XSY=XSY+1.0 + XSY=XSY+HSIZE/10. + 200 CONTINUE + ENDIF + IF(NMESS .GT. 0) THEN + +! Clear upper box area + + CALL CLRBOX + +! Write out message + + MESOUT=MESS(NMESS) +!ipk mar01 + CALL SYMBL(0.,7.65,0.20,MESOUT,0.,47) + + ENDIF + IF(NBRR .NE. 0) THEN + +! Put box on right + +! Draw box around selections + + NBX=NBRR + if(NBX.gt.5) NBX=NBRR-1 !ycw mar97 + IF(NBX .GT. 6) NBX=4 + if(nbrr .eq. 10) NBX=5 +! XLEFT=10-NBX + XLEFT=(10-NBX)*HSIZE/10. + DO 250 K=1,NBX + X(1)=XLEFT + X(4)=XLEFT + X(5)=XLEFT +! XLEFT=XLEFT+1.0 + XLEFT=XLEFT+HSIZE/10. + X(2)=XLEFT + X(3)=XLEFT + IBLK=IBAKK + CALL POLYFL(X,Y,5,IBLK) + CALL RBLACK + CALL PLOTT(X(1),Y(1),3) + CALL PLOTT(X(2),Y(2),2) + CALL PLOTT(X(3),Y(3),2) + CALL PLOTT(X(4),Y(4),2) + CALL PLOTT(X(1),Y(1),2) +!ipk mar01 + CALL SYMBL(XLEFT-1.,7.65,0.20,HEADR(K,NBRR),0.0,8) + 250 CONTINUE +! ENDIF + ENDIF + RETURN + END + + + +! Get xy location of cursor in screen coordinates (inches) + + + subroutine xyloc(xscrn,yscrn,iflag,ibox) + save + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + CHARACTER*80 TITLE + CHARACTER*24 HLABL + CHARACTER*1 ALABL(10) + CHARACTER*40 MPDUM + + COMMON /SSIZE/ HSIZE + + COMMON /BLKA1/ TITLE,HLABL,ALABL,MPDUM +!IPk oct 95 lines defining MPDUM added + +!ipk jan01 Expand IPSW to 10 + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout + + character*1 iflag + common /blktek/ xmin, xmax, ymin, ymax,& + xpiv, ypiv, cthet, sthet,& + xscal, yscal, theta, thetdg,& + pgscl,scrnx,scrny,ix,iy + +! IRDISP= 0 means no redisplay + + irdisp=0 + 100 continue +! iy=ymax +! write(90,*) 'to tekgin nhtp',nhtp + call tekgin(xscrn,yscrn,iflag) +! write(90,*) 'back tekgin nhtp',nhtp,xscrn,yscrn,IRDISP +! write(90,'(a)') 'iflag',iflag + + if(iflag .eq. 'P') then + call hedr +!IPk nov97 add (0) + call plotot(0) + call hedr +!ipk may01 + irdisp=1 + go to 100 + endif + + +!IPk mar94 if(yscrn .gt. 7.0 .and. iflag .eq. 'c') then + if(yscrn .gt. 7.5 .and. iflag .eq. 'c') then +! ibox=ifix(xscrn+0.9999) + ibox=ifix(xscrn*10./HSIZE+0.9999) + iflag='c' + elseif(iflag .eq. 'M') then + irmain = 1 + elseif(iflag .ne. 'c') then + ibox=1 + else + ibox=0 + endif + if(irmain .eq. 1) return + +! Check for zoom command + + if(nhtp .eq. 2 .or. nhtp .eq. 5 .or. nhtp .eq. 12 .or.& + nhtp .eq. 8 .or. nhtp .eq. 9) then + return + elseif(nhtp .eq. 0 .and. (nbrr .eq. 0 .or. nbrr .eq. 2& + .or. nbrr .eq. 7)) then + return + elseif(ibox .eq. 8 .or. iflag .eq. 'z') then + n1=nhtp + n2=nbrr + nhtp=0 + nbrr=0 + CALL ZOOM + nhtp=n1 + nbrr=n2 +!ipk may01 + irdisp=1 + if(irmain .eq. 1) return + call hedr + IF(N2 .EQ. 10) CALL PLTPT + go to 100 + elseif(ibox .eq. 9 .or. iflag .eq. 'r') then + +! Save display parameters + + n1=nhtp + n2=nmess + n3=nbrr + CALL RDRW(0) + if(n2 .eq. 11) call pltpt +!ipk may01 + irdisp=1 + if(irmain .eq. 1) return + +! Restore display parameters + + nhtp=n1 + nmess=n2 + nbrr=n3 + call hedr + go to 100 + endif + + return + + end diff --git a/src/HELPS.F90 b/src/HELPS.F90 new file mode 100644 index 0000000..632bb25 --- /dev/null +++ b/src/HELPS.F90 @@ -0,0 +1,98 @@ +!ipk last update Nov 18 1997 +! + SUBROUTINE HELPS(NTPIN) + USE WINTERACTER +! +! Master routine controlling the help facility +! +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + INCLUDE 'BFILES.I90' +! + CHARACTER(LEN=256) :: FILTER + CHARACTER*32 ANS + CHARACTER*78 AHP + character*55 strels +! INTEGER*2 IPAG +! INTEGER*2 NT + DIMENSION NPOS(11),NFIN(10) + LOGICAL*4 EXST + + INQUIRE(FILE=DIRECT,EXIST=EXST) + IF(.not. EXST) THEN + CALL CLSCRN +! WRITE(strels,6000) +! 6000 format( 'Help files not available, press enter to return to menu') +! CALL SYMBL(0.2,7.0,0.25,STRELS,0.0,55) +! NDIG=1 +! call gtcharx(ans,ndig,6.0,7.0) + + Filter='HTM file -- *.htm|*.htm|' + + CALL WSelectFile(FILTER,PromptOn,DIRECT,'Help files not available - BROWSE') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + GO TO 200 + ELSE + CALL PLOTOT(1) + RETURN + ENDIF + ENDIF +! +! Write list of options and request choice +! + 200 CONTINUE +! +! Decode choice and open appropriate file +! + IF(NTPIN .EQ. 0) THEN + if(nhtp .lt. 3) then + call WHelpfile(DIRECT) + elseif(nhtp .eq. 3) then + call WHelpfile(DIRECT,'REORDER') + elseif(nhtp .eq. 4) then + call WHelpfile(DIRECT,'NODE') + elseif(nhtp .eq. 5) then + call WHelpfile(DIRECT,'REDRAW') + elseif(nhtp .eq. 6) then + call WHelpfile(DIRECT,'ELEMENT') + elseif(nhtp .eq. 7) then + call WHelpfile(DIRECT,'SELECT') + elseif(nhtp .eq. 8) then + call WHelpfile(DIRECT,'REFINE') + elseif(nhtp .eq. 9) then + call WHelpfile(DIRECT,'ELEVATION') + elseif(nhtp .eq. 10) then + call WHelpfile(DIRECT,'DELETE') + elseif(nhtp .eq. 11) then + call WHelpfile(DIRECT,'SAVE') + elseif(nhtp .eq. 12) then + call WHelpfile(DIRECT,'MAP') + elseif(nhtp .eq. 13) then + call WHelpfile(DIRECT,'WIDTH') + elseif(nhtp .eq. 14) then + call WHelpfile(DIRECT,'POLNODE') + elseif(nhtp .eq. 15) then + call WHelpfile(DIRECT,'POLELEM') + endif + ELSEIF(NTPIN .EQ. 1) THEN + call WHelpfile(DIRECT,'FILE') + ELSEIF(NTPIN .EQ. 2) THEN + call WHelpfile(DIRECT,'ELEMENT') + ELSEIF(NTPIN .EQ. 3) THEN + call WHelpfile(DIRECT,'NODE') + ELSEIF(NTPIN .EQ. 4) THEN + call WHelpfile(DIRECT,'ELEVATION') + ELSEIF(NTPIN .EQ. 5) THEN + call WHelpfile(DIRECT,'REORDER') + ELSEIF(NTPIN .EQ. 6) THEN + call WHelpfile(DIRECT,'SELECT') + ELSEIF(NTPIN .EQ. 7) THEN + call WHelpfile(DIRECT,'DELETE') + ELSEIF(NTPIN .EQ. 8) THEN + call WHelpfile(DIRECT,'SAVE') + + ENDIF + RETURN + END diff --git a/src/INITSIZ.f90 b/src/INITSIZ.f90 new file mode 100644 index 0000000..45177f2 --- /dev/null +++ b/src/INITSIZ.f90 @@ -0,0 +1,162 @@ + SUBROUTINE INITSIZ(IIN1,N1,M1,K1) + + USE WINTERACTER + USE BLK1MOD + USE BLK2MOD + USE BLKMAP + + INCLUDE 'D.INC' + + IF(K1 .EQ. 0) THEN + MAXPL=200000 + MAXP=100000 + MAXE=60000 + MAXSTO=2 + MAXLIN=3000 + MAXECON=60 + MAXECON1=30 + MAXLN=20 + MAELN=300 + RETURN + ENDIF + IMIDS=0 + IF(IIN1 .EQ. 10. .AND. IGFG .EQ. 0 .AND. ITRIAN .EQ. 0) THEN + CALL RDRM1(IIN1,N1,M1,IMIDS) + ENDIF + IF(ITRIAN .EQ. 0) NMIDS=1 + iqsw(1)=1 + iqsw(2)=0 + CALL WMenuSetState(ID_ITYPN,ItemChecked,1) + + IF(N1 .GT. MAXP .OR. M1 .GT. MAXE .AND. IMIDS .EQ. 0) then + + CALL WMessageBox(YesNo, QuestionIcon, 1,'Do you wish to add 20,000 nodes and elements to the limit (YES) or reset sizes (NO)','LIMITS EXCEEDED') + + IF (WInfoDialog(4) .ne. 2) then +! yes + MAXP=N1+20000 + MAXE=M1+20000 + ELSE + CALL RESETSIZ + ENDIF + ELSEIF((N1 .GT. MAXP/3 .OR. M1 .GT. MAXE) .AND. IMIDS .EQ. 1) then + CALL WMessageBox(YesNo, QuestionIcon, 1,'This is a large unfilled network, do you wish to reset sizes?','LIMITS EXCEEDED') + IF (WInfoDialog(4) .ne. 2) then +! yes + CALL RESETSIZ + ENDIF + + endif + + ALLOCATE (CORD(MAXP,2),XUSR(MAXP),YUSR(MAXP),XC(MAXE),YC(MAXE)& + ,NOP(MAXE,8),IMAT(MAXE),THTA(MAXE),IMATL(MAXE),CORDSN(MAXP,2)& + ,WD(MAXP) ,WD1(MAXP),INSKP(MAXP), IESKP(MAXE),NCORN(MAXE)& + ,WIDTH(MAXP), SS1(MAXP), SS2(MAXP), WIDS(MAXP)& + ,IJUN(MAXP),INEW(MAXP),IEM(MAXE),LINTYP(MAXLIN),NEFLAG(MAXP),NEF(MAXP,3),LAY(0:MAXP+1),WTLAY(0:MAXP+1,9)& + ,WIDBS(MAXP),SSO(MAXP),NODDEL(MAXP),IELDEL(MAXE)& + ,NOPSV(MAXE,8),nefsv(MAXP,3),IMATSV(MAXE),LOCK(MAXP),BS1(MAXP),EDIF(0:MAXP),IGRPSER(MAXE),IOD(MAXP)) + + IJUN=0 + lay=0 + IGRPSER=1 + + ALLOCATE (NRIVCR1(MAXP),WTRIVCR1(MAXP),NRIVCR2(MAXP),WTRIVCR2(MAXP)) + + + ALLOCATE (xusrsto(MAXP,MAXSTO),yusrsto(MAXP,MAXSTO),wdsto(MAXP,MAXSTO),& + WIDTHsto(MAXP,MAXSTO), SS1sto(MAXP,MAXSTO), SS2sto(MAXP,MAXSTO), WIDSsto(MAXP,MAXSTO)& + ,WIDBSsto(MAXP,MAXSTO),SSOsto(MAXP,MAXSTO),bs1sto(MAXP,MAXSTO)& + ,nopsto(MAXE,8,MAXSTO),imatsto(MAXE,MAXSTO),thtasto(MAXE,MAXSTO)) + + ALLOCATE (ICCLNSTO(50,350,MAXSTO)& + ,NPSTO(MAXSTO),NESTO(MAXSTO),NLSTSTO(MAXSTO),NCLMSTO(MAXSTO)) + + ALLOCATE (ILISTSTO(MAXLN,MAELN,MAXSTO),LLISTSTO(MAXLN,MAXSTO)) + + + ALLOCATE (MLIST(MAXE),ENXT(MAXE),NDELM(MAXP),LIST(MAXP) & + ,NINC(MAXP),NELIM(MAXE)) + + ALLOCATE (ICON(MAXE,MAXECON)) + + ALLOCATE (NECON(MAXP,MAXECON)) + + ALLOCATE (MSN(MAXP),ICN(MAXP)) + + ALLOCATE (ILIST(MAXLN,MAELN),LLIST(MAXLN)) + + RETURN + END + + SUBROUTINE RESETSIZ + + USE WINTERACTER + USE BLK1MOD + USE BLKMAP + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: NTYP,NLOCC + + + call wdialogload(IDD_MLIMITS) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_MLIMITS) + ierr=infoerror(1) + + CALL WDialogPutINTEGER(IDF_INTEGER1,MAXP) + CALL WDialogPutINTEGER(IDF_INTEGER2,MAXE) + CALL WDialogPutINTEGER(IDF_INTEGER3,MAXPL) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetINTEGER(IDF_INTEGER1,MAXP) + CALL WDialogGetINTEGER(IDF_INTEGER2,MAXE) + CALL WDialogGetINTEGER(IDF_INTEGER3,MAXPL) + + GO TO 100 + ENDIF + + enddo + + 100 CONTINUE + return + end + + SUBROUTINE SETGFGTRIAN(I1,I2,N2,M2) + USE BLK1MOD +! Define a common block with file names etc + + INCLUDE 'BFILES.I90' + CHARACTER (LEN=255) :: FNAMTMP + IGFG=I1 + ITRIAN=I2 + IF(ITRIAN .EQ. 1) THEN + READ(10,*) M2 + REWIND (10) + itunit=14 + FNAMTMP=FNAMKEP + DO L=255,1,-1 + IF(FNAMTMP(L:L) .EQ. '.') THEN + FNAMTMP(L+1:L+4)='node' + OPEN(ITUNIT,FILE=FNAMTMP,STATUS='OLD',ACTION='READ') + READ(ITUNIT,*) N2 + CLOSE(ITUNIT) + RETURN + ENDIF + ENDDO + ENDIF + RETURN + END \ No newline at end of file diff --git a/src/INOUT.F90 b/src/INOUT.F90 new file mode 100644 index 0000000..862fe42 --- /dev/null +++ b/src/INOUT.F90 @@ -0,0 +1,2504 @@ +!IPK LAST UPDATE SEP 23 2015 ADD OPTION FOR SURFER FORMAT MAPS +!IPK LAST UPDATE FEB 11 2002 ADD LOCK AS VARIABLE AND READ NEW MAP FILE +!ipk jan99 fix restart file +! +! +!**************************************************************** +! + SUBROUTINE WRTOUT(IFOM) +!ipk oct95 IFO replaced by IFOM because the value changes +! +! Write out updated data +! +! IFO = 0 write to backup +! IFO = 1 write to output in ASCII +!IPK MAR94 add a line +! IFO = -1 write to ASCII in emergency +! IFO = 2 write to output as binary +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*55 FMTT + CHARACTER*39 FMTU +!IPK JUL98 + CHARACTER*8 ID8 + CHARACTER*60 LIND + CHARACTER*32 IJNK +! + DATA ISET /2/,ZERO/0.0/ +!ipk oct95 copy IFO from IFOM +!ipk feb99 IOT=20 +!ipk feb99 IOT1=22 + + IF((IFOM .EQ. 2 .AND. IOT1 .EQ. 0) .OR. & + & (IFOM .EQ. 1 .AND. IOT .EQ. 0)) THEN + CALL CLRBOX + WRITE(LIND,*) 'You have attempted to save without opening save f& + &ile' + CALL SYMBL(0.2,7.80,0.20,LIND,0.0,60) + WRITE(LIND,*) 'Press return to continue' + CALL SYMBL(0.2,7.55,0.20,LIND,0.0,60) + CALL GTCHARX(IJNK,NDIG,5.0,7.6) + CALL CLRBOX + RETURN + ENDIF + IFO=IFOM + + IF(IFO .GT. 0) THEN +! +! Check connectivity before saving +! + CALL CHKCON(IREP) + IF(IREP .EQ. 0) RETURN + ENDIF +! +! Setup 1-D + IOD=2 + DO N=1,NE + IF(NCORN(N) .LT. 6) THEN + IF(NCORN(N) .EQ. 5) THEN + NCN=3 + ELSE + NCN=NCORN(N) + ENDIF + DO K=1,NCN + INODE=NOP(N,K) + IF(INODE .GT. 0) IOD(INODE)=1 + ENDDO + ELSE + DO K=1,8 + INODE=NOP(N,K) + IF(INODE .GT. 0) then + IF(IOD(INODE) .EQ. 2) IOD(INODE)=0 + ENDIF + ENDDO + ENDIF + ENDDO + DO J=1,NP + IF(IOD(J) .EQ. 0) THEN + WIDTH(J)=0. + SS1(J)=0. + SS2(J)=0. + WIDS(J)=0. + WIDBS(J)=0. + SSO(J)=0. + BS1(J)=0. + ENDIF + ENDDO +!IPK MAR94 add a line + IFO = ABS(IFO) + if((ifo .eq. 1 .and. igfgsw .eq. 0) .or. ifo .ne. 1) then + if(itrianout .eq. 0) CALL HEADIN(IFO,ISET) + endif + IF(IFO .EQ. 0 ) THEN + WRITE(IBAK) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE) + WRITE(IBAK) & + & (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), & + & WIDBS(J),SSO(J),BS1(J),J=1,NP) +!IPK MAR02 add BS1 +!IPK JUL98 + (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J) + WRITE(IBAK) NLST + IF(NLST .GT. 0) THEN + WRITE(IBAK) (LLIST(J),J=1,NLST), & + & ((ILIST(J,I),I=1,LLIST(J)),J=1,NLST) + ENDIF +!IPK JAN01 + WRITE(IBAK) NENTRY,NLAYD,NCLM + IF(NENTRY .GT. 0) THEN + WRITE(IBAK) ((NEF(I,J),J=1,3),I=1,NENTRY) + ENDIF + IF(NLAYD .GT. 0) THEN + WRITE(IBAK) (LAY(I),I=0,NP),((WTLAY(I,J),J=1,9),I=0,NP) + ENDIF +!IPK JAN01 + IF(NCLM .GT. 0) THEN + WRITE(IBAK) ((ICCLN(I,J),J=1,350),I=1,NCLM) + ENDIF + IF(IBAK .EQ. 21) THEN + CLOSE (IBAK) + OPEN(IBAK,FILE='ELT.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost) + if(iost .gt. 0) then + OPEN(IBAK,FILE='ELT1.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost) + if(iost .gt. 0) then + OPEN(IBAK,FILE='ELT2.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost) + if(iost .gt. 0) then + write(*,*) 'ERROR UNABLE TO OPEN ELT.BAK FILE' + write(*,*) 'PRESS RETURN TO END' + read(*,'(I5)') junk + STOP + endif + ENDIF + ENDIF +! OPEN(IBAK,FILE='ELT.BAK',STATUS='UNKNOWN',FORM='BINARY') + ENDIF + + ELSEIF(IFO .EQ. 2) THEN + if(igfgswb .eq. 0) then +!ipk may02 REWIND IOT1 + WRITE(IOT1) & + & NP,NE,(XUSR(J),YUSR(J),ZERO,WD(J),J=1,NP), & + & ((NOP(J,K),K=1,8),IMAT(J),THTA(J),IEM(J),J=1,NE), & + & (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,NP) +!IPK JUL98 + ID8='part-2 ' + WRITE(IOT1) ID8 + WRITE(IOT1) (WIDBS(J),SSO(J),J=1,NP) + +!IPK JAN01 Add part 3 write for continuity lines + IF(NCLM .GT. 0) THEN + ID8='part-3 ' + WRITE(IOT1) ID8 + WRITE(IOT1) NCLM,((ICCLN(I,J),J=1,350),I=1,NCLM) + ENDIF +!IPK JAN01 Add part 4 write for continuity lines + ID8='part-4 ' + WRITE(IOT1) ID8 +!ipk mar02 add BS1 + write(iot1) (lock(j),bs1(j),j=1,np),& + nlst,((ilist(j,k),k=1,maeln),llist(j),j=1,maxln) + else + call wrtbin + endif + ELSE + if(igfgsw .eq. 0 .and. itrianout .eq. 0) then + IOF=IOT + + JJ=0 + DO 10 J=1,NE + IF (IMAT(J) .NE. 0) THEN + JJ=JJ+1 + IF(IECHG .EQ. 0) IEM(JJ)=JJ + + if(np .lt. 100000) then + WRITE(IOF,'(10I5,F10.3,I5)') & + & J, (NOP(J,K),K=1,8), IMAT(J),THTA(J),IEM(JJ) + else + WRITE(IOF,'(10I6,F10.3,I6)') & + & J, (NOP(J,K),K=1,8), IMAT(J),THTA(J),IEM(JJ) + endif + ENDIF + 10 CONTINUE +! +!ipk jan98 restore 9999 + if(np .lt. 100000) then + WRITE(IOF,'(I5)') 9999 + else + WRITE(IOF,'(I6)') 9999 + endif +! +! Write out nodal data +! +!ipk jun97 find max or min number in x or y + cminx=0. + cmaxx=0. + wdmin=1.e10 + wdmax=-1.e10 + do j=1,np + if(inew(j) .eq. 1) then +! write(90,*) j,xusr(j),yusr(j) + if(xusr(j) .gt. cmaxx) cmaxx=xusr(j) + if(yusr(j) .gt. cmaxx) cmaxx=yusr(j) + if(xusr(j) .lt. cminx) cminx=xusr(j) + if(yusr(j) .lt. cminx) cminx=yusr(j) + wdmin=min(wdmin,wd(j)) + wdmax=max(wdmax,wd(j)) + endif + enddo + if(abs(wdmin) .gt. abs(wdmax)) then + temp=log10(abs(wdmin)) + else + temp=log10(abs(wdmax)) + endif + if(temp .gt. 2.) then + itp=3 + elseif(temp .gt. 1.) then + itp=4 + else + itp=5 + endif + ndigp=1 + if(cmaxx .gt. 1.) then + ndigp=int(log10(cmaxx))+1 + endif + ndigm=2 + if(abs(cminx) .gt. 1.) then + ndigm=int(log10(abs(cminx)))+2 + endif + ndigo=max(ndigp,ndigm) + ndec=min(8-ndigo,4) +! write(90,*) 'ndigp',ndigp,ndigm,cmaxx,cminx,ndigo,ndec + if(ntempin .lt. 2) then + write(fmtt,6200) NDEC,NDEC,itp +!IPK JUL98 6200 format('(I10,F10.',i1,',F10.'I1,',F10.3,F10.1,2F10.3,F +!IPK FEB02 ALLOW FOR LOCK AND BS1 + 6200 format('(I10,F10.',i1,',F10.'I1,',F10.',I1,',F10.1,2F10.3,3F10.2,I10,F10.4)') + WRITE(FMTU,6201) NDEC,NDEC,ITP +!IPK FEB02 ALLOW FOR LOCK AND BS1 + 6201 format('(I10,F10.',i1,',F10.'I1,',F10.',I1,',60X,I10,F10.4)') + else + ndec=min(14-ndigo,4) +! write(fmtt,6202) NDEC+10,NDEC+10,ITP + write(fmtt,6202) NDEC+9,NDEC+9,ITP + 6202 format('(I10,g20.',i2,',g20.'I2,',F10.',I1,',F10.1,2F10.3,3F10.2,I10,F10.4)') +! WRITE(FMTU,6203) NDEC+10,NDEC+10,ITP + WRITE(FMTU,6203) NDEC+9,NDEC+9,ITP + 6203 format('(I10,g20.',i2,',g20.'I2,',F10.',I1,',60X,I10,F10.4)') + endif + DO 20 J=1,NP + IF (INEW(J) .EQ. 1) THEN +!ipk oct94 IF(WIDTH(J) .GT. 0.01) THEN + IF(WIDTH(J) .GT. 0.001 .or. bs1(j) .gt. 0.) THEN +!ipk feb97 WRITE(IOF, '(I10,2F10.3,F10.2,F10.1,2F10.3,F10.1 +!IPK JUL97 WRITE(IOF, '(I10,3F10.3,F10.1,2F10.3,F10.1)') +!IPK FEB02 ADD LOCK AND BS1 + + WRITE(IOF, FMTT) & + & J,XUSR(J),YUSR(J),WD(J), & + & WIDTH(J),SS1(J),SS2(J),WIDS(J) & + & ,WIDBS(J),SSO(J),LOCK(J),BS1(J) + + ELSE +! write(90,7777) fmtu,j,xusr(j),yusr(j),ndec,ndigo + 7777 format(3x,a23,i5,2e15.6,2i8) + +!ipk feb97 WRITE(IOF, '(I10,2F10.3,F10.2)') +!IPK JUL97 WRITE(IOF, '(I10,3F10.3)') +!ipk feb02 add lock AND BS1 + WRITE(IOF, FMTU) & + & J,XUSR(J),YUSR(J),WD(J),lock(j),BS1(J) + ENDIF + ENDIF + 20 CONTINUE +!ipk jan98 restore 9999 + WRITE(IOF,'(I10)') 9999 + IF(NLST .GT. 0) THEN + DO 30 J=1,NLST + IF(LLIST(J) .GT. 0) THEN + if(np .lt. 100000) then + WRITE(IOF,'(16I5)') (ILIST(J,I),I=1,LLIST(J)) + else + WRITE(IOF,'(16I6)') (ILIST(J,I),I=1,LLIST(J)) + endif + ENDIF + 30 CONTINUE + ENDIF +!ipk jan98 restore 9999 + WRITE(IOF,'(I5)') 9999 +! IF(NLAYD .GT. 0) THEN +! WRITE(IOF,'(2I5)') (I,LAY(I),I=1,NP) +! ENDIF + WRITE(IOF,6000) NENTRY + 6000 FORMAT(I5,20X,'NENTRY') + IF(NENTRY .GT. 0) THEN + WRITE(IOF,'(15I5)') (NEF(I,1),NEF(I,2),NEF(I,3),I=1,NENTRY) + ENDIF + WRITE(IOF,6001) NCLM + 6001 FORMAT(I5,20X,'NCLM') + IF(NCLM .GT. 0) THEN + DO I=1,NCLM + DO J=1,350 + IF(ICCLN(I,J) .EQ. 0) THEN + NTRAC=J-1 + IF(NTRAC .GT. 0) THEN + WRITE(IOF,6002) I,(ICCLN(I,KK),KK=1,NTRAC) + 6002 FORMAT('CC1',I5,9I8/('CC2',5X,9I8)) + ELSE + WRITE(IOF,6002) I + ENDIF + GO TO 40 + ENDIF + ENDDO + 40 CONTINUE + ENDDO + ENDIF + WRITE(IOF,6003) + 6003 FORMAT('ENDDATA') + elseif(itrianout .gt. 0) then + call wrtele(IOT,itrianout) + else + call wrtgfg(IOT) + endif + ENDIF + RETURN + END +!**************************************************************** + SUBROUTINE HEADIN(IUNIT,ISET) +! +! Read and write header data +! +!**************************************************************** +! + USE BLK1MOD + INTEGER*2 I32 + CHARACTER*80 ALINE +!ipk dec97 + character*40 dlin + CHARACTER*32 IJNK +!IPK JUL98 +!ipk may02 + CHARACTER*8 ID8 + CHARACTER*3 ID + CHARACTER*1000 HEADER + + COMMON /RECOD/ IRECD,TSPC +! INCLUDE 'BLK1.COM' + INCLUDE 'BFILES.I90' + INTEGER*2 NOP2(MAXE,8) + DATA ISLP/0/,IPRT/1/,IPO/1/,IRO/1/,IRFN/0/,IGEN/0/,NXZL/0/,NITST/1/,ISCTXT/0/,IFILL/0/,IALTGM/1/ + DATA HORIZ/10./,VERT/8./,XSALE/1./,YSALE/1./,XFACT/1./,YFACT/1./,AR/0./,ANG/0./ + ! ELSE + !ISLP=0 + !IPRT=1 + !IPO=1 + !IRO=1 + !IRFN=0 + !IGEN=0 + !NXZL=0 + !NITST=1 + !ISCTXT=0 + !IFILL=0 + !IALTGM=1 + + + +! IF ISET = 1 read file +! IUNIT = 0 get a title +! IUNIT ne 0 and IIN = 11 read RST header +! IUNIT ne 0 and IIN = 12 read GEO data +! IUNIT ne 0 and IIN = 10 read RM1 header +! IUNIT ne 0 and IIN = 10 ITRIAN .NE. 0 read ELE header +! IF ISET = 2 write file +! IUNIT = 0 write a backup header +! IUNIT = 0 write RM1 header + +! + IF(ISET .EQ. 1) THEN + IF(IUNIT .EQ. 0) THEN +! +! Generate values +! + CALL SETD(23) +!ipk oct96 WRITE(*,*) 'Enter a title for output file' + WRITE(DLIN,'(a29)') 'Enter a title for output file' +!ipk oct96 change to dlin +! call symbl(0.5,5.0,0.25,dlin,0.0,29) +! ndig=29 +! call gtcharx(title,ndig,0.,4.5) + + IF(IRECD .NE. 2) call get_label(dlin,title) + +! + +!ipk oct96 end changes +!ipk oct96 READ(*,5000) TITLE + CALL SETD(2) +! ISPL=0 + IPRT=1 + IPNN=1 + IPEN=1 + IPO=1 + IRO=1 + IPP=0 + IRFN=0 + IGEN=0 + NXZL=0 + NITST=1 + ISCTXT=0 + IFILL=0 + IALTGM=1 + NLAYD=0 + HORIZ=10. + VERT=8. + XSALE=0. + YSALE=0. + XFACT=0. + YFACT=0. + AR=0. + ANG=0. + xadded=0. + yadded=0. + ntempin=0. + ELSE + IF(IIN .EQ. 11) THEN +!IPK FEB03 READ(IIN) TITLE,NP,NE +!IPK FEB03 READ(IIN) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & +!IPK FEB03 & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin +!IPK FEB03 READ(IIN) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG +!IPK FEB03 IF(IPP .GT. 0) READ(IIN) ALINE + CALL RDRST(1,IIN) + + ELSEIF(IIN .EQ. 12) THEN + CALL SETD(23) + IPRT=1 + IPNN=1 + IPEN=1 + IPO=1 + IRO=1 + IPP=0 + IRFN=0 + IGEN=0 + NXZL=0 + NITST=1 + ISCTXT=0 + IFILL=0 + IALTGM=1 + NLAYD=0 + HORIZ=10. + VERT=8. + XSALE=0. + YSALE=0. + XFACT=0. + YFACT=0. + AR=0. + ANG=0. + xadded=0. + yadded=0. + ntempin=0. + !ipk oct96 WRITE(*,*) 'Enter a title for output file' + WRITE(dLIN,'(a29)') 'Enter a title for output file' + + call get_label(dlin,title) + +! call symbl(0.5,5.0,0.25,dlin,0.0,29) +! ndig=29 +! call gtcharx(title,ndig,0.,4.5) + +!ipk oct96 end changes +!ipk oct96 READ(*,5000) TITLE + CALL SETD(2) + IF(IGFG .EQ. 2) THEN + CALL RDBIN(IIN) + RETURN + ENDIF +!ipk dec97 + read(iin,err=100) header + if(header(1:6) .eq. 'RMAGEN' .or. header(1:6) .eq. 'RMASIM') then + inopt=2 + else + inopt=1 + rewind iin + endif + read(iin) n1,m1 + rewind iin + write(90,*) 'Apparent nodes and elements from file are' + write(90,'(i15,i10)') n1,m1 + if(n1 .gt. maxp .or. m1 .gt. maxe) then +! +!...... Perhaps the file format is wrong, close and reopen +! + WRITE(DLIN,'(A32)') 'Parameter limits may be violated' + call symbl(0.5,4.5,0.20,dlin,0.0,32) + WRITE(DLIN,'(A35)') 'Retrying with alternate file format' + call symbl(0.5,4.2,0.20,dlin,0.0,35) + close (iin) + open(iin ,file=fnamkep,status='old',form='unformatted') + read(iin) n1,m1 + write(90,*) 'Revised nodes and elements from file are' + write(90,'(i15,i10)') n1,m1 + if(n1 .gt. maxp .or. m1 .gt. maxe) then + WRITE(DLIN,'(A31)') 'Parameter limits still violated' + call symbl(0.5,3.9,0.20,dlin,0.0,31) + WRITE(DLIN,'(A27)') 'Apparent nodes and elts are' + call symbl(0.5,3.6,0.20,dlin,0.0,27) + WRITE(DLIN,'(2i10)') n1,m1 + call symbl(0.5,3.3,0.20,dlin,0.0,20) + WRITE(DLIN,'(A24)') 'Press enter to terminate' + call symbl(0.5,4.5,0.20,dlin,0.0,24) + CALL GTCHARX(ijnk,ndig,5.0,4.0) +!cipk aug00 read(*,'(i1)') junk + call quit_pgm + endif + endif + rewind iin +!ipk dec97 end changes +!ipk may02 + if(inopt .eq. 2) then + read(iin,err=100) header + READ(IIN,ERR=100) & + & N1,M1,((CORD(J,K),K=1,2),ALPHA,WD(J),J=1,N1), & + & ((NOP(J,K),K=1,8),IMAT(J),THTA(J),I3,J=1,M1) & + & , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1) +!IPK JUL98 + else + READ(IIN,ERR=100) & + & N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), & + & ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1) & + & , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1) + DO J=1,N1 + DO K=1,2 + CORD(J,K)=CORDSN(J,K) + ENDDO + ENDDO + DO J=1,M1 + DO K=1,8 + NOP(J,K)=NOP2(J,K) + ENDDO + ENDDO + endif + read(IIN,err=120,end=120) id8 + if(id8(1:6) .eq. 'part-2') then + read(IIN,err=104) (widbs(j),sso(j),j=1,n1) + read(IIN,err=120,end=120) id8 + endif + +!IPK JAN01 Add part 3 write for continuity lines + if(id8(1:6) .eq. 'part-3') then + +!ipk aug02 IF(NCLM .GT. 0) THEN + READ(IIN,ERR=104) NCLM,((ICCLN(I,J),J=1,350),I=1,NCLM) +!ipk aug02 ENDIF + read(IIN,err=120,end=120) id8 + endif +!IPK DEB02 Add part 4 write for lock and BS1 lines and reordering + if(id8(1:6) .eq. 'part-4') then + read(iin,err=104,end=120) (lock(j),bs1(j),j=1,n1) + read(iin,err=104,end=90) & + nlst,((ilist(j,k),k=1,maeln),llist(j),j=1,maxln) + endif + GO TO 120 +!IPK MAR04 + 90 NLST=0 + DO J=1,MAXLN + LLIST(J)=0 + DO K=1,MAELN + ILIST(J,K)=0 + ENDDO + ENDDO + GO TO 120 + + 100 READ(IIN,ERR=104) & + & N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), & + & ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1) + DO J=1,N1 + DO K=1,2 + CORD(J,K)=CORDSN(J,K) + ENDDO + ENDDO + DO J=1,M1 + DO K=1,8 + NOP(J,K)=NOP2(J,K) + ENDDO + ENDDO + GO TO 120 + + 104 WRITE(90,*) 'Error reading binary geometry file' +!ipk jan98 CALL SETD(23) + call clscrn() + WRITE(aline,*) 'Error reading binary geometry file' + call symbl & + & (1.1,3.3,0.20,aline,0.0,80) + WRITE(aline,*) 'Press enter to exit' + call symbl & + & (1.1,3.0,0.20,aline,0.0,80) + ndig=1 + CALL GTCHARX(IJNK,NDIG,5.0,7.6) + CALL Quit_Pgm + STOP + + 120 CONTINUE + NP=N1 + NE=M1 + ELSE + IF(IGFG .EQ. 0 .AND. ITRIAN .EQ. 0) THEN + READ(IIN,5000) TITLE + write(90,5000) title + 5000 FORMAT( A80) + READ(IIN,5010) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & + & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin + write(90,5010) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & + & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin + 5010 FORMAT( 15I5,2f10.1,i10) + READ(IIN,5011) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG + 5011 FORMAT( 2F10.0,4F10.4,2F10.0 ) + IF(IPP .GT. 0) READ(IIN,5012) ALINE + 5012 FORMAT(A80) + ELSEIF(IGFG .GT. 0 .OR. ITRIAN .EQ. 1) THEN + write(90,*) 'reading gfg/TRIAN title' + IPRT=1 + IPNN=1 + IPEN=1 + IPO=1 + IRO=1 + IPP=0 + IRFN=0 + IGEN=0 + NXZL=0 + NITST=1 + ISCTXT=0 + IFILL=0 + IALTGM=1 + NLAYD=0 + HORIZ=10. + VERT=8. + XSALE=0. + YSALE=0. + XFACT=0. + YFACT=0. + AR=0. + ANG=0. + xadded=0. + yadded=0. + ntempin=0. + IF(IGFG .EQ. 1) THEN + DO I=1,10000 + READ(IIN,'(A3,A77)') ID,DLIN + IF(ID .EQ. 'T1 ') THEN + TITLE(1:77)=DLIN + GO TO 140 + ENDIF + ENDDO + ELSEIF(IGFG .EQ. 3) THEN + DO I=1,10000 + READ(IIN,'(A8,A77)') ID8,DLIN + IF(ID8 .EQ. 'MESHNAME') THEN + TITLE(1:77)=DLIN + GO TO 140 + ENDIF + ENDDO + ENDIF + 140 CONTINUE + REWIND IIN + ENDIF + ENDIF + ENDIF + ELSE + IF(IUNIT .EQ. 0 ) THEN + IF(IPNN .NE. 1) THEN + ISLP=0 + IPRT=1 + IPNN=1 + IPEN=1 + IPO=1 + IRO=1 + IPP=0 + IRFN=0 + IGEN=0 + NXZL=0 + NITST=1 + ISCTXT=0 + IFILL=0 + IALTGM=1 + NLAYD=0 + HORIZ=10. + VERT=8. + XSALE=0. + YSALE=0. + XFACT=0. + YFACT=0. + AR=0. + ANG=0. + xadded=0. + yadded=0. + ntempin=0 + ENDIF + REWIND IBAK + WRITE(IBAK) TITLE,NP,NE + WRITE(IBAK) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & + & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin + WRITE(IBAK) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG + IF(IPP .GT. 0) WRITE(IBAK) ALINE + ELSEIF(IUNIT .EQ. 1) THEN + IOF=IOT + REWIND IOF +!ipk nov02 +!IPK MAR04 +! if(ne .gt. 99999) then + if(np .gt. 99999) then + if(ntempin .eq. 0) then + ntempin=1 + else + ntempin=3 + endif + endif + ISLP=0 + IPRT=1 + IPO=1 + IRO=1 + IPP=0 + IRFN=0 + IGEN=0 + NXZL=0 + NITST=1 + ISCTXT=0 + IFILL=0 + IALTGM=1 + NLAYD=0 + HORIZ=0 + VERT=0 + XSALE=0 + YSALE=0 + XFACT=0 + YFACT=0 + AR=0 + ANG=0 + WRITE(IOF,5000) TITLE + WRITE(IOF,5010) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & + & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin + WRITE(IOF,5011) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG + IF(IPP .GT. 0) WRITE(IOF,5012) ALINE + ENDIF + ENDIF + RETURN + END +! + SUBROUTINE RDCORD(IUNIT) +! +! Read in coordinates +! +!IPK MAY02 + USE WINTERACTER + USE BLK1MOD + + include 'd.inc' + + REAL*8 CX,CY,VALS(7) + + + DIMENSION IRLINE(16) + CHARACTER*1 IJNK,ans + character*30 blank + CHARACTER*32 ANS32 + CHARACTER*77 DLIN2 + CHARACTER*28 MESG + CHARACTER*3 ID + character*80 dlin +!ipk feb02 expand to 110 + character*150 dlin1 +! INCLUDE 'BLK1.COM' + DATA IFIRST / 0 / + data blank/' '/ +! + IF (IFIRST .EQ. 0) THEN + IF(IIN .EQ. 10) THEN + NP = 0 + ENDIF + VOID = - 1.0E+10 + VDX = -1.E+9 + IFIRST = 1 + ENDIF + ISTART=0 + JZ=0 +! +! + IF(IUNIT .EQ. 0) RETURN + IF(IUNIT .EQ. 10) THEN + IF(IGFG .gt. 0) REWIND IUNIT +!ipk oct96 upgrade to model limits + 20 continue + IF(IGFG .EQ. 0 .AND. ITRIAN .EQ. 0) THEN +!IPK JUL98 read(iunit,'(a80)',end=98) dlin +!ipk feb02 expand to 110 +!ipk may02 expand to 150 + read(iunit,'(a150)',end=98) dlin1 + if(dlin1(11:30) .eq. blank) go to 98 +!IPK JUL98 READ(dlin,'(I10,7F10.0)') J, CX, CY, BELEV, +!ipk feb02 add lock and BS1 + if(ntempin .lt. 2) then + READ(dlin1,'(I10,9F10.0,I10,F10.0)') J, CX, CY, BELEV, & + & WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11 + else + READ(dlin1,'(I10,2f20.0,7F10.0,I10,F10.0)',err=8888) J, CX, CY, BELEV, & + & WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11 + go to 8889 + 8888 do kcl=61,140 + dlin1(kcl:kcl)=' ' + enddo + READ(DLIN1,'(I10,2F20.0,7F10.0,I10,F10.0)') J, CX, CY, BELEV,& + WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11 +8889 continue + + + endif + ELSEIF(ITRIAN .EQ. 1) THEN + IF(ISTART .EQ. 0) THEN + READ(IUNIT,*) NPPP,NDUM,NATTR + ISTART=1 + ENDIF + READ(IUNIT,*) J,CX,CY,(VALS(K),K=1,NATTR) + IF(J .EQ. 0) THEN + J=NPPP + JZ=1 + ENDIF + BELEV=-9999. + WDTHX=0. + SS1X=0. + SS2X=0. + WDSX=0. + WEL=0. + SSSO=0. + LOCK1=0 + BS11=0. + IF(NATTR .GT. 0) BELEV=VALS(1) + IF(NATTR .GT. 1) WDTHX=VALS(2) + IF(NATTR .GT. 2) SS1X=VALS(3) + IF(NATTR .GT. 3) SS2X=VALS(4) + + ELSE + +!ipk jun02 Allow for GFGEN input + DO ICOUNTC=1,1000000 + DO JJ=1,150 + DLIN1(JJ:JJ)=' ' + ENDDO + READ(IUNIT,'(A3,A150)', END=400) ID,DLIN1 + IF(ID .EQ. 'GNN' .OR. ID .EQ. 'GWN') THEN +! Count the number of variables + I=0 + ICOUNT=0 + 75 CONTINUE + IF(DLIN1(I+1:I+1) .NE. ' ') THEN + GO TO 80 + ELSE + I=I+1 + GO TO 75 + ENDIF + 80 I=I+1 + IF(I .EQ. 151) THEN + ICOUNT =ICOUNT+1 + GO TO 90 + ENDIF + IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN + ICOUNT=ICOUNT+1 + 85 CONTINUE + IF(I+1 .EQ. 151) GO TO 90 + IF(DLIN1(I+1:I+1) .EQ. ' ') THEN + I=I+1 + GO TO 85 + ELSE + GO TO 80 + ENDIF + ELSE + GO TO 80 + ENDIF + ELSEIF(ID(1:2) .EQ. 'ND') THEN + ICOUNT=4 + go to 90 + ENDIF + ENDDO + 90 CONTINUE + DO K=1,7 + VALS(K)=0. + ENDDO + READ(DLIN1,*) J,(VALS(K),K=1,ICOUNT-1) +! WRITE(109,'(A8,I8,10F15.6)') ID,J,(VALS(K),K=1,ICOUNT-1) + IF(ID .EQ. 'GNN' .OR. ID .EQ. 'ND ') THEN + CX=VALS(1) + CY=VALS(2) + BELEV=VALS(3) + NP = MAX(NP,J) + CORD(J,1) = CX + CORD(J,2) = CY + XUSR(J) = CX + YUSR(J) = CY + WD(J) = BELEV + INSKP(J)=0 + INEW(J) = 1 + GO TO 20 + ELSE + WDTHX=VALS(1) + SS1X=VALS(2) + SS2X=VALS(3) + WDSX=VALS(4) + WIDTH(J)=WDTHX + SS1(J)=SS1X + SS2(J)=SS2X + WIDS(J)=WDSX + GO TO 20 + ENDIF + ENDIF +!c IF (J .GT. 9000) GOTO 98 + IF (J .GE. MAXP) THEN +!ipk jan98 CALL SETD(23) + call clscrn() + WRITE(dlin,*) ' Node number exceeds MAXP in RDCORD',j + call symbl & + & (1.1,3.3,0.20,dlin,0.0,80) + WRITE(90,*) ' Node number exceeds MAXP in RDCORD' + WRITE(DLIN,*) ' Press enter to exit' + call symbl & + & (1.1,3.0,0.20,dlin,0.0,80) + ndig=1 + CALL GTCHARX(ANS32,ndig,5.0,4.0) +!ipk jan98 READ(*,'(A)') IJNK + CALL Quit_Pgm + STOP + ENDIF + NP = MAX(NP,J) + CORD(J,1) = CX + CORD(J,2) = CY + XUSR(J) = CX + YUSR(J) = CY + WD(J) = BELEV + WIDTH(J)=WDTHX + SS1(J)=SS1X + SS2(J)=SS2X + WIDS(J)=WDSX +!IPK JUL98 + WIDBS(J)=WEL + SSO(J)=SSSO + INSKP(J)=0 + INEW(J) = 1 +!IPK FEB02 ADD LOCK + LOCK(J)=LOCK1 + BS1(J)=BS11 + IF(ITRIAN .EQ. 1) THEN + IF((JZ .EQ. 0 .AND. J .EQ. NPPP) .OR. (JZ .EQ. 1 .AND. J .EQ. NPPP-1)) GO TO 400 + ENDIF +! + GOTO 20 +! + 98 CONTINUE + NLST=0 + KK=0 + 102 continue + if(np .gt. 99999) then + READ(IUNIT,'(16I6)') IRLINE + else + READ(IUNIT,'(16I5)') IRLINE + endif + IF(IRLINE(1) .EQ. 9999 .or. IRLINE(1) .EQ. 99999) GO TO 300 + IF(KK .EQ. 0) NLST=NLST+1 + 104 DO 105 K=1,16 + IF(IRLINE(K) .EQ. 0) GO TO 106 + KK=KK+1 + ILIST(NLST,KK)=IRLINE(K) + 105 CONTINUE + GO TO 102 + 106 CONTINUE + LLIST(NLST)=KK + KK=0 + GO TO 102 + 300 CONTINUE +! IF(NLAYD .GT. 0) THEN +! DO 320 L=1,NP +! READ(IUNIT,'(2I5)') I,LAY(I) +! IF(I .GT. 9000) GO TO 325 +! 320 CONTINUE +! 325 CONTINUE +! ENDIF +!IPK JAN01 + READ(IUNIT,'(I5)',end=375) NENTRY + IF(NENTRY .GT. 0) THEN + READ(IUNIT,'(15I5)') (NEF(I,1),NEF(I,2),NEF(I,3),I=1,NENTRY) + ENDIF + READ(IUNIT,'(I5)', end=375) NCLM + write(90,*) 'INOUT-695 NCLM',nclm + IF(NCLM .GT. 0) THEN + READ(IUNIT,'(A3,A77)') ID,DLIN2 + WRITE(90,'(''INOUT-698'',A3,A77)'),ID,DLIN + IF(ID .EQ. 'CC1') THEN + 330 READ(DLIN2,'(I5,9I8)') I,(ICCLN(I,J),J=1,9) + WRITE(90,'(I5,9I8)') I,(ICCLN(I,J),J=1,9) + NL=1 + 340 NL=NL+9 + READ(IUNIT,'(A3,A77)',end=375) ID,DLIN2 + WRITE(90,'(''INOUT-705'',A3,A77)'),ID,DLIN + IF(ID .EQ. 'CC2') THEN + READ(DLIN2,'(5X,9I8)') (ICCLN(I,J),J=NL,NL+8) + ELSEIF(ID .EQ. 'CC1') THEN + GO TO 330 + ELSEIF(ID .EQ. 'END') THEN + GO TO 375 + ENDIF + GO TO 340 + ENDIF + ENDIF + + 375 CONTINUE + WRITE(90,*) 'INOUT-718 NCLM',NCLM + ELSE + IF(IUNIT .EQ. 11) THEN +!IPK FEB03 READ(IUNIT) & +!IPK FEB03 & (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), & +!IPK FEB03 & WIDBS(J),SSO(J),BS1(J),J=1,NP) +!IPK FEB03!ipk jan99 + (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J) +!IPK FEB03 DO 350 J=1,NP +!IPK FEB03 CORD(J,1) = XUSR(J) +!IPK FEB03 CORD(J,2) = YUSR(J) +!IPK FEB03 INSKP(J)=0 +!IPK FEB03 IF (CORD(J,1) .GT. VDX) THEN +!IPK FEB03 INEW(J) = 1 +!IPK FEB03 ENDIF +!IPK FEB03 350 CONTINUE +!IPK FEB03 READ(IUNIT) NLST +!IPK FEB03 IF(NLST .GT. 0) THEN +!IPK FEB03 READ(IUNIT) (LLIST(J),J=1,NLST), & +!IPK FEB03 ((ILIST(J,I),I=1,LLIST(J)),J=1,NLST) +!IPK FEB03 ENDIF + +!IPK FEB03 READ(IUNIT) NENTRY,NLAYD,NCLM +!IPK FEB03 IF(NENTRY .GT. 0) THEN +!IPK FEB03 READ(IUNIT) ((NEF(I,J),J=1,3),I=1,NENTRY) +!IPK FEB03 ENDIF +!IPK FEB03 IF(NLAYD .GT. 0) THEN +!IPK FEB03 READ(IUNIT) (LAY(I),I=1,NP) +!IPK FEB03 ENDIF +!IPK FEB03 IF(NCLM .GT. 0) THEN +!IPK FEB03 READ(IUNIT) ((ICCLN(I,J),J=1,350),I=1,NCLM) +!IPK FEB03 ENDIF + + CALL RDRST(3,IUNIT) + + ELSE + DO 360 J=1,NP + XUSR(J) = CORD(J,1) + YUSR(J) = CORD(J,2) +!!apr99 INSKP(J)=0 + IF (CORD(J,1) .GT. VDX) THEN + INSKP(J)=0 + INEW(J) = 1 + ENDIF + 360 CONTINUE + ENDIF + ENDIF + 400 CONTINUE + WRITE(90,*) 'INOUT-762 NCLM',NCLM + +! +!ipk jun02 look for nodes that do not have coordinates but are defined in NOP + + do n=1,ne + if(imat(n) .gt. 0) then + ncn=ncorn(n) + if(ncn .eq. 3) then + n1=nop(n,2) + if(n1 .ne. 0) then + if(inew(n1) .ne. 1) then + cord(n1,1)=(cord(nop(n,1),1)+cord(nop(n,3),1))/2. + cord(n1,2)=(cord(nop(n,1),2)+cord(nop(n,3),2))/2. + XUSR(n1) = CORD(n1,1) + YUSR(n1) = CORD(n1,2) + INSKP(n1)=0 + INEW(n1) = 1 + endif + endif + elseif(ncn .gt. 5) then + do k=2,ncn,2 + n1=nop(n,k) + IF(N1 .NE. 0) THEN + if(inew(n1) .ne. 1) then + kk=mod(k+1,ncn) + cord(n1,1)=(cord(nop(n,k-1),1)+cord(nop(n,kk),1))/2. + cord(n1,2)=(cord(nop(n,k-1),2)+cord(nop(n,kk),2))/2. + XUSR(n1) = CORD(n1,1) + YUSR(n1) = CORD(n1,2) + INSKP(n1)=0 + INEW(n1) = 1 + NP = MAX(NP,n1) + endif + ENDIF + if(inew(nop(n,k-1)) .eq. 0) then + CALL EltERRDisp(n,ims) + if(ims .eq. 1) CALL DELTEL(n) + go to 120 + endif + enddo +120 continue + endif + endif + enddo + WRITE(90,*) 'INOUT-797 NCLM',NCLM + + WRITE(MESG,6010) NE + 6010 FORMAT(I7,' Nodes read from file') + CALL SYMBL(1.1,3.3,0.25,mesg,0.0,28) + + RETURN +! + END +! +!**************************************************************** +! + SUBROUTINE RDMAP(IFIRST,IMPP,JSTT,KSTT) +! +! Read in coordinates of map lines +! + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + DIMENSION NTMP(9) + DIMENSION VALS(2000) + INTEGER*8 II +! + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! + CHARACTER*80 ALIN,lind +!ipk jan98 CHARACTER*1 IJNK + CHARACTER*1 ans + CHARACTER*32 ANS32 + CHARACTER*5 LAB1 + CHARACTER*9 LAB2 + CHARACTER*8 LAB3 + CHARACTER*12 LAB4 + CHARACTER*4 HEDR +! + 5 continue + + + ielvsw=0 +! IF (IFIRST .EQ. 0) THEN + IF(IFIRST .EQ. 2) IMP=IMPP + VOID = - 1.0E+10 + VDX = -1.0E+9 + CXO=VDX + CYO=VDX + DO 10 J=JSTT+1,MAXPL + CMAP(J,1) = VOID + CMAP(J,2) = VOID + XMAP(J) = VOID + YMAP(J) = VOID + 9 CONTINUE + 10 CONTINUE + write(90,*) 'maxpl in rdmap - 1 ',maxpl +!ipk jan98 + ylv=7.9 + call clscrn +! ENDIF +! +!ipkfeb94 added logic + if(imp .eq. 9) then +! + I=0 + J=0 + K=1 +20 READ(IMP,'(A80)') ALIN + if(alin(1:5) .eq. 'NCOLS') THEN + CALL RDESRI(alin,j,k) + GO TO 98 + ENDIF +!ipk oct96 addition to identify first point + KFIRST=0 + I=I+1 + IF(MOD(I,25) .EQ. 0) REWIND 90 + WRITE(90,'(2i5,A65)') I,K,ALIN +!ipk oct94 3 lines added + if(mod(i,2000) .eq. 0) then +!ipk jan98 write(*,*) i,' map lines now processed' + ylv=ylv-0.3 + if(ylv .lt. 0.1) then + ylv=7.9 + call clscrn + endif + write(lind,6010) i + call symbl & + & (1.1,ylv,0.20,LIND,0.0,80) + endif + DO KC=1,5 + IF(ALIN(KC:KC) .EQ. 'E' .OR. ALIN(KC:KC) .EQ. 'e') THEN + GO TO 98 + ENDIF + ENDDO + READ(ALIN,*) LINTYP(K),VALL + valkp=vall + IF(K .GT. MAXLIN) THEN +!ipk dec09 CALL SETD(23) +!ipk jan98 +!ipk dec09 WRITE(lind,*) 'Too many map lines. increase maxlin in common' +!ipk dec09 ylv=ylv-0.6 +!ipk dec09 if(ylv .lt. 0.1) then +!ipk dec09 ylv=7.9 +!ipk dec09 call clscrn +!ipk dec09 endif +!ipk dec09 call symbl & +!ipk dec09 & (1.1,ylv,0.20,LIND,0.0,80) +!ipk dec09 WRITE(90,*) 'Too many map lines. increase maxlin in common' +!ipk jan98 WRITE(*,*) ' Press enter to exit' +!ipk jan98 READ(*,'(A)') IJNK +!ipk dec09 WRITE(LIND,*) ' Press enter to exit' +!ipk dec09 call symbl & +!ipk dec09 & (1.1,ylv-0.3,0.20,lind,0.0,80) +!ipk dec09 ndig=1 +!ipk dec09 CALL GTCHARX(ANS,IJNK,5.0,4.0) +!ipk dec09 CALL Quit_Pgm + + MAXPLL=MAXPL + call ADJUSTMAP(MAXPLL) + MAXPL=MAXPLL + deallocate (CMAP,XMAP,YMAP,VAL,imap,NCRS) + + allocate (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL)) + + ALLOCATE (imap(maxpl),NCRS(MAXPL)) + + maxpts=maxpl + ifirst=0 + rewind imp + go to 5 + + ENDIF + 21 CONTINUE + READ(IMP,'(A80)') ALIN + +!ipk sep05 + + do i=1,80 + if(alin(i:i) .eq. char(9)) then + alin(i:i)=',' + endif + enddo + + I=I+1 + IF(MOD(I,25) .EQ. 0) REWIND 90 + WRITE(90,'(2i5,A65)') I,K,ALIN +!ipk oct94 3 lines added + if(mod(i,10000) .eq. 0) then +!ipk jan98 write(*,*) i,' map lines now processed' + ylv=ylv-0.3 + if(ylv .lt. 0.1) then + ylv=7.9 + call clscrn + endif + write(lind,6010) i + 6010 format(i8,' map points processed') + call symbl & + & (1.1,ylv,0.20,LIND,0.0,80) + endif + DO KC=1,5 + IF(ALIN(KC:KC) .EQ. 'E' .OR. ALIN(KC:KC) .EQ. 'e') THEN + GO TO 97 + ENDIF + ENDDO +!ipk oct96 change to permit more line types +!ipk jan01 IF(LINTYP(K) .NE. 2 .and. valkp .lt. -9998.) THEN +!IPK APR03 IF(LINTYP(K) .NE. 2 .and. valkp .ne. 0.) THEN +!IPK APR03 READ(ALIN,*) CX, CY +!IPK APR03 vall=valkp +!IPK APR03 ELSE +!IPK APR03 READ(ALIN,*) CX, CY, VALL +!IPK APR03 ENDIF + IF(LINTYP(K) .EQ. 2) THEN + READ(ALIN,*) CX, CY, VALL + ELSEIF(VALKP .LT. 9999.) THEN + READ(ALIN,*) CX, CY + vall=valkp + ELSEIF(VALKP .EQ. 9999.) THEN + READ(ALIN,*) CX, CY, VALL + ENDIF +!ipk oct96 addition to prevent test on first point + if(kfirst .ne. 0) then + IF(CX .EQ. CXO .AND. CY .EQ. CYO) GO TO 21 + else + kfirst=1 + endif + IF(J .EQ. MAXPL) THEN + CALL SETD(23) +!ipk jan98 WRITE(*,*) 'Too many map points. increase maxpl in co +!ipk jan98 WRITE(90,*) 'Too many map points. increase maxpl in c +!ipk jan98 WRITE(*,*) ' Press enter to exit' +!ipk jan98 READ(*,'(A)') IJNK +!ipk jan98 +!ipk dec09 WRITE(lind,6030) maxpl +!ipk dec09 6030 format ('Map point exceed',i10,' increase maxpl in common' ) +!ipk dec09 ylv=ylv-0.6 +!ipk dec09 if(ylv .lt. 0.1) then +!ipk dec09 ylv=7.9 +!ipk dec09 call clscrn +!ipk dec09 endif +!ipk dec09 call symbl & +!ipk dec09 & (1.1,ylv,0.20,LIND,0.0,80) +!ipk dec09 WRITE(90,6030) maxpl +!ipk jan98 WRITE(*,*) ' Press enter to exit' +!ipk jan98 READ(*,'(A)') IJNK +!ipk dec09 WRITE(LIND,*) ' Press enter to exit' +!ipk dec09 call symbl & +!ipk dec09 & (1.1,ylv-0.3,0.20,lind,0.0,80) +!ipk dec09 ndig=1 +!ipk dec09 CALL GTCHARX(ANS,IJNK,5.0,4.0) +!ipk dec09 CALL Quit_Pgm + + call ADJUSTMAP(MAXPL) + deallocate (CMAP,XMAP,YMAP,VAL,imap,NCRS) + + allocate (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL)) + + ALLOCATE (imap(maxpl),NCRS(MAXPL)) + + maxpts=maxpl + + rewind imp + go to 5 + + + + + ENDIF + J=J+1 + CMAP(J,1) = CX + CMAP(J,2) = CY + XMAP(J) = CX + YMAP(J) = CY + VAL(J) = VALL + CXO=CX + CYO=CY +! + GOTO 21 +! + 97 CONTINUE + J=J+1 + K=K+1 + GO TO 20 + 98 CONTINUE +!ipk feb94 + klint=k-1 + jlint=j +!ipk feb94 end change + J=J+1 + +!IPK FEB03 + + MAXPTS=J-2 + + write(90,*) 'maxpts in rdmap - 2 ',maxpts,xmap(908) + +!IPK FEB02 SCLAE NEW VALUES + + IF(IFIRST .EQ. 2) THEN + IF(CMAP(MAXPTS,1) .GE. VDX) MAXPTS=MAXPTS+1 + DO K=1,MAXPTS + IF (CMAP(K,1) .GT. VDX) THEN + CMAP(K,1) = (CMAP(K,1)+XS)/TXSCAL + CMAP(K,2) = (CMAP(K,2)+YS)/TXSCAL + ENDIF + END DO + ENDIF + write(90,*) 'maxpts',maxpts + CLOSE(IMP) +! do k=1,maxpts +! write(90,*) cmap(k,1),cmap(k,2),xmap(k),ymap(k),val(k) +! enddo + RETURN + ELSEIF(IMP .EQ. 113) THEN + CALL READSHP +! +! +!ipkfeb94 logic to add binary read of map +! + elseif(imp .eq. 92 .OR. IMP .GT. 94) then + + +!ipk jan98 test for max lines + read(imp) klint,jlint + rewind imp + if(klint+KSTT .gt. maxlin .or. jlint +JSTT .gt. maxpl) then + call clscrn + write(lind,6310) + 6310 format(' Compilation limits exceeded') + call symbl & + & (0.5,3.5,0.20,LIND,0.0,80) + write(lind,6311) maxpl,jlint + 6311 FORMAT(' Maximum map points =',2i8,' points requested') + call symbl & + & (0.5,3.2,0.20,LIND,0.0,80) + write(lind,6312) maxlin,klint + 6312 FORMAT( ' Maximum lines =',2i8,' lines requested') + call symbl & + & (0.5,2.9,0.20,LIND,0.0,80) + WRITE(LIND,*) ' Press enter to exit' + call symbl & + & (0.5,2.0,0.20,lind,0.0,80) + ndig=1 + CALL GTCHARX(ANS32,IJNK,5.0,4.0) + CALL Quit_Pgm + STOP + endif + read(imp) klint,jlint,(xmap(j),ymap(j),val(j),j=JSTT+1,JSTT+jlint) & + & ,(lintyp(k),k=KSTT+1,KSTT+klint) + read(imp,end=200) nelts ,((nopel(j,k),k=1,3),j=1,nelts) + maxpts=jlint+JSTT + go to 220 + 200 continue + MAXPTS=JLINT+JSTT + nelts=0 + 220 continue + do j=JSTT+1,JSTT+jlint + cmap(j,1)=xmap(j) + cmap(j,2)=ymap(j) + enddo + JLINT=MAXPTS + KLINT=KSTT+klint + ELSEIF(IMP .EQ. 94) THEN + READ(IMP,'(A4)') HEDR + IF(HEDR .EQ. 'DSAA') THEN + READ(IMP,*) NCOLS1,NROWS1 + maxpts=ncols1*nrows1 + if(maxpts .gt. maxpl) then + maxpl=maxpts+1 + deallocate (CMAP,XMAP,YMAP,VAL,imap,NCRS) + + allocate (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL)) + + ALLOCATE (imap(maxpl),NCRS(MAXPL)) + + endif + READ(IMP,*) XXORG,XXTOP,YYORG,YYTOP + READ(IMP,*) DD1,DD2 + DXINT=(XXTOP-XXORG)/(NCOLS1-1) + DYINT=(YYTOP-YYORG)/(NROWS1-1) + JJ=0 + II=0 + ANODAT=1.E36 + READ(IMP,*) (VAL(I),I=1,MAXPTS) + DO J=NROWS1,1,-1 + DO I=1,NCOLS1 + II=II+1 + IF(VAL(II) .GT. ANODAT) CYCLE + JJ=JJ+1 + XMAP(JJ)=DXINT*(I-1)+XXORG + YMAP(JJ)=DYINT*(NROWS1+1-J)+YYORG + CMAP(JJ,1)=XMAP(JJ) + CMAP(JJ,2)=YMAP(JJ) + VAL(JJ)=VAL(II) + ENDDO + ENDDO + + ELSE + REWIND IMP + READ(IMP,*) LAB1,NCOLS1 + READ(IMP,*) LAB1,NROWS1 + maxpts=ncols1*nrows1 + if(maxpts .gt. maxpl) then + maxpl=maxpts+1 + deallocate (CMAP,XMAP,YMAP,VAL,imap,NCRS) + + allocate (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL)) + + ALLOCATE (imap(maxpl),NCRS(MAXPL)) + + endif + READ(IMP,*) LAB2,XXORG + READ(IMP,*) LAB2,YYORG + READ(IMP,*) LAB3,CELLSIZ + READ(IMP,*) LAB4,ANODAT + JJ=0 + II=0 + READ(IMP,*) (VAL(I),I=1,MAXPTS) + DO J=1,NROWS1 +! READ(IMP,*) (VALS(I),I=1,NCOLS1) + DO I=1,NCOLS1 + II=II+1 + IF(VAL(II) .EQ. ANODAT) CYCLE + JJ=JJ+1 + XMAP(JJ)=CELLSIZ*(I-1)+XXORG + YMAP(JJ)=CELLSIZ*(NROWS1+1-J)+YYORG + CMAP(JJ,1)=XMAP(JJ) + CMAP(JJ,2)=YMAP(JJ) + VAL(JJ)=VAL(II) + ENDDO + ENDDO + ENDIF + MAXPTS=JJ + XMAP(MAXPTS+1)= VOID + + KLINT=1 + LINTYP(1)=2 + else + +! READ AN RM1 FILE AS A MAP FILE + +! first headers + jlint=0 + READ(IMP,'(a80)') alin + READ(IMP,5010) IPP,nnrl8 + 5010 FORMAT( 30x,i5,60x,i10) + READ(IMP,'(a80)') alin + IF(IPP .GT. 0) READ(IMP,'(a80)') ALIN + +! next elements + + 230 CONTINUE + read(imp,'(a80)',end=300) ALIN + + IF(ALIN(6:20) .EQ. ' ') GO TO 250 + if(mod(nnrl8,2) .eq. 0) then + READ(ALIN,'(10I5)',END=250) J, (NTMP(K),K=1,9) + else + READ(ALIN,'(10I6)',END=250) J, (NTMP(K),K=1,9) + endif + NOPEL(J,1)=NTMP(1) + NOPEL(J,2)=NTMP(3) + NOPEL(J,3)=NTMP(5) + NELTS=MAX(J,NELTS) + GO TO 230 + +! finally nodes + 250 CONTINUE + read(imp,'(a80)',end=300) ALIN + if(ALIN(11:30) .eq. ' ') go to 300 + if(nnrl8 .lt. 2) then + READ(alin,'(I10,3F10.0)') J, CX, CY,BELEV + + else + READ(alin,'(I10,2f20.0,F10.0)') J, CX, CY, BELEV + + endif + xmap(j)=cx + CMAP(J,1)=CX + ymap(j)=cy + CMAP(J,2)=CY + val(j)=belev + jlint=max(j,jlint) + + GO TO 250 + + 300 maxpts=jlint + klint=1 + lintyp(1)=2 + ENDIF + +!IPK FEB02 SCALE NEW VALUES + + IF(IFIRST .EQ. 2) THEN + DO K=JSTT+1,MAXPTS + IF (CMAP(K,1) .GT. VDX) THEN + CMAP(K,1) = (CMAP(K,1)+XS)/TXSCAL + CMAP(K,2) = (CMAP(K,2)+YS)/TXSCAL + ENDIF + END DO + ENDIF + CLOSE(IMP) + return + END +! +!*********************************************************************** +! + SUBROUTINE RDELEM(IUNIT) +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + INCLUDE 'BFILES.I90' + CHARACTER*1 AA,ANS + CHARACTER*32 ANS32 + CHARACTER*81 DLIN + CHARACTER*150 DLIN1 + CHARACTER*3 ID +!cipk aug00 + CHARACTER*80 LIND + CHARACTER*25 BLANK + CHARACTER*31 MESG + DIMENSION NTMP(9),ATT(9) +! + DATA IFIRST / 0 / + DATA IERRL /0/ + DATA BLANK /' '/ +!ipk jul94 add a line + MEL=MAXE +!cipk aug00 + ylv=7.5 +! +! Read in existing elements +! + IF (IFIRST .EQ. 0) THEN +! +! Initialize arrays +! + VOID = - 1.0E+10 + VDX = -1.E+9 + IF(IIN .EQ. 10) NE = 0 + IFIRST = 1 + ENDIF + ISTART=0 + NTMP=0 + ATT=0. +! + IF(IUNIT .EQ. 0) RETURN + IF(IUNIT .EQ. 10) THEN + + IF(IGFG .GT. 0) REWIND IUNIT + JZ=0 +!ipk oct96 move around login to allow long length files + 10 CONTINUE + IF(IGFG .EQ. 0 .AND. ITRIAN .EQ. 0) THEN + READ(IUNIT,'(A81)',END=98) DLIN +!ipk mar04 IF(DLIN(6:20) .EQ. BLANK .AND. IERRL .EQ. 0) THEN + IF(DLIN(7:20) .EQ. BLANK .AND. IERRL .EQ. 0) THEN + GO TO 175 +!ipk dec97 generalize to allow multiple errors +!ipk dec97 ELSEIF(IERRL .EQ. 1) THEN + ELSEIF(IERRL .EQ. 1 .and. dlin(6:20) .eq. blank) THEN + CALL SETD(23) +!cipk aug00 + WRITE(lind,6000) + 6000 FORMAT(' Press enter to exit') + call symbl & + & (1.1,ylv-0.3,0.20,lind,0.0,80) + ndig=1 + CALL GTCHARX(ANS32,IJNK,5.0,4.0) + CALL Quit_Pgm + STOP + + ENDIF + ifree=1 + do j=1,10 + if(dlin(j:j) .eq. ',') then + ifree=0 + endif + enddo + if(ifree .eq. 1) then + if(mod(ntempin,2) .eq. 0) then + READ(DLIN,'(10I5,F10.3,I5)',END=98) J, (NTMP(K),K=1,9),THT & + & ,NTEMP + else + READ(DLIN,'(10I6,F10.3,I6)',END=98) J, (NTMP(K),K=1,9),THT & + & ,NTEMP + endif + else + READ(DLIN,*,END=98) J, (NTMP(K),K=1,9),THT & + & ,NTEMP + endif + ELSEIF(ITRIAN .EQ. 1) THEN + IF(ISTART .EQ. 0) THEN + REWIND(IUNIT) + READ(IUNIT,*) NE,NCNTR,NATTR + ISTART=1 + ENDIF + READ(IUNIT,*) J,(NTMP(K),K=1,NCNTR),(ATT(K),K=1,NATTR) + IF(J .EQ. 0) THEN + JZ=1 + J=NE + ENDIF + ELSE +!ipk jun02 Allow for GFGEN input + DO ICOUNTC=1,700000 + DO JJ=1,150 + DLIN1(JJ:JJ)=' ' + ENDDO + READ(IUNIT,'(A3,A150)', END=175) ID,DLIN1 + IF(ID .EQ. 'GE ') THEN +! Count the number of variables + I=0 + ICOUNT=0 + 75 CONTINUE + IF(DLIN1(I+1:I+1) .NE. ' ') THEN + GO TO 80 + ELSE + I=I+1 + GO TO 75 + ENDIF + 80 I=I+1 + IF(I .EQ. 151) THEN + ICOUNT =ICOUNT+1 + GO TO 90 + ENDIF + IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN + ICOUNT=ICOUNT+1 + 85 CONTINUE + IF(I+1 .EQ. 151) GO TO 90 + IF(DLIN1(I+1:I+1) .EQ. ' ') THEN + I=I+1 + GO TO 85 + ELSE + GO TO 80 + ENDIF + ELSE + GO TO 80 + ENDIF + ELSEIF(ID .EQ. 'E3T') THEN + ICOUNT=4 + GO TO 90 + ELSEIF(ID .EQ. 'E4Q') THEN + ICOUNT=5 + GO TO 90 + ENDIF + ENDDO + 90 CONTINUE + IF(ICOUNT .GT. 10) THEN + READ(DLIN1,*) J, (NTMP(K),K=1,9),THT + ELSEIF(IGFG .EQ. 3) THEN + IF(ICOUNT .EQ. 4) THEN + READ(DLIN1,*) J, (NTMP(K),K=1,7,2) + IF(NTMP(7) .EQ. 0) NTMP(9)=1 + NTMP(2)=0 + NTMP(4)=0 + NTMP(6)=0 + NTMP(7)=0 + NTMP(8)=0 + ELSEIF(ICOUNT .EQ. 5) THEN + READ(DLIN1,*) J, (NTMP(K),K=1,9,2) + IF(NTMP(9) .EQ. 0) NTMP(9)=1 + NTMP(2)=0 + NTMP(4)=0 + NTMP(6)=0 + NTMP(8)=0 + ENDIF + ELSE + READ(DLIN1,*) J, (NTMP(K),K=1,9) + ENDIF + ENDIF + +!c IF (J .GT. 9000 .AND. IERRL .EQ. 0) THEN +!c GO TO 175 +!IPK OCT96 END CHANGES + IF (J .GE. MEL) THEN + CALL SETD(23) +!cipk aug00 + WRITE(lind,*) ' Element number exceeds MAXE in RDELEM' + call symbl & + & (1.1,ylv-0.3,0.20,lind,0.0,80) + ndig=1 + WRITE(90,*) ' Element number exceeds MAXE in RDELEM' + WRITE(lind,6000) + CALL GTCHARX(ANS32,IJNK,5.0,4.0) + CALL Quit_Pgm + STOP + ENDIF +! +! Check to ensure there are no duplicate numbers in input stream +! of element connections +! + DO 12 K=1,7 + IF(NTMP(K) .EQ. 0) GO TO 12 + DO 11 L=K+1,8 + IF(NTMP(K) .EQ. NTMP(L)) THEN + CALL SETD(23) +!cipk aug00 +! WRITE(90,5000) J +! write(90,5001) (NTMP(MM),MM=1,8) +! WRITE(lind,5000) J +! call symbl & +! & (1.1,ylv-0.3,0.25,lind,0.0,80) +! ylv=ylv-0.3 +! if(ylv .lt. 0.4) then +! call clscrn +! ylv=7.5 +! endif +! write(lind,5001) (NTMP(MM),MM=1,8) +! call symbl & +! & (1.1,ylv-0.3,0.25,lind,0.0,80) +! ylv=ylv-0.3 +! if(ylv .lt. 0.4) then +! call clscrn +! ylv=7.5 +! endif + 5000 FORMAT(' **ERROR** Nodes at element number',i5,' are duplicated') + 5001 FORMAT(' node list as follows ',8i5) +! IERRL=1 + DO KK=1,8 + NOP(J,KK) = NTMP(KK) + ENDDO + IMAT(J)=NTMP(9) + call eltdisp(j) + DO KK=1,8 + NTMP(KK) = NOP(J,KK) + ENDDO + NTMP(9)=IMAT(J) + GO TO 13 + ENDIF + 11 CONTINUE + 12 CONTINUE + 13 CONTINUE + IF(ITRIAN .EQ. 0) THEN + DO 15 K=1,8 + NOP(J,K) = NTMP(K) + ND = NTMP(K) + IF (ND .GT. 0) THEN + INEW(ND) = 2 + NP = MAX(NP,ND) + ENDIF + 15 CONTINUE + IMAT(J) = NTMP(9) + THTA(J)=0 + IEM(J) = j + ELSE + DO K=1,3 + NOP(J,2*K-1)=NTMP(K) + IF(NCNTR .EQ. 3) THEN + NOP(J,2*K)=0 + ELSEIF(NCNTR .EQ. 6) THEN + NOP(J,2*K)=NTMP(K+3) + ENDIF + ND = NTMP(K) + IF (ND .GT. 0) THEN + INEW(ND) = 2 + NP = MAX(NP,ND) + ENDIF + ENDDO + NOP(J,7)=0 + NOP(J,8)=0 + IF(NATTR .GT. 0) THEN + IMAT(J)=ATT(1)+0.5 + IF(NATTR .GT. 1) THEN + THTA(J)=ATT(2) + IF(NATTR .GT. 2) THEN + IEM(J)=ATT(3) + ELSE + IEM(J)=0 + ENDIF + ELSE + THTA(J)=0. + IEM(J)=0 + ENDIF + ELSE + IMAT(J)=1 + THTA(J)=0. + IEM(J)=0 + ENDIF + ENDIF + NCN = 2 + IF (NOP(J,3) .NE. 0) NCN = 3 + IF (NOP(J,4) .NE. 0) NCN = 4 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6 + IF (NOP(J,6) .NE. 0) NCN = 6 + IF (NOP(J,7) .NE. 0) NCN = 8 + NCORN(J) = NCN + IESKP(J) = 0 + DO 25 K=2,NCN,2 + ND = NTMP(K) + IF (ND .GT. 0) THEN + IF(NCN .EQ. 5 .AND. K .EQ. 4) GO TO 25 + WD(ND)=0. + ENDIF + 25 CONTINUE + IF(ITRIAN .EQ. 1) THEN + IF((JZ .EQ. 0 .AND. J .EQ. NE) .OR. (JZ .EQ. 1 .AND. J .EQ. NE-1)) THEN + CLOSE(IUNIT) + DO L=255,1,-1 + IF(FNAMKEP(L:L) .EQ. '.') THEN + FNAMKEP(L+1:L+1)='n' + FNAMKEP(L+2:L+2)='o' + FNAMKEP(L+3:L+3)='d' + FNAMKEP(L+4:L+4)='e' + OPEN(IUNIT,FILE=FNAMKEP,STATUS='OLD',ACTION='READ') + IF(JZ .EQ. 1) THEN + READ(IUNIT,*) NPPP,NDUM,NATTR + REWIND(IUNIT) + DO J=1,NE + DO K=1,5,2 + IF(NOP(J,K) .EQ. 0) NOP(J,K)=NPPP + ENDDO + ENDDO + ENDIF + GO TO 175 + ENDIF + ENDDO + ENDIF + ENDIF + NE = MAX(J,NE) +! + GOTO 10 +! + 98 CONTINUE + ELSE + IF(IUNIT .EQ. 11) THEN +!IPK FEB03 READ(IUNIT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE) + + CALL RDRST(2,IUNIT) + ENDIF + DO 140 J=1,NE + IF(IMAT(J) .EQ. 0) GO TO 140 + NCN = 2 + IF (NOP(J,3) .NE. 0) NCN = 3 + IF (NOP(J,4) .NE. 0) NCN = 4 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6 + IF (NOP(J,6) .NE. 0) NCN = 6 + IF (NOP(J,7) .NE. 0) NCN = 8 + NCORN(J) = NCN + IESKP(J) = 0 +! DO 125 K=2,NCN,2 +! ND = NOP(J,K) +! IF (ND .GT. 0) THEN +! IF(NCN .EQ. 5 .AND. K .EQ. 4) GO TO 125 +! WD(ND)=0. +! ENDIF +! 125 CONTINUE + 140 CONTINUE + ENDIF +! +! Set up junction counter array +! + 175 CONTINUE + DO 180 N=1,NP + IJUN(N)=0 + 180 END DO + DO 200 N=1,NE +!ipkoct93 IF(IMAT(N) .GT. 900) THEN + IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN + DO 190 K=1,NCORN(N) + IF(NOP(N,K) .GT. 0) THEN + IJUN(NOP(N,K))=K + ENDIF + 190 CONTINUE + ENDIF + 200 END DO + WRITE(MESG,6010) NE + 6010 FORMAT(I7,' Elements read from file') + CALL SYMBL(1.1,4.3,0.25,mesg,0.0,31) + RETURN + END + SUBROUTINE CHKCON(IREP) + USE WINTERACTER +! +! Check connectivity of grid +! +!- + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + CHARACTER*80 LIND +! + CHARACTER*1 ANS +! CHARACTER*60 STRELS +! DATA STRELS/' You have tried to save before executing "FILL"'/ +! +! Test to make sure fill has been executed. +! + IF(IREP .EQ. 1) GO TO 100 + ylv=7.5 + IREP = 1 + DO 70 N=1,NE + IF(IMAT(N) .GT. 0) THEN + DO 60 M=2,NCORN(N),2 + IF(NOP(N,M) .EQ. 0 .AND. IMAT(N) .NE. 999) THEN + CALL GETSVPN(ANS) + IF(ANS .EQ. 'T' .OR. ANS .EQ. 't') THEN + IREP = 0 +!ipk nov97 add 0 + CALL PLOTOT(0) + CALL HEDR + RETURN + ELSEIF(ANS .EQ. 'S' .OR. ANS .EQ. 's') THEN +!ipk nov97 add (0) + CALL PLOTOT(0) + CALL HEDR + IREP = 1 + return +! go to 100 +!ipk jun04 RETURN + ELSEIF(ANS .EQ. 'F' .OR. ANS .EQ. 'f') THEN +!ipk aug02 + CALL FILM(0) + IREP = 1 + ELSE + IREP = 2 + ENDIF + ENDIF + 60 CONTINUE + ENDIF + 70 END DO + 100 CONTINUE + + + IDUP=0 + call kcon(1) + do n=1,ne + if(imat(n) .lt. 900 .and. imat(n) .gt. 0) then + ndup=0 + do j=2,ncorn(n),2 + if(nop(n,j) .eq. 0) go to 120 + if(ndelm(nop(n,j)) .gt. 2) then + ndup=ndup+1 + endif + enddo + if(ndup .eq. ncorn(n)/2) then + IDUP=1 + write(90,*) ' DUPLICATE ELEMENT',n + endif + endif + enddo + + 120 continue + + IF(IDUP .EQ. 1) THEN +!cipk aug00 + + Call WMessageBox(1,3,0,'Duplicate elements have been found'//Char(13)//& + 'See file MESSGEN.OUT for details'//'Press OK to continue save',& + 'ERROR IN NETWORK!!') + IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then + CALL HEDR + CALL PLOTOT(0) + IREP = 1 + ELSE + IREP = 0 + CALL HEDR +!ipk nov97 add (0) + CALL PLOTOT(0) + RETURN + ENDIF + endif + +! +! Test for areas of each element +! + INEG = 0 + DO 250 N=1,NE + IF(IMAT(N) .GT. 0 .AND. NCORN(N) .GT. 5) THEN + J1=NOP(N,1) + J2=NOP(N,3) + J3=NOP(N,5) + AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- & + & (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2)) + IF(AREA .LT. 0.) THEN +! IF(INEG .EQ. 0) CALL CLSCRN +! CALL SETD(23) +!cipk aug00 +! WRITE(lind,*) 'Negative area for element number',N + WRITE(90,*) ' NEGATIVE AREA FOR ELEMENT NUMBER',N +! if(ylv .lt. 0.4) then +! ylv=7.5 +! call clscrn +! endif +! call symbl & +! & (1.1,ylv-0.3,0.20,lind,0.0,80) +! ylv=ylv-0.3 +! ndig=1 + INEG = 1 + GO TO 250 + ENDIF + IF(NCORN(N) .EQ. 8) THEN + J1=NOP(N,3) + J2=NOP(N,5) + J3=NOP(N,7) + AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- & + & (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2)) + IF(AREA .LT. 0.) THEN +! IF(INEG .EQ. 0) CALL CLSCRN +! CALL SETD(23) +!cipk aug00 +! WRITE(lind,*) 'Negative area for element number',N + WRITE(90,*) 'Negative area for element number',N +! if(ylv .lt. 0.4) then +! ylv=7.5 +! call clscrn +! endif +! call symbl & +! & (1.1,ylv-0.3,0.20,lind,0.0,80) +! ylv=ylv-0.3 +! ndig=1 + INEG = 1 + ENDIF + ENDIF + ENDIF + 250 END DO + + IF(INEG .EQ. 1) THEN +!cipk aug00 + + Call WMessageBox(1,3,0,'Negative Areas have been found'//Char(13)//& + 'See file MESSGEN.OUT for details'//'Press OK to continue save',& + 'ERROR IN NETWORK!!') + +! WRITE(lind,*) 'If you wish to terminate save enter (t)' +! if(ylv .lt. 0.7) then +! ylv=7.5 +! call clscrn +! endif +! call symbl & +! & (1.1,ylv-0.3,0.20,lind,0.0,80) +! ylv=ylv-0.3 +! WRITE(lind,*) 'If you still wish to save enter (s)' +! call symbl & +! & (1.1,ylv-0.3,0.20,lind,0.0,80) + +!ipk jun96 change * to (a) + +!cipkaug00 READ(*,'(A)') ANS +! READ(*,*) ANS +! CALL GTCHARX(ANS,IJNK,5.0,4.0) + +! CALL SETD(2) +! IF(ANS .EQ. 'T' .OR. ANS .EQ. 't') THEN + IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then + CALL HEDR + CALL PLOTOT(0) + IREP = 1 + RETURN + ELSE + IREP = 0 + CALL HEDR +!ipk nov97 add (0) + CALL PLOTOT(0) + RETURN + ENDIF +! ELSEIF(ANS .EQ. 'S' .OR. ANS .EQ. 's') THEN +! CALL HEDR +!ipknov97 add (0) +! CALL PLOTOT(0) +! IREP = 1 +! RETURN +! ENDIF + ENDIF + + RETURN + END +!ipk oct98 update call + SUBROUTINE WRTMAP(isw) +! +! Write map file in binary format +! + USE BLKMAP + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + character*3 ends +! +! +! Open binary map file +! + IF(ISW .GT. 90) THEN + IMPF=ISW + ELSE + impf=93 + ENDIF + +!ipk oct98 + if(isw .eq. 0) then + OPEN(IMPF ,FILE=mpnam,STATUS='unknown',form='unformatted') +!IPK FRB03 + else + rewind impf + endif + + if(isw .eq. 2) then + impf=94 + aninin=-9999. + zero=0. + ends='END' + if(lintyp(1) .eq. 0 .or. lintyp(1) .eq. 1) then + write(impf,*) lintyp(1),aninin + ifm=1 + elseif(lintyp(1) .eq. 2) then + write(impf,*) lintyp(1),zero + ifm=2 + else + write(impf,*) lintyp(1),val(1) + ifm=1 + endif + ilin=1 + do J=1,maxpts + if(xmap(J) .gt. vdx) then + if(ifm .eq. 1) then + write(impf,*) xmap(j),ymap(j) + else + write(impf,*) xmap(j),ymap(j),val(j) + endif + if(j .eq. maxpts) write(impf,'(a3)') ends + else + write(impf,'(a3)') ends + ilin=ilin+1 + if(j .eq. maxpts) go to 200 + if(lintyp(ilin) .eq. 0 .or. lintyp(ilin) .eq. 1) then + write(impf,*) lintyp(ilin),aninin + ifm=1 + elseif(lintyp(ilin) .eq. 2) then + write(impf,*) lintyp(ilin),zero + ifm=2 + else + write(impf,*) lintyp(ilin),val(j+1) + ifm=1 + endif + endif + + enddo + 200 continue + write(impf,'(a3)') ends + return + endif + jlint=maxpts + write(impf) klint,jlint,(xmap(j),ymap(j),val(j),j=1,jlint) & + & ,(lintyp(k),k=1,klint) + + if(nelts .gt. 0) then + write(impf) nelts,((nopel(j,k),k=1,3),j=1,nelts) + endif + return + END + + SUBROUTINE GETSVPN(ANS) + + use winteracter + + implicit none + + include 'D.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + INTEGER :: IPOS + INTEGER :: JNK,ierr + CHARACTER*1 :: ANS,CDAT(4) + DATA CDAT/'s','t','f','c'/ + call wdialogload(IDD_DIALOG07) + ierr=infoerror(1) + + + call wdialogputRadioButton(idf_radio1) + + + CALL WDialogSelect(IDD_DIALOG07) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,ipos) + ans=cdat(ipos) + return + endif +!IPK SEP02 + ans=cdat(1) + return + enddo + RETURN + END + +!*************************************************************************************** + + subroutine wrtgfg(IOF) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + IOF=IOT + WRITE(IOF,5000) TITLE + 5000 format('T1'/'T2'/'T3 ',A80) + WRITE(IOF,5001) + 5001 FORMAT('SI 1') + WRITE(IOF,5002) + 5002 FORMAT('$L 3 0 6 0') +! +! CURRENTLY DISABLED +! +! IF(NLST .GT. 0) THEN +! DO J=1,NLST +! IF(LLIST(J) .GT. 0) THEN +! IF(J .EQ. 1) THEN +! ILIST(J,LLIST(J))=-ABS(ILIST(J,LLIST(J))) +! ENDIF +! WRITE(IOF,5003) (ILIST(J,I),I=1,LLIST(J)) +! 5003 FORMAT('GO 2',11I6/('GO',12I6)) +! ENDIF +! ENDDO +! ENDIF + DO J=1,NE + IF (IMAT(J) .NE. 0) THEN + IF(IECHG .EQ. 0) IEM(J)=J + WRITE(IOF,5004) & + & J, (NOP(J,K),K=1,8), IMAT(J),THTA(J) + 5004 FORMAT('GE',10I6,F10.4) + ENDIF + ENDDO + DO J=1,NP + IF (INEW(J) .EQ. 1) THEN + WRITE(IOF, 5005) & + & J,XUSR(J),YUSR(J),WD(J) + 5005 FORMAT('GNN',I6,2F14.3,F10.3) + ENDIF + ENDDO + DO J=1,NP + IF (INEW(J) .EQ. 1) THEN + IF(WIDTH(J) .GT. 0.) THEN + WRITE(IOF, 5006) & + & J, & + & WIDTH(J),SS1(J),SS2(J),WIDS(J) + 5006 FORMAT('GWN',I6,1X,F9.1,1X,2F6.2,1X,F9.1) + ENDIF + ENDIF + ENDDO + + + return + end + + subroutine wrtele(IOF,itr) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + IOF=IOT + NVRT=2 + if(itr .eq. 1) then + NEL=NE + NATT=2 + IF(NOP(1,2) .EQ. 0) THEN + NVRT=3 + ELSE + NVRT=6 + ENDIF + write(IOF,6001) NEL,NVRT,NATT + DO N=1,NE + IF(NVRT .EQ. 3) THEN + WRITE(IOF,6002) N,(NOP(N,J),J=1,5,2),IMAT(N),THTA(N) + ELSE + WRITE(IOF,6003) N,(NOP(N,J),J=1,5,2),(NOP(N,J),J=2,6,2),IMAT(N),THTA(N) + ENDIF + ENDDO + else + NPL=NP + NATT=1 + write(IOF,6001) NPL,NVRT,NATT + DO N=1,NPL + WRITE(IOF,6004) N,XUSR(N),YUSR(N),WD(N) + ENDDO + + endif + 6001 FORMAT(I6,I2,I2,I2) + 6002 FORMAT(I6,3(' ',I6),I5,' ',F6.2) + 6003 FORMAT(I6,6(' ',I6),I5,' ',F6.2) + 6004 FORMAT(I6,2F16.6,F11.4) + return + end + + + SUBROUTINE RDRST(IENT,IUNIT) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*80 ALINE + + IF(IENT .EQ. 1) THEN + READ(IUNIT) TITLE,NP,NE + READ(IUNIT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & + & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin + READ(IUNIT) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG + IF(IPP .GT. 0) READ(IIN) ALINE + + ELSEIF(IENT .EQ. 2) THEN + READ(IUNIT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE) + DO J=1,NE + IF(IMAT(J) .NE. 0) THEN + NCN = 2 + IF (NOP(J,3) .NE. 0) NCN = 3 + IF (NOP(J,4) .NE. 0) NCN = 4 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6 + IF (NOP(J,6) .NE. 0) NCN = 6 + IF (NOP(J,7) .NE. 0) NCN = 8 + NCORN(J) = NCN + IESKP(J) = 0 + ENDIF + ENDDO + ELSE + + + READ(IUNIT) & + & (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), & + & WIDBS(J),SSO(J),BS1(J),J=1,NP) + DO J=1,NP + CORD(J,1) = XUSR(J) + CORD(J,2) = YUSR(J) + INSKP(J)=0 + INEW(J)=0 + IF (CORD(J,1) .GT. VDX) THEN + INEW(J) = 1 + ENDIF + ENDDO + READ(IUNIT) NLST + IF(NLST .GT. 0) THEN + READ(IUNIT) (LLIST(J),J=1,NLST), & + ((ILIST(J,I),I=1,LLIST(J)),J=1,NLST) + ENDIF + + READ(IUNIT) NENTRY,NLAYD,NCLM + IF(NENTRY .GT. 0) THEN + READ(IUNIT) ((NEF(I,J),J=1,3),I=1,NENTRY) + ENDIF + IF(NLAYD .GT. 0) THEN + READ(IUNIT) (LAY(I),I=1,NP),((WTLAY(I,J),J=1,9),I=0,NP) + ENDIF + IF(NCLM .GT. 0) THEN + READ(IUNIT) ((ICCLN(I,J),J=1,350),I=1,NCLM) + ENDIF + ENDIF + RETURN + END + + SUBROUTINE ADJUSTMAP(MAXPLL) +! +! Generate continuity lines +! + + USE WINTERACTER + USE BLKMAP + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: NTYP,NLOCC + + + call wdialogload(IDD_SETMAXMAP) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_SETMAXMAP) + ierr=infoerror(1) + + CALL WDialogPutINTEGER(IDF_INTEGER1,MAXPLL) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetINTEGER(IDF_INTEGER1,MAXPLL) + + GO TO 100 + ENDIF + + enddo + + 100 CONTINUE + return + end + + SUBROUTINE RDESRI(alin,k,j) + use blkmap + use blk1mod + real*8 xorig,yorig,cellsize + character*80 alin +! READ HEADERS + read(alin(6:80),*) ncols + READ(IMP,'(A80)') ALIN + read(alin(6:80),*) nrows + READ(IMP,'(A80)') ALIN + read(alin(10:80),*) xorig + READ(IMP,'(A80)') ALIN + read(alin(10:80),*) yorig + READ(IMP,'(A80)') ALIN + read(alin(9:80),*) cellsize + READ(IMP,'(A80)') ALIN + read(alin(13:80),*) xnodat + ntot=ncols*nrows + read(imp,'(10f12.0)') (val(i),i=1,ntot) + ict=0 + ikp=0 + do n=1,nrows + ytemp=cellsize*(n-1)+yorig + do m=1,ncols + ict=ict+1 + if(val(ict) .ne. xnodat) then + xtemp=cellsize*(m-1)+xorig + ikp=ikp+1 + xmap(ikp)=xtemp + ymap(ikp)=ytemp + cmap(ikp,1)=xtemp + cmap(ikp,2)=ytemp + val(ikp)=val(ict) + endif + enddo + LINTYP(1)=2 + k=2 + j=ikp + enddo + RETURN + END \ No newline at end of file diff --git a/src/INTEL.F90 b/src/INTEL.F90 new file mode 100644 index 0000000..9fb6fe0 --- /dev/null +++ b/src/INTEL.F90 @@ -0,0 +1,438 @@ + SUBROUTINE GRELV +! +! THIS ROUTINE COMPUTES THE GRIDDED ELEVATION +! + use winteracter + USE BLK1MOD +! INCLUDE 'BLK1.COM' + INCLUDE 'TXFRM.COM' +!- + + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + INTEGER :: IERR,ISET + REAL :: ASET + DATA NXP,NYP/30,20/ + DATA ITIM/0/ + + IF(ITIM .EQ. 0) THEN + NX=NXP+2 + NY=NYP+2 + ITIM=0 + ENDIF + + call wdialogload(IDD_GETINTP) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_GETINTP) + ierr=infoerror(1) + + 100 continue + NXP=NX-2 + NYP=NY-2 + XGR=XGRID*TXSCAL + YGR=YGRID*TXSCAL + CALL WDialogPutINTEGER(IDF_INTEGER1,NXP) + CALL WDialogPutINTEGER(IDF_INTEGER2,NYP) + CALL WDialogPutREAL(IDF_REAL1,XGR) + CALL WDialogPutREAL(IDF_REAL2,YGR) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + + CALL WDialogGetINTEGER(IDF_INTEGER1,NXP) + CALL WDialogGetINTEGER(IDF_INTEGER2,NYP) + CALL WDialogGetREAL(IDF_REAL1,XGR) + CALL WDialogGetREAL(IDF_REAL2,YGR) + GO TO 200 + else + NRECC=0 + endif + + enddo + + 200 CONTINUE + NX=NXP+2 + NY=NYP+2 + XGRID=XGR/TXSCAL + YGRID=YGR/TXSCAL +!- + AXMAX = HSIZE + AYMAX = 7.0 + if(xgrid .eq. 0.) then + XGRID = AXMAX/FLOAT(NX-3) + ELSE + NX=(AXMAX/XGRID+0.5)+3 + ENDIF + IF(YGRID .EQ. 0.) THEN + YGRID = AYMAX/FLOAT(NY-3) + ELSE + NY=(AYMAX/YGRID+0.5)+3 + ENDIF + + IF(NX .GT. MAXGRD .OR. NY .GT. MAXGRD) THEN + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK, & + 'Maximum number of interpolation points exceeded '//CHAR(13) & + //'Choose a lower resolution.', & + 'Warning') + go to 100 + endif + + CALL LOCATE +! + CALL POINTEL + + RETURN + END + + SUBROUTINE POINTEL +!*********************************** .....POINTS..... +!- +!......SUBROUTINE TO EVALUATE FUNCTION AT GRID POINTS +!- +!- + USE WINTERACTER + USE BLK1MOD + + include 'd.inc' + + INCLUDE 'TXFRM.COM' +! + REAL*8 XN,DNX,DNY + DOUBLE PRECISION XG,YG,XK,YK,XP,YP +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLKV1.COM' +! INCLUDE 'BLKV2.COM' + INCLUDE 'BFILES.I90' +!- +!ipk jul94 DIMENSION X(8),Y(8) + DIMENSION X(9),Y(9) + CHARACTER(LEN=255) :: FNAME,FNAMR + CHARACTER(LEN=256) :: FILTER + CHARACTER(LEN=3) :: SUB,SUB1 +!- + DATA TOL/0.01/ +!- + +!- +!......LOOP ON ALL GRID POINTS +!- + FILTER = 'Map file *.map|*.map|' + CALL WSelectFile(FILTER,SaveDialog+PromptOn,FNAME,'Save Map File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(199,FILE=FNAME,STATUS='UNKNOWN') + WRITE(199,8000) + 8000 FORMAT('2,0.') + ELSE + RETURN + ENDIF + + DO 1000 NN=1,NX + DO 950 MM=1,NY + N=IGRID(NN,MM) + IF(N.EQ.0) GO TO 950 + HGN=0. + 250 CONTINUE +!- +!......DETERMINE ELEMENT TYPE +!- +!IPKOCT93 ADD + NCN=8 + IT=1 + + IF(NOP(N,7).NE.0) GO TO 275 + NCN=6 + IT=2 + 275 CONTINUE +!- +!......ESTABLISH LOCAL COORDINATES FOR EACH NODE POINT +!- + K1=NOP(N,1) + X(1)=0. + Y(1)=0. + DO 300 K=2,NCN + K2=NOP(N,K) + X(K)=CORD(K2,1)-CORD(K1,1) + Y(K)=CORD(K2,2)-CORD(K1,2) + 300 END DO +!- +!......ESTABLISH LOCAL COORDINATES OF DESIRED POINT +!- + XP=FLOAT(NN-2)*XGRID + XRL=XP*TXSCAL-XS + XP=XP-CORD(K1,1) + YP=FLOAT(MM-2)*YGRID + YRL=YP*TXSCAL-YS + YP=YP-CORD(K1,2) + XG=0. + YG=0. +!- +!......ITERATE TO FIND LOCAL COORDINATE +!- + DO 400 ITER=1,10 + DXKDX=0. + DXKDY=0. + DYKDX=0. + DYKDY=0. + XK=-XP + YK=-YP + DO 350 K=2,NCN + XK=XK+XN(IT,K,XG,YG)*X(K) + YK=YK+XN(IT,K,XG,YG)*Y(K) + DXKDX=DXKDX+DNX(IT,K,XG,YG)*X(K) + DYKDX=DYKDX+DNX(IT,K,XG,YG)*Y(K) + DXKDY=DXKDY+DNY(IT,K,XG,YG)*X(K) + DYKDY=DYKDY+DNY(IT,K,XG,YG)*Y(K) + 350 END DO + DET=DXKDX*DYKDY-DXKDY*DYKDX + DX=(-DYKDY*XK+DXKDY*YK)/DET + DY=( DYKDX*XK-DXKDX*YK)/DET + XG=XG+DX + YG=YG+DY + IF(ABS(DX).LT.TOL .AND. ABS(DY).LT.TOL) GO TO 420 + 400 END DO +!- +!......NOW EVALUATE GRID POINT +!- + 420 CONTINUE + DO 450 K=1,NCN + J=NOP(N,K) + HGN=HGN+XN(IT,K,XG,YG)*WD(J) + 450 END DO + WRITE(199,9800) XRL,YRL,HGN + 9800 FORMAT(F14.2',',F14.2,',',F14.3) + 950 END DO + 1000 END DO +! IF(NVEL .EQ. 1) WRITE(6,9803) ((UGRID(NN,MM),MM=1,32), +! 1NN=1,32) +! IF(NVEL .EQ. 1) WRITE(6,9803) ((VGRID(NN,MM),MM=1,32), +! 1NN=1,32) + 9803 FORMAT(8E12.4) +! WRITE(6,9802)((GRID(NN,MM),MM=1,16),NN=1,16) +!9802 FORMAT(16F8.2) + WRITE(199,8001) + 8001 FORMAT('END') + WRITE(199,8001) + RETURN + END + +! + SUBROUTINE LOCATE +!*********************************** .....LOCATE..... +!- +!......LOCATE ESTABLISHES ELEMENT NUMBERS FOR ALL GRID POINTS +!- + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLKV1.COM' +! INCLUDE 'BLKV2.COM' + INCLUDE 'BFILES.I90' +! + COMMON XS(4,3),YS(4,3),XM(4,3),ROOT(10) +! + VOID=1.E+20 + NPTS= 7 + DS=1./(FLOAT(NPTS)-1.) + DO 340 N=1,MAXGRD + DO 340 M=1,MAXGRD + 340 IGRID(N,M)=0 +!- +!....... PROCESS EACH ELEMENT +!- + DO 900 N=1,NE + IF(IESKP(N) .NE. 0) GO TO 900 + IF(IMAT(N).LE.0) GO TO 900 + IF(NOP(N,6) .EQ. 0) GO TO 900 + XMINN=VOID + YMINN=VOID + XMAXX=-VOID + YMAXX=-VOID +!- +!...... TRACE AROUND EACH SIDE FOR MAX AND MIN LOCATIONS +!- + NCN=8 + IF(NOP(N,7).EQ.0) NCN=6 + NSIDE=NCN/2 + K=0 + DO 600 M=1,NCN,2 + K=K+1 + M1=NOP(N,M) + M2=NOP(N,M+1) + M3=MOD(M+2,NCN) + M3=NOP(N,M3) + XS(K,1)=CORD(M1,1) + XS(K,2)=CORD(M2,1) + XS(K,3)=CORD(M3,1) + YS(K,1)=CORD(M1,2) + YS(K,2)=CORD(M2,2) + YS(K,3)=CORD(M3,2) + XM(K,1)=2.*XS(K,1)-4.*XS(K,2)+2.*XS(K,3) + XM(K,2)=-3.*XS(K,1)+4.*XS(K,2)-XS(K,3) + XM(K,3)=XS(K,1) +!- +!..... WORK ALONG BOUNDARY OF ELEMENT +!- + S=0. + DO 550 J=1,NPTS + XN1=(1.-S)*(1.-2.*S) + XN2=4.*(1.-S)*S + XN3=S*(2.*S-1.) + X=XN1*XS(K,1)+XN2*XS(K,2)+XN3*XS(K,3) + Y=XN1*YS(K,1)+XN2*YS(K,2)+XN3*YS(K,3) + IF(X.LT.XMINN) XMINN=X + IF(X.GT.XMAXX) XMAXX=X + IF(Y.LT.YMINN) YMINN=Y + IF(Y.GT.YMAXX) YMAXX=Y + S=S+DS + 550 END DO + 600 END DO +!- +!...... ESTABLISH GRID FRAMEWORK +!- + XLH=XMINN/XGRID + XRH=XMAXX/XGRID + YBT=YMINN/YGRID + YTP=YMAXX/YGRID + IXL=XLH+2.999 + IXT=XRH+2.001 + IYL=YBT+2.999 + IYT=YTP+2.001 + IERR=0 +!$$$ + IF(IXL.LT.0) IERR=1 + IF (IXL .LT. 1) IXL = 1 + IF(IYL.LT.0) IERR=1 + IF (IYL .LT. 1) IYL = 1 + IF(IXT.GT.NX) IERR=1 + IF (IXT .GT. NX) IXT = NX + IF(IYT.GT.NY) IERR=1 + IF (IYT .GT. NY) IYT = NY +! + IF(IERR.EQ.0) GO TO 620 +! WRITE(6,9989) N +! 9989 FORMAT(///' ERROR STOP FOR ELEMENT',I5) +! WRITE(6,9990) (K,(XS(K,M),YS(K,M),XM(K,M),M=1,3),K=1,NSIDE) +! 9990 FORMAT(I10,9E13.4) +! WRITE(6,9992) XLH,XRH,YBT,YTP,IXL,IXT,IYL,IYT +! 9992 FORMAT(4F20.6,4I8) +!$$$ STOP + 620 CONTINUE +!- +!...... FIND INTERSECTIONS FOR HORIZONTAL GRID LINE +!- + DO 800 M=IYL,IYT + Y=(M-2)*YGRID + IL=0 + DO 700 K=1,NSIDE + A=2.*YS(K,1)-4.*YS(K,2)+2.*YS(K,3) + B=-3.*YS(K,1)+4.*YS(K,2)-YS(K,3) + C=YS(K,1)-Y + SQ=B**2-4.*A*C + IF(ABS(A).LT.0.01) GO TO 650 + IF(SQ.GT..001) GO TO 660 + IF(SQ.LT.-.001) GO TO 700 + S=-B/(2.*A) + IF(S.LT.0. .OR. S.GT.1.0) GO TO 700 + IL=IL+1 + ROOT(IL)=XM(K,1)*S**2+XM(K,2)*S+XM(K,3) + IL=IL+1 + ROOT(IL)=ROOT(IL-1) + GO TO 700 + 650 IF(ABS(B).LT. 0.001) GO TO 700 + S=-C/B + GO TO 670 + 660 CONTINUE + S=(-B+SQRT(SQ))/(2.*A) + IF(S.LT.0. .OR. S.GT.1.0) GO TO 665 + IL=IL+1 + ROOT(IL)=XM(K,1)*S**2+XM(K,2)*S+XM(K,3) + 665 S=(-B-SQRT(SQ))/(2.*A) + 670 CONTINUE + IF(S.LT.0. .OR. S.GT.1.0) GO TO 700 + IL=IL+1 + ROOT(IL)=XM(K,1)*S**2+XM(K,2)*S+XM(K,3) + 700 END DO + IF(IL.GT.0) GO TO 705 + DO 703 K=1,NSIDE + IF(ABS(YS(K,3)-Y).LT.0.05) GO TO 704 + 703 END DO + GO TO 800 + 704 IL=2 + ROOT(1)=XS(K,3)-0.05 + ROOT(2)=XS(K,3)+0.05 + 705 CONTINUE + CALL SORTE(ROOT,IL) +! ISET=0 + IC=1 +!- +!....... LOCATE VALUES INTO IGRID +!- + 9908 FORMAT(I10,F20.2) + 9997 FORMAT(5F20.4) + DO 750 K=IXL,IXT + X=(K-2)*XGRID + 710 CONTINUE + IF(X.LE.ROOT(IC)) GO TO 720 + IC=IC+1 + IF(IC.GT.IL) GO TO 800 + GO TO 710 + 720 IF(MOD(IC,2).EQ.0) IGRID(K,M)=N + 750 END DO + 800 END DO + 900 END DO +!CC WRITE(*,9800) ((IGRID(N,M),N=1,20),M=1,20) + 9800 FORMAT(20I3) + RETURN + END +! + SUBROUTINE SORTE(A,N) +!*********************************** .....SORT..... +!- +!......SORT IS A SIMPLE SHELL SORT ROUTINE +!- +! SHELL SORT + SAVE +! + DIMENSION A(*) + IF(N.LT.2) RETURN + ID = N + 100 ID = ID / 2 + 110 IB = 1 + 120 GO TO 200 + 130 IB = IB + 1 + IF( IB .LE. ID ) GO TO 200 + IF( ID .GT. 1 ) GO TO 100 + RETURN + 200 I = IB + 210 K = I + ID + 220 IF( A(I) .LE. A(K) ) GO TO 250 + T = A(K) + A(K) = A(I) + J = I + 230 K = J - ID + IF( K .LT. 1 ) GO TO 240 + IF( T .GT. A(K) ) GO TO 240 + A(J) = A(K) + J = K + GO TO 230 + 240 A(J) = T + 250 I = I + ID + IF( I + ID .LE. N ) GO TO 210 + GO TO 130 + END +! diff --git a/src/JLINE.F90 b/src/JLINE.F90 new file mode 100644 index 0000000..2de216e --- /dev/null +++ b/src/JLINE.F90 @@ -0,0 +1,122 @@ + SUBROUTINE JLINE(ILIN,CVAL) + +! Routine to join up points + + USE BLKMAP + USE BLK1MOD + ! INCLUDE 'BLK1.COM' + INCLUDE 'TXFRM.COM' + COMMON /CCGEN/ XCLIN(4000,2),YCLIN(4000,2),ALIN(-4000:4000,2),IUSED(4000) + + + VOID=-1.0E+10 + + DO K=1,MAXLIN + IF(LINTYP(K) .EQ. -999) THEN + NLIN=K-1 + GO TO 100 + ENDIF + ENDDO + NLIN=MAXLIN + 100 CONTINUE + + DO I=1,ILIN + IUSED(I)=0 + ENDDO +! Loop through remaining poins + + DO I=1,ILIN + IF(IUSED(I) .EQ. 0) THEN + +! Set first points + + IFW=2 + IFB=1 + IUSED(I)=1 + ALIN(1,1)=XCLIN(I,1) + ALIN(1,2)=YCLIN(I,1) + ALIN(2,1)=XCLIN(I,2) + ALIN(2,2)=YCLIN(I,2) + +! Look at remaining points for match + + 200 CONTINUE + + DO J=I,ILIN + IF(IUSED(J) .EQ. 0) THEN +! First for forward points + + IF(XCLIN(J,1) .EQ. ALIN(IFW,1) .AND. YCLIN(J,1) .EQ. ALIN(IFW,2)) THEN + IFW=IFW+1 + ALIN(IFW,1)=XCLIN(J,2) + ALIN(IFW,2)=YCLIN(J,2) + IUSED(J)=1 + ELSEIF(XCLIN(J,2) .EQ. ALIN(IFW,1) .AND. YCLIN(J,2) .EQ. ALIN(IFW,2)) THEN + IFW=IFW+1 + ALIN(IFW,1)=XCLIN(J,1) + ALIN(IFW,2)=YCLIN(J,1) + IUSED(J)=1 + ELSEIF(XCLIN(J,1) .EQ. ALIN(IFB,1) .AND. YCLIN(J,1) .EQ. ALIN(IFB,2)) THEN + IFB=IFB-1 + ALIN(IFB,1)=XCLIN(J,2) + ALIN(IFB,2)=YCLIN(J,2) + IUSED(J)=1 + ELSEIF(XCLIN(J,2) .EQ. ALIN(IFB,1) .AND. YCLIN(J,2) .EQ. ALIN(IFB,2)) THEN + IFB=IFB-1 + ALIN(IFB,1)=XCLIN(J,1) + ALIN(IFB,2)=YCLIN(J,1) + IUSED(J)=1 + ENDIF + IF(IUSED(J) .EQ. 1) GO TO 200 + ENDIF + ENDDO + +! No new points found line must be complete +! Check for loops +! First end points + + 250 CONTINUE +! IF((ALIN(IFB,1) .EQ. ALIN(IFW,1)) .AND. (ALIN(IFB,2) .EQ. ALIN(IFW,2))) THEN +! IFB=IFB+1 +! IF(IFB .EQ. IFW) GO TO 300 +! GO TO 250 +! ENDIF + NLIN=NLIN+1 + LINTYP(NLIN)=3 + IF(IMP .EQ. 0) IMP=9 + N=0 + IF(MAXPTS .EQ. MAXPL) MAXPTS=0 + IF(MAXPTS .GT. 0) THEN + MAXPTS=MAXPTS+1 + CMAP(MAXPTS,1) = VOID + CMAP(MAXPTS,2) = VOID + XMAP(MAXPTS) = VOID + YMAP(MAXPTS) = VOID +! WRITE(198,'(I5,3F15.6)') MAXPTS,XMAP(MAXPTS),YMAP(MAXPTS),VAL(MAXPTS) + ENDIF + A1= VOID + A2= VOID + DO J=IFB,IFW + IF(ALIN(J,1) .EQ. A1 .AND. ALIN(J,2) .EQ. A2) GO TO 275 + MAXPTS=MAXPTS+1 +! Check for double points + XMAP(MAXPTS) = ALIN(J,1) + YMAP(MAXPTS) = ALIN(J,2) + VAL(MAXPTS) = CVAL + CMAP(MAXPTS,1)=(XMAP(MAXPTS)+XS)/TXSCAL + CMAP(MAXPTS,2)=(YMAP(MAXPTS)+YS)/TXSCAL + +! WRITE(198,'(I5,3F15.6)') MAXPTS,XMAP(MAXPTS),YMAP(MAXPTS),VAL(MAXPTS) + 275 CONTINUE + ENDDO + 300 CONTINUE + ENDIF + +! Copy values into contour line array + + ENDDO + klint=nlin + + RETURN + END + diff --git a/src/JOIN.bmp b/src/JOIN.bmp new file mode 100644 index 0000000..60f0ed5 Binary files /dev/null and b/src/JOIN.bmp differ diff --git a/src/JOINEL.F90 b/src/JOINEL.F90 new file mode 100644 index 0000000..5e311b8 --- /dev/null +++ b/src/JOINEL.F90 @@ -0,0 +1,445 @@ +!IPK LAST UPDATE SEP 23 2015 ADD OPTION FOR JOINING ELEMENTS + subroutine joinel + + USE BLK1MOD + USE BLK2MOD + use blkmap + INTEGER LIST1(1000),LIST2(1000),idel(1000) + real xmapt(1000),ymapt(1000) + + + CHARACTER*1 IFLAG,ANSW(10) + CHARACTER*60 STRELS + DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/ + + + DATA STRELS/' You have tried to join before executing "FILL"'/ +! +! +! Test to make sure fill has been executed. +! + DO N=1,NE + IF(IMAT(N) .GT. 0) THEN + DO M=2,NCORN(N),2 +!ipkoct93 + if(imat(n) .LT. 900) THEN + IF(NOP(N,M) .EQ. 0) THEN + CALL SYMBL(0.,7.30,0.20,STRELS,0.,60) + RETURN + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO +! Initiliaze list etc + + NHTPSV=NHTP + NMESSSV=NMESS + NBRRSV=NBRR + +! get starting elements + CALL KCON(0) + DO N=1,NE + DO M=1,8 + NOPSV(N,M)=NOP(N,M) + ENDDO + IMATSV(N)=IMAT(N) + ENDDO + NESAV=NE + NEFSAV=NENTRY + NPUNDO=0 + list1=0 + list2=0 +! SELECT FIRST ELEMENT +10 CONTINUE + CALL PANELTYP(NMTYP) + NHTP=0 + NMESS=20 + NBRR=8 + CALL HEDR + + CALL PROX(XC,YC,NE,XX,YY,NEL1,IFLAG,IESKP,IBOX) + IF(IRMAIN .EQ. 1) THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + RETURN + ENDIF + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + CALL fillem(NEL1) +! + IF(IFLAG .EQ. 'q') THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + RETURN + ENDIF + + CALL PROX(XC,YC,NE,XX,YY,NEL2,IFLAG,IESKP,IBOX) + IF(IRMAIN .EQ. 1) THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + RETURN + ENDIF + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF +! + IF(IFLAG .EQ. 'q') THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + RETURN + ENDIF + CALL fillem(NEL1) + CALL fillem(NEL2) + + CALL PROX(XC,YC,NE,XX,YY,NEL3,IFLAG,IESKP,IBOX) + IF(IRMAIN .EQ. 1) THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + RETURN + ENDIF + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF +! + IF(IFLAG .EQ. 'q') THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + RETURN + ENDIF + + CALL fillem(NEL1) + CALL fillem(NEL2) + CALL fillem(NEL3) + CALL PROX(XC,YC,NE,XX,YY,NEL4,IFLAG,IESKP,IBOX) + IF(IRMAIN .EQ. 1) THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + RETURN + ENDIF + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF +! + IF(IFLAG .EQ. 'q') THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + RETURN + ENDIF + CALL fillem(NEL1) + CALL fillem(NEL2) + CALL fillem(NEL3) + CALL fillem(NEL4) + +! work on first pair +! get starting mid-side + ilc=0 + call findbcel(nel1,nd1,nd2,nd3,ierr,ilc) +! save back node + list1(1)=nd1 + write(90,*) '1',nd1 + +! get adjacent corner save corner + m=2 + list1(m)=nd3 + write(90,*) 'm',nd3 + nelc=nel1 + nelcsv=nel1 +! start looop + do nss=1,1000 +! find next element and get mid side + nadj=ndelm(nd3) + do kkk=1,nadj + nd3=list1(m) + nelc=nelcsv + if(necon(nd3,kkk) .ne. nelc) then + nelc=necon(nd3,kkk) + ilc=2 + call findbcel(nelc,nd1,nd2,nd3,ierr,ilc) + if(ierr .eq. 0) go to 200 + endif + enddo +200 continue + nelcsv=nelc +! get and save next corner + m=m+1 + if(m .gt. 1000) THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + RETURN + ENDIF + list1(m)=nd3 +! test for last element + if(nelc .eq. nel2) go to 250 + enddo +250 continue + m1=m + +! repeat for second pair +! get starting mid-side + ilc=1 + call findbcel(nel3,nd1,nd2,nd3,ierr,ilc) +! save back node + list2(1)=nd1 + +! get adjacent corner save corner + m=2 + list2(m)=nd3 + nelc=nel3 + nelcsv=nel3 +! start looop + do nss=1,1000 +! find next element and get mid side + nadj=ndelm(nd3) + do kkk=1,nadj + nd3=list2(m) + nelc=nelcsv + if(necon(nd3,kkk) .ne. nelc) then + nelc=necon(nd3,kkk) + ilc=2 + call findbcel(nelc,nd1,nd2,nd3,ierr,ilc) + if(ierr .eq. 0) go to 300 + + endif + enddo +300 continue + nelcsv=nelc +! get and save next corner + m=m+1 + if(m .gt. 1000) THEN + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + ENDIF + list2(m)=nd3 +! test for last element + if(nelc .eq. nel4) go to 350 + enddo +350 continue + m2=m + ! add points in triangle list + do j=1,m2 + list1(m1+j)=list2(j) + enddo + nvert=m1+m2 + do n=1,nvert + write(90,*) n,list1(n) + enddo + do j=1,nvert + xmap(j)=xusr(list1(j)) + ymap(j)=yusr(list1(j)) + xmapt(j)=xusr(list1(j)) + ymapt(j)=yusr(list1(j)) + imap(j)=1 + val(j)=1. + enddo +! call for triangulation + + CALL DELAUNAY(NVERT) + + do n=1,nelts + if(nopel(n,1) .le. m1) then + if(nopel(n,2) .le. m1 .and. nopel(n,3) .le. m1) then + cycle + endif + else + if(nopel(n,2) .gt. m1 .and. nopel(n,3) .gt. m1) then + cycle + endif +500 continue + endif +! FORM A NEW ELEMENT ASSIGN TYPE AS INDICATED + CALL GETELM(J) + NOP(J,1)=list1(nopel(n,1)) + NOP(J,3)=list1(nopel(n,2)) + NOP(J,5)=list1(nopel(n,3)) + NOP(J,2)=0 + NOP(J,4)=0 + NOP(J,6)=0 + NOP(J,7)=0 + NOP(J,8)=0 + IMAT(J)=NMTYP + IESKP(J) = 0 + NCORN(J)=6 + enddo + CALL PLOTOT(1) + NHTP=NHTPSV + NMESS=NMESSSV + NBRR=NBRRSV + + CALL HEDR + return + end + + subroutine findbcel(nel,nd1,nd2,nd3,ierr,ilc) + use blk1mod + USE BLK2MOD + integer nel,nd1,nd2,nd3,mlc(5),ndkp + ndkp=nd3 + ierr=0 + kk=0 + do k=2,ncorn(nel),2 + nd2=nop(nel,k) + if(ndelm(nd2) .eq. 1) then + nd1=nop(nel,k-1) + jj=mod(k,ncorn(nel))+1 + nd3=nop(nel,jj) + if(ilc .gt. 0) then + kk=kk+1 + mlc(kk)=k + cycle + else +! check for more than 1 + kj=k+2 + if(kj .gt. ncorn(nel)) kj=2 + nd2a=nop(nel,kj) + if(ndelm(nd2a) .eq. 1) then + nd1=nop(nel,kj-1) + jj=mod(kj,ncorn(nel))+1 + nd3=nop(nel,jj) + nd2=nd2a + endif + return + endif + + endif + enddo + if(ilc .gt. 0) then + if(kk .eq. 1) then + if(nd1 .eq. ndkp) then + return + else + ierr=1 + return + endif + elseif(kk .eq. 2) then + if(abs(mlc(2)-mlc(1)) .eq. 4) then + do kk=1,2 + nd1=nop(nel,mlc(kk)-1) + if(nd1 .eq. ndkp) then + nd2=nop(nel,mlc(kk)) + nd3=mod(mlc(kk),ncorn(nel))+1 + nd3=nop(nel,nd3) + return + endif + enddo + endif + if(ilc .eq. 1) then + if(mlc(kk) .eq. ncorn(nel) .and. mlc(kk-1) .eq. 2) then + nd1=nop(nel,1) + nd2=nop(nel,2) + nd3=nop(nel,3) + else + return + endif + else + if(mlc(kk) .eq. ncorn(nel) .and. mlc(kk-1) .eq. 2) then + return + else + nd1=nop(nel,mlc(1)-1) + nd2=nop(nel,mlc(1)) + nd3=nop(nel,mlc(1)+1) + endif + endif + elseif(kk .eq. 3) then + if(mlc(kk) .eq. ncorn(nel)) then + if(mlc(kk-1) .eq. ncorn(nel)-2) then + nd1=nop(nel,1) + nd2=nop(nel,2) + nd3=nop(nel,3) + elseif(mlc(kk-1) .eq. ncorn(nel)-4) then + nd1=nop(nel,3) + nd2=nop(nel,4) + nd3=nop(nel,5) + else + return + endif + else + return + endif + endif +! else +! return + endif + ierr=1 + return + end + + SUBROUTINE PANELTYP(N1) + +! Choose options and intervals + + use winteracter + + implicit none + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,itime,IERR + data itime/0/ + + if(itime .eq. 0) then + n1=1 + itime=1 + endif + + call wdialogload(IDD_MATTYP) + ierr=infoerror(1) + + CALL WDialogPutInteger(idf_integer1,N1) + + CALL WDialogSelect(IDD_MATTYP) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(idf_integer1,N1) + ELSE + N1=1 + RETURN + + ENDIF + + RETURN + END + \ No newline at end of file diff --git a/src/LAYDISP.F90 b/src/LAYDISP.F90 new file mode 100644 index 0000000..1607335 --- /dev/null +++ b/src/LAYDISP.F90 @@ -0,0 +1,69 @@ + Subroutine LayDisp + + USE WINTERACTER + USE BLK1MOD +! + include 'd.inc' +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INTEGER :: INODE,IBOX,NN + INTEGER :: IERR + CHARACTER*1 :: IFLAG + + DATA INODE/1/ + + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select node','CHOOSE NODE') + IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + + 100 continue + call wdialogload(IDD_LAY) + ierr=infoerror(1) + + + IF(ILAYTP .EQ. 1) THEN + call wdialogputRadioButton(idf_radio1) + ELSE + call wdialogputRadioButton(idf_radio2) + ENDIF + lno=lay(INODE) + CALL WDialogPutINTEGER(IDF_INTEGER1,lno) + do i=1,7 + CALL WGridPutCellReal(IDF_GRID1,i,1,wtlay(INODE,i)) + enddo + + + CALL WDialogSelect(IDD_LAY) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,ilaytp) + + CALL WDialogGetINTEGER(IDF_INTEGER1,lno) + lay(INODE)=lno + do i=1,7 + CALL WGridGetCellReal(IDF_GRID1,i,1,wtlay(INODE,i)) + enddo + return + ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + RETURN + endif +!IPK SEP02 + return + enddo + RETURN + END diff --git a/src/LEVSETTYP.F90 b/src/LEVSETTYP.F90 new file mode 100644 index 0000000..60fd971 --- /dev/null +++ b/src/LEVSETTYP.F90 @@ -0,0 +1,50 @@ + SUBROUTINE LEVSETTYP + USE WINTERACTER + USE BLK1MOD + include 'd.inc' + + CHARACTER*47 MESSAGE + + DATA ITIME/0/ + IMATTYP=1 + BLELVEL=0. + + call wdialogload(IDD_LEVSETTYP) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_LEVSETTYP) + ierr=infoerror(1) + + CALL WDialogPutReal(IDF_REAL1,BLEVEL) + + CALL WDialogPutInteger(IDF_INTEGER1,IMATTYP) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) +! Branch depending on type of message. +! + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetInteger(IDF_INTEGER1,IMATTYP) + CALL WDialogGetReal(IDF_REAL1,BLEVEL) + GO TO 200 + ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + RETURN + ENDIF + ENDDO + +200 CONTINUE + + DO N=1,NE + IF(IMAT(N) .EQ. 99) CYCLE + DO K=1,NCORN(N) + IF(NOP(N,K) .EQ. 0) CYCLE + IF(WD(NOP(N,K)) .LT. BLEVEL) GO TO 300 + ENDDO + IMAT(N)=IMATTYP +300 CONTINUE + ENDDO + RETURN + END + \ No newline at end of file diff --git a/src/LOADFIL.F90 b/src/LOADFIL.F90 new file mode 100644 index 0000000..94d7173 --- /dev/null +++ b/src/LOADFIL.F90 @@ -0,0 +1,22 @@ + SUBROUTINE LOADFIL + + INCLUDE 'BFILES.I90' + + + IFILOUT=IACTVFIL+50 + +! Zero out current arrays + + CALL ZEROOUT + + IFNUM=IACTVFIL+50 + CALL RDRST(1,IFNUM) + CALL RDRST(2,IFNUM) + CALL RDRST(3,IFNUM) + REWIND IFNUM + + CALL RESCAL + CALL HEDR + + RETURN + END \ No newline at end of file diff --git a/src/MMAP.F90 b/src/MMAP.F90 new file mode 100644 index 0000000..04909ec --- /dev/null +++ b/src/MMAP.F90 @@ -0,0 +1,99 @@ +!IPK LAST UPDATE SEP 23 2015 ADD NEW FORMAT TO 6 DEC + Subroutine MMap + + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + CALL OPENMP + + CALL SVELEM(IYES) + + rewind 99 + +! if IYES .eq. 1 save as an element format + + valmap=0. + mapno=2 + IF(IYES .EQ. 1) THEN + do n=1,ne + write(99,6001) + 6001 format(' 3,9999.') + if(imat(n) .gt. 0) then + ncn=ncorn(n) + do m=1,ncn + j=nop(n,m) + if(j .gt. 0) then + write(99,'(3f16.3)') xusr(j),yusr(j),wd(j) + endif + enddo + j=nop(n,1) + if(j .gt. 0) then + write(99,'(3f16.3)') xusr(j),yusr(j),wd(j) + endif + endif + write(99,6000) + 6000 format('END') + enddo + +! if IYES .eq. 0 save as a nodal list + + + ELSE + write(99,6002) + 6002 format(' 2,0') + do j=1,np + if(inew(j) .eq. 1) then + write(99,'(3f16.6)') xusr(j),yusr(j),wd(j) + endif + enddo + write(99,6000) + ENDIF + write(99,6000) + close (99) + return + end + + subroutine openmp + + use winteracter + + implicit none + + include 'd.inc' + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + CALL WSelectFile(ID_STRING7,SaveDialog+PromptOn,FNAME,'Save Network as Mapfile') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='map' + CALL ADDSUB(FNAME,SUB) + open(99,file=fname, form='formatted', status='unknown') + ENDIF + RETURN + END + + SUBROUTINE SVELEM(IYES) + + USE WINTERACTER + + INCLUDE 'D.INC' + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save element layout?'//& + CHAR(13)//' ','Map option') +! +! If answer 'No', return +! + iyes=1 + IF (WInfoDialog(4).EQ.2) iyes=0 + return + end + \ No newline at end of file diff --git a/src/MOVMESH.f90 b/src/MOVMESH.f90 new file mode 100644 index 0000000..ef3e501 --- /dev/null +++ b/src/MOVMESH.f90 @@ -0,0 +1,386 @@ + SUBROUTINE MOVMESH + + USE WINTERACTER + USE BLK1MOD + + SAVE + +! implicit none + + include 'd.inc' + + INCLUDE 'TXFRM.COM' + + INCLUDE 'BFILES.I90' + + CHARACTER*1 IFLAG + REAL xlocorg,ylocorg,xlocscl,ylocscl,XREFPT,YREFPT,xlocs,ylocs,xlocf,ylocf,stscalx,stscaly,xtest,ytest + INTEGER NTYPR,ITIMETHRU + + allocatable xusrt(:),yusrt(:),xcrst(:),ycrst(:) + + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + DATA ITIMTHRU/0/,NTYPR/1/,xlocorg/0./,ylocorg/0./,xlocscl/0./,ylocscl/0./ + + call wdialogload(IDD_DIALOG048) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_DIALOG048) + ierr=infoerror(1) + + IF(NTYPR .EQ. 1) THEN + call wdialogputRadioButton(idf_radio1) + ELSE + call wdialogputRadioButton(idf_radio2) + ENDIF + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,ntypr) + go to 100 + + elseif(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + return + ENDIF + + enddo + + 100 continue + + IF(NTYPR .EQ. 1) THEN + + call wdialogload(IDD_DIALOG047) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_DIALOG047) + ierr=infoerror(1) + + CALL WDialogPutReal(IDF_REAL1,xlocorg) + CALL WDialogPutReal(IDF_REAL2,ylocorg) + CALL WDialogPutReal(IDF_REAL3,xlocscl) + CALL WDialogPutReal(IDF_REAL4,ylocscl) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetReal(IDF_REAL1,xlocorg) + CALL WDialogGetReal(IDF_REAL2,ylocorg) + CALL WDialogGetReal(IDF_REAL3,xlocscl) + CALL WDialoggetReal(IDF_REAL4,ylocscl) + + allocate (xusrt(np),yusrt(np)) + + if(xlocscl .eq. 0.) then + do j=1,np + xusrt(j)=xusr(j) + yusrt(j)=yusr(j) + xusr(j)=xusr(j)+xlocorg + yusr(j)=yusr(j)+ylocorg + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + enddo + if(ncrsec .gt. 0) then + allocate (xcrst(nrsec),ycrst(nrsec)) + do j=1,ncrsec + xcrst(j)=xcrs(j) + ycrst(j)=ycrs(j) + xcrs(j)=xcrs(j)+xlocorg + ycrs(j)=ycrs(j)+ylocorg + enddo + endif + else + do j=1,np + xusr(j)=(xusr(j)-xlocorg)*xlocscl + yusr(j)=(yusr(j)-ylocorg)*ylocscl + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + enddo + if(ncrsec .gt. 0) then + allocate (xcrst(nrsec),ycrst(nrsec)) + do j=1,ncrsec + xcrst(j)=xcrs(j) + ycrst(j)=ycrs(j) + xcrs(j)=(xcrs(j)-xlocorg)*xlocscl + ycrs(j)=(ycrs(j)-ylocorg)*ylocscl + enddo + endif + endif + + go to 300 + + elseif(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + return + endif + enddo + + else + +! get reference point +! xrefpt +! yrefpt + + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select Fixed Reference point','CHOOSE REFERENCE') + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + XREFPT = XTEMP*TXSCAL - XS + YREFPT = YTEMP*TXSCAL - YS + +! get start move point +! xlocs +! ylocs + + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select Starting point','CHOOSE START') + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + XLOCS = XTEMP*TXSCAL - XS + YLOCS = YTEMP*TXSCAL - YS + +! get finish move point +! xlocf +! ylocf + + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select Finishing point','CHOOSE FINISH') + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + XLOCF = XTEMP*TXSCAL - XS + YLOCF = YTEMP*TXSCAL - YS + +! establish x moves + stscalx=(xlocf-xrefpt)/(xlocs-xrefpt) + +! establish y moves + stscaly=(ylocf-yrefpt)/(ylocs-yrefpt) + + allocate (xusrt(np),yusrt(np)) + do j=1,np + xusrt(j)=xusr(j) + yusrt(j)=yusr(j) + xusr(j)=xrefpt-(xrefpt-xusr(j))*stscalx + yusr(j)=yrefpt-(yrefpt-yusr(j))*stscaly + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + enddo + if(ncrsec .gt. 0) then + allocate (xcrst(nrsec),ycrst(nrsec)) + do j=1,ncrsec + xcrst(j)=xcrs(j) + ycrst(j)=ycrs(j) + xcrs(j)=xrefpt-(xrefpt-xcrs(j))*stscalx + ycrs(j)=yrefpt-(yrefpt-ycrs(j))*stscaly + enddo + endif + + endif + + 300 continue + CALL CLSCRN + CALL PLOTOT(1) + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to keep '//& + CHAR(13)//' ','new locations?') + ! +! If answer 'No', reset +! + IF (WInfoDialog(4).EQ.2) then + do j=1,np + xusr(j)=xusrt(j) + yusr(j)=yusrt(j) + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + enddo + if(ncrsec .gt. 0) then + do j=1,ncrsec + xcrs(j)=xcrst(j) + ycrs(j)=ycrst(j) + enddo + deallocate (xcrst,ycrst) + endif + CALL CLSCRN + CALL PLOTOT(1) + endif + + deallocate(xusrt,yusrt) + + RETURN + END + + SUBROUTINE TRANSMESH + + USE WINTERACTER + USE BLK1MOD + + SAVE + +! implicit none + + include 'd.inc' + + INCLUDE 'TXFRM.COM' + + INCLUDE 'BFILES.I90' + + CHARACTER*1 IFLAG + allocatable xusrt(:),yusrt(:),xcrst(:),ycrst(:) + data iopt1/1/ + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + call wdialogload(IDD_TRANSFORM) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_TRANSFORM) + ierr=infoerror(1) + + CALL WDialogPutINTEGER(IDF_INTEGER1,IOPT1) + + CALL WDialogPutReal(IDF_REAL3,COEF1) + CALL WDialogPutReal(IDF_REAL4,COEF2) + CALL WDialogPutReal(IDF_REAL5,COEF3) + CALL WDialogPutReal(IDF_REAL6,COEF4) + CALL WDialogPutReal(IDF_REAL7,COEF5) + CALL WDialogPutReal(IDF_REAL8,COEF6) + CALL WDialogPutINTEGER(IDF_INTEGER2,ICOEF1) + CALL WDialogPutINTEGER(IDF_INTEGER3,ICOEF2) + CALL WDialogPutINTEGER(IDF_INTEGER4,ICOEF3) + CALL WDialogPutINTEGER(IDF_INTEGER5,ICOEF4) + CALL WDialogPutINTEGER(IDF_INTEGER9,ICOEF5) + CALL WDialogPutINTEGER(IDF_INTEGER10,ICOEF6) + + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetINTEGER(IDF_INTEGER1,IOPT1) + CALL WDialogGetReal(IDF_REAL3,COEF1) + CALL WDialogGetReal(IDF_REAL4,COEF2) + CALL WDialogGetReal(IDF_REAL5,COEF3) + CALL WDialoggetReal(IDF_REAL6,COEF4) + CALL WDialoggetReal(IDF_REAL7,COEF5) + CALL WDialoggetReal(IDF_REAL8,COEF6) + CALL WDialogGetINTEGER(IDF_INTEGER2,ICOEF1) + CALL WDialogGetINTEGER(IDF_INTEGER3,ICOEF2) + CALL WDialogGetINTEGER(IDF_INTEGER4,ICOEF3) + CALL WDialogGetINTEGER(IDF_INTEGER5,ICOEF4) + CALL WDialogGetINTEGER(IDF_INTEGER9,ICOEF5) + CALL WDialogGetINTEGER(IDF_INTEGER10,ICOEF6) + go to 200 + elseif(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + return + ENDIF + + enddo +200 continue + if(.not. allocated(xusrt)) then + allocate (xusrt(np),yusrt(np)) + + do j=1,np + xusrt(j)=xusr(j) + yusrt(j)=yusr(j) + enddo + if(ncrsec .gt. 0) then + allocate (xcrst(nrsec),ycrst(nrsec)) + do j=1,ncrsec + xcrst(j)=xcrs(j) + ycrst(j)=ycrs(j) + enddo + endif + endif + IF(IOPT1 .EQ. 1) THEN + DO J=1,NP + XUSR(J)=COEF1*XUSR(J)+COEF2 + YUSR(J)=COEF3*YUSR(J)+COEF4 + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + IF(COEF5 .EQ. 0. .AND. COEF6 .EQ. 0.) CYCLE + WD(J)=COEF5*WD(J)+COEF6 + ENDDO + if(ncrsec .gt. 0) then + do j=1,ncrsec + xcrs(j)=coef1*XCRS(J)+COEF2 + ycrs(j)=coef3*YCRS(J)+COEF4 + enddo + endif + ELSE IF(IOPT1 .EQ. 2) THEN + do j=1,np + reff=coef3 + angl=(xusr(j)-coef1)/reff + a=cos(angl) + a=reff*cos(angl) + b=reff*sin(angl) + xusr(j)=reff*sin(angl)-(yusr(j)-coef2)*sin(angl) + yusr(j)=(yusr(j)-coef2)*cos(angl)+reff*(1.-cos(angl)) + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + enddo + if(ncrsec .gt. 0) then + do j=1,ncrsec + reff=coef3+coef2-ycrs(j) + ang=(xcrs(j)-coef1)/reff + xcrs(j)=coef1+reff*sin(angl) + ycrs(j)=coef2+reff*cos(angl) + enddo + endif + ELSEIF(IOPT1 .EQ. 3) THEN + DO J=1,NP + A=(XUSR(J)-COEF1)*COS(COEF3)-(YUSR(J)-COEF2)*SIN(COEF3) + B=(XUSR(J)-COEF1)*SIN(COEF3)+(YUSR(J)-COEF2)*COS(COEF3) + XUSR(J)=A + YUSR(J)=B + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + ENDDO + if(ncrsec .gt. 0) then + do j=1,ncrsec + A=(XCRS(J)-COEF1)*COS(COEF3)-(YCRS(J)-COEF2)*SIN(COEF3) + B=(XCRS(J)-COEF1)*SIN(COEF3)+(YCRS(J)-COEF2)*COS(COEF3) + xcrs(j)=A + ycrs(j)=B + enddo + endif + ENDIF + CALL CLSCRN + CALL PLOTOT(1) + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to keep '//& + CHAR(13)//' ','new locations?') + ! +! If answer 'No', reset +! + IF (WInfoDialog(4).EQ.2) then + do j=1,np + xusr(j)=xusrt(j) + yusr(j)=yusrt(j) + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + enddo + deallocate (Xusrt,yusrt) + if(ncrsec .gt. 0) then + do j=1,ncrsec + xcrs(j)=xcrst(j) + ycrs(j)=ycrst(j) + enddo + deallocate (xcrst,ycrst) + endif + CALL CLSCRN + CALL PLOTOT(1) + endif + RETURN + END \ No newline at end of file diff --git a/src/NECON.F90 b/src/NECON.F90 new file mode 100644 index 0000000..c5a88c7 --- /dev/null +++ b/src/NECON.F90 @@ -0,0 +1,44 @@ + SUBROUTINE NDNECON(IERR) +! +! ESTABLISH ELEMENT CONNECTED TO ELEMENT TABLE +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' +! +! INITIALIZE +! + ISWT=IERR + NCM=MAXECON + DO J=1,NCM + DO N=1,NP + NECON(N,J)=0 + ENDDO + ENDDO + DO N=1,NP + NDELM(N)=0 + ENDDO +! +! FORM TABLE OF ELEMENTS CONNECTED TO EACH NODE +! +! IERR=0 + DO M=1,NE + IF(IMAT(M) .NE. 0) THEN + DO K=1,8 + IF(ISWT .EQ. 1 .AND. MOD(K,2) .EQ. 1) CYCLE + N=NOP(M,K) + IF (N .GT. 0) THEN + NDELM(N)=NDELM(N)+1 + J=NDELM(N) + IF(J .GT. MAXECON) THEN + IERR=MAX(IERR,J) + ELSE + NECON(N,J)=M + ENDIF + ENDIF + ENDDO + ENDIF + END DO + RETURN + END diff --git a/src/NEWRMGN.F90 b/src/NEWRMGN.F90 new file mode 100644 index 0000000..463e191 --- /dev/null +++ b/src/NEWRMGN.F90 @@ -0,0 +1,944 @@ +!IPK LAST UPDATE SEP 23 2015 ADD MORE INFO ON FRAME +! + PROGRAM NEWRMAGEN +! +! Use of the module is compulsory +! + USE WINTERACTER + USE DFLIB +! + IMPLICIT NONE +! +! Define some parameters to match those in the resource file +! + include 'd.inc' + INCLUDE 'TXFRM.COM' + + REAL HSIZE,scratio + COMMON /SSIZE/ HSIZE + +! + INTEGER :: IBASEV =40042 + INTEGER :: I,IRES,N2,M2,ID1,ID2 + INTEGER :: ITYPE, IX, IY, IWIDTH, IHEIGHT, KEY,IYES + INTEGER :: MOUSEX, MOUSEY, MBUTTON, ITIME, IWINDOW + INTEGER :: IDFIELDOLD, IDFIELDNEW, IDBUTN, IDFIELD,TOOLID(4) + INTEGER :: LNNAM,K,LMPNAM,IMP,IIN,MENUS,IOT,IOT1,impf,IGFG,ITRIAN,INFO(3) + INTEGER , DIMENSION(5) :: WIDSTAT + INTEGER*2 :: N1,STATUS,lnnnam,iswtfl,n + CHARACTER(LEN=255) :: FNAME,FNAMD,FILTER + CHARACTER(LEN=3) :: SUB,SUB1 + CHARACTER(LEN=4) :: SUB2 + CHARACTER(LEN=1000) :: HEADR + INTEGER ,EXTERNAL :: LENSTR + LOGICAL :: OPENED,exists + LOGICAL(4) :: statud + REAL :: XX1,XX2,XX3,XX4,XX5,XX6 + + + INTEGER ISCRWID,ISCRHGT + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + TYPE(WIN_MESSAGE) :: MESSAGE + TYPE (WIN_FONT) :: FONT + +! Define a common block with background file names + + INCLUDE 'BFILES.I90' + +! +! Get initial directory and add help name + + fname = FILE$CURDRIVE + IRES=GETDRIVEDIRQQ (fname) +! lnnnam=windowstringlength(fname) + lnnnam=lenstr(fname) + direct=fname(1:lnnnam)//'\doc\rmagen81M.htm' + +! write(128,*) fname,lnnnam,direct + +! +! +! Initialise WiSK +! + CALL WInitialise() +! +! Create a root window with : +! - System menu +! - Minimise button +! - Maximise button +! +! WINDOW%FLAGS = SysMenuOn + MinButton + MaxButton + StatusBar + + ISCRWID = WInfoScreen(1) ! Get screen width + ISCRHGT = WInfoScreen(2) ! Get screen height + scratio=float(iscrwid)/float(iscrhgt) + HSIZE=scratio*8. + +! +! Centre the window on the screen at 80% of screen size +! + WINDOW%X = -1 + WINDOW%Y = -1 + WINDOW%WIDTH = 0 + WINDOW%HEIGHT = 0 +! +! Identify the menu to be attached to the window +! and specify the initial window title +! +! WINDOW%MENUID = IDR_MENU1 +! WINDOW%TITLE = 'RMAGEN' +! +! Now open the root window +! + CALL WindowOpen(FLAGS =SysMenuOn+MinButton+MaxButton+StatusBar, & + MENUID=IDR_MENU1, & + TOOLID=(/0,ID_TOOLBAR1,0,0/), & + TITLE ='RMAGEN') +! CALL WindowOpen(WINDOW,TITLE ='RMAGEN') ! Open root window + +! +! Add a toolbar +! +! CALL WMenuToolbar(ID_TOOLBAR1) +! +! Main message loop +! +! initialise palette +! + CALL IGrPaletteInit +! +! set fill style to solid +! + CALL IGrFillPattern(Solid) + + FONT%IBCOL = TextWhite + CALL WindowFont(FONT) +! CALL WindowClear(RGB=RGB_yellow) ! clear window to yellow +! IRGB = WRGB(220,220,220) +! IRGB = WRGB(191,191,191) + IRGB = WRGB(227,227,227) + CALL WindowClear(rgb=irgb) ! clear to yellow + + WIDSTAT(1) = 1000 + WIDSTAT(2) = 2000 + WIDSTAT(3) = 1500 + WIDSTAT(4) = 1000 + WIDSTAT(5) = 2500 + CALL WindowStatusBarParts(5, WIDSTAT) + CALL WindowOutStatusBar(1, ' X and Y location') + CALL WindowOutStatusBar(4, ' Active File Name') + CALL IgrUnits(0.,0.,HSIZE,8.0) + +! IF(ISW .EQ. 1) THEN +! CALL WMessageEnable(MouseMove , Enabled) +! MENUS=-3 +! CALL RMAGEN(MENUS,IMP,IIN,1,IOT,IOT1,IGFG) +! ENDIF + + +! CALL WMenuSetState(ID_NETWD,ItemChecked,1) +! DO I=1,12 +! CALL WMenuSetState(IBASEV+I,ItemChecked,1) +! ENDDO + N2=0 + M2=0 + TXSCAL = 1. + XS=0. + YS=0. + NBKFL=0 + IRDONE=-1 + DO I=1,10 + ISWBKFL(I)=0 + ENDDO + IACTVFIL=0 + ITOTFIL=0 + IOT=0 + IOT1=0 + IMP=0 + + CALL INITSIZ(IIN,N2,M2,0) + + CALL WMenuSetState(ID_loadrm1,ItemEnabled,0) + CALL WMenuSetState(ID_sbin,ItemEnabled,0) + CALL WMenuSetState(ID_crsf,ItemEnabled,0) + CALL WMenuSetState(ID_savcrs,ItemEnabled,0) + CALL WMenuSetState(ID_LAYFL,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM13,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM14,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM18,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM15,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM16,ItemEnabled,0) + CALL WMenuSetState(ID_ICOPY,ItemEnabled,0) + CALL WMenuSetState(ID_Clip,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM24,ItemEnabled,0) + CALL WMenuSetState(ID_MMAP,ItemEnabled,0) + CALL WMenuSetState(ID_MAPM,ItemEnabled,0) + CALL WMenuSetState(ID_NETWORK,ItemEnabled,0) + CALL WMenuSetState(ID_NODE,ItemEnabled,0) + CALL WMenuSetState(ID_ELTS,ItemEnabled,0) + CALL WMenuSetState(ID_ORDR,ItemEnabled,0) + CALL WMenuSetState(ID_CCLN,ItemEnabled,0) + CALL WMenuSetState(ID_CONTR,ItemEnabled,0) + CALL WMenuSetState(ID_CSEC,ItemEnabled,0) + CALL WMenuSetState(ID_CSEC1,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM20,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM26,ItemEnabled,0) + CALL WMenuSetState(ID_ZOOM,ItemEnabled,0) + CALL WMenuSetState(ID_DRAW,ItemEnabled,0) + CALL WMenuSetState(ID_UNDOM,ItemEnabled,0) + CALL WMenuSetState(ID_NMAP,ItemEnabled,0) + CALL WMenuSetState(ID_CDATA,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM56,ItemEnabled,0) + CALL WMenuSetState(ID_SECGRP,ItemEnabled,0) + + iswtfl=0 + N1=1 + CALL GETARG(N1,FNAME,STATUS) + if(status .ne. -1 ) then + + CALL SHORTNAME(FNAME,FNAMEDISP) + do n=status,1,-1 + if(fname(n:n) .eq. '\') then + lnnnam=n-1 + go to 99 + endif + enddo + 99 continue + if(lnnnam .gt. 0) then + fnamd=fname(1:lnnnam) + statud = CHANGEDIRQQ(fnamd) + endif + iswtfl=1 + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + ITRIAN=0 + IF(SUB .EQ. 'geo') then + IIN=12 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ') + FNAMKEP=FNAME + READ(IIN) HEADR + READ(IIN) N2,M2 + REWIND (IIN) + + ELSEIF(SUB .EQ. 'gfg') then + IIN = 10 + IGFG=1 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ELSEIF(SUB .EQ. '2dm') then + IIN = 10 + IGFG=3 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ELSEIF(SUB .EQ. 'rst') then + IIN=11 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') + IGFG=0 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + ELSEIF(SUB .EQ. 'bin') then + IIN=12 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') + IGFG=2 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + ELSEIF(SUB .EQ. 'ele') then + IIN=10 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ') + ITRIAN=1 + IGFG=0 + FNAMKEP=FNAME + CALL SETGFGTRIAN(IGFG,ITRIAN,N2,M2) + ELSEIF(SUB .EQ. 'map') then + IMP=9 + OPEN(9,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then + IMP=94 + OPEN(94,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'shp') then + IMP=113 + OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + sub='dbf' + call addsub(fname,sub) + OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + ELSE + IIN = 10 + IGFG=0 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ENDIF + IF(IMP .EQ. 0) THEN + IACTVFIL=1 + ITOTFIL=1 + FNAMEOUT(1)=FNAME + ENDIF + CALL WMenuSetState(ID_loadrm1,ItemEnabled,1) + CALL WMenuSetState(ID_sbin,ItemEnabled,1) + CALL WMenuSetState(ID_crsf,ItemEnabled,1) + CALL WMenuSetState(ID_savcrs,ItemEnabled,1) + CALL WMenuSetState(ID_LAYFL,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM13,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM14,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM18,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM15,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM16,ItemEnabled,1) + CALL WMenuSetState(ID_ICOPY,ItemEnabled,1) + CALL WMenuSetState(ID_Clip,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM24,ItemEnabled,1) + CALL WMenuSetState(ID_MMAP,ItemEnabled,1) + CALL WMenuSetState(ID_MAPM,ItemEnabled,1) + CALL WMenuSetState(ID_NETWORK,ItemEnabled,1) + CALL WMenuSetState(ID_NODE,ItemEnabled,1) + CALL WMenuSetState(ID_ELTS,ItemEnabled,1) + CALL WMenuSetState(ID_ORDR,ItemEnabled,1) + CALL WMenuSetState(ID_CCLN,ItemEnabled,1) + CALL WMenuSetState(ID_CONTR,ItemEnabled,1) +! CALL WMenuSetState(ID_CSEC,ItemEnabled,0) + CALL WMenuSetState(ID_CSEC1,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM20,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM26,ItemEnabled,1) + CALL WMenuSetState(ID_ZOOM,ItemEnabled,1) + CALL WMenuSetState(ID_DRAW,ItemEnabled,1) + CALL WMenuSetState(ID_UNDOM,ItemEnabled,1) + CALL WMenuSetState(ID_NMAP,ItemEnabled,1) + CALL WMenuSetState(ID_CDATA,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM56,ItemEnabled,1) + CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0) + CALL WMessageEnable(MouseMove , Enabled) + + IF(IMP .GT. 0) THEN + MENUS=-2 + CALL INITSIZ(IIN,N2,M2,1) + go to 500 + ENDIF + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to load '//& + CHAR(13)//'a map file?' ,& + 'Map File Input?') +! +! If answer 'No' skip out +! + IMP=0 + IF (WInfoDialog(4) .NE. 2) then + + fname=' ' + CALL WSelectFile(ID_STRING1,PromptOn,FNAME,'Load Map File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + IF(SUB .EQ. 'map') then + IMP=9 + OPEN(9,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then + IMP=94 + OPEN(94,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'mpb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read') + ELSEIF(SUB .EQ. 'mbb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read') + ELSEIF(SUB .EQ. 'rm1') then + imp=13 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'shp') then + IMP=113 + OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + SUB='DBF' + CALL ADDSUB(FNAME,SUB) + OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + ENDIF + ENDIF + END IF + MENUS=-2 + CALL INITSIZ(IIN,N2,M2,1) + + go to 500 + endif + + + + DO WHILE (.TRUE.) ! Loop until user terminates + + 100 continue + CALL WMessage(ITYPE, MESSAGE) + SELECT CASE (ITYPE) + CASE (KeyDown) ! Key pressed + KEY = MESSAGE%VALUE1 + MOUSEX = MESSAGE%X + MOUSEY = MESSAGE%Y + CASE (MenuSelect) ! Menu item selected + SELECT CASE (MESSAGE%VALUE1) +! CASE (ID_FILE) ! File option selected + CASE (ID_RESETLIM) + CALL RESETSIZ + + CASE (ID_ITEM11) ! New option + IMP=0 + IIN=0 + CALL INITSIZ(IIN,N2,M2,1) + CALL WMenuSetState(ID_loadrm1,ItemEnabled,1) + CALL WMenuSetState(ID_sbin,ItemEnabled,1) + CALL WMenuSetState(ID_crsf,ItemEnabled,1) + CALL WMenuSetState(ID_savcrs,ItemEnabled,1) + CALL WMenuSetState(ID_LAYFL,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM13,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM14,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM18,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM15,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM16,ItemEnabled,1) + CALL WMenuSetState(ID_ICOPY,ItemEnabled,1) + CALL WMenuSetState(ID_Clip,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM24,ItemEnabled,1) + CALL WMenuSetState(ID_MMAP,ItemEnabled,1) + CALL WMenuSetState(ID_MAPM,ItemEnabled,1) + CALL WMenuSetState(ID_NETWORK,ItemEnabled,1) + CALL WMenuSetState(ID_NODE,ItemEnabled,1) + CALL WMenuSetState(ID_ELTS,ItemEnabled,1) + CALL WMenuSetState(ID_ORDR,ItemEnabled,1) + CALL WMenuSetState(ID_CCLN,ItemEnabled,1) + CALL WMenuSetState(ID_CONTR,ItemEnabled,1) +! CALL WMenuSetState(ID_CSEC,ItemEnabled,0) + CALL WMenuSetState(ID_CSEC1,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM20,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM26,ItemEnabled,1) + CALL WMenuSetState(ID_ZOOM,ItemEnabled,1) + CALL WMenuSetState(ID_DRAW,ItemEnabled,1) + CALL WMenuSetState(ID_UNDOM,ItemEnabled,1) + CALL WMenuSetState(ID_NMAP,ItemEnabled,1) + CALL WMenuSetState(ID_CDATA,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM56,ItemEnabled,1) + CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0) + CALL WMessageEnable(MouseMove , Enabled) + + + MENUS=-2 + EXIT + CASE (ID_ITEM12) ! Open option + IMP=0 + IIN=0 + if(iswtfl .eq. 1) go to 200 + fname=' ' + FILTER ="Network Files|*.rm1;*.geo;*.gfg;*.bin;*.ele;*.2dm|Rm1 file -- *.rm1|*.rm1|Geo file -- *.geo|*.geo|GFGEN file -- *.gfg|*.gfg|GFGEN bin file -- *.bin|*.bin|Rst file -- *.rst|*.rst|ele file -- *.ele|*.ele|MESH2D file -- *.2dm|*.2dm|All files|All files|*.*|" + CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + GO TO 200 + ELSE + GO TO 250 + ENDIF + 200 CONTINUE + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + IF(SUB .EQ. 'geo') then + IIN=12 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',form='binary',ACTION='READ') + FNAMKEP=FNAME + READ(IIN) HEADR + READ(IIN) N2,M2 + REWIND (IIN) + + ITRIAN=0 + ELSEIF(SUB .EQ. 'gfg') then + IIN = 10 + IGFG=1 + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ITRIAN=0 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + ELSEIF(SUB .EQ. '2dm') then + IIN = 10 + IGFG=3 + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ITRIAN=0 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + ELSEIF(SUB .EQ. '2dm') then + IIN = 10 + IGFG=3 + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ITRIAN=0 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + ELSEIF(SUB .EQ. 'bin') then + IIN=12 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') + IGFG=2 + ITRIAN=0 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + ELSEIF(SUB .EQ. 'rst') then + IIN=11 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED') + IGFG=0 + ITRIAN=0 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + ELSEIF(SUB .EQ. 'ele') then + IIN=10 + OPEN(IIN ,FILE=FNAME,STATUS='OLD',ACTION='READ') + ITRIAN=1 + IGFG=0 + FNAMKEP=FNAME + CALL SETGFGTRIAN(IGFG,ITRIAN,N2,M2) + ELSE + IIN = 10 + IGFG=0 + OPEN(10,FILE=FNAME,STATUS='OLD',ACTION='READ') + ITRIAN=0 + CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2) + ENDIF + IACTVFIL=1 + ITOTFIL=1 + FNAMEOUT(1)=FNAME + CALL SHORTNAME(FNAME,FNAMEDISP) + 250 CONTINUE + fname=' ' + filter="Map file -- *.map |*.map|Bin Map file -- *.mpb|*.mpb|Bin Map file (no head) -- *.mbb|*.mbb|RM1 file (as map) -- *.rm1|*.rm1|ESRI ASC file -- *.asc|*.asc|SURFER GRD file -- *.grd|*.grd|ESRI SHP file -- *.shp|*.shp|" + CALL WSelectFile(filter,PromptOn,FNAME,'Load Map File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + IF(SUB .EQ. 'map') then + IMP=9 + OPEN(9,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then + IMP=94 + OPEN(94,FILE=FNAME,STATUS='OLD',action='read') + ELSEIF(SUB .EQ. 'shp') then + IMP=113 + OPEN(113,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + SUB='DBF' + CALL ADDSUB(FNAME,SUB) + OPEN(114,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read') + ELSEIF(SUB .EQ. 'mpb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read') + ELSEIF(SUB .EQ. 'mbb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read') + ELSEIF(SUB .EQ. 'rm1') then + imp=13 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',action='read') + ENDIF + ENDIF + CALL WMenuSetState(ID_loadrm1,ItemEnabled,1) + CALL WMenuSetState(ID_sbin,ItemEnabled,1) + CALL WMenuSetState(ID_crsf,ItemEnabled,1) + CALL WMenuSetState(ID_savcrs,ItemEnabled,1) + CALL WMenuSetState(ID_LAYFL,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM13,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM14,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM18,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM15,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM16,ItemEnabled,1) + CALL WMenuSetState(ID_ICOPY,ItemEnabled,1) + CALL WMenuSetState(ID_Clip,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM24,ItemEnabled,1) + CALL WMenuSetState(ID_MMAP,ItemEnabled,1) + CALL WMenuSetState(ID_MAPM,ItemEnabled,1) + CALL WMenuSetState(ID_NETWORK,ItemEnabled,1) + CALL WMenuSetState(ID_NODE,ItemEnabled,1) + CALL WMenuSetState(ID_ELTS,ItemEnabled,1) + CALL WMenuSetState(ID_ORDR,ItemEnabled,1) + CALL WMenuSetState(ID_CCLN,ItemEnabled,1) + CALL WMenuSetState(ID_CONTR,ItemEnabled,1) + CALL WMenuSetState(ID_CSEC1,ItemEnabled,1) +! CALL WMenuSetState(ID_CSEC,ItemEnabled,0) + CALL WMenuSetState(ID_ITEM20,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM26,ItemEnabled,1) + CALL WMenuSetState(ID_ZOOM,ItemEnabled,1) + CALL WMenuSetState(ID_DRAW,ItemEnabled,1) + CALL WMenuSetState(ID_UNDOM,ItemEnabled,1) + CALL WMenuSetState(ID_NMAP,ItemEnabled,1) + CALL WMenuSetState(ID_CDATA,ItemEnabled,1) + CALL WMenuSetState(ID_ITEM56,ItemEnabled,1) + CALL WMenuSetState(ID_RESETLIM,ItemEnabled,0) + CALL WMessageEnable(MouseMove , Enabled) + + + MENUS=-2 + CALL INITSIZ(IIN,N2,M2,1) + EXIT + CASE (ID_ITEM13) ! Save option + WRITE(90,*) 'NWRM ITEM13' + INQUIRE(20, OPENED=OPENED) + if(.not. opened) then + FILTER ="Network Files|*.rm1;*.gfg;*.ele|Rm1 file -- *.rm1|*.rm1|GFGEN file -- *.gfg|*.gfg|ele file -- *.ele|*.ele|All files|*.*|" + + CALL WSelectFile(FILTER,SaveDialog+PromptOn,FNAME,'Save Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='rm1' + CALL ADDSUB(FNAME,SUB) + + WRITE(90,*) 'IN ITEM13-NEW',IOT + WRITE(90,'(A)') FNAME,SUB + IOT = 20 + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN',ACTION='READWRITE') + + call wrtout(1) + ENDIF + else + call wrtout(1) + endif + + CASE (ID_ITEM14) ! Save option + WRITE(90,*) 'NWRM ITEM14' + + INQUIRE(22, OPENED=OPENED) + if(.not. opened) then + CALL WSelectFile(ID_STRING4,SaveDialog+PromptOn,FNAME,'Save Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='geo' + CALL ADDSUB(FNAME,SUB) + + WRITE(90,*) 'IN ITEM14-NEW',IOT1 + WRITE(90,'(A)') FNAME,SUB + IOT1=22 + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary',ACTION='READWRITE') + call wrtout(2) + ENDIF + else + call wrtout(2) + endif + + CASE (ID_ITEM18) ! Save As option + + CALL WSelectFile(ID_STRING5,SaveDialog+PromptOn,FNAME,'Save Bin Map File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='mpb' + CALL ADDSUB(FNAME,SUB) + impf=93 + OPEN(IMPF ,FILE=fname,STATUS='unknown',form='unformatted',ACTION='READWRITE') + + call wrtmap(1) + + ENDIF + + CASE (ID_ITEM15) ! Save As option + + CALL WSelectFile(ID_STRING3,SaveDialog+PromptOn,FNAME,'Save Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='rm1' + CALL ADDSUB(FNAME,SUB) + + IOT = 20 + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN',ACTION='READWRITE') + call wrtout(1) + ENDIF + + CASE (ID_ITEM16) ! Save As option + + CALL WSelectFile(ID_STRING4,SaveDialog+PromptOn,FNAME,'Save Network File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='geo' + CALL ADDSUB(FNAME,SUB) + + IOT1 = 22 + OPEN(IOT1 ,FILE=FNAME,STATUS='UNKNOWN',form='binary',ACTION='READWRITE') + call wrtout(2) + ENDIF + + CASE (ID_BKF) ! Read background option + + fname=' ' + FILTER ="Background File|*.wmf;*.bmp;*.pcx;*.png;*.cgm;*.pic;*.jpg|wmf file -- *.wmf|*.wmf|bmp file -- *.bmp|*.bmp|pcx file -- *.pcx|*.pcx|png file -- *.png|*.png|jpeg file -- *.jpg|*.jpg|cgm file -- *.cgm|*.cgm|pic file -- *.pic|*.pic|" + CALL WSelectFile(FILTER,PromptOn+DirChange,FNAME,'Load Background file') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + NBKFL=NBKFL+1 + BFNAME(NBKFL)=FNAME + SUB1=SUB + IF(SUB .EQ. 'bmp') then + ISWBKFL(NBKFL) = 2 + ELSEIF(SUB .EQ. 'pcx') then + ISWBKFL(NBKFL) = 2 + ELSEIF(SUB .EQ. 'png' .or. sub .eq. 'jpg') then + ISWBKFL(NBKFL) = 2 + ELSE + ISWBKFL(NBKFL)=1 + ENDIF + SUB='ORG' + CALL ADDSUB(FNAME,SUB) + BFNAMR(NBKFL)=FNAME + INQUIRE (FILE = fname, EXIST = exists) + IF (.NOT. exists) THEN + IF(SUB1 .EQ. 'PNG' .or. SUB1 .EQ. 'png') SUB2='PNGW' + IF(SUB1 .EQ. 'JPG' .or. SUB1 .EQ. 'jpg') SUB2='JPGW' + CALL ADDSUB(FNAME,SUB2) + BFNAMR(NBKFL)=FNAME + INQUIRE (FILE = fname, EXIST = exists) + IF (.NOT. exists) THEN + IF(SUB2 .EQ. 'JPGW') THEN + SUB1='JGW' + CALL ADDSUB(FNAME,SUB1) + BFNAMR(NBKFL)=FNAME + ENDIF + ENDIF + INQUIRE (FILE = fname, EXIST = exists) + IF (.NOT. exists) THEN + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'ORG file does not exist!!'//CHAR(13)// & + 'Do you wish to create file and view image','Looking for ORG file') +! If answer 'Yes' set ifrmel to 0 +! + IF (WInfoDialog(4) .ne. 2) then + OPEN(104,FILE=FNAME,STATUS ='NEW', FORM ='FORMATTED') + BFMINMAX(NBKFL,1) = - XS + BFMINMAX(NBKFL,2) = - YS + BFMINMAX(NBKFL,3) = HSIZE*TXSCAL - XS + BFMINMAX(NBKFL,4) = 7.50*TXSCAL - YS + WRITE(104,'(4G16.8)') (BFMINMAX(NBKFL,I),I=1,4) + CLOSE(104) + + EXIT + ELSE + NBKFL=NBKFL-1 + EXIT + ENDIF + ENDIF +! yes + OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED') + READ(104,'(G16.8)') XX1 + READ(104,'(G16.8)') XX2 + READ(104,'(G16.8)') XX3 + READ(104,'(G16.8)') XX4 + READ(104,'(G16.8)') XX5 + READ(104,'(G16.8)') XX6 + CLOSE(104) + call IGrFileInfo(BFNAME(NBKFL),INFO,3) + + BFMINMAX(NBKFL,1) = XX5 + BFMINMAX(NBKFL,2) = XX6+INFO(3)*XX4 + BFMINMAX(NBKFL,3) = XX5+INFO(2)*XX1 + BFMINMAX(NBKFL,4) = XX6 + + CLOSE(104) + GO TO 125 + ENDIF + + OPEN(104,FILE=FNAME,STATUS ='OLD', FORM ='FORMATTED') + READ(104,'(4G16.8)') (BFMINMAX(NBKFL,I),I=1,4) + CLOSE(104) + 125 CONTINUE + ENDIF + + CASE (ID_ITEM24) ! Print option is selected + CALL WHardcopyOptions(3) +! +! If the user clicked OK on page setup dialog then output the contents +! of the subroutine DOPLOT to the selected printer +! + IF (WinfoDialog(ExitButtonCommon).EQ.CommonOK) THEN + CALL IGrInit('HP') ! hardcopy only output + CALL IGrFillPattern(Solid) + + CALL IgrUnits(0.,0.,HSIZE,7.5) + CALL IGrHardcopy(' ') ! Start print manager + call clscrn + CALL PLOTOT(0) ! plot graph + call rblack + CALL IGrRectangle(0.,0.,HSIZE,7.5) + + CALL IGrHardcopy('S') ! Send data to the printer + CALL IGrInit('P') ! Turn graphics back on + CALL IGrFillPattern(Solid) + + CALL IgrUnits(0.,0.,HSIZE,8.0) + CALL PLOTOT(0) + CALL HEDR + call rblack + CALL IGrRectangle(0.,0.,HSIZE,7.5) + END IF + + CASE (ID_ITEM19) ! Demo option + MENUS=-1 + IMP=0 + IIN=0 + EXIT + CASE (ID_ITEM17) ! Exit option + call rquit(iyes) + if(iyes .ne. 1) go to 100 + MENUS=0 + EXIT + CASE (ID_EXIT) ! Exit program (menu option) + call rquit(iyes) + if(iyes .ne. 1) go to 100 + MENUS=0 + EXIT + CASE (ID_NODE) + MENUS=2 + EXIT + CASE (ID_ELTS) + MENUS=1 + EXIT + CASE (ID_ORDR) + MENUS=3 + EXIT + CASE (ID_CCLN) + MENUS=6 + EXIT + CASE (ID_CSEC) + MENUS=7 + EXIT + CASE (ID_ZOOM) + MENUS=8 + EXIT + CASE (ID_DRAW) + MENUS=9 + EXIT + + CASE (ID_HELP1) + call helps(0) + go to 100 + + CASE (ID_HELP2) + call RMINFO + go to 100 + + CASE (ID_ITEM20) + CALL GDIST + CYCLE + + CASE (ID_ITEM22) + CALL SELNODE(0) + CYCLE + + CASE (ID_ALLNODES) + CALL SELNODE(1) + CYCLE + + CASE (ID_UNUSNODES) + CALL SELNODE(2) + CYCLE + + CASE (ID_ITEM23) + CALL SELELT(0) + CYCLE + END SELECT + CASE (PushButton) ! Dialog button pressed + IDBUTN = MESSAGE%VALUE1 + IDFIELD = MESSAGE%VALUE2 + CASE (MouseButDown,MouseButUp) ! Mouse button down/up + MBUTTON = MESSAGE%VALUE1 + ITIME = MESSAGE%VALUE2 + MOUSEX = MESSAGE%X + MOUSEY = MESSAGE%Y + CASE (MouseMove) ! Mouse moved + ITIME = MESSAGE%VALUE2 + MOUSEX = MESSAGE%X + MOUSEY = MESSAGE%Y + CASE (Expose) ! Window partly/wholly exposed + IX = MESSAGE%X + IY = MESSAGE%Y + IWIDTH = MESSAGE%VALUE1 + IHEIGHT = MESSAGE%VALUE2 + CASE (Resize) ! Window resized + IWIDTH = MESSAGE%VALUE1 + IHEIGHT = MESSAGE%VALUE2 + CASE (CloseRequest) ! Close window (e.g. Alt/F4) + IWINDOW = MESSAGE%WIN + call rquit(iyes) + if(iyes .ne. 1) go to 100 + menus=0 + exit +! IF (IWINDOW.EQ.0) EXIT ! Root window : exit program +! CALL WindowCloseChild(IWINDOW) + CASE (FieldChanged) ! Field change in modeless dialog + IDFIELDOLD = MESSAGE%VALUE1 + IDFIELDNEW = MESSAGE%VALUE2 + END SELECT + END DO + +500 continue + IF(MENUS .NE. 0) THEN + CALL RMAGEN(MENUS,IMP,IIN,0,IOT,IOT1,IGFG,ITRIAN,N2,M2) + ENDIF + close(90) + CALL WindowClose ! Remove program window + stop +!! CALL WindowClose ! Remove program window + END PROGRAM NEWRMAGEN + + SUBROUTINE GETSUB(FNAME,SUB) + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB + INTEGER ,EXTERNAL :: LENSTR + INTEGER :: LNNAM,K + + LNNAM=LENSTR(FNAME) + SUB=' ' + DO K=LNNAM,1,-1 + IF(FNAME(K:K) .EQ. '.') THEN + IF(LNNAM .GT. K+2) THEN + SUB=FNAME(K+1:K+3) + ELSE + SUB=' ' + ENDIF + GO TO 110 + ENDIF + ENDDO +110 CONTINUE + RETURN + END + + SUBROUTINE ADDSUB(FNAME,SUB) + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=*) :: SUB + INTEGER ,EXTERNAL :: LENSTR + INTEGER :: LNNAM,K,LMPNAM + + LNNAM=LENSTR(FNAME) + DO K=LNNAM,1,-1 + IF(FNAME(K:K) .EQ. '.') THEN + lmpnam=k + FNAME=FNAME(1:LMPNAM)//SUB + GO TO 110 + ENDIF + ENDDO + FNAME=FNAME(1:LNNAM)//'.'//SUB +110 CONTINUE + RETURN + END + + SUBROUTINE SHORTNAME(FNAMELL,FNAMES) + CHARACTER(LEN=255) :: FNAMELL + CHARACTER(LEN=48) :: FNAMES + INTEGER ,EXTERNAL :: LENSTR + INTEGER :: LNNAM,K,KSTART,KEND + + LNNAM=LENSTR(FNAMELL) + DO K=1,48 + FNAMES(K:K)=' ' + ENDDO + KSTART=1 + DO K=LNNAM,1,-1 + IF(FNAMELL(K:K) .EQ. '\') THEN + KSTART=K+1 + GO TO 200 + ENDIF + ENDDO +200 KEND=LNNAM-KSTART+1 + IF(KEND .GT. 48) KEND=48 + + FNAMES(1:KEND)=FNAMELL(KSTART:KSTART+KEND-1) + RETURN + END + \ No newline at end of file diff --git a/src/NODEDISP.F90 b/src/NODEDISP.F90 new file mode 100644 index 0000000..93582c8 --- /dev/null +++ b/src/NODEDISP.F90 @@ -0,0 +1,149 @@ + Subroutine NodeDisp(nin) + + USE WINTERACTER + USE BLK1MOD +! + include 'd.inc' +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INTEGER :: N,IBOX,NN + INTEGER :: IERR + CHARACTER*1 :: IFLAG + + if(nin .eq. 0) then + n=1 + else + n=nin + endif + ims=0 + 100 continue + call wdialogload(IDD_NODEDATA) + ierr=infoerror(1) + + CALL WDialogPutInteger(IDF_INTEGER1,N) + NN=N + XTEMP=XUSR(N) + YTEMP=YUSR(N) + WDTEMP=WIDTH(N) + CALL WDialogPutReal(IDF_REAL1,XTEMP,'(F10.2)') + CALL WDialogPutReal(IDF_REAL2,YTEMP,'(F10.2)') + CALL WDialogPutReal(IDF_REAL3,WD(N),'(F10.2)') + CALL WDialogPutReal(IDF_REAL4,WDTEMP,'(F10.2)') + CALL WDialogPutReal(IDF_REAL5,SS1(N),'(F10.2)') + CALL WDialogPutReal(IDF_REAL6,SS2(N),'(F10.2)') + CALL WDialogPutReal(IDF_REAL7,WIDS(N),'(F10.2)') + CALL WDialogPutReal(IDF_REAL8,WIDBS(N),'(F10.2)') + CALL WDialogPutReal(IDF_REAL9,SSO(N),'(F10.2)') + CALL WDialogPutReal(IDF_REAL10,BS1(N),'(F10.4)') + IF(LOCK(N) .NE. 0) then + CALL WDialogPutCheckBox(IDF_CHECK1,1) + ELSE + CALL WDialogPutCheckBox(IDF_CHECK1,0) + ENDIF + + CALL WDialogSelect(IDD_NODEDATA) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modeless) + ierr=infoerror(1) + + if(ims .eq. 1 .or. nin .gt. 0) go to 200 + 150 CONTINUE + call wdialogload(IDD_SELNODE) + ierr=infoerror(1) + + CALL WDialogPutInteger(IDF_INTEGER1,N) + + CALL WDialogSelect(IDD_SELNODE) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,ModaL) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + ims=1 + go to 100 + endif +!ipk sep02 + ims=1 + go to 100 + enddo + + 200 continue +! CALL WDialogSelect(IDD_NODEDATA) +! ierr=infoerror(1) +! Branch depending on type of message. +! +! CALL WDialogGetInteger(IDF_INTEGER1,N) +! WRITE(90,*) 'IN NODEDISP N,NN', N,NN +! IF(N .NE. NN) go to 100 + + DO +!WHILE(.NOT.QUIT) + CALL WMessage(ITYPE,MESSAGE) + SELECT CASE (ITYPE) + CASE (PushButton) + IF(MESSAGE%VALUE1.EQ.IDOK) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + CALL WDialogGetReal(IDF_REAL1,XTEMP) + CALL WDialogGetReal(IDF_REAL2,YTEMP) + XUSR(N)=XTEMP + YUSR(N)=YTEMP + CALL WDialogGetReal(IDF_REAL3,WD(N)) + CALL WDialogGetReal(IDF_REAL4,WDTEMP) + CALL WDialogGetReal(IDF_REAL5,SS1(N)) + CALL WDialogGetReal(IDF_REAL6,SS2(N)) + CALL WDialogGetReal(IDF_REAL7,WIDS(N)) + CALL WDialogGetReal(IDF_REAL8,WIDBS(N)) + CALL WDialogGetReal(IDF_REAL9,SSO(N)) + CALL WDialogGetReal(IDF_REAL10,BS1(N)) + CORD(N,1)=(XUSR(N)+XS)/TXSCAL + CORD(N,2)=(YUSR(N)+YS)/TXSCAL + call WDialogHide() + call wdialogUNload() + WIDTH(N)=WDTEMP + RETURN + ELSEIF(MESSAGE%VALUE1.EQ.IDNEXT) THEN + CALL WDialogGetInteger(IDF_INTEGER1,N) + CALL WDialogGetReal(IDF_REAL1,XTEMP) + CALL WDialogGetReal(IDF_REAL2,YTEMP) + XUSR(N)=XTEMP + YUSR(N)=YTEMP + CALL WDialogGetReal(IDF_REAL3,WD(N)) + CALL WDialogGetReal(IDF_REAL4,WDTEMP) + CALL WDialogGetReal(IDF_REAL5,SS1(N)) + CALL WDialogGetReal(IDF_REAL6,SS2(N)) + CALL WDialogGetReal(IDF_REAL7,WIDS(N)) + CALL WDialogGetReal(IDF_REAL8,WIDBS(N)) + CALL WDialogGetReal(IDF_REAL9,SSO(N)) + CALL WDialogGetReal(IDF_REAL10,BS1(N)) + CORD(N,1)=(XUSR(N)+XS)/TXSCAL + CORD(N,2)=(YUSR(N)+YS)/TXSCAL + WIDTH(N)=WDTEMP + GO TO 150 + ELSEIF(MESSAGE%VALUE1.EQ.IDCANCEL) THEN + call WDialogHide() + call wdialogUNload() + RETURN + ENDIF + END SELECT + END DO + + + + RETURN + END + + \ No newline at end of file diff --git a/src/NODES.F90 b/src/NODES.F90 new file mode 100644 index 0000000..7335da5 --- /dev/null +++ b/src/NODES.F90 @@ -0,0 +1,911 @@ +!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR CHNAGED ELEMENTS/NODES +! Last change: IPK 13 Jan 98 10:01 am +!ipk last update to add deletion opton when moving nodes +!ipk last update Jan 12 1998 +!ipk last update Nov18 1997 +! +!**************************************************************** +! + SUBROUTINE ADDNOD +! +! Input additional node locations from screen +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +!IPK MAY02 + INCLUDE 'TXFRM.COM' +! + CHARACTER*1 IFLAG,ANS,ANSW(0:9) + CHARACTER*32 JUNK + CHARACTER*20 NODH +!ipk jan98 + CHARACTER*80 LIND + DATA ANSW/'a','m','d','f','g','e','h','z','r','q'/ + data itime/0/ + + if(itime .eq. 0) then + nodsh=1 + itime=1 + endif + ISWT=3 +! +! Draw box around selections +! + 2 CONTINUE + NHTP=4 + NMESS=0 + NBRR=0 + CALL HEDR +! +! Get answer +! + 3 call xyloc(XPT,YPT,ANS,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + + IF(ANS .EQ. 'c') THEN + if(ibox .eq. 0) go to 3 + I=IBOX-1 + ANS=ANSW(I) + ENDIF +! + IF(ANS .EQ. 'a') THEN + ISWT=1 + NHTP=0 + NBRR=0 + NMESS=16 + ELSEIF(ANS .EQ. 'm') THEN + ISWT=0 + NHTP=0 + NBRR=0 + NMESS=17 + ELSEIF(ANS .EQ. 'd') THEN +! +! Call deleting operations +! + CALL DELOP + IF(IRMAIN .EQ. 1) RETURN + GO TO 2 + ELSEIF(ANS .EQ. 'e') THEN + CALL GRIDSB(0) + IF(IRMAIN .EQ. 1) RETURN + GO TO 2 + ELSEIF(ANS .EQ. 'q') THEN + RETURN + ELSEIF(ANS .EQ. 'f') THEN +! +! Search for a plot a grid centered around a node +! + NHTP=0 + NBRR=0 + NMESS=1 + CALL HEDR + NMESS=1 + CALL GETINT(NODSH) + IF(INEW(NODSH) .LE. 0) GO TO 2 + DO 4 I=1,NP + IF(CORD(I,1) .GT. VOID) THEN + INSKP(I)=0 + ENDIF + 4 CONTINUE + DO 5 I=1,NE + IF(IMAT(I) .GT. 0) THEN + IESKP(I)=0 + ENDIF + 5 CONTINUE + XP=CORD(NODSH,1) + YP=CORD(NODSH,2) + XMIN=XP-5.0*PSCALE + YMIN=YP-3.5*PSCALE +!ipk nov97 add (1) + CALL PLOTOT(1) + FPN=NODSH + HT=0.15 + XP=CORD(NODSH,1) + YP=CORD(NODSH,2) + CALL RCYAN + CALL NUMBR(XP,YP+0.07,HT,FPN,0.0,-1) + CALL RBLUE +! + GO TO 2 + ELSEIF(ANS .EQ. 'g') THEN +! +! This option generates nodes on a line +! + CALL GNODE(1) + IF(IRMAIN .EQ. 1) RETURN + GO TO 2 + ELSEIF(ANS .EQ. 'h') THEN + CALL HELPS(3) + IF(IRMAIN .EQ. 1) RETURN + GO TO 2 + ELSE + GO TO 3 + ENDIF + 6 CONTINUE +! +! Test for adding operation +! + IF(ISWT .EQ. 1) THEN +! + CALL GETNOD(J) + CALL GETNOD(J) + CALL GETNOD(J) + IF(IRMAIN .EQ. 1) RETURN +! +! Get number of node nearest cursor (if ISWT = 0) +! + ELSE + 61 IBOX=1 +! CALL CLRBOX + CALL HEDR +!ipk jan98 + call wrtbox(idelv) + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +!ipk jan98 add option for deleting elevation on move + IF(IBOX .EQ. 7 .or. iflag .eq. 'e') THEN + IDELV=MOD(IDELV+1,2) + GO TO 61 + ENDIF + J=INODE +!ipk jan98 + if(idelv .eq. 1) then + WD(J)=-9999. + WIDTH(J)=0. + SS1(J)=0. + SS2(J)=0. + WIDS(J)=0. + WIDBS(J)=0. + SSO(J)=0. + endif +!ipk jan98 +! + IF(IFLAG .EQ. 'q') THEN +!ipk feb94 CALL WRTOUT(0) + GO TO 2 + ENDIF + CALL PLTNOD(J,1) +! + ENDIF +! +! Deleting operation +! + IF(ISWT .EQ. 2) THEN + WRITE(NODH,5000) j +! CALL CLRBOX + CALL HEDR + CALL SYMBL(0.,7.70,0.20,NODH,0.,20) + CALL DELETN(J) + GO TO 6 + ENDIF + WRITE(NODH,5000) j + 5000 FORMAT('Processing node',i5) + 7 CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,NODH,0.,20) + NHTP=0 +! NMESS=0 + NBRR=3 + IF(ISWT .EQ. 0) then + NMESS=16 + endif + CALL HEDR +! + IF (J .GE. MAXP) THEN + CALL SETD(23) +!IPK JAN98 WRITE(*,*) ' Node number exceeds MAXP ' +!IPK JAN98 WRITE(*,*) ' Enter -save- to save the file as is' +!IPK JAN98 WRITE(*,*) ' Enter -quit- to terminate' +!IPK JAN98 READ(*,'(A)') JUNK + CALL CLSCRN() + WRITE(LIND,*) ' Node number exceeds MAXP ' + call symbl & + & (1.1,4.6,0.25,LIND,0.0,80) + WRITE(LIND,*) ' Enter -save- to save the file as is' + call symbl & + & (1.1,4.1,0.25,LIND,0.0,80) + WRITE(LIND,*) ' Enter -quit- to terminate' + call symbl & + & (1.1,3.8,0.25,LIND,0.0,80) + ndig=4 + CALL GTCHARX(JUNK,NDIG,5.0,4.0) + IF(JUNK .NE. 'save') THEN + CALL WRTOUT(0) + CALL Quit_Pgm() + stop + else + call wrtout(1) + CALL Quit_Pgm() + stop + ENDIF +!ipk an97 RETURN + ENDIF +! +! Get screen coordinate of node +! + CALL XYLOC(XX,YY,IFLAG,IBOX) + IF(IRMAIN .EQ. 1) RETURN + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN +!ipk feb94 CALL WRTOUT(0) +! IF(ISWT .EQ. 2) NP=NP-1 + if(inew(j) .eq. 0 .and. j .eq. np) np=np-1 + GO TO 2 + ENDIF +! + IF (IFLAG .EQ. 'c') THEN +! + IF(YY .GT. 7.5) THEN + CALL DELETN(J) + GO TO 6 + ENDIF + INSKP(J)=0 + CORD(J,1) = XX + CORD(J,2) = YY + INEW(J) = 1 +! + XUSR(J) = XX*TXSCAL - XS + YUSR(J) = YY*TXSCAL - YS + IF (J .GT. NP) NP = J +! WRITE(IOT,'(I10,2F10.3)') J, XUSR(J),YUSR(J) + CALL PLTNOD(J,0) + ICHG=0 +! + IF(ISWT .EQ. 0) NMESS=17 + GOTO 6 + ENDIF + RETURN +! + END +! +!**************************************************************** +! + SUBROUTINE ADDPTH +! +! Add nodal bottom elevations +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + CHARACTER*1 IFLAG,ANSW(10) + DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/ + DATA NTYPP,NLOCC,BELEV/1,0,0./ +! + 4 CONTINUE + NHTP = 0 + NMESS = 45 + NBRR = 0 + CALL HEDR + xprt=3.2 + NMESS = 14 +! + CALL ADJUSTOPT(NTYPP,NLOCC) + + CALL GETFPN(BELEV) +! +! Write out current depths +! + 7 HT = .15 + DO 10 J=1,NP + IF(INSKP(J) .EQ. 0) THEN + IF (CORD(J,1) .GT. VDX) THEN +!!SEP02 FPN = WD(J)*10. + FPN = WD(J) + X = CORD(J,1) + Y = CORD(J,2) + .07 + IF(X .GT. 0. .AND. X .LT. 10.0 .AND. & + & Y .GT. 0. .AND. Y .LT. 7.5) THEN +!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1) + call numbr(x,y,0.12,fpn,0.0,1) + ENDIF + ENDIF + ENDIF + 10 END DO +! +! Input new depths +! + NMESS = 15 + NBRR = 4 + CALL HEDR + 5 IBOX=1 + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF +! + IF(IFLAG .EQ. 'q') THEN +!ipk feb94 CALL WRTOUT(0) + RETURN + ELSEIF(IFLAG .EQ. 'e' .OR. IFLAG .EQ. 'n') THEN +!ipk nov97 add (1) + CALL PLOTOT(1) + GO TO 4 + ENDIF + XPRT=XPRT+0.5 + IF(XPRT .GT. 10.) XPRT=0. + FPN= INODE + CALL RRED + CALL NUMBR(XPRT,7.70,HT,FPN,0.0,-1) + IF (IFLAG .EQ. 'c') THEN + IF(NTYPP .EQ. 1) THEN + WD(INODE) = BELEV + ELSE + WD(INODE) = WD(INODE)+BELEV + ENDIF + IF(NLOCC .EQ. 1) THEN + LOCK(INODE)=1 + ENDIF + ichg=0 + FPN = WD(INODE) + X = CORD(INODE,1) + Y = CORD(INODE,2) -0.10 + call numbr(x,y,0.12,fpn,0.0,1) +!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1) + CALL RBLUE +! + ELSEIF(IFLAG .EQ. 'a') THEN + CALL RRED + ichg=0 + DO 100 J=1,NP + IF (CORD(J,1) .GE. VDX) THEN + WD(J)=BELEV + FPN=BELEV + X = CORD(J,1) + Y = CORD(J,2) + .11 + CALL NUMBR(X,Y,HT,FPN,0.0,-1) + ENDIF + 100 CONTINUE + CALL RBLUE + CALL WRTOUT(0) + ELSEIF(IFLAG .EQ. 'f') THEN + CALL RRED + DO 110 J=1,NP + IF (CORD(J,1) .GE. VDX .AND. WD(J) .LT. -9000.) THEN + WD(J)=BELEV + ichg=0 + FPN=BELEV + X = CORD(J,1) + Y = CORD(J,2) + .11 + CALL NUMBR(X,Y,HT,FPN,0.0,-1) + ENDIF + 110 CONTINUE + CALL RBLUE + CALL WRTOUT(0) +! + ELSE +!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7) + ENDIF +! + GOTO 5 +! + END +! + SUBROUTINE JUNGEN(J,I,IERR) +! +! Find elements coming into node J, change all but first node +! Form a new junction element +! +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +!IPK MAY02 + INCLUDE 'TXFRM.COM' + +! + KOUNT=1 + DO 200 N=1,NE +!IPKOCT93 IF(IMAT(N) .GT. 0 .AND. IMAT(N) .LT. 901) THEN + IF(IMAT(N) .GT. 0 .AND. (IMAT(N) .LT. 901 .OR. & + & IMAT(N) .GT. 903) ) THEN + DO 180 K=1,8 + IF(NOP(N,K) .EQ. I) THEN + IF(K .GT. 3) THEN + IERR=1 + RETURN + ENDIF + IF(KOUNT .EQ. 1) THEN + NOP(J,1)=I + IJUN(J)=1 + KOUNT=2 + ELSE + CALL GETNOD(N2) + NOP(J,KOUNT)=N2 + IJUN(N2)=KOUNT + KOUNT=KOUNT+1 + CORD(N2,1) = CORD(I,1) + CORD(N2,2) = CORD(I,2) + WD(N2)=WD(I) + WIDTH(N2) = WIDTH(I) + SS1(N2)=SS1(I) + SS2(N2)=SS2(I) + WIDS(N2)=WIDS(I) + INSKP(N2)=0 + INEW(N2) = 1 + NOP(N,K) = N2 +! + XUSR(N2) = CORD(N2,1)*TXSCAL - XS + YUSR(N2) = CORD(N2,2)*TXSCAL - YS + CALL PLTNOD(N2,1) + GO TO 200 + ENDIF + ENDIF + 180 CONTINUE + ENDIF + 200 END DO + IF(KOUNT .LT. 9) THEN + DO 300 K=KOUNT,8 + NOP(J,K)=0 + 300 CONTINUE + ENDIF + IMAT(J)=901 + IESKP(J)=1 + RETURN + END +! +!**************************************************************** +! + SUBROUTINE ELDAT +! +! Add bottom elevations to message file and display +! + USE BLKMAP + USE BLK1MOD + USE WINTERACTER + + include 'd.inc' + +! INCLUDE 'BLK1.COM' + +!IPK MAY02 + INCLUDE 'TXFRM.COM' +! + CHARACTER*1 IFLAG,ANSW(10) + CHARACTER(LEN=256) :: FILTER + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB + LOGICAL :: OPENED + DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/ +! +!ipk mar00 + jp=2 + DO 200 N=1,MAXLIN + IF(LINTYP(N) .EQ. -999) THEN + NLIN=N + GO TO 205 + ENDIF + 200 END DO + 205 CONTINUE + IF(NLIN .GT. 1) THEN + IF(LINTYP(NLIN-1) .NE. 2) THEN + LINTYP(NLIN)=2 + ELSE + NLIN=NLIN-1 + ENDIF + ENDIF + DO 250 J=MAXPL,1,-1 + IF(CMAP(J,1) .GE. VDX) THEN + JP=J+1 + GO TO 255 + ENDIF + 250 END DO + 255 JP=JP-1 + IPSW(6)=1 +!ipk nov97 add (1) + CALL PLOTOT(1) + write(90,6010) + 6010 format(' The lines that follow are locations and new bottom ' & + & ,'elevations.'/' Note that a zoom operation may insert'& + & ,' other information') +! + 4 CONTINUE + NHTP = 0 + NMESS = 45 + NBRR = 0 + CALL HEDR +! + NMESS = 14 + CALL GETFPN(BELEV) +! +! Input new depths +! + 7 CONTINUE + NMESS = 15 + NBRR = 4 + CALL HEDR +! +! Get screen coordinates +! + IBOX = 0 + CALL XYLOC(XX,YY,IFLAG,IBOX) + IF(IRMAIN .EQ. 1) RETURN + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF + IF(IFLAG .EQ. 'q')THEN + RETURN + ENDIF + IF(IFLAG .EQ. 'e') THEN + RETURN + ENDIF + IF(IFLAG .EQ. 'n')THEN + GO TO 4 + ENDIF +! + IF (IFLAG .EQ. 'c') THEN +! + JP=JP+1 + CMAP(JP,1) = XX + CMAP(JP,2) = YY + VAL(JP)=BELEV +! + XMAP(JP) = XX*TXSCAL - XS + YMAP(JP) = YY*TXSCAL - YS + IMAPOUT=27 + INQUIRE(27, OPENED=OPENED) + if(.not. opened) then + Filter='MAP file -- *.map|*.map|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Map Data File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(IMAPOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') + WRITE(IMAPOUT,*) '2,0' + ELSE + GO TO 260 + ENDIF + ENDIF + WRITE(IMAPOUT,6000) XMAP(JP),YMAP(JP),VAL(JP) + 260 CONTINUE + WRITE(90,6000) XMAP(JP),YMAP(JP),VAL(JP) + 6000 FORMAT(3F16.4) + FPN = BELEV + HT=0.15 + CALL RRED + CALL NUMBR(XX,YY,HT,FPN,0.0,-1) +! + GOTO 7 +! + ELSE +!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7) + ENDIF +! + GOTO 7 +! + END +! + SUBROUTINE DELOP +! +! Input additional delete options from screen +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +!IPK MAY02 + INCLUDE 'TXFRM.COM' + + INCLUDE 'BFILES.I90' + +! + CHARACTER*1 IFLAG,ANS,ANSW(0:9) + CHARACTER*20 NODH + DATA ANSW/'l','m','g','u','f','j','h','z','r','q'/ +! +! Draw box around selections +! + 2 CONTINUE + NHTP=10 + NMESS=0 + NBRR=0 + CALL HEDR +! +! Get answer +! + 3 call xyloc(XPT,YPT,ANS,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF(ANS .EQ. 'c') THEN + if(ibox .eq. 0) go to 3 + I=IBOX-1 + ANS=ANSW(I) + ENDIF + IF(ANS .EQ. 'l') THEN +! +! Delete all midside nodes +! + CALL DELETM(0) + ELSEIF(ANS .EQ. 'm') THEN +! +! Delete all center located midsides +! + CALL DELETM(1) + ELSEIF(ANS .EQ. 'g') THEN +! +! Deleting operation for nodes +! + NHTP=0 + NBRR=3 + NMESS=18 + + 6 CONTINUE +! + IBOX=1 + CALL HEDR + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN + J=INODE +! + IF(IFLAG .EQ. 'q') THEN +!ipk feb94 CALL WRTOUT(0) + GO TO 2 + ENDIF + CALL PLTNOD(J,1) +! + WRITE(NODH,5000) j + 5000 FORMAT('Processing node',i5) + CALL HEDR + CALL SYMBL(0.,7.70,0.20,NODH,0.,20) + CALL DELETN(J) + IRDONE=0 + GO TO 6 + ELSEIF(ANS .EQ. 'u') THEN +! +! Delete all unused nodes +! + CALL DELETM(2) + ELSEIF(ANS .EQ. 'j') THEN +! +! Join two nodes together in the element lists +! + CALL JOIN(1) + ELSEIF(ANS .EQ. 'f') THEN +! +! Fill midside nodes +! +!ipk aug02 + CALL FILM(0) + ELSEIF(ANS .EQ. 'h') THEN + CALL HELPS(7) + ELSEIF(ANS .EQ. 'q') THEN + RETURN + ENDIF + GO TO 2 + END +! + SUBROUTINE JOIN(ISWTJ) +! +! Routine to join references to two nodes +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*1 IFLAG +! + 61 IBOX=1 + NHTP=0 + NBRR=3 + NMESS=15 + CALL HEDR + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX) + IF(IFLAG .EQ. 'q') THEN + RETURN + ENDIF + FPN= INODE + CALL NUMBR(2.0,7.70,0.2,FPN,0.0,-1) +! CALL PROX(CORD(1,1),CORD(1,2),NP,XX2,YY2,INODE2,IFLAG,INSKP,IBOX) +! IF(IFLAG .EQ. 'q') THEN +! RETURN +! ELSEIF(INODE2 .EQ. INODE) THEN +! +! Get second node +! + CALL PROX2(CORD(1,1),CORD(1,2),NP,XX,YY,INODE, & + & XX2,YY2,INODE2,IFLAG,INSKP,IBOX) + IF(IFLAG .EQ. 'q') THEN + RETURN + ENDIF +! ENDIF +! FPN= INODE2 +! CALL NUMBR(2.5,7.70,0.2,FPN,0.0,-1) + + INODE1=INODE + CALL JOINDEL(INODE1,INODE2) + + CALL PLOTOT(1) + GO TO 61 +! ENDIF + END + + SUBROUTINE JOINDEL(INODE1,INODE2) +! Routine to join references to two nodes +! + USE BLK1MOD +! +! Search for references to INODE2 +! + DO N=1,NE + NCN=NCORN(N) + IF(NCN .GT. 0) THEN + DO M=1,NCN + IF(NOP(N,M) .EQ. INODE2) THEN +! +! Change them to INODE +! + NOP(N,M)=INODE1 + ENDIF + ENDDO + ENDIF + ENDDO +! +! Remove node now +! + CORD(INODE2,1)=VOID + CORD(INODE2,2)=VOID + XUSR(INODE2) = VOID + YUSR(INODE2) = VOID + INSKP(INODE2)=1 + INEW(INODE2) = 0 + WD(INODE2)=-9999. + WIDTH(INODE2)=0. + SS1(INODE2)=0. + SS2(INODE2)=0. + WIDS(INODE2)=0. +!IPK MAY03 + ICHG=0 +!ipk nov97 add (1) + RETURN + END + + SUBROUTINE JOINALL + USE BLK1MOD + + NMESS = 46 + TOLER=0.1 + CALL GETFPN(TOLER) + + DO N=1,NP-1 + IF(CORD(N,1) .EQ. VOID) CYCLE + DO M=N+1,NP + IF(CORD(M,1) .EQ. VOID) CYCLE + DIST=SQRT((YUSR(M)-YUSR(N))**2+(XUSR(M)-XUSR(N))**2) + IF(DIST .LT. TOLER) THEN + CALL JOINDEL(N,M) + GO TO 100 + ENDIF + ENDDO + 100 CONTINUE + ENDDO + + CALL PLOTOT(1) + RETURN + END +!**************************************************************** +! + SUBROUTINE ADDPTH2(nodlist,ndlist) +! +! Add nodal bottom elevations +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + CHARACTER*1 IFLAG,ANSW(10) + + dimension nodlist(*) + + DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/ + DATA NTYPP,NLOCC/1,0/ +! + 4 CONTINUE + NHTP = 0 + NMESS = 45 + NBRR = 0 + CALL HEDR + xprt=3.2 + NMESS = 14 +! + CALL ADJUSTOPT(NTYPP,NLOCC) + + CALL GETFPN(BELEV) +! +! Write out current depths +! + 7 HT = .15 + DO 10 J=1,NP + IF(INSKP(J) .EQ. 0) THEN + IF (CORD(J,1) .GT. VDX) THEN +!!SEP02 FPN = WD(J)*10. + FPN = WD(J) + X = CORD(J,1) + Y = CORD(J,2) + .07 + IF(X .GT. 0. .AND. X .LT. HSIZE .AND. & + & Y .GT. 0. .AND. Y .LT. 7.5) THEN +!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1) + call numbr(x,y,0.12,fpn,0.0,1) + ENDIF + ENDIF + ENDIF + 10 END DO +! +! Input new depths +! + DO J=1,NDLIST + INODE=NODLIST(J) + FPN= INODE + CALL RRED + + IF(NTYPP .EQ. 1) THEN + WD(INODE) = BELEV + ELSE + WD(INODE) = WD(INODE)+BELEV + ENDIF + IF(NLOCC .EQ. 1) THEN + LOCK(INODE)=1 + ENDIF + ichg=0 + FPN = WD(INODE) + X = CORD(INODE,1) + Y = CORD(INODE,2) -0.10 + call numbr(x,y,0.12,fpn,0.0,1) +!!SEP02 CALL NUMBR(X,Y,HT,FPN,0.0,-1) + CALL RBLUE + ENDDO +! +! + RETURN +! + END +! + SUBROUTINE FINDNOD +! +! Search for a plot a grid centered around a node +! +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +!IPK MAY02 + INCLUDE 'TXFRM.COM' +! + NHTPSAV=NHTP + NMESSAV=NMESS + NBRRSAV=NBRR + NHTP=0 + NBRR=0 + NMESS=1 + CALL HEDR + NMESS=1 + CALL GETINT(NODSH) + IF(INEW(NODSH) .LE. 0) RETURN + DO 4 I=1,NP + IF(CORD(I,1) .GT. VOID) THEN + INSKP(I)=0 + ENDIF + 4 CONTINUE + DO 5 I=1,NE + IF(IMAT(I) .GT. 0) THEN + IESKP(I)=0 + ENDIF + 5 CONTINUE + XP=CORD(NODSH,1) + YP=CORD(NODSH,2) + XMIN=XP-5.0*PSCALE + YMIN=YP-3.5*PSCALE +!ipk nov97 add (1) + CALL PLOTOT(1) + FPN=NODSH + HT=0.15 + XP=CORD(NODSH,1) + YP=CORD(NODSH,2) + CALL RCYAN + CALL NUMBR(XP,YP+0.07,HT,FPN,0.0,-1) + CALL RBLUE + NHTP=NHTPSAV + NMESS=NMESSAV + NBRR=NBRRSAV + CALL HEDR +! + RETURN + END \ No newline at end of file diff --git a/src/OK.ICO b/src/OK.ICO new file mode 100644 index 0000000..e95f890 Binary files /dev/null and b/src/OK.ICO differ diff --git a/src/OUTLINES.F90 b/src/OUTLINES.F90 new file mode 100644 index 0000000..8dfe87e --- /dev/null +++ b/src/OUTLINES.F90 @@ -0,0 +1,191 @@ + SUBROUTINE OUTLINES + + USE WINTERACTER + USE BLK1MOD + include 'd.inc' +! INCLUDE 'BLK1.COM' + +! INTEGER*2 MSN +! COMMON /MID/ MSN(MAXP) + + CHARACTER(LEN=255) :: FNAME,FILTER + CHARACTER(LEN=4) :: SUB + LOGICAL OPENED + CHARACTER*1 IFLAG,ANS(10) + DATA ANS/' ',' ',' ',' ',' ',' ','n','z','r','q'/ + + IF(.NOT. ALLOCATED(ICONNCT)) THEN + ALLOCATE (ICONNCT(MAXP,2),IOUTLST(10,5000),NOUTLST(10)) + ENDIF + IF(.NOT. ALLOCATED(XOUT)) THEN + ALLOCATE (XOUT(5000,10),YOUT(5000,10)) + ENDIF + + IOUTOUT=26 + INQUIRE(26, OPENED=OPENED) + if(.not. opened) then + Filter='OUTLINE file -- *.dat|*.dat|POLY file -- *.poly|*.poly|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Outline File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(IOUTOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') + ELSE + GO TO 1 + ENDIF + ENDIF + + 1 CONTINUE + + call wdialogload(IDD_DIALOG08) + ierr=infoerror(1) + + + call wdialogputRadioButton(idf_radio1) + + + CALL WDialogSelect(IDD_DIALOG08) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,ipos) + ipos=3-ipos + go to 50 + endif + ipos= 0 + go to 50 + enddo + ipos= 2 + 50 continue + IF(SUB(1:3) .EQ. 'dat') THEN + IOUTSW=0 + ELSE + IOUTSW=1 + ENDIF +! +! FORM LIST OF ELEMENT SIDES THAT ARE ON THE OUTSIDE + + DO N=1,NP + MSN(N)=0 + ENDDO + DO N=1,NE + IF(IMAT(N) .NE. 999 .AND. NCORN(N) .GT. 5 .AND. (IMAT(N) .LT. 900 .OR. IMAT(N) .GT. 903)) THEN + NCN=NCORN(N) + DO K=2,NCN,2 + J = NOP(N,K) + if(J .gt. 0) then + MSN(J) = MSN(J) + 1 + ICONNCT(J,1)=NOP(N,K-1) + IF(K .EQ. NCN) THEN + ICONNCT(J,2)=NOP(N,1) + ELSE + ICONNCT(J,2)=NOP(N,K+1) + ENDIF + endif + ENDDO + ENDIF + ENDDO + +! WORK THROUGH OUTSIDE NODES FORMING UP TO 10 CONTIUOUS SEQUENCES + + DO K=1,10 + JJ=0 + DO J=1,NP + IF(MSN(J) .EQ. 1) THEN +! +! THIS IS A STARTING POINT EXTRACT A CORNER NODE + IOUTLST(K,1)=ICONNCT(J,1) + if(ipos .eq. 1) then + IOUTLST(K,2)=ICONNCT(J,2) + JJ=2 + else + IOUTLST(K,2)=J + IOUTLST(K,3)=ICONNCT(J,2) + JJ=3 + endif + MSN(J)=0 + ICONNCT(J,1)=0 + ICONNCT(J,2)=0 + +! NOW LOOK FOR A CONNECTION TO ICONNCT(J,2) + + 100 CONTINUE + DO L=1,NP + IF(MSN(L) .EQ. 1) THEN + IF(ICONNCT(L,1) .EQ. IOUTLST(K,JJ)) THEN + +! FOUND ONE + + if(ipos .eq. 2) then + IOUTLST(K,JJ+1)=ICONNCT(L,2) + JJ=JJ+1 + else + IOUTLST(K,JJ+1)=L + IOUTLST(K,JJ+2)=ICONNCT(L,2) + JJ=JJ+2 + endif + MSN(L)=0 + ICONNCT(L,1)=0 + JTEMP=ICONNCT(L,2) + ICONNCT(L,2)=0 + IF(JTEMP .EQ. IOUTLST(K,1)) GO TO 200 + GO TO 100 + ELSEIF(ICONNCT(L,2) .EQ. IOUTLST(K,JJ)) THEN + +! FOUND ONE THE OPPOSITE WAY + + IOUTLST(K,JJ+1)=L + IOUTLST(K,JJ+2)=ICONNCT(L,1) + JJ=JJ+2 + MSN(L)=0 + JTEMP=ICONNCT(L,1) + ICONNCT(L,1)=0 + ICONNCT(L,2)=0 + IF(JTEMP .EQ. IOUTLST(K,1)) GO TO 200 + GO TO 100 + ENDIF + + ENDIF + ENDDO + ENDIF + ENDDO + GO TO 300 + 200 CONTINUE + NOUTLST(K)=JJ + IF(JJ .GT. 0) THEN + IF(IOUTSW .EQ. 1) THEN + NDIM=2 + NZERO=0 + NONE=1 + WRITE(IOUTOUT,*)NOUTLST(K)-1,NDIM,NZERO,NZERO + DO L=1,NOUTLST(K)-1 + WRITE(IOUTOUT,*) L,XUSR(IOUTLST(K,L)),YUSR(IOUTLST(K,L)) + ENDDO + WRITE(IOUTOUT,*) NOUTLST(K)-1,NZERO + DO I=1,NOUTLST(K)-2 + WRITE(IOUTOUT,*) I,I,I+1 + ENDDO + WRITE(IOUTOUT,*) NOUTLST(K)-1,NOUTLST(K)-1,NONE + + WRITE(IOUTOUT,*) NZERO + ELSE + DO L=1,NOUTLST(K) + XOUT(L,K)=XUSR(IOUTLST(K,L)) + YOUT(L,K)=YUSR(IOUTLST(K,L)) + WRITE(IOUTOUT,*) XOUT(L,K),YOUT(L,K) + ENDDO + ENDIF + ENDIF + ENDDO + 300 CONTINUE + RETURN + END \ No newline at end of file diff --git a/src/PARAM.COM b/src/PARAM.COM new file mode 100644 index 0000000..1374108 --- /dev/null +++ b/src/PARAM.COM @@ -0,0 +1,65 @@ +!IPK LAST UPDATED JULY 17 1998 +!ipk last update Dec 10 1997 +!IPK LAST UPDATED OCT 18 1996 +! + SAVE +! +! This version is compiled for: LARGE +! MAXE = maximum number of elements = 200000 +! MAXP = maximum number of nodes =400000 +! MAXPL = maximum number of map data points =1800000 +! MAXLIN = maximum number of map lines = 3000 +! MAXLN = maximum number of reordering lines = 20 +! MAELN = maximum number of elements in a reodering list = 300 +! MAXPGEN= maximum number elements in a genreated block = 2000 +! MAXGRD = maximum number of grid points = 3000 +! +! +! +! PARAMETER (MAXE= 200000,MAXP=400000,MAXLIN=6000,MAXECON=60) +! PARAMETER (MAXLN=20,MAELN=300,MAXPGEN=2000,MAXGRD=3000,MAXSTO=2) +! PARAMETER (MAXE8=8*MAXE,MAXP2=2*MAXP) + +! This version is compiled for: MEDIUM +! MAXE = maximum number of elements =130000 +! MAXP = maximum number of nodes =200000 +! MAXPL = maximum number of map data points =1500000 +! MAXLIN = maximum number of map lines = 3000 +! MAXLN = maximum number of reordering lines = 20 +! MAELN = maximum number of elements in a reodering list = 300 +! MAXPGEN= maximum number elements in a genreated block = 2000 +! MAXGRD = maximum number of grid points = 1000 +! MAXSTO = maximum storage locations = 2 +! +! + PARAMETER (MAXPGEN=20000,MAXGRD=1000) +! PARAMETER (MAXE8=8*MAXE,MAXP2=2*MAXP) + PARAMETER (MCRS=1000,MPTS=75) + +! This version is compiled for: STANDARD +! MAXE = maximum number of elements = 40000 +! MAXP = maximum number of nodes = 50000 +! MAXPL = maximum number of map data points = 200000 +! MAXLIN = maximum number of map lines = 3000 +! MAXLN = maximum number of reordering lines = 20 +! MAELN = maximum number of elements in a reodering list = 300 +! MAXPGEN= maximum number elements in a genreated block = 2000 +! MAXGRD = maximum number of grid points = 300 +! MAXSTO = maximum storage locations = 2 +! +! +! PARAMETER (MAXE= 40000,MAXP=50000,MAXLIN=6000,MAXECON=60) +! PARAMETER (MAXLN=20,MAELN=300,MAXPGEN=2000,MAXGRD=3000,MAXSTO=2) +! PARAMETER (MCRS=600,MPTS=50) +! PARAMETER (MAXE8=8*MAXE,MAXP2=2*MAXP) + +! +! CORD is the screen scale variable +! XUSR is the map scale variable +! To get to CORD from XUSR use +! CORD(N,1)=(XUSR(N)+XS)/TXSCAL +! To get to XUSR from CORD use +! XUSR(N2) = CORD(N2,1)*TXSCAL - XS +! XS,YS and TXSCAL are kept in TXFRM.COM +! REAL*8 XS,YS,TXSCAL +! COMMON /TXFRM/ XS, YS, TXSCAL \ No newline at end of file diff --git a/src/PLOTORDS.F90 b/src/PLOTORDS.F90 new file mode 100644 index 0000000..049dbd0 --- /dev/null +++ b/src/PLOTORDS.F90 @@ -0,0 +1,41 @@ + SUBROUTINE PLOTORDS + + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + + NLSTP=NLST+1 + call getxc + DO N=1,NLSTP + FPN=N + DO M=1,NE + +! Get element in list + + IF(N .LT. NLSTP) THEN + J=ILIST(N,M) + ELSE + J=ilisttmp(M) + ENDIF +! IF(IMAT(J) .EQ. 0) THEN +! ENDIF + + IF(J .GT. 0) THEN + IF(XC(J) .GT. 0. .AND. XC(J) .LT. HSIZE) THEN + IF(YC(J) .GT. 0. .AND. YC(J) .LT. 7.5) THEN + xxc=xc(j) + yyc=yc(j) + CALL NUMBR(XXC,YYC,0.15,FPN,0.0,-1) + ENDIF + ENDIF + ELSE + GO TO 300 + ENDIF + + ENDDO + 300 CONTINUE + ENDDO + + RETURN + END \ No newline at end of file diff --git a/src/PLOTR.F90 b/src/PLOTR.F90 new file mode 100644 index 0000000..8628043 --- /dev/null +++ b/src/PLOTR.F90 @@ -0,0 +1,176 @@ +!ipk last change July 14 updating of cycw changes in 97 +! Last change: IPK 12 Jan 98 1:55 pm +!ipk last update Nov 18 1997 +!ipk last updated Oct 17 1996 +!ipk last updated Oct 14 1996 + + SUBROUTINE RDRW(IS) + +! Determine how to draw grid according to switch setting + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*1 ANS,ANSW(10) + character*38 mesg + +! Draw box around selections + + DATA ANSW/'m','o','e','n','t','y','l','d','b','r'/ +! m 1 o 2 e 5 n 3 t 4 u 7 g 8 d 6 b 9 + NHTP=5 + NMESS=0 + NBRR=0 + 100 CONTINUE + CALL HEDR + +! Get answer + + call xyloc(XPT,YPT,ANS,IBOX) + IF(IRMAIN .EQ. 1) RETURN + if(ibox .le. 0) go to 100 + IF(ANS .EQ. 'c') THEN + ANS=ANSW(IBOX) + ENDIF + IF(ANS .EQ. 'm') THEN +!ipk oct96 + if(ipsw(1) .eq. 0) then + call getmpcl + NHTP=5 + endif +!ipk oc96 end addition + IPSW(1)=MOD(IPSW(1)+1,2) + GO TO 100 + ELSEIF(ANS .EQ. 'o') THEN + IPSW(2)=MOD(IPSW(2)+1,2) + GO TO 100 + ELSEIF(ANS .EQ. 'n') THEN + IPSW(3)=MOD(IPSW(3)+1,2) + IF(IPSW(3) .EQ. 1) IPSW(9)=0 + IF(IPSW(3) .EQ. 1) IPSW(14)=0 + GO TO 100 + ELSEIF(ANS .EQ. 't') THEN + IPSW(4)=MOD(IPSW(4)+1,2) + GO TO 100 + ELSEIF(ANS .EQ. 'e') THEN + IPSW(5)=MOD(IPSW(5)+1,2) + if(ipsw(5) .eq. 1) ipsw(7)=0 + GO TO 100 + ELSEIF(ANS .EQ. 'd') THEN + IPSW(6)=MOD(IPSW(6)+1,2) + if(ipsw(6) .eq. 1) then +!ipk apr02 + call getmdis(nmapf,nsigf,icolsw,rad,colint) +! write(mesg,*) 'Enter output frequency for map display' +! call symbl (1.1,7.3,0.25,mesg,0.0,38) +! call getint(nmapf) + endif + GO TO 100 + ELSEIF(ANS .EQ. 'y') THEN + IPSW(7)=MOD(IPSW(7)+1,2) + if(ipsw(7) .eq. 1) ipsw(5)=0 + GO TO 100 +!ipk feb01 drop this option in favour of ccline ELSEIF(ANS .EQ. 'g') THEN +!ipk feb01 IPSW(8)=MOD(IPSW(8)+1,2) +!ipk feb01 GO TO 100 + ELSEIF(ANS .EQ. 'l') THEN + IPSW(10)=MOD(IPSW(10)+1,2) + GO TO 100 + ELSEIF(ANS .EQ. 'b') THEN + IPSW(9)=MOD(IPSW(9)+1,2) + IF(IPSW(9) .EQ. 1) IPSW(3)=0 + IF(IPSW(9) .EQ. 1) IPSW(14)=0 + GO TO 100 + ELSEIF(ANS .EQ. 'r') THEN + +! CALL PLOTS(IS) +!ipk nov97 add (0) + CALL PLOTOT(1) + RETURN + ENDIF + GO TO 100 + END + + SUBROUTINE GETMPCL + +! Determine how to draw grid according to switch setting + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*1 ANS,ANSW(10) + +! Draw box around selections + + DATA ANSW/'e','o','t','h','f','i','s','v','g','q'/ +! m 1 o 2 e 5 n 3 t 4 u 7 g 8 d 6 b 9 + NHTP=12 + 100 CONTINUE + CALL HEDR + +! Get answer + + call xyloc(XPT,YPT,ANS,IBOX) + IF(ANS .NE. 'c') then + DO K=1,10 + IF(ANS .EQ. ANSW(K)) THEN + IBOX=K + GO TO 102 + ENDIF + ENDDO + 102 CONTINUE + ENDIF + IF(IBOX .EQ. 10) GO TO 150 + ICOLON(IBOX)=MOD(ICOLON(IBOX)+1,2) + CALL HEDR + GO TO 100 + 150 NHTP=5 + RETURN + END + + SUBROUTINE GDIST + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*1 ANS,ANSW(10) + + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + DATA ANSW/6*' ','n','z','r','q'/ +! + NHTPSV=NHTP + NMESSV=NMESS + NBRRSV=NBRR + 100 CONTINUE + NHTP=0 + NMESS=41 + NBRR=4 + CALL CLRBOX + CALL HEDR + call xyloc(XPT1,YPT1,ANS,IBOX) + call xyloc(XPT2,YPT2,ANS,IBOX) + DIST=SQRT((YPT2-YPT1)**2+(XPT2-XPT1)**2)*TXSCAL + CALL CLRBOX + NMESS=0 + NBRR=4 + CALL HEDR + CALL NUMBR(0.5,7.55,0.20,DIST,0.0,2) + CALL XYLOC(XPT1,YPT1,ANS,IBOX) + IF(ANS .NE. 'c') then + DO K=1,10 + IF(ANS .EQ. ANSW(K)) THEN + IBOX=K + GO TO 102 + ENDIF + ENDDO + 102 CONTINUE + ENDIF + IF(IBOX .EQ. 7) GO TO 100 + NHTP=NHTPSV + NMESS=NMESSV + NBRR=NBRRSV + CALL CLRBOX + CALL HEDR + + RETURN + END diff --git a/src/PLOTR1.F90 b/src/PLOTR1.F90 new file mode 100644 index 0000000..94012bf --- /dev/null +++ b/src/PLOTR1.F90 @@ -0,0 +1,1620 @@ +!ipk last update March 6 2000 fix IMAT display bug +!ipk last update Feb 22 1999 add element type option +!ipk last update Jan 21 1999 add plotting of storage widths +!ipk lsat update oct 23 1998 change location of label in pgrid +! +!**************************************************************** +! +!ipk nov97 change call + SUBROUTINE PLOTOT(imz) +! +! Display grid according to switch setting +! + USE BLKMAP + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' + INCLUDE 'BFILES.I90' + include 'TXFRM.COM' + DIMENSION XLIN(350),YLIN(350) + CHARACTER*1 IFLAG + CHARACTER*80 LIND + !ycw mar97 add for cross section + REAL XPL(5),YPL(5) + DATA IFIRST/0/ + IF(IFIRST .EQ. 0) THEN + NTTRAC=0 + IFIRST=1 + ENDIF + HT=0.2 +! + if(imz .ne. 2) CALL CLSCRN +! +!ipk oct97 output to backup file +! +!ipk test for write to backup + if(imz .eq. 1) then + rewind ibak + call wrtout(0) + endif +! +!ycw mar97 add for cross section + if(LCROSS) then +!! call plotcs + return + endif +!ycw +! +! Rescale coordinates for plotting +! + CALL SCLMAP +!rrr + IF (IPSW(8) .EQ. 1) CALL PGRID +! + CALL SCLCRD +!ycw mar97 add for cross section + if(ICRS.ne.0) then + do i=1,2 + XPCS(i)=(XPCS(i)-XMIN)/PSCALE + YPCS(i)=(YPCS(i)-YMIN)/PSCALE + enddo + do i=1,NCSNOD + XCND(i)=(XCND(i)-XMIN)/PSCALE + YCND(i)=(YCND(i)-YMIN)/PSCALE + enddo + endif +!ycw + PSCALE = 1. + XMIN = 0. + YMIN = 0. + + if(ipsw(4) .eq. 1) then + do j=1,ne + if(ieskp(j) .eq. 0 .and. imz .ne. 2) call fillemC(j,1) + enddo + endif + +! write(90,*) 'going to drawbk',nbkfl,iswbkfl(1) + IF(NBKFL .GT. 0) THEN + DO I=1,NBKFL + IF(ISWBKFL(I) .EQ. 1) CALL DRAWBK(I,IMZ) + IF(ISWBKFL(I) .EQ. 2) CALL DRAWBKBM(I,IMZ) + ENDDO + ENDIF +! write(90,*) 'finished drawbk' +! +! Plot map data +! + IF(IMP .NE. 0) THEN + IF(IPSW(1) .EQ. 1) THEN + CALL PLTMAP + ENDIF + ENDIF +! +! If IPSW(1) = 1 plot map or plot outline if no map +! + IF(IMP .EQ. 0) THEN + IF(IPSW(1) .EQ. 1) IPSW(2)=1 +!ipk sep94 allow plotting of outline after map +! ELSE +! IF(IPSW(1) .EQ. 1) GO TO 10 + ENDIF +! +! Plot outline of grid only +! + IF(IPSW(2) .EQ. 1) THEN + CALL OUTLN +! GO TO 250 + ENDIF +! +! Plot nodes when IPSW(3) .EQ. 1 +! + 10 CONTINUE + IF(IPSW(3) .EQ. 1 .OR. IPSW(9) .EQ. 1 .OR. IPSW(14) .EQ. 1) THEN + IF(NP .GT. 0) THEN + IF(IPSW(3) .EQ. 1) ITP=0 + IF(IPSW(14) .EQ. 1) ITP=2 + IF(IPSW(9) .EQ. 1) then + ITP=-1 + wdmin=1.e10 + wdmax=-1.e10 + do j=1,np + IF(INSKP(J) .EQ. 1) cycle + IF(CORD(J,1) .GT. 0. .AND. CORD(J,1) .LT. HSIZE) THEN + IF(CORD(J,2) .GT. 0. .AND. CORD(J,2) .LT. 7.5) THEN + wdmin=min(wdmin,wd(j)) + wdmax=max(wdmax,wd(j)) + else + cycle + endif + else + cycle + endif + enddo + if(abs(wdmin) .ge. abs(wdmax)) then + temp=log10(abs(wdmin)) + else + temp=log10(wdmax) + endif + if(temp .gt. 2.) then + itp=-3 + elseif(temp .gt. 1.) then + itp=-4 + else + itp=-5 + endif + endif + DO 15 J=1,NP + IF(MOD(J,10) .EQ. 0) THEN + CALL CHINT(IFLAG) + IF(IFLAG .EQ. 'i') GO TO 250 + ENDIF + IF(INSKP(J) .EQ. 1) GO TO 15 + IF(CORD(J,1) .GT. 0. .AND. CORD(J,1) .LT. HSIZE) THEN + IF(CORD(J,2) .GT. 0. .AND. CORD(J,2) .LT. 7.5) THEN + CALL PLTNOD(J,ITP) + GO TO 15 + ENDIF + ENDIF + INSKP(J)=1 + 15 CONTINUE + ENDIF + ENDIF +! +! Plot data points +! + IF(IPSW(6) .EQ. 1) THEN + FCT=10**NSIGF + DO 80 J=1,MAXPTS,nmapf + IF(VAL(J) .GT. -9000.) THEN + X=CMAP(J,1) + Y=CMAP(J,2) + IF(X .GT. 0. .AND. X .LT. HSIZE) THEN + IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN + CALL PLOTT(X,Y,3) + if(icolsw .eq. 0) then + CALL PLOTT(X,Y,2) + + CALL Rblack +! ipk mar01 +! ipk jun04 CALL NUMBR(X,Y,0.15,VAL(J)*FCT,0.0,-1) + if(nsigf .lt.1) then + nsigff=1 + else + nsigff=nsigf + endif + call numbr(x,y,0.12,val(j),0.0,nsigff) + CALL RBlue + else + if(colint .eq. 0.) colint=1. + if(val(j) .ge. 0.) then + ncoln=val(j)/colint + else + ncoln=-val(j)/colint + endif + ncoln=mod(ncoln,13)+2 + call change_color(ncoln) + raddisp=rad/txscal + if(raddisp .lt. 0.01) raddisp=0.01 + call circle(x,y,raddisp) + endif + ENDIF + ENDIF + ENDIF + 80 CONTINUE + Call RBlue +! GO TO 250 + ENDIF +! +! Plot existing elements +! +!ipk add element type option + IF(IPSW(5) .EQ. 1 .OR. IPSW(4) .EQ. 1 .or. ipsw(7) .eq. 1) THEN +! CALL PLOTT(0.,7.0,3) +! CALL PLOTT(10.,7.0,2) +!IPK JAN98 + IERC=imz + if(ne .gt. 0) then + DO 20 J=1,NE + XC(J)=VOID + YC(J)=VOID + IF(MOD(J,10) .EQ. 0) THEN + CALL CHINT(IFLAG) + IF(IFLAG .EQ. 'i') GO TO 250 + ENDIF + IF(IESKP(J) .EQ. 0) THEN +!IPK JAN98 ADD IERC + IF (IMAT(J) .NE. 0) CALL PLTELM(J,IERC) + ENDIF + 20 CONTINUE + IF(IERC .GT. 0) THEN +! call clscrn() +! WRITE(LIND,*) ' Zero node corner nodes' +! call symbl & +! & (1.1,5.5,0.25,LIND,0.0,80) +! WRITE(LIND,*) ' See MESSAGES.OUT file for details' +! call symbl & +! & (1.1,5.2,0.25,LIND,0.0,80) +! WRITE(LIND,*) ' Press enter to terminate' +! call symbl & +! & (1.1,4.9,0.25,LIND,0.0,80) +! ndig=1 +! CALL GTCHARX(IFLAG,NDIG,5.0,5.5) +! CALL QUIT_PGM() +! stop + CALL WMessageBox(0,0,0,'Error in element connnection'//& + CHAR(13)//'Zero corner node found'//& + CHAR(13)//'See Mesgen.out for details',& + 'ERROR IN ELEMENT CONNECTIONS') + + ENDIF + endif + ENDIF +!ycw mar97 add for cross section + if(ICRS.ne.0) then + call plott(XPCS(1),YPCS(1),3) + call RRED + call plott(XPCS(2),YPCS(2),2) + do i=1,NCSNOD + xpl(1)=XCND(i)-0.04 + ypl(1)=YCND(i)-0.04 + xpl(2)=XCND(i)+0.04 + ypl(2)=ypl(1) + xpl(3)=xpl(2) + ypl(3)=YCND(i)+0.04 + xpl(4)=xpl(1) + ypl(4)=ypl(3) + xpl(5)=xpl(1) + ypl(5)=ypl(1) + call polyfl(xpl,ypl,5,1) + enddo + call RBLACK + endif +!ycw +250 continue + IF(NTRACT .GT. 0) THEN + DO KK=1,NTRACT + XLIN(KK)=CORD(ITRAC(KK),1) + YLIN(KK)=CORD(ITRAC(KK),2) + ENDDO + CALL RRED +!ipk jan01 + CALL THICKL + CALL DASHLN(XLIN,YLIN,NTRAC,0) +!ipk jan01 + CALL RBLACK + CALL THINL + call pltnod(ITRAC(1),0) + call pltnod(ITRAC(NTRACT),0) + ENDIF + + IF (IPSW(8) .EQ. 1) CALL PGRID + +!IPK JAN01 + IF(IPSW(10) .EQ. 1) CALL PLOTCC + +!ipk oct02 + IF(IPSW(11) .EQ. 1) CALL PLOTCSTR + +!ipk oct03 + IF(IPSW(12) .EQ. 1) CALL PLOTCRSS(0) + + if(ipsw(13) .eq. 1) call plotcrss(1) + + IF(INREORD .EQ. 1) THEN + CALL PLOTORDS + ENDIF + + IF(IMZ .NE. 1) THEN + CALL DOPLOT(IMZ) + ENDIF + + RETURN + END +! +!**************************************************************** +! + SUBROUTINE PLTNOD(J,ICOL) +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! +! Plot nodes on screen +! + HT = .20 + IF (CORD(J,1) .LT. VDX) RETURN + X = CORD(J,1) + Y = CORD(J,2) + CALL PLOTT(X,Y,3) + CALL PLOTT(X,Y,2) + IF(ICOL .EQ. 0 .OR. ICOL .EQ. 1) THEN + Y = Y+0.07 + FPN = J + ELSEIF(ICOL .EQ. 2) THEN + Y = Y+0.07 + FPN = LAY(J) + IF(LAY(J) .EQ. -9999) GO TO 500 + ELSE +!ipk jul02 Y = Y-0.11 + Y = Y+0.10 +!ipk jul02 FPN=WD(J)*10. + fpn=wd(j) + if(icrin .eq. 23) fpn=wd1(j) + ENDIF + IF(IJUN(J) .NE. 0) THEN + Y=Y-0.17*FLOAT(IJUN(J)-2) + ENDIF + IF(ICOL .LT. 1) THEN + CALL RRed + if(lock(j) .eq. 1) call rgreen + ELSE + CALL RBlack + ENDIF + IF(X .GT. 0. .AND. X .LT. HSIZE) THEN + IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN +! ipk mar01 +! ipk jul02 + if(icol .lt. 0) then + call numbr(x,y,0.12,fpn,0.0,-icol) + else + CALL NUMBR(X,Y,0.15,FPN,0.0,-1) + endif + ENDIF + ENDIF + 500 CONTINUE + CALL RBlue +! + END +! +!**************************************************************** +! +!IPK JAN98 SUBROUTINE PLTELM(J) + SUBROUTINE PLTELM(J,IERC) + + USE BLK1MOD +!ipk jan99 + + INCLUDE 'TXFRM.COM' + INCLUDE 'BFILES.I90' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + DIMENSION XLIN(9),YLIN(9),BLVL(9) +! +! INCLUDE 'BLK1.COM' + CHARACTER*1 IJNK + CHARACTER*80 LIND +! +! Plot elements already formed +! + imz=ierc + ierc=0 + call rblue + IF (IMAT(J) .EQ. 0 ) RETURN + NCN = NCORN(J) +! + XXC = 0. + YYC = 0. + NLINP=0 + IESKP(J)=1 + DO 15 K=1,NCN + N = NOP(J,K) + IF (N .EQ. 0 .AND. MOD(K,2) .EQ. 1) THEN + CALL SETD(23) +! CALL CLSCRN() +!IPK JAN98 WRITE(*,*) ' Zero node corner node' +!IPK JAN98 WRITE(*,*) ' ELEM, NOP(ELEM,K) ' +!IPK JAN98 WRITE(*,'(I5,I10,7I5)') J,(NOP(J,KK),KK=1,NCN) + WRITE(90,*) ' ELEM, NOP(ELEM,K) ' + WRITE(90,'(I5,I10,7I5)') J,(NOP(J,KK),KK=1,NCN) +!IPK JAN98 WRITE(*,*) 'Press enter to exit' +!IPK JAN98 READ(*,'(A)') IJNK +!IPK JAN98 CALL Quit_Pgm +!IPK JAN98 STOP + IERC=IERC+1 + do kk=1,8 + nop(j,kk)=0 + enddo + imat(j)=0 + RETURN + ENDIF +! +! IF (N .EQ. 0 .OR. CORD(N,1) .LT. VDX) GOTO 15 + IF (N .EQ. 0) GO TO 15 + IF(MOD(K,2) .EQ. 1 .AND. CORD(N,1) .LT. VDX) GOTO 15 + IF(CORD(N,1) .LT. VDX) THEN + IF(K .EQ. NCN) THEN + X=(CORD(NOP(J,K-1),1)+CORD(NOP(J,1),1))/2. + Y=(CORD(NOP(J,K-1),2)+CORD(NOP(J,1),1))/2. + ELSE + X=(CORD(NOP(J,K-1),1)+CORD(NOP(J,K+1),1))/2. + Y=(CORD(NOP(J,K-1),2)+CORD(NOP(J,K+1),1))/2. + ENDIF + ELSE +! + X = CORD(N,1) + Y = CORD(N,2) + ENDIF + IF(X .GT. 0. .AND. X .LT. HSIZE) THEN + IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN + IESKP(J)=0 + GO TO 16 + ENDIF + ENDIF + 15 END DO + 16 CONTINUE +! + IF(IESKP(J) .EQ. 1) GO TO 26 + + if(ipsw(7) .eq. 1 .and. iqsw(2) .GT. 0) then + IF(IQSW(2) .EQ. 1) ittmp=imat(j) + IF(IQSW(2) .EQ. 2) ittmp=igrpser(j) + IF(ITTMP .GT. 900 ) THEN + ICCT=MOD(ITTMP+1,10)+4 + ELSE + icct=MOD(ittmp,10)+4 + ENDIF + if(imz .ne. 2) then + call fillemc(j,icct) + endif + endif + + DO 25 K=1,NCN + N = NOP(J,K) +! + IF (N .EQ. 0) go to 25 + IF (CORD(N,1) .LT. VDX) GOTO 25 +! + X = CORD(N,1) + Y = CORD(N,2) +! + IF (NCN .NE. 5 .OR. K .LT. 5) THEN + IF (MOD(K,2) .EQ. 1) THEN + XXC = XXC + X + YYC = YYC + Y + ENDIF + ENDIF + NLINP=NLINP+1 +! + XLIN(NLINP)=X + YLIN(NLINP)=Y + BLVL(NLINP)=WD(N) + IF (K .EQ. 1) THEN + X1 = X + Y1 = Y + ENDIF + 25 END DO + IF(NCN .GT. 5) THEN + NLINP=NLINP+1 + XLIN(NLINP)=X1 + YLIN(NLINP)=Y1 + BLVL(NLINP)=WD(NOP(J,1)) + ENDIF + if(i3dview .eq. 1) then + do k=1,nlinp + YLIN(K)=YLIN(K)+(BLVL(K)-VRTORIG)*COS(VANG/57.29578)/VRTSCAL + enddo + endif +!ipkoct93 + if(ipsw(4) .eq. 1) then + if(ncn .eq. 8 .or. imat(j) .lt. 901) then + CALL DASHLN(XLIN,YLIN,NLINP,0) + endif + endif +! IF(IMAT(J) .LT. 901 .AND. IPSW(4) .EQ. 1) +! + CALL DASHLN(XLIN,YLIN,NLINP,0) +!ipkoct93 +! +! Plot elem number at center if IPSW(5) = 1 +! + CALL RCyan + IF (NCN .EQ. 3 .OR. NCN .EQ. 5) NCN = 4 + XC(J) = 2.*XXC/NCN + YC(J) = 2.*YYC/NCN +! IF(IMAT(J) .GT. 900 ) THEN + IF(IMAT(J) .GT. 900 .and. ncorn(j) .ne. 8) THEN + CALL RBlue + RETURN + ENDIF +!ipk feb99 add element type option + IF(IPSW(5) .EQ. 1 .or. ipsw(7) .eq. 1) THEN + HT = .20 + if(ipsw(5) .eq. 1) then + FPN = J +!ipk mar00 fix imat display bug + elseif((iqsw(1) .gt. 0) .or. (iqsw(1) .eq. 0 .and. iqsw(2) .eq. 0) ) then + CALL RBLACK + if(iqsw(1) .eq. 1) fpn=imat(j) + if(iqsw(1) .eq. 2) fpn=igrpser(j) +! elseif(iqsw(2) .eq. 1) then +! CALL RBLACK +! fpn=imat(j) + else + go to 30 + endif + IF(XC(J) .GT. 0. .AND. XC(J) .LT. HSIZE) THEN + IF(YC(J) .GT. 0. .AND. YC(J) .LT. 7.5) THEN +!ipkoct93 +! IF(IMAT(J) .LT. 901) CALL NUMBR(XC(J),YC(J),HT,FPN,0.0,-1) +! ipk mar01 +!ipk jun02 + xxc=xc(j) + yyc=yc(j) + CALL NUMBR(XXC,YYC,0.15,FPN,0.0,-1) + ENDIF +! elseif(iqsw(2) .eq. 1) then +! CALL RBLACK +! fpn=imat(j) + endif + 30 continue + ENDIF + +!ipk jan99 add plot of 1-d element widths + if(ncorn(j) .eq. 3 .or. ncorn(j) .eq. 5) then + ncn=3 + n1=nop(j,1) + n2=nop(j,3) +! +!...... first for widths + + IF(IPW1 .EQ. 1) THEN + wd11=width(n1)/txscal + wd2=width(n2)/txscal + ELSE + IF(NRIVCR1(N1) .EQ. 0 .AND. NRIVCR2(N1) .EQ. 0) RETURN + IF(NRIVCR1(N2) .EQ. 0 .AND. NRIVCR2(N2) .EQ. 0) RETURN + BT1= & + CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ & + CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1) + BT2= & + CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ & + CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2) + H1=WIDEL-BT1 + H2=WIDEL-BT2 + CALL INTERPWLV(N1,H1,AR1,WR1,DWR1) + CALL INTERPWLV(N2,H2,AR2,WR2,DWR2) + WIDTH(N1)=WR1 + WIDTH(N2)=WR2 + IF(IPW1 .EQ. 2) THEN + WD11=WR1*WIDSCL/TXSCAL + WD2=WR2*WIDSCL/TXSCAL + ELSE + WD11=AR1*WIDSCL/TXSCAL + WD2=AR2*WIDSCL/TXSCAL + ENDIF + + ENDIF + if(wd11 .gt. 0. .and. wd2 .gt. 0.) then + x1= cord(n1,1) + x2= cord(n2,1) + y1= cord(n1,2) + y2= cord(n2,2) + eldir=atan2(y2-y1,x2-x1) + elnorm=eldir-1.5708 + xlin(1)=x1+cos(elnorm)*wd11/2. + xlin(5)=xlin(1) + xlin(4)=x1-cos(elnorm)*wd11/2. + xlin(2)=x2+cos(elnorm)*wd2/2. + xlin(3)=x2-cos(elnorm)*wd2/2. + ylin(1)=y1+sin(elnorm)*wd11/2. + ylin(5)=ylin(1) + ylin(4)=y1-sin(elnorm)*wd11/2. + ylin(2)=y2+sin(elnorm)*wd2/2. + ylin(3)=y2-sin(elnorm)*wd2/2. + call dashln(xlin,ylin,5,0) + endif + +!...... then for storage widths + + wd11=(wids(n1)+width(n1))/txscal + wd2=(wids(n2)+width(n2))/txscal + if(wids(n1) .gt. 0. .and. wids(n2) .gt. 0.) then + x1= cord(n1,1) + x2= cord(n2,1) + y1= cord(n1,2) + y2= cord(n2,2) + eldir=atan2(y2-y1,x2-x1) + elnorm=eldir-1.5708 + xlin(1)=x1+cos(elnorm)*wd11/2. + xlin(5)=xlin(1) + xlin(4)=x1-cos(elnorm)*wd11/2. + xlin(2)=x2+cos(elnorm)*wd2/2. + xlin(3)=x2-cos(elnorm)*wd2/2. + ylin(1)=y1+sin(elnorm)*wd11/2. + ylin(5)=ylin(1) + ylin(4)=y1-sin(elnorm)*wd11/2. + ylin(2)=y2+sin(elnorm)*wd2/2. + ylin(3)=y2-sin(elnorm)*wd2/2. + call dashln(xlin,ylin,5,1) + endif + endif + + + CALL RBlue + 26 CONTINUE +! + RETURN + END +! +!**************************************************************** +! + SUBROUTINE PLTMAP +! + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! +! Plot map of input data +! +! Determine how long each line is +! + JS=1 +! + K=0 + CALL RCyan + DO 20 J=1,MAXPTS + MLEN=J-JS +! write(90,*) 'j,mlen',j,mlen,cmap(j,1),k+1,lintyp(k+1),vdx +! write(123,*) 'j,mlen',j,mlen,cmap(j,1),k+1,lintyp(k+1),vdx + IF(XMAP(J) .LE. VDX .or. j .eq. maxpts) THEN + if(j .eq. maxpts .and. xmap(j) .gt. vdx) mlen=mlen+1 +! +! Now draw it. +! + K=K+1 + IF(MLEN .GT. 1) THEN + LTP=LINTYP(K) +!ipk oct96 + if(icolon(ltp+1) .eq. 1) then + + IF(LTP .NE. 2) THEN +!ipk oct96 IF(LTP .LT. 2) THEN + CALL RRed + +! write(90,*) 'at nwpen ltp',ltp + IF(LTP .GT. 0) CALL NWPEN(2*LTP+1) + IF(LTP .GT. 2) LTP=0 + CALL DBDASHLN(cmap(js,1),cmap(js,2),MLEN,LTP) + ENDIF + ENDIF + ENDIF + IF(MLEN .EQ. 0 .AND. LINTYP(K) .EQ. -999) GO TO 30 + JS=J+1 + ENDIF + 20 CONTINUE + 30 CONTINUE + CALL RBlue + RETURN +! + END +! +!*********************************************************************** +! + SUBROUTINE SCLMAP +! +! Scale map coordinates for plotting +! Keep track and update information for mapping +! screen coordinates back to user coordinates +! + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! +!ipk may94 moved to blk1.com DATA XREF,YREF / 0.0, 0.0 / +! + DO 10 J=1,MAXPTS + IF (CMAP(J,1) .LT. VDX) GOTO 10 + CMAP(J,1) = (CMAP(J,1)-XMIN)/PSCALE + CMAP(J,2) = (CMAP(J,2)-YMIN)/PSCALE + 10 END DO +! + XREF = (XREF-XMIN)/PSCALE + YREF = (YREF-YMIN)/PSCALE + IF(IASPCT .EQ. 1) THEN + VRTSCAL=VRTSCAL*PSCALE + ENDIF + TXSCAL = TXSCAL*PSCALE + XS = XREF*TXSCAL + YS = YREF*TXSCAL + write(90,*) ' The line that follows gives the values used for a te& + &mporary origin and scale' + write(90,6000) xs,ys,txscal + 6000 format(3f15.4) +! + RETURN + END +! +!*********************************************************************** +! + SUBROUTINE SCLCRD +! +! Scale coordinates for plotting +! Keep track and update information for mapping +! screen coordinates back to user coordinates +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + REAL*8 ANGPT,ANGNEW,DRAD,DVANG,DVANGOLD + + DATA PI/3.14159265/,ITIME/0/,DRAD/57.29577957855/ + IF(ITIME .EQ. 0) THEN + VANGOLD=90. + VANG=90. + HANG=0. + HANGOLD=0. +! DRAD=180./PI + ITIME=1 + ENDIF + DVANG=VANG + DVANGOLD=VANGOLD +! + +! ROTATE BACK IF NEEDED + + + IF((HANGOLD .EQ. HANG) .AND. (VANGOLD .EQ. VANG)) GO TO 5 + IF(HANGOLD .NE. 0. .OR. VANGOLD .NE. 90.) THEN + IF(NP .GT. 0) THEN + DO J=1,NP + IF (CORD(J,1) .GE. VDX) THEN + + IF(VANGOLD .LT. 90.) THEN + CORD(J,2)=4.+(CORD(J,2)-4.)/DSIN(DVANGOLD/DRAD) + ENDIF + + ANGPT=DATAN2D(CORD(J,2)-4,CORD(J,1)-5.) + VLEN=SQRT((CORD(J,1)-5.)**2+(CORD(J,2)-4.)**2) + ANGNEW=ANGPT+HANGOLD +! IF(J .EQ. 1) THEN +! WRITE(90,*) 'ROTBACK',ANGPT,VLEN,ANGNEW,CORD(J,1),CORD(J,2) +! ENDIF + CORD(J,1)=5.+VLEN*DCOS(ANGNEW/DRAD) + CORD(J,2)=4.+VLEN*DSIN(ANGNEW/DRAD) +! IF(J .EQ. 1) THEN +! WRITE(90,*) CORD(J,1),CORD(J,2) +! ENDIF + ENDIF + ENDDO + ENDIF + ENDIF + + 5 CONTINUE + + IF(NP .GT. 0) THEN + DO 10 J=1,NP + IF (CORD(J,1) .LT. VDX) GOTO 10 + CORD(J,1) = (CORD(J,1)-XMIN)/PSCALE + CORD(J,2) = (CORD(J,2)-YMIN)/PSCALE + 10 CONTINUE + ENDIF +! +! ROTATE IF NEEDED + + IF((HANGOLD .EQ. HANG) .AND. (VANGOLD .EQ. VANG)) GO TO 15 + + IF(HANG .NE. 0 .OR. VANG .LT. 90.) THEN + IF(NP .GT. 0) THEN + DO J=1,NP + IF (CORD(J,1) .GE. VDX) THEN + ANGPT=DATAN2D(CORD(J,2)-4,CORD(J,1)-5.) + VLEN=SQRT((CORD(J,1)-5.)**2+(CORD(J,2)-4.)**2) + ANGNEW=ANGPT-HANG +! IF(J .EQ. 1) THEN +! WRITE(90,*) 'ROT',ANGPT,VLEN,ANGNEW,CORD(J,1),CORD(J,2) +! ENDIF + CORD(J,1)=5.+VLEN*DCOS(ANGNEW/DRAD) + CORD(J,2)=4.+VLEN*DSIN(ANGNEW/DRAD) + IF(VANG .LT. 90.) THEN + CORD(J,2)=4.+(CORD(J,2)-4.)*DSIN(DVANG/DRAD) + ENDIF +! IF(J .EQ. 1) THEN +! WRITE(90,*) CORD(J,1),CORD(J,2) +! ENDIF + ENDIF + ENDDO + ENDIF + ENDIF + HANGOLD=HANG + VANGOLD=VANG + + 15 CONTINUE + + RETURN +! + END + SUBROUTINE BOX(HEAD,NSIZ) +! +! Routine to draw NSIZ header boxes at top of page with the HEAD label +! + CHARACTER*8 HEAD(*) + XSY=0. + XLMT=FLOAT(NSIZ) + DO 200 N=1,NSIZ + CALL SYMBL(XSY,7.65,0.20,HEAD(N),0.0, 8) + XSY=XSY+1.0 + 200 CONTINUE +! +! Draw box around selections +! + CALL PLOTT(0.0,7.0,3) + CALL PLOTT(XLMT,7.0,2) + CALL PLOTT(XLMT,7.495,2) + CALL PLOTT(0.0,7.495,2) + CALL PLOTT(0.0,7.0,2) + XPT=0. + DO 205 I=1,NSIZ + XPT=XPT+1.0 + CALL PLOTT(XPT,7.0,3) + CALL PLOTT(XPT,7.495,2) + 205 CONTINUE + RETURN + END + SUBROUTINE BOXR(NBOX) + SAVE +! +! Routine to draw header box at top right of page with the HEAD label +! + CHARACTER*24 HEAD + CHARACTER*16 HEAD1 + CHARACTER*24 HEAD2 + DIMENSION X(5),Y(5) + DATA HEAD /' (z)oom r(d)raw (q)uit '/ + DATA HEAD1 /' r(d)raw (q)uit '/ + DATA HEAD2 /' (n)ext (z)oom (q)uit '/ +! +! Draw box around selections +! + NBX=IABS(NBOX) + XLEFT=10-NBX + Y(1)=7.5 + Y(2)=7.5 + Y(3)=7.995 + Y(4)=7.995 + Y(5)=7.5 +! CALL PLOTT(XLEFT,7.0,3) +! CALL PLOTT(10.0,7.0,2) +! CALL PLOTT(10.0,7.495,2) +! CALL PLOTT(XLEFT,7.495,2) +! CALL PLOTT(XLEFT,7.0,2) +! IF(NBOX .GT. 1) THEN + DO 200 K=1,NBX + X(1)=XLEFT + X(4)=XLEFT + X(5)=XLEFT + XLEFT=XLEFT+1.0 + X(2)=XLEFT + X(3)=XLEFT + IBLK=4 + CALL POLYFL(X,Y,5,IBLK) + CALL RBLACK + CALL PLOTT(X(1),Y(1),3) + CALL PLOTT(X(2),Y(2),2) + CALL PLOTT(X(3),Y(3),2) + CALL PLOTT(X(4),Y(4),2) + CALL PLOTT(X(1),Y(1),2) +! DO 200 K=1,NBOX-1 +! XLEFT=XLEFT+1. +! CALL PLOTT(XLEFT,7.0,3) +! CALL PLOTT(XLEFT,7.495,2) + 200 END DO +! ENDIF +! +! Establish label +! + IF(NBOX .EQ. 3) THEN + CALL SYMBL(7.0,7.65,0.20,HEAD,0.0,24) + ELSEIF(NBOX .EQ. -3) THEN + CALL SYMBL(7.0,7.65,0.20,HEAD2,0.0,24) + ELSEIF(NBOX .EQ. 2) THEN + CALL SYMBL(8.0,7.65,0.20,HEAD1,0.0,16) + ENDIF + RETURN + END +! +! + SUBROUTINE OUTLN +!- +!......OUTLN DRAWS BOUNDARIES FOR THE SYSTEM +!- + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! +! INTEGER*2 MSN +! COMMON /MID/ MSN(MAXP) +! + DATA IFIRST / 1 / +!- +!- +! DATA MAXB/MAXE/ + YMAXX = 7.50 +!- +!-.....PLOT BOUNDARY OUTLINE..... +!- +! 100 DO 110 J=1,MAXB +! NBP(J) = 0 +! 110 CONTINUE +! + IF (IFIRST .EQ. 1) GOTO 185 + IFIRST = 0 +! + NPTS=-1 +! READ(5,5020) NPTS +! 5020 FORMAT( 16I5 ) + IF( NPTS .EQ. 0 ) RETURN + 185 CONTINUE + DO 186 I=1,NP + 186 MSN(I) = 0 + DO 187 J=1,NE + IF(IESKP(J) .NE. 0) GO TO 187 + IF (IMAT(J) .LE. 0) GOTO 187 + IF (IMAT(J) .GT. 900) GO TO 187 + NCN = 6 + IF (NOP(J,7) .NE. 0) NCN = 8 + IF (NOP(J,6) .EQ. 0) NCN=3 + DO 188 K=2,NCN,2 + N = NOP(J,K) + if(n .gt. 0) then + MSN(N) = MSN(N) + 1 + endif + 188 CONTINUE + 187 END DO + DO 195 J = 1, NE + IF(IESKP(J) .NE. 0) GO TO 195 + IF(IMAT(J) .LE. 0) GO TO 195 +!ipkoct93 +! IF(IMAT(J) .GT. 900) GO TO 195 + IF(IMAT(J) .GT. 900 .and. nop(j,7) .eq. 0) GO TO 195 + NCN = 6 + IF (NOP(J,7) .NE. 0) NCN = 8 + IF (NOP(J,6) .EQ. 0) NCN=3 + DO 194 K = 2,NCN , 2 + L=NOP(J,K) + IF(L .EQ. 0) GO TO 194 + IF(MSN(L) .EQ. 1) THEN + N1 = NOP(J,K-1) + N2 = NOP(J,K) + N3 = MOD(K+1,NCN) + IF(N3 .EQ. 0) N3=NCN + N3 = NOP(J,N3) + X1 = CORD(N1,1) + Y1 = CORD(N1,2) + X2 = CORD(N2,1) + Y2 = CORD(N2,2) + X3 = CORD(N3,1) + Y3 = CORD(N3,2) + CALL FIT(X1,Y1,X2,Y2,X3,Y3) + ENDIF + 194 CONTINUE + 195 END DO + RETURN + END + SUBROUTINE AROHD(XPAGE,YPAGE,XTIP,YTIP,AHLEN,AHWID,ICODE) +!*********************************** .....AROHD..... + SAVE +! + IF(AHWID.LE.0.001) AHWID=AHLEN + I1=ICODE/10+3 + IF(I1.NE.3) I1=2 + KK=MOD(ICODE,10) + I2=2 + I3=2 + I4=2 + IF(KK.EQ.2) GO TO 10 + IF(KK.NE.4) GO TO 20 + I3=3 + GO TO 10 + 20 IF(KK.NE.5) GO TO 30 + I2=3 + I3=3 + GO TO 10 + 30 IF(KK.NE.8) GO TO 10 + I2=3 + I3=3 + I4=4 + 10 CONTINUE + CALL PLOTT(XPAGE,YPAGE,3) + CALL PLOTT(XTIP,YTIP,I1) + TX=XTIP-XPAGE + TY=YTIP-YPAGE + XLEN=SQRT(TX**2+TY**2) + IF(XLEN .GT. 0.001) GO TO 200 + XLEN=0.001 + IF(ABS(TX) .LT. 0.001) TX=SIGN(0.001,TX) + IF(ABS(TY) .LT. 0.001) TY=SIGN(0.001,TY) + 200 CONTINUE + TA=AHLEN/XLEN + XX=XTIP-TA*TX + YY=YTIP-TA*TY + AH=(AHWID/2.)**2 + DY=SQRT(AH*TX**2/(TX**2+TY**2)) + DY = SIGN(DY,TX) + DX=SQRT(AH*TY**2/(TX**2+TY**2)) + DX = SIGN(DX,TY) + X1=XX+DX + X2=XX-DX + Y1=YY+DY + Y2=YY-DY + CALL PLOTT(X2,Y1,I2) + CALL PLOTT(X1,Y2,I3) + CALL PLOTT(XTIP,YTIP,I4) + RETURN + END +! +!$$$ AUG 1987 +! SUBROUTINE TEST(X,Y,IG) +! +!...... Routine to that plot is on paper +! +! SAVE +! +! +! IG=0 +! IF(X .LT. 0. ) RETURN +! IF(X .GT. 10.) RETURN +! IF(Y .LT. 0. ) RETURN +! IF(Y .GT. 7.0) RETURN +! IG=1 +! RETURN +! END +! + SUBROUTINE FIT(X1,Y1,X2,Y2,X3,Y3) + SAVE +! + INTEGER I2,I3,IG + common /tek/ itek + + DATA I2/2/,I3/3/ + NPTS = 7 + DS = 1.0/FLOAT(NPTS) + S = 0.0 +! IG=0 +! CALL TEST(X1,Y1,IT) +! IF(IT .GT. 0) THEN + CALL PLOTT(X1,Y1,I3) + IG=I3 +! ENDIF + + dx3 = x1-x3 + dx2 = x1-x2 + dy3 = y1-y3 + dy2 = y1-y2 + if (abs(dx2) .le. 1.E-8) dx2 = 1.E-8 + if (abs(dx3) .le. 2.E-8) dx3 = 2.E-8 +! call test(x3,y3,itt) + if (abs(dy3/dx3 - dy2/dx2) .le. abs(.01*dy2/dx2)) then +! .and. +! + itt .gt. 0 .and. it .gt. 0) then + call plott(x3,y3,i2) + else + + DO 100 J = 1, NPTS + S = S + DS + XN1 = 1.0-3.0*S+2.0*S**2 + XN2 = 4.0*S*(1.0-S) + XN3 = S*(2.0*S-1.0) + X= XN1*X1 + XN2*X2 + XN3*X3 + Y = XN1*Y1 + XN2*Y2 + XN3*Y3 +! CALL TEST(X,Y,IT) +! IF(IT .GT. 0) THEN +! IF(IG .EQ. 0) THEN +! IG=I3 +! ELSE + IG=I2 +! ENDIF + CALL PLOTT(X,Y,IG) +! ELSE +! IG=0 +! ENDIF + 100 END DO + endif + + RETURN + END +! +!**************************************************************** +! + SUBROUTINE PGRID +! +! Form rectangular grid for guide lines by filling map arrays +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + + INCLUDE 'TXFRM.COM' + +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! + DIMENSION XG(2),YG(2) +! + DATA IFIRST / 1 / +! + IF (IFIRST .EQ. 1) THEN + DX = 10. + DY = 10. + X0 = -100. +!ipk sep94 update to 7.5 size Y0 = -70. + Y0 = -75. + X9 = HSIZE*10. +!ipk sep94 update to 7.5 size Y9 = 70. + Y9 = 75. +! + IF (XMIN .GT. -VDX) THEN + XMIN = -100. + XMAX = -XMIN + IPSW(8) = 1 + ENDIF + IF (YMIN .GT. -VDX) THEN +!ipk sep94 update to 7.5 size YMIN = -70. + YMIN = -75. + YMAX = -YMIN + IPSW(8) = 1 + ENDIF +! + IFIRST = 0 + RETURN +! + ELSE +! XDIF = TXSCAL * 10.5 + XDIF = TXSCAL * HSIZE*1.05 + IXDIF = IFIX( LOG10(XDIF) ) + XRANGE = 10**IXDIF + XFAC = XDIF/XRANGE + DX = XRANGE/10. + IF ( XFAC .GE. 5.) THEN + DX = 5.*DX + ELSEIF (XFAC .GE. 2.) THEN + DX = 2.*DX + ENDIF +! + X0 = -NINT(XS/DX - .5) * DX - DX + X9 = X0 + XDIF +! + DY = DX +!ipk sep94 update to 7.5 scale YDIF = .70*XDIF + YDIF = .75*XDIF + Y0 = -NINT(YS/DY -.5) * DY - DY + Y9 = Y0 + YDIF + + ENDIF +! +! vertical-grid lines + LTP = 0 + MLEN = 2 + HT = .18 +! + DO 10 CX = X0,X9, DX + XG(1) = (CX + XS)/TXSCAL + YG(1) = (Y0 + YS)/TXSCAL + XG(2) = XG(1) + YG(2) = (Y9 + YS)/TXSCAL + CALL NWPEN(8) + CALL DASHLN(XG,YG,MLEN,LTP) +! + FPN = CX + IF (AMOD(FPN,1.) .EQ. 0. .OR. ABS(FPN) .LT. 0.01) THEN + IPLC = -1 + ELSE + IPLC = 1 + ENDIF + X = XG(1) +! Y = YG(1) + .02 +!ipk oct98 change y location + Y = .20 + IF ( (X .GT. 0. .AND. X .LT. HSIZE) .AND. & + & (Y .GT. 0. .AND. Y .LT. 7.5) ) THEN +!ipk sep94 change colour CALL NWPEN(12) + CALL NWPEN(8) +! ipk mar01 + CALL NUMBR(X,Y,0.15,FPN,0.0,IPLC) + ENDIF + 10 END DO +! +! horizontal-grid lines + DO 20 CY = Y0,Y9, DY + XG(1) = (X0 + XS)/TXSCAL + YG(1) = (CY + YS)/TXSCAL + XG(2) = (X9 + XS)/TXSCAL + YG(2) = YG(1) + CALL NWPEN(8) + CALL DASHLN(XG,YG,MLEN,LTP) +! + FPN = CY + IF (AMOD(FPN,1.) .EQ. 0. .OR. ABS(FPN) .LT. 0.01) THEN + IPLC = -1 + ELSE + IPLC = 1 + ENDIF +! X = XG(1) + X = .02 + Y = YG(1) + IF ( (X .GT. 0. .AND. X .LT. HSIZE) .AND. & + & (Y .GT. 0. .AND. Y .LT. 7.5) ) THEN +!ipk sep94 change color CALL NWPEN(12) + CALL NWPEN(8) +! ipk mar01 + CALL NUMBR(X,Y,0.15,FPN,0.0,IPLC) + ENDIF + 20 END DO +! + CALL RBlue +! + END + + SUBROUTINE RESCAL +! +! Scale for plotting +! +! + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' + + INCLUDE 'BFILES.I90' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! + VDX = - 1.0E+10 + XREF=0. + YREF=0. +! +! Reset map coordinates to original scale +! + IF(MAXPTS .GT. 0) THEN + DO J=1,MAXPTS + IF(CMAP(J,1) .GE. VDX) THEN + CMAP(J,1)=TXSCAL*CMAP(J,1) - XS + CMAP(J,2)=TXSCAL*CMAP(J,2) - YS + ENDIF + ENDDO + ENDIF +! +! Reset nodal coordinates +! + IF(NP .GT. 0) THEN + DO J=1,NP + CORD(J,1) = XUSR(J) + CORD(J,2) = YUSR(J) + ENDDO + ENDIF +!ycw mar97 add for cross section + if(ICRS.ne.0) then + do i=1,2 + XPCS(i)=XPCS(i)*TXSCAL - XS + YPCS(i)=YPCS(i)*TXSCAL - YS + enddo + do i=1,NCSNOD + XCND(i)=XCND(i)*TXSCAL - XS + YCND(i)=YCND(i)*TXSCAL - YS + enddo + endif +!ycw +! +! Reset controlling scales +! + TXSCAL = 1. + XS=0. + YS=0. + XMIN = 1.E+20 + XMAX = -XMIN + YMIN = 1.E+20 + YMAX = -YMIN + IF(IMP .GT. 0) THEN +! +! Find max and min +! +! + DO J=1,MAXPTS + IF (CMAP(J,1) .GT. VDX) THEN + IF (CMAP(J,1) .LT. XMIN) XMIN = CMAP(J,1) + IF (CMAP(J,1) .GT. XMAX) XMAX = CMAP(J,1) + IF (CMAP(J,2) .LT. YMIN) YMIN = CMAP(J,2) + IF (CMAP(J,2) .GT. YMAX) YMAX = CMAP(J,2) + ENDIF + ENDDO + ENDIF +! + IF(NP .GT. 0) THEN + DO J=1,NP + IF (CORD(J,1) .GT. VDX) THEN + INSKP(J)=0 + IF (CORD(J,1) .LT. XMIN) XMIN = CORD(J,1) + IF (CORD(J,1) .GT. XMAX) XMAX = CORD(J,1) + IF (CORD(J,2) .LT. YMIN) YMIN = CORD(J,2) + IF (CORD(J,2) .GT. YMAX) YMAX = CORD(J,2) + ENDIF + ENDDO + ENDIF + IF(NE .GT. 0) THEN + DO J=1,NE + IF(NOP(J,1) .NE. 0) THEN + IESKP(J)=0 + ENDIF + ENDDO + ENDIF +! +! + DO J=1,NBKFL + XMAX=MAX(XMAX,BFMINMAX(J,1),BFMINMAX(J,3)) + XMIN=MIN(XMIN,BFMINMAX(J,1),BFMINMAX(J,3)) + YMAX=MAX(YMAX,BFMINMAX(J,2),BFMINMAX(J,4)) + YMIN=MIN(YMIN,BFMINMAX(J,2),BFMINMAX(J,4)) + ENDDO + AMAP=(XMAX-XMIN)*(YMAX-YMIN) + XSCALE = (XMAX-XMIN)/(hsize-0.5) + YSCALE = (YMAX-YMIN)/6.5 + PSCALE = MAX(XSCALE,YSCALE) +! + XAVE = (XMIN + XMAX) /2.0 + YAVE = (YMIN + YMAX) /2.0 + XMIN = XAVE - hsize/2.*PSCALE + YMIN = YAVE - 3.5*PSCALE + XMAX = XAVE + (hsize-0.5)/2.*PSCALE + YMAX = YAVE + 3.25*PSCALE +! +! Plot all data +! + CALL PLOTSV(0) +!ipk nov97 add (0) + CALL PLOTOT(0) + RETURN + END + +!IPK JAN01 NEW ROUTINE + + SUBROUTINE PLOTCC + + USE BLK1MOD + use blk2mod +! INCLUDE 'BLK1.COM' + DIMENSION XLIN(350),YLIN(350) + + IF(NCLM .GT. 0) THEN + +!Process each line + CALL RBLUE + + DO NCLL=1,NCLM + WRITE(90,*) 'PLOTR1-1130 NCLL,NCLM',NCLL,NCLM + DO KK=1,350 + IF(ICCLN(NCLL,KK) .NE. 0) THEN + IF(KK .EQ. 1) THEN + X=CORD(ICCLN(NCLL,KK),1)+0.1 + Y=CORD(ICCLN(NCLL,KK),2)+0.1 + IF(X .GT. 0. .AND. X .LT. HSIZE) THEN + IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN + FPN=NCLL +! ipk mar01 + CALL NUMBR(X,Y,0.2,FPN,0.0,-1) + ENDIF + ENDIF + ENDIF + XLIN(KK)=CORD(ICCLN(NCLL,KK),1) + YLIN(KK)=CORD(ICCLN(NCLL,KK),2) + ELSE + if(kk .eq. 1) GO TO 510 + NTRAC=KK-1 + X=CORD(ICCLN(NCLL,KK-1),1)+0.1 + Y=CORD(ICCLN(NCLL,KK-1),2)+0.1 + IF(X .GT. 0. .AND. X .LT. HSIZE) THEN + IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN + FPN=NCLL +! ipk mar01 + CALL NUMBR(X,Y,0.2,FPN,0.0,-1) + ENDIF + ENDIF + if(ntrac .eq. 1) then + call IGrCharSize(0.5,0.5) + call IGrMarker(x-0.1,y-0.1,14) + call IGrCharSize(1.0,1.0) + endif +! +! Draw along line +! + IF(NTRAC .GT. 1) THEN + CALL THICKL + CALL DASHLN(XLIN,YLIN,NTRAC,0) + CALL THINL + ENDIF + GO TO 400 + ENDIF + 359 CONTINUE + ENDDO + 400 CONTINUE + IF(NTRAC .EQ. 1) THEN + NODL=ICCLN(NCLL,1) + DO N=1,NE + IF(IMAT(N) .LT. 900 .AND. IMAT(N) .GT. 0) THEN + IF(NCORN(N) .EQ. 5 .OR. NCORN(N) .EQ. 3) THEN + IF(NOP(N,1) .EQ. NODL) THEN + DIRX=CORD(NOP(N,3),1)-CORD(NOP(N,1),1) + DIRY=CORD(NOP(N,3),2)-CORD(NOP(N,1),2) + GO TO 420 + ELSEIF(NOP(N,3) .EQ. NODL) THEN + DIRX=CORD(NOP(N,1),1)-CORD(NOP(N,3),1) + DIRY=CORD(NOP(N,1),2)-CORD(NOP(N,3),2) + GO TO 420 + ENDIF + ENDIF + ENDIF + ENDDO + 420 DIR=ATAN2(DIRX,-DIRY) + D1=CORD(NODL,1) + D2=CORD(NODL,2) + ELSE + +! Plot arrows on continuity line + + DIRX=CORD(ICCLN(NCLL,1),1)-CORD(ICCLN(NCLL,NTRAC),1) + DIRY=CORD(ICCLN(NCLL,1),2)-CORD(ICCLN(NCLL,NTRAC),2) + IF(DIRX .EQ. 0. .AND. DIRY .EQ. 0.) THEN + DIR=0. + ELSE + DIR=ATAN2(DIRX,-DIRY) + D1=(CORD(ICCLN(NCLL,1),1)+CORD(ICCLN(NCLL,NTRAC),1))/2. + D2=(CORD(ICCLN(NCLL,1),2)+CORD(ICCLN(NCLL,NTRAC),2))/2. + ENDIF + ENDIF + DIR1=DIR+2.35619 + DIR2=DIR-2.35619 + DE1=D1+0.4*COS(DIR) + DE2=D2+0.4*SIN(DIR) + DEA1=DE1+0.1*COS(DIR1) + DEA2=DE2+0.1*SIN(DIR1) + DEB1=DE1+0.1*COS(DIR2) + DEB2=DE2+0.1*SIN(DIR2) + CALL RBLUE + CALL PLOTT(D1,D2,3) + CALL PLOTT(DE1,DE2,2) + CALL PLOTT(DEA1,DEA2,2) + CALL PLOTT(DE1,DE2,3) + CALL PLOTT(DEB1,DEB2,2) + CALL RBLUE +510 CONTINUE + ENDDO + ENDIF + + RETURN + END + + SUBROUTINE PLOTCSTR + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +! Plot arrows on control structures + + DO N=1,NE + IF(IMAT(N) .GT. 903) THEN + + DIRX=CORD(NOP(N,3),1)-CORD(NOP(N,1),1) + DIRY=CORD(NOP(N,3),2)-CORD(NOP(N,1),2) + IF(DIRX .EQ. 0. .AND. DIRY .EQ. 0.) THEN + DIR=0. + ELSEIF(NCORN(N) .LT. 6) THEN + DIR=ATAN2(DIRY,DIRX) + D1=CORD(NOP(N,1),1) + D2=CORD(NOP(N,1),2) + ELSE + DIR=ATAN2(DIRX,-DIRY) + D1=CORD(NOP(N,2),1) + D2=CORD(NOP(N,2),2) + ENDIF + DIR1=DIR+2.35619 + DIR2=DIR-2.35619 + IF(IESKP(N) .EQ. 0) THEN + D1=CORD(NOP(N,2),1) + D2=CORD(NOP(N,2),2) + DE1=D1+0.4*COS(DIR) + DE2=D2+0.4*SIN(DIR) + DEA1=DE1+0.1*COS(DIR1) + DEA2=DE2+0.1*SIN(DIR1) + DEB1=DE1+0.1*COS(DIR2) + DEB2=DE2+0.1*SIN(DIR2) + CALL RRED + CALL PLOTT(D1,D2,3) + CALL PLOTT(DE1,DE2,2) + CALL PLOTT(DEA1,DEA2,2) + CALL PLOTT(DE1,DE2,3) + CALL PLOTT(DEB1,DEB2,2) + CALL RBLUE + ENDIF + ENDIF + ENDDO + RETURN + END + + SUBROUTINE PLOTCRSS(isw) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + INCLUDE 'TXFRM.COM' +! COMMON/ICN1/ ICN(MAXP) + + CHARACTER*11 PART1,PART2 + + if(isw .eq. 0) then + CALL RGREEN + + DO NN=1,NCRSEC + N=IVMIL(NN) + xpt=(xcrs(n)+xs)/txscal + ypt=(ycrs(n)+ys)/txscal + a=NOREACH(N)/1000. + fpn=n+a + IF(XPT .GT. 0. .AND. XPT .LT. HSIZE) THEN + IF(YPT .GT. 0. .AND. YPT .LT. 7.5) THEN + call plotcr(xpt,ypt,0.05) + CALL NUMBR(xpt,ypt-0.1,0.13,FPN,0.0,3) + ENDIF + ENDIF + ENDDO + ENDIF + + IF(ISW .EQ. 1) THEN + + DO J=1,MAXP + ICN(J)=0 + END DO +! First sort out the potential midsides +! Note that transition elements caues a problem +! Find these first + DO 200 N=1,NE + if(NCORN(N) .GT. 5) GO TO 200 + IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN +! +! We have a transition mark node number as if it were corner +! + ICN(NOP(N,3))=1 + ICN(NOP(N,1))=2 + ICN(NOP(N,4))=2 + ICN(NOP(N,5))=2 + ELSE +! +! Store ICN = 2 for corner nodes +! + NCN=NCORN(N) +!IPKOCT93 IF(IMAT(N) .GT. 900) THEN + IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN + MST=1 + ELSE + MST=2 + ENDIF + DO 180 M=1,NCN,MST + ICN(NOP(N,M))=2 + 180 CONTINUE + ENDIF + 200 END DO + + DO J=1,NP + + IF(ICN(J) .EQ. 2) THEN + WRITE(PART1,'(I5,F6.3)') & + ,NRIVCR1(J),WTRIVCR1(J) + + WRITE(PART2,'(I5,F6.3)') & + ,NRIVCR2(J),WTRIVCR2(J) + + IF (CORD(J,1) .LT. VDX) GO TO 300 + X = CORD(J,1) + Y = CORD(J,2) + + CALL RBlack + IF(X .GT. 0. .AND. X .LT. HSIZE) THEN + IF(Y .GT. 0. .AND. Y .LT. 7.5) THEN + CALL SYMBL(X-0.25,Y+.24,0.10,PART1,0.0,11) + CALL SYMBL(X-0.25,Y+.12,0.10,PART2,0.0,11) + endif + ENDIF + 300 CONTINUE + ENDIF + ENDDO + ENDIF + CALL RBlue + RETURN + END diff --git a/src/RDOUTLIN.F90 b/src/RDOUTLIN.F90 new file mode 100644 index 0000000..5b30624 --- /dev/null +++ b/src/RDOUTLIN.F90 @@ -0,0 +1,46 @@ + MODULE BLKOUT + ALLOCATABLE XOUTL(:),YOUTL(:) + INTEGER NOUTLIN + ENDMODULE + + SUBROUTINE RDOUTLIN +! +! ROUTINE TO READ COORDINATES OF MESH OUTLINE + + USE WINTERACTER + USE BLKOUT + + CHARACTER(LEN=255) :: FNAME +! CHARACTER(LEN=3) :: SUB,SUB1 + CHARACTER(LEN=256) :: FILTER + CHARACTER*3 SUB + + FILTER ="Outline files -- *.txt|*.txt|map files -- |*.map|All files -- |*.*|" + CALL WSelectFile(FILTER,PromptOn,FNAME,'Load Outline File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + OPEN(99,FILE=FNAME,STATUS='OLD') + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + IF(SUB .EQ. 'map') then + KTYP=2 + ELSE + KTYP=1 + ENDIF + ELSE + RETURN + ENDIF + + ALLOCATE (XOUTL(5000),YOUTL(5000)) + IF(KTYP .EQ. 2) READ(99,*) INDM + DO N=1,5000 + READ(99,*,END=500,ERR=500) XOUTL(N),YOUTL(N) + ENDDO + close(99) +500 CONTINUE + NOUTLIN=N-1 + RETURN + END + diff --git a/src/RDRM1.F90 b/src/RDRM1.F90 new file mode 100644 index 0000000..c1968e3 --- /dev/null +++ b/src/RDRM1.F90 @@ -0,0 +1,111 @@ + SUBROUTINE RDRM1(IFILE,NPTEMP,NETEMP,IMIDS) + + SAVE + + REAL*8 CX,CY + CHARACTER DLINE*140,ID1*3,BLANK*20 + DIMENSION ILN(8) + + data blank/' '/ + + + REWIND (IFILE) + READ(ifile,'(A80)') TITLE + READ(IFILE,'(100X,I5)') IFORM1 + READ(IFILE,'(A80)') DLINE(1:80) + + IMIDS=0 + NP=0 + NE=0 + NPTEMP=0 + NETEMP=0 + + 100 CALL GINPT1(IFILE,DLINE) + + +!ipk feb12 add format test + IF(MOD(IFORM1,2) .EQ. 1) THEN + READ(DLINE,'(10I6,F10.3,I6)') J,ILN,IMT,EDIR,INU + ELSE + READ(DLINE,'(10I5,F10.3,I5)') J,ILN,IMT,EDIR,INU + ENDIF + IF(ILN(1) .EQ. 0 .AND. (J .EQ. 9999 .OR. J .EQ. 99999)) THEN + GO TO 120 + ELSE + IF(ILN(7) .NE. 0) THEN + NCN=8 + ELSEIF(ILN(5) .NE. 0) THEN + NCN=6 + ELSEIF(ILN(3) .NE. 0) THEN + NCN=3 + ENDIF + + DO K=1,NCN + NPTEMP=MAX(NPTEMP,ILN(K)) + NETEMP=MAX(NETEMP,J) + IF(MOD(K,2) .EQ. 0 .AND. ILN(K) .EQ. 0) IMIDS=1 + ENDDO + GO TO 100 + ENDIF + + 120 continue + + CALL GINPT1(IFILE,DLINE) + + IF(IFORM1 .LT. 2) THEN + READ(DLINE,'(I10,9F10.0,I10,F10.0)') J, CX, CY, BELEV,& + WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11 + ELSE +! do kct=1,140 +! if(dline(kct:kct) .eq. '*') then + do kcl=61,140 + dline(kcl:kcl)=' ' + enddo +! go to 8888 +! endif +! enddo +!8888 continue + READ(DLINE,'(I10,2F20.0,7F10.0,I10,F10.0)',err=8888) J, CX, CY, BELEV,& + WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11 + go to 8889 + 8888 do kcl=61,140 + dline(kcl:kcl)=' ' + enddo + READ(DLINE,'(I10,2F20.0,7F10.0,I10,F10.0)') J, CX, CY, BELEV,& + WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11 +8889 continue + ENDIF + + + IF(DLINE(11:30) .eq. blank .AND. (J .EQ. 9999 .OR. J .EQ. 99999)) THEN + GO TO 140 + ELSE + NPTEMP=MAX(NPTEMP,J) + GO TO 120 + ENDIF +140 CONTINUE + + REWIND(IFILE) + RETURN + END + + SUBROUTINE GINPT1(IIN,DLIN) + CHARACTER DLIN*140 + 100 CONTINUE + READ(IIN,7000) DLIN +!IPK SEP08 write(75,7000) dlin + 7000 FORMAT(A140) + do i=1,140 + if(dlin(i:i) .eq. char(9)) go to 200 + enddo + RETURN + 200 continue +!IPK SEP04 + CLOSE(75) + OPEN(75,file='ERROR.OUT') + write(*,*) 'Error Tab character found in the following line' + write(75,*) 'Error Tab character found in the following line' + write(75,7000) dlin + write(*,7000) dlin + stop + END diff --git a/src/READSHP.FOR b/src/READSHP.FOR new file mode 100644 index 0000000..f3e8262 --- /dev/null +++ b/src/READSHP.FOR @@ -0,0 +1,209 @@ + SUBROUTINE READSHP + + USE BLKMAP + USE BLK1MOD + character*4 temp + character*100 header,field + character*4 ai7,aai7,ai8 + integer status,i1,i2,i3,i4,i5,i6,i7,i8,i9 + integer*2 i1s,i2s,i3s + integer*1 i1vs(20),i2vs(20) + real*8 fp1,fp2,fp3,fp4,fp5,fp6,fp7,fp8,vtemp(20) + character*11 label(20),fomat(20) + character*1 type(20),a2,a3,a4 + equivalence (aai7,ia7),(aai8,ia8) + +c read header + + read(113) i1,i2,i3,i4,i5,i6,ai7,i8,i9 + read(113) fp1,fp2,fp3,fp4,fp5,fp6,fp7,fp8 + CALL BTOL(AI7,IA7) + write(90,*) 'file length',ia7 + write(90,*) 'version',i8 + write(90,*) 'shapetype',i9 + +c read data + + read(114) i1,i2,i1s,i2s,i3,i4,i5,i6,i7 + nrecs=i2 + nbytesh=i1s + nrecsh=nbytesh/32-1 + ndytesrec=i2s + nfl=0 + +c now process labels + + do k=1,nrecsh + read(114) label(k),type(k),i3,i1vs(k),i2vs(k),i3s,i4,i5,i6 + if(type(k) .eq. 'F' .or. type(k) .eq. 'N') then + write(fomat(k),6000) i1vs(k),i2vs(k) + 6000 format('(F',i2,'.',i1,')') + else + if(i1vs (k) .lt. 10) then + write(fomat(k),6001) i1vs(k) + 6001 format('(A',i1,')') + else + write(fomat(k),6002) i1vs(k) + 6002 format('(A',i2,')') + endif + endif + nfl=nfl+i1vs(k) + enddo + read(114) a3 + call choosrec(label,nrecsh,nchs) + + + 230 continue + JK=0 + JL=0 + if(i9 .eq. 1) then + do JJ=1,100000 + read(113,end=300) ai7,ai8 + CALL BTOL(AI7,IA7) + CALL BTOL(AI8,IA8) + READ(113) I1,FP1,FP2 + CMAP(JJ,1)=FP1 + CMAP(JJ,2)=FP2 + XMAP(JJ)=FP1 + YMAP(JJ)=FP2 + MAXPTS=JJ +c VAL(JJ)=-2. + ENDDO + 300 CONTINUE + XMAP(MAXPTS+1)= VOID + LINTYP(1)=2 + +! +!c finished shape file now read dbf stat with header +! +! read(114) i1,i2,i1s,i2s,i3,i4,i5,i6,i7 +! nrecs=i2 +! nbytesh=i1s +! nrecsh=nbytesh/32-1 +! ndytesrec=i2s +! nfl=0 +! +!c now process labels +! +! do k=1,nrecsh +! read(114) label(k),type(k),i3,i1vs(k),i2vs(k),i3s,i4,i5,i6 +! if(type(k) .eq. 'F' .or. type(k) .eq. 'N') then +! write(fomat(k),6000) i1vs(k),i2vs(k) +! 6000 format('(F',i2,'.',i1,')') +! else +! if(i1vs (k) .lt. 10) then +! write(fomat(k),6001) i1vs(k) +! 6001 format('(A',i1,')') +! else +! write(fomat(k),6002) i1vs(k) +! 6002 format('(A',i2,')') +! endif +! endif +! nfl=nfl+i1vs(k) +! enddo + !read(114) a3 + !call choosrec(label,nrecsh,nchs) + do j=1,nrecs + do k=1,nrecsh + read(114) field(1:i1vs(k)) + read(field,fomat(k)) vtemp(k) + enddo + val(j)=vtemp(NCHS) + read(114) a3 + enddo + else + do JJ=1,100000 + read(113,end=500) ai7,ai8 + CALL BTOL(AI7,IA7) + CALL BTOL(AI8,IA8) + read(113) istp,FP1,FP2,FP3,FP4,npart,npts,nd1 +! do j=1,nrecs + do k=1,nrecsh + read(114) field(1:i1vs(k)) + read(field,fomat(k)) vtemp(k) + enddo + read(114) a3 +! enddo + JL=JL+1 + LINTYP(JL)=1 + do k=1,npts + read(113) fp1,fp2 + WRITE(155,*) JK,JL,FP1,FP2,VTEMP(NCHS) + jk=jk+1 + CMAP(jk,1)=FP1 + CMAP(jk,2)=FP2 + XMAP(jk)=FP1 + YMAP(jk)=FP2 + MAXPTS=jk + val(jK)=vtemp(NCHS) + + enddo + jk=jk+1 + CMAP(jk,1)=-1.e10 + CMAP(jk,2)=-1.e10 + XMAP(jk)=-1.e10 + YMAP(jk)=-1.e10 + MAXPTS=jk + val(jK)=0. + enddo + 500 continue + MAXPTS=JK-1 + KLINT=JL + JLINT=MAXPTS + endif + CLOSE (113) + RETURN + END + + + SUBROUTINE BTOL(AICHG,ICHG) + INTEGER ICHG,ITEMP + CHARACTER*4 AICHG,AAICHG + EQUIVALENCE(ITEMP,AAICHG) + aaICHG(1:1)=aICHG(4:4) + aaICHG(2:2)=aICHG(3:3) + aaICHG(3:3)=aICHG(2:2) + aaICHG(4:4)=aICHG(1:1) + ICHG=ITEMP + RETURN + END + + subroutine choosrec(label,nrecsh,nchs) + use winteracter + implicit none + include 'D.inc' + SAVE + character*11 label(*) + INTEGER NRECSH,NCHS,IERR,N + + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + call wdialogload(IDD_CHSTYP) + ierr=infoerror(1) + + do n=1,NRECSH + write(90,'(a)') 'file',n,LABEL(N) + CALL WDialogPutString(idf_string25+n-1,LABEL(n)) + call wdialogputradiobutton(idf_radio1) + enddo + CALL WDialogSelect(IDD_CHSTYP) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + call wdialogGetradiobutton(idf_radio1,NCHS) + ENDIF + RETURN + END + + + + \ No newline at end of file diff --git a/src/REATTACH.F90 b/src/REATTACH.F90 new file mode 100644 index 0000000..de7d884 --- /dev/null +++ b/src/REATTACH.F90 @@ -0,0 +1,79 @@ + SUBROUTINE REATTACH + + + USE BLK1MOD + USE BLK2MOD + + INTEGER NS1(3),NT1(3) + CHARACTER*1 IFLAG,ANSW(10) + DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/ + +! SETUP CONNECTIVITY TABLE + CALL KCON(0) +! SELECT FIRST ELEMENT +10 CONTINUE + NHTP=0 + NMESS=20 + NBRR=8 + CALL HEDR + + CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX) + call fillem(ielem) + IF(IRMAIN .EQ. 1) RETURN + IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN + IFLAG=ANSW(IBOX) + ENDIF +! + IF(IFLAG .EQ. 'q') THEN + RETURN + ENDIF +! GET UNATTACHED NOP + DO K=2,NCORN(IELEM),2 + NSX=NOP(IELEM,K) + IF(NDELM(NSX) .EQ. 1) THEN +! FOUND IT + NS1(1)=NOP(IELEM,K-1) + NS1(2)=NSX + KK=MOD(K,NCORN(IELEM))+1 + NS1(3)=NOP(IELEM,KK) + GO TO 280 + ENDIF + ENDDO + 280 CONTINUE + +! SELECT NEXT ELEMENT + + CALL PROX(XC,YC,NE,XX,YY,IELEM1,IFLAG,IESKP,IBOX) + call fillem(ielem1) + +! GET UNNATCHED SIDE +! FIND AN UNATTACHED SIDE (INDICATE OF TRIANGLE OR QUADRILATERAL) + DO K=2,NCORN(IELEM1),2 + NSX=NOP(IELEM1,K) + IF(NDELM(NSX) .EQ. 1) THEN +! FOUND IT + NT1(1)=NOP(IELEM1,K-1) + NT1(2)=NSX + KK=MOD(K,NCORN(IELEM1))+1 + NT1(3)=NOP(IELEM1,KK) + GO TO 300 + ENDIF + ENDDO +300 CONTINUE + +! FORM A NEW ELEMENT ASSIGN TYPE AS INDICATED + CALL GETELM(J) + DO K=1,3 + NOP(J,K)=NS1(K) + NOP(J,K+4)=NT1(K) + ENDDO + NOP(J,4)=0 + NOP(J,8)=0 + IMAT(J)=1 + IESKP(J) = 0 + NCORN(J)=8 + +! GO BACK TO LOOK FOR NEW PAIR + GO TO 10 + RETURN + END \ No newline at end of file diff --git a/src/REFINB.F90 b/src/REFINB.F90 new file mode 100644 index 0000000..72fabb6 --- /dev/null +++ b/src/REFINB.F90 @@ -0,0 +1,1436 @@ +!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR CHNAGED ELEMENTS/NODES +! last update Sept 20 1999 +! Last change: IPK 13 Jan 98 10:05 am +!ipk last update Nov 18 1997 +!ipk last update Oct 24 1996 + SUBROUTINE REFB +! +! Routines to control refinement of elements +! + USE BLK1MOD + + INCLUDE 'BFILES.I90' +! INCLUDE 'BLK1.COM' +! + CHARACTER*1 ANS,ANSW(10) + DATA ANSW/'f','l','s','t','v','n',' ','m',' ','q'/ +! +! Draw box around selections +! + 100 CONTINUE + NHTP=8 + NMESS=0 + NBRR=0 + CALL HEDR +! +! Get answer +! +!ipk jan98 + 210 continue + call wrtbox(idelv) + call xyloc(XPT,YPT,ANS,IBOX) + IF(IRMAIN .EQ. 1) RETURN +!ipk jan98 add option for deleting elevation on move + IF(IBOX .EQ. 7 .or. ANS .eq. 'e') THEN + IDELV=MOD(IDELV+1,2) + GO TO 210 + ENDIF + IF(ANS .EQ. 'c') THEN + if(ibox .eq. 0) go to 210 + ANS=ANSW(IBOX) + ENDIF +! +! Element generation +! + IF (ANS .EQ. 'f') THEN +! +! Refine elements by four +! + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL REFIN(0) + IRDONE=0 + IF(IRMAIN .EQ. 1) RETURN +! + ELSEIF (ANS .EQ. 'l') THEN +! +! Refine elements by two long +! + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL REFIN(1) + IRDONE=0 + IF(IRMAIN .EQ. 1) RETURN +! + ELSEIF (ANS .EQ. 's') THEN +! +! Refine elements by two short +! + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL REFIN(2) + IRDONE=0 + IF(IRMAIN .EQ. 1) RETURN +! +! + ELSEIF (ANS .EQ. 't') THEN +! +! Refine elements by splitting quads +! + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL REFIN(3) + IRDONE=0 + IF(IRMAIN .EQ. 1) RETURN +! +! + ELSEIF (ANS .EQ. 'v') THEN +! +! Reverse element diagonals for quads +! + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL REFIN(4) + IRDONE=0 + IF(IRMAIN .EQ. 1) RETURN +! + ELSEIF (ANS .EQ. 'n') THEN +! +! Clean up element refinement +! + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL CLENUP(0) + IRDONE=0 + IF(IRMAIN .EQ. 1) RETURN +! + ELSEIF (ANS .EQ. 'm') THEN + IF(IRMAIN .EQ. 1) RETURN +! +! simplify layout +! + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL SMFY ! + IRDONE=0 + ELSEIF (ANS .EQ. 'q') THEN + CALL WRTOUT(0) ! + + + RETURN +! +! Look again +! + ENDIF + GO TO 100 + END +! + SUBROUTINE REFIN(ITYPT) +! +! Routine to refine elements +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! + DIMENSION NTRAN(9),IELGB(8) + CHARACTER*1 IFLAG + DIST(N1,N2)=SQRT((CORD(N1,1)-CORD(N2,1))**2 & + & +(CORD(N1,2)-CORD(N2,2))**2) +! + ITYP=ITYPT + IF(NEFL .GT. 0) GO TO 150 +!ipk may94 change so that refine does not change display +! DO 2 I=1,9 +! IPSW(I)=0 +! 2 CONTINUE +! IPSW(4)=1 +! CALL PLOTOT +!ipk may94 end changes + 3 CONTINUE + NHTP=0 + NMESS=12 + NBRR=3 + CALL HEDR +! +! Write out +! + NEFL=0 + 4 CONTINUE + IBOX=1 + CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN +! + IF (IFLAG .EQ. 'c') THEN + NEFL=NEFL+1 + NEFLAG(NEFL)=IELEM + CALL FILLEM(IELEM) + ELSEIF (IFLAG .EQ. 'U') THEN + NEFLAG(NEFL)=0 + NEFL=NEFL-1 + CALL PLOTOT(1) + CALL HEDR + DO IELEM=1,NEFL + CALL FILLEM(NEFLAG(IELEM)) + ENDDO +! +! ELSEIF(IFLAG .EQ. 'r') THEN +! CALL PLOTS(0) +! CALL PLOTOT +! GO TO 4 + ELSEIF(IFLAG .EQ. 'q' .OR. IFLAG .EQ. 'e') THEN + GO TO 152 +! + ELSE +!IPK JAN98 WRITE(*,*) CHAR(7),CHAR(7) + ENDIF +! + GOTO 4 +! +! + 150 CONTINUE +! IPSWO=IPSW +! IPSW=4 +! CALL PLOTS(0) +!ipk oct96 DO 151 I=1,9 +!ipk oct96 IPSW(I)=0 +!ipk oct96 151 CONTINUE +!ipk oct96 IPSW(4)=1 + +!ipk nov97 add (1) + CALL PLOTOT(1) +! IPSW=IPSWO +! +! Define NEF and process elements +! + 152 CONTINUE + + DO N=1,NE + DO M=1,8 + NOPSV(N,M)=NOP(N,M) + ENDDO + IMATSV(N)=IMAT(N) + ENDDO + NPUNDO=0 + NEUNDO=0 + NESAV=NE + NEFSAV=NENTRY + IF(NENTRY .GT. 0) THEN + DO N=1,NENTRY + DO M=1,3 + NEFSV(N,M)=NEF(N,M) + ENDDO + ENDDO + ENDIF + ITYPSV=ITYP + DO 250 NN=1,NEFL + ITYP=ITYPSV + N=NEFLAG(NN) + IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) GO TO 250 +! IF(IMAT(N) .EQ. 999) ITYP=1 + NCN=NCORN(N) +! +! Split a one-dimensional element in two +! + IF(NCN .EQ. 3) THEN + N1=NOP(N,1) + N2=NOP(N,2) + N3=NOP(N,3) + IF(NOP(N,2) .EQ. 0) THEN + CALL GETNOD(N2) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=N2 + ELSEIF(INEW(N2) .EQ. 1) THEN + GO TO 153 + ENDIF + CORD(N2,1)=(CORD(N1,1)+CORD(N3,1))/2. + CORD(N2,2)=(CORD(N1,2)+CORD(N3,2))/2. + IF(LOCK(N1) .EQ. 1 .AND. LOCK(N3) .EQ. 1) LOCK(N2)=1 + XUSR(N2) = CORD(N2,1)*TXSCAL - XS + YUSR(N2) = CORD(N2,2)*TXSCAL - YS + INEW(N2) = 1 + INSKP(N2) =0 + 153 CALL GETELM(NEM) + NEUNDO=NEUNDO+1 + IELDEL(NEUNDO)=NEM + NOP(NEM,3)=N3 + NOP(N,2)=0 + NOP(N,3)=N2 + NOP(NEM,1)=N2 + NOP(NEM,2)=0. + NOP(NEM,3)=N3 + IMAT(NEM)=IMAT(N) + IESKP(NEM)=0 + NCORN(NEM)=3 +!ipk jan98 + IF(IDELV .EQ. 1) then + WD(N2)=-9999. + WIDTH(N2)=0. + SS1(N2)=0. + SS2(N2)=0. + WIDS(N2)=0. + ELSE + WD(N2)=(WD(N1)+WD(N3))/2. + WIDTH(N2)=(WIDTH(N1)+WIDTH(N3))/2. + SS1(N2)=(SS1(N1)+SS1(N3))/2. + SS2(N2)=(SS2(N1)+SS2(N3))/2. + WIDS(N2)=(WIDS(N1)+WIDS(N3))/2. + IF(ICRIN .EQ. 23) CALL COMPWGT + ENDIF + GO TO 250 + ENDIF +! +! Setup for each type of refinement +! +!ipk jan08 + IF(ITYP .EQ. 0) THEN +! +! Full refinement all nodes are eligible +! +! IF(imat(n) .eq. 999) then +! IELGB(2)=2 +! IELGB(4)=0 +! IELGB(6)=2 +! IELGB(8)=0 +! ELSE + DO M=2,NCN + IELGB(M)=1 + ENDDO +! ENDIF + ELSEIF(ITYP .EQ. 1 .OR. ITYP .EQ. 2) THEN +! +! Setup for long or short side refinement +! + IF(ITYP .EQ. 1) THEN + DISTLL=0. + DISTL=0. + ELSE + DISTLL=-VOID + DISTL=-VOID + ENDIF +! +! Sort out longest or shortest sides +! + DO 165 M=2,NCN,2 + IELGB(M)=0 + N1=NOP(N,M-1) + N2=MOD(M,NCN)+1 + N2=NOP(N,N2) + DSEP=DIST(N1,N2) + IF(ITYP .EQ. 1) THEN + IF(DISTLL .LT. DSEP) THEN +! Separation greater DISTLL + IF(DISTLL .GT. 0.) THEN +! DISTLL already exists then move it down the line + DISTL=DISTLL + NDS=NDSS + ENDIF +! Save separation + DISTLL=DSEP + NDSS=M + GO TO 165 + ELSEIF(DISTL .LT. DSEP) THEN +! 2nd longest + DISTL=DSEP + NDS=M + ENDIF + ELSE + IF(DSEP .LT. DISTLL) THEN +! Separation less than DISTLL + IF(DISTLL .LT. -VDX) THEN +! DISTLL already exists then move it up the line + DISTL=DISTLL + NDS=NDSS + ENDIF + DISTLL=DSEP + NDSS=M + GO TO 165 + ELSEIF(DSEP .LT. DISTL) THEN +! 2nd shortest + DISTL=DSEP + NDS=M + ENDIF + ENDIF + 165 CONTINUE + IELGB(NDSS)=2 + IELGB(NDS)=2 + ELSEIF(ITYP .EQ. 3) THEN +!ipk jan98 IF(NCN .EQ. 8) CALL SPLIT(N) + IF(NCN .GT. 5) CALL SPLIT(N) + GO TO 250 + ELSEIF(ITYP .EQ. 4) THEN + NPL=NEFLAG(NN+1) + CALL REVERS(N,NPL) + GO TO 255 + ENDIF +! +! Loop through element sides +! + DO 200 M=2,NCN,2 + IF(IELGB(M) .EQ. 0) GO TO 200 + N1=NOP(N,M-1) + N3=MOD(M+1,NCN) + N3=NOP(N,N3) +! +! Search table for N1 +! + IF(NENTRY .EQ. 0) GO TO 182 + DO 180 J=1,NENTRY + IF(N1 .EQ. NEF(J,3) .AND. N3 .EQ. NEF(J,1)) THEN +! +! We have found match so use this info +! + NOP(N,M)=NEF(J,2) +! +! For regular ops remove value in NEF(J,1) so that it seems blank and s +! otherwise set value negative + IF(IELGB(M) .EQ. 1) THEN + NEF(J,1)=0 + ELSE + NEF(J,1)=-NEF(J,1) + ENDIF + GO TO 200 + ENDIF + 180 CONTINUE + 182 CONTINUE +! +! Define a node, enter it, initialize it, and make entry in NEF +! + IF(IMAT(N) .EQ. 999 .AND. (M .EQ. 4 .OR. M .EQ. 8)) GO TO 200 + + IF(NOP(N,M) .EQ. 0) THEN + CALL GETNOD(N2) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=N2 + NOP(N,M)=N2 + CORD(N2,1)=(CORD(N1,1)+CORD(N3,1))/2. + CORD(N2,2)=(CORD(N1,2)+CORD(N3,2))/2. + IF(LOCK(N1) .EQ. 1 .AND. LOCK(N3) .EQ. 1) LOCK(N2)=1 + XUSR(N2) = CORD(N2,1)*TXSCAL - XS + YUSR(N2) = CORD(N2,2)*TXSCAL - YS + INEW(N2) = 1 + INSKP(N2) =0 + ELSE + N2=NOP(N,M) + IF(INEW(N2) .NE. 1) THEN + CORD(N2,1)=(CORD(N1,1)+CORD(N3,1))/2. + CORD(N2,2)=(CORD(N1,2)+CORD(N3,2))/2. + XUSR(N2) = CORD(N2,1)*TXSCAL - XS + YUSR(N2) = CORD(N2,2)*TXSCAL - YS + INEW(N2) = 1 + INSKP(N2) =0 + ENDIF + ENDIF +!ipk jan98 + IF(IDELV .EQ. 1) then + WD(N2)=-9999. + ELSE + WD(N2)=(WD(N1)+WD(N3))/2. + ENDIF + IF(M .EQ. 2 .AND. IMAT(N) .EQ. 999) THEN + WIDTH(N2)=(WIDTH(N1)+WIDTH(N3))/2. + SS1(N2)=(SS1(N1)+SS1(N3))/2. + SS2(N2)=(SS2(N1)+SS2(N3))/2. + WIDS(N2)=(WIDS(N1)+WIDS(N3))/2. + ELSE + WIDTH(N2)=0. + SS1(N2)=0. + SS2(N2)=0. + WIDS(N2)=0. + ENDIF + NENTRY=NENTRY+1 + NEF(NENTRY,1)=N1 + NEF(NENTRY,2)=N2 + NEF(NENTRY,3)=N3 + 200 CONTINUE + IF(ITYP .GT. 0) GO TO 250 +! +! Copy NOP into temporary NTRAN for processing then delete element +! + DO 220 K=1,8 + NTRAN(K)=NOP(N,K) + NOP(N,K)=0 + 220 CONTINUE + NRMAT=IMAT(N) + IMAT(N)=0 + IESKP(N)=-1 + NTYP=1 + NELAST= MIN(NELAST,N) + IF(NCN .EQ. 8) THEN + IF(NRMAT .EQ. 999) THEN + IF(NTRAN(2) .EQ. 0) THEN + CALL GETNOD(N2) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=N2 + N1=NTRAN(1) + N3=NTRAN(3) + CORD(N2,1)=(CORD(N1,1)+CORD(N3,1))/2. + CORD(N2,2)=(CORD(N1,2)+CORD(N3,2))/2. + INEW(N2) = 1 + IF(LOCK(N1) .EQ. 1 .AND. LOCK(N3) .EQ. 1) LOCK(N2)=1 + NTRAN(2)=N2 + WD(N2)=(WD(N1)+WD(N3))/2. + WIDTH(N2)=(WIDTH(N1)+WIDTH(N3))/2. + SS1(N2)=(SS1(N1)+SS1(N3))/2. + SS2(N2)=(SS2(N1)+SS2(N3))/2. + WIDS(N2)=(WIDS(N1)+WIDS(N3))/2. + ENDIF + IF(NTRAN(6) .EQ. 0) THEN + CALL GETNOD(N6) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=N6 + N5=NTRAN(5) + N7=NTRAN(7) + CORD(N6,1)=(CORD(N5,1)+CORD(N7,1))/2. + CORD(N6,2)=(CORD(N5,2)+CORD(N7,2))/2. + INEW(N6) = 1 + IF(LOCK(N5) .EQ. 1 .AND. LOCK(N7) .EQ. 1) LOCK(N6)=1 + NTRAN(6)=N6 + WD(N6)=(WD(N5)+WD(N7))/2. + WIDTH(N6)=(WIDTH(N5)+WIDTH(N7))/2. + SS1(N6)=(SS1(N5)+SS1(N7))/2. + SS2(N6)=(SS2(N5)+SS2(N7))/2. + WIDS(N6)=(WIDS(N5)+WIDS(N7))/2. + ENDIF + CALL GETELM(NEM) + NEUNDO=NEUNDO+1 + IELDEL(NEUNDO)=NEM + NOP(NEM,1)=NTRAN(1) + NOP(NEM,3)=NTRAN(2) + NOP(NEM,5)=NTRAN(6) + NOP(NEM,7)=NTRAN(7) + IMAT(NEM)=999 + IESKP(NEM)=0 + NCORN(NEM)=8 + CALL GETELM(NEM) + NEUNDO=NEUNDO+1 + IELDEL(NEUNDO)=NEM + NOP(NEM,1)=NTRAN(2) + NOP(NEM,3)=NTRAN(3) + NOP(NEM,5)=NTRAN(5) + NOP(NEM,7)=NTRAN(6) + IMAT(NEM)=999 + IESKP(NEM)=0 + NCORN(NEM)=8 + ELSE + CALL GETNOD(N2) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=N2 + CORD(N2,1)=(CORD(NTRAN(1),1)+CORD(NTRAN(3),1) & + & +CORD(NTRAN(5),1)+CORD(NTRAN(7),1))/4. + CORD(N2,2)=(CORD(NTRAN(1),2)+CORD(NTRAN(3),2) & + & +CORD(NTRAN(5),2)+CORD(NTRAN(7),2))/4. + INEW(N2) = 1 + IF(LOCK(NTRAN(1)) .EQ. 1 .AND. LOCK(NTRAN(3)) .EQ. 1 .AND. & + & LOCK(NTRAN(5)) .EQ. 1 .AND. LOCK(NTRAN(7)) .EQ. 1) LOCK(N2)=1 + +!ipk jan98 + IF(IDELV .EQ. 1) then + WD(N2)=-9999. + ELSE + WD(N2) =(WD(NTRAN(1))+WD(NTRAN(3)) & + & +WD(NTRAN(5))+WD(NTRAN(7)))/4. + ENDIF + WIDTH(N2)=0. + SS1(N2)=0. + SS2(N2)=0. + WIDS(N2)=0. + XUSR(N2) = CORD(N2,1)*TXSCAL - XS + YUSR(N2) = CORD(N2,2)*TXSCAL - YS + NTRAN(9)=N2 + INSKP(N2)=0 + CALL RGEN(NTRAN,NTYP,NRMAT) + ENDIF + ELSE + CALL TGEN(NTRAN,NTYP,NRMAT) + ENDIF + IF(MOD(NN,20) .EQ. 0) THEN +! +! Compress NEF for later use +! + NCT=0 + DO 245 N=1,NENTRY + IF(NEF(N,1) .NE. 0) THEN + NCT=NCT+1 + NEF(NCT,1)=NEF(N,1) + NEF(NCT,2)=NEF(N,2) + NEF(NCT,3)=NEF(N,3) + ENDIF + 245 CONTINUE + NENTRY=NCT + ENDIF + 250 END DO + 255 CONTINUE + IF(ITYP .GT. 2) THEN +!ipk nov97 add (1) + call plotot(1) + NEFL=0 + RETURN + ENDIF +! +! Process the ITYP = 1 or 2 situation +! + IF(ITYP .GT. 0) THEN + CALL CLENUP(ITYP) + ENDIF +! +! Search for left over entries NEF +! + DO 600 I=1,NENTRY + DO 500 N=1,NE + IF(IMAT(N) .EQ. 0) GO TO 500 + NCN=NCORN(N) + +!ipk sep99 add test for line element + + if(ncn .eq. 3) go to 500 +! +! Loop on sides +! + DO 400 K=2,NCN,2 + IF(NOP(N,K-1) .EQ. NEF(I,3)) THEN + KP=MOD(K+1,NCN) + IF(NOP(N,KP) .EQ. ABS(NEF(I,1))) THEN +! +! We have a match, quit search for this entry +! + GO TO 600 + ENDIF + ENDIF + 400 CONTINUE + 500 CONTINUE +! +! No match this must be a boundary eliminate NEF value +! + NEF(I,1)=0 + NEF(I,3)=0 + 600 END DO +! +! Now compress remaining NEF for later use +! + NCT=0 + DO 700 N=1,NENTRY + IF(NEF(N,1) .GT. 0) THEN + NCT=NCT+1 + NEF(NCT,1)=NEF(N,1) + NEF(NCT,2)=NEF(N,2) + NEF(NCT,3)=NEF(N,3) + ENDIF + 700 END DO + NENTRY=NCT + NEFL=0 + RETURN + END +! + SUBROUTINE CLENUP(ITYP) +! +! Clean up transitions on the boundary of the refined area +! +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! + DIMENSION NTEMP(9),NTRAN(9),NSWT(8) +! +! First loop through elements looking for transitions +! + IF(ITYP .EQ. 0) THEN + NEO=NE + ELSE + NEO=NEFL + ENDIF +! DO KN=1,NEO +! WRITE(234,*) KN,NEFLAG(KN),NEF(KN,1),NEF(KN,2),NEF(KN,3) +! ENDDO + DO 500 KN=1,NEO + IF(ITYP .EQ. 0) THEN + N=KN + IF(IMAT(N) .EQ. 0) GO TO 500 + ELSE + N=NEFLAG(KN) + ENDIF + NCN=NCORN(N) + +!ipk sep99 add test for line element + + if(ncn .eq. 3) go to 500 +! +! Loop on sides +! + IFND=0 + NSWT(8)=0 + DO 400 K=2,NCN,2 +! +! Search for left over entry in NEF +! + DO 350 I=1,NENTRY + IF(NOP(N,K-1) .EQ. NEF(I,3)) THEN + KP=MOD(K+1,NCN) + IF(NOP(N,KP) .EQ. ABS(NEF(I,1))) THEN +! +! We have a match, start building TEMP +! + NTEMP(K-1)=NEF(I,3) + NTEMP(K)=NEF(I,2) + NSWT(K)=1 + IFND=1 + GO TO 400 + ENDIF + ENDIF + IF(ITYP .GT. 0) THEN + IF(NOP(N,K-1) .EQ. ABS(NEF(I,1))) THEN + KP=MOD(K+1,NCN) + IF(NOP(N,KP) .EQ. NEF(I,3)) THEN +! +! We have a match, start building TEMP +! + NTEMP(K-1)=ABS(NEF(I,1)) + NTEMP(K)=NEF(I,2) + NSWT(K)=1 + IFND=1 + GO TO 400 + ENDIF + ENDIF + ENDIF + 350 CONTINUE +! +! No match copy old values +! + NTEMP(K-1)=NOP(N,K-1) + NTEMP(K)=NOP(N,K) + NSWT(K)=0 + 400 CONTINUE + IF(IFND .EQ. 0) GO TO 500 +! +! Now test for match +! + NTOT=NSWT(2)+NSWT(4)+NSWT(6)+NSWT(8) + IF(NTOT .EQ. 0) GO TO 500 +! +! Delete element +! + DO 420 K=1,8 + NOP(N,K)=0 + 420 CONTINUE + NRMAT=IMAT(N) + IMAT(N)=0 + NELAST=MIN(NELAST,N) +! +! Work with triangles first +! + IF(NCN .EQ. 6) THEN +! +! Determine transition type and prepare to rotate connections +! + IF(NTOT .EQ. 1) THEN + NTYP=3 + IF(NSWT(2) .EQ. 1) THEN + ISHIFT=0 + ELSEIF(NSWT(4) .EQ. 1) THEN + ISHIFT=2 + ELSEIF(NSWT(6) .EQ. 1) THEN + ISHIFT=4 + ENDIF + ELSEIF(NTOT .EQ. 2) THEN + NTYP=2 + IF(NSWT(2) .EQ. 0) THEN + ISHIFT=2 + ELSEIF(NSWT(4) .EQ. 0) THEN + ISHIFT=4 + ELSEIF(NSWT(6) .EQ. 0) THEN + ISHIFT=0 + ENDIF + ELSE + NTYP=1 + ISHIFT=0 + ENDIF +! +! Now rotate so that first mid node is refined +! + DO 430 K=1,NCN + KS=MOD(K+ISHIFT,NCN) + IF(KS .EQ. 0) KS=NCN + NTRAN(K)=NTEMP(KS) + 430 CONTINUE +! +! Now generate transition refined elements +! + CALL TGEN(NTRAN,NTYP,NRMAT) +! +! Now work on quadrilateral elements +! + ELSE +! +! Determine transition type and prepare to rotate connections +! + IF(NTOT .EQ. 1) THEN + NTYP=2 + IF(NSWT(2) .EQ. 1) THEN + ISHIFT=0 + ELSEIF(NSWT(4) .EQ. 1) THEN + ISHIFT=2 + ELSEIF(NSWT(6) .EQ. 1) THEN + ISHIFT=4 + ELSEIF(NSWT(8) .EQ. 1) THEN + ISHIFT=6 + ENDIF + ELSEIF(NTOT .EQ. 2) THEN + IF(NSWT(2) .EQ. 1) THEN + IF(NSWT(4) .EQ. 1) THEN + NTYP=3 + ISHIFT=0 + ELSEIF(NSWT(6) .EQ. 1) THEN + NTYP=4 + ISHIFT=0 + ELSE + NTYP=3 + ISHIFT=6 + ENDIF + ELSEIF(NSWT(4) .EQ. 1) THEN + IF(NSWT(6) .EQ. 1) THEN + NTYP=3 + ISHIFT=2 + ELSEIF(NSWT(8) .EQ. 1) THEN + NTYP=4 + ISHIFT=2 + ENDIF + ELSE + NTYP=3 + ISHIFT=4 + ENDIF + ELSEIF(NTOT .EQ. 3) THEN + NTYP=5 + IF(NSWT(2) .EQ. 0) THEN + ISHIFT=2 + ELSEIF(NSWT(4) .EQ. 0) THEN + ISHIFT=4 + ELSEIF(NSWT(6) .EQ. 0) THEN + ISHIFT=6 + ELSEIF(NSWT(8) .EQ. 0) THEN + ISHIFT=0 + ENDIF + ELSE + NTYP=1 + ISHIFT=0 + ENDIF +! +! Now rotate so that first mid node is refined +! + DO 450 K=1,NCN + KS=MOD(K+ISHIFT,NCN) + IF(KS .EQ. 0) KS=NCN + NTRAN(K)=NTEMP(KS) + 450 CONTINUE +! + IF(NTYP .EQ. 1 .OR. NTYP .EQ. 5) THEN +! +! If appropriate define a new node at the centroid +! + CALL GETNOD(N2) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=N2 + CORD(N2,1)=(CORD(NTEMP(1),1)+CORD(NTEMP(3),1) & + & +CORD(NTEMP(5),1)+CORD(NTEMP(7),1))/4. + CORD(N2,2)=(CORD(NTEMP(1),2)+CORD(NTEMP(3),2) & + & +CORD(NTEMP(5),2)+CORD(NTEMP(7),2))/4. + IF(LOCK(NTEMP(1)) .EQ. 1 .AND. LOCK(NTEMP(3)) .EQ. 1 .AND. & + & LOCK(NTEMP(5)) .EQ. 1 .AND. LOCK(NTEMP(7)) .EQ. 1) LOCK(N2)=1 + INEW(N2) = 1 +!ipk jan98 + IF(IDELV .EQ. 1) then + WD(N2)=-9999. + ELSE + WD(N2)= (WD(NTEMP(1))+WD(NTEMP(3)) & + & +WD(NTEMP(5))+WD(NTEMP(7)))/4. + ENDIF + WIDTH(N2)=0. + SS1(N2)=0. + SS2(N2)=0. + WIDS(N2)=0. + XUSR(N2) = CORD(N2,1)*TXSCAL - XS + YUSR(N2) = CORD(N2,2)*TXSCAL - YS + NTRAN(9)=N2 + INSKP(N2)=0 +! +! Now generate transition refined elements +! + ENDIF + CALL RGEN(NTRAN,NTYP,NRMAT) + ENDIF + 500 END DO + IF(ITYP .EQ. 0) THEN + NENTRY=0 + ELSE + DO 600 I=1,NENTRY + IF(NEF(I,1) .LT. 0) NEF(I,1)=0 + 600 CONTINUE + ENDIF + RETURN + END +! + SUBROUTINE RGEN(NTRAN,NTYP,NRMAT) +! +! Routine to refine quadrilateral elements +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! +! IRGEN contains pointers to the various connections +! + INTEGER*2 IRGEN + DIMENSION NTRAN(9),IRGEN(8,5,5) +! + DATA IRGEN /1,0,2,0,9,0,8,0,3,0,4,0,9,0,2,0,5,0,6,0,9,0,4,0, & + & 7,0,8,0,9,0,6,0,8*0, & + & 1,0,2,0,7,8,0,0,3,4,5,0,2,0,0,0,5,6,7,0,2,0,0,0,16*0, & + & 1,0,2,0,7,8,0,0,3,0,4,0,2,0,0,0,5,6,7,0,4,0,0,0, & + & 7,0,2,0,4,0,0,0,8*0, & + & 1,0,2,0,6,0,7,8,2,0,3,4,5,0,6,0,24*0, & + & 1,0,2,0,9,0,0,0,3,0,4,0,9,0,2,0,5,0,6,0,9,0,4,0, & + & 7,0,9,0,6,0,0,0,7,8,1,0,9,0,0,0/ +! + DO 300 N=1,5 + IF(IRGEN(1,N,NTYP) .EQ. 0) GO TO 310 + CALL GETELM(NEM) + NEUNDO=NEUNDO+1 + IELDEL(NEUNDO)=NEM + DO 250 K=1,7,2 + INN=IRGEN(K,N,NTYP) + INP=IRGEN(K+1,N,NTYP) + IF(INN .GT. 0) INN=NTRAN(INN) + IF(INP .GT. 0) INP=NTRAN(INP) + NOP(NEM,K)=INN + NOP(NEM,K+1)=INP + 250 CONTINUE + IF(NOP(NEM,7) .EQ. 0) THEN + NCORN(NEM)=6 + ELSE + NCORN(NEM)=8 + ENDIF + IMAT(NEM)=NRMAT + IESKP(NEM)=0 +!IPK JAN98 + IERC=0 + CALL PLTELM(NEM,IERC) + 300 END DO + 310 CONTINUE + RETURN + END +! + SUBROUTINE TGEN(NTRAN,NTYP,NRMAT) +! +! Routine to refine triangular elements +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! +! ITGEN contains pointers to the various connections +! + INTEGER*2 ITGEN + DIMENSION NTRAN(9),ITGEN(8,4,3) +! + DATA ITGEN /1,0,2,0,6,0,0,0,3,0,4,0,2,0,0,0, & + & 5,0,6,0,4,0,0,0,2,0,4,0,6,0,0,0, & + & 1,0,2,0,4,0,5,6,2,0,3,0,4,0,0,0,16*0, & + & 1,0,2,0,5,6,0,0,3,4,5,0,2,0,0,0,16*0/ +! + DO 300 N=1,4 + IF(ITGEN(1,N,NTYP) .EQ. 0) GO TO 310 + CALL GETELM(NEM) + NEUNDO=NEUNDO+1 + IELDEL(NEUNDO)=NEM + DO 250 K=1,7,2 + INN=ITGEN(K,N,NTYP) + INP=ITGEN(K+1,N,NTYP) + IF(INN .GT. 0) INN=NTRAN(INN) + IF(INP .GT. 0) INP=NTRAN(INP) + NOP(NEM,K)=INN + NOP(NEM,K+1)=INP + 250 CONTINUE + IF(NOP(NEM,7) .EQ. 0) THEN + NCORN(NEM)=6 + ELSE + NCORN(NEM)=8 + ENDIF + IMAT(NEM)=NRMAT + IESKP(NEM)=0 + IERC=0 + CALL PLTELM(NEM,IERC) + 300 END DO + 310 CONTINUE + RETURN + END + SUBROUTINE SPLIT(N) +! +! Routine to split quadrilateral elements in two +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! + DIST(N1,N2)=SQRT((CORD(N1,1)-CORD(N2,1))**2 & + & +(CORD(N1,2)-CORD(N2,2))**2) + if(nop(n,7) .eq. 0) go to 100 +! +! Loop around element looking for longest diagonal +! + L1=NOP(N,1) + L5=NOP(N,5) + D15=DIST(L1,L5) + L3=NOP(N,3) + L7=NOP(N,7) + D37=DIST(L3,L7) + CALL GETELM(NEM) + NEUNDO=NEUNDO+1 + IELDEL(NEUNDO)=NEM + IF(D15 .LT. D37) THEN + NOP(NEM,1)=L1 + NOP(NEM,2)=0 + NOP(NEM,3)=L5 + NOP(NEM,4)=NOP(N,6) + NOP(NEM,5)=L7 + NOP(NEM,6)=NOP(N,8) + IMAT(NEM)=IMAT(N) + IESKP(NEM)=0 + NCORN(NEM)=6 + NOP(N,6)=0 + NOP(N,7)=0 + NOP(N,8)=0 + NCORN(N)=6 + ELSE + NOP(NEM,1)=L3 + NOP(NEM,2)=NOP(N,4) + NOP(NEM,3)=L5 + NOP(NEM,4)=NOP(N,6) + NOP(NEM,5)=L7 + NOP(NEM,6)=0 + IMAT(NEM)=IMAT(N) + IESKP(NEM)=0 + NCORN(NEM)=6 + NOP(N,4)=0 + NOP(N,5)=L7 + NOP(N,6)=NOP(N,8) + NOP(N,7)=0 + NOP(N,8)=0 + NCORN(N)=6 + ENDIF + +! call plotot + RETURN + 100 continue +! +! triangle split +! + l1=nop(n,1) + l3=nop(n,3) + l5=nop(n,5) + d13=dist(l1,l3) + d35=dist(l3,l5) + d51=dist(l5,l1) + CALL GETELM(NEM) + NEUNDO=NEUNDO+1 + IELDEL(NEUNDO)=NEM + IMAT(NEM)=IMAT(N) + IESKP(NEM)=0 + NCORN(NEM)=6 + write(90,*) l1,l3,l5,d13,d35,d51,nentry + if(d13 .gt. d35) then + if(d13 .gt. d51) then +! +! Search table for L1 +! + IF(NENTRY .NE. 0) THEN + DO J=1,NENTRY + IF(L1 .EQ. NEF(J,3) .AND. L3 .EQ. NEF(J,1)) THEN +! +! We have found match so use this info +! + NOP(N,2)=NEF(J,2) + NEWND=NEF(J,2) +! +! For regular ops remove value in NEF(J,1) so that it seems blank and s +! otherwise set value negative +! IF(IELGB(2) .EQ. 1) THEN +! NEF(J,1)=0 +! ELSE + NEF(J,1)=-NEF(J,1) +! ENDIF + GO TO 200 + ENDIF + ENDDO + ENDIF +! +! Define a node, enter it, initialize it, and make entry in NEF +! + IF(NOP(N,2) .EQ. 0) THEN + CALL GETNOD(NEWND) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=NEWND + NOP(N,2)=NEWND + CORD(NEWND,1)=(CORD(L1,1)+CORD(L3,1))/2. + CORD(NEWND,2)=(CORD(L1,2)+CORD(L3,2))/2. + XUSR(NEWND) = CORD(NEWND,1)*TXSCAL - XS + YUSR(NEWND) = CORD(NEWND,2)*TXSCAL - YS + INEW(NEWND) = 1 + IF(LOCK(L1) .EQ. 1 .AND. LOCK(L3) .EQ. 1 ) LOCK(NEWND)=1 + + INSKP(NEWND) =0 + ELSE + NEWND=NOP(N,2) + IF(INEW(NEWND) .NE. 1) THEN + CORD(NEWND,1)=(CORD(L1,1)+CORD(L3,1))/2. + CORD(NEWND,2)=(CORD(L1,2)+CORD(L3,2))/2. + XUSR(NEWND) = CORD(NEWND,1)*TXSCAL - XS + YUSR(NEWND) = CORD(NEWND,2)*TXSCAL - YS + INEW(NEWND) = 1 + INSKP(NEWND) =0 + ENDIF + ENDIF +!ipk jan98 + IF(IDELV .EQ. 1) then + WD(NEWND)=-9999. + ELSE + WD(NEWND)=(WD(L1)+WD(L3))/2. + ENDIF + WIDTH(NEWND)=0. + SS1(NEWND)=0. + SS2(NEWND)=0. + WIDS(NEWND)=0. + NENTRY=NENTRY+1 + NEF(NENTRY,1)=L1 + NEF(NENTRY,2)=NEWND + NEF(NENTRY,3)=L3 + 200 CONTINUE + + nop(nem,1)=nop(n,1) + nop(nem,3)=newnd + nop(nem,5)=nop(n,5) + nop(nem,6)=nop(n,6) + nop(n,1)=newnd + nop(n,2)=0 + nop(n,6)=0 + else + +! +! Search table for L5 +! + IF(NENTRY .NE. 0) THEN + DO J=1,NENTRY + IF(L5 .EQ. NEF(J,3) .AND. L1 .EQ. NEF(J,1)) THEN +! +! We have found match so use this info +! + NOP(N,2)=NEF(J,2) + NEWND=NEF(J,2) +! +! For regular ops remove value in NEF(J,1) so that it seems blank and s +! otherwise set value negative +! IF(IELGB(2) .EQ. 1) THEN +! NEF(J,1)=0 +! ELSE + NEF(J,1)=-NEF(J,1) +! ENDIF + GO TO 300 + ENDIF + ENDDO + ENDIF +! +! Define a node, enter it, initialize it, and make entry in NEF +! + IF(NOP(N,6) .EQ. 0) THEN + CALL GETNOD(NEWND) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=NEWND + NOP(N,6)=NEWND + CORD(NEWND,1)=(CORD(L5,1)+CORD(L1,1))/2. + CORD(NEWND,2)=(CORD(L5,2)+CORD(L1,2))/2. + XUSR(NEWND) = CORD(NEWND,1)*TXSCAL - XS + YUSR(NEWND) = CORD(NEWND,2)*TXSCAL - YS + INEW(NEWND) = 1 + IF(LOCK(L1) .EQ. 1 .AND. LOCK(L5) .EQ. 1) LOCK(NEWND)=1 + INSKP(NEWND) =0 + ELSE + NEWND=NOP(N,6) + IF(INEW(NEWND) .NE. 1) THEN + CORD(NEWND,1)=(CORD(L5,1)+CORD(L1,1))/2. + CORD(NEWND,2)=(CORD(L5,2)+CORD(L1,2))/2. + XUSR(NEWND) = CORD(NEWND,1)*TXSCAL - XS + YUSR(NEWND) = CORD(NEWND,2)*TXSCAL - YS + INEW(NEWND) = 1 + INSKP(NEWND) =0 + ENDIF + ENDIF +!ipk jan98 + IF(IDELV .EQ. 1) then + WD(NEWND)=-9999. + ELSE + WD(NEWND)=(WD(L5)+WD(L1))/2. + ENDIF + WIDTH(NEWND)=0. + SS1(NEWND)=0. + SS2(NEWND)=0. + WIDS(NEWND)=0. + NENTRY=NENTRY+1 + NEF(NENTRY,1)=L5 + NEF(NENTRY,2)=NEWND + NEF(NENTRY,3)=L1 + 300 CONTINUE + + nop(nem,1)=nop(n,1) + nop(nem,2)=nop(n,2) + nop(nem,3)=nop(n,3) + nop(nem,5)=newnd + nop(n,1)=newnd + nop(n,2)=0 + nop(n,6)=0 + endif + elseif(d35 .gt. d51) then + +! +! Search table for L3 +! + IF(NENTRY .NE. 0) THEN + DO J=1,NENTRY + IF(L3 .EQ. NEF(J,3) .AND. L5 .EQ. NEF(J,1)) THEN +! +! We have found match so use this info +! + NOP(N,4)=NEF(J,2) + NEWND=NEF(J,2) +! +! For regular ops remove value in NEF(J,1) so that it seems blank and s +! otherwise set value negative +! IF(IELGB(2) .EQ. 1) THEN +! NEF(J,1)=0 +! ELSE + NEF(J,1)=-NEF(J,1) +! ENDIF + GO TO 400 + ENDIF + ENDDO + ENDIF +! +! Define a node, enter it, initialize it, and make entry in NEF +! + IF(NOP(N,4) .EQ. 0) THEN + CALL GETNOD(NEWND) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=NEWND + NOP(N,4)=NEWND + CORD(NEWND,1)=(CORD(L3,1)+CORD(L5,1))/2. + CORD(NEWND,2)=(CORD(L3,2)+CORD(L5,2))/2. + XUSR(NEWND) = CORD(NEWND,1)*TXSCAL - XS + YUSR(NEWND) = CORD(NEWND,2)*TXSCAL - YS + INEW(NEWND) = 1 + IF(LOCK(L3) .EQ. 1 .AND. LOCK(L5) .EQ. 1) LOCK(NEWND)=1 + INSKP(NEWND) =0 + ELSE + NEWND=NOP(N,4) + IF(INEW(NEWND) .NE. 1) THEN + CORD(NEWND,1)=(CORD(L3,1)+CORD(L5,1))/2. + CORD(NEWND,2)=(CORD(L3,2)+CORD(L5,2))/2. + XUSR(NEWND) = CORD(NEWND,1)*TXSCAL - XS + YUSR(NEWND) = CORD(NEWND,2)*TXSCAL - YS + INEW(NEWND) = 1 + INSKP(NEWND) =0 + ENDIF + ENDIF +!ipk jan98 + IF(IDELV .EQ. 1) then + WD(NEWND)=-9999. + ELSE + WD(NEWND)=(WD(L3)+WD(L5))/2. + ENDIF + WIDTH(NEWND)=0. + SS1(NEWND)=0. + SS2(NEWND)=0. + WIDS(NEWND)=0. + NENTRY=NENTRY+1 + NEF(NENTRY,1)=L3 + NEF(NENTRY,2)=NEWND + NEF(NENTRY,3)=L5 + 400 CONTINUE + + nop(nem,1)=nop(n,1) + nop(nem,2)=nop(n,2) + nop(nem,3)=nop(n,3) + nop(nem,5)=newnd + nop(n,3)=newnd + nop(n,2)=0 + nop(n,4)=0 + else + +! +! Search table for L5 +! + IF(NENTRY .NE. 0) THEN + DO J=1,NENTRY + IF(L5 .EQ. NEF(J,3) .AND. L1 .EQ. NEF(J,1)) THEN +! +! We have found match so use this info +! + NOP(N,2)=NEF(J,2) + NEWND=NEF(J,2) +! +! For regular ops remove value in NEF(J,1) so that it seems blank and s +! otherwise set value negative +! IF(IELGB(2) .EQ. 1) THEN +! NEF(J,1)=0 +! ELSE + NEF(J,1)=-NEF(J,1) +! ENDIF + GO TO 500 + ENDIF + ENDDO + ENDIF +! +! Define a node, enter it, initialize it, and make entry in NEF +! + IF(NOP(N,6) .EQ. 0) THEN + CALL GETNOD(NEWND) + NPUNDO=NPUNDO+1 + NODDEL(NPUNDO)=NEWND + NOP(N,6)=NEWND + CORD(NEWND,1)=(CORD(L5,1)+CORD(L1,1))/2. + CORD(NEWND,2)=(CORD(L5,2)+CORD(L1,2))/2. + XUSR(NEWND) = CORD(NEWND,1)*TXSCAL - XS + YUSR(NEWND) = CORD(NEWND,2)*TXSCAL - YS + INEW(NEWND) = 1 + IF(LOCK(L1) .EQ. 1 .AND. LOCK(L5) .EQ. 1) LOCK(NEWND)=1 + INSKP(NEWND) =0 + ELSE + NEWND=NOP(N,6) + IF(INEW(NEWND) .NE. 1) THEN + CORD(NEWND,1)=(CORD(L5,1)+CORD(L1,1))/2. + CORD(NEWND,2)=(CORD(L5,2)+CORD(L1,2))/2. + XUSR(NEWND) = CORD(NEWND,1)*TXSCAL - XS + YUSR(NEWND) = CORD(NEWND,2)*TXSCAL - YS + INEW(NEWND) = 1 + INSKP(NEWND) =0 + ENDIF + ENDIF +!ipk jan98 + IF(IDELV .EQ. 1) then + WD(NEWND)=-9999. + ELSE + WD(NEWND)=(WD(L5)+WD(L1))/2. + ENDIF + WIDTH(NEWND)=0. + SS1(NEWND)=0. + SS2(NEWND)=0. + WIDS(NEWND)=0. + NENTRY=NENTRY+1 + NEF(NENTRY,1)=L5 + NEF(NENTRY,2)=NEWND + NEF(NENTRY,3)=L1 + 500 CONTINUE + + nop(nem,1)=nop(n,1) + nop(nem,2)=nop(n,2) + nop(nem,3)=nop(n,3) + nop(nem,5)=newnd + nop(n,1)=newnd + nop(n,2)=0 + nop(n,6)=0 + endif + return + END + SUBROUTINE REVERS(N1,N2) +! +! Routine to reverse diagonal of two quadrilateral elements +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! +! Search for common nodes on the elements +! + DO 300 M=1,NCORN(N1),2 + J=NOP(N1,M) + DO 250 MM=1,NCORN(N2),2 + JJ=NOP(N2,MM) + IF(JJ .EQ. J) THEN +! +! We have a match find the other nodes around element +! + MID1=M+1 + JMID1=NOP(N1,MID1) + write(90,*) n1,mid1,jmid1 + MID2=M+3 + IF(M .EQ. 5) MID2=2 + JMID2=NOP(N1,MID2) + MID3=M+5 + IF(MID3 .GT. 6) MID3=MID3-6 + JMID3=NOP(N1,MID3) +! +! Now find the other node +! + M1=M+2 + IF(M1 .GT. 6) M1=1 + J1=NOP(N1,M1) + MM1=MM-2 + IF(MM1 .LT. 1) MM1=5 + JJ1=NOP(N2,MM1) + IF(J1 .EQ. JJ1) THEN +! +! We have the other match find nodes around the element +! + MID4=MM+1 + JMID4=NOP(N2,MID4) + MID5=MM+3 + IF(MM .EQ. 5) MID5=2 + JMID5=NOP(N2,MID5) + M2=9-M-M1 + MM2=9-MM-MM1 + J2=NOP(N1,M2) + JJ2=NOP(N2,MM2) + NOP(N1,1)=J2 + NOP(N1,2)=JMID3 + NOP(N1,3)=J + NOP(N1,4)=JMID4 + NOP(N1,5)=JJ2 + NOP(N1,6)=JMID1 + NOP(N2,1)=JJ2 + NOP(N2,2)=JMID5 + NOP(N2,3)=J1 + NOP(N2,4)=JMID2 + NOP(N2,5)=J2 + NOP(N2,6)=JMID1 + write(90,*) (nop(n1,i),i=1,6) + write(90,*) (nop(n2,i),i=1,6) + if(jmid1 .gt. 0) then + CORD(JMID1,1) = (CORD(J2,1)+CORD(JJ2,1))/2.0 + CORD(JMID1,2) = (CORD(J2,2)+CORD(JJ2,2))/2.0 + XUSR(JMID1) = CORD(JMID1,1)*TXSCAL - XS + YUSR(JMID1) = CORD(JMID1,2)*TXSCAL - YS + IF(NECON(JMID2,1) .EQ. N1) NECON(JMID2,1)=N2 + IF(NECON(JMID2,2) .EQ. N1) NECON(JMID2,2)=N2 + IF(NECON(JMID4,1) .EQ. N2) NECON(JMID4,1)=N1 + IF(NECON(JMID4,2) .EQ. N2) NECON(JMID4,2)=N1 + endif + GO TO 350 + ENDIF + ENDIF + 250 CONTINUE + 300 END DO + 350 CONTINUE +! CALL PLOTOT + RETURN + END diff --git a/src/REGSTR.F90 b/src/REGSTR.F90 new file mode 100644 index 0000000..44a4d45 --- /dev/null +++ b/src/REGSTR.F90 @@ -0,0 +1,325 @@ +! Last change: IPK 24 Aug 2001 3:08 pm + SUBROUTINE REGISTR(I) + USE BLK1MOD +! INCLUDE 'BLK1.COM' + INCLUDE 'BFILES.I90' + + CALL SLPOINT(A1,B1,A2,B2,C1,D1,C2,D2,N) +! +! A1 = X CORD OF DESIRED WORLD-1 +! B1 = Y CORD OF DESIRED WORLD-1 +! A2 = X CORD OF DESIRED WORLD-2 +! B2 = X CORD OF DESIRED WORLD-2 +! C1 = X CORD OF INPUT WORLD-1 +! D1 = Y CORD OF INPUT WORLD-1 +! C2 = X CORD OF INPUT WORLD-2 +! D2 = X CORD OF INPUT WORLD-2 + + IF(N .EQ. 1) THEN + +! Compute new locations + + SCALEER= (A2-A1)/(C2-C1) + ASIZ=(BFMINMAX(I,3)-BFMINMAX(I,1))*SCALEER + FLEFT=(C1-BFMINMAX(I,1))/(BFMINMAX(I,3)-BFMINMAX(I,1)) + XNEW1=A1-FLEFT*ASIZ + XNEW2=XNEW1+ASIZ + WRITE(90,*) 'X-SCAL',SCALEER,ASIZ,FLEFT,XNEW1,XNEW2 + SCALEER= (B2-B1)/(D2-D1) + BSIZ=(BFMINMAX(I,4)-BFMINMAX(I,2))*SCALEER + FBEL=(D1-BFMINMAX(I,2))/(BFMINMAX(I,4)-BFMINMAX(I,2)) + YNEW1=B1-FBEL*BSIZ + YNEW2=YNEW1+BSIZ + WRITE(90,*) 'Y-SCAL',SCALEER,BSIZ,FBEL,YNEW1,YNEW2 + +! Confirm that they are acceptable + + CALL DISPREG(BFMINMAX(I,1),BFMINMAX(I,2),BFMINMAX(I,3),BFMINMAX(I,4),XNEW1,YNEW1,XNEW2,YNEW2,NN) + WRITE(90,*) 'AFTER DIS',NN,XNEW1,YNEW1,XNEW2,YNEW2 + +! Store them in the appropriate array + + IF(NN .EQ. 1) THEN + BFMINMAX(I,1)=XNEW1 + BFMINMAX(I,2)=YNEW1 + BFMINMAX(I,3)=XNEW2 + BFMINMAX(I,4)=YNEW2 + ELSE + RETURN + ENDIF + +! Save them if they are wanted + + CALL SAVORG(I,1) + + ENDIF + + RETURN + END SUBROUTINE + +! Display selected origins + + SUBROUTINE DISPREG(A1,B1,A2,B2,C1,D1,C2,D2,NN) + +! This subroutine gets points +! + USE WINTERACTER + + IMPLICIT NONE +! +! Define some parameters to match those in the resource file +! + include 'd.inc' +! +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INTEGER :: N,IBOX,NN + INTEGER :: IERR + REAL :: A1,B1,A2,B2,C1,D1,C2,D2 + CHARACTER*1 :: IFLAG + + + + call wdialogload(IDD_CONFIRM) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_CONFIRM) + ierr=infoerror(1) + + CALL WDialogPutReal(IDF_REAL1,A1,'(F8.0)') + CALL WDialogPutReal(IDF_REAL2,B1,'(F8.0)') + CALL WDialogPutReal(IDF_REAL5,A2,'(F8.0)') + CALL WDialogPutReal(IDF_REAL6,B2,'(F8.0)') + CALL WDialogPutReal(IDF_REAL3,C1,'(F8.0)') + CALL WDialogPutReal(IDF_REAL4,D1,'(F8.0)') + CALL WDialogPutReal(IDF_REAL7,C2,'(F8.0)') + CALL WDialogPutReal(IDF_REAL8,D2,'(F8.0)') + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + +! Branch depending on type of message. +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + NN=1 + CALL WDialogGetReal(IDF_REAL1,A1) + CALL WDialogGetReal(IDF_REAL2,B1) + CALL WDialogGetReal(IDF_REAL5,A2) + CALL WDialogGetReal(IDF_REAL6,B2) + CALL WDialogGetReal(IDF_REAL3,C1) + CALL WDialogGetReal(IDF_REAL4,D1) + CALL WDialogGetReal(IDF_REAL7,C2) + CALL WDialogGetReal(IDF_REAL8,D2) + RETURN + ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + NN=0 + RETURN + ENDIF +!ipk sep02 + NN=0 + RETURN + ENDDO + RETURN + END + +! Select points + + SUBROUTINE SLPOINT(A1,B1,A2,B2,C1,D1,C2,D2,NN) +! +! This subroutine gets points +! + USE WINTERACTER + + IMPLICIT NONE +! +! +! Define some parameters to match those in the resource file +! + include 'd.inc' + + INTEGER :: NP,NE,NHTP,NMESS,NBRR,IPSW,IRMAIN,ISCRN,icolon,IQSW,IRDISP,ntempin,IGFGSW,IGFGSWB,ICRIN,IPW1,WIDEL,WIDSCL,itrianout + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout + + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL +! + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INTEGER :: N,IBOX,NN + INTEGER :: IERR +!IPK MAY02 + REAL :: A1,B1,A2,B2,C1,D1,C2,D2,XX,YY + CHARACTER*1 :: IFLAG + + + call wdialogload(IDD_SLRGNO) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_SLRGNO) + ierr=infoerror(1) + + CALL WDialogPutINTEGER(IDF_INTEGER1,N) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + +! Branch depending on type of message. +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetINTEGER(IDF_INTEGER1,N) + GO TO 150 + ENDIF +!ipk sep02 + RETURN + ENDDO + 150 CONTINUE + + NHTP=0 + NBRR=3 + NMESS=43 + CALL HEDR + WRITE(90,*) 'BACK FROM HEDR' + IF(N .EQ. 1) THEN + CALL XYLOC(XX,YY,iflag,ibox) + C1 = XX*TXSCAL - XS + D1 = YY*TXSCAL - YS + WRITE(90,*) 'BACK FROM XYLOC-1',C1,D1,IBOX,IFLAG + ELSE + CALL XYLOC(XX,YY,iflag,ibox) + C2 = XX*TXSCAL - XS + D2 = YY*TXSCAL - YS + WRITE(90,*) 'BACK FROM XYLOC-2',C2,D2,IBOX,IFLAG + ENDIF + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + CALL WRTOUT(0) + RETURN + ENDIF + + call wdialogload(IDD_REGST) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_REGST) + ierr=infoerror(1) + + CALL WDialogPutReal(IDF_REAL1,A1,'(F8.0)') + CALL WDialogPutReal(IDF_REAL2,B1,'(F8.0)') + CALL WDialogPutReal(IDF_REAL3,A2,'(F8.0)') + CALL WDialogPutReal(IDF_REAL4,B2,'(F8.0)') + CALL WDialogPutReal(IDF_REAL5,C1,'(F8.0)') + CALL WDialogPutReal(IDF_REAL6,D1,'(F8.0)') + CALL WDialogPutReal(IDF_REAL7,C2,'(F8.0)') + CALL WDialogPutReal(IDF_REAL8,D2,'(F8.0)') + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + +! Branch depending on type of message. +! + IF (WInfoDialog(ExitButton) .EQ. IDADJUST) THEN + + CALL WDialogGetReal(IDF_REAL1,A1) + CALL WDialogGetReal(IDF_REAL2,B1) + CALL WDialogGetReal(IDF_REAL3,A2) + CALL WDialogGetReal(IDF_REAL4,B2) + CALL WDialogGetReal(IDF_REAL5,C1) + CALL WDialogGetReal(IDF_REAL6,D1) + CALL WDialogGetReal(IDF_REAL7,C2) + CALL WDialogGetReal(IDF_REAL8,D2) + NN=1 + RETURN + ELSEIF (WInfoDialog(ExitButton) .EQ. IDFSWITCH) THEN + + CALL WDialogGetReal(IDF_REAL1,A1) + CALL WDialogGetReal(IDF_REAL2,B1) + CALL WDialogGetReal(IDF_REAL3,A2) + CALL WDialogGetReal(IDF_REAL4,B2) + CALL WDialogGetReal(IDF_REAL5,C1) + CALL WDialogGetReal(IDF_REAL6,D1) + CALL WDialogGetReal(IDF_REAL7,C2) + CALL WDialogGetReal(IDF_REAL8,D2) + IF(N .EQ. 1) THEN + N=2 + ELSE + N=1 + ENDIF + GO TO 150 + ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + NN=0 + RETURN + ENDIF +!IPK SEP02 + NN=0 + RETURN + ENDDO + RETURN + END + + + SUBROUTINE SAVORG(NN,III) + +! This subroutine askf to check first then saves ORG file data +! + USE WINTERACTER + + IMPLICIT NONE +! +! Define some parameters to match those in the resource file +! + include 'd.inc' +! +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INCLUDE 'BFILES.I90' + + INTEGER :: NN,I,III + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB + + IF(III .EQ. 1) THEN + CALL WMessageBox(YesNo,QuestionIcon,CommonOK, 'Do you wish to '// & + 'save locations as ORG file?', 'SAVE ORG FILE') +! +! If answer 'NO', return +! + IF (WInfoDialog(4) .EQ. 2) RETURN + ENDIF + +! Otherwise process + + CALL WSelectFile(ID_STRING11,SaveDialog+PromptOn,FNAME,'Save ORG File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + SUB='org' + CALL ADDSUB(FNAME,SUB) + OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED') + WRITE(104,'(4G16.8)') (BFMINMAX(NN,I),I=1,4) + CLOSE(104) + ENDIF + + RETURN + END \ No newline at end of file diff --git a/src/REORD.F90 b/src/REORD.F90 new file mode 100644 index 0000000..edc863b --- /dev/null +++ b/src/REORD.F90 @@ -0,0 +1,1049 @@ +!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR REORDERING + SUBROUTINE ORDALL + + INCLUDE 'BFILES.I90' + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout + + ISWALL=1 + nmess=45 + + CALL GETINT(ISWALL) + IF(ISWALL .EQ. 0) ISWALL=1 + ISW=0 + CALL REORD(ISW,ISWALL) + CALL WMessageBox(0,4,1,'REORDERING COMPLETE',' ') + + IRDONE=1 + + RETURN + + END + + + +!IPK LAST UPDATE JULY 11 2005 FIX BUG IN REORDERING +!ipk last update Nov 18 1996 +! Last change: IPK 12 Jan 98 2:06 pm +!ipk last update Jan 6 1997 disallow negative sums + SUBROUTINE ADDORD(ISW) +! +! Enter reordering sequence +! + USE WINTERACTER + USE BLK1MOD + INCLUDE 'BFILES.I90' + +! INCLUDE 'BLK1.COM' +!iPK APR94 + COMMON /RECOD/ IRECD,TSPC +! dimension ilisttmp(100) +! + CHARACTER*1 IFLAG + CHARACTER*14 HEADR + CHARACTER*60 STRELS + CHARACTER*80 LIND +! INTEGER*2 IPAG,NT + DATA MULTPG/0/ + DATA STRELS/' You have tried to reorder before executing "FILL"'/ + DATA XPRT/0./ +! +! Test to make sure fill has been executed. +! + IF(ISW .NE. 1) THEN + DO 70 N=1,NE + IF(IMAT(N) .GT. 0) THEN + DO 60 M=2,NCORN(N),2 +!ipkoct93 + if(imat(n) .gt. 900) go to 60 + IF(NOP(N,M) .EQ. 0) THEN + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK, & + 'You have tried to reorder before executing "FILL"'//CHAR(13) & + //'Reordering terminated',& + 'UNABLE TO REORDER') +! CALL SYMBL(0.,7.30,0.20,STRELS,0.,60) + RETURN + ENDIF + 60 CONTINUE + ENDIF + 70 CONTINUE + ENDIF +! +! + IF(ISW .EQ. 0) THEN +! +! Change screens if possible +! + IF(MULTPG .EQ. 1) THEN +! IPAG=1 +! NT=SETACTIVEPAGE(IPAG) +! NT=SETVISUALPAGE(IPAG) + ELSE + CALL CLSCRN + CALL SETD(23) + ENDIF + ISWW=0 + CALL WCursorShape(CurHourGlass ) + ISWALL=0 + CALL REORD(ISWW,ISWALL) + IRDONE=1 +!IPK AUG05 CALL REORD(ISWW) + CALL WCursorShape(CurArrow ) +! +! Restore screen +! +!pk jan98 WRITE(*,*) 'Press "Return" to restore grapical screen' + + CALL SHOWORD +! WRITE(LIND,6002) +! 6002 FORMAT( 'Press "Return" to restore grapical screen') +! call rblue +! call symbl & +! & (1.1,3.0,0.20,LIND,0.0,80) +! ndig=1 +! CALL GTCHARX(IFLAG,NDIG,5.0,7.6) + +!ipk jan98 READ(*,'(A)') IFLAG + IF(MULTPG .EQ. 1) THEN + IPAG=0 +! NT=SETACTIVEPAGE(IPAG) +! NT=SETVISUALPAGE(IPAG) + ELSE + CALL CLSCRN + CALL SETD(2) +! CALL PLOTS(0) +!ipk nov97 add (1) + CALL PLOTOT(1) + do n=1,ne + nn=iem(n) + if(imat(nn) .ne. 0 .AND. IESKP(NN) .EQ. 0) then + + call fillemC(nn,MOD(N/25,15)) + endif +! if(mod(n,200) .eq. 0) then +! READ(*,'(A)') IFLAG +! endif + enddo + ENDIF + ELSEIF(ISW .EQ. 1) THEN + 100 continue +! 100 WRITE(HEADR,5000) NLST +! 5000 FORMAT(' NLIST = ',I5) +! NHTP = 0 +! NMESS = 13 +! NBRR = 0 +! CALL HEDR +! CALL SYMBL(0.,7.50,0.20,HEADR,0.,14) +! XPRT=3.2 +! +! Form element reordering list by clicking on elements with cursor +! + 5001 FORMAT(I10) +! CALL GETINT(NLIST) +! READ(*,5001,ERR=220) NLIST +! +! Find element nearest cursor +! + J=0 + 200 IBOX=1 + NMESS = 12 + NBRR = 9 + CALL HEDR + CALL PLOTORDS + INREORD=1 + CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX) + INREORD=0 + CALL PLOTORDS +! write(90,*) 'reord' +! write(90,'(i10,a10)') ibox,iflag + IF(IRMAIN .EQ. 1) THEN + DO J=1,100 + ilisttmp (j)=0 + ENDDO + RETURN + ENDIF + 210 IF(IFLAG .EQ. 'c' .and. ibox .ne. 7) THEN + CALL FILLEM(IELEM) + XPRT=XPRT+0.5 + IF(XPRT .GT. HSIZE) XPRT=0. + FPN= IELEM + CALL NUMBR(XPRT,7.20,0.20,FPN,0.0,-1) + J=J+1 + ilisttmp (j)=ielem +! ILIST(NLIST,J)=IELEM + GO TO 200 + ELSEIF (IFLAG .EQ. 'U') THEN + ilisttmp (j)=0 + J=J-1 + CALL PLOTOT(1) + CALL HEDR + DO IELEM=1,J + CALL FILLEM(ILISTTMP(IELEM)) + ENDDO + GO TO 200 + ELSEIF(IFLAG .EQ. 'e') THEN +! LLIST(NLIST)=J + nlist=nlst+1 + call getnlist(nlist) + LLIST(NLIST)=J + do i=1,j + ilist(nlist,i)=ilisttmp(i) + enddo + IF(NLIST .GT. NLST) NLST=NLIST + DO J=1,100 + ilisttmp (j)=0 + ENDDO + GO TO 100 + ELSEIF(IFLAG .EQ. 'a' .or. ibox .eq. 7) THEN + nlist=nlst+1 + IF(IRECD .NE.2) call getnlist(nlist) + LLIST(NLIST)=J + do i=1,j + ilist(nlist,i)=ilisttmp(i) + enddo + IF(NLIST .GT. NLST) NLST=NLIST + DO J=1,100 + ilisttmp (j)=0 + ENDDO + GO TO 100 + ELSEIF(IFLAG .EQ. 'q') THEN +! LLIST(NLIST)=J +! IF(NLIST .GT. NLST) NLST=NLIST +! CALL REORD(NLIST) +! CALL WRTOUT(0) + DO J=1,100 + ilisttmp (j)=0 + ENDDO + ENDIF + ELSEIF(ISW .EQ. 2) THEN +! +! Change screens if possible +! + IF(MULTPG .EQ. 1) THEN + IPAG=1 +! NT=SETACTIVEPAGE(IPAG) +! NT=SETVISUALPAGE(IPAG) + ELSE + CALL CLSCRN + CALL SETD(23) + ENDIF + ISWW=NLIST + ISWALL=0 + CALL REORD(ISWW,ISWALL) +!IPK AUG05 CALL REORD(ISWW) +! +! Restore screen +! +!IPK JAN98 WRITE(*,*) 'Press "Return" to restore grapical screen' +!IPK JAN98 READ(*,'(A)') IFLAG + CALL SHOWORD +! WRITE(LIND,6002) +! call symbl & +! & (1.1,3.0,0.20,LIND,0.0,80) +! ndig=1 +! CALL GTCHARX(IFLAG,NDIG,5.0,7.6) + IF(MULTPG .EQ. 1) THEN + IPAG=0 +! NT=SETACTIVEPAGE(IPAG) +! NT=SETVISUALPAGE(IPAG) + ELSE + CALL CLSCRN + CALL SETD(2) +! CALL PLOTS(0) +!ipk nov97 add (1) + CALL PLOTOT(1) + ENDIF + ENDIF + 220 RETURN + END + SUBROUTINE REORD (ISW,ISWALL) +! +! DRIVING ROUTINE TO REORDER ELEMENTS +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' +! +! INITIALIZE +! + IF(IECHG .EQ. 0) THEN + NCM=MAXECON + NCMI=MAXECON + NAD=0 + MP=0 + IPASS=1 +! +! GET TABLE OF ELEMENT CONNECTIONS +! + CALL KCON(0) +! +! SETUP NELIM. IDENTIFIES 3 NODE ELEMENTS OR JUNCTIONS WHEN = 1 +! + DO 250 N=1,NE + IF(IMAT(N) .NE. 0) THEN +!ipkoct93 + IF(NCORN(N) .EQ. 3 .OR. (IMAT(N) .GT. 900 .and. & + & ncorn(n) .ne. 8)) THEN + NELIM(N)=1 + ELSE + NELIM(N)=0 + ENDIF + ELSE + NELIM(N)=1 + ENDIF + 250 CONTINUE + IECHG=1 +!IPK MAY03 + ICHG=0 + +! +! PROCESS INITIAL ORDER +! + IF(ISW .EQ. 0) THEN + CALL ORDER(ISWALL) + ISW=ISW+1 + ENDIF + ENDIF + IF(ISW .EQ. 0) ISW=1 +! +! OTHERWISE RESET MLIST +! + 305 DO 310 N=1,NAE + MLIST(N)=0 + 310 END DO +! +! SET STARTING SEQUENCE +! + +!IPK AUG05 + IF(ISWALL .EQ. 0) THEN + + NN=1 + DO 320 N=1,NAE + MLIST(NN)=ILIST(ISW,N) + IF(NN .GT. 1) THEN + IF(MLIST(NN) .EQ. MLIST(NN-1)) THEN + NN=NN-1 + ENDIF +!IPK JUL05 FIX BUG MOVE DOWN NN=NN+1 + ENDIF + NN=NN+1 +! write(90,*) 'Entries forming start of list',n,mlist(n) + IF(MLIST(N) .EQ. 0) GO TO 325 + 320 END DO + ELSE + 322 CONTINUE + IF(MOD(ISW,ISWALL) .EQ. 0) THEN + MLIST(1)=ISW + ELSE + ISW=ISW+1 + GO TO 322 + ENDIF + + ENDIF +! + 325 MP=0 + NAD=0 +! +! RESET NODE TO ELEMENT LIST +! + DO 340 N=1,NP + DO 335 M=1,NCM + IF(NECON(N,M) .EQ. 0) GO TO 338 + 335 CONTINUE + 338 NDELM(N)=M-1 + 340 END DO +! +! RESET ELEMENT CONNECTIONS +! + DO 350 N=1,NE + DO 350 M=1,NCMI + ICON(N,M)=IABS(ICON(N,M)) + 350 CONTINUE +! +! GO TO PROCESS THIS SEQUENCE +! + IF(MLIST(1) .GT. 0) THEN + CALL ORDER(ISWALL) + ISW=ISW+1 + ELSE + GO TO 600 + ENDIF + IF(ISWALL .EQ. 0) THEN + IF(ISW .GT. NLST) GO TO 600 + ELSE + WRITE(90,*) MLIST(1),MTSUMSV(NSEQ),NFWSV(NSEQ),IEM(1),MRSUM + + IF(ISW .GT. NE) GO TO 600 + ENDIF + GO TO 305 +! +! PRINT FINAL ORDER +! + 600 WRITE(90,6040) (IEM(K),K=1,NAE) + 6040 FORMAT(//' SELECTED ELEMENT ORDER'/(10I6)) +! +! RETURN TO MAIN +! + RETURN + END + SUBROUTINE ORDER(ISWALL) +! +! FIND ORDER AND FRONT SUM FOR A GIVEN START POINT +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' +! +! SET LIST OF INCORPORATED NODES +! + DO 200 N=1,NP + 200 NINC(N)=0 +! +! SET COUNTER ON ELEMENTS +! + KNT=0 + MTSUM=0 +!ipk feb97 add mtsum1 + mtsum1=0 +!IPK MAY94 LINE ADDED + NFWSAV=0 +! +! PROCESS THROUGH ELEMENTS +! + 300 CONTINUE +! +! SET MLIST FROM INPUT IF NON-ZERO WE MUST FIND KREC +! + KREC=MLIST(KNT+1) +! +! GET NEXT ELEMENT TO ADDED +! + CALL MOVFNT(KREC,ISWALL) + +!ipk mar04 + IF(KREC .lt. 0) THEN + write(90,*) 'krec',knt,mlist(knt) + MTSUM=9999999999999 + MTSUM1=9999999999999 + GO TO 310 + ENDIF +! +! SAVE SELECTED VALUE +! + MLIST(KNT+1)=KREC + KNT=KNT+1 +! +! UPDATE FRONT AND CONNECTION TABLES +! + CALL UPFNT(KREC) +! WRITE(91,9000) KREC,MTSUM,MSUM,MP,NAD +! 9000 FORMAT(' KREC MTSUM MSUM MP NAD'/I6,2I15,2I5) +! +! TEST FOR FULL SET OF ELEMENTS +! + IF (KNT.LT.NAE) GO TO 300 +! +! FOR COMPLETE ORDER CHECK IF IT IS IMPROVEMENT +! +!IPK MAR04 + 310 CONTINUE + CALL CHKOUT(ISWALL) +! +! FINISHED +! + RETURN + END + SUBROUTINE MOVFNT(KREC,ISWALL) +! +! GET ELEMENT THAT INCREASES FRONT WIDTH LEAST +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + INTEGER*8 MSAV,MSA + CHARACTER*80 LIND + CHARACTER*1 JUNK +! +! INITIALIZE +! + MSAV=99999999 + NSN=99999 +! +! SKIP IF KREC ALREADY DEFINED +! + IF(KREC .GT. 0) GO TO 310 +! +! SEARCH ADJACENT ELEMENTS +! + NTST=NITST + 260 NFD=0 + if(nad .eq. 0) then +!IPK JAN98 write(*,*) 'nad in trouble type q and press return,enxt(1)',enxt(1) +!IPK JAN98 read(*,*) njunk +!ipk mar04 WRITE(LIND,6002)krec,nsn +!ipk mar04 6002 FORMAT( 'NAD =0 illegal connection. krec,nsn',2i5,'Type q to exit') +!ipk mar04 call symbl & +!ipk mar04 & (1.1,3.0,0.20,LIND,0.0,80) +!ipk mar04 ndig=1 +!ipk mar04 CALL GTCHARX(JUNK,NDIG,5.0,7.6) +!ipk mar04 stop + IF(ISWALL .GT. 0) THEN + KREC=-1 + RETURN + ENDIF + write(90,*) nae + write(90,'(5(i7,i6))') (n,mlist(n),n=1,ne) + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK, & + 'No active adjacent elements found '//CHAR(13) & + //'Possible network error.'//CHAR(13) & + //'or erroneous starting element'//CHAR(13) & + //'Reordering terminated',& + 'ERROR') + krec=-1 + return + endif + DO 300 K=1,NAD + NEL=ENXT(K) + IF(NTST .EQ. 0) GO TO 270 + IF(NELIM(NEL) .EQ. 1) GO TO 300 + 270 CONTINUE + NFD=1 +! +! GET SUMS FOR NEL +! + CALL SUMIT(NEL) +! +! MSA IS THE AVERAGE PER NODE ADDED +! + MSA=MSUM +! MSA=9999999 + IF(NDP .GT. 1) MSA=(MSUM+NDP/2)/NDP +! +! CHECK IF IT IS LESS +! + IF (MSA.GT.MSAV) GO TO 300 + IF (MSA.LT.MSAV) GO TO 280 +! +! IF EQUAL TAKE CASE WITH LEAST NODES ADDED +! + IF (NDP.GE.NSN) GO TO 300 + 280 KREC=NEL + NSN=NDP + MSAV=MSA + 300 END DO + IF(NFD .EQ. 0) THEN + NTST=0 + GO TO 260 + ENDIF + 310 CONTINUE +! +! GET INFORMATION AGAIN FOR SELECTED ELEMENT +! + CALL SUMIT(KREC) +!IPK MAY94 ADD A LINE + IF(NFWS .GT. NFWSAV) NFWSAV=NFWS + IF(MSUM .EQ. 9999999) MSUM=0 + MTSUM=MTSUM+MSUM +!ipk feb97 add pseudo double precision + 320 continue +! if(mtsum .gt. 100000000) then +! mtsum1=mtsum1+1 +! mtsum=mtsum-100000000 +! go to 320 +! endif +! +! UPDATE LIST OF NODES IN FRONT +! + MPN=MP + IF (MP.EQ.0) GO TO 420 + IF (NDP.EQ.0) GO TO 420 +! +! REMOVE THE DROPPED NODES +! +! ict2=ict2+1 +! write(88,*) ict2,'z',krec,ndp,(ndrop(n),n=1,ndp) + DO 400 N=1,NDP +! +! FIND THE NODE TO BE DROPPED IN LIST +! + DO 390 M=1,MP + IF (LIST(M).NE.NDROP(N)) GO TO 390 + LIST(M)=-LIST(M) + GO TO 400 + 390 CONTINUE + 400 END DO +! +! NOW DROP THEM +! + MPN=0 + DO 410 M=1,MP + IF (LIST(M).LT.0) GO TO 410 + MPN=MPN+1 + LIST(MPN)=LIST(M) + 410 END DO +! +! NOW ADD NEWLY GENERATED NODES +! + IF (NNEW.EQ.0) GO TO 435 + 420 DO 430 M=1,NNEW +! +! FIRST SEE IF LNEW IS IN DROP LIST +! + IF(NDP .EQ. 0) GO TO 428 + DO 425 N=1,NDP + IF(LNEW(M) .EQ. NDROP(N)) GO TO 430 + 425 CONTINUE + 428 CONTINUE + MPN=MPN+1 + LIST(MPN)=LNEW(M) + K=LNEW(M) + NINC(K)=1 + 430 END DO +! +! REDUCE COUNT OF ELEMENTS ACQUIRED AT THE NODES OF THE ELEMENT +! + 435 CONTINUE + MP=MPN +! ict1=ict1+1 +! write(85,*) ict1,'x',krec,mp,(list(n),n=1,mp) + DO 440 K=1,8 + N=NOP(KREC,K) + IF (N.EQ.0) GO TO 440 + NDELM(N)=NDELM(N)-1 + 440 END DO + RETURN + END + SUBROUTINE UPFNT(KREC) +! +! DEFINE NEW INFO ON FRONT +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' +! +! SET ICON ENTRIES NEGATIVE TO SAY THIS ELEMENT ALREADY ADDED +! + DO 450 M=1,NCMI + K=ICON(KREC,M) + IF (K.EQ.0) GO TO 460 + IF (K.LT.0) GO TO 450 + DO 430 J=1,NCMI + IF (ICON(K,J).NE.KREC) GO TO 430 + ICON(K,J)=-ICON(K,J) + GO TO 450 + 430 CONTINUE + 450 END DO +! +! UPDATE LIST OF ELEMENTS STILL IN FRONT +! + 460 MNAD=0 +! +! FIRST ELIMINATE KREC +! + IF(NAD .EQ. 0) GO TO 510 + DO 500 K=1,NAD + IF (ENXT(K).EQ.KREC) GO TO 500 + MNAD=MNAD+1 + ENXT(MNAD)=ENXT(K) + 500 END DO + 510 CONTINUE + NAD=MNAD +! +! NOW ADD NEW ELEMENTS +! + DO 520 J=1,NCMI + K=ICON(KREC,J) + IF (K.LE.0) GO TO 520 +! +! CHECK OF -K- ALREADY IN LIST +! + DO 515 M=1,NAD + IF(K .EQ. ENXT(M)) GO TO 520 + 515 CONTINUE + MNAD=MNAD+1 + ENXT(MNAD)=K + 520 END DO + NAD=MNAD + RETURN + END + SUBROUTINE SUMIT(NEL) +! +! DEVELOP SUMS FOR MAKING ELIMINATION CHOICE +! + USE BLK1MOD + USE BLK2MOD + INTEGER*8 MSUMP +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' +! +! LOCATE NEW NODES +! + NDP=0 + NNEW=0 + DO 280 K=1,8 + N=NOP(NEL,K) + IF (N.EQ.0) GO TO 280 +! +! TEST WHETHER THIS NODE ALREADY INCORPORATED +! + IF (NINC(N).EQ.1) GO TO 260 + NNEW=NNEW+1 + LNEW(NNEW)=N +! +! NOW TEST IF THE NODE IS COMPLETELY FORMED +! + 260 IF (NDELM(N).GT.1) GO TO 280 + NDP=NDP+1 + NDROP(NDP)=N + 280 END DO +! +! IMMEDIATELY ON ADDING NEW FRONT SIZE IS +! + NFW=MP+NNEW +!IPK MAY94 ADD A LINE + NFWS=NFW +! +! NOW TAKE OUT ALL WE CAN +! + MSUM=99999999 +! MSUM=0 + IF(NDP .EQ. 0) RETURN + MSUMP=0 + DO 300 K=1,NDP + MSUMP=MSUMP+NFW**2 + NFW=NFW-1 + 300 END DO + msum=msump + if(msum .gt. 99999999) THEN + write(90,*) ndp,msum,nfw,nel + ENDIF + RETURN + END + SUBROUTINE CHKOUT(ISWALL) +! +! CHECK FINAL TOTAL SAVE ORDER IF BETTER +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + CHARACTER*80 LIND +! + DATA ITIME/0/ + IF(ITIME .EQ. 0) THEN +! call rblue +! call clscrn +! YT=7.5 +! WRITE(90,6010) mtsum1,MTSUM,NFWSAV +! WRITE(LIND,6010) mtsum1,MTSUM,NFWSAV +! WRITE(90,6010) MTSUM,NFWSAV +! WRITE(LIND,6010) MTSUM,NFWSAV +! call symbl & +! & (0.1,YT,0.20,LIND,0.0,80) + NSEQ=0 + MTSUMSV(NSEQ)=MTSUM + NFWSV(NSEQ)=NFWSAV +! elseif(mtsum1 .gt. mrsum1) then +! WRITE(90,6020) mtsum1,MTSUM,NFWSAV +! WRITE(LIND,6020) mtsum1,MTSUM,NFWSAV +! YT=YT-0.3 +! call symbl & +! & (0.1,YT,0.20,LIND,0.0,80) +! RETURN +! elseif(mtsum1 .eq. mrsum1) then +!IPK AUG05 ELSE + ELSEIF(ISWALL .EQ. 0) THEN + NSEQ=NSEQ+1 + MTSUMSV(NSEQ)=MTSUM + NFWSV(NSEQ)=NFWSAV + if(mtsum .ge. mrsum .AND. MRSUM .GT. 0) then +! WRITE(90,6020) mtsum1,MTSUM,NFWSAV +! WRITE(LIND,6020) mtsum1,MTSUM,NFWSAV +! WRITE(90,6020) MTSUM,NFWSAV +! WRITE(LIND,6020) MTSUM,NFWSAV +! YT=YT-0.3 +! call symbl & +! & (0.1,YT,0.20,LIND,0.0,80) + RETURN + else +! WRITE(90,6020) mtsum1,MTSUM,NFWSAV +! WRITE(LIND,6020) mtsum1,MTSUM,NFWSAV +! WRITE(90,6020) MTSUM,NFWSAV +! WRITE(LIND,6020) MTSUM,NFWSAV +! YT=YT-0.3 +! call symbl & +! & (0.1,YT,0.20,LIND,0.0,80) + endif +! ELSE +! WRITE(90,6020) mtsum1,MTSUM,NFWSAV +! WRITE(LIND,6020) mtsum1,MTSUM,NFWSAV +! WRITE(90,6020) MTSUM,NFWSAV +! WRITE(LIND,6020) MTSUM,NFWSAV +! YT=YT-0.3 +! call symbl & +! & (0.1,YT,0.20,LIND,0.0,80) + ELSE +! NSEQ=NSEQ+1 + if(mtsum .ge. mrsum .AND. MRSUM .GT. 0) then + NSEQ=0 + MTSUMSV(NSEQ)=MTSUM + NFWSV(NSEQ)=NFWSAV + RETURN + ELSE + NSEQ=0 + MTSUMSV(NSEQ)=MTSUM + NFWSV(NSEQ)=NFWSAV + endif + ENDIF +! mrsum1=mtsum1 + MRSUM=MTSUM + ITIME=1 +! 6010 FORMAT('ORDERING SUM, ORIGINAL ELEMENT ORDER, MAX FRONT' & +! &,I4,I8.8,I7) +! 6020 FORMAT('ORDERING SUM, LATEST START POINT, MAX FRONT' & +! &,I4,I8.8,I7) + 6010 FORMAT('ORDERING SUM, ORIGINAL ELEMENT ORDER, MAX FRONT' & + &,I12,I7) + 6020 FORMAT('ORDERING SUM, LATEST START POINT, MAX FRONT' & + &,I12,I7) +!ipk feb97 end changes +! +! COPY ORDER +! + DO 300 N=1,NAE + IEM(N)=MLIST(N) + 300 END DO +! +! FILL IEM ARRAY +! + NAEP=NAE+1 + DO 400 N=1,NE + IF(IMAT(N) .EQ. 0) THEN + IEM(NAEP)=N + NAEP=NAEP+1 + ENDIF + 400 END DO + RETURN + END + SUBROUTINE KCON(isw1) +! +! ESTABLISH ELEMENT CONNECTED TO ELEMENT TABLE +! + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' +! +! INITIALIZE +! + DO 200 J=1,NCM + DO 200 N=1,NP + 200 NECON(N,J)=0 + DO 210 J=1,NCMI + DO 210 M=1,NE + 210 ICON(M,J)=0 + DO 230 N=1,NP + 230 NDELM(N)=0 +! +! FORM TABLE OF ELEMENTS CONNECTED TO EACH NODE +! + DO 300 M=1,NE + IF(IMAT(M) .EQ. 0) GO TO 300 + if(isw1 .eq. 1) then + if(imat(m) .eq. 999) go to 300 + endif + DO 280 K=1,8 + N=NOP(M,K) + IF (N .GT. 0) THEN + NDELM(N)=NDELM(N)+1 + J=NDELM(N) + NECON(N,J)=M +!ipkoct93 ELSE +!ipkoct93 GO TO 300 + ENDIF + 280 CONTINUE + 300 END DO +! do n=1,np +! write(87,'(31i6)') n,(necon(n,j),j=1,ncmi) +! enddo +! write(89,*) 'yy' +! DO N=1,NP +! WRITE(89,*) 'NDELM',N,NDELM(N) +! ENDDO +! +! CONVERT TABLE TO ELEMENT TO ELEMENT CONNECTION +! + DO 600 N=1,NP +! +! PLACE PAIRS OF ENTRIES FOR EACH NODE INTO APPROPRIATE ROWS +! + NL=NDELM(N)-1 +! +! SKIP OUT WHEN ONE ELEMENT OR LESS NODE +! + IF (NL.LE.0) GO TO 600 + DO 420 J=1,NL + M=NECON(N,J) +! +! PROCESS SECOND ELEMENT IN A GIVEN ROW +! + DO 370 K=J+1,NL+1 + MR=NECON(N,K) + MS=M +! +! PROCESS EACH DIRECTION OF CONNECTION +! + DO 360 MX=1,2 +! +! SEARCH IN CASE CONNECTION ALREADY FOUND +! + DO 350 L=1,NCMI + IF (ICON(MS,L).NE.0) GO TO 345 + ICON(MS,L)=MR + GO TO 355 + 345 IF (ICON(MS,L).EQ.MR) GO TO 355 + 350 CONTINUE +! +! REVERSE MR-MS FOR SECOND PASS +! + 355 CONTINUE + MS=MR + MR=M + 360 CONTINUE +! +! END LOOP ON SECOND ELEMENT +! + 370 CONTINUE +! +! END LOOP ON FIRST ELEMENT +! + 420 CONTINUE +! +! END LOOP FOR THIS NODE +! + 600 END DO + +! do n=1,ne +! write(86,'(31i6)') n,(icon(n,j),j=1,ncmi) +! enddo + + + +! +! PROCESS TO FIND NUMBER OF ACTIVE ELEMENTS +! + NAE=0 + NTE=NE+1 + DO 700 M=1,NE + IF (IMAT(M) .LT. 1) GO TO 650 + NAE=NAE+1 + MLIST(NAE)=M + GO TO 700 + 650 NTE=NTE-1 + MLIST(NTE)=M + 700 END DO + RETURN + END + +!ipk jan01 + subroutine getnlist(ipos) + use winteracter + + implicit none + + include 'd.inc' + + INTEGER :: IPOS,IERR + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + + call wdialogload(IDD_DIALOG001) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_DIALOG001) + ierr=infoerror(1) + + CALL WDialogPutINTEGER(IDF_INTEGER1,IPOS) + +! write(90,*) 'iposin',ipos + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetINTEGER(IDF_INTEGER1,IPOS) +! write(90,*) 'iposout',ipos + + return + endif + return + enddo + + RETURN + END + +!ipk jan04 + subroutine SHOWORD + use winteracter + + + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + + include 'd.inc' + + INTEGER :: IERR + CHARACTER*6 SCOL1(101) + CHARACTER*18 SCOL2(101) + CHARACTER*8 SCOL3(101) + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + + call wdialogload(IDD_ORDEROUT) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_ORDEROUT) + ierr=infoerror(1) + DO I=0,NSEQ + WRITE(SCOL1(I+1),'(I4)') I + WRITE(SCOL2(I+1),'(I16)') MTSUMSV(I) + WRITE(SCOL3(I+1),'(I8)') NFWSV(I) + ENDDO + + CALL WGridPutString(IDF_GRID1,1,SCOL1,NSEQ+1) + CALL WGridPutString(IDF_GRID1,2,SCOL2,NSEQ+1) + CALL WGridPutString(IDF_GRID1,3,SCOL3,NSEQ+1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + + return + endif + enddo + + RETURN + END + diff --git a/src/RESETREG.f90 b/src/RESETREG.f90 new file mode 100644 index 0000000..ec3b3bd --- /dev/null +++ b/src/RESETREG.f90 @@ -0,0 +1,87 @@ + SUBROUTINE RESETREG + + USE WINTERACTER + + INCLUDE 'TXFRM.COM' + + INCLUDE 'BFILES.I90' + + CHARACTER*1 IFLAG + + + XORIGMIN=BFMINMAX(NBKFL,1) + YORIGMIN=BFMINMAX(NBKFL,2) + XORIGMAX=BFMINMAX(NBKFL,3) + YORIGMAX=BFMINMAX(NBKFL,4) + +! get reference point +! xrefpt +! yrefpt + + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select Fixed Reference point','CHOOSE REFERENCE') + + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + XREFPT = XTEMP*TXSCAL - XS + YREFPT = YTEMP*TXSCAL - YS + +! get start move point +! xlocs +! ylocs + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select Starting point','CHOOSE START') + + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + XLOCS = XTEMP*TXSCAL - XS + YLOCS = YTEMP*TXSCAL - YS + +! get finish move point +! xlocf +! ylocf + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Select Finishing point','CHOOSE FINISH') + + + CALL XYLOC(XTEMP,YTEMP,IFLAG,IBOX) + XLOCF = XTEMP*TXSCAL - XS + YLOCF = YTEMP*TXSCAL - YS + +! establish x moves + + stscal=(xlocf-xrefpt)/(xlocs-xrefpt) + xnewmin=xrefpt-(xrefpt-xorigmin)*stscal + xnewmax=xrefpt+(xorigmax-xrefpt)*stscal + +! establish y moves + + stscal=(ylocf-yrefpt)/(ylocs-yrefpt) + ynewmin=yrefpt-(yrefpt-yorigmin)*stscal + ynewmax=yrefpt+(yorigmax-yrefpt)*stscal + + BFMINMAX(NBKFL,1)=xnewmin + BFMINMAX(NBKFL,2)=ynewmin + BFMINMAX(NBKFL,3)=xnewmax + BFMINMAX(NBKFL,4)=ynewmax + + CALL CLSCRN + CALL PLOTOT(1) + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to use and save'//& + CHAR(13)//'this registration?','CHOOSE REGISTRATION?') +! +! If answer NO revert +! + IF (WInfoDialog(4) .EQ. 2) then + BFMINMAX(NBKFL,1)=XORIGMIN + BFMINMAX(NBKFL,2)=YORIGMIN + BFMINMAX(NBKFL,3)=XORIGMAX + BFMINMAX(NBKFL,4)=YORIGMAX + CALL CLSCRN + CALL PLOTOT(1) + else + ! + ! otherwise SAVE + + CALL SAVORG(NBKFL,2) + END IF +! + + RETURN + END \ No newline at end of file diff --git a/src/RESETWHGT.f90 b/src/RESETWHGT.f90 new file mode 100644 index 0000000..dfb5f29 --- /dev/null +++ b/src/RESETWHGT.f90 @@ -0,0 +1,291 @@ + SUBROUTINE RESETWHGT + USE BLK1MOD + USE BLK2MOD + INCLUDE 'TXFRM.COM' + SAVE + DIST(N,M)=Sqrt((cord(n,1)-cord(m,1))**2+(cord(n,2)-cord(m,2))**2)*txscal +! INCLUDE 'BLK1A.COM' +! DIMENSION K1(50000),levrem(50000) +! ALLOCATABLE NRF(:),AREF(:),LEVREM(:),TRANSEL(:),WLEN(:),WHGT(:),TRCEL(:) + IF(.NOT. ALLOCATED (NRF)) THEN + ALLOCATE (NRF(MAXP),AREF(MAXP),LEVREM(MAXP)) + ENDIF + IF(.NOT. ALLOCATED (TRANSEL)) THEN + ALLOCATE(TRANSEL(MAXP),WLEN(MAXP),WHGT(MAXP)) + ENDIF + NRF=0 + AREF=0 + K1=0 + levrem=0 + WHGT=-9999. + call kcon(1) + CALL PANELWHT(IWTYP,ISWL,R1,R2) + IF(IWTYP .LE. 0) RETURN + IF(ISWL .EQ. 2) GO TO 300 + DO N=1,NE + IF(IMAT(N) .EQ. IWTYP) THEN + DO K=2,6,4 + KK=NOP(N,K) + DO M=1,NE + IF(IMAT(M) .EQ. IWTYP) CYCLE + DO L=2,NCORN(M),2 + IF(NOP(M,L) .EQ. KK) THEN + IF(NCORN(M) .EQ. 8) THEN + IF(L .EQ. 2) THEN + IOP1=NOP(M,5) + IOP2=NOP(M,7) + ELSEIF(L .EQ. 4) THEN + IOP1=NOP(M,7) + IOP2=NOP(M,1) + ELSEIF(L .EQ. 6) THEN + IOP1=NOP(M,1) + IOP2=NOP(M,3) + ELSEIF(L .EQ. 8) THEN + IOP1=NOP(M,3) + IOP2=NOP(M,5) + ENDIF + + ELSE + IF(L .EQ. 2) THEN + IOP1=NOP(M,5) + IOP2=NOP(M,5) + ELSEIF(L .EQ. 4) THEN + IOP1=NOP(M,1) + IOP2=NOP(M,1) + ELSE + IOP1=NOP(M,3) + IOP2=NOP(M,3) + ENDIF + ENDIF + IF(NRF(NOP(N,K-1)) .EQ. 0) THEN + NRF(NOP(N,K-1))=IOP1 + AREF(NOP(N,K-1))=WD(IOP1) + ELSEIF(WD(IOP1) .GT. WD(NOP(N,K-1))) THEN + NRF(NOP(N,K-1))=IOP1 + AREF(NOP(N,K-1))=WD(IOP1) + ENDIF + IF(NRF(NOP(N,K+1)) .EQ. 0) THEN + NRF(NOP(N,K+1))=IOP2 + AREF(NOP(N,K+1))=WD(IOP2) + ELSEIF(WD(IOP2) .GT. WD(NOP(N,K+1))) THEN + NRF(NOP(N,K+1))=IOP2 + AREF(NOP(N,K+1))=WD(IOP2) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDDO + DO N=1,NE + IF(IMAT(N) .EQ. IWTYP) THEN + DO K=1,7,2 + IF(AREF(NOP(N,K)) .GE. WD(NOP(N,K))-0.1) THEN + IMAT(N)=IWTYP + nnn=nop(n,k) + write(151,*) 'levee reset',n,k,nnn,aref(nnn),WD(nnn) + do kk=1,7,2 + levrem(nop(n,kk))=1 + enddo + GO TO 150 + ELSEIF(NRF(NOP(N,K)) .EQ. 0) THEN + IMAT(N)=99 + nnn=nop(n,k) + write(151,*) 'Levee element removed',n,k,nnn + GO TO 150 + ELSE + WRITE(151,*) 'Levee active', n,aref(nop(n,k)),iop1 + IMAT(N)=IWTYP+900 + ENDIF + ENDDO + ENDIF + 150 CONTINUE + ENDDO + IF(IWTP .LT. 900) IWTYP=IWTYP+900 + DO N=1,NE + IF(IMAT(N) .EQ. IWTYP) THEN + KCT=1 + NPK1=NOP(N,1) + NPK2=NOP(N,3) + 160 CONTINUE + IF(levrem(NPK1) .eq. 1) then + if(levrem(npk2) .eq. 1) then + IMAT(N)=IWTYP-900 + GO TO 180 + else + IF(KCT .EQ. 1) THEN + MA=NECON(NOP(N,4),1) + MB=NECON(NOP(N,4),2) + ELSE + MA=NECON(NOP(N,8),1) + MB=NECON(NOP(N,8),2) + ENDIF + IF(MA .EQ. N) MA=MB + IF(MA .NE. 0) THEN + IF(NOP(MA,1) .EQ. NPK2) THEN + IF(LEVREM(NOP(MA,3)) .EQ. 1) THEN + IMAT(N)=IWTYP-900 + IMAT(MA)=IWTYP-900 + ENDIF + ELSEIF(NOP(MA,3) .EQ. NPK2) THEN + IF(LEVREM(NOP(MA,1)) .EQ. 1) THEN + IMAT(N)=IWTYP-900 + IMAT(MA)=IWTYP-900 + ENDIF + ENDIF + ENDIF + endif + ENDIF + NPK2=NOP(N,1) + NPK1=NOP(N,3) + IF(KCT .EQ. 1) THEN + KCT=2 + GO TO 160 + ENDIF + ENDIF + 180 CONTINUE + ENDDO + DO N=1,NE + IF(IMAT(N) .EQ. IWTYP) THEN + DO K=1,7,2 + IOP1=NRF(NOP(N,K)) + IF(IOP1 .GT. 0) THEN + NPK=NOP(N,K) + WHGT(NPK)=WD(NPK) + TRANSEL(NPK)=WHGT(NPK)+R1 + n1=nop(n,k) + n2=nop(n,8-k) + wlen(NPK)=dist(n1,n2) + NRF(NPK)=-NRF(NPK) + if(levrem(NPK) .eq. 0) then + WD(NPK)=WD(IOP1) + TRANSEL(NPK)=WHGT(NPK)+R1 + n1=nop(n,k) + n2=nop(n,8-k) + wlen(NPK)=dist(n1,n2) +! wlen(NPK)=8. + endif + ENDIF + ENDDO + 200 CONTINUE +! AMMN=(WHGT(NOP(N,1))+WHGT(NOP(N,3)))/2. +! IF(AMMN .GT. WHGT(NOP(N,1))) THEN +! TRCEL(N)=AMMN - WHGT(NOP(N,1))+0.1 +! ELSE +! TRCEL(N)=AMMN - WHGT(NOP(N,3))+0.1 +! ENDIF +! TRCEL(N)=0.25 +! write(151,*) 'levee element trc set',n,trcel(n),whgt(nop(n,1))& +! ,whgt(nop(n,3)) + ENDIF + ENDDO + DEALLOCATE (NRF,AREF,LEVREM) + GO TO 400 + 300 CONTINUE + DO N=1,NE + IF(IMAT(N) .EQ. IWTYP) THEN + DO K=1,7,2 + NPK=NOP(N,K) + WHGT(NPK)=WD(NPK)+R2 + TRANSEL(NPK)=WHGT(NPK)+R1 + n1=nop(n,k) + n2=nop(n,8-k) + wlen(NPK)=dist(n1,n2) + ENDDO + ENDIF + ENDDO + 400 call OUTWDT + RETURN + END + + SUBROUTINE PANELWHT(N1,ISWL,R1,R2) + + use winteracter + + implicit none + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,IERR,ISWL + real :: R1,R2 + character*3 :: sub + + call wdialogload(IDD_SETWRS) + ierr=infoerror(1) + + call wdialogputRadioButton(idf_radio1) + CALL WDialogPutInteger(idf_integer1,n1) + CALL WDialogPutReal(idf_real1,r1) + CALL WDialogPutReal(idf_real2,r2) + + + CALL WDialogSelect(IDD_SETWRS) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + call wdialoggetradiobutton(idf_radio1,ISWL) + CALL WDialogGetInteger(idf_integer1,n1) + CALL WDialogGetReal(idf_real1,r1) + CALL WDialogGetReal(idf_real2,r2) + ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + N1=-1 + + ENDIF + RETURN + END + + SUBROUTINE OUTWDT + + USE WINTERACTER + USE BLK1MOD + INCLUDE 'TXFRM.COM' + + CHARACTER(LEN=255) :: FNAME,FILTER + CHARACTER(LEN=4) :: SUB + LOGICAL OPENED + CHARACTER*1 IFLAG,ANS(10) + + IOUTWR=81 + INQUIRE(81, OPENED=OPENED) + if(.not. opened) then + Filter='WDT file -- *.dat|*.dat|' + + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Weir Data File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + OPEN(IOUTWR,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE') + GO TO 3 + ELSE + GO TO 1 + ENDIF + ELSE + REWIND(IOUTWR) + GO TO 3 + ENDIF + +1 RETURN + +3 DO N=1,NP + IF(WHGT(N) .GT. -9999.) THEN + WRITE(IOUTWR,7778) N,WHGT(N),WLEN(N),TRANSEL(N) +7778 FORMAT('WDT',5X,I8,3F8.2) + ENDIF + ENDDO + CLOSE(IOUTWR) + + RETURN + END \ No newline at end of file diff --git a/src/RESOURCE.F90 b/src/RESOURCE.F90 new file mode 100644 index 0000000..7873ca2 --- /dev/null +++ b/src/RESOURCE.F90 @@ -0,0 +1,32 @@ +! Winteracter module created : 07/Nov/1998 14:27:06 +! + MODULE MENUED + INTEGER, PARAMETER :: IDR_MENU1 = 30001 + INTEGER, PARAMETER :: ID_FILE = 40001 + INTEGER, PARAMETER :: ID_EXIT = 40002 + INTEGER, PARAMETER :: ID_NODE = 40003 + INTEGER, PARAMETER :: ID_ELTS = 40004 + INTEGER, PARAMETER :: ID_ORDR = 40005 + INTEGER, PARAMETER :: ID_CCLN = 40006 + INTEGER, PARAMETER :: ID_CSEC = 40007 + INTEGER, PARAMETER :: ID_ZOOM = 40008 + INTEGER, PARAMETER :: ID_DRAW = 40009 + INTEGER, PARAMETER :: ID_HELP = 40010 + INTEGER, PARAMETER :: ID_STRING1 = 50001 + INTEGER, PARAMETER :: ID_STRING2 = 50002 + INTEGER, PARAMETER :: ID_STRING3 = 50003 + INTEGER, PARAMETER :: ID_STRING4 = 50004 + INTEGER, PARAMETER :: ID_STRING5 = 50005 + INTEGER, PARAMETER :: ID_ITEM11 = 40011 + INTEGER, PARAMETER :: ID_ITEM12 = 40012 + INTEGER, PARAMETER :: ID_ITEM13 = 40013 + INTEGER, PARAMETER :: ID_ITEM14 = 40014 + INTEGER, PARAMETER :: ID_ITEM15 = 40015 + INTEGER, PARAMETER :: ID_ITEM16 = 40016 + INTEGER, PARAMETER :: ID_ITEM17 = 40017 + INTEGER, PARAMETER :: ID_ITEM18 = 40018 + INTEGER, PARAMETER :: ID_ITEM19 = 40019 + INTEGER, PARAMETER :: IDF_STRING1 = 1002 + INTEGER, PARAMETER :: IDF_GROUP1 = 1001 + INTEGER, PARAMETER :: IDF_STRING3 = 1003 + END MODULE MENUED diff --git a/src/RMAGEN - Shortcut.lnk b/src/RMAGEN - Shortcut.lnk new file mode 100644 index 0000000..a126725 Binary files /dev/null and b/src/RMAGEN - Shortcut.lnk differ diff --git a/src/RMAGEN.F90 b/src/RMAGEN.F90 new file mode 100644 index 0000000..869581d --- /dev/null +++ b/src/RMAGEN.F90 @@ -0,0 +1,694 @@ +!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR CHNAGED ELEMENTS/NODES OR REORDERING +! Last change: IPK 13 Jan 98 10:01 am +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + SUBROUTINE RMAGEN(MENUS,N1,N2,N3,N4,N5,N6,N7,N8,N9) +! +! +! +! RMAGEN Version 4.2 +! +! Release date Jan 13 1998 +! +! +! Changes in this version include: +! (1) Revisions to operate in a graphical mode, reducing the amount of +! DOS screen input. +! (2) Addition of options for both the node move operation and refine +! options to allow the user to stop preservation or automatic +! interpolation of bottom elevations from the corner node values. +! This option is a user setting. The default initial setting +! retains the value for the move operation and interpolaton during +! refinement. +! (3) Input of "geo" has been made more flexible. The model +! automatically detects binary files with and without headers. Note +! that this option is only relevant for PC versions. +! (4) The screen now displays compilation limits on startup. +! +! +! RMAGEN Version 4.1(a) +! +! Release date Nov 18 1997 +! +! +! +! Changes in this version include: +! (1) Revised interpolation scheme for computing bottom elevations from +! map file data. +! (2) More consistent backup +! (3) Addition of option to split triangles when refining +! +! RMAGEN Version 4.1 +! +! Release date Oct 19 1996 + +! Changes in this version include: +! (1) New options that allow selective drawing of maps in different +! colours +! (2) An option that allows construction of continuity lines from the +! map screen + +! RMAGEN Version 3.3 + +! Release date April 1 1994 + +! Changes in this version include: +! (1) Incorporation of the ability to record and play scripts. +! (2) Correction to correctly operate in the top half inch of the network + +! RMAGEN Version 3.2 + +! Release date March 1 1994 + +! Changes in this version include: +! (1) Modification to the save options to enter a menu of save choices. +! (2) Addition of the capability to save a binary version of the map file. +! (3) Correction to the "backup file" to make it work consistently. +! (4) Changes to the algorithm of the bottom elevation generation routine +! to improve reliability. +! (5) Removal of an implied limitation of 32000 lines for the map file by +! deleting some INTEGER*2 variable to INTEGER*4. + +! RMAGEN Version 3.1(a) + +! Release date Aug 1 1993 + +! Changes in this version include: +! (1) Correction to colurs that make them more readable. +! (2) Additions to the SELECT options that permit more flexible choice +! of elements. + +! RMAGEN Version 3.1 + +! Release date March 1 1993 + +! Changes in this version include: +! (1) Correction in fill operation to ensure correct fill when there are +! a number of gaps in the nodal sequence. +! (2) Additions to the NODE-DELETE options that permit more flexible +! deletion options such as all mid-side nodes, all exact mid-side +! location nodes or all unused nodes. The fill option has added +! flexibility. + + +! Version 3.0(c) August 1 1992 + +! Changes in this version include: +! (1) Revisions to incorporate REGIS graphics capability +! (2) Block of routines available to use DEC 340 REGIS graphics +! terminal with unix system + + +! Version 3.0(b) May 20 1992 + +! Changes in this version include: +! (1) Renaming of all colours for compatibility with Silicon Graphics +! (2) Modification of nodal delete so that when a mid-side node is +! selected for deletion it is removed and the associated reference +! in the element is set to zero. The element is no longer deleted. +! (3) Cleanup of array subscripts in SUBROUTINE HEDRC + +! Version 3.0(a) April 1992 + +! Changes to a number of routines to correct minor errors +! and nuisances. + +! Version 3.0 January 1992 + +! This version revises the naming of input and output files. +! Output files may be generated in ASCII or BINARY form. +! The binary file is designed to bypass RMA-1. +! This file optionally may contain element reordering numbers +! New capabilities include: +! (1) Automatic filling of zero's in element connection arrays. +! (2) Input of reordering sequences and executing the reordering +! process. + + + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'BFILES.I90' + + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + +!ipk oct96 + character*64 fnams + character*25 mesg + CHARACTER*1 ANS,ANSW(0:9),ansx(0:9) + DATA ANSW/'e','n','o','h','s','l','t','z','r','q'/ + data ansx/'s','b','m','p',2*' ','h','z','r','q'/ + + DATA IFIRST / 1 / + + IF(N3 .EQ. 1) GO TO 101 + + ISWTAGN=0 + ISWTINTP=0 + WIDSCL=1.0 + WIDEL=0.0 + IPW1=1 + IMP=N1 + IIN=N2 + IOT=N4 + IOT1=N5 + IGFG=N6 + ITRIAN=N7 +!ipk jul98 + LCROSS=.FALSE. + ICRS=0 + DFACTOR=50. + ZREF=5. + +!iPK JAN98 + IDELV=0 + IRESTT=0 + 1 CONTINUE + IFIRST=1 + IECHG=0 + NELAST=1 + NPLAST=1 + NLST=0 + NENTRY=0 + TXSCAL = 1. + XS=0. + YS=0. + VDX = - 1.0E+10 + VOID = - 1.0E+20 + + IPSW(1)=0 + IPSW(2)=0 + IPSW(3)=0 + IPSW(4)=1 + IPSW(5)=0 + IPSW(6)=0 + IPSW(7)=0 + IPSW(8)=0 + IPSW(9)=0 + IPSW(12)=0 + IF(N8 .GT. 100000) THEN + IPSW(2)=1 + IPSW(4)=0 + ENDIF + MAXPTS=MAXPL +!ipk jan98 + call file(1) + + + write(90,*) 'rmagen',iot,iot1 + +! Initialize plot + +!! CALL GINIT + +! Startup files + WRITE(MESG,6010) + 6010 FORMAT(' Going to initialisation ') + CALL SYMBL(1.1,6.3,0.15,mesg,0.0,25) + + CALL FILE(2) + + WRITE(MESG,6011) + 6011 FORMAT(' Back from initialisation') + CALL SYMBL(1.1,5.3,0.15,mesg,0.0,25) + + IF(MENUS .EQ. -1) CALL DEMOS + + IF(IIN .EQ. 0) IPSW(1)=1 + +! Initialize plot + +!ipk jan98 CALL GINIT + + IF(IMP .GT. 0) THEN + +! Read map file + WRITE(90,*) 'GOING TO READ MAP' + CALL RDMAP(0,0,0,0) + IF (IFIRST .EQ. 1) THEN + +! Find max and min + + XMIN = 1.E+20 + XMAX = -XMIN + YMIN = 1.E+20 + YMAX = -YMIN + + DO 8 J=1,MAXPTS + IF (CMAP(J,1) .LT. VDX) GOTO 8 + IF (CMAP(J,1) .LT. XMIN) XMIN = CMAP(J,1) + IF (CMAP(J,1) .GT. XMAX) XMAX = CMAP(J,1) + IF (CMAP(J,2) .LT. YMIN) YMIN = CMAP(J,2) + IF (CMAP(J,2) .GT. YMAX) YMAX = CMAP(J,2) + 8 CONTINUE + 9 CONTINUE + ENDIF + ENDIF + +! Read in header lines + + ISET=1 + WRITE(90,*) 'GOING TO HEADIN' + CALL HEADIN(IIN,ISET) + +! Read in existing elements + WRITE(90,*) 'GOING TO RDELEM' + CALL RDELEM(IIN) + +! Read in nodal coordinates + + WRITE(90,*) 'GOING TO RDCORD' + CALL RDCORD(IIN) + + WRITE(90,*) 'RMAGEN-243 NCLM',NCLM + + +!ipk may03 + ichg=1 + +! Close input file + + if(iin .ne. 0) then + CLOSE(IIN) + endif + +! Scale for plotting + + IF (IFIRST .EQ. 1) THEN + IF (IMP .EQ. 0) THEN + XMIN = 1.E+20 + XMAX = -XMIN + YMIN = 1.E+20 + YMAX = -YMIN + ENDIF + + IF(NP .GT. 0) THEN + DO 10 J=1,NP + IF (CORD(J,1) .LT. VDX) GOTO 10 + IF (CORD(J,1) .LT. XMIN) XMIN = CORD(J,1) + IF (CORD(J,1) .GT. XMAX) XMAX = CORD(J,1) + IF (CORD(J,2) .LT. YMIN) YMIN = CORD(J,2) + IF (CORD(J,2) .GT. YMAX) YMAX = CORD(J,2) + 10 CONTINUE + ENDIF + +! Check for background limits + WRITE(90,*) 'NBKFL',NBKFL + IF(NBKFL .GT. 0) THEN + DO I=1,NBKFL + IF(BFMINMAX(I,1) .LT. XMIN) XMIN=BFMINMAX(I,1) + IF(BFMINMAX(I,2) .LT. YMIN) YMIN=BFMINMAX(I,2) + IF(BFMINMAX(I,3) .GT. XMAX) XMAX=BFMINMAX(I,3) + IF(BFMINMAX(I,4) .GT. YMAX) YMAX=BFMINMAX(I,4) + WRITE(90,*) 'XX',XMIN,XMAX,YMIN,YMAX + WRITE(90,*) 'BFMIN',(BFMINMAX(I,K4),K4=1,4) + ENDDO + ENDIF + +!rrr + WRITE(90,*) 'GOING TO PGRID' + CALL PGRID + + AMAP=(XMAX-XMIN)*(YMAX-YMIN) + XSCALE = (XMAX-XMIN)/(hsize-0.5) + YSCALE = (YMAX-YMIN)/6.5 + PSCALE = MAX(XSCALE,YSCALE) + + XAVE = (XMIN + XMAX) /2.0 + YAVE = (YMIN + YMAX) /2.0 + XMIN = XAVE - hsize/2.*PSCALE + YMIN = YAVE - 3.5*PSCALE + XMAX = XAVE + (hsize-0.5)/2.*PSCALE + YMAX = YAVE + 3.25*PSCALE +! YMIN = YMIN - .01*PSCALE +! XMIN = XMIN - .01*PSCALE + +! Reset values if STARTUP.DAT file is used + + IF(IS11 .GT. 0) THEN + READ(IS11,5200) XS,YS,PSCALE + 5200 FORMAT(3F15.0) + XMIN=-XS + YMIN=-YS + ENDIF + + IFIRST = 0 + + ENDIF + +! Plot all data + + CALL PLOTSV(0) +!ipk nov97 add (1) + CALL PLOTOT(1) + GO TO 101 + +! Top of loop ******************************** + + 100 CONTINUE + 101 CONTINUE + if(menus .gt. 9) go to 25 + IF(MENUS .GT. 0) THEN + ANS=ANSW(MENUS-1) + MENUS=0 + GO TO 130 + ENDIF + +! List options + + 25 CONTINUE + +! Draw box around selections + + IF(MENUS .EQ. -3) THEN + CALL PLOTOT(0) + MENUS=-2 + ENDIF + NHTP=1 + NMESS=0 + NBRR=0 + CALL HEDR +! Get answer + + call xyloc(XPT,YPT,ANS,IBOX) + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + IF(ANS .EQ. 'c') THEN + I=IBOX-1 + if(i .lt. 0) go to 25 + ANS=ANSW(I) + ENDIF + + 130 CONTINUE + +! Add elements + + IF (ANS .EQ. 'e') THEN + CALL ELTS + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + +! Go to help facility + + ELSEIF (ANS .EQ. 'h') THEN + CALL HELPS(1) + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + +! Process nodes + + ELSEIF (ANS .EQ. 'n') THEN + CALL ADDNOD +!ipk feb94 call for backup + CALL WRTOUT(0) + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + +! Add element reordering sequence + + ELSEIF (ANS .EQ. 'o') THEN + +! Draw box around selections + + 140 CONTINUE + NHTP=3 + NMESS=0 + NBRR=0 + CALL PLOTORDS + + CALL HEDR + +! Get answer + + call xyloc(XPT,YPT,ANS,IBOX) + CALL PLOTORDS + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + IF(ANS .EQ. 'c') THEN + I=IBOX-1 + ELSE + IF(ANS .EQ. 'l') THEN + +! Process current list including baseine order + + I=0 + ELSEIF(ANS .EQ. 'g') THEN + +! Add another order to the list + + I=1 + ELSEIF(ANS .EQ. 'p') THEN + +! Process the latest addition to the list + + I=2 + ELSEIF(ANS .EQ. 'o') THEN + I=3 + ELSEIF(ANS .EQ. 't') THEN + I=4 + ELSEIF(ANS .EQ. 'h') THEN + I=5 + ELSEIF(ANS .EQ. 'z') THEN + I=7 + ELSEIF(ANS .EQ. 'r') THEN + I=8 + ELSEIF(ANS .EQ. 'q') THEN + I=9 + ENDIF + ENDIF + IF(I .LT. 3) THEN + + CALL ADDORD(I) + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + GO TO 140 + ELSEIF(I .gt. 2 .and. I .lt. 5) THEN +! +! compact elements and nodes +! + call compact(i) + go to 100 + + ELSEIF(I .EQ. 5) THEN + +! Get help screen + + CALL HELPS(5) + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + + ELSEIF(I .EQ. 9) THEN + +! Return to main menu + + GO TO 100 + + ELSE + +! Return to try for character again + + GO TO 140 + ENDIF + GO TO 140 + +! ENDIF +!ipk oct96 add continuity lines + + ELSEIF (ANS .EQ. 'l') THEN + CALL CCLINE(1) + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + +!ycw mar97 add cross section + + ELSEIF (ANS .EQ. 't') THEN + CALL CRSECT + IF(IRMAIN .EQ. 1) THEN + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF +!ycw + ELSEIF (ANS .EQ. 'r') THEN +! Save display parameters + + n1=nhtp + n2=nmess + n3=nbrr + CALL RDRW(0) + if(irmain .eq. 1) return + +! Restore display parameters + + nhtp=n1 + nmess=n2 + nbrr=n3 + + ELSEIF (ANS .EQ. 's') THEN + +! Save files + + +! Draw box around selections + + 210 NHTP=11 + NMESS=0 + NBRR=0 + CALL HEDR + +! Get answer + + call xyloc(XPT,YPT,ANS,IBOX) + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + IF(ANS .EQ. 'c') THEN + if(ibox .le. 0) go to 210 + I=IBOX-1 + ANS=ANSX(I) + ENDIF + +! Save plot file + + IF (ANS .EQ. 'p') THEN + + CALL PLOTSV(1) +!ipk nov97 add(1) + CALL PLOTOT(1) + CALL NDPLSV + + ELSEIF (ANS .EQ. 'b') THEN + +! Save file in binary form + + CALL WRTOUT(2) + + ELSEIF (ANS .EQ. 'm') THEN + +! Save map file + + CALL WRTMAP(0) + + ELSEIF (ANS .EQ. 's') THEN + +! Save file + + CALL WRTOUT(1) + +! Go to help facility + + ELSEIF (ANS .EQ. 'h') THEN + CALL HELPS(8) + IF(IRMAIN .EQ. 1) THEN +!ipk may94 add line + CALL RESCAL + IRMAIN=0 + GO TO 100 + ENDIF + ELSEIF (ANS .EQ. 'q') THEN + GO TO 100 + ENDIF + GO TO 210 + + + ELSEIF (ANS .EQ. 'q') THEN + +! Quit program after checking + + + CALL RQUIT(IYES) + IF(IYES .EQ. 1) THEN + CALL Quit_Pgm + STOP +!!SEP02 CALL CLSCRN +!!SEP02 CALL SETD(23) +!ipk oct96 move to screen output + +!!SEP02 WRITE(FNAMS,*) 'Do you really want to quit? (y) or (n)' +!!SEP02 CALL SYMBL(1.,7.20,0.20,FNAMS,0.,38) +!!SEP02 ndig=1 +!!SEP02 call gtcharx(ans,ndig,6.,7.2) +!ipk oct96 READ(*,'(A)') ANS +!!SEP02 IF(ANS .EQ. 'y' .OR. ANS .EQ. 'Y') THEN +!!SEP02 CALL Quit_Pgm +!!SEP02 STOP +!!SEP02 ELSE +!!SEP02 WRITE(FNAMS,*)'Do you want to restart? (y) or (n)' +!!SEP02 CALL SYMBL(1.,6.20,0.20,FNAMS,0.,34) +!!SEP02 ndig=1 +!!SEP02 call gtcharx(ans,ndig,6.,7.2) +!ipk oct96 READ(*,'(A)') ANS +!!SEP02 IF(ANS .EQ. 'y' .OR. ANS .EQ. 'Y') THEN +!!SEP02 IRESTT=1 +!!SEP02 GO TO 1 +!!SEP02 ENDIF +!!SEP02 CALL SETD(2) + ENDIF + + ENDIF + + GOTO 100 + + END + + + SUBROUTINE RQUIT(IYES) + + USE WINTERACTER + + INCLUDE 'BFILES.I90' + + INCLUDE 'D.INC' + + IF(IRDONE .NE. 0) THEN + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you really wish to quit?'//& + CHAR(13)//' ','Quit option') + ELSE + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'You have not reordered'//Char(13)//'Do you really wish to quit?'//& + CHAR(13)//' ','Quit option') + ENDIF +! +! If answer 'No', return +! + iyes=1 + IF (WInfoDialog(4).EQ.2) iyes=0 + return + end + diff --git a/src/RMAGENV83c.rc b/src/RMAGENV83c.rc new file mode 100644 index 0000000..cd4e683 --- /dev/null +++ b/src/RMAGENV83c.rc @@ -0,0 +1,2408 @@ +/////////////////////////////////////////////////// +// +// THIS FILE SHOULD NOT BE EDITED USING A TEXT +// EDITOR OR 3RD PARTY RESOURCE EDITOR, EXCEPT +// WHEN SPECIFICALLY INSTRUCTED BY I.S.S. +// +/////////////////////////////////////////////////// +// +// Winteracter resource script. +// +// Modified : 03/Aug/2016 15:52:15 +// +/////////////////////////////////////////////////// +// +// Include files +// +#include "winparam.h" + +/////////////////////////////////////////////////// +// +// Parameter Definitions +// +#define IDR_MENU1 30001 +#define ID_FILE 40001 +#define ID_EXIT 40002 +#define ID_NODE 40003 +#define ID_ELTS 40004 +#define ID_ORDRT 40005 +#define ID_CCLNA 40006 +#define ID_CSEC1 40007 +#define ID_ZOOM 40008 +#define ID_DRAW 40009 +#define ID_HELP 40010 +#define ID_STRING1 50001 +#define ID_STRING2 50002 +#define ID_STRING3 50003 +#define ID_STRING4 50004 +#define ID_STRING5 50005 +#define ID_STRING6 50006 +#define ID_STRING7 50007 +#define ID_STRING8 50008 +#define ID_STRING9 50009 +#define ID_STRING10 50010 +#define ID_STRING11 50011 +#define ID_ITEM11 40011 +#define ID_ITEM12 40012 +#define ID_ITEM13 40013 +#define ID_ITEM14 40014 +#define ID_ITEM15 40015 +#define ID_ITEM16 40016 +#define ID_ITEM17 40017 +#define ID_ITEM18 40018 +#define ID_ITEM19 40019 +#define IDF_STRING24 1041 +#define IDD_DIALOG1 101 +#define IDF_LABEL5 1042 +#define IDC_BUTTON2 20001 +#define ID_ITEM20 40021 +#define ID_ITEM73 40022 +#define ID_ITEM23 40023 +#define ID_ITEM24 40024 +#define ID_TOOLBAR1 30101 +#define ID_ZIN 40025 +#define ID_ZOUT 40026 +#define ID_OUT2 40027 +#define ID_OUT4 40028 +#define ID_RSET 40029 +#define ID_PLEFT 40031 +#define ID_PRIGHT 40032 +#define ID_PUP 40033 +#define ID_PDOWN 40034 +#define ID_IDRWT 40035 +#define ID_TYPD 40039 +#define ID_DRAWD 40041 +#define ID_MAPOPD 40042 +#define ID_CONTR 40060 +#define IDF_LABEL1 1001 +#define IDF_LABEL2 1002 +#define IDF_LABEL3 1003 +#define IDF_LABEL4 1004 +#define IDF_STRING1 1013 +#define IDF_STRING2 1014 +#define IDF_STRING3 1015 +#define IDF_STRING4 1016 +#define IDF_STRING5 1017 +#define IDF_STRING6 1018 +#define IDF_STRING7 1019 +#define IDF_STRING8 1020 +#define IDF_STRING9 1021 +#define IDF_STRING10 1022 +#define IDF_STRING11 1023 +#define IDF_STRING12 1024 +#define IDD_DIALOG02 102 +#define IDF_STRING13 1025 +#define IDF_STRING14 1026 +#define IDF_STRING15 1027 +#define IDF_STRING16 1028 +#define IDF_STRING17 1029 +#define IDF_STRING18 1030 +#define IDF_STRING19 1031 +#define IDF_STRING20 1032 +#define IDF_STRING21 1033 +#define IDF_STRING22 1034 +#define IDF_STRING23 1035 +#define IDF_CHECK1 1036 +#define IDF_CHECK2 1037 +#define IDF_CHECK3 1038 +#define IDF_CHECK4 1039 +#define IDF_CHECK5 1040 +#define ID_DCONTR 40056 +#define ID_CONTOPT 40061 +#define ID_ITYPN 40064 +#define ID_ITYPC 40065 +#define ID_ICOPY 40067 +#define IDD_DIALOG04 104 +#define ID_BACGD 40050 +#define ID_ITEM26 40071 +#define IDD_DIALOG05 103 +#define IDF_CMAP8 1005 +#define IDF_CMAP9 1006 +#define IDF_CMAP0 1007 +#define IDF_CMAP1 1008 +#define IDF_CMAP2 1009 +#define IDF_CMAP10 1010 +#define IDF_CMAP11 1011 +#define IDF_CMAP3 1012 +#define IDF_CMAP4 1043 +#define IDF_CMAP5 1044 +#define IDF_CMAP6 1045 +#define IDF_CMAP7 1046 +#define IDD_DIALOG006 105 +#define IDF_RADIO1 1047 +#define IDF_RADIO2 1048 +#define IDF_RADIO3 1049 +#define IDF_RADIO4 1050 +#define IDF_RADIO5 1051 +#define IDF_RADIO6 1052 +#define IDF_RADIO7 1053 +#define IDF_RADIO8 1054 +#define IDF_RADIO9 1055 +#define ID_MMAP 40043 +#define IDD_DIALOG07 106 +#define IDD_DIALOG08 107 +#define ID_Help1 40040 +#define ID_Help2 40044 +#define IDD_DIALOG09 108 +#define IDF_LABEL7 1056 +#define IDD_DIALOG10 109 +#define IDF_INTEGER1 1057 +#define IDF_INTEGER2 1058 +#define ID_LAYFL 40046 +#define IDF_RADIO10 1056 +#define IDD_DIALOG010 110 +#define IDD_DIALOG001 111 +#define ID_BKF 40047 +#define IDD_DIALOG012 113 +#define IDF_CHECK6 1041 +#define IDF_CHECK7 1042 +#define IDF_CHECK8 1043 +#define IDF_CHECK9 1044 +#define IDF_CHECK10 1045 +#define IDF_CHECK11 1059 +#define ID_Clip 40020 +#define ID_UNDOM 40030 +#define ID_BSEL 40036 +#define ID_REGST 40037 +#define IDD_REGST 112 +#define IDF_LABEL6 1005 +#define IDF_REAL1 1060 +#define IDF_REAL2 1061 +#define IDF_REAL3 1062 +#define IDF_REAL4 1063 +#define IDF_LABEL8 1006 +#define IDF_LABEL9 1007 +#define IDF_LABEL10 1008 +#define IDF_LABEL11 1043 +#define IDF_REAL5 1064 +#define IDF_REAL6 1065 +#define IDF_REAL7 1066 +#define IDF_REAL8 1067 +#define IDF_LABEL12 1009 +#define IDADJUST 1068 +#define IDFSWITCH 1069 +#define IDD_SLRGNO 114 +#define IDD_CONFIRM 115 +#define ID_network 40038 +#define ID_NMAP 40045 +#define ID_ITEM56 40048 +#define ID_Nodedata 40049 +#define ID_Eltdata 40051 +#define IDD_nodedata 116 +#define IDF_REAL9 1068 +#define IDF_REAL10 1069 +#define IDD_eltdata 117 +#define IDF_INTEGER3 1059 +#define IDF_INTEGER4 1060 +#define IDF_INTEGER5 1061 +#define IDF_INTEGER6 1062 +#define IDF_INTEGER7 1063 +#define IDF_INTEGER8 1064 +#define IDF_INTEGER9 1070 +#define IDF_INTEGER10 1071 +#define IDD_SELNODE 118 +#define IDNEXT 1072 +#define IDD_SELELT 119 +#define IDD_ELTERR 120 +#define ID_DRAG 40052 +#define ID_DELM 40103 +#define ID_FILL 40102 +#define IDF_Delete 1073 +#define IDFROTATE 1074 +#define IDF_RADIO11 1057 +#define ID_GETELM 40053 +#define ID_mapm 40054 +#define ID_map 40055 +#define IDD_GETINTP 160 +#define ID_SBIN 40057 +#define IDD_headertp 121 +#define ID_TRIAN 40058 +#define ID_SWMAP 40059 +#define ID_SWRM1 40062 +#define IDD_TRIAN 122 +#define IDD_NODERR 123 +#define IDF_STRING25 1106 +#define IDF_STRING26 1107 +#define IDF_STRING27 1108 +#define IDF_STRING28 1109 +#define IDF_STRING29 1110 +#define IDF_STRING30 1111 +#define IDF_STRING31 1112 +#define IDF_STRING32 1113 +#define IDF_STRING33 1114 +#define IDF_STRING34 1115 +#define IDD_SELTFL2 148 +#define ID_LOADRM1 40063 +#define ID_cdata 40066 +#define ID_SELRM1 40068 +#define ID_addmesh 40069 +#define ID_MRGMESH 40070 +#define ID_ITEM22 40072 +#define ID_ALLNODES 40073 +#define ID_UNUSNODES 40074 +#define ID_TRIANG 40075 +#define IDD_TRIANG 124 +#define IDD_QUAD 125 +#define ID_QUAD 40076 +#define ID_JOIN 40104 +#define ID_CSEC 40077 +#define ID_CRSCAL 40078 +#define ID_SAVCRS 40079 +#define ID_crsf 40080 +#define IDD_DIALOG06 126 +#define IDF_RADIO13 1076 +#define IDF_RADIO12 1058 +#define IDD_GETFPN 154 +#define IDD_GETINT 153 +#define ID_CSLOC 40081 +#define IDD_CSLOC 127 +#define ID_UNDO 40082 +#define ID_UNDOS 40083 +#define ID_CREATM 40084 +#define IDD_CREATM 128 +#define IDD_TEMPLATE001 129 +#define IDF_GRID1 1075 +#define ISS1 1077 +#define ISS2 1078 +#define ISS3 1079 +#define IDD_CREATM1 130 +#define ID_CGEN 40085 +#define IDF_STRING35 1042 +#define IDD_ORDEROUT 131 +#define IDD_TEMPLATE002 132 +#define IDF_RADIO14 1080 +#define IDF_RADIO15 1081 +#define IDF_RADIO16 1082 +#define ID_selarea 40086 +#define ID_crsect 40087 +#define IDD_selcrsec 133 +#define IDD_TEMPLATE003 134 +#define ISS4 1083 +#define ISS5 1084 +#define IDD_LIMITS 135 +#define IDF_RADIO17 1059 +#define IDD_lAY 136 +#define IDD_TEMPLATE004 137 +#define ISS6 1085 +#define ISS7 1086 +#define ID_EDLAY 40088 +#define IDF_RADIO18 1062 +#define ID_ORDR 40089 +#define ID_ORDR1 40090 +#define id_chk 2002 +#define id_chck 2001 +#define idchk 2003 +#define ID_SPLITN 40091 +#define IDD_DISPLIT 138 +#define IDD_DIRSPLIT 139 +#define ID_OUTLAY 40093 +#define ID_FORM999 40092 +#define ID_g1d 40094 +#define IDD_SETOPT 140 +#define ID_CCLN 40095 +#define ID_CHKCCLN 40096 +#define ID_GOUTLIN 40097 +#define ID_XOUTLIN 40098 +#define IDD_SETMAXMAP 141 +#define ID_RESETLIM 40099 +#define IDD_MLIMITS 143 +#define IDD_VIEWANG 174 +#define ID_3DVIEW 40100 +#define ID_VIEWANGLE 40101 +#define ID_ROTATE 40106 +#define ID_RESETRG 40105 +#define IDD_CHKOPT 142 +#define ID_ITEM103 40107 +#define ID_SECGRP 40108 +#define IDD_SETSEL 144 +#define ID_SELPR 40109 +#define IDD_CHK1DOPT 145 +#define ID_VROTATE 40110 +#define id_mchck 40111 +#define ID_MOVMESH 40112 +#define IDD_DIALOG047 146 +#define IDD_DIALOG048 147 +#define ID_SELELTYP 40113 +#define IDD_SELELTYP 149 +#define ID_OPENGP 40114 +#define ID_SAVGP 40115 +#define IDF_RADIO19 1063 +#define ID_IGPN 40116 +#define ID_IGPC 40117 +#define ID_DISPTYP 40118 +#define ID_TRANSFORM 40119 +#define IDD_TRANSFORM 151 +#define ID_deletelm 40120 +#define IDD_ELTERR2 152 +#define ID_FORM2D 40121 +#define ID_JOINALL 40122 +#define ID_MOVGRP 40123 +#define ID_CRGRID 40124 +#define IDD_GENBLK 155 +#define ID_SETUPLEV 40125 +#define IDD_SETWRS 156 +#define ID_findnode 40126 +#define ID_findelem 40127 +#define IDD_FORMLINE 157 +#define ID_FILLAGAP 40129 +#define IDD_MATTYP 158 +#define ID_ITEM126 40130 +#define ID_SETTYPLEV 40131 +#define IDD_LEVSETTYP 159 +#define ID_Complex 40132 +#define ID_attach 40133 +#define IDD_CHSTYP 161 +#define ID_SAVSHP 40128 +#define ID_ADDMAP 40134 +#define ID_OUTLINFL 40135 +#define ID_GETSTRESSFIL 40136 +#define IDD_FBED 162 +#define IDD_SETYRDT 163 +#define ID_SMOOTHMAP 40137 +#define IDD_GETINTR 164 +#define ID_RVSDIAG 40138 +#define ID_TESTOUT 40139 +#define ID_LOADELTLD 40140 +#define ID_SHOWELTLD 40141 +#define IDD_CHOOSEMODEL 165 +#define IDD_SETUPELDISP 166 +#define ID_SAVELTLD 40142 +#define ID_RESHOWELTLD 40143 +#define ID_ASSIGNELTLD 40144 +#define ID_FILLTR 40145 +#define IDD_FTRIAN 167 + +/////////////////////////////////////////////////// +// +// Dialogs +// +IDD_DIALOG02 DIALOG 0, 0, 402, 255 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT CONTOURS" +BEGIN + CONTROL "Computed max and min",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 20, 120, 8 + CONTROL "Over-riding maximum limit",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 48, 120, 8 + CONTROL "Over-riding minimum limit",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 68, 120, 8 + CONTROL "c-max",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 150, 17, 40, 14 + CONTROL "c-min",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 200, 17, 40, 14 + CONTROL "Max",IDF_STRING3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 160, 45, 40, 14 + CONTROL "Min",IDF_STRING22,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 160, 65, 40, 14 + CONTROL "Number",IDF_STRING23,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 160, 85, 40, 14 + CONTROL " Accept values",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 250, 8, 100, 10 + CONTROL " Use logarithmic interval",IDF_CHECK2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 250, 28, 100, 10 + CONTROL " Recompute use input limits to set values",IDF_CHECK3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 250, 48, 144, 10 + CONTROL " Use values input below",IDF_CHECK4,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 250, 68, 100, 10 + CONTROL " Retain these values",IDF_CHECK5,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 250, 88, 100, 10 + CONTROL "v1",IDF_STRING4,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 20, 111, 40, 14 + CONTROL "String",IDF_STRING5,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 80, 111, 40, 14 + CONTROL "String",IDF_STRING6,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 140, 111, 40, 14 + CONTROL "String",IDF_STRING7,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 200, 111, 40, 14 + CONTROL "String",IDF_STRING8,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 260, 111, 40, 14 + CONTROL "v6",IDF_STRING9,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 320, 111, 40, 14 + CONTROL "String",IDF_STRING10,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 20, 133, 40, 14 + CONTROL "String",IDF_STRING11,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 80, 133, 40, 14 + CONTROL "String",IDF_STRING12,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 140, 133, 40, 14 + CONTROL "String",IDF_STRING13,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 200, 133, 40, 14 + CONTROL "String",IDF_STRING14,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 260, 133, 40, 14 + CONTROL "v12",IDF_STRING15,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 320, 133, 40, 14 + CONTROL "String",IDF_STRING16,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 19, 155, 40, 14 + CONTROL "String",IDF_STRING17,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 79, 155, 40, 14 + CONTROL "String",IDF_STRING18,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 139, 155, 40, 14 + CONTROL "String",IDF_STRING19,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 201, 155, 40, 14 + CONTROL "String",IDF_STRING20,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 259, 155, 40, 14 + CONTROL "v18",IDF_STRING21,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 319, 155, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 181, 228, 40, 14 + CONTROL "Number of contours",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 88, 120, 8 + CONTROL "String",IDF_STRING25,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 78, 176, 40, 14 + CONTROL "String",IDF_STRING26,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 138, 176, 40, 14 + CONTROL "String",IDF_STRING27,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 200, 176, 40, 14 + CONTROL "String",IDF_STRING28,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 259, 176, 40, 14 + CONTROL "String",IDF_STRING29,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 320, 176, 40, 14 + CONTROL "v18",IDF_STRING30,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 20, 198, 40, 14 + CONTROL "String",IDF_STRING24,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 20, 176, 40, 14 + CONTROL "String",IDF_STRING31,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 79, 197, 40, 14 + CONTROL "String",IDF_STRING32,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 139, 197, 40, 14 + CONTROL "String",IDF_STRING33,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 201, 197, 40, 14 + CONTROL "String",IDF_STRING34,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 259, 197, 40, 14 + CONTROL "v18",IDF_STRING35,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 319, 197, 40, 14 +END + +IDD_DIALOG02 RCDATA +BEGIN +"[Checks] \n" +" 1036 1 \n" +" 1037 0 \n" +" 1038 0 \n" +" 1039 0 \n" +" 1040 0 \n" +,0 +END + +IDD_DIALOG1 DIALOG 0, 0, 182, 79 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 10, "MS Sans Serif" +CAPTION "TITLE" +BEGIN + CONTROL "",IDF_STRING24,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 0, 24, 181, 20 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 74, 52, 40, 14 + CONTROL "Enter Title for Ouput File",IDF_LABEL5,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 32, 4, 136, 14 +END + +IDD_DIALOG04 DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "ERROR" +BEGIN + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 56, 40, 14 + CONTROL "Error in Data -- Press OK and Re-enter Values as Needed",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 15, 20, 130, 16 +END + +IDD_DIALOG04 RCDATA +BEGIN +"[Colours] \n" +" 1 256 256 256 255 000 000 \n" +" 1001 000 000 000 255 000 000 \n" +,0 +END + +IDD_DIALOG05 DIALOG 0, 0, 260, 116 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "MAP DISPLAY OPTIONS" +BEGIN + CONTROL "Map-3",IDF_CMAP3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 200, 12, 40, 14 + CONTROL "Map-4",IDF_CMAP4,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 20, 36, 40, 14 + CONTROL "Map-5",IDF_CMAP5,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 80, 36, 40, 14 + CONTROL "Map-6",IDF_CMAP6,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 140, 36, 40, 14 + CONTROL "Map-7",IDF_CMAP7,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 200, 36, 40, 14 + CONTROL "Map-8",IDF_CMAP8,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 20, 60, 40, 14 + CONTROL "Map-9",IDF_CMAP9,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 80, 60, 40, 14 + CONTROL "Map-0",IDF_CMAP0,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 20, 12, 40, 14 + CONTROL "Map-1",IDF_CMAP1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 80, 12, 40, 14 + CONTROL "Map-2",IDF_CMAP2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 140, 12, 40, 14 + CONTROL "Map-10",IDF_CMAP10,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 140, 60, 40, 14 + CONTROL "Map-11",IDF_CMAP11,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 200, 60, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 112, 92, 40, 14 +END + +IDD_DIALOG05 RCDATA +BEGIN +"[Checks] \n" +" 1012 0 \n" +" 1043 0 \n" +" 1044 0 \n" +" 1045 0 \n" +" 1046 0 \n" +" 1005 0 \n" +" 1006 0 \n" +" 1007 0 \n" +" 1008 0 \n" +" 1009 0 \n" +" 1010 0 \n" +" 1011 0 \n" +"[Colours] \n" +" 1012 256 256 256 128 255 128 \n" +" 1043 256 256 256 128 255 128 \n" +" 1044 256 256 256 128 255 128 \n" +" 1045 256 256 256 128 255 128 \n" +" 1046 256 256 256 128 255 128 \n" +" 1005 256 256 256 128 255 128 \n" +" 1006 256 256 256 128 255 128 \n" +" 1007 256 256 256 128 255 128 \n" +" 1008 256 256 256 128 255 128 \n" +" 1009 256 256 256 128 255 128 \n" +" 1010 256 256 256 128 255 128 \n" +" 1011 256 256 256 128 255 128 \n" +,0 +END + +IDD_DIALOG006 DIALOG 0, 0, 199, 183 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT DISPLAY OPTIONS" +BEGIN + CONTROL "Map",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 20, 12, 40, 14 + CONTROL "Outline",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 80, 12, 40, 14 + CONTROL "Network",IDF_RADIO3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 140, 12, 40, 14 + CONTROL "Nodes",IDF_RADIO4,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 20, 32, 40, 14 + CONTROL "B-elev",IDF_RADIO5,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 20, 52, 40, 14 + CONTROL "Elements",IDF_RADIO6,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 80, 32, 40, 14 + CONTROL "Type",IDF_RADIO7,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 80, 52, 40, 14 + CONTROL "Data",IDF_RADIO8,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 140, 32, 40, 14 + CONTROL "Grid",IDF_RADIO9,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 140, 52, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 80, 148, 40, 14 + CONTROL "CC-lines",IDF_RADIO10,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 20, 80, 40, 14 + CONTROL "Con Str",IDF_RADIO11,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 142, 80, 38, 14 +END + +IDD_DIALOG006 RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +" 1049 0 \n" +" 1050 0 \n" +" 1051 0 \n" +" 1052 0 \n" +" 1053 0 \n" +" 1054 0 \n" +" 1055 0 \n" +" 1056 0 \n" +" 1057 0 \n" +,0 +END + +IDD_DIALOG07 DIALOG 0, 0, 213, 170 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SAVE OPTIONS" +BEGIN + CONTROL "Skip checking and then save",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 34, 40, 146, 17 + CONTROL "Terminate save",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 34, 56, 146, 17 + CONTROL "Execute fill then save",IDF_RADIO3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 34, 72, 146, 17 + CONTROL "You have entered save without executing fill",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | SS_LEFT, 34, 16, 146, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 87, 144, 40, 14 + CONTROL "Continue checking",IDF_RADIO4,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 34, 88, 146, 17 + CONTROL "Note that if checking is continued without fill, Checks for duplicate elements are ineffective",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | SS_LEFT, 38, 116, 138, 20 +END + +IDD_DIALOG07 RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +" 1049 0 \n" +" 1050 0 \n" +"[Colours] \n" +" 1001 256 256 256 255 255 128 \n" +" 1002 256 256 256 255 255 128 \n" +,0 +END + +IDD_DIALOG08 DIALOG 0, 0, 140, 88 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT CCLINE TYPES" +BEGIN + CONTROL "Save corner nodes only",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 12, 102, 14 + CONTROL "Save corner and mid-sides",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 36, 100, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 50, 64, 40, 14 +END + +IDD_DIALOG08 RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +,0 +END + +IDD_DIALOG09 DIALOG 0, 0, 160, 86 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "RMAGEN INFO" +BEGIN + CONTROL "RMAGEN Version 8.3 Nov 2014",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 14, 8, 130, 12 + CONTROL "Resource Modelling Associates",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | SS_CENTER, 20, 36, 120, 12 + CONTROL "Sydney, NSW Australia",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | SS_CENTER, 20, 48, 118, 12 + CONTROL "Copyright",IDF_LABEL7,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 22, 24, 118, 8 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 64, 40, 14 +END + +IDD_DIALOG10 DIALOG 0, 0, 320, 115 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT PROPERTIES" +BEGIN + CONTROL "Number of figures beyond decimal",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 20, 60, 16 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 20, 40, 16 + CONTROL "Frequency for display",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 44, 60, 16 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 44, 40, 16 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 140, 88, 40, 14 + CONTROL "Draw as colour dots",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 180, 14, 120, 10 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 260, 57, 40, 14 + CONTROL "Radius of dot circle (m)",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 180, 56, 60, 16 + CONTROL "Colour interval (m)",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 181, 36, 60, 12 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 261, 32, 40, 14 +END + +IDD_DIALOG10 RCDATA +BEGIN +"[Checks] \n" +" 1036 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_DIALOG010 DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT CONTINUITY LINE NUMBER" +BEGIN + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 104, 28, 42, 14 + CONTROL " Continuity line number",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | SS_LEFT, 20, 28, 76, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 56, 52, 40, 14 +END + +IDD_DIALOG010 RCDATA +BEGIN +"[Ranges] \n" +"[Colours] \n" +" 1001 256 256 256 255 255 255 \n" +,0 +END + +IDD_DIALOG001 DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT REORDERING LIST NUMBER" +BEGIN + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 104, 28, 42, 14 + CONTROL "List Number",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | SS_CENTER, 20, 28, 76, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 56, 52, 40, 14 +END + +IDD_DIALOG001 RCDATA +BEGIN +"[Ranges] \n" +"[Colours] \n" +" 1001 256 256 256 255 255 255 \n" +,0 +END + +IDD_DIALOG012 DIALOG 0, 0, 300, 224 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT ACTIVE BACKGROUND COLOURS AND FILES" +BEGIN + CONTROL "",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 36, 180, 12 + CONTROL "",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 50, 180, 12 + CONTROL "",IDF_STRING3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 64, 180, 12 + CONTROL "",IDF_STRING4,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 78, 180, 12 + CONTROL "",IDF_STRING5,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 92, 180, 12 + CONTROL "",IDF_STRING6,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 106, 180, 12 + CONTROL "",IDF_STRING7,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 120, 180, 12 + CONTROL "",IDF_STRING8,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 134, 180, 12 + CONTROL "",IDF_STRING9,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 148, 180, 12 + CONTROL "",IDF_STRING10,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 162, 180, 12 + CONTROL "",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 36, 40, 14 + CONTROL "",IDF_CHECK2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 50, 40, 14 + CONTROL "",IDF_CHECK3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 64, 40, 14 + CONTROL "",IDF_CHECK4,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 78, 40, 14 + CONTROL "",IDF_CHECK5,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 92, 40, 14 + CONTROL "",IDF_CHECK6,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 106, 40, 14 + CONTROL "",IDF_CHECK7,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 120, 40, 14 + CONTROL "",IDF_CHECK8,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 134, 40, 14 + CONTROL "",IDF_CHECK9,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 148, 40, 14 + CONTROL "",IDF_CHECK10,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 240, 162, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 130, 196, 40, 14 + CONTROL "Grey Background on",IDF_CHECK11,"BUTTON",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 106, 12, 86, 14 +END + +IDD_DIALOG012 RCDATA +BEGIN +"[Checks] \n" +" 1036 0 \n" +" 1037 0 \n" +" 1038 0 \n" +" 1039 0 \n" +" 1040 0 \n" +" 1041 0 \n" +" 1042 0 \n" +" 1043 0 \n" +" 1044 0 \n" +" 1045 0 \n" +" 1059 0 \n" +"[Colours] \n" +" 1013 256 256 256 255 255 128 \n" +" 1014 256 256 256 255 255 128 \n" +" 1015 256 256 256 255 255 128 \n" +" 1016 256 256 256 255 255 128 \n" +" 1017 256 256 256 255 255 128 \n" +" 1018 256 256 256 255 255 128 \n" +" 1019 256 256 256 255 255 128 \n" +" 1020 256 256 256 255 255 128 \n" +" 1021 256 256 256 255 255 128 \n" +" 1022 256 256 256 255 255 128 \n" +" 1059 256 256 256 255 255 128 \n" +,0 +END + +IDD_REGST DIALOG 0, 0, 322, 183 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "REGISTER BACKGROUND LOCATION" +BEGIN + CONTROL "1st Value from Image",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 220, 12, 66, 12 + CONTROL "X coordinate",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 32, 40, 8 + CONTROL "Y coordinate",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 48, 40, 8 + CONTROL " 2nd True Location",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 48, 68, 76, 12 + CONTROL "Y coordinate",IDF_LABEL5,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 112, 40, 8 + CONTROL "X coordinate",IDF_LABEL6,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 180, 92, 40, 8 + CONTROL " 1st True Location",IDF_LABEL7,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 46, 12, 74, 12 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 80, 32, 60, 14 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 82, 48, 58, 14 + CONTROL "0.0000",IDF_REAL3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 82, 88, 58, 14 + CONTROL "0.0000",IDF_REAL4,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 82, 108, 58, 14 + CONTROL "X coordinate",IDF_LABEL8,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 180, 36, 40, 8 + CONTROL "Y coordinate",IDF_LABEL9,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 180, 48, 40, 8 + CONTROL "X coordinate",IDF_LABEL10,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 92, 40, 8 + CONTROL "Y coordinate",IDF_LABEL11,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 180, 112, 40, 8 + CONTROL "0.0000",IDF_REAL5,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 241, 35, 56, 14 + CONTROL "0.0000",IDF_REAL6,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 48, 58, 11 + CONTROL "0.0000",IDF_REAL7,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 92, 60, 14 + CONTROL "0.0000",IDF_REAL8,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 112, 58, 14 + CONTROL "2nd Value from Image",IDF_LABEL12,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 220, 70, 67, 9 + CONTROL "Adjust Register",IDADJUST,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 20, 148, 52, 12 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 141, 148, 40, 14 + CONTROL "Switch Point",IDFSWITCH,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 246, 148, 54, 14 +END + +IDD_REGST RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_SLRGNO DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT REGISTER POINT NUMBER" +BEGIN + CONTROL "Choose Point Number",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 20, 24, 60, 16 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 24, 42, 16 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 58, 56, 40, 14 +END + +IDD_SLRGNO RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_CONFIRM DIALOG 0, 0, 322, 171 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "CONFIRM REGISTER LOCATIONS" +BEGIN + CONTROL "Current upper right",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 220, 12, 66, 12 + CONTROL "X coordinate",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 32, 40, 8 + CONTROL "Y coordinate",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 48, 40, 8 + CONTROL "Proposed lower left",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 48, 68, 76, 12 + CONTROL "Y coordinate",IDF_LABEL5,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 112, 40, 8 + CONTROL "X coordinate",IDF_LABEL6,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 180, 92, 40, 8 + CONTROL "Current lower left",IDF_LABEL7,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 46, 12, 74, 12 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 80, 32, 60, 14 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 82, 48, 58, 14 + CONTROL "0.0000",IDF_REAL3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 82, 88, 58, 14 + CONTROL "0.0000",IDF_REAL4,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 82, 108, 58, 14 + CONTROL "X coordinate",IDF_LABEL8,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 180, 36, 40, 8 + CONTROL "Y coordinate",IDF_LABEL9,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 180, 48, 40, 8 + CONTROL "X coordinate",IDF_LABEL10,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 92, 40, 8 + CONTROL "Y coordinate",IDF_LABEL11,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 180, 112, 40, 8 + CONTROL "0.0000",IDF_REAL5,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 241, 35, 56, 14 + CONTROL "0.0000",IDF_REAL6,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 48, 58, 11 + CONTROL "0.0000",IDF_REAL7,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 92, 60, 14 + CONTROL "0.0000",IDF_REAL8,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 112, 58, 14 + CONTROL "Proposed upper right",IDF_LABEL12,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 220, 70, 66, 9 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 82, 140, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 199, 140, 40, 14 +END + +IDD_CONFIRM RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_nodedata DIALOG 0, 0, 334, 175 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Node Data" +BEGIN + CONTROL "Node Number",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 34, 20, 66, 8 + CONTROL "X-coordinate",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 34, 36, 66, 8 + CONTROL "Y-coordinate",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 34, 52, 66, 8 + CONTROL "Bed Elevation",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 34, 68, 66, 8 + CONTROL "Bottom Width",IDF_LABEL5,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 170, 20, 66, 8 + CONTROL "Side Slope 1",IDF_LABEL6,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 170, 36, 66, 8 + CONTROL "Side Slope 2",IDF_LABEL7,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 170, 52, 66, 8 + CONTROL "Storage Width",IDF_LABEL8,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 170, 68, 66, 8 + CONTROL "Storage Base Elevation",IDF_LABEL9,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 170, 84, 77, 8 + CONTROL "Storage Slope",IDF_LABEL10,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 170, 100, 66, 8 + CONTROL "Bed Slope",IDF_LABEL11,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 170, 116, 66, 8 + CONTROL "Elevation Locked",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 34, 88, 126, 11 + CONTROL "0",IDF_INTEGER1,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE | ES_READONLY, 110, 19, 50, 12 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 110, 36, 50, 12 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 110, 51, 50, 12 + CONTROL "0.0000",IDF_REAL3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 110, 67, 50, 12 + CONTROL "0.0000",IDF_REAL4,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 250, 19, 50, 12 + CONTROL "0.0000",IDF_REAL5,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 250, 35, 50, 12 + CONTROL "0.0000",IDF_REAL6,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 250, 50, 50, 12 + CONTROL "0.0000",IDF_REAL7,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 250, 66, 50, 12 + CONTROL "0.0000",IDF_REAL8,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 250, 82, 50, 12 + CONTROL "0.0000",IDF_REAL9,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 250, 97, 50, 12 + CONTROL "0.0000",IDF_REAL10,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 250, 114, 50, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 140, 40, 14 + CONTROL "NEXT",IDNEXT,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 147, 140, 40, 14 + CONTROL "CANCEL",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 236, 140, 40, 14 +END + +IDD_nodedata RCDATA +BEGIN +"[Checks] \n" +" 1036 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_eltdata DIALOG 0, 0, 352, 156 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Element Data" +BEGIN + CONTROL "Element Number",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 70, 12, 70, 8 + CONTROL "Element Connections",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 141, 34, 70, 8 + CONTROL "0",IDF_INTEGER2,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 20, 50, 30, 12 + CONTROL "0",IDF_INTEGER3,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 60, 50, 30, 12 + CONTROL "0",IDF_INTEGER4,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 50, 30, 12 + CONTROL "0",IDF_INTEGER5,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 140, 50, 30, 12 + CONTROL "0",IDF_INTEGER6,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 180, 50, 30, 12 + CONTROL "0",IDF_INTEGER7,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 220, 50, 30, 12 + CONTROL "0",IDF_INTEGER8,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 260, 50, 30, 12 + CONTROL "0",IDF_INTEGER9,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 300, 50, 30, 12 + CONTROL "0",IDF_INTEGER1,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE | ES_READONLY, 180, 10, 40, 14 + CONTROL "Element Type Number",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 70, 72, 70, 8 + CONTROL "0",IDF_INTEGER10,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 180, 68, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 40, 96, 40, 14 + CONTROL "NEXT",IDNEXT,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 116, 96, 40, 14 + CONTROL "CANCEL",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 270, 96, 40, 14 + CONTROL "DELETE",IDF_Delete,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 195, 96, 40, 14 + CONTROL "ROTATE",IDFROTATE,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 156, 124, 40, 14 +END + +IDD_eltdata RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_SELNODE DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Select Node Number" +BEGIN + CONTROL "Node Number",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 26, 21, 54, 8 + CONTROL "0",IDF_INTEGER1,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 18, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 46, 40, 14 +END + +IDD_SELNODE RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_SELELT DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Select Element Number" +BEGIN + CONTROL "Element Number",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 26, 21, 54, 8 + CONTROL "0",IDF_INTEGER1,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 18, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 46, 40, 14 +END + +IDD_SELELT RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_ELTERR DIALOG 0, 0, 160, 105 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Element Data Error" +BEGIN + CONTROL "ERROR IN ELEMENT CONNECTIONS",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 15, 12, 130, 8 + CONTROL "Remove Element by Deleting Connections",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 12, 28, 136, 8 + CONTROL "Element Number",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 23, 58, 58, 8 + CONTROL "0",IDF_INTEGER1,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 101, 57, 38, 11 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 78, 40, 14 + CONTROL "or Edit Entries",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 57, 40, 46, 8 +END + +IDD_ELTERR RCDATA +BEGIN +"[Ranges] \n" +"[Colours] \n" +" 1001 256 256 256 255 128 000 \n" +,0 +END + +IDD_GETINTP DIALOG 0, 0, 194, 126 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Set Interpolation" +BEGIN + CONTROL "Number of X interpolation points",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 17, 100, 8 + CONTROL "Number of Y interpolation points",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 20, 37, 100, 8 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 125, 15, 40, 14 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 125, 35, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 72, 100, 40, 14 + CONTROL "X-interpolation interval",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 58, 100, 8 + CONTROL "Y-interpolation interval",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 78, 100, 8 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 125, 55, 40, 14 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 125, 75, 40, 14 +END + +IDD_GETINTP RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_headertp DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT HEADER TYPE" +BEGIN + CONTROL "Little Endian",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 24, 10, 112, 14 + CONTROL "Big Endian",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 24, 26, 112, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 52, 40, 14 +END + +IDD_headertp RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +,0 +END + +IDD_TRIAN DIALOG 0, 0, 260, 100 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "TRIANGULARIZATION OPTIONS" +BEGIN + CONTROL "Data frequency (default=1)",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 22, 100, 10 + CONTROL "Minimum spacing (default = 0.0)",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 40, 110, 10 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 160, 21, 60, 12 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 160, 39, 60, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 110, 67, 40, 14 +END + +IDD_TRIAN RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_NODERR DIALOG 0, 0, 240, 111 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "ERROR IN FILL PROCESS" +BEGIN + CONTROL "MAXIMUM NUMBER OF ELEMENTS CONNECTED",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 36, 8, 168, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 110, 89, 40, 14 + CONTROL "ALLOWABLE LIMIT IS",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 50, 80, 12 + CONTROL "CONNECTIONS DETECTED",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 67, 96, 12 + CONTROL "0",IDF_INTEGER2,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 160, 50, 40, 12 + CONTROL "0",IDF_INTEGER3,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 161, 66, 40, 12 + CONTROL " TO NODE EXCEEDED",IDF_LABEL5,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 80, 20, 80, 10 + CONTROL "FILL TERMINATED",IDF_LABEL6,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 87, 30, 65, 11 +END + +IDD_NODERR RCDATA +BEGIN +"[Ranges] \n" +"[Colours] \n" +" 1002 256 256 256 255 255 128 \n" +" 1042 256 256 256 255 255 128 \n" +" 1005 256 256 256 255 255 128 \n" +,0 +END + +IDD_SELTFL2 DIALOG 0, 0, 400, 224 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION " SELECT FILE" +BEGIN + CONTROL "",IDF_STRING25,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 36, 340, 12 + CONTROL "",IDF_STRING26,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 50, 340, 12 + CONTROL "",IDF_STRING27,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 64, 340, 12 + CONTROL "",IDF_STRING28,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 78, 340, 12 + CONTROL "",IDF_STRING29,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 92, 340, 12 + CONTROL "",IDF_STRING30,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 106, 340, 12 + CONTROL "",IDF_STRING31,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 120, 340, 12 + CONTROL "",IDF_STRING32,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 134, 340, 12 + CONTROL "",IDF_STRING33,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 148, 340, 12 + CONTROL "",IDF_STRING34,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 162, 340, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 180, 196, 40, 14 + CONTROL "",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 36, 20, 12 + CONTROL "",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 50, 20, 12 + CONTROL "",IDF_RADIO3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 64, 20, 12 + CONTROL "",IDF_RADIO4,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 78, 20, 12 + CONTROL "",IDF_RADIO5,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 92, 20, 12 + CONTROL "",IDF_RADIO6,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 106, 20, 12 + CONTROL "",IDF_RADIO7,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 120, 20, 12 + CONTROL "",IDF_RADIO8,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 134, 20, 12 + CONTROL "",IDF_RADIO9,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 148, 20, 12 + CONTROL "",IDF_RADIO10,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 162, 20, 12 +END + +IDD_SELTFL2 RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +" 1049 0 \n" +" 1050 0 \n" +" 1051 0 \n" +" 1052 0 \n" +" 1053 0 \n" +" 1054 0 \n" +" 1055 0 \n" +" 1056 0 \n" +"[Colours] \n" +" 1106 256 256 256 255 255 128 \n" +" 1107 256 256 256 255 255 128 \n" +" 1108 256 256 256 255 255 128 \n" +" 1109 256 256 256 255 255 128 \n" +" 1110 256 256 256 255 255 128 \n" +" 1111 256 256 256 255 255 128 \n" +" 1112 256 256 256 255 255 128 \n" +" 1113 256 256 256 255 255 128 \n" +" 1114 256 256 256 255 255 128 \n" +" 1115 256 256 256 255 255 128 \n" +,0 +END + +IDD_TRIANG DIALOG 0, 0, 197, 103 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "TRIANGULAR BLOCK" +BEGIN + CONTROL "Elements on side 1",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 41, 18, 62, 8 + CONTROL "Elements on side 2",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 41, 30, 62, 8 + CONTROL "Elements on side 3",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 41, 42, 62, 8 + CONTROL "1",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 16, 40, 12 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 30, 40, 12 + CONTROL "0",IDF_INTEGER3,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 42, 40, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 80, 64, 40, 14 +END + +IDD_TRIANG RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_QUAD DIALOG 0, 0, 197, 103 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "QUADRILATERAL BLOCK" +BEGIN + CONTROL "Elements on side 1",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 41, 18, 62, 8 + CONTROL "Elements on side 2",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 41, 32, 62, 8 + CONTROL "Elements on side 3",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 41, 46, 62, 8 + CONTROL "1",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 16, 40, 12 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 30, 40, 12 + CONTROL "0",IDF_INTEGER3,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 44, 40, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 80, 79, 40, 14 + CONTROL "Elements on side 4",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 41, 60, 62, 8 + CONTROL "0",IDF_INTEGER4,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 58, 40, 12 +END + +IDD_QUAD RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_DIALOG06 DIALOG 0, 0, 316, 202 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT DISPLAY OPTIONS" +BEGIN + CONTROL "Map",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 20, 12, 40, 14 + CONTROL "Outline",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 80, 12, 40, 14 + CONTROL "Network",IDF_RADIO3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 200, 12, 40, 14 + CONTROL "Nodes",IDF_RADIO4,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 20, 36, 40, 14 + CONTROL "B-elev",IDF_RADIO5,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 80, 36, 40, 14 + CONTROL "Layers",IDF_RADIO17,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 140, 36, 40, 14 + CONTROL "No nodal display",IDF_RADIO18,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 198, 36, 80, 14 + CONTROL "Elements",IDF_RADIO6,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 20, 60, 40, 14 + CONTROL "Type",IDF_RADIO7,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 80, 60, 40, 14 + CONTROL "Group",IDF_RADIO19,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 140, 60, 40, 14 + CONTROL "Data",IDF_RADIO8,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 260, 57, 40, 14 + CONTROL "Grid",IDF_RADIO9,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 140, 12, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 200, 137, 40, 14 + CONTROL "CC-lines",IDF_RADIO10,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 260, 12, 40, 14 + CONTROL "Con Str",IDF_RADIO11,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 200, 58, 40, 14 + CONTROL "1-D cross-sec locactions",IDF_RADIO12,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 160, 91, 100, 14 + CONTROL "Cross-sec weighting factors",IDF_RADIO13,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 160, 109, 100, 14 + CONTROL "Display 1-D as input RM1 width",IDF_RADIO14,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 21, 93, 108, 16 + CONTROL "Display 1-D as computed width",IDF_RADIO15,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 21, 109, 108, 16 + CONTROL "Display 1-D as computed area",IDF_RADIO16,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 21, 126, 108, 16 + CONTROL "Nominal Elevation",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 151, 62, 12 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 88, 150, 40, 14 + CONTROL "Width scale factor",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 168, 62, 12 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 88, 167, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 200, 169, 40, 14 +END + +IDD_DIALOG06 RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +" 1049 0 \n" +" 1050 0 \n" +" 1051 0 \n" +" 1059 0 \n" +" 1062 0 \n" +" 1052 0 \n" +" 1053 0 \n" +" 1063 0 \n" +" 1054 0 \n" +" 1055 0 \n" +" 1056 0 \n" +" 1057 0 \n" +" 1058 0 \n" +" 1076 0 \n" +" 1080 0 \n" +" 1081 0 \n" +" 1082 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_GETFPN DIALOG 0, 0, 160, 89 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "ENTER FLOATING POINT" +BEGIN + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 60, 32, 40, 14 + CONTROL "",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | ES_LEFT | ES_CENTER | ES_MULTILINE | ES_UPPERCASE | ES_READONLY, 15, 8, 130, 16 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 59, 40, 14 +END + +IDD_GETFPN RCDATA +BEGIN +"[Ranges] \n" +"[Colours] \n" +" 1013 256 256 256 255 255 255 \n" +"[Formats] \n" +,0 +END + +IDD_GETINT DIALOG 0, 0, 181, 88 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "ENTER INTEGER" +BEGIN + CONTROL "",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | ES_LEFT | ES_CENTER | ES_MULTILINE | ES_UPPERCASE | ES_READONLY, 13, 8, 154, 16 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 70, 36, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 70, 60, 40, 14 +END + +IDD_GETINT RCDATA +BEGIN +"[Ranges] \n" +"[Colours] \n" +" 1013 256 256 256 255 255 255 \n" +,0 +END + +IDD_CSLOC DIALOG 0, 0, 219, 147 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "GET CROSS-SECTION LOCATIONS" +BEGIN + CONTROL "Cross-section Number",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 35, 27, 74, 12 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 142, 24, 44, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 148, 112, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 35, 112, 40, 14 + CONTROL "After selecting Cross-section number, press OK and click location on network display. Press Cancel to terminate.",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_MULTILINE, 36, 52, 148, 36 +END + +IDD_CSLOC RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_CREATM DIALOG 0, 0, 259, 177 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT CONTOUR LINES AND INTERVALS" +BEGIN + CONTROL "",IDF_GRID1,"ISSGRID",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_VSCROLL | WS_HSCROLL | WS_GROUP | WS_TABSTOP | GS_DEFROWLABELS | GS_COLUMNLABELS, 33, 20, 192, 112 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 62, 144, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 159, 144, 40, 14 +END + +IDD_CREATM RCDATA +BEGIN +"[Grids] \n" +" 1075 3 21 129 \n" +,0 +END + +IDD_TEMPLATE001 DIALOG 0, 0, 1000, 16 +STYLE DS_3DLOOK +FONT 8, "MS Sans Serif" +BEGIN + CONTROL "Activate Contour",ISS1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_TEXT, 0, 0, 60, 14 + CONTROL "Contour value",ISS2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 60, 14 + CONTROL "Nodal interval",ISS3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 60, 14 +END + +IDD_TEMPLATE001 RCDATA +BEGIN +"[Checks] \n" +" 1077 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_CREATM1 DIALOG 0, 0, 200, 120 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "CHOOSE OPTIONS" +BEGIN + CONTROL "Use all contour lines",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 40, 17, 120, 14 + CONTROL "Use same interval for all lines",IDF_CHECK2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 40, 37, 120, 14 + CONTROL "Nodal interval along lines",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 61, 78, 8 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 121, 58, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 40, 85, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 121, 84, 40, 14 +END + +IDD_CREATM1 RCDATA +BEGIN +"[Checks] \n" +" 1036 0 \n" +" 1037 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_ORDEROUT DIALOG 0, 0, 276, 248 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "RE-ORDERING RESULTS" +BEGIN + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 118, 216, 40, 14 + CONTROL "",IDF_GRID1,"ISSGRID",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_VSCROLL | WS_HSCROLL | WS_GROUP | WS_TABSTOP | GS_DEFROWLABELS | GS_COLUMNLABELS | GS_ROWLABELS, 33, 24, 211, 148 + CONTROL "Note that sequence number 0 is original order",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 60, 186, 156, 12 +END + +IDD_ORDEROUT RCDATA +BEGIN +"[Grids] \n" +" 1075 3 101 132 \n" +" 0 \n" +"[Colours] \n" +" 1001 256 256 256 255 255 000 \n" +,0 +END + +IDD_TEMPLATE002 DIALOG 0, 0, 1000, 16 +STYLE DS_3DLOOK +FONT 8, "MS Sans Serif" +BEGIN + CONTROL "SEQUENCE NO.",ISS1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_CENTER | ES_MULTILINE, 0, 0, 63, 14 + CONTROL "RE-ORDERING SUM",ISS2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 80, 14 + CONTROL "MAX-FRONT",ISS3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 55, 14 +END + +IDD_selcrsec DIALOG 0, 0, 225, 123 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT CROSS-SECTION NUMBERS" +BEGIN + CONTROL "",IDF_GRID1,"ISSGRID",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | GS_DEFROWLABELS | GS_COLUMNLABELS, 37, 24, 150, 28 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 52, 97, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 149, 97, 40, 14 + CONTROL "Use automatic axis scales",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 68, 60, 88, 12 + CONTROL "Input axis scales",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 68, 73, 88, 12 +END + +IDD_selcrsec RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +"[Grids] \n" +" 1075 5 1 134 \n" +,0 +END + +IDD_TEMPLATE003 DIALOG 0, 0, 1000, 16 +STYLE DS_3DLOOK +FONT 8, "MS Sans Serif" +BEGIN + CONTROL "SEC-1",ISS1,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 30, 14 + CONTROL "SEC-2",ISS2,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 30, 14 + CONTROL "SEC-3",ISS3,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 30, 14 + CONTROL "SEC-4",ISS4,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 30, 14 + CONTROL "SEC-5",ISS5,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 30, 14 +END + +IDD_TEMPLATE003 RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_LIMITS DIALOG 0, 0, 209, 141 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SET CROSS-SECTION AXIS LIMITS" +BEGIN + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 126, 20, 40, 14 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 126, 40, 40, 14 + CONTROL "0.0000",IDF_REAL3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 126, 60, 40, 14 + CONTROL "0.0000",IDF_REAL4,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 126, 80, 40, 14 + CONTROL "X-Axis Minimum",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 23, 80, 8 + CONTROL "Y-Axis Minimum",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 63, 80, 8 + CONTROL "X-Axis Maximum",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 43, 80, 8 + CONTROL "Y-Axis Maximum",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 82, 80, 8 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 40, 108, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 140, 108, 40, 14 +END + +IDD_LIMITS RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_lAY DIALOG 0, 0, 279, 113 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "LAYER DATA" +BEGIN + CONTROL "Layer type LD2",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 50, 12, 58, 14 + CONTROL "Layer type LD3",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 50, 29, 58, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 88, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 180, 88, 40, 14 + CONTROL "",IDF_GRID1,"ISSGRID",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | GS_DEFROWLABELS | GS_COLUMNLABELS, 16, 52, 248, 28 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 200, 20, 40, 14 + CONTROL "Number of layers",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 140, 23, 52, 8 +END + +IDD_lAY RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +"[Ranges] \n" +"[Grids] \n" +" 1075 7 1 137 \n" +,0 +END + +IDD_TEMPLATE004 DIALOG 0, 0, 1000, 16 +STYLE DS_3DLOOK +FONT 8, "MS Sans Serif" +BEGIN + CONTROL "layer 1",ISS1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 35, 14 + CONTROL "layer 2",ISS2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 35, 14 + CONTROL "layer 3",ISS3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 35, 14 + CONTROL "layer 4",ISS4,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 35, 14 + CONTROL "layer 5",ISS5,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 35, 14 + CONTROL "layer 6",ISS6,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 35, 14 + CONTROL "layer 7",ISS7,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 0, 0, 35, 14 +END + +IDD_TEMPLATE004 RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_DISPLIT DIALOG 0, 0, 180, 240 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT SPLIT OPTIONS" +BEGIN + CONTROL "Distance Apart of Split Nodes",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 22, 65, 98, 10 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 122, 64, 38, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 70, 201, 40, 14 + CONTROL "Element type number",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 47, 104, 68, 10 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 123, 102, 35, 12 + CONTROL "Insert elements",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 61, 83, 70, 11 + CONTROL "Add end triangles",IDF_CHECK2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 56, 123, 75, 11 + CONTROL "Direction to split nodes for single node split",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 24, 173, 79, 18 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 122, 176, 38, 12 + CONTROL "Continuity Line Number",IDF_LABEL6,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 22, 46, 98, 10 + CONTROL "Form Line by Clicking Nodes",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 22, 8, 110, 12 + CONTROL "Use Existing Continuity Line",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 22, 27, 110, 12 + CONTROL "0",IDF_INTEGER3,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 123, 47, 35, 12 + CONTROL "End Element type number",IDF_LABEL5,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 34, 144, 80, 10 + CONTROL "0",IDF_INTEGER6,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 142, 35, 12 +END + +IDD_DISPLIT RCDATA +BEGIN +"[Checks] \n" +" 1036 0 \n" +" 1037 0 \n" +" 1047 0 \n" +" 1048 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_DIRSPLIT DIALOG 0, 0, 177, 81 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "DIRECTION OF SPLIT" +BEGIN + CONTROL "Direction to split nodes",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 21, 21, 79, 11 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 122, 20, 38, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 68, 48, 40, 14 +END + +IDD_DIRSPLIT RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_SETOPT DIALOG 0, 0, 160, 103 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Set option" +BEGIN + CONTROL "Set nodal value",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 12, 80, 14 + CONTROL "Apply as adjustment",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 24, 80, 14 + CONTROL "Lock value after adjustment",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 32, 48, 95, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 76, 40, 14 +END + +IDD_SETOPT RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +" 1036 0 \n" +,0 +END + +IDD_SETMAXMAP DIALOG 0, 0, 175, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "RESET MAXIMUM MAP FILE SIZE" +BEGIN + CONTROL "Maximum number of map lines",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 20, 24, 60, 16 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 24, 60, 16 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 58, 56, 40, 14 +END + +IDD_SETMAXMAP RCDATA +BEGIN +"[Ranges] \n" +"[Colours] \n" +" 1001 255 000 000 255 255 000 \n" +,0 +END + +IDD_MLIMITS DIALOG 0, 0, 175, 159 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "RESET LIMITS" +BEGIN + CONTROL "Maximum number of nodes",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 20, 22, 60, 24 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 26, 60, 16 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 68, 127, 40, 14 + CONTROL "Maximum Number of Elements",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 22, 53, 60, 24 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 101, 56, 60, 16 + CONTROL "Maximum Number of Map Points",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_CENTER, 20, 88, 60, 24 + CONTROL "0",IDF_INTEGER3,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 91, 60, 16 +END + +IDD_MLIMITS RCDATA +BEGIN +"[Ranges] \n" +"[Colours] \n" +" 1001 255 000 000 255 255 000 \n" +" 1002 255 000 000 255 255 000 \n" +" 1003 255 000 000 255 255 000 \n" +,0 +END + +IDD_CHKOPT DIALOG 0, 0, 230, 147 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "CHECK OPTIONS" +BEGIN + CONTROL "Check areas",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 40, 18, 150, 11 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 50, 115, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 140, 115, 40, 14 + CONTROL "Check bed elevation/section differences",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 34, 150, 11 + CONTROL "Check normailized depth/section differences",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 50, 150, 11 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 130, 67, 60, 14 + CONTROL "Reference elevation",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 68, 80, 11 + CONTROL "Additional options for 1-D elements",IDF_CHECK2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 40, 86, 150, 11 +END + +IDD_CHKOPT RCDATA +BEGIN +"[Checks] \n" +" 1036 1 \n" +" 1047 0 \n" +" 1048 0 \n" +" 1037 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_SETSEL DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SET SELECTION FRACTION" +BEGIN + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 18, 40, 14 + CONTROL "Selection fraction",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 20, 60, 8 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 48, 40, 14 +END + +IDD_SETSEL RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_CHK1DOPT DIALOG 0, 0, 200, 116 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SET 1-D OPTIONS" +BEGIN + CONTROL "Check width differences",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 16, 120, 11 + CONTROL "Check area differences",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 35, 120, 11 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 40, 84, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 120, 84, 40, 14 + CONTROL "Reference elevation",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 40, 55, 80, 11 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 54, 40, 14 +END + +IDD_CHK1DOPT RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_VIEWANG DIALOG 0, 0, 219, 263 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Set Viewing Angle and Vertical Scale" +BEGIN + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 160, 33, 40, 14 + CONTROL "90.000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 160, 72, 40, 14 + CONTROL "Angle of View Horizontally",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 29, 90, 10 + CONTROL "Angle of View Looking Down",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 69, 95, 11 + CONTROL "To North = 0.0 to West = 90.0",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 40, 100, 11 + CONTROL "Horizontal = 0.0 Vertical = 90.0",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 80, 114, 11 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 90, 230, 40, 14 + CONTROL "Vertical Scale Factor",IDF_LABEL5,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 109, 95, 11 + CONTROL "1.0000",IDF_REAL3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 160, 115, 40, 14 + CONTROL "Prototype Dimension per Unit Plot Dimension",IDF_LABEL6,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 120, 114, 16 + CONTROL "Vertical Scale Origin for Contour Plot",IDF_LABEL7,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 21, 154, 95, 17 + CONTROL "Units of Contour Plot",IDF_LABEL8,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 21, 176, 85, 15 + CONTROL "1.0000",IDF_REAL4,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 161, 160, 40, 14 + CONTROL "Hold vertical/horizontal aspect ratio constant",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 22, 202, 176, 14 +END + +IDD_VIEWANG RCDATA +BEGIN +"[Checks] \n" +" 1036 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_DIALOG047 DIALOG 0, 0, 199, 132 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SET MOVE OPTIONS" +BEGIN + CONTROL "X-Shift or X-Origin for scaling",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 18, 100, 8 + CONTROL "Y-Shift or Y-Origin for scaling",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 40, 100, 8 + CONTROL "X-Scale",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 21, 62, 100, 8 + CONTROL "Y-Scale",IDF_LABEL4,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 82, 100, 8 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 140, 15, 40, 14 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 141, 37, 40, 14 + CONTROL "0.0000",IDF_REAL3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 141, 59, 40, 14 + CONTROL "0.0000",IDF_REAL4,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 141, 81, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 42, 104, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 120, 104, 40, 14 +END + +IDD_DIALOG047 RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_DIALOG048 DIALOG 0, 0, 160, 90 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT METHOD" +BEGIN + CONTROL "Use fixed shift or scaling",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 20, 12, 120, 14 + CONTROL "Use graphical adjustment",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 20, 35, 120, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 22, 60, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 99, 60, 40, 14 +END + +IDD_DIALOG048 RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +,0 +END + +IDD_SELELTYP DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT ELEMENT TYPE" +BEGIN + CONTROL "Element Type",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 26, 21, 54, 8 + CONTROL "0",IDF_INTEGER1,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 18, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 46, 40, 14 +END + +IDD_SELELTYP RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_TRANSFORM DIALOG 0, 0, 302, 197 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "TRANSFORM COEFFICIENTS" +BEGIN + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 152, 17, 40, 14 + CONTROL "SELECT OPTION",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 75, 16, 66, 14 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 94, 40, 40, 14 + CONTROL "0",IDF_INTEGER3,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 94, 58, 40, 14 + CONTROL "0",IDF_INTEGER4,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 95, 78, 40, 14 + CONTROL "0",IDF_INTEGER5,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 95, 99, 40, 14 + CONTROL "INT COEFFICIENT 1",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 19, 41, 70, 14 + CONTROL "INT COEFFICIENT 2",IDF_STRING3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 20, 59, 70, 14 + CONTROL "INT COEFFICIENT 3",IDF_STRING4,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 20, 78, 70, 14 + CONTROL "INT COEFFICIENT 4",IDF_STRING5,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 20, 99, 70, 14 + CONTROL "RL COEFFICIENT 1",IDF_STRING6,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 160, 40, 70, 14 + CONTROL "RL COEFFICIENT 2",IDF_STRING7,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 160, 58, 70, 14 + CONTROL "RL COEFFICIENT 3",IDF_STRING8,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 160, 77, 70, 14 + CONTROL "RL COEFFICIENT 4",IDF_STRING9,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 160, 98, 70, 14 + CONTROL "0.0000",IDF_REAL3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 40, 40, 14 + CONTROL "0.0000",IDF_REAL4,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 58, 40, 14 + CONTROL "0.0000",IDF_REAL5,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 78, 40, 14 + CONTROL "0.0000",IDF_REAL6,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 241, 96, 40, 14 + CONTROL "INT COEFFICIENT 5",IDF_STRING10,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 20, 120, 70, 14 + CONTROL "0",IDF_INTEGER9,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 95, 120, 40, 14 + CONTROL "RL COEFFICIENT 5",IDF_STRING11,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 160, 119, 70, 14 + CONTROL "0.0000",IDF_REAL7,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 241, 117, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 76, 175, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 188, 174, 40, 14 + CONTROL "INT COEFFICIENT 6",IDF_STRING12,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 20, 144, 70, 14 + CONTROL "0",IDF_INTEGER10,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 94, 144, 40, 14 + CONTROL " RL COEFFICIENT 6",IDF_STRING13,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 160, 143, 70, 14 + CONTROL "0.0000",IDF_REAL8,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 240, 141, 40, 14 +END + +IDD_TRANSFORM RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_ELTERR2 DIALOG 0, 0, 220, 105 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Element Data Error" +BEGIN + CONTROL "ERROR IN ELEMENT CONNECTIONS NODE UNDEFINED",IDF_LABEL1,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 20, 12, 181, 8 + CONTROL "Element Number",IDF_LABEL3,"STATIC",WS_CHILD | WS_VISIBLE | SS_LEFT, 56, 35, 58, 8 + CONTROL "0",IDF_INTEGER1,"INTEGEREDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 123, 33, 38, 11 + CONTROL "YES",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 78, 40, 14 + CONTROL "REMOVE ELEMENT?",IDF_LABEL2,"STATIC",WS_CHILD | WS_VISIBLE | WS_GROUP | SS_LEFT, 75, 56, 70, 8 + CONTROL "NO",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 120, 78, 40, 14 +END + +IDD_ELTERR2 RCDATA +BEGIN +"[Ranges] \n" +"[Colours] \n" +" 1001 256 256 256 255 128 000 \n" +" 1002 256 256 256 255 128 000 \n" +,0 +END + +IDD_GENBLK DIALOG 0, 0, 260, 188 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT GENBLK VALUES" +BEGIN + CONTROL "1",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 180, 22, 40, 12 + CONTROL "10.000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 180, 43, 40, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 110, 156, 40, 14 + CONTROL "Number of Elements in Cross-Section",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 22, 120, 12 + CONTROL "Element Length along Channel",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 40, 43, 100, 12 + CONTROL "Right Bank Map Line Number",IDF_STRING3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 40, 98, 100, 12 + CONTROL "Left Bank Map Line Number",IDF_STRING4,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 40, 65, 102, 12 + CONTROL "1",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 180, 67, 40, 12 + CONTROL "2",IDF_INTEGER3,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 180, 100, 40, 12 + CONTROL "Reverse Order",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 158, 83, 60, 10 + CONTROL "Reverse Order",IDF_CHECK2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 158, 112, 60, 10 + CONTROL "Connection Option",IDF_STRING5,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 41, 129, 100, 12 + CONTROL "1",IDF_INTEGER5,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 179, 130, 40, 12 +END + +IDD_GENBLK RCDATA +BEGIN +"[Checks] \n" +" 1036 0 \n" +" 1037 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_SETWRS DIALOG 0, 0, 236, 176 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SETUP LEVEE/WEIR DATA" +BEGIN + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 160, 96, 40, 14 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 160, 122, 40, 14 + CONTROL "Element Type for Transformation",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 96, 102, 14 + CONTROL " Incr. on Weir Height for Transition",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 122, 118, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 60, 150, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 140, 150, 40, 14 + CONTROL "Option 1 Add increment to form levee height",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 24, 160, 16,WS_EX_STATICEDGE + CONTROL "Option 2 Use Bed Levels for Height,- Reset Bed",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 49, 160, 16,WS_EX_STATICEDGE + CONTROL "Increment to Form Weir Height",IDF_STRING3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 75, 96, 14 + CONTROL "0.0000",IDF_REAL2,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 160, 75, 40, 14 +END + +IDD_SETWRS RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +"[Ranges] \n" +"[Colours] \n" +" 1047 256 256 256 255 255 255 \n" +" 1048 256 256 256 255 255 255 \n" +"[Formats] \n" +,0 +END + +IDD_FORMLINE DIALOG 0, 0, 201, 267 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "FORM LINE OPTIONS" +BEGIN + CONTROL "Form Simple Line",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 20, 120, 14 + CONTROL "Form Complex Line",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 36, 120, 14 + CONTROL "Nodal Spacing",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 57, 54, 14 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 57, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 40, 223, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 120, 223, 40, 14 + CONTROL " Input Controls From File",IDF_CHECK3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 40, 196, 120, 14 + CONTROL "Element Type Number",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 123, 72, 14 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 122, 123, 40, 14 + CONTROL "Form Only Nodes",IDF_RADIO3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 75, 120, 14 + CONTROL "Add One-D Elements",IDF_RADIO4,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 89, 120, 14 + CONTROL "Add Two-D Elements",IDF_RADIO5,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 40, 103, 120, 14 + CONTROL "Number of Elements in Section",IDF_STRING3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_MULTILINE, 44, 170, 72, 19 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 122, 172, 40, 14 + CONTROL "Starting Structure Number",IDF_STRING4,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 39, 145, 79, 14 + CONTROL "0",IDF_INTEGER3,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 121, 145, 40, 14 +END + +IDD_FORMLINE RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +" 1038 0 \n" +" 1049 0 \n" +" 1050 0 \n" +" 1051 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_MATTYP DIALOG 0, 0, 160, 80 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Input an Element Type" +BEGIN + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 108, 16, 40, 14 + CONTROL "Element Type Number",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 24, 16, 74, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 20, 48, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 100, 49, 40, 14 +END + +IDD_MATTYP RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_LEVSETTYP DIALOG 0, 0, 181, 92 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Set Element by Level" +BEGIN + CONTROL "Bed Elevation",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 20, 16, 70, 12 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 16, 40, 14 + CONTROL "Element Type",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 20, 38, 70, 12 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 120, 37, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 20, 64, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 120, 64, 40, 14 +END + +IDD_LEVSETTYP RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_CHSTYP DIALOG 0, 0, 181, 224 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SELECT DATA SET" +BEGIN + CONTROL "",IDF_STRING25,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 36, 80, 12 + CONTROL "",IDF_STRING26,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 50, 80, 12 + CONTROL "",IDF_STRING27,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 64, 80, 12 + CONTROL "",IDF_STRING28,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 78, 80, 12 + CONTROL "",IDF_STRING29,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 92, 80, 12 + CONTROL "",IDF_STRING30,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 106, 80, 12 + CONTROL "",IDF_STRING31,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 120, 80, 12 + CONTROL "",IDF_STRING32,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 134, 80, 12 + CONTROL "",IDF_STRING33,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 148, 80, 12 + CONTROL "",IDF_STRING34,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 162, 80, 12 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 71, 196, 40, 14 + CONTROL "",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 36, 20, 12 + CONTROL "",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 50, 20, 12 + CONTROL "",IDF_RADIO3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 64, 20, 12 + CONTROL "",IDF_RADIO4,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 78, 20, 12 + CONTROL "",IDF_RADIO5,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 92, 20, 12 + CONTROL "",IDF_RADIO6,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 106, 20, 12 + CONTROL "",IDF_RADIO7,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 120, 20, 12 + CONTROL "",IDF_RADIO8,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 134, 20, 12 + CONTROL "",IDF_RADIO9,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 148, 20, 12 + CONTROL "",IDF_RADIO10,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 120, 162, 20, 12 +END + +IDD_CHSTYP RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +" 1049 0 \n" +" 1050 0 \n" +" 1051 0 \n" +" 1052 0 \n" +" 1053 0 \n" +" 1054 0 \n" +" 1055 0 \n" +" 1056 0 \n" +"[Colours] \n" +" 1106 256 256 256 255 255 128 \n" +" 1107 256 256 256 255 255 128 \n" +" 1108 256 256 256 255 255 128 \n" +" 1109 256 256 256 255 255 128 \n" +" 1110 256 256 256 255 255 128 \n" +" 1111 256 256 256 255 255 128 \n" +" 1112 256 256 256 255 255 128 \n" +" 1113 256 256 256 255 255 128 \n" +" 1114 256 256 256 255 255 128 \n" +" 1115 256 256 256 255 255 128 \n" +,0 +END + +IDD_FBED DIALOG 0, 0, 219, 137 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "FAILED TO INTERPOLATE ALL" +BEGIN + CONTROL "INTERPOLATION FAILURE DETECTED",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 46, 20, 126, 14 + CONTROL "Nodes Failed",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 110, 47, 52, 14 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 51, 46, 40, 14 + CONTROL "Use Adjacent Node Value?",IDF_STRING3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 67, 72, 84, 14 + CONTROL "YES",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 53, 100, 40, 14 + CONTROL "NO",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 131, 100, 40, 14 +END + +IDD_FBED RCDATA +BEGIN +"[Ranges] \n" +,0 +END + +IDD_SETYRDT DIALOG 0, 0, 219, 157 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "SET YEAR AND DATE" +BEGIN + CONTROL "SET YEAR AND DATE",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 46, 20, 126, 14 + CONTROL "Year",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 48, 39, 52, 14 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 132, 37, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 90, 124, 40, 14 + CONTROL "Month",IDF_STRING3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 48, 57, 52, 14 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 132, 57, 40, 14 + CONTROL "Day",IDF_STRING4,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 48, 75, 52, 14 + CONTROL "0",IDF_INTEGER3,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 132, 75, 40, 14 + CONTROL "Hour",IDF_STRING5,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 48, 93, 52, 14 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 132, 93, 40, 14 +END + +IDD_SETYRDT RCDATA +BEGIN +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_GETINTR DIALOG 0, 0, 200, 111 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "GET NUMBER OF ELEMENTS TO REVERSE" +BEGIN + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 139, 20, 40, 14 + CONTROL "Number of pairs to reverse",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 19, 20, 94, 14 + CONTROL "Do Not Reverse Equal Elevations",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 20, 48, 155, 14,WS_EX_STATICEDGE + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 40, 80, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 120, 80, 40, 14 +END + +IDD_GETINTR RCDATA +BEGIN +"[Checks] \n" +" 1036 0 \n" +"[Ranges] \n" +,0 +END + +IDD_CHOOSEMODEL DIALOG 0, 0, 179, 137 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "CHOOSE MODEL" +BEGIN + CONTROL "RMA-2",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 45, 25, 90, 18,WS_EX_STATICEDGE + CONTROL "RMA-10",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 45, 50, 90, 14,WS_EX_STATICEDGE + CONTROL "RMA-11",IDF_RADIO3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 45, 75, 90, 14,WS_EX_STATICEDGE + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 69, 100, 40, 14 +END + +IDD_CHOOSEMODEL RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +" 1049 0 \n" +,0 +END + +IDD_SETUPELDISP DIALOG 0, 0, 249, 233 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Setup Element Load Display" +BEGIN + CONTROL " Display Maximum Flow",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 69, 14, 110, 14 + CONTROL " Display Cumulative Flow",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_LEFTTEXT | BS_TEXT, 69, 40, 110, 14 + CONTROL " Use Limited Time Period",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 69, 67, 110, 14 + CONTROL "Start Time",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 104, 88, 40, 14 + CONTROL "YEAR JUL DAY HOUR",IDF_STRING2,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT, 54, 110, 140, 14 + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 54, 127, 40, 14 + CONTROL "0",IDF_INTEGER2,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 127, 40, 14 + CONTROL "0.0000",IDF_REAL1,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 145, 127, 40, 14 + CONTROL "End Time",IDF_STRING3,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 104, 149, 40, 14 + CONTROL "0",IDF_INTEGER3,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 54, 171, 40, 14 + CONTROL "0",IDF_INTEGER5,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 100, 171, 40, 14 + CONTROL "0.0000",IDF_REAL3,"REALEDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 145, 171, 40, 14 + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 54, 202, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 143, 201, 40, 14 +END + +IDD_SETUPELDISP RCDATA +BEGIN +"[Checks] \n" +" 1047 0 \n" +" 1048 0 \n" +" 1036 0 \n" +"[Ranges] \n" +"[Formats] \n" +,0 +END + +IDD_FTRIAN DIALOG 0, 0, 200, 142 +STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME +FONT 8, "MS Sans Serif" +CAPTION "Options for TRIANG" +BEGIN + CONTROL "Nominal Element Length",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 26, 52, 86, 14 + CONTROL "Add Nodes to Improve Mesh Quality",IDF_CHECK1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 26, 28, 148, 14,WS_EX_STATICEDGE + CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 28, 108, 40, 14 + CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 132, 108, 40, 14 + CONTROL "Force Conforming Boundary Nodes",IDF_CHECK2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTOCHECKBOX | BS_LEFTTEXT | BS_TEXT, 26, 80, 148, 14,WS_EX_STATICEDGE + CONTROL "0",IDF_INTEGER1,"INTEGERSPIN",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT | ES_RIGHT | ES_MULTILINE, 130, 52, 40, 14 +END + +IDD_FTRIAN RCDATA +BEGIN +"[Checks] \n" +" 1036 0 \n" +" 1037 0 \n" +"[Ranges] \n" +,0 +END + +/////////////////////////////////////////////////// +// +// Menus +// +IDR_MENU1 MENU +BEGIN + POPUP "&File" + BEGIN + MENUITEM "&New", ID_ITEM11 + MENUITEM "&Open\aCtrl+O", ID_ITEM12 + MENUITEM "Open Additional Mesh Files", ID_LOADRM1 + MENUITEM "Open Background file", ID_BKF + MENUITEM "Open &Layer Data File", ID_LAYFL + MENUITEM "Open New Map file", ID_NMAP + MENUITEM "Open Additional Map File (Combine)", ID_ADDMAP + MENUITEM "Open Cross-Section file", ID_crsf + MENUITEM "Open &Group File", ID_OPENGP + MENUITEM "Open Outline File", ID_OUTLINFL + MENUITEM "Reset Limits", ID_RESETLIM + MENUITEM "Save a&scii\aCtrl+S", ID_ITEM13 + MENUITEM "&Save binary\aCtrl+B", ID_ITEM14 + MENUITEM "Save as &bin map", ID_ITEM18 + MENUITEM "Save &as ascii", ID_ITEM15 + MENUITEM "Save as &binary", ID_ITEM16 + MENUITEM "Save as binary with header", ID_SBIN + MENUITEM "Save Cross-Section Data", ID_SAVCRS + MENUITEM "Save Layer Data File", ID_OUTLAY + MENUITEM "Save ASCII Group File", ID_SAVGP + MENUITEM "Copy to File", ID_ICOPY + MENUITEM "Copy to Clipboard", ID_Clip + MENUITEM "Copy to Shapefile", ID_SAVSHP + MENUITEM "&Print", ID_ITEM24 + MENUITEM "&Demo", ID_ITEM19 + MENUITEM "E&xit", ID_ITEM17 + END + POPUP "Edit" + BEGIN + MENUITEM "Node Data", ID_Nodedata + MENUITEM "Element Data", ID_Eltdata + MENUITEM "Select Element", ID_GETELM + MENUITEM "Layer data", ID_EDLAY + END + MENUITEM "&Node", ID_NODE + MENUITEM "&Elts", ID_ELTS + POPUP "&Order" + BEGIN + MENUITEM "Reorder menu\aCtrl+R", ID_ORDR + MENUITEM "Reorder All", ID_ORDR1 + END + POPUP "Mesh" + BEGIN + MENUITEM "Select mesh file", ID_SELRM1 + MENUITEM "Add mesh to existing", ID_addmesh + MENUITEM "Merge mesh to existing", ID_MRGMESH + MENUITEM "Generate triangular block", ID_TRIANG + MENUITEM "Generate quadrilateral block", ID_QUAD + MENUITEM "Form a line of 1-D elements", ID_g1d + MENUITEM "Create mesh from map lines", ID_CREATM + MENUITEM "Create Block From 2 Map Lines", ID_CRGRID + MENUITEM "Generate Contour lines", ID_CGEN + MENUITEM "Split a line", ID_SPLITN + MENUITEM "Form type 999 line", ID_FORM999 + MENUITEM "Form 2D elements from 1-D", ID_FORM2D + MENUITEM "Generate outline file", ID_GOUTLIN + MENUITEM "Extract Outline List", ID_XOUTLIN + MENUITEM "Check mesh", id_mchck + MENUITEM "Move mesh", ID_MOVMESH + MENUITEM "Transform mesh", ID_TRANSFORM + MENUITEM "Delete element type", ID_deletelm + MENUITEM "Join all overlapping nodes", ID_JOINALL + MENUITEM "Setup Levee Elements", ID_SETUPLEV + END + POPUP "Map" + BEGIN + MENUITEM "Make map from nodes", ID_MMAP + MENUITEM "Interpolate to make map", ID_map + MENUITEM "Triangulate Map data", ID_TRIAN + MENUITEM "Switch to show MAP data", ID_SWMAP + MENUITEM "Switch to show RM1 data", ID_SWRM1 + MENUITEM "Create map data", ID_cdata + END + POPUP "Cc&line" + BEGIN + MENUITEM "Get Ccline", ID_CCLN + MENUITEM "Update Ccline", ID_CHKCCLN + END + POPUP "Contour" + BEGIN + MENUITEM "Contour Options", ID_CONTOPT + MENUITEM "Draw Contour", ID_DCONTR + END + POPUP "Csec&t" + BEGIN + MENUITEM "Trapezoids", ID_CSEC + MENUITEM "Assign Cross-section locations", ID_CSLOC + MENUITEM "Compute Weighting", ID_CRSCAL + MENUITEM "View Cross-sections", ID_crsect + END + MENUITEM "&Distance", ID_ITEM20 + POPUP "S&elect" + BEGIN + POPUP "Nodes" + BEGIN + MENUITEM "Use Polygon", ID_ITEM22 + MENUITEM "All Nodes", ID_ALLNODES + MENUITEM "Unused Nodes", ID_UNUSNODES + MENUITEM "By Element Type", ID_SELELTYP + MENUITEM "Nodes for Move", ID_MOVGRP + END + MENUITEM "Elem&ents", ID_ITEM23 + MENUITEM "Select Area for extraction", ID_selarea + POPUP "Select Group" + BEGIN + MENUITEM "Select Processed Differences", ID_SECGRP + END + MENUITEM "Select pairs for reversal", ID_SELPR + MENUITEM "Find and Display Element type", ID_DISPTYP + END + POPUP "&Undo" + BEGIN + MENUITEM "Undo Refine or Gblock", ID_UNDO + MENUITEM "Undo Last Selected Element", ID_UNDOS + END + POPUP "&View" + BEGIN + MENUITEM "Zoom &In\aCtrl+Z", ID_ZIN + POPUP "Zoom &Out" + BEGIN + MENUITEM "&2 times", ID_OUT2 + MENUITEM "&4 times", ID_OUT4 + END + MENUITEM "Drag", ID_DRAG + MENUITEM "Pan &Left", ID_PLEFT + MENUITEM "Pan &Right", ID_PRIGHT + MENUITEM "Pan &Up", ID_PUP + MENUITEM "Pan &Down", ID_PDOWN + MENUITEM "Re&set", ID_RSET + MENUITEM "View in 3-D", ID_3DVIEW + MENUITEM "Set View Angle", ID_VIEWANGLE + MENUITEM "Rotate 3-D view", ID_VROTATE + MENUITEM "Find Node\aCtrl+F", ID_findnode + MENUITEM "Find Element\aCtrl+E", ID_findelem + END + POPUP "&Rdraw" + BEGIN + MENUITEM "Re-draw", ID_DRAWD + MENUITEM "Draw Options", ID_IDRWT + POPUP "&Background" + BEGIN + MENUITEM "Select", ID_BSEL + MENUITEM "Register", ID_REGST + MENUITEM "Reset Registration", ID_RESETRG + END + POPUP "Type/Group Options" + BEGIN + MENUITEM "Type Number", ID_ITYPN + MENUITEM "Type Colour", ID_ITYPC + MENUITEM "Group Number", ID_IGPN + MENUITEM "Group Colour", ID_IGPC + END + MENUITEM "Map Options", ID_MAPOPD + END + POPUP "&Help" + BEGIN + MENUITEM "Open &help file", ID_Help1 + MENUITEM "About RMAGEN", ID_Help2 + END + POPUP "Experimental" + BEGIN + MENUITEM "Select Elements to attach", ID_attach + MENUITEM "Fill a Gap Between Elements", ID_FILLAGAP + MENUITEM "Set Type by Level", ID_SETTYPLEV + MENUITEM "Form a complex line of elements", ID_Complex + MENUITEM "Interpolate Map File for Stress File", ID_GETSTRESSFIL + MENUITEM "Smooth Mesh to Map Contours", ID_SMOOTHMAP + MENUITEM "Smooth Mesh Using Reversal", ID_RVSDIAG + MENUITEM "Remove Elements Outside Outline", ID_TESTOUT + MENUITEM "Input Element Load file", ID_LOADELTLD + MENUITEM "Assign Element Loads to Elements", ID_ASSIGNELTLD + MENUITEM "Show Element Loads", ID_SHOWELTLD + MENUITEM "Re-Show Element Loads", ID_RESHOWELTLD + MENUITEM "Save Element Load File", ID_SAVELTLD + MENUITEM "Form Elements from Map File", ID_FILLTR + END + MENUITEM "E&xit", ID_EXIT +END + +IDR_MENU1 RCDATA +BEGIN +ID_FILE,1,0, +ID_ITEM56,2,0, +ID_ORDRT,5,0, +ID_network,6,0, +ID_mapm,7,0, +ID_CCLNA,8,0, +ID_CONTR,9,0, +ID_CSEC1,10,0, +ID_ITEM26,12,0, +ID_ITEM73,12,1,0, +ID_ITEM103,12,4,0, +ID_UNDOM,13,0, +ID_ZOOM,14,0, +ID_ZOUT,14,2,0, +ID_DRAW,15,0, +ID_BACGD,15,3,0, +ID_TYPD,15,4,0, +ID_HELP,16,0, +ID_ITEM126,17,0, +0 +END + +/////////////////////////////////////////////////// +// +// Accelerators +// +IDR_MENU1 ACCELERATORS +BEGIN + 79 , ID_ITEM12 ,NOINVERT,VIRTKEY,CONTROL + 83 , ID_ITEM13 ,NOINVERT,VIRTKEY,CONTROL + 66 , ID_ITEM14 ,NOINVERT,VIRTKEY,CONTROL + 82 , ID_ORDR ,NOINVERT,VIRTKEY,CONTROL + 90 , ID_ZIN ,NOINVERT,VIRTKEY,CONTROL + 70 , ID_findnode ,NOINVERT,VIRTKEY,CONTROL + 69 , ID_findelem ,NOINVERT,VIRTKEY,CONTROL +END + +/////////////////////////////////////////////////// +// +// Bitmaps +// +ID_TOOLBAR1 BITMAP DISCARDABLE "zoom.BMP" +id_chck BITMAP DISCARDABLE "chck.bmp" +id_chk BITMAP DISCARDABLE "chck.bmp" +idchk BITMAP DISCARDABLE "chck.bmp" + +/////////////////////////////////////////////////// +// +// Icons +// +icon1 ICON DISCARDABLE "winter.ico" +IDC_BUTTON2 ICON DISCARDABLE "button.ico" +IDOK ICON DISCARDABLE "ok.ico" +IDCANCEL ICON DISCARDABLE "cancel.ico" + +/////////////////////////////////////////////////// +// +// Strings +// +STRINGTABLE DISCARDABLE +BEGIN + ID_STRING1 "Map file -- *.map |*.map|Bin Map file -- *.mpb|*.mpb|Bin Map file (no head) -- *.mbb|*.mbb|RM1 file (as map) -- *.rm1|*.rm1|ESRI ASC file -- *.asc|*.asc|SURFER GRD file -- *.grd|*.grd|SHAPE FILE -- *.shp|*.shp|" + ID_STRING2 "Network files |*.rm1,*.geo,*.gfg,*.rst,*.bin|Rm1 file -- *.rm1|*.rm1|Geo file -- *.geo|*.geo|Gfg file -- *.gfg|*.gfg|Rst file -- *.rst|*.rst|Bin file -- *.bin|*.bin|" + ID_STRING3 "Rm1 file -- *.rm1|*.rm1|" + ID_STRING4 "Geo file -- * .geo|*.geo|" + ID_STRING5 "Bin Map file -- *.mpb|*.mpb|" + ID_STRING6 "jpeg file -- *.jpg|*.jpg|png file -- *.png|*.png|pcx file -- *.pcx|*.pcx|bmp file -- *.bmp|*.bmp|cgm file -- *.cgm|*.cgm|pic file -- *.pic|*.pic|emf file -- *.emf|*.emf|wmf file -- *.wmf|*.wmf|dxf file -- *.dxf|*.dxf|" + ID_STRING7 "Map file -- *.map |*.map|" + ID_STRING8 "Cln file -- *.cln |*.cln|" + ID_STRING9 "Layer file -- *.lay |*.lay|" + ID_STRING10 "jpeg file -- *.jpg|*.jpg|wmf file -- *.wmf|*.wmf|bmp file -- *.bmp|*.bmp|pcx file -- *.pcx|*.pcx|png file -- *.png|*.png|cgm file -- *.cgm|*.cgm|pic file -- *.pic|*.pic|" + ID_STRING11 "org file -- *.org|*.org|" + ID_DELM "Delete all Mid-side nodes" + ID_FILL "Fill Mid-side nodes" + ID_RSET "Reset to basic view" + ID_DRAG "Pan Screen" + ID_ZIN "Zoom In" + ID_OUT2 "Zoom Out" + ID_JOIN "Merge Two Nodes" + ID_IDRWT "Show Network Display Options" + id_chck "Check Network" + ID_ROTATE "Rotate 3-D View" +END + +/////////////////////////////////////////////////// +// +// Toolbar Data +// +ID_TOOLBAR1 RCDATA +BEGIN + 16, 16, + ID_ZIN, + ID_OUT2, + ID_DRAG, + ID_RSET, + ID_DELM, + ID_FILL, + ID_JOIN, + ID_IDRWT, + id_chck, + ID_ROTATE, +0,0 +END + + +/////////////////////////////////////////////////// +// +// Winteracter Visual Tool Settings +// +//*WI* BASEMENU 30001 +//*WI* BASEITEM 40001 +//*WI* BASEDIALOG 101 +//*WI* BASEFIELD 1001 +//*WI* BASETOOLBAR 30101 +//*WI* BASEBUTTON 40101 +//*WI* BASEIMAGE 2001 +//*WI* F90MODULE 0 +//*WI* FORTSAVE 1 +//*WI* FILENAME D.INC +//*WI* FMODNAME +//*WI* LASTTYPE 2 +//*WI* LASTRES 67 diff --git a/src/RVSDIAG.F90 b/src/RVSDIAG.F90 new file mode 100644 index 0000000..f0d4587 --- /dev/null +++ b/src/RVSDIAG.F90 @@ -0,0 +1,112 @@ + SUBROUTINE RVSDIAG +! routine to test for and reverse diagonals + USE BLK1MOD + USE BLK2MOD + REAL IGrDistanceLine + +! fill midsides + CALL FILM(1) +! get elements connected to nodes table + MIDSIDE=0 + IERR=1 + CALL NDNECON(IERR) + +! gets nodes nodes opposite +! loop on midsides + KCOUNT=0 + DO N=1,NP + IF(NECON(N,2) .EQ. 0) CYCLE + NEL1=NECON(N,1) + NEL2=NECON(N,2) + WRITE(160,*) 'ELTS',NEL1,NEL2 +! test for two triangles + IF(NCORN(NEL1) .EQ. 8 .OR. NCORN(NEL1) .LT. 6) CYCLE + IF(NCORN(NEL2) .EQ. 8 .OR. NCORN(NEL2) .LT. 6) CYCLE +! get the adjacent nodes N1 and N2 + DO K=2,6,2 + IF(N .EQ. NOP(NEL1,K)) THEN +! get the adjacent nodes N1 and N2 + N1=NOP(NEL1,K-1) + N2=K+1 + IF(N2 .GT. 6) N2=1 + N2=NOP(NEL1,N2) +! get first of two nodes facing each other N3 + N3=K+3 + IF(N3 .GT. 6) N3=N3-6 + N3=NOP(NEL1,N3) + ENDIF + ENDDO +! get second of two nodes facing each other N4 + DO K=2,6,2 + IF(N .EQ. NOP(NEL2,K)) THEN + N4=K+3 + IF(N4 .GT. 6) N4=N4-6 + N4=NOP(NEL2,N4) + ENDIF + ENDDO + IF(WD(N1) .EQ. WD(N3) .AND. WD(N2) .EQ. WD(N3)) GO TO 500 + IF(WD(N1) .EQ. WD(N4) .AND. WD(N2) .EQ. WD(N4)) GO TO 500 + IF(WD(N1) .EQ. WD(N3) .AND. WD(N1) .EQ. WD(N4)) GO TO 500 + IF(WD(N2) .EQ. WD(N3) .AND. WD(N2) .EQ. WD(N4)) GO TO 500 + X1=XUSR(N1) + X2=XUSR(N2) + X3=XUSR(N3) + X4=XUSR(N4) + Y1=YUSR(N1) + Y2=YUSR(N2) + Y3=YUSR(N3) + Y4=YUSR(N4) + CALL IGRINTERSECTLINE(X1,Y1,X2,Y2,X3,Y3,X4,Y4,XINTER,YINTER,ISTAT) + IF(ISTAT .NE. 5) GO TO 500 + METHOD=1 + D1=IGrDistanceLine(X1,Y1,X2,Y2,XINTER,YINTER,METHOD) +! D2=IGrDistanceLine(X1,Y1,X2,Y2,X4,Y4,METHOD) + D1=SQRT((X1-XINTER)**2+(Y1-YINTER)**2) + D2=SQRT((X2-XINTER)**2+(Y2-YINTER)**2) + D3=SQRT((X1-X2)**2+(Y1-Y2)**2) + IF(D1 .LT. 0.05*D3) GO TO 500 + IF(D2 .LT. 0.05*D3) GO TO 500 + IF(WD(N3) .EQ. WD(N1)) THEN + IF(ABS(WD(N4)-WD(N3)) .LT. ABS(WD(N2)-WD(N3))) THEN + KCOUNT=KCOUNT+1 + WRITE(160,*) 'QV1',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 + CALL DUMPBIN(KCOUNT,1) + CALL REVERS(NEL1,NEL2) + GO TO 500 + ELSE + GO TO 500 + ENDIF + ELSEIF(WD(N3) .EQ. WD(N2)) THEN + IF(ABS(WD(N4)-WD(N3)) .LT. ABS(WD(N3)-WD(N2))) THEN + KCOUNT=KCOUNT+1 + WRITE(160,*) 'QV2',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 + CALL DUMPBIN(KCOUNT,1) + CALL REVERS(NEL1,NEL2) + GO TO 500 + ELSE + GO TO 500 + ENDIF + ENDIF +! test if they are equal height + IF(WD(N3) .EQ. WD(N4) .or. ABS(WD(N3) -WD(N4)) .LT. ABS(WD(N1)-WD(N2))) THEN +! if so reverse connections + KCOUNT=KCOUNT+1 + WRITE(160,*) 'RV1',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 + CALL REVERS(NEL1,NEL2) + CALL DUMPBIN(KCOUNT,1) + + ELSE +! test if N4 closer or equal to N3 than N1 or N2 + IF(ABS(WD(N4) - WD(N3)) .LT. ABS(WD(N1) - WD(N3)) .OR. ABS(WD(N4) - WD(N3)) .LT. ABS(WD(N2) - WD(N3))) THEN +! if so reverse connections + KCOUNT=KCOUNT+1 + WRITE(160,*) 'RV2',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 + CALL REVERS(NEL1,NEL2) + CALL DUMPBIN(KCOUNT,1) + ENDIF + ENDIF +500 CONTINUE +! end loop + ENDDO + RETURN + END \ No newline at end of file diff --git a/src/SAVELTLD.F90 b/src/SAVELTLD.F90 new file mode 100644 index 0000000..60e8176 --- /dev/null +++ b/src/SAVELTLD.F90 @@ -0,0 +1,110 @@ + SUBROUTINE SAVEEQ + USE WINTERACTER + + USE BLKELTLD + + include 'D.inc' + character*255 fnamein,filter + CHARACTER *24 DATAOUT + + filter='Element Input files|*.elt|' + CALL WSelectFile(filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAMEIN,'Element Load File Name') + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + OPEN(202,FILE=FNAMEIN,STATUS='UNKNOWN') + ELSE + RETURN + ENDIF + IF(IRMATYP .EQ. 11) WRITE(202,6000) +6000 FORMAT('TI') + IF(IRMATYP .EQ. 2 .OR. IRMATYP .EQ. 10) WRITE(202,6001) +6001 FORMAT('TE') + DO I=1,NQHYD + HRYEAR=365*24. + IYR=IYDATE(I) + IF(MOD(IYDATE(I),4) .EQ. 0) HRYEAR=HRYEAR+24. + IF(IRMATYP .EQ. 2 .OR. IRMATYP .EQ. 10) THEN + WRITE(202,6002) NCLINE(I),NEST(I),IYDATE(I),XYCEL(I,1),XYCEL(I,2) +!6002 FORMAT('QEI',5X,3I8) +6002 FORMAT('QEI',5X,3I8,2F16.2) + NST=NHYE(I) + DO N=1,NST + IF(TAE(N,I) .GE. HRYEAR) THEN + TAOUT=TAE(N,I)-HRYEAR + IYR=IYR+1 + ELSE + IF(N .GT. 1) THEN + IF(TAE(N,I) .LT.TAE(N-1,I)) IYR=IYR+1 + ENDIF + TAOUT=TAE(N,I) + ENDIF + CALL ENCODDAT(DATAOUT,TAE(N,I),IYR) + IF(IRMATYP .EQ. 2) THEN + WRITE(202,6003) DATAOUT,HAE(N,I) +6003 FORMAT(A24,F8.3) + ELSE + WRITE(202,6004) DATAOUT,ILAYRE(N,I),HAE(N,I),(HDE(N,I,K),K=1,3) +6004 FORMAT(A24,I8,F8.3,3F8.2) + ENDIF + ENDDO + + ELSEIF(IRMATYP .EQ. 11) THEN + WRITE(202,6002) NCLINE(I),NEST(I),IYDATE(I),XYCEL(I,1),XYCEL(I,2) + NST=NHYE(I) + DO N=1,NST + IF(TAE(N,I) .GE. HRYEAR) THEN + TAOUT=TAE(N,I)-HRYEAR + IYR=IYR+1 + ELSE + IF(N .GT. 1 .AND. TAE(N,I) .LT.TAE(N-1,I)) IYR=IYR+1 + TAOUT=TAE(N,I) + ENDIF + CALL ENCODDAT(DATAOUT,TAE(N,I),IYR) + WRITE(202,6006) DATAOUT,HAE(N,I),(HDE(N,I,K),K=1,3) +6006 FORMAT(A24,4F8.3) + ENDDO + ENDIF + ENDDO + WRITE(202,6010) +6010 FORMAT('ENDDATA') + CLOSE (202) + RETURN + END + + SUBROUTINE ENCODDAT(DATAOUT,DAYJUL,IYR) + CHARACTER*24 DATAOUT + REAL DAYJUL,TIME + INTEGER IMTS(12,2),IDAY,IMO,IYR,RMIN + DATA IMTS/0,31,59,90,120,151,181,212,243,273,304,334,0,31,60,91,121,152,182,213,244,274,305,335/ + LP=1 + IF(MOD(IYR,4) .EQ. 0) LP=2 + DO K=1,12 + + IF(DAYJUL/24. .LT. IMTS(K,LP)) THEN + IMO=K-1 + IDAY=DAYJUL/24.-IMTS(IMO,LP)+1 + IDT=DAYJUL/24. + HR=DAYJUL-FLOAT(IDT)*24. + IHR=HR + RMIN=(HR-FLOAT(IHR))*60.+.5 + GO TO 100 + ENDIF + ENDDO + IMO=12 + IDAY=DAYJUL/24.-(334+LP-1)+1 + IDT=DAYJUL/24. + HR=DAYJUL-FLOAT(IDT)*24. + IHR=HR + RMIN=(HR-FLOAT(IHR))*60.+.5 + + 100 IF(IHR .LT. 10) THEN + WRITE(DATAOUT(1:24),6000) IDAY,IMO,IYR,IHR,RMIN +6000 FORMAT('QM',7X,I2.2,'/',I2.2,'/',I4,I2,':',I2.2) + ELSE + WRITE(DATAOUT(1:24),6001) IDAY,IMO,IYR,IHR,RMIN +6001 FORMAT('QM',6X,I2.2,'/',I2.2,'/',I4,I3,':',I2.2) + ENDIF + RETURN + END + + \ No newline at end of file diff --git a/src/SAVESHP.F90 b/src/SAVESHP.F90 new file mode 100644 index 0000000..e8b7fd7 --- /dev/null +++ b/src/SAVESHP.F90 @@ -0,0 +1,175 @@ + SUBROUTINE SAVESHP +! +! ROUTINE TO SAVE NETWORK AS A SHAPEFILE +! + + USE WINTERACTER + USE BLK1MOD + + REAL*8 XK(12),YK(12),DEP(12) +! SAVE INFO TO A SCRATCH + VOID = -1.E10 + + Call WMessageBox(3,2,1,'Do you wish to save as a complex polygon'//Char(13)//& + 'shapefile containing all the network data'//'Press YES to accept',& + 'CHOOSE SHAPEFILE TYPE -1- !!') + IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then + IOPTSV=1 + IOPTSVNOD=0 + IOPTSVEL=0 + ELSE + IOPTSV=2 + Call WMessageBox(3,2,1,'Do you wish to save as a polygon'//Char(13)//& + 'shapefile containing network outline'//'Press YES to accept',& + 'CHOOSE SHAPEFILE TYPE -2- !!') + IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then + IOPTSVEL=1 + ELSE + IOPTSVEL=0 + ENDIF + Call WMessageBox(3,2,1,'Do you wish to save as a point'//Char(13)//& + 'shapefile containing bed levels'//'Press YES to accept',& + 'CHOOSE SHAPEFILE TYPE -3- !!') + IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then + IOPTSVNOD=1 + ELSE + IOPTSVNOD=0 + ENDIF + ENDIF + IF(IOPTSVEL .EQ. 1 .OR. IOPTSV .EQ. 1) THEN + OPEN(113,FORM='BINARY',STATUS='SCRATCH') + DO N=1,NE + IF(IMAT(N) .GT. 0) THEN + NC=0 + IF(NCORN(N) .GT. 5) THEN + DO KK=1,NCORN(N)+1 + K=MOD(KK,NCORN(N)) + IF(K .EQ. 0) K=NCORN(N) + NODE=NOP(N,K) + IF(NODE .GT. 0) THEN + NC=NC+1 + XK(NC)=XUSR(NODE) + YK(NC)=YUSR(NODE) + DEP(NC)=WD(NODE) + ENDIF + ENDDO + IMATT=IMAT(N) + WRITE(113) N,IMATT,NC,(XK(K),YK(K),DEP(K),K=1,NC) + !ELSEIF(NCORN(N) .EQ. 5) THEN + ! DO K=1,5 + ! NODE=NOP(N,K) + ! IF(NODE .GT. 0) THEN + ! NC=NC+1 + ! XK(NC)=XUSR(NODE) + ! YK(NC)=YUSR(NODE) + ! DEP(NC)=WD(NODE) + ! ENDIF + ! ENDDO + ! DO K=3,1,-1 + ! NODE=NOP(N,K) + ! IF(NODE .GT. 0) THEN + ! NC=NC+1 + ! XK(NC)=XUSR(NODE) + ! YK(NC)=YUSR(NODE) + ! DEP(NC)=WD(NODE) + ! ENDIF + ! ENDDO + ! IMATT=IMAT(N) + ! WRITE(113) N,IMATT,NC,(XK(K),YK(K),DEP(K),K=1,NC) + ELSEIF(NCORN(N) .LT. 6 .AND. (IMAT(N) .LT. 900 .OR. IMAT(N) .GT. 903)) THEN + NODE1=NOP(N,1) + DO K=1,3 + NODE=NOP(N,K) + IF(NODE .GT. 0) THEN + NC=NC+1 + XK(NC)=XUSR(NODE) + YK(NC)=YUSR(NODE) + DEP(NC)=WD(NODE) + ENDIF + ENDDO + IF(WIDTH(NODE) .GT. 0.) THEN + eldir=atan2(YUSR(NOP(N,3))-YUSR(NOP(N,1)),XUSR(NOP(N,3))-XUSR(NOP(N,1))) + elnorm=eldir-1.5708 + NC=NC+1 + xK(NC)=XK(NC-1)+cos(elnorm)*WIDTH(NODE)/2. + yK(NC)=YK(NC-1)+sin(elnorm)*WIDTH(NODE)/2. + NMID=0 + IF(NOP(N,2) .GT. 0) THEN + NMID=1 + NC=NC+1 + xK(NC)=XK(2)+cos(elnorm)*(WIDTH(NODE)+WIDTH(NODE1))/4. + yK(NC)=YK(2)+sin(elnorm)*(WIDTH(NODE)+WIDTH(NODE1))/4. + ENDIF + NC=NC+1 + xK(NC)=XK(1)+cos(elnorm)*WIDTH(NODE1)/2. + yK(NC)=YK(1)+sin(elnorm)*WIDTH(NODE1)/2. + NC=NC+1 + xK(NC)=XK(1)-cos(elnorm)*WIDTH(NODE1)/2. + yK(NC)=YK(1)-sin(elnorm)*WIDTH(NODE1)/2. + IF(NMID .GT. 0) THEN + NC=NC+1 + xK(NC)=XK(2)-cos(elnorm)*(WIDTH(NODE)+WIDTH(NODE1))/4. + yK(NC)=YK(2)-sin(elnorm)*(WIDTH(NODE)+WIDTH(NODE1))/4. + NC=NC+1 + xK(NC)=XK(3)-cos(elnorm)*WIDTH(NODE)/2. + yK(NC)=YK(3)-sin(elnorm)*WIDTH(NODE)/2. + NC=NC+1 + XK(NC)=XK(3) + YK(NC)=YK(3) + ELSE + NC=NC+1 + xK(NC)=XK(2)-cos(elnorm)*WIDTH(NODE)/2. + yK(NC)=YK(2)-sin(elnorm)*WIDTH(NODE)/2. + NC=NC+1 + XK(NC)=XK(2) + YK(NC)=YK(2) + ENDIF + ELSE + DO K=2,1,-1 + NODE=NOP(N,K) + IF(NODE .GT. 0) THEN + NC=NC+1 + XK(NC)=XUSR(NODE) + YK(NC)=YUSR(NODE) + DEP(NC)=WD(NODE) + ENDIF + ENDDO + ENDIF + IMATT=IMAT(N) + WRITE(113) N,IMATT,NC,(XK(K),YK(K),DEP(K),K=1,NC) + ENDIF + ENDIF + ENDDO + REWIND 113 + +! CALL FORMSHP TO WRITE OUT SHAPEFILE + IF(IOPTSV .EQ. 1) THEN + ISTYP=25 +! ISTYP=25 is saving element list + IVECACT=4 + ELSE +! ISTYP=5 is saving element list with polygons? + ISTYP=5 + IVECACT=5 + ENDIF + CALL FORMSHP2(istyp,ivecact) + CLOSE(113) + ENDIF + + IF(IOPTSVNOD .EQ. 1) THEN + OPEN(113,FORM='BINARY',STATUS='SCRATCH') + DO NODE=1,NP + IF(XUSR(NODE) .GT. VOID) THEN + WRITE(113) NODE,XUSR(NODE),YUSR(NODE),WD(NODE) + ENDIF + ENDDO + REWIND 113 +! ISTYP=1 is saving of nodal values + ISTYP=1 + IVECACT=6 + CALL FORMSHP2(istyp,ivecact) + CLOSE (113) + ENDIF + + RETURN + END \ No newline at end of file diff --git a/src/SELT.F90 b/src/SELT.F90 new file mode 100644 index 0000000..19824a7 --- /dev/null +++ b/src/SELT.F90 @@ -0,0 +1,958 @@ +! last update feb 10 2002 add lock/unlock +! Last change: IPK 2 Mar 1999 12:05 pm + SUBROUTINE SELNODE(ISW) + + USE WINTERACTER + USE BLKMAP + USE BLK1MOD + USE BLK2MOD + + include 'd.inc' + + dimension xot(100),yot(100) +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' +! + dimension nodlist(maxp),RLAY(9) +! DIMENSION ICN(MAXP) + character*1 iflag + CHARACTER*1 ANS,ANSW(10) + CHARACTER*63 STRELS + DATA ANSW/'m','a','f','s','k','u','t','w','h','q'/ + DATA STRELS/' You have tried set to set elevation with no mapfile"'/ + + +! +! save nhtp etc + + nhtps=nhtp + nbrs=nbrr + nmessv=nmess + if(isw .eq. 0 .or. isw .eq. 4) then + + CALL GETPOLY(XOT,YOT,NPTS) + +! look for points inside polygon + + ndlist=0 + do j=1,np + if(inskp(j) .eq. 0) then + inswt=0 + call cpoly(xot,yot,npts,cord(j,1),cord(j,2),inswt) + if(inswt .eq. 1) then + call rred + fpn=j + x = cord(j,1) + y = cord(j,2) - .11 + call numbr(x,y,ht,fpn,0.0,-1) + ndlist=ndlist+1 + nodlist(ndlist)=j + endif + endif + enddo + call rblue + elseif(isw .eq. 1) then +! +! Add all nodes to list +! + NDLIST=0 + DO J=1,NP + IF(INEW(J) .EQ. 1) THEN + NDLIST=NDLIST+1 + NODLIST(NDLIST)=J + ENDIF + END DO + + elseif(isw .eq. 2) then + +! Get inactive nodes + + DO I=1,NP + ICN(I) = 0 + ENDDO + DO J = 1, NE + IF( IMAT(J) .NE. 0 ) THEN + DO K = 1, 8 + IF( NOP(J,K) .GT. 0) THEN + ICN(NOP(J,K))=999 + ENDIF + ENDDO + ENDIF + END DO +! +! Add nodes to list +! + NDLIST=0 + DO J=1,NP + IF(ICN(J) .EQ. 0 .AND. INEW(J) .EQ. 1) THEN + NDLIST=NDLIST+1 + NODLIST(NDLIST)=J + ENDIF + END DO + + elseif(isw .eq. 3) then + NS=1 + call wdialogload(IDD_SELELTYP) + ierr=infoerror(1) + + CALL WDialogPutInteger(IDF_INTEGER1,NS) + + CALL WDialogSelect(IDD_SELELTYP) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,ModaL) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(IDF_INTEGER1,NS) + go to 80 + ENDIF + enddo + 80 CONTINUE + DO I=1,NP + ICN(I) = 0 + ENDDO + NDLIST=0 + DO K=1,NE + IF(IMAT(K) .EQ. NS) THEN + DO L=1,8 + NST=NOP(K,L) + IF(NST .GT. 0) THEN + IF(ICN(NST) .EQ. 0) THEN + NDLIST=NDLIST+1 + NODLIST(NDLIST)=NST + ICN(NST)=1 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + + endif +! NEW MOVE OPERATION + + IF(ISW .EQ. 4) THEN + CALL MVGRP(NDLIST,NODLIST) + nhtp=nhtps + nbrr=nbrs + nmess=nmessv + call hedr + RETURN + ENDIF + nbrr=0 + nhtp=14 + call hedr + CALL XYLOC(xscrn1,yscrn1,iflag,ibox) + if(ibox .eq. 1 .or. iflag .eq. 'd') then + do n=1,ndlist + j=nodlist(n) + call deletn(j) + enddo + elseif(ibox .eq. 2 .or. iflag .eq. 'e') then + do n=1,ndlist + j=nodlist(n) + wd(j)=-9999. + enddo + elseif(ibox .eq. 3 .or. iflag .eq. 't') then +! +! Establish size for range +! +! IF(IMP .EQ. 0) THEN +! CALL SYMBL(0.,7.25,0.20,STRELS,0.,63) +! nhtp=nhtps +! nbrr=nbrs +! nmess=nmessv +! call hedr +! RETURN +! endif + + 100 CONTINUE + NHTP = 16 + NMESS = 0 + NBRR = 0 + CALL HEDR +! +! Get answer +! + 110 call xyloc(XPT,YPT,ANS,IBOX) + IF(IRMAIN .EQ. 1) RETURN + IF(ANS .EQ. 'c') THEN + if(ibox .eq. 0) go to 110 + ANS=ANSW(IBOX) + ENDIF + IF(ANS .EQ. 'm') THEN +! +! This option allows changes to bottom elevations +! + CALL ADDPTH2(NODLIST,NDLIST) + GO TO 220 + + ELSEIF (ANS .EQ. 'a') THEN +! +! All nodes +! + ISWT = -1 + ELSEIF(ANS .EQ. 'f') THEN +! +! Fill nodes +! + ISWT = 0 +! ELSEIF(ANS .EQ. 's') THEN +! +! Single node at a time +! +! ISWT = 1 + +!ipk feb02 add lock/unlock and remove cdata + +! ELSEIF(ANS .EQ. 'w') THEN +! +! This option allows changes to nodal widths +! +! CALL ADDWID +! IF(IRMAIN .EQ. 1) RETURN +! GO TO 100 +! +! Call to help screen +! + ELSEIF(ANS .EQ. 'h') THEN + CALL HELPS(4) + IF(IRMAIN .EQ. 1) RETURN + GO TO 100 +! + ELSEIF(ANS .EQ. 'q') THEN +! +! Writeout and return +! + CALL WRTOUT(0) + RETURN + ENDIF + + IF(IMP .EQ. 0) THEN + CALL SYMBL(0.,7.25,0.20,STRELS,0.,63) + go to 100 + endif +! +! Establish size for range +! +!!!!!!!!!!!!!!!!!!!!!!!!! + + IF(ISWTAGN .EQ. 0) THEN + +! IF(IRECD .EQ. 2) THEN +! iswtintp=0 +! iswtagn=0 +! go to 210 +! ENDIF + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to interpolate '//& + CHAR(13)//'from the triangulated map file?' ,& + 'Select Interpolation method?') +! If answer 'Yes' set interpolate switch to 1 +! + IF (WInfoDialog(4) .EQ. 2) then + iswtintp=0 + ELSE + iswtintp=1 + ENDIF + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Ask this question again?'//& + CHAR(13)//' ' ,& + 'Ask again?') +! If answer 'Yes' set again switch to 0 +! + IF (WInfoDialog(4) .EQ. 2) then + iswtagn=1 + ELSE + iswtagn=0 + ENDIF + ENDIF + + 210 CONTINUE + +!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IF(ISWTINTP .EQ. 0) THEN + + call setrng(xnears,nmap) + iswt=0 + do n=1,ndlist + m=nodlist(n) +!ipk feb02 +!ipk jan08 chnage subscript + if(lock(m) .eq. 0) CALL SETELV(XNEARS,NMAP,M,ISWT) + enddo + ELSE + if(nelts .eq. 0) then + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'No triangulated exists'//& + CHAR(13)//'Do you wish to triangulate now?' ,& + 'NO TRIANGULATION AVAILABLE?') +! If answer 'Yes' set triangulate now +! + IF (WInfoDialog(4) .EQ. 2) then + return + ELSE + call triang + ENDIF + + endif + do n=1,ndlist + m=nodlist(n) + if(lock(m) .eq. 0) CALL TRIANINT(NMAP,M,ISWT,ITIME) + enddo + ENDIF + 220 CONTINUE + + elseif(ibox .eq. 4 .or. iflag .eq. 'l') then + +! Define layers + + call openlay + + NHTP=0 + NBRR=0 + NMESS=45 + CALL HEDR + NMESS=4 + xprt=3.2 +! +! call getint(nlay) + + call GETLAYDAT(NLAY,ipos,RLAY) + ILAYTP=IPOS + + do n=1,ndlist + j=nodlist(n) + lay(j)=nlay + DO I=1,NLAY + WTLAY(J,I)=RLAY(I) + ENDDO + enddo + REWIND 102 + DO J=1,NP + IF(LAY(J) .GT. -9998) THEN + if(ILAYTP .eq. 1) then + write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + 6000 format('LD2 ',2i8,9F8.2) + else + write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J)) + 6001 format('LD3 ',2i8,9F8.2) + endif + ENDIF + ENDDO + nlayd=1 +!ipk feb02 add lcok/unlock + elseif(ibox .eq. 5 .or. iflag .eq. 'k') then + do n=1,ndlist + j=nodlist(n) + lock(j)=1 + enddo + elseif(ibox .eq. 6 .or. iflag .eq. 'u') then + do n=1,ndlist + j=nodlist(n) + lock(j)=0 + enddo + elseif(ibox .eq. 7 .or. iflag .eq. 'f') then + do n=1,np + list(n)=0 + enddo + do n=1,ndlist + list(nodlist(n))=1 + enddo + call deln2(np,0) + endif + +! CALL PLOTOT(1) + + nhtp=nhtps + nbrr=nbrs + nmess=nmessv + call hedr + RETURN + END + + SUBROUTINE SELELT(ISW) + + USE BLK1MOD + save fracd + dimension xot(100),yot(100) + +! INCLUDE 'BLK1.COM' +! + dimension nodlist(maxp) + character*1 iflag + + data itime/0/ + + if(itime .eq. 0) then + mat=0 + itime=1 + endif + + IF(ISW .EQ. 2) GO TO 200 + + CALL GETPOLY(XOT,YOT,NPTS) + + +! +! save nhtp etc + + nhtps=nhtp + nbrs=nbrr + nmessv=nmess + +! look for points inside polygon + + ndlist=0 + nefl=0 + do n=1,ne + ieswt=0 + if(ieskp(n) .eq. 0) then + ieswt=1 + do m=1,ncorn(n) + j=nop(n,m) + if(j .gt. 0) then + inswt=0 + call cpoly(xot,yot,npts,cord(j,1),cord(j,2),inswt) + if(inswt .eq. 1) then +! call rred +! fpn=j +! x = cord(j,1) +! y = cord(j,2) - .11 +! call numbr(x,y,ht,fpn,0.0,-1) + ndlist=ndlist+1 + nodlist(ndlist)=j + else + ieswt=0 + endif + endif + enddo + endif + if(ieswt .eq. 1) then + nefl=nefl+1 + neflag(nefl)=n +! call rcyan +! fpn = n +! x = xc(n) +! y = yc(n) + .01 +! call numbr(x,y,0.20,fpn,0.0,-1) + call fillem(n) + endif + enddo + call rblue + + GO TO 300 +200 CONTINUE +! +! save nhtp etc + + nhtps=nhtp + nbrs=nbrr + nmessv=nmess + NEFL=0 + CALL GETFRAC(FRACD) + call plotot(0) + DO N=1,NE + IF(EDIF(N) .GT. (1.-FRACD)*EDIF(0)) THEN + nefl=nefl+1 + neflag(nefl)=n + call fillem(n) + ENDIF + ENDDO +300 CONTINUE + if(isw .eq. 0 .OR. ISW .EQ. 2) then + nbrr=0 + nhtp=15 + call hedr + CALL XYLOC(xscrn1,yscrn1,iflag,ibox) + if(ibox .eq. 1 .or. iflag .eq. 'd') then + do n=1,nefl + j=neflag(n) + call deltel(j) + enddo + nefl=0 + elseif(ibox .eq. 2 .or. iflag .eq. 'e') then + call refb + elseif(ibox .eq. 3 .or. iflag .eq. 't') then + nhtp=0 + nbrr=4 + NMESS=45 + call hedr + nmess=2 + call getint(mat) + ipsw(7)=1 + ipsw(5)=0 + do n=1,nefl + j=neflag(n) + imat(j) = mat + enddo + nefl=0 + elseif(ibox .eq. 4 .or. iflag .eq. 'm') then +! +! simplify layout +! + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL SMFY + +!ipk dec11 + elseif(ibox .eq. 5 .or. iflag .eq. 'g') then +! +! form group +! + CALL FORMGP + + endif + + + + CALL PLOTOT(1) + + nhtp=nhtps + nbrr=nbrs + nmess=nmessv + call clrbox + call hedr + else + call extract(NODLIST,NDLIST) + +! display extracted file + + + CALL PLOTOT(1) + + nhtp=nhtps + nbrr=nbrs + nmess=nmessv + call clrbox + call hedr + endif + + + RETURN + END + + SUBROUTINE CPOLY(XOT,YOT,NPTS,X,Y,INSWT) + DIMENSION XOT(*),YOT(*) + REAL*8 X,Y + DATA PI/3.14159/ + SUMA=0 + DO N=1,NPTS-1 + ANG1=ATAN2(YOT(N+1)-Y,XOT(N+1)-X) + ANG2=ATAN2(YOT(N)-Y,XOT(N)-X) + DIFA=ANG2-ANG1 + IF(ABS(DIFA) .GT. PI) THEN + IF(DIFA .LT. -PI) DIFA=DIFA+2.*PI + IF(DIFA .GT. PI) DIFA=DIFA-2.*PI + ENDIF + SUMA=SUMA+DIFA + ENDDO + IF(ABS(SUMA) .GT. PI) THEN + INSWT=1 + ELSE + INSWT=0 + ENDIF + RETURN + END + + SUBROUTINE GETPOLY(XOT,YOT,NPTS) + + USE BLK1MOD + dimension xot(*),yot(*) +! INCLUDE 'BLK1.COM' +! + CHARACTER*23 SELN3 + CHARACTER*32 SELN + CHARACTER*24 SELN2 + CHARACTER*1 IFLAG + data SELN/' Click at points to form polygon'/ + data SELN2/' Click next point '/ + data SELN3/' Click last point again'/ + + 80 CALL CLRBOX + nhtp=0 + nbrr=5 + nmess=0 + call hedr + CALL SYMBL(0.,7.70,0.20,SELN,0.,32) +! + 100 continue +! +! Get cursor location +! + CALL XYLOC(xscrn,yscrn,iflag,ibox) + IF(IRMAIN .EQ. 1) RETURN +! + if (iflag .eq. 'q') return +! + if(iflag .eq. 'c') then + xot(1)=xscrn + yot(1)=yscrn + npts=1 +! +! This option is creating an inset locations +! + 120 continue + CALL XYLOC(xscrn1,yscrn1,iflag,ibox) + IF(IRMAIN .EQ. 1) RETURN + if(ibox .eq. 6 .or. iflag .eq. 'b') then + npts=npts-1 + go to 120 + endif + if(iflag .eq. 'c') then +! +! Look for a screen size +! + 122 continue + xsiz=abs(xscrn1-xscrn) + ysiz=abs(yscrn1-yscrn) +!ipk jun96 test for zero sizes + if(xsiz .lt. 0.001 .or. ysiz .lt. 0.001) then + CALL CLRBOX + call hedr + CALL SYMBL(0.,7.70,0.20,seln3,0.,23) + go to 120 + endif + npts=npts+1 + xot(npts)=xscrn1 + yot(npts)=yscrn1 + call DASHLN(xot,yot,npts,1) + CALL CLRBOX + call hedr + + CALL SYMBL(0.,7.70,0.20,seln2,0.,24) + CALL XYLOC(xscrn1,yscrn1,iflag,ibox) + IF(IRMAIN .EQ. 1) RETURN + + if(ibox .eq. 6 .or. iflag .eq. 'b') then + npts=npts-1 + go to 120 + elseif(ibox .eq. 7 .or. iflag .eq. 'n') then + npts=npts+1 + xot(npts)=xot(1) + yot(npts)=yot(1) + call DASHLN(xot,yot,npts,1) + go to 280 + else + go to 122 + endif + endif + ENDIF + 280 continue + RETURN + END + + subroutine extract(NODLIST,NDLIST) + + USE WINTERACTER + USE BLK1MOD + INCLUDE 'BFILES.I90' +! include 'blk1.com' + + + include 'd.inc' + + DIMENSION NODLIST(*) + CHARACTER(LEN=256) :: FILTER + CHARACTER(LEN=255) :: FNAME,FNAMRM + +! select filename for new file + + FILTER ="Rm1 file -- *.rm1|*.rm1|" + CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Filename for extracted file') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + GO TO 200 + ELSE + GO TO 500 + ENDIF + 200 CONTINUE + CALL IlowerCase(FNAME) + + ITOTFIL=ITOTFIL+1 + FNAMEOUT(ITOTFIL)=FNAME + +! save current file + + IFILOUT=IACTVFIL+50 + CALL WRTFIL(IFILOUT) + +! create network structure + + CALL ZERORELM(NODLIST,NDLIST) + + IACTVFIL=ITOTFIL + + + +! save new structure + + IOT = 20 + FNAMRM=FNAME + igfgsw=0 + close(iot) + OPEN(IOT,FILE=FNAME,STATUS='UNKNOWN') +! +! Check if file cords format to be short or long +! +! + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save'//& + CHAR(13)//'coordinates in long format?' ,& + 'Coordinate save format') +! +! If answer 'No', use short format +! + IF (WInfoDialog(4) .EQ. 2) then + ntempin=0 + else + ntempin=2 + END IF +! + call wrtout(1) + CLOSE (IOT) + OPEN(IOT,FILE=FNAMRM,STATUS='UNKNOWN') + + 500 continue + return + end + + SUBROUTINE ZERORELM(NODLIST,NDLIST) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + dimension nodlist(*) + + DO N=1,NP + +! search nodlist + + do k=1,ndlist + if(n .eq. nodlist(K)) go to 300 + enddo + call deletn(n) + 300 continue + ENDDO + +! reset NP + + do k=np,1,-1 + if(inew(k) .gt. 0) then + np=k + go to 350 + endif + enddo + 350 continue + +! reset NE + + do k=ne,1,-1 + if(imat(k) .gt. 0) then + ne=k + go to 400 + endif + enddo + 400 continue + + RETURN + END + + SUBROUTINE GETFRAC(FRACD) +! +! Generate continuity lines +! + + USE WINTERACTER + save + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: I1,I2,I3,ITIME,IPOS + + REAL :: FRACD + + data itime/0/ + + IF(ITIME .EQ. 0) THEN + FRACD=0.1 + itime=1 + ENDIF + + call wdialogload(IDD_SETSEL) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_SETSEL) + ierr=infoerror(1) + + CALL WDialogPutReal(IDF_REAL1,FRACD) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialoggetReal(IDF_REAL1,FRACD) + GO TO 100 + + ENDIF + + enddo + + 100 CONTINUE + return + end + + SUBROUTINE FINDTYP + + USE WINTERACTER + USE BLKMAP + USE BLK1MOD + USE BLK2MOD + character*1 iflag + + include 'd.inc' + + DATA NS/1/ + + + call wdialogload(IDD_SELELTYP) + ierr=infoerror(1) + + CALL WDialogPutInteger(IDF_INTEGER1,NS) + + CALL WDialogSelect(IDD_SELELTYP) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,ModaL) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + CALL WDialogGetInteger(IDF_INTEGER1,NS) + go to 80 + ENDIF + enddo +80 CONTINUE + ICLL=4 + call clscrn + call plotot(0) + nefl=0 + DO N=1,NE + IF(IMAT(N) .EQ. NS) THEN + CALL FILLEMC(N,ICLL) + nefl=nefl+1 + neflag(nefl)=n + + ENDIF + ENDDO + nbrr=0 + nhtp=15 + call hedr + CALL XYLOC(xscrn1,yscrn1,iflag,ibox) + if(ibox .eq. 1 .or. iflag .eq. 'd') then + do n=1,nefl + j=neflag(n) + call deltel(j) + enddo + nefl=0 + elseif(ibox .eq. 2 .or. iflag .eq. 'e') then + call refb + elseif(ibox .eq. 3 .or. iflag .eq. 't') then + nhtp=0 + nbrr=4 + NMESS=45 + call hedr + nmess=2 + call getint(mat) + ipsw(7)=1 + ipsw(5)=0 + do n=1,nefl + j=neflag(n) + imat(j) = mat + enddo + nefl=0 + elseif(ibox .eq. 4 .or. iflag .eq. 'm') then +! +! simplify layout +! + IECHG=0 +!IPK MAY03 + ICHG=0 + CALL SMFY + +!ipk dec11 + elseif(ibox .eq. 5 .or. iflag .eq. 'g') then +! +! form group +! + CALL FORMGP + + elseif(ibox .eq. 6) then + do n=1,nefl + j=neflag(n) + do jj=1,8 + if(nop(j,jj) .ne. 0) then + wd(nop(j,jj))=-9999. + endif + enddo + enddo + endif + + RETURN + END + + SUBROUTINE MVGRP(NDLIST,NODLIST) + + USE WINTERACTER + USE BLK1MOD + INCLUDE 'TXFRM.COM' + dimension nodlist(maxp),RLAY(9) + character*1 iflag +! GET AMOUNT OF SHIFT IN PAGE UNITS + 200 continue + NHTP = 16 + NMESS = 47 + NBRR = 0 + CALL HEDR + CALL xyloc(xscrn1,yscrn1,iflag,ibox) + CALL XYLOC(XSCRN2,YSCRN2,IFLAG,IBOX) + XSHIFT=XSCRN2-XSCRN1 + YSHIFT=YSCRN2-YSCRN1 +! APPLY SHIFT TO NODES IN THE LIST + DO N=1,NDLIST + CORD(NODLIST(N),1)=CORD(NODLIST(N),1)+XSHIFT + CORD(NODLIST(N),2)=CORD(NODLIST(N),2)+YSHIFT + ENDDO + CALL PLOTOT(0) + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to save'//& + CHAR(13)//'new coordinate location?' ,& + 'COORDINATE MOVE') + IF (WInfoDialog(4) .EQ. 2) then +! revert to old + DO N=1,NDLIST + CORD(NODLIST(N),1)=(XUSR(NODLIST(N))+XS)/TXSCAL + CORD(NODLIST(N),2)=(YUSR(NODLIST(N))+YS)/TXSCAL + ENDDO + CALL PLOTOT(0) + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to '//& + CHAR(13)//'try again?' ,& + 'COORDINATE MOVE') + IF (WInfoDialog(4) .EQ. 2) then + return + else + go to 200 + endif + else +! accept + END IF + RETURN + END \ No newline at end of file diff --git a/src/SHOWEQ.F90 b/src/SHOWEQ.F90 new file mode 100644 index 0000000..735dc5c --- /dev/null +++ b/src/SHOWEQ.F90 @@ -0,0 +1,237 @@ + SUBROUTINE SHOWEQ(ISWT) + use winteracter + USE BLKELTLD + save + include 'D.inc' + INCLUDE 'TXFRM.COM' +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL + REAL HMAX(200),HRSTART,HREND + INTEGER IYSTART, IYEND, IDYSTART,IDYEND,ick1 + data ick1/0/,ITIME/0/ + IF(ISWT .EQ. 1) GO TO 140 + IF(ITIME .EQ. 0) THEN + IYSTART=IYDATE(1) + IYEND=IYDATE(1) + IDYSTART=TAE(1,1)/24. + HRSTART=TAE(1,1)-IDYSTART*24 + IDYSTART=IDYSTART+1 + IDYEND=IDYSTART + HREND=HRSTART + ITIME=1 + ENDIF + call wdialogload(IDD_SETUPELDISP) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_IDD_SETUPELDISP) + ierr=infoerror(1) + call wdialogputRadioButton(idf_radio1) + call wdialogputCheckBox(idf_check1,ick1) + CALL WDialogPutInteger(idf_integer1,IYSTART) + CALL WDialogPutInteger(idf_integer2,IDYSTART) + CALL WDialogPutInteger(idf_integer3,IYEND) + CALL WDialogPutInteger(idf_integer5,IDYEND) + CALL WDialogPutReal(idf_real1,HRSTART) + CALL WDialogPutReal(idf_real3,HREND) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + + call wdialogGetRadioButton(idf_radio1,iopt) + call wdialogGetCheckBox(idf_check1,ick1) + CALL WDialogGetInteger(idf_integer1,IYSTART) + CALL WDialogGetInteger(idf_integer2,IDYSTART) + CALL WDialogGetInteger(idf_integer3,IYEND) + CALL WDialogGetInteger(idf_integer5,IDYEND) + CALL WDialogGetReal(idf_real1,HRSTART) + CALL WDialogGetReal(idf_real3,HREND) + GO TO 80 + + elseif(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + RETURN + ENDIF + ENDDO +80 CONTINUE + TTMIN=1.E20 + TTMAX=-1.E20 + if(ick1 .eq. 0) then + DO I=1,NQHYD + IF(IRMATYP .EQ. 11) THEN + IF(NEST(I) .EQ. 3) CYCLE + ENDIF + NST=NHYE(I) + if(iopt .eq. 1) then + HMAX(I)=-1.E20 + DO K=1,NST + HMAX(I)=MAX(HAE(K,I),HMAX(I)) + ENDDO + TTMIN=MIN(HMAX(I),TTMIN) + TTMAX=MAX(HMAX(I),TTMAX) + else + HMAX(I)=0.0 + DO K=2,NST + IF(TAE(K,I)-TAE(K-1,I) .LT. 0.) THEN + IF(MOD(IYDATE(I),4) .EQ. 0) THEN + TCOR=366*24. + ELSE + TCOR=365*24. + ENDIF + ELSE + TCOR=0. + ENDIF + HMAX(I)=HMAX(I)+(HAE(K-1,I)+HAE(K,I))/2.*(TAE(K,I)+TCOR-TAE(K-1,I))*3.600E-3 + ENDDO + TTMIN=MIN(HMAX(I),TTMIN) + TTMAX=MAX(HMAX(I),TTMAX) + endif + ENDDO + else + DO I=1,NQHYD + IF(IRMATYP .EQ. 11) THEN + IF(NEST(I) .EQ. 3) CYCLE + ENDIF + TASTART=(IDYSTART-1)*24.+HRSTART + TAEND=(IDYEND-1)*24.+HREND + IF(IYSTART-IYDATE(I) .GT. 0) THEN + TASTART=TASTART+365*24.*(IYSTART-IYDATE(I)) + IF(MOD(IYDATE(I),4) .EQ. 0) TASTART=TASTART+24. + ENDIF + IF(IYEND-IYDATE(I) .GT. 0) THEN + TAEND=TAEND+365*24.*(IYEND-IYDATE(I)) + IF(MOD(IYDATE(I),4) .EQ. 0) TAEND=TAEND+24. + ENDIF + NST=NHYE(I) + if(iopt .eq. 1) then + HMAX(I)=-1.E20 + TCOR=0. + DO K=2,NST + IF(TAE(K,I)-TAE(K-1,I) .LT. 0.) THEN + TCOR=TCOR+365*24. + ENDIF + TTEMP=TAE(K,I)+TCOR + IF(TTEMP .LT. TASTART) CYCLE + IF(TTEMP .GT. TAEND) GO TO 120 + HMAX(I)=MAX(HAE(K,I),HMAX(I)) + ENDDO +120 CONTINUE + TTMIN=MIN(HMAX(I),TTMIN) + TTMAX=MAX(HMAX(I),TTMAX) + else + HMAX(I)=0.0 + TCOR=0. + DO K=2,NST + IF(TAE(K,I)-TAE(K-1,I) .LT. 0.) THEN + IF(MOD(IYDATE(I),4) .EQ. 0) THEN + TCOR=TCOR+366*24. + ELSE + TCOR=TCOR+365*24. + ENDIF +! TCOR=TCOR+365*24. + TDIF=TAE(K,I)-TAE(K-1,I)+TCOR + ELSE + TDIF=TAE(K,I)-TAE(K-1,I) + ENDIF + TTEMP=TAE(K,I)+TCOR + IF(TTEMP .LT. TASTART) CYCLE + IF(TTEMP .GT. TAEND) GO TO 130 + HMAX(I)=HMAX(I)+(HAE(K-1,I)+HAE(K,I))/2.*TDIF*3.600E-3 + ENDDO +130 CONTINUE + TTMIN=MIN(HMAX(I),TTMIN) + TTMAX=MAX(HMAX(I),TTMAX) + endif + ENDDO + endif + ISZ=1 + RAD=10. + CALL CSET(TTMIN,TTMAX,isz) +140 CONTINUE + DO I=1,NQHYD + IF(IRMATYP .EQ. 11) THEN + IF(NEST(I) .EQ. 3) CYCLE + ENDIF + DO J=1,NUMV + IF(HMAX(I) .LE. CONTUR(J)) THEN + ncoln=mod(J,13)+4 + JJ=NCLINE(I) +! CALL GETXCL(JJ,XCJ,YCJ) + call change_color(ncoln) +! CALL FILLEMC(NCLINE(I),NCOLN) + + raddisp=0.05 +! if(raddisp .lt. 0.01) raddisp=0.01 +! call circle(xcj,ycj,raddisp) + XCT=(XYCEL(I,1)+XS)/TXSCAL + YCT=(XYCEL(I,2)+YS)/TXSCAL + call circle(xct,yct,raddisp) + GO TO 200 + ENDIF + ENDDO +200 CONTINUE + ENDDO + CALL RBLACK + DO I=1,NQHYD + IF(IRMATYP .EQ. 11) THEN + IF(NEST(I) .EQ. 3) CYCLE + ENDIF + JJ=NCLINE(I) +! CALL GETXCL(JJ,XCJ,YCJ) +! CALL NUMBR(XCJ,YCJ,0.15,HMAX(I),0.0,1) + XCT=(XYCEL(I,1)+XS)/TXSCAL + YCT=(XYCEL(I,2)+YS)/TXSCAL + CALL NUMBR(XCT,YCT,0.15,HMAX(I),0.0,1) + enddo + RETURN + + END + + SUBROUTINE GETXCL(J,XCJ,YCJ) + + USE BLK1MOD + + XXC=0. + YYC=0. + IF(IMAT(J) .EQ. 0) GO TO 50 + NCN = NCORN(J) + IF(NCN .EQ. 9) THEN + NCNR=8 + ELSE + NCNR=NCN + ENDIF + NCNT=0 + DO 25 K=1,NCNR + N = NOP(J,K) +! + IF (N .EQ. 0 .OR. XUSR(N) .LT. VDX) GOTO 25 +! ! + IF (NCN .NE. 5 .OR. K .LT. 5) THEN + IF (MOD(K,2) .EQ. 1) THEN + XXC = XXC + XUSR(N) + YYC = YYC + YUSR(N) + NCNT=NCNT+1 + ENDIF + ENDIF + 25 CONTINUE + + IF(NCN .LT. 9) THEN + XCJ = XXC/NCNT + YCJ = YYC/NCNT + ELSE + XCJ= XUSR(NOP(J,9)) + YCJ= YUSR(NOP(J,9)) + ENDIF + 50 CONTINUE + RETURN + END + \ No newline at end of file diff --git a/src/SHOWEQ.FOR b/src/SHOWEQ.FOR new file mode 100644 index 0000000..8d7972b --- /dev/null +++ b/src/SHOWEQ.FOR @@ -0,0 +1,8 @@ + SUBROUTINE SHOWEQ + USE BLKELTLD + DO I=1,NQHYD + IELEM=NCLINE(I) + CALL FILLEM(IELEM) + ENDDO + RETURN + END diff --git a/src/SMFY.F90 b/src/SMFY.F90 new file mode 100644 index 0000000..ac1810f --- /dev/null +++ b/src/SMFY.F90 @@ -0,0 +1,70 @@ + SUBROUTINE SMFY + + USE BLKMAP + USE BLK1MOD + USE BLK2MOD + DATA SPAC/0.0/ +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + +! First delete selected elements and create list of nodes + + do n=1,np + list(n)=0 + ninc(n)=0 + enddo + + do n=1,nefl + j=neflag(n) + do k=1,8,2 + if(nop(j,k) .gt. 0) list(nop(j,k))=1 + enddo + call deltel(j) + enddo + +! All corner nodes connected to elements now have LIST=1 + +! Remove nodes that are still connected from list +! But keep list of nodes that are dropped +! Now form list of nodes to be refined + do n=1,ne + if(imat(n) .gt. 0) then + do k=1,8,2 + if(nop(n,k) .gt. 0) then + if(list(nop(n,k)) .eq. 1) then + ninc(nop(n,k))=1 + endif + list(nop(n,k))=0 + endif + enddo + endif + enddo + + +! Get simplification options + + CALL TRIANOPT(NINTV,SPAC) + +! Sort points into ascending x order + + CALL SORTDB(XUSR,NKEY,NP) + +! Drop points based on spacing + + IF(NINTV .GT. 1 .OR. SPAC .GT. 0.) THEN + CALL DROPPTS(NP,NINTV,SPAC) + ENDIF + +! Add back in the edge nodes + + DO N=1,NP + IF(NINC(N) .EQ. 1) LIST(N)=1 + ENDDO + +! Form new triangles + + call deln2(np,2) + +! + RETURN + END \ No newline at end of file diff --git a/src/SPLIT.F90 b/src/SPLIT.F90 new file mode 100644 index 0000000..ed7c10c --- /dev/null +++ b/src/SPLIT.F90 @@ -0,0 +1,345 @@ +!IPK NEW ROUTINE SEP 9 2006 + SUBROUTINE SPLITN +! +! Generate continuity lines +! + + USE WINTERACTER + USE BLK1MOD + USE BLK2MOD + include 'd.inc' + +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + INCLUDE 'TXFRM.COM' + CHARACTER*1 IFLAG + DIMENSION DIRL(350),IPROCES(MAXE) +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3,IERR + + DATA SPAC/10./,ieltyp/1/,ielsw/1/,iensw/0/ + +! DIST(N1,N2)=SQRT((CORD(N1,1)-CORD(N2,1))**2 & +! & +(CORD(N1,2)-CORD(N2,2))**2) + PROJ(N1,N2,DR)= (CORD(N2,1)-CORD(N1,1))*COS(DR)+(CORD(N2,2)-CORD(N1,2))*SIN(DR) +! + icln=1 + dirsplIt=0. + ieltyp=1 + ientyp=1 + SPAC=10. + call wdialogload(IDD_DISPLIT) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_DISPLIT) + ierr=infoerror(1) + + call wdialogputradiobutton(idf_radio1) + CALL WDialogPutinteger(IDF_INTEGER3,icln) + CALL WDialogPutReal(IDF_REAL1,SPAC) + CALL WDialogPutinteger(IDF_INTEGER2,IELTYP) + call wdialogputcheckbox(IDF_check1,ielsw) + call wdialogputcheckbox(IDF_check2,iensw) + CALL WDialogPutinteger(IDF_INTEGER6,IENTYP) + CALL WDialogPutReal(IDF_REAL2,DIRSPLIT) + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,iswr) + CALL WDialogGetinteger(IDF_INTEGER3,icln) + CALL WDialogGetREAL(IDF_REAL1,SPAC) + CALL WDialogGetinteger(IDF_INTEGER2,IELTYP) + call wdialogGetcheckbox(IDF_check1,ielsw) + call wdialogGetcheckbox(IDF_check2,iensw) + CALL WDialogGetinteger(IDF_INTEGER6,IENTYP) + CALL WDialogGetREAL(IDF_REAL2,DIRSPLIT) + GO TO 100 + ENDIF + + enddo + +100 CONTINUE + + if(iswr .eq. 1) then + CALL CCLINE(2) + else + DO KK=1,350 + if(iccln(icln,KK) .eq. 0) then + ntract=kk-1 + go to 102 + endif + itrac(kk)=ICCLN(icln,KK) + enddo +102 continue + endif + DO N=1,NTRACT + + N1=ITRAC(N) + IF(N .GT. 1) THEN + N0=ITRAC(N-1) + ENDIF + IF(N .LT. NTRACT) THEN + N2=ITRAC(N+1) + ENDIF + +! Get direction + + IF(N .EQ. 1) THEN + IF(NTRACT .GT. 1) THEN + DIRX=XUSR(N2)-XUSR(N1) + DIRY=YUSR(N2)-YUSR(N1) + DIRL(N)=ATAN2(DIRX,-DIRY) + ELSE + DIRL(N)=DIRSPLIT + ENDIF + ELSEIF(N .EQ. NTRACT) THEN + DIRX=XUSR(N1)-XUSR(N0) + DIRY=YUSR(N1)-YUSR(N0) + DIRL(N)=ATAN2(DIRX,-DIRY) + ELSE + DIRX=XUSR(N2)-XUSR(N0) + DIRY=YUSR(N2)-YUSR(N0) + DIRL(N)=ATAN2(DIRX,-DIRY) + ENDIF + ENDDO +! Move nodes apart adding new numbers + + DO N=1,NTRACT + N1=ITRAC(N) + CALL GETNOD(J) + JTRAC(N)=J + XUSR(J)=XUSR(N1)-SPAC/2.*COS(DIRL(N)) + YUSR(J)=YUSR(N1)-SPAC/2.*SIN(DIRL(N)) + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + INEW(J)=1 + INSKP(J) = 0 + + XUSR(N1)=XUSR(N1)+SPAC/2.*COS(DIRL(N)) + YUSR(N1)=YUSR(N1)+SPAC/2.*SIN(DIRL(N)) + CORD(N1,1)=(XUSR(N1)+XS)/TXSCAL + CORD(N1,2)=(YUSR(N1)+YS)/TXSCAL + WD(J)=WD(N1) + WIDTH(J)=WIDTH(N1) + SS1(J)=SS1(N1) + SS2(J)=SS2(N1) + WIDS(J)=WIDS(N1) + WIDBS(J)=WIDBS(N1) + SSO(J)=SSO(N1) + ENDDO + + +! Form list of elements connected to nodes + IERR=0 + CALL NDNECON(IERR) + +! find each element + + IPROCES=0 + + IF(NTRACT .GT. 1) THEN + DO N=1,NTRACT-1 + DO K=1,NDELM(ITRAC(N)) + J=NECON(ITRAC(N),K) +! IF(IPROCES(J) .EQ. 0) THEN + IJ=0 + II=0 + DO L=1,NCORN(J),2 + IF(NOP(J,L) .EQ. ITRAC(N) .or. NOP(J,L) .EQ. JTRAC(N)) II=L + IF(NOP(J,L) .EQ. ITRAC(N+1)) IJ=L + ENDDO + IF(IJ .NE. 0) THEN + IF(IJ .LT. II .OR. (II .EQ. 1 .and. ij .ne. 3) ) THEN + IF(II .EQ. NCORN(J)-1 .AND. IJ .EQ. 1) GO TO 200 +! MATCH FOUND + NOP(J,II)= JTRAC(N) + NOP(J,IJ)= JTRAC(N+1) + IPROCES(J)=1 + GO TO 300 + ENDIF + 200 CONTINUE + IPROCES(J)=1 + ENDIF + 300 CONTINUE +! ENDIF + ENDDO + ENDDO + + ENDIF + + DO N=1,NTRACT + DO K=1,NDELM(ITRAC(N)) + J=NECON(ITRAC(N),K) + IF(IPROCES(J) .EQ. 0) THEN + II=0 + DO L=1,NCORN(J),2 + IF(NOP(J,L) .EQ. ITRAC(N)) II=L + ENDDO + IF(II .NE. 0) THEN + A0P=-9999. + A0M=9999. + B0P=-9999. + B0M=9999. + DO L=1,NCORN(J),2 + IF(II .NE. NOP(J,L)) THEN + ITEST=NOP(J,L) + ENDIF + A1=PROJ(ITEST,ITRAC(N),DIRL(N)) + IF(A1 .GT. A0P) A0P=A1 + IF(A1 .LT. A0M) A0M=A1 + B1=PROJ(ITEST,JTRAC(N),DIRL(N)) + IF(B1 .GT. B0P) B0P=B1 + IF(B1 .LT. B0M) B0M=B1 + ENDDO + IF(ABS(A0M) .GT. ABS(A0P)) THEN + A0P=A0M + B0P=B0M + ENDIF + IF(ABS(A0P) .GT. ABS(B0P)) THEN + NOP(J,II)= JTRAC(N) + ENDIF + IPROCES(J)=1 + ENDIF + ENDIF + ENDDO + ENDDO + IERR=0 + CALL NDNECON(IERR) + + IF(IELSW .EQ. 0) GO TO 400 +! form new elements + + DO N=1,NTRACT-1 + CALL GETELM(J) + NOP(J,1)=JTRAC(N) + NOP(J,3)=JTRAC(N+1) + NOP(J,5)=ITRAC(N+1) + NOP(J,7)=ITRAC(N) + NOP(J,2)=0 + NOP(J,4)=0 + NOP(J,6)=0 + NOP(J,8)=0 + IMAT(J)=IELTYP + NCORN(J) = 8 + IESKP(J) = 0 + NE = MAX(J,NE) + ENDDO + + 400 CONTINUE + + if(iensw .gt. 0) then + + + +! start at first node + IF(NDELM(ITRAC(1)) .GT. 1) THEN + DO K=1,NDELM(ITRAC(1)) + J=NECON(ITRAC(1),K) + DO KZ=1,NCORN(J),2 + IF(NOP(J,KZ) .EQ. ITRAC(1)) THEN + K1=KZ + GO TO 500 + ENDIF + ENDDO + 500 KK=K1-2 + IF(KK .LT. 0) KK=NCORN(J)-1 + KUP=NOP(J,KK) + DO KZ=1,NDELM(KUP) + JJ=NECON(KUP,KZ) + DO KY=1,NCORN(JJ),2 + IF(NOP(JJ,KY) .EQ. KUP) THEN + K2=KY + GO TO 550 + ENDIF + ENDDO + 550 KL=K2-2 + IF(KL .LT. 0) KL=NCORN(JJ)-1 + IF(NOP(JJ,KL) .EQ. JTRAC(1)) THEN + GO TO 600 + ENDIF + ENDDO + ENDDO + +! FOUND A MATCH + + 600 CONTINUE + CALL GETELM(JK) + NOP(JK,1)=ITRAC(1) + NOP(JK,3)=KUP + NOP(JK,5)=JTRAC(1) + NOP(JK,2)=0 + NOP(JK,4)=0 + NOP(JK,6)=0 + IMAT(JK)=IENTYP + NCORN(JK) = 6 + IESKP(JK) = 0 + NE = MAX(JK,NE) + ENDIF + + IF(NDELM(ITRAC(NTRACT)) .GT. 1) THEN + DO K=1,NDELM(ITRAC(NTRACT)) + J=NECON(ITRAC(NTRACT),K) + DO KZ=1,NCORN(J),2 + IF(NOP(J,KZ) .EQ. ITRAC(NTRACT)) THEN + K1=KZ + GO TO 650 + ENDIF + ENDDO + 650 KK=K1+2 + IF(KK .GT. NCORN(J)) KK=1 + KUP=NOP(J,KK) + DO KK=1,NDELM(KUP) + JJ=NECON(KUP,KK) + DO KY=1,NCORN(JJ),2 + IF(NOP(JJ,KY) .EQ. KUP) THEN + K2=KY + GO TO 700 + ENDIF + ENDDO + 700 KL=K2+2 + IF(KL .GT. NCORN(JJ)) KL=1 + IF(NOP(JJ,KL) .EQ. JTRAC(NTRACT)) THEN + GO TO 750 + ENDIF + ENDDO + ENDDO + GO TO 800 + +! FOUND A MATCH + + 750 CONTINUE + CALL GETELM(JK) + + NOP(JK,1)=JTRAC(NTRACT) + NOP(JK,3)=KUP + NOP(JK,5)=ITRAC(NTRACT) + NOP(JK,2)=0 + NOP(JK,4)=0 + NOP(JK,6)=0 + IMAT(JK)=IENTYP + NCORN(JK) = 6 + IESKP(JK) = 0 + NE = MAX(JK,NE) + ENDIF + + endif + + 800 CONTINUE + call clscrn + CALL PLOTOT(1) + NHTP=1 + NMESS=0 + NBRR=0 + CALL HEDR + RETURN + END \ No newline at end of file diff --git a/src/SWMAP.F90 b/src/SWMAP.F90 new file mode 100644 index 0000000..e57ddef --- /dev/null +++ b/src/SWMAP.F90 @@ -0,0 +1,91 @@ + SUBROUTINE SWMAP + + USE BLKMAP + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + + LOGICAL OPENTS + CHARACTER*1 iflag + + ISWAP=IBAK + IBAK=15 + +! Write out RM1 file + + INQUIRE(IBAK, OPENED=OPENTS) + IF(.NOT. OPENTS) THEN + OPEN(IBAK,STATUS='SCRATCH',FORM='UNFORMATTED') + ENDIF + REWIND IBAK + CALL WRTOUT(0) + REWIND IBAK + IBAK=ISWAP + +! Now put map data into RM1 position + + NE=NELTS + DO J=1,NE + DO K=1,8 + NOP(J,K)=0. + ENDDO + IF(NOPEL(J,1) .GT. 0) THEN + NOP(J,1)=NOPEL(J,1) + NOP(J,3)=NOPEL(J,2) + NOP(J,5)=NOPEL(J,3) + NCORN(J)=6 + IMAT(J)=1 + IESKP(J) = 0 + ELSE + NCORN(J)=0 + IMAT(J)=0 + IESKP(J) = 1 + ENDIF + ENDDO + NP=MAXPTS + DO J=1,NP + XUSR(J)=XMAP(J) + YUSR(J)=YMAP(J) + CORD(J,1) = XUSR(J) + CORD(J,2) = YUSR(J) + WD(J)=VAL(J) + INSKP(J)=0 + IF (CORD(J,1) .GT. VDX) THEN + INEW(J) = 1 + ENDIF + ENDDO + NLST=0 + NENTRY=0 + NLAYD=0 + NCLM=0 + CALL RESCAL + CALL HEDR + RETURN + END + + SUBROUTINE SWRM1 + + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + DO N=1,NE + IF(IMAT(N) .GT. 0) THEN + NOPEL(N,1)=NOP(N,1) + NOPEL(N,2)=NOP(N,3) + NOPEL(N,3)=NOP(N,5) + ELSE + NOPEL(N,1)=0 + NOPEL(N,2)=0 + NOPEL(N,3)=0 + ENDIF + ENDDO + CALL RDRST(1,15) + CALL RDRST(2,15) + CALL RDRST(3,15) + REWIND 15 + CALL RESCAL + CALL HEDR + RETURN + END diff --git a/src/SYMBL.F90 b/src/SYMBL.F90 new file mode 100644 index 0000000..7ef3282 --- /dev/null +++ b/src/SYMBL.F90 @@ -0,0 +1,1441 @@ +!IPK LAST UPDATE SEP 23 2015 REVISE TESTING FOR RIVER SECTIONS + subroutine tekgin(x,y,iflag) + save +!iPK APR94 + COMMON /RECOD/ IRECD,TSPC + character*1 iflag,iiflag,iflags + data rsclx,rscly/100.0,100./ + data itime/0/ + if(itime .eq. 0) then + itime=1 + iky=0 + endif +!iPK APR94 + IF(IRECD .EQ. 2) THEN + if(iky .eq. 0) then + READ(91,'(2F7.2,A1)') X,Y,IFLAG + iflags=iflag + xs=x + ys=y + else + iflag=iflags + x=xs + y=ys + endif +! write(*,'(2f7.2,a1,i4)') x,y,iflag,iky + call flush_screen + CALL INTRVL(TA,0) + 90 CALL INTRVL(TA,1) + IF(TA .LT. TSPC) GO TO 90 + if(tspc .eq. 0.) then + call gim_an_event(ix,iy,iiflag) + if(iiflag .eq. '~') then + iflag='P' + iky=1 + return + endif + endif + iky=0 + ENDIF +100 continue +! write(*,'(2i15,a1,i3)') ix,iy,iflag,iky + if(irecd .eq. 2) return + call flush_screen + CALL gim_an_event(ix, iy, iiflag) +! write(*,'(2i5,a1)') ix,iy,iiflag + IF (iiflag.eq.'~') then +! call hedr +! CALL plotot +! call hedr + iflag='P' + iky=1 +! go to 100 + return + endif + iky=0 +! if(irecd .eq. 2) return + x= float(ix)/rsclx +! y= 8.0-float(iy)/rscly + y= float(iy)/rscly + iflag=iiflag +! write(90,666) x,y,iflag,ix,iy,iiflag,iky +! 666 format('tekgin',2f8.2,a1,2i5,a1,i2) + if(iflag .eq. 'u') then + go to 100 + endif + +!ipk apr94 + if(irecd .eq. 1) then + write(91,'(2f7.2,a1)') x,y,iflag + endif + + return + end + + subroutine draw(x,y) + save + common /pltc/ipsav,iflg,xll,yll + + data rsclx,rscly/100.,100./ + ix=x*rsclx + iy=y*rscly + CALL gim_a_line(ix, iy) + +! save data on file if requested + + if(ipsav .gt. 0) then + +! don't write out point unless > .005" from previous point + + if (abs(xll-x) .ge. .005 .or. abs(yll-y) .ge. .005 ) then + write(ipsav,99) 'pa',x,y + xll = x + yll = y + iflg = 0 + else + iflg = 1 + endif + endif +99 format (a2,2f8.3) + return + end + + + subroutine move(x,y) + save + common /pltc/ipsav,iflg,xll,yll + + data rsclx,rscly/100.,100./ + ix=x*rsclx + iy=y*rscly + CALL move_da_pointer(ix, iy) + +! save data on file if requested + + if(ipsav .gt. 0) then + +! don't write out point unless > .005" from previous point + + write(ipsav,99) 'ma',x,y + xll = x + yll = y + iflg = 0 + endif +99 format (a2,2f8.3) + return + end + +!************************************************************* +! +! SYMBOL SUBROUTINE +! +! ROUTINE TO OUTPUT !HARACTER STRINGS. +! +!***************************************************************** + SUBROUTINE SYMBL (X,Y,HEIGHT,STRING,ANGLE,NCHAR) + save + COMMON /PLTC/IPSAV,IFLG,XLL,YLL + CHARACTER*(*) STRING + CHARACTER*32 FMT1 + CHARACTER*2 PS + CHARACTER*2 IHT + DATA PS/'PS'/,HT/0.8/ + integer*4 nchar + IHT(1:1)=CHAR(27) + IHT(2:2)=':' + + HT=height*5. + +! if(height .gt. 0.7) then +! ht=height +! else +! ipk mar01 +! ht=0.6 +! endif +! +! Centered symbols +! + ICHR = -1 + IF (NCHAR .LT. 0) THEN + ICHR = ICHAR(STRING(1:1)) + IF (ICHR .EQ. 0) STRING(1:1) = CHAR(35) + IF (ICHR .EQ. 1) STRING(1:1) = CHAR(33) + IF (ICHR .EQ. 2) STRING(1:1) = CHAR(39) + IF (ICHR .EQ. 3) STRING(1:1) = CHAR(41) +!cc WRITE(2,'(A)') 'SS "CENTERED.SYM"' + ENDIF +! + ZANGLE = ANGLE + LSTR = LENSTR(STRING) + LSTR = MIN(LSTR,IABS(NCHAR)) +! +! ixx = x*scrnx +! iyy = (7.50-y-0.2)*scrny + +! +! + CALL QUAD(X,Y,ITS) + IF(ITS .EQ. 22) THEN + yy=y +! CALL move( x, yy) + CALL LABL(X,YY,LSTR,HT,STRING) + ANGL = ZANGLE/3.14159 + XLAS = X + COS(ANGL)*(HEIGHT*LSTR) + YLAS = Y + SIN(ANGL)*(HEIGHT*LSTR) +! + IF(IPSAV .GT. 0) THEN + HTG=HT*0.75 + WRITE(FMT1,198) NCHAR + 198 FORMAT(18h(A2,4F8.3,1X,1H",A,i2,5h,1H")) + WRITE(ipsav,FMT1) PS,X,Y,HTG,ANGLE,STRING + ENDIF + + ENDIF +! + RETURN + END + SUBROUTINE QUAD(X,Y,IST) +!- +!...... Subroutine to establish location of X and Y relative to bounds +!- + COMMON /PAGE/ XL,XH,YL,YH +!- +!...... Test side of X +!- + IST=22 + IF(X .LT. XL) IST=12 + IF(X .GT. XH) IST=32 +!- +!...... Test side of Y +!- + IF(Y .LT. YL) IST=IST-1 + IF(Y .GT. YH) IST=IST+1 +!- +!...... Final pattern for IST is +!- +! 13 23 33 +! ------ +! 12 | 22 | 32 +! ------ +! 11 21 31 +! + RETURN + END + + SUBROUTINE TRIM(XO,YO,XI,YI,XB,YB,IST,ISTN) + +!...... Subroutine to compute coordinates for XB and YB on the boundary + + COMMON /PAGE/ XL,XH,YL,YH + IF(IST .LT. 20) THEN + +!...... XO is to the left + + IF(ISTN .LT. 20) THEN + +!...... XI is also left skip out +! by setting IST negative + + IST=-IST + RETURN + ELSE + XB = XL + YB = YO+(YI-YO)/(XI-XO)*(XL-XO) + +!...... Check location of YB. If its within limits we are done +! or have found a totally crossing line + + IF(YB .LT. YL) THEN + +!...... Below + + IF (YI .EQ. YB) THEN + XB = 999. + ELSE + XB = XB+(XI-XB)/(YI-YB)*(YL-YB) + ENDIF + YB = YL + IF(XB .GT. XH .OR. XB .LT. XL) THEN + +!...... Signify that final point is still out by negative IST + + IST=-IST + ELSEIF(ISTN .NE. 22) THEN + +!...... Part of a crossing line set ISTN negative + + ISTN=-ISTN + ENDIF + ELSEIF(YB .GT. YH) THEN + +!...... Above + + IF (YI .EQ. YB) THEN + XB = 999. + ELSE + XB = XB+(XI-XB)/(YI-YB)*(YH-YB) + ENDIF + YB = YH + IF(XB .GT. XH .OR. XB .LT. XL) THEN + IST=-IST + ELSEIF(ISTN .NE. 22) THEN + ISTN=-ISTN + ENDIF + ELSEIF(ISTN .NE. 22) THEN + ISTN=-ISTN + ENDIF + ENDIF + ELSEIF(IST .GT. 30) THEN + +!...... XO is to the right + + IF(ISTN .GT. 30) THEN + +!...... XI is also right skip out + IST=-IST + ELSE + XB = XH + YB = YO+(YI-YO)/(XI-XO)*(XH-XO) + +!...... Check location of YB. If its within limits we are done + + IF(YB .LT. YL) THEN + +!...... Below + + IF (YI .EQ. YB) THEN + XB = 999. + ELSE + XB = XB+(XI-XB)/(YI-YB)*(YL-YB) + ENDIF + YB = YL + IF(XB .GT. XH .OR. XB .LT. XL) THEN + IST=-IST + ELSEIF(ISTN .NE. 22) THEN + ISTN=-ISTN + ENDIF + ELSEIF(YB .GT. YH) THEN + +!...... Above + + IF (YI .EQ. YB) THEN + XB = 999. + ELSE + XB = XB+(XI-XB)/(YI-YB)*(YH-YB) + ENDIF + YB = YH + IF(XB .GT. XH .OR. XB .LT. XL) THEN + IST=-IST + ELSEIF(ISTN .NE. 22) THEN + ISTN=-ISTN + ENDIF + ELSEIF(ISTN .NE. 22) THEN + ISTN=-ISTN + ENDIF + ENDIF + ELSE + +!...... XO is in the middle section + +!...... Check location of YB. If its within limits we are done + + IF(YO .LT. YL) THEN + +!...... Below + + IF(MOD(ISTN,10) .EQ. 1) THEN + +!...... still out + + IST=-IST + ELSE + YB = YL + IF (YI .EQ. YO) THEN + XB = 999. + ELSE + XB = XO+(XI-XO)/(YI-YO)*(YL-YO) + ENDIF + IF(XB .GT. XH .OR. XB .LT. XL) THEN + IST=-IST + ELSEIF(ISTN .NE. 22) THEN + ISTN=-ISTN + ENDIF + ENDIF + ELSEIF(YO .GT. YH) THEN + +!...... Above + + IF(MOD(ISTN,10) .EQ. 3) THEN + +!...... still out + + IST=-IST + ELSE + YB = YH + IF (YI .EQ. YO) THEN + XB = 999. + ELSE + XB = XO+(XI-XO)/(YI-YO)*(YH-YO) + ENDIF + IF(XB .GT. XH .OR. XB .LT. XL) THEN + IST=-IST + ELSEIF(ISTN .NE. 22) THEN + ISTN=-ISTN + ENDIF + ENDIF + ENDIF + ENDIF + RETURN + END + + SUBROUTINE NUMBR(X,Y,HITE,RNUM,THETA,NDEC) +! This routine has been extensively rewritten AUG 94 + SAVE + COMMON /PLTC/IPSAV,IFLG,XLL,YLL + integer*4 ndec + CHARACTER*36 FMT,FMT1,NARRAY + CHARACTER*1 QOT + + +! WHERE: X,Y DEFINE THE COORDINATES OF THE LOWER-LEFT CORNER OF THE +! FIRST DIGIT TO BE PLOTTED +! HITE CHARACTER HEIGHT (INCHES) +! RNUM THE REAL NUMBER TO BE PLOTTED +! THETA THE ANGLE (IN DEGREES) THE CHARACTER STRING MAKES WITH THE +! X-AXIS +! NDEC THE OF DECIMAL PLACES TO WHICH THE IS PLOTTED + + + DATA QOT/'"'/ + CALL CVF(RNUM,NDEC,NARRAY,NUMC) + CALL SYMBL(X,Y,HITE,NARRAY,THETA,NUMC) + IF(IPSAV .GT. 0) THEN + XLAS=X+NUMC*HITE*0.75 + YLAS=Y + ZANGLE = THETA + HTG=HITE*0.75 + WRITE(IPSAV,199) 'PS',X,Y,HTG,ZANGLE,(NARRAY(I:I),I=1,NUMC),QOT +199 FORMAT (A2,2F8.3,2F8.3,1X,1H",11A1) + ENDIF + RETURN + + END + + + + subroutine polyfl(x,y,npts,icol) +! polygon fill routine npts close it , colour code is icol + save + dimension x(*),y(*) + dimension itran(0:16) + data itran/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/ + IF(icol .EQ. -11) then + icll=8 + else + icll=itran(icol) + endif + if (npts .lt. 4) return + CALL nwpen(icll) + CALL fill_a_polygon(x,y,npts) + call Rblue + return + end +! --------------------------------------------------------------------------- + + subroutine nwpen(icl) + + CALL change_color(icl) + return + end + + subroutine RGrey + icl=15 +! 240 + call nwpen(icl) + return + end +! ----------------------------------------------------------------------------- + + + subroutine RBlack + icl=14 +! 223 + call nwpen(icl) + return + end +! ----------------------------------------------------------------------------- + + subroutine Rwhite + icl=0 +! 224 + call nwpen(icl) + return + end +! ----------------------------------------------------------------------------- + + subroutine Rwhiteb + icl=1 +! 224 + call nwpen(icl) + return + end +! ----------------------------------------------------------------------------- + + subroutine RRed + icl=12 +! 16 + call nwpen(icl) + return + end +! ----------------------------------------------------------------------------- + + subroutine RBlue + icl=3 +! 175 + call nwpen(icl) + return + end +! ----------------------------------------------------------------------------- + + subroutine Rcyan + icl=5 +! 112 + call nwpen(icl) + return + end +! ----------------------------------------------------------------------------- + subroutine RGreen + icl=7 +! 96 + call nwpen(icl) + return + end +! ----------------------------------------------------------------------------- + + + + +! Routine to obtain keyboard entry in ascii code + + SUBROUTINE KEYBRD(K) + character*1 cha + call gim_a_charac(K,cha,x,y) + RETURN + END + + + subroutine clscrn + CALL clear_screen + return + end + + + SUBROUTINE PLOTT(XX,YY,II) + SAVE + COMMON /PLTC/IPSAV,IFLG,XLL,YLL + + COMMON /PAGE/ XL,XH,YL,YH + COMMON /PLXZ/ XLAS,YLAS,NPLT,NCHRS,XORG,YORG + + +! Save data on file if requested + + IF(IPSAV .GT. 0 .AND. II .LT. 0) THEN + WRITE(IPSAV,99) 'tr',XX,YY + WRITE(IPSAV,99) 'pi',0.0,0.0 + WRITE(IPSAV,99) 'ma',0.0,0.0 + xold=xx + yold=yy + ENDIF + 99 FORMAT (a2,2F8.3) + + IF(II .EQ. 3) THEN + CALL QUAD(XX,YY,ITS) + XOLD=XX + YOLD=YY + IF(ITS .EQ. 22) call move(xx,yy) + ENDIF + IF(II .EQ. 2) THEN + IF(ITS .EQ. 22) THEN +! was in + CALL QUAD(XX,YY,ITS) + IF(ITS .EQ. 22) THEN +! still in + CALL DRAW(XX,YY) + XOLD=XX + YOLD=YY + ELSE +! now out + ITSN=22 + CALL TRIM(XX,YY,XOLD,YOLD,XB,YB,ITS,ITSN) + CALL DRAW(XB, YB) + XOLD=XX + YOLD=YY + ITS=IABS(ITS) + ENDIF + ELSE +! was out + CALL QUAD(XX,YY,ITSN) + IF(ITSN .EQ. 22) THEN +! now in + CALL TRIM(XOLD,YOLD,XX,YY,XB,YB,ITS,ITSN) + CALL MOVE(XB, YB) + CALL DRAW(XX, YY) + XOLD=XX + YOLD=YY + ITS=22 + ELSE +! still out but could have been in for a time so test + CALL TRIM(XOLD,YOLD,XX,YY,XB,YB,ITS,ITSN) + IF(ITS .LT. 0) THEN +! yes + XOLD=XX + YOLD=YY + ITS=IABS(ITSN) + ELSEIF(ITSN .LT. 0) THEN + CALL MOVE(XB,YB) + ITSN=-ITSN + ITS=22 + XOLD=XB + YOLD=YB + CALL TRIM(XX,YY,XOLD,YOLD,XB,YB,ITSN,ITS) + CALL DRAW(XB, YB) + XOLD=XX + YOLD=YY + ITS=IABS(ITSN) + ENDIF + ENDIF + ENDIF + ENDIF + XLAS=XOLD + YLAS=YOLD + RETURN + END + + + subroutine quit_pgm + call setd(24) + close (90) + CALL get_rid_window + stop + end + +! ----------------------------------------------------------------------------- + + subroutine clrbox + CALL clear_box + return + end + + SUBROUTINE INTRVL(TA,IS) + +!...... Timing routine + +! TA is interval time in seconds + +!IPK APR94 + COMMON /RECOD/ IRECD,TSPC + + INTEGER*4 ITA,ITN + + IF(IS .EQ. 0) THEN +! CALL TIMER(ITA) + CALL GETTIM(IHR,IMIN,ISEC,IHUN) + TB=3600.*IHR+60.*IMIN+ISEC+ FLOAT(IHUN)/100. + RETURN + ELSE + CALL GETTIM(IHR,IMIN,ISEC,IHUN) + TA=3600.*IHR+60.*IMIN+ISEC+ FLOAT(IHUN)/100. +! CALL TIMER(ITN) + ENDIF +! ITIC=ITN-ITA +! IF(ITIC .LT. 0) THEN +! ITA=ITN +! ITIC=0 +! ENDIF +! TA=FLOAT(ITIC)/100. + TA=TA-TB + IF(TSPC .EQ. 0.) THEN + TA=TA-0.5 + ENDIF + RETURN + END + + SUBROUTINE DASHLN(XLIN,YLIN,NLINP,ICD) + +! Routine to draw a line with dashes + + DIMENSION XLIN(*),YLIN(*) + +! Work through points + + DO 200 K=1,NLINP + IF(K .EQ. 1) THEN + CALL PLOTT(XLIN(K),YLIN(K),3) + ELSEIF(ICD .EQ. 0) THEN + CALL PLOTT(XLIN(K),YLIN(K),2) + ELSE + +! Draw dashed line + + DASHNT=0.2/2.**ICD + SC1=(XLIN(K)-XLIN(K-1))**2 + SC2=(YLIN(K)-YLIN(K-1))**2 + SLEN=SQRT(SC1+SC2) + NDASH=IFIX(SLEN/DASHNT)+1 + XINC=(XLIN(K)-XLIN(K-1))/SLEN*DASHNT + YINC=(YLIN(K)-YLIN(K-1))/SLEN*DASHNT + XP=XLIN(K-1) + YP=YLIN(K-1) + DO 180 ND=1,NDASH + IF(ND .LT. NDASH) THEN + XP=XP+XINC + YP=YP+YINC + ELSE + XP=XLIN(K) + YP=YLIN(K) + ENDIF + IF(MOD(ND,2) .EQ. 1) THEN + CALL PLOTT(XP,YP,2) + ELSE + CALL PLOTT(XP,YP,3) + ENDIF + 180 CONTINUE + ENDIF + 200 CONTINUE + RETURN + END + + subroutine chint(iflag) + character*1 iflag + iflag='c' + return + end + SUBROUTINE GETINTAA(INUM) + + COMMON /RECOD/ IRECD,TSPC + + character*50 cha + CHARACTER*11 DATA + + CHARACTER*30 MES + DATA MES/'Error reading integer, Reenter'/ + + if(irecd .eq. 2) then + read(91,'(i7)') inum + CALL INTRVL(TA,0) + 70 CALL INTRVL(TA,1) + IF(TA .LT. TSPC) GO TO 70 + return + endif + + 80 CONTINUE + DO 90 I=1,11 + DATA(I:I)=' ' + 90 CONTINUE + + I = 1 + 10 CONTINUE + I = I+1 + + call gim_a_charac(key,cha,x,y) + +! write(90,*) 'key',key + + IF (KEY .EQ. 8) THEN + I = I-2 + GO TO 10 + ENDIF + IF(KEY .EQ. 13) GO TO 200 + DATA(I:I)=CHAR(KEY) + CALL GTEXT(4,I+20,DATA(I:I)) + 100 CONTINUE + GO TO 10 + 200 CONTINUE + + READ(DATA,5000,ERR=300) INUM + 5000 FORMAT(1X,I10) + + if(irecd .eq. 1) then + write(91,'(i7)') inum + endif + + RETURN + + 300 CONTINUE + CALL SYMBL(3.0,7.6,0.2,MES,0.0,30) + GO TO 80 + END + + + SUBROUTINE GETFPNA(FPN) + +!IPK APR94 + COMMON /RECOD/ IRECD,TSPC + + CHARACTER*11 DATA + character*50 cha + + CHARACTER*30 MES + DATA MES/'Error reading number, Reenter.'/ + + if(irecd .eq. 2) then + read(91,'(f7.2)') fpn + CALL INTRVL(TA,0) + 70 CALL INTRVL(TA,1) + IF(TA .LT. TSPC) GO TO 70 + return + endif + + 80 CONTINUE + DO 90 I=1,11 + DATA(I:I)=' ' + 90 CONTINUE + + I = 1 + 10 CONTINUE + I = I+1 + + call gim_a_charac(key,cha,x,y) + +! write(90,*) 'key',key + IF (KEY .EQ. 8) THEN + I = I-2 + GO TO 10 + ENDIF + IF(KEY .EQ. 13) GO TO 200 + DATA(I:I)=CHAR(KEY) + CALL GTEXT(4,I+20,DATA(I:I)) + 100 CONTINUE + GO TO 10 + 200 CONTINUE + + READ(DATA,5000,ERR=300) FPN + 5000 FORMAT(1X,F10.0) + + if(irecd .eq. 1) then + write(91,'(f7.2)') fpn + endif + + RETURN + + 300 CONTINUE + CALL SYMBL(3.0,7.6,0.2,MES,0.0,30) + GO TO 80 + END + + SUBROUTINE FLUSHWN + CALL FLUSH_SCREEN + RETURN + END + + subroutine gtext(j,i,cha) + character*1 cha + y=8.0-0.1*j + x=i*0.15 + call symbl(x,y,0.15,cha,0.0,1) + return + end + + subroutine fillem(ielem) + + USE BLK1MOD + INCLUDE 'TXFRM.COM' + dimension xvs(9),yvs(9) +! include 'BLK1.COM' + + ncn=ncorn(ielem) + if(ncn .gt. 5) go to 200 + N1=NOP(IELEM,1) + N2=NOP(IELEM,3) + + IF(IPW1 .EQ. 1) THEN + wd11=width(n1)/txscal + wd2=width(n2)/txscal + ELSE + BT1= & + CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ & + CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1) + BT2= & + CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ & + CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2) + H1=WIDEL-BT1 + H2=WIDEL-BT2 + CALL INTERPWLV(N1,H1,AR1,WR1,DWR1) + CALL INTERPWLV(N2,H2,AR2,WR2,DWR2) + WIDTH(N1)=WR1 + WIDTH(N2)=WR2 + IF(IPW1 .EQ. 2) THEN + WD11=WR1*WIDSCL/TXSCAL + WD2=WR2*WIDSCL/TXSCAL + ELSE + WD11=AR1*WIDSCL/TXSCAL + WD2=AR2*WIDSCL/TXSCAL + ENDIF + + ENDIF + + + IF(WD11 .GT. 0. .AND. WD2 .GT. 0.) THEN + X1= CORD(N1,1) + X2= CORD(N2,1) + Y1= CORD(N1,2) + Y2= CORD(N2,2) + ELDIR=ATAN2(Y2-Y1,X2-X1) + ELNORM=ELDIR-1.5708 + XVS(1)=X1+COS(ELNORM)*WD11/2. + XVS(4)=X1-COS(ELNORM)*WD11/2. + XVS(2)=X2+COS(ELNORM)*WD2/2. + XVS(3)=X2-COS(ELNORM)*WD2/2. + YVS(1)=Y1+SIN(ELNORM)*WD11/2. + YVS(4)=Y1-SIN(ELNORM)*WD11/2. + YVS(2)=Y2+SIN(ELNORM)*WD2/2. + YVS(3)=Y2-SIN(ELNORM)*WD2/2. + NPTS=4 + call polyfl(xvs,yvs,npts,14) + ENDIF + RETURN + + 200 xvs(1)=cord(nop(ielem,1),1) + yvs(1)=cord(nop(ielem,1),2) + + npts=1 + do 100 n=1,ncn + + if(n .ge. 9) go to 100 + if(nop(ielem,n) .eq. 0) go to 100 + npts=npts+1 + xvs(npts)=cord(nop(ielem,n),1) + yvs(npts)=cord(nop(ielem,n),2) + 100 continue + + call polyfl(xvs,yvs,npts,14) + return + end + + SUBROUTINE CLRSTP(y1,y2) + + REAL HSIZE + COMMON /SSIZE/ HSIZE + + dimension x(4),y(4) + x(1)=0. + x(2)=HSIZE + x(3)=HSIZE + x(4)=0. + y(1)=y1 + y(2)=y1 + y(3)=y2 + y(4)=y2 + call Rwhite + CALL fill_a_polygon(x,y,4) + call RBlue + return + end + + SUBROUTINE FILLEMC(IELEM,ICCT) + + USE BLK1MOD + INCLUDE 'BFILES.I90' + INCLUDE 'TXFRM.COM' + +! INCLUDE 'BLK1.COM' + DIMENSION X(4),Y(4) + DO 300 N=1,NCORN(IELEM),2 + M=NOP(IELEM,N) + IF(M .EQ. 0) THEN + GO TO 310 + ELSE + X((N+1)/2)=CORD(M,1) + Y((N+1)/2)=CORD(M,2) + if(i3dview .eq. 1) then + Y((N+1)/2)=Y((N+1)/2)+(WD(M)-VRTORIG)*COS(VANG/57.29578)/VRTSCAL + endif + NPOL=(N+1)/2 + ENDIF + 300 CONTINUE + 310 CONTINUE + IF(NCORN(IELEM) .GT. 5) THEN + CALL NWPEN(ICCT) + CALL fill_a_polygon(x,y,npol) + ELSE + N1=NOP(IELEM,1) + N2=NOP(IELEM,3) + IF(IPW1 .EQ. 1) THEN + wd11=width(n1)/txscal + wd2=width(n2)/txscal + ELSE + IF(NRIVCR1(N1) .EQ. 0 .AND. NRIVCR2(N1) .EQ. 0) RETURN + IF(NRIVCR1(N2) .EQ. 0 .AND. NRIVCR2(N2) .EQ. 0) RETURN + BT1= & + CRSDAT(NRIVCR1(N1),1,1)*WTRIVCR1(N1)+ & + CRSDAT(NRIVCR2(N1),1,1)*WTRIVCR2(N1) + BT2= & + CRSDAT(NRIVCR1(N2),1,1)*WTRIVCR1(N2)+ & + CRSDAT(NRIVCR2(N2),1,1)*WTRIVCR2(N2) + H1=WIDEL-BT1 + H2=WIDEL-BT2 + CALL INTERPWLV(N1,H1,AR1,WR1,DWR1) + CALL INTERPWLV(N2,H2,AR2,WR2,DWR2) + WIDTH(N1)=WR1 + WIDTH(N2)=WR2 + IF(IPW1 .EQ. 2) THEN + WD11=WR1*WIDSCL/TXSCAL + WD2=WR2*WIDSCL/TXSCAL + ELSE + WD11=AR1*WIDSCL/TXSCAL + WD2=AR2*WIDSCL/TXSCAL + ENDIF + + ENDIF + IF(WD11 .GT. 0. .AND. WD2 .GT. 0.) THEN + X1= CORD(N1,1) + X2= CORD(N2,1) + Y1= CORD(N1,2) + Y2= CORD(N2,2) + ELDIR=ATAN2(Y2-Y1,X2-X1) + ELNORM=ELDIR-1.5708 + X(1)=X1+COS(ELNORM)*WD11/2. + X(4)=X1-COS(ELNORM)*WD11/2. + X(2)=X2+COS(ELNORM)*WD2/2. + X(3)=X2-COS(ELNORM)*WD2/2. + Y(1)=Y1+SIN(ELNORM)*WD11/2. + Y(4)=Y1-SIN(ELNORM)*WD11/2. + Y(2)=Y2+SIN(ELNORM)*WD2/2. + Y(3)=Y2-SIN(ELNORM)*WD2/2. + NPOL=4 + CALL NWPEN(ICCT) + CALL fill_a_polygon(x,y,npol) + ENDIF + ENDIF + CALL RBlue + RETURN + END + + SUBROUTINE POLYG(AX,AY,NPT,N) + SAVE + DIMENSION AX(10),AY(10),BX(15),BY(15) + +! Duplicate numbers around AX to form long list +! + DO 200 I=1,NPT + AX(I+NPT)=AX(I) + AY(I+NPT)=AY(I) + 200 CONTINUE + +! Find a starting point that is on the page + + DO 250 I=1,NPT + CALL QUAD(AX(I),AY(I),ITS) + IF(ITS .EQ. 22) THEN + +! We have a starting point + + II=I + GO TO 350 + ENDIF + +! Keep looking + + 250 CONTINUE + +! No point on page then skip out + + RETURN + +! Loop to check each point and trim as required + + 350 CONTINUE + JJ=1 + BX(1)=AX(II) + BY(1)=AY(II) + XOLD=AX(II) + YOLD=AY(II) + DO 500 J=2,NPT+1 + II=II+1 + IF(ITS .EQ. 22) THEN + CALL QUAD(AX(II),AY(II),ITS) + IF(ITS .EQ. 22) THEN + +! still in copy over from A to B + + JJ=JJ+1 + BX(JJ)=AX(II) + BY(JJ)=AY(II) + XOLD=AX(II) + YOLD=AY(II) + ELSE + +! now out copy over boundary + + ITSN=22 + CALL TRIM(AX(II),AY(II),XOLD,YOLD,XB,YB,ITS,ITSN) + JJ=JJ+1 + BX(JJ)=XB + BY(JJ)=YB + XOLD=AX(II) + YOLD=AY(II) + ITS=IABS(ITS) + ENDIF + ELSE + +! WAS OUT + + CALL QUAD(AX(II),AY(II),ITSN) + IF(ITSN .EQ. 22) THEN + +! now in copy over point of return + + CALL TRIM(XOLD,YOLD,AX(II),AY(II),XB,YB,ITS,ITSN) + JJ=JJ+1 + BX(JJ)=XB + BY(JJ)=YB + +! Copy destination point + + JJ=JJ+1 + BX(JJ)=AX(II) + BY(JJ)=AY(II) + XOLD=AX(II) + YOLD=AY(II) + ITS=22 + ELSE + +! still out but could have been in for a time so test + + CALL TRIM(XOLD,YOLD,AX(II),AY(II),XB,YB,ITS,ITSN) + IF(ITS .LT. 0) THEN + +! no + + XOLD=AX(II) + YOLD=AY(II) + ITS=IABS(ITSN) + ELSEIF(ITSN .LT. 0) THEN + +! Temporarily in. Copy point of return + + JJ=JJ+1 + BX(JJ)=XB + BY(JJ)=YB + ITSN=-ITSN + ITS=22 + XOLD=XB + YOLD=YB + CALL TRIM(AX(II),AY(II),XOLD,YOLD,XB,YB,ITSN,ITS) + +! Now copy over point of exit + + JJ=JJ+1 + BX(JJ)=XB + BY(JJ)=YB + XOLD=AX(II) + YOLD=AY(II) + ITS=IABS(ITSN) + ENDIF + ENDIF + ENDIF + 500 CONTINUE + +! Record final number of points + + NPTS=JJ +!ipk sep 94 icl=mod(n,16)+1 + icl=mod(n-1,14) + call polyfl(bx,by,npts,icl) + RETURN + END + + SUBROUTINE DBDASHLN(XLIN,YLIN,NLINP,ICD) + +! Routine to draw a line with dashes + + REAL*8 XLIN(*),YLIN(*) + +! Work through points + + DO 200 K=1,NLINP + IF(K .EQ. 1) THEN + XCT=XLIN(K) + YCT=YLIN(K) + CALL PLOTT(XCT,YCT,3) + ELSEIF(ICD .EQ. 0) THEN + XCT=XLIN(K) + YCT=YLIN(K) + CALL PLOTT(XCT,YCT,2) + ELSE + +! Draw dashed line + + DASHNT=0.2/2.**ICD + SC1=(XLIN(K)-XLIN(K-1))**2 + SC2=(YLIN(K)-YLIN(K-1))**2 + SLEN=SQRT(SC1+SC2) + if(slen .lt. 0.1) then + XP=XLIN(K-1) + YP=YLIN(K-1) + CALL PLOTT(XP,YP,3) + XP=XLIN(K) + YP=YLIN(K) + CALL PLOTT(XP,YP,2) + cycle + endif + NDASH=IFIX(SLEN/DASHNT)+1 + XINC=(XLIN(K)-XLIN(K-1))/SLEN*DASHNT + YINC=(YLIN(K)-YLIN(K-1))/SLEN*DASHNT + XP=XLIN(K-1) + YP=YLIN(K-1) + DO 180 ND=1,NDASH + IF(ND .LT. NDASH) THEN + XP=XP+XINC + YP=YP+YINC + ELSE + XP=XLIN(K) + YP=YLIN(K) + ENDIF + IF(MOD(ND,2) .EQ. 1) THEN + CALL PLOTT(XP,YP,2) + ELSE + CALL PLOTT(XP,YP,3) + ENDIF + 180 CONTINUE + ENDIF + 200 CONTINUE + RETURN + END + + SUBROUTINE GETINT(ISW) + USE WINTERACTER +! +! + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + COMMON /RECOD/ IRECD,TSPC + + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout + CHARACTER*47 MESOUT,MESS(46) + + DATA MESS /'Enter node to search for',' Enter material type',& + 'Enter element to search for ',& + 'Enter number of layers ',& + 'Enter width ',& + 'Click mouse at end of line ',& + 'Enter number of nodes in line ',& + 'Click at corners of block ',& + 'Enter number of elements in x-dir ',& + 'Enter number of elements in y-dir ',& + 'Click to move boundaries or (q)uit to terminate',& + 'Click on elements','Enter starting list number ',& + 'Enter bed elevation','Click on node ',& + 'Click location of new node','Click at node to move ',& + 'Click at node to delete ',& + 'Type 1 to use all nodes else type 0 ',& + 'Enter element to select','Click location of node',& + 'Enter SS1','Enter SS2','Enter STRWID','Enter STORAGE ELEVATION',& + 'Click mouse on node','click mouse on next node',& + 'ERROR - Midside node selected - Select node again',& + 'Plotting a selected cross section',& + 'Click two locations to form a cross section',& + 'Click to adjust the cross section',& + 'Compute cross section parameters',& + 'Click a node for the cross section',& + 'Click two locations to form the width','Click to adjust the line','Click two locations to form left slope',& + 'Click two locations to form right slope','Click a location'& + ,'Enter storage elevation','Enter storage slope',& + 'Click at two locations to determine distance'& + ,'Enter continuity line number. Use 0 to end','Click at location to define register point'& + ,'Enter 1-D cross-section bed slope','Enter element frequency for search'& + ,'Enter no. of elements to reverse '/ + + + if(irecd .eq. 2) then + read(91,'(i7)') isw + CALL INTRVL(TA,0) + 70 CALL INTRVL(TA,1) + IF(TA .LT. TSPC) GO TO 70 + return + endif + + + if(isw .eq. 0) isw=1 + call wdialogload(IDD_GETINT) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_GETINT) + ierr=infoerror(1) + + CALL WDialogPutString(IDF_STRING1,MESS(NMESS)) + CALL WDialogPutInteger(IDF_INTEGER1,ISW) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) +! Branch depending on type of message. +! + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetInteger(IDF_INTEGER1,ISW) + RETURN + ELSE + RETURN + ENDIF + ENDDO + + RETURN + END + + SUBROUTINE GETFPN(FPN) + USE WINTERACTER +! +! + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + COMMON /RECOD/ IRECD,TSPC + + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout + CHARACTER*47 MESOUT,MESS(46) + + DATA MESS /'Enter node to search for',' Enter material type',& + 'Enter element to search for ',& + 'Enter number of layers ',& + 'Enter width ',& + 'Click mouse at end of line ',& + 'Enter number of nodes in line ',& + 'Click at corners of block ',& + 'Enter number of elements in x-dir ',& + 'Enter number of elements in y-dir ',& + 'Click to move boundaries or (q)uit to terminate',& + 'Click on elements','Enter starting list number ',& + 'Enter bed elevation','Click on node ',& + 'Click location of new node','Click at node to move ',& + 'Click at node to delete ',& + 'Type 1 to use all nodes else type 0 ',& + 'Enter element to select','Click location of node',& + 'Enter SS1','Enter SS2','Enter STRWID','Enter STORAGE ELEVATION',& + 'Click mouse on node','click mouse on next node',& + 'ERROR - Midside node selected - Select node again',& + 'Plotting a selected cross section',& + 'Click two locations to form a cross section',& + 'Click to adjust the cross section',& + 'Compute cross section parameters',& + 'Click a node for the cross section',& + 'Click two locations to form the width','Click to adjust the line','Click two locations to form left slope',& + 'Click two locations to form right slope','Click a location'& + ,'Enter storage elevation','Enter storage slope',& + 'Click at two locations to determine distance'& + ,'Enter continuity line number. Use 0 to end','Click at location to define register point'& + ,'Enter 1-D cross-section bed slope','Enter time interval for display of steps'& + ,'Enter tolerance for overlapping points'/ + if(irecd .eq. 2) then + read(91,'(f7.2)') fpn + CALL INTRVL(TA,0) + 70 CALL INTRVL(TA,1) + IF(TA .LT. TSPC) GO TO 70 + return + endif + + call wdialogload(IDD_GETFPN) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_GETFPN) + ierr=infoerror(1) + + CALL WDialogPutString(IDF_STRING1,MESS(NMESS)) + CALL WDialogPutReal(IDF_REAL1,FPN) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) +! Branch depending on type of message. +! + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetReal(IDF_REAL1,FPN) + RETURN + ELSE + RETURN + ENDIF + ENDDO + + RETURN + END + + subroutine drawcr(x,y,siz) + +! routine to draw x mark + + siz1=0.707/2.*siz + x1=x-siz1 + y1=y-siz1 + call plott(x1,y1,3) + x1=x+siz1 + y1=y+siz1 + call plott(x1,y1,2) + x1=x-siz1 + y1=y+siz1 + call plott(x1,y1,3) + x1=x+siz1 + y1=y-siz1 + call plott(x1,y1,2) + return + end + + SUBROUTINE GETREV(ISW,ILMIT) + USE WINTERACTER +! +! + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + INTEGER ISW,ILMIT + + + + call wdialogload(IDD_GETINTR) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_GETINTR) + ierr=infoerror(1) + + CALL WDialogPutCheckBox(IDF_check1,ILMIT) + CALL WDialogPutInteger(IDF_INTEGER1,ISW) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) +! Branch depending on type of message. +! + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetCheckBox(IDF_check1,ILMIT) + CALL WDialogGetInteger(IDF_INTEGER1,ISW) + RETURN + ELSE + ISW=-1 + RETURN + ENDIF + ENDDO + + RETURN + END + \ No newline at end of file diff --git a/src/TXFRM.COM b/src/TXFRM.COM new file mode 100644 index 0000000..f277e40 --- /dev/null +++ b/src/TXFRM.COM @@ -0,0 +1,4 @@ + REAL*8 XS,YS,TXSCAL + INTEGER IRGB + COMMON /TXFRM/ XS, YS, TXSCAL,IRGB + diff --git a/src/UTIL.F90 b/src/UTIL.F90 new file mode 100644 index 0000000..49eafde --- /dev/null +++ b/src/UTIL.F90 @@ -0,0 +1,1268 @@ +!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR CHNAGED ELEMENTS/NODES +!ipk last update Jan25 2001 fix when deleting center-mid expand ipsw +! last change ipk 12 July 1999 +! Last change: IPK 13 Jan 98 10:01 am +!ipk last update Nov 18 1997 +!ipk last updated Oct 23 1996 +!ipk last updated June 23 1996 +!ipk last updated Oct 25 1995 + SUBROUTINE GETELM(NEM) +! +! Routine to find first free element number +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + DO 200 J=NELAST,NE + IF(IMAT(J) .EQ. 0) THEN + NEM=J + NELAST=J + RETURN + ENDIF + 200 END DO + NE=NE+1 + NELAST=NE + NEM=NE + RETURN + END + +! + SUBROUTINE GETNOD(NPT) +! +! Routine to find first free node number +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + IF(NP .GT. 0) THEN + DO 200 J=NPLAST,NP + IF(INEW(J) .EQ. 0) THEN + NPT=J + NPLAST=J + RETURN + ENDIF + 200 END DO + ELSE + NP=0 + ENDIF + NP=NP+1 + NPLAST=NP + NPT=NP + IF(NPT .GT. MAXP) THEN + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Execution terminated, nodal limits exceeded. Backup written','LIMITS EXCEEDED') + CALL WRTOUT(0) + STOP + ENDIF +!IPK MAY03 + ICHG=0 + RETURN + END +! +!*********************************************************************** +! + SUBROUTINE DELETN(J) +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! +! Search for elements that attach to node J and remove them +! + DO 200 N=1,NE + IF(IMAT(N) .GT. 0) THEN + NCN=NCORN(N) + DO 180 K=1,NCN + IF(NOP(N,K) .EQ. J) THEN +!IPK APR94 + IF(IMAT(N) .LT. 901 .OR. IMAT(N) .GT. 903) THEN + IF(MOD(K,2) .EQ. 0) THEN + IF(NCN .NE. 2) THEN + IF(NCN .NE. 5 .OR. K .EQ. 2) THEN + NOP(N,K)=0 + GO TO 200 + ENDIF +!IPK APR94 END CHANGES + ENDIF + ENDIF + ENDIF + IMAT(N)=0 + XC(N)=VOID + YC(N)=VOID + NCORN(N)=0. + IF(N .LT. NELAST) NELAST=N + DO 170 KK=1,8 + NOP(N,KK)=0 + 170 CONTINUE + IESKP(N)=1 + GO TO 200 + ENDIF + 180 CONTINUE + ENDIF + 200 END DO + + +!IPK FEB08 TEST FOR LOWERING NE + DO N=NE,1,-1 + IF(IMAT(N) .NE. 0) THEN + JJ=N + GO TO 225 + ENDIF + ENDDO + 225 NE=JJ + +! +! Remove node now +! + CORD(J,1)=VOID + CORD(J,2)=VOID + XUSR(J) = VOID + YUSR(J) = VOID + INSKP(J)=1 + INEW(J) = 0 + WD(J)=-9999. + WIDTH(J)=0. + SS1(J)=0. + SS2(J)=0. + WIDS(J)=0. + IF(NPLAST .GT. J) NPLAST=J +!IPK FEB08 TEST FOR LOWERING NE + IF(J .EQ. NP) THEN + DO N=NP,1,-1 + IF(INEW(N) .NE. 0) THEN + JJ=N + GO TO 250 + ENDIF + ENDDO + 250 NP=JJ + ENDIF + + RETURN + END +! +! +!*********************************************************************** + + function lenstr(str) +! +! Find length of string (position of last non-blank character) +! + character*(*) str + + n = len(str) + lenstr = n + do 10 i=0,n-1 + idx = n-i + if (str(idx:idx) .ne. ' ') then + lenstr = idx + return + endif + 10 continue + return + END +! +!**************************************************************** +! + subroutine prox(x,y,npts,xx,yy,ipt,iflag,inskp,ibox) +! x=array of x node locations +! y=array of y node location +! npts= max number of nodes +! xx=x screen lpcation +! yy=y screen location +! iflag=character flag +! inskp=array telling nodes to skip +! ibox=any box checked + save + CHARACTER*80 TITLE + CHARACTER*24 HLABL + CHARACTER*1 ALABL(10) + CHARACTER*40 MPDUM + COMMON /BLKA1/ TITLE,HLABL,ALABL & + & ,MPDUM +!ipk oct 95 lines defining MPDUM added +! +!ipk jan01 expand IPSW + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout +! + integer*2 inskp(*) +!IPK MAY02 + REAL*8 x(*),y(*) + character*1 iflag +! +! if(ibox .eq. 0) then +! nbx=2 +! call boxr(nbx) +! endif +! +! Get location of cursor +! + 10 call xyloc(xscrn,yscrn,iflag,ibox) +! write(90,*) 'ibox,xscrn,yscrn',ibox,xscrn,yscrn,irmain +! write(90,7893) iflag + 7893 format(' iflag',a2) +! read(*,*) junk + if(irmain .eq. 1) return + if(ibox .eq. 10) then + iflag = 'q' + return + elseif(ibox .eq. 9) then + iflag = 'r' +! elseif(ibox .eq. 7) then +! iflag = 'a' + endif +! +! + if (iflag .eq. 'q') then + return + elseif(iflag .eq. 'r') then + return + elseif(iflag .ne. 'c') then + + ibox=0 + if(iflag .eq. 't') return + if(iflag .eq. 'l') return + if(iflag .eq. 'f') return + if(iflag .eq. 'e') return + if(iflag .eq. 'a') return + if(iflag .eq. 'j') return + if(iflag .eq. 'z') return + if(iflag .eq. 'n') return + if(iflag .eq. 'g') return + if(iflag .eq. 'h') return +!ipk oct96 add line below + if(iflag .eq. 'b') return + if(iflag .eq. 'U') return +! + if(iflag .eq. 'm') go to 12 +!ipk jan98 write(*,*) char(7),char(7) + go to 10 + endif +! +! Compare to coordinates + 12 d = 1.E+20 + do 20 i=1,npts +!! write(*,*) 'i,npts',i,npts,inskp(i),x(i),y(i) + if(inskp(i) .ne. 0) go to 20 + dist = sqrt( (xscrn-x(i))**2 + (yscrn-y(i))**2) + if (dist .lt. d) then + d = dist + ipt = i + xx = x(i) + yy = y(i) + endif + 20 continue + return +! +! + END +!*********************************************************** + subroutine zoom +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! + dimension xot(5),yot(5) + character*1 iflag,ans +! +!ipk jun96 add zoomj + character*36 zoomh,zoomj,IFLAG32 + character*22 zoomi +!ipk jan98 + CHARACTER*80 lind + data zoomh/' Zooming, click at diagonal corners'/ + data zoomi/' Click left if size OK'/ +!ipk jun96 add zoomj + data zoomj/' Double click, click second point '/ +! +! + 80 CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomh,0.,36) + +!jan09 xcc = 5.00 + xcc = 5.00*hsize/10. + ycc = 3.5 +! + 100 continue +! +! Get cursor location +! + CALL XYLOC(xscrn,yscrn,iflag,ibox) + IF(IRMAIN .EQ. 1) RETURN +! + if (iflag .eq. 'q') return +! + xp = xmin + xscrn + yp = ymin + yscrn + if(iflag .eq. 'c') then +! +! This option is creating an inset window +! +!ipk jun96 add new path + 120 continue + CALL XYLOC(xscrn1,yscrn1,iflag,ibox) + IF(IRMAIN .EQ. 1) RETURN + if(iflag .eq. 'c') then +! +! Look for a screen size +! + xsiz=abs(xscrn1-xscrn) + ysiz=abs(yscrn1-yscrn) +!ipk jun96 test for zero sizes + if(xsiz .lt. 0.001 .or. ysiz .lt. 0.001) then + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomj,0.,36) + go to 120 + endif + if(xscrn1 .lt. xscrn) xscrn=xscrn1 + if(yscrn1 .lt. yscrn) yscrn=yscrn1 + fact=HSIZE/xsiz +!jan09 if(7./ysiz .lt. fact) fact=7./ysiz + if(7.5/ysiz .lt. fact) fact=7.5/ysiz + xot(1)=xscrn + xot(5)=xscrn + yot(1)=yscrn + yot(5)=yscrn + yot(2)=yscrn + xot(4)=xscrn +!jan09 xscrn=xscrn+5./fact +!jan09 yscrn=yscrn+3.5/fact + xscrn=xscrn+xcc/fact + yscrn=yscrn+3.75/fact +!jan09 xot(2)=xscrn+5./fact + xot(2)=xscrn+xcc/fact + xot(3)=xot(2) +!jan09 yot(3)=yscrn+3.5/fact + yot(3)=yscrn+3.75/fact + yot(4)=yot(3) + call DASHLN(xot,yot,5,1) + xp=xscrn + yp=yscrn + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomi,0.,22) + CALL XYLOC(xscrn1,yscrn1,iflag,ibox) + IF(IRMAIN .EQ. 1) RETURN + if(iflag .ne. 'c') go to 80 + go to 280 +! +! pan right +! + else if(iflag .eq. 'r') then + fact=1.0 +!jan09 xscrn=xscrn+5.0 + xscrn=xscrn+hsize/2. + xp=xscrn + yp=yscrn +! +! pan left +! + else if(iflag .eq. 'l') then + fact=1.0 +!jan09 xscrn=xscrn-5.0 + xscrn=xscrn-hsize/2. + xp=xscrn + yp=yscrn + endif +! +! redraw at half size +! + elseif(iflag .eq. 'r') then + fact = 0.500 +! +! user controlled redraw +! + else + call setd(23) + write (*,*) ' factor ' + read(*,*) fact + call setd(2) + endif + do 250 i=1,np + if(cord(i,1) .gt. void) then + inskp(i)=0 + endif + 250 continue + do 270 i=1,ne + if(imat(i) .gt. 0) then + ieskp(i)=0 + endif + 270 continue + 280 continue + pscale = pscale/fact + xmino=xmin + ymino=ymin +! + xmin = xp - (xcc*pscale) + ymin = yp - (ycc*pscale) +! + if(iflag .eq. 'c') then +! CALL PLOTS(0) +!ipk nov97 add (0) + CALL PLOTOT(0) + return + elseif(iflag .eq. 'r') then +! CALL PLOTS(0) +!ipk nov97 add (0) + CALL PLOTOT(0) + return + elseif(iflag .eq. 'l') then +! CALL PLOTS(0) +!ipk nov97 add (0) + CALL PLOTOT(0) + return + endif + call setd(23) + write(lind,*) 'Illegal zoom press return to continue' + call symbl & + & (1.1,7.1,0.20,LIND,0.0,80) + ndig=1 + CALL GTCHARX(IFLAG32,NDIG,5.0,7.6) +!ipk jan98 write(*,*) 'O.K. to plot at this scale? (y)es .or. (n)o' +!ipk jan98 write(*,*) 'Note n means redraw old plot' +!ipk jan98 read(*,'(a)') ans +!ipk jan98 call setd(2) +!ipk jan98 if (ans .eq. 'y') then +! CALL PLOTS(0) +!ipk nov97 add (0) + CALL PLOTOT(0) + return +!ipk jan98 endif + pscale = pscale * fact + xmin=xmino + ymin=ymino +! CALL PLOTS(0) +!ipk nov97 add (0) + CALL PLOTOT(0) + return + END +!*********************************************************** + SUBROUTINE DELETM(ISW) +! + USE BLK1MOD + + INCLUDE 'BFILES.I90' +! INCLUDE 'BLK1.COM' +! +! COMMON /ICN1/ ICN(MAXP) + DIST(N1,N2)=SQRT((CORD(N1,1)-CORD(N2,1))**2 & + & +(CORD(N1,2)-CORD(N2,2))**2) + DO 150 J=1,MAXP + ICN(J)=0 + 150 END DO + IF(ISW .EQ. 2) GO TO 650 +! First sort out the potential midsides +! Note that transition elements caues a problem +! Find these first + IRDONE=0 + DO 200 N=1,NE + IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN +! +! We have a transition mark node number as if it were corner +! + ICN(NOP(N,3))=1 + ICN(NOP(N,1))=2 + ICN(NOP(N,4))=2 + ICN(NOP(N,5))=2 + ELSE + if(imat(n) .eq. 0) then + ncorn(n)=0 + go to 200 + endif +! +! Store ICN = 2 for corner nodes +! + NCN=NCORN(N) +!IPKOCT93 IF(IMAT(N) .GT. 900) THEN + IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN + MST=1 + ELSE + MST=2 + ENDIF + DO 180 M=1,NCN,MST + ICN(NOP(N,M))=2 + 180 CONTINUE + ENDIF + 200 END DO +! +! test ISW +! if isw=0 then delete all midsides except at transition +! if isw=1 then delete only midsides that are truely in the middle +! + IF(ISW .EQ. 0) THEN + DO 400 N=1,NE +!IPKOCT93 IF(IMAT(N) .LT. 901) THEN + IF(IMAT(N) .LT. 901 .OR. IMAT(N) .GT. 903) THEN + IF(NCORN(N) .EQ. 5) THEN + NCN=3 + ELSE + NCN=NCORN(N) + ENDIF + + DO 350 M=2,NCN,2 + J=NOP(N,M) +!SEP93 IPK + IF(J .EQ. 0) GO TO 350 +!SEP93 IPK + IF(ICN(J) .NE. 1) THEN + NOP(N,M)=0 + IF(ICN(J) .EQ. 0) THEN +! +! Remove node now +! + CORD(J,1)=VOID + CORD(J,2)=VOID + XUSR(J) = VOID + YUSR(J) = VOID + INSKP(J)=1 + INEW(J) = 0 + WD(J)=-9999. + WIDTH(J)=0. + SS1(J)=0. + SS2(J)=0. + WIDS(J)=0. +!IPK MAY03 + ICHG=0 + IF(NPLAST .GT. J) NPLAST=J + ENDIF + ENDIF + 350 CONTINUE + ENDIF + 400 CONTINUE + ELSE + DO 600 N=1,NE + IF(IMAT(N) .LT. 901) THEN + IF(NCORN(N) .EQ. 5) THEN + NCN=3 + ELSE + NCN=NCORN(N) + ENDIF + DO 550 M=2,NCN,2 + J1=M-1 + IF(M .EQ. NCN) THEN + J2=1 + ELSE + J2=M+1 + ENDIF + J=NOP(N,M) +!ipk jul99 + if(j .gt. 0) then +!ipk jan01 + IF(INEW(J) .EQ. 0 .or. inew(j) .eq. 2) THEN + inew(j)=0 + NOP(N,M)=0 + GO TO 550 + ENDIF + else + go to 550 + endif + ! +! Test for distance separation of midside node +! + XMID=(CORD(NOP(N,J1),1)+CORD(NOP(N,J2),1))/2. + YMID=(CORD(NOP(N,J1),2)+CORD(NOP(N,J2),2))/2. + DM=SQRT((XMID-CORD(J,1))**2+(YMID-CORD(J,2))**2) + DL=DIST(J1,J2) + IF(DM .LT. 0.005*DL) THEN + IF(ICN(J) .NE. 1) THEN + NOP(N,M)=0 + IF(ICN(J) .EQ. 0) THEN +! +! Remove node now +! + CORD(J,1)=VOID + CORD(J,2)=VOID + XUSR(J) = VOID + YUSR(J) = VOID + INSKP(J)=1 + INEW(J) = 0 + WD(J)=-9999. + WIDTH(J)=0. + SS1(J)=0. + SS2(J)=0. + WIDS(J)=0. +!IPK MAY03 + ICHG=0 + IF(NPLAST .GT. J) NPLAST=J + ENDIF + ENDIF + ENDIF + 550 CONTINUE + ENDIF + 600 CONTINUE + ENDIF +!IPK FEB08 RESET NP + + DO J=NP,1,-1 + IF(INEW(J) .NE. 0) THEN + JJ=J + GO TO 625 + ENDIF + ENDDO + 625 CONTINUE + NP=JJ + + RETURN +!- +!-.....FIND MISSING NODE NUMBERS..... +!- + 650 CONTINUE + DO 700 I=1,MAXP + 700 ICN(I) = 0 + DO 725 J = 1, NE + IF( IMAT(J) .EQ. 0 ) GO TO 725 + DO 720 K = 1, 8 + IF( NOP(J,K) .LE. 0) GOTO 720 + ICN(NOP(J,K))=999 + 720 CONTINUE + 725 END DO +! +! Remove nodes +! + DO 800 J=1,NP + IF(ICN(J) .EQ. 0) THEN + CORD(J,1)=VOID + CORD(J,2)=VOID + XUSR(J) = VOID + YUSR(J) = VOID + INSKP(J)=1 + INEW(J) = 0 + WD(J)=-9999. + WIDTH(J)=0. + SS1(J)=0. + SS2(J)=0. + WIDS(J)=0. + IF(NPLAST .GT. J) NPLAST=J + !IPK MAY03 + ICHG=0 + ENDIF + 800 END DO + +!IPK FEB08 RESET NP + + DO J=NP,1,-1 + IF(INEW(J) .NE. 0) THEN + JJ=J + GO TO 900 + ENDIF + ENDDO + 900 CONTINUE + NP=JJ + RETURN + END +!**************************************************************** +! + subroutine prox2(x,y,npts,xx,yy,ipt,xx2,yy2,ipt2,iflag,inskp,ibox) + save + CHARACTER*80 TITLE + CHARACTER*24 HLABL + CHARACTER*1 ALABL(10) + CHARACTER*40 MPDUM + COMMON /BLKA1/ TITLE,HLABL,ALABL ,MPDUM +!ipk oct 95 lines defining MPDUM added +! +!ipk jan01 expand IPSW + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout +! + integer*2 inskp(*) +!IPK MAY02 + REAL*8 x(*),y(*) + character*1 iflag +! +! if(ibox .eq. 0) then +! nbx=2 +! call boxr(nbx) +! endif +! +! Get location of cursor +! + 10 call xyloc(xscrn,yscrn,iflag,ibox) + if(irmain .eq. 1) return + if(ibox .eq. 10) then + iflag = 'q' + return + elseif(ibox .eq. 9) then + iflag = 'r' + endif +! +! + if (iflag .eq. 'q') then + return + elseif(iflag .eq. 'r') then + return + elseif(iflag .ne. 'c') then + ibox=0 + if(iflag .eq. 't') return + if(iflag .eq. 'l') return + if(iflag .eq. 'f') return + if(iflag .eq. 'e') return + if(iflag .eq. 'a') return + if(iflag .eq. 'j') return + if(iflag .eq. 'z') return + if(iflag .eq. 'n') return + if(iflag .eq. 'g') return + if(iflag .eq. 'h') return +! + if(iflag .eq. 'm') go to 12 +!ipk jan98 write(*,*) char(7),char(7) + go to 10 + endif +! +! Compare to coordinates +! + ipt2=0 + 12 d = 1.E+20 + do 20 i=1,npts + if(inskp(i) .ne. 0) go to 20 + dist = sqrt( (xscrn-x(i))**2 + (yscrn-y(i))**2) + if (dist .lt. d) then + if(i .ne. ipt) then + xx2=x(i) + yy2=y(i) + ipt2=i + d = dist + go to 20 + endif + endif + 20 continue + return +! + END + SUBROUTINE CVF(FPN,IDEC,NUMSTR,NUMC) +! +! Routine to convert number to array and prepare for plotting +! + CHARACTER*36 NUMSTR + CHARACTER*36 FMT,FMT1 + + IF(FPN .NE. 0.) THEN + if(idec .eq. 1) then + NDIG = ALOG10(ABS(FPN)+0.05) + elseif(idec .eq. 2) then + NDIG = ALOG10(ABS(FPN)+0.005) + elseif(idec .eq. 3) then + NDIG = ALOG10(ABS(FPN)+0.0005) + else + NDIG = ALOG10(ABS(FPN)+0.50005) + endif + ELSE + NDIG = 0 + ENDIF +! +! Check for Numbers than 10 +! + IF(NDIG .LE. 0) THEN +! +! Check for negative numbers +! + IF(FPN .LT. 0.) THEN +! +! Check for integer plot +! + IF(IDEC .LT. 0) THEN + NUMC = 2 + IF(FPN .EQ. 0) NUMC=1 + ELSE +! +! This is a negative number less than 10 +! + NUMC = IDEC+3 + ENDIF +! +! Check for integer plot probably a zero +! + ELSEIF(IDEC .LT. 0) THEN + NUMC = 1 + ELSE +! +! This is a positive number less than 1 +! + NUMC = IDEC+2 + ENDIF +! +! Now check numbers of magnitude greater than 1 +! + ELSEIF(FPN .LT. 0.) THEN +! +! Check for integer plot. A negative number +! + IF(IDEC .LT. 0) THEN + NUMC = NDIG+2 + ELSE +! +! This is a negative number smaller than -1. +! + NUMC = IDEC+NDIG+3 + ENDIF + +! +! Check for integer plot. A positive number +! + ELSEIF(IDEC .LT. 0) THEN + NUMC = NDIG+1 + ELSE +! +! This is a positive number greater than 1. +! + NUMC = IDEC+NDIG+2 + ENDIF + IF(IDEC .LT. 0) THEN + IF(FPN .LT. 0.) THEN + NUM = FPN-0.5 + ELSE + NUM = FPN+0.5 + ENDIF + WRITE(FMT,97) NUMC + WRITE(NUMSTR,FMT) NUM + 97 FORMAT('(I',i1,')') + ELSE +!ipk mar95 fix bug that causes error when IDEC >12 + if(idec .gt. 9) then + write(fmt1,99) numc,idec + 99 format('(F',i2,'.',i2,')') + else + WRITE(FMT1,98) NUMC,IDEC + 98 FORMAT('(F',i2,'.',i1,')') + endif + WRITE(NUMSTR,FMT1) FPN + ENDIF + RETURN + END +!ipk oct96 routines below added + + SUBROUTINE GTCHARX(DATA,NDIG,XLC,YLC) + COMMON /RECOD/ IRECD,TSPC + + CHARACTER*32 DATA + if(irecd .eq. 2) then + read(91,'(A32)') DATA + CALL INTRVL(TA,0) + 70 CALL INTRVL(TA,1) + IF(TA .LT. TSPC) GO TO 70 + return + endif + + 80 CONTINUE + DO 90 I=1,NDIG + DATA(I:I)=' ' + 90 END DO +! + I = 1 + 10 CONTINUE + I = I+1 + call keybrd(key) + IF (KEY .EQ. 8) THEN + I = I-2 + xp=XLC+(i+1)*0.20 + call drblk(xp,YLC+0.23,0.20,0.30,-11) + GO TO 10 + ENDIF + IF(KEY .EQ. 13 .OR. I .EQ. ndig+2) GO TO 200 + if(key .eq. 1072 .or. key .eq. 1075 .or. key .eq. 1077 .or.& + & key .eq. 1080) go to 200 + DATA(I-1:I-1)=CHAR(KEY) + xp=XLC+i*0.20 + call drblk(xp,YLC+0.23,0.20,0.30,-11) + call rblue + call symbl(xp,YLC,0.20,data(i-1:i-1),0.0,1) + 100 CONTINUE + GO TO 10 + 200 CONTINUE + NDIG=I-2 + call rblue + RETURN +!ipk mar94 add + END + SUBROUTINE DRBLK(XS,YS,XL,YL,ICOL) + DIMENSION X(4),Y(4) + X(1)=XS + X(2)=XS + X(3)=XS+XL + X(4)=XS+XL + Y(1)=YS + Y(2)=YS-YL + Y(3)=Y(2) + Y(4)=YS +! WRITE(90,*) 'GOING TO POLYFL',X,Y,ICOL + CALL POLYFL(X,Y,4,ICOL) + call rblue + RETURN + END + SUBROUTINE GTFPNX(FPN,NDEC,NDIG,XLC,YLC) + CHARACTER*11 DATA + CHARACTER*30 MES + + REAL HSIZE + COMMON /SSIZE/ HSIZE + + DATA MES/'Error reading number, Reenter.'/ + 80 CONTINUE + DO 90 I=1,11 + DATA(I:I)=' ' + 90 END DO +! + I = 1 + NDEC=-2 + 10 CONTINUE + I = I+1 + call keybrd(key) +! WRITE(90,*) 'BACK FROMKEYBRD',KEY,I + IF (KEY .EQ. 8) THEN + I = I-2 + xp=xlc+(i+1)*0.20 + call drblk(xp,ylc+0.23,0.20,0.30,13) + GO TO 10 + ENDIF + IF(KEY .EQ. 46) THEN + NDEC=-1 + ENDIF + IF(KEY .EQ. 13) GO TO 200 + if(key .eq. 1072 .or. key .eq. 1075 .or. key .eq. 1077 .or.& + & key .eq. 1080) go to 200 + IF(NDEC .GE. -1) NDEC=NDEC+1 + DATA(I:I)=CHAR(KEY) +! WRITE(90,'(A)') ' GETTING CHAR',DATA(I:I) + xp=xlc+i*0.20 +! WRITE(90,*) 'GOING TO DRBLK',XP,YLC + call drblk(xp,ylc+0.23,0.20,0.30,-11) +! WRITE(90,*) 'BACK FROM DRBLK' + call rblue + call symbl(xp,ylc,0.20,data(i:i),0.0,1) + 100 CONTINUE + GO TO 10 + 200 CONTINUE + NDIG=I-2 + READ(DATA,5000,ERR=300) FPN + 5000 FORMAT(1X,F10.0) + call rblue + RETURN + 300 CONTINUE + CALL SYMBL(3.0,1.73,0.20,MES,0.0,30) + GO TO 80 + END + SUBROUTINE GTINTX(INUM,NDIG,XLC,YLC) + CHARACTER*11 DATA + CHARACTER*30 MES + DATA MES/'Error reading integer, Reenter'/ + 80 CONTINUE + DO 90 I=1,11 + DATA(I:I)=' ' + 90 END DO +! + I = 1 + 10 CONTINUE + I = I+1 + call keybrd(key) + IF (KEY .EQ. 8) THEN + I = I-2 + xp=xlc+(i+1)*0.20 + call drblk(xp,ylc+0.00,0.20,0.32,-11) + GO TO 10 + ENDIF + IF(KEY .EQ. 13) GO TO 200 + if(key .eq. 1072 .or. key .eq. 1075 .or. key .eq. 1077 .or.& + & key .eq. 1080) go to 200 + DATA(I:I)=CHAR(KEY) + xp=xlc+i*0.20 + call drblk(xp,ylc+0.00,0.20,0.32,-11) + call rblue + call symbl(xp,ylc-0.20,0.20,data(i:i),0.0,1) + 100 CONTINUE + GO TO 10 + 200 CONTINUE + NDIG=I-2 + READ(DATA,5000,ERR=300) INUM + 5000 FORMAT(1X,I10) + call rblue + RETURN + 300 CONTINUE + CALL SYMBL(3.0,1.73,0.20,MES,0.0,30) + GO TO 80 + END + SUBROUTINE WRTBOX(IDELV) + dimension x(5),y(5) + CHARACTER*6 label + COMMON /SSIZE/ HSIZE + DATA label/'(e)lsw'/ +! +! Draw box around selections with colour +! + Y(1)=7.5 + Y(2)=7.5 + Y(3)=7.995 + Y(4)=7.995 + Y(5)=7.5 + X(1)=6.0*HSIZE/10. + X(2)=7.0*HSIZE/10. + X(3)=7.0*HSIZE/10. + X(4)=6.0*HSIZE/10. + X(5)=6.0*HSIZE/10. + IF(IDELV .EQ. 1) THEN + IBLK=12 + ELSE + IBLK= 8 + ENDIF + CALL POLYFL(X,Y,5,IBLK) + CALL RBLACK + CALL PLOTT(X(1),Y(1),3) + CALL PLOTT(X(2),Y(2),2) + CALL PLOTT(X(3),Y(3),2) + CALL PLOTT(X(4),Y(4),2) + CALL PLOTT(X(1),Y(1),2) + call symbl(6.02*hsize/10.,7.6,0.20,label,0.0,6) + RETURN + END + + SUBROUTINE UNDOACT + + USE BLK1MOD +! INCLUDE '!BLK1.COM' + +! IF(NEUNDO .GT. 0) THEN +! DO N=1,NEUNDO +! J=IELDEL(N) +! CALL DELTEL(J) +! ENDDO +! ELSE +! RETURN +! ENDIF + IF(NPUNDO .GT. 0) THEN + DO N=1,NPUNDO + J=NODDEL(N) + if(j .gt. 0) CALL DELETN(J) + ENDDO + ENDIF + NPUNDO=0 + NEUNDO=0 + WRITE(90,*) 'NESAV,NEFSAV',NESAV,NEFSAV,NE,NENTRY + IF(NESAV .GT. 0) THEN + DO J=1,NESAV + DO K=1,8 + NOP(J,K)=NOPSV(J,K) + ENDDO + NCN = 2 + IF (NOP(J,3) .NE. 0) NCN = 3 + IF (NOP(J,4) .NE. 0) NCN = 4 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5 + IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6 + IF (NOP(J,6) .NE. 0) NCN = 6 + IF (NOP(J,7) .NE. 0) NCN = 8 + NCORN(J) = NCN + IESKP(J) = 0 + IMAT(J)=IMATSV(J) + ENDDO + NE=NESAV + ENDIF + NESAV=0 + IF(NENTRY .GT. NEFSAV) THEN + IF(NEFSAV .GT. 0) THEN + DO N=1,NEFSAV + DO M=1,3 + NEF(N,M)=NEFSV(N,M) + ENDDO + ENDDO + ENDIF + NENTRY=NEFSAV + ENDIF + NEFSAV=NENTRY + CALL PLOTOT(-1) + CALL HEDR + RETURN + END + + SUBROUTINE GETXC + + USE BLK1MOD + + DO J=1,NE + XXC=0. + YYC=0. + IF(IMAT(J) .EQ. 0) GO TO 50 + NCN = NCORN(J) + IF(NCN .EQ. 9) THEN + NCNR=8 + ELSE + NCNR=NCN + ENDIF + DO 25 K=1,NCNR + N = NOP(J,K) +! + IF (N .EQ. 0 .OR. CORD(N,1) .LT. VDX) GOTO 25 +! ! + IF (NCN .NE. 5 .OR. K .LT. 5) THEN + IF (MOD(K,2) .EQ. 1) THEN + XXC = XXC + CORD(N,1) + YYC = YYC + CORD(N,2) + ENDIF + ENDIF + 25 END DO + + IF(NCN .LT. 9) THEN + XC(J) = 2.*XXC/NCN + YC(J) = 2.*YYC/NCN + ELSE + XC(J)= CORD(NOP(J,9),1) + YC(J)= CORD(NOP(J,9),2) + ENDIF + 50 CONTINUE + ENDDO + RETURN + END + + SUBROUTINE DELETEM + USE WINTERACTER + USE BLK1MOD + SAVE + +! implicit none + + include 'd.inc' + + INCLUDE 'TXFRM.COM' + + INCLUDE 'BFILES.I90' + + CHARACTER*1 IFLAG + CHARACTER*24 MESSAG + INTEGER NTYPR,ITIMETHRU + DATA MESSAG/'GET ELEMENT TYPE NUMBER '/ + + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + call wdialogload(IDD_GETINT) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_GETINT) + ierr=infoerror(1) + NFD=0 + CALL WDialogPutString(IDF_STRING1,MESSAG) + CALL WDialogPutInteger(IDF_INTEGER1,NFD) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) +! Branch depending on type of message. +! + DO + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetInteger(IDF_INTEGER1,NFD) + GO TO 200 + ENDIF + ENDDO +200 CONTINUE + IF(NFD .EQ. 0) RETURN +! ASK FOR ELEMENT NUMBER +! LOOP ON ELEMENTS DROPPING ELEMENTS OF GIVEN TYPE + DO N=1,NE + IF(IMAT(N) .EQ. NFD) THEN + DO K=1,8 + NOP(N,K)=0 + ENDDO + IMAT(N)=0 + NCORN(N)=0 + ENDIF + ENDDO + RETURN + END + +! +!**************************************************************** +! + subroutine proxel(x,y,npts,xx,yy,ipt,iflag,inskp,ibox,neac) +! x=array of x node locations +! y=array of y node location +! npts= max number of nodes +! xx=x screen lpcation +! yy=y screen location +! iflag=character flag +! inskp=array telling nodes to skip +! ibox=any box checked + save + CHARACTER*80 TITLE + CHARACTER*24 HLABL + CHARACTER*1 ALABL(10) + CHARACTER*40 MPDUM + COMMON /BLKA1/ TITLE,HLABL,ALABL & + & ,MPDUM +!ipk oct 95 lines defining MPDUM added +! +!ipk jan01 expand IPSW + COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout +! + integer*2 inskp(*) + INTEGER neac(*) +!IPK MAY02 + REAL*8 x(*),y(*) + character*1 iflag +! +! if(ibox .eq. 0) then +! nbx=2 +! call boxr(nbx) +! endif +! +! Get location of cursor +! + 10 call xyloc(xscrn,yscrn,iflag,ibox) +! write(90,*) 'ibox,xscrn,yscrn',ibox,xscrn,yscrn,irmain +! write(90,7893) iflag + 7893 format(' iflag',a2) +! read(*,*) junk + if(irmain .eq. 1) return + if(ibox .eq. 10) then + iflag = 'q' + return + elseif(ibox .eq. 9) then + iflag = 'r' +! elseif(ibox .eq. 7) then +! iflag = 'a' + endif +! +! + if (iflag .eq. 'q') then + return + elseif(iflag .eq. 'r') then + return + elseif(iflag .ne. 'c') then + + ibox=0 + if(iflag .eq. 't') return + if(iflag .eq. 'l') return + if(iflag .eq. 'f') return + if(iflag .eq. 'e') return + if(iflag .eq. 'a') return + if(iflag .eq. 'j') return + if(iflag .eq. 'z') return + if(iflag .eq. 'n') return + if(iflag .eq. 'g') return + if(iflag .eq. 'h') return +!ipk oct96 add line below + if(iflag .eq. 'b') return + if(iflag .eq. 'U') return +! + if(iflag .eq. 'm') go to 12 +!ipk jan98 write(*,*) char(7),char(7) + go to 10 + endif +! +! Compare to coordinates + 12 d = 1.E+20 + do ii=1,8 + i=neac(ii) + if(neac(ii) .eq. 0) cycle +!! write(*,*) 'i,npts',i,npts,inskp(i),x(i),y(i) + if(inskp(i) .ne. 0) cycle + dist = sqrt( (xscrn-x(i))**2 + (yscrn-y(i))**2) + if (dist .lt. d) then + d = dist + ipt = i + xx = x(i) + yy = y(i) + endif + enddo + return +! +! + END + \ No newline at end of file diff --git a/src/WINNEW.F90 b/src/WINNEW.F90 new file mode 100644 index 0000000..af36efb --- /dev/null +++ b/src/WINNEW.F90 @@ -0,0 +1,690 @@ +!IPK LAST UPDATE SEP 23 2015 REVISE org NUMBERS + SUBROUTINE get_label(dlin,title) + + use winteracter + + implicit none + + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + INTEGER :: ITYPE,ierr + + character*40 dlin,title + write(90,'(a)') 'dlin',dlin + write(90,'(a)') 'lind',title + + call wdialogload(IDD_DIALOG1) + ierr=infoerror(1) + + write(90,'(a)') 'dlin-0',dlin + write(90,'(a)') 'lind-0',title + CALL WDialogPutString(idf_label5,dlin) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_DIALOG1) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + + + do +!! CALL WMessage(ITYPE,MESSAGE) +! +! Branch depending on type of message. +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetstring(idf_string24,title) + write(90,'(a)') 'dlin-1',dlin + write(90,'(a)') 'lind-1',title + return + endif + return + enddo + + return + + end + +! ---------------------------------------------------------------------------- + + subroutine labl(x,y,llen,ht,string) + USE WINTERACTER + character*(*) string + integer llen + character*80 outstring + data rsclx,rscly/100.,100./ + DO i=1,llen + outstring(i:i)=string(i:i) + ENDDO + + ix=x*rsclx + iy=y*rscly + CALL gim_a_string(ix,iy,ht,outstring,llen) + RETURN + end + + SUBROUTINE gim_a_string(ix,iy,ht,outstring,lenth) + USE WINTERACTER + CHARACTER*(*) OUTSTRING + CALL WGrTextFont(102,0,ht*0.0133333,ht*0.04) +! CALL IGrCharSet(' ') +! CALL IGrCharSize(ht,ht) + call WGrTextOrientation(0) +! CALL IGrCharJustify('L') + x=ix/100. + y=iy/100. + CALL WGrTextString(x,y,outstring(:lenth)) + +! CALL IGrCharOut(x,y,outstring(:lenth)) + RETURN + END SUBROUTINE + + SUBROUTINE change_color(icl) + USE WINTERACTER + DIMENSION ICOLRS(0:16) + + data icolrs/224,0,160,175,159,112,128,96,80,& + 48,63,24,16,47,223,7,224/ +! 240 + ICV=ICOLRS(mod(ICL,16)) + CALL IGrcolourN(ICV) + RETURN + END SUBROUTINE + + SUBROUTINE fill_a_polygon(x,y,npts) + USE WINTERACTER + dimension x(*),y(*) + CALL IGrFillPattern(4,0,0) + call IGrPolygonComplex(x,y,npts) + RETURN + END SUBROUTINE + + SUBROUTINE gim_a_charac(key,cha,x,y) + USE WINTERACTER + CHARACTER*(*) cha + INTEGER :: ITYPE, KEY + INTEGER, PARAMETER :: ID_EXIT = 40002 + + TYPE(WIN_MESSAGE) :: MESSAGE + + 100 CONTINUE + + CALL WMessage(ITYPE, MESSAGE) + SELECT CASE (ITYPE) + CASE (KeyDown) ! Key pressed + KEY = MESSAGE%VALUE1 + MOUSEX = MESSAGE%X + MOUSEY = MESSAGE%Y + +! check key status + if(KEY .lt. 127) then + cha=char(KEY) + go to 250 + else + go to 100 + endif + CASE (MenuSelect) ! Menu item selected + SELECT CASE (MESSAGE%VALUE1) + CASE (ID_EXIT) + call WindowClose + END SELECT + END SELECT + GO TO 100 + 250 CONTINUE + RETURN + END SUBROUTINE + + SUBROUTINE clear_screen + USE WINTERACTER + INCLUDE 'TXFRM.COM' + TYPE (WIN_FONT) :: FONT +! FONT%IBCOL = TextWhite +! CALL WindowFont(FONT) +! IRGB = WRGB(220,220,220) + CALL WindowClear(rgb=irgb) ! clear to yellow + RETURN + END SUBROUTINE + + SUBROUTINE gim_a_line(ix,iy) + USE WINTERACTER + x=ix/100. + y=iy/100. + CALL IGrLineto(x,y) + RETURN + END SUBROUTINE + + SUBROUTINE move_da_pointer(ix, iy) + USE WINTERACTER + x=ix/100. + y=iy/100. + CALL IGrMoveto(x,y) + RETURN + END SUBROUTINE + + SUBROUTINE clear_box + USE WINTERACTER + + REAL HSIZE + COMMON /SSIZE/ HSIZE + + dimension x(4),y(4) + x(1)=0. + x(2)=HSIZE + x(3)=HSIZE + x(4)=0. + y(1)=7.50 + y(2)=7.50 + y(3)=8.0 + y(4)=8.0 + + call Rwhite + + call IGrColourN(48) + + CALL IGrFillPattern(4,0,0) + + call IGrPolygonComplex(x,y,4) + + call RBlue + + return + END SUBROUTINE + + SUBROUTINE get_rid_window + USE WINTERACTER + call WindowClose + RETURN + END SUBROUTINE + + SUBROUTINE flush_screen + RETURN + END SUBROUTINE + + SUBROUTINE RMINFO + + use winteracter + + implicit none + + include 'd.inc' + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB + LOGICAL :: OPENED + INTEGER :: IERR + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + + call wdialogload(IDD_DIALOG09) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_DIALOG09) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + return + endif + return + enddo + + RETURN + END SUBROUTINE + + SUBROUTINE GETMDIS(nmapf,nsigf,icolsw,rad,colint) + + use winteracter + + implicit none + + include 'd.inc' + CHARACTER(LEN=255) :: FNAME + CHARACTER(LEN=3) :: SUB + LOGICAL :: OPENED + INTEGER :: IERR,NMAPF,NSIGF,icolsw + REAL :: RAD,COLINT + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + + call wdialogload(IDD_DIALOG10) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_DIALOG10) + ierr=infoerror(1) + + CALL WDialogPutINTEGER(IDF_INTEGER1,nsigf) + + CALL WDialogPutINTEGER(IDF_INTEGER2,nmapf) + + CALL WDialogPutReal(IDF_REAL1,rad) + + CALL WDialogPutReal(IDF_REAL2,colint) + + call wdialogputcheckbox(idf_check1,icolsw) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + CALL WDialogGetINTEGER(IDF_INTEGER1,nsigf) + + CALL WDialogGetINTEGER(IDF_INTEGER2,nmapf) + + call wdialogGetcheckbox(idf_check1,icolsw) + + CALL WDialogGetReal(IDF_REAL1,rad) + + CALL WDialogGetReal(IDF_REAL2,colint) + + return + endif + return + enddo + + RETURN + END SUBROUTINE + + SUBROUTINE THICKL + CALL IGrLineWidth(2,2,2) + RETURN + END + + SUBROUTINE THINL + CALL IGrLineWidth(1,1,1) + RETURN + END + + SUBROUTINE OUTORG(FNAME) + + CHARACTER(LEN=255) :: FNAME + + INCLUDE 'TXFRM.COM' + + REAL HSIZE + COMMON /SSIZE/ HSIZE + +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED') +!!! WRITE(104,'(4G16.8)') -XS,-YS,HSIZE*TXSCAL-XS,7.5*TXSCAL-YS + WRITE(104,'(4G16.8)') -XS,-YS,HSIZE*TXSCAL-XS,8.0*TXSCAL-YS + CLOSE(104) + RETURN + END + + SUBROUTINE DRAWBK(I,IMZ) + + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + INCLUDE 'BFILES.I90' + + REAL HSIZE + COMMON /SSIZE/ HSIZE + + IF(IMZ .EQ. -1) THEN + VRANGE=7.5 + ELSE + VRANGE=8.0 + ENDIF + XBKMN=((BFMINMAX(I,1)+XS)/TXSCAL)/HSIZE + XBKMX=((BFMINMAX(I,3)+XS)/TXSCAL)/HSIZE + YBKMN=((BFMINMAX(I,2)+YS)/TXSCAL)/VRANGE + YBKMX=((BFMINMAX(I,4)+YS)/TXSCAL)/VRANGE +! WRITE(90,*) 'BACKGND',XBKMN,XBKMX,YBKMN,YHSIZEBKMX + IF(XBKMN .GT. 1.) RETURN + IF(XBKMX .LT. 0.) RETURN + IF(YBKMN .GT. 1.) RETURN + IF(YBKMX .LT. 0.) RETURN + XRANGE=XBKMX-XBKMN + YRANGE=YBKMX-YBKMN + IF(XBKMX .GT. 1.) THEN + XGRMX=(1.-XBKMN)/XRANGE + XBKMX=1.0 + ELSE + XGRMX=1. + ENDIF + IF(XBKMN .LT. 0.) THEN + XGRMN=-XBKMN/XRANGE + XBKMN=0. + ELSE + XGRMN=0. + ENDIF + IF(YBKMX .GT. 1.) THEN + YGRMX=(1.-YBKMN)/YRANGE + YBKMX=1.0 + ELSE + YGRMX=1. + ENDIF + IF(YBKMN .LT. 0.) THEN + YGRMN=-YBKMN/YRANGE + YBKMN=0. + ELSE + YGRMN=0. + ENDIF +! WRITE(90,*) 'BACKGN2',XBKMN,XBKMX,YBKMN,YBKMX +! WRITE(90,*) 'XGR ',XGRMN,YGRMN,XGRMX,YGRMX + CALL IGrArea(XBKMN,YBKMN,XBKMX,YBKMX) + CALL IGrReplayArea(XGRMN,YGRMN,XGRMX,YGRMX) + call IGrReplay(BFNAME(I)) + CALL IGrArea(0.0,0.0,1.0,1.0) + RETURN + END + + SUBROUTINE DRAWBKBM(I,IMZ) + + USE WINTERACTER + + REAL HSIZE + COMMON /SSIZE/ HSIZE + + CHARACTER*1 IFLAG + INTEGER, DIMENSION(6) :: INFO + + INCLUDE 'TXFRM.COM' +!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL + + INCLUDE 'BFILES.I90' + DATA IHAND1,IHAND2/0,0/ + XBKMN=((BFMINMAX(I,1)+XS)/TXSCAL) + XBKMX=((BFMINMAX(I,3)+XS)/TXSCAL) + YBKMN=((BFMINMAX(I,2)+YS)/TXSCAL) + YBKMX=((BFMINMAX(I,4)+YS)/TXSCAL) +! WRITE(90,*) 'BACKGND-cm',XBKMN,XBKMX,YBKMN,YBKMX + CALL IGrUnitsToPixels(0.,0.,IXPM,IYPM) + CALL IGrUnitsToPixels(HSIZE,8.0,IXPXC,IYPXC) +! WRITE(90,*) 'PIXELS',IXPM,IYPXC-IYPXC,IXPXC,IYPXC-IYPM + CALL IGrUnitsToPixels(XBKMN,YBKMN,IXPM,IYPM) + CALL IGrUnitsToPixels(XBKMX,YBKMX,IXPX,IYPX) + IYPX=IYPXC-IYPX + IYPM=IYPXC-IYPM +! WRITE(90,*) 'PIXELS',IXPM,IYPX,IXPX,IYPM,IXPXC,IYPXC + IF(XBKMN .GT. HSIZE) RETURN + IF(XBKMX .LT. 0.) RETURN + IF(YBKMN .GT. 8.) RETURN + IF(YBKMX .LT. 0.) RETURN + CALL IGrFileInfo(BFNAME(I),INFO,6) +! WRITE(90,*)'BITMAP INFO',INFO + IF(INFO(1) .EQ. 1 .or. info(1) .eq. 2 .or. info(1) .eq. 15 .or. info(1) .eq. 19) THEN + IXPIX=INFO(2) + IYPIX=INFO(3) + ENDIF + XRANGE=IXPX-IXPM + YRANGE=IYPM-IYPX +! WRITE(90,*) 'RANGE',XRANGE,YRANGE + FRACX1=0. + FRACX2=0. + FRACY1=0. + FRACY2=0. + IF(IXPX .GT. IXPXC) THEN + FRACX1=(IXPX-IXPXC)/XRANGE + IXPX = IXPXC + ENDIF + IF(IYPM .GT. IYPXC) THEN + FRACY1=(IYPM-IYPXC)/YRANGE + IYPM = IYPXC + ENDIF + IF(IXPM .LT. 0) THEN + FRACX2=-IXPM/XRANGE + IXPM=0 + ENDIF + IF(IYPX .LT. 0) THEN + FRACY2=-IYPX/YRANGE + IYPX=0 + ENDIF + +! WRITE(90,*) 'BACKGN2-bm',IXPM,IYPX,IXPX,IYPM +! WRITE(90,*) 'FRAC-bm ',FRACX1,FRACX2,FRACY1,FRACY2 + IF(IHAND1 .NE. 0) THEN + CALL WBitmapDestroy(IHAND1) + CALL WBitmapDestroy(IHAND2) + ENDIF +! WRITE(90,*) 'PIXEL INFO',IXPIX,IYPIX + CALL WBitMapCreate(IHAND1,IXPIX,IYPIX) + IERR = InfoError(LastError) +! WRITE(90,*) 'ERROR CREATE', IERR,IHAND1 + CALL IGrSelect(DrawBitmap,IHAND1) + if(ihand1 .eq. 0) then + IERR = InfoError(LastError) + CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,& + 'Too many pixels for image to display correctly '//CHAR(13)//'Image will not register ','IMAGE ERROR') + endif +! WRITE(90,*) 'ERROR SELECT', IERR + CALL IGrLoadImage(BFNAME(I),1) + IERR = InfoError(LastError) +! WRITE(90,*) 'ERROR LOAD', IERR + + IX2PIX=IXPIX*(1.-FRACX1-FRACX2) + IY2PIX=IYPIX*(1.-FRACY1-FRACY2) + IXLPIX=IXPIX*FRACX2 + IYLPIX=IYPIX*FRACY2 + IXMPIX=IXPIX*(1.-FRACX1) + IYMPIX=IYPIX*(1.-FRACY1) +! WRITE(90,*) 'HANDL2',IHAND2,IX2PIX,IY2PIX +! WRITE(90,*) 'LOCAL ',IXLPIX,IYLPIX,IXMPIX,IYMPIX + CALL WBitMapCreate(IHAND2,IX2PIX,IY2PIX) + CALL IGrSelect(DrawBitmap,IHAND2) + CALL WBitMapPutPart(IHAND1,0,IXLPIX,IYLPIX,IXMPIX,IYMPIX) + CALL IGrSelect(DrawWin) + IERR = InfoError(LastError) +! WRITE(90,*) 'ERROR SELECT DRAW', IERR + CALL WBitmapPut(IHAND2,1,1,IXPM,IYPX,IXPX,IYPM) +! call gim_an_event(ix,iy,iflag) + + RETURN + END + + Subroutine panel012(ibkon) + + use winteracter + + implicit none + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: n,ibkon,IERR +! real :: + character*3 :: sub + + call wdialogload(IDD_DIALOG012) + ierr=infoerror(1) + + do n=1,nbkfl + CALL WDialogPutString(idf_string1+n-1,BFNAME(n)) + call wdialogputcheckbox(idf_check1+n-1,iswbkfl(n)) + enddo + + call wdialogputcheckbox(idf_check11,ibkon) + + CALL WDialogSelect(IDD_DIALOG012) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + do n=1,nbkfl + call wdialogGetcheckbox(idf_check1+n-1,iswbkfl(n)) + CALL GETSUB(BFNAME(n),SUB) + if(sub .eq. 'bmp') then + if(iswbkfl(n) .eq. 1) iswbkfl(n)=2 + ELSEIF(SUB .EQ. 'pcx') then + if(iswbkfl(n) .eq. 1) ISWBKFL(N) = 2 + ELSEIF(SUB .EQ. 'png' .or. sub .eq. 'jpg') then + if(iswbkfl(n) .eq. 1) ISWBKFL(N) = 2 + endif + enddo + + call wdialogGetcheckbox(idf_check11,ibkon) + + ENDIF + RETURN + END + + SUBROUTINE UNDO(IYES) + + USE WINTERACTER + + INCLUDE 'D.INC' + + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do wish to undo?'//& + CHAR(13)//' ','Undo option') +! +! If answer 'No', return +! + iyes=1 + IF (WInfoDialog(4).EQ.2) iyes=0 + return + end + + subroutine frame(xmn,ymn,xmx,ymx) + + CALL PLOTT(xmn,ymn,3) + CALL PLOTT(xmx,ymn,2) + CALL PLOTT(xmx,ymx,2) + CALL PLOTT(xmn,ymx,2) + CALL PLOTT(xmn,ymn,2) + return + end + + SUBROUTINE CIRCLE(CX,CY,rad) + dimension x(8),y(8) + DO I=1,8 + ANGLE=FLOAT(I-1)*6.28318/8. + X(I)=CX+rad*COS(ANGLE) + Y(I)=CY+rad*SIN(ANGLE) + ENDDO +! write(90,*) 'circle',x,y + CALL IGrPolygonComplex(x,y,8) + return + end + + Subroutine GETHDRTYP(IHDSWT) + + use winteracter + + implicit none + + include 'D.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: IHDSWT,IERR + + call wdialogload(IDD_HEADERTP) + ierr=infoerror(1) + + call wdialogputRadioButton(idf_radio1) + + CALL WDialogSelect(IDD_HEADERTP) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,IHDSWT) + return + endif + IHDSWT=1 + RETURN + enddo + RETURN + END + + Subroutine panelfil + + use winteracter + + implicit none + + include 'D.inc' + INCLUDE 'BFILES.I90' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: n,iflon,IERR +! real :: + character*3 :: sub + + call wdialogload(IDD_SELTFL2) + ierr=infoerror(1) + + write(90,*) 'iactvfil,itotfil',iactvfil,itotfil + do n=1,itotfil + write(90,'(a)') 'file',n,fnameout(n) + CALL WDialogPutString(idf_string25+n-1,FNAMEOUT(n)) + if(n .eq. iactvfil) then + call wdialogputradiobutton(idf_radio1+n-1) + endif + enddo + CALL WDialogSelect(IDD_SELTFL2) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + call wdialogGetradiobutton(idf_radio1,iactvfil) + ENDIF + write(90,*) 'Selected iactvfil', iactvfil + RETURN + END + subroutine plotcr(x,y,siz) + + CALL PLOTT(x-siz/2.,y,3) + CALL PLOTT(x+siz/2,y,2) + CALL PLOTT(x,y-siz/2.,3) + CALL PLOTT(x,y+siz/2.,2) + return + end + + diff --git a/src/WINTER.ICO b/src/WINTER.ICO new file mode 100644 index 0000000..a29a006 Binary files /dev/null and b/src/WINTER.ICO differ diff --git a/src/WRTBIN.F90 b/src/WRTBIN.F90 new file mode 100644 index 0000000..9e25a70 --- /dev/null +++ b/src/WRTBIN.F90 @@ -0,0 +1,106 @@ + SUBROUTINE WRTBIN + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + DIMENSION IREC(40),FREC(40) + + CHARACTER*4 IPACKB(1200),IPACKT(77) + + DATA (IREC(I),I=1,40) / 40*0 / + DATA (FREC(I),I=1,40) / 40*0. / + +! Write GFGEN banners + + IREC(1) = 435 + MFLG = 100 + WRITE(IOT1) MFLG,IREC(1),NP,NE + IWRT1 = 1200 + DO I=11,1200 + IPACKB(I)=' ' + ENDDO + IPACKB(1)='RMA ' + IPACKB(2)='IMPL' + IPACKB(3)='EMEN' + IPACKB(4)='TATI' + IPACKB(5)='ON O' + IPACKB(6)='F SM' + IPACKB(7)='S OU' + IPACKB(8)='TPUT' + IPACKB(9)=' FOR' + IPACKB(10)='MAT ' + + WRITE (IOT1) IWRT1, (IPACKB(I),I= 1,IWRT1) + + IWRT2 = 40 + IWRT3 = 40 + WRITE (IOT1) IWRT2, IWRT3,(IREC(I),I=1, IWRT2), (FREC(I),I=1,IWRT3) + DO I=1,77 + IPACKT(I)=' ' + IF(I .LT. 73) THEN + IPACKT(I)(1:1)=TITLE(I:I) + ENDIF + ENDDO + IWRT4 = 77 + WRITE (IOT1) IWRT4, (IPACKT(I),I= 1,IWRT4) + + DO J=1,NP +!IPK FEB05 + CORDSN(J,1)=XUSR(J) + CORDSN(J,2)=YUSR(J) + ENDDO + DO J=1,NE + IMATL(J)=IMAT(J) + ENDDO + ALPHA=0. + WRITE(IOT1) NP,NE,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,NP)& + ,((NOP(J,K),K=1,8),IMATL(J),THTA(J),IEM(J),J=1,NE) + WRITE(IOT1) (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,NP) + + + RETURN + END + + + SUBROUTINE RDBIN(IIIN) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + IIN=IIIN + +! Read GFGEN banners + + READ(IIN) MFLG,IREC,N,M + READ(IIN) IWRT1,(IDUM,I=1,IWRT1) + READ(IIN) IWRT2,IWRT3,(IDUM,I=1,IWRT2),(FDUM,I=1,IWRT3) + READ(IIN) IWRT4,(IDUM,I=1,IWRT4) + + READ(IIN) N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1),& + ((NOP(J,K),K=1,8),IMATL(J),TH0,I3,J=1,M1) + READ(IIN) (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1) + + DO J=1,N1 + DO K=1,2 + CORD(J,K)=CORDSN(J,K) + ENDDO + XUSR(J)=CORD(J,1) + YUSR(J)=CORD(J,2) + ENDDO + + DO J=1,M1 + IMAT(J)=IMATL(J) +!ipk feb08 + ncorn(j)=0 + DO K=1,8 + if(nop(j,k) .gt. 0) ncorn(j)=k + ENDDO + ENDDO + NP=N1 + NE=M1 + + + CLOSE(IIN) + + RETURN + END diff --git a/src/XN.F90 b/src/XN.F90 new file mode 100644 index 0000000..24a2c34 --- /dev/null +++ b/src/XN.F90 @@ -0,0 +1,200 @@ + DOUBLE PRECISION FUNCTION XN(IT,K,X,Y) + + SAVE + DOUBLE PRECISION X,Y +! +!......FUNCTION TO DEFINE SHAPE FUNCTION VALUES +! + IF(IT .EQ. 2) THEN +! +!......TRIANGULAR ELEMENT +! + GO TO ( 110,120,130,140,150,160),K + 110 XN=(1.-2.*X-2.*Y)*(1.-X-Y) + RETURN + 120 XN=4.*X*(1.-X-Y) + RETURN + 130 XN=(2.*X-1.)*X + RETURN + 140 XN=4.*X*Y + RETURN + 150 XN=(2.*Y-1.)*Y + RETURN + 160 XN=4.*Y*(1.-X-Y) + RETURN +! +!......QUADRILATERAL ELEMENT +! + ELSEIF(IT .EQ. 1) THEN + GO TO (510,520,530,540,550,560,570,580),K + 510 XN=(1.-X)*(1.-Y)*(-X-Y-1.)/4. + RETURN + 520 XN=(1.-X*X)*(1.-Y)/2. + RETURN + 530 XN=(1.+X)*(1.-Y)*(X-Y-1.)/4. + RETURN + 540 XN=(1.+X)*(1.-Y*Y)/2. + RETURN + 550 XN=(1.+X)*(1.+Y)*(X+Y-1.)/4. + RETURN + 560 XN=(1.-X*X)*(1.+Y)/2. + RETURN + 570 XN=(1.-X)*(1.+Y)*(-X+Y-1.)/4. + RETURN + 580 XN=(1.-X)*(1.-Y*Y)/2. + ELSE + GO TO (610,620,630,640,650,660,670,680,690),K + 610 XN=(1.-X)*(1.-Y)*X*Y/4. + RETURN + 620 XN=-Y*(1.-X*X)*(1.-Y)/2. + RETURN + 630 XN=-(1.+X)*(1.-Y)*X*Y/4. + RETURN + 640 XN=X*(1.+X)*(1.-Y*Y)/2. + RETURN + 650 XN=(1.+X)*(1.+Y)*X*Y/4. + RETURN + 660 XN=Y*(1.-X*X)*(1.+Y)/2. + RETURN + 670 XN=-(1.-X)*(1.+Y)*X*Y/4. + RETURN + 680 XN=-X*(1.-X)*(1.-Y*Y)/2. + RETURN + 690 XN=(1.+X)*(1.-X)*(1.+Y)*(1.-Y) + RETURN + ENDIF + END + DOUBLE PRECISION FUNCTION DNX(IT,K,X,Y) + + SAVE + DOUBLE PRECISION X,Y +!- +!......FUNCTION TO DETERMINE X-DERIVATIVE OF SHAPE FUNCTION +!- + IF(IT .EQ. 2) THEN +!- +!......TRIANGULAR ELEMENT +!- + GO TO (110,120,130,140,150,160),K + 110 DNX=-3. +4.*X+4.*Y + RETURN + 120 DNX=4.-8.*X-4.*Y + RETURN + 130 DNX=4.*X-1. + RETURN + 140 DNX=4.*Y + RETURN + 150 DNX=0. + RETURN + 160 DNX=-4.*Y + RETURN +!- +!......QUADRILATERAL ELEMENT +!- + ELSEIF(IT .EQ. 1) THEN + GO TO (510,520,530,540,550,560,570,580),K + 510 DNX=-(1.-Y)*(-2.*X-Y)/4. + RETURN + 520 DNX=-X*(1.-Y) + RETURN + 530 DNX=(1.-Y)*(2.*X-Y)/4. + RETURN + 540 DNX=(1.-Y*Y)/2. + RETURN + 550 DNX=(1.+Y)*(2.*X+Y)/4. + RETURN + 560 DNX=-X*(1.+Y) + RETURN + 570 DNX=-(1.+Y)*(-2.*X+Y)/4. + RETURN + 580 DNX=-(1.-Y*Y)/2. + RETURN + ELSE + GO TO (610,620,630,640,650,660,670,680,690),K + 610 DNX=(Y-Y**2)*(1.-2.*X)/4. + RETURN + 620 DNX= X*(Y-Y**2) + RETURN + 630 DNX=-(Y-Y**2)*(1.+2.*X)/4. + RETURN + 640 DNX=(1.-Y*Y)/2.*(1.+2.*X) + RETURN + 650 DNX=(Y+Y**2)*(1.+2.*X)/4. + RETURN + 660 DNX=-X*(Y+Y**2) + RETURN + 670 DNX=-(Y+Y**2)*(1.-2.*X)/4. + RETURN + 680 DNX=-(1.-Y*Y)/2.*(1.-2.*X) + RETURN + 690 DNX=-2.*X*(1.-Y**2) + RETURN + ENDIF + END + DOUBLE PRECISION FUNCTION DNY(IT,K,X,Y) + SAVE + DOUBLE PRECISION X,Y +!- +! +!......FUNCTION TO DETERMINE Y-DERIVATIVE OF SHAPE FUNCTION +!- + IF(IT .EQ. 2) THEN +!- +!......TRIANGULAR ELEMENT +!- + GO TO (110,120,130,140,150,160),K + 110 DNY=-3.+4.*X+4.*Y + RETURN + 120 DNY=-4.*X + RETURN + 130 DNY=0. + RETURN + 140 DNY=4.*X + RETURN + 150 DNY=4.*Y-1. + RETURN + 160 DNY=4.-4.*X-8.*Y + RETURN +!- +!......QUADRILATERAL ELEMENT +!- + ELSEIF(IT .EQ. 1) THEN + GO TO (510,520,530,540,550,560,570,580),K + 510 DNY=-(1.-X)*(-2.*Y-X)/4. + RETURN + 520 DNY=-(1.-X*X)/2. + RETURN + 530 DNY=-(1.+X)*(X-2.*Y)/4. + RETURN + 540 DNY=-Y*(1.+X) + RETURN + 550 DNY=(1.+X)*(2.*Y+X)/4. + RETURN + 560 DNY=(1.-X*X)/2. + RETURN + 570 DNY=(1.-X)*(2.*Y-X)/4. + RETURN + 580 DNY=-Y*(1.-X) + RETURN + ELSE + GO TO (610,620,630,640,650,660,670,680,690),K + 610 DNY=(X-X**2)*(1.-2.*Y)/4. + RETURN + 620 DNY=-(1.-X*X)/2.*(1.-2.*Y) + RETURN + 630 DNY=-(X+X**2)*(1.-2.*Y)/4. + RETURN + 640 DNY=-Y*(X+X**2) + RETURN + 650 DNY=(X+X**2)*(1.+2.*Y)/4. + RETURN + 660 DNY=(1.-X*X)/2.*(1.+2.*Y) + RETURN + 670 DNY=-(X-X**2)*(1.+2.*Y)/4. + RETURN + 680 DNY= Y*(X-X**2) + RETURN + 690 DNY=-2.*Y*(1.-X**2) + RETURN + ENDIF + END diff --git a/src/ZOOM.BMP b/src/ZOOM.BMP new file mode 100644 index 0000000..27841b8 Binary files /dev/null and b/src/ZOOM.BMP differ diff --git a/src/ZOOMNEW.F90 b/src/ZOOMNEW.F90 new file mode 100644 index 0000000..a21abf9 --- /dev/null +++ b/src/ZOOMNEW.F90 @@ -0,0 +1,104 @@ +!*********************************************************** + subroutine zoomnew(xscrn,yscrn,xscrn1,yscrn1,iflag) +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + character*1 iflag +! +! +!ipk jun96 add zoomj + character*43 zoomh,zoomj + character*23 zoomi +!ipk jan98 + CHARACTER*80 lind + data zoomh/' Zooming, click and drag to form rectangle'/ + data zoomi/' Click right if size OK'/ +!ipk jun96 add zoomj + data zoomj/' Double click, click second point '/ +! +! + 80 CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomh,0.,43) + +!jan09 xcc = 5.00 +!jan09 xp = 5.00 + xcc = 5.00*hsize/10. + xp = 5.00*hsize/10. + ycc = 3.5 + yp = 3.5 +! +! Got cursor location +! + if(iflag .eq. 'r') then +! This option is scaling a window +! +! +! Look for a screen size +! + xsiz=abs(xscrn1-xscrn) + ysiz=abs(yscrn1-yscrn) +!ipk jun96 test for zero sizes + if(xsiz .lt. 0.001 .or. ysiz .lt. 0.001) then + CALL CLRBOX + CALL SYMBL(0.,7.70,0.20,zoomj,0.,43) + return + endif + if(xscrn1 .lt. xscrn) xscrn=xscrn1 + if(yscrn1 .lt. yscrn) yscrn=yscrn1 + fact=HSIZE/xsiz + if(7.5/ysiz .lt. fact) fact=7.5/ysiz +!jan09 if(8./ysiz .lt. fact) fact=8./ysiz +!jan09 xscrn=xscrn+5./fact + xscrn=xscrn+xcc/fact + yscrn=yscrn+3.5/fact + xp=xscrn + yp=yscrn + CALL CLRBOX +! CALL SYMBL(0.,7.70,0.20,zoomi,0.,22) + go to 250 + elseif(iflag .eq. 'w') then + call rescal + return + elseif(iflag .eq. 'y')then + fact=0.5 + elseif(iflag .eq. 'x') then + fact=0.25 + elseif(iflag .eq. 'v')then + fact=1.0 + xp=xp-5. + elseif(iflag .eq. 'u') then + fact=1.0 + xp=xp+5. + elseif(iflag .eq. 't')then + fact=1.0 + yp=yp+3.5 + elseif(iflag .eq. 's') then + fact=1.0 + yp=yp-3.5 + elseif(iflag .eq. 'd') then + fact=1.0 + xp=xp-xscrn + yp=yp-yscrn + endif + do i=1,np + if(cord(i,1) .gt. void) then + inskp(i)=0 + endif + enddo + do i=1,ne + if(imat(i) .gt. 0) then + ieskp(i)=0 + endif + enddo + 250 continue + pscale = pscale/fact + xmino=xmin + ymino=ymin +! + xmin = xp - (xcc*pscale) + ymin = yp - (ycc*pscale) +! + CALL PLOTOT(0) + if(nmess .eq. 11) call pltpt + return + END diff --git a/src/addmap.f90 b/src/addmap.f90 new file mode 100644 index 0000000..21a5b63 --- /dev/null +++ b/src/addmap.f90 @@ -0,0 +1,86 @@ + SUBROUTINE ADDMAP +! +! ROUTINE TO ADD TWO MAPS FILES TOGETHER +! + + USE WINTERACTER + + USE BLKMAP + USE BLK1MOD + USE BLK2MOD + + include 'd.inc' + + + CHARACTER(LEN=255) :: FNAME,FNAMGE,FNAMRM,FNAMEB + CHARACTER(LEN=3) :: SUB,SUB1 + +! FIRST WRITE EXISTING MAP TO SCRATCH + close(99) + OPEN(99,FORM='BINARY',STATUS='SCRATCH') + + +! SAVE THE CONTROL INFORMATION + KEEP1=klint + JEEP1=jlint + + CALL WRTMAP(99) + REWIND 99 + +! NEXT READ NEW MAP AND ALSO WRITE TO A SECOND SCRATCH +! FIRST OPEN A MAP FILE + CALL WSelectFile(ID_STRING1,PromptOn,FNAME,'Load Map File') + + IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN + + CALL IlowerCase(FNAME) + CALL GETSUB(FNAME,SUB) + + IF(SUB .EQ. 'map') then + IMP=9 + OPEN(9,FILE=FNAME,STATUS='OLD') + ELSEIF(SUB .EQ. 'asc' .or. SUB .EQ. 'grd') then + IMP=94 + OPEN(94,FILE=FNAME,STATUS='OLD') + ELSEIF(SUB .EQ. 'mpb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='unformatted',action='read') + ELSEIF(SUB .EQ. 'mbb') then + imp=92 + OPEN(IMP ,FILE=FNAME,STATUS='OLD',form='binary',action='read') + ENDIF + ENDIF + CALL RDMAP(2,IMP,0,0) + NEWMAXK=KEEP1+klint + NEWMAXPL=JEEP1+jlint + IF(NEWMAXPL .GT. MAXPL) THEN +!! +! NOW OPEN THE FILE FOR SAVING + OPEN(98,FORM='BINARY',STATUS='SCRATCH') + + CALL WRTMAP(98) + REWIND 98 + + +! WORK OUT SIZES AND ALLOCATE ARRAYS + + + deallocate (CMAP,XMAP,YMAP,VAL,imap,NCRS) + + allocate (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL)) + + ALLOCATE (imap(maxpl),NCRS(MAXPL)) + + CALL RDMAP(2,98,0,0) ! XXXXX + CLOSE(98) + ENDIF +! READ IN AND MERGE MAP FILES + + JSTT=JLINT + KSTT=KLINT + CALL RDMAP(2,99,JSTT,KSTT) + CLOSE(99) + call PLOTOT(0) + CALL HEDR + RETURN + END \ No newline at end of file diff --git a/src/addtomesh.f90 b/src/addtomesh.f90 new file mode 100644 index 0000000..5023939 --- /dev/null +++ b/src/addtomesh.f90 @@ -0,0 +1,499 @@ +!ipk last update sep 20 2013 add more output of progress and flushing of messages + SUBROUTINE ADDTOMESH(IADDFIL,ISWT) + +! iswt = 0 ADD TO MESH +! ISWT = 1 MERGE MESHES + + USE WINTERACTER + USE BLK1MOD + + INCLUDE 'D.INC' + +! INCLUDE 'BLK1.COM' + INCLUDE 'BFILES.I90' + + IADD=IADDFIL+50 + CALL RDTOCLIP(IADD) + + IF(ISWT .EQ. 1) THEN + ISWT1=0 + CALL MERGEMESH1(ISWT1) + write(90,*) 'finished mergemesh1' + CALL MERGEMESH + write(90,*) 'finished mergemesh' + flush(90) + ENDIF + + CALL ADDMESH(0) + write(90,*) 'finished addmesh' + + IF(ISWT .EQ. 1 ) THEN + CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to delete unused nodes?'//& + CHAR(13)//' ','Delete unused nodes?') + ! +! If answer 'No', return +! + IF (WInfoDialog(4).EQ.2) return +! +! Delete all unused nodes +! + CALL DELETM(2) + ENDIF + + RETURN + END + + + SUBROUTINE RDTOCLIP(IUNIT) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + CHARACTER*80 ALINE + + REWIND IUNIT + READ(IUNIT) TITLE,NPSTO(1),NESTO(1) +! WRITE(90,*) 'IN RDTOCLIP',IUNIT +! WRITE(90,*) TITLE,NPSTO(1),NESTO(1) + READ(IUNIT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & + & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempinc +! WRITE(90,*) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & +! & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempinc + READ(IUNIT) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG +! WRITE(90,*) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG + IF(IPP .GT. 0) READ(IIN) ALINE + + READ(IUNIT) ((NOPSTO(J,K,1),K=1,8),IMATSTO(J,1),THTASTO(J,1),J=1,NESTO(1)) + + READ(IUNIT) & + & (XUSRSTO(J,1),YUSRSTO(J,1),WDSTO(J,1),WIDTHSTO(J,1),SS1STO(J,1),SS2STO(J,1),WIDSSTO(J,1), & + & WIDBSSTO(J,1),SSOSTO(J,1),BS1STO(J,1),J=1,NPSTO(1)) + + READ(IUNIT) NLSTSTO(1) + IF(NLSTSTO(1) .GT. 0) THEN + READ(IUNIT) (LLISTSTO(J,1),J=1,NLSTSTO(1)), & + ((ILISTSTO(J,I,1),I=1,LLISTSTO(J,1)),J=1,NLSTSTO(1)) + ENDIF + + READ(IUNIT) NENTRYC,NLAYDC,NCLMSTO(1) + IF(NENTRYC .GT. 0) THEN + READ(IUNIT) ((NEFC,J=1,3),I=1,NENTRYC) + ENDIF + IF(NLAYDC .GT. 0) THEN + READ(IUNIT) (LAYC,I=1,NPSTO(1)) + ENDIF + IF(NCLMSTO(1) .GT. 0) THEN + READ(IUNIT) ((ICCLNSTO(I,J,1),J=1,350),I=1,NCLMSTO(1)) + ENDIF + + REWIND IUNIT + RETURN + END + + SUBROUTINE ADDMESH(ISWT) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + + ALLOCATABLE NODETRAN(:) + DATA VDX9/-9.E9/ + +! Loop through nodes assigning new number and adding to list + + IF(.NOT. ALLOCATED(NODETRAN)) ALLOCATE (NODETRAN(maxp)) + + IF(ISWT .EQ. 0) THEN + DO N=1,NPSTO(1) + IF(XUSRSTO(N,1) .GT. VDX9) THEN + CALL GETNOD(J) + NODETRAN(N)=J + XUSR(J)=XUSRSTO(N,1) + YUSR(J)=YUSRSTO(N,1) + WD(J)=WDSTO(N,1) + WIDTH(J)=WIDTHSTO(N,1) + SS1(J)=SS1STO(N,1) + SS2(J)=SS2STO(N,1) + WIDS(J)=WIDSSTO(N,1) + WIDBS(J)=WIDBSSTO(N,1) + SSO(J)=SSOSTO(N,1) + BS1(J)=BS1STO(N,1) + INSKP(J) = 0 + INEW(J) = 1 + ENDIF + ENDDO + ELSE + DO N=1,NPSTO(1) + NODETRAN(N)=N + ENDDO + ENDIF + +! Loop through elements assigning new number and adding to list + + DO N=1,NESTO(1) + IF(IMATSTO(N,1) .GT. 0) THEN + CALL GETELM(M) + DO K=1,8 + IF(NOPSTO(N,K,1) .GT. 0) THEN + J=NODETRAN(NOPSTO(N,K,1)) + NOP(M,K)=J + ELSE + NOP(M,K)=0 + ENDIF + ENDDO + IMAT(M)=IMATSTO(N,1) + THTA(M)=THTASTO(N,1) + IESKP(M)=0 + NCN = 2 + IF (NOP(M,3) .NE. 0) NCN = 3 + IF (NOP(M,4) .NE. 0) NCN = 4 + IF (NOP(M,5) .NE. 0 .AND. NOP(M,4) .NE. 0) NCN = 5 + IF (NOP(M,5) .NE. 0 .AND. NOP(M,4) .EQ. 0) NCN = 6 + IF (NOP(M,6) .NE. 0) NCN = 6 + IF (NOP(M,7) .NE. 0) NCN = 8 + NCORN(M) = NCN + + ENDIF + ENDDO + + if(iswt .eq. 0) CALL RESCAL + CALL HEDR + + RETURN + END + + SUBROUTINE MERGEMESH1(ISWT1) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + REAL*8 ELXMIN,ELXMAX,ELYMIN,ELYMAX,XLC,YLC,XXX,YYY + + ALLOCATABLE ELXMIN(:),ELXMAX(:),ELYMIN(:),ELYMAX(:),KEY(:),NKEY(:) + + IF(.NOT. ALLOCATED(ELXMIN)) & + ALLOCATE (ELXMIN(MAXE),ELXMAX(MAXE),ELYMIN(MAXE),ELYMAX(MAXE),KEY(MAXE),NKEY(MAXP)) + +! First sort coordinates for min of element connection + +! List all limiting values + + DO N=1,NE + IF(IMAT(N) .GT. 0) THEN + ELXMIN(N)=XUSR(NOP(N,1)) + ELXMAX(N)=XUSR(NOP(N,1)) + ELYMIN(N)=YUSR(NOP(N,1)) + ELYMAX(N)=YUSR(NOP(N,1)) + DO M=2,8 + IF(NOP(N,M) .NE. 0) THEN + ELXMIN(N)=MIN(ELXMIN(N),XUSR(NOP(N,M))) + ELXMAX(N)=MAX(ELXMAX(N),XUSR(NOP(N,M))) + ELYMIN(N)=MIN(ELYMIN(N),YUSR(NOP(N,M))) + ELYMAX(N)=MAX(ELYMAX(N),YUSR(NOP(N,M))) + ENDIF + ENDDO + ELSE + ELXMIN(N)=VOID + ELXMAX(N)=VOID + ELYMIN(N)=VOID + ELYMAX(N)=VOID + ENDIF + ENDDO + + CALL SORTDB(XUSRSTO,NKEY,NPSTO(1)) + + CALL SORTDB(ELXMIN,KEY,NE) + +! Loop on elements to check for overlap + + + DO KK=1,NESTO(1) + IF (NOPSTO(KK,6,1) .EQ. 0) CYCLE + IF(IMATSTO(KK,1) .GT. 0) THEN + if(mod(kk,1000) .eq. 0) write(90,*) 'merged',kk + flush(90) + KL=1 + 200 CONTINUE + IF(ISWT1 .EQ. 0) THEN + DO K=KL,8 + J=NOPSTO(KK,K,1) + IF(J .GT. 0) THEN + KLL=KL + XXX=XUSRSTO(J,1) + YYY=YUSRSTO(J,1) + GO TO 220 + ENDIF + ENDDO + KLL=8 + GO TO 400 + 220 CONTINUE + ELSE + XXX=0. + YYY=0. + DO K=1,7,2 + JJ=NOPSTO(KK,K,1) + IF(JJ .GT. 0) THEN + XXX=XXX+XUSRSTO(JJ,1) + YYY=YYY+YUSRSTO(JJ,1) + ENDIF + ENDDO + IF(JJ .EQ. 0) THEN + XXX=XXX/3. + YYY=YYY/3. + ELSE + XXX=XXX/4. + YYY=YYY/4. + ENDIF + ENDIF +! Search on elements to find a startin point + + DO NN=1,NE + + N=KEY(NN) + IF(IMAT(N) .GT. 0) THEN +!- +!...... DETERMINE ELEMENT TYPE +!- + NCN=8 + IT=1 + IF(NOP(N,7) .EQ. 0) THEN + NCN=6 + IT=2 + ELSEIF(NOP(N,6) .EQ. 0) THEN + GOTO 350 + ENDIF +! Test for point inside an element + + +! Test for max and min within + + IF(XXX .GT. ELXMIN(N)) THEN + IF(XXX .GT. ELXMAX(N)) GO TO 350 + IF(YYY .GT. ELYMIN(N)) THEN + IF(YYY .GT. ELYMAX(N)) GO TO 350 + +! Now get local coordinate as final test + + CALL GPTEV(N,XXX,YYY,XLC,YLC,IT,NCN) + + IF(IT .EQ. 2) THEN + IF(XLC .LT. 0. .OR. YLC .LT. 0. .OR. XLC+YLC .GT. 1.) THEN + GO TO 350 + ELSE + CALL DELEM(KK) + GO TO 400 + ENDIF + ELSE + IF(XLC .LT. -1. .OR. YLC .LT. -1. .OR. & + XLC .GT. 1. .OR. YLC .GT. 1.) THEN + GO TO 350 + ELSE + CALL DELEM(KK) + GO TO 400 + ENDIF + ENDIF + + ENDIF + ENDIF + ENDIF + 350 CONTINUE + ENDDO + KL=KLL+1 + IF(KL .LT. 8 .AND. ISWT1 .EQ. 0) GO TO 200 + ENDIF + +! Finished test + + 400 CONTINUE + ENDDO + RETURN + END + + + SUBROUTINE GPTEV(N,XSW,YSW,XG,YG,IT,NCN) +!- +!......EVALUATE FUNCTION AT GRID POINTS +!- +!- N = ELEMENT NUMBER +!_ XSW = X COORDINATE OF DESIRED POINT +!_ YSW = Y COORDINATE OF DESIRED POINT +! XG = X LOCAL COORDINATE +! YG = Y LOCAL COORDINATE +! IT = SWITCH FOR CHOICE BETWEEN LINEAR AND QUADRATIC WEIGHTING +! = 1 FOR LINEAR +! = 2 FOR QUADRATIC +! FROM COMMON +! NOP = LIST OF NODAL CONNECTIONS AROUND AN ELEMET +! XUSR = REAL*8 ARRAY OF NODAL COORDINATES +! + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + REAL*8 XN,DNX,DNY,XSW,YSW + DOUBLE PRECISION XG,YG,XK,YK,XP,YP +!- + DIMENSION X(9),Y(9),WGT(8) +!- + DATA TOL/0.01/ +!- + +!- +!......ESTABLISH LOCAL COORDINATES FOR EACH NODE POINT OF ELEMENT +!- + K1=NOP(N,1) + X(1)=0. + Y(1)=0. + DO 300 K=3,NCN,2 + K2=NOP(N,K) + X(K)=XUSR(K2)-XUSR(K1) + Y(K)=YUSR(K2)-YUSR(K1) + 300 END DO + X(2)=X(3)/2. + Y(2)=Y(3)/2. + X(4)=(X(3)+X(5))/2. + Y(4)=(Y(3)+Y(5))/2. + IF(IT .EQ. 2) THEN + X(6)=X(5)/2. + Y(6)=Y(5)/2. + + xminl=min(x(1),x(3),x(5)) + yminl=min(y(1),y(3),y(5)) + xmaxl=max(x(1),x(3),x(5)) + ymaxl=max(y(1),y(3),y(5)) + ELSE + X(6)=(X(5)+X(7))/2. + Y(6)=(Y(5)+Y(7))/2. + X(8)=X(7)/2. + Y(8)=Y(7)/2. + + xminl=min(x(1),x(3),x(5),x(7)) + yminl=min(y(1),y(3),y(5),y(7)) + xmaxl=max(x(1),x(3),x(5),x(7)) + ymaxl=max(y(1),y(3),y(5),y(7)) + ENDIF + + +!- +!......ESTABLISH LOCAL COORDINATES OF DESIRED POINT +!- + XP=XSW-XUSR(K1) + YP=YSW-YUSR(K1) + + XG=0. + YG=0. +!- +!......ITERATE TO FIND LOCAL COORDINATE +!- + DO ITER=1,10 + DXKDX=0. + DXKDY=0. + DYKDX=0. + DYKDY=0. + XK=-XP + YK=-YP + DO K=2,NCN + XK=XK+XN(IT,K,XG,YG)*X(K) + YK=YK+XN(IT,K,XG,YG)*Y(K) + DXKDX=DXKDX+DNX(IT,K,XG,YG)*X(K) + DYKDX=DYKDX+DNX(IT,K,XG,YG)*Y(K) + DXKDY=DXKDY+DNY(IT,K,XG,YG)*X(K) + DYKDY=DYKDY+DNY(IT,K,XG,YG)*Y(K) + END DO + DET=DXKDX*DYKDY-DXKDY*DYKDX + DX=(-DYKDY*XK+DXKDY*YK)/DET + DY=( DYKDX*XK-DXKDX*YK)/DET + XG=XG+DX + YG=YG+DY + IF(ABS(DX).LT.TOL .AND. ABS(DY).LT.TOL) GO TO 420 + END DO +!- +!......NOW GET WEIGHTING FUNCTIONS FOR QUAD FUNCTION +!- + 420 CONTINUE + + + RETURN + END + + SUBROUTINE DELEM(J) +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! +!- +!......DELETE ELEMENT +! +! Search for elements that attach to node J and remove them +! + + IMATSTO(J,1)=0 + DO KK=1,8 + NOPSTO(J,KK,1)=0 + ENDDO +! + + RETURN + END + + + SUBROUTINE MERGEMESH + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +! Loop on element to be added + + DO N=1,NESTO(1) + IF(IMATSTO(N,1) .NE. 0) THEN + if(mod(n,1000) .eq. 0) write(90,*) 'adding',n,nesto(1) + flush(90) + +! loop on sides + + DO M=1,7,2 + N1=NOPSTO(N,M,1) + IF(N1 .GT. 0) THEN + IF((M .EQ. 5 .AND. NOPSTO(N,7,1) .EQ. 0) .OR. (M .EQ. 7)) THEN + N2=NOPSTO(N,1,1) + ELSE + N2=NOPSTO(N,M+2,1) + ENDIF + +! Now loop trough existing elements + + DO I=1,NE + IF(IMAT(I) .NE. 0) THEN + DO J=1,7,2 + M1=NOP(I,J) + IF(M1 .GT. 0) THEN + IF((J .EQ. 5 .AND. NOP(I,7) .EQ. 0) .OR. (J .EQ. 7)) THEN + M2=NOP(I,1) + ELSE + M2=NOP(I,J+2) + ENDIF + if(m2 .eq. 0) cycle + X1=XUSRSTO(N1,1) + X2=XUSRSTO(N2,1) + Y1=YUSRSTO(N1,1) + Y2=YUSRSTO(N2,1) + X3=XUSR(M1) + X4=XUSR(M2) + Y3=YUSR(M1) + Y4=YUSR(M2) + CALL IGrIntersectLine(X1,Y1,X2,Y2,X3,Y3,X4,Y4,XINTER,YINTER,ISTATUS) + IF(ISTATUS .EQ. 5) THEN + CALL DELEM(N) + GO TO 400 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + 400 CONTINUE + ENDDO + + RETURN + END diff --git a/src/adjustopt.f90 b/src/adjustopt.f90 new file mode 100644 index 0000000..e9fbd60 --- /dev/null +++ b/src/adjustopt.f90 @@ -0,0 +1,49 @@ +!IPK NEW ROUTINE SEP 9 2006 + SUBROUTINE ADJUSTOPT(NTYP,NLOCC) +! +! Generate continuity lines +! + + USE WINTERACTER + include 'd.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: NTYP,NLOCC + + + call wdialogload(IDD_SETOPT) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_SETOPT) + ierr=infoerror(1) + + IF(NTYP .EQ. 1) THEN + call wdialogputRadioButton(idf_radio1) + ELSE + call wdialogputRadioButton(idf_radio2) + ENDIF + call wdialogputcheckbox(IDF_check1,NLOCC) + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,ntyp) + + call wdialogGetcheckbox(IDF_check1,NLOCC) + GO TO 100 + ENDIF + + enddo + + 100 CONTINUE + return + end diff --git a/src/blkmap.f90 b/src/blkmap.f90 new file mode 100644 index 0000000..79c64a5 --- /dev/null +++ b/src/blkmap.f90 @@ -0,0 +1,17 @@ + MODULE BLKMAP + +! PARAMETER (MAXPL=500000,MAXELMP=50000) + + REAL*8 XCEN,YCEN,RADS,MAP,XMAP,YMAP,CMAP + + ALLOCATABLE NOPEL(:,:),XCEN(:),YCEN(:)& + ,RADS(:) ,NKEY(:),CMAP(:,:)& + ,XMAP(:),YMAP(:),VAL(:),CCMAP(:) + + INTEGER IEDGE(15000,2),IGAP(15000),NELFM(15000) + + INTEGER NELTS,MAXPL,MAXELMP + + ALLOCATABLE imap(:),NCRS(:) + + END MODULE diff --git a/src/cgen.f90 b/src/cgen.f90 new file mode 100644 index 0000000..4ac2e45 --- /dev/null +++ b/src/cgen.f90 @@ -0,0 +1,151 @@ + SUBROUTINE CGEN + +! Routine to establish contour lines + + USE BLKMAP + USE BLK1MOD +! INCLUDE 'BLK1.COM' + DIMENSION XINT(2),YINT(2),CSEL(100)& + ,X(5),Y(5),VALC(5) + COMMON /CCGEN/ XCLIN(4000,2),YCLIN(4000,2),ALIN(-4000:4000,2),IUSED(4000) + COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL + common itempel(5000) + +! Set up contours to be developed +! + CALL TOLMAX(WD,TTMIN,TTMAX) + + + ISZ=1 + CALL CSET(TTMIN,TTMAX,isz) + + NCLIN=NUMV + + DO N=1,NUMV + CSEL(N)=CONTUR(N) + ENDDO + +! Loop through each contour then each element + + DO J=1,NCLIN + + ILIN=0 + DO N=1,NE + IF(IMAT(N) .GT. 0 .AND. IMAT(N) .LT. 901 .AND. NCORN(N) .GT. 5) THEN + ISWT=0 + NCNX=NCORN(N)/2 + DO K=1,3 + X(K)=XUSR(NOP(N,2*K-1)) + Y(K)=YUSR(NOP(N,2*K-1)) + VALC(K)=WD(NOP(N,2*K-1)) + ENDDO + NCNXX=3 + CALL CGENTR(N,ISWT,NCNXX,X,Y,VALC,CSEL(J),XINT,YINT) + IF(ISWT .GT. 0) THEN + ILIN=ILIN+1 + DO K=1,2 + XCLIN(ILIN,K)=XINT(K) + YCLIN(ILIN,K)=YINT(K) + ENDDO + itempel(ilin)=n + ENDIF + + IF(NCNX .EQ. 4) THEN + ISWT=0 + DO K=3,5 + IF(K .LT. 5) THEN + KK=2*K-1 + ELSE + KK=1 + ENDIF + X(K-2)=XUSR(NOP(N,KK)) + Y(K-2)=YUSR(NOP(N,KK)) + VALC(K-2)=WD(NOP(N,KK)) + ENDDO + CALL CGENTR(N,ISWT,NCNXX,X,Y,VALC,CSEL(J),XINT,YINT) + IF(ISWT .GT. 0) THEN + ILIN=ILIN+1 + DO K=1,2 + XCLIN(ILIN,K)=XINT(K) + YCLIN(ILIN,K)=YINT(K) + ENDDO + ENDIF + ENDIF + ENDIF + ENDDO + do k=1,ilin + write(199,'(2i5,4f15.3)') k,itempel(k),xclin(k,1),yclin(k,1),xclin(k,2),yclin(k,2) + enddo + +! Join up points to form contour lines + + IF(ILIN .GT. 0) CALL JLINE(ILIN,CSEL(J)) + + ENDDO + MAXPTS=MAXPTS+1 + CMAP(MAXPTS,1) = VOID + CMAP(MAXPTS,2) = VOID + XMAP(MAXPTS) = VOID + YMAP(MAXPTS) = VOID + + RETURN + + END + + SUBROUTINE CGENTR(N,ISWT,NCN,X,Y,VAL,CVAL,XINT,YINT) + +! Routine to find line (if it exists) across element N + + DIMENSION X(5),Y(5),VAL(5),XINT(2),YINT(2) + +! Get the max and min + + IF(NCN .EQ. 3) THEN + CMAX=MAX(VAL(1),VAL(2),VAL(3)) + CMIN=MIN(VAL(1),VAL(2),VAL(3)) + ELSE + CMAX=MAX(VAL(1),VAL(2),VAL(3),VAL(4)) + CMIN=MIN(VAL(1),VAL(2),VAL(3),VAL(4)) + ENDIF + +! Test if there is a contour + + IF(CVAL .LT. CMIN .OR. CVAL .GT. CMAX) THEN + +! No then return + + ISWT=0 + RETURN + ELSE + +! Yes, determine end locations + + ISWT=1 + ENDIF + +! Find the line number that it crosses + + X(NCN+1)=X(1) + Y(NCN+1)=Y(1) + VAL(NCN+1)=VAL(1) + + DO K=1,NCN + IF(CVAL .GE. VAL(K) .AND. CVAL .LT. VAL(K+1)) THEN + FRAC=(CVAL-VAL(K))/(VAL(K+1)-VAL(K)) + XINT(ISWT)=X(K)+FRAC*(X(K+1)-X(K)) + YINT(ISWT)=Y(K)+FRAC*(Y(K+1)-Y(K)) + write(199,'(2i5,4f12.4)') n,k,frac,cval,val(k),val(k+1) + ISWT=ISWT+1 + ELSEIF(CVAL .LT. VAL(K) .AND. CVAL .GE. VAL(K+1)) THEN + FRAC=(VAL(K)-CVAL)/(VAL(K)-VAL(K+1)) + XINT(ISWT)=X(K)+FRAC*(X(K+1)-X(K)) + YINT(ISWT)=Y(K)+FRAC*(Y(K+1)-Y(K)) + write(199,'(2i5,4f12.4)') n,k,frac,cval,val(k),val(k+1) + ISWT=ISWT+1 + ENDIF + + ENDDO + + RETURN + END + diff --git a/src/chck.bmp b/src/chck.bmp new file mode 100644 index 0000000..7149d76 Binary files /dev/null and b/src/chck.bmp differ diff --git a/src/deln2 - Copy.f90 b/src/deln2 - Copy.f90 new file mode 100644 index 0000000..26865e5 --- /dev/null +++ b/src/deln2 - Copy.f90 @@ -0,0 +1,237 @@ + SUBROUTINE DELN2(NVERT,ISWT1) + + USE BLKMAP + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + + CHARACTER*80 LIND + CHARACTER*1 ANS + DATA SPAC/0.0/ + VOID = -1.E10 + NEDGE=0 + NINTV=1 + NGAP=0 + +! Check options + + IF(ISWT1 .EQ. 0) THEN + CALL TRIANOPT(NINTV,SPAC) + ELSE + NINTV=1 + SPAC=0 + ENDIF + +! Sort points into ascending x order + + CALL SORTDB(XUSR,NKEY,NVERT) + +! Drop points based on spacing + + IF(ISWT1 .NE. 0) THEN + IF(NINTV .GT. 1 .OR. SPAC .GT. 0.) THEN + CALL DROPPTS(NVERT,NINTV,SPAC) + ENDIF + ENDIF + +! Get location of supertriangle + + iprt=0 + + call supert(XUSR,YUSR,NVERT) + + NELTS=1 + + NVERTM=NVERT-3 + +! Loop on the vertices + + DO NN=1,NVERT-3 + +! process next point + + N=NKEY(NN) +! Skip out if inactive point + IF(N .EQ. 0) GO TO 500 + IF(LIST(N) .EQ. 0) GO TO 500 + + IF(NN .LT. NVERTM) THEN + DO KK=NN+1,NVERTM + K=NKEY(KK) + IF(K .NE. 0) THEN + IF(XUSR(N) .EQ. XUSR(K)) THEN + IF(YUSR(N) .EQ. YUSR(K)) THEN + WRITE(45,*) 'IDENT',N,K + NKEY(KK)=0 + ENDIF + ELSE + GO TO 200 + ENDIF + ENDIF + 200 CONTINUE + ENDDO + ENDIF + +! Set edge buffers to zero + + IF(NEDGE .GT. 0) THEN + DO J=1,NEDGE + IEDGE(J,1)=0 + IEDGE(J,2)=0 + END DO + ELSE + DO J=1,100 + IEDGE(J,1)=0 + IEDGE(J,2)=0 + END DO + ENDIF + NEDGE=0 + +! test for point in circumcircle + + if(n .eq. 6) then + aa=0 + endif + DO J=1,NELTS + CALL INSIDCIRC(XUSR,YUSR,J,N,ISWT) + +! If inside process edges + + IF(ISWT .EQ. 1) THEN + CALL PROCESS(J,NEDGE,NGAP) + ENDIF + END DO + +! Setup to form new triangles + + CALL SETEDG(NEDGE) + +! Now form triangles as needed + + DO J=1,NEDGE + NELFM(J)=0 + IF(IEDGE(J,1) .NE. 0) THEN + CALL FORMT(XUSR,YUSR,J,N,NGAP,KK,WD) + NELFM(J)=KK + ENDIF + END DO + + DO J=1,NEDGE + IF(NELFM(J) .GT. 0) THEN + CALL TESTTR(XUSR,YUSR,NELFM(J)) + ENDIF + ENDDO + + NEDGE=0 + iprt=0 + if(iprt .eq. 0) go to 500 + DO J=1,NELTS + IF(NOPEL(J,1) .GT. 0) THEN + WRITE(150+nn,'(2i5,2i10,19x,''1'')') J,(NOPEL(J,K),K=1,3) + ENDIF + END DO + ninnin=9999 + write(150+nn,'(i5)') ninnin + + do j=1,nvert + write(150+nn,'(i10,f16.6,f20.6,f10.2)') j,xusr(j),yusr(j),val(j) + enddo + write(150+nn,'(i10)') ninnin + 500 continue + END DO + +! Get rid of elements from super point + + CALL RIDPOINT(NVERT) + + XUSR(NP+1)=VOID + XUSR(NP+2)=VOID + XUSR(NP+3)=VOID + YUSR(NP+1)=VOID + YUSR(NP+2)=VOID + YUSR(NP+3)=VOID + DO J=1,NELTS + DO K=1,3 + NOPSTO(J,2*K-1,1)=NOPEL(J,K) + NOPSTO(J,2*K,1)=0 + ENDDO + NOPSTO(J,7,1)=0 + NOPSTO(J,8,1)=0 + IMATSTO(J,1)=1 + THTASTO(J,1)=0. + ENDDO + NP=NP-3 + NPSTO(1)=NP + NESTO(1)=NELTS + +! Get edge nodes for later filling + +! IF(ISWT1 .EQ. 0) THEN +! CALL GETEDG +! ENDIF + if(iswt1 .eq. 2) then + do j=1,np + xusrsto(j,1)=xusr(j) + yusrsto(j,1)=yusr(j) + enddo + call mergemesh1(1) +! call mergemesh + endif + CALL ADDMESH(1) + + RETURN + END SUBROUTINE + + + SUBROUTINE GETEDG + + USE BLKMAP + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + +! Look for edges that are duplicates + + DO N=1,NESTO(1) + DO NN=1,3 + N1=NOPEL(N,NN) + IF(NN .EQ. 3) THEN + N2=NOPEL(N,1) + ELSE + N2=NOPEL(N,NN+1) + ENDIF + + DO M=1,NESTO(1) + DO MM=1,3 + M1=NOPEL(M,MM) + IF(M1 .EQ. N2) THEN + +! Keep looking for match + + IF(MM .EQ. 3) THEN + M2=NOPEL(M,1) + ELSE + M2=NOPEL(M,MM+1) + ENDIF + IF(M2 .EQ. N1) THEN + +! We have a match, this is no edge skip out to next side + + GO TO 400 + ENDIF + ENDIF + ENDDO + ENDDO + +! No match these nodes are on an edge + + NINC(N1)=1 + NINC(N2)=1 + + 400 CONTINUE + ENDDO + ENDDO + RETURN + END \ No newline at end of file diff --git a/src/deln2.f90 b/src/deln2.f90 new file mode 100644 index 0000000..baa355f --- /dev/null +++ b/src/deln2.f90 @@ -0,0 +1,239 @@ + SUBROUTINE DELN2(NVERT,ISWT1) + + USE BLKMAP + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + + CHARACTER*80 LIND + CHARACTER*1 ANS + DATA SPAC/0.0/ + VOID = -1.E10 + NEDGE=0 + NINTV=1 + NGAP=0 + +! Check options + + IF(ISWT1 .EQ. 0) THEN + CALL TRIANOPT(NINTV,SPAC) + ELSE + NINTV=1 + SPAC=0 + ENDIF + +! Sort points into ascending x order + + CALL SORTDB(XUSR,NKEY,NVERT) + +! Drop points based on spacing + + IF(ISWT1 .NE. 0) THEN + IF(NINTV .GT. 1 .OR. SPAC .GT. 0.) THEN + CALL DROPPTS(NVERT,NINTV,SPAC) + ENDIF + ENDIF + +! Get location of supertriangle + + iprt=0 + + call supert(XUSR,YUSR,NVERT) + + NELTS=1 + + NVERTM=NVERT-3 + +! Loop on the vertices + + DO NN=1,NVERT-3 + +! process next point + + N=NKEY(NN) +! Skip out if inactive point + IF(N .EQ. 0) GO TO 500 + IF(LIST(N) .EQ. 0) GO TO 500 + + IF(NN .LT. NVERTM) THEN + DO KK=NN+1,NVERTM + K=NKEY(KK) + IF(K .NE. 0) THEN + IF(XUSR(N) .EQ. XUSR(K)) THEN + IF(YUSR(N) .EQ. YUSR(K)) THEN + WRITE(45,*) 'IDENT',N,K + NKEY(KK)=0 + ENDIF + ELSE + GO TO 200 + ENDIF + ENDIF + 200 CONTINUE + ENDDO + ENDIF + +! Set edge buffers to zero + + IF(NEDGE .GT. 0) THEN + DO J=1,NEDGE + IEDGE(J,1)=0 + IEDGE(J,2)=0 + END DO + ELSE + DO J=1,100 + IEDGE(J,1)=0 + IEDGE(J,2)=0 + END DO + ENDIF + NEDGE=0 + +! test for point in circumcircle + + if(n .eq. 6) then + aa=0 + endif + DO J=1,NELTS + CALL INSIDCIRC(XUSR,YUSR,J,N,ISWT) + WRITE(156,*) J,N,ISWT + +! If inside process edges + + IF(ISWT .EQ. 1) THEN + CALL PROCESS(J,NEDGE,NGAP) + WRITE(156,*) J,NEDGE,NGAP + ENDIF + END DO + +! Setup to form new triangles + + CALL SETEDG(NEDGE) + +! Now form triangles as needed + + DO J=1,NEDGE + NELFM(J)=0 + IF(IEDGE(J,1) .NE. 0) THEN + CALL FORMT(XUSR,YUSR,J,N,NGAP,KK,WD) + NELFM(J)=KK + ENDIF + END DO + + DO J=1,NEDGE + IF(NELFM(J) .GT. 0) THEN + CALL TESTTR(XUSR,YUSR,NELFM(J),WD) + ENDIF + ENDDO + + NEDGE=0 + iprt=1 + if(iprt .eq. 0) go to 500 + DO J=1,NELTS + IF(NOPEL(J,1) .GT. 0) THEN + WRITE(155,'(2i5,2i10,19x,''1'')') J,(NOPEL(J,K),K=1,3) + ENDIF + END DO + ninnin=9999 +! write(150+nn,'(i5)') ninnin + +! do j=1,nvert +! write(150+nn,'(i10,f16.6,f20.6,f10.2)') j,xusr(j),yusr(j),val(j) +! enddo +! write(150+nn,'(i10)') ninnin + 500 continue + END DO + +! Get rid of elements from super point + + CALL RIDPOINT(NVERT) + + XUSR(NP+1)=VOID + XUSR(NP+2)=VOID + XUSR(NP+3)=VOID + YUSR(NP+1)=VOID + YUSR(NP+2)=VOID + YUSR(NP+3)=VOID + DO J=1,NELTS + DO K=1,3 + NOPSTO(J,2*K-1,1)=NOPEL(J,K) + NOPSTO(J,2*K,1)=0 + ENDDO + NOPSTO(J,7,1)=0 + NOPSTO(J,8,1)=0 + IMATSTO(J,1)=1 + THTASTO(J,1)=0. + ENDDO + NP=NP-3 + NPSTO(1)=NP + NESTO(1)=NELTS + +! Get edge nodes for later filling + +! IF(ISWT1 .EQ. 0) THEN +! CALL GETEDG +! ENDIF + if(iswt1 .eq. 2) then + do j=1,np + xusrsto(j,1)=xusr(j) + yusrsto(j,1)=yusr(j) + enddo + call mergemesh1(1) +! call mergemesh + endif + CALL ADDMESH(1) + + RETURN + END SUBROUTINE + + + SUBROUTINE GETEDG + + USE BLKMAP + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + +! Look for edges that are duplicates + + DO N=1,NESTO(1) + DO NN=1,3 + N1=NOPEL(N,NN) + IF(NN .EQ. 3) THEN + N2=NOPEL(N,1) + ELSE + N2=NOPEL(N,NN+1) + ENDIF + + DO M=1,NESTO(1) + DO MM=1,3 + M1=NOPEL(M,MM) + IF(M1 .EQ. N2) THEN + +! Keep looking for match + + IF(MM .EQ. 3) THEN + M2=NOPEL(M,1) + ELSE + M2=NOPEL(M,MM+1) + ENDIF + IF(M2 .EQ. N1) THEN + +! We have a match, this is no edge skip out to next side + + GO TO 400 + ENDIF + ENDIF + ENDDO + ENDDO + +! No match these nodes are on an edge + + NINC(N1)=1 + NINC(N2)=1 + + 400 CONTINUE + ENDDO + ENDDO + RETURN + END \ No newline at end of file diff --git a/src/disp.bmp b/src/disp.bmp new file mode 100644 index 0000000..f2c35ee Binary files /dev/null and b/src/disp.bmp differ diff --git a/src/droppts.f90 b/src/droppts.f90 new file mode 100644 index 0000000..f013402 --- /dev/null +++ b/src/droppts.f90 @@ -0,0 +1,41 @@ + SUBROUTINE DROPPTS(NVERT,NINTV,SPAC) + + USE BLKMAP + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + + NN=0 + DO NM=1,NVERT + N=NKEY(NM) + IF(LIST(N) .EQ. 1) THEN + NN=NN+1 + IF(MOD(NN-1,NINTV) .EQ. 0) THEN + LIST(N)=1 + ELSE + LIST(N)=0 + ENDIF + ENDIF + ENDDO + + IF(SPAC .GT. 0.) THEN + DO NM=1,NVERT + N=NKEY(NM) + IF(LIST(N) .EQ. 1) THEN + IF(N .LT. NVERT) THEN + DO M=N+1,NVERT + IF(LIST(M) .EQ. 1) THEN + DISQ=(XUSR(M)-XUSR(N))**2+(XUSR(M)-XUSR(N))**2 + IF(DISQ .LT. SPAC**2) THEN + LIST(M)=0 + ENDIF + ENDIF + ENDDO + ENDIF + ENDIF + ENDDO + ENDIF + + RETURN + END diff --git a/src/form999.f90 b/src/form999.f90 new file mode 100644 index 0000000..c0eaa81 --- /dev/null +++ b/src/form999.f90 @@ -0,0 +1,420 @@ +!IPK NEW ROUTINE SEP 9 2006 + SUBROUTINE FORM999(ISWT9,iswtw,NELC) +! +! Generate continuity lines +! + + USE WINTERACTER + USE BLK1MOD + USE BLK2MOD + include 'd.inc' + +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + INCLUDE 'TXFRM.COM' + CHARACTER*1 IFLAG + DIMENSION DIRL(5000),IPROCES(MAXE) +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3,IERR + + DATA SPAC/10./,ieltyp/1/,ielsw/1/,iensw/0/ + +! DIST(N1,N2)=SQRT((CORD(N1,1)-CORD(N2,1))**2 & +! & +(CORD(N1,2)-CORD(N2,2))**2) +! PROJ(N1,N2,DR)= (CORD(N2,1)-CORD(N1,1))*COS(DR)+(CORD(N2,2)-CORD(N1,2))*SIN(DR) +! +! WRITE(150,*) 'IN FORM999',ISWT9,iswtw,NELC +! FLUSH(150) + if(iswtw .eq. 1) THEN + IFRMEL=0 + IGTWEL=0 + CALL ADD999(ISWT9,NELC) + RETURN + ENDIF + CALL WMessageBox(YesNo, QuestionIcon, 1,'Are 1-D elements already formed?','1-D ELEMENTS') + +! If answer 'Yes' set ifrmel to 0 +! + IF (WInfoDialog(4) .EQ. 2) then + IFRMEL=1 +!NO +! WRITE(150,*) 'GOING TO FROM1DEL' +! FLUSH(150) + CALL FORM1DEL +! WRITE(150,*) 'BACK FROM FROM1DEL' +! FLUSH(150) + + ELSE +!YES + IFRMEL=0 + + + CALL WMessageBox(YesNo, QuestionIcon, 1,'Is width data available?','WIDTH DATA') + +! If answer 'Yes' set igtwel to 0 +! + IF (WInfoDialog(4) .EQ. 2) then +!NO + IGTWEL=1 + CALL SETWID +! WRITE(150,*) 'BACK FROM SETWID' +! FLUSH(150) + ELSE +!YES + IGTWEL=0 +! CALL CCLINE(2) +! WRITE(150,*) 'GOING TO ADD999' +! FLUSH(150) + CALL ADD999(ISWT9,NELC) +! WRITE(150,*) 'BACK FROM ADD999' +! FLUSH(150) + RETURN + ENDIF + +100 CONTINUE + + ENDIF + +! GET NODAL CONNECTIONS +! WRITE(150,*) 'ABOUT TO GO TO NDNECON' +! FLUSH(150) + IERR=0 + CALL NDNECON(IERR) + +! START ALONG LINE OF ELEMENTS + + DO N=1,NTRAC + + N1=ITRAC(N) + IF(N .GT. 1) THEN + N0=ITRAC(N-1) + ENDIF + IF(N .LT. NTRAC) THEN + N2=ITRAC(N+1) + ENDIF + +! Get direction + + IF(N .EQ. 1) THEN + DIRX=XUSR(N2)-XUSR(N1) + DIRY=YUSR(N2)-YUSR(N1) + DIRL(N)=ATAN2(DIRX,-DIRY) + ELSEIF(N .EQ. NTRAC) THEN + DIRX=XUSR(N1)-XUSR(N0) + DIRY=YUSR(N1)-YUSR(N0) + DIRL(N)=ATAN2(DIRX,-DIRY) + ELSE + DIRX=XUSR(N2)-XUSR(N0) + DIRY=YUSR(N2)-YUSR(N0) + DIRL(N)=ATAN2(DIRX,-DIRY) + ENDIF + ENDDO + +! Move nodes apart adding new numbers + + DO N=1,NTRAC +! WRITE(150,*) 'STARTING NTRAC ITRAC',N,ITRAC(N) + N1=ITRAC(N) + CALL GETNOD(J) + JTRAC(N)=J +! XUSR(J)=XUSR(N1)-WIDTHD(N1)/2.*COS(DIRL(N)) +! YUSR(J)=YUSR(N1)-WIDTHD(N1)/2.*SIN(DIRL(N)) + XUSR(J)=XUSR(N1)-WIDTH(N1)/2.*COS(DIRL(N)) + YUSR(J)=YUSR(N1)-WIDTH(N1)/2.*SIN(DIRL(N)) + CORD(J,1)=(XUSR(J)+XS)/TXSCAL + CORD(J,2)=(YUSR(J)+YS)/TXSCAL + INEW(J)=1 + INSKP(J) = 0 + WD(J)=-9999. + WIDTH(J)=0. + SS1(J)=0. + SS2(J)=0. + WIDS(J)=0. + WIDBS(J)=0. + SSO(J)=0. + + CALL GETNOD(J1) + KTRAC(N)=J1 +! XUSR(J1)=XUSR(N1)+WIDTHD(N1)/2.*COS(DIRL(N)) +! YUSR(J1)=YUSR(N1)+WIDTHD(N1)/2.*SIN(DIRL(N)) + XUSR(J1)=XUSR(N1)+WIDTH(N1)/2.*COS(DIRL(N)) + YUSR(J1)=YUSR(N1)+WIDTH(N1)/2.*SIN(DIRL(N)) + CORD(J1,1)=(XUSR(J1)+XS)/TXSCAL + CORD(J1,2)=(YUSR(J1)+YS)/TXSCAL + INEW(J1)=1 + INSKP(J1) = 0 + WD(J1)=-9999. + WIDTH(J1)=0. + SS1(J1)=0. + SS2(J1)=0. + WIDS(J1)=0. + WIDBS(J1)=0. + SSO(J1)=0. + ENDDO + DO N=1,NTRAC-1 + CALL GETELM(J) + NOP(J,1)=ITRAC(N+1) + NOP(J,3)=ITRAC(N) + NOP(J,5)=JTRAC(N) + NOP(J,7)=JTRAC(N+1) + NOP(J,2)=0 + NOP(J,4)=0 + NOP(J,6)=0 + NOP(J,8)=0 + IMAT(J)=999 + NCORN(J) = 8 + IESKP(J) = 0 + CALL GETELM(J) + NOP(J,1)=ITRAC(N) + NOP(J,3)=ITRAC(N+1) + NOP(J,5)=KTRAC(N+1) + NOP(J,7)=KTRAC(N) + NOP(J,2)=0 + NOP(J,4)=0 + NOP(J,6)=0 + NOP(J,8)=0 + IMAT(J)=999 + NCORN(J) = 8 + IESKP(J) = 0 + NE = MAX(J,NE) + ENDDO + NE = MAX(J,NE) + + + RETURN + END + + SUBROUTINE FORM1DEL + + USE WINTERACTER + USE BLK1MOD + USE BLK2MOD + include 'd.inc' + +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + INCLUDE 'TXFRM.COM' + CHARACTER*1 IFLAG +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3,IERR + + CALL WMessageBox(YesNo, QuestionIcon, 1,'Are 1-D nodes already defined?','FORM 1-D ELEMENTS') + +! If answer 'Yes' set ifrmel to 0 +! + IF (WInfoDialog(4) .ne. 2) then + +! yes + CALL FRMEL(1) + ELSE +! no + CALL WMessageBox(YesNo, QuestionIcon, 1,'Use same width etc properties ?','FORM 1-D ELEMENTS') + +! If answer 'Yes' set IGWID=1 +! + IF (WInfoDialog(4) .ne. 2) then + +! yes + IGWID=1 + ELSE + IGWID=0 +! no + ENDIF + + CALL WMessageBox(OKCancel, 4, 1,'Click on each node to form elements?'//CHAR(13)// & + 'Then click quit to continue','FORM 1-D ELEMENTS') + JREF=0 + NTRAC=0 + NHTP=0 + NBRR=3 + NMESS=15 + CALL HEDR + + 100 CONTINUE + CALL XYLOC(XX,YY,IFLAG,IBOX) + IF(IRMAIN .EQ. 1) RETURN + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + GO TO 200 + ENDIF +! + IF (IFLAG .EQ. 'c') THEN +! + call getnod(j) + NTRAC=NTRAC+1 + ITRAC(NTRAC)=J + INSKP(J)=0 + CORD(J,1) = XX + CORD(J,2) = YY + INEW(J) = 1 +! + XUSR(J) = XX*TXSCAL - XS + YUSR(J) = YY*TXSCAL - YS + IF (J .GT. NP) NP = J + call pltnod(j,1) + IF(JREF .EQ.0) THEN + WIDTH(J)=50. + call nodedisp(j) + ELSE + WIDTH(J)=WIDTH(J1) + WD(J)=WD(J1) + SS1(J)=SS1(J1) + SS2(J)=SS2(J1) + WIDS(J)=WIDS(J1) + WIDBS(J)=WIDBS(J1) + SSO(J)=SSO(J1) + BS1(J)=BS1(J1) + IF(IGWID .EQ. 0) THEN + call nodedisp(j) + ENDIF + CALL PLTNOD(J,0) + call getelm(k) + NOP(K,1)=J1 + NOP(K,2)=0 + NOP(K,3)=J + NCORN(K)=3 + IMAT(K)=1 + IESKP(K) = 0 + NE = MAX(K,NE) + IERC=0 + CALL PLTELM(K,IERC) + + ENDIF + J1=J + JREF=1 + GO TO 100 + ENDIF + ENDIF + + 200 CONTINUE + call clscrn + CALL PLOTOT(1) + NHTP=1 + NMESS=0 + NBRR=0 + CALL HEDR + RETURN + END + + SUBROUTINE SETWID + + CALL FRMEL(0) + RETURN + END + + SUBROUTINE FRMEL(ISW) + + USE WINTERACTER + USE BLK1MOD + USE BLK2MOD + include 'd.inc' + +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + INCLUDE 'TXFRM.COM' + CHARACTER*1 IFLAG +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + + integer :: N1,N2,N3,IERR + + NHTP=0 + NBRR=3 + NMESS=15 + CALL HEDR + + IF(ISW .EQ. 1) THEN + CALL WMessageBox(YesNo, QuestionIcon, 1,'Is width data available?','WIDTH DATA') + +! If answer 'Yes' set igtwel to 0 +! + IF (WInfoDialog(4) .EQ. 2) then +!NO + IGTWEL=1 + ELSE +!YES + IGTWEL=0 + ENDIF + ELSE + + IGTWEL=1 + ENDIF + + IF(IGTWEL .EQ. 1) THEN + CALL WMessageBox(YesNo, QuestionIcon, 1,'Use same width etc properties ?','FORM 1-D ELEMENTS') + +! If answer 'Yes' set IGWID=1 +! + IF (WInfoDialog(4) .ne. 2) then + +! yes + IGWID=1 + ELSE + IGWID=0 +! no + ENDIF + ENDIF + NTRAC=0 + 100 CONTINUE + CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,J,IFLAG,INSKP,IBOX) + IF(IRMAIN .EQ. 1) RETURN + IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN + GO TO 200 + ENDIF +! + IF (IFLAG .EQ. 'c') THEN +! + IF(IGTWEL .EQ. 1) THEN + IF(NTRAC .EQ. 0) THEN + call nodedisp(j) + ELSE + WIDTH(J)=WIDTH(J1) + WD(J)=WD(J1) + SS1(J)=SS1(J1) + SS2(J)=SS2(J1) + WIDS(J)=WIDS(J1) + WIDBS(J)=WIDBS(J1) + SSO(J)=SSO(J1) + BS1(J)=BS1(J1) + IF(IGWID .EQ. 0) THEN + call nodedisp(j) + ENDIF + ENDIF + ENDIF + CALL PLTNOD(J,0) +! IF(ISW .EQ. 1) THEN + if(ntrac .ne. 0) then + call getelm(k) + NOP(K,1)=J1 + NOP(K,2)=0 + NOP(K,3)=J + NCORN(K)=3 + IMAT(K)=1 + IESKP(K) = 0 + NE = MAX(K,NE) + IERC=0 + CALL PLTELM(K,IERC) + ENDIF + J1=J + NTRAC=NTRAC+1 + ITRAC(NTRAC)=J + GO TO 100 + ENDIF + 200 CONTINUE + RETURN + END \ No newline at end of file diff --git a/src/formlinel - Copy.f90 b/src/formlinel - Copy.f90 new file mode 100644 index 0000000..ba3dd86 --- /dev/null +++ b/src/formlinel - Copy.f90 @@ -0,0 +1,122 @@ + SUBROUTINE FORMLINEL(I1D,I2D,ALXX,ALYY,ALWD,JST,JEND,JKP,XLENGTH,ITYPB,ICTT) +! +! Routine to create a form series of nodes along a line +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' + REAL*8 ALXX(*),ALYY(*),ALWD(*) +! COMPUTE OVERALL LENGTH + + TOTLEN=0. + DO J=JST,JEND-1 + TOTLEN=TOTLEN+SQRT((ALXX(J+1)-ALXX(J))**2+(ALYY(J+1)-ALYY(J))**2) + ENDDO +! ESTIMATE NUMBER OF ELEMENTS + NELTS=TOTLEN*TXSCAL/XLENGTH+1 + XLENGTH=TOTLEN*TXSCAL/NELTS +! GET NEW NODE LOCATIONS AND CREAT ELEMENT + + IF(JKP .EQ. 0) THEN + CALL GETNOD(J) + JKP=J +! +! Store ALXX and ALYY into it +! + + CORD(J,1) = ALXX(1) + CORD(J,2) = ALYY(1) + IF(ALWD(1).GT. 0.) THEN + WIDTH(J)=ALWD(1) + ENDIF + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = ALXX(1)*TXSCAL - XS + YUSR(J) = ALYY(1)*TXSCAL - YS +! +! Display point +! + ENDIF + CALL PLTNOD(JKP,1) + JPTC=JST+1 + XLENGTHR=XLENGTH/TXSCAL + XCUR=ALXX(JST) + YCUR=ALYY(JST) + DO N=1,NELTS + 500 ANGLEL=ATAN2(ALYY(JPTC)-ALYY(JPTC-1),ALXX(JPTC)-ALXX(JPTC-1)) + XNEXT=XCUR+XLENGTHR*COS(ANGLEL) + YNEXT=YCUR+XLENGTHR*SIN(ANGLEL) + IF(ALXX(JPTC)-ALXX(JPTC-1) .NE. 0.) THEN + FRAC=(XNEXT-ALXX(JPTC-1))/(ALXX(JPTC)-ALXX(JPTC-1)) + ELSE + FRAC=(YNEXT-ALYY(JPTC-1))/(ALYY(JPTC)-ALYY(JPTC-1)) + ENDIF + IF(FRAC .GT. 1. .AND. JPTC .LT. JEND) THEN + XLENGTHR=XLENGTHR-SQRT((ALXX(JPTC)-XCUR)**2+(ALYY(JPTC)-YCUR)**2) + XCUR=ALXX(JPTC) + YCUR=ALYY(JPTC) + JPTC=JPTC+1 + GO TO 500 + ENDIF +! GET NEW LOCATION + + CALL GETNOD(J) + + IF(ALWD(1).GT. 0.) THEN + WIDTH(J)=ALWD(JPTC-1)+FRAC*(ALWD(JPTC)-ALWD(JPTC-1)) + ENDIF +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = XNEXT + CORD(J,2) = YNEXT + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = XNEXT*TXSCAL - XS + YUSR(J) = YNEXT*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) + XCUR=XNEXT + YCUR=YNEXT + XLENGTHR=XLENGTH/TXSCAL + + IF(I1D .EQ. 1 .OR. I2D .EQ. 1) THEN + IF(N .EQ. 1) THEN + J1=JKP + IF(ALWD(1) .NE. 0.) GO TO 600 + call nodedisp(jKP) + ENDIF + IF(ALWD(1) .NE. 0.) GO TO 600 + WIDTH(J)=WIDTH(J1) + WD(J)=WD(J1) + SS1(J)=SS1(J1) + SS2(J)=SS2(J1) + WIDS(J)=WIDS(J1) + WIDBS(J)=WIDBS(J1) + SSO(J)=SSO(J1) + BS1(J)=BS1(J1) +600 call getelm(k) + NOP(K,1)=J1 + NOP(K,2)=0 + NOP(K,3)=J + NCORN(K)=3 + IMAT(K)=ITYPB + IESKP(K) = 0 + NE = MAX(K,NE) + IERC=0 + CALL PLTELM(K,IERC) + J1=J + ENDIF + + ENDDO + JKP=J + WRITE(155,*),JST,JEND,JKP + RETURN + END + + \ No newline at end of file diff --git a/src/formlinel.f90 b/src/formlinel.f90 new file mode 100644 index 0000000..a8c5955 --- /dev/null +++ b/src/formlinel.f90 @@ -0,0 +1,265 @@ + SUBROUTINE FORMLINEL(I1D,I2D,JST,JEND,JKP,XLENGTH,ITYPB,ICTT) +! +! Routine to create a form series of nodes along a line +! + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + INCLUDE 'TXFRM.COM' +! COMPUTE OVERALL LENGTH + REAL*8 XNEXT,YNEXT,FRAC,XCUR,YCUR,ZNEXT(3),ZCUR(3) + REAL*8 EMB + EMB=5. + TOTLEN=0. + DO J=JST,JEND-1 + TOTLEN=TOTLEN+SQRT((ALXX(J+1)-ALXX(J))**2+(ALYY(J+1)-ALYY(J))**2) + ENDDO +! ESTIMATE NUMBER OF ELEMENTS + NELTS=TOTLEN*TXSCAL/XLENGTH+1 + if(ictt .ne. 0) then + nelts=nelts+2 + if(ictt .eq. 1) then + XLENGTH=TOTLEN*TXSCAL/(NELTS-2) + else + XLENGTH=(TOTLEN*TXSCAL-EMB*2)/(NELTS-2) + ENDIF + ELSE + XLENGTH=TOTLEN*TXSCAL/NELTS + ENDIF +! GET NEW NODE LOCATIONS AND CREAT ELEMENT +! JFIST=0 + IF(JKP .EQ. 0) THEN +! JFIST=1 + CALL GETNOD(J) + JKP=J +! +! Store ALXX and ALYY into it +! + + CORD(J,1) = ALXX(1) + CORD(J,2) = ALYY(1) + WD(J)=HMID(J) + HSET(J,1)=HLEFT(1) + HSET(J,2)=HMID(1) + HSET(J,3)=HRIGHT(1) + IF(ALWD(1).GT. 0.) THEN + WIDTHD(J)=ALWD(1) + ENDIF + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = ALXX(1)*TXSCAL - XS + YUSR(J) = ALYY(1)*TXSCAL - YS +! +! Display point +! + ENDIF + CALL PLTNOD(JKP,1) + JPTC=JST+1 + XLENGTHR=XLENGTH/TXSCAL + XCUR=ALXX(JST) + YCUR=ALYY(JST) + DO N=1,NELTS + IF(NELTS .EQ. 1) THEN + XNEXT=ALXX(JEND) + YNEXT=ALYY(JEND) + if(ictt .eq. 0) then + ZNEXT(1)=HLEFT(JEND) + ZNEXT(2)=HMID(JEND) + ZNEXT(3)=HRIGHT(JEND) + else + ZNEXT(1)=HLEFT(JST) + ZNEXT(2)=HMID(JST) + ZNEXT(3)=HRIGHT(JST) + endif + CALL GETNOD(J) + + IF(ALWD(J).GT. 0.) THEN + WIDTHD(J)=ALWD(JEND) + ENDIF + ELSEIF(N .EQ. 1 .AND. ICTT .NE. 0) THEN + IF(ICTT .EQ. 1) THEN + XNEXT=XCUR + YNEXT=YCUR + ZCUR(1)=HLEFT(JST) + ZCUR(2)=HMID(JST) + ZCUR(3)=HRIGHT(JST) + ZNEXT(1)=HLEFT(JST) + ZNEXT(2)=HMID(JST) + ZNEXT(3)=HRIGHT(JST) + ELSE + ANGLEL=ATAN2(ALYY(JPTC)-ALYY(JPTC-1),ALXX(JPTC)-ALXX(JPTC-1)) + XNEXT=XCUR+EMB/TXSCAL*COS(ANGLEL) + YNEXT=YCUR+EMB/TXSCAL*SIN(ANGLEL) + ZCUR(1)=HLEFT(JST) + ZCUR(2)=HMID(JST) + ZCUR(3)=HRIGHT(JST) + ENDIF + CALL GETNOD(J) + IF(ALWD(J).GT. 0.) THEN + WIDTHD(J)=ALWD(JST) + ENDIF +! ELSEIF(N .EQ. 1 .AND. ICTT .EQ. 0) THEN +! ANGLEL=ATAN2(ALYY(JPTC)-ALYY(JPTC-1),ALXX(JPTC)-ALXX(JPTC-1)) +! XNEXT=XCUR+EMB/TXSCAL*COS(ANGLEL) +! YNEXT=YCUR+EMB/TXSCAL*SIN(ANGLEL) +! ZCUR(1)=HLEFT(JST+1) +! ZCUR(2)=HMID(JST+1) +! ZCUR(3)=HRIGHT(JST+1) +! CALL GETNOD(J) +! IF(ALWD(J).GT. 0.) THEN +! WIDTHD(J)=ALWD(JST+1) +! ENDIF + ELSEIF(N .EQ. NELTS .AND. ICTT .NE. 0) THEN + IF(ICTT .EQ. 1) THEN + XNEXT=ALXX(JEND) + YNEXT=ALYY(JEND) + ZCUR(1)=HLEFT(JEND) + ZCUR(2)=HMID(JEND) + ZCUR(3)=HRIGHT(JEND) + ZNEXT(1)=ZCUR(1) + ZNEXT(2)=ZCUR(2) + ZNEXT(3)=ZCUR(3) + ELSE + XNEXT=ALXX(JEND) + YNEXT=ALYY(JEND) + ZCUR(1)=HLEFT(JEND) + ZCUR(2)=HMID(JEND) + ZCUR(3)=HRIGHT(JEND) + ENDIF + CALL GETNOD(J) + IF(ALWD(J).GT. 0.) THEN + WIDTHD(J)=ALWD(JST) + ENDIF + ELSE + 500 ANGLEL=ATAN2(ALYY(JPTC)-ALYY(JPTC-1),ALXX(JPTC)-ALXX(JPTC-1)) + XNEXT=XCUR+XLENGTHR*COS(ANGLEL) + YNEXT=YCUR+XLENGTHR*SIN(ANGLEL) + IF(ALXX(JPTC)-ALXX(JPTC-1) .NE. 0.) THEN + FRAC=(XNEXT-ALXX(JPTC-1))/(ALXX(JPTC)-ALXX(JPTC-1)) + ELSEIF(ALYY(JPTC)-ALYY(JPTC-1) .NE. 0.) THEN + FRAC=(YNEXT-ALYY(JPTC-1))/(ALYY(JPTC)-ALYY(JPTC-1)) + ELSE + FRAC=1.5 + ENDIF + + IF(FRAC .GT. 1.00001 .AND. JPTC .LT. JEND) THEN + XLENGTHR=XLENGTHR-SQRT((ALXX(JPTC)-XCUR)**2+(ALYY(JPTC)-YCUR)**2) + XCUR=ALXX(JPTC) + YCUR=ALYY(JPTC) + ZCUR(1)=HLEFT(JPTC) + ZCUR(2)=HMID(JPTC) + ZCUR(3)=HRIGHT(JPTC) + JPTC=JPTC+1 + GO TO 500 + ENDIF + if(n .eq. nelts .and. ictt .eq. 0) then + ZNEXT(1)=HLEFT(JPTC-1) + ZNEXT(2)=HMID(JPTC-1) + ZNEXT(3)=HRIGHT(JPTC-1) + else + ZNEXT(1)=HLEFT(JPTC-1)+FRAC*(HLEFT(JPTC)-HLEFT(JPTC-1)) + ZNEXT(2)=HMID(JPTC-1)+FRAC*(HMID(JPTC)-HMID(JPTC-1)) + ZNEXT(3)=HRIGHT(JPTC-1)+FRAC*(HRIGHT(JPTC)-HRIGHT(JPTC-1)) + endif + if(ictt .eq. 2) then + ZNEXT(1)=-9999. + ZNEXT(2)=-9999. + ZNEXT(3)=-9999. + endif +! GET NEW LOCATION + + CALL GETNOD(J) + + IF(ALWD(1).GT. 0.) THEN + WIDTHD(J)=ALWD(JPTC-1)+FRAC*(ALWD(JPTC)-ALWD(JPTC-1)) + ENDIF + ENDIF +! +! Store GRIDX and GRIDY into it +! + CORD(J,1) = XNEXT + CORD(J,2) = YNEXT + WD(J)=ZNEXT(2) + HSET(J,1)=ZNEXT(1) + HSET(J,2)=ZNEXT(2) + HSET(J,3)=ZNEXT(3) + INEW(J) = 1 + INSKP(J) = 0 +! + XUSR(J) = XNEXT*TXSCAL - XS + YUSR(J) = YNEXT*TXSCAL - YS +! +! Display point +! + CALL PLTNOD(J,1) + XCUR=XNEXT + YCUR=YNEXT + XLENGTHR=XLENGTH/TXSCAL + + IF(I1D .EQ. 1 .OR. I2D .EQ. 1) THEN + IF(N .EQ. 1) THEN + J1=JKP + IF(ALWD(1) .NE. 0.) GO TO 600 + call nodedisp(jKP) + ENDIF + IF(ALWD(1) .NE. 0.) GO TO 600 + WIDTHD(J)=WIDTHD(J1) + WD(J)=WD(J1) + SS1(J)=SS1(J1) + SS2(J)=SS2(J1) + WIDS(J)=WIDS(J1) + WIDBS(J)=WIDBS(J1) + SSO(J)=SSO(J1) + BS1(J)=BS1(J1) +600 CONTINUE +! IF(N .EQ. 1 .AND. ICTT .EQ. 1) THEN +! J1=J +! CYCLE +! ELSEIF(N .EQ. NELTS .AND. ICTT .EQ. 1) THEN + IF(N .EQ. NELTS .AND. ICTT .EQ. 1) THEN + WIDTHD(J1)=WIDTHD(J) + WD(J1)=WD(J) + SS1(J1)=SS1(J) + SS2(J1)=SS2(J) + WIDS(J1)=WIDS(J) + WIDBS(J1)=WIDBS(J) + SSO(J1)=SSO(J) + BS1(J1)=BS1(J) + XUSR(J1)=XUSR(J) + YUSR(J1)=YUSR(J) + CORD(J1,1)=CORD(J,1) + CORD(J1,2)=CORD(J,2) + HSET(J1,1)=HSET(J,1) + HSET(J1,2)=HSET(J,2) + HSET(J1,3)=HSET(J,3) + ENDIF + call getelm(k) + if(n .eq. 1 .and. ictt .eq. 0 .and. jst .ne. 1) then + wd(j1)=wd(j) + hset(j1,1)=hset(j,1) + hset(j1,2)=hset(j,2) + hset(j1,3)=hset(j,3) + endif + NOP(K,1)=J1 + NOP(K,2)=0 + NOP(K,3)=J + NCORN(K)=3 + IMAT(K)=ITYPB + if(ictt .eq. 1) then + if(n .eq. 1) imat(k)= 2000 + if(n .eq. nelts) imat(k)= 2001 + endif + IESKP(K) = 0 + NE = MAX(K,NE) + IERC=0 + CALL PLTELM(K,IERC) + J1=J + ENDIF + + ENDDO + JKP=J + RETURN + END + + \ No newline at end of file diff --git a/src/frmnodt.f90 b/src/frmnodt.f90 new file mode 100644 index 0000000..6874960 --- /dev/null +++ b/src/frmnodt.f90 @@ -0,0 +1,58 @@ + SUBROUTINE FRMNODT(X1,Y1,X2,Y2,X3,Y3,NPTS) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + +! X1,X2,X3 AND Y1,Y2,Y3 are vertices of triangle +! NPTS is the nominal number of elements on each side + + +! Work along first side AND backwards along second line + + DO N=1,NPTS-1 + RATIO=FLOAT(N)/FLOAT(NPTS) + X12=X1+RATIO*(X2-X1) + Y12=Y1+RATIO*(Y2-Y1) + X32=X3+RATIO*(X2-X3) + Y32=Y3+RATIO*(Y2-Y3) + +! Now get interior points + + NINT=NPTS-N + DO M=1,NINT-1 + RATIO=FLOAT(M)/FLOAT(NINT) + XNEW=X12+RATIO*(X32-X12) + YNEW=Y12+RATIO*(Y32-Y12) + CALL DEFNOD(XNEW,YNEW) + ENDDO + ENDDO + RETURN + END + + SUBROUTINE DEFNOD(XNEW,YNEW) + + USE BLK1MOD + USE BLK2MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'BLK2.COM' + INCLUDE 'TXFRM.COM' + + CALL GETNOD(N2) + CORD(N2,1) = XNEW + CORD(N2,2) = YNEW + WD(N2)=-9999. + WIDTH(N2) = 0. + SS1(N2)=0. + SS2(N2)=0. + WIDS(N2)=0. + BS1(N2)=0. + INSKP(N2)=0 + INEW(N2) = 1 +! + XUSR(N2) = CORD(N2,1)*TXSCAL - XS + YUSR(N2) = CORD(N2,2)*TXSCAL - YS + LIST(N2)=1 + CALL PLTNOD(N2,1) + + RETURN + END \ No newline at end of file diff --git a/src/getlaydat.f90 b/src/getlaydat.f90 new file mode 100644 index 0000000..831f520 --- /dev/null +++ b/src/getlaydat.f90 @@ -0,0 +1,58 @@ + SUBROUTINE GETLAYDAT(NLAY,ipos,rlay) + + use winteracter + + implicit none + + include 'D.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + INTEGER :: IPOS,NLAY,I + INTEGER :: JNK,ierr + REAL :: rlay(9) + + call wdialogload(IDD_LAY) + ierr=infoerror(1) + + + IF(IPOS .EQ. 1) THEN + call wdialogputRadioButton(idf_radio1) + ELSE + call wdialogputRadioButton(idf_radio2) + ENDIF + CALL WDialogPutINTEGER(IDF_INTEGER1,NLAY) + do i=1,7 + CALL WGridPutCellReal(IDF_GRID1,i,1,rlay(i)) + enddo + + + CALL WDialogSelect(IDD_LAY) + ierr=infoerror(1) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + + do + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + call wdialoggetradiobutton(idf_radio1,ipos) + + CALL WDialogGetINTEGER(IDF_INTEGER1,NLAY) + do i=1,7 + CALL WGridGetCellReal(IDF_GRID1,i,1,rlay(i)) + enddo + return + ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN + RETURN + endif +!IPK SEP02 + return + enddo + RETURN + END diff --git a/src/interpelv.f90 b/src/interpelv.f90 new file mode 100644 index 0000000..1b393e4 --- /dev/null +++ b/src/interpelv.f90 @@ -0,0 +1,78 @@ + SUBROUTINE INTERPWLV(NODE1,H,ARIV,WRIV,DWRIV) + + USE BLK1MOD +! INCLUDE 'BLK1.COM' + + NLSEC11=NRIVCR1(node1) + IF(NRIVL(NLSEC11) .EQ. 0) THEN + IF(WTRIVCR1(node1) .gt. 0.) THEN + ARIV=0. + WRIV=0. + RETURN + ELSE + A11=0. + W11=0. + DW11=0. + GO TO 272 + ENDIF + ENDIF + DO K=2,NRIVL(NLSEC11) + DEPL=CRSDAT(NLSEC11,K,1)-CRSDAT(NLSEC11,1,1) + IF(DEPL .GT. H) THEN + FRAC= (H+CRSDAT(NLSEC11,1,1)-CRSDAT(NLSEC11,K-1,1))/& + (CRSDAT(NLSEC11,K,1)-CRSDAT(NLSEC11,K-1,1)) + A11=CRSDAT(NLSEC11,K-1,2)*(1.-FRAC) +& + CRSDAT(NLSEC11,K,2)*FRAC + W11=CRSDAT(NLSEC11,K-1,3)*(1.-FRAC) +& + CRSDAT(NLSEC11,K,3)*FRAC + DW11=(CRSDAT(NLSEC11,K,3)-CRSDAT(NLSEC11,K-1,3))/& + (CRSDAT(NLSEC11,K,1)-CRSDAT(NLSEC11,K-1,1)) + GO TO 272 + ENDIF + ENDDO + +!IPK MAY04 ALLOW FOR LEVEL ABOVE HIGHEST LAYER + + W11=CRSDAT(NLSEC11,NRIVL(NLSEC11),3) + DW11=0. + A11=CRSDAT(NLSEC11,NRIVL(NLSEC11),2)+W11*(H-DEPL) + + 272 CONTINUE + NLSEC12=NRIVCR2(node1) + IF(NRIVL(NLSEC12) .EQ. 0) THEN + IF(WTRIVCR2(node1) .gt. 0.) THEN + ARIV=0. + WRIV=0. + RETURN + ELSE + A12=0. + W12=0. + DW12=0. + GO TO 274 + ENDIF + ENDIF + DO K=2,NRIVL(NLSEC12) + DEPL=CRSDAT(NLSEC12,K,1)-CRSDAT(NLSEC12,1,1) + IF(DEPL .GT. H) THEN + FRAC= (H+CRSDAT(NLSEC12,1,1)-CRSDAT(NLSEC12,K-1,1))/& + (CRSDAT(NLSEC12,K,1)-CRSDAT(NLSEC12,K-1,1)) + A12=CRSDAT(NLSEC12,K-1,2)*(1.-FRAC) +& + CRSDAT(NLSEC12,K,2)*FRAC + W12=CRSDAT(NLSEC12,K-1,3)*(1.-FRAC) +& + CRSDAT(NLSEC12,K,3)*FRAC + DW12=(CRSDAT(NLSEC12,K,3)-CRSDAT(NLSEC12,K-1,3))/& + (CRSDAT(NLSEC12,K,1)-CRSDAT(NLSEC12,K-1,1)) + GO TO 274 + ENDIF + ENDDO +!IPK MAY04 ALLOW FOR LEVEL ABOVE HIGHEST LAYER + W12=CRSDAT(NLSEC12,NRIVL(NLSEC12),3) + DW12=0. + A12=CRSDAT(NLSEC12,NRIVL(NLSEC12),2)+W12*(H-DEPL) + 274 CONTINUE + ARIV=WTRIVCR1(node1)*A11+WTRIVCR2(node1)*A12 + WRIV=WTRIVCR1(node1)*W11+WTRIVCR2(node1)*W12 + DWRIV=WTRIVCR1(node1)*DW11+WTRIVCR2(node1)*DW12 + + 300 RETURN + END \ No newline at end of file diff --git a/src/resource.fd b/src/resource.fd new file mode 100644 index 0000000..c22a66d --- /dev/null +++ b/src/resource.fd @@ -0,0 +1,276 @@ +!MS$FREEFORM +! Microsoft Developer Studio generated include file. +! Used by rmagen73f.RC +! + integer, parameter :: IDD_DIALOG1 = 101 + integer, parameter :: IDD_DIALOG02 = 102 + integer, parameter :: IDD_DIALOG05 = 103 + integer, parameter :: IDD_DIALOG04 = 104 + integer, parameter :: IDD_DIALOG006 = 105 + integer, parameter :: IDD_DIALOG07 = 106 + integer, parameter :: IDD_DIALOG08 = 107 + integer, parameter :: IDD_DIALOG09 = 108 + integer, parameter :: IDD_DIALOG10 = 109 + integer, parameter :: IDD_DIALOG010 = 110 + integer, parameter :: IDD_DIALOG001 = 111 + integer, parameter :: IDD_REGST = 112 + integer, parameter :: IDD_DIALOG012 = 113 + integer, parameter :: IDD_SLRGNO = 114 + integer, parameter :: IDD_CONFIRM = 115 + integer, parameter :: IDD_nodedata = 116 + integer, parameter :: IDD_eltdata = 117 + integer, parameter :: IDD_SELNODE = 118 + integer, parameter :: IDD_SELELT = 119 + integer, parameter :: IDD_ELTERR = 120 + integer, parameter :: IDD_headertp = 121 + integer, parameter :: IDD_TRIAN = 122 + integer, parameter :: IDD_NODERR = 123 + integer, parameter :: IDD_TRIANG = 124 + integer, parameter :: IDD_QUAD = 125 + integer, parameter :: IDD_DIALOG06 = 126 + integer, parameter :: IDD_CSLOC = 127 + integer, parameter :: IDD_CREATM = 128 + integer, parameter :: IDD_TEMPLATE001 = 129 + integer, parameter :: IDD_CREATM1 = 130 + integer, parameter :: IDD_ORDEROUT = 131 + integer, parameter :: IDD_TEMPLATE002 = 132 + integer, parameter :: IDD_selcrsec = 133 + integer, parameter :: IDD_TEMPLATE003 = 134 + integer, parameter :: IDD_LIMITS = 135 + integer, parameter :: IDD_lAY = 136 + integer, parameter :: IDD_TEMPLATE004 = 137 + integer, parameter :: IDD_SELTFL2 = 148 + integer, parameter :: IDD_GETINT = 153 + integer, parameter :: IDD_GETFPN = 154 + integer, parameter :: IDD_GETINTP = 160 + integer, parameter :: IDF_LABEL1 = 1001 + integer, parameter :: IDF_LABEL2 = 1002 + integer, parameter :: IDF_LABEL3 = 1003 + integer, parameter :: IDF_LABEL4 = 1004 + integer, parameter :: IDF_CMAP8 = 1005 + integer, parameter :: IDF_LABEL6 = 1005 + integer, parameter :: IDF_CMAP9 = 1006 + integer, parameter :: IDF_LABEL8 = 1006 + integer, parameter :: IDF_CMAP0 = 1007 + integer, parameter :: IDF_LABEL9 = 1007 + integer, parameter :: IDF_CMAP1 = 1008 + integer, parameter :: IDF_LABEL10 = 1008 + integer, parameter :: IDF_CMAP2 = 1009 + integer, parameter :: IDF_LABEL12 = 1009 + integer, parameter :: IDF_CMAP10 = 1010 + integer, parameter :: IDF_CMAP11 = 1011 + integer, parameter :: IDF_CMAP3 = 1012 + integer, parameter :: IDF_STRING1 = 1013 + integer, parameter :: IDF_STRING2 = 1014 + integer, parameter :: IDF_STRING3 = 1015 + integer, parameter :: IDF_STRING4 = 1016 + integer, parameter :: IDF_STRING5 = 1017 + integer, parameter :: IDF_STRING6 = 1018 + integer, parameter :: IDF_STRING7 = 1019 + integer, parameter :: IDF_STRING8 = 1020 + integer, parameter :: IDF_STRING9 = 1021 + integer, parameter :: IDF_STRING10 = 1022 + integer, parameter :: IDF_STRING11 = 1023 + integer, parameter :: IDF_STRING12 = 1024 + integer, parameter :: IDF_STRING13 = 1025 + integer, parameter :: IDF_STRING14 = 1026 + integer, parameter :: IDF_STRING15 = 1027 + integer, parameter :: IDF_STRING16 = 1028 + integer, parameter :: IDF_STRING17 = 1029 + integer, parameter :: IDF_STRING18 = 1030 + integer, parameter :: IDF_STRING19 = 1031 + integer, parameter :: IDF_STRING20 = 1032 + integer, parameter :: IDF_STRING21 = 1033 + integer, parameter :: IDF_STRING22 = 1034 + integer, parameter :: IDF_STRING23 = 1035 + integer, parameter :: IDF_CHECK1 = 1036 + integer, parameter :: IDF_CHECK2 = 1037 + integer, parameter :: IDF_CHECK3 = 1038 + integer, parameter :: IDF_CHECK4 = 1039 + integer, parameter :: IDF_CHECK5 = 1040 + integer, parameter :: IDF_STRING24 = 1041 + integer, parameter :: IDF_CHECK6 = 1041 + integer, parameter :: IDF_LABEL5 = 1042 + integer, parameter :: IDF_CHECK7 = 1042 + integer, parameter :: IDF_STRING35 = 1042 + integer, parameter :: IDF_CMAP4 = 1043 + integer, parameter :: IDF_CHECK8 = 1043 + integer, parameter :: IDF_LABEL11 = 1043 + integer, parameter :: IDF_CMAP5 = 1044 + integer, parameter :: IDF_CHECK9 = 1044 + integer, parameter :: IDF_CMAP6 = 1045 + integer, parameter :: IDF_CHECK10 = 1045 + integer, parameter :: IDF_CMAP7 = 1046 + integer, parameter :: IDF_RADIO1 = 1047 + integer, parameter :: IDF_RADIO2 = 1048 + integer, parameter :: IDF_RADIO3 = 1049 + integer, parameter :: IDF_RADIO4 = 1050 + integer, parameter :: IDF_RADIO5 = 1051 + integer, parameter :: IDF_RADIO6 = 1052 + integer, parameter :: IDF_RADIO7 = 1053 + integer, parameter :: IDF_RADIO8 = 1054 + integer, parameter :: IDF_RADIO9 = 1055 + integer, parameter :: IDF_LABEL7 = 1056 + integer, parameter :: IDF_RADIO10 = 1056 + integer, parameter :: IDF_INTEGER1 = 1057 + integer, parameter :: IDF_RADIO11 = 1057 + integer, parameter :: IDF_INTEGER2 = 1058 + integer, parameter :: IDF_RADIO12 = 1058 + integer, parameter :: IDF_CHECK11 = 1059 + integer, parameter :: IDF_INTEGER3 = 1059 + integer, parameter :: IDF_RADIO17 = 1059 + integer, parameter :: IDF_REAL1 = 1060 + integer, parameter :: IDF_INTEGER4 = 1060 + integer, parameter :: IDF_REAL2 = 1061 + integer, parameter :: IDF_INTEGER5 = 1061 + integer, parameter :: IDF_REAL3 = 1062 + integer, parameter :: IDF_INTEGER6 = 1062 + integer, parameter :: IDF_RADIO18 = 1062 + integer, parameter :: IDF_REAL4 = 1063 + integer, parameter :: IDF_INTEGER7 = 1063 + integer, parameter :: IDF_REAL5 = 1064 + integer, parameter :: IDF_INTEGER8 = 1064 + integer, parameter :: IDF_REAL6 = 1065 + integer, parameter :: IDF_REAL7 = 1066 + integer, parameter :: IDF_REAL8 = 1067 + integer, parameter :: IDADJUST = 1068 + integer, parameter :: IDF_REAL9 = 1068 + integer, parameter :: IDFSWITCH = 1069 + integer, parameter :: IDF_REAL10 = 1069 + integer, parameter :: IDF_INTEGER9 = 1070 + integer, parameter :: IDF_INTEGER10 = 1071 + integer, parameter :: IDNEXT = 1072 + integer, parameter :: IDF_Delete = 1073 + integer, parameter :: IDFROTATE = 1074 + integer, parameter :: IDF_GRID1 = 1075 + integer, parameter :: IDF_RADIO13 = 1076 + integer, parameter :: ISS1 = 1077 + integer, parameter :: ISS2 = 1078 + integer, parameter :: ISS3 = 1079 + integer, parameter :: IDF_RADIO14 = 1080 + integer, parameter :: IDF_RADIO15 = 1081 + integer, parameter :: IDF_RADIO16 = 1082 + integer, parameter :: ISS4 = 1083 + integer, parameter :: ISS5 = 1084 + integer, parameter :: ISS6 = 1085 + integer, parameter :: ISS7 = 1086 + integer, parameter :: IDF_STRING25 = 1106 + integer, parameter :: IDF_STRING26 = 1107 + integer, parameter :: IDF_STRING27 = 1108 + integer, parameter :: IDF_STRING28 = 1109 + integer, parameter :: IDF_STRING29 = 1110 + integer, parameter :: IDF_STRING30 = 1111 + integer, parameter :: IDF_STRING31 = 1112 + integer, parameter :: IDF_STRING32 = 1113 + integer, parameter :: IDF_STRING33 = 1114 + integer, parameter :: IDF_STRING34 = 1115 + integer, parameter :: id_chck = 2001 + integer, parameter :: id_chk = 2002 + integer, parameter :: idchk = 2003 + integer, parameter :: IDC_BUTTON2 = 20001 + integer, parameter :: IDR_MENU1 = 30001 + integer, parameter :: ID_TOOLBAR1 = 30101 + integer, parameter :: ID_FILE = 40001 + integer, parameter :: ID_EXIT = 40002 + integer, parameter :: ID_NODE = 40003 + integer, parameter :: ID_ELTS = 40004 + integer, parameter :: ID_ORDRT = 40005 + integer, parameter :: ID_CCLN = 40006 + integer, parameter :: ID_CSEC1 = 40007 + integer, parameter :: ID_ZOOM = 40008 + integer, parameter :: ID_DRAW = 40009 + integer, parameter :: ID_HELP = 40010 + integer, parameter :: ID_ITEM11 = 40011 + integer, parameter :: ID_ITEM12 = 40012 + integer, parameter :: ID_ITEM13 = 40013 + integer, parameter :: ID_ITEM14 = 40014 + integer, parameter :: ID_ITEM15 = 40015 + integer, parameter :: ID_ITEM16 = 40016 + integer, parameter :: ID_ITEM17 = 40017 + integer, parameter :: ID_ITEM18 = 40018 + integer, parameter :: ID_ITEM19 = 40019 + integer, parameter :: ID_Clip = 40020 + integer, parameter :: ID_ITEM20 = 40021 + integer, parameter :: ID_ITEM73 = 40022 + integer, parameter :: ID_ITEM23 = 40023 + integer, parameter :: ID_ITEM24 = 40024 + integer, parameter :: ID_ZIN = 40025 + integer, parameter :: ID_ZOUT = 40026 + integer, parameter :: ID_OUT2 = 40027 + integer, parameter :: ID_OUT4 = 40028 + integer, parameter :: ID_RSET = 40029 + integer, parameter :: ID_UNDOM = 40030 + integer, parameter :: ID_PLEFT = 40031 + integer, parameter :: ID_PRIGHT = 40032 + integer, parameter :: ID_PUP = 40033 + integer, parameter :: ID_PDOWN = 40034 + integer, parameter :: ID_IDRWT = 40035 + integer, parameter :: ID_BSEL = 40036 + integer, parameter :: ID_REGST = 40037 + integer, parameter :: ID_network = 40038 + integer, parameter :: ID_TYPD = 40039 + integer, parameter :: ID_Help1 = 40040 + integer, parameter :: ID_DRAWD = 40041 + integer, parameter :: ID_MAPOPD = 40042 + integer, parameter :: ID_MMAP = 40043 + integer, parameter :: ID_Help2 = 40044 + integer, parameter :: ID_NMAP = 40045 + integer, parameter :: ID_LAYFL = 40046 + integer, parameter :: ID_BKF = 40047 + integer, parameter :: ID_ITEM56 = 40048 + integer, parameter :: ID_Nodedata = 40049 + integer, parameter :: ID_BACGD = 40050 + integer, parameter :: ID_Eltdata = 40051 + integer, parameter :: ID_DRAG = 40052 + integer, parameter :: ID_GETELM = 40053 + integer, parameter :: ID_mapm = 40054 + integer, parameter :: ID_map = 40055 + integer, parameter :: ID_DCONTR = 40056 + integer, parameter :: ID_SBIN = 40057 + integer, parameter :: ID_TRIAN = 40058 + integer, parameter :: ID_SWMAP = 40059 + integer, parameter :: ID_CONTR = 40060 + integer, parameter :: ID_CONTOPT = 40061 + integer, parameter :: ID_SWRM1 = 40062 + integer, parameter :: ID_LOADRM1 = 40063 + integer, parameter :: ID_ITYPN = 40064 + integer, parameter :: ID_ITYPC = 40065 + integer, parameter :: ID_cdata = 40066 + integer, parameter :: ID_ICOPY = 40067 + integer, parameter :: ID_SELRM1 = 40068 + integer, parameter :: ID_addmesh = 40069 + integer, parameter :: ID_MRGMESH = 40070 + integer, parameter :: ID_ITEM26 = 40071 + integer, parameter :: ID_ITEM22 = 40072 + integer, parameter :: ID_ALLNODES = 40073 + integer, parameter :: ID_UNUSNODES = 40074 + integer, parameter :: ID_TRIANG = 40075 + integer, parameter :: ID_QUAD = 40076 + integer, parameter :: ID_CSEC = 40077 + integer, parameter :: ID_CRSCAL = 40078 + integer, parameter :: ID_SAVCRS = 40079 + integer, parameter :: ID_crsf = 40080 + integer, parameter :: ID_CSLOC = 40081 + integer, parameter :: ID_UNDO = 40082 + integer, parameter :: ID_UNDOS = 40083 + integer, parameter :: ID_CREATM = 40084 + integer, parameter :: ID_CGEN = 40085 + integer, parameter :: ID_selarea = 40086 + integer, parameter :: ID_crsect = 40087 + integer, parameter :: ID_EDLAY = 40088 + integer, parameter :: ID_ORDR = 40089 + integer, parameter :: ID_ORDR1 = 40090 + integer, parameter :: ID_FILL = 40102 + integer, parameter :: ID_DELM = 40103 + integer, parameter :: ID_JOIN = 40104 + integer, parameter :: ID_STRING1 = 50001 + integer, parameter :: ID_STRING2 = 50002 + integer, parameter :: ID_STRING3 = 50003 + integer, parameter :: ID_STRING4 = 50004 + integer, parameter :: ID_STRING5 = 50005 + integer, parameter :: ID_STRING6 = 50006 + integer, parameter :: ID_STRING7 = 50007 + integer, parameter :: ID_STRING8 = 50008 + integer, parameter :: ID_STRING9 = 50009 + integer, parameter :: ID_STRING10 = 50010 + integer, parameter :: ID_STRING11 = 50011 diff --git a/src/resource.h b/src/resource.h new file mode 100644 index 0000000..a06556d --- /dev/null +++ b/src/resource.h @@ -0,0 +1,424 @@ +//{{NO_DEPENDENCIES}} +// Microsoft Visual C++ generated include file. +// Used by AC.rc +// +#define TCS_TABS 0x0000 +#define TCS_SINGLELINE 0x0000 +#define TCS_RIGHTJUSTIFY 0x0000 +#define TBS_HORZ 0x0000 +#define TBS_BOTTOM 0x0000 +#define TBS_RIGHT 0x0000 +#define IDOK 1 +#define TBS_AUTOTICKS 0x0001 +#define TVS_HASBUTTONS 0x0001 +#define VK_LBUTTON 0x01 +#define IDCANCEL 2 +#define TBS_VERT 0x0002 +#define TVS_HASLINES 0x0002 +#define VK_RBUTTON 0x02 +#define IDABORT 3 +#define VK_CANCEL 0x03 +#define IDRETRY 4 +#define TBS_TOP 0x0004 +#define TBS_LEFT 0x0004 +#define TVS_LINESATROOT 0x0004 +#define VK_MBUTTON 0x04 +#define IDIGNORE 5 +#define IDYES 6 +#define IDNO 7 +#define IDCLOSE 8 +#define TBS_BOTH 0x0008 +#define TVS_EDITLABELS 0x0008 +#define VK_BACK 0x08 +#define IDHELP 9 +#define VK_TAB 0x09 +#define VK_CLEAR 0x0C +#define VK_RETURN 0x0D +#define TBS_NOTICKS 0x0010 +#define TVS_DISABLEDRAGDROP 0x0010 +#define VK_SHIFT 0x10 +#define VK_CONTROL 0x11 +#define VK_MENU 0x12 +#define VK_PAUSE 0x13 +#define VK_CAPITAL 0x14 +#define VK_ESCAPE 0x1B +#define TBS_ENABLESELRANGE 0x0020 +#define TVS_SHOWSELALWAYS 0x0020 +#define VK_SPACE 0x20 +#define VK_PRIOR 0x21 +#define VK_NEXT 0x22 +#define VK_END 0x23 +#define VK_HOME 0x24 +#define VK_LEFT 0x25 +#define VK_UP 0x26 +#define VK_RIGHT 0x27 +#define VK_DOWN 0x28 +#define VK_SELECT 0x29 +#define VK_PRINT 0x2A +#define VK_EXECUTE 0x2B +#define VK_SNAPSHOT 0x2C +#define VK_INSERT 0x2D +#define VK_DELETE 0x2E +#define VK_HELP 0x2F +#define TBS_FIXEDLENGTH 0x0040 +#define VK_NUMPAD0 0x60 +#define VK_NUMPAD1 0x61 +#define VK_NUMPAD2 0x62 +#define VK_NUMPAD3 0x63 +#define VK_NUMPAD4 0x64 +#define VK_NUMPAD5 0x65 +#define IDD_DIALOG1 101 +#define VK_NUMPAD6 0x66 +#define IDD_DIALOG02 102 +#define VK_NUMPAD7 0x67 +#define IDD_DIALOG05 103 +#define VK_NUMPAD8 0x68 +#define IDD_DIALOG04 104 +#define VK_NUMPAD9 0x69 +#define IDD_DIALOG006 105 +#define VK_MULTIPLY 0x6A +#define IDD_DIALOG07 106 +#define VK_ADD 0x6B +#define IDD_DIALOG08 107 +#define VK_SEPARATOR 0x6C +#define IDD_DIALOG09 108 +#define VK_SUBTRACT 0x6D +#define IDD_DIALOG10 109 +#define VK_DECIMAL 0x6E +#define IDD_DIALOG010 110 +#define VK_DIVIDE 0x6F +#define IDD_DIALOG001 111 +#define VK_F1 0x70 +#define IDD_REGST 112 +#define VK_F2 0x71 +#define IDD_DIALOG012 113 +#define VK_F3 0x72 +#define IDD_SLRGNO 114 +#define VK_F4 0x73 +#define IDD_CONFIRM 115 +#define VK_F5 0x74 +#define IDD_nodedata 116 +#define VK_F6 0x75 +#define IDD_eltdata 117 +#define VK_F7 0x76 +#define IDD_SELNODE 118 +#define VK_F8 0x77 +#define IDD_SELELT 119 +#define VK_F9 0x78 +#define IDD_ELTERR 120 +#define VK_F10 0x79 +#define IDD_headertp 121 +#define VK_F11 0x7A +#define IDD_TRIAN 122 +#define VK_F12 0x7B +#define IDD_NODERR 123 +#define VK_F13 0x7C +#define IDD_TRIANG 124 +#define VK_F14 0x7D +#define IDD_QUAD 125 +#define VK_F15 0x7E +#define IDD_DIALOG06 126 +#define VK_F16 0x7F +#define IDD_CSLOC 127 +#define TBS_NOTHUMB 0x0080 +#define VK_F17 0x80 +#define IDD_CREATM 128 +#define VK_F18 0x81 +#define IDD_TEMPLATE001 129 +#define VK_F19 0x82 +#define IDD_CREATM1 130 +#define VK_F20 0x83 +#define IDD_ORDEROUT 131 +#define VK_F21 0x84 +#define IDD_TEMPLATE002 132 +#define VK_F22 0x85 +#define IDD_selcrsec 133 +#define VK_F23 0x86 +#define IDD_TEMPLATE003 134 +#define VK_F24 0x87 +#define IDD_LIMITS 135 +#define IDD_lAY 136 +#define IDD_TEMPLATE004 137 +#define IDD_DISPLIT 138 +#define IDD_DIRSPLIT 139 +#define IDD_SETOPT 140 +#define IDD_SETMAXMAP 141 +#define VK_NUMLOCK 0x90 +#define VK_SCROLL 0x91 +#define IDD_SELTFL2 148 +#define IDD_GETINT 153 +#define IDD_GETFPN 154 +#define VK_LSHIFT 0xA0 +#define IDD_GETINTP 160 +#define VK_RSHIFT 0xA1 +#define VK_LCONTROL 0xA2 +#define VK_RCONTROL 0xA3 +#define VK_LMENU 0xA4 +#define VK_RMENU 0xA5 +#define VK_ATTN 0xF6 +#define VK_CRSEL 0xF7 +#define VK_EXSEL 0xF8 +#define VK_EREOF 0xF9 +#define VK_PLAY 0xFA +#define VK_ZOOM 0xFB +#define VK_NONAME 0xFC +#define VK_PA1 0xFD +#define VK_OEM_CLEAR 0xFE +#define TCS_BUTTONS 0x0100 +#define TCS_MULTILINE 0x0200 +#define IDF_LABEL1 1001 +#define IDF_LABEL2 1002 +#define IDF_LABEL3 1003 +#define IDF_LABEL4 1004 +#define IDF_CMAP8 1005 +#define IDF_LABEL6 1005 +#define IDF_CMAP9 1006 +#define IDF_LABEL8 1006 +#define IDF_CMAP0 1007 +#define IDF_LABEL9 1007 +#define IDF_CMAP1 1008 +#define IDF_LABEL10 1008 +#define IDF_CMAP2 1009 +#define IDF_LABEL12 1009 +#define IDF_CMAP10 1010 +#define IDF_CMAP11 1011 +#define IDF_CMAP3 1012 +#define IDF_STRING1 1013 +#define IDF_STRING2 1014 +#define IDF_STRING3 1015 +#define IDF_STRING4 1016 +#define IDF_STRING5 1017 +#define IDF_STRING6 1018 +#define IDF_STRING7 1019 +#define IDF_STRING8 1020 +#define IDF_STRING9 1021 +#define IDF_STRING10 1022 +#define IDF_STRING11 1023 +#define TCS_FIXEDWIDTH 0x0400 +#define IDF_STRING12 1024 +#define IDF_STRING13 1025 +#define IDF_STRING14 1026 +#define IDF_STRING15 1027 +#define IDF_STRING16 1028 +#define IDF_STRING17 1029 +#define IDF_STRING18 1030 +#define IDF_STRING19 1031 +#define IDF_STRING20 1032 +#define IDF_STRING21 1033 +#define IDF_STRING22 1034 +#define IDF_STRING23 1035 +#define IDF_CHECK1 1036 +#define IDF_CHECK2 1037 +#define IDF_CHECK3 1038 +#define IDF_CHECK4 1039 +#define IDF_CHECK5 1040 +#define IDF_STRING24 1041 +#define IDF_CHECK6 1041 +#define IDF_LABEL5 1042 +#define IDF_CHECK7 1042 +#define IDF_STRING35 1042 +#define IDF_CMAP4 1043 +#define IDF_CHECK8 1043 +#define IDF_LABEL11 1043 +#define IDF_CMAP5 1044 +#define IDF_CHECK9 1044 +#define IDF_CMAP6 1045 +#define IDF_CHECK10 1045 +#define IDF_CMAP7 1046 +#define IDF_RADIO1 1047 +#define IDF_RADIO2 1048 +#define IDF_RADIO3 1049 +#define IDF_RADIO4 1050 +#define IDF_RADIO5 1051 +#define IDF_RADIO6 1052 +#define IDF_RADIO7 1053 +#define IDF_RADIO8 1054 +#define IDF_RADIO9 1055 +#define IDF_LABEL7 1056 +#define IDF_RADIO10 1056 +#define IDF_INTEGER1 1057 +#define IDF_RADIO11 1057 +#define IDF_INTEGER2 1058 +#define IDF_RADIO12 1058 +#define IDF_CHECK11 1059 +#define IDF_INTEGER3 1059 +#define IDF_RADIO17 1059 +#define IDF_REAL1 1060 +#define IDF_INTEGER4 1060 +#define IDF_REAL2 1061 +#define IDF_INTEGER5 1061 +#define IDF_REAL3 1062 +#define IDF_INTEGER6 1062 +#define IDF_RADIO18 1062 +#define IDF_REAL4 1063 +#define IDF_INTEGER7 1063 +#define IDF_REAL5 1064 +#define IDF_INTEGER8 1064 +#define IDF_REAL6 1065 +#define IDF_REAL7 1066 +#define IDF_REAL8 1067 +#define IDADJUST 1068 +#define IDF_REAL9 1068 +#define IDFSWITCH 1069 +#define IDF_REAL10 1069 +#define IDF_INTEGER9 1070 +#define IDF_INTEGER10 1071 +#define IDNEXT 1072 +#define IDF_Delete 1073 +#define IDFROTATE 1074 +#define IDF_GRID1 1075 +#define IDF_RADIO13 1076 +#define ISS1 1077 +#define ISS2 1078 +#define ISS3 1079 +#define IDF_RADIO14 1080 +#define IDF_RADIO15 1081 +#define IDF_RADIO16 1082 +#define ISS4 1083 +#define ISS5 1084 +#define ISS6 1085 +#define ISS7 1086 +#define IDF_STRING25 1106 +#define IDF_STRING26 1107 +#define IDF_STRING27 1108 +#define IDF_STRING28 1109 +#define IDF_STRING29 1110 +#define IDF_STRING30 1111 +#define IDF_STRING31 1112 +#define IDF_STRING32 1113 +#define IDF_STRING33 1114 +#define IDF_STRING34 1115 +#define id_chck 2001 +#define id_chk 2002 +#define idchk 2003 +#define TCS_RAGGEDRIGHT 0x0800 +#define TCS_FOCUSONBUTTONDOWN 0x1000 +#define IDC_BUTTON2 20001 +#define IDR_MENU1 30001 +#define ID_TOOLBAR1 30101 +#define TCS_FOCUSNEVER 0x8000 +#define ID_FILE 40001 +#define ID_Menu 40001 +#define ID_EXIT 40002 +#define ID_RESET 40002 +#define ID_NODE 40003 +#define ID_ELTS 40004 +#define ID_ORDRT 40005 +#define ID_CCLNA 40006 +#define ID_CSEC1 40007 +#define ID_ZOOM 40008 +#define ID_DRAW 40009 +#define ID_HELP 40010 +#define ID_ITEM11 40011 +#define ID_ITEM12 40012 +#define ID_ITEM13 40013 +#define ID_ITEM14 40014 +#define ID_ITEM15 40015 +#define ID_ITEM16 40016 +#define ID_ITEM17 40017 +#define ID_ITEM18 40018 +#define ID_ITEM19 40019 +#define ID_Clip 40020 +#define ID_ITEM20 40021 +#define ID_ITEM73 40022 +#define ID_ITEM23 40023 +#define ID_ITEM24 40024 +#define ID_ZIN 40025 +#define ID_ZOUT 40026 +#define ID_OUT2 40027 +#define ID_OUT4 40028 +#define ID_RSET 40029 +#define ID_UNDOM 40030 +#define ID_PLEFT 40031 +#define ID_PRIGHT 40032 +#define ID_PUP 40033 +#define ID_PDOWN 40034 +#define ID_IDRWT 40035 +#define ID_BSEL 40036 +#define ID_REGST 40037 +#define ID_network 40038 +#define ID_TYPD 40039 +#define ID_Help1 40040 +#define ID_DRAWD 40041 +#define ID_MAPOPD 40042 +#define ID_MMAP 40043 +#define ID_Help2 40044 +#define ID_NMAP 40045 +#define ID_LAYFL 40046 +#define ID_BKF 40047 +#define ID_ITEM56 40048 +#define ID_Nodedata 40049 +#define ID_BACGD 40050 +#define ID_Eltdata 40051 +#define ID_DRAG 40052 +#define ID_GETELM 40053 +#define ID_mapm 40054 +#define ID_map 40055 +#define ID_DCONTR 40056 +#define ID_SBIN 40057 +#define ID_TRIAN 40058 +#define ID_SWMAP 40059 +#define ID_CONTR 40060 +#define ID_CONTOPT 40061 +#define ID_SWRM1 40062 +#define ID_LOADRM1 40063 +#define ID_ITYPN 40064 +#define ID_ITYPC 40065 +#define ID_cdata 40066 +#define ID_ICOPY 40067 +#define ID_SELRM1 40068 +#define ID_addmesh 40069 +#define ID_MRGMESH 40070 +#define ID_ITEM26 40071 +#define ID_ITEM22 40072 +#define ID_ALLNODES 40073 +#define ID_UNUSNODES 40074 +#define ID_TRIANG 40075 +#define ID_QUAD 40076 +#define ID_CSEC 40077 +#define ID_CRSCAL 40078 +#define ID_SAVCRS 40079 +#define ID_crsf 40080 +#define ID_CSLOC 40081 +#define ID_UNDO 40082 +#define ID_UNDOS 40083 +#define ID_CREATM 40084 +#define ID_CGEN 40085 +#define ID_selarea 40086 +#define ID_crsect 40087 +#define ID_EDLAY 40088 +#define ID_ORDR 40089 +#define ID_ORDR1 40090 +#define ID_SPLITN 40091 +#define ID_FORM999 40092 +#define ID_OUTLAY 40093 +#define ID_g1d 40094 +#define ID_CCLN 40095 +#define ID_CHKCCLN 40096 +#define ID_GOUTLIN 40097 +#define ID_XOUTLIN 40098 +#define ID_FILL 40102 +#define ID_DELM 40103 +#define ID_JOIN 40104 +#define ID_STRING1 50001 +#define ID_STRING2 50002 +#define ID_STRING3 50003 +#define ID_STRING4 50004 +#define ID_STRING5 50005 +#define ID_STRING6 50006 +#define ID_STRING7 50007 +#define ID_STRING8 50008 +#define ID_STRING9 50009 +#define ID_STRING10 50010 +#define ID_STRING11 50011 + +// Next default values for new objects +// +#ifdef APSTUDIO_INVOKED +#ifndef APSTUDIO_READONLY_SYMBOLS +#define _APS_NEXT_RESOURCE_VALUE 101 +#define _APS_NEXT_COMMAND_VALUE 40003 +#define _APS_NEXT_CONTROL_VALUE 1000 +#define _APS_NEXT_SYMED_VALUE 101 +#endif +#endif diff --git a/src/rotate.bmp b/src/rotate.bmp new file mode 100644 index 0000000..87a06ef Binary files /dev/null and b/src/rotate.bmp differ diff --git a/src/setangle.f90 b/src/setangle.f90 new file mode 100644 index 0000000..5594250 --- /dev/null +++ b/src/setangle.f90 @@ -0,0 +1,91 @@ + SUBROUTINE SETANGLE +! +! THIS ROUTINE SETS THE ANGLES FOR 3-F VIEWS +! + use winteracter +! USE BLKV1 +! USE BLKV2 +! USE BLK + + USE BLK1MOD +! INCLUDE 'BLK1.COM' +! INCLUDE 'TXFRM.COM' +!- + + include 'D.inc' + +! +! Declare window-type and message variables +! + TYPE(WIN_STYLE) :: WINDOW + + TYPE(WIN_MESSAGE) :: MESSAGE + INTEGER :: IERR + DATA ITIM/0/ + + IF(ITIM .EQ. 0) THEN + HANG=0. + VANG=90. + VRTSCAL=100.0 + VRTORIG=0. + ITIM=1 + IASPCT=0 + IASPCTOLD=0 + ENDIF + + VANGOLD=VANG + HANGOLD=HANG + + call wdialogload(IDD_VIEWANG) + ierr=infoerror(1) + + CALL WDialogSelect(IDD_VIEWANG) + ierr=infoerror(1) + + 100 continue + CALL WDialogPutREAL(IDF_REAL1,HANG) + CALL WDialogPutREAL(IDF_REAL2,VANG) + CALL WDialogPutREAL(IDF_REAL3,VRTSCAL) + CALL WDialogPutREAL(IDF_REAL4,VRTORIG) + CALL WDialogPutCheckBox(IDF_check1,IASPCT) + + CALL WDialogShow(-1,-1,0,Modal) + ierr=infoerror(1) + + do +! + IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN + + + CALL WDialogGetREAL(IDF_REAL1,HANG) + CALL WDialogGetREAL(IDF_REAL2,VANG) + CALL WDialogGetREAL(IDF_REAL3,VRTSCAL) + CALL WDialogGetREAL(IDF_REAL4,VRTORIG) + CALL WDialogGetCheckBox(IDF_check1,IASPCT) + GO TO 200 +! else +! HANG=0. +! VANG=90. +! VRTSCAL=100. + endif + + enddo + + 200 CONTINUE + RETURN + END + + SUBROUTINE adjustang(hrad,vrad) + + USE BLK1MOD + + VANGOLD=VANG + HANGOLD=HANG + + VANG=VANG+VRAD*57. + HANG=HANG+HRAD*57. + + CALL PLOTOT(0) + + RETURN + END \ No newline at end of file diff --git a/src/winparam.h b/src/winparam.h new file mode 100644 index 0000000..fbc156c --- /dev/null +++ b/src/winparam.h @@ -0,0 +1,241 @@ +#define IDOK 1 +#define IDCANCEL 2 +#define IDABORT 3 +#define IDRETRY 4 +#define IDIGNORE 5 +#define IDYES 6 +#define IDNO 7 +#define IDCLOSE 8 +#define IDHELP 9 +#define WS_OVERLAPPED 0x00000000L +#define WS_POPUP 0x80000000L +#define WS_CHILD 0x40000000L +#define WS_MINIMIZE 0x20000000L +#define WS_VISIBLE 0x10000000L +#define WS_DISABLED 0x08000000L +#define WS_CLIPSIBLINGS 0x04000000L +#define WS_CLIPCHILDREN 0x02000000L +#define WS_MAXIMIZE 0x01000000L +#define WS_CAPTION 0x00C00000L +#define WS_BORDER 0x00800000L +#define WS_DLGFRAME 0x00400000L +#define WS_VSCROLL 0x00200000L +#define WS_HSCROLL 0x00100000L +#define WS_SYSMENU 0x00080000L +#define WS_THICKFRAME 0x00040000L +#define WS_GROUP 0x00020000L +#define WS_TABSTOP 0x00010000L +#define WS_MINIMIZEBOX 0x00020000L +#define WS_MAXIMIZEBOX 0x00010000L +#define ES_LEFT 0x00000000L +#define ES_CENTER 0x00000001L +#define ES_RIGHT 0x00000002L +#define ES_MULTILINE 0x00000004L +#define ES_UPPERCASE 0x00000008L +#define ES_LOWERCASE 0x00000010L +#define ES_PASSWORD 0x00000020L +#define ES_AUTOVSCROLL 0x00000040L +#define ES_AUTOHSCROLL 0x00000080L +#define ES_READONLY 0x00000800L +#define ES_WANTRETURN 0x00001000L +#define BS_PUSHBUTTON 0x00000000L +#define BS_DEFPUSHBUTTON 0x00000001L +#define BS_AUTOCHECKBOX 0x00000003L +#define BS_GROUPBOX 0x00000007L +#define BS_USERBUTTON 0x00000008L +#define BS_AUTORADIOBUTTON 0x00000009L +#define BS_OWNERDRAW 0x0000000BL +#define BS_LEFTTEXT 0x00000020L +#define BS_TEXT 0x00000000L +#define BS_ICON 0x00000040L +#define BS_BITMAP 0x00000080L +#define BS_LEFT 0x00000100L +#define BS_RIGHT 0x00000200L +#define BS_CENTER 0x00000300L +#define BS_TOP 0x00000400L +#define BS_BOTTOM 0x00000800L +#define BS_VCENTER 0x00000C00L +#define BS_PUSHLIKE 0x00001000L +#define BS_MULTILINE 0x00002000L +#define BS_FLAT 0x00008000L +#define SS_LEFT 0x00000000L +#define SS_CENTER 0x00000001L +#define SS_RIGHT 0x00000002L +#define SS_ICON 0x00000003L +#define SS_BLACKRECT 0x00000004L +#define SS_GRAYRECT 0x00000005L +#define SS_WHITERECT 0x00000006L +#define SS_BLACKFRAME 0x00000007L +#define SS_GRAYFRAME 0x00000008L +#define SS_WHITEFRAME 0x00000009L +#define SS_SIMPLE 0x0000000BL +#define SS_LEFTNOWORDWRAP 0x0000000CL +#define SS_NOPREFIX 0x00000080L +#define SS_BITMAP 0x0000000EL +#define SS_ENHMETAFILE 0x0000000FL +#define SS_ETCHEDHORZ 0x00000010L +#define SS_ETCHEDVERT 0x00000011L +#define SS_ETCHEDFRAME 0x00000012L +#define SS_NOTIFY 0x00000100L +#define SS_CENTERIMAGE 0x00000200L +#define SS_RIGHTJUST 0x00000400L +#define SS_REALSIZEIMAGE 0x00000800L +#define SS_SUNKEN 0x00001000L +#define DS_SYSMODAL 0x00000002L +#define DS_3DLOOK 0x00000004L +#define DS_SETFONT 0x00000040L +#define DS_MODALFRAME 0x00000080L +#define DS_CONTROL 0x00000400L +#define LBS_NOTIFY 0x00000001L +#define LBS_MULTIPLESEL 0x00000008L +#define LBS_HASSTRINGS 0x00000040L +#define LBS_USETABSTOPS 0x00000080L +#define LBS_NOINTEGRALHEIGHT 0x00000100L +#define LBS_MULTICOLUMN 0x00000200L +#define LBS_EXTENDEDSEL 0x00000800L +#define LBS_DISABLENOSCROLL 0x00001000L +#define LBS_NOSEL 0x00004000L +#define CBS_SIMPLE 0x00000001L +#define CBS_DROPDOWN 0x00000002L +#define CBS_DROPDOWNLIST 0x00000003L +#define CBS_OWNERDRAWFIXED 0x00000010L +#define CBS_AUTOHSCROLL 0x00000040L +#define CBS_SORT 0x00000100L +#define CBS_HASSTRINGS 0x00000200L +#define CBS_DISABLENOSCROLL 0x00000800L +#define CBS_UPPERCASE 0x00002000L +#define CBS_LOWERCASE 0x00004000L +#define WS_EX_DLGMODALFRAME 0x00000001L +#define WS_EX_WINDOWEDGE 0x00000100L +#define WS_EX_CLIENTEDGE 0x00000200L +#define WS_EX_LEFTSCROLLBAR 0x00004000L +#define WS_EX_STATICEDGE 0x00020000L +#define TCS_TABS 0x0000 +#define TCS_BUTTONS 0x0100 +#define TCS_SINGLELINE 0x0000 +#define TCS_MULTILINE 0x0200 +#define TCS_RIGHTJUSTIFY 0x0000 +#define TCS_FIXEDWIDTH 0x0400 +#define TCS_RAGGEDRIGHT 0x0800 +#define TCS_FOCUSONBUTTONDOWN 0x1000 +#define TCS_FOCUSNEVER 0x8000 +#define GS_READONLYCOLOUR 0x00000010L +#define GS_REPSELECTION 0x00000020L +#define GS_REPCUTPASTE 0x00000040L +#define GS_DEFROWLABELS 0x00000080L +#define GS_NOINTEGRALHEIGHT 0x00000100L +#define GS_COLUMNLABELS 0x00000200L +#define GS_ROWLABELS 0x00000400L +#define GS_READONLY 0x00000800L +#define GS_WANTRETURN 0x00001000L +#define GS_RESIZECOLUMNS 0x00002000L +#define GS_WANTTAB 0x00004000L +#define GS_WRAP 0x00008000L +#define TBS_AUTOTICKS 0x0001 +#define TBS_VERT 0x0002 +#define TBS_HORZ 0x0000 +#define TBS_TOP 0x0004 +#define TBS_BOTTOM 0x0000 +#define TBS_LEFT 0x0004 +#define TBS_RIGHT 0x0000 +#define TBS_BOTH 0x0008 +#define TBS_NOTICKS 0x0010 +#define TBS_ENABLESELRANGE 0x0020 +#define TBS_FIXEDLENGTH 0x0040 +#define TBS_NOTHUMB 0x0080 +#define TVS_HASBUTTONS 0x0001 +#define TVS_HASLINES 0x0002 +#define TVS_LINESATROOT 0x0004 +#define TVS_EDITLABELS 0x0008 +#define TVS_DISABLEDRAGDROP 0x0010 +#define TVS_SHOWSELALWAYS 0x0020 +#define VK_LBUTTON 0x01 +#define VK_RBUTTON 0x02 +#define VK_CANCEL 0x03 +#define VK_MBUTTON 0x04 +#define VK_BACK 0x08 +#define VK_TAB 0x09 +#define VK_CLEAR 0x0C +#define VK_RETURN 0x0D +#define VK_SHIFT 0x10 +#define VK_CONTROL 0x11 +#define VK_MENU 0x12 +#define VK_PAUSE 0x13 +#define VK_CAPITAL 0x14 +#define VK_ESCAPE 0x1B +#define VK_SPACE 0x20 +#define VK_PRIOR 0x21 +#define VK_NEXT 0x22 +#define VK_END 0x23 +#define VK_HOME 0x24 +#define VK_LEFT 0x25 +#define VK_UP 0x26 +#define VK_RIGHT 0x27 +#define VK_DOWN 0x28 +#define VK_SELECT 0x29 +#define VK_PRINT 0x2A +#define VK_EXECUTE 0x2B +#define VK_SNAPSHOT 0x2C +#define VK_INSERT 0x2D +#define VK_DELETE 0x2E +#define VK_HELP 0x2F +#define VK_NUMPAD0 0x60 +#define VK_NUMPAD1 0x61 +#define VK_NUMPAD2 0x62 +#define VK_NUMPAD3 0x63 +#define VK_NUMPAD4 0x64 +#define VK_NUMPAD5 0x65 +#define VK_NUMPAD6 0x66 +#define VK_NUMPAD7 0x67 +#define VK_NUMPAD8 0x68 +#define VK_NUMPAD9 0x69 +#define VK_MULTIPLY 0x6A +#define VK_ADD 0x6B +#define VK_SEPARATOR 0x6C +#define VK_SUBTRACT 0x6D +#define VK_DECIMAL 0x6E +#define VK_DIVIDE 0x6F +#define VK_F1 0x70 +#define VK_F2 0x71 +#define VK_F3 0x72 +#define VK_F4 0x73 +#define VK_F5 0x74 +#define VK_F6 0x75 +#define VK_F7 0x76 +#define VK_F8 0x77 +#define VK_F9 0x78 +#define VK_F10 0x79 +#define VK_F11 0x7A +#define VK_F12 0x7B +#define VK_F13 0x7C +#define VK_F14 0x7D +#define VK_F15 0x7E +#define VK_F16 0x7F +#define VK_F17 0x80 +#define VK_F18 0x81 +#define VK_F19 0x82 +#define VK_F20 0x83 +#define VK_F21 0x84 +#define VK_F22 0x85 +#define VK_F23 0x86 +#define VK_F24 0x87 +#define VK_NUMLOCK 0x90 +#define VK_SCROLL 0x91 +#define VK_LSHIFT 0xA0 +#define VK_RSHIFT 0xA1 +#define VK_LCONTROL 0xA2 +#define VK_RCONTROL 0xA3 +#define VK_LMENU 0xA4 +#define VK_RMENU 0xA5 +#define VK_ATTN 0xF6 +#define VK_CRSEL 0xF7 +#define VK_EXSEL 0xF8 +#define VK_EREOF 0xF9 +#define VK_PLAY 0xFA +#define VK_ZOOM 0xFB +#define VK_NONAME 0xFC +#define VK_PA1 0xFD +#define VK_OEM_CLEAR 0xFE + +#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1 +#define RT_MANIFEST 24 diff --git a/src/winteracter.mod b/src/winteracter.mod new file mode 100644 index 0000000..d471d09 Binary files /dev/null and b/src/winteracter.mod differ diff --git a/src/winttypes.mod b/src/winttypes.mod new file mode 100644 index 0000000..450edd4 Binary files /dev/null and b/src/winttypes.mod differ