Version 83d plus merge demo

master
IanKing 8 years ago
parent 0c8e29e340
commit 3ff4dbed38

Binary file not shown.

@ -0,0 +1,31 @@
<!DOCTYPE HTML>
<html>
<head>
<meta name="DC.date" content="2017-02-07 04:09:51 PM" />
<meta name="DC.language" content="ENU" />
<meta name="google" value="notranslate" />
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1">
<title>Created by Camtasia Studio 8</title>
<style>
html, body {
margin: 0px;
padding: 0px;
font-family:Verdana, Geneva, sans-serif;
background-color: #1a1a1a;
text-align: center;
width: 100%;
height: 100%;
}
</style>
<link href="MERGEDEMO_embed.css" rel="stylesheet" type="text/css">
</head>
<body>
<iframe class="tscplayer_inline" id="embeddedSmartPlayerInstance" src="MERGEDEMO_player.html?embedIFrameId=embeddedSmartPlayerInstance" scrolling="no" frameborder="0" webkitAllowFullScreen mozallowfullscreen allowFullScreen></iframe>
</body>
</html>

Binary file not shown.

After

Width:  |  Height:  |  Size: 792 KiB

@ -0,0 +1,36 @@
<x:xmpmeta xmlns:x="adobe:ns:meta/">
<rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:xmp="http://ns.adobe.com/xap/1.0/" xmlns:xmpDM="http://ns.adobe.com/xmp/1.0/DynamicMedia/" xmlns:xmpG="http://ns.adobe.com/xap/1.0/g/" xmlns:tsc="http://www.techsmith.com/xmp/tsc/" xmlns:xmpMM="http://ns.adobe.com/xap/1.0/mm/" xmlns:tscDM="http://www.techsmith.com/xmp/tscDM/" xmlns:tscIQ="http://www.techsmith.com/xmp/tscIQ/" xmlns:tscHS="http://www.techsmith.com/xmp/tscHS/" xmlns:stDim="http://ns.adobe.com/xap/1.0/sType/Dimensions#" xmlns:stFnt="http://ns.adobe.com/xap/1.0/sType/Font#" xmlns:exif="http://ns.adobe.com/exif/1.0" xmlns:dc="http://purl.org/dc/elements/1.1/">
<rdf:Description tsc:version="2.0.1" dc:date="2017-02-07 04:12:15 PM" dc:source="Camtasia Studio,8.5.1,enu" dc:title="MERGEDEMO" tscDM:firstFrame="MERGEDEMO_First_Frame.png" tscDM:originId="8B31DDA3-03CB-436E-AA29-8B6426F9E569" tscDM:project="capture-3">
<xmpDM:duration xmpDM:scale="1/1000" xmpDM:value="68033"/>
<xmpDM:videoFrameSize stDim:unit="pixel" stDim:h="1080" stDim:w="1920"/>
<tsc:langName>
<rdf:Bag>
<rdf:li xml:lang="en-US">English</rdf:li></rdf:Bag>
</tsc:langName>
<xmpDM:Tracks>
<rdf:Bag>
</rdf:Bag>
</xmpDM:Tracks>
<tscDM:controller>
<rdf:Description xmpDM:name="tscplayer">
<tscDM:parameters>
<rdf:Bag>
<rdf:li xmpDM:name="autohide" xmpDM:value="true"/><rdf:li xmpDM:name="autoplay" xmpDM:value="false"/><rdf:li xmpDM:name="loop" xmpDM:value="false"/><rdf:li xmpDM:name="searchable" xmpDM:value="false"/><rdf:li xmpDM:name="captionsenabled" xmpDM:value="false"/><rdf:li xmpDM:name="sidebarenabled" xmpDM:value="false"/><rdf:li xmpDM:name="unicodeenabled" xmpDM:value="false"/><rdf:li xmpDM:name="backgroundcolor" xmpDM:value="000000"/><rdf:li xmpDM:name="sidebarlocation" xmpDM:value="left"/><rdf:li xmpDM:name="endaction" xmpDM:value="stop"/><rdf:li xmpDM:name="endactionparam" xmpDM:value="true"/><rdf:li xmpDM:name="locale" xmpDM:value="en-US"/></rdf:Bag>
</tscDM:parameters>
<tscDM:controllerText>
<rdf:Bag>
</rdf:Bag>
</tscDM:controllerText>
</rdf:Description>
</tscDM:controller>
<tscDM:contentList>
<rdf:Description>
<tscDM:files>
<rdf:Seq>
<rdf:li xmpDM:name="0" xmpDM:value="MERGEDEMO.MP4"/><rdf:li xmpDM:name="1" xmpDM:value="MERGEDEMO_First_Frame.png"/></rdf:Seq>
</tscDM:files>
</rdf:Description>
</tscDM:contentList>
</rdf:Description>
</rdf:RDF>
</x:xmpmeta>

@ -0,0 +1,28 @@
@charset "utf-8";
#tsc_player {
z-index: 9999;
}
.tscplayer_inline {
position:static;
margin: 30px;
width: 852px;
height: 480px;
z-index:auto;
}
.tscplayer_fullframe {
position:absolute;
top: 0px;
left: 0px;
margin: 0px;
padding: 0px;
z-index: 9999;
}
@media screen and (max-width: 852px) {
.tscplayer_inline {
width: 100%;
}
}

@ -0,0 +1,75 @@
<!DOCTYPE html>
<!-- saved from url=(0014)about:internet -->
<html>
<head>
<meta name="google" value="notranslate" />
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<meta name="viewport" content="width=device-width, initial-scale=1" />
<meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1">
<title></title>
<link href='https://fonts.googleapis.com/css?family=Quicksand|Actor' rel='stylesheet' type='text/css'>
<link href="skins/overlay/techsmith-smart-player.min.css" rel="stylesheet" type="text/css" />
<style>
html, body {
background-color: #1a1a1a;
}
</style>
</head>
<body>
<div id="tscVideoContent">
<img width="32px" height="32px" style="position: absolute; top: 50%; left: 50%; margin: -16px 0 0 -16px"
src="data:image/gif;base64,R0lGODlhIAAgAPMAAAAAAP///zg4OHp6ekhISGRkZMjIyKioqCYmJhoaGkJCQuDg4Pr6+gAAAAAAAAAAACH/C05FVFNDQVBFMi4wAwEAAAAh/hpDcmVhdGVkIHdpdGggYWpheGxvYWQuaW5mbwAh+QQJCgAAACwAAAAAIAAgAAAE5xDISWlhperN52JLhSSdRgwVo1ICQZRUsiwHpTJT4iowNS8vyW2icCF6k8HMMBkCEDskxTBDAZwuAkkqIfxIQyhBQBFvAQSDITM5VDW6XNE4KagNh6Bgwe60smQUB3d4Rz1ZBApnFASDd0hihh12BkE9kjAJVlycXIg7CQIFA6SlnJ87paqbSKiKoqusnbMdmDC2tXQlkUhziYtyWTxIfy6BE8WJt5YJvpJivxNaGmLHT0VnOgSYf0dZXS7APdpB309RnHOG5gDqXGLDaC457D1zZ/V/nmOM82XiHRLYKhKP1oZmADdEAAAh+QQJCgAAACwAAAAAIAAgAAAE6hDISWlZpOrNp1lGNRSdRpDUolIGw5RUYhhHukqFu8DsrEyqnWThGvAmhVlteBvojpTDDBUEIFwMFBRAmBkSgOrBFZogCASwBDEY/CZSg7GSE0gSCjQBMVG023xWBhklAnoEdhQEfyNqMIcKjhRsjEdnezB+A4k8gTwJhFuiW4dokXiloUepBAp5qaKpp6+Ho7aWW54wl7obvEe0kRuoplCGepwSx2jJvqHEmGt6whJpGpfJCHmOoNHKaHx61WiSR92E4lbFoq+B6QDtuetcaBPnW6+O7wDHpIiK9SaVK5GgV543tzjgGcghAgAh+QQJCgAAACwAAAAAIAAgAAAE7hDISSkxpOrN5zFHNWRdhSiVoVLHspRUMoyUakyEe8PTPCATW9A14E0UvuAKMNAZKYUZCiBMuBakSQKG8G2FzUWox2AUtAQFcBKlVQoLgQReZhQlCIJesQXI5B0CBnUMOxMCenoCfTCEWBsJColTMANldx15BGs8B5wlCZ9Po6OJkwmRpnqkqnuSrayqfKmqpLajoiW5HJq7FL1Gr2mMMcKUMIiJgIemy7xZtJsTmsM4xHiKv5KMCXqfyUCJEonXPN2rAOIAmsfB3uPoAK++G+w48edZPK+M6hLJpQg484enXIdQFSS1u6UhksENEQAAIfkECQoAAAAsAAAAACAAIAAABOcQyEmpGKLqzWcZRVUQnZYg1aBSh2GUVEIQ2aQOE+G+cD4ntpWkZQj1JIiZIogDFFyHI0UxQwFugMSOFIPJftfVAEoZLBbcLEFhlQiqGp1Vd140AUklUN3eCA51C1EWMzMCezCBBmkxVIVHBWd3HHl9JQOIJSdSnJ0TDKChCwUJjoWMPaGqDKannasMo6WnM562R5YluZRwur0wpgqZE7NKUm+FNRPIhjBJxKZteWuIBMN4zRMIVIhffcgojwCF117i4nlLnY5ztRLsnOk+aV+oJY7V7m76PdkS4trKcdg0Zc0tTcKkRAAAIfkECQoAAAAsAAAAACAAIAAABO4QyEkpKqjqzScpRaVkXZWQEximw1BSCUEIlDohrft6cpKCk5xid5MNJTaAIkekKGQkWyKHkvhKsR7ARmitkAYDYRIbUQRQjWBwJRzChi9CRlBcY1UN4g0/VNB0AlcvcAYHRyZPdEQFYV8ccwR5HWxEJ02YmRMLnJ1xCYp0Y5idpQuhopmmC2KgojKasUQDk5BNAwwMOh2RtRq5uQuPZKGIJQIGwAwGf6I0JXMpC8C7kXWDBINFMxS4DKMAWVWAGYsAdNqW5uaRxkSKJOZKaU3tPOBZ4DuK2LATgJhkPJMgTwKCdFjyPHEnKxFCDhEAACH5BAkKAAAALAAAAAAgACAAAATzEMhJaVKp6s2nIkolIJ2WkBShpkVRWqqQrhLSEu9MZJKK9y1ZrqYK9WiClmvoUaF8gIQSNeF1Er4MNFn4SRSDARWroAIETg1iVwuHjYB1kYc1mwruwXKC9gmsJXliGxc+XiUCby9ydh1sOSdMkpMTBpaXBzsfhoc5l58Gm5yToAaZhaOUqjkDgCWNHAULCwOLaTmzswadEqggQwgHuQsHIoZCHQMMQgQGubVEcxOPFAcMDAYUA85eWARmfSRQCdcMe0zeP1AAygwLlJtPNAAL19DARdPzBOWSm1brJBi45soRAWQAAkrQIykShQ9wVhHCwCQCACH5BAkKAAAALAAAAAAgACAAAATrEMhJaVKp6s2nIkqFZF2VIBWhUsJaTokqUCoBq+E71SRQeyqUToLA7VxF0JDyIQh/MVVPMt1ECZlfcjZJ9mIKoaTl1MRIl5o4CUKXOwmyrCInCKqcWtvadL2SYhyASyNDJ0uIiRMDjI0Fd30/iI2UA5GSS5UDj2l6NoqgOgN4gksEBgYFf0FDqKgHnyZ9OX8HrgYHdHpcHQULXAS2qKpENRg7eAMLC7kTBaixUYFkKAzWAAnLC7FLVxLWDBLKCwaKTULgEwbLA4hJtOkSBNqITT3xEgfLpBtzE/jiuL04RGEBgwWhShRgQExHBAAh+QQJCgAAACwAAAAAIAAgAAAE7xDISWlSqerNpyJKhWRdlSAVoVLCWk6JKlAqAavhO9UkUHsqlE6CwO1cRdCQ8iEIfzFVTzLdRAmZX3I2SfZiCqGk5dTESJeaOAlClzsJsqwiJwiqnFrb2nS9kmIcgEsjQydLiIlHehhpejaIjzh9eomSjZR+ipslWIRLAgMDOR2DOqKogTB9pCUJBagDBXR6XB0EBkIIsaRsGGMMAxoDBgYHTKJiUYEGDAzHC9EACcUGkIgFzgwZ0QsSBcXHiQvOwgDdEwfFs0sDzt4S6BK4xYjkDOzn0unFeBzOBijIm1Dgmg5YFQwsCMjp1oJ8LyIAACH5BAkKAAAALAAAAAAgACAAAATwEMhJaVKp6s2nIkqFZF2VIBWhUsJaTokqUCoBq+E71SRQeyqUToLA7VxF0JDyIQh/MVVPMt1ECZlfcjZJ9mIKoaTl1MRIl5o4CUKXOwmyrCInCKqcWtvadL2SYhyASyNDJ0uIiUd6GGl6NoiPOH16iZKNlH6KmyWFOggHhEEvAwwMA0N9GBsEC6amhnVcEwavDAazGwIDaH1ipaYLBUTCGgQDA8NdHz0FpqgTBwsLqAbWAAnIA4FWKdMLGdYGEgraigbT0OITBcg5QwPT4xLrROZL6AuQAPUS7bxLpoWidY0JtxLHKhwwMJBTHgPKdEQAACH5BAkKAAAALAAAAAAgACAAAATrEMhJaVKp6s2nIkqFZF2VIBWhUsJaTokqUCoBq+E71SRQeyqUToLA7VxF0JDyIQh/MVVPMt1ECZlfcjZJ9mIKoaTl1MRIl5o4CUKXOwmyrCInCKqcWtvadL2SYhyASyNDJ0uIiUd6GAULDJCRiXo1CpGXDJOUjY+Yip9DhToJA4RBLwMLCwVDfRgbBAaqqoZ1XBMHswsHtxtFaH1iqaoGNgAIxRpbFAgfPQSqpbgGBqUD1wBXeCYp1AYZ19JJOYgH1KwA4UBvQwXUBxPqVD9L3sbp2BNk2xvvFPJd+MFCN6HAAIKgNggY0KtEBAAh+QQJCgAAACwAAAAAIAAgAAAE6BDISWlSqerNpyJKhWRdlSAVoVLCWk6JKlAqAavhO9UkUHsqlE6CwO1cRdCQ8iEIfzFVTzLdRAmZX3I2SfYIDMaAFdTESJeaEDAIMxYFqrOUaNW4E4ObYcCXaiBVEgULe0NJaxxtYksjh2NLkZISgDgJhHthkpU4mW6blRiYmZOlh4JWkDqILwUGBnE6TYEbCgevr0N1gH4At7gHiRpFaLNrrq8HNgAJA70AWxQIH1+vsYMDAzZQPC9VCNkDWUhGkuE5PxJNwiUK4UfLzOlD4WvzAHaoG9nxPi5d+jYUqfAhhykOFwJWiAAAIfkECQoAAAAsAAAAACAAIAAABPAQyElpUqnqzaciSoVkXVUMFaFSwlpOCcMYlErAavhOMnNLNo8KsZsMZItJEIDIFSkLGQoQTNhIsFehRww2CQLKF0tYGKYSg+ygsZIuNqJksKgbfgIGepNo2cIUB3V1B3IvNiBYNQaDSTtfhhx0CwVPI0UJe0+bm4g5VgcGoqOcnjmjqDSdnhgEoamcsZuXO1aWQy8KAwOAuTYYGwi7w5h+Kr0SJ8MFihpNbx+4Erq7BYBuzsdiH1jCAzoSfl0rVirNbRXlBBlLX+BP0XJLAPGzTkAuAOqb0WT5AH7OcdCm5B8TgRwSRKIHQtaLCwg1RAAAOwAAAAAAAAAAAA==">
</div>
<script src="scripts/config_xml.js"></script>
<script type="text/javascript">
(function (window) {
function setup(TSC) {
TSC.playerConfiguration.setFlashPlayerSwf("MERGEDEMO_controller.swf");
TSC.playerConfiguration.addMediaSrc("MERGEDEMO.MP4");
TSC.playerConfiguration.setXMPSrc("MERGEDEMO_config.xml");
TSC.playerConfiguration.setAutoHideControls(true);
TSC.playerConfiguration.setBackgroundColor("#000000");
TSC.playerConfiguration.setCaptionsEnabled(false);
TSC.playerConfiguration.setSidebarEnabled(false);
TSC.playerConfiguration.setAutoPlayMedia(false);
TSC.playerConfiguration.setPosterImageSrc("MERGEDEMO_First_Frame.png");
TSC.playerConfiguration.setIsSearchable(false);
TSC.playerConfiguration.setEndActionType("stop");
TSC.playerConfiguration.setEndActionParam("true");
TSC.playerConfiguration.setAllowRewind(-1);
TSC.localizationStrings.setLanguage(TSC.languageCodes.ENGLISH);
// Uncomment to turn full frame mode on
//TSC.playerConfiguration.setDisableFullframeMode(false);
// Uncomment to set custom skin for Flash
//TSC.playerConfiguration.setConfigurationSrc("skins/configuration_present.xml");
// Use Fathom service
//TSC.playerConfiguration.setFathomId("666850b8c609432d8c465dbaab3702a7");
// Uncomment to see hotspot shapes
//TSC.playerConfiguration.setDebugHotspot(true);
// Uncomment to force flash player
//TSC.playerConfiguration.setForceFlashPlayer(true);
TSC.mediaPlayer.init("#tscVideoContent");
}
function loadScript(e,t){if(!e||!(typeof e==="string")){return}var n=document.createElement("script");if(typeof document.attachEvent==="object"){n.onreadystatechange=function(){if(n.readyState==="complete"||n.readyState==="loaded"){if(t){t()}}}}else{n.onload=function(){if(t){t()}}}n.src=e;document.getElementsByTagName("head")[0].appendChild(n)}
loadScript('scripts/techsmith-smart-player.min.js', function() {
setup(window["TSC"]);
});
}(window));
</script>
</body>
</html>

