home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / sigm / vol266 / set.for < prev    next >
Encoding:
Text File  |  1986-05-19  |  7.3 KB  |  277 lines
  1.         SUBROUTINE      SET(JQ,NSET)
  2. C////////////////////////////////////////////////////////////////
  3. C/                                                              /
  4. C/      Program-id.     SET                                     /
  5. C/      Date-written.   Jan. 16th 1984                          /
  6. C/      File-name.      SET.FOR (Ver2.0)                        /
  7. C/      Remarks.        Subroutine SET.FOR page 62.             /
  8. C/                      Subroutine SET is the heart of the      /
  9. C/                      information storage and retrieval       /
  10. C/                      system. SET performs three functions:   /
  11. C/                      1. Initialize the filing array NSET     /
  12. C/                      2. Updates the pointer system.          /
  13. C/                      3. Maintain statistics on the number    /
  14. C/                         of entries in each file.             /
  15. C/                                                              /
  16. C////////////////////////////////////////////////////////////////
  17. C
  18. C    * Default size of INTEGER = 2 bytes in F80
  19. C       
  20.         INTEGER*4       NSET(6,1)
  21. C
  22.       COMMON /C1/ID,IM,INIT,JEVNT,JMNIT,MFA,MSTOP,MX,MXC,NCLCT,NHIST,
  23.      1           NOQ,NORPT,NOT,NPRMS,NRUN,NRUNS,NSTAT,OUT,SCALE,ISEED,
  24.      2           TNOW,TBEG,TFIN,MXX,NPRNT,NCRDR,NEP,VNQ(4)
  25. C
  26.       COMMON /C2/ATRIB(4),ENQ(4),INN(4),JCELS(5,22),KRANK(4),MAXNQ(4),
  27.      1           MFE(4),MLC(4),MLE(4),NCELS(5),NQ(4),PARAM(20,4),
  28. C
  29.      2           QTIME(4),SSUMA(10,5),SUMA(10,5),NAME(6),NPROJ,MON,
  30.      3         NDAY,NYR,JCLR
  31. C
  32. C       --- INIT should be one for initialization of file
  33. C
  34.         IF (INIT - 1) 27,28,27
  35. C
  36. C       --- Initialize file to zero. Set up pointers
  37. C           must initialize KRANK(JQ)
  38. C           must initialize INN(JQ)
  39. C
  40.    28    KOL = 7777
  41.     KOF = 8888
  42.     KLE = 9999
  43.     MX = IM + 1
  44.     MXX = IM + 2
  45. C
  46. C    --- Inirtialize pointing cells of NSET and zero other cells
  47. C        of NSET
  48. C
  49.       DO 1 I=1,ID
  50.     DO 2 J=1,IM
  51.       NSET(J,I) = 0
  52.     2   CONTINUE
  53.     NSET(MXX,I) = I - 1
  54.     NSET(MX,I) = I + 1
  55.     1 CONTINUE
  56.     NSET(MX,ID) = KOF
  57.       DO 3 K=1,NOQ
  58.     NQ(K) = 0
  59.     MLC(K) = 0
  60.     MFE(K) = 0
  61.     MAXNQ(K) = 0
  62.     MLE(K) = 0
  63.     ENQ(K) = 0.0
  64.     VNQ(K) = 0.0
  65.         QTIME(K) = TNOW
  66.     3 CONTINUE
  67. C
  68. C    --- First available column = 1
  69. C
  70.     MFA = 1
  71.     INIT = 0
  72.     OUT = 0.0
  73.     RETURN
  74. C
  75. C       --- MFEX is first entry in file which has not been compared 
  76. C           with ITEM to be inserted.
  77. C
  78.    27    MFEX = MFE(JQ)
  79. C
  80. C       --- KNT is a check code to indicate that no comparisons have
  81. C           been made.
  82. C
  83.         KNT = 2
  84. C
  85. C       --- KS is the row on which items of file JQ are ranked.
  86. C
  87.         KS = KRANK(JQ)
  88. C
  89. C       --- Test for putting value in or out
  90. C           if out equals one an item is to be removed from file JQ
  91. C           If OUT is less than ONE an item is to be inserted in
  92. C           file JQ
  93. C
  94.         IF (OUT-1.0) 8,5,100
  95. C
  96. C       --- Putting an entry in file JQ
  97. C
  98.     8   NXFA = NSET(MX,MFA)
  99. C
  100. C       --- If INN(JQ) equals two the file is a HVF file. If INN(JQ)
  101. C           is one the file is a LVF file. For LVF files try to insert
  102. C           Stating at end of file. MLEX is last entry in file which
  103. C           has not been compared with items to be inserted.
  104. C
  105.         IF (INN(JQ) - 1) 100,7,6
  106.     7   MLEX = MLE(JQ)
  107. C
  108. C       --- If MLEX is zero file is empty. item to be inserted will be
  109. C           only item in file.
  110. C
  111.         IF (MLEX) 100,10,11
  112.    10   NSET(MXX,MFA) = KLE
  113.         MFE(JQ) = MFA
  114. C
  115. C       --- There is no successor of item inserted. Since item was 
  116. C           inserted in column MFA the last entry of file JQ is in
  117. C           column MFA.
  118. C
  119.    17   NSET(MX,MFA) = KOL
  120.         MLE(JQ) = MFA
  121. C
  122. C       --- Set new MFA equal to successor of old MFA. that is NXFA
  123. C
  124.    14   MFA = NXFA
  125.         IF (MFA - KOF) 237,238,238
  126.   237   NSET(MXX,MFA) = KLE
  127. C
  128. C       ---Update statistics of file JQ
  129. C
  130.   238   XNQ = NQ(JQ)
  131.         ENQ(JQ) = ENQ(JQ) + XNQ * (TNOW - QTIME(JQ))
  132.         VNQ(JQ) = VNQ(JQ) + XNQ * XNQ * (TNOW - QTIME(JQ))
  133.         QTIME(JQ) = TNOW
  134.         NQ(JQ) = NQ(JQ) + 1
  135.         MAXNQ(JQ) = MAX0(MAXNQ(JQ),NQ(JQ))
  136.         MLC(JQ) = MFE(JQ)
  137.         RETURN
  138. C
  139. C       --- Test ranking value of new item against value of item
  140. C           in column
  141. C
  142.    11   IF (NSET(KS,MFA)-NSET(KS,MLEX)) 12,13,13
  143. C
  144. C       --- Insert item after column MLEX.
  145. C
  146.    13   MSU = NSET(MX,MLEX)
  147.         NSET(MX,MLEX) = MFA
  148.         NSET(MXX,MFA) = MLEX
  149.         GO TO (18,17),KNT
  150. C
  151. C       --- Since KNT equals one a comparison was made and there
  152. C           is A.
  153. C
  154.    18   NSET(MX,MFA) = MSU
  155.         NSET(MXX,MSU) = MFA
  156.                         GO TO 14
  157. C
  158. C       --- Set KNT to one since a comparison was made.
  159. C
  160.    12   KNT = 1
  161. C
  162. C       --- Test MFA against predecessor of MLEX by letting
  163. C           MLEX equal predecessor of MLEX.
  164. C
  165.         MLEX = NSET(MXX,MLEX)
  166.         IF (MLEX-KLE) 11,16,11
  167. C
  168. C       --- If MLEX had no predecessor MFA is first in file
  169. C
  170.    16   NSET(MXX,MFA) = KLE
  171.         MFE(JQ) = MFA
  172. C
  173. C
  174. C
  175.    26   NSET(MX,MFA) = MFEX
  176.         NSET(MXX,MFEX) = MFA
  177.                         GO TO 14
  178. C
  179. C       --- FOR HVF OPERATION TRY TO INSERT ITEM STARTING AT BEGINNING
  180. C           OF FILE JQ.
  181. C
  182.     6   IF (MFEX) 100,10,19
  183. C
  184. C       --- Test ranking value of new item against value of
  185. C           item in column MFEX.
  186. C
  187.    19   IF (NSET(KS,MFA)-NSET(KS,MFEX)) 20,21,21
  188. C
  189. C       --- If new value if lower. MFA must be compared against 
  190. C           successor of MFEX.
  191. C
  192.    20   KNT = 1
  193. C
  194. C       --- Let MPRE = MFEX and let MFEX be the successor of MFEX.
  195. C
  196.         MPRE = MFEX
  197.         MFEX = NSET(MX,MFEX)
  198.         IF (MFEX-KOL) 19,24,19
  199. C
  200. C       --- If new value is higher, it should be inserted between
  201. C           MFEX and ITS.
  202. C
  203.    21   GO TO (22,16),KNT
  204.    22   KNT = 2
  205. C
  206. C       --- MFA is to be inserted after MPRE. Make MPRE the prdece
  207. C           ssor of MFA and MFA the successor of MPRE.
  208. C
  209.    24   NSET(MXX,MFA) = MPRE
  210.         NSET(MX,MPRE) = MFA
  211. C
  212. C       --- If KNT was not reset to 2, thre is no successor of MFA
  213. C           pointers are updated at statement 17.
  214. C
  215.         GO TO (17,26), KNT
  216. C
  217. C       --- Removal of an item from file JQ.
  218. C
  219. 5       OUT = 0.0
  220. C
  221. C       --- Update pointing system to account for removal of MLC(JQ)
  222. C
  223.         MMLC = MLC(JQ)
  224. C
  225. C       --- Reset out to 0 and clear column removed.
  226. C
  227.       DO 32 I=1,IM
  228.        NSET(I,MMLC) = 0
  229.    32 CONTINUE
  230.         JL = NSET(MX,MMLC)
  231.         JK = NSET(MXX,MMLC)
  232.         IF (JL - KOL) 33,34,33
  233.    33   IF (JK - KLE) 35,36,35
  234.    35   NSET(MX,JK) = JL
  235.         NSET(MXX,JL) = JK
  236. C
  237. C       --- Update pointers.
  238. C
  239.    37   NSET(MX,MMLC) = MFA
  240.         NSET(MXX,MMLC) = KLE
  241.         IF (MFA - KOF) 234,235,235
  242.   234   NSET(MXX,MFA) = MMLC
  243.   235   MFA = MLC(JQ)
  244.         MLC(JQ) = MFE(JQ)
  245. C
  246. C       --- Update file statistaics
  247. C
  248.         XNQ = NQ(JQ)
  249.         ENQ(JQ) = ENQ(JQ) + XNQ * (TNOW - QTIME(JQ))
  250.         VNQ(JQ) = VNQ(JQ) + XNQ * XNQ * (TNOW - QTIME(JQ))
  251.         QTIME(JQ) = TNOW
  252.         NQ(JQ) = NQ(JQ) - 1
  253.         RETURN
  254. C
  255. C       --- MLC was first entry but not last entry. update pointers.
  256. C
  257.    36   NSET(MXX,JL) = KLE
  258.         MFE(JQ) = JL
  259.                         GO TO 37
  260.    34   IF (JK - KLE) 38,39,38
  261. C
  262. C       --- MLC was last entry but not first entry. Update pointers.
  263. C
  264.    38   NSET(MX,JK) = KOL
  265.         MLE(JQ) = JK
  266.                         GO TO 37
  267. C
  268. C       --- MLC was both the last and first entry, therefore, it is
  269. C           the only entry.
  270. C
  271.    39   MFE(JQ) = 0
  272.         MLE(JQ) = 0
  273.                         GO TO 37
  274.   100   CALL    ERROR(88,NSET)
  275.         CALL    EXIT
  276.         END
  277.