iank
/
RMAGEN
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Version 83d plus merge demo

Browse Source
master
IanKing 8 years ago
parent 0c8e29e340
commit 3ff4dbed38
50 changed files with 2461 additions and 179 deletions
Show Stats Download Patch File Download Diff File

BIN
MERGEDEMO/MERGEDEMO.MP4
View File

Binary file not shown.

31
MERGEDEMO/MERGEDEMO.html
Unescape Escape View File

@ -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>

BIN
MERGEDEMO/MERGEDEMO_First_Frame.png
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 792 KiB

36
MERGEDEMO/MERGEDEMO_config.xml
Unescape Escape View File

@ -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>

BIN
MERGEDEMO/MERGEDEMO_controller.swf
View File

Binary file not shown.

28
MERGEDEMO/MERGEDEMO_embed.css
Unescape Escape View File

@ -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%;
}
}

75
MERGEDEMO/MERGEDEMO_player.html
Unescape Escape View File

@ -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>

BIN
MERGEDEMO/playerProductInstall.swf
View File

Binary file not shown.

38
MERGEDEMO/scripts/config_xml.js
Unescape Escape View File

@ -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>';

58
MERGEDEMO/scripts/techsmith-smart-player.min.js vendored
View File

File diff suppressed because one or more lines are too long

1
MERGEDEMO/skins/overlay/spritesheet.min.css vendored
View File

File diff suppressed because one or more lines are too long

BIN
MERGEDEMO/skins/overlay/spritesheet.png
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 42 KiB

1
MERGEDEMO/skins/overlay/techsmith-smart-player.min.css vendored
View File

File diff suppressed because one or more lines are too long

22
RMAGEN/RMAGEN.common.settings
Unescape Escape View File

@ -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>

9
RMAGEN/fort.155
Unescape Escape View File

@ -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

BIN
RMAGEN/test.rm1
View File

Binary file not shown.

130
Untitled.camproj
Unescape Escape View File

@ -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>

BIN
capture-3.trec
View File

Binary file not shown.

6
src/BLK1.f90
Unescape Escape View File

@ -12,7 +12,7 @@
INTEGER*2 INSKP,IESKP,INEW,NCORN,IJUN,ISWTAGN,iswtintp INTEGER*2 INSKP,IESKP,INEW,NCORN,IJUN,ISWTAGN,iswtintp
!IPK MAY02 INTEGER*2 NOP,IMAT,IEM,NEF,NEFLAG,LINTYP,LAY !IPK MAY02 INTEGER*2 NOP,IMAT,IEM,NEF,NEFLAG,LINTYP,LAY
INTEGER*2 IMAT,LINTYP,LAY,IRTYP 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,CMAP,XMAP,YMAP,pscale,xref,yref
REAL*8 CORD,XUSR,YUSR,XC,YC,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 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& ,IIN, IBAK, LUNIT,IGIN,IS11,IMP,IGFG,ISWAP,ITRIAN&
,klint,jlint,lmpnam,IDELV,nmapf,NSIGF,NPUNDO,NEUNDO,nefsav,nesav& ,klint,jlint,lmpnam,IDELV,nmapf,NSIGF,NPUNDO,NEUNDO,nefsav,nesav&
,xadded,yadded,icolsw,rad,colint,ielvsw,ISWTAGN,iswtintp,eref,igrp,igrpout,MAXIGRP& ,xadded,yadded,icolsw,rad,colint,ielvsw,ISWTAGN,iswtintp,eref,igrp,igrpout,MAXIGRP&
,JPTSB ,JPTSB,ILINEL
!IPK MAR02 ADD BS1 !IPK MAR02 ADD BS1
!IPK FEB02 ADD LOCK !IPK FEB02 ADD LOCK
!IPK MAY01 ADD NODDEL AND IELDEL !IPK MAY01 ADD NODDEL AND IELDEL
@ -111,7 +111,7 @@
ALLOCATABLE ICN(:) ALLOCATABLE ICN(:)
ALLOCATABLE ICONNCT(:,:) ALLOCATABLE ICONNCT(:,:),NKEP(:)
ALLOCATABLE IOUTLST(:,:),NOUTLST(:),XOUT(:,:),YOUT(:,:) ALLOCATABLE IOUTLST(:,:),NOUTLST(:),XOUT(:,:),YOUT(:,:)

6
src/D.INC
Unescape Escape View File

@ -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. ! This file is generated by the Winteracter resource editor.
! It should not be edited manually. It is also not advisable to load this ! 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_ASSIGNELTLD = 40144
INTEGER, PARAMETER :: ID_FILLTR = 40145 INTEGER, PARAMETER :: ID_FILLTR = 40145
INTEGER, PARAMETER :: IDD_FTRIAN = 167 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

30
src/EVENT.F90
Unescape Escape View File