@ -0,0 +1,38 @@
var TSC = TSC || {};
TSC.embedded_config_xml = '<x:xmpmeta xmlns:x="adobe:ns:meta/">\
<rdf:RDF xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#" xmlns:xmp="http://ns.adobe.com/xap/1.0/" xmlns:xmpDM="http://ns.adobe.com/xmp/1.0/DynamicMedia/" xmlns:xmpG="http://ns.adobe.com/xap/1.0/g/" xmlns:tsc="http://www.techsmith.com/xmp/tsc/" xmlns:xmpMM="http://ns.adobe.com/xap/1.0/mm/" xmlns:tscDM="http://www.techsmith.com/xmp/tscDM/" xmlns:tscIQ="http://www.techsmith.com/xmp/tscIQ/" xmlns:tscHS="http://www.techsmith.com/xmp/tscHS/" xmlns:stDim="http://ns.adobe.com/xap/1.0/sType/Dimensions#" xmlns:stFnt="http://ns.adobe.com/xap/1.0/sType/Font#" xmlns:exif="http://ns.adobe.com/exif/1.0" xmlns:dc="http://purl.org/dc/elements/1.1/">\
<rdf:Description tsc:version="2.0.1" dc:date="2017-02-07 04:12:15 PM" dc:source="Camtasia Studio,8.5.1,enu" dc:title="MERGEDEMO" tscDM:firstFrame="MERGEDEMO_First_Frame.png" tscDM:originId="8B31DDA3-03CB-436E-AA29-8B6426F9E569" tscDM:project="capture-3">\
<xmpDM:duration xmpDM:scale="1/1000" xmpDM:value="68033"/>\
<xmpDM:videoFrameSize stDim:unit="pixel" stDim:h="1080" stDim:w="1920"/>\
<tsc:langName>\
<rdf:Bag>\
<rdf:li xml:lang="en-US">English</rdf:li></rdf:Bag>\
</tsc:langName>\
<xmpDM:Tracks>\
<rdf:Bag>\
</rdf:Bag>\
</xmpDM:Tracks>\
<tscDM:controller>\
<rdf:Description xmpDM:name="tscplayer">\
<tscDM:parameters>\
<rdf:Bag>\
<rdf:li xmpDM:name="autohide" xmpDM:value="true"/><rdf:li xmpDM:name="autoplay" xmpDM:value="false"/><rdf:li xmpDM:name="loop" xmpDM:value="false"/><rdf:li xmpDM:name="searchable" xmpDM:value="false"/><rdf:li xmpDM:name="captionsenabled" xmpDM:value="false"/><rdf:li xmpDM:name="sidebarenabled" xmpDM:value="false"/><rdf:li xmpDM:name="unicodeenabled" xmpDM:value="false"/><rdf:li xmpDM:name="backgroundcolor" xmpDM:value="000000"/><rdf:li xmpDM:name="sidebarlocation" xmpDM:value="left"/><rdf:li xmpDM:name="endaction" xmpDM:value="stop"/><rdf:li xmpDM:name="endactionparam" xmpDM:value="true"/><rdf:li xmpDM:name="locale" xmpDM:value="en-US"/></rdf:Bag>\
</tscDM:parameters>\
<tscDM:controllerText>\
<rdf:Bag>\
</rdf:Bag>\
</tscDM:controllerText>\
</rdf:Description>\
</tscDM:controller>\
<tscDM:contentList>\
<rdf:Description>\
<tscDM:files>\
<rdf:Seq>\
<rdf:li xmpDM:name="0" xmpDM:value="MERGEDEMO.MP4"/><rdf:li xmpDM:name="1" xmpDM:value="MERGEDEMO_First_Frame.png"/></rdf:Seq>\
</tscDM:files>\
</rdf:Description>\
</tscDM:contentList>\
</rdf:Description>\
</rdf:RDF>\
</x:xmpmeta>';

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

Binary file not shown.

After

Width:  |  Height:  |  Size: 42 KiB

File diff suppressed because one or more lines are too long

@ -0,0 +1,22 @@
<?xml version="1.0"?>
<CommonSettings xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd="http://www.w3.org/2001/XMLSchema">
<PGO>
<ViewModel>
<RunPhase1>true</RunPhase1>
<AppCollection>
<AppDataViewModel>
<Application>C:\Users\RMA5440\Fortran-Projects\RMAGEN\RMAGEN\INSTALL\RMAGENV83X.EXE</Application>
<Arguments />
<Directory>C:\Users\RMA5440\proj-17\ftn\jan31\RMA2 test files</Directory>
<Environment />
<MergeEnvironment>true</MergeEnvironment>
</AppDataViewModel>
</AppCollection>
<RunPhase2>true</RunPhase2>
<RunPhase3>true</RunPhase3>
</ViewModel>
<InstrumentThreadSafe>false</InstrumentThreadSafe>
<InstrumentFuncOrder>true</InstrumentFuncOrder>
<InstrumentDataLayout>false</InstrumentDataLayout>
</PGO>
</CommonSettings>

@ -0,0 +1,9 @@
0.0000000E+00 0.0000000E+00 0.0000000E+00
0.0000000E+00 0.0000000E+00 0.0000000E+00
0.0000000E+00 0.0000000E+00 0.0000000E+00
0.0000000E+00 0.0000000E+00 0.0000000E+00
0.0000000E+00 0.0000000E+00 0.0000000E+00
0.0000000E+00 0.0000000E+00 0.0000000E+00
0.0000000E+00 0.0000000E+00 0.0000000E+00
0.0000000E+00 0.0000000E+00 0.0000000E+00
0.0000000E+00 0.0000000E+00 0.0000000E+00

Binary file not shown.

