subroutine aptword (lword, nwords, la, lb, mods, kbet, nerr) ccbeg. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c SUBROUTINE APTWORD c c call aptword (lword, nwords, la, lb, mods, mods, kbet, nerr) c c Version: aptword Updated 1992 May 22 14:20. c aptword Originated 1990 July 30 11:40. c c Author: Arthur L. Edwards, LLNL, L-298, Telephone (925) 422-4123. c c c Purpose: To find out if the nwords words lword are in the range from c la to lb, inclusive. The mode of lword, la and lb is c alphanumeric (mods = 0), integer (mods = 1) or floating point c (mods = 2). c Flag nerr indicates any input errors. c c Input: lword, nwords, la, lb, mods. c c Output: kbet, nerr. c c Glossary: c c kbet Output Indicates, if 1, that nwords(n) is in the range c from la to lb, inclusive. Size nwords. c c la Input First limit of an range. c c lb Input Second limit of an range. c c lword Input An array of words. Size nwords. c c mods Input Indicates mode of lword, la and lb: c 0 for alphanumeric. c 1 for integer. c 2 for floating point. c c nerr Output Indicates any input errors, if not zero: c 1 if nwords is less than 1. c 2 if mods is not in the range from 0 to 2. c c nwords Input The size of arrays lword and kbet. c cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccend. c.... Dimensioned arguments. c---- If 1, lword between la and lb. dimension kbet (1) c---- An alphanumeric word. dimension lword (1) c.... Equivalences to arguments. c---- ASCII string equivalent of la = lla. character*8 ala c---- ASCII string equivalent of la = lla. equivalence (ala, lla) c---- ASCII string equivalent of lb = llb. character*8 alb c---- ASCII string equivalent of lb = llb. equivalence (alb, llb) c---- Floating point equivalent of la = lla. equivalence (fla, lla) c---- Floating point equivalent of lb = llb. equivalence (flb, llb) c.... Local variables. c---- Difference between ftest and fla. common /laptword/ fdiffa c---- Difference between flb and ftest. common /laptword/ fdiffb c---- Sign of direction from fla to flb. common /laptword/ fsign c---- Difference between ltest and la. common /laptword/ ldiffa c---- Difference between lb and ltest. common /laptword/ ldiffb c---- Sign of direction from la to lb. common /laptword/ lsign c---- A test word. common /laptword/ ltest (64) c---- ASCII string equivalent of ltest. character*8 atest c---- ASCII string equivalent of ltest. dimension atest(64) c---- ASCII string equivalent of ltest. equivalence (atest, ltest) c---- Floating point equivalent of ltest. dimension ftest(64) c---- Floating point equivalent of ltest. equivalence (ftest, ltest) c---- Index in arrays lword, kbet. common /laptword/ n cbugc***DEBUG begins. cbug 9901 format (/ 'aptword testing words to see if in the range:') cbug 9902 format (' la= "',a8,'"' / ' lb= "',a8,'"') cbug 9903 format (' la= ',i20 / ' lb= ',i20) cbug 9904 format (' la= ',1pe22.14 / ' lb= ',1pe22.14) cbug 9905 format (i3,' lword="',a8,'"') cbug 9906 format (i3,' lword=',i20) cbug 9907 format (i3,' lword=',1pe22.14) cbug cbug write ( 3, 9901) cbug if (mods .le. 0) then cbug write ( 3, 9902) la, lb cbug write ( 3, 9905) (n, lword(n), n = 1, nwords) cbug elseif (mods .eq. 1) then cbug write ( 3, 9903) la, lb cbug write ( 3, 9906) (n, lword(n), n = 1, nwords) cbug else cbug write ( 3, 9904) la, lb cbug write ( 3, 9907) (n, lword(n), n = 1, nwords) cbug endif cbugc***DEBUG ends. c.... Initialize local variables. lla = la llb = lb c.... Test for input errors. nerr = 0 if (nwords .lt. 1) then nerr = 1 go to 210 endif if ((mods .lt. 0) .or. (mods .gt. 2)) then nerr = 2 go to 210 endif c.... Find the direction from la to lb. c---- Alphanumeric mode. if (mods .eq. 0) then if (alb .gt. ala) then lsign = 1 else lsign = -1 endif c---- Integer mode. elseif (mods .eq. 1) then if (llb .gt. lla) then lsign = 1 else lsign = -1 endif c---- Floating point mode. else if (flb .ge. fla) then fsign = 1.0 else fsign = -1.0 endif c---- Tested mods. endif c.... Set up the indices of the first subset of data. n1 = 1 n2 = min (nwords, 64) 110 ns = n2 - n1 + 1 c.... Find temporary set of test words. c---- Loop over subset of words. do 120 n = 1, ns nn = n + n1 - 1 ltest(n) = lword(nn) c---- End of loop over subset of words. 120 continue c.... See if each word lword is between la and lb. c---- Mode is alphanumeric. if (mods .eq. 0) then c---- Word la is greater than lb. if (lsign .eq. -1) then c---- Loop over subset of words. do 130 n = 1, ns nn = n + n1 - 1 if ((atest(n) .le. ala) .and. (atest(n) .ge. alb)) then kbet(nn) = 1 else kbet(nn) = 0 endif c---- End of loop over subset of words. 130 continue c---- Word la is not greater than lb. else c---- Loop over subset of words. do 140 n = 1, ns nn = n + n1 - 1 if ((atest(n) .ge. ala) .and. (atest(n) .le. alb)) then kbet(nn) = 1 else kbet(nn) = 0 endif c---- End of loop over subset of words. 140 continue c---- Tested order of la, lb. endif c---- Mode is integer. elseif (mods .eq. 1) then c---- Loop over subset of words. do 150 n = 1, ns nn = n + n1 - 1 ldiffa = lsign * (ltest(n) - lla) ldiffb = lsign * (llb - ltest(n)) if ((ldiffa .ge. 0) .and. (ldiffb .ge. 0)) then kbet(nn) = 1 else kbet(nn) = 0 endif c---- End of loop over subset of words. 150 continue c---- Mode is floating point. else c---- Loop over subset of words. do 160 n = 1, ns nn = n + n1 - 1 fdiffa = fsign * (ftest(n) - fla) fdiffb = fsign * (flb - ftest(n)) if ((fdiffa .ge. 0.0) .and. (fdiffb .ge. 0.0)) then kbet(nn) = 1 else kbet(nn) = 0 endif c---- End of loop over subset of words. 160 continue c---- Tested mode. endif c.... See if all data subsets are done. c---- Do another subset of data. if (n2 .lt. nwords) then n1 = n2 + 1 n2 = min (nwords, n1 + 63) go to 110 endif 210 continue cbugc***DEBUG begins. cbug 9908 format (/ 'aptword results:') cbug 9909 format (i3,' lword="',a8,'" kbet=',i3) cbug 9910 format (i3,' lword=',i20,' kbet=',i3) cbug 9911 format (i3,' lword=',1pe22.14,' kbet=',i3) cbug cbug write ( 3, 9908) cbug if (mods .le. 0) then cbug write ( 3, 9909) (n, lword(n), kbet(n), n = 1, nwords) cbug elseif (mods .eq. 1) then cbug write ( 3, 9910) (n, lword(n), kbet(n), n = 1, nwords) cbug else cbug write ( 3, 9911) (n, lword(n), kbet(n), n = 1, nwords) cbug endif cbugc***DEBUG ends. return c.... End of subroutine aptword. (+1 line.) end UCRL-WEB-209832