@ -833,8 +833,16 @@
CALL OUTORG(FNAMEB) CALL OUTORG(FNAMEB)
if(sub .eq. 'jpg' .or. sub .eq. 'png' .or. sub .eq. 'pcx' .or. sub .eq. 'bmp') then if(sub .eq. 'jpg' .or. sub .eq. 'png' .or. sub .eq. 'pcx' .or. sub .eq. 'bmp') then
! call doplot(0) ! call doplot(0)
CALL WGrSaveImageOptions(31,100)
CALL WGrSaveImageOptions(32,150)
call igrsaveimage(fname) call igrsaveimage(fname)
call doplot(0) 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 CALL HEDR
go to 100 go to 100
endif endif
@ -1067,6 +1075,10 @@
IACTVFIL=IOLDACT IACTVFIL=IOLDACT
CALL ADDTOMESH(IFILADD,1) CALL ADDTOMESH(IFILADD,1)
GO TO 100 GO TO 100
!ipk sep16 ADD MESH FROM POINTS
CASE (ID_ADDMESHTR)
CALL ADDMESHT
GO TO 100
!ipk may03 !ipk may03
CASE (ID_TRIANG) ! add a triangle of elements CASE (ID_TRIANG) ! add a triangle of elements
CALL ADDTRIANG CALL ADDTRIANG
@ -1235,6 +1247,12 @@
CALL REATTACH CALL REATTACH
GO TO 101 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) CASE (ID_COMPLEX)
CALL GNODE(2) CALL GNODE(2)
GO TO 101 GO TO 101
@ -1346,6 +1364,7 @@
CASE (ID_SMOOTHMAP) CASE (ID_SMOOTHMAP)
CALL SMOOTHMP CALL SMOOTHMP
GO TO 101 GO TO 101
CASE (ID_DRAG) CASE (ID_DRAG)
MENUS=8 MENUS=8
iflag='d' iflag='d'
@ -1702,11 +1721,20 @@
GO TO 100 GO TO 100
CASE (ID_UNDOS) CASE (ID_UNDOS)
IFLAG='U' 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) CASE (ID_GOUTLIN)
CALL GOUTLIN CALL GOUTLIN
GO TO 100 GO TO 100
CASE (ID_XOUTLIN) CASE (ID_XOUTLIN)
CALL OUTLINES CALL OUTLINES(0)
GO TO 100 GO TO 100
END SELECT END SELECT

47
src/EXP.rc
Unescape Escape View File

@ -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

39
src/FILLTR.F90
Unescape Escape View File

@ -4,6 +4,7 @@
USE BLKMAP USE BLKMAP
CHARACTER(LEN=256) :: FILTER,FNAME CHARACTER(LEN=256) :: FILTER,FNAME
CHARACTER(LEN=80) :: DATAIN,OPTIONS CHARACTER(LEN=80) :: DATAIN,OPTIONS
CHARACTER(LEN=96) :: LOCDIR
CHARACTER(LEN=3) :: SUB CHARACTER(LEN=3) :: SUB
INTEGER INOUTL,NOUTL,OUTPOL INTEGER INOUTL,NOUTL,OUTPOL
INTEGER NTRIAN(5000,2),TWO,ZERO,ntrans(5000) INTEGER NTRIAN(5000,2),TWO,ZERO,ntrans(5000)
@ -168,9 +169,9 @@
! OPTIONS = ' -pqa5000V TEST' ! OPTIONS = ' -pqa5000V TEST'
OPTIONS(1:3) = ' -p' OPTIONS(1:3) = ' -p'
nct=3 nct=3
! iswq=1 iswq=1
! iswy=0 iswy=0
! id1=105 id1=100
CALL PANELFILLT(ISWQ,ISWY,ID1) CALL PANELFILLT(ISWQ,ISWY,ID1)
IF(ISWQ .EQ. 1) THEN IF(ISWQ .EQ. 1) THEN
@ -202,9 +203,29 @@
open(77,file= 'test.1.poly') open(77,file= 'test.1.poly')
close(77,status='DELETE') close(77,status='DELETE')
ENDIF 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("C:\Program Files\RMA\TRIANGLE", OPTIONS)
! RESULT= RUNQQ("TRIANGLE", OPTIONS) ! RESULT= RUNQQ("TRIANGLE", OPTIONS)
600 CONTINUE
IF(IMAPIN .EQ. 1) THEN IF(IMAPIN .EQ. 1) THEN
READ(113) XMAP,YMAP READ(113) XMAP,YMAP
CLOSE (113) CLOSE (113)
@ -239,12 +260,12 @@
! real :: ! real ::
! character*3 :: ! character*3 ::
DATA ITIME/0/ DATA ITIME/0/
IF(ITIME .EQ. 0) THEN ! IF(ITIME .EQ. 0) THEN
ITIME=1 ! ITIME=1
N1=1 ! N1=1
N2=0 ! N2=0
N3=100 ! N3=100
ENDIF ! ENDIF
call wdialogload(IDD_FTRIAN) call wdialogload(IDD_FTRIAN)
ierr=infoerror(1) ierr=infoerror(1)

757
src/GETNEWFIL - Copy.F90
Unescape Escape View File

@ -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

48
src/GETNEWFIL.F90
Unescape Escape View File

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

31
src/GETWT.F90
Unescape Escape View File