@ -0,0 +1,130 @@
<?xml version="1.0"?>
<Project_Data Version="8.00">
<Project_Settings>
<ProfileName></ProfileName>
<ProjectWidth>1920</ProjectWidth>
<ProjectHeight>1080</ProjectHeight>
<IsCustomProject>1</IsCustomProject>
<SavedProjectSettings>1</SavedProjectSettings>
<LastFlashTemplate>-1</LastFlashTemplate>
</Project_Settings>
<AutoSaveFile>C:\Users\RMA5440\AppData\Local\TechSmith\Camtasia Studio\8.0\Auto-Saves\Untitled4eaa9470.autosave.camproj</AutoSaveFile>
<ProjectID>B0BE3E18-C5DF-40FA-A859-8E865C918D77</ProjectID>
<PowerPointProject>0</PowerPointProject>
<PowerPointFilename></PowerPointFilename>
<Project_Notes>
</Project_Notes>
<Project_MetaData>
<Project_MetaData_Object>
<FieldArrayKey>8</FieldArrayKey>
<Value>Untitled</Value>
</Project_MetaData_Object>
<Project_MetaData_Object>
<FieldArrayKey>13</FieldArrayKey>
<Value>2017-02-07 04:09:51 PM</Value>
</Project_MetaData_Object>
<Project_MetaData_Object>
<FieldArrayKey>16</FieldArrayKey>
<Value>ENU</Value>
</Project_MetaData_Object>
</Project_MetaData>
<CSMLData>
<GoProject id="1" version="3.0" >
<Project id="2" editRate="30/1" version="3.0" >
<Author></Author>
<Comment></Comment>
<System></System>
<SourceBin id="3" >
<Source id="4" src="C:\Users\RMA5440\Fortran-Projects\RMAGEN\capture-3.trec" lastMod="20170207T050821" rect="(0,0,1920,1080)" >
<SourceTrack range="(0,2030)" type="0" editRate="30/1" trackRect="(0,0,1920,1080)" sampleRate="0/1" bitDepth="0" numChannels="0" filename="capture-3.trec!Strack0.tsc2" metaData="capture-3.trec;" />
<SourceTrack range="(0,3000320)" type="2" editRate="44100/1" trackRect="(0,0,0,0)" sampleRate="44100/1" bitDepth="16" numChannels="2" filename="capture-3.trec!Maudio1.mp4" metaData="" />
<SourceTrack range="(0,3000320)" type="2" editRate="44100/1" trackRect="(0,0,0,0)" sampleRate="44100/1" bitDepth="16" numChannels="2" filename="capture-3.trec!$audio2.mp4" metaData="" />
</Source>
</SourceBin>
<Timeline id="5" >
<Attributes>
<Attribute id="6" value="800" name="width"/>
<Attribute id="7" value="600" name="height"/>
<Attribute id="8" value="(0,0,0,255)" name="backgroundColor"/>
</Attributes>
<GenericMixer id="9" name="Unified Mixer">
<MetaData>
<entry key="MixerType" val="TimelineMixer"/>
</MetaData>
<Tracks>
<GenericTrack id="10" >
<Attributes>
<Attribute id="11" value="" name="ident"/>
<Attribute id="12" value="0" name="audioMuted"/>
<Attribute id="13" value="0" name="videoHidden"/>
</Attributes>
<MetaData>
<entry key="IsLocked" val="False"/>
<entry key="WinTrackHeight" val="62"/>
</MetaData>
<Medias>
</Medias>
</GenericTrack>
<GenericTrack id="14" >
<Attributes>
<Attribute id="15" value="" name="ident"/>
<Attribute id="16" value="0" name="audioMuted"/>
<Attribute id="17" value="0" name="videoHidden"/>
</Attributes>
<MetaData>
<entry key="IsLocked" val="False"/>
<entry key="WinTrackHeight" val="62"/>
</MetaData>
<Medias>
</Medias>
</GenericTrack>
</Tracks>
</GenericMixer>
<CaptionAttributes id="18" >
<Attribute id="19" value="1" name="captionsEnabled"/>
<Attribute id="20" value="Arial" name="captionsFontName"/>
<Attribute id="21" value="20" name="captionsFontSize"/>
<Attribute id="22" value="(0,0,0,255)" name="captionsBackgroundColor"/>
<Attribute id="23" value="(255,255,255,255)" name="captionsForegroundColor"/>
<Attribute id="24" value="en" name="lang"/>
<Attribute id="25" value="0" name="captionsAlignment"/>
<Attribute id="26" value="1" name="captionsDefaultFontSize"/>
<Attribute id="27" value="0.5" name="captionsOpacity"/>
<Attribute id="28" value="1" name="captionsBackgroundEnabled"/>
<Attribute id="29" value="1" name="captionsBackgroundOnlyAroundText"/>
</CaptionAttributes>
<Parameters>
<VectorParam id="30" name="eyePosition">
<InterpolatingParam id="31" interp="linr" time="0/1" value="0" leadInLength="0/1" />
<InterpolatingParam id="32" interp="linr" time="0/1" value="0" leadInLength="0/1" />
<InterpolatingParam id="33" interp="linr" time="0/1" value="3000" leadInLength="0/1" />
</VectorParam>
<VectorParam id="34" name="eyeLookAtPosition">
<InterpolatingParam id="35" interp="linr" time="0/1" value="0" leadInLength="0/1" />
<InterpolatingParam id="36" interp="linr" time="0/1" value="0" leadInLength="0/1" />
<InterpolatingParam id="37" interp="linr" time="0/1" value="0" leadInLength="0/1" />
</VectorParam>
<VectorParam id="38" name="eyeUpVector">
<InterpolatingParam id="39" interp="linr" time="0/1" value="0" leadInLength="0/1" />
<InterpolatingParam id="40" interp="linr" time="0/1" value="1" leadInLength="0/1" />
<InterpolatingParam id="41" interp="linr" time="0/1" value="0" leadInLength="0/1" />
</VectorParam>
<InterpolatingParam id="42" interp="linr" time="0/1" value="0" leadInLength="0/1" name="fov"/>
<InterpolatingParam id="43" interp="linr" time="0/1" value="1.5" leadInLength="0/1" name="nearClipDistance"/>
<InterpolatingParam id="44" interp="linr" time="0/1" value="6000" leadInLength="0/1" name="farClipDistance"/>
</Parameters>
</Timeline>
</Project>
</GoProject>
</CSMLData>
</Project_Data>

Binary file not shown.

@ -12,7 +12,7 @@
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
INTEGER*4 NOP,IEM,NEF,NEFLAG,ILINEL
! 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
@ -42,7 +42,7 @@
,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
,JPTSB,ILINEL
!IPK MAR02 ADD BS1
!IPK FEB02 ADD LOCK
!IPK MAY01 ADD NODDEL AND IELDEL
@ -111,7 +111,7 @@
ALLOCATABLE ICN(:)
ALLOCATABLE ICONNCT(:,:)
ALLOCATABLE ICONNCT(:,:),NKEP(:)
ALLOCATABLE IOUTLST(:,:),NOUTLST(:),XOUT(:,:),YOUT(:,:)

@ -1,4 +1,4 @@
! Winteracter resource identifiers. Created : 03/Aug/2016 15:52:15
! Winteracter resource identifiers. Created : 13/Feb/2017 12:04:28
!
! This file is generated by the Winteracter resource editor.
! It should not be edited manually. It is also not advisable to load this
@ -361,3 +361,7 @@
INTEGER, PARAMETER :: ID_ASSIGNELTLD = 40144
INTEGER, PARAMETER :: ID_FILLTR = 40145
INTEGER, PARAMETER :: IDD_FTRIAN = 167
INTEGER, PARAMETER :: ID_addmeshtr = 40146
INTEGER, PARAMETER :: ID_UNDOGEN = 40147
INTEGER, PARAMETER :: IDD_GETFL = 168
INTEGER, PARAMETER :: ID_DDRAW = 40148

@ -833,8 +833,16 @@
CALL OUTORG(FNAMEB)
if(sub .eq. 'jpg' .or. sub .eq. 'png' .or. sub .eq. 'pcx' .or. sub .eq. 'bmp') then
! call doplot(0)
CALL WGrSaveImageOptions(31,100)
CALL WGrSaveImageOptions(32,150)
call igrsaveimage(fname)
call doplot(0)
call IGrFileInfo(FNAME,INFO,3)
IF(SUB .EQ. 'jpg') THEN
SUB2='jpgw'
CALL ADDSUB(FNAMEB,SUB2)
CALL OUTJPGW(FNAMEB,INFO)
ENDIF
CALL HEDR
go to 100
endif
@ -1067,6 +1075,10 @@
IACTVFIL=IOLDACT
CALL ADDTOMESH(IFILADD,1)
GO TO 100
!ipk sep16 ADD MESH FROM POINTS
CASE (ID_ADDMESHTR)
CALL ADDMESHT
GO TO 100
!ipk may03
CASE (ID_TRIANG) ! add a triangle of elements
CALL ADDTRIANG
@ -1235,6 +1247,12 @@
CALL REATTACH
GO TO 101
CASE (ID_DDRAW)
IDDSW=MOD(IDDSW+1,2)
IF(IDDSW .EQ. 1) CALL WMenuSetState(ID_DDRAW,ItemChecked,1)
GO TO 101
CASE (ID_COMPLEX)
CALL GNODE(2)
GO TO 101
@ -1346,6 +1364,7 @@
CASE (ID_SMOOTHMAP)
CALL SMOOTHMP
GO TO 101
CASE (ID_DRAG)
MENUS=8
iflag='d'
@ -1702,11 +1721,20 @@
GO TO 100
CASE (ID_UNDOS)
IFLAG='U'
CASE (ID_UNDOGEN)
! IF(ITOTFIL .EQ. 1) THEN
! CALL ZEROOUT
! IACTVFIL=0
! CALL PLOTOT(0)
! ELSE
CALL UNDOGEN
! ENDIF
GO TO 100
CASE (ID_GOUTLIN)
CALL GOUTLIN
GO TO 100
CASE (ID_XOUTLIN)
CALL OUTLINES
CALL OUTLINES(0)
GO TO 100
END SELECT

@ -1,47 +0,0 @@
///////////////////////////////////////////////////
//
// 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

@ -4,6 +4,7 @@
USE BLKMAP
CHARACTER(LEN=256) :: FILTER,FNAME
CHARACTER(LEN=80) :: DATAIN,OPTIONS
CHARACTER(LEN=96) :: LOCDIR
CHARACTER(LEN=3) :: SUB
INTEGER INOUTL,NOUTL,OUTPOL
INTEGER NTRIAN(5000,2),TWO,ZERO,ntrans(5000)
@ -168,9 +169,9 @@
! OPTIONS = ' -pqa5000V TEST'
OPTIONS(1:3) = ' -p'
nct=3
! iswq=1
! iswy=0
! id1=105
iswq=1
iswy=0
id1=100
CALL PANELFILLT(ISWQ,ISWY,ID1)
IF(ISWQ .EQ. 1) THEN
@ -202,9 +203,29 @@
open(77,file= 'test.1.poly')
close(77,status='DELETE')
ENDIF
INQUIRE (FILE = "C:\Program Files\RMA\TRIANGLE.EXE", EXIST = exists)
if(.not. exists) then
INQUIRE (FILE = "TRIANGLE.EXE", EXIST = exists)
if(.not. exists) then
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'TRIANGLE is not available in '//CHAR(13)//&
'C:\Program Files\RMA\ directory'//CHAR(13)//'Do you wish to define directory?'&
,'WARNING TRIANGLE IS NOT AVAILABLE')
! If answer 'No', return
!
IF (WInfoDialog(4).EQ.2) return
CALL GETDIR(LOCDIR)
else
LOCDIR(1:8)='TRIANGLE'
! WRITE(155,*) LOCDIR
RESULT= RUNQQ(LOCDIR, OPTIONS)
GO TO 600
endif
endif
RESULT= RUNQQ("C:\Program Files\RMA\TRIANGLE", OPTIONS)
! RESULT= RUNQQ("TRIANGLE", OPTIONS)
600 CONTINUE
IF(IMAPIN .EQ. 1) THEN
READ(113) XMAP,YMAP
CLOSE (113)
@ -239,12 +260,12 @@
! real ::
! character*3 ::
DATA ITIME/0/
IF(ITIME .EQ. 0) THEN
ITIME=1
N1=1
N2=0
N3=100
ENDIF
! IF(ITIME .EQ. 0) THEN
! ITIME=1
! N1=1
! N2=0
! N3=100
! ENDIF
call wdialogload(IDD_FTRIAN)
ierr=infoerror(1)

