module Global ! ! To prevent crashes due to the bug(s) associated with !"WRITE(msg," or "READ(msg," when msg is a local subroutine variable, ! declare msg here to be a large permanent vector: ! character(255) msg ! Note: At one time, this was the longest string supported. character(255) windowHeightString ! ! Input file ! character(255) dig_inp, feg_inp, feg_sav character(255) title_string logical(4) GridLoaded ! loading status of F-E Grid logical(4) BaseLoaded ! loading status of F-E Base ! ! Associated with F-E Grid ! character(len=80) title integer(4) numnod, nrealn, nfaken, n1000 ! note: mxnode, mxel, mxfel larger than numnod,numel,nfl ! for adding or deleting node/element/fault integer(4) mxnode, mxel, mxfel integer, parameter:: MXBN = 10000 ! maximum boundary node # integer(4) NODCON(MXBN) ! boundary node list logical brief integer(4) numel, nfl real FIPoint(4)/.125, .375,.625, .875/ ! points for plotting fault dips real shallow, steep ! fault dip angle in degree real, allocatable:: nodeABG(:,:), eqcm(:,:) ! node real,allocatable:: fdip(:,:),offset(:) ! fault integer(4), allocatable:: nodes(:,:),nodef(:,:) ! element/fault integer(2), allocatable:: NMemo(:) ! status of node integer(2),allocatable:: EMemo(:) ! flipped status of element ! ! Following 3 arrays used in Perimeter/Area test ! These three are allocated and deallocated only in routine PATest ! integer, allocatable:: Nflags(:,:) !Nflags(2,NUMNOD), 1-- already known; 2 -- exterior node integer, allocatable:: Fside(:,:) !Fside(2,NFL), 1-2: side 1-2 integer, allocatable:: Eside(:,:) !Eside(3,NUMEL), 1-3: side 1-3 ! ! Associated with Basemap ! type :: point real:: Alpha, Beta, Gamma type(point), pointer :: next_point end type type(point), pointer :: phead, ptail ! ! Transformation ! real winright(3), winout(3), winup(3) real scales(2,2) real unscale(2,2) real cart2(3,3) ! 2nd origin transformation integer(4) HiRow, HiCol, Lines ! physical dimension of pixels along x, y axes real WindowHeight real winlat, winlon real R2C real tolerance ! distance for finding cloest node, element ! ! Micellaneous ! real nettempvec(3) ! (alpha, beta, gamma) of center point of the net integer zcol,zrow ! (zcol,zrow) used in selectpoint_zoom ! ! Associated with Tile region with grid ! integer nslice ! in GTdialog, Isosahedron integer oldslice ! in GTdialog integer Npoly integer, parameter:: Npoly_maxsize = 100 ! maximum vertice point # of polygon integer vertcol(Npoly_maxsize), vertrow(Npoly_maxsize) real Normals(3, Npoly_maxsize) ! ! Logical switches ! logical graymenu ! if no size for node/element/fault, gray some menu logical DoIcon ! put triangle at the center of element logical ShowNodes ! display node location with circle logical AddDropNode_checked logical AdjustNode_checked logical AddDeleteElement_checked logical CutHealFault_checked logical Finclination_checked logical Fheading_checked logical eqcmDraw_checked logical BlockSetValue_checked logical ZoomInOut_checked logical Using2ndOrigin logical TileGrid_checked logical ViewGap_checked logical OrbData5 ! signals 6 real variables per node in SHELLS .feg files (not just 4) ! ! Other switches ! integer AppType ! specify application type: thin-shell, restore2, restore3 ! ! color table ! integer drawtype integer(4) colorpick integer(4) ifrontcolor integer(4) ibackcolor integer(4) ibasecolor integer(4) inodecolor integer(4) ifaultcolor integer(4) ifaultcolor2 integer(4) ielecolor integer(4) Redvalue DATA Redvalue /0/ integer(4) Greenvalue DATA Greenvalue /0/ integer(4) Bluevalue DATA Bluevalue /0/ INTEGER(4), DIMENSION(3, 6):: RGB_int_of_IDC_LIST_line !(i = 1,2,3 = R, G, B; each 0...255); !(j = 1, ... ,6 = Outer Circle, Basemap, Node, Element, Fault, Background) DATA RGB_int_of_IDC_LIST_line / 0,255,255, 255,255,255, 0,0,255, 0,255,0, 255,0,0, 0,0,0/ CHARACTER*1 :: RedByte, GreenByte, BlueByte INTEGER(1) :: RedInt1, GreenInt1, BlueInt1 EQUIVALENCE (RedByte, RedInt1) EQUIVALENCE (GreenByte, GreenInt1) EQUIVALENCE (BlueByte, BlueInt1) ! ! contour map ! integer(4):: Hicolor = 15 ! color# integer idata, oldidata integer contour integer ColorIn ! used in view gap, switch in DrawElement real botf, topf, oldbotf, oldtopf, dfc integer(4) colorarray(15) ! store 15 colors as [R, G, B] triplets logical logs ! ! Adjusting node, element etc. ! integer NItsOn, EItsOn, FItsOn integer JIP ! used for adding/deleting element integer(4) Non(1000), Eon(1000), Fon(1000) integer ColOld, RowOld, ColNew, RowNew integer click integer Col_MouseClick, Row_MouseClick integer col11, row11 real xold, yold real fixup real oldHead, Heading real last_val ! used in setEQCM ! ! editing counter for autosaving ! integer(4) editingcounter ! ! file unit number associated with debug.log ! open in SUBR initialization ! integer:: iunitd = 1000 !------------------------------------------------------------------------------------------ ! ! Toolbar & Statusbar ! INTEGER:: hFrame, & !Handle of the frame window hInst, & !Instance handle hMDI, & !Handle of the MDI client window hStatus, & !Status bar handle hToolbar, & !Toolbar handle lpfnOldFrameProc !Address of the default MDI windos procedure INTEGER,PARAMETER:: & !Define our own message for toolbar creation. !Should be > WM_USER=#0400 WM_CREATETOOLBAR=#0500 INTEGER,PARAMETER:: WM_CREATESTATUS=#0600 ! TYPE T_MENUITEMINFO INTEGER(4) cbSize INTEGER(4) fMask INTEGER(4) fType INTEGER(4) fState INTEGER(4) wID INTEGER(4) hSubMenu INTEGER(4) hbmpChecked INTEGER(4) hbmpUnchecked INTEGER(4) dwItemData INTEGER(4) dwTypeData INTEGER(4) cch END TYPE T_MENUITEMINFO !--------------- important utility subroutine ----------------- CONTAINS SUBROUTINE Repair_String(string_from_C) ! ! Repairs a character-string variable which was defined ! in Fortran, but which got its present value from any ! C++ routine (e.g., path-filenames from Windows API ! Open-File or Save-File menus). ! Apparently, the default is that Fortran's hidden !"length" integer is set to the allocated length, ! and the string is padded with nulls (CHAR(0)). ! Such a string cannot be correctly processed by ! either TRIM() or LEN_TRIM(), and when output it may ! cause I/O problems due to the unexpected nulls. ! This routine determines the correct length by ! searching for the first null byte, then tries to ! set the Fortran length integer by copying the string. ! This should also guarantee that the string is properly ! padded by spaces (CHAR(32)), not nulls. ! ! by Peter Bird, UCLA, 2005.04.12 ! IMPLICIT NONE CHARACTER*(*), INTENT(INOUT) :: string_from_C CHARACTER*(255) :: temporary_string INTEGER :: i, length, content_length, apparent_LEN_TRIM, test SAVE ! all local variables apparent_LEN_TRIM = LEN_TRIM(string_from_C) ! may be too large in some cases length = LEN(string_from_C) ! allocated-memory length, not length of contents content_length = MIN(apparent_LEN_TRIM, length) ! unless reduced by loops below... scanning: DO i = 1, content_length IF (string_from_C(i:i) == CHAR(0)) THEN content_length = i - 1 EXIT scanning END IF END DO scanning IF (content_length > 0) THEN content_length = MIN(content_length, 255) ! so as not to overflow temporary_string temporary_string = string_from_C(1:content_length) content_length = MIN(content_length, length) ! so as not to overflow string_from_C string_from_C = temporary_string(1:content_length) ELSE string_from_C = ' ' END IF test = LEN_TRIM(string_from_C) test = test -1 + 1 ! put breakpoint here END SUBROUTINE Repair_String ! end module Global