@ -6,8 +6,26 @@
! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK1.COM'
DIMENSION WGT(8) DIMENSION WGT(8)
REAL*8 XMINL,YMINL,XMAXL,YMAXL
! data itime/0/ ! 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 ! 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))) 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))) 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))) 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 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 go to 250
endif endif
! IF(M .EQ. 6316) WRITE(156,*) 'PASSED X AND Y TEST',N
DISQ=(XUSR(M)-XCEN(N))**2+(YUSR(M)-YCEN(N))**2 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(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 ! We have a candidate
CALL GETWT(N,XUSR(M),YUSR(M),WGT,1) CALL GETWT(N,XUSR(M),YUSR(M),WGT,1)
DO K=1,3 DO K=1,3
IF(WGT(K) .LT. -1E-4 .OR. WGT(K) .GT. 1.0001) THEN 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 GO TO 250
ENDIF ENDIF
ENDDO ENDDO

9
src/HEDR.F90
Unescape Escape View File

@ -27,7 +27,7 @@
common /cols/ ibakk,icolr,iblkk common /cols/ ibakk,icolr,iblkk
CHARACTER*8 HED(10),HEAD(10,16) CHARACTER*8 HED(10),HEAD(10,16)
CHARACTER*47 MESOUT,MESS(47) CHARACTER*47 MESOUT,MESS(48)
!ipk lan01 add to MESS !ipk lan01 add to MESS
!ipk jan99 add to MESS !ipk jan99 add to MESS
!ycw mar97 change HEADR(5,5) to HEADR(6,7) !ycw mar97 change HEADR(5,5) to HEADR(6,7)
@ -37,7 +37,7 @@
DIMENSION X(5),Y(5),IRV(10) DIMENSION X(5),Y(5),IRV(10)
!IPk feb 94 this statement reconstructed !IPk feb 94 this statement reconstructed
!IPK OCT 96 THIS STATMENT DONE AGAIN !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 'cc(l)ine',' csec(t)',' (z)oom ',' (r)draw',' (q)uit ','(n)od bk',& !1/2
' (e)l bk',& ' (e)l bk',&
're(f)ine','spli(t) ','c(l)ean ',5*' ','pr(l)st ','get(g)rp'& ! 2/3 '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 '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 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 ,'Enter 1-d cross-section bed slope','Click at location to define outline point'& ! 44 45
,' ','Click two locations to define move'/ ! 46 47 ,' ','Click two locations to define move'& ! 46 47
! last line Jan 2001 ,'Click locations to form outline'/ ! 48
! last line Jan 2001
! line above added Jan 1999 ! line above added Jan 1999
DATA HEADR /& DATA HEADR /&
' (q)uit ',5*' ',& ' (q)uit ',5*' ',&

3
src/HELPS.F90
Unescape Escape View File

@ -30,8 +30,9 @@
Filter='HTM file -- *.htm|*.htm|' 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 IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
GO TO 200 GO TO 200
ELSE ELSE

4
src/INITSIZ.f90
Unescape Escape View File

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

26
src/INOUT.F90
Unescape Escape View File

@ -206,6 +206,8 @@
enddo enddo
if(abs(wdmin) .gt. abs(wdmax)) then if(abs(wdmin) .gt. abs(wdmax)) then
temp=log10(abs(wdmin)) temp=log10(abs(wdmin))
elseif(wdmax .eq. 0.) then
temp=2.5
else else
temp=log10(abs(wdmax)) temp=log10(abs(wdmax))
endif endif
@ -2288,7 +2290,7 @@
IF(IECHG .EQ. 0) IEM(J)=J IF(IECHG .EQ. 0) IEM(J)=J
WRITE(IOF,5004) & WRITE(IOF,5004) &
& J, (NOP(J,K),K=1,8), IMAT(J),THTA(J) & 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 ENDIF
ENDDO ENDDO
DO J=1,NP DO J=1,NP
@ -2360,13 +2362,22 @@
CHARACTER*80 ALINE CHARACTER*80 ALINE
IF(IENT .EQ. 1) THEN IF(IENT .EQ. 1) THEN
! READ(IUNIT) IDUMMY1
READ(IUNIT) TITLE,NP,NE READ(IUNIT) TITLE,NP,NE
! READ(IUNIT) IDUMMY1,IDUMMY2
READ(IUNIT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & READ(IUNIT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
! READ(IUNIT) ,IDUMMY2,IDUMMY3
READ(IUNIT) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG 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 ELSEIF(IENT .EQ. 2) THEN
! READ(IUNIT) IDUMMY4,IDUMMY5
READ(IUNIT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE) READ(IUNIT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE)
DO J=1,NE DO J=1,NE
IF(IMAT(J) .NE. 0) THEN IF(IMAT(J) .NE. 0) THEN
@ -2383,7 +2394,7 @@
ENDDO ENDDO
ELSE ELSE
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) & READ(IUNIT) &
& (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), & & (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), &
& WIDBS(J),SSO(J),BS1(J),J=1,NP) & WIDBS(J),SSO(J),BS1(J),J=1,NP)
@ -2396,20 +2407,29 @@
INEW(J) = 1 INEW(J) = 1
ENDIF ENDIF
ENDDO ENDDO
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) NLST READ(IUNIT) NLST
IF(NLST .GT. 0) THEN IF(NLST .GT. 0) THEN
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) (LLIST(J),J=1,NLST), & READ(IUNIT) (LLIST(J),J=1,NLST), &
((ILIST(J,I),I=1,LLIST(J)),J=1,NLST) ((ILIST(J,I),I=1,LLIST(J)),J=1,NLST)
ENDIF ENDIF
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) NENTRY,NLAYD,NCLM 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 IF(NENTRY .GT. 0) THEN
! READ(IUNIT) IDUMMY5,IDUMMY6
READ(IUNIT) ((NEF(I,J),J=1,3),I=1,NENTRY) READ(IUNIT) ((NEF(I,J),J=1,3),I=1,NENTRY)
ENDIF ENDIF
IF(NLAYD .GT. 0) THEN 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) READ(IUNIT) (LAY(I),I=1,NP),((WTLAY(I,J),J=1,9),I=0,NP)
ENDIF ENDIF
IF(NCLM .GT. 0) THEN IF(NCLM .GT. 0) THEN
! READ(IUNIT) IDUMMY5,IDUMMY6
! NCLM=11
READ(IUNIT) ((ICCLN(I,J),J=1,350),I=1,NCLM) READ(IUNIT) ((ICCLN(I,J),J=1,350),I=1,NCLM)
ENDIF ENDIF
ENDIF ENDIF