@ -0,0 +1,757 @@
SUBROUTINE GETNEWFIL(IIN,IGFG,ITRIAN,ISWT)
INCLUDE 'BFILES.I90'
! WRITE CURRENT DATA TO A SCRATCH FILE
IF(IACTVFIL .GT. 0 .AND. ISWT .NE. -1) THEN
IFILOUT=IACTVFIL+50
CALL WRTFIL(IFILOUT)
CALL ZEROOUT
IACTVFIL=ITOTFIL
ELSEIF(IACTVFIL .EQ. 0) THEN
IACTVFIL=1
ENDIF
IF(abs(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

@ -4,12 +4,13 @@
! WRITE CURRENT DATA TO A SCRATCH FILE
IF(IACTVFIL .GT. 0) THEN
IF(IACTVFIL .GT. 0 .AND. ISWT .NE. -1) THEN
IFILOUT=IACTVFIL+50
WRITE(90,*) 'INGETNEWFIL IFILOUT',IFILOUT
CALL WRTFIL(IFILOUT)
CALL ZEROOUT
IACTVFIL=ITOTFIL
ELSE
ELSEIF(IACTVFIL .EQ. 0) THEN
IACTVFIL=1
ENDIF
IF(ISWT .EQ. 1) THEN
@ -19,9 +20,11 @@
FNAMEOUT(IACTVFIL)='TEST.1.ELE'
WRITE(90,*) 'ITOTFIL,IACTVFIL',ITOTFIL,IACTVFIL
WRITE(90,'(A80)') (FNAMEOUT(KKK),KKK=1,3)
ELSE
FNAMKEP='TEST.1.ELE'
ENDIF
IF(ITRIAN .EQ. 1) THEN
CALL READGFG(IIN,1)
IF(ABS(ITRIAN) .EQ. 1) THEN
CALL READGFG(IIN,ITRIAN)
! TEST FOR GFG FORMAT
ELSEIF(IGFG .EQ. 1) THEN
@ -42,6 +45,7 @@
CALL RDBIN(IIN)
ENDIF
IF(ITRIAN .EQ. -1) RETURN
IFILOUT=IACTVFIL+50
WRITE(90,*) 'IFILOUT', IFILOUT
@ -62,10 +66,16 @@
USE BLK1MOD
CHARACTER*80 ALINE
CHARACTER*10 FMT
! INCLUDE 'BLK1.COM'
CLOSE (IFILOUT)
OPEN(IFILOUT,STATUS='scratch',FORM='binary')
FMT(1:8)='TEMPFIL.'
WRITE(FMT(9:10),'(I2)') IFILOUT
! OPEN(IFILOUT,STATUS='scratch',FORM='binary')
WRITE(90,*) 'IFILOUT',IFILOUT
! OPEN(IFILOUT,STATUS='scratch',FORM='unformatted')
OPEN(IFILOUT,FILE=FMT,STATUS='UNKNOWN',FORM='BINARY')
ISLP=0
IPRT=1
@ -93,13 +103,14 @@
xadded=0.
yadded=0.
ntempin=0.
! WRITE(90,*) 'IN GETNEWFIL', IFILOUT,NP,NE,IPRT
WRITE(90,*) 'IN WRTFIL', 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(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
WRITE(90,*) 'IPP',IPP
IF(IPP .GT. 0) WRITE(IFILOUT) ALINE
WRITE(IFILOUT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE)
@ -355,6 +366,7 @@
USE BLK1MOD
INCLUDE "BFILES.I90"
! INCLUDE 'BLK1.COM'
INCLUDE 'TXFRM.COM'
CHARACTER*1 ANS
CHARACTER*32 ANS32
CHARACTER*3 ID
@ -394,7 +406,7 @@
yadded=0.
ntempin=0.
KLIN=0
IF(ISW .EQ. 1) GO TO 500
IF(ABS(ISW) .EQ. 1) GO TO 500
DO I=1,10000
READ(IIN,'(A3,A77)') ID,DLIN
IF(ID .EQ. 'T1 ') THEN
@ -626,11 +638,15 @@
RETURN
500 CONTINUE
IF(ISW .EQ. -1) THEN
NESV=NE
NPSV=NP
ENDIF
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(ISW .EQ. -1) J=J+NESV
IF (J .GE. MEL) THEN
CALL SETD(23)
WRITE(lind,*) ' Element number exceeds MAXE in RDELEM'
@ -644,7 +660,11 @@
STOP
ENDIF
DO KK=1,3
IF(ISW .EQ. -1) THEN
NOP(J,2*KK-1) = NTMP(KK)+NPSV
ELSE
NOP(J,2*KK-1) = NTMP(KK)
ENDIF
NOP(J,2*KK)=0
ENDDO
IF(NATTR .GT. 0) THEN
@ -655,6 +675,7 @@
NCORN(J)=6
IESKP(J)=0
ENDDO
NE=J
CLOSE(IUNIT)
DO L=255,1,-1
IF(FNAMKEP(L:L) .EQ. '.') THEN
@ -668,6 +689,7 @@
READ(IUNIT,*) NPPP,NDUM,NATTR
DO KK=1,NPPP
READ(IUNIT,*) J,CX,CY,(VALS(K),K=1,NATTR)
IF(ISW .EQ. -1) J=J+NPSV
IF(J .EQ. 0) THEN
J=NPPP
JZ=1
@ -691,10 +713,10 @@
STOP
ENDIF
NP = MAX(NP,J)
CORD(J,1) = CX
CORD(J,2) = CY
XUSR(J) = CX
YUSR(J) = CY
CORD(J,1) = (XUSR(J)+XS)/TXSCAL
CORD(J,2) = (YUSR(J)+YS)/TXSCAL
WD(J) = BELEV
WIDTH(J)=0.
SS1(J)=0.

@ -6,8 +6,26 @@
! INCLUDE 'BLK1.COM'
DIMENSION WGT(8)
REAL*8 XMINL,YMINL,XMAXL,YMAXL
! data itime/0/
! LOOK FOR MATCHING POINTS
DO K=1,MAXPTS
DISQ=(XUSR(M)-XMAP(K))**2+(YUSR(M)-YMAP(K))**2
IF(DISQ .LT. 1.) THEN
WD(M)=VAL(K)
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
ENDDO
! Search for element that has circumcircle around the node
@ -43,23 +61,28 @@
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
! IF(M .EQ. 6316) THEN
! WRITE(156,'(2I6,6F15.2)') M,N,XUSR(M),XMINL,XMAXL,YUSR(M),YMINL,YMAXL
! ENDIF
if(xusr(m) .lt. xminl-0.01 .or. xusr(m) .gt. xmaxl+0.01) then
go to 250
elseif(yusr(m) .lt. yminl .or. yusr(m) .gt. ymaxl) then
elseif(yusr(m) .lt. yminl-0.01 .or. yusr(m) .gt. ymaxl+0.01) then
go to 250
endif
! IF(M .EQ. 6316) WRITE(156,*) 'PASSED X AND Y TEST',N
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
! IF(M .EQ. 6316) write(156,*) m,n,disq,rads(n)**2,xusr(m),xcen(n)
! 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)
WRITE(142,*) 'REJECT',m,n,disq,rads(n)**2,wgt(1),wgt(2),wgt(3)
GO TO 250
ENDIF
ENDDO

@ -27,7 +27,7 @@
common /cols/ ibakk,icolr,iblkk
CHARACTER*8 HED(10),HEAD(10,16)
CHARACTER*47 MESOUT,MESS(47)
CHARACTER*47 MESOUT,MESS(48)
!ipk lan01 add to MESS
!ipk jan99 add to MESS
!ycw mar97 change HEADR(5,5) to HEADR(6,7)
@ -37,7 +37,7 @@
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 ',&
DATA HEAD/ ' (e)lts ','(n)odes ','(o)rder ',' (h)elp ',' ',&
'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
@ -98,8 +98,9 @@
'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
,' ','Click two locations to define move'& ! 46 47
,'Click locations to form outline'/ ! 48
! last line Jan 2001
! line above added Jan 1999
DATA HEADR /&
' (q)uit ',5*' ',&

@ -30,8 +30,9 @@
Filter='HTM file -- *.htm|*.htm|'
CALL WSelectFile(FILTER,PromptOn,DIRECT,'Help files not available - BROWSE')
! CALL WSelectFile(FILTER,PromptOn,DIRECT,'Help files not available - BROWSE')
CALL WSelectFile(FILTER,LoadDialog+MustExist,DIRECT,'Help files not available - BROWSE')
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
GO TO 200
ELSE

@ -9,8 +9,8 @@
IF(K1 .EQ. 0) THEN
MAXPL=200000
MAXP=100000
MAXE=60000
MAXP=200000
MAXE=120000
MAXSTO=2
MAXLIN=3000
MAXECON=60

@ -206,6 +206,8 @@
enddo
if(abs(wdmin) .gt. abs(wdmax)) then
temp=log10(abs(wdmin))
elseif(wdmax .eq. 0.) then
temp=2.5
else
temp=log10(abs(wdmax))
endif
@ -2288,7 +2290,7 @@
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)
5004 FORMAT('GE',10(1X,I6),F17.4)
ENDIF
ENDDO
DO J=1,NP
@ -2360,13 +2362,22 @@
CHARACTER*80 ALINE
IF(IENT .EQ. 1) THEN
! READ(IUNIT) IDUMMY1
READ(IUNIT) TITLE,NP,NE
! READ(IUNIT) IDUMMY1,IDUMMY2
READ(IUNIT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
! READ(IUNIT) ,IDUMMY2,IDUMMY3
READ(IUNIT) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG
IF(IPP .GT. 0) READ(IIN) ALINE
IPP=0
NTEMPIN=2
IF(IPP .GT. 0) THEN
! READ(IIN) IDUMMY3,IDUMMY4
READ(IIN) ALINE
ENDIF
ELSEIF(IENT .EQ. 2) THEN
! READ(IUNIT) IDUMMY4,IDUMMY5
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
@ -2383,7 +2394,7 @@
ENDDO
ELSE
! READ(IUNIT) IDUMMY5,IDUMMY6
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)
@ -2396,20 +2407,29 @@
INEW(J) = 1
ENDIF
ENDDO
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) NLST
IF(NLST .GT. 0) THEN
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) (LLIST(J),J=1,NLST), &
((ILIST(J,I),I=1,LLIST(J)),J=1,NLST)
ENDIF
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) NENTRY,NLAYD,NCLM
if(nentry .eq. 0 .and. nlayd .eq. 0 .and. nclm .eq. 0) return
! READ(IUNIT) IDUMMY5,IDUMMY6
IF(NENTRY .GT. 0) THEN
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) ((NEF(I,J),J=1,3),I=1,NENTRY)
ENDIF
IF(NLAYD .GT. 0) THEN
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) (LAY(I),I=1,NP),((WTLAY(I,J),J=1,9),I=0,NP)
ENDIF
IF(NCLM .GT. 0) THEN
! READ(IUNIT) IDUMMY5,IDUMMY6
! NCLM=11
READ(IUNIT) ((ICCLN(I,J),J=1,350),I=1,NCLM)
ENDIF
ENDIF

