home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / fortran / mslang / prefor / prefor32.for < prev    next >
Encoding:
Text File  |  1993-10-26  |  34.3 KB  |  842 lines
  1. C     Totally FORTRAN implementation of Precompiler Includes Generator
  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),c(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.       CHARACTER*30 file_in_for
  125.       LOGICAL*1 MODIFY_OLD,FLGCONFIRMED,GROUPCONFIRM
  126.       REAL*8 INFROWS(2)
  127.       REAL*8 LINEROWS(1)
  128.       CHARACTER*30 FILEN,file_out_pre
  129.       integer*1 itemchfile(2)
  130.       LOGICAL*1 REDRAW,NONE,GRAPH,RESOLUTION
  131.       integer*4 color(80)
  132.       character*1 image(1500000)
  133.       integer*4 start_char(50000)
  134.       integer*2 length_char(50000)
  135.       common/bigimage/image
  136.       common/pallet2/bitmapinfo,pal
  137.       Record /tagbitmapfileheader/ bitmapfileheader
  138.       Record /tagbitmapinfoheader/ bitmapinfo
  139.       integer*4 hmemorydc,hbitmap,deletedc
  140.       integer*4 pal(512)
  141.       integer*4 createcompatibledc,createdibitmap,bitblt
  142.       integer*4 hpenbackground,hpenline,cychar
  143.       COMMON/COLORS/hpenbackground,hpenline,cychar
  144.       EQUIVALENCE (INFROWS(1),INFILEPTR)
  145.       equivalence (a,a1(1))
  146.       logical*1 copying,found
  147.       integer*4 hpenblue,hpengreen,hpenyellow,hpenwhite,hpenred,
  148.      1 hpenblack
  149.        integer*4 return,escape,char_fsmall,char_flarge
  150.        integer*4 char_nsmall,char_nlarge,char_lsmall,char_llarge
  151.        integer*4 char_dsmall,char_dlarge,char_usmall,char_ularge
  152.        integer*4 char_asmall,char_alarge,char_psmall,char_plarge
  153.        integer*4 char_hsmall,char_hlarge
  154.        integer*4 char_0,char_1,char_2,char_3,char_4,char_5,char_6
  155.        integer*4 char_7,char_8,char_9,alt,shift
  156.        integer*4 left_arrow,right_arrow,up_arrow,down_arrow
  157.        integer*4 blue,yellow,red,black,white,green,lightblue,purple
  158.        integer*4 idm_next
  159.        integer*1 base_small_letters
  160.        parameter (idm_next=#300)
  161. c      colorref format is #bbggrr    blue green red
  162.        parameter (blue=#7F0000)
  163.        parameter (yellow=#00CFCF)
  164.        parameter (green=#00FF00)
  165.        parameter (red=#0000FF)
  166.        parameter (white=#FFFFFF)
  167.        parameter (black=#0)
  168.        parameter (lightblue=#CFCF00)
  169.        parameter (purple=#CF00CF)
  170.        parameter (return=13)
  171.        parameter (escape=27)
  172.        parameter (alt=#12)
  173.        parameter (shift=#10)
  174.        parameter (right_arrow=#27)
  175.        parameter (left_arrow=#25)
  176.        parameter (up_arrow=#26)
  177.        parameter (down_arrow=#28)
  178.        parameter (char_fsmall=#66)
  179.        parameter (char_flarge=#46)
  180.        parameter (char_hsmall=#68)
  181.        parameter (char_hlarge=#48)
  182.        parameter (char_lsmall=#6c)
  183.        parameter (char_llarge=#4c)
  184.        parameter (char_nsmall=#6e)
  185.        parameter (char_nlarge=#4e)
  186.        parameter (char_psmall=#70)
  187.        parameter (char_plarge=#50)
  188.        parameter (char_usmall=#75)
  189.        parameter (char_ularge=#55)
  190.        parameter (char_dsmall=#64)
  191.        parameter (char_dlarge=#44)
  192.        parameter (char_asmall=#61)
  193.        parameter (char_alarge=#41)
  194.        parameter (char_0=#30)
  195.        parameter (char_1=#31)
  196.        parameter (char_2=#32)
  197.        parameter (char_3=#33)
  198.        parameter (char_4=#34)
  199.        parameter (char_5=#35)
  200.        parameter (char_6=#36)
  201.        parameter (char_7=#37)
  202.        parameter (char_8=#38)
  203.        parameter (char_9=#39)
  204.       integer*4 CreatePenIndirect
  205.       data itemchfile/0,1/
  206.       DATA FILEform/'cProgram Name^OOPS, EXIT PROGRAM^|\0'c/   
  207.       data itemchline/0/
  208.       DATA SPACE/1H /,ZERO/1H0/
  209.       DATA INFCHOS,INFCHOS2,ONE,TWO,MINUS/1,2,1H1,1H2,1H-/  
  210.       DATA IIA/1HA/,
  211.      1 IIS/1HS/,IIY/1HY/,IIN/1HN/,IIP/1HP/
  212.       DATA IIE/1HE/,IIL/1HL/,IIM/1HM/,IID/1HD/,IIR/1HR/,IIX/1HX/,
  213.      1 IIT/1HT/
  214.       data filen/'\0'c/
  215.       data pen.style,pen.x,pen.y,pen.color/PS_SOLID,1,1,YELLOW/
  216.       data base_small_letters/96/
  217.       data filefd/'USER32.FD   ','GDI32.FD    ','KERNEL32.FD ',
  218.      1'COMDLG32.FD ','COMCTL32.FD ','WIN32SPL.FD ','SHELL32.FD  ',
  219.      2'NETAPI32.FD ','OLECLI32.FD ','OLESVR32.FD ','RASAPI32.FD ',
  220.      3'LZ32.FD     ','ADVAPI32.FD ',7*'            '/
  221.       data filefi/'USER32.FI   ','GDI32.FI    ','KERNEL32.FI ',
  222.      1'COMDLG32.FI ','COMCTL32.FI ','WIN32SPL.FI ','SHELL32.FI  ',
  223.      2'NETAPI32.FI ','OLECLI32.FI ','OLESVR32.FI ','RASAPI32.FI ',
  224.      3'LZ32.FI     ','ADVAPI32.FI ',7*'            '/            
  225.       data number_include_files/13/
  226.       data copying,found/2*.FALSE./
  227. c     return TRUE unless unless handles by DefWindowProc
  228.       mainwindowproc = true
  229.       select case (wMsgID)
  230.          case (WM_CREATE)
  231.            hdc=GetDC(hWnd)
  232.            ierr=SelectObject(hdc,GetStockObject(SYSTEM_FIXED_FONT))
  233.            ierr=GetTextMetrics(hdc,tm)
  234.            cxChar=tm.tmAveCharWidth
  235.            cyChar=tm.tmHeight+tm.tmExternalLeading
  236.            ierr=ReleaseDC(hwnd,hdc)
  237.            pen.color=yellow
  238.            hpenyellow=CreatePenIndirect(pen)
  239.            pen.color=red
  240.            hpenred=CreatePenIndirect(pen)
  241.            pen.color=green
  242.            hpengreen=CreatePenIndirect(pen)
  243.            pen.color=white
  244.            hpenwhite=CreatePenIndirect(pen)
  245.            pen.color=black
  246.            hpenblack=CreatePenIndirect(pen)
  247.            pen.color=blue
  248.            hpenblue=CreatePenIndirect(pen)
  249.            hpenbackground=hpenblue
  250.            pen.color=lightblue
  251.            hpenlightblue=CreatePenIndirect(pen)
  252.            pen.color=purple
  253.            hpenpurple=CreatePenIndirect(pen)
  254.            color(1)=hpenblue
  255.            color(2)=hpenyellow
  256.            color(3)=hpengreen
  257.            color(4)=hpenwhite
  258.            color(5)=hpenblack
  259.            color(6)=hpenred
  260.            color(7)=hpenpurple
  261.            color(8)=hpenlightblue
  262.            IPIXX=640
  263.            IPIXY=480
  264.            IPIXLET=10     
  265.            IPIXY1=IPIXY-1
  266.            PIXY=IPIXY
  267.            PIXY1=IPIXY1
  268.            IPIXX1=IPIXX-1
  269.            PIXX1=IPIXX1
  270.            PIXX=IPIXX
  271.                OPEN(7,FILE='corps.bmp',FORM='BINARY',STATUS='OLD',ERR=9)
  272.                read(7,err=8,end=8) bitmapfileheader.bftype,
  273.      1          bitmapfileheader.bfSize,bitmapfileheader.bfReserved1,
  274.      2          bitmapfileheader.bfReserved2,bitmapfileheader.bfOffbits
  275.                read(7,err=8,end=8) bitmapinfo.bisize,
  276.      1          bitmapinfo.biWidth,bitmapinfo.biHeight,
  277.      2          bitmapinfo.biPlanes,bitmapinfo.biBitCount,
  278.      3          bitmapinfo.biCompression,bitmapinfo.biSizeImage,
  279.      4          bitmapinfo.biXPelsPerMeter,bitmapinfo.biYPelsPerMeter,
  280.      5          bitmapinfo.biClrUsed,bitmapinfo.biClrImportant
  281. c    40 and 14 are the sizes of the 2 header blocks; pal is Integer*4 array
  282.                iskip=(bitmapfileheader.bfOffbits-40-14)/4
  283.                if(iskip.ge.1) then
  284.                   do j=1,iskip
  285.                      read(7,err=8134,end=8134) pal(j)
  286.                   enddo
  287.                endif
  288. 8134              if(bitmapinfo.biBitCount.eq.1) 
  289.      1             linewidthbytes=(bitmapinfo.biWidth+7)/8
  290.                   if(bitmapinfo.biBitCount.eq.4) 
  291.      1             linewidthbytes=(bitmapinfo.biWidth+1)/2
  292.                   if(bitmapinfo.biBitCount.eq.8) 
  293.      1             linewidthbytes=bitmapinfo.biWidth
  294.                   if(bitmapinfo.biBitCount.eq.24) 
  295.      1             linewidthbytes=bitmapinfo.biWidth*3
  296.                ibase=0
  297.                do j=bitmapinfo.biheight,1,-1
  298.                   read(7,err=8,end=8) (image(jj+ibase),
  299.      1             jj=1,linewidthbytes)
  300.                   ibase=ibase+linewidthbytes
  301.                
  302.                enddo
  303. 8              close(7)
  304. 9              continue
  305.                ifirsttime=0
  306.                call InvalidateRect(hWnd,Null,True)
  307.          case (WM_COMMAND)
  308.            select case (wParam)
  309.              case (IDM_NEXT)
  310.                INFILEPTR=LOCFAR(FILEN)
  311.                IF(FORM(hinst,hWnd,fileform,itemchfile,infrows)) THEN
  312.                   IF(Itemchfile(1).EQ.1) GO TO 7777
  313.                   CALL GET_NAME_OF_FILE(FILEN,FILE_IN_FDH,NUMCHAR)
  314.                   file_in_fdh(numchar+1:numchar+3)='FDH'
  315.                   file_in_fih=file_in_fdh
  316.                   file_in_fih(numchar+1:numchar+3)='FIH'
  317.                   file_out_fi=file_in_fdh
  318.                   file_out_fi(numchar+1:numchar+3)='FI '
  319.                   file_out_fd=file_in_fdh
  320.                   file_out_fd(numchar+1:numchar+3)='FD '
  321.                   file_out_pre=file_in_fdh
  322.                   file_out_pre(numchar+1:numchar+3)='PRE'
  323.                   file_in_for=file_in_fdh
  324.                   file_in_for(numchar+1:numchar+3)='FOR'
  325.                else
  326.                  nerr=destroywindow(hwnd)
  327.                  return
  328.                ENDIF
  329. c*******************Search Masterfi.lis*************************
  330.                masterficount=0
  331.                icharcount=1
  332.                start_char(1)=1
  333.                open(3,file='MASTERFI.LIS',status='old',err=13)
  334. 618              read(3,10,end=612,err=612) a
  335.                  icount=1
  336.                  if (a1(1).ne.32.and.a1(1).ne.13.and.
  337.      1            a1(1).ne.10) then
  338.                     masterficount=masterficount+1
  339.                     do while (a1(icount).ne.32.and.
  340.      1               a1(icount).ne.13.and.
  341.      1               a1(icount).ne.10.and.icount.le.80)
  342.                        if(a1(icount).gt.base_small_letters) 
  343.      1                  a1(icount)=a1(icount)-32
  344.                        image(icharcount)=a1(icount)
  345.                        icharcount=icharcount+1
  346.                        icount=icount+1
  347.                     enddo
  348. c*************************new************************
  349.                     length_char(masterficount)=icharcount-
  350.      1               start_char(masterficount)
  351. c                    mc=masterficount+1
  352.                     start_char(masterficount+1)=icharcount+1
  353. c***************************************************
  354.                     image(icharcount)=' '
  355.                     icharcount=icharcount+1
  356.                  endif
  357.                  go to 618
  358. 612            close(3)
  359.                open(3,file=file_in_for,status='OLD',err=13)
  360.                open(4,file=file_in_fih,status='UNKNOWN',err=13)
  361. 628            read(3,10,end=629,err=629) a
  362.                if(a1(1).ne.'C'.and.a1(1).ne.'c'.and.a1(1).ne.'$') then
  363.                   icount=7
  364. 623               mcount=0
  365.                   do while (((a1(icount).ge.'A'.and.a1(icount).le.'Z')
  366.      1              .or.a1(icount).eq.'_'.or.(a1(icount).ge.'a'.and.
  367.      1              a1(icount).le.'z').or.(a1(icount).ge.'0'.and.
  368.      1              a1(icount).le.'9')).and.icount.le.80)
  369.                      if(a1(icount).gt.base_small_letters) 
  370.      1                a1(icount)=a1(icount)-32
  371.                      mcount=mcount+1
  372.                      c(mcount)=a1(icount)
  373.                      icount=icount+1
  374.                   enddo
  375.                   icount=icount+1
  376.                   if(mcount.gt.0) then
  377.                     nowchar=1
  378.                     found=.false.
  379.                     do m=1,masterficount
  380. c******************new1***************
  381.                     if(c(1).eq.image(start_char(m)).and.mcount.eq.
  382.      1               length_char(m)) then
  383. c**********************************
  384.                      if(.not.found) then
  385.                        icharnow=1
  386.                        do while (image(nowchar).ne.' '.and.
  387.      1                  image(nowchar).ne.'*')
  388.                           b(icharnow)=image(nowchar)
  389.                           icharnow=icharnow+1
  390.                           nowchar=nowchar+1
  391.                        enddo
  392.                        icharnow=icharnow-1
  393.                        if(icharnow.eq.mcount.and.icharnow.ne.0.and.
  394.      1                  c(1).eq.b(1)) then
  395.                          found=.true.
  396.                          do inow=1,icharnow
  397.                             if(c(inow).ne.b(inow)) found=.false.
  398.                          enddo
  399.                          if(found.and.image(nowchar).ne.'*') then
  400.                             write(4,100,err=629) (b(jj),jj=1,icharnow)
  401.                             image(nowchar)='*'
  402.                          endif
  403.                        endif
  404.                        nowchar=nowchar+1
  405.                      endif
  406. c************************new2**********************
  407.                     else
  408.                        nowchar=start_char(m+1)
  409.                     endif
  410. c****************************************************
  411.                     enddo
  412.                   endif
  413.                   if(icount.le.80) go to 623
  414.                endif
  415.                go to 628
  416. 629            close(4)
  417.                close(3)
  418. c***************************************************************
  419. c*******************Search Masterfd.lis*************************
  420.                masterfdcount=0
  421.                icharcount=1
  422.                start_char(1)=1
  423.                open(3,file='MASTERFD.LIS',status='old',err=13)
  424. 718              read(3,10,end=712,err=712) a
  425.                  icount=1
  426.                  if (a1(1).ne.32.and.a1(1).ne.13.and.
  427.      1            a1(1).ne.10) then
  428.                     masterfdcount=masterfdcount+1
  429.                     do while (a1(icount).ne.32.and.
  430.      1               a1(icount).ne.13.and.
  431.      1               a1(icount).ne.10.and.icount.le.80)
  432.                        if(a1(icount).gt.base_small_letters) 
  433.      1                  a1(icount)=a1(icount)-32
  434.                        image(icharcount)=a1(icount)
  435.                        icharcount=icharcount+1
  436.                        icount=icount+1
  437.                     enddo
  438. c************************new**************************
  439.                     length_char(masterfdcount)=icharcount-
  440.      1               start_char(masterfdcount)
  441. c                    mc=masterfdcount+1
  442.                     start_char(masterfdcount+1)=icharcount+1
  443. c*****************************************************
  444.                     image(icharcount)=' '
  445.                     icharcount=icharcount+1
  446.                  endif
  447.                  go to 718
  448. 712            close(3)
  449.                open(3,file=file_in_for,status='OLD',err=13)
  450.                open(4,file=file_in_fdh,status='UNKNOWN',err=13)
  451. 728            read(3,10,end=729,err=729) a
  452.                if(a1(1).ne.99.and.a1(1).ne.67.and.a1(1).ne.36) then
  453.                   icount=7
  454. 723               mcount=0
  455.                   do while (((a1(icount).ge.'A'.and.a1(icount).le.'Z')
  456.      1              .or.a1(icount).eq.'_'.or.(a1(icount).ge.'a'.and.
  457.      1              a1(icount).le.'z').or.(a1(icount).ge.'0'.and.
  458.      1              a1(icount).le.'9')).and.icount.le.80)
  459.                      if(a1(icount).gt.base_small_letters) 
  460.      1                a1(icount)=a1(icount)-32
  461.                      mcount=mcount+1
  462.                      c(mcount)=a1(icount)
  463.                      icount=icount+1
  464.                   enddo
  465.                   icount=icount+1
  466.                   if(mcount.gt.0) then
  467.                     nowchar=1
  468.                     found=.false.
  469.                     do m=1,masterfdcount
  470. c******************new1***************
  471.                     if(c(1).eq.image(start_char(m)).and.mcount.eq.
  472.      1               length_char(m)) then
  473. c**********************************
  474.                      if(.not.found) then
  475.                        icharnow=1
  476.                        do while (image(nowchar).ne.' '.and.
  477.      1                  image(nowchar).ne.'*')
  478.                           b(icharnow)=image(nowchar)
  479.                           icharnow=icharnow+1
  480.                           nowchar=nowchar+1
  481.                        enddo
  482.                        icharnow=icharnow-1
  483.                        if(icharnow.eq.mcount.and.icharnow.ne.0.and.
  484.      1                  c(1).eq.b(1)) then
  485.                          found=.true.
  486.                          do inow=1,icharnow
  487.                             if(c(inow).ne.b(inow)) found=.false.
  488.                          enddo
  489.                          if(found.and.image(nowchar).ne.'*') then
  490.                             write(4,100,err=729) (b(jj),jj=1,icharnow)
  491.                             image(nowchar)='*'
  492.                          endif
  493.                        endif
  494.                        nowchar=nowchar+1
  495.                      endif
  496. c************************new2**********************
  497.                     else
  498.                        nowchar=start_char(m+1)
  499.                     endif
  500. c****************************************************
  501.                     enddo
  502.                   endif
  503.                   if(icount.le.80) go to 723
  504.                endif
  505.                go to 728
  506. 729            close(4)
  507.                close(3)
  508. c***************************************************************
  509.                  icharcount=1
  510.                  ifdcount=0
  511.                  open(5,file=file_out_pre)
  512.                  open(3,file=file_in_fdh,status='OLD',err=13)
  513.  18              read(3,10,end=12,err=12) a
  514.  10              format(a80)
  515.                  icount=1
  516.                  ifdcount=ifdcount+1
  517.                  do while (a1(icount).ne.' '.and.icount.le.80)
  518.                     if(a1(icount).gt.base_small_letters) 
  519.      1               a1(icount)=a1(icount)-32
  520.                     icount=icount+1
  521.                  enddo
  522.                  a1(icount)=' '
  523.                  if(a1(1).ne.32.and.a1(1).ne.13.and.a1(1).ne.10) then
  524.                     do j=1,icount
  525.                        ii=j-1+icharcount
  526.                        image(ii)=a1(j)
  527.                     enddo
  528.                     icharcount=icharcount+icount
  529.                  else
  530.                     ifdcount=ifdcount-1
  531.                  endif
  532.                  go to 18
  533.  12              close(3)
  534.                  ifound=ifdcount
  535.                  open(4,file=file_out_fd,err=13)
  536.                  do ifilecnt=1,number_include_files
  537.                     if(ifound.eq.0) go to 88
  538.                     copying=.false.
  539.                     open(3,file=filefd(ifilecnt),status='OLD',err=88)
  540.  98                 read(3,10,end=49,err=49) a
  541.                     nowchar=1
  542.                     if(a1(1).eq.'c') a1(1)='C'
  543.                     if(copying.and.a1(1).ne.'C') then
  544.                        jcount=80
  545.                        do while(a1(jcount).eq.32.or.a1(jcount).eq.13.
  546.      1                  .or.a1(jcount).eq.10.or.a1(jcount).eq.0)
  547.                           jcount=jcount-1
  548.                        enddo
  549. c                       write(4,10,err=49) a
  550.                         write(4,100,err=49) (a1(jj),jj=1,jcount)
  551.  100                    format(80a1)
  552.                     endif
  553.                     icount=1
  554.                     do while (a1(icount).ne.' '.and.icount.le.80)
  555.                        if(a1(icount).gt.base_small_letters) 
  556.      1                  a1(icount)=a1(icount)-32
  557.                        icount=icount+1
  558.                     enddo
  559.                     icount=icount-1
  560.                     if(a1(1).eq.'C'.and.a1(2).eq.'*') then
  561.                        copying=.FALSE.
  562.                        ncount=icount-2
  563.                        icharcount=1
  564. c     Search list in image to see if current module name is one we want
  565.                        found=.false.
  566.                        do m=1,ifdcount
  567.                           icharnow=1
  568.                           do while (image(nowchar).ne.' '.and.
  569.      1                     image(nowchar).ne.'*')
  570.                              b(icharnow)=image(nowchar)
  571.                              icharnow=icharnow+1
  572.                              nowchar=nowchar+1
  573.                           enddo
  574.                           if(.not.found) nowchar=nowchar+1
  575.                           if(image(nowchar-1).eq.' '.and.
  576.      1                     icharnow-1.eq.ncount) then
  577.                              copying=.true.
  578.                              do jj=1,ncount
  579.                                 if(b(jj).ne.a1(jj+2)) copying=.false.
  580.                              enddo
  581.                              if(copying) then
  582.                                 image(nowchar-1)='*'
  583.                                 ifound=ifound-1
  584.                                 nowchar=nowchar-1
  585.                                 found=.true.
  586.                              endif
  587.                           endif
  588.                        enddo
  589.                     endif
  590.                     go to 98
  591. 49                  close(3)
  592. 88               enddo
  593.  11              close(4)
  594.                  write(5,54,err=55) ifdcount,' FD',ifound,' FD','d'
  595.  54              format(i8,a3,' Symbols were specified'/i8,a3,
  596.      1            ' Symbols were not foun',a1)
  597. c     Search list in image to see what symbols were not found
  598.                    if(ifound.gt.0) then
  599.                        nowchar=1
  600.                        write(5,53,err=55) ' FD',':'
  601.  53                    format(a3,' Symbols not found',a1)
  602.                        do m=1,ifdcount
  603.                           icharnow=1
  604.                           do while (image(nowchar).ne.' '.and.
  605.      1                     image(nowchar).ne.'*')
  606.                              b(icharnow)=image(nowchar)
  607.                              icharnow=icharnow+1
  608.                              nowchar=nowchar+1
  609.                           enddo
  610.                           if(image(nowchar).eq.' ') then
  611.                              write(5,157,err=154) 
  612.      1                        (b(jj),jj=1,icharnow-1)
  613.  157                         format(80a1)
  614.  154                      endif
  615.                           nowchar=nowchar+1
  616.                        enddo
  617.                     endif
  618.  55              icharcount=1
  619.                  ificount=0
  620.                  open(3,file=file_in_fih,status='OLD',err=13)
  621.  28              read(3,10,end=14,err=14) a
  622.                  icount=1
  623.                  ificount=ificount+1
  624.                  do while (a1(icount).ne.' '.and.icount.le.80)
  625.                     if(a1(icount).gt.base_small_letters) 
  626.      1               a1(icount)=a1(icount)-32
  627.                     icount=icount+1
  628.                  enddo
  629.                  a1(icount)=' '
  630.                  if(a1(1).ne.32.and.a1(1).ne.13.and.a1(1).ne.10) then
  631.                     do j=1,icount
  632.                        ii=j-1+icharcount
  633.                        image(ii)=a1(j)
  634.                     enddo
  635.                     icharcount=icharcount+icount
  636.                  else
  637.                     ificount=ificount-1
  638.                  endif
  639.                  go to 28
  640.  14              close(3)
  641.                  ifound=ificount
  642.                  open(4,file=file_out_fi,err=13)
  643.                  do ifilecnt=1,number_include_files
  644.                     if(ifound.eq.0) go to 38
  645.                     copying=.false.
  646.                     open(3,file=filefi(ifilecnt),status='OLD',err=38)
  647.  68                 read(3,10,end=59,err=59) a
  648.                     nowchar=1
  649.                     if(a1(1).eq.'c') a1(1)='C'
  650.                     if(copying.and.a1(1).ne.'C') then
  651.                        jcount=80
  652.                        do while(a1(jcount).eq.32.or.a1(jcount).eq.13.
  653.      1                  .or.a1(jcount).eq.10.or.a1(jcount).eq.0)
  654.                           jcount=jcount-1
  655.                        enddo
  656. c                       write(4,10,err=49) a
  657.                         write(4,100,err=49) (a1(jj),jj=1,jcount)
  658.                     endif
  659.                     icount=1
  660.                     do while (a1(icount).ne.' '.and.icount.le.80)
  661.                        if(a1(icount).gt.base_small_letters) 
  662.      1                  a1(icount)=a1(icount)-32
  663.                        icount=icount+1
  664.                     enddo
  665.                     icount=icount-1
  666.                     if(a1(1).eq.'C'.and.a1(2).eq.'*') then
  667.                        copying=.FALSE.
  668.                        ncount=icount-2
  669.                        icharcount=1
  670. c     Search list in image to see if current module name is one we want
  671.                        found=.false.
  672.                        do m=1,ificount
  673.                           icharnow=1
  674.                           do while (image(nowchar).ne.' '.and.
  675.      1                     image(nowchar).ne.'*')
  676.                              b(icharnow)=image(nowchar)
  677.                              icharnow=icharnow+1
  678.                              nowchar=nowchar+1
  679.                           enddo
  680.                           if(.not.found) nowchar=nowchar+1
  681.                           if(image(nowchar-1).eq.' '.and.
  682.      1                     icharnow-1.eq.ncount) then
  683.                              copying=.true.
  684.                              do jj=1,ncount
  685.                                 if(b(jj).ne.a1(jj+2)) copying=.false.
  686.                              enddo
  687.                              if(copying) then
  688.                                 image(nowchar-1)='*'
  689.                                 ifound=ifound-1
  690.                                 nowchar=nowchar-1
  691.                                 found=.true.
  692.                              endif
  693.                           endif
  694.                        enddo
  695.                     endif
  696.                     go to 68
  697. 59                  close(3)
  698. 38               enddo
  699. c                 write(4,19,err=21) (image(j),j=1,icharcount-1)
  700.  21              close(4)
  701.                  write(5,54,err=56) ificount,' FI',ifound,' FI','d'
  702. c     Search list in image to see what symbols were not found
  703.                    if(ifound.gt.0) then
  704.                        nowchar=1
  705.                        write(5,53,err=56) ' FI',':'
  706.                        do m=1,ificount
  707.                           icharnow=1
  708.                           do while (image(nowchar).ne.' '.and.
  709.      1                     image(nowchar).ne.'*')
  710.                              b(icharnow)=image(nowchar)
  711.                              icharnow=icharnow+1
  712.                              nowchar=nowchar+1
  713.                           enddo
  714.                           if(image(nowchar).eq.' ') then
  715.                              write(5,157,err=51) (b(jj),jj=1,icharnow-1)
  716.  51                       endif
  717.                           nowchar=nowchar+1
  718.                        enddo
  719.                     endif
  720.  56              close(5)
  721.  13              nerr=destroywindow(hwnd)
  722.            end select
  723.          case (WM_PAINT)
  724.             hDC=BeginPaint(hWnd,ps)
  725.             ierr=SetBkMode(hDC,OPAQUE)
  726.             ipreviouscolor=SetTextColor(hdc,yellow)
  727.             ipreviouscolor=SetBkColor(hdc,blue)
  728.             ierr=SelectObject(hDC,GetStockObject(SYSTEM_FIXED_FONT))
  729.             ierr=GetTextMetrics(hDC,tm)
  730.             cxChar=tm.tmAveCharWidth
  731.             cyChar=tm.tmHeight+tm.tmExternalLeading
  732.             Wintitle=filepre
  733.             wintitle(numchar+4:numchar+4)='\0'c
  734.             call SetWindowText(hWnd,WinTitle)
  735.                hmemorydc=createcompatibledc(hdc)
  736.                hbitmap=createdibitmap(hdc,locfar(bitmapinfo),
  737.      1          CBM_INIT,locfar(image),locfar(bitmapinfo),
  738.      2          DIB_RGB_COLORS)
  739.                holdbitmap=selectobject(hmemorydc,hbitmap)
  740. C   extent_x&y set by wm_size message handler and are correct               
  741.                ierr=bitblt(hdc,0,0,extent_x,extent_y,
  742.      1          hmemorydc,0,0,SRCCOPY)
  743.                ierr=deletedc(hmemorydc)
  744.                call deleteobject(hbitmap)
  745.             if(ifirsttime.eq.0) then
  746.                ifirsttime=1
  747.                iberr=SendMessage(hwnd,WM_COMMAND,IDM_NEXT,1)
  748.             endif
  749.             Call EndPaint(hwnd,ps)
  750.          case (WM_SIZE)
  751.             IPIXX=LOWORD(lParam)
  752.             IPIXY=HIWORD(lParam)
  753.             IPIXX1=IPIXX-1
  754.             IPIXY1=IPIXY-1
  755.             pixx1=ipixx1
  756.             pixy1=ipixy1
  757.             pixx=ipixx
  758.             pixy=ipixy
  759.             extent_x=IPIXX
  760.             extent_y=IPIXY
  761.             ifirstpass=0
  762.             call InvalidateRect(hWnd,Null,True)
  763.          case (WM_CHAR)
  764.            select case (wParam)
  765.             case(escape)
  766.                nerr=destroywindow(hwnd)
  767.                return
  768.             case DEFAULT
  769.               mainwindowproc = DefWindowProc (hWnd, 
  770.      1         wMsgID, wParam, lParam)
  771.          END SELECT
  772.       case (WM_CLOSE)
  773.          nerr=destroywindow(hwnd)
  774.       case (WM_DESTROY)
  775.          Call DeleteObject(hbgbrush)
  776.          Call DeleteObject(hpenblue)
  777.          Call DeleteObject(hpenred)
  778.          Call DeleteObject(hpenblack)
  779.          Call DeleteObject(hpenwhite)
  780.          Call DeleteObject(hpengreen)
  781.          Call DeleteObject(hpenyellow)
  782.          Call DeleteObject(hpenlightblue)
  783.          Call DeleteObject(hpenpurple)
  784.          Call PostQuitMessage(0)
  785.       case DEFAULT
  786.          mainwindowproc = DefWindowProc (hWnd, 
  787.      1    wMsgID, wParam, lParam)
  788.       END SELECT
  789.       return
  790. 7777  nerr=destroywindow(hwnd)
  791.       return
  792. 9940  NUMERRS=NUMERRS+1
  793.       IF(NUMERRS.GT.20) nerr=destroywindow(hwnd)
  794.       return
  795.       end
  796.  
  797.       SUBROUTINE GET_NAME_OF_FILE(BUF,FILEEQUIPMENT,NUMCHAR)
  798.       CHARACTER*30 FILEEQUIPMENT,BUF
  799.       character*1 term
  800.       PARAMETER (term=0)
  801.       NUMCHAR=1
  802.       DO WHILE (NUMCHAR.le.30.and.BUF(NUMCHAR:NUMCHAR).ne.term)
  803.             NUMCHAR=NUMCHAR+1
  804.       END DO
  805.       DO J=1,30
  806.          IF (J.LE.Numchar-1) THEN
  807.             FILEEQUIPMENT(J:J)=BUF(J:J)
  808.          ELSE
  809.             IF (J.EQ.Numchar) THEN
  810.                FILEEQUIPMENT(J:J)='.'
  811.             ELSE IF (J.EQ.Numchar+1) THEN
  812.                FILEEQUIPMENT(J:J)='E'
  813.             ELSE IF (J.EQ.Numchar+2) THEN
  814.                
  815.                FILEEQUIPMENT(J:J)='Q'
  816.             ELSE IF (J.EQ.Numchar+3) THEN
  817.                FILEEQUIPMENT(J:J)='U'
  818.             ELSE
  819.                FILEEQUIPMENT(J:J)=' '
  820.             ENDIF
  821.          ENDIF
  822.       END DO
  823.       RETURN
  824.       END
  825.       Subroutine Put_Buffer(name1,name2,value1,value2,ipointer,length)
  826.       Real name1(1),name2(1)
  827.       ipointer=ipointer+1
  828.       if(ipointer.gt.length) ipointer=1
  829.       name1(ipointer)=value1
  830.       name2(ipointer)=value2
  831.       Return
  832.       End
  833.       Subroutine Get_Buffer(name1,value1,ipointer,length,index)
  834.       Real name1(1)
  835.       iipointer=ipointer+index
  836.       if(iipointer.gt.length) iipointer=iipointer-length
  837.       if(iipointer.lt.1) iipointer=length+iipointer
  838.       value1=name1(iipointer)
  839.       Return
  840.       End
  841.  
  842.