9
src/JOINEL.F90
Unescape Escape View File

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

1
src/LOADFIL.F90
Unescape Escape View File

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

10
src/NEWRMGN.F90
Unescape Escape View File

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

142
src/OUTLINES.F90
Unescape Escape View File

@ -1,4 +1,4 @@
SUBROUTINE OUTLINES SUBROUTINE OUTLINES(ISWT)
USE WINTERACTER USE WINTERACTER
USE BLK1MOD USE BLK1MOD
@ -10,17 +10,21 @@
CHARACTER(LEN=255) :: FNAME,FILTER CHARACTER(LEN=255) :: FNAME,FILTER
CHARACTER(LEN=4) :: SUB CHARACTER(LEN=4) :: SUB
LOGICAL OPENED REAL XCEN(10),YCEN(10),MTYP(10)
LOGICAL OPENED,LSTAT
CHARACTER*1 IFLAG,ANS(10) CHARACTER*1 IFLAG,ANS(10)
DATA ANS/' ',' ',' ',' ',' ',' ','n','z','r','q'/ DATA ANS/' ',' ',' ',' ',' ',' ','n','z','r','q'/
DATA PI2/1.5708/
IF(.NOT. ALLOCATED(ICONNCT)) THEN 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 ENDIF
IF(.NOT. ALLOCATED(XOUT)) THEN IF(.NOT. ALLOCATED(XOUT)) THEN
ALLOCATE (XOUT(5000,10),YOUT(5000,10)) ALLOCATE (XOUT(5000,10),YOUT(5000,10))
ENDIF ENDIF
NOUTLST=0
IOUTSW=2
IPOS=2
IF(ISWT .EQ. 1) GO TO 80
IOUTOUT=26 IOUTOUT=26
INQUIRE(26, OPENED=OPENED) INQUIRE(26, OPENED=OPENED)
if(.not. opened) then if(.not. opened) then
@ -73,17 +77,20 @@
ENDIF ENDIF
! !
! FORM LIST OF ELEMENT SIDES THAT ARE ON THE OUTSIDE ! FORM LIST OF ELEMENT SIDES THAT ARE ON THE OUTSIDE
80 CONTINUE
DO N=1,NP DO N=1,NP
MSN(N)=0 MSN(N)=0
ENDDO ENDDO
ILINEL=0
DO N=1,NE 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 IF(IMAT(N) .NE. 999 .AND. NCORN(N) .GT. 5 .AND. (IMAT(N) .LT. 900 .OR. IMAT(N) .GT. 903)) THEN
NCN=NCORN(N) NCN=NCORN(N)
DO K=2,NCN,2 DO K=2,NCN,2
J = NOP(N,K) J = NOP(N,K)
if(J .gt. 0) then if(J .gt. 0) then
MSN(J) = MSN(J) + 1 MSN(J) = MSN(J) + 1
ICONNCT(J,3)=N
ICONNCT(J,1)=NOP(N,K-1) ICONNCT(J,1)=NOP(N,K-1)
IF(K .EQ. NCN) THEN IF(K .EQ. NCN) THEN
ICONNCT(J,2)=NOP(N,1) ICONNCT(J,2)=NOP(N,1)
@ -92,6 +99,21 @@
ENDIF ENDIF
endif endif
ENDDO 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 ENDIF
ENDDO ENDDO
@ -101,6 +123,7 @@
JJ=0 JJ=0
DO J=1,NP DO J=1,NP
IF(MSN(J) .EQ. 1) THEN IF(MSN(J) .EQ. 1) THEN
MTYP(K)=1
! !
! THIS IS A STARTING POINT EXTRACT A CORNER NODE ! THIS IS A STARTING POINT EXTRACT A CORNER NODE
IOUTLST(K,1)=ICONNCT(J,1) IOUTLST(K,1)=ICONNCT(J,1)
@ -111,7 +134,15 @@
IOUTLST(K,2)=J IOUTLST(K,2)=J
IOUTLST(K,3)=ICONNCT(J,2) IOUTLST(K,3)=ICONNCT(J,2)
JJ=3 JJ=3
endif 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 MSN(J)=0
ICONNCT(J,1)=0 ICONNCT(J,1)=0
ICONNCT(J,2)=0 ICONNCT(J,2)=0
@ -155,7 +186,61 @@
ENDIF ENDIF
ENDIF ENDIF
ENDDO 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 ENDIF
ENDDO ENDDO
GO TO 300 GO TO 300
@ -179,13 +264,40 @@
WRITE(IOUTOUT,*) NZERO WRITE(IOUTOUT,*) NZERO
ELSE ELSE
DO L=1,NOUTLST(K) DO L=1,NOUTLST(K)
XOUT(L,K)=XUSR(IOUTLST(K,L)) IF(MTYP(K) .EQ. 1) THEN
YOUT(L,K)=YUSR(IOUTLST(K,L)) XOUT(L,K)=XUSR(IOUTLST(K,L))
WRITE(IOUTOUT,*) XOUT(L,K),YOUT(L,K) YOUT(L,K)=YUSR(IOUTLST(K,L))
ENDDO ENDIF
IF(IOUTSW .EQ. 0) THEN
WRITE(IOUTOUT,*) XOUT(L,K),YOUT(L,K)
ENDIF
ENDDO
ENDIF ENDIF
ENDIF ENDIF
ENDDO 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 RETURN
END 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