@ -167,7 +167,7 @@
! get adjacent corner save corner
m=2
list1(m)=nd3
write(90,*) 'm',nd3
write(90,*) m,nd3
nelc=nel1
nelcsv=nel1
! start looop
@ -197,6 +197,7 @@
RETURN
ENDIF
list1(m)=nd3
write(90,*) m,nd3
! test for last element
if(nelc .eq. nel2) go to 250
enddo
@ -209,10 +210,12 @@
call findbcel(nel3,nd1,nd2,nd3,ierr,ilc)
! save back node
list2(1)=nd1
write(90,*) m,nd1
! get adjacent corner save corner
m=2
list2(m)=nd3
write(90,*) m,nd3
nelc=nel3
nelcsv=nel3
! start looop
@ -225,6 +228,7 @@
if(necon(nd3,kkk) .ne. nelc) then
nelc=necon(nd3,kkk)
ilc=2
if(nelc .eq. nel4) ilc=4
call findbcel(nelc,nd1,nd2,nd3,ierr,ilc)
if(ierr .eq. 0) go to 300
@ -242,6 +246,7 @@
CALL HEDR
ENDIF
list2(m)=nd3
write(90,*) m,nd3
! test for last element
if(nelc .eq. nel4) go to 350
enddo
@ -312,8 +317,10 @@
nd2=nop(nel,k)
if(ndelm(nd2) .eq. 1) then
nd1=nop(nel,k-1)
if(nd1 .ne. ndkp .and. ilc .gt. 1) cycle
jj=mod(k,ncorn(nel))+1
nd3=nop(nel,jj)
if(ilc .eq. 4) return
if(ilc .gt. 0) then
kk=kk+1
mlc(kk)=k

@ -10,6 +10,7 @@
CALL ZEROOUT
IFNUM=IACTVFIL+50
WRITE(90,*) 'IN LOADFIL IFNUM',IFNUM
CALL RDRST(1,IFNUM)
CALL RDRST(2,IFNUM)
CALL RDRST(3,IFNUM)

@ -34,6 +34,8 @@
LOGICAL :: OPENED,exists
LOGICAL(4) :: statud
REAL :: XX1,XX2,XX3,XX4,XX5,XX6
INTEGER :: iw,ih,ihandle,ient,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
common /hands/ ihandle,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
INTEGER ISCRWID,ISCRHGT
@ -56,7 +58,7 @@
IRES=GETDRIVEDIRQQ (fname)
! lnnnam=windowstringlength(fname)
lnnnam=lenstr(fname)
direct=fname(1:lnnnam)//'\doc\rmagen81M.htm'
direct=fname(1:lnnnam)//'\doc\rmagen83d.htm'
! write(128,*) fname,lnnnam,direct
@ -144,6 +146,10 @@
! DO I=1,12
! CALL WMenuSetState(IBASEV+I,ItemChecked,1)
! ENDDO
IDDSW=-1
IHANDLE=0
IHAND1=0
IHAND2=0
N2=0
M2=0
TXSCAL = 1.
@ -238,6 +244,7 @@
ELSEIF(SUB .EQ. 'rst') then
IIN=11
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
! OPEN(IIN,FILE=FNAME,STATUS='OLD',FORM ='BINARY',action='read')
IGFG=0
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)
ELSEIF(SUB .EQ. 'bin') then
@ -473,6 +480,7 @@
ELSEIF(SUB .EQ. 'rst') then
IIN=11
OPEN(IIN ,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
! OPEN(IIN,FILE=FNAME,STATUS='OLD',FORM ='BINARY')
IGFG=0
ITRIAN=0
CALL SETGFGTRIAN(IGFG,ITRIAN,ID1,ID2)

@ -1,4 +1,4 @@
SUBROUTINE OUTLINES
SUBROUTINE OUTLINES(ISWT)
USE WINTERACTER
USE BLK1MOD
@ -10,17 +10,21 @@
CHARACTER(LEN=255) :: FNAME,FILTER
CHARACTER(LEN=4) :: SUB
LOGICAL OPENED
REAL XCEN(10),YCEN(10),MTYP(10)
LOGICAL OPENED,LSTAT
CHARACTER*1 IFLAG,ANS(10)
DATA ANS/' ',' ',' ',' ',' ',' ','n','z','r','q'/
DATA PI2/1.5708/
IF(.NOT. ALLOCATED(ICONNCT)) THEN
ALLOCATE (ICONNCT(MAXP,2),IOUTLST(10,5000),NOUTLST(10))
ALLOCATE (ICONNCT(MAXP,3),IOUTLST(10,5000),NOUTLST(10),NKEP(MAXP))
ENDIF
IF(.NOT. ALLOCATED(XOUT)) THEN
ALLOCATE (XOUT(5000,10),YOUT(5000,10))
ENDIF
NOUTLST=0
IOUTSW=2
IPOS=2
IF(ISWT .EQ. 1) GO TO 80
IOUTOUT=26
INQUIRE(26, OPENED=OPENED)
if(.not. opened) then
@ -73,17 +77,20 @@
ENDIF
!
! FORM LIST OF ELEMENT SIDES THAT ARE ON THE OUTSIDE
80 CONTINUE
DO N=1,NP
MSN(N)=0
ENDDO
ILINEL=0
DO N=1,NE
IF(IMAT(N) .LE. 0) CYCLE
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,3)=N
ICONNCT(J,1)=NOP(N,K-1)
IF(K .EQ. NCN) THEN
ICONNCT(J,2)=NOP(N,1)
@ -92,6 +99,21 @@
ENDIF
endif
ENDDO
ELSEIF(IMAT(N) .NE. 999 .AND. NCORN(N) .LE. 5 .AND. (IMAT(N) .LT. 900 .OR. IMAT(N) .GT. 903)) THEN
ILINEL=1
IF(NCORN(N) .EQ. 5) THEN
DO K=1,5,4
J=NOP(N,K)
MSN(J)=MSN(J)-1
ICONNCT(J,-MSN(J))=N
ENDDO
ELSE
DO K=1,3,2
J=NOP(N,K)
MSN(J)=MSN(J)-1
ICONNCT(J,-MSN(J))=N
ENDDO
ENDIF
ENDIF
ENDDO
@ -101,6 +123,7 @@
JJ=0
DO J=1,NP
IF(MSN(J) .EQ. 1) THEN
MTYP(K)=1
!
! THIS IS A STARTING POINT EXTRACT A CORNER NODE
IOUTLST(K,1)=ICONNCT(J,1)
@ -112,6 +135,14 @@
IOUTLST(K,3)=ICONNCT(J,2)
JJ=3
endif
N=ICONNCT(J,3)
IF(NOP(N,7) .EQ. 0) THEN
XCEN(K)=(XUSR(NOP(N,1))+XUSR(NOP(N,3))+XUSR(NOP(N,5)))/3.
YCEN(K)=(YUSR(NOP(N,1))+YUSR(NOP(N,3))+YUSR(NOP(N,5)))/3.
ELSE
XCEN(K)=(XUSR(NOP(N,1))+XUSR(NOP(N,3))+XUSR(NOP(N,5))+XUSR(NOP(N,7)))/4.
YCEN(K)=(YUSR(NOP(N,1))+YUSR(NOP(N,3))+YUSR(NOP(N,5))+YUSR(NOP(N,7)))/4.
ENDIF
MSN(J)=0
ICONNCT(J,1)=0
ICONNCT(J,2)=0
@ -156,6 +187,60 @@
ENDIF
ENDDO
ELSEIF(MSN(J) .EQ. -1) THEN
MTYP(K)=-1
JJ=J
JO=J
LL=1
NN=ICONNCT(JJ,LL)
IOUTLST(K,LL)=JJ
130 LL=LL+1
IF(NCORN(NN) .EQ. 5) THEN
NNOP=5
ELSE
NNOP=3
ENDIF
IF(NOP(NN,1) .EQ. JJ) THEN
JJ=NOP(NN,NNOP)
JL=NOP(NN,3)
IOUTLST(K,LL)=JL
ELSE
JJ=NOP(NN,1)
JL=JJ
IOUTLST(K,LL)=JJ
ENDIF
CALL GETLINANG(ANGL,JO,JJ)
ANGL1=ANGL-PI2
IF(LL .EQ. 2) THEN
XOUT(1,K)=XUSR(JO)+WIDTH(JO)/2.*COS(ANGL1)
YOUT(1,K)=YUSR(JO)+WIDTH(JO)/2.*SIN(ANGL1)
XOUT(4999,K)=XUSR(JO)-WIDTH(JO)/2.*COS(ANGL1)
YOUT(4999,K)=YUSR(JO)-WIDTH(JO)/2.*SIN(ANGL1)
ENDIF
XOUT(LL,K)=XUSR(JL)+WIDTH(JL)/2.*COS(ANGL1)
YOUT(LL,K)=YUSR(JL)+WIDTH(JL)/2.*SIN(ANGL1)
XOUT(5000-LL,K)=XUSR(JL)-WIDTH(JL)/2.*COS(ANGL1)
YOUT(5000-LL,K)=YUSR(JL)-WIDTH(JL)/2.*SIN(ANGL1)
IF(MSN(JJ) .EQ. -1) GO TO 150
IF(ICONNCT(JJ,1) .EQ. NN) THEN
NN=ICONNCT(JJ,2)
ELSE
NN=ICONNCT(JJ,1)
ENDIF
GO TO 130
150 MSN(JJ)=0
JJ=LL
DO JJJ=LL,1,-1
JJ=JJ+1
XOUT(JJ,K)=XOUT(5000-JJJ,K)
YOUT(JJ,K)=YOUT(5000-JJJ,K)
ENDDO
JJ=JJ+1
XOUT(JJ,K)=XOUT(1,K)
YOUT(JJ,K)=YOUT(1,K)
MSN(J)=0
GO TO 200
ENDIF
ENDDO
GO TO 300
@ -179,13 +264,40 @@
WRITE(IOUTOUT,*) NZERO
ELSE
DO L=1,NOUTLST(K)
IF(MTYP(K) .EQ. 1) THEN
XOUT(L,K)=XUSR(IOUTLST(K,L))
YOUT(L,K)=YUSR(IOUTLST(K,L))
ENDIF
IF(IOUTSW .EQ. 0) THEN
WRITE(IOUTOUT,*) XOUT(L,K),YOUT(L,K)
ENDIF
ENDDO
ENDIF
ENDIF
ENDDO
300 CONTINUE
300 CONTINUE
DO K=1,10
IF(NOUTLST(K) .EQ. 0) GO TO 400
IF(MTYP(K) .EQ. 1) THEN
LSTAT=IGrInsidePolygon(XOUT(1,K),YOUT(1,K),NOUTLST(K),XCEN(K),YCEN(K))
ELSE
LSTAT=.TRUE.
ENDIF
IF(LSTAT) THEN
NOUTLST(K)=ABS(NOUTLST(K))
ELSE
NOUTLST(K)=-ABS(NOUTLST(K))
ENDIF
ENDDO
400 CONTINUE
RETURN
END
SUBROUTINE GETLINANG(angle,n1,n2)
USE BLK1MOD
! use ATAN2 and angle into range 0 to 2*pi
ANGLE=ATAN2(YUSR(N2)-YUSR(N1),XUSR(N2)-XUSR(N1))
IF(ANGLE .LT. 0.) ANGLE=ANGLE+6.28318515
RETURN
END

@ -174,3 +174,31 @@
RETURN
END
SUBROUTINE CHEXIT
USE WINTERACTER
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: ITYPE
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
CALL WMessagePeek(ITYPE, MESSAGE)
SELECT CASE (ITYPE)
CASE (-1)
RETURN
CASE (KeyDown) ! Key pressed
IPSW(1)=0
IPSW(2)=1
IPSW(3)=0
IPSW(4)=0
IPSW(5)=0
IPSW(6)=0
IPSW(7)=0
IPSW(8)=0
IPSW(9)=0
IPSW(12)=0
RETURN
ENDSELECT
RETURN
END

