home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 2 BBS / 02-BBS.zip / SUD.ZIP / SUD.LST < prev    next >
File List  |  1991-07-04  |  21KB  |  463 lines
  1.                                                                         PAGE   1
  2.                                                                        07-04-91
  3.                                                                        16:34:47
  4.  
  5.  Line#  Source Line          Microsoft FORTRAN Optimizing Compiler Version 5.00
  6.  
  7.      1  C *** M/L Routine to DELETE users from the Simplex 1.04 userbase
  8.      2  C *** who haven't called in xxx days.  Sort Alphabetically.
  9.      3  C *** Copyright Fred R. Niemczenia 1991.  All rights reserved.
  10.      4  C *** Coded in MS-FORTRAN ver. 5.0, just to remind SysOps from
  11.      5  C *** whence all this marvelous language variety began!
  12.      6  C *** FORTRAN assumes all integers as signed.  To avoid an overflow
  13.      7  C *** store in a large intermediate integer and MAP into variable
  14.      8  C *** space.
  15.      9  
  16.     10  C *** Define the SIMPLEX User block...
  17.     11        STRUCTURE      /s_block/
  18.     12            CHARACTER *41 s_name
  19.     13            CHARACTER *16 s_password
  20.     14            CHARACTER *31 s_city
  21.     15            CHARACTER *15 s_home
  22.     16            CHARACTER *15 s_data
  23.     17            CHARACTER *1  s_priv        ! 0 - 255
  24.     18            INTEGER   *2  s_keys        ! User flags ver. 1.04
  25.     19            CHARACTER *1  s_screenlen
  26.     20            INTEGER   *2  s_credit
  27.     21            INTEGER   *2  s_flags
  28.     22            INTEGER   *2  s_fdate
  29.     23            INTEGER   *2  s_ldate
  30.     24            INTEGER   *2  s_ltime
  31.     25            INTEGER   *2  s_calls
  32.     26            INTEGER   *2  s_time
  33.     27            INTEGER   *2  s_upload
  34.     28            INTEGER   *4  s_upbyte
  35.     29            INTEGER   *2  s_dnload
  36.     30            INTEGER   *4  s_dnbyte
  37.     31            CHARACTER *4  s_resrved     ! Was 6, now 4 bytes.
  38.     32        END STRUCTURE
  39.     33        RECORD /s_block/ s
  40.     34  C ***               152 bytes defined in s_block
  41.     35  
  42.     36        CHARACTER*32 infile
  43.     37        INTEGER *2 ihr, imin, isec, i100, iyr, imon, iday
  44.     38        INTEGER *2 lyr, lmon, lday
  45.     39        INTEGER *4 ldays, today, pdays, diff
  46.     40        LOGICAL test
  47.     41  
  48.     42  C *** Begin playing to beat the Intel stupid segmented 64k
  49.     43  C *** boundary alignment.  F2128 - huge array cannot be aligned
  50.     44  C *** to segment boundary.  Arrrrrrgh!  Element .LE. 64 bytes.
  51.     45  C *** There goes structuring for .GT. 128 bytes...  I busted up
  52.     46  C *** the 152 byte record for this. Now if it had been 256 bytes...
  53.     47        CHARACTER  name[HUGE]*41(1000), pad1[HUGE]*55(1000),
  54.     48       & pad2[HUGE]*56(1000)
  55.     49  
  56.     50        PRINT *,' S_U_D version 1.01,  (c) Fred Niemczenia'
  57.     51        PRINT *,' SIMPLEX Userbase Deleter since last day called!!!'
  58.     52        PRINT *,' You may use this utility without charge.'
  59.     53        PRINT *
  60.     54        PRINT *, ' Do NOT append \USERLIST.BBS, I will do this for you.'
  61.     55        PRINT *, ' I expect something as:  C:\SIMPLEX {ENTER}.'
  62.     56        WRITE (*,'(A\)') '  Enter SIMPLEX User PATHspec: '
  63.     57        READ (*,'(A)') infile
  64.     58        PRINT *
  65.                                                                         PAGE   2
  66.                                                                        07-04-91
  67.                                                                        16:34:47
  68.  
  69.  Line#  Source Line          Microsoft FORTRAN Optimizing Compiler Version 5.00
  70.  
  71.     59        PRINT *, ' Enter the number of days you wish to use for'
  72.     60        PRINT *, ' the purge.  I expect something as:  96 {ENTER}.'
  73.     61        WRITE (*,'(A\)') '  Days: '
  74.     62        READ (*,*) pdays
  75.     63        PRINT *
  76.     64   
  77.     65  C *** So what is the date and time right now?
  78.     66        CALL  GETTIM (ihr, imin, isec, i100)
  79.     67        CALL  GETDAT (iyr, imon, iday)
  80.     68        CALL  days ( iyr, imon, iday, today)
  81.     69        
  82.     70  C *** Process infile filespec.  Check if the user is running it in
  83.     71  C *** the SIMPLEX directory.  `infile' is initially the pathspec.
  84.     72        length= LEN_TRIM (infile)
  85.     73          IF  ( length .LT. 1)  THEN
  86.     74              infile= infile(1:length) // 'USERLIST.BBS'
  87.     75            ELSE
  88.     76              infile= infile(1:length) // '\USERLIST.BBS'
  89.     77          END IF
  90.     78        PRINT *, ' Processing SIMPLEX: ', infile
  91.     79        PRINT 9001, imon, iday, iyr
  92.     80        PRINT *
  93.     81  
  94.     82  C *** Test if infile exists. It is now a `filespec'.
  95.     83        INQUIRE (FILE= infile, EXIST= test)
  96.     84          IF  ( .NOT. test )  THEN
  97.     85             PRINT *, ' I couldn''t find: ', infile
  98.     86             PRINT *, ' Run me again and get it right this time!'
  99.     87             GOTO 9999
  100.     88          END IF
  101.     89          length= LEN_TRIM (infile)
  102.     90          infile= infile(1:length)
  103.     91  
  104.     92  C *** Open the user file and open the scratch file.  The scratch file
  105.     93  C *** will NOT contain users that have been deleted.
  106.     94        OPEN (UNIT=10, FILE= infile, FORM= 'BINARY', RECL = 152,
  107.     95       & ACCESS= 'DIRECT', STATUS= 'UNKNOWN')
  108.     96        OPEN (UNIT=11, FORM= 'BINARY', ACCESS= 'SEQUENTIAL', STATUS=
  109.     97       & 'SCRATCH')
  110.     98  
  111.     99  C *** Implied processing LOOP begins
  112.    100        idelete= 0
  113.    101        icount= 0
  114.    102  1000  icount= icount + 1
  115.    103  
  116.    104          READ (10, END=4000, REC= icount)
  117.    105       &   s.s_name, s.s_password, s.s_city,
  118.    106       &   s.s_home, s.s_data, s.s_priv, s.s_keys, s.s_screenlen,
  119.    107       &   s.s_credit, s.s_flags, s.s_fdate, s.s_ldate, s.s_ltime,
  120.    108       &   s.s_calls, s.s_time, s.s_upload, s.s_upbyte, s.s_dnload,
  121.    109       &   s.s_dnbyte, s.s_resrved
  122.    110  
  123.    111  C *** Read last call date.  This is bit mapped stuff per OTOS.
  124.    112  C *** Laforet uses DOS date/time stamp.  YYYY YYYM MMMD DDDD
  125.    113  C ***
  126.    114  C *** User file conversion option BIT Map
  127.    115  C *** FORTRAN flags bits by number       1111 11-- ---- ----
  128.    116  C *** from 0 to 15 for a 2 byte integer  5432 1098 7654 3210
  129.                                                                         PAGE   3
  130.                                                                        07-04-91
  131.                                                                        16:34:47
  132.  
  133.  Line#  Source Line          Microsoft FORTRAN Optimizing Compiler Version 5.00
  134.  
  135.    117  C *** 
  136.    118  C ***       Classic C                    n000 0n00 00n0 000n
  137.    119  C ***   0x000n convention                8421 8421 8421 8421
  138.    120  
  139.    121          lday= 0
  140.    122          DO 2000, i= 0, 4              ! Do the day
  141.    123            IF (       BTEST ( s.s_ldate,  i ) )
  142.    124       &      lday= IBSET ( lday, i )
  143.    125  2000    CONTINUE
  144.    126  
  145.    127          lmon= 0
  146.    128          DO 2001, i= 0, 3              ! Do the month
  147.    129            IF (       BTEST ( s.s_ldate,  i+5 ) )
  148.    130       &      lmon= IBSET ( lmon, i )
  149.    131  2001    CONTINUE
  150.    132  
  151.    133          lyr= 0
  152.    134          DO 2002, i= 0, 6              ! Do the year
  153.    135            IF (       BTEST ( s.s_ldate,  i+9 ) )
  154.    136       &      lyr=  IBSET ( lyr,  i )
  155.    137  2002    CONTINUE
  156.    138          lyr= lyr + 1980               ! 1980 is 0 in DOS
  157.    139  
  158.    140          CALL  days  ( lyr, lmon, lday, ldays)
  159.    141          diff= today - ldays
  160.    142  
  161.    143          IF  ( diff .LT. pdays  .OR.  icount .EQ. 1)  THEN
  162.    144            WRITE (11)
  163.    145       &    s.s_name, s.s_password, s.s_city,
  164.    146       &    s.s_home, s.s_data, s.s_priv, s.s_keys, s.s_screenlen,
  165.    147       &    s.s_credit, s.s_flags, s.s_fdate, s.s_ldate, s.s_ltime,
  166.    148       &    s.s_calls, s.s_time, s.s_upload, s.s_upbyte, s.s_dnload,
  167.    149       &    s.s_dnbyte, s.s_resrved
  168.    150            PRINT 9002,  icount, s.s_name, diff
  169.    151          ELSE
  170.    152            PRINT 9003,  icount, s.s_name, diff
  171.    153            idelete= idelete + 1
  172.    154          END IF
  173.    155          GOTO 1000
  174.    156  
  175.    157  4000  icount= icount - 1
  176.    158        PRINT 9004, icount, idelete
  177.    159  C *** No sense processing deleted users.  Modify count.
  178.    160        iprocess=  icount - idelete
  179.    161  
  180.    162        CLOSE (UNIT=10)
  181.    163  C *** Set scratch file to 1st record.
  182.    164        REWIND (UNIT=11)
  183.    165  
  184.    166  C *** Bubble sort portion of SUD called in `sort'.
  185.    167        IF  ( iprocess .GT. 1000 )  THEN
  186.    168           PRINT *, 'More than 1000 records, sort abandoned!'
  187.    169           PRINT *
  188.    170           GOTO 9999
  189.    171        END IF
  190.    172  
  191.    173        IF  ( idelete .LE. 0 )  THEN
  192.    174           PRINT *, 'There was nothing to do!'
  193.                                                                         PAGE   4
  194.                                                                        07-04-91
  195.                                                                        16:34:47
  196.  
  197.  Line#  Source Line          Microsoft FORTRAN Optimizing Compiler Version 5.00
  198.  
  199.    175           PRINT *
  200.    176           GOTO 9999
  201.    177        END IF
  202.    178  
  203.    179        PRINT *, 'Reloading  SCRATCH FILE  from disk!'
  204.    180        PRINT *, 'Beginning sort of', iprocess, ' users in RAM!'
  205.    181        PRINT *, 'Be patient - Simple bubble sort in progress!'
  206.    182        PRINT *
  207.    183  
  208.    184        DO 5000, j=1, iprocess
  209.    185           READ (11)  name(j), pad1(j), pad2(j)
  210.    186  5000  CONTINUE
  211.    187        CLOSE (UNIT=11)
  212.    188  
  213.    189        CALL  sort  ( name, pad1, pad2, iprocess )
  214.    190  
  215.    191        PRINT *, 'Writing sorted USERLIST to DISK!'
  216.    192  
  217.    193        OPEN (UNIT=11, FILE= infile, FORM= 'BINARY', 
  218.    194       & ACCESS= 'SEQUENTIAL', STATUS= 'UNKNOWN')
  219.    195  
  220.    196        DO 6000, j=1, iprocess
  221.    197           WRITE (11)  name(j), pad1(j), pad2(j)
  222.    198  6000  CONTINUE
  223.    199  
  224.    200  C *** We done!
  225.    201        CLOSE (UNIT=11)
  226.    202        PRINT *, 'I''m done!'
  227.    203  9999  CONTINUE
  228.    204  
  229.    205  9001  FORMAT (1X,'Base date: ',2(I2,'-'),I4,)
  230.    206  9002  FORMAT (' ',I5,1X,A20,I6,' Saved.')
  231.    207  9003  FORMAT (' ',I5,1X,A20,I6,' Deleted.')
  232.    208  9004  FORMAT (' ','Processed ',I4,' users;   Deleted ',I4,' users.'//
  233.    209       & ' ','Wrote  SCRATCH FILE  in current directory.'/)
  234.    210        END
  235.  
  236.  
  237. main  Local Symbols
  238.  
  239. Name                      Class   Type              Size   Offset  
  240.  
  241. NAME. . . . . . . . . . . local   CHAR*41          41000    0000
  242. PAD1. . . . . . . . . . . local   CHAR*55          55000    0000
  243. PAD2. . . . . . . . . . . local   CHAR*56          56000    0000
  244. TEST. . . . . . . . . . . local   LOGICAL*4            4    0002
  245. PDAYS . . . . . . . . . . local   INTEGER*4            4    0006
  246. TODAY . . . . . . . . . . local   INTEGER*4            4    000a
  247. LENGTH. . . . . . . . . . local   INTEGER*4            4    000e
  248. I . . . . . . . . . . . . local   INTEGER*4            4    0012
  249. J . . . . . . . . . . . . local   INTEGER*4            4    0016
  250. ICOUNT. . . . . . . . . . local   INTEGER*4            4    001a
  251. S . . . . . . . . . . . . local   CHAR*154           154    001e
  252. DIFF. . . . . . . . . . . local   INTEGER*4            4    00b8
  253. I100. . . . . . . . . . . local   INTEGER*2            2    00bc
  254. IHR . . . . . . . . . . . local   INTEGER*2            2    00be
  255. ISEC. . . . . . . . . . . local   INTEGER*2            2    00c0
  256. IDAY. . . . . . . . . . . local   INTEGER*2            2    00c2
  257.                                                                         PAGE   5
  258.                                                                        07-04-91
  259.                                                                        16:34:47
  260.  
  261.                              Microsoft FORTRAN Optimizing Compiler Version 5.00
  262.  
  263.  
  264. main  Local Symbols
  265.  
  266. Name                      Class   Type              Size   Offset  
  267.  
  268. IPROCESS. . . . . . . . . local   INTEGER*4            4    00c4
  269. LDAY. . . . . . . . . . . local   INTEGER*2            2    00c8
  270. IMIN. . . . . . . . . . . local   INTEGER*2            2    00ca
  271. IMON. . . . . . . . . . . local   INTEGER*2            2    00cc
  272. IYR . . . . . . . . . . . local   INTEGER*2            2    00ce
  273. LMON. . . . . . . . . . . local   INTEGER*2            2    00d0
  274. LYR . . . . . . . . . . . local   INTEGER*2            2    00d2
  275. INFILE. . . . . . . . . . local   CHAR*32             32    00d4
  276. IDELETE . . . . . . . . . local   INTEGER*4            4    00f4
  277. LDAYS . . . . . . . . . . local   INTEGER*4            4    00f8
  278.  
  279.    211  
  280.    212  $Page
  281.                                                                         PAGE   6
  282.                                                                        07-04-91
  283.                                                                        16:34:47
  284.  
  285.  Line#  Source Line          Microsoft FORTRAN Optimizing Compiler Version 5.00
  286.  
  287.    213  C *** Subroutine to calc number of days since 0-0-0.  Array daymon
  288.    214  C *** holds the number of days to the first of any month.
  289.    215        SUBROUTINE  days  ( iyr, imon, iday, ndays )
  290.    216        INTEGER *2  iyr, imon, iday, daymon
  291.    217        INTEGER *4  ndays
  292.    218        DIMENSION   daymon(12)
  293.    219        DATA daymon /0,31,59,90,120,151,181,212,243,273,304,334/
  294.    220        ndays= daymon(imon)
  295.    221        ndays= ndays + iyr*365 + iyr/4 + iday + 1
  296.    222        ndays= ndays - iyr/100 + iyr/400
  297.    223  C *** Is this a leap year or leap century.  Leap years are SKIPPED
  298.    224  C *** on a leap century.  Exit if leap year.
  299.    225          IF  ( iyr/400*400 .EQ. iyr )  GOTO 100
  300.    226          IF  ( iyr/100*100 .EQ. iyr )  RETURN
  301.    227  100   CONTINUE
  302.    228          IF  ( imon .GT. 2)  RETURN
  303.    229  C *** Not a leap year.  Take off the extra day!
  304.    230        ndays= ndays - 1
  305.    231        RETURN
  306.    232        END
  307.  
  308.  
  309. DAYS  Local Symbols
  310.  
  311. Name                      Class   Type              Size   Offset  
  312.  
  313. NDAYS . . . . . . . . . . param                             0006
  314. IDAY. . . . . . . . . . . param                             000a
  315. IMON. . . . . . . . . . . param                             000e
  316. IYR . . . . . . . . . . . param                             0012
  317. DAYMON. . . . . . . . . . local   INTEGER*2           24    0504
  318.  
  319.    233  
  320.    234  $Page
  321.                                                                         PAGE   7
  322.                                                                        07-04-91
  323.                                                                        16:34:47
  324.  
  325.  Line#  Source Line          Microsoft FORTRAN Optimizing Compiler Version 5.00
  326.  
  327.    235  C *** Subroutine   SORT  performs a bubble sort on a one-dimensional
  328.    236  C *** character real array of arbitrary length.   It  sorts
  329.    237  C *** the array in ascending order.  This routine courtesy of 
  330.    238  C *** MS-FORTRAN 3.13 via Tandy Corp.  MS disavows all knowledge
  331.    239  C *** of this release.  Have they been watching Mission Impossible?
  332.    240  C *** See M/L comments for boundary alignment modifications.
  333.    241        SUBROUTINE   sort  ( name, pad1, pad2, end )
  334.    242        CHARACTER   temp1*41, temp2*55, temp3*56, tempL1*41, tempL2*41
  335.    243        INTEGER  end, a1, a2, spa1, spa2
  336.    244  
  337.    245        CHARACTER  name[HUGE]*41(1000), pad1[HUGE]*55(1000),
  338.    246       & pad2[HUGE]*56(1000)
  339.    247  
  340.    248  C *** Why sort a 2 record database if the SysOp is first?
  341.    249        IF (end .LE. 2) RETURN
  342.    250  
  343.    251        DO 201 a1= 2, end-1
  344.    252          DO 301 a2= a1 + 1, end
  345.    253            spa1= INDEX ( name(a1), ' ' )
  346.    254            spa2= INDEX ( name(a2), ' ' )
  347.    255  
  348.    256            IF  ( spa1 .NE. 0 )  THEN
  349.    257              tempL1 = name(a1) (spa1:)
  350.    258            ELSE
  351.    259              tempL1 = name(a1)
  352.    260            END IF
  353.    261  
  354.    262            IF  ( spa2 .NE. 0 )  THEN
  355.    263              tempL2 = name(a2) (spa2:)
  356.    264            ELSE
  357.    265              tempL2 = name(a2)
  358.    266            END IF
  359.    267  
  360.    268  C *** Convert to upper case.
  361.    269            len= LEN_TRIM ( tempL1 )
  362.    270            CALL  convert  ( tempL1, len )
  363.    271            len= LEN_TRIM ( tempL2 )
  364.    272            CALL  convert  ( tempL2, len )
  365.    273  
  366.    274            IF (tempL1 .LE. tempL2) GOTO 401
  367.    275            temp1 = name(a1)
  368.    276            temp2 = pad1(a1)
  369.    277            temp3 = pad2(a1)
  370.    278            name(a1) = name(a2)
  371.    279            pad1(a1) = pad1(a2)
  372.    280            pad2(a1) = pad2(a2)
  373.    281            name(a2) = temp1
  374.    282            pad1(a2) = temp2
  375.    283            pad2(a2) = temp3
  376.    284  401       CONTINUE
  377.    285  301     CONTINUE
  378.    286  201   CONTINUE
  379.    287  
  380.    288        RETURN
  381.    289        END
  382.  
  383.                                                                         PAGE   8
  384.                                                                        07-04-91
  385.                                                                        16:34:47
  386.  
  387.                              Microsoft FORTRAN Optimizing Compiler Version 5.00
  388.  
  389. SORT  Local Symbols
  390.  
  391. Name                      Class   Type              Size   Offset  
  392.  
  393. END . . . . . . . . . . . param                             0006
  394. PAD2. . . . . . . . . . . param                             000a
  395. PAD1. . . . . . . . . . . param                             000e
  396. NAME. . . . . . . . . . . param                             0012
  397. SPA1. . . . . . . . . . . local   INTEGER*4            4    00fc
  398. SPA2. . . . . . . . . . . local   INTEGER*4            4    0100
  399. LEN . . . . . . . . . . . local   INTEGER*4            4    0104
  400. TEMP1 . . . . . . . . . . local   CHAR*41             41    0108
  401. TEMP2 . . . . . . . . . . local   CHAR*55             55    0132
  402. TEMP3 . . . . . . . . . . local   CHAR*56             56    016a
  403. A1. . . . . . . . . . . . local   INTEGER*4            4    01a2
  404. A2. . . . . . . . . . . . local   INTEGER*4            4    01a6
  405. TEMPL1. . . . . . . . . . local   CHAR*41             41    01aa
  406. TEMPL2. . . . . . . . . . local   CHAR*41             41    01d4
  407.  
  408.    290  
  409.    291  $PAGE
  410.                                                                         PAGE   9
  411.                                                                        07-04-91
  412.                                                                        16:34:47
  413.  
  414.  Line#  Source Line          Microsoft FORTRAN Optimizing Compiler Version 5.00
  415.  
  416.    292  C *** Subroutine to convert lower case to upper case.
  417.    293  C *** Some compilers treat INTEGER and CHARACTER comparison
  418.    294  C *** as an error.  MS Fortran ver 5.0 considers this as a
  419.    295  C *** recoverable error.  95 implies shutting bit 6 (32 decimal)
  420.    296  C *** off.  The difference between lower case and upper case is
  421.    297  C *** is 32 in the ASCII collating sequence!  01011111
  422.    298        SUBROUTINE convert (test,iend)
  423.    299        INTEGER*1 test
  424.    300        DIMENSION test(41)
  425.    301        IF  ( iend .GT. 40 )  iend= 40
  426. ***** sud.for(301) : error F3606: CONVERT : formal argument TEST : type mismatc
  427. h
  428.    302  C *** IGNORE ERROR MESSAGE!
  429.    303        DO 100, i= 1, iend
  430.    304          IF  ( test(i) .LT.  97 )  GOTO 100
  431.    305          IF  ( test(i) .GT. 122 )  GOTO 100
  432.    306          test(i)=  IAND (test(i),95)
  433.    307  100   CONTINUE
  434.    308        RETURN
  435.    309        END
  436.  
  437.  
  438. CONVERT  Local Symbols
  439.  
  440. Name                      Class   Type              Size   Offset  
  441.  
  442. IEND. . . . . . . . . . . param                             0006
  443. TEST. . . . . . . . . . . param                             000a
  444. I . . . . . . . . . . . . local   INTEGER*4            4    01fe
  445.  
  446.  
  447. Global Symbols
  448.  
  449. Name                      Class   Type              Size   Offset  
  450.  
  451. CONVERT . . . . . . . . . FSUBRT  ***                ***    0c80
  452. DAYS. . . . . . . . . . . FSUBRT  ***                ***    069b
  453. GETDAT. . . . . . . . . . extern  ***                ***     ***
  454. GETTIM. . . . . . . . . . extern  ***                ***     ***
  455. SORT. . . . . . . . . . . FSUBRT  ***                ***    078a
  456. main. . . . . . . . . . . FSUBRT  ***                ***    0000
  457.  
  458. Code size = 0d21 (3361)
  459. Data size = 051e (1310)
  460. Bss size  = 0202 (514)
  461.  
  462. No errors detected
  463.