28
src/PLOTR.F90
Unescape Escape View File

@ -174,3 +174,31 @@
RETURN RETURN
END 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

51
src/PLOTR1.F90
Unescape Escape View File

@ -27,6 +27,7 @@
IFIRST=1 IFIRST=1
ENDIF ENDIF
HT=0.2 HT=0.2
! CALL CHEXIT
! !
if(imz .ne. 2) CALL CLSCRN if(imz .ne. 2) CALL CLSCRN
! !
@ -67,6 +68,28 @@
PSCALE = 1. PSCALE = 1.
XMIN = 0. XMIN = 0.
YMIN = 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 if(ipsw(4) .eq. 1) then
do j=1,ne do j=1,ne
@ -74,7 +97,6 @@
enddo enddo
endif endif
! write(90,*) 'going to drawbk',nbkfl,iswbkfl(1)
IF(NBKFL .GT. 0) THEN IF(NBKFL .GT. 0) THEN
DO I=1,NBKFL DO I=1,NBKFL
IF(ISWBKFL(I) .EQ. 1) CALL DRAWBK(I,IMZ) IF(ISWBKFL(I) .EQ. 1) CALL DRAWBK(I,IMZ)
@ -131,8 +153,10 @@
cycle cycle
endif endif
enddo enddo
if(abs(wdmin) .ge. abs(wdmax)) then if(abs(wdmin) .gt. abs(wdmax)) then
temp=log10(abs(wdmin)) temp=log10(abs(wdmin))
elseif(wdmin .eq. 0) then
temp=2.5
else else
temp=log10(wdmax) temp=log10(wdmax)
endif endif
@ -145,10 +169,10 @@
endif endif
endif endif
DO 15 J=1,NP DO 15 J=1,NP
IF(MOD(J,10) .EQ. 0) THEN ! IF(MOD(J,10) .EQ. 0) THEN
CALL CHINT(IFLAG) ! CALL CHINT(IFLAG)
IF(IFLAG .EQ. 'i') GO TO 250 ! IF(IFLAG .EQ. 'i') GO TO 250
ENDIF ! ENDIF
IF(INSKP(J) .EQ. 1) GO TO 15 IF(INSKP(J) .EQ. 1) GO TO 15
IF(CORD(J,1) .GT. 0. .AND. CORD(J,1) .LT. HSIZE) THEN 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 IF(CORD(J,2) .GT. 0. .AND. CORD(J,2) .LT. 7.5) THEN
@ -218,15 +242,15 @@
DO 20 J=1,NE DO 20 J=1,NE
XC(J)=VOID XC(J)=VOID
YC(J)=VOID YC(J)=VOID
IF(MOD(J,10) .EQ. 0) THEN ! IF(MOD(J,10) .EQ. 0) THEN
CALL CHINT(IFLAG) ! CALL CHINT(IFLAG)
IF(IFLAG .EQ. 'i') GO TO 250 ! IF(IFLAG .EQ. 'i') GO TO 250
ENDIF ! ENDIF
IF(IESKP(J) .EQ. 0) THEN IF(IESKP(J) .EQ. 0) THEN
!IPK JAN98 ADD IERC !IPK JAN98 ADD IERC
IF (IMAT(J) .NE. 0) CALL PLTELM(J,IERC) IF (IMAT(J) .NE. 0) CALL PLTELM(J,IERC)
ENDIF ENDIF
20 CONTINUE 20 CONTINUE
IF(IERC .GT. 0) THEN IF(IERC .GT. 0) THEN
! call clscrn() ! call clscrn()
! WRITE(LIND,*) ' Zero node corner nodes' ! WRITE(LIND,*) ' Zero node corner nodes'
@ -250,6 +274,9 @@
ENDIF ENDIF
endif endif
ENDIF ENDIF
if(IDDSW .EQ. 0) then
call backc(2)
endif
!ycw mar97 add for cross section !ycw mar97 add for cross section
if(ICRS.ne.0) then if(ICRS.ne.0) then
call plott(XPCS(1),YPCS(1),3) call plott(XPCS(1),YPCS(1),3)
@ -308,7 +335,7 @@
IF(IMZ .NE. 1) THEN IF(IMZ .NE. 1) THEN
CALL DOPLOT(IMZ) CALL DOPLOT(IMZ)
ENDIF ENDIF
CALL CHEXIT
RETURN RETURN
END END
! !

65
src/REATTACH.F90
Unescape Escape View File

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

34
src/REGSTR.F90
Unescape Escape View File