@ -27,6 +27,7 @@
IFIRST=1
ENDIF
HT=0.2
! CALL CHEXIT
!
if(imz .ne. 2) CALL CLSCRN
!
@ -67,6 +68,28 @@
PSCALE = 1.
XMIN = 0.
YMIN = 0.
! if(np .gt. 100000) call backc(1)
! 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
IF(IDDSW .EQ. -1) THEN
IF(NP .GT. 100000) THEN
IDDSW=0
ELSE
IDDSW=1
ENDIF
ENDIF
if(IDDSW .EQ. 0) call backc(1)
if(ipsw(4) .eq. 1) then
do j=1,ne
@ -74,7 +97,6 @@
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)
@ -131,8 +153,10 @@
cycle
endif
enddo
if(abs(wdmin) .ge. abs(wdmax)) then
if(abs(wdmin) .gt. abs(wdmax)) then
temp=log10(abs(wdmin))
elseif(wdmin .eq. 0) then
temp=2.5
else
temp=log10(wdmax)
endif
@ -145,10 +169,10 @@
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(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
@ -218,15 +242,15 @@
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(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
20 CONTINUE
IF(IERC .GT. 0) THEN
! call clscrn()
! WRITE(LIND,*) ' Zero node corner nodes'
@ -250,6 +274,9 @@
ENDIF
endif
ENDIF
if(IDDSW .EQ. 0) then
call backc(2)
endif
!ycw mar97 add for cross section
if(ICRS.ne.0) then
call plott(XPCS(1),YPCS(1),3)
@ -308,7 +335,7 @@
IF(IMZ .NE. 1) THEN
CALL DOPLOT(IMZ)
ENDIF
CALL CHEXIT
RETURN
END
!

@ -4,7 +4,7 @@
USE BLK1MOD
USE BLK2MOD
INTEGER NS1(3),NT1(3)
INTEGER NS1(3,4),NT1(3,4)
CHARACTER*1 IFLAG,ANSW(10)
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
@ -12,34 +12,50 @@
CALL KCON(0)
! SELECT FIRST ELEMENT
10 CONTINUE
NHTPSV=NHTP
NMESSSV=NMESS
NBRRSV=NBRR
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(IRMAIN .EQ. 1) THEN
NHTP=NHTPSV
NMESS=NMESSSV
NBRR=NBRRSV
CALL HEDR
RETURN
ENDIF
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
IFLAG=ANSW(IBOX)
ENDIF
!
IF(IFLAG .EQ. 'q') THEN
NHTP=NHTPSV
NMESS=NMESSSV
NBRR=NBRRSV
CALL HEDR
RETURN
ENDIF
call fillem(ielem)
! GET UNATTACHED NOP
kk=0
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
KK=KK+1
NS1(1,KK)=NOP(IELEM,K-1)
NS1(2,KK)=NSX
KKK=MOD(K,NCORN(IELEM))+1
NS1(3,KK)=NOP(IELEM,KKK)
! GO TO 280
ENDIF
ENDDO
280 CONTINUE
280 CONTINUE
! SELECT NEXT ELEMENT
@ -48,24 +64,38 @@
! GET UNNATCHED SIDE
! FIND AN UNATTACHED SIDE (INDICATE OF TRIANGLE OR QUADRILATERAL)
LL=0
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
LL=LL+1
NT1(1,LL)=NOP(IELEM1,K-1)
NT1(2,LL)=NSX
KKK=MOD(K,NCORN(IELEM1))+1
NT1(3,LL)=NOP(IELEM1,KKK)
! GO TO 300
ENDIF
ENDDO
300 CONTINUE
! FORM A NEW ELEMENT ASSIGN TYPE AS INDICATED
! GET THE NEAREST TWO FACES
DISTKP=1.E20
DO NN=1,KK
DO MM=1,LL
DIST=(XUSR(NS1(2,NN))-XUSR(NT1(2,MM)))**2+(YUSR(NS1(2,NN))-YUSR(NT1(2,MM)))**2
IF(DIST .LT. DISTKP) THEN
NNN=NN
MMM=MM
DISTKP=DIST
ENDIF
ENDDO
ENDDO
CALL GETELM(J)
DO K=1,3
NOP(J,K)=NS1(K)
NOP(J,K+4)=NT1(K)
NOP(J,K)=NS1(K,NNN)
NOP(J,K+4)=NT1(K,MMM)
ENDDO
NOP(J,4)=0
NOP(J,8)=0
@ -74,6 +104,7 @@
NCORN(J)=8
! GO BACK TO LOOK FOR NEW PAIR
CALL PLOTOT(1)
GO TO 10
RETURN
END

@ -294,14 +294,16 @@
TYPE(WIN_MESSAGE) :: MESSAGE
INCLUDE 'BFILES.I90'
CHARACTER(LEN=256) :: FILTER
INTEGER :: NN,I,III
CHARACTER(LEN=255) :: FNAME
CHARACTER(LEN=3) :: SUB
INTEGER :: INFO(3)
REAL :: XSIZ,YSIZ
IF(III .EQ. 1) THEN
CALL WMessageBox(YesNo,QuestionIcon,CommonOK, 'Do you wish to '// &
'save locations as ORG file?', 'SAVE ORG FILE')
'save locations as ORG or JPGW file?', 'SAVE ORG/JPGW FILE')
!
! If answer 'NO', return
!
@ -309,16 +311,34 @@
ENDIF
! Otherwise process
call IGrFileInfo(BFNAME(NN),INFO,3)
FILTER ="Registration Files|*.org;*.jpgw|ORG file -- *.org|*.org|JPGW file -- *.jpgw|*.jpgw|"
CALL WSelectFile(ID_STRING11,SaveDialog+PromptOn,FNAME,'Save ORG File')
CALL WSelectFile(FILTER,SaveDialog+PromptOn+AppendExt,FNAME,'Save ORG/JPGW File')
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
SUB='org'
CALL ADDSUB(FNAME,SUB)
! SUB='org'
OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED')
CALL IlowerCase(FNAME)
CALL GETSUB(FNAME,SUB)
if(sub .eq. 'jpg') then
XSIZ=(BFMINMAX(NN,3)-BFMINMAX(NN,1))/FLOAT(INFO(2))
YSIZ=(BFMINMAX(NN,2)-BFMINMAX(NN,4))/FLOAT(INFO(3))
WRITE(104,*) XSIZ
WRITE(104,*) ' 0.0'
WRITE(104,*) ' 0.0'
WRITE(104,*) YSIZ
WRITE(104,*) BFMINMAX(NN,1)
WRITE(104,*) BFMINMAX(NN,4)
CLOSE(104)
else
! 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
ENDIF
RETURN

Binary file not shown.

@ -188,10 +188,10 @@
IPSW(8)=0
IPSW(9)=0
IPSW(12)=0
IF(N8 .GT. 100000) THEN
IPSW(2)=1
IPSW(4)=0
ENDIF
! IF(N8 .GT. 100000) THEN
! IPSW(2)=1
! IPSW(4)=0
! ENDIF
MAXPTS=MAXPL
!ipk jan98
call file(1)

@ -8,7 +8,7 @@
//
// Winteracter resource script.
//
// Modified : 03/Aug/2016 15:52:15
// Modified : 13/Feb/2017 12:04:28
//
///////////////////////////////////////////////////
//
@ -371,6 +371,10 @@
#define ID_ASSIGNELTLD 40144
#define ID_FILLTR 40145
#define IDD_FTRIAN 167
#define ID_addmeshtr 40146
#define ID_UNDOGEN 40147
#define IDD_GETFL 168
#define ID_DDRAW 40148
///////////////////////////////////////////////////
//
@ -1045,7 +1049,7 @@ BEGIN
CONTROL "",IDF_STRING32,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 134, 340, 12
CONTROL "",IDF_STRING33,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 148, 340, 12
CONTROL "",IDF_STRING34,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | WS_TABSTOP | ES_LEFT, 40, 162, 340, 12
CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 180, 196, 40, 14
CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 88, 196, 40, 14
CONTROL "",IDF_RADIO1,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 36, 20, 12
CONTROL "",IDF_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 50, 20, 12
CONTROL "",IDF_RADIO3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 64, 20, 12
@ -1056,6 +1060,7 @@ BEGIN
CONTROL "",IDF_RADIO8,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 134, 20, 12
CONTROL "",IDF_RADIO9,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 148, 20, 12
CONTROL "",IDF_RADIO10,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 162, 20, 12
CONTROL "Cancel",IDCANCEL,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_PUSHBUTTON | BS_TEXT, 278, 195, 40, 14
END
IDD_SELTFL2 RCDATA
@ -2095,6 +2100,22 @@ BEGIN
,0
END
IDD_GETFL DIALOG 0, 0, 233, 89
STYLE WS_POPUP | WS_BORDER | WS_DLGFRAME | WS_SYSMENU | DS_3DLOOK | DS_MODALFRAME
FONT 8, "MS Sans Serif"
CAPTION "ENTER FILE DIRECTORY FOR TRIANGLE"
BEGIN
CONTROL "",IDF_STRING1,"EDIT",WS_CHILD | WS_VISIBLE | WS_BORDER | WS_GROUP | ES_LEFT | ES_CENTER | ES_MULTILINE | ES_UPPERCASE, 17, 24, 198, 16
CONTROL "OK",IDOK,"BUTTON",WS_CHILD | WS_VISIBLE | WS_GROUP | WS_TABSTOP | BS_DEFPUSHBUTTON | BS_TEXT, 96, 59, 40, 14
END
IDD_GETFL RCDATA
BEGIN
"[Colours] \n"
" 1013 256 256 256 255 255 255 \n"
,0
END
///////////////////////////////////////////////////
//
// Menus
@ -2147,6 +2168,7 @@ BEGIN
POPUP "Mesh"
BEGIN
MENUITEM "Select mesh file", ID_SELRM1
MENUITEM "Input Outline to Add Mesh", ID_addmeshtr
MENUITEM "Add mesh to existing", ID_addmesh
MENUITEM "Merge mesh to existing", ID_MRGMESH
MENUITEM "Generate triangular block", ID_TRIANG
@ -2217,6 +2239,7 @@ BEGIN
BEGIN
MENUITEM "Undo Refine or Gblock", ID_UNDO
MENUITEM "Undo Last Selected Element", ID_UNDOS
MENUITEM "Undo Last Auto Mesh Gneration", ID_UNDOGEN
END
POPUP "&View"
BEGIN
@ -2256,6 +2279,7 @@ BEGIN
MENUITEM "Group Colour", ID_IGPC
END
MENUITEM "Map Options", ID_MAPOPD
MENUITEM "Force Direct Draw", ID_DDRAW
END
POPUP "&Help"
BEGIN
@ -2269,7 +2293,7 @@ BEGIN
MENUITEM "Set Type by Level", ID_SETTYPLEV
MENUITEM "Form a complex line of elements", ID_Complex
MENUITEM "Interpolate Map File for Stress File", ID_GETSTRESSFIL
MENUITEM "Smooth Mesh to Map Contours", ID_SMOOTHMAP
MENUITEM "Smooth Map Contours", ID_SMOOTHMAP
MENUITEM "Smooth Mesh Using Reversal", ID_RVSDIAG
MENUITEM "Remove Elements Outside Outline", ID_TESTOUT
MENUITEM "Input Element Load file", ID_LOADELTLD
@ -2404,5 +2428,5 @@ END
//*WI* FORTSAVE 1
//*WI* FILENAME D.INC
//*WI* FMODNAME
//*WI* LASTTYPE 2
//*WI* LASTRES 67
//*WI* LASTTYPE 1
//*WI* LASTRES 1

@ -2,7 +2,14 @@
! routine to test for and reverse diagonals
USE BLK1MOD
USE BLK2MOD
INCLUDE 'BFILES.I90'
REAL IGrDistanceLine
dist(n1,n2)=sqrt((xusr(n1)-xusr(n2))**2+(yusr(n1)-yusr(n2))**2)
! save current file
IFILOUT=IACTVFIL+50
CALL WRTFIL(IFILOUT)
! fill midsides
CALL FILM(1)
@ -90,6 +97,7 @@
! test if they are equal height
IF(WD(N3) .EQ. WD(N4) .or. ABS(WD(N3) -WD(N4)) .LT. ABS(WD(N1)-WD(N2))) THEN
! if so reverse connections
if(dist(n1,n2)*1.5 .lt. dist(n3,n4)) go to 500
KCOUNT=KCOUNT+1
WRITE(160,*) 'RV1',KCOUNT,NEL1,NEL2,N1,N2,N3,N4
CALL REVERS(NEL1,NEL2)
@ -99,6 +107,7 @@
! test if N4 closer or equal to N3 than N1 or N2
IF(ABS(WD(N4) - WD(N3)) .LT. ABS(WD(N1) - WD(N3)) .OR. ABS(WD(N4) - WD(N3)) .LT. ABS(WD(N2) - WD(N3))) THEN
! if so reverse connections
if(dist(n1,n2)*1.5 .lt. dist(n3,n4)) go to 500
KCOUNT=KCOUNT+1
WRITE(160,*) 'RV2',KCOUNT,NEL1,NEL2,N1,N2,N3,N4
CALL REVERS(NEL1,NEL2)

@ -1,4 +1,4 @@
REAL*8 XS,YS,TXSCAL
INTEGER IRGB
COMMON /TXFRM/ XS, YS, TXSCAL,IRGB
INTEGER IRGB,IDDSW
COMMON /TXFRM/ XS, YS, TXSCAL,IRGB,IDDSW

@ -1083,7 +1083,8 @@
DO 25 K=1,NCNR
N = NOP(J,K)
!
IF (N .EQ. 0 .OR. CORD(N,1) .LT. VDX) GOTO 25
IF (N .EQ. 0) GO TO 25
IF (CORD(N,1) .LT. VDX) GOTO 25
! !
IF (NCN .NE. 5 .OR. K .LT. 5) THEN
IF (MOD(K,2) .EQ. 1) THEN

@ -413,7 +413,10 @@
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
INCLUDE 'BFILES.I90'
DATA IHAND1,IHAND2/0,0/
! DATA IHAND1,IHAND2/0,0/
INTEGER :: iw,ih,ihandle,ient,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
common /hands/ ihandle,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
XBKMN=((BFMINMAX(I,1)+XS)/TXSCAL)
XBKMX=((BFMINMAX(I,3)+XS)/TXSCAL)
YBKMN=((BFMINMAX(I,2)+YS)/TXSCAL)
@ -493,7 +496,11 @@
CALL WBitMapCreate(IHAND2,IX2PIX,IY2PIX)
CALL IGrSelect(DrawBitmap,IHAND2)
CALL WBitMapPutPart(IHAND1,0,IXLPIX,IYLPIX,IXMPIX,IYMPIX)
IF(IDDSW .EQ. 1) THEN
CALL IGrSelect(DrawWin)
ELSE
CALL IGrSelect(DrawBitmap,IHANDLE)
ENDIF
IERR = InfoError(LastError)
! WRITE(90,*) 'ERROR SELECT DRAW', IERR
CALL WBitmapPut(IHAND2,1,1,IXPM,IYPX,IXPX,IYPM)
@ -672,12 +679,19 @@
CALL WDialogShow(-1,-1,0,Modal)
ierr=infoerror(1)
DO
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
call wdialogGetradiobutton(idf_radio1,iactvfil)
ENDIF
write(90,*) 'Selected iactvfil', iactvfil
RETURN
ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
RETURN
ENDIF
ENDDO
END
subroutine plotcr(x,y,siz)
CALL PLOTT(x-siz/2.,y,3)
@ -687,4 +701,29 @@
return
end
SUBROUTINE OUTJPGW(FNAME,INFO)
CHARACTER(LEN=255) :: FNAME
INTEGER INFO(3)
INCLUDE 'TXFRM.COM'
REAL HSIZE
COMMON /SSIZE/ HSIZE
XR=HSIZE*TXSCAL-XS
YT=8.0*TXSCAL-YS
XSIZ=HSIZE*TXSCAL/FLOAT(INFO(2))
YSIZ=-8*TXSCAL/FLOAT(INFO(3))
OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED')
WRITE(104,*) XSIZ
WRITE(104,*) ' 0.0'
WRITE(104,*) ' 0.0'
WRITE(104,*) YSIZ
WRITE(104,*) -XS
WRITE(104,*) YT
CLOSE(104)
RETURN
END

@ -0,0 +1,239 @@
SUBROUTINE ADDMESHT
USE BLK1MOD
USE WINTERACTER
INCLUDE 'BFILES.I90'
INCLUDE 'TXFRM.COM'
INTEGER OUTPOL,TWO,ZERO,IFILOUT
INTEGER NTRIAN(5000,2),ICT
REAL XMAP1(5000),YMAP1(5000)
CHARACTER*1 ANSW(10),ANS
CHARACTER(LEN=80) :: DATAIN,OPTIONS
LOGICAL EXISTS
DATA ANSW/' ',' ',' ',' ',' ','b','n','z','r','q'/
do k=1,80
options(k:k)=' '
enddo
TWO=2
ZERO=0
OUTPOL=23
ICT=0
! add headers
NHTPSV=NHTP
NMESSSV=NMESS
NBRRSV=NBRR
NHTP=0
NMESS=48
NBRR=5
call hedr
! go and get points to form outline
200 CALL xyloc(XTEMP,YTEMP,ans,IBOX)
siz=0.1
call drawcr(xtemp,ytemp,siz)
IF(IRMAIN .EQ. 1) RETURN
!
IF(ANS .EQ. 'c') THEN
if(ibox .eq. 0) go to 400
I=IBOX
ANS=ANSW(I)
ENDIF
IF(ANS .EQ. 'b') THEN
ICT=ICT-1
GO TO 200
ELSEIF(ANS .EQ. 'n') THEN
GO TO 500
ELSEIF(ANS .EQ. 'q') THEN
RETURN
ENDIF
400 ICT=ICT+1
XMAP1(ICT) = XTEMP*TXSCAL - XS
YMAP1(ICT) = YTEMP*TXSCAL - XS
IF(ICT .GT. 1) THEN
NTRIAN(ICT-1,1)=ICT-1
NTRIAN(ICT-1,2)=ICT
ENDIF
GO TO 200
500 CONTINUE
NTRIAN(ICT,1)=ICT
NTRIAN(ICT,2)=1
! write current data to a scratch file for later addition
IF(IACTVFIL .GT. 0) THEN
CALL WRTFIL(50)
IFILOUT=IACTVFIL+50
CALL WRTFIL(IFILOUT)
CALL ZEROOUT
IACTVFIL=ITOTFIL
ELSE
IACTVFIL=1
ENDIF
! clear screen
CALL clscrn
! form TRIANG file
OPEN(OUTPOL,FILE='TEST.POLY', STATUS='UNKNOWN')
WRITE(OUTPOL,*) ICT,TWO,ZERO,ZERO
DO K=1,ICT
WRITE(OUTPOL,*) K,XMAP1(K),YMAP1(K)
ENDDO
WRITE(OUTPOL,*) ICT,ZERO
DO J=1, ICT
WRITE(OUTPOL,*) J,ntrian(J,1),ntrian(J,2)
ENDDO
WRITE(OUTPOL,*) ZERO
FLUSH (OUTPOL)
REWIND (OUTPOL)
CLOSE (OUTPOL)
! 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)
IIN=10
OPEN(IIN,FILE='TEST.1.ELE', STATUS='OLD')
write(155,*) 'going to get newfile'
CALL GETNEWFIL(IIN,0,1,-1)
IADD=50+iactvfil+1
CALL RDTOCLIP(IADD)
IF(IADD .EQ. 51) THEN
write(90,*) 'finished addmesh'
NHTP=NHTPSV
NMESS=NMESSSV
NBRR=NBRRSV
call hedr
ELSE
CALL ADDMESH(0)
NHTP=NHTPSV
NMESS=NMESSSV
NBRR=NBRRSV
call hedr
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
! get new mesh
! add meshes together
RETURN
END
SUBROUTINE UNDOGEN
USE BLK1MOD
ALLOCATABLE NODETRAN(:)
DATA VDX9/-9.E9/
! Loop through nodes assigning new number and adding to list
IF(.NOT. ALLOCATED(NODETRAN)) ALLOCATE (NODETRAN(maxp))
CALL ZEROOUT
IADD=50
CALL RDTOCLIP(IADD)
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
! 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 RESCAL
CALL HEDR
RETURN
END

