home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / fortran / mslang / prefor / defs.for < prev    next >
Text File  |  1993-10-21  |  21KB  |  514 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*7 pound_define
  124.       CHARACTER*30 file_in_h,file_out_def,file_out_fd
  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(200000)
  133.       common/bigimage/image
  134.       common/pallet2/bitmapinfo,pal
  135.       Record /tagbitmapfileheader/ bitmapfileheader
  136.       Record /tagbitmapinfoheader/ bitmapinfo
  137.       integer*4 hmemorydc,hbitmap,deletedc
  138.       integer*4 pal(512)
  139.       integer*4 createcompatibledc,createdibitmap,bitblt
  140.       integer*4 hpenbackground,hpenline,cychar
  141.       COMMON/COLORS/hpenbackground,hpenline,cychar
  142.       EQUIVALENCE (INFROWS(1),INFILEPTR)
  143.       equivalence (a,a1(1))
  144.       logical*1 copying,found,hex
  145.       integer*4 hpenblue,hpengreen,hpenyellow,hpenwhite,hpenred,
  146.      1 hpenblack
  147.        integer*4 return,escape,char_fsmall,char_flarge
  148.        integer*4 char_nsmall,char_nlarge,char_lsmall,char_llarge
  149.        integer*4 char_dsmall,char_dlarge,char_usmall,char_ularge
  150.        integer*4 char_asmall,char_alarge,char_psmall,char_plarge
  151.        integer*4 char_hsmall,char_hlarge
  152.        integer*4 char_0,char_1,char_2,char_3,char_4,char_5,char_6
  153.        integer*4 char_7,char_8,char_9,alt,shift
  154.        integer*4 left_arrow,right_arrow,up_arrow,down_arrow
  155.        integer*4 blue,yellow,red,black,white,green,lightblue,purple
  156.        integer*4 idm_next
  157.        integer*1 base_small_letters
  158.        parameter (idm_next=#300)
  159. c      colorref format is #bbggrr    blue green red
  160.        parameter (blue=#7F0000)
  161.        parameter (yellow=#00CFCF)
  162.        parameter (green=#00FF00)
  163.        parameter (red=#0000FF)
  164.        parameter (white=#FFFFFF)
  165.        parameter (black=#0)
  166.        parameter (lightblue=#CFCF00)
  167.        parameter (purple=#CF00CF)
  168.        parameter (return=13)
  169.        parameter (escape=27)
  170.        parameter (alt=#12)
  171.        parameter (shift=#10)
  172.        parameter (right_arrow=#27)
  173.        parameter (left_arrow=#25)
  174.        parameter (up_arrow=#26)
  175.        parameter (down_arrow=#28)
  176.        parameter (char_fsmall=#66)
  177.        parameter (char_flarge=#46)
  178.        parameter (char_hsmall=#68)
  179.        parameter (char_hlarge=#48)
  180.        parameter (char_lsmall=#6c)
  181.        parameter (char_llarge=#4c)
  182.        parameter (char_nsmall=#6e)
  183.        parameter (char_nlarge=#4e)
  184.        parameter (char_psmall=#70)
  185.        parameter (char_plarge=#50)
  186.        parameter (char_usmall=#75)
  187.        parameter (char_ularge=#55)
  188.        parameter (char_dsmall=#64)
  189.        parameter (char_dlarge=#44)
  190.        parameter (char_asmall=#61)
  191.        parameter (char_alarge=#41)
  192.        parameter (char_0=#30)
  193.        parameter (char_1=#31)
  194.        parameter (char_2=#32)
  195.        parameter (char_3=#33)
  196.        parameter (char_4=#34)
  197.        parameter (char_5=#35)
  198.        parameter (char_6=#36)
  199.        parameter (char_7=#37)
  200.        parameter (char_8=#38)
  201.        parameter (char_9=#39)
  202.       integer*4 CreatePenIndirect
  203.       data itemchfile/0,1/
  204.       DATA FILEform/'cProgram Name^OOPS, EXIT PROGRAM^|\0'c/   
  205.       data itemchline/0/
  206.       DATA SPACE/1H /,ZERO/1H0/
  207.       DATA INFCHOS,INFCHOS2,ONE,TWO,MINUS/1,2,1H1,1H2,1H-/  
  208.       DATA IIA/1HA/,
  209.      1 IIS/1HS/,IIY/1HY/,IIN/1HN/,IIP/1HP/
  210.       DATA IIE/1HE/,IIL/1HL/,IIM/1HM/,IID/1HD/,IIR/1HR/,IIX/1HX/,
  211.      1 IIT/1HT/
  212.       data filen/'\0'c/
  213.       data pen.style,pen.x,pen.y,pen.color/PS_SOLID,1,1,YELLOW/
  214.       data base_small_letters/96/
  215.       data filefd/'USER32.FD   ','GDI32.FD    ','KERNEL32.FD ',
  216.      1'COMDLG32.FD ','COMCTL32.FD ','WIN32SPL.FD ','SHELL32.FD  ',
  217.      2'NETAPI32.FD ','OLECLI32.FD ','OLESVR32.FD ','RASAPI32.FD ',
  218.      3'LZ32.FD     ','ADVAPI32.FD ',7*'            '/
  219.       data filefi/'USER32.FI   ','GDI32.FI    ','KERNEL32.FI ',
  220.      1'COMDLG32.FI ','COMCTL32.FI ','WIN32SPL.FI ','SHELL32.FI  ',
  221.      2'NETAPI32.FI ','OLECLI32.FI ','OLESVR32.FI ','RASAPI32.FI ',
  222.      3'LZ32.FI     ','ADVAPI32.FI ',7*'            '/            
  223.       data number_include_files/13/
  224.       data copying,found/2*.FALSE./
  225.       data pound_define/'#DEFINE'/
  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_H,NUMCHAR)
  313.                   file_in_h(numchar+1:numchar+3)='H  '
  314.                   file_out_def=file_in_h
  315.                   file_out_def(numchar+1:numchar+3)='DEF'
  316.                   file_out_fd=file_in_h
  317.                   file_out_fd(numchar+1:numchar+3)='FD '
  318.                else
  319.                  nerr=destroywindow(hwnd)
  320.                  return
  321.                ENDIF
  322.                open(3,file=file_in_h,status='OLD',err=13)
  323.                open(4,file=file_out_def,status='UNKNOWN',err=13)
  324.                open(5,file=file_out_fd,status='UNKNOWN',err=13)
  325. 628            read(3,10,end=629,err=629) a
  326. 10             format(a80)
  327.                    do icount=1,80
  328.                      if(a1(icount).gt.base_small_letters) 
  329.      1                a1(icount)=a1(icount)-32
  330.                    enddo
  331.                    if(pound_define.eq.a(1:7)) then
  332.                       istart=8
  333.                       do while(a1(istart).eq.' '.and.istart.le.80)
  334.                          istart=istart+1
  335.                       enddo
  336.                       iend=istart+1
  337.                       do while((a1(iend).ge.'A'.and.a1(iend).le.'Z')
  338.      1                 .or.(a1(iend).ge.'0'.and.a1(iend).le.'9')
  339.      2                 .or.a1(iend).eq.'_')
  340.                          iend=iend+1
  341.                       enddo
  342.                       If(a1(iend).eq.' ') then
  343.                          istart2=iend
  344.                          iend=iend-1
  345.                          do while(a1(istart2).eq.' '.and.
  346.      1                    istart2.le.80)
  347.                             istart2=istart2+1
  348.                          enddo
  349.                          if(a1(istart2).eq.'(') istart2=istart2+1
  350.                          iend2=istart2+1
  351.                          hex=.false.
  352.                          do while((a1(iend2).ge.'A'.and.a1(iend2).le.
  353.      1                    'Z').or.a1(iend2).eq.'X'.or.a1(iend2).eq.'-'
  354.      2                    .or.(a1(iend2).ge.'0'.and.a1(iend2).le.'9'))
  355.                           if(a1(iend2).eq.'X') hex=.true.
  356.                             iend2=iend2+1
  357.                          enddo
  358.                          iend2=iend2-1
  359.                          found=.true.
  360.                          do jj=istart2,iend2
  361.                             if(a1(jj).lt.'0'.or.a1(jj).gt.'9') 
  362.      1                       found=.false.
  363.                          enddo
  364.                          if(found.or.hex) then
  365.                           if(hex) then
  366.                              a1(istart2)='#'
  367.                              ii=istart2+1
  368.                              a1(ii)='0'
  369.                              if(a1(iend2).eq.'L') iend2=iend2-1
  370.                           endif
  371.                           found=.true.
  372.                           do jj=istart2,iend2
  373.                              if(a1(jj).gt.'F') found=.false.
  374.                           enddo
  375.                           if(found) then
  376.                           write(4,11,err=629) (a1(jj),jj=istart,iend)
  377.                           write(5,112,err=629) (a1(jj),jj=istart,iend)
  378.                           write(5,113,err=629) (a1(jj),jj=istart,iend)
  379.                           write(5,114,err=629) (a1(jj),jj=istart,iend),
  380.      1                     '=',(a1(jjj),jjj=istart2,iend2),')'
  381.                           endif
  382.                          endif
  383.                       endif
  384. 11                    format(80a1)
  385. 112                   format('C*',80a1)
  386. 113                   format('       INTEGER*4 ',80a1)
  387. 114                   format('       PARAMETER (',80a1)
  388.                    endif
  389.                go to 628
  390. 629            close(4)
  391.                close(3)
  392.                close(5)
  393.  13            nerr=destroywindow(hwnd)
  394.            end select
  395.          case (WM_PAINT)
  396.             hDC=BeginPaint(hWnd,ps)
  397.             ierr=SetBkMode(hDC,OPAQUE)
  398.             ipreviouscolor=SetTextColor(hdc,yellow)
  399.             ipreviouscolor=SetBkColor(hdc,blue)
  400.             ierr=SelectObject(hDC,GetStockObject(SYSTEM_FIXED_FONT))
  401.             ierr=GetTextMetrics(hDC,tm)
  402.             cxChar=tm.tmAveCharWidth
  403.             cyChar=tm.tmHeight+tm.tmExternalLeading
  404.             Wintitle=filepre
  405.             wintitle(numchar+4:numchar+4)='\0'c
  406.             call SetWindowText(hWnd,WinTitle)
  407.                hmemorydc=createcompatibledc(hdc)
  408.                hbitmap=createdibitmap(hdc,locfar(bitmapinfo),
  409.      1          CBM_INIT,locfar(image),locfar(bitmapinfo),
  410.      2          DIB_RGB_COLORS)
  411.                holdbitmap=selectobject(hmemorydc,hbitmap)
  412. C   extent_x&y set by wm_size message handler and are correct               
  413.                ierr=bitblt(hdc,0,0,extent_x,extent_y,
  414.      1          hmemorydc,0,0,SRCCOPY)
  415.                ierr=deletedc(hmemorydc)
  416.                call deleteobject(hbitmap)
  417.             if(ifirsttime.eq.0) then
  418.                ifirsttime=1
  419.                iberr=SendMessage(hwnd,WM_COMMAND,IDM_NEXT,1)
  420.             endif
  421.             Call EndPaint(hwnd,ps)
  422.          case (WM_SIZE)
  423.             IPIXX=LOWORD(lParam)
  424.             IPIXY=HIWORD(lParam)
  425.             IPIXX1=IPIXX-1
  426.             IPIXY1=IPIXY-1
  427.             pixx1=ipixx1
  428.             pixy1=ipixy1
  429.             pixx=ipixx
  430.             pixy=ipixy
  431.             extent_x=IPIXX
  432.             extent_y=IPIXY
  433.             ifirstpass=0
  434.             call InvalidateRect(hWnd,Null,True)
  435.          case (WM_CHAR)
  436.            select case (wParam)
  437.             case(escape)
  438.                nerr=destroywindow(hwnd)
  439.                return
  440.             case DEFAULT
  441.               mainwindowproc = DefWindowProc (hWnd, 
  442.      1         wMsgID, wParam, lParam)
  443.          END SELECT
  444.       case (WM_CLOSE)
  445.          nerr=destroywindow(hwnd)
  446.       case (WM_DESTROY)
  447.          Call DeleteObject(hbgbrush)
  448.          Call DeleteObject(hpenblue)
  449.          Call DeleteObject(hpenred)
  450.          Call DeleteObject(hpenblack)
  451.          Call DeleteObject(hpenwhite)
  452.          Call DeleteObject(hpengreen)
  453.          Call DeleteObject(hpenyellow)
  454.          Call DeleteObject(hpenlightblue)
  455.          Call DeleteObject(hpenpurple)
  456.          Call PostQuitMessage(0)
  457.       case DEFAULT
  458.          mainwindowproc = DefWindowProc (hWnd, 
  459.      1    wMsgID, wParam, lParam)
  460.       END SELECT
  461.       return
  462. 7777  nerr=destroywindow(hwnd)
  463.       return
  464. 9940  NUMERRS=NUMERRS+1
  465.       IF(NUMERRS.GT.20) nerr=destroywindow(hwnd)
  466.       return
  467.       end
  468.  
  469.       SUBROUTINE GET_NAME_OF_FILE(BUF,FILEEQUIPMENT,NUMCHAR)
  470.       CHARACTER*30 FILEEQUIPMENT,BUF
  471.       character*1 term
  472.       PARAMETER (term=0)
  473.       NUMCHAR=1
  474.       DO WHILE (NUMCHAR.le.30.and.BUF(NUMCHAR:NUMCHAR).ne.term)
  475.             NUMCHAR=NUMCHAR+1
  476.       END DO
  477.       DO J=1,30
  478.          IF (J.LE.Numchar-1) THEN
  479.             FILEEQUIPMENT(J:J)=BUF(J:J)
  480.          ELSE
  481.             IF (J.EQ.Numchar) THEN
  482.                FILEEQUIPMENT(J:J)='.'
  483.             ELSE IF (J.EQ.Numchar+1) THEN
  484.                FILEEQUIPMENT(J:J)='E'
  485.             ELSE IF (J.EQ.Numchar+2) THEN
  486.                
  487.                FILEEQUIPMENT(J:J)='Q'
  488.             ELSE IF (J.EQ.Numchar+3) THEN
  489.                FILEEQUIPMENT(J:J)='U'
  490.             ELSE
  491.                FILEEQUIPMENT(J:J)=' '
  492.             ENDIF
  493.          ENDIF
  494.       END DO
  495.       RETURN
  496.       END
  497.       Subroutine Put_Buffer(name1,name2,value1,value2,ipointer,length)
  498.       Real name1(1),name2(1)
  499.       ipointer=ipointer+1
  500.       if(ipointer.gt.length) ipointer=1
  501.       name1(ipointer)=value1
  502.       name2(ipointer)=value2
  503.       Return
  504.       End
  505.       Subroutine Get_Buffer(name1,value1,ipointer,length,index)
  506.       Real name1(1)
  507.       iipointer=ipointer+index
  508.       if(iipointer.gt.length) iipointer=iipointer-length
  509.       if(iipointer.lt.1) iipointer=length+iipointer
  510.       value1=name1(iipointer)
  511.       Return
  512.       End
  513.  
  514.