@ -294,14 +294,16 @@
TYPE(WIN_MESSAGE) :: MESSAGE TYPE(WIN_MESSAGE) :: MESSAGE
INCLUDE 'BFILES.I90' INCLUDE 'BFILES.I90'
CHARACTER(LEN=256) :: FILTER
INTEGER :: NN,I,III INTEGER :: NN,I,III
CHARACTER(LEN=255) :: FNAME CHARACTER(LEN=255) :: FNAME
CHARACTER(LEN=3) :: SUB CHARACTER(LEN=3) :: SUB
INTEGER :: INFO(3)
REAL :: XSIZ,YSIZ
IF(III .EQ. 1) THEN IF(III .EQ. 1) THEN
CALL WMessageBox(YesNo,QuestionIcon,CommonOK, 'Do you wish to '// & 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 ! If answer 'NO', return
! !
@ -309,16 +311,34 @@
ENDIF ENDIF
! Otherwise process ! 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 IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
SUB='org' ! SUB='org'
CALL ADDSUB(FNAME,SUB)
OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED') OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED')
WRITE(104,'(4G16.8)') (BFMINMAX(NN,I),I=1,4) CALL IlowerCase(FNAME)
CLOSE(104) 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 ENDIF
RETURN RETURN

BIN
src/RMAGEN - Shortcut.lnk
View File

Binary file not shown.

8
src/RMAGEN.F90
Unescape Escape View File

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

34
src/RMAGENV83c.rc → src/RMAGENV83d.rc
Unescape Escape View File

@ -8,7 +8,7 @@
// //
// Winteracter resource script. // 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_ASSIGNELTLD 40144
#define ID_FILLTR 40145 #define ID_FILLTR 40145
#define IDD_FTRIAN 167 #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_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_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 "",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_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_RADIO2,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 50, 20, 12
CONTROL "",IDF_RADIO3,"BUTTON",WS_CHILD | WS_VISIBLE | WS_TABSTOP | BS_AUTORADIOBUTTON | BS_TEXT, 20, 64, 20, 12 CONTROL "",IDF_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_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_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 "",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 END
IDD_SELTFL2 RCDATA IDD_SELTFL2 RCDATA
@ -2095,6 +2100,22 @@ BEGIN
,0 ,0
END 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 // Menus
@ -2147,6 +2168,7 @@ BEGIN
POPUP "Mesh" POPUP "Mesh"
BEGIN BEGIN
MENUITEM "Select mesh file", ID_SELRM1 MENUITEM "Select mesh file", ID_SELRM1
MENUITEM "Input Outline to Add Mesh", ID_addmeshtr
MENUITEM "Add mesh to existing", ID_addmesh MENUITEM "Add mesh to existing", ID_addmesh
MENUITEM "Merge mesh to existing", ID_MRGMESH MENUITEM "Merge mesh to existing", ID_MRGMESH
MENUITEM "Generate triangular block", ID_TRIANG MENUITEM "Generate triangular block", ID_TRIANG
@ -2217,6 +2239,7 @@ BEGIN
BEGIN BEGIN
MENUITEM "Undo Refine or Gblock", ID_UNDO MENUITEM "Undo Refine or Gblock", ID_UNDO
MENUITEM "Undo Last Selected Element", ID_UNDOS MENUITEM "Undo Last Selected Element", ID_UNDOS
MENUITEM "Undo Last Auto Mesh Gneration", ID_UNDOGEN
END END
POPUP "&View" POPUP "&View"
BEGIN BEGIN
@ -2256,6 +2279,7 @@ BEGIN
MENUITEM "Group Colour", ID_IGPC MENUITEM "Group Colour", ID_IGPC
END END
MENUITEM "Map Options", ID_MAPOPD MENUITEM "Map Options", ID_MAPOPD
MENUITEM "Force Direct Draw", ID_DDRAW
END END
POPUP "&Help" POPUP "&Help"
BEGIN BEGIN
@ -2269,7 +2293,7 @@ BEGIN
MENUITEM "Set Type by Level", ID_SETTYPLEV MENUITEM "Set Type by Level", ID_SETTYPLEV
MENUITEM "Form a complex line of elements", ID_Complex MENUITEM "Form a complex line of elements", ID_Complex
MENUITEM "Interpolate Map File for Stress File", ID_GETSTRESSFIL 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 "Smooth Mesh Using Reversal", ID_RVSDIAG
MENUITEM "Remove Elements Outside Outline", ID_TESTOUT MENUITEM "Remove Elements Outside Outline", ID_TESTOUT
MENUITEM "Input Element Load file", ID_LOADELTLD MENUITEM "Input Element Load file", ID_LOADELTLD
@ -2404,5 +2428,5 @@ END
//*WI* FORTSAVE 1 //*WI* FORTSAVE 1
//*WI* FILENAME D.INC //*WI* FILENAME D.INC
//*WI* FMODNAME //*WI* FMODNAME
//*WI* LASTTYPE 2 //*WI* LASTTYPE 1
//*WI* LASTRES 67 //*WI* LASTRES 1

11
src/RVSDIAG.F90
Unescape Escape View File