@ -0,0 +1,307 @@
SUBROUTINE ADDMESHT
USE BLK1MOD
USE WINTERACTER
INCLUDE 'BFILES.I90'
INCLUDE 'TXFRM.COM'
INTEGER OUTPOL,TWO,ZERO,IFILOUT
INTEGER NTRIAN(5000,2),ICT
REAL XMAP1(5000),YMAP1(5000)
CHARACTER*1 ANSW(10),ANS
CHARACTER(LEN=80) :: DATAIN,OPTIONS
CHARACTER(LEN=96) :: LOCDIR
LOGICAL EXISTS
DATA ANSW/' ',' ',' ',' ',' ','b','n','z','r','q'/
do k=1,80
options(k:k)=' '
enddo
TWO=2
ZERO=0
OUTPOL=23
ICT=0
! add headers
NHTPSV=NHTP
NMESSSV=NMESS
NBRRSV=NBRR
NHTP=0
NMESS=48
NBRR=5
call hedr
! go and get points to form outline
200 CALL xyloc(XTEMP,YTEMP,ans,IBOX)
siz=0.1
call drawcr(xtemp,ytemp,siz)
IF(IRMAIN .EQ. 1) RETURN
!
IF(ANS .EQ. 'c') THEN
if(ibox .eq. 0) go to 400
I=IBOX
ANS=ANSW(I)
ENDIF
IF(ANS .EQ. 'b') THEN
ICT=ICT-1
GO TO 200
ELSEIF(ANS .EQ. 'n') THEN
GO TO 500
ELSEIF(ANS .EQ. 'q') THEN
RETURN
ENDIF
400 ICT=ICT+1
XMAP1(ICT) = XTEMP*TXSCAL - XS
YMAP1(ICT) = YTEMP*TXSCAL - YS
IF(ICT .GT. 1) THEN
NTRIAN(ICT-1,1)=ICT-1
NTRIAN(ICT-1,2)=ICT
ENDIF
GO TO 200
500 CONTINUE
NTRIAN(ICT,1)=ICT
NTRIAN(ICT,2)=1
! write current data to a scratch file for later addition
IFILOUT=IACTVFIL+50
CALL WRTFIL(IFILOUT)
!
! IF(IACTVFIL .GT. 0) THEN
! CALL WRTFIL(50)
! IFILOUT=IACTVFIL+50
! CALL WRTFIL(IFILOUT)
! CALL ZEROOUT
! IACTVFIL=ITOTFIL
! ELSE
! IACTVFIL=1
! ENDIF
!
!! clear screen
! CALL clscrn
! form TRIANG file
OPEN(OUTPOL,FILE='TEST.POLY', STATUS='UNKNOWN')
WRITE(OUTPOL,*) ICT,TWO,ZERO,ZERO
DO K=1,ICT
WRITE(OUTPOL,*) K,XMAP1(K),YMAP1(K)
ENDDO
WRITE(OUTPOL,*) ICT,ZERO
DO J=1, ICT
WRITE(OUTPOL,*) J,ntrian(J,1),ntrian(J,2)
ENDDO
WRITE(OUTPOL,*) ZERO
FLUSH (OUTPOL)
REWIND (OUTPOL)
CLOSE (OUTPOL)
! OPTIONS = ' -pqa5000V TEST'
OPTIONS(1:3) = ' -p'
nct=3
iswq=1
iswy=0
id1=100
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
INQUIRE (FILE = "C:\Program Files\RMA\TRIANGLE.EXE", EXIST = exists)
if(.not. exists) then
INQUIRE (FILE = "TRIANGLE.EXE", EXIST = exists)
if(.not. exists) then
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'TRIANGLE is not available in '//CHAR(13)//&
'C:\Program Files\RMA\ directory'//CHAR(13)//'Do you wish to define directory?'&
,'WARNING TRIANGLE IS NOT AVAILABLE')
! If answer 'No', return
!
IF (WInfoDialog(4).EQ.2) return
CALL GETDIR(LOCDIR)
else
LOCDIR(1:8)='TRIANGLE'
! WRITE(155,*) LOCDIR
RESULT= RUNQQ(LOCDIR, OPTIONS)
GO TO 600
endif
endif
RESULT= RUNQQ("C:\Program Files\RMA\TRIANGLE", OPTIONS)
! RESULT= RUNQQ("TRIANGLE", OPTIONS)
600 IIN=10
OPEN(IIN,FILE='TEST.1.ELE', STATUS='OLD')
! write(155,*) 'going to get newfile'
CALL GETNEWFIL(IIN,0,-1,-1)
!IADD=50+iactvfil+1
!CALL RDTOCLIP(IADD)
!
!IF(IADD .EQ. 51) THEN
!write(90,*) 'finished addmesh'
!
!NHTP=NHTPSV
!NMESS=NMESSSV
!NBRR=NBRRSV
!call hedr
!ELSE
! CALL ADDMESH(0)
NHTP=NHTPSV
NMESS=NMESSSV
NBRR=NBRRSV
call hedr
CALL PLOTOT(0)
! 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
! get new mesh
! add meshes together
RETURN
END
SUBROUTINE UNDOGEN
USE BLK1MOD
INCLUDE 'BFILES.I90'
ALLOCATABLE NODETRAN(:)
DATA VDX9/-9.E9/
! Loop through nodes assigning new number and adding to list
IF(.NOT. ALLOCATED(NODETRAN)) ALLOCATE (NODETRAN(maxp))
CALL ZEROOUT
IADD=50+IACTVFIL
CALL RDTOCLIP(IADD)
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
! 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 RESCAL
CALL HEDR
RETURN
END
SUBROUTINE GETDIR(LOCDIR)
use winteracter
implicit none
include 'D.inc'
INCLUDE 'BFILES.I90'
!
! Declare window-type and message variables
!
TYPE(WIN_STYLE) :: WINDOW
TYPE(WIN_MESSAGE) :: MESSAGE
CHARACTER*96 LOCDIR
integer ierr,K,KL
call wdialogload(IDD_GETFL)
ierr=infoerror(1)
CALL WDialogPutString(idf_string1,locdir)
! LOCDIR='C:\Users\RMA5440\TRIANGLE\TRIANGLE'
CALL WDialogSelect(IDD_GETFL)
ierr=infoerror(1)
CALL WDialogShow(-1,-1,0,Modal)
ierr=infoerror(1)
do
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
CALL WDialogGetString(idf_string1,locdir)
DO K=96,1,-1
KL=K
IF(LOCDIR(K:K) .NE. ' ') GO TO 200
ENDDO
LOCDIR(1:8)='TRIANGLE'
RETURN
200 CONTINUE
LOCDIR(KL+1:KL+9)='\TRIANGLE'
WRITE(90,*) LOCDIR
RETURN
endif
enddo
END

