From 0c8e29e340eca5af07d6ef7915ac75b562f082b8 Mon Sep 17 00:00:00 2001 From: IanKing Date: Wed, 21 Sep 2016 14:36:48 +1000 Subject: [PATCH] basline2 --- .gitignore | 42 + RMAGEN.sln | 20 + src/ADD999.F90 | 487 ++++++++ src/ADDLAY.F90 | 343 +++++ src/ADDQUAD.F90 | 192 +++ src/ADDTRIANG.F90 | 191 +++ src/ADDWID.F90 | 464 +++++++ src/AREA.F90 | 457 +++++++ src/ASSIGNEQ.f90 | 33 + src/BFILES.I90 | 9 + src/BLK1 - Copy.f90 | 117 ++ src/BLK1.f90 | 123 ++ src/BLK1OLD.COM | 85 ++ src/BLK2.COM | 23 + src/BLK2MOD.F90 | 30 + src/BLKELTLD.F90 | 6 + src/BLKMAP.COM | 14 + src/BRKDWN.F90 | 856 +++++++++++++ src/BUTTON.ICO | Bin 0 -> 1426 bytes src/CANCEL.ICO | Bin 0 -> 1446 bytes src/CCLINE.F90 | 496 ++++++++ src/COMPACT.F90 | 120 ++ src/COMPSCAL.F90 | 147 +++ src/CONT.F90 | 300 +++++ src/CREATGRID.f90 | 193 +++ src/CREATM.F90 | 278 ++++ src/CRGRID.f90 | 376 ++++++ src/CRSECT.F90 | 158 +++ src/CSETNEW.F90 | 407 ++++++ src/D.INC | 363 ++++++ src/DELAN2 - Copy.F90 | 401 ++++++ src/DELAN2.F90 | 451 +++++++ src/DELAUNAY.F90 | 264 ++++ src/DEMOS.F90 | 45 + src/DOGRAPH.F90 | 306 +++++ src/DUMMY.F90 | 12 + src/EGEN - Copy (2).F90 | 1061 ++++++++++++++++ src/EGEN - Copy.F90 | 1014 +++++++++++++++ src/EGEN.F90 | 1163 +++++++++++++++++ src/ELEVINT.F90 | 245 ++++ src/ELTDISP.F90 | 426 +++++++ src/ELTS.F90 | 712 +++++++++++ src/ELVSET.F90 | 425 +++++++ src/EVENT.F90 | 2057 ++++++++++++++++++++++++++++++ src/EXP.rc | 47 + src/FILE.F90 | 160 +++ src/FILL.F90 | 269 ++++ src/FILLTR.F90 | 272 ++++ src/FORMGP.F90 | 145 +++ src/FORMSHP.F90 | 455 +++++++ src/FRMNODQ.f90 | 29 + src/GETANG.F90 | 144 +++ src/GETCRS.F90 | 241 ++++ src/GETEQ1.F90 | 485 +++++++ src/GETNEWFIL.F90 | 757 +++++++++++ src/GETPGRP.F90 | 109 ++ src/GETSTRESSFIL.F90 | 175 +++ src/GETTRIANG.F90 | 139 ++ src/GETWT.F90 | 215 ++++ src/GINPT.F90 | 47 + src/GOUTLIN.F90 | 127 ++ src/GRIDSB.F90 | 872 +++++++++++++ src/HEDR.F90 | 333 +++++ src/HELPS.F90 | 98 ++ src/INITSIZ.f90 | 162 +++ src/INOUT.F90 | 2504 +++++++++++++++++++++++++++++++++++++ src/INTEL.F90 | 438 +++++++ src/JLINE.F90 | 122 ++ src/JOIN.bmp | Bin 0 -> 246 bytes src/JOINEL.F90 | 445 +++++++ src/LAYDISP.F90 | 69 + src/LEVSETTYP.F90 | 50 + src/LOADFIL.F90 | 22 + src/MMAP.F90 | 99 ++ src/MOVMESH.f90 | 386 ++++++ src/NECON.F90 | 44 + src/NEWRMGN.F90 | 944 ++++++++++++++ src/NODEDISP.F90 | 149 +++ src/NODES.F90 | 911 ++++++++++++++ src/OK.ICO | Bin 0 -> 1446 bytes src/OUTLINES.F90 | 191 +++ src/PARAM.COM | 65 + src/PLOTORDS.F90 | 41 + src/PLOTR.F90 | 176 +++ src/PLOTR1.F90 | 1620 ++++++++++++++++++++++++ src/RDOUTLIN.F90 | 46 + src/RDRM1.F90 | 111 ++ src/READSHP.FOR | 209 ++++ src/REATTACH.F90 | 79 ++ src/REFINB.F90 | 1436 +++++++++++++++++++++ src/REGSTR.F90 | 325 +++++ src/REORD.F90 | 1049 ++++++++++++++++ src/RESETREG.f90 | 87 ++ src/RESETWHGT.f90 | 291 +++++ src/RESOURCE.F90 | 32 + src/RMAGEN - Shortcut.lnk | Bin 0 -> 1089 bytes src/RMAGEN.F90 | 694 ++++++++++ src/RMAGENV83c.rc | 2408 +++++++++++++++++++++++++++++++++++ src/RVSDIAG.F90 | 112 ++ src/SAVELTLD.F90 | 110 ++ src/SAVESHP.F90 | 175 +++ src/SELT.F90 | 958 ++++++++++++++ src/SHOWEQ.F90 | 237 ++++ src/SHOWEQ.FOR | 8 + src/SMFY.F90 | 70 ++ src/SPLIT.F90 | 345 +++++ src/SWMAP.F90 | 91 ++ src/SYMBL.F90 | 1441 +++++++++++++++++++++ src/TXFRM.COM | 4 + src/UTIL.F90 | 1268 +++++++++++++++++++ src/WINNEW.F90 | 690 ++++++++++ src/WINTER.ICO | Bin 0 -> 2238 bytes src/WRTBIN.F90 | 106 ++ src/XN.F90 | 200 +++ src/ZOOM.BMP | Bin 0 -> 3638 bytes src/ZOOMNEW.F90 | 104 ++ src/addmap.f90 | 86 ++ src/addtomesh.f90 | 499 ++++++++ src/adjustopt.f90 | 49 + src/blkmap.f90 | 17 + src/cgen.f90 | 151 +++ src/chck.bmp | Bin 0 -> 3126 bytes src/deln2 - Copy.f90 | 237 ++++ src/deln2.f90 | 239 ++++ src/disp.bmp | Bin 0 -> 822 bytes src/droppts.f90 | 41 + src/form999.f90 | 420 +++++++ src/formlinel - Copy.f90 | 122 ++ src/formlinel.f90 | 265 ++++ src/frmnodt.f90 | 58 + src/getlaydat.f90 | 58 + src/interpelv.f90 | 78 ++ src/resource.fd | 276 ++++ src/resource.h | 424 +++++++ src/rotate.bmp | Bin 0 -> 246 bytes src/setangle.f90 | 91 ++ src/winparam.h | 241 ++++ src/winteracter.mod | Bin 0 -> 514652 bytes src/winttypes.mod | Bin 0 -> 3912 bytes 139 files changed, 44507 insertions(+) create mode 100644 RMAGEN.sln create mode 100644 src/ADD999.F90 create mode 100644 src/ADDLAY.F90 create mode 100644 src/ADDQUAD.F90 create mode 100644 src/ADDTRIANG.F90 create mode 100644 src/ADDWID.F90 create mode 100644 src/AREA.F90 create mode 100644 src/ASSIGNEQ.f90 create mode 100644 src/BFILES.I90 create mode 100644 src/BLK1 - Copy.f90 create mode 100644 src/BLK1.f90 create mode 100644 src/BLK1OLD.COM create mode 100644 src/BLK2.COM create mode 100644 src/BLK2MOD.F90 create mode 100644 src/BLKELTLD.F90 create mode 100644 src/BLKMAP.COM create mode 100644 src/BRKDWN.F90 create mode 100644 src/BUTTON.ICO create mode 100644 src/CANCEL.ICO create mode 100644 src/CCLINE.F90 create mode 100644 src/COMPACT.F90 create mode 100644 src/COMPSCAL.F90 create mode 100644 src/CONT.F90 create mode 100644 src/CREATGRID.f90 create mode 100644 src/CREATM.F90 create mode 100644 src/CRGRID.f90 create mode 100644 src/CRSECT.F90 create mode 100644 src/CSETNEW.F90 create mode 100644 src/D.INC create mode 100644 src/DELAN2 - Copy.F90 create mode 100644 src/DELAN2.F90 create mode 100644 src/DELAUNAY.F90 create mode 100644 src/DEMOS.F90 create mode 100644 src/DOGRAPH.F90 create mode 100644 src/DUMMY.F90 create mode 100644 src/EGEN - Copy (2).F90 create mode 100644 src/EGEN - Copy.F90 create mode 100644 src/EGEN.F90 create mode 100644 src/ELEVINT.F90 create mode 100644 src/ELTDISP.F90 create mode 100644 src/ELTS.F90 create mode 100644 src/ELVSET.F90 create mode 100644 src/EVENT.F90 create mode 100644 src/EXP.rc create mode 100644 src/FILE.F90 create mode 100644 src/FILL.F90 create mode 100644 src/FILLTR.F90 create mode 100644 src/FORMGP.F90 create mode 100644 src/FORMSHP.F90 create mode 100644 src/FRMNODQ.f90 create mode 100644 src/GETANG.F90 create mode 100644 src/GETCRS.F90 create mode 100644 src/GETEQ1.F90 create mode 100644 src/GETNEWFIL.F90 create mode 100644 src/GETPGRP.F90 create mode 100644 src/GETSTRESSFIL.F90 create mode 100644 src/GETTRIANG.F90 create mode 100644 src/GETWT.F90 create mode 100644 src/GINPT.F90 create mode 100644 src/GOUTLIN.F90 create mode 100644 src/GRIDSB.F90 create mode 100644 src/HEDR.F90 create mode 100644 src/HELPS.F90 create mode 100644 src/INITSIZ.f90 create mode 100644 src/INOUT.F90 create mode 100644 src/INTEL.F90 create mode 100644 src/JLINE.F90 create mode 100644 src/JOIN.bmp create mode 100644 src/JOINEL.F90 create mode 100644 src/LAYDISP.F90 create mode 100644 src/LEVSETTYP.F90 create mode 100644 src/LOADFIL.F90 create mode 100644 src/MMAP.F90 create mode 100644 src/MOVMESH.f90 create mode 100644 src/NECON.F90 create mode 100644 src/NEWRMGN.F90 create mode 100644 src/NODEDISP.F90 create mode 100644 src/NODES.F90 create mode 100644 src/OK.ICO create mode 100644 src/OUTLINES.F90 create mode 100644 src/PARAM.COM create mode 100644 src/PLOTORDS.F90 create mode 100644 src/PLOTR.F90 create mode 100644 src/PLOTR1.F90 create mode 100644 src/RDOUTLIN.F90 create mode 100644 src/RDRM1.F90 create mode 100644 src/READSHP.FOR create mode 100644 src/REATTACH.F90 create mode 100644 src/REFINB.F90 create mode 100644 src/REGSTR.F90 create mode 100644 src/REORD.F90 create mode 100644 src/RESETREG.f90 create mode 100644 src/RESETWHGT.f90 create mode 100644 src/RESOURCE.F90 create mode 100644 src/RMAGEN - Shortcut.lnk create mode 100644 src/RMAGEN.F90 create mode 100644 src/RMAGENV83c.rc create mode 100644 src/RVSDIAG.F90 create mode 100644 src/SAVELTLD.F90 create mode 100644 src/SAVESHP.F90 create mode 100644 src/SELT.F90 create mode 100644 src/SHOWEQ.F90 create mode 100644 src/SHOWEQ.FOR create mode 100644 src/SMFY.F90 create mode 100644 src/SPLIT.F90 create mode 100644 src/SWMAP.F90 create mode 100644 src/SYMBL.F90 create mode 100644 src/TXFRM.COM create mode 100644 src/UTIL.F90 create mode 100644 src/WINNEW.F90 create mode 100644 src/WINTER.ICO create mode 100644 src/WRTBIN.F90 create mode 100644 src/XN.F90 create mode 100644 src/ZOOM.BMP create mode 100644 src/ZOOMNEW.F90 create mode 100644 src/addmap.f90 create mode 100644 src/addtomesh.f90 create mode 100644 src/adjustopt.f90 create mode 100644 src/blkmap.f90 create mode 100644 src/cgen.f90 create mode 100644 src/chck.bmp create mode 100644 src/deln2 - Copy.f90 create mode 100644 src/deln2.f90 create mode 100644 src/disp.bmp create mode 100644 src/droppts.f90 create mode 100644 src/form999.f90 create mode 100644 src/formlinel - Copy.f90 create mode 100644 src/formlinel.f90 create mode 100644 src/frmnodt.f90 create mode 100644 src/getlaydat.f90 create mode 100644 src/interpelv.f90 create mode 100644 src/resource.fd create mode 100644 src/resource.h create mode 100644 src/rotate.bmp create mode 100644 src/setangle.f90 create mode 100644 src/winparam.h create mode 100644 src/winteracter.mod create mode 100644 src/winttypes.mod 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 0000000000000000000000000000000000000000..90b9993ac0ef35c3d64069694492d5dab309461b GIT binary patch literal 1426 zcmc&!&ui2`6n?RF&8|T_358-2W$|iHEi4VaDU|KMu+oCp_EuprBlR%5ENrBgolDKl zlD}d^4=n`$hJvNNuDc!*jEUcy?2puX6nx3dd+(cX-h1=1vqTo2=F)v)Y2PM#0R0rB ziLr`d(IRG|A5ijcF$%VUF$wdM5Nu)KfuXgAW+XQ+&gz{v;&;2m_EA&o)?@XEq=fG{>4OK^2$*5K^)DBt>{q3#5o5QB?z?FbqgWBpuBg zr#wY=H^h=X<-rNbF7v8BQYzo>1~Lr6vjrm|-hg^q5&#pg>cgli=G8)z3J4s6*F#do zobyP@E|Om3(G4D2pk(bj4@qi4IUXr)l@iRuf%$xj5FCjE8QB1eyx?(tsN3*31oP0S z+6hi2`7B0?2Abj!vvBQ2d%G2!9h+?$8zRY0kXXGzZ{II4AT=#s}6lKl4lCKf4+o@Pm^{pMh<6csF?5N7t{=2vCh*H`;6STId z-O)ix7iT^#FF*H&R{C`}9_{uU>-lgY+pe@V=?yC%uV<}$uv^(qo;0%7Nq7T4OWh)yqTlNlkwA3i( zJ0}})7~!0|&%N({oU!OVIm@=%#uFdfJ96rod^veQJRDSovC;L7vLGi1SjMf#b{!le&NF< zL@F5M_cbu`%Eaf-?bDnuA#y^2m&XkHE>K~J(Gwb(5)To7sxA?Em^}(~vG9qU31MP< zn--$l{XYVHBUs)W_-U)wWmk{9tL^iI(G~X>4Gzy3%OX8$klNoA__Cy%@pLx=&i9+Q zy|uJFY_ 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 0000000000000000000000000000000000000000..60f0ed564f0fd7386b3535b4ef9519f4b21a6961 GIT binary patch literal 246 zcmZ?r{l)+RWk5;;hy|dSk%0v)(Eucm@If$G07|s9v@jevaDd_e|NkUoV%uqgzHfCmE0O)I9hQtf7r9))% z-`Q-*i4E-B{m%WDFRm+vsK8ubUl5O{Q=&`g4PuShA_`g{6TL(Hd5Y96Wh5sTImasm zCKi3)L%9;=q8NFFz~mCA|1i$Hz6>B}0{|Oy@0$}b1#@0jt%pJ1nT7W^B1ITL?K-$)?050`T zW(H_JcA)zB3A%4u-KXwqa$|p4#5aP+Tat!V~~j9*34W7aWi$Qpn2A@#-A Htg3tiP3kOK literal 0 HcmV?d00001 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 0000000000000000000000000000000000000000..a1267250d6a66e6cd5808a74d679429b01e74d6f GIT binary patch literal 1089 zcmah{ZAg<*6n>_Qz9f~c8Wy?=!=lyZ(sUI$H#aqPbFT}9k&0iKWwu#ABI;MsDk)e- zzfz*~kMu8tvf3XBB2CI7BanhVK$?huq9S|leRUBe-OF?CInO=!ob#UdlmXD_6DWbG zlyF_dGNe#9SWRETS4T8veWY#n&7Tt;s-s3d;xYz3GMw(T#G2r~erI^t-~Fr296OIr zq{HD-Tn1RAZ>2pqF$KPIyVvJAEve45nuFISUlw<@thElsvhEL$e4p%TIbaXFho7`X z2hTWJkrvaBEcOV*>#dBV9auuSTP;0agAe7f!wVlgC`Az*sDi>wD+8L`_^FF*zJ6r%82NZQ(NYB_{yGzKh-|4@k .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 0000000000000000000000000000000000000000..a29a00665fd2e47719d20ede1fa616471a359e81 GIT binary patch literal 2238 zcmd6mv2GJV5Qfh(s~}qnTyeO`iAZj!E=b!@rt=#hHzP-xGyg&zrMY!syDp7BQA++Vp1V;?Os&X z*LevSc&IARNC=ULOrV(*c|`Px9?>JZ4HI@CX1xF(I*##M^=?ya+r3kHF)t zf=A#Hcmy7S$J+;wz$5SoJOYokRNxVK1RjA$;PEzlXN<<~OrX=B1W$q|!IR)g@c4GX zli*1}Bnl>y`xY@NF(C1g;7RcKw!xF&N$@0i58J-MJhR2TqJQiJ3teA;ZHTfeufGC&QEB zK_=|P*e+RTjD{N?g-790coZImhv@`5JPMD(qwtWDK!-=+QFs&{$`I)AC_D;}0z+v6 zorKC{WnlSj0rVeVF#eM(gwS>CXH%`)rCq~-O$b+AHy+%%y$nTb{A=uo)oO(}FWT%c ze~!CYC2B>a^@?$^rT&)dYj+dWP;t9}wgIMiVYb$Rx9s$>f!=djTveS~@{71km{6jx8 zhEU2cobd!0+;6bA^|_ay)wW^3`CU`vx95#HvxPyNI_&d96DY7M<(msDFf5?6^oMTa z{>;gWKPg*F5Bz9;+WcWlS?0XS#QnvrEY@T)|Zcu z3-GhIEhm5W^fPJvN5Dwm)@^B}?@e3wb=5mwq4Z2R-AUkjN$S@r;q3VPgQ?T z?%$5$)kAel+>PRB+Sx<(>FmC`CaP0Rd7s`{ye8gTOeeP%ABMP@?vJ0RljF^Fcf2|K Ke*B{P1Dan!RLlSX literal 0 HcmV?d00001 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 0000000000000000000000000000000000000000..27841b837f232e127fa7a9a0a93a2fb9549594dc GIT binary patch literal 3638 zcmd6pKS<<96vtmcSRrDv#aY?J>Z}J2Y`t2z#@cQ=Ynv2SlJX!ROlOe@A&q8s=g)id{(OFKc6N7j>&>#My;(4O&FYB$HT?@) zWQ_LRmuBAQ+rAlZ+ux6gk)@rSoY=|lC-&*LpKM`a!4?-6ZE0!A#^bTAtgP7T>Z+}+ zt=anex@~W7+t${WZEkMb#>R&2f7|TcyJp|pnYC%PU(c@X?Bhp!|MM>-O7u)G^crG9 zm(V42$#pGEGWv`@qtECwdUq@63;Kdk&=>SfR?%1V6@5if(KqCV+^RAs#zg)^poCMh zW=hYHU`Q||7!nLZf+4|>U`Q||7=#H!f+4|>U`Q|s9fkx$f+4|>U`P!e90`u(9IdGW zXqf#~=#`G%9~qWR@=T&k&42MbuM}{H8kYVuBWjHbn z8HP%(#;6jKCtk=ZuU7{uau=*rYH}Bt3P}qI3QUFEh0Q{cLheFt9fxwGCx0P-A-^9{ zA%CGZ1%?7cp$>j*R7FpZhMCciks4I;RoE&Vm3%r{=b#1^j_Mpdn2sB#3QL8h0#Qk* zj{qzc$BI!!QDNatCk|&)VX0mZvG}LKPXQea4Tc6ogQ3CDV9>`2h6+Q2p}|mLAPgOQ z7#a)>h6V$n>F8l-FfkD8bBO{MTL zXoqq?&)wbUKG>cQqKFW8O zE8`l5PO=WmH^WipZt1dK@(d>FJqS%y(~*q;((QFhzr|f{*ZK%vUCH>`M@3SqE_v2i zYIkT7#vMUsv7SX4s%Bw4l$r;H%v(VDI%F0=vi|()!ymNWT^~QZ`izTLpvUcV5YIun zjqH4!@%7qiqx(E;%gUoi{GQ{1ue06rg>1{?uV_n4K8}}_){i7ob%_7Yr}Gtv<9k4# z#1xY+T?rrC(Zu>leyV=`N!?vBT=u9B@dH@0Yh84k!8$y{DYj*U?cezPJ0_~;qmA^P z!%EtJ`1}P*=ZnNMzEHY>j0Q~q$``iXFZ{V5y2QfKy^tJu$exWh{QmPNoOKW44=j}7 z;A_b~MuD{G)&u{(=~MUUliVp1zp<*{{r8Il(My!6 BPZ$6I literal 0 HcmV?d00001 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 0000000000000000000000000000000000000000..7149d7697b06755d49599629ee649c5c764fe870 GIT binary patch literal 3126 zcmZ?rHRE9b12Z700mKSW%*Y@CWI;d&HvHM1X7D3bithgXTVK^i$JtsRgWeJn+a literal 0 HcmV?d00001 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 0000000000000000000000000000000000000000..d471d098663e53423246ce568e37f10d3c584c9a GIT binary patch literal 514652 zcmd?S1$1P`@%`WS+LqUGHq5lim=ZgVHERm5R+`n0Es8Yjl{QQcGqc0Y%*@Qp%*@Qp z%)k5TekIN8jC!lr%Kv%YnHdk4hz{C&yWx@>(f|C+?pcL!soX={-wj(g zz{leJp7C($%z<`x!(}RaUrS%K7|PM{&{^$&Xm>XpF>3d=aAc+9wZvWO&GaS*HYbmY z-4E~UhNI7B-#hy=z436&P|xh?hRg16zy0aOg_-%m?EIAay&U}x?dgVN&qlvX6KC}L zvlG+3sfoeFso}V$^VaU}iQ)45?P6hiuD1vF-Ee&De09foxWd`!b$QUAJbht)X*`_J zbZdLMfzzt}I(g_XOs}l=+im)_J>9TvfBW6DZEB`Jy-SCe6Y127-Eh*`=y7p=FfmX< zoZNJo%H42EWuKg7#6wD-G+pdX=%ndX`dlq{!xdZQZQ)9-@`>Tft@26XDy{O#;i|3j zDdB3Z@~PqKD(~Nj8RyAe6FS6hZ}rQ*ZkVX-yRFBb#XchMSnW9O=!VJmj%{J8z2n5t zYwtKI>}>BiIZU^AoDz1mcbppf+Ohw-M5;-c)7m{JWlrDU-uFz-&n_(XmNffj=y*qPRq&NWu|DCuVc zmp+|60G0-e{kiF|q#gSu{+``)YXS{ow`+U4VfX&_tK~_H>Ga~n!mjaf2K^50>4rV* z(O+O1Y}LO*brs5iFMBPkd_dU5WyI=>>!D76d8W5>5LTkSGMHZod(-Yk7O!y4w13C^ zU@$)$u0?5adPlgn49=AFI_$uB{;b}c*Q$If)2#$O-yBuPsGa_4ZPrAQhB{;fB%N z+3(Fvg&WEC@S(Z!F?=a$@KJ+@hv7TX-X6kM8HehY!ic%RE{hj|d9iQkj=}hmx>Ir8 zrNN41zj3Te_N}lr(Pz3Rog8kh0$0ymKE~Gp;ehRpIsA_f`Y=$1l=I9KGO#A|84An%*i;)b zxXHxZU@nK-@^2;Fj(;f=Z;#nz;vKM?OuQrZV19l^S$QYyv|y-o=U5YS^e&h-XYNWt zN01#8lc$Hfso)6{UKXYYPXIM|BCWwAM-3jyYVgQvc^3~!?q*y{Z;TB3Fts>*E`-ORtUu+x#?zA`;4B|b!<`bYpN+M!#`k$@;@S9>HNWZKmp z36O_&O2eun!C5p@yV@fGy3=k!+nOT*`9r>rI1-G^yJij?dQjoSk2H*PKwHlo;7Dn6 zfR?<_do`~gKp~x_JP>m^JcxfQ;lcb%x%m*xCO037-Q?!Ou$yDU!?9P74UdR5@!0T4 z%)Z_x=*U9cJk_m&QZ=@oJS*N7~gT;0Y>t2!k`i9>-4< zI(JMDp0-aK(RLGUr}~S%$+_@k?77{uJ9NY6DcIbyc&ZGKk~Geh^ay|>6TtALt6caP z-V^lGgw6$PjnvZxFvqP_!Hxdx1+K>NGlb3^bL42&|7T)0>;JQ`m&3F9w-TPizy1<; ztiy9<8@ZAy^k(Edcs$nNp;m)`P9>f=t$)v`K2PXe+|AmzI{%&@3+WjAf@m-8-jRwg zOvQzn{vf;vyE*c{7`r+0z65*q$otY*6OX(v!?c6#%T;I&4#g7;$PgWiTRJ#w68rzW z(4cI9E34+rwB9j`7#8xG`)`N{oSIX2hkxM*Y- zzuA$GL^fYoTetNRc+YI< zzlQo7gwCnQgz7IZ^q0dMRo&^YV7@7u%eoC7-kkPgzD1@4f?AXh!wkk@lkAJ7s#}rlTzG!%Dj1EyEY%hLXkY z(Fxv$_vrL4p-m_9mRFn#duH`cu|8rF@18Ywc(-ah{lUsYFMI~`jER}uz3^F?=g^;~ zM0&0BHVUof?da{=lCu#nr#cUv3-8g6)Zch`@2cGm?_0IEh4-)8Cx#DTFNY8EZzX() zf76l9c=+&Ip&LFD3(Mi7@&8Kr82<xKQe`OTeYQ)w;h>9yCbyK+;_Jl6KQvh zwoD(dKk}A#oLe!5UR}s?+MS^7IrZml$DE+uiP~<_pSK+|h<2xHdoKNX+cDp0cNJ~P zHQITWzRw6}OW!4;9g0gU%NF?U@jvr^-6by~gxe}(ozG`{PF1#$%8akLkf!DG^V-qT z$5!We?hId$-2_xTR?sE}q&3omr(eT+*8VRFZItCAz9MB4VxiYNy|w;-NtkB+|1oA- z|9>LWv;Nas9!IbLUsjc^|6f_PyWy*=_O|e~Rr|#7b?oKv4gRf!Z}QL9|8K1oy5ZZg zupGV<|F4Aa@;|Qs-@}UQ|M#)t`u_v0xc>hTE3W@PlI2-Hh=9C}TW!4gPPDXREk=HC zJCvavYh2CxkBYRbUH?&>cD3t2LqxmU^`9}NUG4hM@Y9YdgEroEl}w@CR&8nHZTB5v zX;-`clZmveUH{2j+SRWAWI63>*MH^&?P}M5W)SUa*MH_4?XIG2&HB%ZRI~oGY>iz1 zM=yI3y}fu0_^B}E1$Fn*uGWJ3Gqq?I)W2h<1@#{?Jqs$W<#F_a`g2v;g8GY9yBmJF zYHtg_TD4CMzs6n;zv16X_$~izLH*rYp&Nc53(MgT@&8KrBmd)q`X{Wop#B*vE~tOO ziVNyrvEqXIH(8zql?X_LxYfqHFcK~8Y8O@U`jEQ5^%D+><_adasP$cy z`1x7BnQY9~?h3&|Jkr0or6*(N!Q-w552qa8y5~zRkmi-XQJrqL9~t*;*YIjJU*{5W zv-+1(99~vmcEX?38uVtvVM6H>HH-Qn|2brO0;Ne#yd)(38s0O+hYOz%FYKBtNv zrr>HkZyDh^CRcxoEIOB}rIoC6W5u^m(eON!nh$K8SGI>5eHk?m9*;G6I2rz8nE7I( z#2L;mc!Ot)$vX<3!8)J7`CzRrBB*nIAxxbM$o51_o1A?s#WMEvyFctNsCGH~P3mcF zY%e54Ge0gI&2-Lu5!s$VXl{Xc@c5{~!^7~N;ku~sdBE-Ax|k3)To;$^VNDxjVaZk+ zF8T$}7So$-mk>B-zcyS`;gYIfJz`xd7J5_Dy|7iLCl1d41aRve8`X@9l-lVX7M*MRIIH#5akKi#DC`7SH8X zvH)9yn5`Yq$OAMXTkSvrZC-FTAw78Fs=*U`4IY7N@Th2bk4`8Jo-L;LJ!eM6{CIR? z+zjuTB*zP%CmLPod@p9j6;v?4rHKKq#_tIu{KmzoITILHy`6J*v3Jhzo|_8WWSZP9 zI$2uMe1GJ|m4(rSedr zXJ&eXaJ5*N&@&0k!ri}xm3Cbu`1Ps z>XTGEq7{dH5_2+|Q*rN(d41Wn7tMk6n+!Xnt;w(B)pWFDg6xXs&Ut+Xd44AJV~Ov% zQ94Z}Q?R5sj4VRKmlTJ04W8f(@0o@u0G=(T_aK2>=EoBUlGfmny#~+N)ZiJt8a(4` zc+bWB>B1{BM_)ET_TYm@O~wRrrlZ5QviP(id&! z7gxfW0`P77MCT?d@xIh{o&LAJIhxU-)i9kc`e+!thQC1$#q~bQJ$zcw@ehXPN*gHfkH0N?^DXX@&G! zTdLrZnMQ4yx9pe9rP&Ub8kxCWRfzLe!*SkP1&`)5$~CtXDRHO&b-0iGj_GZL&$-jZ z>dJFll{`mNa7Gw&M3Rgoa65r>072 zlP;Q-=gzV{Nd?YE5pzURja2z?VRQGJw6Af07xlHe^4v8QxVX5ROpoHUZ!3PD{ZhP? zSkN-XZQ_?sIpA)1&#{4zh7=^aySiJI=pLznME8{G89CbLBWGch!p4<_Vfa$m@G*QA z_Q>VtUc%>L(?y4eKZkqEG_NI=;MVavG9USXdhRtYa?$I3)LWC8XE_Pb#0WGQTRah? zU-10nZ;PHF9e2t0tPz>CBZK7A^y>$CU%6|7yq`>u$~3VcJ;zM?1<#fjtA*#L$^F$% z#9KE_=!(;)lotdJW z;Q7bj7CljXqmLtSH%=ab&J($`pD(#4&_mQ)BhW)J8-X4s+cR1;H!_|z4IkjyVv=9x zr?f`F$NXeLk6fc3E_^#_J>Z`38BwSP4)Dw z)<;KsCEAZ!-QNw5UESXekHc=p4Dm?5j9 z@=O7mZ}5j_MZ0;F%Cjlh^EsZQLL+bc>;W<`YF_jf>1k`jQCfQNXyJJ9kjn9;;fA;2 zJ#sx)_*^c!Se5H}DtU;4t8x7N5sq84=LG`T68S=GX3~qIp_%mJw5JxjlOE0vDjFShC1~qtes==eB;XOn92I2Fec1>?O)RG4TZO-{n37hY>!y@wqQJX_|@Qvp$1Q! zHF&hB!J}7>FD;>HT7yS-!+VnBoxR~mZ-z&h{+yC#Qq&KJ*dxObc;r%KZsZtR1VL^B<`|tvuEvEOf4?Z=) ze?a(R@E;U_Cjc#m4@E0|_VvTEE$q@*(Awx2zLcN%sKLX-@Sgnqi12y1bkT`#qkmMU zhb6cguOA!XHC^R4zlQK}0c^?q1omoveKMAGe)g$o==|){X-_wNChh5l&&n{`rNO|9 z(e~hBQiF$UjxP;1A=TiCyatazHF$J1yeFAHCw!hvt;O#10<4|nd_g6T?6fi(&G}sM zLWzFC$E`MF`bIIkymu@-p?*;v=ApLE=e{JsTBu)+rDYD?3SbM=x3K%o z;C?$6n!)|fT1_{6cde!yzL#or=WYW(XaU0{v39Ct%teArBrOIldGyJPhv% z_*cT`0k@8XzZPKa6#6$Rd1%whXn0PV=@&d(%n|S0k9_arw*u$%X`jvte<#z}mP7+* zY(1j=euUS9@oKk&{vd!BT0TGc$7sf{i~lK_@!Laxj%G@ozsNS0rISE9HI{}iMTO@Y zJoIYt#887LPQ!at{;Tl$*tS&un*g?Q{XN>v%Jq*}h(iA}n)=LZ{BFd*RBEIvo|w^d zq^hk+T^bs^TWB6U1ao|8D2bv5Pn?GLNd0f&bE)ZKHKFycze@;kHI5GuK6l(&ehyS= zZTZ=xl1E=!84b_!L%-nJ61R8xIY{kt`mGc_Sb$FYZNoz_S7zq-=)>1zad-M{!$af# z-3trazge~?KDxE|3}4D0e1qSt;5>Nv)!>Pt22Y%Z_vEJ@X!0LA)5U6joK>9`UTInCQZ(%c6pl6l|EMm5SAa2C$f6yooyomT}tq{gQs7^dpKW0_?$CiXq+#p`ql4@T`CsRkF0E!?IA=5M#zK5M-3hxhW7+~Y2ovL z>B0iOj0*AF&H5pkj%*KS+8759o_-DQ;e3SfCC*2xUJt{V*b$DBr^@sj z@!EPAA1!>&csQ+&QN2xt%SJn8)#YS+_|rb)-~Ko}wLqE|J~DhUUU<~Rd#vzzy!7DF z>bMbY)9Gb8Z@9ebr4^T%$43+E3TbCtOHRPH2S>>E2uP=yAVmT3T!V*S4W1Yb?>R{u zZ}7CLIZ5lPT|Q7LG1Fl`Y!g6g^ZU~$Mzi_Bz>`$)2uphl#PFr_9GukP;bC}BcAYHz z=zvppouc~A)XrHw^ybvYoLCN5lxgfshj3aO8^f2P#Rd4oG-e(=JPhxN_DaH+qP?=} zwbB#qRT@*#UR9>CDMd@`nrLxRgNKLVJ<(oG_&i#=SUq50T_ro1ZI|r{k~T)dgQs7^ zdq__RpOfCC9_#?TL-l$T0Yfy|m>QxfnI1N@HZ~qSE^6@bFuW()p75n;cdEX#7!z{3 zF%|7DnI87EHa3PYO+Q?K_ue6Zhv7ZZ_Jz-*O>aY_#pX2C>qKP-gL}H!igza2OM~7* zn3Zj@lqMs6<*}FW_^ZLgDaV(zg}327TFnWcYZb3*bcHZ6Gd~^X1@H&~uEz1g2*-3` z6Yv@;q-TLF%JMLvg)uOENhpc<}UVcn{+< zgwGjoQV+&>kLvCGcRAYW{C7pRhY#(Ij|Y#B8azAM>@TGXKsd|g|TG-9$>a}Hi z_|x9_c<}fzyytWh9^l#5oK9Xx?ee(Of*0Qwx~{7EjWeCFUoVp}@VQWQVejnRNCn;J?e(X34Z@98@B~RCBjLf*ui-P& zBkvLN)cTzC@Zs!CNYBkL&Q8pPn_%~MPUr&^H;tx#K4(dfLc5s?#;vp>(U)=a;PIE^ zO9=$28a%uW@6qZ4Lg!j-(mq@9Zm#}Jt6N|vt!^pP6E4k-jt7qm@ZK{Wco^Oj?gfP| zg?lUYXW`x&JB522nI8HyuL&0y;Jw#X@GyK9?#Nr4w-vq=?(I~cj=;B%Ryvy9LAEDa zTGvF2j~YBY4DX5dj>4Csy_4!=v`gX6m~*=IwiNCn(-SSNjg9B~Ah-Y@x7v(_i){Fp z9^h`AJPO@a_*@~nXnvOTZn8Pt^RuLPmu-jO)&iA1oP#zNrX7M!&Q?26K${o+*HFKQ z@HzEO>cJMOd#avmW?hQhE1Gdlzqd?dQ(DGpZEQSvT;%vtwD2&zXQ1vQd>(DO%1Bf6 zEY*8>f~)a+-w}S3%IT4F_fvgmG1>RWo=WxuWE-E74zxEu9y~t4dyfb30MCNz(fNVG z=Q`VopnjP1L8@+k?DoOYT%MZQ9UhYQVm?%+#Zk&HI?CfN;qjK?i#NWZ6!F?Ne2RE@ z8{VVS!-QW)CuDfIs-+X=Bcd69qv?@pFTZg5D48Ce=qQW3cz+vj8NL`dlq_zKPVhFo zN2f;%pX-$7?Zo6jKh78)BY+7}nke8bFpuNMuIo5myF6~lZz=J>)%bn<2)}e;%kmRc zuv?i=lx?w>IMBv8cm|1nYX<2_!smlT7smO?D%isI6xklmw5j1tzu=YKu7&EU!k0Kd zP4)I%(5K7xaHdTSXZo$t`5D5OI6qVM#`#&YJ)CJ%!m#E%O%U&wm!( zURzI&yhiw(^YC4-*Q!3fKk&L}=|Vz}<9>a#c^cdsWO?GCpPD%EW^q{Dr3DX0HF$U% z-lNkSh0k>wUg6)Qdb{WSX6$Bxe~WC7KD4jV2Oq}Ya=N8YmecS6&z6@rr{Ah}dE9hm z3;f$uursx{%l5=dn=IDi={o%y-ZNJ35I*NTJXY^iy`8DO3wx(->gp@-GClNZZgf0& zT!825(sOSF9^lz>81oL*d(^HJ_Ip*|>CaB2T#9-&p3}fTe^tQIp^UIe|;Fv%~|3{uxBTh zRSX}+wrBZ&j6$=zd|bANC>wU@bqhV4{7== zk^bB;>CZb!)5u78Mu&deqjSl#Gdd$rfWIIgd7zu*)kf!ws<$=yOW4h$A-^o!BRuUb zW)B`8IlgoZf`{R=fgKs|SA@^wWtp*fzp8owJo0RTuOH={hfnK%8aeZ0Z9j|FqJAa)=UDa~ zyI(Yg_#L}ns^DQsug21Y$9D}LhB>~J83a*-Cr-nAROTRODzj?viYo7!UhGe$Z}3g_ zW@gsD#rG?Du)O(Qv>AinM~gA|1D1WW?~fGhn|*&$!Sl^NJc!jg-|YJ}UG~#A`+gJc z_|3lG%Jh8Gj^^sT`kQ^Yq8-Z%ruUnD@S`s@G?+e6r@e}^i97_;o5*QI4!V%qNENxVru^&M{=X%51& zNqlfqh?Dpb6+9Z!SB>U)%<-j345=DCyba&M+=o_|5yG@uZxTzXwHZ7n2R4Jx5p9G# z9Lo;b=cHgWc#8_28BD*Tvd#=XlrEb?_U35E8GM*b&kUwHGb(Pi@y=je(XMs|!;5yc zGZ;Z_^gP*z?1uNuHbw^gs2ThpqwMLB(RFv&0lSuuBd;aTr4B70BU~Hu(o*i+s`n@Z z&Xn=^JM(<2BS88HtY zZ-)2W$AS|0xYcGXT&n6mmiZ_xhQ!+Tv9-!ahvxf8zzfSqo`Ay_jTcdUI(S?ZOFs!d z6E2qa^`>@D_QJ(uVP;}SPXl!c6+CLwtEuh5<2%Qfl!IXno*-)Q#A)~r<~~%ur0}`Q z@uLX+DJ}}arBuK6kfE)V`tfbCOGk5Rwl}vsTqfG-$!?vd!9b68IwI|l_#>kYe2>2F zc+^^p{(LxEC6CyUvEb}pR7>paUKDh}vt{iXe%Gbd4iuo~MQrBBc$M(PUxP;@!+YXD zNAPTG;y`orB3AH7Z*i1{5<#;5 zi$jlUHF%`0!K1(7JDB@e$Hs-v(}UQxc4_3hsMP6kL_uqd!h^?$;XP5qV}GK)irVE-51-RqRrM+At6|Oc=azc< zG}+bT?zzdu-o#QbY>%bpyk}vsncX@N8}E=}_25)H~I#6!o;~ zQ-1BjYNGDT_C!Hzi^7A)hv7X@!()G(f=gb`Cp3sc(~MHkQ(>!wnj_bU7WbDHWf_-N z2CLohdO%y_(%{?2kqnQAh}YJGhlk-inEQxzN%%ZgZa!I#3{)Ru9S^(B?1nR<8P5&( znAr`>m^=IWpz_3QFRW0SnxBk?y()O*!CfX#@pKDLHF${E;EApVj|7IdsohHDY(YaL z@N8{C^Rz?Hyj_P~`xx$Ps$D+ZbhY}?r)#NXpR~DlwBv8;Tt}v7{Ah0Rd+@l(@h!cm z1=76WVfaqmw>^ZdGS;~|x~}kfyu(Z2^;Dmx^7XN%^vEG*_zhBFVwu7XRq(_@U&hUY z$77B!#SSU(-f!>2+wdLCedNZCgfD4zW7Q|E&Wu*0)lE_%X?0T-Jh9VP9(!ro#AA*x zX$7eoJiHCx!Q6*dHxs_3)y-9(w7Lb>Vx!e9Qz2<}D-}Fi(U)=a;PIH_OIkq+y!T7b z@HTu0b01pWTKHV61J%k7F}G2DXHEx`rEpuBo)Br0hgeD<`Zat9b03s%CwxwM_^5b$ z)vq1t?m&tA-s9npW_H7!q8X2ocQ&&d?h?&(UUgU5o@nuA?Cs#tiZ(l_zy~~AJE)kS zQX)X!{CMz0Sc6A~8a!In;L+3Y9n5`<^4)~bM>&2$ws{o$-BrIf%J-m@M){s*cEi1* z8AtivW_H7UqM1hdEbKvlpdX33Z`{3OesM}Sf$x_J)5@E0f7zyZYh;NhMv^u#vIsqy z0B7)QYchcV&5!XaWezIT;E}2ZkDfJnG&j8I)Z(Ab7zPGB+Zvr1L-XU&iE%c32Xh}8 z`T*hc3>`jwd7$dkVdg>6QXYl}M~jDvJw%qVDrFVD7%RiK)S?zh^TJmR9!52IcpJWh zxet{dDtxZe@ZF<_slJ)H4>z+L9udtrb02ADH#|zFX;9LPK8>T{OPb-h1`oR$JR#KJ ziPP{M%zbG5XyHp5KSuTOZQ$@&tmaLI$3;78{CG3F;R!NLvy#U2X&gOxJm>h*n82)1<^{+)Ow+8k2qHlp6|Ybs>GaBI zq0_5md19rlaq-~sP=kku;X9c7i1pRN=dljw#A{TaVtsA2i1l^RN>8(Sy=+e$^kcj{ zc)Zo%;gsQvcjw_9@!EDU_o34pgfHpzM%5>s-V`l#dNWq@+`G5P_QXv;SscX&CE%?F z52p-Y)Cu0;y^o)ItMDbA-lqDb)7ztkPVb0T%BOeA_UJ@ESsX>3@K%F|Q-&|<1n-E~ zwu8Bke0rDgC7s@_`lQo)qJ>WHjaKupfcL535sHqoK#D@)t_BaO3||xq-ZetKU-*(x zA5eV~>Vwfjs1IQ^51;(7Y>!U#lf_Zg32!xcIA!>vPVffreTvdYgfHpzQPn4%J{B!> z`Z!keT!~M}_UJ@ESsX>3@K%F|li`~iKy96}8$j>|&z6_><2s*IyOLg?Qhn0v)6t5{ z(^B{h1>R}e-CGKuRl%bfeOXK%JRS|-e0aI70kuGy7o2RvGKOfA=}zOZt9Z^-13^V5P(4QurbT)Avg%7`M{x2KtKJ6toAA zN5gycg%o(Ud_wauDX`J{5^IgVUlzWk?^jfx^!;kInw0$-1=IKIDtPpwFVo9|$D`pr z`a;U|P5FDohU-hLHTr%-_>#WgRDII-ThU5~<)!d#N^@5Fj!GWI=*<-K;PGjAkHWBO zD}3aJD@?343V&DllEU9peNy=QSm}7a6n;R#GWdroc=Vz#)60X$qv1XJLTXsw&EcpG z*Oypp^!<_WC4GOa`lRnqu+n+JQurwa)Awg8c=Vz#)60X$qv4N}wOtEq>*$jmaWSLr+aJ&BeddZokWMZA%hww<_ddng^{elC1T<6o#gY5dD*an|*#Xr;@YU(5FB zML(vO2amTJJe+Fq@HTu0b03#GzY#vyY50wv->N?8^t))G)9r0?KwC|6y zJsQxbarEHvT!V*S4W1aldmjo&oZ#7Vw&6Xq{gc||T9e~;`|8iCPg?&aT4?>(Xr-L| zn{1C>^ivZ*-fHl0s=>qC@Ey#3H!(@B(qMw@h@m7O}li}@i z9IZ>Z>;Mn%{n6_jYFE)A!=4 zPx@X0t2sNkBzE(VSf27>AJkt8TPdyHBDl0l9wqT&tUY+R7{0m0YOg+7_QBVb$J!E( ztx|sY605b+(<>b|ulU3h9T~@z;+~8^E#rkb7LKdp<i*= zBaVoc-3~gE((1?`rILpoy%{?X9-oHyC=9E%!k6E0g^ATTc@#cc_*~)PLnz)UV=eUD5#;NAGb9uGP z$B3?M796ia8lx*<*$t)>DA*W{tKiX@zAPpW9*>6itbUL(4Y0O^D^!h(cl9G)wL zUEy<$>A}->+laOY(zd^Qu0IGTs(S51@+YZe!nRIQpo_=mMJo%ylB@J96!beREJAt6 zpR9Iy;6vn3QS}=6Q&sYir&SGk`rRM$S5&*4d|JJB>>dpC>uy&PfT=MTt{knY-cHqo zt5BHjElr23Vx{jMTur70S30oLrv>N1n*|OqkN4$AEPsUtb z?Q+qFGG@D~*D_{8B@?NX?zGB-E~PvD8hI>ly6;fC0{KZ*uaTcp$wQu2HRS1cf5`XL zu0VdLs@KR*tK=b1s~Yn3yASdsKf8UDTIJ+7X&(=747;G7rePnmKe=0v7*NG&Dp?ez zHx%d~Mxm`Ge=FazNrM-Q!X}NKSG3xJ0@}RbW9=}8#v{CFH~g$dd-P!`X%LIS%1%LK<)D2)3JD^H?bIYtGY8gKd0c&!0b;=tb{$$O5Xxp#!ix~$TUe>Awmpx z&5J&xB-(oLIIh7%FUPl}qZUZ>B7}$^8lo0HlbSfevt38(kqg8z5xJauBKzZkAXA<2C0gozK?yN+y=u#|=LYax2@_%^&{Uu#G+ zNuXzvV0p8aSgf5%Y5ZE}5ukuJFXE2;wDqjbmlbYgmP=nLuY*>&uDUeouZL~YU!Ovf z{ssvXrN5zUlcptoCJp_r7hC`uETe)CX0)Ni78IrTJg z7xWm7o2s@mhjp`PahzWaH^=7CehZA0KDU&~*~-@Z$Hri#KYP(5JQ)tmu`nLbR@i%> z_8g^Sg1vaRWB6sdwR8|*7zI!I=a^*p(rhD^h}X8k7oSB)$cFcf3%Y=3Ybkgng|J;> zX+EuU;J%gGX zk?LN;=Tgywr|rE*w8ecR^L=ES%x7UYGT%4uPcq+6wnt|AvamdO{MF#$RD*}N;XP8_ zU-(?+blh5A=r7NN2dKW&Uy1euvE!QgAgs7%J~-CTD^K+V=ZC1^5rIx2IlPpVav8@N z{?O7vA9_&)Z5uvCJV9jm;*-~i)A)EqeyH%d$Q;Bv{fW70Jsag=s`uyyuEy`fNBE6{ z8wc?bs!fCVNUVMu@JB^E4fvy@-3;zyRPd0b+bHJHnL}xCah~Ceg9X7Tg0`N)C5Q}P z99-gzc=7iP?qh||2bV6I#pZFcZLxVgcC*+#A?{C$%@bvNq@}M+s`eYw)Bk!+WH9lJL1yaUP`mUg62A_ng9j!!KLfdv9bsWj+6MJNkpA@KjZMh5;PzS-w1B zKW$yN={n%)PQT!4{61rZ-%aX)pB`V)vhz&U#}gzyK=@hFPRr4=WqWj>z40-8>1+uf zHF$U!-lOw#gddq+Gm{ew;kl~yumo4*^?B=hJ#Ajc#OFKRf~#@+f_2@-tArOi-GZxe z`=SwUo1B_loZAy#tolxW*Tmw~p74@r>*s1G^b`cy9`$K&d^~u3)ZpP^cu!8fO!z#f zV!Zt9i>~2cuKIWl{|b!0E+Yrwl`@Tc>BvW0&=dsd5)^_BL z%gYIuw~b5t!c2UK>Z{eaXK4oqXSVAs?IZmk8}aQMr_q1({u=da3YQcESEJZ#h0mj2 zJHdLLYSRhU>#-Imruw^=!W*!c(n|YA?1^N*Nw#q;WevT;(R*Qs?;1S(YVgERgC|bI zXPGtfrr?`}&oz!Su+j4^sy98~irwh>HrXCMX>WWyczo30;bC}Byl)pik2ii+GM==* zL$xWV-ibA#2To7xjhA=DLcExGH)ek#9tGZmy-UADCCGbad*Z``@%7;0QGwe*1ufvLm?yN-fWQHfSHEpi zc<8~?_A4XWZlY~GYJF9;>8SNJtmer5b=jVAptZ%}!Q-O_4-dn8V*Q5jxlZw1vx)1Q zs`u~&SL63vBmB}u()imllg8h{YPfti*#rHe-uGmBXwi|;^5Ah-gNITL9^Quc4A1w4 z&xa?zG1N%%1Jz3&B>ACCPlz-z3LZTD8s0Bx9_ z@OZ1iL#YN2Z^L_Z`i=0pPH_rEL4K>+v{L*|mM1=1n12tRehu&8`+MO>@=YW72UT~b z;t2jxriTGdjDZJFzlQfP{*&-I<4x)zt;K&*{wmwUh1SN!gU3e=9v(7Mw~{`V^LN#Ic!I0(`;QTR*RuGZs!baI%jusMH9FC+;XOI=Z{c&DBHxt7 zL3f6lEIvS{M=_ch0}q~l4ew!mpzt~4)q4%&VUwzx_4FXjblf@E_IAS|nB0Sy2xFM( zXMhit>0wLv#@2&}Lk%9HHF%<_!4q-~9$mnD=iO%E^U)zCo8#JHs&4Y>9GGbw4#!O6 za88*XUFoPM4!qUip;Uv1ca2V4gwJ(aTPMz?+O$rbTb4%;TGa5RU&DK5-Fbu`$v3SN z=T&txuIH2KVN4Ta;K9?c;XRDcFMQ5;lX^%;y9=l`DSSb!xik2E(hJG7uU(XGXVVxe zajVVd(5?E~g~tc9+CH{b`S3_ey!h}=?h6Z_OByG4JVm>RYLlcF#Y&Q1471Niy)Q1y z6FA+p13$4UaE}iNwtbvb<-;Q`k(;<4Jo*^kli!yRe*M9?q-xV(TnektM|QVjrD3_W zOpj1>(-!LFDxo|+AlUYC%7*(O^kE-k;nXT0o&iMDngP6w@c96y1uAq@)maHg@GlM6 zkup7E(sDS^&EbkwfqHyEtL@`TRX#jo5^s%|M+rY#Og<%jv})6AI0h?8dRdvCaB18Q z_sUh_dVD~u?c*v{K0J~VZ;hmv6F!%8b+sQ4$ErGNIv$S0Oeflxx4qqPyi5--I)az? z&0)ON;GtB5hqvK93-J|%&vlBYa_O%B397cc{^PPelF-H|c<}UVcn{^S@Hyr9dx;F< zc-W@uW@t~uOhbE;?d^t>G1IyGDQ4~nr(&kl_$$iv5XX}d_u!#ZgNJhsp1^AGL|=nP zq8dCpg7==GT}k+SVCkZ{{JOI2<~02(m}v;FYUYk`HOw@GSC{D-68fwO3CA^f*wx?( zp$1Q!;Jp%W7e1GG=>Efms++m912fH?N!!~EQ?_?o=-J+FVW&)w+H_wN9UN-#5Us%z zO%0xqYw+k|c+bi`oe>dn zc=pKjNJrmo>8@TSoyP~n+dj5e`7pUlH)N2*hO?d9KUnq4!NVoF_0rf0b6rycfW)o^=!K(g&) zs>+8+TS_THH)#!D8Vd9=yk{t`Eqp!{&5XZ}sx%bW<=^U1T#r(m@z;;l%=jBbL>!(Q z%JfJ_-)-r7RnmEUK)mf^XO$0=yEHt=VRAQ|iZdS3+MK4VW~0Xk!_oG!tICJPT}m^? z+2Z!3*^PwH)2x~CH&&I>>`eZxrrAwmDW=p-WqO92e%fL8tA^X-1CnhYr&akdX-g?Z z=q9bnwrhSW+(Wi;DvcfOEe4NP_}Cw<;A63S68xUR=Lx=g zUpm}NwK2cLy|J2KlDQ9d^HAWkWLx~DF{CGp--E|rjxXs8C-B~1hJiPDww8+?z3!`a zxnA+O)89EU+n-qp_Y=UrUweP-bmRH~n9ax4ABa6SG206dN?@%Cz3^b!9%XO+51wXvXltz|l3~!m;!e@`4A!hJwO?gk;=woqsM(QEL=OeY2*$-81%It?>_0#Y6 zJUrTI#2z8r!;79Qeh(ghIlh$HaI&~P{lnYvM`G?{^?Ri7`Rd0zF7a1Wn?u*5gs~Ox z(XwrvTfDPzrVTvU){Ha#8-LF@KSua`oHwZlp3SC779Okm&eHB3*pI{RFU9%xc-fvf zXrIU7X@{@8ooD>uRTKXcgwNxT@0jtB{JHQ%Ra<&LNw!gF4IK{g+Pr9E6g+tPHN0oY zo-BM$IZn;~#7uvBE<8o`o%E&Hr((vBygUtSE&-k{+laN+8fd_!dC`#(^WgCY-n;g} zsiuE;8{Q+-GlU;0RJ@XTrfSm~_AIRCr=p&X-5i~tBij=FG|FOz$Nt3p zLbc0dj`P1iu{7E5hZm{7ISF~OOb>OMK*f8CLBAHNXP90hd`_8R)^mwx!b_bb!5K-9 z)0dT;zTD{)T#eILl$^fO=@eXz(^r+8zS`*&T#eJ$l$^fS=@eXz)7O=pzTW8+T#eH= zl$^fN=@eXz(>IlzzS-#%T#eJWl$^fR=@eXz)3=qJzTN2*T#eIrl$^fP=@eXz(|3(< zN)MjZ?A>Rh?R(Bf+xMQ0w(mO|ZQnnlZ9HU5OzL}_bKwK3x1((7%mN%^#J1+l;)5gn zr?c$z7@!ZSUQhq&&4mxkvV&~vc#mJ)HZNLOws`RLYj{tFd_?&CAR8I;O?o|->Z7Xf zOwCWm8xbEc&dl1C7EPS(Pdj+!?L1@gb+yaKBBswmoIl@C^=jOH=iGLp)pQ zf|tf8|G?Gw{r-A>n>%+{rkB;NV?ee(k%I+ZkP=(Hp*@dZz!9@5G zg}!bPhaX34*YqI#Bw9S(|EIEyYHMh+rJXKws-EB2!~1Z%En&Xuy#OL)-GvvjjA#C zj30sH!@IN~kKsMzjfmja#(U8{-p0R_PmB!xA1DVNJi}-FJ$T00@LB$id}iVAgwOMj z*ma38Gp`?#`Mv7RZ)=^v3$B_MxEjBISl_QcgD?nxbovEXr(k zaeP0Pvm{;R{8jbwS9)~f6#hn`ALsAiqZ#M#KccDcbZT7w8SV7jO8=7Wnb)|0GFzM1 zo_4Uw+gVPOavka>kq1wFHFz|r!K0JmJ#*vV!sl}%T}sC{tb&Hm&WsL_Z6TJX32lsm z2T#9-_fS4i_yXlksy508$@Wm7jZyI6>DTZc$_ERdQ{JQ=>>bbI*4`W#RmG%Ch zHyiYuJ+7puIds@s(tAGSg)?iH4rWWS{cR5zi~l+J^SK~?vS`?*6)%re#84yEX5mXx z9j1Cd(y`bZOzsNjpcEe}e7G#nM5n#QY+6|yrHPIwi^GG5kKsKja!%p%xET{mku9q4 z^zFp=T(QI%(YdkG8PR!UdL*E$Tmnm%(yvP4)Y_$V8C0c9b8b@nB`U(f2Sby5?2bOz zyRUOm&#<5o{c~>O8J6=3pAQS%Y*@~xdXMJdOgl?EkN@+J@E_A6{YKFRRBgX!aY5|n z_be_H_ov^pxUg)KrnGL;7ZiuzZ!h8TSA&OB4IbWx_egaS;q##yI+R^h)plICm~4+E zw1I;6Oq_lVeSSM5wr51>vL+&Y*Wlq-gC~X>JaHP{qwwW~ z&lRSNM&V;+OX1`ACxw^8<&(uDMvupAq`pGLC8Sh0hZ<9uWFVyCxQTVM_J9%{j4WVu#+p>#68T8=6HLI{F*FbeTxMhWE^~ox+c# z9X}*Ft=jY<$z8I{f9a&07E$IQz9l^U8s5XVFMQ6I1-{dt-*H-Rau7}vptBrK=if@0 z;a_^{$}DDj(D$57PcZalVj8~m<#(LMV6^q%VVB{HIZOzVkG9r-DH(_}_OHS4h&wNQ zE^f?!6L&!XiF*zHt%ODXrNih_teBlYqZbCTGMc+Fllo`KG|HuXz(WjCls(5rsDO`K zZ8nGHs$-+a2XVH2tW^2%#EpO!cY`mc0xE;&0O`Rq6g7CpEAr9SlRA5Z&r@gUKEbl8 z?LNT@c5|O#Z`_~m6I@faM=JV?p*WWq{MF#$RD*}N;XP7aOZZ$Wg`zJxEcPbCwN>l6 zp#u)DY-#QN)ywOw=e<9zw>86cRqYuBaJc7u(G&FbM!0PbkNR=$>#MdiGqIyL6K>!n zKocY2(TjffN3R>I-N@0Jo9a!58#&p6GqxVNZoHn?^hKC6oo>P5mRo8bw>KH#HjdI# ze{V0`RJ9$xD}S>g_od?x4a~hIRS8eOhWF6Dx$q;$M!BrdWZYtiX6cv%u4Zsyq1Bsai+9_#uH?M|*kaV(%K^Hqq9PfyutDY*VB}jlPVU;Y$kQuLcjN8a%uW?-`-n z37?P9&|%^BsQrfANaV{W-RR8uQT$}$Pl-2vY1PFv@yJAWUe4|VPqbt?wXN#P&CuXJQ%wf znTKFEBlA$%#Dv$i^)x(6(RpxZL`9|@>Rqc@h z9B#cQQjZwnHZJDNOOtxj{E@2GZyRDhN~Y)hl_oG?O8}hjd)m=|-p(W3qtz}KF5L@Y zA$W{x(}OL>!(&(NZg||Py)8UG+WJP!czA-D-SEU{@{!pm$?|BAFB@{hmr@EoHF!AJ z;EAgSPw+K(6sp0aqv1Ux`()wsk=>*o(s=g5Q&g{?rCp9A_tdpQH#|)R8-dayLl4G? z@PEd-e#wL+AR>QMH}xKNq_>*MDBzpU(B4 zFWVyteHk?m9)C4>IMv|cZFtWRy+HVpiLt1U-h~&c))N)D8m})J;WZwV_Ri|Vu`gC_ zXD|L=;`C1o^Y7tHzlQgy^itt-l_KACD)cf{>-O`+%K8TeYMjsxEjB&8R0h$>mc3S zdadd^OUZtnlLKvxgGVd+HM}PkUoU)VjNahn39iQP8w-B*1=8>)r(baE_#JuKc!JP* zym5?HcFYe3`eFMwtHaL9V16OI#Yuq{M!_>g^lSKRh(=N#7kVV+{!)Lc7v2hC4u5ZR z@}&X(hwq-0PCMy$9lj&4Ox`a1NWM!8^L#tw9jfolCHtMS?Yg+cfi`f6TWvOn>-@*b z&Ds4xHC#-WY+Odh`7Yr{#@XL7u^8U1T8r{MvOQ7KW;n{RaNP}$5-v4SzE}8>QKsY5 z`&4bms`tzG9II$E9OmY5J-OJ}V-;LtnA&;<^8>=?VGbXwKB#)ncB;|C>_%xI`W_-rUmj?Lv9y9279lj&i z($5M%l5ca&_?+r(HT}G7&uU5=IK-_so5S@td^LrO>5`4h$T+_s{Kz=tG2@G>wJ5(N z+Y=>ihNBz{H`wqf;ZhUjmxUi0WjbbjMb&o9_^NErF@rY4VQvmLl#7i$X22zesjX)) zzb1Sh=I}A&>#FxmZgBYZ9y7i%!td}gG@&n;>ebX^&ez8BT zyC6RlptI5xex!npa_O|2My9q0PrruuWW|q#&so!hr|nNhwB1BoJ^5*JG5l23_I}dO zum}BtKA!q>nVv^b(A>rtYfHFs)fju<#ekamVeJ@h*BY7Z(Hg{&xAUm>3$@D?PapB% z-H%_YHvN9Yudr4)Mff#V()2enEe%Sy$>|1i!)FU6JkG$g0DAg|lHomX6~TLd#QLq; zD>oFv-&AcO{9U$D zDTP3roQkz8g+Tv#J5LDzP`f;YIQYCl+YA46(gwFb?*CPG|8J*zaQow)U$)4jj{}$% zGrjGmBR_UHP^RagKoetvwI!TceNgbsHu&JjJKHu1Ux@S|RX33yEYlMyP1=#(vPYAThsaU(xaz_7oJ5LB()GiNUXgNEVlQy{haewZz`|~*6gWDhX z=N;jGXgT9uxn`1|U#4f0$2an{%)p1&mT=Sm$|Q#m5qp=j3zQ?h;98^?az;uM(;RC{ zxY>UtQux$FdST&5W^_6`yNIei%Ne*Dw-+7Zc4#fQn5u0pxVUVa)1~E%Hl}dRaz_7o zJI`8h3AM|W8w%l)scXCXLQK1Pn}N?OfNaq0oC&Gn8O&h^xNaJ{0FE4Vh-J8d}ED~;f~NnSe( z`lgdU&wpjrcP8{O5q$ybD%ic{g^9VTa8=o!+@O6shC5fq;F)Cb!UvPgPTg9QGP|b; zcjLsI<|5pagI80#JO`sz%^AhjRo`jyaXYphdL~rxh(!lRES+lHrAjQ14~VsW+_lPw z4M=IpCSH7am+T$F=fVMS&$7$h9u-L+L&HL1&`kJ z+t%VfRa$s_z_;z=tPS^p4s9Rz-EbcWJnUmE+^@=qCvO-xe0Ue~Md9ayx>Y*w7SX*0}wb9i7CZ_n7k#eCF^&0e(|IX06i7q6*$&;2cM<{xWI zcu-Z0-m}YVjo>@H=3ZO%w&q?3`;7FRlIupBPg7kF%a+{htKgYlbZgh3D}B z-L{X1Y`70(X#05RhWkL^wvUHZ`S2{cj2k|@OYRMX&(nPPqU46Ex3swtwk61oRqzZR z9khdfcva9I9}sK%ctn*CkFdmBBkY;N=fVzOl-xx1ChSeIn{%L>VVlS|SHU9yowWsc zWR(COACPSOc+`gbAo#YAM_2jq3?!P?4CF0@&j&Ittm#Dcma6W|El>4l!>yvZf_ZDq z<@nsC+hDFl^R_aP`apdHymf~GLa=IH^f@fUSa?j}5%~unFcuEcpZy}lNwVj4_kl9U zV%yK7`SZGbACug^J?_QAidU3*t4^iDc`0&Ojj!Pt5W{5l;8D!*mX4*H1jst9(dO{j zs#Nj#V7%Hs9#`eVb6#~j`N-3Y&o0?|aC_A^`E`eA#{9Y?=HAKqIsGutov>4`-5E3G z+FfLNa*h7mF+To(F4qvoa>tWvsAqUj9-werqbF45fyW0!*Y@$m4fjD#w0%6O%7-VP z?YMyJE1EIC?u*&1m-oX?xpsfd zlxq)=>B%+vZ^!tw|G8X47|R_`uA!dcJ$Zn_ZH=B@l?NUl3|-sDGdA1@Innm<%qkzA ze14#ObPqxy!9l^8y=dzWsiNU)vqK)A_Bk)k+^AU(w zYRwVrVXALN;Nj7XBk%~!_~fET%JPf_{j|s8+5dB6fdHnhXXQX8!+SJB%VCYi!gKyl zY2?YLM=6FJqU=!vS< z?+iRi|DsU5ml4z(jhff+1vqd5_kKT)ehu$Q^Ct_R2MyaM=%=XK^7-kqJp$0CAiz`U zawR-X|2zT!w}3o&`Zc^Kvxo|O+-kEqJb%M8>lyNqi#&XG@J!V=Yss^s8P}3$%k-=t zv~EZ6g8#YogRqIgdv<^}hWDiTbA-=FVEF9dxvFnQ;Ca!EBk+98cy{mtS)Q?=pY~Y1 z@PBSB5WuwctmUX=c#lSCIjqrGc+vkUjXe4ELd8(Zrx&Td$)^`bGv?DvFq^Z3m&*32 zMNh+OZ4NK~Kc$u@Ly*8S#DhmC!=usmeViSjWm}_{Z1@`fGWi%e;^_^9m#exN@K;1L z4)`mhxtI46UM15r-gGn^%UF16*rZbfd)L7J+q(qAcl|l0jM~ou-S+42AW)a@qn~^q zt7XkQ4ePa6H}U1k1C+Ep@ZgcV2G5un-ZSf8EqtB>@vdn4Fu`k7-Q>V)qZxDHb42y?K(Wv;Nf9-&jfp`@OiY& zb<^8arOSr5^KWl>2mjLh>*1Yo*CIcZ_pZ2mIoj`z_DZzhllHR?zc=m1e4k9uIODoK z&abE%XO9o!YWsNQhWkLYwvSg;`LK*C%?SnrADqZH>s#@`!i-p()2nspSv%a>VQcs> z#|Hpye}0&uF5gE6jXHFduxb)to|wrri`j!G8(a9T4flbZZ6B}Oa373S+sEsxe0cJi9KeTn z&XXx^PH)isT$}TyQ(S&8+2;Q6nxLC#tNZi$PhGx`e)4_f{HS%Jw!ONEFOPOi71Pdx zXFk>7nRG4uKGqs$W(}U{TZ3ng8{V@veMb0vZHhN;mKUbS!)H~iN0rI?9G3QV!{?iQ z-S7oj9!=>5PQzzGrDGhvYVa_s!Nc3|9*w>ze6CS^Gd*hbCDkU4zKpdOwZ4KC)%t2v z+YMi9YP;d9TZqK1Hk-p6s}^;S4`{W0ys65ECn1Oz9~?M5f__K%Tu@sK!go~}1^pg| z(mZ@0BPsg>nVzWWq#gB}tD^S!fM46kTQ=MWp|^d!waSNQ^w6|s^nNJ(x}*0aRmRc# zF-CuJdPn#PRvNya%JfJ}FYU13Ru#6#2L#(b-oD{J2z}VcSa?U356|$SY0dEcO!$2G z;>|Bsv!AOn4&N^@n0&v)h~xMxtTc|lmg&)$?uO&v9Nt+KzsCnm+dkg4;XV+d?c?1W z?gM#;eT;?oRQd4a3gd;qzQsJ@Wlll`&U-hmjKF_cA?$M%&?FH;4CD1?%wv zt+tQ%Rr&A;O1w3K{z3R$(A6W~A5|Fz{SyY0@6Q-X*}us2L`^5{sNY`|wZ{ki+CDz8 z;XVkx?c;-0K0Kp`rZuDYSK&vGUT=92{-)Z_3fAATSWf>Dcggst3=bpvfRXnS22UBj zc$*GF5wC5-r-+BQ;XP+|{}O(rLetAUi2C2E?o7vLQtM+k_Cu!!U@lHf^>;6Y17&-J zqNgnI;^%L0m*ISl;x3%-m=h($%NAy zJlryTG5LtVr1D5hoQC&EyG8h1+ISRdCgHhM-~0&ixiQn^Jx?^_u zZyCNQ6qGD*k5KS7yho_>37-pJo*pEd|>!URm`58xu|@slQS1nm2&3d{7X4=3Cxr;m&9yx=2F;A&TN%!v6b#- z()n;~o5M$|V)OWbdE3Xws(g5I07-02J$Q5jKYYqm$^o>s{w?Mb9{q=7J}`W|DrQg4 zTv|TzoQVr^|BRlV)pi+GHwn|h>@Q3#_VhE1N5n!}W{#9?;gr&ZzJ|jY3!kV8$1^05 zG>Hvgl9)JZ@Wg6(kGw|-KT_V=i9v6%uP5UjEkwG@aSYbduKrvvTo!YBW`1cYTu!D% zQc{_*^O8#@E6$F{xjdIZpMRRn;!9k|#=9B$2Fd;f=OLU5WHCc9z1+%@X)Qn6HyJGplk5xVt7xgoFaUlD$N<) zsjAY^`HK8YN9QX=b7|092v^2zj?P!XZjR1ZmF-z}=^UPMtIg){$*N`7;{)bxAD^o7 zVfj*;nn+@Ld+_L%<4gIAwuZNuOL+7jj`_gw>8hALIde7n$a5y$vd*0S zZ>KwWIWp&?3$knE2{5I>Qb&Z752(D&Ls}Cso_k&;CVKfhx0Xs&pDIvTwg8rm&3JG zPd0156mNop!!KVxPP669nkDIDl-w|9#_&-~>V|Fmh~#>8g2$I9mTT`Lmg}s=a#%@o zaP3&W62Bz}$NxesBNw)l#ULM-nElNoIz_S5pIGiMh3m<*Oe(Es*KMNm9`)%L6}(IF zDI*v&+RZ)u>%(|C+<<>8;fDO%8*Ze39_}=Tilqb?CU|f6SKW=Yau%Qxt;UjHdwmZ(jW9@!);aYJd~K`5Ms*$%tL;g z>#E|yi!*D-bQ=p_jqUAo?JTzRWecs@wBqFvml*IdVksDT=)RrsWwCBAgx$%w1NQ2z zs5`3U(Tg4|Zqv(RDJ|}JvsgTM_!!=kD0dP*k3BBjtBG=FAuRU0$o51_oBfHF{%hFZ zRrrzYr_#4l@1}Ztr1#xrn}VeS4{hLZn1;z>ZH-X&V=DBU$Ldl39%`3!j|U*#HlFS4 zUgkXo==7HcEBejidts;dyzZTLFX-NKxQ}d$sl^dS&}v?EWx9IsxU0d#3H%9qbDClWj4U#+f$8!SE%{^lSJdF~jyydKS+8g%{`8 zD#Ep4=Eu7!OFCPfn+^|9t>svYYnEf+@Xgj%507pSOdN2z`bxS@%=D+{!h=-bnM?MA zWqWj>jp^XQ)34z@oF5|m$gyr7)BjM_+nj!wY~#?<50AKQUbKM&`DuE$#yZoRe!;V? z(fi?Qmvg6mry1`@sNVdy_-6jW?T`OQj_}`%_tIp)A0DOpPMRi z;=Kx`U+_rnnI?}Be$+JKvua9BovA!l2#;vs_D8hGB?coViQY0EgvYBo5qW|vldLs* zxW#w#qJ>G;5O1FoWur~MMjXrgg9%SmyFA;{Xh-5tQuW%2%9B;{kf)WA_u%Q*@Sf@Y z6ybByafXjoZzW>fs1an^|*c72)9F8Jzdplke{(epm@KH78bWBJLwlZ z+nOcinQB+i>sd~^;Eb+EuV;^NJEYfhRL!}GJ_`_@>!d&%qu|Lb`Zc_V^7Dkxm5P*i zF3!(}=c~3em=7<|f6sV<&&SKtj{fs@9`-L(yV2}*#TH(qT004Uv1|_$+T=`3_tJ__ z|24Y5MELcYzf`rl^)t{X{9Y#0L!2h-5ihN~^j|~#<-+I0Sz{#h6p8%`)pzZe_dy%Wh@7Q3Vevn&+fEw=!^M z?MR!k@UqC@E)n&E_^Ok%;=f8dq3&)4leiZIVOK9d5^8>ffo}eu3$~_ zeA>wYT+YFxz-JPN)=@cLwm1GitNJE+KZmKzWi9$Vc9Y0oz-~^rzL@N#{@z~rQnKTh zLB1^8GmyB;!|=3&Ti&kuUBu$LO&rz^YfJcg90Kq0pLO0Q#zBS0V51R!kk-yi4k_T# z(Riivl5bS;^7vqU+CIKn<-_7GEeMQzjN7>&d`0-ug78(aONM&>;D`7kGk^!kE1yM{~80v6w`Z?5uz9amfWdUImw6B(4B0F-g{4|q4&@` zgx*^SEhG?nhfoq)NGPHA-aGjJerI;1-PyZ&-+ll1_dMC>(cPTpozJ}UmYLbTy}Jti zo9SR$q2F9c`!5O5k7gnX3(+fs+5}g2G;-QFYd9;Wyyxu*!1vopCY4vIo$p1nBDzt$ zMgq0dik&TVKjP~smwKD1E_%cKzrC?kj^3oA(=l~o=IIEOucM31R69sPG(ONR+TogL z+)vP>P|fv&QX=!y?H~n#_`o3Zn6Wv7udJPZX5L_?^7O{2!6L9{{Q3`IrP^^M4W-jrl*t z3uFGzsN_tL$^p-GAo(Vcv_rSm+J#IG4gGd5S5xgE1=0Axc+gIIGr;F0@0-v>aC28j zMTIW4ak}yLJK!UiAkWR zlgDBo(amz9sKr(MA;}Qf%IHRql8FD7n5yu?^PlDuy$vqOlD^%K?C7Oj1Lrn1C7Xp^?jYyUs?3Et@loy>SC z`XuB1h2;J5n&9Z}X`^W`no0Gwg`S>{Ldm=@@5VlaPH7|wi}uh5k8T-o?NW1+H+PzQ z0K9gR#D!jY#y=a$`{OtMj>kNd>fM-U7mgWi{4qP-Q|kq!AQ~Uw=h1x*lJ|9ojcYrb z={jX8nv?1!{X#BJzr!l@Yi!mT%|%u2o&4d#?$O3|ABRSI%jbm#xRA#q4(aB9ZffV7 z%cwnYAJ;r2QCsLMMDtR?MQO@oo+@bIRPmxaI0W!rJCvkDn2*}|L$Fi1c?)I)RmX3^ z%#UIbZ^0};B{x%sW>z#dZlFhrJbK6@4?Uc`WM*2B6&0Uuw%kimb-Wc{nu?N)L=&fZo{R+FwL?jok;_oKzzCM5 z>UadpQBg7iG;x}EBS^3O-dqH}-%b)d%Tqgl1ZEW}PNls(y?0nc0&!LZw}Fs@0@Bln zkrg^NlbP}T3RFvPiZ?eG=z9`s&5Kx{73qbCrQI#Sel^ zB01mS=Jd%KypDjiO}(wHg`Q|7lsn5^J%z@WXl3)l6jwp9Sent;9j!`5$+&>cGcI)P z#wFoHyF7dh!RM#8gs6o`d|;f8FR}Avk`CH=6ak%`S3}v^d9-<9?7TXP*3N5CQDO&R zou2MOacJR1*N``l^e`-Xo%BwhJ7PL==Z&rmc^nd*Fe0Z@ET7(>pcW$WfnghYdUX7d zZ(tk8m-uEak`DT2O#(XKj6vD?rrx|TzG*^u=gYv)N+bb5yD46M^r zk^|@(^5&5qhDUGw>N$WBIh`cF$FPk&J-RW6d;{A!zQi}{kaW;DlL_d2vlhzEH*1?0 z#y9JrXnnIT6`h_T-vI0Ml-L1XLmoRy2_M?!;bRC!o*o@PWM_=i@g;U%m!yMsUXOsz z&g-M>>^#N1Fm`T4(b~C*icZgvoq=_FN^$^QL*6{n!)(!;zj_W}L{2A(?=fs6PmgZQ zA>Y6@jxX`edL$k6O)~+VZ(2}xzA2a&#y71fTHmx$(dilT4X{p6i5<{262BDhkM`C2?Z{+DwVzfq*3mR=h z0y?AhpzMrRGB1qL%2bpX4J^TNa{k#4udIKzr=rs});pP3&el8Qm9_OQRCKzAYyq^>Rgw$n9`fdq9)?Hn z{_44aK{=h`F$DdCVH>xy{GhEd1S3z6jvul$#_9MHTep#P(AIkq(AoMoC=b~B zx8{|z_1<`8ZM_c_ovtBU1MPH`_&KT}CM=%0NF==`%E$^-t{-@J1EIRLM$e||?rr)$VRKs#L}^5`D&_?i-lJQVc! zL0e-8MxGuWKV)l+)A1#?E|PT6)&~;M+4>-q2W)+?dF5<<2wquRA4)~1Ysl6>J6$EY zfbJoWM|pn>e_$KOm-uG`lJ@Q}} z@_^xvF|VBAj-^);!-3}p6raGScl_Q}5A^8_hti1XgIv)pH8e)!^pY4F<8_9vLou2X zg}z|t_ask-HuvBeaeBaIeDe_`^JQkokpwr0N zO(lsf(Aa4tnJLi&328_72l~JLij{MzBpD}K zxc)0%&P6Rm;sadBV~p;Q#L9WpE*vZ83pIwE(^%5;1r>T8oWfd*h4z-{LXxo-yhx}8 zS~x8vb_UnUOSHb2@G2Y$@3PK)_ zIFfszko_Y@_dK!3%q@?k!Z5XoL1n8;O6=1?2IFL+T&sTv~oH~#tN=KR!OYfM(zAqNlz$$BMG{{zNa`nx}Ay=<~$~6`}V?K z$?kux*7uQ2ZLztlJ-XkNdb(yr510~Gl?SOL(F_!)nM59a<&lR*dE}wDlb2ZPA(Hnk zHRxYh;$f1A*Vjj=C>bQ0I3=8XC>_9c@{;-IQIaR6O)Ip-VQ1a=1mo{iWh3%2l;ZXE zaVk4?LeYlSP92Fn`f&1+sSA2Q9*;OMO-p?B1hw;hm7WEjBngSekaHSKdj3b1o`JD; z{->~K$mQwzsVY4Wp2=|--dVZ!t&x4r}2imhFWDW3~Pz|(jYDioKu9KIz>R%)u z4wC1EnnEs5&;PE_^Ps^nmHdY!$Xfl~h3EyL5@_O-aOMh4CEz-FiMd`R`LMZO5^4&$ zJUzc$rDtGlNc~sXGvxC0{7QwM2OU+SAMJdVB&-gv33WgVr-SoTXpRNf$xHn7I?0Fq z^oCGV$mQwzO}6K^ggrwpPtR|&J-;LD8FH>?$pZVX?b)PxSe~tI~$;(HHbeVk3~9sNBL?^#kaNc4&iRMD(GtEy}pND)cLD=mYOo*7$wU|B{zMVFA~N-SU4V z?nAYBM#h>H(UQag7xH*S62L+d?SG(lzV_xfh~1?0BMHQF!%ryU`$MCjQL-nyzn~cZ zEX+)lOIkP6piC%N2wDooC786!Z}g2E-XdE@FMo%TvV3W7G34B zE%fonEa?Z@yM83{7^9PyBoPeZ>lNR}67)H2=Gxi&SUxjJnEWmyBxJP@<2v0!aROhs zKJp~^aBAnrNh-nTCV@Ck=0VZK$-F4p=$Oy^)4q=|0_8Y3=BKj63E<~(0+jFvD(MF* z=jjLIs?tx;*|34>haM%4gPr_-BniF%weua9O7I0qAa>kBC>qCM-mwY32ujw4i<)ZV z!cw#tUc^3JoXQg0qN_Z%g+Bh6CHgon^Ed%Y_yd*n z1C{gigK<^qCz#-{0oq|9mn1ms<@a3tU@3>Tg*N{N$xREFt$E|>pS;1>jvMyW^ zMeD*+REHO_4_BhH#J1=vk8PokKW0fk(BAbUk;fRFyz@os;*YnRf+2jpBnb|ixpqkK z;n5erdV<3ju8%wkzB0A*<0O^ftB^n(C##}p;$##`Hab>AF@C3FG|F*stWIT#6Tr{o z1SsJTRMHPr&eIRZ<@XZ@Njky3Ab|~BJCv|BbHNqbg27&{T^ z2wyMBr)*&}*AAr-(U-XrT^cL!hwCR#tW2PGeyo^lbtU?38Tw_?iBw=Wp1dGgmDeG8-vOy)U6%ynWL*zM`UY;Bo9oA~?5WZeys{OID8`pa zn#{kudg!-DqGl?)A*5m*3dic>2|c)C2LnJm zw81eV`pVqEjOboA9A@|(g#eD?&HT?eMrIzHulFaX$OD!?IdBc5w-KfWGInp zJLBEx#w1W%GVd5}Vu~$=QggH^6=U}Yw{mC=wJ^EGCJw&Ii!Rb8{)yDHM~?kTun*{- z?&IfNeMro@8TH|t75lJ({rl!5K%ZVTA7k1A<+3sHmZoTKa@vZDk_-dMn3(J&aS3|M z;}WQpHrFq?%q4L<#+vS9X0ARYF4>y;@LggeJ>FAoL-lR}-4^9|JHH*3ogYGHA!zUU zA@~7E^a1(gx08hU&;#<=x=O~oJ<0pyMJlDf9PNw}-GG7{RX>$$kU_em5QIjK8)mjufT4#bk}NEYio2k)l2k*oYPa%?-3RH#aol^ zx6+QJdi+-728HHwbQE5=&jlWh7kCGu*c}~%a$`$N4}KZpSW|)f{CI?F`_FQ@ zk$x2Ucq4AhCs0{3Feu^%CP`c93VA%jkjYEyDMx#0i(&cgB>KSwPCrS4z)G$kltx6e ziVbScl`f)Z+jRizt;{$PnJ}@;(#*Wx> zI-xWonj@D^(*5R%)Q_LM=+8^Qii=n$$@y)EqV2#>K%GSN+HzNSu{k;!Me~vIQ>Y|K z12lFfaA_bhHF|QUmdHaNCodUx7fJiWHk;IeVV_FGc-W^=Q8HLG@dqnu2fp9V8$`uP z`*dnoaS-N&`V6X#XTLM4C{YAWd_^SI2fvE-D=K~#$@_|%)y6J1XD8H6<)b%OLe5uL zVz+ZDbZ=t5*jX$i0HQyTgj<5nHRZn6uFkUgmGSfFwKHZ&J1~6hB*sL4&X^K;=;P!i zqd%YIedC*Ls~PzPRO?25p(&TjjXmY)B2zBVPnlj!B{%-iN(Pc<{OHw2kBmPa1? zJ9&w{E+Ki}UM5bjg>NX!I)#!TqU4a4;l3PkKH7$C!Nil)+I8k@oxHnCEA=TK)W))Sf^8sg9_e9N zG%VMcCC=QCxD}mge0eQt;C%T#ZDp`tH)j5BW_6`V6~G-WvRCR4J`yxEkkGyhCw zi8Db>4s3Wdcdmg+oC9s0u_f{tlP@1~CdTdLCC-Fxl4Bkg&68`)5@(jEhlElR%v(*_I`cLvyYrLOEbHx`Ky?E{X+$({u7OD}DM4draEU`PE?++6 zP>kKlOB@ROxN&0!9v01)YuuhgD{gWBMt%4W9ZG!-o>$#Y61Bz7)~@IdlsX#w%=h`- zNiW=bo?5;<=b^b9ggdixgHJgfQV@*~bmrRG!H>u_c!>is2J}(k!h6L%Mwz62V?j4u z2&Bt@cM;BA6TBN`Tob&<6mU)OUMfi}28$o#JcDr< zd3y9htfJL=NiJZu`v~W(c0bCn+5@Hlt3601H%Wxz3>Y_hSZzc!f3AxdXdU+xv@%po z_p?B*xI}Ab<;WT7$+a{3hZR$>Cy8_#l(MzN79Fhmu$xC#8l;nM#P5!ks_VmyXX8)b)2Pdw_%q#n*<>M$9?Gp3^ zl`#X=_}Av43;nqRG-!utvYYz_hv1Da9R8gS{%d^5FnLJw9{Qp`Jfa)quWOfDR=gP& zWAocNZ>8En3Zn4=JD^>K*{@>6JW2At^=-sh>;Hr52d)24dL^+kT0skp7}^bs7Mi72 zhF<6okIu@H*n5iF`J;!vwLNz9PgDKi=$|pKZ0tRYavXclQCVUY(2`ae9xXgetpa_0 zt4LxGWAocdVh?seJ8A6wi{yRl4<$lvv$g*7R6l6_f8$kb@&8a6^LmY+?Oqmv;4F^P zh-eYD#gmzvn*Y2$p{K@r7*ihWy+HE5^?<02=gk-C#h~?G!mHSNFQZ&8mg!pKf6c#} z?AHAi`=SlsulK4cH?|ksI-}Q6Zf|VDx9z2?F*AtADFVust-|)v+AR`jI8>Y%92ciCeDg>ja_1vW)jBgTT~LUunXE@RgicN z#?$lzJG*`)dchZYGrWp3;&YU3MtouZ9cRRs_JzrauT0ry#Mdat8SzbAMn-&#a=gxbM`cNNKr3e% zWXJGm=~z(lE{UBAwQTM%jAk& zNgs%tbRWy+>O(SHAs*2O9-ZGMS@k`&^RvpVGx6T{2dW>;svq$x&Z?hKwpsPF`FEUE zzt|Tht7e+A&8lb~l8>`$NL)r%%|>Ns#n284nxw6`oH~=FduWW;x2hy+VH>oQW)lpk z=?AuU{YdnJKk~@KXHMSvD70&XUm-u3P0QzsbV(nGmvkRBx%!Y~#ZcFk9Ds*hFzr;7J&qejMoy}7l zd!pe~jHjgF#Y{AT3V6hUq>F8q{(uhEVQF*+_<2;Ho8*Jenui3Ovr;n*x^cbIGvrLi z~M+^3cP{OB}oi$@`IofT`_iYl;@7O8O0e zXfgBL5iM?>`=cf3S)x4JJ7r?|U|OIbBTtVKdFYcz9(p@@Nf0ba@?@MUK`=F1it1~N z?a|WaxfCr!&l0@k_luDlCL^}tVxwNZpNTwOjK|F2NN|=2}7RZzrO$l=+7OXKqd1? z55uBbGi2!}eI#yxes0*YPU-C*Y9SII7)4sA6?46p9qSZa6JZ~t6Fo{?F_z@3x?&tv z(id|@q9^3?^xIvbUl1fZ zZ&;zNnV#Y=vgo0D_wGfB%1-~#)(dT*zx4akz=b>>VJ}=zkmz2fcD}vM3{`Ax>?pSP zN4+F~dw=`sUV-T-Z&c_j_e3*LG#~WpvjW|X^bLyrRCc2aMG>IRI}&+xoJStoL0^a$pn8f%bFa#lRF>EQ zZJZq>^58moiOyS*d_`Z!-xaqt)w@|?8!9^;LcT^D=pc=2a5eVcmfHEcn^`#a_jXh- z@i*i&{cm5P|JdK9=3+70f$D2*n(RnLXSz_>qlt5$L>^pcYDt>xMDl)`3?+iSGTUFE z%lA8z2z`FJlahNE6pJl%bL*~Da{7c^kH)_KA$jzWM;>}OdC7QpBYA(ka8Y8syOT&f z-aV)&86}!HEhO^bI(doKdy>4bHNKp0Q0w|=FOsop*GIoW8Gfpdert+wWJ9#~fJj5M zj}vK#_NAgkYxLl>mdHbkJn~RAk35ExM;=4YBM-Ycd5M?yBYEFTn11XOU~*}H5|Nk= za;|I1tbKs(IJEnIv;FGb`O3C%B4bgbSM=no@RRQ z3IPsf@rWbwzFqKq9h$g7N{j+^^T=aRzIiHu;Z#RS>N4o# zOeAp`bj~A>aryEo7oZj*@qw}Dk%xVpydRn=<;eO$Xdk$M8P^M`L{vv^uLk?L!kr}jiA zQ9%-SXy6n-e*bAp8bPq)VeEsVts(1Fk8D(q#KT}a+e>8_$iA!NY`=bjt43wlBCg|hZIr~e7 ze+#wq!!J4Q{)Ot@wEI^oOI(3AzAlm#8+^2rPP?~~d`S1(sNSW~->59n9c?tagO7I7 zY4>)L59xjf)w^l;PAW@uM;ndq;G>;%+P#b9eccgrE=}%E=o?y|A?Nf(39&AT*?TJV zpN!disotEW+$U574SYo;1_$4@%ae5XQ#;>)W&i`W+R-3VGdBidvN!%{@53ZR*Cpvr-$$r~n}TMGYJ%5@(86g0^xRQh z=0>IQLxx3N6f3xS2|c>sRIc=Y&~TXfrv}O`gqQG^Ig)E7bVT1+D(}}J!xp5PU8~7LD;yGA!x+xi5_woGC2!13n~*BLgjw^*!}d;IG6(&G8{mT^_qUTYxx%O{YY>57YqV>uPagn_8A{8ZGK~HI~tnxpX zfiO|ZyUgqeJEr8B41}@s$ipL^e0tqNEkxo2ZiBou+TdF!FPYt6B6)vy_t&?VNycXR zf2kyi9JGKIc(nPv>i=0jLr3&2UEf|IdEWy5`t~Zx#5wnxD>g*0qiA#P4OeW4-lU?$ zMqs9GH0pmYyI>4wYsvZsi>2h5?1EYI$iwzdUK0Ipk-YDFM87#lh`(WiL~QWCLnVo0 z-;R|qsuFVuGkQLL`8{-z=WFS z(R4TZe=hc63}LQGxc(CoiCzDxD>g)*p=e$IxhpnA zUrtWVB^02*=m$?2*lJ{MYO^3;P`Z~hq z=qr+_?Za;V8(X4ndRL@9#<8w>P%*gZBP`B&@xEMyVf`|Hb}~EI-r!k4n+J13nny ziv7`SRFt>_z4-1JSnm3wA5AyWPxK_QGQ{&(4ct8PutXkt*ej1bteQt2w$CFE2SFYi zQHed_MJF#gQ5;J06jcbKfy11f+l|ZYRBbmdbD-4NgP58#E>b8BqoQQO1_x@HM|v0@ zt?_@hoq^`gB(VvDXG<6!oi6qgkOBq*}XTENn{@J&T}ZSLj7iY(>g1W=mAPIF%&J1knC6 zkyy1CqH4)}201fc;rxej{AG{`5SGPoCpXFd5~6vO{UA9|ETF`~rD zOQK~(lBXz6ZSe=9#V(6=Bw}|WD^Ur{+Z1N%Mhhrm9_e9tG$ym>z&m*Ey&G4CJPt`< zLKkO9$v{^od4HgD5W%FZ9q1|~60iTOx?)2#3PrpAujYyk(P%14R(degrl|j)Tj^m8 zXKLdbW~GP4Qu0i=z^r-XVS6VpasBEf@4G&IzPtuW*x7oFEzx{ikCL648>lGh2pE6r zO{~0YQne(sA&2ov&zGTd9(jx`k35E-$KGQ}-nV!9e0dy6SbI-E$*hhO?f=N~lkESf zG#Mr9gSA|-KU$lL5_h1NfIG%hwZt8e%VRDKDUUn`o<|<$$s-RV=8=b`AunCh;0`A* zamzX+?}rDn#GHx6cWbrLG9G8p6T=peN95WA*boTxmy24{J>_^Le-M= zf*iU>xJiaxsMhTUy`^%oHEN}LiP<6N4_gwxZMOf^jtOQr8;Ll4rwVm|oUen#21Tnw z%JoBuRNF^i&=GAwwYB{yO+zWxsh!Faf1ovVlCD1J!^unR4m~tu?x1!R!#y5fC)G>( zhn%MWu4?@^cDB*?IdoIC#JrGm=90L2!)o2eGgS}OONI?O&9F-q`ZqIWpZN*hGF8|1 zn_@2&B^E#vX90;kxK3VTvFRjVF;J|dW(d`UT%K*OWTy%ov(J~M9{^hH}!6J?q%f_Gn2G&bIkiV~ZF>2#FHqvt&G&@PWWhTzMGY>aU_d5MkpCwbq-SR-p2 zo6E(n&gcNDm#ndnL%(>;v&R0eLjOaFQQK<1a_m5=uI(%}_jE=Fq1e@Jv^to|60OkO z*Gl45^yRE5=?D7w{Yb2T2(|OAZg*-gw4#`>O z;na@w&YWeMizMdPg^v(w3^}K%$*c*klb6ieXOp}?YnwH* zxvQg*zQ*Gms+X)9kVC(C%(G_xp+f)WB&&sX^3CPwT&ky^c`r9ljm|?cz7}&n%ALI( z^fJ1D$`TcU@>P_yL%)8z(exks>|%OB@;(C(9bG$=MnvN>Uud5E+#QDP-lwhfe=u<1 z%DV{#dUJ60z~>iX7xZt!55;Io6xGmEm9KudkmUVPFbjBJS5L8xZjiZ%1Zw-^7Z=kD zNkF0zw2+=mf$QWY0elI``&yfue>SpT^l&NF*LL>dL#LOSVn2$PqqtEsT|MuKu0Xl1 zr`XaLUFnMb(N$EGyzLCW^RhjQAOAo1wlfT4B84*7MONsOv9O+#mt2K_h0`{gkn1Xh zqz||*-N(dVy${4hx{pb@`jEu))zpU{&t^i5l`+qJDU>N6D$qWYTIeAGOz`|)8t&=MbBz?ej=|0x| z)%!q9r2AMeS09oY>=x?7kLTnJ_7|#;GXxVb{#Nhdv}=x?NgxwnX}Am5I1b8km) zdvphi?T!6iz2)dml-qjB{oRG=E-FiQmcTkoNaWGAlb7uKp`WvyJEf7d!&o%!FmAt{ zmv0rVKZ9BYtbaFQo%QcQ*;@Zz6l3e(hjMKF`>8CkCa}($k~l=yZgiLphDD9J;!t9F zjLG$p$72}3rX6hMx077>dw|-J$1;~3?Ins*f!@M;kVGVIfE-ki-qZ7t?K*Wo3rt1t z@6hQ!-Cgmpuw%&O>G+Wf9ox&pebJ*-M_*4J{ax5Mbd-iLJnLx=G~GUmkhrlt&(VJ9&w%{zLN4R+v_BnCWFkv9qOX z25wiZqvGb~zQq?vn0`xy?qGa_O8Ahe`DC+gGh_;$y#p->xN;3W!UbjqB|iOrCSmA$ zVDuuG@o&+*WXe+u=KboI&5Ne4_Lk_srdXyQUTKbAG3DOQ7P^h|Ra0)okIcVjrBQsH zii=ZUR<~2ouNxWtckn>ZRJFW$qz7DfleB}DXovA&l99HYnHws;}*AGUa!L zI-rfyL83FbPF^x)yhrktO=UCmeW9L^%hT@%iGE!|8(R%dRrGs@X12l)HhxIr^z+>` zA$*Dw{`DCZB(oNp(im696EY6jiV(94^GCoH?ZW)ADVv4)6Dmrk4>TuQ?r8^Ipfzz{-HwWHbDBLAF0mW-2W4mCB8-*H~5Nrd+!#43wb<3Z|Uc2ex`PQ zjKChX#lGkls>6BJOgzUw>ln>PW&5SoL#QYj3NUUc5_xo&M;6O|u74+7a zYBp+D%~V6F4yKyjJlnSp=P+gagKcwCSu%ET@{Aq*<&lR@dE}wDlb58yFp{rkqq(RK zHX4rS`1{c3M%jkbJXDmJ2pFf5L>}Gck%vl<$2qqo^Po56@t7y`=B0MNsj##o^X8*E zm}&%`sT7cToc+EK%2smIbY_Q!J7bF>p4v_P8 zkc8(#R)_56t8!yov~ab~(G~iO56Gc&D33oJ5(6w^JFjd2b63xzBq4Dzog^k(lG;^`8Dp}ggc?K6X)KA9 zrESkClfl{algypH^hW72!hRu_r{86(_3JLME+_05a;{@j#7pnH-^{<_hvkjXkcE(r zIB>5Kefzg9+o#my7zwn7fx7f@z~U;1 z&z&&7VUkGS6&dhMPvHsU$Bz|hTo(Y_sVhycpD?k$eu7Ntl^FI+&m4w5S*G{O3_J2H zLhOkXCQlF05)ikC0F(MOKp~{mruwQvj9xub%>9;Z#M2{MYrt5})2>?WRB@Zia{!=|($1>35 zehsK`MxKFMq3Xj=?c9hpNdmQ#KxHU~K9ICVIocXckWj5qb!tsab5CPMR-G8IDs-LV zaPjj5ky)*oD(i}1J=CMtH;4>7IiM`CezZ1>7g=^K4(rA1_VY;A_H~jhfZ0$ zW-vD0fPt!3)@ckhb?#0I+69Brv^@YtjMA0m)KM>*Q92l^`G)KSw_Y@*bTU+P9X&}E z&Hr5t)l?^`qO9s>s3Q_Y6zfIP|Aq{8exEAJs~(1`+p?8Bs(+$q&hio`dPdynUwy7B zd(7l%n?LshB?{JF2I_-Fu{xcBs^uaOb~_bRt$Eo3|6!lY|UWthF^mWwqdY%+c|kO zOc3p}wq>yMWU!*--HyS|o56~*YC9w1Vx(VCT}1izxF3V9&0s}Ywm*YiF@qIl*#Qi;E`t?i+3y(aN*Syu%MN6)qdn|c*?Tev zG1%2JSdq&PX0U5yup*Zo!eH0TU_~xFl);Y4U_~xFjKS7tu%e0aa0c6u!HOovBN*)1 z3|2HT9?4+GWw4@&@hAp6K7$oaj7Kxr2|iYKf$kUvJ28V5W!bR|c2Wi_%Cg@x*vT2J zD9esxuxn+oqAWX}!LFUbin8nk2D?rME6TDH8SJ_ltSHM)VzBFFu%awGnZd4~!HTl% z6b3uR$I9;9IF-RRX0W0xJB`6MWw4?wJDtHcXRx9yJA=WtWU!(vJCnf{GFVZToyA~V zGgwiUoy}m|GFVZTox@i<*l8K8D9g@guvKD9bKluw5CfD9bKpu-zG~D9bKkup4HuqAa_V!S-aZqAa_N z!Im;uQI=iKV9P#soG8n#V6eRztSHN_WU$jSSW%W;#b9S-u%axxn!)yEu%axxhQan{ zu%axxmcee6!HTl%j|_I>3|5q7*D=^lGFVZT{fWVDn!$>)?0N>fnU9s-L3{&)-8_R8 zW!a4kc8d&Flw~(D*ex?yQI_4zV7JO(MOpS|2D^0zE6TE480 zR|dOX1}n<4TN&*38LTMFZey@J_*mJy(titJLG-Ay`@U~ypsG7Q?qHy*JO1uupsG9m z?qZ;-JO1uwpeje*!$4Jzx|e~fY+be?AV5{8)PoFE<*A1ls4Ar% zW}qtfKf*v&DfK7=Roz7UcLu7uiS{uDs*3){8K~-RwHhqqPs%-i%2C5qV^9)p#`~MC=F?8L^_aBB@L*(Qk z`)Jw=40TEpNoCnb(_Rcv5&MUFRN+U{UShERhFbX1w3j)o7q7yPru{d7HNomdtn{;4 zuW;O&v~?%dPZphJzZ&40Ex?pCw|>IdNum?t*EsN@Y4F&Fi4#O;gRgU7FCg$?ebGtr z8v(H0xTHg(er)}ii6SGv86ex;OWMlg>L-sIJ4R&Yw^(%A&XdMYnlxdI$k1;G(D4+R zS}5=(0Q5n9k*(heuv5@DNJLkW-({daSafykJqDVN3HorqkvD2r|ES6P3{x3hq4#SByi*0RXr}!p0LFx< zniRifpsGpnI|iznzrJUns;TCO02D*l?e%|Ts5Nokx+mFQ|EB;|?f;({sLKDpFi_Q^ zIFo^@f{K1VkdDeG@YG+sx+O0fvPl}lYy!<9mYUa zn$E>QRhkZGpsF;Tn}Mo^KMw;{4S!w+>Sky6EIM58)g zTE{?Dj#`OW9olB1!Gg)-mW7PoHUd&IYYr}+w`f;L5 zK%-c4+7#m(#x+b5*60VJbt3c9HUuujY~1}+%RVH#QO1~i+HOC(6J>_ zVLW#1`0?Y$$u3^35nv;WRhhgd15Ig5ortV3hJmJ|P52$E^$au}Xu|JMZD61(n~r6m zDw~dDpsI;%JOfoZY61gQT@aecKvg$WO=6&`_j4vQP*t3+#Xwc>=d2xoB1U!Z=d2T; zs;8-S8K^3y)?=WmGl8K}zp9Sk(#BU2PPs*{1L9M#1@ zRgUUrpejdg$Us$&>S3U&%~Xkjs=Qxjpepb8GEkNGr!!EM_h&FrmG}D?sLE0OvjVyi z166r{<5>aSWL7{oofXi{W(9O}2CB-aEoKFD%K#K9dZ-uu!ds}fVzB;o6yYt@TL-Xy z@I!IYin)$X?FAHRI>u(vT%29iJP~+~zWkk(SG3?_p{hwk`Ie%Xd z>MQz7tf@1txpUCGF!Q5t98T(0~x5wrUx-l zl}!(3psF*~Ll~&aQHL^6l}!(0pejudXP~N(I)Z_!hJPdjRfW`14Af0d?pd^_KAM55 z9CZu>RXOTd2I_|Go<+m|Jp)w@|2PJ!8vgMN)D7D`i-vy!162+GLIRYsl5Kvfq$&SRh|o1V`=RW`jK07W=$<5DSp7XG&Ng$#Dv3|6%7 zzlgzZm%)l|qPm#DZlA%5J`H*agWVy672ODUX#k7BQU%v#3{(|dmordR!d}5ZRSA0~ z16A4dDh8^u>D3HWwFX?nKvl!PmVv5<|3?O@8vb<*)XP)ZMXx_GP?b%uXP_#Z-oQXr z!@rS%s)m2ltbpFkKvg#VGXqt{=`9RYHJ|>4fvQd^{>ngArxdp`P}M2LZ46YkocxV} zs_r4ZJpe_F>h2-EgQ4oa6XZ^Ys{2*zyBO-=m2*2~$$o(MZiZ^A6LX;KSFP`1sJdUZ zzL%lu-ch}ep)QyhJ&N_BllA)<>OwwM^kJ0;80x}4RrHHt6JgV%cavox+i~3a2 zNzlU#buphRItO}$p)T%IMW;ZIGSnq}s^|>p?+kTGpDOw)oW~gIQa)Am38=>zs_y5# zpJ1rV__~U6>q&;XtWOo?);}2PavoLo13CX>sLT6QQEolOP-}duD7T&tP_YqIUJZGM z!78tYJj-B}S3{m-u*$0;|6;H^dLFAEBbp4JXRteEu%g-E-wbx=3|6$%{)fTtlEI4R zgBKX=t{JRoLU@tE?&f1{>wmBXPmDvP}Ldds|-}7 z>1zzsbHB_{uQO1UquyYks^P!MKvj-x4ZO`jRgQXxfvOz!E(29L>OBUk8vgqX zR5kn$7^rIaA2LvtrXMj-m8KsvP*p~K!a!9S^(g~YT^IX|fvPTHea=8tm$1GFK;e1a zC9E$Qs_qijR}58m3G3?s6$zzEs&5#mDyhC@psJ+$j)AI@>U##Nx`O=!165_}j|^0G z1^Xuks!IQ#15kvM?o#V73{`jWZYD$3UA&9T723*Qwh9aAF0%~@Q2pGePGo!E*%+t~ z7M-LFWuU4_Wp)ONAtw*fIoccyR5koL8K`Rb!x*S)PMwQ^s)j$DfvSc-Hv?4-e;x*^ zT2kg^psFQhJ_f2Z5;YhN?TCT85$O&Zm}TsJeaX zatzgMI1~F6*)0LfGgMQZq>A3Ds9~tOTLMNhRNXBBD=<{uEdjL*Rd-ggB16@kRn#$5 z-7NttF;v~T%E}B?cT2!33{`haz^V*YcT2!1hN`r+K5%vgrHqE8jQ6+Vuk z*7;P?JK^IQ>PkLU^hWrE02Sv0s#ENV3{-WJF^PeyPBJDlP}NDsS`1WmlCd@eRXJ)M z59)t`gXWti*7cbF7dUufD!UH29s^a4etib23ezbJR28O;vjW=0Kvl8d%s^GK-@-su zC)foBsye}LWuU4P>^26fI>DYAfa*`MiwsqFg1rGl)tz8ZW2m|l>~@B#JHhT?sHQqG zv(}5YKb;I!cY@u;P<1ER-3(QCg1sR_)tzAX1gKc4R0~UqfvOgkG6Pku0lf@VwFXRQ zpo!o&MbZ0fGZ?69ThYfrRhsrQP?e?|F;G>UZp=Vcak>cuRmJJ13{(}Tn=w$8_cv#t zD(`Q>Kvmw~l7XtczZC;jd4FpLs`CCe3{cBUXL; zGF078b*BK;Pg2YTqE%{V2I_-FH^J<}KvmhlD+5(&x*G#kX}UWDRn1d-Fi_PzwI>5r z%~N|ZP}My38wRTK{%;wm%KLjWP?h)hVW2AS@5?|{-rtXbs=U8H168e32QX08D)l=C zs#>KEWT2|xKZt>W|us^C8= z07Z=I?o~UQq3X71#{{TIQdOcJ%Rp6$`ukY{J&u8@67_fns*2PTW(D-b02EHrUGhAM zq1F&NdC1!XK|VYt~@T4q(mX;>|G9-^4hF<9d^f^!Kv=5a9Z20fJa`%6{&wfS$)deQib8 z0nTTjUTn#J732a2s@h^+$UwcglKm>kMGRE6#k`n-s&c%PsLD~dFi@4F{=z_2 zj`}MDRXOTb2C8z@Z46Yk@c)g0s;({F&OlXD{~Zieb#3X+02DE*yS8)}L)Bedx|^Zu zZdAL6q3Ui_yO*KrZdALEp_=N%N+r8d?S6);+fzKiP<1z|J;+dXH>y3vP<1z|JshB7 zQBf@{k1$Zx!ty8sRV^%kXP~Nu< zRc!;_V4$jPz?%$IwGDWSfvPrvZ!=Jp_upZlD(}C`Kvmv<&x8INAFO=eWBw{1to(q1 zs+|8J164WyBL=E+{>Kbdl~A8BP?b$TWuPjXe#SsmntskeRhoXmKvmxVl7XsH|0@Qn zn)ttFpsG0ihJmWi|Gs6Qs`J0^7^v#}@B080F{-<;_ya@Lo&WvFP<7{jKQUC@`QOhB zRd@dPOMr@LN;Or@WT2|4%D%%{`Ri4orE01gV$MXXLse7NYz$Oo)1eGhWz*RisLG~u zFi@3E=VYL&>3|f`48HstW%37^o`v zM=(%T@XyacRl&ai162k8f(%p@{0lKqRq!v&KvjF6MFLR$-e*yUs@wZ4#!z*8pT!xf zZtt@ML)GnlmSm`A7n7I-WpAo3#ZXOkk}CT0v!xlT?%MY<0V*bH)nvUa1657d%P~;Z zWW78CRZZ443{*8)k7S@KN3Fm>RgS7S_#Cx2le2sJc~kb%v^2Ro7ssx>a>ehN@dt#{{VAm8zbBswTh& z2CA9>$1+gW1UQa?suq>;3{+*)2@F(a(}@gJWz$IvRJEu~W}qrZt;Il9j#`_6svNZr z164U{-2ha-sI13Ob&JaS3{|(NOkt?HMWvCUn(ExAKTQl(cau&tL)G0*)51`7x6>3D zs_u50R)(s(ou-YU>b_flDnng55mhKQh`#^3$WV3Pt-k?7UBT0Jtmxa?r!mx(eX8i! zwc8o$Djs#5=sIu*LmlN)8wTea+td>oa240R2kD!LG~ zAw#YAsiGL@VW{Ih>Ufb|OAK{_PZim<%upx#RMD6A_A=D9e5&Y^u+tgp`W|(H$gVRO z>J*Whwj0C!CCe4%+wKf^ zW|k|;w>=ncy`L-X!oh!=~<=g%YcX*a7%C`d;?%Y|fXnp$~!<{F~ z73JH340qlvSCnrDG2HpGTv5Iq%y36!xuSeKgyGJg<%;s{P=>oehAX>{a~Q*2Fv}I? z+u;m%p)6OFZ$~iPg|l2yz8%SM7s+x(`F0e;T{O!T<=fE=cd;y2lyAo{+{Lq8QNA6^ zaF@t(Mfvu7hPz~zE6TUy817OT?s(Dqc09vfI?EO1+X)PJnJib7ZznR`WwTsSzMaHy zm&zl2Yh}5jeETEAT|3Ja<=b@(cbzO(ly84xxa(%Q zqI|oa;jWkEit_CShP!^2E6TSU8Sa!USCnrzG2F&1SCnrzGu);Ocd{to{>*Tjvs_WW z-NJBNvRqNV{e|HcvRqNV{gvUiX1St#yOrU#Wx1k!yN%&a&2mNg_BV!G%yLEfc00q} zAj=iy+Z_ydT9zxyw>uebyU(Q?K_qvC-NkS_vRqNV-OX@2vs_WW-NSIZvRqNV-OF&h zvs_WW-N$e@%yLEfc0a@I$#O;c_5i~zWx1k!dywIlvs_WWJ;ZQ(vs_WWJYXSlNa zOCDjkGqPM!zCFrt`?6e7zWtry_Gh`Ge0z-HZj|MU^6hbkyK$B)%C{#N?j~8TDBqrB zxSM9VqI~-Y!`&>)73JGM8Sds;t|;H0Vz^smxU&08o(^!;AAEa;fvP_H^DG1PZY+sJ zY4#ig^{guUb)tVUP}PUDo@bz{PyYU!fvP_F`yU3X`sD8m3{>?QwHFzvDo$Twpemcb z%s^E({VxMmeVY1}02KDreLvf)3|05Rx7Qe|?t^cyGt|M;4tvLYy=bO-gQ4m^P5mZA z)qR@!tpF8?s+z0bW}vFPdWV6k^6Fg%s>-YP0#JQkz0Xi}dG!H9)#cTP3{{s`A2C#2 zUVY3^b$Rs(Lp9ZQQZbM9qAm8P3|05tKc6vF-A8IaXQ;aGz5jxt>OQFZB}3JHQ1>f_ zs{5es*9=wnLEUc{s_uL5zh$VpkNONHb14Gq)sQ5>Qx~y*j z(TVF%40Sn=D!WblXNJ1GPZeDx`h}scr8#@q~4b(S$t01D6RcG>eXRNXFnK8C8>xsG6{y1mf+3{|%mT7aSI_7@8> z)REr2GFEg|U?GOOu}7UOS_KwnsGImy(OV^p1gMy*w(+RKcW4)7uwQwX2FJ_Z_+2c3 z1<|8MBEv4uKvm1Y5)4$e3@ph&Rm;Fq3{i-9_9QhN@czM>161GPnXm)m?0=WvIG~O)D}~-I86$P|aCQV#=0XY+5NmRZpuc zGf>sEx(WkTO{=RiP}Q_Lih-(@s?`{%YWSlWsA~ADGf>s=*I=NkkXn<0s%$!jfvRj; z&p=fxbpr!ct<+-~sA{Di$3Rsp^>_xVTB#=lp!$`1B16@!)RP#hZl#{gP<1QyS`1aU zQm@TWbu0Bc3{|&Mugg$Pb#na|U9?+|q3YfiTA!in-WHm|P<3w$H8ND)1@R_^s=FZG z%us6*{zq}F=t4kCfU4dD78s~%!ER-sss+1^fvOhlsSH%L3>F!vY8l*sfvT3lX#uEy z8Ej{$x@E9~q3V{wPKK&m2D=!lZW-)msJdlvLx!qb274H)sZLCT^`d346rif7z%m0> zO@X}(R5b-oXP~Mna0UZaowM{YP}Mn0KLb@w)*CTU)oJj?3{(|Tn=nw7rkgTQm8P39 zP*w16&OlYczXbzT1^<=|R2BSNF;G?TZ_PkeJC$u1sA{LOZ2+p@scgqkbvu>q8LDol zvI9fa?NoMTsJflXP7GDIQ`woJ>UJu-FjP~Wd#AE1L)D$I@5WGdC+xd3RNV>t9t>4? z@4}u8Rd?^gUJO-tALnlvs_s6{-!fF)eHME&RNZ}?`!H19eVqF;RNZ}?`!Q7AeVqFT zsOmG80~n}k)Al4q>3GP1~UiRJCb4jDe~)ZHEV- z`c2yr3{|&jJCdR5Hf={SRNbcSXojlWv>n4xb(^+h8LDp6_IrkEs&jAJj$^30P22Gd zRkvw7fuZU)Z6`8R-KOm%hN|1Noy<^mo3>LJs&3PEDnr$6+D>Drx=q{Z3{|&jJA zHf?7zRNbcSEQYFkukmb#s(Y{T9EMtxm<3Ukz1R2$hC0%xif+3;m!YoUQ$^p+a$bO{ z-eRB6Kvi4p3mB+si+v#jRc)~^VxX!m_QecTwZ*=KfvUFHmoiY*rS{7hs4Ao`XP~N( zx`KhKLh4EestT#A7^o_wu4bUBkh+F}s?OT3WuU6Fwm$}-`m?s{7^?29?N1CdxBkWvIHdw)+@rO=1>AQFhjLe}Jk!6MBGwsPcc;8 zn*B6G)vejj1gMxfr zfEO63>Vm+F3^eI^lttcuiGiwY`Z5DmZ7crEKvi-23IkQe>8lJ><*3&JP}oyn99VcZu~=hN_zYKVzu63Gnj()n8Gu8i0=u9wM85!$4Iw{g#2MZ2BDoRoV1=2C7=Aeqf-gmFhT)pBbpiroS*y)$%tp0L9RCmwzI2eW&`ju+}7#l*+QppFJgdrlH77%z;!$P38Wx~p@;lU{);Ea0+;*-2)^|U8 z5G^ai8K@5yE!A@~P}OWT4+B-rR`W7Y)e0~l167??j9{RuT%A7vg_Cr9^#vHJZm+&z zfa*u7IQ$o4pgvd>{tGiuRroK$Kvlb{MH#3nrxs(Ns+?M!fvV2`mtdf(L|u}BsuFc6 z2C6#$UpfFqjOxz+mtm;7Ib~Ufs+&`mW2n0G|K%B~?)<;Tqna&WB0_(eX%EbOI0kh$ zyJLSQGcqF?W{jL^goVr%JmwJUc}T2hB_%}Llv)PrgGKZ7iVRdWPuDR})jYit169q_ zD>G2lJiQ77Rn60@GSEa8m`D|Ui_a(qs+y-)W1y;edUOD)pQl$3Q2lg*RYiHa1_SlM zqC8!bfvWO!3IHT;PT zR5kob3{j5v7W%eg>+Fs*M<^H+t99IT=Ct;WBw{v ze79wwstDMQfvP5z?HQ=*%x4D%s#^bcWT2`mzB@5c)fL~J8K~-t?=B2fwfyhOKvh?K zcMCufqq=wIc4w%%cjoqBsJeIN_GGAo?{3-YwO;hqKYKA$-8*x?VW_%0bAQWFb^FS_ z15`|@swrR}2CA9@_6XDRV^$BFi_RP@;e5qT38Nb zpsJ`kh=Ho2>R<+{T38NYpkAa#qBuR2fvOgk!vawK!g4r6)h#SXFjU>ba%6z2PXD7A zs4D%BW}vF{KZb#-(*IZns?zlL3{*9z9LGRa>3=)}Rjnu|Fi_R-PYgg2qq+~fpTtnd z+AZ3^<9N}#{wD{hh|=%8sHz_$`w`<)81Bprw?VYGJeA=t=A~Bsm~o;r_R|<{kI$_i zBjTPO;HoFWGZ?69B0Q6UdJc<3?mCNsdRC1@pVBy+fvS@BoB$N|tQklwTaaA}{sTiD z=~G2kJ(r=b;8R6rJ&&Q*`qc4*r-#*VemtL{uIN)mX>|cZt@Ej(o7FC4s4M%_$r1}( z#86lBsN+O2a4|z2?NdcDa0x?Q-KUCT;8KRVhEEm6z-0ldzZpOWqFa_OXP`bFLY4MR1bW=uqu>>DPp4N&2H)r$2;2C6#AzK(&a zqUukx0(w0IRoV0g2CCWx+{i#xj=G6~svLDQ16A4d&kR&`iRBgss=CDTmjD#@99)>~ z3?RF5{nr2$$*-FIZ)Kn=_us}qRkQ!!W(D+i2CB-_I~b_SQFk&>m80%rpeje*%|KPj ze-8syIqF^ps+v&mW1y<*OZPKS)!g?0169p^4+fx!QQiBN56u$l!vU&#Mtvjzg#mQm zfBa~G3RN@dk1yCfpZ>6YMdfz8)o!<2gs*hIgZ{?R-v;zIqu5z4_jeacM($Jk&vg33 zvHiBYO`+PBt{Gk3h0bV2`d5KE+5&ZSq^p~!7Ta5*k@Wv7NM<7=5z7=>isiOKxm@Tg zM>z4FNdj9{5$JC0DI3a`q;ZDQ-8)FRg9I{^SYUv%EKOe-N_(-hK>C<&_N^vBq-X_F z@@W#-B&lpmv9Z0Yt+}hctG6e@8TaZmn;nvsD0LS*I}1Ifa-ln_rRwWQY_qHwDbi8s z>@^~D(-c-ggj6viu-y(Mk{Y#DheW!%%f&A1rN>BUi)2@AJ;fHQadV-)Jz9zCM$yc+ zO%<80_TG+8qtQtumC|UC)YCP?c=IC?+202x2M;T5OH*FTilst(p}8Dev4$k>BZ2B{TcXYKBj2e4V{nm;0R9|YGUMO}nwiQ|$%Z(dj-&U^lI9zzZJyfLV@7rgN!;nTpV3n! zJc6&C-X=@>(Ev=fAuLBC*OEv|zvixv?w&%aWc2&Rubo5fCe9}YP*?kke&nR_K z8rRT&{!TSXlg{Yv9N?mUB;9P0thXL%>uKzs8ZATh`%}Fm+qtN@y+C8epgyCzG4#A8 z{Uz$^ihb>cR-3&wbk{{ik$%b-Goy7^lj!R)u0zrtT1}?EsjFP>>M$d{v5HVnTay{d zYgE4u!EiWjyGjK!3oS#}CyTZ!S!d_eRjFcI67a`Cjg3HEacW~{3#AD{@JtfiB1N(j zgvpVwGZb4{SB!;V)jGN^k?v|hh;qf)thcI2Yq3D9033G|$?TC*1dB+$LF22@j-a|B z^f$P`)YnmY^HRCLy|5aU;zel!$>3&wgG?B7kw`jHtXn9<+v!GB69$Kn%&oxDG3e?BGpkLY?-kFsZ?MiZv(9!^ zB>GJ4SygKL4gKLNwZh7bKJoCE~z2#@?eAudIx-H#TS+Rgs}tsHw4enwf2mBbmKP7RR7Z%v@3* zji-OkB!O&xT7ki&ON80l)adXfD(UYx%4F(9YI?h@X);~W>ncok|oH?7ZD*3;qXMr)H9E6ipjmrcf4&aE&b zN$?~Re2|`Tc+t}kfz-2fRZ_#iT7`}C;UPgYqniY~IV9F+MBWIA^qXD!LbNDV8D9g% zG)>YG%+(YUizf!i?G=)XX9vh#N^;rR!I*VmiWo(5BWUris@}jn0jsS?l2yXjO&0LN zJ|SR{PLK+nW#g_ZLxOJFz>4rZ36|&?N9_3Ca*1}Zy`?7Fk)hL7X(Q>4A|X?t(cGp(0MCOzO-rn9%BsnBDl+j(lL z$Y5s(E!HN1^bqa2k6Am8%(gbCP6LA^8$`E|(6021!w#}k+^B%l77S!0rLCu=t&QUz zTigw+%EUomLqdmD73zyne^b@^elwQWtJW70M+M{X1!*z7o?tlQv2?c=%Vs3^P+dBk zN~jyK1;TVSdhkYTW$cWCbKi|gq#~x&+cY@uJW>s0`ZV*-w^cxi?ZMXMfg`EUEz`qE zZV%oikxJ?eq&>C=CGyf9l{f?2g9k{W62|2)+`J|Ye>Zx@5gXSfFmkgLji!nVNXWBb zN~o^W%C1hbPm=65^qd%8TDEBB)=~uFdYZq&!e%|PTAWG3K`n~bRW!jy50PwoYO=c~ z7;XughSOf(JBIWX!biF8j^g3gMX>52*>=1>yZfu3<#yY+S!%ca&HI!7+{722)J z?`1%q6rGxqxH0k)G+(AW&B*pU*{Qs2A8BQ{`|+~KGB-=Vja4F$Un( z)M{L!RXvSsEahy_6v+)a8tlw9NN&ZkgTIVx(3UYBn!O}zmb4u%2rRq?GoH5OfY4$Z z+afulan#}nu0^@nk-WTtHg|AskPZpopv{+D8zhF;W;IHOpg(71+icCXnVN1x`=RJO zYBMlpxD+blJqB~B@^Px}Br&sOxN75PQ@tcL9hl4G>OyB@6P*NO1>1$HeYmZzvt3}i zK0hGT)!EhBYW7`EkklR|jl)eD-G#!m2=l-?6wv;(fy(4ukgzYpa%l<~-@bkmZ~9n^ znw2EYGI@ZO$BSDgQvod>5VuTDC20AhxMgxW!BvH^WLDNZ$(Ti>oh6NuNw_vOx=hk2 zJGG$cOY){kn_?MQnDUYxUuud$t7)QE$q}NDBP6Z7sRr%tkhJrr8?^gU($1T5&~7#I zA)b@Do=u7L6ax9JCGEVa2V1%GsGUDMnEveC0FlQ@q^FWfb_&7?*|OxA%*4=JnrbG7 z6R9#YF;Hb-V%UXdhl~}xCKV=z%O%Y!P7E)LTPA}T>AeW)$*OAl^e2XPaZ7(t&R?@YG#sEJurx z)TSiW3q|N4UFa49OkFpp+jjQW#n&RB{u`M}Iy=Yx9p>$nh1QLtoj{|*09)I;8q2s2 zhke(9RGUz$v)9$S4sb$wT~#4E@r|!Wyl&T<9>Tzzx?t^lnUKBDF{KQwE{vWB47a6 zX(tj)BtE@=NHsAnaT)ef5}QuqIE?CKosMpMKhJklJcVrC;MlS3uF~lB6AQ(CEJq?+ zkO<}<9Hx&_(xLZJZ7Kj=?O;C$!OyFTS%)ILMmAML6>Y9BPeL1#P-?`cKXYB0F7rfJ zRb-%gP#^g8-z1l^?*OJQ9{RE*HGgyBZF~3!?;hf+I)=16Ri;KBSK5y3TZ|V~lW`di zAN;ebP@#pcmOzo2BvPhl9L5Let6a4AN|ahEC_2Ds5KMc_L~ z<{Hxlb%MLY%#9?_aGOG+wX3N^b!TITy%Feq5*e_@fQX&OM-t+R%JnT~iiE&Vl?Ck8 z#2OM9-CD7S)-HO-1ofL#uE!;JGr^xg^#djt(2xdEj^7b@uri?4oFc;vUsV>s5OB2( zqgb&mil)*t4rfE+({x_wGw)>WLIS>>oIqXC_6290PjZ_Z%mAp<-pKbO)p+CRY;k^s z4r56HuL}~0r|23I*t()XYgaGzfcn#^KGS!c7Ijqr1=VLXu=Nxa1X+cIMir|I(R$h5 z*jz9(-Bu)*(Kd#~I>R2Pkr=iCIILlv-`~mrsD_5?>KCC!BHe+hH*rxzv=*u#nEp*% zboF#Jmg!=8qfzjNYlC z+FN2v=G}=+yDKRhOVkzPyJz8<6T^~rhk%LauCSoFHFX)1`|0vV@k;3R#~GMcE@8#kaRbP>kzYD zz1?%F1-&E?|43@8Y!QrFB2kO@rxXGphBi14KjI4Z`j$ zk{Q@SVjiLqK?ZLc*Bje>KoXUdH4-ri;n_(B_H8pj8klF$=fNadt}8% z(qMfmk`5rbl(iCasYtq(1XGbjf+h}(i+`rtlyh8dB9gY;DBG1G)FmS6R1!)>QVg<@ z^dGAAtpkMf1-!bz#@_ZYCJaW>?j%u3SwE7VB{|zdHb zM%-y6QE7yJ#61@1aWLYb+YgK+bgLn`QJZ=z20rl;U$DRqau2FcS!1xi4n?yqxR``! z0WpV}Z{m;5)SH?1^GXOx^m+?ek(!O%%=3){#DRoK?I@C|)JcQs}55ULc`Lnpm4npcNo980scrv+YPEV>2T%sL6#@ zF|j7gMp5(+5=!k%FeJLZVG?AKttu!&mDVC7sd)=YoJP+$W;7Mc9gW@eE^lXx`M3_| z;^#?Vz+|2P?M^znjU+N-t*sNCWhDDr3MISp>=cyiACNmYCER>@1nfG#ioJJ|vGLHl6)k4C48zEW}g}+$IO(N84t4iiP^>%>{-r zRR#L3z!p^n`Wg)3l&S*#R^Z-h0=P30)5B*Zusf8c!wr)@6h+rvvFY4=yX+85?Z80m zNb2P3QuelApzf(I6yN^{sZXm)xqIxEC#mJPPwWe<4=E1HJze%jSiU(UlVr@W9_^I$?X|QJ2OG@Y(~<~ zO^|$qk+icD{P8VGUO>+{1}$W)1Am;cOQm6?EQ9QLu)0_rcaZw(|1owRaCQ~dAKwH) zkdD$zHjoDdY1se?NZayu_mORE$?ir<0zpD2(tD92U8PD9B7*cLML{W2rHCLPy?2lz zAmAVL|NEUYGk50Rnfth(PkgxNd(WJ6X6DS?d*{wgQ#FkTsR?_ei_}<<8Z4nS4y2AL zp)>}hZY-fj2KcTosn<)WQK8u4zPG1$HR9Sg-lc>Z+>HD_kU2n#EzTmY#Z3fyP93z3 zEBRLf_y9m8OgT(7;t8JKXITenG*=#Ft{`U0ZNa#CftoFhyZuh+%##TXPa_D_N3a;MP}X6*ODodl10n1*aP$w}-#2ke_F zG002I*uMoDFI7>Sv8i_9{mRu!CYU5W_y=`RNe7DVRtFWWO``R@I;d#XQS>38^I$WN zEJ_j~X6@ZEKP=Ws5FKW;^V67VpH%j6nyQ(Y5c{eGGw~p{_5o?rOe~0PQ-YZ|(1Vjp zFpdKHZ2gZV6h{GlN&kIN$f9zXm?9_h!5&MRabUr2mAc-}40&Rj$|jt*rXe%oq^ft* zlqNV%l2^bqk;#XLwOKb7pv{LsnrjBS?Lc7jm1(NEr^770eJ%~DH5`N%KDdx6pe*m>8=ikMJ6+Ei9Zfv8Wm_^kg|) zQFt&tDp}<&NDCHI>da-|`8Y}GZWl}!f8tv*G#xoy6TPGoJ$BUzq(CAQKA2iXe z>j4!aD4m@VT=1xfF+q1{1gC;>-Q7m8*x~mE=I-z7dvVQevZRB{mE>90J$`uw1dr)u zYYJW%ed?E4B+aA1aUj<|I@@h$SV`ToW|Gw0sSvxG3&gfKx_EnXoO;rXTjp*-QUZ*~G6ouO?{zzLP( zydhpIN!+#%xH)w_4ouDppRwh0MtpNU)N}!=eX|~`ODI1Ip{%v{rKf!>Ku1&2Af+X*RAx^LU}5+WpOgmm4>K?W9OkjX5yEJSBhx} zYR!6(Js(%)bGBsSi<}TOFT}MK5a0Bh;A+fDz;_3}DSmkvqdRNZEsKr&GRScGAcv9Z zn$JSxUirj=jYZNr#k%eOW+%vUR(f^VH{lCe`;WcMdWZNb z+*&|p1IZcVA+}B?f;^*~Y-`7gUs-H)PhGHiL^9H+3G=W32z%@G%e8F(DRKJ@V-2J$ zN7qGZA;}x+lg7kXK@Q;z9)1LE(p(#VpK@y4M8mjsLEi_vb3InO9`nW7K)1s$55H)v zdB&(XAp2#o?SGa~>2Wqn>jJNw7PmIQ`xq(GL*I->w8n!z7Ie&HTtIY54ty=4j(|0C z4Ji8V&*DZ3*Do!NSZf^&W>tXg18jHv^6(>xM`5kgxImh<_)xo7E^1P#+or7%)N;Ql419RFnoWjw zg?xQ*-ekziZ8#X;bIUO1Tp47eWw}B2^jJxd+Hz!&O+#*w1u_#R@o-TYv;&ei$i`KL zqoxL8J*ZmbjHr1b?hUfv1Xp92S$79M6TduSM$4$edU&{wUV=7YpH0C&pN*>^M_jL4`aS9$h3`~K^=w?}+%g-fl{PlQ z#x9V#@eqkhJ3hy+D~g(|+}g(c`fM4-%tu|{Ij>+j^x|$n1snBNfIlVP-w>WXKUFvE92UfV^iG&+#Fhk!x*nAr-6@cb7=Y|O#3 z&kx}ZzX3eb)-@y>PVMv!;8DV?#4`cMT(espNm}|kq0vHci~86m*O?c0D?_DdqTAL* zWk)2Ur_@CyRI32}6VTi=bEroyWtj#R_;tiQy_juom94}%MsEbF6Tdu6eakX29mP2V zI=rYSBW%ZGI=BYlAobuds&F$#ntn^~hzyBiFD}^RAyygtW>Xzfv*vh^JAf<}Yc8YN zMQ)C&Qot5T?#(jJbP)!2ncu_;^sdpQY3>Rtmkr>mN7Mpjc>eoH(zH^QKY{fy*_0S74=`uh%v-qS*PaDNKKX z$#*RziOqt%XqL!rAlR>eUWRpdn5{?dDx>7GoFmM~po%r*k1*A1qekh?VQbbzsM@a_ z%yRi901v_mJWR7i7_t#&mFr?91|tmfNDnY}VlS6lH5G4wxw%AJck>8H>2q(EV0L6+ zsmoj+tLnmd)dOq~;5Tcv8m*{d)W1-`3jQOc$ zWuCGt9Sd?MetBfoMBsh94WdqLvk|m zI-p`Y@+KowZ;4q{oQ%u?S1c`@jBtdy2pl^Yk1VEkP?jNd!QaP0ITazkoz-qIEJ(DN%6~6`jXba zd{sHXMvhHr)muH|3LLjZAk|+=@heswhmJ0z>@ppKH`D=Tp$^@A72p~8<&kr9B$0_`k0U&Woe!0#j;1~YmH#slAU}s~T+4_yn%q`hrvpxhT zy7ZSf)y%nz(whXk3fY{To1-LtYdH9tmUr3uI zU1Y`E=YXD!UmgWln&i7LJKqs+k>X0M zO|os>gOg%yGCV2YDmTTMUwy+f^X>8nICq0PzgeldmMOCfoEmGH#$eMnSz+hbA#H^{ z433F3-|mb?+wxdpjdzuzw(T_n-4|%2?V+*jJ(ZUskN82kZFL+%m-urD#-2k@w=98d zdn31ZIVX*+5!^-KPQWh@ud$)HriLc`ZQ|Y0mPWZzfTPvpm+8S`KU5U@OQL$EDD&cI4S`pm( z_j+?d$;t99y;UJP5TdX#QDocE1Q3@+PtLZ1Ve9@Vs>Lx@-O4~4@AIBNoACi(ozyRu zoB&~HjdUgV7;7~s_(O`}=dg4;n0J882I|L;WpMK&gLL1YM6lMqp%G_a4JGJ5rBlCE#&tEf@Us;wpwMOi zf@O91VXn0Lt%Z%&7@BO1iexK_pU}GG_L(%REOM57!Ub2ae201 z-^p=6-+Z8kKLUsvVfWknG@(IkU|X8-P}D|VpmV=HB7;Dfja^&PP>2<^UWwzKK+Xoj zL*gh~)X~D>hjaQVv5kYk@c;rB1TdE{1nx*^;CBxj8UcJ51+uO7#yt`>0UcqIoZp+2 zH;Md+xEu{v&%ZV)*YjV3ydQS*aKSMSvgJ?uYa{~Z(o5pVpgmGzAhU%ZQ`Ikl zZHHeTQWhT~Nd}QtFO#g#^QuC|R?bAISmV)Lsd*H-MdvWUpcZqWSD&W=&6|i=s(ovs z(0@h>wSYBlb#N>Ht!P}v;lCsmbc4!U<|t!UBeWe0?qK}#kjUv$S)iKh{+BN;lUt)$ znd?24Gs?%TP1~11J$iy%nw?g{)q41b6FvvVklj%RntaE;^dYz)_9D{;qS1OhXTAqm zHyQiGN;$R)nsqg(AojjC6Z=)by#cOh7NfmM6ge+uWI5)-qlglXE^G(nq6G#*Xu+|3P{hetBr2SXHOH z-JJSVzF3NE-O#1m69kIZ{Zu|k1G-(xD*uR=0rONtPa4oow+;soR8C~K#hc@dzuV#m zKxQ%sII=kCtx|n#)$?@BR71FjrcADfmy>$elilc=a!_9UWSn0Fw>y4$h;iPUc+l6Yg)j)@#uv7lrC(0!l5miz zmNJ?x_e(Pp7V5dAlxY&*o=h_u9x9sum6UI~ppqGBGcbjAqCslu?dSf(oGI*4LUpj$ z@bdctKtIAS53LPMk#PrJ*5}UmYQ7v5+PYwtnw(@<1c@D!1fnOz=}E$_Grt?ezO)gC zHPhWrkhD7GwW6(#um*Gd*tr~(mO<|9x}0w5c7Hi1Erj|$ugf*b)#Dnk=Uwf^%8v2S za2_OKwL@ZEW3GKD3h+LNod17OvA0e8_uq&X;QIa#lXCr#`$>=ocSr`jb?j10W8Tb{ z;1SjpcJWE&AYI~MI;#{j3%(ispO=EV+?xa2UFDovV9#d#G00u;%R`%F=88UYp7B=N zS$7kV&YoBfT4!%9#XM)$WjH-eO;>SBB2#;IkwKkxu^NMniHEb=gFVtme9?3=jnKQ4T zl}57s&FYeRb+Q`RJ;25sGV8}!@RJF3#T8`pe-Jm(l5}NFXxy+4M@LxlPUW0glg8$D zCdil@_UhyNV7^Xh%Uyp=1iH?LaYr0VPY7;X52PzB{FHj2RtbmAKLOnZzdWSDn~LUL zT?yanAH}UBVA~e^*Yr}3E|5B|l%oA~^yX5^tZbt7Zvu?fgj_+f@_RmxTkl^((XPWw zIcxnjr4+4anJ<=6X4wvV!(#u68*gqgu}$s|WPSY3!au)u6tUrFp_kSnZEtw04rhDA z0-xk&+NNEYlFdp~*1_f=cgHUeXCvR|;rj|S?Fs+|Ck$X+U>!VL%GplvolkSmqG*`Y zCJkFZ?zJbtWU;*AFjUnqfBXty-T{-5Xx4W=E9$X1MlU{@6E-QKXgX&yyMmdGU%xhu zCe1E-`}nVERo3iAX!$R&yxBGbNooHs+U-(`8qPuH+%n9zng;>pEqA(1C|T9(ex5GV z+Rh8B?ZEAcUmmv2NXB6(AC4&TvkfO7UnLou%xYWvi=xS@#omG=^)pcUMj}*?rD*P* zpz@)X6hm{@{<5gTPcJlgn4hDuuMSC9$Q@aS zv+4c1a?VV4XyeNugWE}g8{9LBYw+1-miuqK25nN}%;ZQgLF+TxTr$zb#7V$)^-%gu z@a1|Soo3-n{I5>oS>KhWnEB*vpww*a4{!>OxeJ?nt#4A;V8p4=TD^O z0w{DIH}%n;!&;bE%Gqx77^q;x@rpAqN9#mt!*7)oYg70*l)Dqa1M$nl)`Q7*H0yq$U)|C}ywy0!7Q(`8x@S4N?`fIAMqJZ#0d>DGr4CHd*rxCM&^ zDMOQ4ZM`7a2i;@6Okg=q^V>~YgJw#P$21+z@p zWXxev??jZS*d}ipz5I8IMOn($R}D)gQYn=A%55Q%G98jqZ^CgTSZ<+X0cYs(aa?`(>a zy;A_T^?)7;`bA)z$zDPD&kngW{d5A*XN2q@ODyTtn=J3(LPc9~oCfR!!c|~{F&F|3ao(MR!V5B(I_B@nyt2I2}<(o2SV(l0GU zv?5tei+;~bV?5E(oUw?!1a;xl_R-eUbefXV)e>tyE7Yq#_60Nn2`i}p!6h9rp7JEEI zxmtn-r>LkN314!OU+M!->!2Sh@L-5PPc){MF zub?cte4zvpa+blbonw_a^XF!1Ov26VzXzC{C8~=5%UYvHm!u%Imu0<>E=!hs)2BsO zi29^2S^pHmh#^f}ZUdLl@x-S)f#qtDmh$X=Dc`A&S;@kW2&2Y9xU3_~W5SuQFh;F>5-S4tGB)1aNyRT1|lhV>T zYguqYY1z`?+4H8BbG6?7S_j^|VJ*%9+KFEt)*bzXjog^KE~3eP;YPn*!yfoDC_BBk zO6*2#qGqU4G~5E(kvZ=;wu}A@H61|$RS45(0ij|A!3*!ey9 zsa2=yhx^Cl}A9tkNX}&;Dca zY#Ew(_I%$jluTKrO9&?4$slIpmxnQ1KQ6?X$mzw?MTi)-_T#JYWbRHfyvv}>CrO5% zn$ed!R$F_FTNedG%=j-cI07Osks6WT8m^5KoL{gxzZ4hOu)K9pa@*qT1VfN1!43b@ zAog0S{Vw4o3Bc(PdVR$SD}7z^G6bXi5E!p#URUoRPi)eUV=ar*n?cxT zEQn2Wf2*{co5Bk(}k{3BgU3$HsK%U1fW`=Z^@oG^zpv|1;?pKsHtCSh# z5=dv_mxmhKZ{}w6ub(dy5?d_mXu~LAN+z&V6flJ^58zAyN8*=<6wU`E;_swf*$`-? zD6Ph%5-XOvUrdUbwtTgmiRh9jARlXMg!svrxYjKFkMjAOBDQsE7i7!X5b{Iu%fmV) zU7y3i^^ub$JB)BD(m>>u6f!CZU0iZ<(FD~p*el(qIR%UYU=Em@0*s?%=A{_V*~h>f z0hR}xZRzT5oyHrY;z{2IftgNNkxvy0a%2jT&lC!BT?)}p6f$Hlrx5)`|SwwJd!?q3ULXZ-Sj%+vM5&w6Yjf29CNNuOQJuVmHIePCO zmmBNZbuUd3*f>~H-%|kW?TE}e`p3Hn6E}$&=sCzBjFvzwhF6s*fSH3|9wxWNO^9POf9d6G-nTeX2_P`v`{D=re=M6 zvla)`Flsm`4z#)343{SWsaUr5X8`o!mj}Yd2_G^koAboY0_#+gwf51dSoE?np8#<` zmEv%E={R%NbFp*jx*ASo;msqZ3*t=w0T8dFn%h=1{p|2$bIVGCLh=1kvFK$`KaYxy zdiu7;7C}c<34LQ5-3vl5NjRast;V2V2*wLK^P~y-hq<#wk_CO-mZ5SLyP)?%>;+x* z+Mv&iof`)Iu_Piza56Whd5rtmAnFyLr)uu%g6m8YM?mJeZe^xHlejiPQ2iv)@lt}& z?nWJpx5P`K4xPnrksvr%YL-&=N)R=f46%(|2*T^O))xko>FV39Q6sW&5}Hy1Nk9qh zoQBk1LT9HTHJOvn`vG~ast?y@`U&G@+d^Y0&^E=y*b$Su`aS?suStng27xv4m&ln} z1W0_DB1AuliPbR;Kg2H&wx`~%(T-kRTzB_%RY&A0_c0)5Lpm!)s2hCv{B|iO<*f;< zt34MBzr0G%^eXO+u>KDPw-bJOWOm_#N1tE30&&qOiq#@!f@(*SakYOr7{AM?`=Uo} zp`vHf5I&00-@v4`P-o2EfzIYOd>(?g4)z34v{(VPnbhNDlvqt_qgsis8ZUKOBjl68-=wQxglN$6IkxNy!pl4T)z(41rsbgcczC)KiUsVNmYJaLaATWHGb=KiKJRY z*VZMJddFUP6sW`T%R{`YX(!-_@xQzVm6_Tmv0i`95<_TZlh{5%WV4LZ5`j~^xo>X2q1NmI7eP)w$GRQ89=dYYYwc|gx#KUTXn;`B@7 zh>X~jKLz;#_~qeL$b3aVP}e;@QoPDxAZzsc5@J*yBQHH1G1KU9#&W_|1z3oKEsXt& z(B&l%gDo9q(UFoO#d%)(ZwAV*k%2xLwK$?&1d(rwir_MZ-x`eyN99sx4upQCm@}QD z9P-XdFk%^j2LSlhqDoA?FduF)BW8k)mE^;V%aBo7VDRl9#%#@34V(BBki~e|@@&}8 zE2E@xIDGxDv{Z=!XXfi|6Vy)YP(N<0vD$tCfoF>dP%{+$J0=>Hb~OY~P1>$#m5q-~gw9L@qq6q*O8{QW@e1Ih67ACyP}0Qh(pRL8}1&8AQcA zSK#8EU4g`6qeumDolJ$;PvU)9kUs+iH5$gAoaE@q&eHn z>kJ&!1UWZ}xc2j45-~4_G35UNlyfe8bAp3h)9f(~N8^`=v9=uzUaI3p$a1z)hV^01 z-L)$ELFm>D(u_`X1L&WJ5N&E0y{byY$~jSWoihd&R* zUaJ^i&5Il2ZrhIvcG~wkq;A+k_f0cWIZW8UNi*iNhNPY-p)@jVOyAmhOv4C%c^H#T zLuUU7K@z$EN7C_=GE6d!0aWPG0HBDren+QQqW?=6~3^cs~I}dkf{tdzym;eZxk|{ zV)+iTM6-NGkg4M3h@uRs)SA0$9r^|OC3Y>^<&k=2zY1;&*CID&JjMAJ0;BA|54v<`nltRqAT5QsP1F{W%d6-%? zd6s3Yy?en*mCC>-`Ei>h;_~CkKyqdnEv6`rulE4THLvWM+_HNV><}R;dZ4vd6GJ*u zjH+Q39{{9^UmkFFIy;oPS=c(-kCivIR#_YR$52&_tJFI5Uhey8om`(jO=kX+_6+Rz z6$<3E%>tOP5D&tewMk!^)+Uf>V^(`Atqtp5YWV0B8}y2MC5=-`^fBK~1DUt3ZHV_; z)i}oZXAx~4Bf8kM?u_WF4Gav7cDHaZb*8!b_bwWiAueVc0?S*aHvmVn8aOzj%ZHq{ zE7IDs8u&1+Ev$iYbCb4tH82~Lmw}~u7~{MeU{*LIrVsb{+OR}Pt_q)tsWO1`aiJd< ztr|poa23f#f<1upM){CvV+uJO;HLQHfnL?iUe$(4q&~R4H6m@t+R`?8`uXpORKrZo zP5Trz4-BIT$nB3kV^V28atU+=#GPW4+y%l%iu&*hmRth;3nH74aO1>?D&{k_Y@KWE z8$7ts_sqCx5KB0#J<@Fs1!Cg^B{{?{>SC9;s+_D*Bgc#9!Fl(x?aOVF-6ri9m~3U0 zw(7tjR@kw3?vg@!Tiv{D9vGWtozZ=xb|7cHe+s1FmqW~8&b%>U|5DH!&<8u5Kcn4c@>+WKqL^}UmY4~zx`3Tc^)K|??y0WnCnS1W7&6tFwsmxmW$PMky^ z7f62?*JqhZt;ZF;#zE1d9ojpjY8mM5>#%m4XLjea!FsO)WUtss^L;PWlu0XnQu7?p zRy#Pb%wudh6;M9}Yx9%`C8t75T3f~=FNHO+}dPX`k% z+BPU{D4Z1?7pi09l@|#mVt<9uYa&i)uL0P&7dSMy)9)C(Io3Q?<|YS$h-neRs$ze? z9^f4O&cZ*mvQSl}rMr)3$iTh)VS$4=vW5wnV6}3rvtv-OgMiIUmMgFRFl9dj>k zFZ1+Y%Jt!y4L*KD@XK~}8#Q&M+YcK-5 zoCTs^PJAplkvrO(6PG{AD_S~D6)#W9f5@9eHOOl$4u}4^+ONwsei1nnFU`rRO=8ra zLHtBd<@^M95P4HiyAh|E)uXdkk&{cB#qi2{IjjzbtSGnKZvtm~cV3;wnwjj4GD-qX z)0X~8i7q@TM_9#!GE83|WNz9In9Yl@%ymnf7TL)k2vy}7lNH%TzNkZbORx%5u<@%IVZ|Ah*Xa4AND+xf|a_OB_*eZ}CvAaCQc}>OETtFCPFVKA@epKp(RdCm1bUNqDNZ-vi%fwr6$?V!v21G zOp5_bS7DXjU51&C(g^MoaL3@62g++h(`xR)hH_lF!jbiWlLDiCd1XW&UHrBL8CB#T zCCG?A-T3y&>4HY}ZR#l{$cStKC9P`b5^OZX&Mv{c`?2=}`>}*a0)%e~)!M3NX*VZX z8=n%`?aR%>;ay4yU19Xg62dH$X4U_t1oQm=vIH~!v!zWuHG6R#HLr%-mEWxT-vID> zM*zSzB2SbdqcS9Z>$DOra88%%ZBR~ei8fpH>@v)RfZQ2noEL+8z|95E!^Oa?BoqfX z{8^CkGzJDRG5BQ}qV@YVkU}J_7G1$btJnE?3FdjXZ5iizcM7<9;+ye~TMl4Zm~?LD zzjc3+E6@YjyUA=<#-MwXIkk*I|0Z*L8G{Z^=7Tb3WU?@;oL*w{s4_ie%*Y0!=kPLS zbOUK_*OW0MI)i1!y;#PLD#wY=VrP`t&dfWA*VlOIw>iLJ{PGyaGw^}leyo1%tBU1k zdRlxTUT74Csp8%w)7IZS+}wg24J_v~V0|nE2j{C&5}$rDvsKT`to4O@|DVKuDMD`l z^J?J|5PRU42XtWaXLcuA>a0My2=FbZmaWh}e zKOZegIL4kGTrG%Eh*yW)T|E{;+lj3!6gsQ9KH?@ov++C2^H-n|F>m>E5@LOXdl6aLY3%E8dn{b$om$hsdwVQA9g%u_ zEG&3#R<1i)U-xG8rbfix+-MHO?Z9~8>{h&_zo&uiK|ABz`bvf4UN#SEx4@%O@p{iET80)CUZ?ekCUUbVzUcQ zm0twp8;v{YR!K!wakO6M{J?ikLAsl}FcIb+YgDrh0NZvDoB*icbFZz^!cPX}`Cjd+ zPS*#kY+HX1RXAZqAC&UCYQ77`H1y(^2TG~pk!25;aL~kl$UF$4p7Z#}_A=I$#8ME4#p@INlwcy?ov)aU81x=TK=a8psI?jO5v(gF8`5cDs zNg{epLgv#XgV$E8TT7yzaAB$_ytfL5i?s&9c-?GTbyV6Z!*NG=x)GVq#)kZ195DTj z#JGzB3!Dn=awK}=gtx)M5g^=q9DN<;Z6aRny zGjYW{UMIC*nle{cq%KKQW_b`h)svw1$1e{U)Ps#SaMw(4aZS58u*S-;T@JQDkYW0e z1c99&utx>sd?g4wD0%wv&I)(;7i96@#EZd&Ht%gw%N7X)J(Q`8j_d`b=!m|a^+xn` zd|lo-vh*b}8zxmUN2)0zb7a2+;yH3j0`VMq5{Q?HWD6K3A@-P+E)C4IGLt0Pr@KIS zJ!YU4%R;cOj(y@+5P8Yoi10Qv7y+J&1ET_PMzz>)$26RXUmmDTUEIZ69p^ycB{mUg zXKaM@fw&aAh)imr{EMW#N#tu@7S)dPbv^n>RF17qCdtI-rzx?%2>bh}n9mBBXWoW% z2mJD|E>CW29x)@|R+kq|Q!(=cw@KmHaWJUe@jI)a1Pe(<#86^y*26R${Z|CTu@r-j zB3D+t*K-c!`N}YI`Cz|!rMrjhF-XN$Cg z9r8!yhW{%-`sDOX!3=2$lddkBHls2FpXLP zUXpaeislxM`JLAUrDupqr0n|#g7NBf1VgU9p1L!4x{7R#(!h^$C(HDYr?d2_*M_BA zp;f@1G6#$|qDoq+>g!?visy4GGBK3^lqy~1`mjn#p`1xF{oWoz-wG?NjJDvh74{ZkIzKH5 zVY!EtaR&&mIgS`LdfRgG8=__4DHQJ$N=n}%g)my|Fna;;Yi(!%_i3bIGL_s7soyZ2 zv@#$|>&4YIeixdNK|Ko5)nP#1xHRIRPUJ~Rl9z*smPG=0_|b=XA7jxQ6Qv1eN@OG1 z44~KJMuQ&rGYGxHoY3oWpN0ixi0N@GW5P{ALmajJLORXv5PD6(3H^q6J{T|jGSqsV z=A)d7c&BN+IV{MdyiU^x%F7N~ly|FS+9_bz$I=8t;ocFr`ZyeUn{m> zNPa#&qJlljTz4=N-JL{qkYKHR0>{e96)l;L-peNqUc#ZGfE0Ke8;W0wB# zIi!Bua#Fw3{O}K<85v}nFlTHh0rEP{sDs!Un5bR=5G@LTb{XCxY`!&77AddC%mwGw z&5WSO+ykLkloNVAX3g7zax%p0F(Y8SRyZT*F&E_&SfSrz{szX2{fw-!OGGC8F|;8Q z`@_s&nle3xBib>bd|R^?Ek!+?Q<8~ogJ)a$3Y2fJt3zokeSZq0>ZE>Kxe<_;NM>Y^ zsXX2@dmYep{PMueM`oyv`0q__4^HOaDwB13!xV-Xjh?LkdT;{B4iajiN{ieTLwSouDlPX6m^r68{HjI%?S;s;3q&>&<>#~fGPg26k^Jt`Co$ZLm=H; z%-`~!umF)%R8H#-guHO3weF7C$+S+-XQh4)#LLNeiws|MV5QdX4H~@&Oq-|pdWgMN zsbbt49nh@^Ux7HUmR7MbPQI_GnMP?#BXJ&xymAt%pT$1}!gG5x*JhTwKTzO_O`BmV zYXRi78J*B{RonGFu`?m{YBrOas%6uBB*}Qqd;SL^#pvix9U~AI$`P?Chy&x#(vT^M z4m|+M4~o>Xb7=9ugatXNX$=f(2bh9}%+^z5D%94jMcxOwx5oP%GKt#y(UmLygoHMrKzq`9hS*+Ss{ZykN}8wXs)16`t5@ zV@p09RKCs+T$Rj*)T{eU>b0@+lZ@BKo`@Br5n&r!=?>aHeAwz2Kgke8{>2IU7u z>%9@@znD8;BwnUj=C47e&2X7!4g_5#i;1z+FY5oSWS5+#`GEKvy!K?;zz*ek! z*ZZuUka?3lE31s?jR@w?tAKdVovQu)z5U?yvF+F4`A%5jEgs4Lv;G#8;1QkJd07(a zy+HOsNj%`5Lq_!d{;7|}HH?hnG6AKqwVt15#1htV!{cc^Vhf?!X=qfSH2^&T$P2h< zu$f&C$jI~suyz)V1Aes+^~lpDci(RFziUewQcSAS|u!%V2*fjIWns#ya*4l=I+TUiDFf%2t)vDu5C~YsM{q`%5v!Q*# zde^#xT^|tDcWk@K&Hc;5YNFc(+L`k zs4(v-w`%*7DI6%f`w6J&SenqQ`9>xzuLh=OQrjg6os@)3BO>%+5}K|z^O+zAUP~1> zop;CS)h$50tmRo`I}0CKyamcjqa&kz%{4QZ=zKjW!-%Xuyz03sP8ers=MrxOMpzxz z0#?qJK)i%AGCD(FHpTO6x^XqcUK{Yl))G=nzL}(qHKg`SQ>JS&-9H1$3!Gn~wVQ+J zLT?4LBy>etCnOh)heCD_7}KJxOrHMr3$f+fK_QOl8Nqu3LhPL)MlEp>2ro2F2W~jv z;VCQVTkpgPTwa2p7jr-yiC-RQ)poU$4AgH!7I>j6p(-X;(gNPixnYpZjptK@xWP8E z$a^^>Z80zg@42v;y%R|0=@SVe^K|O_-X{peQ_Pv#^g+&5kcFO#%=dKff95?^B=hv5 z6yYlDZyrow<8ykEOCo(tA0dXWk!b2;JE5_7~Qn<3`u_}r6i zRf~L-AY6rQ3Lc3Ovaeb(YAjNkqJD1oAErjt)E!aHj>`O$NIDPvVw9ZjE8?S?1HYF~rm! zQtf4wn8YDse^4>!sf!bb22SKQ`D{$XuK48<+KnZ9oS^*%KwJwp7xMDqoPVb*2dAbp zZJtw#iR~=)0bpL^@xsYcwFR;E*Zw@XY!^;0!dPwlK-h!dG5BYFqp&hV5XR^(AYMav z=PQD%G(sPjL;9Z4_%DJxB2E)+l@_osfS5G|j76Nl{ux-zq6~vo1pieZ)cw*{{jwNK z20%6PfBR*UbsV^SPZ}7k_DN5A9m0GwpwKn}#{07W6ipW<>q$>15!aIz{J&yPq87GT zwxGQsk6FTIZQ3LI$Od1q%#TN)_pP(#Y4vo}_l0p7dt`aV=p_I_|$I z%Y&YDb1CL}(wo3$BOYdwA??zdWqT4Qu3P;t2>bNjuA%PgWCnc#q&Gmi2>OxHl1a^E zh0N^@WBr!vF&b|&AEX(vn9M3;l6q!v_~CT02aI>~$(4mrOSgtNW-bD#Q*}a*jE$G$ zqD<)P63DfWb>>TJ5|gQETR^k%n-3w1(>~Y;;az~dK8RW60KU-L+R0Btv+&1 zID3XPy15X0sW4Nn6Kt7%&I5A~N-|N+m>FCZE^2oAc1q2NW6n%6qrxz~-J4`&Rz&2p zBqD8vA*n1lw&6Pb^62fi( z6M$IU-5nGO>zSauKIU6GoeP55z~(KS)-+>Kol%a_GG_fR$}xmY9N1>55(g%m?@#bT`DB1Q797xzCp1Y4_z*-fvWAer za*j3d-7?Bre@iJPUv%J`thYsK^lAJwaNZ4cQ%%ZE)_YnYQpRiSY5a;ymr*pH z)Dfi=BhLzYt(0;ub}W;2(bf;IY7PLGYx;b`(j@8oZxH6Z6QR@!hmZ}HO#t+XqtrP7 zat&QIXpm{a13+?3oXBLcV6Ek%1!!n#!Ko>L77+MX3SdBK;`HUCCfXoP0CF4<&qP^6 z&Tsvhj}%Lfcso>+XDTCH6~c?DfXq4M4y?m55*&>#1Gfu)d0-65 z7u+Y$A(mXR)VjV(hpdR=!-eL$s4R^lI=3FGHO`54%Iy>P}Tu1TMo zyi(B}N4Vs&V=2Y>vFDv$N=f|^ySo&V+GVr*1lVr)wRJ!La0BowvY0zZJ zKKxc1nn9DK(JwnbsmW}Z&f%s5RKntc?%v)(-OuMrP(`=RNGOx@)mDw^F$A1v0zJNz z(R)YlfhqcL^=Js#@K#){jMFHvW~Y^MCJ+P<0ay%#E!f0@lkk@S+AfP4YRB8oy3lW{ z34sO?;F+TR2G=zZd!DIS9pVV}VoZ$9)vz1rU_&E-#VV2WjRSmSvN`1T#wzUUZpOL; z>^rSVKRnmU@D)D;(SoNFkjy5SXct^Pu)v;N8R%sDCowfabaeG%lT;Qm2ZUXY>{+Q% zWX0YdS7D;59G_HwP{vu)dbMIt?8!p2EDAdZ)X(wD11j*w zt2i@p&ERDG8K;e~#;YSzXQNR-onZPuAu6{<$Q_M8M3Ld%{%In9Cn{#M74h;DV-})S z>4p|Hh`oN@U&Vbb?AX8w*_2AFQj?r<20ZSczjRVG{PabE&n2R;*?ZDnwd(#_TmbUW#&NarP_GsN=w z*9m-g=c@B;N*jVW9ltzaS9P?i?_Gu`;?EWQ(@zb35tWU~d26m46ll(yA+nL8tiRf> zI)56Ksm|X=Wiw=NfVYdXp+4OLWx4eVrVQZ|(|nxY857Nr7b_2h=!X&wi3j${?;M;Y z=KnoBNhPQw*6w`k2W1(Vnm;)z)0Z`OjLIa#aryY^5a*3)k^(<~WG0AN_=jqf0-KC6 zJ(FTGHRhVAOpRHrDR!P1!*;kQ#CCBmitOv}Af*40K{SAZI%J;_se*{=H(hAfxy<5pgTBJoeFMf_MVrPWot*8dQPCgi-g7PM#oI$xF4roe!HZB~MaDHb>RP_wG z3AYJ^c12e_v=A2X?^)?|{$2o{askX}M&mwFkU zKL}<`+yzw%J_LXF3g+L#f`13VD_8(iFjLHH5Zi@$Fq|vN&AL2ZW=z>MI60HrWqE{l z2IQIGL1tAR)Afab>@74?j(j|ZNowKE3Z+mMd`IX9DMt5F;EZ6m1frJ$oNS$!AiQtN zJOm^c54(7f7fa(dFPNHJJ4mXxgwk(+F!V=&>cTG%6B6^LIivazq`9c7)P6OK4$Zek z!P@+HX@-G#_0QVz5c^#k&ZmzrC%w08;1!d)!;mc6 zRtO2U=5rz04&q!$jMxjwsep1Jv5+WY-P{KzXQPZ(OjvS{Z_#R@BnNo*ZU)S2W2~0x z*kXYj8L|q0R@7p|MhC-xX9>j37xn7kBT!t*!=u(a(AwKK$^lAR+UD(<$DXXhThlV~ z?wc^WA{k4{%L0pvaj_Du5l0rgDdS!a90C!+{X2YwkWEZfY|tGPlu0YSU2Px* z+C2#&VG?5F`3)dDNTM9=nb?C}%XvRkkx47MeW6@dOy~(!)cDF@4?ar7!DV*{y^!EE z6OyV+9^to0O2)3TR^2}s2d>_7V-dyurfr2sS6TcfbdcZiWkDmtJ@4D2-%U7I_?A!DaBMLQ%?SU;be;J$r5G|_U<)mpugIIY~4R<^z9Q+UK+JQ z;=a_hXS>m;(GUl|ot4Hi-~L((Io}qT5%rBlif`Chfent}9D)n*sHFymUBe_T$M9}xs}MIOv{bRbqRtK8 z0KxNlWPW5HWoX|fR))wcH7#gOoO%N=uQ?b~3}*IGXKlV(#;H|o6H9FyOe2iCY1kE7 zdf$&AE;>%JwTaE|aZp8@l+vPDkz=>h`_TAL2B11pZROO8@!bI;uOf}8(%0XCrXs|- zaRM*9cVl8t9glvV_%Bb>NmilMKkf(nYsC{xsO zpl%1{rT^jPnm)W;U}kVO|Bg>4VgflJR}&jS?Dm-M9cb?Fz+!bwbT|<^HaykJDm~H_ zZi3V^-bu~93Rd+$f!OOv#J_o9ptltlGQ88zhPCCaP(vopG9)Kl2c|j1TyFMX2V@(d zJW!Hc?a+lqb_l%Jiy^tvp>)%TRIhS4t=T;yt?>$n;XWTiFSE&|0abo`$DlyHERZ=r z12QEdHS>LncaDh7T%Y2zBjRqo6yTioeu%v*QEr+gX>UAa%gqi#ZDo2lg>AVHfY-v%=QoD|nTcN>H6rqzQabPg zB(6hPNfzOych2eNiMTP>iifwFPpWak6i(Ck192cr#vz5{24kCk_2-}YlSSlAXC16O zCue~oEko_?_&OYWT6dhlJBvhRx_wvzalqAapf)hv+$VR^UI0*VLRTse?GmvNI~AG` z(1~M#xS2Sk%z~RLo)hoHmH199ziYId9_K_Y4rERo1fbx=WC`NOv2!N}PK@6zQvPJ$ ziLK*=@5E6F#5r+&9LSt_1wg@x4aAAj-6Iy_Ba2>5oB*Uy6Zm9f)|~zsSK>Rd@*dH0 zvYP0Q1DO+t0Vp`Jp*Znb?A#3lCn|eJ%HPm;Vkl1dP8^#+Tus~*2Qnw#08nsZBXMHe zy&@KF6gY7TkU~vtl8aVNDAcdNk>O1jST#4^QWuIs{SxpSZ z0d;~y(XjyB9uGE2a?_wma^3Z>*!d!M&T!(n>b|)FjZsw0baJ`)1{I8%8D*W~(0pPE zCbdJmZv_;!Ti;SyW4}aE*$_dyhk?z(uUtF%-n(IfcHfa!=G*;Y2_|-PQZR1+vDp_e zS>iyoI!$IqheHxXhY}ZM`g~2C;MTjGxxE+_n*}SJmo0X{*oH&#%R}Y_!~OUwrhY5z zM96~DRp!d)n15@6F;&dEdpCg~PNGmIXe%5TFRO>hAT~+i=)F|}(xyvy4hB(lM?YEi z@95cC<I~&UF^It<&tetH3KzANbFkbD9Jv^=^aHlB+`R?qHfHHS} z0iswt8;LuM9TBr5n@7-{&A}9F$4w+yJHJk-3EX)+1^MobJu+dCTqrOVG=V6(Gez9F zCVF-@qo6x4CK#`F7CS0t#FQ`CA?Yx+Re0LW6Nx~qhokoc^(v(JgM7##p+2O5Y&RNyXRb4xS6!zK5> zzK=gYlUEZU&SKW?LMLR+y{HX)_Vb<^`%g1K+g>7|RAD2yx#0Tn%R{;9^jfPtoR@jo zT?IW(u0Aqxd|a?9gXA6_Tf)Q>bFpm0YdF379_l`jh1QBpOJGf148T5NR5Jx=uT{Hr zpUW@f8U(<~3gI}rpLkNVB*U@Zc^`HZR8a5kQ><+E7Z-Gx54EbjboTE+m~DB8z16lF zZi7jynR0T@1eLjZroTI<7+T2gd3Fjg!xNR<55}!=V-MGY`tbBwzh}A9DN#!VP+yp# zx=JbebUi2MhXS*gzMjkGhCUzdei~P#gma%oPB=Acm?aqm_J%=VHu)EdteD*(S@Ox{ z`b^BI@{gsYc{s_NsqX^}nuzRU+|UToMyKVi=dRBhP)6!UkZ*@y9%?q_crG;1j728& z|DLD@L#QGND6r6fPZ3^AP=!nfYyT`}Ql^k!C}hLm2Ao}`Bc}0kRJt%5{&jgRR+=@I zmw^N(ImG^ll(XE=b4?T9v+w6ifikY_0cns9tW?Wk`@bNKP?6NbBVd9m>gdOK*~Vpp zlG~R3MWGlg*MfL)-T^4cJhJBwyVnK9(`#)u*KqWBBo5dl^EJe~0^=dErsh_BFiVWv z`SgNuDzzoBLe5S@+%byC{b{7%Y%>0N8lkOpWsNfm^~GnrOeCz0Lm|#pm=S9rIY?Yp z!blQn1oS+h?eWXQ#l)l#w&Ne187au71#@?qh3!_x(JA(_^8f{Hl@(x=ndCv={|+qI zjQokx%4Zc#>KUwJBX;$j!$CKgoC-G!I=gs&HVfjD#QXCn+m6j#vgFyh(z8AdFWIG= zK?IW|-2G{0XOxG?=M>LZsmsS~L=U7X29x>l3m}1u-Mx4WDE+YIoV<+`X>{n|k0B4n zsXn}gg_}MNbnyQC$wsKB)40#m1k;){-(Tj8>+A5Va4y6_^L65^3g;D7xGH?Fcz#%g zE1sK6tM+T4^l&c-bESJ<1SN4{l3?`Nz#at=L?7P{s^YF0^VIU^<@Bp8bFBs-Jb4uF zoOa8}rx#8ZnV!u2cz6C}?k^!hU-bN3xs>RMto6+xuHl!5baiC^0Y2Pk|2+=Eplcdo z#X@xYc0hsMP}7E-MyD6NAXm7`w0Jg&sQ_H@cEYXCa+w>B^3M;%u4Ay6>wz7DUmn8_ zyZOn>*d<-LAu;*E!0t4eO>mVh_42~w{>)UrxP6j3r<*&%YAhgbY&?fOWK*> z7N6&h(AF+4r;!A=6Qr(p`BE2sUKX4Qst|qZsKEPy!ERl<`v|C`K=W|5jfHLI!{Qiu}l1~o=RPYNp!v6mfLAU#1Ud=pt1I5TpDOt2hb;g3Y{O-V<8tL z7QWhLrG?uj$Hw_XpyhgPm`@^V z$`ad5G&t?*1Q%;!^kF~}#S0T06h7(Nc*9a}wA=m(Oxlrfto$d~SZ6c(ys@%! zT^+49K0|dtH&z}Cu&iv2BnPZNft-WiS@`GA5UiCNN*yaJ*OzNG!Q}LBTc8Kwmxog; z%PKicJQY(UYbOWrDqX9-DYw`SkN>)ih?Mb8$3zM<$P@Bv)4+mDLHC?Ld-JQ55 zP3fzl>_9I9I-O48aDHLIsyEr3`@2YK4srR1?R_55LN#Tmb|BW$GXM*zAOrE5OID+s z-B^#+pRclx$fICx`0wZ;pq^k}jTv&!`V;K*a{Yv4C358d2ui^>3-;nJVQ3U?$L5 zqvJpzdGnKmE&{H>aUfgm_i^(C)cD9u3RtYU3Fd-B@{T&BIw3{>p`>UH3kSy^0*h6+ z6zxqHPAXNWjf@@kZg8Anu6_AaC3 zZ8J8yCqT`_FArz>5MElumK)e~iXCTzJ0jLQ#D3n5qoRHG#<<*Py|cr0GC zFW2|{Id7+tT6bB>ae%^7EY!tPc(e3oARYMSp%Lk-POo+~Fj`+1Pp7P+1n=&zb9cT% zm?h=plOVErLKRB_H8E(!$#;VYt#c_>G<*`*U@C&efB&Ab4L`y!k72y?*Vm6{o4R+| z&mpqKXCkissp+E8za#;^Ey-KKWA4rD^HlUeK_kSI5@McC<7Po#Fi!VAyB{Jq<+XOp zx*lWPdiSLOYuwo&Z19|MSo33yyFVf3>D-p}bI5J?8*Zz%*1Az`^lFRyJ-tRy!R`0n z_IB}VFUT(k$78tK-CXM$sNywNHkaid@J@9iJeQPhP1qhgLAXlE2)riEz53+2Xg7k`6u&%%+q;GaI?b8`HlU9nbi-n2wX2U$=X42n??YZ7ohW<3 zkscfm#(}yGFH-+Wz8)vk9rk<++*jEdO zsegK{I*jWo8vk|vWR+zvzHRtO&N~BW1=0MSK-kQtPkCDS5S`kug2=T)c{oH-MO!&d zdmVu5yEQzY!m=W~Gb#CftG@;(TNyTjsbNDaJU?aYI2w=(ex|^72F?m@NFgKK&`maY zpc}6OVHq+N?PkWp2)+-QOXzGa=3)x#J57Tc{724yLwF79m=t0g)Qu@1Yf!HP2`a%B zqjkVQbv~W#(|`trPRZoN<$iMQayi7Va|Yrpi?h040q2$EsnMOUn8~Wo1Wx;m-TaD8 zd_Q0=sp12NZobA|^c;lF9#3dyY&7M&&!!R1YgoP0z_|9~tKr0mRd`4epbDCKC5VWb z`Y!R3&v`8%({JZ)H1nVm#G3gEn24D=f1{a8KA!@pg6*^!gj*Kg|Q8L<9Aj;Txo0W@5hz~ zYeMpOP_AABC0RS8wuN6zb9yg@R4XVKw@{lI)fz$V1In$V3Ibk}$3qYC1kiWp_010Fw`p zrcg~D%nTob*#W;iY`vN!M`N~rMMomPUTvPs>h)ew`Fb^!Gn(4I2A4O;CMz|m5!5=b zj%~OZzdXdG&cW_3)7DsHuR$IJF_YWI#u^)VEoYR6IjgAeB!Gcc9%vd8jlZo#-(YRf ztf~K`Oj(O&WEQ&G>m`M@;H%yG0o8#r4Aan#9(nTc6JWEU)m4+{LRWJO7jd%Cx5_bF z=(IOVBB#xZ>GdbTuD~x3S5LNUvAeJHW~8EQr>SZ4;fP&61+&#)csV;IClyX{MsW5Vr-Y(}@W4t|d zCb&YEk*ve#Thrc&)PtXP7_!>{6)GXjJJj_FutLcEq{8I1+Pf)T8hdu9AA(6JGJ$7t zCzVhVbwanLAq_d9_W%__E{2ITw-OL z4>K!U=tBRDl$B4d)YlBK5Y8~SGU{_n^kqrx@-k&!5__hUb4hHW4@zvylGw(;3N>V0 z@RHaCNFOQqKZb$3dmrJPRM z_z7tD;+tQ-dM%HG+CTDIK#{R`c$r5J2O4$91hI#&0!nbM0a?QtJcgZ8JV5n=^LbR8 zW1J%l&Ke&l^jWtX7@WO9743sYOF5kk&PAX*@yjEy(F@MoU|d)9{V*OIbZMw){MXoq z5m82U-MYutf%s!)QTHgmkS%*}T~_#exBUI-!rw<_%cccC$u<+F@`1iC%$u2+cY?$( zK_r#_juyGRI5R4R5u8ch8y9wq@UysZw1K`>KJ|R<#5$zq@W;dOM`sECh+xa#uP*$( zOaA^s;qL?D>!P1|zCust>#mUaC4|178stTzd}Une>(Th5 zvjl&v)cWP`Hx&NfA%B0h@b?z+b*az28(Pq#TlBJC=Rz_QzcS;p5~)|tsvm>YFJI29 z^w2!coW^_+6Px)9ujeKK*cQJ$hH+L8cFwMvZ9z}Xoor-MHkIEF`Aqy;%d8xm#p?~v zRlW>Mw?Gd8mfizkNBr_&>GoBNM*RQlA#+JOleyBD{!ggfzKP*{uL6iEaOPc}(m?Zg zL+Kd+esHn|xY7TGg@+CBM^PzS1{>g6abbrD?~4mt8kWJC|AufTet9rj`b=f|SD`6* zsi9vUwj5U!bco>QqM$_tZx#i5b7GmVy?f>?x!2@7HiMlZ^qZg+N=-4po(;g|PVa0x zqVR_9qhNl7UmoI{#<~&zcf9?=M#Wn1tGbl}S$%gr|w$Op6Vc7al zcUzqciC4Bt@TLhiwZt~O4CuT#(Z;Ay+&dpoJQVQR>S$4jHCCX&qx#>tC`kfob_y7<&OGSy?-B}I5wFwp8hj3m3 zk_(u*vXj++lfPB4(_Z-TY5$PEa<^j%m3;{3bWmMk%*@-zyiR!u(ws9YwLP2;Ejxd~ zTJI}2vNmKlAYS`n&3K6aA)NEdN$*2A4;72$wO9j98n-~9Jh@IYOG}9K0?D~1h_^1| zcpz^2sEy8KN5yIHRu2UJBz|9Rrhg4`uU(G1I&c^t1*AIcXZvm8cX+%mZmWCCN<6Bq^%sP`v9tfJ!q1R*jf z)Bor4+EwO<=)24246umKLK~rF8j!3J$bJ<;nz;h<%)~%$mkcw_JR6i0V#a2snWdKV z4GJ+$Gn_DO1G4MJ)eAO#mqkm z%>d+@M*tar*gk%dgw&fxFb{%pb*SeK_Il4cS6RU;D3sf}WQ3;!a}|-p%sOi}spEhZ zO0&(L&zqi&6=$2ZagE$kD@Mw*oN4|HbqlycfsB_7(Pu&GqG+wA)Vjt{|20;WK&C#J z>i!GJrMjWMJ}=d^ujCctM79L>qr*Yik!83#(ubY+U2}TWJKK}l(;IR6w^z;z@DV$3 zZ2|cZI3B}%nu$zN?U7w97|JvJ(*tp~CW3KzIL(Pd$(r94pkR1v| zv+&Q8*+=GVA5Q^s%}84zPse9bYPyBU0^{a$`*&qJbT!Q3kljZ3PS?^H(~rFl zp?{JLOg}CmnuPdug6MWS9xox9jNs?puH4o)^9-X59mZ_NRyJ)oi{+bSURX*tv+ zHcyz4)T9+bO@rl-YC0wjWg)t;6hesDk6#C5uU>74Sfv~mHmMY=)T>W6{+og1gG0nM z{x<;}2#`mnUmO2+s~6+%1)q(7)iq-JZRAPxmk`?ck4_L-^G3D!NXCL+|e(cM)=Oi4W&GuR-iSGiJn14OBd1q8A-2F^VZ)Wv!xO z8yL!al5*95cvP-I;rZ7jZSbxT?7cWE+ z_`_7yTMmtiM@J+f=k&EnWYosxr6e+fo+t$^zJAK&Q6dc87D+@yM`o{5W>lK~gNegTTH>8N>ejAckOAz?WtF@(?=4&_szdSrU zwH2HP;XM${$_c$Ly8Yy+oi@wR(9_BgE$EIEl6BD!%MjHvZi9p^SwwnE5JY4=%sm2# z-P6E}i1u|}PkjNP1HXRXK*Y1YENgPN*f45LMxlpL+g@dyw0}|;mQygDmn)B!QQCf~ z?0;ogI~xzF^)@PVfc=Hh+8)$7_~ns{md>C)2awMsCR!$$aJF8Zk}S;S6LS02<@8IS zmy~fXs!x_tl2{ms`KOlHCb@;whGmqb7uL{DWt7$su`}yo>gByA%CGw^FzMrmyJZsyovQ3pl#>^4&w#i?`g#Uozhxx0;0+YKjB3A&T;uD z+R#yzP)@oA5zfz2< zVdq`7!@D_dVgNOKNVW#VyFr|520RyH1abu54epbEc`>k@r+AI8+K+cK^uheQMLiBM zFHSSpuiBZVlHrbiE*!zz{djUWI3!=_<-SAvgRwOeVK6-N6j=#;X5dVe98fn#4G$%6Z>uwbjV|(O2IeR;Z=h6}! zI2-G|`f4N9E-or#lpYPw_Qcx1$^0+PNFOJ&-n769Uk_$Oy7k!hB}|8G2F>1nS_##{ z6-rDPcL3TKzdYcTS!c(^##Ax6D=;RL+SPXKG&?4tS|>`OQ>P~py!+It-|f9S$XBqsR1&> zX+~UPM>rmgmr?tg?SAWzLg1wW5mYcI;Lyu#_3d8oId(^Xf0gg-4?@U_+X+JNWGAe& zyM=NW0P&)gAwAexyyyQ5I}8kKHhq(O3L>Bp`=u65)C%3k+tF3(=(U^R&mc{tlU(YV(mwI|4sQ>wl zssQ%-m*xaeKP{80UAfRi8k7@`QN3<>W2Le8^&bkh1T6frcU?a{d}b&Q_EP;j;UR0e z)jAHycVT0)&ZEXXqPQ8p*sIr(hsp2`-!iTp3xB8Mi~RB7`ZC6Gm@6}Xza5G&XtK_+ zWh(G=+6V4TEb6s36Z?h_TL)1m2h#1lj34iq)}!FTq1VJ(^55A##J%^*HHlRgHF59ah5_*jR({FQ4slvcraI~&XB)7m8?{}&$a z0hA;}9wrZ}H3Vl*cMSxQ2?R~9^mC7t-d@?Ow*h)P0^S-1y_rbvs}K%L8H(GqH-CJL zL{)0Pdn0c;lj&SCJbO>Z%M4}(l|w%OPGkkJ%?OTQ=bn(v2>Q}&pr`Nb#gk+LzqbdT zmf>%d_3}N<0+!(WPK-;i2lujiCAb|P!e~1WHsZ|74JXAB_x!mMym_zQvJ!k2-onUx z(gs}#wk_R@zkYcth>`ow-nU2B=dPi=c*%KnC_g4SoI=bx)!84HyD@H5yUhI|%#hWfS$cd5 zbHozX6>Op3g&%8_)u(4jv(uPzCG1~3A+d+-)F)?RlTLGbls>H6aIp@?0%rP0Kx{lR zGP$hVLtjh70T}@w1hkX1ETo?7I(T_PXggMf{NjQ%R8`x#fOh@k&KcRo!b^V8?5I(+ zSa|me@8f}|Y_U)o+KXE(oIkXuY_V{|(0;NB&(rX82GY%+UXoUXt$8;la|IcS7OeE* zD>tQO9OZz!-1N?hbNA*AYY5}*JA3oi-%>T>-=4jB8xU`t$GvTpGwRd0iw2O#j#mO* zjlXZok|hd2_*%+;Ov68V*tF}z=E29v(_OoBf+kzvxRDHD&^)|ga}eyfHwq?4KDoBqxYLP3e$sg_{AvDyUuuntPrJ-7l^UzeWO5a zIBpk(x%7>~;NYzvrUBpiF~W4=FQ*P(IZ3H=oE-Ndr^IrcStG0Y0pP4Rk-E%~#FNY7 ziQU@8@YI99{5cssE(omxCvi_DrKpF=6{b}E?f2o-*Q`ILPR*i^gFidzcOS$lK@^UB zaC1_Sdcev={IN^F1^!ks+W0v^?46kCL(Uv7CuqYK!QKgem*THiKCC@!;NOl#fi&wM zhg(a2m19Ht{u>99F3kHD+r%H=I2b!MFBAv=NgqjNFjG`U=E_Q;2VSc18dey3!GEHt z`v!bi%P5yjQ2=wY`fBnUqDL<4fi6ztj`(OQChAL@^RNbZ>xZ{?{N>O4R?h%b;r!S& zX))y51<7P(Cw%4WOQwqzwdsK$OGPO2Gr27PlwrIbUP}@s8!5BXf&NZf%_Z;P@(CZ0Bb0F*X_Aqq6<)&cI4@??f?rw#Z>PjxGS<_q z70;x;q?{86dKvSHL}aWNjm+_T@nVdtSz>3xTQ1H-K!tHYwh&C`q6nNyRfh9)t}aD_9*wkUoNj@>cC{p_*5d+sxDFc zi<5@-pbxEHHlzn*=grL74o|r}md`ko`oF?YKm78S<*=zVEb+=&iKr^KmE!!pdC^L7 z1H9y7Vx)K<`z^fLZ9$EULbEqG74d02JC@{o@i*93!DrY!dkXDhs!l!2mYf_z@w7|3 z=viKXk8B=Hja4>S&ORr|6D3Z|b~12gA#Vd_s@|JZfk{;W%k5cs@p4P$ix<@xvw|Ib zZWKGKE|qq=4AdL1+p3o8N4Rvj0$#Gtu&Y$*?XFh!==_s@U`z1!aizDc*S7Av+FQTa z+i2Vhh8tDA@RCI!=OtUiQ0cxIUhO#2iaiLtx85q(jO_6MZVVK6#(d@)7XX9N(w0sh zgE|Og6G$Ka@<+mr9ENxT?gQeg?z$M@M7a69kPP55V_g5ncwGu)H<%fEYLjDP2r%n7$4_1wJxhrGQ+Tp_*O|;APjyAor zVIy3v{txzAx_+$7672C1*?h0dcs+An5RNaG+nWoR6PrV9nxCu)p8&GiiZALb^Lo8a z%(R(22V#5hN>#5VV}TxfffK5?kX5SKk!IpQn?v>9%0fJDOZb}{ z>@Gleq3ZEtE_6bfm$EmjHzr-~Av}?SXJa)ppZDBZ3(PeijN;K3IcYVy!Ck5XV{w^> z5NQynk!`0o0q-Zu+?Vk4_ zTW%F*MzX~rP5YQjJh|nbu0jp_PE{B)slMs69+o`Oc@}zX^qXuZzl8_e1y!o{!2p)f zF_*e*XzQ+anU+9wd4#lE(5fCGb59ymdGuvYAZiIuu&O}@%i^*SBKIVE&%xPdH^Ow6 zuuZKU#?hAtq*N~!pmb!CE(ftqn6(l20HD8R8~traRBMLX!)!k8vq30jQth}%z9L1j zxq_W_2L3||cb3p?GeRw&3q;p2XyBua&{cUNpJaBul4trs25kR)PNaN}0lylu-WtqF zx=VNlmvSp@ezjdVb_OUtAxJT#uHT zJpHSogxRyid1LH6Tb%dA&W++c`@#J2#8-GqLj=ai06NNXT4qzBG28C(h5u z&hy3j*sn)IG?kx^oEv9Jm3c9AmS%@?I7iUc zDKuBmpHpa_patJd2%InI>nWtI>(vxOp|cmNek&ny_H1F_PO?T}|4gzbVLjhY$!r$( z-6WeMY@cgW;pPe(NV0jtZcMWI!bbf^N~Y$^NhyYE!fySRkQIBnJ5ftW_WjR5q7Xf7 zc}jvbNtinlq*=(=@8qS;5wapd<_g)7AoGMw{BB;_d?6o7kfWvI+>;=v9BdHpxGpaa zb%W?*DWq-XXDOs@rQ!O7Ky52$rI5Cj2U1Ae%H$go0=2EINg-`352ujk#?&o&fu`qJ z4`f$BoHUsA9j7agd8n)0+S-X{?PM*$CN}Lx7fvQ4hHKmlur9+?(A9JphG+^ysA5#RR(;r{z7w8|6l+4BN0 zfZaSs=9htMr7E(g+~UiSwUCS&YXWyZLM1bUhdk%D&T0YI6<2y?nJC@K;Xm-C!FtOo zc394-;I4i~Vyr>%}_I#>^g&IPio9^Pn)3WtlIBn1z7 z2v5?{G7b@~nMMB*ce;Q|`S?dcCy;9a`yrh_g*BPb@r%21i~%L_Gq*b3n#>N(18vNh zi#()`y%+IEPO*GmgS*wHsxHFRCTaimAEu~OG}ij-l33~tcSc73C>7e& z#RhmdDd|D$BljzA9hyVeA`6@S?{WFa_~Tj2R<3^~`lqI#UgpK(xg&wGjAzQm{5UVx zQ|~MTw$0ssRUSEK*gGOfi*#6i@B|6_g8hFIiq?H5#^=P85bG8}Vn zD3K@D%0)v|5lM5A^suU$MCwZi`yU=bB zlkq(d(F(H<$GVKdj@{*39&j=(rp|^%f1<~f^vfuomldT#mQ!kjPB{`_I zg6zf|D|VD&Rl~+R@*yV_QED&g1CT_6F%sJ`iOLoaNdQ|-SmGmo=|l=FV4l)lt}m1v z9*AkFzt~xTc{J%HH;4g=8p^`R@2uNdB# zkNZ60kJ=s1$JI|2H!OL_p`WNuTsCHXhJRh7kRPZV-j@p>!JL*w4HE@#{ zJ{2S8A18a*6Q9)~M&VBQS%Sa(89!PBWg~_I%*4l>k4lyGRO^FjSggn&g_jd30Y59G zzSty#xo|%`*!cuK1S8OUb|s*@PV%f2?!|UNxhTECFFcM{=P(26h7CRYi9>gXg54)w!1S&qtO_JQ8{v=hlB zvt_iQ`^L;pCqExecrd0&4fyO&QkZMB0o^%#$1{2Pxaznnx%v?gc3`Ffjc{GSj{{If z&x};EFFW{GPFzQk@!+k+*rOAAW_8E&+wc%KNP_JZNdny z$T5^2leG=NuA_Mcc*VXI!g@L3cOm2()wqTfuXZv4r-Rzw1L}`fZ(H;(4>45+F(wDR z=t5y8-Bq(D5vx4F{d-JGdOD;N*x?bJLDOMM$b{d!u1yx+T%QS9<&gp|{zUhHbq_Q5 zE{{-}tgMAh{DVubQ+qI%KI9R80;?THu}|9PJt-*5X133F{Lu~dSx|lNk=mY*1KUi* z1hdZ?X8bgAHyg`Lz`On{3?lpTQkWl$h&785z0$oNgl!>*7jb{*OHNz|&+nOu;78$Z zx5|w>v;{Z~!?ORe7YG~h^}6_w`RBneyKoL^P*&j&gWD8$(H_MNF6?1`m_ z;-FVt2yCHu8+(QidCpL5m0^oY-#_%6F(|~*KbgHEcb9hxmbjBei zw!=eI5W^HezB1u2PFOb|b0(1f!~^w3y|5axWV=VY%1Ge?3|A6n{QpG4gs?HJ@JLGu zvsPGNWWlz1P)bnh8M9{GU!A~KC?iqL=)Bx_F4S53*eS;mWW#?F@1b~*BGGS+TeOrL))wUjUi-+Xg ze*bV1+uBIwI5v~{!2m&X&kJ-|IJW}y;V*w}ZKB&?evbZM-`Obdq-~rU5U9!*m!NGa zXpsg?)P$1M@&ELt)d#w8&O*Mv3c&UhZFM<)!PxEyoXz0|Hp~hC=ld7)38{Syv@&4T zS^={M>8`eWz`KiteX;QIuREb0=ZSSm@roSp=Bz@pe4EF_RTm$qVfva|^@D-mYz z@|Zz)uOs1BkH`a=+z60pjD3@nC&YA0>`G3Hnd}ls-rwmV42IhMFb@0g!c!tsW`jVmgdScz6ukfb9Fm zy~WAvsI|ielXrP=Vl2~|6&}V?1lF#2luWuI4g%XfDt5eL8(P#Im>)C_hmT2!E*7O)otI)zjOx`WkEAHa9r-e~Qq%TN$d;RcaSu6HSZD*xj=ef6Z)o?2@YqdyvG(_EKACxq8yeFyBE|S9zLOOt_2 zsh9^knM$R_NeWhbtk8=YKUTE;ZGs;35E57FDP(y(`5@Qmkt+FESG#^~b;z=CTlzO;0eG8(HoQ#VLmtuzMvI=7IsDyDB*SF8NUJ@7b2r#VqMlW<(IX6^ z@&rvj#7ScygP2?AdWcm7XKymy_s)RLYo0f!P*5weNexb5M@@;YY0vQp@~B$rD9@kO zp+Fy)hzWClf@mz>^ByP7erYyBF~w(r+4|vF zla$B(Ubu2gS9@Fk{8`dzzvnO~5PHu75>_tGo;6=bxwAZ4=)%+pt-7n$G;5aH?)}2U zk|!dTaXEC76Ke=sqbip^6|*izhN14u6A8sy&@kCagw0i@uTZQZ7||zzY{ENgoeOXk zAdQn*5AVw%T>Ho{haT?2Xokp_I24`bp^jP&;$&R8KX7iPGrw@ylt2(PS0+~HDIY=~X*v1^1-Dor9@f@4etO92ql@r(ufsEhg02NvJz*?vhiy zsSK5pnK65Y6X!AHmIS@f!yPpd*^E+?q&)>@Cuf>b?Aru2&h!yeEr_GTg#qeZ(43Jc zJ<^I(WbG9ufWrEo9twDY2eFu1T<&VGV~US6by#XM^b_!4)t?;g(b2b2 zrzQ!UIopZm6(KlNR^cfy=I5q}VR9$#k4Ns942t`V#!wa~VwAHna>tTFn(OY!JMon~rXztAog>lLzr4YH-aMdl{_eAb>%p2)G zYhEY^n?~Y(LFA5uQWBvjBX>@`C1V=ryKK`HwHh=q(=N<0S-41-^<<7w5PCC}`C}r#~R&c$Ke0y_5q3ac_ z8`pb0iiK7Qn)xD>l>0eSSLHifsjP!wStNoKs)Nk)-CwSlwD zl)5nle66*;vtVp8c89Rug=^5|Jy(W2>bO9p*}A~H^!(n25SCj?xY3-Ic~=OE*ibU+ zjOp(Sa%;UyH2i{;DAfl%goM_CyUB0r}tqY;3 zYw7-I=q}Zn@toQc2&21Np>jsFHiWFHuzHd;#3M7M)zAtz9C*51t=^TD5aP zAV2tU1Y1gjuws?WKB6@g*iv^!j^{-TnPm)#e;E;etsQ&fEWRnFP@+v9W4R_`j3LWc ziszvOR7Eev9^U4}*4o7`8&@cF$$-2%V6e)jZK5v09}Ezbs18kT_a!naT-J-ga|6Vu zBr>!!Kv_1k1Dw?13&gUDIsysEw4W2uL3w^dAnVZs0fd^#G|t1yuBFu47sLFkOJgY# zLx?(7)z4AlPCz? zg^^TDMYP499TV7(b;Hb0iu`^++Yv}4sV_#cs=oNJ&IFaVdQMC_aORiSM6kB+j3EjM z!vrhQ)x_Ad#6`iG(6kdZ;XBomd~k#RX`$S-hmX z^AvYOK~E%tXI4jK)^{4)9vIf+tBmf2IoMI4Z6w!K&w#nImrDjF!nwKTJ7Y^yW)2sJ zuFyT`a_i~99f!54@M0xsTI7rADs(S2;GzJS4Kmh_rvkvc8L_~XdehkL%c266gr#_) zN2)Cgn)D_Koq|LN$KX+Y8MWDUCys%55J99}5P^CZ?pEoLFi&`h<{?d3dCQDtR*w@V zKomMuzsrnebBuKugFXQBdQNHf#2#RL&@J6vNfq%kdtLpO4`5yc6D+2FGf-B7-PHw6 z&<%H}nsQH!@LFtLH`Zq^cA;p_(uCVfB*!*+fELhAeVBPkHF`WI#zL2on9=9NNvPfm zb^}D<#u(w@dtJ@!j!8Qv6op>3uRW?il344&2Dn6IgNM4BT6NSnTVA_DCRwZtyy*i@ zAVOhRDGSIRa(xb)u!N7r5EZ;!z?KE!w820y&IOoT5!h_kg%Dr017HK_qd5xuEhCz( zbLx^nG|PxW*TUKMg-8n28w=2*(+-$T=+ThM>j63qn|4AFPKcGcK4g-3W{`&5m7s{K z6vt5~22z~h z6|*x=4g|G#!um)GdSeKrWvdRB-`Nf7RfEz1It#kb_+aclpz+GN4{G{C_wG`g%9(Xa zAP4R$=YpL3po}F?hVH$!esOMG7KrIJ_9hp_&Vy2WpAMa+j_Px0&8G%(gy?a*PbbKr zWcjZ`!V0ZrG554U7=fO;yd)0>rJ6qrU~7|_u0c~~G%NF#$IRQzxFip;afM->9p|re zP+mGBn!6$vDi5F#eI|$6@T7@E^H&~{YrVQ#3 za^Sd?jQbvSBGndGzB%*5pM8lKI@`96_11pu5)9#vTt#QA^HKA+I$B)F;f(aCPsSpJn%6@&r)=uVcc00wZ>y9jF~sHvE{S^t*tQZWe-;-Osj!}7=&9!>W-hTI<%1_lB>e6am1@J2>-@ru)rl{_ycW+CL6gS_ zZi0`j9U668R$U)YKzy6IGGk3XoVH_~1SPOG9tPf>pr-vuWk1i!=6Nsfdx-hIe0f7e zIqaAbu>rDoC9s<6>vDej`Jr&w(5v>Fz2f>jv<9z_MaZ13=O?GF4Mi$~J*v^Vtcy5i z#hAN@-59%)MeNwhA=ZI+H?i1ksBjyjuRRmjQH-zhwOUsE&;-$Hipt+>!KGh zvftg{K`totJ^^O&E{~M;`K%)BqGif4eUlT3I|`w~$5nq|QXf3liW^e!5+n@GCD>yg zG9snj@N?5PJCP8`6v%meMsi)Ap`&5i9?cWIqk$r)UJ!_c#tU{BIBLKwUkheCFnkVY zXZVbv^uAKRLJae9cOBWZ3xl971)l#^rP%rqWluOs>UV_@;d*f>N7tQ4T@=VfEPHsG zN7A@4WC+KO7TdXO_mAfwZx=<|mQT*SI22n&f6~#ey5-F=V=pQ<0J9N25mH#!KzT(= zQr`7R53@fVh(@en<%J6{Sa34JTo`$fgEKsYjeeS0{8Y%fE0(pjrq2YzF*}9Eq^$sh zwFZQ|IHdd{2M-C&O7Tp{SwMQfKMQ`&C6VY#k9MOv`Tb0Y5mw&HV1$1iq6+WHL7ybm zY2KxQR7453N?o;1tW;S_mxdU%4L1ClMdouMrC2k(1LjL25t-P zlCnMivjL+fPj2SmSFa2i;si@YE)xk~4k5d4>_~R%r48+$3#4M1VMb4u&NU&FNeQ!% z+5fkYF*+tBzghi!AQpq0Hz;2lLL8#1;xsCb!OL9X^^nR(-Eme5@B2a^T;D-tyx6a8 z2_fb8&A^lBMVdgdFq5P_$e`?5Q}Hhn%ek`&Ck` zJ3=HUlGz_Hp$C2`5Q|{2Ime5o^35|NDA&K5<9m$Ly(w<01sm-lR|dji&>^cE)Ez0` zvqEfcjAqQ3RXan&2u zWO4}4W)^4VIll=tJZ_<3Vt0lf>a|i4swT}h@i65Z!54I&Oe>R`MXU`y*i#D9keK1S zLT=5!O^-z%Grt*p!ul|M7JXcp_F>MdG{DC*L-@e04N`IDeJl8eEa%K}Q<8ak$n{8) z^}r~+5PC56)!M+b%^d&j;1lXYj!H74uM8;+oN@N0)vV&!FTWgmP=Y%SOgGqmZ6MuM z`v!!)CWN^4&s`Ho*?$W;>`yYw6;|l#e+05+h+_^(wY@fkx_4%_7+;T>?!_=S`u;PJ z$;~s}rII<`mY9Y+V57bh1s1a@7_CcLE{!RxymxNt)|g|8LN8L#W4;@SrX{o=wdJ9Q z)=r#p_iP?_gt*j&nKXMR8Mm(sWDBcv0naixGXYCD?t-Nr^XuLOhK{+chUte~A4u*) z;Yf-Y@~n_y(yE=BHqV_QHT|8Q_Gg@@+z?2{&Y&^2VVu{7P^&a%Y-U-qE5s_BGs2QF zeA^Ppu2k)Phg{oU7((6}4ud^e_C6CLv+baZgBt^p2FYZNt?cp;b9~Sqjnf-x#-Rr_ z(8?M^14JBuQ}6|DOSBZ~CFydRCs(F9%1S=)avFQ{^7fm94>Yx+26C%XhL3AvD1-&| zx0rDMi4#%Qf$H}nnJ@rlNL|=o8&hefb`tw~NNs{k{YVk>wD0?YY^?;ChR983^spuL zUU+m&{X$Wm-nfgnS-x_-0xJeTjC`l#hV}1|_Z)(MKS-T-l@s@{_ zf#qZ%CmB0JhP`>cTk*hK1Bsk&%KB1Tahln@yf?(zo&%R%%&J3f%ZcWMQs=9be^%(h zJXS8_IUCK+5Yyb2oextw<#wl`>8iIge^BYQR;|f196M&Hhw?-wTU=5den(CsOw>tM z=Si!^;=w#&4=LZ8d}mHxmgnc@nb;CD({_5y7*^`|%=L8xJWSf^1RD=nVxyK|+nCWk z$K%YC5*E8^AoM^;aMvdZ3*xYCPNvy}lXW{*VQg?`16!RJR_ZmiHRfHetnd#+lzp{K zh?wP*w!5Ibk*S3h5^4m-^jweCTHAEqEt&VAM>xl_{Utwl_zou#6He%Fx(9G$t>*d~ zK&xTLr|{|vYn&;4kHM%zh9hp8Fq((o<-(b2DE3ZdtMd%wuj;BE1hY9)#|r^a+#vZl zRt-~ZX6)g2Cpq+mQkHAdm=?v7@xSyr??%alGbfJtp(or@ie{OepMoNon(RkBiaxGI ztP)u!Q-9=ShEt<;9%+YJGd2)q1;dy;<}p@AZWBl|X8ujT#}kP=d1|CMF3DbLgU2vY z6M@XP-JZLbudqgyDmUZDPNdv8!h9iQ$~Sq?l%?)TNS5#Ms3(~d0SP_pCkfF)na~S7 zY7TU>w^SA2lO8m;?J!Qv*2a6CR9?xaS4KC0T;vh-^jxkiMjs-3w+#7oj?-F(A)9~d zWSZ8>evtVub??(2w}sMOl|4`j{*{NJ-IZ&Ib%%fM&pg4^&c(k<4-C|J+H0g8!jlQ}WvD2$=ePvGwsQFxjbSh%Ga}FWOph`PJCu>U--VNtIeuV{ zaF=-=48t8*k}uEuNaYeWAk;Arq{Z5xpY=FK03%qW{?7)uWn}lqR zp9ky1U;b2it#|)o>dSfNiyoGO=Rx1h2XpED54x;1a~d%lA^T#)I6|=#~)+))M1PG^ksoCO zj(gbUDie-eK`4Dd;|qC)V9H+1GlbLnef%RinFyy>ID9c;ZnKfG`9nk(m+J_rR+@!J zL#aGEjZf;r>PkS{N~Qdu*|nE1vS0jTf=e@K04zL~56lsi*+>4R1n1~W&f52fhkVjUmFMI(!aAHUm|oN>;OWP*D|nsXHE z6b~;ZJa9si^$_oSJpTnAWRQW7P3sE@59~X6FjLp~zf1U#o7vEtN+gcklmCWzz}i+k ze10eo)ZH=@Uw{YO|LJ{5Z3SEcp_;zqo`|8wjZN+gc~-+ob2I6BF-PSVBhC6JW2rjn zqzy0Y#20g%BPUEA75^cRG3nqaDJd>I6-(z8>BJpH5r1XQ12^7e9OT#kD~B`}( zJTLt!AEwx$G8wHeC%H+N#5>`EyP()t)R%u-f1Uq=@h~7MziKECg?^Rr55RA)YSp%$}FF}{kM6^ z;8?w>dhF^1&unu4+lN(zQB{?6K5Z{}g2~j_OsA?}@nEgJjLyl<%U%fyH7)XbE2mwh z-#L*8MeTGiZb%~fatbvHdO3xfWP0EFVjvJF#MpJR9bOd@ICE4Zc_}0~sa3%umgP|V zeISjef^-{?@LvIK13=v6$Pkoc+84hRLRz25{ox$@TmKLQq?J56Vx4AvImuM!D{HRM0ja8Nq5`riVv z*t!*=ERz2W5zehH#H3n_`Sm2ztnGa@5NW~<%E0yAJd?~(OQ$#eJr`1_YGwL{pjv3x zhZNnp5zK5K{#qc|Ld~CnG#r%T-V#D4h8ctl2?US)M)2Dr502$uTpX;Y8}j97H@| z@u%9Vk;6u28KGiZU{M0Y4e4D6^Au}NK2fHVv@JPq*R1^Vh&SbAn-wc3!UH*qJrNt6 z9&Si^uxnm=7{1TQY?#-$Lv!Fu7)W`r61Ya#lJh`g2rGgXeFdj6zb11BhaT2_Yed`b(Fl~~xYI)92KX!01 zMU`zu9@^aoAGU*nu`*}uOxL)#IcIbkc)OpW7@oVTb1|x@~(dlbJVRoD-#r?-CwulFb>e7FWhtZO+a4om{b=_i z`7nNbB({itRc}gO;UQ#EmZ{s|ZtEl+v3Tp%s}IIc2uT<2bHdz^1M5m4+tM^s-N3p% z$4nz;X^cO>1*8f<&#N$9D?FkijkO2!V_ObpM=r-rbP_dOcJgnzhxGJg7HVq_Wd}9K z9vBPM^L>oRX<#<9^kdQn8-TXvkYovJy;`DV8(31 zzr^B23BsIR1>_YL6jrc@qxysevLl2rdP4^x^>@O-VX#8K7i?t+jkPwb#`cgP@8qsv z`Ple(1R{+IGNZ8~B0dDhB(*zr6xlSHchu_|w z^H6PTqefo7Jz<`Bs5r=Fm z<1vB;pcOg92~nX4izeaQbKF%Z8M}`hnce0ILm@2uGuu|_$3qP5M~2xyZUwfzF+y|v zkP8_Y>9JFDjA!mxlTOPcY|E1};GKC2V|~e`{io$*ViMfcD6`H}hkz|=gK$S4qw+44 zTpBYyCs$t0Vw9K-%kmt9m7J+2zCDT21*)yh=%ZZmnOs8X?$RRZ;g^BBJT$!s2aDT1 z(ASN#2J%Q9$>}%M8^rn;|C#OzbrN4?XyE!Fwdd>mcl*| zBA7Y0RCOVDi%0s}&E@7;jKEO60Ri9E=wt%x;eBI#e<=7;k7FsJFMyy`(U4T?;`cod zD9$Qg^x=kjU54|wHaY3o2*CaPdTZ)Qu{$1rpw{Pmv3m;u8^c?gogkh@(utZR{lo~l z>nd*cNI%}~Zo+wI?u4_W88ycV^wyke!Ek~HF@-Oe_{ODbRwOnz#k^1-sAwgB^IRua zf@UVvOy3fZGAkt*i~Pn2@cb&HIdYy87d%qQOc{)zdD4d;+TtO0N3@HV5*aby2_(Q> z=aQrW&m9Jj#R?vP!z`C^xFLt2<8GWYSNgEwM>}~M4p(^c!ZztJ`aQ}CiM*VJ!c@+C*sh<%Q8 zvQXP`BD77s_r>mdPuX>zGp^0#Tcnt;P|%y+=LA`IreiVOZ4T+-CDCcH_FM;Kr+%En z3Sdt-{CEdAQ)q1&5XN*2g4qkPF*;&Um*#l`oU`nL;Y15I85c^#hQB`~-H0$F)*rbK zzeoepPgUV*clpknT0&`k9qjK} zHx@@kk|R%#F@L@rQ6xziE61>+%WrD_G+Ba0aD*jkLfHndizt(q!F^go$xNca288U7 zph;%--5VkOw3{;y-5e@>|!qs~xRSCDnb4TTEZ^eK5fX|4wk=cQ6 zuI@m&Vv%hs4SNE7SefpDIOgt6DS~w%*_+!Fp;~mtz9h}e3i3vevOPn!hnqaK_w8^( z9Wv+629pq3 zDz0K8EW0(cT5SM5A*7|sV%#Tdrb*=A4>>~zM`!n~2GTJi$=NCVAM+7@ei=O2l7e}M zm=}t1x0K559_9ACyE1-s&4q(jCbI`*#W=-ddPA|83NnXp^H3>b`z><0Sl}r!4CnU6 z!c#oPPR!Hi-R>b;MWUPF+@6(cOt+J$y$1>7ajHkShUS#SvO7Iy(?!;RaAWJ9M6C2M z+At^$@1*4}_c*Tz$Yx<|oZE(gSY|R#<9nQJ_IGxthiqlU>?RMhdk2^;LdMr99XK{l z=nWCBKIhQ9GIB-%iu?A+9VMhOTkK-iuJch^PfPc((qpV%)LKZ*+TnpcbR=HE`?+POQBVUu&^^^)wGtkAd0^b%iAE zP7iU+5bZa!WB(JKNCMG)6Py|W8QYocJ0f6SN@Z^}=A=-Vdn=WVU|B@{26B7EYy)Bc zJ9=p-RaRr%@Ml4v5<%U3U_5UFvBkrbnXL!rJ4cx%Ybc*G_PaH eo-5nl?Ossqp~;{mebvb>3=&qvS>;-J*#86Mh{-+x literal 0 HcmV?d00001 diff --git a/src/winttypes.mod b/src/winttypes.mod new file mode 100644 index 0000000000000000000000000000000000000000..450edd44c2ccf11a47b8a448c284df47a414799a GIT binary patch literal 3912 zcmchZzi$**5XWcv>0kmOAz(T#JWt0%`RQs+M~l4 zN8EzDtUWq>{X&$3YiN%SUmQ6BZccl2_~I2M%)qNPAf&yi{zY= zJ|V;!m~OpxzFWp9aF{(#31AoC2=j4D09yt(ZV7Nc7{3JIO4iGl0A~a9xsvK)hDmGq z9o(AsSsCyNh4T(q&-P~}mYXJCk2><1a>Ka09z}hjNQ7})uO0b9NuNUoj#1WY=X=O3 z1#a9!#x8LAL-ujP1&6Cw_0O8%?YfPZR{KeRV@23P7`rT}8l9%Wv<=#;y^efoWYX%z zixL{W(eFg-a?$9e#nqnFoHXQDO8WTFoVO1jR#pFge8`60^`VcQ>>gYeNWN!{r@#@< zC z|1IH;Eas~Ri;c`4pPb-uPno9W-K{d2p|PKqu}3nkE0EAduCj+M0`nyT_TEL{=Mn*X z1|x94M8ICh2>eqbV2@@h@RUaWpZcc}E`wyGcWG5eca)Pi-#9gQPZNsI3;9C}!byEY z?#7Nx?_wd(6*x@(y^x)o~`(jPjXw_4|G zb{SC#9~Cj({Y1FFE@Io2#r=3m>pJO5V?~O)RqZFr$S(<_wp077D*j)g#2a_b>63J~ shSXgc{!^iV-5cn?SIBmE3H%p@e0RT~{