@ -2,7 +2,14 @@
! routine to test for and reverse diagonals ! routine to test for and reverse diagonals
USE BLK1MOD USE BLK1MOD
USE BLK2MOD USE BLK2MOD
INCLUDE 'BFILES.I90'
REAL IGrDistanceLine 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 ! fill midsides
CALL FILM(1) CALL FILM(1)
@ -90,6 +97,7 @@
! test if they are equal height ! 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(WD(N3) .EQ. WD(N4) .or. ABS(WD(N3) -WD(N4)) .LT. ABS(WD(N1)-WD(N2))) THEN
! if so reverse connections ! if so reverse connections
if(dist(n1,n2)*1.5 .lt. dist(n3,n4)) go to 500
KCOUNT=KCOUNT+1 KCOUNT=KCOUNT+1
WRITE(160,*) 'RV1',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 WRITE(160,*) 'RV1',KCOUNT,NEL1,NEL2,N1,N2,N3,N4
CALL REVERS(NEL1,NEL2) CALL REVERS(NEL1,NEL2)
@ -98,7 +106,8 @@
ELSE ELSE
! test if N4 closer or equal to N3 than N1 or N2 ! 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(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 so reverse connections
if(dist(n1,n2)*1.5 .lt. dist(n3,n4)) go to 500
KCOUNT=KCOUNT+1 KCOUNT=KCOUNT+1
WRITE(160,*) 'RV2',KCOUNT,NEL1,NEL2,N1,N2,N3,N4 WRITE(160,*) 'RV2',KCOUNT,NEL1,NEL2,N1,N2,N3,N4
CALL REVERS(NEL1,NEL2) CALL REVERS(NEL1,NEL2)

4
src/TXFRM.COM
Unescape Escape View File

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

3
src/UTIL.F90
Unescape Escape View File

@ -1083,7 +1083,8 @@
DO 25 K=1,NCNR DO 25 K=1,NCNR
N = NOP(J,K) 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 (NCN .NE. 5 .OR. K .LT. 5) THEN
IF (MOD(K,2) .EQ. 1) THEN IF (MOD(K,2) .EQ. 1) THEN

53
src/WINNEW.F90
Unescape Escape View File

@ -413,7 +413,10 @@
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL !IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
INCLUDE 'BFILES.I90' 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) XBKMN=((BFMINMAX(I,1)+XS)/TXSCAL)
XBKMX=((BFMINMAX(I,3)+XS)/TXSCAL) XBKMX=((BFMINMAX(I,3)+XS)/TXSCAL)
YBKMN=((BFMINMAX(I,2)+YS)/TXSCAL) YBKMN=((BFMINMAX(I,2)+YS)/TXSCAL)
@ -493,7 +496,11 @@
CALL WBitMapCreate(IHAND2,IX2PIX,IY2PIX) CALL WBitMapCreate(IHAND2,IX2PIX,IY2PIX)
CALL IGrSelect(DrawBitmap,IHAND2) CALL IGrSelect(DrawBitmap,IHAND2)
CALL WBitMapPutPart(IHAND1,0,IXLPIX,IYLPIX,IXMPIX,IYMPIX) CALL WBitMapPutPart(IHAND1,0,IXLPIX,IYLPIX,IXMPIX,IYMPIX)
CALL IGrSelect(DrawWin) IF(IDDSW .EQ. 1) THEN
CALL IGrSelect(DrawWin)
ELSE
CALL IGrSelect(DrawBitmap,IHANDLE)
ENDIF
IERR = InfoError(LastError) IERR = InfoError(LastError)
! WRITE(90,*) 'ERROR SELECT DRAW', IERR ! WRITE(90,*) 'ERROR SELECT DRAW', IERR
CALL WBitmapPut(IHAND2,1,1,IXPM,IYPX,IXPX,IYPM) CALL WBitmapPut(IHAND2,1,1,IXPM,IYPX,IXPX,IYPM)
@ -672,12 +679,19 @@
CALL WDialogShow(-1,-1,0,Modal) CALL WDialogShow(-1,-1,0,Modal)
ierr=infoerror(1) ierr=infoerror(1)
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN DO
call wdialogGetradiobutton(idf_radio1,iactvfil) IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
ENDIF call wdialogGetradiobutton(idf_radio1,iactvfil)
write(90,*) 'Selected iactvfil', iactvfil write(90,*) 'Selected iactvfil', iactvfil
RETURN RETURN
ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
RETURN
ENDIF
ENDDO
END END
subroutine plotcr(x,y,siz) subroutine plotcr(x,y,siz)
CALL PLOTT(x-siz/2.,y,3) CALL PLOTT(x-siz/2.,y,3)
@ -687,4 +701,29 @@
return return
end 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

239
src/addmesht - Copy.f90
Unescape Escape View File

@ -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

307
src/addmesht.f90
Unescape Escape View File

@ -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

151
src/addtomesh.f90
Unescape Escape View File