@ -6,6 +6,7 @@
USE WINTERACTER
USE BLK1MOD
USE BLK2MOD
INCLUDE 'D.INC'
@ -16,10 +17,17 @@
CALL RDTOCLIP(IADD)
IF(ISWT .EQ. 1) THEN
CALL OUTLINES(1)
ISWT1=0
CALL MERGEMESH1(ISWT1)
! IF(NOUTLST(2) .EQ. 0) THEN
ISWT2=1
! ELSE
! ISWT2=0
! ENDIF
CALL MERGEMESH1(ISWT1,ISWT2)
write(90,*) 'finished mergemesh1'
CALL MERGEMESH
IF(ISWT2 .EQ. 0) CALL MERGEMESH
! CALL MERGEMESH
write(90,*) 'finished mergemesh'
flush(90)
ENDIF
@ -52,14 +60,14 @@
REWIND IUNIT
READ(IUNIT) TITLE,NPSTO(1),NESTO(1)
! WRITE(90,*) 'IN RDTOCLIP',IUNIT
! WRITE(90,*) 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
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
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))
@ -161,22 +169,62 @@
RETURN
END
SUBROUTINE MERGEMESH1(ISWT1)
SUBROUTINE MERGEMESH1(ISWT1,ISWT2)
USE BLK1MOD
USE BLK2MOD
USE WINTERACTER
! INCLUDE 'BLK1.COM'
REAL*8 ELXMIN,ELXMAX,ELYMIN,ELYMAX,XLC,YLC,XXX,YYY
LOGICAL LSTAT
ALLOCATABLE ELXMIN(:),ELXMAX(:),ELYMIN(:),ELYMAX(:),KEY(:),NKEY(:)
DIMENSION XOUT1(1000),YOUT1(1000)
IF(.NOT. ALLOCATED(ELXMIN)) &
ALLOCATE (ELXMIN(MAXE),ELXMAX(MAXE),ELYMIN(MAXE),ELYMAX(MAXE),KEY(MAXE),NKEY(MAXP))
IF(ISWT2 .EQ. 0) GO TO 110
! first eliminate any elements inside outline
CALL KCONST(0)
NKEP=0
DO K=1,10
IF(NOUTLST(K) .LE. 0) THEN
DO J=1,NPSTO(1)
XXXX=XUSRSTO(J,1)
YYYY=YUSRSTO(J,1)
LSTAT=IGrInsidePolygon(XOUT(1,K),YOUT(1,K),-NOUTLST(K),XXXX,YYYY)
IF(LSTAT) THEN
NKEP(J)=1
ENDIF
ENDDO
ENDIF
ENDDO
DO K=1,10
IF(NOUTLST(K) .GT. 0) THEN
DO J=1,NPSTO(1)
IF(NKEP(J) .EQ. 1) CYCLE
XXXX=XUSRSTO(J,1)
YYYY=YUSRSTO(J,1)
! WRITE(155,*) J,XXXX,YYYY
LSTAT=IGrInsidePolygon(XOUT(1,K),YOUT(1,K),NOUTLST(K),XXXX,YYYY)
! WRITE(155,*) J,LSTAT
IF(LSTAT) THEN
DO L=1,NDELM(J)
NCAN=NECON(J,L)
CALL DELEM(NCAN)
ENDDO
ENDIF
ENDDO
ENDIF
100 CONTINUE
ENDDO
IF(ISWT2 .EQ. 1) RETURN
! First sort coordinates for min of element connection
! List all limiting values
110 CONTINUE
DO N=1,NE
IF(IMAT(N) .GT. 0) THEN
ELXMIN(N)=XUSR(NOP(N,1))
@ -258,7 +306,8 @@
IF(NOP(N,7) .EQ. 0) THEN
NCN=6
IT=2
ELSEIF(NOP(N,6) .EQ. 0) THEN
ENDIF
IF(NOP(N,6) .EQ. 0) THEN
GOTO 350
ENDIF
! Test for point inside an element
@ -439,25 +488,39 @@
SUBROUTINE MERGEMESH
USE BLK1MOD
LOGICAL LSTAT
! 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)
IF(IMATSTO(N,1) .GT. 900 .AND. IMATSTO(N,1) .LT. 904) THEN
X1=XUSRSTO(NOPSTO(N,1,1),1)
Y1=YUSRSTO(NOPSTO(N,1,1),1)
CALL CHECKIN(X1,Y1,LSTAT)
IF(ISTATUS .EQ. 5) THEN
CALL DELEM(N)
GO TO 400
ENDIF
GO TO 400
ENDIF
! loop on sides
DO M=1,7,2
N1=NOPSTO(N,M,1)
IF(M .EQ. 3 .AND. NOPSTO(N,5,1) .EQ. 0) GO TO 400
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
IF(NKEP(N1) .EQ. 1 .AND. NKEP(N2) .EQ. 1) GO TO 380
! Now loop trough existing elements
@ -465,6 +528,7 @@
IF(IMAT(I) .NE. 0) THEN
DO J=1,7,2
M1=NOP(I,J)
IF(J .EQ. 3 .AND. NOP(I,5) .EQ. 0) GO TO 360
IF(M1 .GT. 0) THEN
IF((J .EQ. 5 .AND. NOP(I,7) .EQ. 0) .OR. (J .EQ. 7)) THEN
M2=NOP(I,1)
@ -488,8 +552,10 @@
ENDIF
ENDDO
ENDIF
360 CONTINUE
ENDDO
ENDIF
380 CONTINUE
ENDDO
ENDIF
400 CONTINUE
@ -497,3 +563,66 @@
RETURN
END
SUBROUTINE CHECKIN(X1,Y1,LSTAT)
USE BLK1MOD
LOGICAL LSTAT
DIMENSION XP(4),YP(4)
! Now loop trough existing elements
DO I=1,NE
IF(IMAT(I) .NE. 0) THEN
JJ=0
DO J=1,7,2
INODE=NOP(I,J)
IF(INODE .GT. 0) THEN
JJ=JJ+1
XP(JJ)=XUSR(INODE)
YP(JJ)=YUSR(INODE)
ENDIF
ENDDO
LSTAT=IGrInsidePolygon(XP,YP,JJ,X1,Y1)
IF(LSTAT) RETURN
ENDIF
ENDDO
RETURN
END
SUBROUTINE KCONST(isw1)
!
! ESTABLISH ELEMENT CONNECTED TO ELEMENT TABLE
!
USE BLK1MOD
USE BLK2MOD
! INCLUDE 'BLK1.COM'
! INCLUDE 'BLK2.COM'
!
! INITIALIZE
!
NCM=11
DO 200 J=1,NCM
DO 200 N=1,NPSTO(1)
200 NECON(N,J)=0
DO 230 N=1,NPSTO(1)
230 NDELM(N)=0
!
! FORM TABLE OF ELEMENTS CONNECTED TO EACH NODE
!
DO 300 M=1,NESTO(1)
IF(IMATSTO(M,1) .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=NOPSTO(M,K,1)
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
RETURN
END

@ -0,0 +1,40 @@
SUBROUTINE backc(ient)
use winteracter
implicit none
include 'd.inc'
!
! Declare window-type and message variables
!
TYPE(WIN_STYLE) :: WINDOW
TYPE(WIN_MESSAGE) :: MESSAGE
INTEGER :: iw,ih,ihandle,ient,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM,IRGB
common /hands/ ihandle,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
if(ient .eq. 1) then
iw=WinfoWindow(WindowWidth)
ih=WinfoWindow(WindowHeight)
WRITE(90,*) 'IW,IH',IW,IH
IF(IHANDLE .EQ. 0) THEN
IRGB = WRGB(220,220,220)
call WBitmapCreate(ihandle,iw,ih,irgb)
call IGrSelect(DrawBitmap,ihandle)
! CALL WBitmapPut(IHAND2,1,1,IXPM,IYPX,IXPX,IYPM)
ELSE
call IGrSelect(DrawBitmap,ihandle)
! CALL WBitmapPut(IHAND2,1,1,IXPM,IYPX,IXPX,IYPM)
ENDIF
return
else
call IGrSelect(DrawWin)
call WBitmapPut(ihandle,0,0)
call WBitmapDestroy(ihandle)
ihandle=0
endif
return
end

@ -74,6 +74,7 @@
CALL ADD999(ISWT9,NELC)
! WRITE(150,*) 'BACK FROM ADD999'
! FLUSH(150)
CALL HEDR
RETURN
ENDIF

Loading…
Cancel
Save