home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
fortran
/
mslang
/
prefor
/
prefor32.for
< prev
next >
Wrap
Text File
|
1993-10-26
|
35KB
|
842 lines
C Totally FORTRAN implementation of Precompiler Includes Generator
C by Barry W. McCleave, PhD, P.E. 601-634-2599
include 'prefor32.fi'
C FORM TEMPLATE
c itemtype()=I (or i) means integer*2 Int
c itemtype()=L (or l) means integer*4 Longint
c itemtype()=R (or r) means real*4 Real
c itemtype()=D (or d )means real*8 Double Precision
c itemtype()=C (or c) means string Characters (termination \)
c itemtype()=S (or s) choice only Selection
c itemtype()=T (or t) comment field Text
c itemtype()=H (or h) form title Heading
c itemchosen()= the list item selected (0 if edit entry)
c delimeter=^ after each selection list item; before first list item
c delimeter=| at end of every form item
c delimeter=\ at end of every text line (\\ produces \ if c string)
c last item followed by 0 (\0 poduces 0 if c string)
integer*4 function WinMain [stdcall,alias:'_WinMain@16']
1 (hInstance[VALUE],
1 hPrevInstance[VALUE],lpszCmdLine[VALUE], nCmdShow[VALUE])
include 'prefor32.fd'
integer*4 hinstance,hprevinstance
integer*4 lpszcmdline
integer*4 ncmdshow
integer*4 initmain
integer*4 hwnd,mainmsgloop
if(initmain(hinstance,hprevinstance,ncmdshow,hwnd).eq.TRUE)
1 WinMain=mainmsgloop(hinstance)
return
end
integer*4 Function Initmain (
1 hInstance,hPrevInstance,ncmdshow,hwnd)
include 'prefor32.fd'
external mainwindowproc
integer*4 hInstance,hPrevInstance,nCmdShow,hbgbrush
integer*4 createwindowex,loadcursor,registerclass
record /wndclass/ windowclass
integer*4 hWnd,hinst,CreateSolidBrush
common /edatamain/ hinst,hbgbrush
integer*4 blue
c colorref format is #bbggrr blue green red
parameter (blue=#7F0000)
c integer*4 idc_arrow
c data idc_arrow/32512/
Initmain = TRUE
hinst=hinstance
if (hPrevInstance.eq.false) then
WindowClass.lpszClassName = locfar('EdatWin'C)
WindowClass.hInstance = hInstance
WindowClass.lpfnWndProc = locfar(mainwindowproc)
WindowClass.hCursor = LoadCursor(null,idc_arrow)
WindowClass.hIcon = NULL
WindowClass.lpszMenuName = NULL
hbgbrush = CreateSolidBrush(blue)
WindowClass.hbrBackground = hbgbrush
WindowClass.style = 0
WindowClass.cbClsExtra = 0
WindowClass.cbWndExtra = 0
if (RegisterClass (WindowClass).eq.false) Initmain = false
end if
hWnd = CreateWindowEx(0,locfar('EdatWin'C),locfar('EDITDATA'C),
1 WS_OVERLAPPEDWINDOW,CW_USEDEFAULT,0,CW_USEDEFAULT,0,NULL,
1 NULL,hInstance,NULL)
call ShowWindow (hWnd,nCmdShow)
call UpdateWindow(hWnd)
return
end
integer*4 Function mainMsgLoop(hInstance)
integer*4 hInstance
include 'prefor32.fd'
Record /tagmsg/ msg
integer*4 GetMessage
DO WHILE (GetMessage(msg,null,0,0).ne.false)
Call TranslateMessage(msg)
Call DispatchMessage(msg)
mainMsgLoop=msg.wParam
End Do
return
end
Integer*4 Function mainwindowproc [stdcall,
1 alias:'_MAINWINDOWPROC']
1 (hWnd[VALUE],wMsgID[VALUE],wParam[VALUE],lParam[VALUE])
include 'prefor32.fd'
integer*4 hWnd,wMsgID,wParam,hparent
Integer*4 lParam,lberr,lselected
Character*80 TextBuffer
integer*4 hinst,hbgbrush
common /edatamain/ hinst,hbgbrush
integer*4 SelectObject,i,nowitem
integer*4 hWndEdit,GetWindowText,xmax,ymax
integer*4 defwindowproc,ws_mybutton
integer*4 createwindow,setfocus,loword,hiword,destroywindow
integer*4 SetBkMode,BeginPaint
integer*4 cxChar,hdc,ierr,TextOut,numread
integer*4 GetDC,GetTextMetrics,GetStockObject,ReleaseDC
INTEGER*4 ipreviouscolor,SetTextColor,SetBkColor,GetSysColor
integer*4 SendMessage
Record /tagTextMetric/ tm
Record /tagRect/ rect
Record /tagPAINTSTRUCT/ ps
Record /tagLOGPEN/ pen
logical*1 form,confirmed
integer*4 hinstance,hprevinstance,hPR
integer*4 lpszcmdline
integer*4 ncmdshow
integer*4 initmain,extent_x,extent_y
INTEGER*1 UPARROW,DOWNARROW,LEFTARROW,RIGHTARROW
CHARACTER*12 FILENAM
character*13 wintitle
CHARACTER*1 TYPDAFIL,RFLAG
integer*1 IIA,IIE,IIS,IIL,IIR,IID,IIP
INTEGER*1 IIM,IIX,IIT,IIY,IIN
integer*4 INFILEPTR
CHARACTER*80 A
integer*1 a1(80),b(80),c(80)
character*12 filefd(20)
character*12 filefi(20)
CHARACTER*35 fileform
character*30 file_in_fih,file_in_fdh,file_out_fi,file_out_fd
CHARACTER*30 file_in_for
LOGICAL*1 MODIFY_OLD,FLGCONFIRMED,GROUPCONFIRM
REAL*8 INFROWS(2)
REAL*8 LINEROWS(1)
CHARACTER*30 FILEN,file_out_pre
integer*1 itemchfile(2)
LOGICAL*1 REDRAW,NONE,GRAPH,RESOLUTION
integer*4 color(80)
character*1 image(1500000)
integer*4 start_char(50000)
integer*2 length_char(50000)
common/bigimage/image
common/pallet2/bitmapinfo,pal
Record /tagbitmapfileheader/ bitmapfileheader
Record /tagbitmapinfoheader/ bitmapinfo
integer*4 hmemorydc,hbitmap,deletedc
integer*4 pal(512)
integer*4 createcompatibledc,createdibitmap,bitblt
integer*4 hpenbackground,hpenline,cychar
COMMON/COLORS/hpenbackground,hpenline,cychar
EQUIVALENCE (INFROWS(1),INFILEPTR)
equivalence (a,a1(1))
logical*1 copying,found
integer*4 hpenblue,hpengreen,hpenyellow,hpenwhite,hpenred,
1 hpenblack
integer*4 return,escape,char_fsmall,char_flarge
integer*4 char_nsmall,char_nlarge,char_lsmall,char_llarge
integer*4 char_dsmall,char_dlarge,char_usmall,char_ularge
integer*4 char_asmall,char_alarge,char_psmall,char_plarge
integer*4 char_hsmall,char_hlarge
integer*4 char_0,char_1,char_2,char_3,char_4,char_5,char_6
integer*4 char_7,char_8,char_9,alt,shift
integer*4 left_arrow,right_arrow,up_arrow,down_arrow
integer*4 blue,yellow,red,black,white,green,lightblue,purple
integer*4 idm_next
integer*1 base_small_letters
parameter (idm_next=#300)
c colorref format is #bbggrr blue green red
parameter (blue=#7F0000)
parameter (yellow=#00CFCF)
parameter (green=#00FF00)
parameter (red=#0000FF)
parameter (white=#FFFFFF)
parameter (black=#0)
parameter (lightblue=#CFCF00)
parameter (purple=#CF00CF)
parameter (return=13)
parameter (escape=27)
parameter (alt=#12)
parameter (shift=#10)
parameter (right_arrow=#27)
parameter (left_arrow=#25)
parameter (up_arrow=#26)
parameter (down_arrow=#28)
parameter (char_fsmall=#66)
parameter (char_flarge=#46)
parameter (char_hsmall=#68)
parameter (char_hlarge=#48)
parameter (char_lsmall=#6c)
parameter (char_llarge=#4c)
parameter (char_nsmall=#6e)
parameter (char_nlarge=#4e)
parameter (char_psmall=#70)
parameter (char_plarge=#50)
parameter (char_usmall=#75)
parameter (char_ularge=#55)
parameter (char_dsmall=#64)
parameter (char_dlarge=#44)
parameter (char_asmall=#61)
parameter (char_alarge=#41)
parameter (char_0=#30)
parameter (char_1=#31)
parameter (char_2=#32)
parameter (char_3=#33)
parameter (char_4=#34)
parameter (char_5=#35)
parameter (char_6=#36)
parameter (char_7=#37)
parameter (char_8=#38)
parameter (char_9=#39)
integer*4 CreatePenIndirect
data itemchfile/0,1/
DATA FILEform/'cProgram Name^OOPS, EXIT PROGRAM^|\0'c/
data itemchline/0/
DATA SPACE/1H /,ZERO/1H0/
DATA INFCHOS,INFCHOS2,ONE,TWO,MINUS/1,2,1H1,1H2,1H-/
DATA IIA/1HA/,
1 IIS/1HS/,IIY/1HY/,IIN/1HN/,IIP/1HP/
DATA IIE/1HE/,IIL/1HL/,IIM/1HM/,IID/1HD/,IIR/1HR/,IIX/1HX/,
1 IIT/1HT/
data filen/'\0'c/
data pen.style,pen.x,pen.y,pen.color/PS_SOLID,1,1,YELLOW/
data base_small_letters/96/
data filefd/'USER32.FD ','GDI32.FD ','KERNEL32.FD ',
1'COMDLG32.FD ','COMCTL32.FD ','WIN32SPL.FD ','SHELL32.FD ',
2'NETAPI32.FD ','OLECLI32.FD ','OLESVR32.FD ','RASAPI32.FD ',
3'LZ32.FD ','ADVAPI32.FD ',7*' '/
data filefi/'USER32.FI ','GDI32.FI ','KERNEL32.FI ',
1'COMDLG32.FI ','COMCTL32.FI ','WIN32SPL.FI ','SHELL32.FI ',
2'NETAPI32.FI ','OLECLI32.FI ','OLESVR32.FI ','RASAPI32.FI ',
3'LZ32.FI ','ADVAPI32.FI ',7*' '/
data number_include_files/13/
data copying,found/2*.FALSE./
c return TRUE unless unless handles by DefWindowProc
mainwindowproc = true
select case (wMsgID)
case (WM_CREATE)
hdc=GetDC(hWnd)
ierr=SelectObject(hdc,GetStockObject(SYSTEM_FIXED_FONT))
ierr=GetTextMetrics(hdc,tm)
cxChar=tm.tmAveCharWidth
cyChar=tm.tmHeight+tm.tmExternalLeading
ierr=ReleaseDC(hwnd,hdc)
pen.color=yellow
hpenyellow=CreatePenIndirect(pen)
pen.color=red
hpenred=CreatePenIndirect(pen)
pen.color=green
hpengreen=CreatePenIndirect(pen)
pen.color=white
hpenwhite=CreatePenIndirect(pen)
pen.color=black
hpenblack=CreatePenIndirect(pen)
pen.color=blue
hpenblue=CreatePenIndirect(pen)
hpenbackground=hpenblue
pen.color=lightblue
hpenlightblue=CreatePenIndirect(pen)
pen.color=purple
hpenpurple=CreatePenIndirect(pen)
color(1)=hpenblue
color(2)=hpenyellow
color(3)=hpengreen
color(4)=hpenwhite
color(5)=hpenblack
color(6)=hpenred
color(7)=hpenpurple
color(8)=hpenlightblue
IPIXX=640
IPIXY=480
IPIXLET=10
IPIXY1=IPIXY-1
PIXY=IPIXY
PIXY1=IPIXY1
IPIXX1=IPIXX-1
PIXX1=IPIXX1
PIXX=IPIXX
OPEN(7,FILE='corps.bmp',FORM='BINARY',STATUS='OLD',ERR=9)
read(7,err=8,end=8) bitmapfileheader.bftype,
1 bitmapfileheader.bfSize,bitmapfileheader.bfReserved1,
2 bitmapfileheader.bfReserved2,bitmapfileheader.bfOffbits
read(7,err=8,end=8) bitmapinfo.bisize,
1 bitmapinfo.biWidth,bitmapinfo.biHeight,
2 bitmapinfo.biPlanes,bitmapinfo.biBitCount,
3 bitmapinfo.biCompression,bitmapinfo.biSizeImage,
4 bitmapinfo.biXPelsPerMeter,bitmapinfo.biYPelsPerMeter,
5 bitmapinfo.biClrUsed,bitmapinfo.biClrImportant
c 40 and 14 are the sizes of the 2 header blocks; pal is Integer*4 array
iskip=(bitmapfileheader.bfOffbits-40-14)/4
if(iskip.ge.1) then
do j=1,iskip
read(7,err=8134,end=8134) pal(j)
enddo
endif
8134 if(bitmapinfo.biBitCount.eq.1)
1 linewidthbytes=(bitmapinfo.biWidth+7)/8
if(bitmapinfo.biBitCount.eq.4)
1 linewidthbytes=(bitmapinfo.biWidth+1)/2
if(bitmapinfo.biBitCount.eq.8)
1 linewidthbytes=bitmapinfo.biWidth
if(bitmapinfo.biBitCount.eq.24)
1 linewidthbytes=bitmapinfo.biWidth*3
ibase=0
do j=bitmapinfo.biheight,1,-1
read(7,err=8,end=8) (image(jj+ibase),
1 jj=1,linewidthbytes)
ibase=ibase+linewidthbytes
enddo
8 close(7)
9 continue
ifirsttime=0
call InvalidateRect(hWnd,Null,True)
case (WM_COMMAND)
select case (wParam)
case (IDM_NEXT)
INFILEPTR=LOCFAR(FILEN)
IF(FORM(hinst,hWnd,fileform,itemchfile,infrows)) THEN
IF(Itemchfile(1).EQ.1) GO TO 7777
CALL GET_NAME_OF_FILE(FILEN,FILE_IN_FDH,NUMCHAR)
file_in_fdh(numchar+1:numchar+3)='FDH'
file_in_fih=file_in_fdh
file_in_fih(numchar+1:numchar+3)='FIH'
file_out_fi=file_in_fdh
file_out_fi(numchar+1:numchar+3)='FI '
file_out_fd=file_in_fdh
file_out_fd(numchar+1:numchar+3)='FD '
file_out_pre=file_in_fdh
file_out_pre(numchar+1:numchar+3)='PRE'
file_in_for=file_in_fdh
file_in_for(numchar+1:numchar+3)='FOR'
else
nerr=destroywindow(hwnd)
return
ENDIF
c*******************Search Masterfi.lis*************************
masterficount=0
icharcount=1
start_char(1)=1
open(3,file='MASTERFI.LIS',status='old',err=13)
618 read(3,10,end=612,err=612) a
icount=1
if (a1(1).ne.32.and.a1(1).ne.13.and.
1 a1(1).ne.10) then
masterficount=masterficount+1
do while (a1(icount).ne.32.and.
1 a1(icount).ne.13.and.
1 a1(icount).ne.10.and.icount.le.80)
if(a1(icount).gt.base_small_letters)
1 a1(icount)=a1(icount)-32
image(icharcount)=a1(icount)
icharcount=icharcount+1
icount=icount+1
enddo
c*************************new************************
length_char(masterficount)=icharcount-
1 start_char(masterficount)
c mc=masterficount+1
start_char(masterficount+1)=icharcount+1
c***************************************************
image(icharcount)=' '
icharcount=icharcount+1
endif
go to 618
612 close(3)
open(3,file=file_in_for,status='OLD',err=13)
open(4,file=file_in_fih,status='UNKNOWN',err=13)
628 read(3,10,end=629,err=629) a
if(a1(1).ne.'C'.and.a1(1).ne.'c'.and.a1(1).ne.'$') then
icount=7
623 mcount=0
do while (((a1(icount).ge.'A'.and.a1(icount).le.'Z')
1 .or.a1(icount).eq.'_'.or.(a1(icount).ge.'a'.and.
1 a1(icount).le.'z').or.(a1(icount).ge.'0'.and.
1 a1(icount).le.'9')).and.icount.le.80)
if(a1(icount).gt.base_small_letters)
1 a1(icount)=a1(icount)-32
mcount=mcount+1
c(mcount)=a1(icount)
icount=icount+1
enddo
icount=icount+1
if(mcount.gt.0) then
nowchar=1
found=.false.
do m=1,masterficount
c******************new1***************
if(c(1).eq.image(start_char(m)).and.mcount.eq.
1 length_char(m)) then
c**********************************
if(.not.found) then
icharnow=1
do while (image(nowchar).ne.' '.and.
1 image(nowchar).ne.'*')
b(icharnow)=image(nowchar)
icharnow=icharnow+1
nowchar=nowchar+1
enddo
icharnow=icharnow-1
if(icharnow.eq.mcount.and.icharnow.ne.0.and.
1 c(1).eq.b(1)) then
found=.true.
do inow=1,icharnow
if(c(inow).ne.b(inow)) found=.false.
enddo
if(found.and.image(nowchar).ne.'*') then
write(4,100,err=629) (b(jj),jj=1,icharnow)
image(nowchar)='*'
endif
endif
nowchar=nowchar+1
endif
c************************new2**********************
else
nowchar=start_char(m+1)
endif
c****************************************************
enddo
endif
if(icount.le.80) go to 623
endif
go to 628
629 close(4)
close(3)
c***************************************************************
c*******************Search Masterfd.lis*************************
masterfdcount=0
icharcount=1
start_char(1)=1
open(3,file='MASTERFD.LIS',status='old',err=13)
718 read(3,10,end=712,err=712) a
icount=1
if (a1(1).ne.32.and.a1(1).ne.13.and.
1 a1(1).ne.10) then
masterfdcount=masterfdcount+1
do while (a1(icount).ne.32.and.
1 a1(icount).ne.13.and.
1 a1(icount).ne.10.and.icount.le.80)
if(a1(icount).gt.base_small_letters)
1 a1(icount)=a1(icount)-32
image(icharcount)=a1(icount)
icharcount=icharcount+1
icount=icount+1
enddo
c************************new**************************
length_char(masterfdcount)=icharcount-
1 start_char(masterfdcount)
c mc=masterfdcount+1
start_char(masterfdcount+1)=icharcount+1
c*****************************************************
image(icharcount)=' '
icharcount=icharcount+1
endif
go to 718
712 close(3)
open(3,file=file_in_for,status='OLD',err=13)
open(4,file=file_in_fdh,status='UNKNOWN',err=13)
728 read(3,10,end=729,err=729) a
if(a1(1).ne.99.and.a1(1).ne.67.and.a1(1).ne.36) then
icount=7
723 mcount=0
do while (((a1(icount).ge.'A'.and.a1(icount).le.'Z')
1 .or.a1(icount).eq.'_'.or.(a1(icount).ge.'a'.and.
1 a1(icount).le.'z').or.(a1(icount).ge.'0'.and.
1 a1(icount).le.'9')).and.icount.le.80)
if(a1(icount).gt.base_small_letters)
1 a1(icount)=a1(icount)-32
mcount=mcount+1
c(mcount)=a1(icount)
icount=icount+1
enddo
icount=icount+1
if(mcount.gt.0) then
nowchar=1
found=.false.
do m=1,masterfdcount
c******************new1***************
if(c(1).eq.image(start_char(m)).and.mcount.eq.
1 length_char(m)) then
c**********************************
if(.not.found) then
icharnow=1
do while (image(nowchar).ne.' '.and.
1 image(nowchar).ne.'*')
b(icharnow)=image(nowchar)
icharnow=icharnow+1
nowchar=nowchar+1
enddo
icharnow=icharnow-1
if(icharnow.eq.mcount.and.icharnow.ne.0.and.
1 c(1).eq.b(1)) then
found=.true.
do inow=1,icharnow
if(c(inow).ne.b(inow)) found=.false.
enddo
if(found.and.image(nowchar).ne.'*') then
write(4,100,err=729) (b(jj),jj=1,icharnow)
image(nowchar)='*'
endif
endif
nowchar=nowchar+1
endif
c************************new2**********************
else
nowchar=start_char(m+1)
endif
c****************************************************
enddo
endif
if(icount.le.80) go to 723
endif
go to 728
729 close(4)
close(3)
c***************************************************************
icharcount=1
ifdcount=0
open(5,file=file_out_pre)
open(3,file=file_in_fdh,status='OLD',err=13)
18 read(3,10,end=12,err=12) a
10 format(a80)
icount=1
ifdcount=ifdcount+1
do while (a1(icount).ne.' '.and.icount.le.80)
if(a1(icount).gt.base_small_letters)
1 a1(icount)=a1(icount)-32
icount=icount+1
enddo
a1(icount)=' '
if(a1(1).ne.32.and.a1(1).ne.13.and.a1(1).ne.10) then
do j=1,icount
ii=j-1+icharcount
image(ii)=a1(j)
enddo
icharcount=icharcount+icount
else
ifdcount=ifdcount-1
endif
go to 18
12 close(3)
ifound=ifdcount
open(4,file=file_out_fd,err=13)
do ifilecnt=1,number_include_files
if(ifound.eq.0) go to 88
copying=.false.
open(3,file=filefd(ifilecnt),status='OLD',err=88)
98 read(3,10,end=49,err=49) a
nowchar=1
if(a1(1).eq.'c') a1(1)='C'
if(copying.and.a1(1).ne.'C') then
jcount=80
do while(a1(jcount).eq.32.or.a1(jcount).eq.13.
1 .or.a1(jcount).eq.10.or.a1(jcount).eq.0)
jcount=jcount-1
enddo
c write(4,10,err=49) a
write(4,100,err=49) (a1(jj),jj=1,jcount)
100 format(80a1)
endif
icount=1
do while (a1(icount).ne.' '.and.icount.le.80)
if(a1(icount).gt.base_small_letters)
1 a1(icount)=a1(icount)-32
icount=icount+1
enddo
icount=icount-1
if(a1(1).eq.'C'.and.a1(2).eq.'*') then
copying=.FALSE.
ncount=icount-2
icharcount=1
c Search list in image to see if current module name is one we want
found=.false.
do m=1,ifdcount
icharnow=1
do while (image(nowchar).ne.' '.and.
1 image(nowchar).ne.'*')
b(icharnow)=image(nowchar)
icharnow=icharnow+1
nowchar=nowchar+1
enddo
if(.not.found) nowchar=nowchar+1
if(image(nowchar-1).eq.' '.and.
1 icharnow-1.eq.ncount) then
copying=.true.
do jj=1,ncount
if(b(jj).ne.a1(jj+2)) copying=.false.
enddo
if(copying) then
image(nowchar-1)='*'
ifound=ifound-1
nowchar=nowchar-1
found=.true.
endif
endif
enddo
endif
go to 98
49 close(3)
88 enddo
11 close(4)
write(5,54,err=55) ifdcount,' FD',ifound,' FD','d'
54 format(i8,a3,' Symbols were specified'/i8,a3,
1 ' Symbols were not foun',a1)
c Search list in image to see what symbols were not found
if(ifound.gt.0) then
nowchar=1
write(5,53,err=55) ' FD',':'
53 format(a3,' Symbols not found',a1)
do m=1,ifdcount
icharnow=1
do while (image(nowchar).ne.' '.and.
1 image(nowchar).ne.'*')
b(icharnow)=image(nowchar)
icharnow=icharnow+1
nowchar=nowchar+1
enddo
if(image(nowchar).eq.' ') then
write(5,157,err=154)
1 (b(jj),jj=1,icharnow-1)
157 format(80a1)
154 endif
nowchar=nowchar+1
enddo
endif
55 icharcount=1
ificount=0
open(3,file=file_in_fih,status='OLD',err=13)
28 read(3,10,end=14,err=14) a
icount=1
ificount=ificount+1
do while (a1(icount).ne.' '.and.icount.le.80)
if(a1(icount).gt.base_small_letters)
1 a1(icount)=a1(icount)-32
icount=icount+1
enddo
a1(icount)=' '
if(a1(1).ne.32.and.a1(1).ne.13.and.a1(1).ne.10) then
do j=1,icount
ii=j-1+icharcount
image(ii)=a1(j)
enddo
icharcount=icharcount+icount
else
ificount=ificount-1
endif
go to 28
14 close(3)
ifound=ificount
open(4,file=file_out_fi,err=13)
do ifilecnt=1,number_include_files
if(ifound.eq.0) go to 38
copying=.false.
open(3,file=filefi(ifilecnt),status='OLD',err=38)
68 read(3,10,end=59,err=59) a
nowchar=1
if(a1(1).eq.'c') a1(1)='C'
if(copying.and.a1(1).ne.'C') then
jcount=80
do while(a1(jcount).eq.32.or.a1(jcount).eq.13.
1 .or.a1(jcount).eq.10.or.a1(jcount).eq.0)
jcount=jcount-1
enddo
c write(4,10,err=49) a
write(4,100,err=49) (a1(jj),jj=1,jcount)
endif
icount=1
do while (a1(icount).ne.' '.and.icount.le.80)
if(a1(icount).gt.base_small_letters)
1 a1(icount)=a1(icount)-32
icount=icount+1
enddo
icount=icount-1
if(a1(1).eq.'C'.and.a1(2).eq.'*') then
copying=.FALSE.
ncount=icount-2
icharcount=1
c Search list in image to see if current module name is one we want
found=.false.
do m=1,ificount
icharnow=1
do while (image(nowchar).ne.' '.and.
1 image(nowchar).ne.'*')
b(icharnow)=image(nowchar)
icharnow=icharnow+1
nowchar=nowchar+1
enddo
if(.not.found) nowchar=nowchar+1
if(image(nowchar-1).eq.' '.and.
1 icharnow-1.eq.ncount) then
copying=.true.
do jj=1,ncount
if(b(jj).ne.a1(jj+2)) copying=.false.
enddo
if(copying) then
image(nowchar-1)='*'
ifound=ifound-1
nowchar=nowchar-1
found=.true.
endif
endif
enddo
endif
go to 68
59 close(3)
38 enddo
c write(4,19,err=21) (image(j),j=1,icharcount-1)
21 close(4)
write(5,54,err=56) ificount,' FI',ifound,' FI','d'
c Search list in image to see what symbols were not found
if(ifound.gt.0) then
nowchar=1
write(5,53,err=56) ' FI',':'
do m=1,ificount
icharnow=1
do while (image(nowchar).ne.' '.and.
1 image(nowchar).ne.'*')
b(icharnow)=image(nowchar)
icharnow=icharnow+1
nowchar=nowchar+1
enddo
if(image(nowchar).eq.' ') then
write(5,157,err=51) (b(jj),jj=1,icharnow-1)
51 endif
nowchar=nowchar+1
enddo
endif
56 close(5)
13 nerr=destroywindow(hwnd)
end select
case (WM_PAINT)
hDC=BeginPaint(hWnd,ps)
ierr=SetBkMode(hDC,OPAQUE)
ipreviouscolor=SetTextColor(hdc,yellow)
ipreviouscolor=SetBkColor(hdc,blue)
ierr=SelectObject(hDC,GetStockObject(SYSTEM_FIXED_FONT))
ierr=GetTextMetrics(hDC,tm)
cxChar=tm.tmAveCharWidth
cyChar=tm.tmHeight+tm.tmExternalLeading
Wintitle=filepre
wintitle(numchar+4:numchar+4)='\0'c
call SetWindowText(hWnd,WinTitle)
hmemorydc=createcompatibledc(hdc)
hbitmap=createdibitmap(hdc,locfar(bitmapinfo),
1 CBM_INIT,locfar(image),locfar(bitmapinfo),
2 DIB_RGB_COLORS)
holdbitmap=selectobject(hmemorydc,hbitmap)
C extent_x&y set by wm_size message handler and are correct
ierr=bitblt(hdc,0,0,extent_x,extent_y,
1 hmemorydc,0,0,SRCCOPY)
ierr=deletedc(hmemorydc)
call deleteobject(hbitmap)
if(ifirsttime.eq.0) then
ifirsttime=1
iberr=SendMessage(hwnd,WM_COMMAND,IDM_NEXT,1)
endif
Call EndPaint(hwnd,ps)
case (WM_SIZE)
IPIXX=LOWORD(lParam)
IPIXY=HIWORD(lParam)
IPIXX1=IPIXX-1
IPIXY1=IPIXY-1
pixx1=ipixx1
pixy1=ipixy1
pixx=ipixx
pixy=ipixy
extent_x=IPIXX
extent_y=IPIXY
ifirstpass=0
call InvalidateRect(hWnd,Null,True)
case (WM_CHAR)
select case (wParam)
case(escape)
nerr=destroywindow(hwnd)
return
case DEFAULT
mainwindowproc = DefWindowProc (hWnd,
1 wMsgID, wParam, lParam)
END SELECT
case (WM_CLOSE)
nerr=destroywindow(hwnd)
case (WM_DESTROY)
Call DeleteObject(hbgbrush)
Call DeleteObject(hpenblue)
Call DeleteObject(hpenred)
Call DeleteObject(hpenblack)
Call DeleteObject(hpenwhite)
Call DeleteObject(hpengreen)
Call DeleteObject(hpenyellow)
Call DeleteObject(hpenlightblue)
Call DeleteObject(hpenpurple)
Call PostQuitMessage(0)
case DEFAULT
mainwindowproc = DefWindowProc (hWnd,
1 wMsgID, wParam, lParam)
END SELECT
return
7777 nerr=destroywindow(hwnd)
return
9940 NUMERRS=NUMERRS+1
IF(NUMERRS.GT.20) nerr=destroywindow(hwnd)
return
end
SUBROUTINE GET_NAME_OF_FILE(BUF,FILEEQUIPMENT,NUMCHAR)
CHARACTER*30 FILEEQUIPMENT,BUF
character*1 term
PARAMETER (term=0)
NUMCHAR=1
DO WHILE (NUMCHAR.le.30.and.BUF(NUMCHAR:NUMCHAR).ne.term)
NUMCHAR=NUMCHAR+1
END DO
DO J=1,30
IF (J.LE.Numchar-1) THEN
FILEEQUIPMENT(J:J)=BUF(J:J)
ELSE
IF (J.EQ.Numchar) THEN
FILEEQUIPMENT(J:J)='.'
ELSE IF (J.EQ.Numchar+1) THEN
FILEEQUIPMENT(J:J)='E'
ELSE IF (J.EQ.Numchar+2) THEN
FILEEQUIPMENT(J:J)='Q'
ELSE IF (J.EQ.Numchar+3) THEN
FILEEQUIPMENT(J:J)='U'
ELSE
FILEEQUIPMENT(J:J)=' '
ENDIF
ENDIF
END DO
RETURN
END
Subroutine Put_Buffer(name1,name2,value1,value2,ipointer,length)
Real name1(1),name2(1)
ipointer=ipointer+1
if(ipointer.gt.length) ipointer=1
name1(ipointer)=value1
name2(ipointer)=value2
Return
End
Subroutine Get_Buffer(name1,value1,ipointer,length,index)
Real name1(1)
iipointer=ipointer+index
if(iipointer.gt.length) iipointer=iipointer-length
if(iipointer.lt.1) iipointer=length+iipointer
value1=name1(iipointer)
Return
End