home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / fortran / mslang / prefor / scrunch_.for < prev    next >
Text File  |  1993-10-19  |  26KB  |  643 lines
  1. C     Totally FORTRAN implementation of Precompiler Includes Scruncher
  2. C     by Barry W. McCleave, PhD, P.E. 601-634-2599
  3.       include 'prefor32.fi'      
  4. C      FORM TEMPLATE
  5. c      itemtype()=I (or i) means integer*2      Int
  6. c      itemtype()=L (or l) means integer*4      Longint
  7. c      itemtype()=R (or r) means real*4         Real
  8. c      itemtype()=D (or d )means real*8         Double Precision
  9. c      itemtype()=C (or c) means string         Characters (termination \)
  10. c      itemtype()=S (or s) choice only          Selection
  11. c      itemtype()=T (or t) comment field        Text
  12. c      itemtype()=H (or h) form title           Heading
  13. c      itemchosen()= the list item selected (0 if edit entry)
  14. c      delimeter=^ after each selection list item; before first list item 
  15. c      delimeter=| at end of every form item
  16. c      delimeter=\ at end of every text line (\\ produces \ if c string)
  17. c      last item followed by 0 (\0 poduces 0 if c string)
  18.  
  19.       integer*4 function WinMain [stdcall,alias:'_WinMain@16'] 
  20.      1 (hInstance[VALUE], 
  21.      1 hPrevInstance[VALUE],lpszCmdLine[VALUE], nCmdShow[VALUE])      
  22.       include 'prefor32.fd'
  23.       integer*4 hinstance,hprevinstance
  24.       integer*4 lpszcmdline
  25.       integer*4 ncmdshow
  26.       integer*4 initmain 
  27.       integer*4 hwnd,mainmsgloop 
  28.       if(initmain(hinstance,hprevinstance,ncmdshow,hwnd).eq.TRUE) 
  29.      1  WinMain=mainmsgloop(hinstance)
  30.       return
  31.       end
  32.  
  33.        integer*4 Function Initmain (
  34.      1 hInstance,hPrevInstance,ncmdshow,hwnd)
  35.        include 'prefor32.fd'
  36.        external mainwindowproc
  37.        integer*4 hInstance,hPrevInstance,nCmdShow,hbgbrush
  38.        integer*4 createwindowex,loadcursor,registerclass
  39.       record /wndclass/ windowclass
  40.       integer*4   hWnd,hinst,CreateSolidBrush
  41.       common /edatamain/ hinst,hbgbrush
  42.        integer*4 blue
  43. c      colorref format is #bbggrr    blue green red
  44.        parameter (blue=#7F0000)
  45. c       integer*4 idc_arrow
  46. c       data idc_arrow/32512/
  47.       Initmain = TRUE
  48.       hinst=hinstance
  49.       if (hPrevInstance.eq.false) then
  50.          WindowClass.lpszClassName = locfar('EdatWin'C)
  51.          WindowClass.hInstance     = hInstance
  52.          WindowClass.lpfnWndProc   = locfar(mainwindowproc)
  53.          WindowClass.hCursor       = LoadCursor(null,idc_arrow)
  54.          WindowClass.hIcon         = NULL
  55.          WindowClass.lpszMenuName  = NULL
  56.          hbgbrush = CreateSolidBrush(blue)
  57.          WindowClass.hbrBackground = hbgbrush
  58.          WindowClass.style         = 0
  59.          WindowClass.cbClsExtra    = 0
  60.          WindowClass.cbWndExtra    = 0
  61.          if (RegisterClass (WindowClass).eq.false) Initmain = false
  62.       end if
  63.       hWnd = CreateWindowEx(0,locfar('EdatWin'C),locfar('EDITDATA'C),            
  64.      1 WS_OVERLAPPEDWINDOW,CW_USEDEFAULT,0,CW_USEDEFAULT,0,NULL,               
  65.      1 NULL,hInstance,NULL)           
  66.       call ShowWindow (hWnd,nCmdShow)
  67.       call UpdateWindow(hWnd)
  68.       return 
  69.       end
  70.  
  71.       integer*4 Function mainMsgLoop(hInstance)
  72.       integer*4 hInstance
  73.        include 'prefor32.fd'
  74.        Record /tagmsg/ msg
  75.        integer*4 GetMessage
  76.       DO WHILE (GetMessage(msg,null,0,0).ne.false)
  77.          Call TranslateMessage(msg)
  78.          Call DispatchMessage(msg)
  79.          mainMsgLoop=msg.wParam
  80.       End Do
  81.       return
  82.       end
  83.       
  84.       Integer*4 Function mainwindowproc [stdcall,
  85.      1 alias:'_MAINWINDOWPROC']
  86.      1 (hWnd[VALUE],wMsgID[VALUE],wParam[VALUE],lParam[VALUE])
  87.       include 'prefor32.fd'
  88.       integer*4 hWnd,wMsgID,wParam,hparent
  89.       Integer*4 lParam,lberr,lselected
  90.       Character*80 TextBuffer 
  91.       integer*4 hinst,hbgbrush 
  92.       common /edatamain/ hinst,hbgbrush
  93.       integer*4 SelectObject,i,nowitem
  94.       integer*4 hWndEdit,GetWindowText,xmax,ymax 
  95.       integer*4 defwindowproc,ws_mybutton
  96.       integer*4 createwindow,setfocus,loword,hiword,destroywindow
  97.       integer*4 SetBkMode,BeginPaint
  98.       integer*4 cxChar,hdc,ierr,TextOut,numread
  99.       integer*4 GetDC,GetTextMetrics,GetStockObject,ReleaseDC
  100.       INTEGER*4 ipreviouscolor,SetTextColor,SetBkColor,GetSysColor
  101.       integer*4 SendMessage
  102.       Record /tagTextMetric/ tm
  103.       Record /tagRect/ rect
  104.       Record /tagPAINTSTRUCT/ ps
  105.       Record /tagLOGPEN/ pen
  106.       logical*1 form,confirmed
  107.       integer*4 hinstance,hprevinstance,hPR
  108.       integer*4 lpszcmdline
  109.       integer*4 ncmdshow
  110.       integer*4 initmain,extent_x,extent_y 
  111.       INTEGER*1 UPARROW,DOWNARROW,LEFTARROW,RIGHTARROW
  112.       CHARACTER*12 FILENAM
  113.       character*13 wintitle
  114.       CHARACTER*1 TYPDAFIL,RFLAG  
  115.        integer*1 IIA,IIE,IIS,IIL,IIR,IID,IIP
  116.       INTEGER*1 IIM,IIX,IIT,IIY,IIN
  117.       integer*4 INFILEPTR
  118.       CHARACTER*80 A
  119.       integer*1 a1(80),b(80)
  120.       character*12 filefd(20)
  121.       character*12 filefi(20)
  122.       CHARACTER*35 fileform 
  123.       character*30 file_in_fih,file_in_fdh,file_out_fi,file_out_fd
  124. c      CHARACTER*30 FILELIN,FILELI2,FILEPRE,FILEPOST
  125.       LOGICAL*1 MODIFY_OLD,FLGCONFIRMED,GROUPCONFIRM
  126.       REAL*8 INFROWS(2)
  127.       REAL*8 LINEROWS(1)
  128. c      INTEGER*1 FILEPOSTDREDGE(30),FILEPOSTLINES(30)
  129.       CHARACTER*30 FILEN,file_out_pre
  130.       integer*1 itemchfile(2)
  131.       LOGICAL*1 REDRAW,NONE,GRAPH,RESOLUTION
  132.       integer*4 color(80)
  133.       character*1 image(200000)
  134.       common/bigimage/image
  135.       common/pallet2/bitmapinfo,pal
  136.       Record /tagbitmapfileheader/ bitmapfileheader
  137.       Record /tagbitmapinfoheader/ bitmapinfo
  138.       integer*4 hmemorydc,hbitmap,deletedc
  139.       integer*4 pal(512)
  140.       integer*4 createcompatibledc,createdibitmap,bitblt
  141.       integer*4 hpenbackground,hpenline,cychar
  142.       COMMON/COLORS/hpenbackground,hpenline,cychar
  143.       EQUIVALENCE (INFROWS(1),INFILEPTR)
  144.       equivalence (a,a1(1))
  145.       logical*1 copying,found
  146.       integer*4 hpenblue,hpengreen,hpenyellow,hpenwhite,hpenred,
  147.      1 hpenblack
  148.        integer*4 return,escape,char_fsmall,char_flarge
  149.        integer*4 char_nsmall,char_nlarge,char_lsmall,char_llarge
  150.        integer*4 char_dsmall,char_dlarge,char_usmall,char_ularge
  151.        integer*4 char_asmall,char_alarge,char_psmall,char_plarge
  152.        integer*4 char_hsmall,char_hlarge
  153.        integer*4 char_0,char_1,char_2,char_3,char_4,char_5,char_6
  154.        integer*4 char_7,char_8,char_9,alt,shift
  155.        integer*4 left_arrow,right_arrow,up_arrow,down_arrow
  156.        integer*4 blue,yellow,red,black,white,green,lightblue,purple
  157.        integer*4 idm_next
  158.        integer*1 base_small_letters
  159.        parameter (idm_next=#300)
  160. c      colorref format is #bbggrr    blue green red
  161.        parameter (blue=#7F0000)
  162.        parameter (yellow=#00CFCF)
  163.        parameter (green=#00FF00)
  164.        parameter (red=#0000FF)
  165.        parameter (white=#FFFFFF)
  166.        parameter (black=#0)
  167.        parameter (lightblue=#CFCF00)
  168.        parameter (purple=#CF00CF)
  169.        parameter (return=13)
  170.        parameter (escape=27)
  171.        parameter (alt=#12)
  172.        parameter (shift=#10)
  173.        parameter (right_arrow=#27)
  174.        parameter (left_arrow=#25)
  175.        parameter (up_arrow=#26)
  176.        parameter (down_arrow=#28)
  177.        parameter (char_fsmall=#66)
  178.        parameter (char_flarge=#46)
  179.        parameter (char_hsmall=#68)
  180.        parameter (char_hlarge=#48)
  181.        parameter (char_lsmall=#6c)
  182.        parameter (char_llarge=#4c)
  183.        parameter (char_nsmall=#6e)
  184.        parameter (char_nlarge=#4e)
  185.        parameter (char_psmall=#70)
  186.        parameter (char_plarge=#50)
  187.        parameter (char_usmall=#75)
  188.        parameter (char_ularge=#55)
  189.        parameter (char_dsmall=#64)
  190.        parameter (char_dlarge=#44)
  191.        parameter (char_asmall=#61)
  192.        parameter (char_alarge=#41)
  193.        parameter (char_0=#30)
  194.        parameter (char_1=#31)
  195.        parameter (char_2=#32)
  196.        parameter (char_3=#33)
  197.        parameter (char_4=#34)
  198.        parameter (char_5=#35)
  199.        parameter (char_6=#36)
  200.        parameter (char_7=#37)
  201.        parameter (char_8=#38)
  202.        parameter (char_9=#39)
  203.       integer*4 CreatePenIndirect
  204.       data itemchfile/0,1/
  205.       DATA FILEform/'cProgram Name^OOPS, EXIT PROGRAM^|\0'c/   
  206.       data itemchline/0/
  207.       DATA SPACE/1H /,ZERO/1H0/
  208.       DATA INFCHOS,INFCHOS2,ONE,TWO,MINUS/1,2,1H1,1H2,1H-/  
  209.       DATA IIA/1HA/,
  210.      1 IIS/1HS/,IIY/1HY/,IIN/1HN/,IIP/1HP/
  211.       DATA IIE/1HE/,IIL/1HL/,IIM/1HM/,IID/1HD/,IIR/1HR/,IIX/1HX/,
  212.      1 IIT/1HT/
  213.       data filen/'\0'c/
  214.       data pen.style,pen.x,pen.y,pen.color/PS_SOLID,1,1,YELLOW/
  215.       data base_small_letters/96/
  216.       data filefd/'USER32.FD   ','GDI32.FD    ','KERNEL32.FD ',
  217.      1'COMDLG32.FD ','COMCTL32.FD ','WIN32SPL.FD ','SHELL32.FD  ',
  218.      2'NETAPI32.FD ','OLECLI32.FD ','OLESVR32.FD ','RASAPI32.FD ',
  219.      3'LZ32.FD     ','ADVAPI32.FD ',7*'            '/
  220.       data filefi/'USER32.FI   ','GDI32.FI    ','KERNEL32.FI ',
  221.      1'COMDLG32.FI ','COMCTL32.FI ','WIN32SPL.FI ','SHELL32.FI  ',
  222.      2'NETAPI32.FI ','OLECLI32.FI ','OLESVR32.FI ','RASAPI32.FI ',
  223.      3'LZ32.FI     ','ADVAPI32.FI ',7*'            '/            
  224.       data number_include_files/13/
  225.       data copying,found/2*.FALSE./
  226. c     return TRUE unless unless handles by DefWindowProc
  227.       mainwindowproc = true
  228.       select case (wMsgID)
  229.          case (WM_CREATE)
  230.            hdc=GetDC(hWnd)
  231.            ierr=SelectObject(hdc,GetStockObject(SYSTEM_FIXED_FONT))
  232.            ierr=GetTextMetrics(hdc,tm)
  233.            cxChar=tm.tmAveCharWidth
  234.            cyChar=tm.tmHeight+tm.tmExternalLeading
  235.            ierr=ReleaseDC(hwnd,hdc)
  236.            pen.color=yellow
  237.            hpenyellow=CreatePenIndirect(pen)
  238.            pen.color=red
  239.            hpenred=CreatePenIndirect(pen)
  240.            pen.color=green
  241.            hpengreen=CreatePenIndirect(pen)
  242.            pen.color=white
  243.            hpenwhite=CreatePenIndirect(pen)
  244.            pen.color=black
  245.            hpenblack=CreatePenIndirect(pen)
  246.            pen.color=blue
  247.            hpenblue=CreatePenIndirect(pen)
  248.            hpenbackground=hpenblue
  249.            pen.color=lightblue
  250.            hpenlightblue=CreatePenIndirect(pen)
  251.            pen.color=purple
  252.            hpenpurple=CreatePenIndirect(pen)
  253.            color(1)=hpenblue
  254.            color(2)=hpenyellow
  255.            color(3)=hpengreen
  256.            color(4)=hpenwhite
  257.            color(5)=hpenblack
  258.            color(6)=hpenred
  259.            color(7)=hpenpurple
  260.            color(8)=hpenlightblue
  261.            IPIXX=640
  262.            IPIXY=480
  263.            IPIXLET=10     
  264.            IPIXY1=IPIXY-1
  265.            PIXY=IPIXY
  266.            PIXY1=IPIXY1
  267.            IPIXX1=IPIXX-1
  268.            PIXX1=IPIXX1
  269.            PIXX=IPIXX
  270.                OPEN(7,FILE='corps.bmp',FORM='BINARY',STATUS='OLD',ERR=9)
  271.                read(7,err=8,end=8) bitmapfileheader.bftype,
  272.      1          bitmapfileheader.bfSize,bitmapfileheader.bfReserved1,
  273.      2          bitmapfileheader.bfReserved2,bitmapfileheader.bfOffbits
  274.                read(7,err=8,end=8) bitmapinfo.bisize,
  275.      1          bitmapinfo.biWidth,bitmapinfo.biHeight,
  276.      2          bitmapinfo.biPlanes,bitmapinfo.biBitCount,
  277.      3          bitmapinfo.biCompression,bitmapinfo.biSizeImage,
  278.      4          bitmapinfo.biXPelsPerMeter,bitmapinfo.biYPelsPerMeter,
  279.      5          bitmapinfo.biClrUsed,bitmapinfo.biClrImportant
  280. c    40 and 14 are the sizes of the 2 header blocks; pal is Integer*4 array
  281.                iskip=(bitmapfileheader.bfOffbits-40-14)/4
  282.                if(iskip.ge.1) then
  283.                   do j=1,iskip
  284.                      read(7,err=8134,end=8134) pal(j)
  285.                   enddo
  286.                endif
  287. 8134              if(bitmapinfo.biBitCount.eq.1) 
  288.      1             linewidthbytes=(bitmapinfo.biWidth+7)/8
  289.                   if(bitmapinfo.biBitCount.eq.4) 
  290.      1             linewidthbytes=(bitmapinfo.biWidth+1)/2
  291.                   if(bitmapinfo.biBitCount.eq.8) 
  292.      1             linewidthbytes=bitmapinfo.biWidth
  293.                   if(bitmapinfo.biBitCount.eq.24) 
  294.      1             linewidthbytes=bitmapinfo.biWidth*3
  295.                ibase=0
  296.                do j=bitmapinfo.biheight,1,-1
  297.                   read(7,err=8,end=8) (image(jj+ibase),
  298.      1             jj=1,linewidthbytes)
  299.                   ibase=ibase+linewidthbytes
  300.                
  301.                enddo
  302. 8              close(7)
  303. 9              continue
  304.                ifirsttime=0
  305.                call InvalidateRect(hWnd,Null,True)
  306.          case (WM_COMMAND)
  307.            select case (wParam)
  308.              case (IDM_NEXT)
  309.                INFILEPTR=LOCFAR(FILEN)
  310.                IF(FORM(hinst,hWnd,fileform,itemchfile,infrows)) THEN
  311.                   IF(Itemchfile(1).EQ.1) GO TO 7777
  312.                   CALL GET_NAME_OF_FILE(FILEN,FILE_IN_FDH,NUMCHAR)
  313.                   file_in_fdh(numchar+1:numchar+3)='FDH'
  314.                   file_in_fih=file_in_fdh
  315.                   file_in_fih(numchar+1:numchar+3)='FIH'
  316.                   file_out_fi=file_in_fdh
  317.                   file_out_fi(numchar+1:numchar+3)='FI '
  318.                   file_out_fd=file_in_fdh
  319.                   file_out_fd(numchar+1:numchar+3)='FD '
  320.                   file_out_pre=file_in_fdh
  321.                   file_out_pre(numchar+1:numchar+3)='PRE'
  322.                else
  323.                  nerr=destroywindow(hwnd)
  324.                  return
  325.                ENDIF
  326.                  icharcount=1
  327.                  ifdcount=0
  328.                  open(5,file=file_out_pre)
  329.                  open(3,file=file_in_fdh,status='OLD',err=13)
  330.  18              read(3,10,end=12,err=12) a
  331.  10              format(a80)
  332.                  icount=1
  333.                  ifdcount=ifdcount+1
  334.                  do while (a1(icount).ne.' '.and.icount.le.80)
  335.                     if(a1(icount).gt.base_small_letters) 
  336.      1               a1(icount)=a1(icount)-32
  337.                     icount=icount+1
  338.                  enddo
  339.                  a1(icount)=' '
  340.                  if(a1(1).ne.32.and.a1(1).ne.13.and.a1(1).ne.10) then
  341.                     do j=1,icount
  342.                        ii=j-1+icharcount
  343.                        image(ii)=a1(j)
  344.                     enddo
  345.                     icharcount=icharcount+icount
  346.                  else
  347.                     ifdcount=ifdcount-1
  348.                  endif
  349.                  go to 18
  350.  12              close(3)
  351.                  ifound=ifdcount
  352.                  open(4,file=file_out_fd,err=13)
  353.                  do ifilecnt=1,number_include_files
  354.                     if(ifound.eq.0) go to 88
  355.                     copying=.false.
  356.                     open(3,file=filefd(ifilecnt),status='OLD',err=88)
  357.  98                 read(3,10,end=49,err=49) a
  358.                     nowchar=1
  359.                     if(a1(1).eq.'c') a1(1)='C'
  360.                     if(copying.and.a1(1).ne.'C') then
  361.                        jcount=80
  362.                        do while(a1(jcount).eq.32.or.a1(jcount).eq.13.
  363.      1                  .or.a1(jcount).eq.10.or.a1(jcount).eq.0)
  364.                           jcount=jcount-1
  365.                        enddo
  366. c                       write(4,10,err=49) a
  367.                         write(4,100,err=49) (a1(jj),jj=1,jcount)
  368.  100                    format(80a1)
  369.                     endif
  370.                     icount=1
  371.                     do while (a1(icount).ne.' '.and.icount.le.80)
  372.                        if(a1(icount).gt.base_small_letters) 
  373.      1                  a1(icount)=a1(icount)-32
  374.                        icount=icount+1
  375.                     enddo
  376.                     icount=icount-1
  377.                     if(a1(1).eq.'C'.and.a1(2).eq.'*') then
  378.                        copying=.FALSE.
  379.                        ncount=icount-2
  380.                        icharcount=1
  381. c     Search list in image to see if current module name is one we want
  382.                        found=.false.
  383.                        do m=1,ifdcount
  384.                           icharnow=1
  385.                           do while (image(nowchar).ne.' '.and.
  386.      1                     image(nowchar).ne.'*')
  387.                              b(icharnow)=image(nowchar)
  388.                              icharnow=icharnow+1
  389.                              nowchar=nowchar+1
  390.                           enddo
  391.                           if(.not.found) nowchar=nowchar+1
  392.                           if(image(nowchar-1).eq.' '.and.
  393.      1                     icharnow-1.eq.ncount) then
  394.                              copying=.true.
  395.                              do jj=1,ncount
  396.                                 if(b(jj).ne.a1(jj+2)) copying=.false.
  397.                              enddo
  398.                              if(copying) then
  399.                                 image(nowchar-1)='*'
  400.                                 ifound=ifound-1
  401.                                 nowchar=nowchar-1
  402.                                 found=.true.
  403.                              endif
  404.                           endif
  405.                        enddo
  406.                     endif
  407.                     go to 98
  408. 49                  close(3)
  409. 88               enddo
  410.  11              close(4)
  411.                  write(5,54,err=55) ifdcount,' FD',ifound,' FD','d'
  412.  54              format(i8,a3,' Symbols were specified'/i8,a3,
  413.      1            ' Symbols were not foun',a1)
  414. c     Search list in image to see what symbols were not found
  415.                    if(ifound.gt.0) then
  416.                        nowchar=1
  417.                        write(5,53,err=55) ' FD',':'
  418.  53                    format(a3,' Symbols not found',a1)
  419.                        do m=1,ifdcount
  420.                           icharnow=1
  421.                           do while (image(nowchar).ne.' '.and.
  422.      1                     image(nowchar).ne.'*')
  423.                              b(icharnow)=image(nowchar)
  424.                              icharnow=icharnow+1
  425.                              nowchar=nowchar+1
  426.                           enddo
  427.                           if(image(nowchar).eq.' ') then
  428.                              write(5,157,err=154) 
  429.      1                        (b(jj),jj=1,icharnow-1)
  430.  157                         format(80a1)
  431.  154                      endif
  432.                           nowchar=nowchar+1
  433.                        enddo
  434.                     endif
  435.  55              icharcount=1
  436.                  ificount=0
  437.                  open(3,file=file_in_fih,status='OLD',err=13)
  438.  28              read(3,10,end=14,err=14) a
  439.                  icount=1
  440.                  ificount=ificount+1
  441.                  do while (a1(icount).ne.' '.and.icount.le.80)
  442.                     if(a1(icount).gt.base_small_letters) 
  443.      1               a1(icount)=a1(icount)-32
  444.                     icount=icount+1
  445.                  enddo
  446.                  a1(icount)=' '
  447.                  if(a1(1).ne.32.and.a1(1).ne.13.and.a1(1).ne.10) then
  448.                     do j=1,icount
  449.                        ii=j-1+icharcount
  450.                        image(ii)=a1(j)
  451.                     enddo
  452.                     icharcount=icharcount+icount
  453.                  else
  454.                     ificount=ificount-1
  455.                  endif
  456.                  go to 28
  457.  14              close(3)
  458.                  ifound=ificount
  459.                  open(4,file=file_out_fi,err=13)
  460.                  do ifilecnt=1,number_include_files
  461.                     if(ifound.eq.0) go to 38
  462.                     copying=.false.
  463.                     open(3,file=filefi(ifilecnt),status='OLD',err=38)
  464.  68                 read(3,10,end=59,err=59) a
  465.                     nowchar=1
  466.                     if(a1(1).eq.'c') a1(1)='C'
  467.                     if(copying.and.a1(1).ne.'C') then
  468.                        jcount=80
  469.                        do while(a1(jcount).eq.32.or.a1(jcount).eq.13.
  470.      1                  .or.a1(jcount).eq.10.or.a1(jcount).eq.0)
  471.                           jcount=jcount-1
  472.                        enddo
  473. c                       write(4,10,err=49) a
  474.                         write(4,100,err=49) (a1(jj),jj=1,jcount)
  475.                     endif
  476.                     icount=1
  477.                     do while (a1(icount).ne.' '.and.icount.le.80)
  478.                        if(a1(icount).gt.base_small_letters) 
  479.      1                  a1(icount)=a1(icount)-32
  480.                        icount=icount+1
  481.                     enddo
  482.                     icount=icount-1
  483.                     if(a1(1).eq.'C'.and.a1(2).eq.'*') then
  484.                        copying=.FALSE.
  485.                        ncount=icount-2
  486.                        icharcount=1
  487. c     Search list in image to see if current module name is one we want
  488.                        found=.false.
  489.                        do m=1,ificount
  490.                           icharnow=1
  491.                           do while (image(nowchar).ne.' '.and.
  492.      1                     image(nowchar).ne.'*')
  493.                              b(icharnow)=image(nowchar)
  494.                              icharnow=icharnow+1
  495.                              nowchar=nowchar+1
  496.                           enddo
  497.                           if(.not.found) nowchar=nowchar+1
  498.                           if(image(nowchar-1).eq.' '.and.
  499.      1                     icharnow-1.eq.ncount) then
  500.                              copying=.true.
  501.                              do jj=1,ncount
  502.                                 if(b(jj).ne.a1(jj+2)) copying=.false.
  503.                              enddo
  504.                              if(copying) then
  505.                                 image(nowchar-1)='*'
  506.                                 ifound=ifound-1
  507.                                 nowchar=nowchar-1
  508.                                 found=.true.
  509.                              endif
  510.                           endif
  511.                        enddo
  512.                     endif
  513.                     go to 68
  514. 59                  close(3)
  515. 38               enddo
  516. c                 write(4,19,err=21) (image(j),j=1,icharcount-1)
  517.  21              close(4)
  518.                  write(5,54,err=56) ificount,' FI',ifound,' FI','d'
  519. c     Search list in image to see what symbols were not found
  520.                    if(ifound.gt.0) then
  521.                        nowchar=1
  522.                        write(5,53,err=56) ' FI',':'
  523.                        do m=1,ificount
  524.                           icharnow=1
  525.                           do while (image(nowchar).ne.' '.and.
  526.      1                     image(nowchar).ne.'*')
  527.                              b(icharnow)=image(nowchar)
  528.                              icharnow=icharnow+1
  529.                              nowchar=nowchar+1
  530.                           enddo
  531.                           if(image(nowchar).eq.' ') then
  532.                              write(5,157,err=51) (b(jj),jj=1,icharnow-1)
  533.  51                       endif
  534.                           nowchar=nowchar+1
  535.                        enddo
  536.                     endif
  537.  56              close(5)
  538.  13              nerr=destroywindow(hwnd)
  539.            end select
  540.          case (WM_PAINT)
  541.             hDC=BeginPaint(hWnd,ps)
  542.             ierr=SetBkMode(hDC,OPAQUE)
  543.             ipreviouscolor=SetTextColor(hdc,yellow)
  544.             ipreviouscolor=SetBkColor(hdc,blue)
  545.             ierr=SelectObject(hDC,GetStockObject(SYSTEM_FIXED_FONT))
  546.             ierr=GetTextMetrics(hDC,tm)
  547.             cxChar=tm.tmAveCharWidth
  548.             cyChar=tm.tmHeight+tm.tmExternalLeading
  549.             Wintitle=filepre
  550.             wintitle(numchar+4:numchar+4)='\0'c
  551.             call SetWindowText(hWnd,WinTitle)
  552.                hmemorydc=createcompatibledc(hdc)
  553.                hbitmap=createdibitmap(hdc,locfar(bitmapinfo),
  554.      1          CBM_INIT,locfar(image),locfar(bitmapinfo),
  555.      2          DIB_RGB_COLORS)
  556.                holdbitmap=selectobject(hmemorydc,hbitmap)
  557. C   extent_x&y set by wm_size message handler and are correct               
  558.                ierr=bitblt(hdc,0,0,extent_x,extent_y,
  559.      1          hmemorydc,0,0,SRCCOPY)
  560.                ierr=deletedc(hmemorydc)
  561.                call deleteobject(hbitmap)
  562.             if(ifirsttime.eq.0) then
  563.                ifirsttime=1
  564.                iberr=SendMessage(hwnd,WM_COMMAND,IDM_NEXT,1)
  565.             endif
  566.             Call EndPaint(hwnd,ps)
  567.          case (WM_SIZE)
  568.             IPIXX=LOWORD(lParam)
  569.             IPIXY=HIWORD(lParam)
  570.             IPIXX1=IPIXX-1
  571.             IPIXY1=IPIXY-1
  572.             pixx1=ipixx1
  573.             pixy1=ipixy1
  574.             pixx=ipixx
  575.             pixy=ipixy
  576.             extent_x=IPIXX
  577.             extent_y=IPIXY
  578.             ifirstpass=0
  579.             call InvalidateRect(hWnd,Null,True)
  580.          case (WM_CHAR)
  581.            select case (wParam)
  582.             case(escape)
  583.                nerr=destroywindow(hwnd)
  584.                return
  585.             case DEFAULT
  586.               mainwindowproc = DefWindowProc (hWnd, 
  587.      1         wMsgID, wParam, lParam)
  588.          END SELECT
  589.       case (WM_CLOSE)
  590.          nerr=destroywindow(hwnd)
  591.       case (WM_DESTROY)
  592.          Call DeleteObject(hbgbrush)
  593.          Call DeleteObject(hpenblue)
  594.          Call DeleteObject(hpenred)
  595.          Call DeleteObject(hpenblack)
  596.          Call DeleteObject(hpenwhite)
  597.          Call DeleteObject(hpengreen)
  598.          Call DeleteObject(hpenyellow)
  599.          Call DeleteObject(hpenlightblue)
  600.          Call DeleteObject(hpenpurple)
  601.          Call PostQuitMessage(0)
  602.       case DEFAULT
  603.          mainwindowproc = DefWindowProc (hWnd, 
  604.      1    wMsgID, wParam, lParam)
  605.       END SELECT
  606.       return
  607. 7777  nerr=destroywindow(hwnd)
  608.       return
  609. 9940  NUMERRS=NUMERRS+1
  610.       IF(NUMERRS.GT.20) nerr=destroywindow(hwnd)
  611.       return
  612.       end
  613.  
  614.       SUBROUTINE GET_NAME_OF_FILE(BUF,FILEEQUIPMENT,NUMCHAR)
  615.       CHARACTER*30 FILEEQUIPMENT,BUF
  616.       character*1 term
  617.       PARAMETER (term=0)
  618.       NUMCHAR=1
  619.       DO WHILE (NUMCHAR.le.30.and.BUF(NUMCHAR:NUMCHAR).ne.term)
  620.             NUMCHAR=NUMCHAR+1
  621.       END DO
  622.       DO J=1,30
  623.          IF (J.LE.Numchar-1) THEN
  624.             FILEEQUIPMENT(J:J)=BUF(J:J)
  625.          ELSE
  626.             IF (J.EQ.Numchar) THEN
  627.                FILEEQUIPMENT(J:J)='.'
  628.             ELSE IF (J.EQ.Numchar+1) THEN
  629.                FILEEQUIPMENT(J:J)='E'
  630.             ELSE IF (J.EQ.Numchar+2) THEN
  631.                
  632.                FILEEQUIPMENT(J:J)='Q'
  633.             ELSE IF (J.EQ.Numchar+3) THEN
  634.                FILEEQUIPMENT(J:J)='U'
  635.             ELSE
  636.                FILEEQUIPMENT(J:J)=' '
  637.             ENDIF
  638.          ENDIF
  639.       END DO
  640.       RETURN
  641.       END
  642.       
  643.