@ -6,6 +6,7 @@
USE WINTERACTER USE WINTERACTER
USE BLK1MOD USE BLK1MOD
USE BLK2MOD
INCLUDE 'D.INC' INCLUDE 'D.INC'
@ -16,10 +17,17 @@
CALL RDTOCLIP(IADD) CALL RDTOCLIP(IADD)
IF(ISWT .EQ. 1) THEN IF(ISWT .EQ. 1) THEN
CALL OUTLINES(1)
ISWT1=0 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' write(90,*) 'finished mergemesh1'
CALL MERGEMESH IF(ISWT2 .EQ. 0) CALL MERGEMESH
! CALL MERGEMESH
write(90,*) 'finished mergemesh' write(90,*) 'finished mergemesh'
flush(90) flush(90)
ENDIF ENDIF
@ -52,14 +60,14 @@
REWIND IUNIT REWIND IUNIT
READ(IUNIT) TITLE,NPSTO(1),NESTO(1) READ(IUNIT) TITLE,NPSTO(1),NESTO(1)
! WRITE(90,*) 'IN RDTOCLIP',IUNIT WRITE(90,*) 'IN RDTOCLIP',IUNIT
! WRITE(90,*) TITLE,NPSTO(1),NESTO(1) WRITE(90,*) TITLE,NPSTO(1),NESTO(1)
READ(IUNIT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & READ(IUNIT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempinc & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempinc
! WRITE(90,*) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN & WRITE(90,*) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
! & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempinc & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempinc
READ(IUNIT) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG 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 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) ((NOPSTO(J,K,1),K=1,8),IMATSTO(J,1),THTASTO(J,1),J=1,NESTO(1))
@ -161,22 +169,62 @@
RETURN RETURN
END END
SUBROUTINE MERGEMESH1(ISWT1) SUBROUTINE MERGEMESH1(ISWT1,ISWT2)
USE BLK1MOD USE BLK1MOD
USE BLK2MOD
USE WINTERACTER
! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK1.COM'
REAL*8 ELXMIN,ELXMAX,ELYMIN,ELYMAX,XLC,YLC,XXX,YYY REAL*8 ELXMIN,ELXMAX,ELYMIN,ELYMAX,XLC,YLC,XXX,YYY
LOGICAL LSTAT
ALLOCATABLE ELXMIN(:),ELXMAX(:),ELYMIN(:),ELYMAX(:),KEY(:),NKEY(:) ALLOCATABLE ELXMIN(:),ELXMAX(:),ELYMIN(:),ELYMAX(:),KEY(:),NKEY(:)
DIMENSION XOUT1(1000),YOUT1(1000)
IF(.NOT. ALLOCATED(ELXMIN)) & IF(.NOT. ALLOCATED(ELXMIN)) &
ALLOCATE (ELXMIN(MAXE),ELXMAX(MAXE),ELYMIN(MAXE),ELYMAX(MAXE),KEY(MAXE),NKEY(MAXP)) 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 ! First sort coordinates for min of element connection
! List all limiting values ! List all limiting values
110 CONTINUE
DO N=1,NE DO N=1,NE
IF(IMAT(N) .GT. 0) THEN IF(IMAT(N) .GT. 0) THEN
ELXMIN(N)=XUSR(NOP(N,1)) ELXMIN(N)=XUSR(NOP(N,1))
@ -258,7 +306,8 @@
IF(NOP(N,7) .EQ. 0) THEN IF(NOP(N,7) .EQ. 0) THEN
NCN=6 NCN=6
IT=2 IT=2
ELSEIF(NOP(N,6) .EQ. 0) THEN ENDIF
IF(NOP(N,6) .EQ. 0) THEN
GOTO 350 GOTO 350
ENDIF ENDIF
! Test for point inside an element ! Test for point inside an element
@ -439,25 +488,39 @@
SUBROUTINE MERGEMESH SUBROUTINE MERGEMESH
USE BLK1MOD USE BLK1MOD
LOGICAL LSTAT
! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK1.COM'
! Loop on element to be added ! Loop on element to be added
DO N=1,NESTO(1) DO N=1,NESTO(1)
IF(IMATSTO(N,1) .NE. 0) THEN IF(IMATSTO(N,1) .NE. 0) THEN
if(mod(n,1000) .eq. 0) write(90,*) 'adding',n,nesto(1) if(mod(n,1000) .eq. 0) write(90,*) 'adding',n,nesto(1)
flush(90) 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 ! loop on sides
DO M=1,7,2 DO M=1,7,2
N1=NOPSTO(N,M,1) 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(N1 .GT. 0) THEN
IF((M .EQ. 5 .AND. NOPSTO(N,7,1) .EQ. 0) .OR. (M .EQ. 7)) THEN IF((M .EQ. 5 .AND. NOPSTO(N,7,1) .EQ. 0) .OR. (M .EQ. 7)) THEN
N2=NOPSTO(N,1,1) N2=NOPSTO(N,1,1)
ELSE ELSE
N2=NOPSTO(N,M+2,1) N2=NOPSTO(N,M+2,1)
ENDIF ENDIF
IF(NKEP(N1) .EQ. 1 .AND. NKEP(N2) .EQ. 1) GO TO 380
! Now loop trough existing elements ! Now loop trough existing elements
@ -465,6 +528,7 @@
IF(IMAT(I) .NE. 0) THEN IF(IMAT(I) .NE. 0) THEN
DO J=1,7,2 DO J=1,7,2
M1=NOP(I,J) M1=NOP(I,J)
IF(J .EQ. 3 .AND. NOP(I,5) .EQ. 0) GO TO 360
IF(M1 .GT. 0) THEN IF(M1 .GT. 0) THEN
IF((J .EQ. 5 .AND. NOP(I,7) .EQ. 0) .OR. (J .EQ. 7)) THEN IF((J .EQ. 5 .AND. NOP(I,7) .EQ. 0) .OR. (J .EQ. 7)) THEN
M2=NOP(I,1) M2=NOP(I,1)
@ -488,8 +552,10 @@
ENDIF ENDIF
ENDDO ENDDO
ENDIF ENDIF
360 CONTINUE
ENDDO ENDDO
ENDIF ENDIF
380 CONTINUE
ENDDO ENDDO
ENDIF ENDIF
400 CONTINUE 400 CONTINUE
@ -497,3 +563,66 @@
RETURN RETURN
END 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

40
src/backc.f90
Unescape Escape View File

@ -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

1
src/form999.f90
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save